Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-compiler-and-rts
compiler
Commits
6fd027e3
Commit
6fd027e3
authored
Apr 13, 2007
by
John van Groningen
Browse files
implement newtype
parent
f736c783
Changes
20
Expand all
Hide whitespace changes
Inline
Side-by-side
frontend/analtypes.icl
View file @
6fd027e3
This diff is collapsed.
Click to expand it.
frontend/analunitypes.icl
View file @
6fd027e3
...
...
@@ -193,7 +193,9 @@ where
#
(
sign_class
,
_,
scs
)
=
signClassOfType
at_type
PositiveSign
DontUSeTopSign
group_nr
ci
scs
=
(
sign_class
,
scs
)
sign_class_of_type_def
module_index
(
RecordType
{
rt_constructor
})
group_nr
ci
scs
=
sign_class_of_type_conses
module_index
[
rt_constructor
]
group_nr
ci
BottomSignClass
scs
=
sign_class_of_type_cons
module_index
rt_constructor
group_nr
ci
BottomSignClass
scs
sign_class_of_type_def
module_index
(
NewType
constructor
)
group_nr
ci
scs
=
sign_class_of_type_cons
module_index
constructor
group_nr
ci
BottomSignClass
scs
sign_class_of_type_def
_
(
AbstractType
properties
)
_
_
scs
|
properties
bitand
cIsNonCoercible
==
0
=
(
PostiveSignClass
,
scs
)
...
...
@@ -202,6 +204,7 @@ where
|
properties
bitand
cIsNonCoercible
==
0
=
(
PostiveSignClass
,
scs
)
=
(
TopSignClass
,
scs
)
sign_class_of_type_conses
module_index
[{
ds_index
}:
conses
]
group_nr
ci
cumm_sign_class
scs
#!
cons_def
=
ci
.[
module_index
].
com_cons_defs
.[
ds_index
]
#
(
cumm_sign_class
,
scs
)
=
sign_class_of_type_of_list
cons_def
.
cons_type
.
st_args
group_nr
ci
cumm_sign_class
scs
...
...
@@ -209,6 +212,10 @@ where
sign_class_of_type_conses
module_index
[]
_
_
cumm_sign_class
scs
=
(
cumm_sign_class
,
scs
)
sign_class_of_type_cons
module_index
{
ds_index
}
group_nr
ci
cumm_sign_class
scs
#!
cons_def
=
ci
.[
module_index
].
com_cons_defs
.[
ds_index
]
=
sign_class_of_type_of_list
cons_def
.
cons_type
.
st_args
group_nr
ci
cumm_sign_class
scs
sign_class_of_type_of_list
[]
_
_
cumm_sign_class
scs
=
(
cumm_sign_class
,
scs
)
sign_class_of_type_of_list
[{
at_type
}
:
types
]
group_nr
ci
cumm_sign_class
scs
...
...
@@ -468,7 +475,9 @@ where
#
(
prop_class
,
_,
pcs
)
=
propClassOfType
at_type
group_nr
ci
pcs
=
(
prop_class
,
pcs
)
prop_class_of_type_def
module_index
(
RecordType
{
rt_constructor
})
group_nr
ci
pcs
=
prop_class_of_type_conses
module_index
[
rt_constructor
]
group_nr
ci
NoPropClass
pcs
=
prop_class_of_type_cons
module_index
rt_constructor
group_nr
ci
NoPropClass
pcs
prop_class_of_type_def
module_index
(
NewType
constructor
)
group_nr
ci
pcs
=
prop_class_of_type_cons
module_index
constructor
group_nr
ci
NoPropClass
pcs
prop_class_of_type_def
_
(
AbstractType
properties
)
_
_
pcs
=
(
PropClass
,
pcs
)
prop_class_of_type_def
_
(
AbstractSynType
properties
_)
_
_
pcs
...
...
@@ -481,6 +490,10 @@ where
prop_class_of_type_conses
module_index
[]
_
_
cumm_prop_class
pcs
=
(
cumm_prop_class
,
pcs
)
prop_class_of_type_cons
module_index
{
ds_index
}
group_nr
ci
cumm_prop_class
pcs
#!
cons_def
=
ci
.[
module_index
].
com_cons_defs
.[
ds_index
]
=
prop_class_of_type_of_list
cons_def
.
cons_type
.
st_args
group_nr
ci
cumm_prop_class
pcs
prop_class_of_type_of_list
[]
_
_
cumm_prop_class
pcs
=
(
cumm_prop_class
,
pcs
)
prop_class_of_type_of_list
[{
at_type
}
:
types
]
group_nr
ci
cumm_prop_class
pcs
...
...
frontend/check.icl
View file @
6fd027e3
...
...
@@ -1455,6 +1455,8 @@ renumber_icl_definitions_as_dcl_definitions (Yes icl_to_dcl_index_table) icl_siz
#
rt_constructor
=
{
rt_constructor
&
ds_index
=
icl_to_dcl_index_table
.[
cConstructorDefs
,
rt_constructor
.
ds_index
]}
#
rt_fields
=
{{
field
&
fs_index
=
icl_to_dcl_index_table
.[
cSelectorDefs
,
field
.
fs_index
]}
\\
field
<-:
rt_fields
}
=
{
td
&
td_rhs
=
RecordType
{
rt_constructor
=
rt_constructor
,
rt_fields
=
rt_fields
,
rt_is_boxed_record
=
rt_is_boxed_record
}}
renumber_type_def
td
=:{
td_rhs
=
NewType
cons
}
=
{
td
&
td_rhs
=
NewType
{
cons
&
ds_index
=
icl_to_dcl_index_table
.[
cConstructorDefs
,
cons
.
ds_index
]}
}
renumber_type_def
td
=
td
renumber_icl_decl_symbol
(
Declaration
icl_decl_symbol
=:{
decl_kind
=
STE_Constructor
,
decl_index
})
cdefs
...
...
@@ -1639,6 +1641,10 @@ where
#
new_cons_defs
=
if
(
dcl_cons_index
==(
-1
))
new_cons_defs
[
com_cons_defs
.[
dcl_cons_index
]
:
new_cons_defs
]
#
(
rt_fields
,
cs
)
=
redirect_field_symbols
td_pos
rt_fields
cs
=
([
{
td
&
td_rhs
=
RecordType
{
rt
&
rt_constructor
=
rt_constructor
,
rt_fields
=
rt_fields
}}
:
new_type_defs
],
new_cons_defs
,
new_selector_defs
,
conversion_table
,
icl_sizes
,
icl_decl_symbols
,
cs
)
add_type_def
td
=:{
td_pos
,
td_rhs
=
NewType
cons
}
new_type_defs
new_cons_defs
new_selector_defs
conversion_table
icl_sizes
icl_decl_symbols
cs
#
(
dcl_cons_index
,
cons
,(
conversion_table
,
icl_sizes
,
icl_decl_symbols
,
cs
))
=
copy_and_redirect_symbol
STE_Constructor
td_pos
cons
(
conversion_table
,
icl_sizes
,
icl_decl_symbols
,
cs
)
#
new_cons_defs
=
if
(
dcl_cons_index
==(
-1
))
new_cons_defs
[
com_cons_defs
.[
dcl_cons_index
]
:
new_cons_defs
]
=
([
{
td
&
td_rhs
=
NewType
cons
}
:
new_type_defs
],
new_cons_defs
,
new_selector_defs
,
conversion_table
,
icl_sizes
,
icl_decl_symbols
,
cs
)
add_type_def
td
=:{
td_ident
,
td_pos
,
td_rhs
=
AbstractType
_}
new_type_defs
new_cons_defs
new_selector_defs
conversion_table
icl_sizes
icl_decl_symbols
cs
#
cs_error
=
checkError
"abstract type not defined in implementation module"
""
(
setErrorAdmin
(
newPosition
td_ident
td_pos
)
cs
.
cs_error
)
...
...
@@ -2703,7 +2709,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
solved_imports
=
{
si_explicit
=[],
si_qualified_explicit
=[],
si_implicit
=[]
}
imports_ikh
=
ikhInsert`
False
cPredefinedModuleIndex
solved_imports
ikhEmpty
(
deferred_stuff
,
(_,
modules
,
macro_and_fun_defs
,
macro_defs
,
heaps
,
cs
))
=
checkDclModule
EndNumbers
[]
imports_ikh
cUndef
False
cDummyArray
support_dynamics
mod
ste_index
cDummyArray
modules
macro_and_fun_defs
macro_defs
heaps
cs
=
check
Predefined
DclModule
EndNumbers
[]
imports_ikh
cUndef
False
cDummyArray
support_dynamics
mod
ste_index
cDummyArray
modules
macro_and_fun_defs
macro_defs
heaps
cs
(
modules
,
heaps
,
cs
)
=
checkInstancesOfDclModule
cPredefinedModuleIndex
deferred_stuff
(
modules
,
heaps
,
cs
)
({
dcl_declared
={
dcls_import
,
dcls_local
,
dcls_local_for_import
}},
modules
)
=
modules
![
ste_index
]
...
...
@@ -3392,10 +3398,10 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
(
Yes
symbol_type
)
=
inst_def
.
ft_type
=
{
instance_defs
&
[
ds_index
]
=
{
inst_def
&
ft_type
=
makeElemTypeOfArrayFunctionStrict
inst_def
.
ft_type
ins_offset
offset_table
}
}
checkDclModule
::
!
NumberSet
![
Int
]
!(
IntKeyHashtable
SolvedImports
)
!
Int
!
Bool
!
LargeBitvect
!
Bool
!(
Module
(
CollectedDefinitions
ClassInstance
IndexRange
))
!
Index
!*
ExplImpInfos
!*{#
DclModule
}
!*{#
FunDef
}
!*{#*{#
FunDef
}}
!*
Heaps
!*
CheckState
->
(!(!
Int
,!
Index
,![
FunType
]),
!(!*
ExplImpInfos
,
!*{#
DclModule
},
!*{#
FunDef
},!*{#*{#
FunDef
}},!*
Heaps
,
!*
CheckState
))
checkDclModule
dcl_imported_module_numbers
components_importing_module
imports_ikh
component_nr
is_on_cycle
modules_in_component_set
support_dynamics
check
Predefined
DclModule
::
!
NumberSet
![
Int
]
!(
IntKeyHashtable
SolvedImports
)
!
Int
!
Bool
!
LargeBitvect
!
Bool
!(
Module
(
CollectedDefinitions
ClassInstance
IndexRange
))
!
Index
!*
ExplImpInfos
!*{#
DclModule
}
!*{#
FunDef
}
!*{#*{#
FunDef
}}
!*
Heaps
!*
CheckState
->
(!(!
Int
,!
Index
,![
FunType
]),
!(!*
ExplImpInfos
,
!*{#
DclModule
},
!*{#
FunDef
},!*{#*{#
FunDef
}},!*
Heaps
,
!*
CheckState
))
check
Predefined
DclModule
dcl_imported_module_numbers
components_importing_module
imports_ikh
component_nr
is_on_cycle
modules_in_component_set
support_dynamics
mod
=:{
mod_ident
,
mod_defs
=
mod_defs
=:{
def_macro_indices
,
def_funtypes
}}
mod_index
expl_imp_info
modules
icl_functions
macro_defs
heaps
cs
#
dcl_common
=
createCommonDefinitions
mod_defs
#!
first_type_index
=
size
dcl_common
.
com_type_defs
...
...
frontend/checkFunctionBodies.icl
View file @
6fd027e3
This diff is collapsed.
Click to expand it.
frontend/checktypes.icl
View file @
6fd027e3
...
...
@@ -341,10 +341,15 @@ where
=
[
av
:
attr_vars
]
add_attr_var
attr
attr_vars
=
attr_vars
check_rhs_of_TypeDef
{
td_rhs
=
SynType
type
}
_
cti
ts_ti_cs
#
(
type
,
type_attr
,
ts_ti_cs
)
=
bindTypes
cti
type
ts_ti_cs
=
(
SynType
type
,
ts_ti_cs
)
check_rhs_of_TypeDef
{
td_ident
,
td_arity
,
td_args
,
td_rhs
=
td_rhs
=:
NewType
cons
}
attr_vars
cti
=:{
cti_module_index
,
cti_type_index
,
cti_lhs_attribute
}
ts_ti_cs
#
type_lhs
=
{
at_attribute
=
cti_lhs_attribute
,
at_type
=
TA
(
MakeTypeSymbIdent
{
glob_object
=
cti_type_index
,
glob_module
=
cti_module_index
}
td_ident
td_arity
)
[{
at_attribute
=
atv_attribute
,
at_type
=
TV
atv_variable
}
\\
{
atv_variable
,
atv_attribute
}
<-
td_args
]}
ts_ti_cs
=
bind_types_of_constructor
cti
-2
[
atv_variable
\\
{
atv_variable
}
<-
td_args
]
attr_vars
type_lhs
cons
ts_ti_cs
=
(
td_rhs
,
ts_ti_cs
)
check_rhs_of_TypeDef
{
td_rhs
=
AbstractSynType
properties
type
}
_
cti
ts_ti_cs
#
(
type
,
type_attr
,
ts_ti_cs
)
=
bindTypes
cti
type
ts_ti_cs
=
(
AbstractSynType
properties
type
,
ts_ti_cs
)
...
...
@@ -380,7 +385,7 @@ where
=
({
ts
&
ts_cons_defs
.[
ds_index
]
=
cons_def
},
{
ti
&
ti_var_heap
=
ti_var_heap
},
{
cs
&
cs_symbol_table
=
symbol_table
})
where
bind_types_of_cons
::
![
AType
]
!
CurrentTypeInfo
![
TypeVar
]
![
AttrInequality
]
!(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
)
->
(![
AType
],
![[
ATypeVar
]],
![
AttrInequality
],
!(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
))
->
(![
AType
],
![[
ATypeVar
]],
![
AttrInequality
],!(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
))
bind_types_of_cons
[]
cti
free_vars
attr_env
ts_ti_cs
=
([],
[],
attr_env
,
ts_ti_cs
)
bind_types_of_cons
[
type
:
types
]
cti
free_vars
attr_env
ts_ti_cs
...
...
@@ -529,7 +534,7 @@ checkArityOfType act_arity form_arity (SynType _)
checkArityOfType
act_arity
form_arity
_
=
form_arity
>=
act_arity
checkAbstractType
type_index
(
AbstractType
_)
=
type_index
<>
cPredefinedModuleIndex
checkAbstractType
type_index
(
AbstractType
_)
=
type_index
<>
cPredefinedModuleIndex
checkAbstractType
type_index
(
AbstractSynType
_
_)
=
type_index
<>
cPredefinedModuleIndex
checkAbstractType
_
_
=
False
...
...
frontend/comparedefimp.icl
View file @
6fd027e3
...
...
@@ -73,7 +73,15 @@ where
=
True
#
field_nr
=
dec
field_nr
=
dcl_fields
.[
field_nr
].
fs_index
==
icl_fields
.[
field_nr
].
fs_index
&&
compare_fields
field_nr
dcl_fields
icl_fields
compare_rhs_of_types
(
NewType
dclConstructor
)
(
NewType
iclConstructor
)
dcl_cons_defs
icl_cons_defs
comp_st
|
dclConstructor
.
ds_index
<>
iclConstructor
.
ds_index
=
(
False
,
icl_cons_defs
,
comp_st
)
#
dcl_cons_def
=
dcl_cons_defs
.[
dclConstructor
.
ds_index
]
(
icl_cons_def
,
icl_cons_defs
)
=
icl_cons_defs
![
iclConstructor
.
ds_index
]
#
(
ok
,
comp_st
)
=
compare_cons_def_types
True
icl_cons_def
dcl_cons_def
comp_st
=
(
ok
,
icl_cons_defs
,
comp_st
)
compare_rhs_of_types
(
AbstractType
_)
(
NewType
_)
dcl_cons_defs
icl_cons_defs
comp_st
=
(
False
,
icl_cons_defs
,
comp_st
)
compare_rhs_of_types
(
AbstractType
_)
icl_type
dcl_cons_defs
icl_cons_defs
comp_st
=
(
True
,
icl_cons_defs
,
comp_st
)
compare_rhs_of_types
(
AbstractSynType
_
dclType
)
(
SynType
iclType
)
dcl_cons_defs
icl_cons_defs
comp_st
...
...
@@ -81,11 +89,15 @@ where
=
(
ok
,
icl_cons_defs
,
comp_st
)
compare_rhs_of_types
dcl_type
icl_type
dcl_cons_defs
icl_cons_defs
comp_st
=
(
False
,
icl_cons_defs
,
comp_st
)
compare_constructors
do_compare_result_types
cons_index
dcl_cons_defs
icl_cons_defs
comp_st
=:{
comp_type_var_heap
}
compare_constructors
do_compare_result_types
cons_index
dcl_cons_defs
icl_cons_defs
comp_st
#
dcl_cons_def
=
dcl_cons_defs
.[
cons_index
]
(
icl_cons_def
,
icl_cons_defs
)
=
icl_cons_defs
![
cons_index
]
dcl_cons_type
=
dcl_cons_def
.
cons_type
(
ok
,
comp_st
)
=
compare_cons_def_types
do_compare_result_types
icl_cons_def
dcl_cons_def
comp_st
=
(
ok
,
icl_cons_defs
,
comp_st
)
compare_cons_def_types
do_compare_result_types
icl_cons_def
dcl_cons_def
comp_st
=:{
comp_type_var_heap
}
#
dcl_cons_type
=
dcl_cons_def
.
cons_type
icl_cons_type
=
icl_cons_def
.
cons_type
comp_type_var_heap
=
initialyseATypeVars
dcl_cons_def
.
cons_exi_vars
icl_cons_def
.
cons_exi_vars
comp_type_var_heap
comp_st
=
{
comp_st
&
comp_type_var_heap
=
comp_type_var_heap
}
...
...
@@ -93,10 +105,9 @@ where
|
dcl_cons_def
.
cons_priority
==
icl_cons_def
.
cons_priority
|
ok
&&
do_compare_result_types
#
(
ok
,
comp_st
)
=
compare
dcl_cons_type
.
st_result
icl_cons_type
.
st_result
comp_st
=
(
ok
,
icl_cons_defs
,
comp_st
)
=
(
ok
,
icl_cons_defs
,
comp_st
)
=
(
False
,
icl_cons_defs
,
comp_st
)
=
(
ok
,
comp_st
)
=
(
ok
,
comp_st
)
=
(
False
,
comp_st
)
compareClassDefs
::
!{#
Int
}
{#
Bool
}
!{#
ClassDef
}
!{#
MemberDef
}
!
u
:{#
ClassDef
}
!
v
:{#
MemberDef
}
!*
CompareState
->
(!
u
:{#
ClassDef
},
!
v
:{#
MemberDef
},
!*
CompareState
)
...
...
@@ -857,10 +868,14 @@ instance t_corresponds TypeRhs where
=
t_corresponds
dclType
iclType
t_corresponds
(
RecordType
dclRecord
)
(
RecordType
iclRecord
)
=
t_corresponds
dclRecord
iclRecord
t_corresponds
(
AbstractType
_)
(
NewType
_)
=
return
False
t_corresponds
(
AbstractType
_)
_
=
return
True
t_corresponds
(
AbstractSynType
_
dclType
)
(
SynType
iclType
)
=
t_corresponds
dclType
iclType
t_corresponds
(
NewType
dclConstructor
)
(
NewType
iclConstructor
)
=
t_corresponds
dclConstructor
iclConstructor
// sanity check ...
t_corresponds
UnknownType
_
...
...
frontend/mergecases.icl
View file @
6fd027e3
...
...
@@ -5,14 +5,6 @@ implementation module mergecases
import
syntax
,
check
,
StdCompare
,
utilities
/*
cContainsFreeVars :== True
cContainsNoFreeVars :== False
cMacroIsCalled :== True
cNoMacroIsCalled :== False
*/
class
GetSetPatternRhs
a
where
get_pattern_rhs
::
!
a
->
Expression
...
...
@@ -41,7 +33,7 @@ mergeCases expr_and_pos [] var_heap symbol_heap error
mergeCases
(
Let
lad
=:{
let_expr
},
pos
)
exprs
var_heap
symbol_heap
error
#
((
let_expr
,
_),
var_heap
,
symbol_heap
,
error
)
=
mergeCases
(
let_expr
,
NoPos
)
exprs
var_heap
symbol_heap
error
=
((
Let
{
lad
&
let_expr
=
let_expr
},
pos
),
var_heap
,
symbol_heap
,
error
)
mergeCases
(
case_expr
=:
(
Case
first_case
=:{
case_expr
=
Var
{
var_info_ptr
},
case_default
=
No
,
case_explicit
}
)
,
case_pos
)
mergeCases
(
Case
first_case
=:{
case_expr
=
Var
{
var_info_ptr
},
case_default
=
No
,
case_explicit
},
case_pos
)
[(
expr
,
expr_pos
)
:
exprs
]
var_heap
symbol_heap
error
|
not
case_explicit
#
(
split_result
,
var_heap
,
symbol_heap
)
=
split_case
var_info_ptr
expr
var_heap
symbol_heap
...
...
@@ -71,7 +63,7 @@ where
->
(
Yes
cees
,
var_heap
,
symbol_heap
)
->
(
No
,
var_heap
,
symbol_heap
)
No
->
(
No
,
var_heap
,
symbol_heap
)
->
(
No
,
var_heap
,
symbol_heap
)
BasicPatterns
type
[
basic_pattern
]
#
(
split_result
,
var_heap
,
symbol_heap
)
=
split_case
split_var_info_ptr
basic_pattern
.
bp_expr
var_heap
symbol_heap
->
case
split_result
of
...
...
@@ -95,7 +87,19 @@ where
->
(
Yes
cees
,
var_heap
,
symbol_heap
)
->
(
No
,
var_heap
,
symbol_heap
)
No
->
(
No
,
var_heap
,
symbol_heap
)
->
(
No
,
var_heap
,
symbol_heap
)
NewTypePatterns
type
[
newtype_pattern
]
#
(
split_result
,
var_heap
,
symbol_heap
)
=
split_case
split_var_info_ptr
newtype_pattern
.
ap_expr
var_heap
symbol_heap
->
case
split_result
of
Yes
split_case
|
not
split_case
.
case_explicit
#
(
cees
,
symbol_heap
)
=
push_expression_into_guards_and_default
(
\
guard_expr
->
{
this_case
&
case_guards
=
NewTypePatterns
type
[{
newtype_pattern
&
ap_expr
=
guard_expr
}]
}
)
split_case
symbol_heap
->
(
Yes
cees
,
var_heap
,
symbol_heap
)
->
(
No
,
var_heap
,
symbol_heap
)
No
->
(
No
,
var_heap
,
symbol_heap
)
DynamicPatterns
[
dynamic_pattern
]
/* Don't merge dynamic cases, as a work around for the following case
apply :: Dynamic Dynamic -> Int
...
...
@@ -175,6 +179,9 @@ where
push_expression_into_guards
split_case
=:{
case_guards
=
OverloadedListPatterns
type
decons_expr
patterns
}
symbol_heap
#
(
new_patterns
,
symbol_heap
)
=
push_expression_into_patterns
patterns
symbol_heap
=
({
split_case
&
case_guards
=
OverloadedListPatterns
type
decons_expr
new_patterns
},
symbol_heap
)
push_expression_into_guards
split_case
=:{
case_guards
=
NewTypePatterns
type
patterns
}
symbol_heap
#
(
new_patterns
,
symbol_heap
)
=
push_expression_into_patterns
patterns
symbol_heap
=
({
split_case
&
case_guards
=
NewTypePatterns
type
new_patterns
},
symbol_heap
)
push_expression_into_guards
split_case
=:{
case_guards
=
DynamicPatterns
patterns
}
symbol_heap
#
(
new_patterns
,
symbol_heap
)
=
push_expression_into_patterns
patterns
symbol_heap
=
({
split_case
&
case_guards
=
DynamicPatterns
new_patterns
},
symbol_heap
)
...
...
@@ -236,6 +243,9 @@ where
push_let_expression_into_guards
lad
(
OverloadedListPatterns
type
decons_expr
patterns
)
var_heap
expr_heap
#
(
patterns
,
var_heap
,
expr_heap
)
=
push_let_expression_into_algebraic_pattern
lad
patterns
var_heap
expr_heap
=
(
OverloadedListPatterns
type
decons_expr
patterns
,
var_heap
,
expr_heap
)
push_let_expression_into_guards
lad
(
NewTypePatterns
type
patterns
)
var_heap
expr_heap
#
(
patterns
,
var_heap
,
expr_heap
)
=
push_let_expression_into_algebraic_pattern
lad
patterns
var_heap
expr_heap
=
(
NewTypePatterns
type
patterns
,
var_heap
,
expr_heap
)
push_let_expression_into_guards
lad
(
DynamicPatterns
patterns
)
var_heap
expr_heap
#
(
patterns
,
var_heap
,
expr_heap
)
=
push_let_expression_into_dynamic_pattern
lad
patterns
var_heap
expr_heap
=
(
DynamicPatterns
patterns
,
var_heap
,
expr_heap
)
...
...
@@ -281,6 +291,11 @@ where
->
merge_overloaded_list_patterns
type1
decons_expr1
patterns1
patterns2
var_heap
symbol_heap
error
_
->
(
guards
,
var_heap
,
symbol_heap
,
incompatible_patterns_in_case_error
error
)
merge_guards
guards
=:(
NewTypePatterns
type1
patterns1
)
(
NewTypePatterns
type2
patterns2
)
var_heap
symbol_heap
error
|
type1
==
type2
#
(
merged_patterns
,
var_heap
,
symbol_heap
,
error
)
=
merge_algebraic_or_overloaded_list_patterns
patterns1
patterns2
var_heap
symbol_heap
error
=
(
NewTypePatterns
type1
merged_patterns
,
var_heap
,
symbol_heap
,
error
)
=
(
guards
,
var_heap
,
symbol_heap
,
incompatible_patterns_in_case_error
error
)
merge_guards
guards
=:(
DynamicPatterns
patterns1
)
(
DynamicPatterns
patterns2
)
var_heap
symbol_heap
error
#
(
merged_patterns
,
var_heap
,
symbol_heap
,
error
)
=
merge_dynamic_patterns
patterns1
patterns2
var_heap
symbol_heap
error
=
(
DynamicPatterns
merged_patterns
,
var_heap
,
symbol_heap
,
error
)
...
...
@@ -401,7 +416,7 @@ where
incompatible_patterns_in_case_error
error
=
checkError
""
"incompatible patterns in case"
error
mergeCases
(
case_expr
=:
(
Case
first_case
=:{
case_default
,
case_default_pos
,
case_explicit
}
)
,
case_pos
)
[
expr
:
exprs
]
var_heap
symbol_heap
error
mergeCases
(
Case
first_case
=:{
case_default
,
case_default_pos
,
case_explicit
},
case_pos
)
[
expr
:
exprs
]
var_heap
symbol_heap
error
|
not
case_explicit
=
case
case_default
of
Yes
default_expr
...
...
@@ -412,7 +427,7 @@ mergeCases (case_expr=:(Case first_case=:{case_default, case_default_pos, case_e
#
((
default_expr
,
pos
),
var_heap
,
symbol_heap
,
error
)
=
mergeCases
expr
exprs
var_heap
symbol_heap
error
->
((
Case
{
first_case
&
case_default
=
Yes
default_expr
,
case_default_pos
=
pos
},
case_pos
),
var_heap
,
symbol_heap
,
error
)
mergeCases
expr_and_pos
_
var_heap
symbol_heap
error
mergeCases
expr_and_pos
=:(_,
pos
)
_
var_heap
symbol_heap
error
=
(
expr_and_pos
,
var_heap
,
symbol_heap
,
checkWarning
""
" alternative will never match"
error
)
isOverloaded
(
OverloadedList
_
_
_
_)
...
...
frontend/overloading.icl
View file @
6fd027e3
...
...
@@ -72,6 +72,9 @@ typeCodeInDynamicError err=:{ea_ok}
err
=
{
err
&
ea_ok
=
ea_ok
}
=
{
err
&
ea_file
=
err
.
ea_file
<<<
"TC context not allowed in dynamic"
<<<
'\n'
}
cycleAfterRemovingNewTypeConstructorsError
ident
err
#
err
=
errorHeading
"Error"
err
=
{
err
&
ea_file
=
err
.
ea_file
<<<
(
" cycle in definition of '"
+++
toString
ident
+++
"' after removing newtype constructors"
)
<<<
'\n'
}
/*
As soon as all overloaded variables in an type context are instantiated, context reduction is carried out.
...
...
@@ -1363,6 +1366,8 @@ class updateExpression e :: !Index !e !*UpdateInfo -> (!e, !*UpdateInfo)
instance
updateExpression
Expression
where
updateExpression
group_index
(
App
{
app_symb
={
symb_kind
=
SK_NewTypeConstructor
_},
app_args
=[
arg
]})
ui
=
updateExpression
group_index
arg
ui
updateExpression
group_index
(
App
app
=:{
app_symb
=
symb
=:{
symb_kind
,
symb_ident
},
app_args
,
app_info_ptr
})
ui
#
(
app_args
,
ui
)
=
updateExpression
group_index
app_args
ui
|
isNilPtr
app_info_ptr
...
...
@@ -1481,10 +1486,13 @@ where
#
((
expr
,
exprs
),
ui
)
=
updateExpression
group_index
(
expr
,
exprs
)
ui
=
(
expr
@
exprs
,
ui
)
updateExpression
group_index
(
Let
lad
=:{
let_lazy_binds
,
let_strict_binds
,
let_expr
})
ui
#
ui
=
set_aliases_for_binds_that_will_become_aliases
let_lazy_binds
ui
#
(
let_lazy_binds
,
ui
)
=
updateExpression
group_index
let_lazy_binds
ui
#
(
let_strict_binds
,
ui
)
=
updateExpression
group_index
let_strict_binds
ui
#
(
let_expr
,
ui
)
=
updateExpression
group_index
let_expr
ui
=
(
Let
{
lad
&
let_lazy_binds
=
let_lazy_binds
,
let_strict_binds
=
let_strict_binds
,
let_expr
=
let_expr
},
ui
)
updateExpression
group_index
case_expr
=:(
Case
{
case_guards
=
NewTypePatterns
_
_})
ui
=
remove_NewTypePatterns_case_and_update_expression
case_expr
group_index
ui
updateExpression
group_index
(
Case
kees
=:{
case_expr
,
case_guards
,
case_default
})
ui
#
((
case_expr
,(
case_guards
,
case_default
)),
ui
)
=
updateExpression
group_index
(
case_expr
,(
case_guards
,
case_default
))
ui
=
(
Case
{
kees
&
case_expr
=
case_expr
,
case_guards
=
case_guards
,
case_default
=
case_default
},
ui
)
...
...
@@ -1515,17 +1523,98 @@ where
(
EI_TypeOfDynamic
type_code
,
ui_symbol_heap
)
=
readPtr
dyn_info_ptr
ui
.
ui_symbol_heap
ui
=
{
ui
&
ui_symbol_heap
=
ui_symbol_heap
}
=
(
DynamicExpr
{
dyn
&
dyn_expr
=
dyn_expr
,
dyn_type_code
=
type_code
},
ui
)
updateExpression
group_index
(
MatchExpr
cons_symbol
expr
)
ui
#
(
expr
,
ui
)
=
updateExpression
group_index
expr
ui
=
(
MatchExpr
cons_symbol
expr
,
ui
)
updateExpression
group_index
(
MatchExpr
cons_symbol
=:{
glob_object
={
ds_arity
}}
expr
)
ui
|
ds_arity
<>
-2
#
(
expr
,
ui
)
=
updateExpression
group_index
expr
ui
=
(
MatchExpr
cons_symbol
expr
,
ui
)
// newtype constructor
=
updateExpression
group_index
expr
ui
updateExpression
group_index
(
TupleSelect
symbol
argn_nr
expr
)
ui
#
(
expr
,
ui
)
=
updateExpression
group_index
expr
ui
=
(
TupleSelect
symbol
argn_nr
expr
,
ui
)
updateExpression
group_index
(
TypeSignature
_
expr
)
ui
=
updateExpression
group_index
expr
ui
updateExpression
group_index
expr
=:(
Var
{
var_info_ptr
})
ui
#
(
var_info
,
var_heap
)
=
readPtr
var_info_ptr
ui
.
ui_var_heap
#
ui
=
{
ui
&
ui_var_heap
=
var_heap
}
=
case
var_info
of
VI_Alias
var2
#
(
var_info2
,
var_heap
)
=
readPtr
var2
.
var_info_ptr
ui
.
ui_var_heap
#
ui
=
{
ui
&
ui_var_heap
=
var_heap
}
->
skip_aliases
var_info2
var2
var_info_ptr
ui
_
->
(
expr
,
ui
)
where
skip_aliases
var_info2
=:(
VI_Alias
var3
)
var2
var_info_ptr1
ui
=:{
ui_var_heap
}
#
ui
=
set_alias_and_detect_cycle
var_info_ptr1
var3
ui
|
var3
.
var_info_ptr
==
var_info_ptr1
=
(
Var
var2
,
ui
)
#
(
var_info3
,
var_heap
)
=
readPtr
var3
.
var_info_ptr
ui
.
ui_var_heap
#
ui
=
{
ui
&
ui_var_heap
=
var_heap
}
=
skip_aliases
var_info3
var3
var2
.
var_info_ptr
ui
skip_aliases
var_info2
var2
var_info
ui
=
(
Var
var2
,
ui
)
updateExpression
group_index
expr
ui
=
(
expr
,
ui
)
set_alias_and_detect_cycle
info_ptr
var
ui
|
info_ptr
<>
var
.
var_info_ptr
=
{
ui
&
ui_var_heap
=
writePtr
info_ptr
(
VI_Alias
var
)
ui
.
ui_var_heap
}
#
(
var_info
,
var_heap
)
=
readPtr
info_ptr
ui
.
ui_var_heap
#
ui
=
{
ui
&
ui_var_heap
=
var_heap
}
=
case
var_info
of
VI_Alias
var
|
var
.
var_info_ptr
==
info_ptr
// to prevent repeating cycle error
->
ui
_
#
ui
=
{
ui
&
ui_var_heap
=
writePtr
info_ptr
(
VI_Alias
var
)
ui
.
ui_var_heap
}
->
{
ui
&
ui_error
=
cycleAfterRemovingNewTypeConstructorsError
var
.
var_ident
ui
.
ui_error
}
remove_NewTypePatterns_case_and_update_expression
::
!
Expression
!
Index
!*
UpdateInfo
->
(!
Expression
,!*
UpdateInfo
)
remove_NewTypePatterns_case_and_update_expression
(
Case
{
case_guards
=
NewTypePatterns
type
[{
ap_symbol
,
ap_vars
=[
ap_var
=:{
fv_info_ptr
}],
ap_expr
,
ap_position
}],
case_expr
,
case_default
,
case_explicit
,
case_info_ptr
})
group_index
ui
#
ap_expr
=
add_case_default
ap_expr
case_default
#
ap_expr
=
if
case_explicit
(
mark_case_explicit
ap_expr
)
ap_expr
#
(
case_expr
,
ui
)
=
updateExpression
group_index
case_expr
ui
=
case
case_expr
of
Var
var
#
ui
=
set_alias_and_detect_cycle
fv_info_ptr
var
ui
->
updateExpression
group_index
ap_expr
ui
case_expr
#
(
ap_expr
,
ui
)
=
updateExpression
group_index
ap_expr
ui
#
let_bind
=
{
lb_dst
=
ap_var
,
lb_src
=
case_expr
,
lb_position
=
ap_position
}
#
(
EI_CaseType
{
ct_pattern_type
},
ui_symbol_heap
)
=
readPtr
case_info_ptr
ui
.
ui_symbol_heap
// # (let_info_ptr, ui_symbol_heap) = newPtr (EI_LetType [ct_pattern_type]) ui_symbol_heap
#
let_info_ptr
=
case_info_ptr
#
ui_symbol_heap
=
writePtr
case_info_ptr
(
EI_LetType
[
ct_pattern_type
])
ui_symbol_heap
#
ui
=
{
ui
&
ui_symbol_heap
=
ui_symbol_heap
}
#
let_expr
=
Let
{
let_strict_binds
=
[],
let_lazy_binds
=
[
let_bind
],
let_expr
=
ap_expr
,
let_info_ptr
=
let_info_ptr
,
let_expr_position
=
ap_position
}
->
(
let_expr
,
ui
)
where
mark_case_explicit
(
Case
case_
=:{
case_explicit
})
=
Case
{
case_
&
case_explicit
=
True
}
mark_case_explicit
(
Let
let_
=:{
let_expr
})
=
Let
{
let_
&
let_expr
=
mark_case_explicit
let_expr
}
mark_case_explicit
expr
=
expr
add_case_default
expr
No
=
expr
add_case_default
expr
(
Yes
default_expr
)
=
add_default
expr
default_expr
where
add_default
(
Case
kees
=:{
case_default
=
No
,
case_explicit
=
False
})
default_expr
=
Case
{
kees
&
case_default
=
Yes
default_expr
}
add_default
(
Case
kees
=:{
case_default
=
Yes
case_default_expr
,
case_explicit
=
False
})
default_expr
=
Case
{
kees
&
case_default
=
Yes
(
add_default
case_default_expr
default_expr
)}
add_default
(
Let
lad
=:{
let_expr
})
default_expr
=
Let
{
lad
&
let_expr
=
add_default
let_expr
default_expr
}
add_default
expr
_
=
expr
instance
updateExpression
LetBind
where
updateExpression
group_index
bind
=:{
lb_src
}
ui
...
...
@@ -1607,6 +1696,50 @@ where
updateExpression
group_index
l
ui
=
mapSt
(
updateExpression
group_index
)
l
ui
set_aliases_for_binds_that_will_become_aliases
::
![
LetBind
]
!*
UpdateInfo
->
*
UpdateInfo
set_aliases_for_binds_that_will_become_aliases
[]
ui
=
ui
set_aliases_for_binds_that_will_become_aliases
[{
lb_dst
={
fv_info_ptr
},
lb_src
}:
let_binds
]
ui
#
ui
=
make_alias_if_expression_will_become_var
lb_src
fv_info_ptr
ui
=
set_aliases_for_binds_that_will_become_aliases
let_binds
ui
where
make_alias_if_expression_will_become_var
(
Var
var
)
fv_info_ptr
ui
=
set_alias_and_detect_cycle
fv_info_ptr
var
ui
make_alias_if_expression_will_become_var
(
App
{
app_symb
={
symb_kind
=
SK_NewTypeConstructor
_},
app_args
=[
arg
]})
fv_info_ptr
ui
=
skip_newtypes_and_make_alias_if_var
arg
fv_info_ptr
ui
make_alias_if_expression_will_become_var
(
MatchExpr
{
glob_object
={
ds_arity
=
-2
}}
expr
)
fv_info_ptr
ui
=
skip_newtypes_and_make_alias_if_var
expr
fv_info_ptr
ui
make_alias_if_expression_will_become_var
expr
=:(
Case
{
case_guards
=
NewTypePatterns
_
_})
fv_info_ptr
ui
=
skip_newtypes_and_make_alias_if_var
expr
fv_info_ptr
ui
make_alias_if_expression_will_become_var
_
fv_info_ptr
ui
=
ui
skip_newtypes_and_make_alias_if_var
expr
fv_info_ptr
ui
=
case
skip_newtypes
expr
of
Var
var
->
set_alias_and_detect_cycle
fv_info_ptr
var
ui
_
->
ui
where
skip_newtypes
(
App
{
app_symb
={
symb_kind
=
SK_NewTypeConstructor
_},
app_args
=[
arg
]})
=
skip_newtypes
arg
skip_newtypes
(
MatchExpr
{
glob_object
={
ds_arity
=
-2
}}
expr
)
=
skip_newtypes
expr
skip_newtypes
expr
=:(
Case
{
case_guards
=
NewTypePatterns
type
[{
ap_symbol
,
ap_vars
=[
ap_var
=:{
fv_info_ptr
}],
ap_expr
}],
case_expr
})
=
case
skip_newtypes
case_expr
of
Var
case_var
->
case
skip_newtypes
ap_expr
of
Var
rhs_var
|
rhs_var
.
var_info_ptr
==
fv_info_ptr
->
case_expr
->
ap_expr
_
->
expr
_
->
expr
skip_newtypes
expr
=
expr
adjustClassExpressions
symb_ident
exprs
tail_exprs
ui
=
mapAppendSt
(
adjustClassExpression
symb_ident
)
exprs
tail_exprs
ui
where
...
...
frontend/parse.icl
View file @
6fd027e3
...
...
@@ -1651,7 +1651,7 @@ wantTypeDef :: !ParseContext !Position !ParseState -> (ParsedDefinition, !Parse
wantTypeDef parseContext pos pState
# (type_lhs, annot, pState) = want_type_lhs pos pState
(token, pState) = nextToken TypeContext pState
(def, pState) = want_type_rhs parseContext type_lhs
token
annot pState
(def, pState) = want_type_rhs
token
parseContext type_lhs annot pState
pState = wantEndOfDefinition "type definition (6)" pState
= (def, pState)
where
...
...
@@ -1664,8 +1664,8 @@ where
(contexts, pState) = optionalContext pState
= (MakeTypeDef ident args (ConsList []) attr contexts pos, annot, pState)
want_type_rhs :: !ParseContext !ParsedTypeDef
!Token
!Annotation !ParseState -> (ParsedDefinition, !ParseState)
want_type_rhs parseContext td=:{td_ident,td_attribute}
EqualToken
annot pState
want_type_rhs ::
!Token
!ParseContext !ParsedTypeDef !Annotation !ParseState -> (ParsedDefinition, !ParseState)
want_type_rhs
EqualToken
parseContext td=:{td_ident,td_attribute} annot pState
# name = td_ident.id_name
pState = verify_annot_attr annot td_attribute name pState
(exi_vars, pState) = optionalExistentialQuantifiedVariables pState
...
...
@@ -1695,7 +1695,7 @@ where
(rec_cons_ident, pState) = stringToIdent ("_" + name) IC_Expression pState
= (PD_Type { td & td_rhs = SelectorList rec_cons_ident exi_vars is_boxed_record fields }, pState)
want_type_rhs parseContext td=:{td_attribute}
ColonDefinesToken
annot pState // type
Macro
want_type_rhs
ColonDefinesToken
parseContext td=:{td_attribute} annot pState // type
synonym
# name = td.td_ident.id_name
pState = verify_annot_attr annot td_attribute name pState
(atype, pState) = want pState // Atype
...
...
@@ -1704,7 +1704,18 @@ where
= (PD_Type td, pState)
= (PD_Type td, parseError "Type synonym" No ("No lhs strictness annotation for the type synonym "+name) pState)
want_type_rhs parseContext td=:{td_attribute} token=:OpenToken annot pState
want_type_rhs DefinesColonToken parseContext td=:{td_ident,td_attribute} annot pState
# name = td_ident.id_name
pState = verify_annot_attr annot td_attribute name pState
(exi_vars, pState) = optionalExistentialQuantifiedVariables pState
(token, pState) = nextToken GeneralContext pState
(condef, pState) = want_newtype_constructor exi_vars token pState
td = { td & td_rhs = NewTypeCons condef }
| annot == AN_None
= (PD_Type td, pState)
= (PD_Type td, parseError "New type" No ("No lhs strictness annotation for the new type "+name) pState)
want_type_rhs token=:OpenToken parseContext td=:{td_attribute} annot pState
| isIclContext parseContext
= (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState)
# pState = wantToken TypeContext "Abstract type synonym" ColonDefinesToken pState
...
...
@@ -1717,7 +1728,7 @@ where
= (PD_Type td, pState)
= (PD_Type td, parseError "abstract type" No ("type attribute "+toString td_attribute+" for abstract type "+name+" is not") (tokenBack pState))
want_type_rhs parseContext td=:{td_attribute}
token
annot pState
want_type_rhs
token
parseContext td=:{td_attribute} annot pState
| isIclContext parseContext
= (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState)
| td_attribute == TA_Anonymous || td_attribute == TA_Unique || td_attribute == TA_None
...
...
@@ -1747,11 +1758,7 @@ where
want_constructor_list :: ![ATypeVar] !Token !ParseState -> (.[ParsedConstructor],ParseState)
want_constructor_list exi_vars token pState
# token = basic_type_to_constructor token
# (pc_cons_ident, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState
(pc_arg_types, pState) = parseList tryBrackSAType pState
cons = { pc_cons_ident = pc_cons_ident, pc_arg_types = atypes_from_satypes pc_arg_types, pc_args_strictness=strictness_from_satypes pc_arg_types, pc_cons_arity = length pc_arg_types,
pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos}
# (cons,pState) = want_constructor exi_vars token pState
(token, pState) = nextToken TypeContext pState
| token == BarToken
# (exi_vars, pState) = optionalExistentialQuantifiedVariables pState
...
...
@@ -1760,31 +1767,51 @@ where
= ([cons : cons_list], pState)
// otherwise