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
b2345e1b
Commit
b2345e1b
authored
Mar 20, 2001
by
Sjaak Smetsers
Browse files
Sjaak: fixed inheritance bugs and strictness attributes
parent
3f236734
Changes
18
Hide whitespace changes
Inline
Side-by-side
frontend/check.icl
View file @
b2345e1b
...
...
@@ -32,9 +32,10 @@ checkGenerics
#
cs
=
{
cs
&
cs_error
=
cs_error
,
cs_symbol_table
=
cs_symbol_table
}
#
type_heaps
=
{
type_heaps
&
th_vars
=
th_vars
}
/*
# (gen_type, specials, type_defs, class_defs, modules, type_heaps, cs) =
checkSymbolType module_index gen_type SP_None type_defs class_defs modules type_heaps cs
*/
#
cs
=
{
cs
&
cs_symbol_table
=
removeVariablesFromSymbolTable
cGlobalScope
gen_args
cs
.
cs_symbol_table
}
#
generic_defs
=
{
generic_defs
&
[
gen_index
]
=
{
gen_def
&
gen_type
=
gen_type
,
gen_args
=
gen_args
}}
...
...
@@ -57,41 +58,17 @@ where
checkTypeClasses
::
!
Index
!
Index
!*{#
ClassDef
}
!*{#
MemberDef
}
!*{#
CheckedTypeDef
}
!*{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!*{#
ClassDef
},
!*{#
MemberDef
},
!*{#
CheckedTypeDef
},
!*{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkTypeClasses
class_index
module_index
class_defs
member_defs
type_defs
modules
type_heaps
=:{
th_vars
}
cs
=:{
cs_symbol_table
,
cs_error
}
checkTypeClasses
class_index
module_index
class_defs
member_defs
type_defs
modules
type_heaps
cs
=:{
cs_symbol_table
,
cs_error
}
|
class_index
==
size
class_defs
=
(
class_defs
,
member_defs
,
type_defs
,
modules
,
type_heaps
,
cs
)
#
(
class_def
=:{
class_name
,
class_pos
,
class_args
,
class_context
,
class_members
},
class_defs
)
=
class_defs
![
class_index
]
position
=
newPosition
class_name
class_pos
cs_error
=
setErrorAdmin
position
cs_error
(
rev_class_args
,
cs_symbol_table
,
th_vars
,
cs_error
)
=
add_variables_to_symbol_table
cGlobalScope
class_args
[]
cs_symbol_table
th_vars
cs_error
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
,
cs_error
=
cs_error
}
(
class_context
,
type_defs
,
class_defs
,
modules
,
type_heaps
,
cs
)
=
checkTypeContexts
class_context
module_index
type_defs
class_defs
modules
{
type_heaps
&
th_vars
=
th_vars
}
cs
(
class_args
,
cs_symbol_table
)
=
retrieve_variables_from_symbol_table
rev_class_args
[]
cs
.
cs_symbol_table
cs
=
{
cs
&
cs_error
=
setErrorAdmin
(
newPosition
class_name
class_pos
)
cs_error
}
(
class_args
,
class_context
,
type_defs
,
class_defs
,
modules
,
type_heaps
,
cs
)
=
checkSuperClasses
class_args
class_context
module_index
type_defs
class_defs
modules
type_heaps
cs
class_defs
=
{
class_defs
&
[
class_index
]
=
{
class_def
&
class_context
=
class_context
,
class_args
=
class_args
}}
member_defs
=
set_classes_in_member_defs
0
class_members
{
glob_object
=
class_index
,
glob_module
=
module_index
}
member_defs
=
checkTypeClasses
(
inc
class_index
)
module_index
class_defs
member_defs
type_defs
modules
type_heaps
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
=
checkTypeClasses
(
inc
class_index
)
module_index
class_defs
member_defs
type_defs
modules
type_heaps
cs
where
add_variables_to_symbol_table
::
!
Level
![
TypeVar
]
![
TypeVar
]
!*
SymbolTable
!*
TypeVarHeap
!*
ErrorAdmin
->
(![
TypeVar
],!*
SymbolTable
,!*
TypeVarHeap
,!*
ErrorAdmin
)
add_variables_to_symbol_table
level
[]
rev_class_args
symbol_table
th_vars
error
=
(
rev_class_args
,
symbol_table
,
th_vars
,
error
)
add_variables_to_symbol_table
level
[
var
=:{
tv_name
={
id_name
,
id_info
}}
:
vars
]
rev_class_args
symbol_table
th_vars
error
#
(
entry
,
symbol_table
)
=
readPtr
id_info
symbol_table
|
entry
.
ste_kind
==
STE_Empty
||
entry
.
ste_def_level
<
level
#
(
new_var_ptr
,
th_vars
)
=
newPtr
TVI_Empty
th_vars
#
symbol_table
=
NewEntry
symbol_table
id_info
(
STE_TypeVariable
new_var_ptr
)
NoIndex
level
entry
=
add_variables_to_symbol_table
level
vars
[{
var
&
tv_info_ptr
=
new_var_ptr
}
:
rev_class_args
]
symbol_table
th_vars
error
=
add_variables_to_symbol_table
level
vars
rev_class_args
symbol_table
th_vars
(
checkError
id_name
"(variable) already defined"
error
)
retrieve_variables_from_symbol_table
::
![
TypeVar
]
![
TypeVar
]
!*
SymbolTable
->
(![
TypeVar
],!*
SymbolTable
)
retrieve_variables_from_symbol_table
[
var
=:{
tv_name
={
id_name
,
id_info
}}
:
vars
]
class_args
symbol_table
#
(
entry
,
symbol_table
)
=
readPtr
id_info
symbol_table
=
retrieve_variables_from_symbol_table
vars
[
var
:
class_args
]
(
symbol_table
<:=
(
id_info
,
entry
.
ste_previous
))
retrieve_variables_from_symbol_table
[]
class_args
symbol_table
=
(
class_args
,
symbol_table
)
set_classes_in_member_defs
mem_offset
class_members
glob_class_index
member_defs
|
mem_offset
==
size
class_members
=
member_defs
...
...
@@ -99,7 +76,6 @@ where
#
(
member_def
,
member_defs
)
=
member_defs
![
ds_index
]
=
set_classes_in_member_defs
(
inc
mem_offset
)
class_members
glob_class_index
{
member_defs
&
[
ds_index
]
=
{
member_def
&
me_class
=
glob_class_index
}}
checkSpecial
::
!
Index
!
FunType
!
Index
!
SpecialSubstitution
(!
Index
,
![
FunType
],
!*
Heaps
,
!*
ErrorAdmin
)
->
(!
Special
,
(!
Index
,
![
FunType
],
!*
Heaps
,
!*
ErrorAdmin
))
checkSpecial
mod_index
fun_type
=:{
ft_type
}
fun_index
subst
(
next_inst_index
,
special_types
,
heaps
,
error
)
...
...
@@ -131,7 +107,7 @@ where
#
position
=
newPosition
ft_symb
ft_pos
cs
=
{
cs
&
cs_error
=
setErrorAdmin
position
cs
.
cs_error
}
(
ft_type
,
ft_specials
,
type_defs
,
class_defs
,
modules
,
hp_type_heaps
,
cs
)
=
check
Symbol
Type
module_index
ft_type
ft_specials
type_defs
class_defs
modules
heaps
.
hp_type_heaps
cs
=
check
Function
Type
module_index
ft_type
ft_specials
type_defs
class_defs
modules
heaps
.
hp_type_heaps
cs
(
spec_types
,
next_inst_index
,
collected_instances
,
heaps
,
cs_error
)
=
check_specials
module_index
{
fun_type
&
ft_type
=
ft_type
}
fun_index
ft_specials
next_inst_index
collected_instances
{
heaps
&
hp_type_heaps
=
hp_type_heaps
}
cs
.
cs_error
...
...
@@ -198,13 +174,13 @@ where
#
(
member_def
=:{
me_symb
,
me_type
,
me_pos
},
member_defs
)
=
member_defs
![
member_index
]
position
=
newPosition
me_symb
me_pos
cs
=
{
cs
&
cs_error
=
setErrorAdmin
position
cs
.
cs_error
}
(
me_type
,
_,
type_defs
,
class_defs
,
modules
,
type_heaps
,
cs
)
=
check
Symbol
Type
module_index
me_type
SP_None
type_defs
class_defs
modules
type_heaps
cs
me_class_vars
=
map
(\(
TV
type_var
)
->
type_var
)
(
hd
me_type
.
st_context
).
tc_types
(
me_type
,
type_defs
,
class_defs
,
modules
,
type_heaps
,
cs
)
=
check
Member
Type
module_index
me_type
type_defs
class_defs
modules
type_heaps
cs
me_class_vars
=
[
type_var
\\
(
TV
type_var
)
<-
(
hd
me_type
.
st_context
).
tc_types
]
(
me_type_ptr
,
var_heap
)
=
newPtr
VI_Empty
var_heap
=
({
member_defs
&
[
member_index
]
=
{
member_def
&
me_type
=
me_type
,
me_class_vars
=
me_class_vars
,
me_type_ptr
=
me_type_ptr
}},
type_defs
,
class_defs
,
modules
,
type_heaps
,
var_heap
,
cs
)
::
InstanceSymbols
=
{
is_type_defs
::
!.{#
CheckedTypeDef
}
,
is_class_defs
::
!.{#
ClassDef
}
...
...
@@ -696,8 +672,9 @@ checkFunction mod_index fun_index def_level fun_defs
(
ef_type_defs
,
ef_modules
,
es_type_heaps
,
es_expr_heap
,
cs
)
=
checkDynamicTypes
mod_index
es_dynamics
fun_type
e_info
.
ef_type_defs
e_info
.
ef_modules
es_type_heaps
es_expr_heap
cs
cs
=
{
cs
&
cs_error
=
popErrorAdmin
cs
.
cs_error
}
fi_properties
=
(
if
ef_is_macro_fun
FI_IsMacroFun
0
)
bitor
(
has_type
fun_type
)
fun_info
=
{
fun_def
.
fun_info
&
fi_calls
=
es_calls
,
fi_def_level
=
def_level
,
fi_free_vars
=
free_vars
,
fi_dynamics
=
es_dynamics
,
fi_is_macro_fun
=
ef_is_macro_fun
}
fi_properties
=
fi_properties
}
fun_defs
=
{
es_fun_defs
&
[
fun_index
]
=
{
fun_def
&
fun_body
=
fun_body
,
fun_index
=
fun_index
,
fun_info
=
fun_info
,
fun_type
=
fun_type
}}
(
fun_defs
,
cs_symbol_table
)
=
remove_calls_from_symbol_table
fun_index
def_level
es_calls
fun_defs
cs
.
cs_symbol_table
=
(
fun_defs
,
...
...
@@ -706,8 +683,11 @@ checkFunction mod_index fun_index def_level fun_defs
{
cs
&
cs_symbol_table
=
cs_symbol_table
})
where
has_type
(
Yes
_)
=
FI_HasTypeSpec
has_type
no
=
0
check_function_type
(
Yes
ft
)
module_index
type_defs
class_defs
modules
var_heap
type_heaps
cs
#
(
ft
,
_,
type_defs
,
class_defs
,
modules
,
type_heaps
,
cs
)
=
check
Symbol
Type
module_index
ft
SP_None
type_defs
class_defs
modules
type_heaps
cs
#
(
ft
,
_,
type_defs
,
class_defs
,
modules
,
type_heaps
,
cs
)
=
check
Function
Type
module_index
ft
SP_None
type_defs
class_defs
modules
type_heaps
cs
(
st_context
,
var_heap
)
=
initializeContextVariables
ft
.
st_context
var_heap
=
(
Yes
{
ft
&
st_context
=
st_context
}
,
type_defs
,
class_defs
,
modules
,
var_heap
,
type_heaps
,
cs
)
...
...
frontend/checkFunctionBodies.icl
View file @
b2345e1b
...
...
@@ -959,12 +959,12 @@ where
->
(!
SymbKind
,
!
Int
,
!
Priority
,
!
Bool
,
!*
ExpressionState
,
!
u
:
ExpressionInfo
,!*
CheckState
)
determine_info_of_symbol
entry
=:{
ste_kind
=
STE_FunctionOrMacro
calls
,
ste_index
,
ste_def_level
}
symb_info
e_input
=:{
ei_fun_index
,
ei_mod_index
}
e_state
=:{
es_fun_defs
,
es_calls
}
e_info
cs
=:{
cs_symbol_table
,
cs_x
}
#
({
fun_symb
,
fun_arity
,
fun_kind
,
fun_priority
,
fun_info
},
es_fun_defs
)
=
es_fun_defs
![
ste_index
]
#
({
fun_symb
,
fun_arity
,
fun_kind
,
fun_priority
,
fun_info
={
fi_properties
}
},
es_fun_defs
)
=
es_fun_defs
![
ste_index
]
#
index
=
{
glob_object
=
ste_index
,
glob_module
=
cs_x
.
x_main_dcl_module_n
}
|
is_called_before
ei_fun_index
calls
|
case
fun_kind
of
FK_DefMacro
->
True
;
FK_ImpMacro
->
True
;
_
->
False
=
(
SK_Macro
index
,
fun_arity
,
fun_priority
,
cIsAFunction
,
{
e_state
&
es_fun_defs
=
es_fun_defs
},
e_info
,
cs
)
#
symbol_kind
=
if
fun_info
.
fi_is_macro_fun
(
SK_LocalMacroFunction
ste_index
)
(
SK_Function
index
)
#
symbol_kind
=
if
(
fi_properties
bitand
FI_IsMacroFun
<>
0
)
(
SK_LocalMacroFunction
ste_index
)
(
SK_Function
index
)
=
(
symbol_kind
,
fun_arity
,
fun_priority
,
cIsAFunction
,
{
e_state
&
es_fun_defs
=
es_fun_defs
},
e_info
,
cs
)
#
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
<:=
(
symb_info
,
{
entry
&
ste_kind
=
STE_FunctionOrMacro
[
ei_fun_index
:
calls
]})}
e_state
=
{
e_state
&
es_fun_defs
=
es_fun_defs
,
es_calls
=
[{
fc_index
=
ste_index
,
fc_level
=
ste_def_level
}
:
es_calls
]}
...
...
@@ -974,7 +974,7 @@ where
FK_ImpMacro
->
SK_Macro
index
;
_
|
f
un_info
.
fi_is_macro_fun
|
f
i_properties
bitand
FI_IsMacroFun
<>
0
->
SK_LocalMacroFunction
ste_index
->
SK_Function
index
=
(
symbol_kind
,
fun_arity
,
fun_priority
,
cIsAFunction
,
e_state
,
e_info
,
cs
)
...
...
frontend/checksupport.icl
View file @
b2345e1b
...
...
@@ -308,7 +308,7 @@ addLocalFunctionDefsToSymbolTable level from_index to_index is_macro_fun fun_def
#
(
fun_def
,
fun_defs
)
=
fun_defs
![
from_index
]
#
(
symbol_table
,
error
)
=
addDefToSymbolTable
level
from_index
fun_def
.
fun_symb
(
STE_FunctionOrMacro
[])
symbol_table
error
|
is_macro_fun
#
fun_defs
=
{
fun_defs
&
[
from_index
].
fun_info
.
fi_
is_macro_fun
=
is_m
acro
_f
un
}
#
fun_defs
=
{
fun_defs
&
[
from_index
].
fun_info
.
fi_
properties
=
fun_def
.
fun_info
.
fi_properties
bitor
FI_IsM
acro
F
un
}
=
addLocalFunctionDefsToSymbolTable
level
(
inc
from_index
)
to_index
is_macro_fun
fun_defs
symbol_table
error
=
addLocalFunctionDefsToSymbolTable
level
(
inc
from_index
)
to_index
is_macro_fun
fun_defs
symbol_table
error
...
...
frontend/checktypes.dcl
View file @
b2345e1b
...
...
@@ -5,15 +5,18 @@ import checksupport, typesupport
checkTypeDefs
::
/* TD */
!
Bool
!
Bool
!*{#
CheckedTypeDef
}
!
Index
!*{#
ConsDef
}
!*{#
SelectorDef
}
!*{#
DclModule
}
!*
VarHeap
!*
TypeHeaps
!*
CheckState
->
(!*{#
CheckedTypeDef
},
!*{#
ConsDef
},
!*{#
SelectorDef
},
!*{#
DclModule
},
!*
VarHeap
,
!*
TypeHeaps
,
!*
CheckState
)
check
Symbol
Type
::
!
Index
!
SymbolType
!
Specials
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
check
Function
Type
::
!
Index
!
SymbolType
!
Specials
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!
SymbolType
,
!
Specials
,
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
check
TypeContexts
::
![
TypeContext
]
!
Index
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!
[
TypeContext
]
,
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
check
MemberType
::
!
Index
!
SymbolType
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!
SymbolType
,
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkInstanceType
::
!
Index
!(
Global
DefinedSymbol
)
!
InstanceType
!
Specials
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!
InstanceType
,
!
Specials
,
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkSuperClasses
::
![
TypeVar
]
![
TypeContext
]
!
Index
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(![
TypeVar
],
![
TypeContext
],
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkDynamicTypes
::
!
Index
![
ExprInfoPtr
]
!(
Optional
SymbolType
)
!
u
:{#
CheckedTypeDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
ExpressionHeap
!*
CheckState
->
(!
u
:{#
CheckedTypeDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
ExpressionHeap
,
!*
CheckState
)
...
...
frontend/checktypes.icl
View file @
b2345e1b
...
...
@@ -674,15 +674,16 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
=
check_fully_polymorphity
it_types
it_context
cs
.
cs_error
ots
=
{
ots_type_defs
=
type_defs
,
ots_modules
=
modules
}
oti
=
{
oti_heaps
=
heaps
,
oti_all_vars
=
[],
oti_all_attrs
=
[],
oti_global_vars
=
[]
}
(
it_types
,
(
ots
,
{
oti_heaps
,
oti_all_vars
,
oti_all_attrs
},
cs
))
=
checkOpenTypes
mod_index
cGlobalScope
DAK_None
it_types
(
ots
,
oti
,
{
cs
&
cs_error
=
cs_error
})
(
it_context
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
=
checkTypeContexts
it_context
mod_index
ots
.
ots_type_defs
class_defs
ots
.
ots_modules
oti_heaps
cs
cs_error
=
foldSt
(
compare_context_and_instance_types
ins_class
it_types
)
it_context
cs
.
cs_error
(
it_types
,
(
ots
,
oti
=:{
oti_all_vars
=
it_vars
,
oti_all_attrs
=
it_attr_vars
},
cs
))
=
checkOpenTypes
mod_index
cGlobalScope
DAK_None
it_types
(
ots
,
oti
,
{
cs
&
cs_error
=
cs_error
})
oti
=
{
oti
&
oti_all_vars
=
[],
oti_all_attrs
=
[]
}
(
it_context
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
=
checkTypeContexts
it_context
mod_index
class_defs
ots
oti
cs
cs_error
=
foldSt
(
compare_context_and_instance_types
ins_class
it_types
)
it_context
cs
.
cs_error
(
specials
,
cs
)
=
checkSpecialTypeVars
specials
{
cs
&
cs_error
=
cs_error
}
cs_symbol_table
=
removeVariablesFromSymbolTable
cGlobalScope
oti_all
_vars
cs
.
cs_symbol_table
cs_symbol_table
=
removeAttributesFromSymbolTable
oti_all_att
rs
cs_symbol_table
cs_symbol_table
=
removeVariablesFromSymbolTable
cGlobalScope
it
_vars
cs
.
cs_symbol_table
cs_symbol_table
=
removeAttributesFromSymbolTable
it_attr_va
rs
cs_symbol_table
(
specials
,
type_defs
,
modules
,
heaps
,
cs
)
=
checkSpecialTypes
mod_index
specials
type_defs
modules
heaps
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
=
({
it
&
it_vars
=
oti_all
_vars
,
it_types
=
it_types
,
it_attr_vars
=
oti_all_att
rs
,
it_context
=
it_context
},
=
({
it
&
it_vars
=
it
_vars
,
it_types
=
it_types
,
it_attr_vars
=
it_attr_va
rs
,
it_context
=
it_context
},
specials
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
where
check_fully_polymorphity
it_types
it_context
cs_error
...
...
@@ -715,32 +716,37 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
compare_context_and_instance_type
_
_
are_equal_accu
=
False
checkFunctionType
::
!
Index
!
SymbolType
!
Specials
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!
SymbolType
,
!
Specials
,
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkFunctionType
mod_index
st
specials
type_defs
class_defs
modules
heaps
cs
=
checkSymbolType
True
mod_index
st
specials
type_defs
class_defs
modules
heaps
cs
checkMemberType
::
!
Index
!
SymbolType
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!
SymbolType
,
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkMemberType
mod_index
st
type_defs
class_defs
modules
heaps
cs
#
(
checked_st
,
specials
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
=
checkSymbolType
False
mod_index
st
SP_None
type_defs
class_defs
modules
heaps
cs
=
(
checked_st
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
checkSymbolType
::
!
Index
!
SymbolType
!
Specials
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
checkSymbolType
::
!
Bool
!
Index
!
SymbolType
!
Specials
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!
SymbolType
,
!
Specials
,
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkSymbolType
mod_index
st
=:{
st_args
,
st_result
,
st_context
,
st_attr_env
}
specials
type_defs
class_defs
modules
heaps
cs
checkSymbolType
is_function
mod_index
st
=:{
st_args
,
st_result
,
st_context
,
st_attr_env
}
specials
type_defs
class_defs
modules
heaps
cs
#
ots
=
{
ots_type_defs
=
type_defs
,
ots_modules
=
modules
}
oti
=
{
oti_heaps
=
heaps
,
oti_all_vars
=
[],
oti_all_attrs
=
[],
oti_global_vars
=
[]
}
(
st_args
,
cot_state
)
=
checkOpenATypes
mod_index
cGlobalScope
st_args
(
ots
,
oti
,
cs
)
(
st_result
,
(
ots
,
{
oti_heaps
,
oti_all_vars
,
oti_all_attrs
},
cs
))
=
checkOpenAType
mod_index
cGlobalScope
DAK_None
st_result
cot_state
(
st_context
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
=
checkTypeContexts
st_context
mod_index
ots
.
ots_type_defs
class_defs
ots
.
ots_modules
oti_heaps
cs
(
st_attr_env
,
cs
)
=
check_attr_inequalities
st_attr_env
cs
(
st_result
,
(
ots
,
oti
=:{
oti_all_vars
=
st_vars
,
oti_all_attrs
=
st_attr_vars
},
cs
))
=
checkOpenAType
mod_index
cGlobalScope
DAK_None
st_result
cot_state
oti
=
{
oti
&
oti_all_vars
=
[],
oti_all_attrs
=
[]
}
(
st_context
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
=
check_type_contexts
is_function
st_context
mod_index
class_defs
ots
oti
cs
(
st_attr_env
,
cs
)
=
mapSt
check_attr_inequality
st_attr_env
cs
(
specials
,
cs
)
=
checkSpecialTypeVars
specials
cs
cs_symbol_table
=
removeVariablesFromSymbolTable
cGlobalScope
oti_all
_vars
cs
.
cs_symbol_table
cs_symbol_table
=
removeAttributesFromSymbolTable
oti_all_att
rs
cs_symbol_table
cs_symbol_table
=
removeVariablesFromSymbolTable
cGlobalScope
st
_vars
cs
.
cs_symbol_table
cs_symbol_table
=
removeAttributesFromSymbolTable
st_attr_va
rs
cs_symbol_table
(
specials
,
type_defs
,
modules
,
heaps
,
cs
)
=
checkSpecialTypes
mod_index
specials
type_defs
modules
heaps
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
checked_st
=
{
st
&
st_vars
=
oti_all
_vars
,
st_args
=
st_args
,
st_result
=
st_result
,
st_context
=
st_context
,
st_attr_vars
=
oti_all_att
rs
,
st_attr_env
=
st_attr_env
}
checked_st
=
{
st
&
st_vars
=
st
_vars
,
st_args
=
st_args
,
st_result
=
st_result
,
st_context
=
st_context
,
st_attr_vars
=
st_attr_va
rs
,
st_attr_env
=
st_attr_env
}
=
(
checked_st
,
specials
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
// ---> ("checkSymbolType", st, checked_st)
where
check_attr_inequalities
[
ineq
:
ineqs
]
cs
#
(
ineq
,
cs
)
=
check_attr_inequality
ineq
cs
(
ineqs
,
cs
)
=
check_attr_inequalities
ineqs
cs
=
([
ineq
:
ineqs
],
cs
)
check_attr_inequalities
[]
cs
=
([],
cs
)
check_attr_inequality
ineq
=:{
ai_demanded
=
ai_demanded
=:{
av_name
=
dem_name
},
ai_offered
=
ai_offered
=:{
av_name
=
off_name
}}
cs
=:{
cs_symbol_table
,
cs_error
}
#
(
dem_entry
,
cs_symbol_table
)
=
readPtr
dem_name
.
id_info
cs_symbol_table
#
(
found_dem_attr
,
dem_attr_ptr
)
=
retrieve_attribute
dem_entry
...
...
@@ -752,46 +758,75 @@ where
{
cs
&
cs_symbol_table
=
cs_symbol_table
})
=
(
ineq
,
{
cs
&
cs_error
=
checkError
off_name
"attribute variable undefined"
cs_error
,
cs_symbol_table
=
cs_symbol_table
})
=
(
ineq
,
{
cs
&
cs_error
=
checkError
dem_name
"attribute variable undefined"
cs_error
,
cs_symbol_table
=
cs_symbol_table
})
retrieve_attribute
{
ste_kind
=
STE_TypeAttribute
attr_ptr
,
ste_def_level
,
ste_index
}
|
ste_def_level
==
cGlobalScope
=
(
True
,
attr_ptr
)
retrieve_attribute
entry
=
(
False
,
abort
"no attribute"
)
checkTypeContexts
::
![
TypeContext
]
!
Index
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(![
TypeContext
],
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkTypeContexts
[
tc
:
tcs
]
mod_index
type_defs
class_defs
modules
heaps
cs
#
(
tc
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
=
check_type_context
tc
mod_index
type_defs
class_defs
modules
heaps
cs
(
tcs
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
=
checkTypeContexts
tcs
mod_index
type_defs
class_defs
modules
heaps
cs
=
([
tc
:
tcs
],
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
where
retrieve_attribute
{
ste_kind
=
STE_TypeAttribute
attr_ptr
,
ste_def_level
,
ste_index
}
|
ste_def_level
==
cGlobalScope
=
(
True
,
attr_ptr
)
retrieve_attribute
entry
=
(
False
,
abort
"no attribute"
)
check_type_contexts
is_function
st_context
mod_index
class_defs
ots
oti
cs
|
is_function
=
checkTypeContexts
st_context
mod_index
class_defs
ots
oti
cs
=
check_member_contexts
st_context
mod_index
class_defs
ots
oti
cs
check_member_contexts
[
tc
:
tcs
]
mod_index
class_defs
ots
oti
cs
#
(
tc
,
(
class_defs
,
ots
,
oti
,
cs
))
=
checkTypeContext
mod_index
tc
(
class_defs
,
ots
,
oti
,
cs
)
cs_symbol_table
=
removeVariablesFromSymbolTable
cGlobalScope
[
tv
\\
(
TV
tv
)
<-
tc
.
tc_types
]
cs
.
cs_symbol_table
(
tcs
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
=
checkTypeContexts
tcs
mod_index
class_defs
ots
oti
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
=
([
tc
:
tcs
],
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
NewEntry
symbol_table
symb_ptr
def_kind
def_index
level
previous
:==
symbol_table
<:=
(
symb_ptr
,{
ste_kind
=
def_kind
,
ste_index
=
def_index
,
ste_def_level
=
level
,
ste_previous
=
previous
})
checkSuperClasses
::
![
TypeVar
]
![
TypeContext
]
!
Index
!
u
:{#
CheckedTypeDef
}
!
v
:{#
ClassDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(![
TypeVar
],
![
TypeContext
],
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkSuperClasses
class_args
class_contexts
mod_index
type_defs
class_defs
modules
heaps
=:{
th_vars
}
cs
=:{
cs_symbol_table
,
cs_error
}
#
(
rev_class_args
,
cs_symbol_table
,
th_vars
,
cs_error
)
=
foldSt
add_variable_to_symbol_table
class_args
([],
cs_symbol_table
,
th_vars
,
cs_error
)
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
,
cs_error
=
cs_error
}
ots
=
{
ots_modules
=
modules
,
ots_type_defs
=
type_defs
}
oti
=
{
oti_heaps
=
{
heaps
&
th_vars
=
th_vars
},
oti_all_vars
=
[],
oti_all_attrs
=
[],
oti_global_vars
=
[]
}
(
class_contexts
,
type_defs
,
class_defs
,
modules
,
type_heaps
,
cs
)
=
checkTypeContexts
class_contexts
mod_index
class_defs
ots
oti
cs
(
class_args
,
cs_symbol_table
)
=
retrieve_variables_from_symbol_table
rev_class_args
[]
cs
.
cs_symbol_table
=
(
class_args
,
class_contexts
,
type_defs
,
class_defs
,
modules
,
type_heaps
,
{
cs
&
cs_symbol_table
=
cs_symbol_table
})
where
check_type_context
::
!
TypeContext
!
Index
v
:{#
CheckedTypeDef
}
!
x
:{#
ClassDef
}
!
u
:{#.
DclModule
}
!*
TypeHeaps
!*
CheckState
->
(!
TypeContext
,!
z
:{#
CheckedTypeDef
},!
x
:{#
ClassDef
},!
w
:{#
DclModule
},!*
TypeHeaps
,!*
CheckState
),
[
u
v
<=
w
,
v
u
<=
z
]
check_type_context
tc
=:{
tc_class
=
tc_class
=:{
glob_object
=
class_name
=:{
ds_ident
=
ds_ident
=:{
id_name
,
id_info
},
ds_arity
}},
tc_types
}
mod_index
type_defs
class_defs
modules
heaps
cs
=:{
cs_symbol_table
,
cs_predef_symbols
}
#
(
entry
,
cs_symbol_table
)
=
readPtr
id_info
cs_symbol_table
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
#
(
class_index
,
class_module
)
=
retrieveGlobalDefinition
entry
STE_Class
mod_index
|
class_index
<>
NotFound
#
(
class_def
,
class_index
,
class_defs
,
modules
)
=
getClassDef
class_index
class_module
mod_index
class_defs
modules
ots
=
{
ots_modules
=
modules
,
ots_type_defs
=
type_defs
}
oti
=
{
oti_heaps
=
heaps
,
oti_all_vars
=
[],
oti_all_attrs
=
[],
oti_global_vars
=
[]
}
(
tc_types
,
(
ots
,
{
oti_all_vars
,
oti_all_attrs
,
oti_heaps
},
cs
))
=
checkOpenTypes
mod_index
cGlobalScope
DAK_Ignore
tc_types
(
ots
,
oti
,
cs
)
cs
=
check_context_types
class_def
.
class_name
tc_types
cs
cs
=
foldr
(\
{
tv_name
}
cs
=:{
cs_symbol_table
,
cs_error
}
->
{
cs
&
cs_symbol_table
=
removeDefinitionFromSymbolTable
cGlobalScope
tv_name
cs_symbol_table
,
cs_error
=
checkError
tv_name
" undefined"
cs_error
})
cs
oti_all_vars
cs
=
foldr
(\
{
av_name
}
cs
=:{
cs_symbol_table
,
cs_error
}
->
{
cs
&
cs_symbol_table
=
removeDefinitionFromSymbolTable
cGlobalScope
av_name
cs_symbol_table
,
cs_error
=
checkError
av_name
" undefined"
cs_error
})
cs
oti_all_attrs
tc
=
{
tc
&
tc_class
=
{
tc_class
&
glob_object
=
{
class_name
&
ds_index
=
class_index
},
glob_module
=
class_module
},
tc_types
=
tc_types
}
|
class_def
.
class_arity
==
ds_arity
=
(
tc
,
ots
.
ots_type_defs
,
class_defs
,
ots
.
ots_modules
,
oti_heaps
,
cs
)
=
(
tc
,
ots
.
ots_type_defs
,
class_defs
,
ots
.
ots_modules
,
oti_heaps
,
{
cs
&
cs_error
=
checkError
id_name
"used with wrong arity"
cs
.
cs_error
})
=
(
tc
,
type_defs
,
class_defs
,
modules
,
heaps
,
{
cs
&
cs_error
=
checkError
id_name
"undefined"
cs
.
cs_error
})
add_variable_to_symbol_table
::
!
TypeVar
!(![
TypeVar
],
!*
SymbolTable
,
!*
TypeVarHeap
,
!*
ErrorAdmin
)
->
(![
TypeVar
],!*
SymbolTable
,!*
TypeVarHeap
,!*
ErrorAdmin
)
add_variable_to_symbol_table
tv
=:{
tv_name
={
id_name
,
id_info
}}
(
rev_class_args
,
symbol_table
,
th_vars
,
error
)
#
(
entry
,
symbol_table
)
=
readPtr
id_info
symbol_table
|
entry
.
ste_kind
==
STE_Empty
||
entry
.
ste_def_level
<
cGlobalScope
#
(
new_var_ptr
,
th_vars
)
=
newPtr
TVI_Empty
th_vars
#
symbol_table
=
NewEntry
symbol_table
id_info
(
STE_TypeVariable
new_var_ptr
)
NoIndex
cGlobalScope
entry
=
([{
tv
&
tv_info_ptr
=
new_var_ptr
}
:
rev_class_args
],
symbol_table
,
th_vars
,
error
)
=
(
rev_class_args
,
symbol_table
,
th_vars
,
checkError
id_name
"(variable) already defined"
error
)
retrieve_variables_from_symbol_table
::
![
TypeVar
]
![
TypeVar
]
!*
SymbolTable
->
(![
TypeVar
],!*
SymbolTable
)
retrieve_variables_from_symbol_table
[
var
=:{
tv_name
={
id_name
,
id_info
}}
:
vars
]
class_args
symbol_table
#
(
entry
,
symbol_table
)
=
readPtr
id_info
symbol_table
=
retrieve_variables_from_symbol_table
vars
[
var
:
class_args
]
(
symbol_table
<:=
(
id_info
,
entry
.
ste_previous
))
retrieve_variables_from_symbol_table
[]
class_args
symbol_table
=
(
class_args
,
symbol_table
)
checkTypeContext
::
!
Index
!
TypeContext
!(!
v
:{#
ClassDef
},
!
u
:
OpenTypeSymbols
,
!*
OpenTypeInfo
,
!*
CheckState
)
->
(!
TypeContext
,!(!
v
:{#
ClassDef
},
!
u
:
OpenTypeSymbols
,
!*
OpenTypeInfo
,
!*
CheckState
))
checkTypeContext
mod_index
tc
=:{
tc_class
=
tc_class
=:{
glob_object
=
class_name
=:{
ds_ident
=
ds_ident
=:{
id_name
,
id_info
},
ds_arity
}},
tc_types
}
(
class_defs
,
ots
,
oti
,
cs
=:{
cs_symbol_table
,
cs_predef_symbols
})
#
(
entry
,
cs_symbol_table
)
=
readPtr
id_info
cs_symbol_table
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
#
(
class_index
,
class_module
)
=
retrieveGlobalDefinition
entry
STE_Class
mod_index
|
class_index
<>
NotFound
#
(
class_def
,
class_index
,
class_defs
,
ots_modules
)
=
getClassDef
class_index
class_module
mod_index
class_defs
ots
.
ots_modules
ots
=
{
ots
&
ots_modules
=
ots_modules
}
(
tc_types
,
(
ots
,
oti
,
cs
))
=
checkOpenTypes
mod_index
cGlobalScope
DAK_Ignore
tc_types
(
ots
,
oti
,
cs
)
cs
=
check_context_types
class_def
.
class_name
tc_types
cs
tc
=
{
tc
&
tc_class
=
{
tc_class
&
glob_object
=
{
class_name
&
ds_index
=
class_index
},
glob_module
=
class_module
},
tc_types
=
tc_types
}
|
class_def
.
class_arity
==
ds_arity
=
(
tc
,
(
class_defs
,
ots
,
oti
,
cs
))
=
(
tc
,
(
class_defs
,
ots
,
oti
,
{
cs
&
cs_error
=
checkError
id_name
"used with wrong arity"
cs
.
cs_error
}))
=
(
tc
,
(
class_defs
,
ots
,
oti
,
{
cs
&
cs_error
=
checkError
id_name
"undefined"
cs
.
cs_error
}))
where
check_context_types
tc_class
[]
cs
=:{
cs_error
}
=
{
cs
&
cs_error
=
checkError
tc_class
" type context should contain one or more type variables"
cs_error
}
check_context_types
tc_class
[
TV
_
:
types
]
cs
...
...
@@ -799,8 +834,28 @@ where
check_context_types
tc_class
[
type
:
types
]
cs
=
check_context_types
tc_class
types
cs
checkTypeContexts
[]
_
type_defs
class_defs
modules
heaps
cs
=
([],
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
checkTypeContexts
::
![
TypeContext
]
!
Index
!
v
:{#
ClassDef
}
!
u
:
OpenTypeSymbols
!*
OpenTypeInfo
!*
CheckState
->
(![
TypeContext
],
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkTypeContexts
tcs
mod_index
class_defs
ots
oti
cs
#
(
tcs
,
(
class_defs
,
{
ots_modules
,
ots_type_defs
},
oti
,
cs
))
=
mapSt
(
checkTypeContext
mod_index
)
tcs
(
class_defs
,
ots
,
oti
,
cs
)
cs
=
check_class_variables
oti
.
oti_all_vars
cs
cs
=
check_class_attributes
oti
.
oti_all_attrs
cs
=
(
tcs
,
ots_type_defs
,
class_defs
,
ots_modules
,
oti
.
oti_heaps
,
cs
)
where
check_class_variables
class_variables
cs
=
foldSt
check_class_variable
class_variables
cs
where
check_class_variable
{
tv_name
}
cs
=:{
cs_symbol_table
,
cs_error
}
=
{
cs
&
cs_symbol_table
=
removeDefinitionFromSymbolTable
cGlobalScope
tv_name
cs_symbol_table
,
cs_error
=
checkError
tv_name
" not defined or defined as class variable"
cs_error
}
check_class_attributes
class_attributes
cs
=
foldSt
check_class_attribute
class_attributes
cs
where
check_class_attribute
{
av_name
}
cs
=:{
cs_symbol_table
,
cs_error
}
=
{
cs
&
cs_symbol_table
=
removeDefinitionFromSymbolTable
cGlobalScope
av_name
cs_symbol_table
,
cs_error
=
checkError
av_name
" undefined"
cs_error
}
checkDynamicTypes
::
!
Index
![
ExprInfoPtr
]
!(
Optional
SymbolType
)
!
u
:{#
CheckedTypeDef
}
!
u
:{#
DclModule
}
!*
TypeHeaps
!*
ExpressionHeap
!*
CheckState
->
(!
u
:{#
CheckedTypeDef
},
!
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
ExpressionHeap
,
!*
CheckState
)
...
...
@@ -831,6 +886,8 @@ where
|
entry
.
ste_kind
==
STE_Empty
=
symbol_table
=
symbol_table
<:=
(
id_info
,
entry
.
ste_previous
)
checkDynamicTypes
mod_index
dyn_type_ptrs
(
Yes
{
st_vars
})
type_defs
modules
type_heaps
expr_heap
cs
=:{
cs_symbol_table
}
#
(
th_vars
,
cs_symbol_table
)
=
foldSt
add_type_variable_to_symbol_table
st_vars
(
type_heaps
.
th_vars
,
cs_symbol_table
)
...
...
frontend/comparedefimp.icl
View file @
b2345e1b
...
...
@@ -252,7 +252,8 @@ compareTwoMacroFuns dclIndex iclIndex
ident_pos
=
getIdentPos
dcl_function
ec_error_admin
=
pushErrorAdmin
ident_pos
ec_state
.
ec_error_admin
ec_state
=
{
ec_state
&
ec_error_admin
=
ec_error_admin
}
|
dcl_function
.
fun_info
.
fi_is_macro_fun
<>
icl_function
.
fun_info
.
fi_is_macro_fun
||
// Sjaak : | dcl_function.fun_info.fi_is_macro_fun<>icl_function.fun_info.fi_is_macro_fun ||
|
dcl_function
.
fun_info
.
fi_properties
bitand
FI_IsMacroFun
<>
icl_function
.
fun_info
.
fi_properties
bitand
FI_IsMacroFun
||
dcl_function
.
fun_priority
<>
icl_function
.
fun_priority
#
ec_state
=
give_error
dcl_function
.
fun_symb
ec_state
=
{
ec_state
&
ec_error_admin
=
popErrorAdmin
ec_state
.
ec_error_admin
}
...
...
frontend/convertDynamics.icl
View file @
b2345e1b
...
...
@@ -68,7 +68,6 @@ write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_modul
convertDynamicPatternsIntoUnifyAppls
::
{!
GlobalTCType
}
!{#
CommonDefs
}
!
Int
!*{!
Group
}
!*{#
FunDef
}
!*
PredefinedSymbols
!*
VarHeap
!*
TypeHeaps
!*
ExpressionHeap
/* TD */
(
Optional
!*
File
)
{#
DclModule
}
!
IclModule
/* TD */
[
String
]
->
(!*{!
Group
},
!*{#
FunDef
},
!*
PredefinedSymbols
,
!*{#{#
CheckedTypeDef
}},
!
ImportedConstructors
,
!*
VarHeap
,
!*
TypeHeaps
,
!*
ExpressionHeap
,
/* TD */
(
Optional
!*
File
))
convertDynamicPatternsIntoUnifyAppls
global_type_instances
common_defs
main_dcl_module_n
groups
fun_defs
predefined_symbols
var_heap
type_heaps
expr_heap
/* TD */
tcl_file
dcl_mods
icl_mod
/* TD */
directly_imported_dcl_modules
// TD ...
#
tcl_file
=
case
tcl_file
of
...
...
@@ -83,7 +82,6 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
// ... TD
#
({
pds_module
,
pds_def
}
,
predefined_symbols
)
=
predefined_symbols
![
PD_StdDynamics
]
#!
(
dynamic_temp_symb_ident
,
ci_sel_value_field
,
ci_sel_type_field
,
predefined_symbols
)
=
case
(
pds_module
==
(
-1
)
||
pds_def
==
(
-1
))
of
...
...
frontend/convertcases.icl
View file @
b2345e1b
...
...
@@ -468,6 +468,8 @@ toOptionalFreeVar No var_heap
::
ImportedFunctions
:==
[
Global
Index
]
cDontRemoveAnnatations
:==
False
addNewFunctionsToGroups
::
!{#.
CommonDefs
}
FunctionHeap
![
FunctionInfoPtr
]
!
Int
!*{!
Group
}
!*{#{#
CheckedTypeDef
}}
!
ImportedFunctions
!*
TypeHeaps
!*
VarHeap
->
(!*{!
Group
},
![
FunDef
],
!*{#{#
CheckedTypeDef
}},
!
ImportedConstructors
,
!*
TypeHeaps
,
!*
VarHeap
)
addNewFunctionsToGroups
common_defs
fun_heap
new_functions
main_dcl_module_n
groups
imported_types
imported_conses
type_heaps
var_heap
...
...
@@ -479,11 +481,13 @@ where
->
(!*{!
Group
},
![
FunDef
],
!*{#{#
CheckedTypeDef
}},
!
ImportedConstructors
,
!*
TypeHeaps
,
!*
VarHeap
)
add_new_function_to_group
fun_heap
common_defs
fun_ptr
(
groups
,
fun_defs
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
#
(
FI_Function
{
gf_fun_def
,
gf_fun_index
})
=
sreadPtr
fun_ptr
fun_heap
group_index
=
gf_fun_def
.
fun_info
.
fi_group_index
{
fun_type
=
Yes
ft
,
fun_info
=
{
fi_group_index
,
fi_properties
}}
=
gf_fun_def
(
Yes
ft
)
=
gf_fun_def
.
fun_type
(
ft
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
common_defs
ft
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
#
(
group
,
groups
)
=
groups
![
group_index
]
=
({
groups
&
[
group_index
]
=
{
group
&
group_members
=
[
gf_fun_index
:
group
.
group_members
]}
},
(
ft
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
(
fi_properties
bitand
FI_HasTypeSpec
==
0
)
common_defs
ft
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
#
(
group
,
groups
)
=
groups
![
fi_group_index
]
=
({
groups
&
[
fi_group_index
]
=
{
group
&
group_members
=
[
gf_fun_index
:
group
.
group_members
]}
},
[
{
gf_fun_def
&
fun_type
=
Yes
ft
}:
fun_defs
],
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
convertCasesOfFunctionsIntoPatterns
::
!*{!
Group
}
!
Int
!{#
{#
FunType
}
}
!{#
CommonDefs
}
!*{#
FunDef
}
!*{#{#
CheckedTypeDef
}}
...
...
@@ -572,7 +576,7 @@ where
convert_dcl_function
dcl_functions
common_defs
dcl_index
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
#
{
ft_type
,
ft_type_ptr
}
=
dcl_functions
.[
dcl_index
]
(
ft_type
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
common_defs
ft_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
convertSymbolType
cDontRemoveAnnatations
common_defs
ft_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
(
imported_types
,
imported_conses
,
var_heap
<:=
(
ft_type_ptr
,
VI_ExpandedType
ft_type
),
type_heaps
)
convertConstructorTypes
cons_defs
main_dcl_module_n
common_defs
types_and_heaps
...
...
@@ -581,7 +585,7 @@ where
convert_constructor_type
common_defs
cons_defs
cons_index
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
#
{
cons_type_ptr
,
cons_type
}
=
cons_defs
.[
cons_index
]
(
cons_type
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
common_defs
cons_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
convertSymbolType
cDontRemoveAnnatations
common_defs
cons_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
(
imported_types
,
imported_conses
,
var_heap
<:=
(
cons_type_ptr
,
VI_ExpandedType
cons_type
),
type_heaps
)
...
...
@@ -591,7 +595,7 @@ where
convert_selector_type
common_defs
selector_defs
sel_index
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
#
{
sd_type_ptr
,
sd_type
}
=
selector_defs
.[
sel_index
]
(
sd_type
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
common_defs
sd_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
convertSymbolType
cDontRemoveAnnatations
common_defs
sd_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
(
imported_types
,
imported_conses
,
var_heap
<:=
(
sd_type_ptr
,
VI_ExpandedType
sd_type
),
type_heaps
)
convertIclModule
::
!
Int
!{#
CommonDefs
}
!*{#{#
CheckedTypeDef
}}
!
ImportedConstructors
!*
VarHeap
!*
TypeHeaps
...
...
@@ -641,7 +645,7 @@ where
convert_imported_function
dcl_functions
common_defs
{
glob_object
,
glob_module
}
(
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
#
{
ft_type_ptr
,
ft_type
}
=
dcl_functions
.[
glob_module
].[
glob_object
]
(
ft_type
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
common_defs
ft_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
convertSymbolType
cDontRemoveAnnatations
common_defs
ft_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
(
imported_types
,
imported_conses
,
type_heaps
,
var_heap
<:=
(
ft_type_ptr
,
VI_ExpandedType
ft_type
))
convert_imported_constructors
common_defs
[]
imported_types
type_heaps
var_heap
...
...
@@ -649,7 +653,8 @@ where
convert_imported_constructors
common_defs
[
{
glob_module
,
glob_object
}
:
conses
]
imported_types
type_heaps
var_heap
#
{
com_cons_defs
,
com_selector_defs
}
=
common_defs
.[
glob_module
]
{
cons_type_ptr
,
cons_type
,
cons_type_index
,
cons_symb
}
=
common_defs
.[
glob_module
].
com_cons_defs
.[
glob_object
]
(
cons_type
,
imported_types
,
conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
common_defs
cons_type
main_dcl_module_n
imported_types
conses
type_heaps
var_heap
(
cons_type
,
imported_types
,
conses
,
type_heaps
,
var_heap
)