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
4a1abad7
Commit
4a1abad7
authored
Jan 17, 2000
by
Sjaak Smetsers
Browse files
Bug fixes
parent
edb4c5f1
Changes
10
Hide whitespace changes
Inline
Side-by-side
frontend/check.icl
View file @
4a1abad7
...
...
@@ -883,7 +883,6 @@ checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input var_env ps e_info cs
checkPattern
(
PE_DynamicPattern
pattern
type
)
opt_var
p_input
var_env
ps
e_info
cs
#
(
dyn_pat
,
var_env
,
ps
,
e_info
,
cs
)
=
checkPattern
pattern
No
p_input
var_env
ps
e_info
cs
// MW was = (AP_Dynamic dyn_pat type opt_var, var_env, ps, e_info, cs)
=
(
AP_Dynamic
dyn_pat
type
opt_var
,
var_env
,
ps
,
e_info
,
{
cs
&
cs_needed_modules
=
cs
.
cs_needed_modules
bitor
cNeedStdDynamics
})
checkPattern
(
PE_Basic
basic_value
)
opt_var
p_input
var_env
ps
e_info
cs
...
...
@@ -1048,7 +1047,8 @@ where
#
index
=
{
glob_object
=
ste_index
,
glob_module
=
cIclModIndex
}
|
is_called_before
ei_fun_index
calls
|
fun_kind
==
FK_Macro
=
(
SK_Macro
index
,
fun_arity
,
fun_priority
,
cIsNotAFunction
,
e_state
,
e_info
,
cs
)
// = (SK_Macro index, fun_arity, fun_priority, cIsNotAFunction, e_state, e_info, cs)
=
(
SK_Macro
index
,
fun_arity
,
fun_priority
,
cIsAFunction
,
e_state
,
e_info
,
cs
)
=
(
SK_Function
index
,
fun_arity
,
fun_priority
,
cIsAFunction
,
e_state
,
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_calls
=
[{
fc_index
=
ste_index
,
fc_level
=
ste_def_level
}
:
es_calls
]}
...
...
@@ -1308,21 +1308,7 @@ where
_
->
(
patterns
,
pattern_scheme
,
pattern_variables
,
defaul
,
var_store
,
expr_heap
,
opt_dynamics
,
{
cs
&
cs_error
=
checkError
basic_val
"illegal combination of patterns"
cs
.
cs_error
})
/*
= case patterns of
BasicPatterns basic_type basic_patterns
| type_symbol == basic_type
-> (BasicPatterns basic_type [pattern : basic_patterns], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
-> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
{ cs & cs_error = checkError basic_val "incompatible types of patterns" cs.cs_error })
NoPattern
-> (BasicPatterns type_symbol [pattern], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
_
-> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
{ cs & cs_error = checkError basic_val "illegal combination of patterns" cs.cs_error})
*/
transform_pattern
(
AP_Dynamic
pattern
type
opt_var
)
patterns
pattern_scheme
pattern_variables
defaul
result_expr
_
var_store
expr_heap
opt_dynamics
cs
// # cs = { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics } // MW++
#
(
var_arg
,
result_expr
,
var_store
,
expr_heap
,
opt_dynamics
,
cs
)
=
convertSubPattern
pattern
result_expr
var_store
expr_heap
opt_dynamics
cs
(
dynamic_info_ptr
,
expr_heap
)
=
newPtr
(
EI_DynamicType
type
opt_dynamics
)
expr_heap
pattern
=
{
dp_var
=
var_arg
,
dp_type
=
dynamic_info_ptr
,
dp_rhs
=
result_expr
,
dp_type_patterns_vars
=
[],
dp_type_code
=
TCE_Empty
}
...
...
@@ -1336,16 +1322,6 @@ where
_
->
(
patterns
,
pattern_scheme
,
pattern_variables
,
defaul
,
var_store
,
expr_heap
,
opt_dynamics
,
{
cs
&
cs_error
=
checkError
"<dynamic pattern>"
"illegal combination of patterns"
cs
.
cs_error
})
/*
= case patterns of
DynamicPatterns dyn_patterns
-> (DynamicPatterns [pattern : dyn_patterns], pattern_variables, defaul, var_store, expr_heap, [dynamic_info_ptr], cs)
NoPattern
-> (DynamicPatterns [pattern], pattern_variables, defaul, var_store, expr_heap, [dynamic_info_ptr], cs)
_
-> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
{ cs & cs_error = checkError "<dynamic pattern>" "illegal combination of patterns" cs.cs_error })
*/
transform_pattern
(
AP_Variable
name
var_info
opt_var
)
NoPattern
pattern_scheme
pattern_variables
No
result_expr
_
var_store
expr_heap
opt_dynamics
cs
=
(
NoPattern
,
pattern_scheme
,
cons_optional
opt_var
pattern_variables
,
Yes
([{
fv_name
=
name
,
fv_info_ptr
=
var_info
,
fv_def_level
=
NotALevel
,
fv_count
=
0
}],
result_expr
),
...
...
@@ -1361,29 +1337,15 @@ where
// if (!has_been_inserted) checkWarning("pattern won't match");
=
(
NoPattern
,
pattern_scheme
,
(
cons_optional
opt_var
pattern_variables
),
Yes
(
cons_opt
free_var
vars_as_patterns
,
new_defaul
),
var_store
,
expr_heap
,
opt_dynamics
,
cs
)
/*
transform_pattern (AP_Variable name var_info opt_var) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs
= (patterns, cons_optional opt_var pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
{ cs & cs_error = checkError name "illegal combination of patterns" cs.cs_error })
*/
// MW added the following alternative
transform_pattern
(
AP_WildCard
(
Yes
opt_var
))
patterns
pattern_scheme
pattern_variables
defaul
result_expr
case_name
var_store
expr_heap
opt_dynamics
cs
=
transform_pattern
(
AP_Variable
opt_var
.
bind_src
opt_var
.
bind_dst
No
)
patterns
pattern_scheme
pattern_variables
defaul
result_expr
case_name
var_store
expr_heap
opt_dynamics
cs
transform_pattern
(
AP_WildCard
no
)
NoPattern
pattern_scheme
pattern_variables
No
result_expr
_
var_store
expr_heap
opt_dynamics
cs
=
(
NoPattern
,
pattern_scheme
,
pattern_variables
,
Yes
([],
result_expr
),
var_store
,
expr_heap
,
opt_dynamics
,
cs
)
/*
transform_pattern (AP_WildCard _) NoPattern pattern_variables No result_expr var_store expr_heap opt_dynamics cs
= (NoPattern, pattern_variables, Yes ([], result_expr), var_store, expr_heap, opt_dynamics, cs)
*/
transform_pattern
(
AP_WildCard
_)
patterns
pattern_scheme
pattern_variables
defaul
result_expr
case_name
var_store
expr_heap
opt_dynamics
cs
#
(
new_info_ptr
,
var_store
)
=
newPtr
VI_Empty
var_store
=
transform_pattern
(
AP_Variable
(
newVarId
"wc"
)
new_info_ptr
No
)
patterns
pattern_scheme
pattern_variables
defaul
result_expr
case_name
var_store
expr_heap
opt_dynamics
cs
/*
transform_pattern (AP_WildCard _) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs
= (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError "_" "illegal combination of patterns" cs.cs_error })
*/
transform_pattern
(
AP_Empty
name
)
patterns
pattern_scheme
pattern_variables
defaul
result_expr
_
var_store
expr_heap
opt_dynamics
cs
=
(
patterns
,
pattern_scheme
,
pattern_variables
,
defaul
,
var_store
,
expr_heap
,
opt_dynamics
,
cs
)
...
...
@@ -1406,19 +1368,6 @@ where
->
(
let_expression
,
expr_heap
)
No
->
(
EE
,
expr_heap
)
/*
build_case NoPattern defaul expr case_ident expr_heap
= case defaul of
Yes (opt_var, result)
-> case opt_var of
Yes var
# (let_expression, expr_heap) = bind_default_variable expr var result expr_heap
-> (let_expression, expr_heap)
No
-> (result, expr_heap)
No
-> (abort "incorrect case expression in build_case", expr_heap)
*/
build_case
(
DynamicPatterns
patterns
)
defaul
expr
case_ident
expr_heap
=
case
defaul
of
Yes
(
vars
,
result
)
...
...
@@ -1434,25 +1383,6 @@ where
No
#
(
type_case_info_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
->
(
buildTypeCase
expr
patterns
No
type_case_info_ptr
,
expr_heap
)
/*
build_case (DynamicPatterns patterns) defaul expr case_ident expr_heap
= case defaul of
Yes (opt_var, result)
-> case opt_var of
Yes var
# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
bound_var = { var_name = var.fv_name, var_info_ptr = var.fv_info_ptr, var_expr_ptr = var_expr_ptr }
result = buildTypeCase (Var bound_var) patterns (Yes result) type_case_info_ptr
(case_expression, expr_heap) = bind_default_variable expr var result expr_heap
-> (case_expression, expr_heap)
No
# (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (buildTypeCase expr patterns (Yes result) type_case_info_ptr, expr_heap)
No
# (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (buildTypeCase expr patterns No type_case_info_ptr, expr_heap)
*/
build_case
patterns
(
Yes
(
vars
,
result
))
expr
case_ident
expr_heap
=
case
vars
of
[]
#
(
case_expr_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
...
...
@@ -1465,31 +1395,9 @@ where
case_ident
=
Yes
case_ident
,
case_info_ptr
=
case_expr_ptr
}
(
case_expression
,
expr_heap
)
=
bind_default_variables
expr
(
reverse
vars
)
result
expr_heap
->
(
case_expression
,
expr_heap
)
/*
build_case patterns (Yes (defaul,result)) expr case_ident expr_heap
= case defaul of
Yes var
# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
bound_var = { var_name = var.fv_name, var_info_ptr = var.fv_info_ptr, var_expr_ptr = var_expr_ptr }
result = Case {case_expr = Var bound_var, case_guards = patterns, case_default = Yes result,
case_ident = Yes case_ident, case_info_ptr = case_expr_ptr}
(case_expression, expr_heap) = bind_default_variable expr var result expr_heap
-> (case_expression, expr_heap)
No
# (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (Case {case_expr = expr, case_guards = patterns, case_default = Yes result,
case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap)
*/
build_case
patterns
No
expr
case_ident
expr_heap
#
(
case_expr_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
=
(
Case
{
case_expr
=
expr
,
case_guards
=
patterns
,
case_default
=
No
,
case_ident
=
Yes
case_ident
,
case_info_ptr
=
case_expr_ptr
},
expr_heap
)
/*
bind_default_variable bind_src bind_dst result_expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Let {let_strict = cIsNotStrict, let_binds = [{ bind_src = bind_src, bind_dst = bind_dst }], let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap)
*/
bind_default_variables
expr
vars
result_expr
expr_heap
#
(
let_expr_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
(
var_binds
,
expr_heap
)
=
build_binds
vars
[]
expr_heap
...
...
@@ -1506,7 +1414,7 @@ where
=
(
pattern_expr
,
[],
expr_heap
)
bind_pattern_variables
[{
bind_src
,
bind_dst
}
:
variables
]
this_pattern_expr
expr_heap
#
free_var
=
{
fv_name
=
bind_src
,
fv_info_ptr
=
bind_dst
,
fv_def_level
=
NotALevel
,
fv_count
=
0
}
(
bound_var
,
expr_heap
)
=
allocate_bound_var
free_var
expr_heap
// MW
(
bound_var
,
expr_heap
)
=
allocate_bound_var
free_var
expr_heap
(
pattern_expr
,
binds
,
expr_heap
)
=
bind_pattern_variables
variables
(
Var
bound_var
)
expr_heap
=
(
pattern_expr
,
[{
bind_src
=
this_pattern_expr
,
bind_dst
=
free_var
}
:
binds
],
expr_heap
)
...
...
@@ -1641,7 +1549,6 @@ checkExpression free_vars (PE_Dynamic expr opt_type) e_input e_state=:{es_expres
(
dyn_expr
,
free_vars
,
e_state
,
e_info
,
cs
)
=
checkExpression
free_vars
expr
e_input
{
e_state
&
es_dynamics
=
[
dyn_info_ptr
:
es_dynamics
],
es_expression_heap
=
es_expression_heap
}
e_info
cs
=
(
DynamicExpr
{
dyn_expr
=
dyn_expr
,
dyn_opt_type
=
opt_type
,
dyn_info_ptr
=
dyn_info_ptr
,
dyn_type_code
=
TCE_Empty
,
dyn_uni_vars
=
[]
},
// MW was free_vars, e_state, e_info, cs)
free_vars
,
e_state
,
e_info
,
{
cs
&
cs_needed_modules
=
cs
.
cs_needed_modules
bitor
cNeedStdDynamics
})
checkExpression
free_vars
(
PE_Basic
basic_value
)
e_input
e_state
e_info
cs
...
...
@@ -1956,14 +1863,15 @@ where
(
binds
,
let_vars_list
,
rhs_expr_level
,
free_vars
,
e_state
,
e_info
,
cs
)
=
check_sequential_lets
free_vars
ewl_nodes
[]
{
e_input
&
ei_expr_level
=
this_expr_level
}
e_state
e_info
cs
(
expr
,
free_vars
,
e_state
,
e_info
,
cs
)
=
checkExpression
free_vars
ewl_expr
{
e_input
&
ei_expr_level
=
rhs_expr_level
}
e_state
e_info
cs
cs
=
{
cs
&
cs_symbol_table
=
remove_seq_let_vars
rhs_expr_level
let_vars_list
cs
.
cs_symbol_table
}
(
expr
,
free_vars
,
e_state
,
e_info
,
cs
)
=
checkRhssAndTransformLocalDefs
free_vars
loc_defs
expr
e_input
e_state
e_info
cs
(
seq_let_expr
,
es_expression_heap
)
=
build_sequential_lets
binds
expr
e_state
.
es_expression_heap
(
expr
,
free_vars
,
e_state
,
e_info
,
cs
)
=
checkRhssAndTransformLocalDefs
free_vars
loc_defs
seq_let_expr
e_input
{
e_state
&
es_expression_heap
=
es_expression_heap
}
e_info
cs
(
es_fun_defs
,
e_info
,
heaps
,
cs
)
=
checkLocalFunctions
ei_mod_index
rhs_expr_level
ewl_locals
e_state
.
es_fun_defs
e_info
=
checkLocalFunctions
ei_mod_index
rhs_expr_level
ewl_locals
e_state
.
es_fun_defs
e_info
{
hp_var_heap
=
e_state
.
es_var_heap
,
hp_expression_heap
=
e_state
.
es_expression_heap
,
hp_type_heaps
=
e_state
.
es_type_heaps
}
cs
(
es_fun_defs
,
cs_symbol_table
)
=
removeLocalsFromSymbolTable
this_expr_level
var_env
ewl_locals
es_fun_defs
cs
.
cs_symbol_table
(
seq_let_expr
,
es_expression_heap
)
=
build_sequential_lets
binds
expr
heaps
.
hp_expression_heap
=
(
seq_let_expr
,
free_vars
,
{
e_state
&
es_fun_defs
=
es_fun_defs
,
es_var_heap
=
heaps
.
hp_var_heap
,
es_expression_heap
=
es_expression_heap
,
es_type_heaps
=
heaps
.
hp_type_heaps
},
e_info
,
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
)
=
(
expr
,
free_vars
,
{
e_state
&
es_fun_defs
=
es_fun_defs
,
es_var_heap
=
heaps
.
hp_var_heap
,
es_expression_heap
=
heaps
.
hp_expression_heap
,
es_type_heaps
=
heaps
.
hp_type_heaps
},
e_info
,
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
)
remove_seq_let_vars
level
[]
symbol_table
=
symbol_table
...
...
@@ -2064,10 +1972,6 @@ convertSubPattern (AP_WildCard opt_var) result_expr var_store expr_heap opt_dyna
=
({
fv_name
=
bind_src
,
fv_info_ptr
=
bind_dst
,
fv_def_level
=
NotALevel
,
fv_count
=
0
},
result_expr
,
var_store
,
expr_heap
,
opt_dynamics
,
cs
)
convertSubPattern
(
AP_Empty
_)
result_expr
var_store
expr_heap
opt_dynamics
cs
=
convertSubPattern
(
AP_WildCard
No
)
EE
var_store
expr_heap
opt_dynamics
cs
/* MW was
convertSubPattern ap result_expr var_store expr_heap opt_dynamics cs
= abort ("convertSubPattern: unknown pattern " ---> ap)
*/
typeOfBasicValue
::
!
BasicValue
!*
CheckState
->
(!
BasicType
,
!*
CheckState
)
typeOfBasicValue
(
BVI
_)
cs
=
(
BT_Int
,
cs
)
...
...
@@ -2197,7 +2101,6 @@ where
=
(
Case
{
case_expr
=
act_var
,
case_guards
=
case_guards
,
case_default
=
No
,
case_ident
=
No
,
case_info_ptr
=
case_expr_ptr
},
var_store
,
expr_heap
,
opt_dynamics
,
cs
)
transform_pattern_into_cases
(
AP_Dynamic
pattern
type
opt_var
)
fun_arg
result_expr
var_store
expr_heap
opt_dynamics
cs
//# cs = { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics } // MW++
#
(
var_arg
,
result_expr
,
var_store
,
expr_heap
,
opt_dynamics
,
cs
)
=
convertSubPattern
pattern
result_expr
var_store
expr_heap
opt_dynamics
cs
(
type_case_info_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
(
dynamic_info_ptr
,
expr_heap
)
=
newPtr
(
EI_DynamicType
type
opt_dynamics
)
expr_heap
...
...
@@ -2564,7 +2467,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
(
scanned_modules
,
icl_functions
,
cs
)
=
add_modules_to_symbol_table
[
dcl_mod
,
pre_def_mod
:
scanned_modules
]
0
icl_functions
{
cs_symbol_table
=
symbol_table
,
cs_predef_symbols
=
predef_symbols
,
cs_error
=
error
,
/*MW*/
cs_needed_modules
=
0
}
{
cs_symbol_table
=
symbol_table
,
cs_predef_symbols
=
predef_symbols
,
cs_error
=
error
,
cs_needed_modules
=
0
}
init_dcl_modules
=
[
initialDclModule
scanned_module
\\
scanned_module
<-
scanned_modules
]
(
dcl_modules
,
local_defs
,
cdefs
,
sizes
,
cs
)
...
...
@@ -2583,7 +2486,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
(_,
{
ii_modules
,
ii_funs_and_macros
=
icl_functions
},
heaps
,
cs
)
=
checkImports
mod_imports
iinfo
heaps
cs
cs
=
{
cs
&
cs_needed_modules
=
0
}
// MW++
cs
=
{
cs
&
cs_needed_modules
=
0
}
(
nr_of_modules
,
(
f_consequences
,
ii_modules
,
icl_functions
,
hp_expression_heap
,
cs
))
=
check_completeness_of_all_dcl_modules
ii_modules
icl_functions
heaps
.
hp_expression_heap
cs
...
...
@@ -2614,7 +2517,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
(
icl_functions
,
e_info
,
heaps
,
cs
)
=
checkMacros
cIclModIndex
cdefs
.
def_macros
icl_functions
e_info
heaps
cs
(
icl_functions
,
e_info
,
heaps
,
cs
)
=
checkFunctions
cIclModIndex
cGlobalScope
0
nr_of_global_funs
icl_functions
e_info
heaps
cs
(
e_info
,
cs
)
=
check_needed_modules_are_imported
mod_name
".icl"
e_info
cs
// MW ++
(
e_info
,
cs
)
=
check_needed_modules_are_imported
mod_name
".icl"
e_info
cs
(
icl_functions
,
e_info
,
heaps
,
{
cs_symbol_table
,
cs_predef_symbols
,
cs_error
})
=
checkInstanceBodies
{
ir_from
=
first_inst_index
,
ir_to
=
nr_of_functions
}
icl_functions
e_info
heaps
cs
...
...
@@ -2829,7 +2732,6 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
(
Yes
symbol_type
)
=
inst_def
.
fun_type
=
{
instance_defs
&
[
ds_index
]
=
{
inst_def
&
fun_type
=
Yes
(
makeElemTypeOfArrayFunctionStrict
symbol_type
ins_offset
offset_table
)
}
}
// MW..
check_needed_modules_are_imported
mod_name
extension
e_info
cs
=:{
cs_needed_modules
}
#
(
e_info
,
cs
)
=
case
cs_needed_modules
bitand
cNeedStdDynamics
of
0
->
(
e_info
,
cs
)
...
...
@@ -2852,7 +2754,6 @@ check_needed_modules_are_imported mod_name extension e_info cs=:{cs_needed_modul
cs_error
=
checkError
pds_ident
"not imported"
cs_error
cs_error
=
popErrorAdmin
cs_error
=
(
e_info
,
{
cs
&
cs_error
=
cs_error
})
// ..MW
arrayFunOffsetToPD_IndexTable
member_defs
predef_symbols
#
nr_of_array_functions
=
size
member_defs
...
...
@@ -2963,7 +2864,6 @@ checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions h
dcl_common
=
createCommonDefinitions
mod_defs
dcl_macros
=
mod_defs
.
def_macros
// MW was (imports, modules, cs) = collect_imported_symbols mod_imports [] modules cs
(
imports
,
modules
,
cs
)
=
collect_imported_symbols
mod_imports
[]
modules
{
cs
&
cs_needed_modules
=
0
}
// imports :: [(Index,Declarations)]
...
...
@@ -2997,7 +2897,7 @@ checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions h
(
icl_functions
,
e_info
,
heaps
,
cs
)
=
checkMacros
mod_index
dcl_macros
icl_functions
e_info
heaps
{
cs
&
cs_error
=
cs_error
}
(
e_info
,
cs
)
=
check_needed_modules_are_imported
mod_name
".dcl"
e_info
cs
// MW ++
(
e_info
,
cs
)
=
check_needed_modules_are_imported
mod_name
".dcl"
e_info
cs
com_instance_defs
=
dcl_common
.
com_instance_defs
com_instance_defs
=
{
inst_def
\\
inst_def
<-
[
inst_def
\\
inst_def
<-:
com_instance_defs
]
++
new_class_instances
}
...
...
frontend/general.icl
View file @
4a1abad7
...
...
@@ -49,15 +49,17 @@ where
(--->)
infix
::
.
a
!
b
->
.
a
|
<<<
b
(--->)
val
message
|
file_to_true
(
stderr
<<<
message
<<<
'\n'
)
=
val
=
abort
"Internal error in --->"
|
file_to_true
(
stderr
<<<
message
<<<
'\n'
)
=
val
=
abort
"Internal error in --->"
(-?->)
infix
::
.
a
!(!
Bool
,
!
b
)
->
.
a
|
<<<
b
(-?->)
val
(
cond
,
message
)
|
cond
&&
file_to_true
(
stderr
<<<
message
<<<
'\n'
)
=
val
=
abort
"Internal error in --->"
|
cond
|
file_to_true
(
stderr
<<<
message
<<<
'\n'
)
=
val
=
abort
"Internal error in --->"
=
val
file_to_true
::
!
File
->
Bool
file_to_true
file
=
code {
...
...
frontend/overloading.icl
View file @
4a1abad7
...
...
@@ -2,7 +2,7 @@ implementation module overloading
import
StdEnv
import
syntax
,
check
,
type
,
typesupport
,
utilities
,
unitype
,
predef
//
, RWSDebug
import
syntax
,
check
,
type
,
typesupport
,
utilities
,
unitype
,
predef
,
RWSDebug
::
InstanceTree
=
IT_Node
!(
Global
Index
)
!
InstanceTree
!
InstanceTree
|
IT_Empty
...
...
@@ -178,8 +178,8 @@ where
#
{
ins_members
,
ins_class
}
=
defs
.[
glob_module
].
com_instance_defs
.[
glob_object
]
|
is_predefined_symbol
ins_class
.
glob_module
ins_class
.
glob_object
.
ds_index
PD_ArrayClass
predef_symbols
&&
is_unboxed_array
tc_types
predef_symbols
#
(
rcs_class_context
,
special_instances
,
predef_symbols
,
error
)
=
check_unboxed_type
glob_module
ins_class
ins_members
tc_types
class_members
defs
special_instances
predef_symbols
error
#
(
rcs_class_context
,
special_instances
,
(
predef_symbols
,
type_heaps
),
error
)
=
check_unboxed_type
glob_module
ins_class
ins_members
tc_types
class_members
defs
special_instances
(
predef_symbols
,
type_heaps
)
error
=
({
rcs_class_context
=
rcs_class_context
,
rcs_constraints_contexts
=
[]},
special_instances
,
type_pattern_vars
,
type_heaps
,
coercion_env
,
predef_symbols
,
error
)
#
(
appls
,
special_instances
,
type_pattern_vars
,
type_heaps
,
coercion_env
,
predef_symbols
,
error
)
...
...
@@ -293,39 +293,40 @@ where
is_unboxed_array
_
predef_symbols
=
False
check_unboxed_type
ins_module
ins_class
ins_members
types
=:[
_,
elem_type
:_]
class_members
defs
special_instances
predef_symbols
error
#
(
unboxable
,
opt_record
,
predef_symbols
)
=
try_to_unbox
elem_type
defs
predef_symbols
check_unboxed_type
ins_module
ins_class
ins_members
types
=:[
_,
elem_type
:_]
class_members
defs
special_instances
predef_symbols_type_heaps
error
#
(
unboxable
,
opt_record
,
predef_symbols_type_heaps
)
=
try_to_unbox
elem_type
defs
predef_symbols_type_heaps
|
unboxable
=
case
opt_record
of
Yes
record
#
(
ins_members
,
special_instances
)
=
add_record_to_array_instances
record
class_members
special_instances
->
({
rc_class
=
ins_class
,
rc_inst_module
=
cIclModIndex
,
rc_inst_members
=
ins_members
,
rc_red_contexts
=
[],
rc_types
=
types
},
special_instances
,
predef_symbols
,
error
)
special_instances
,
predef_symbols
_type_heaps
,
error
)
No
->
({
rc_class
=
ins_class
,
rc_inst_module
=
ins_module
,
rc_inst_members
=
ins_members
,
rc_red_contexts
=
[],
rc_types
=
types
},
special_instances
,
predef_symbols
,
error
)
special_instances
,
predef_symbols
_type_heaps
,
error
)
=
({
rc_class
=
ins_class
,
rc_inst_module
=
ins_module
,
rc_inst_members
=
ins_members
,
rc_red_contexts
=
[],
rc_types
=
types
},
special_instances
,
predef_symbols
,
unboxError
elem_type
error
)
special_instances
,
predef_symbols
_type_heaps
,
unboxError
elem_type
error
)
where
try_to_unbox
(
TB
_)
_
predef_symbols
=
(
True
,
No
,
predef_symbols
)
try_to_unbox
(
TA
type_symb
=:{
type_index
={
glob_module
,
glob_object
},
type_arity
}
_
)
defs
predef_symbols
#
{
td_arity
,
td_rhs
}
=
defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
try_to_unbox
(
TB
_)
_
predef_symbols
_type_heaps
=
(
True
,
No
,
predef_symbols
_type_heaps
)
try_to_unbox
(
TA
type_symb
=:{
type_index
={
glob_module
,
glob_object
},
type_arity
}
type_args
)
defs
(
predef_symbols
,
type_heaps
)
#
{
td_arity
,
td_rhs
,
td_args
}
=
defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
=
case
td_rhs
of
RecordType
_
->
(
True
,
(
Yes
type_symb
),
predef_symbols
)
->
(
True
,
(
Yes
type_symb
),
(
predef_symbols
,
type_heaps
)
)
AbstractType
_
#!
unboxable
=
is_predefined_symbol
glob_module
glob_object
PD_LazyArrayType
predef_symbols
||
is_predefined_symbol
glob_module
glob_object
PD_StrictArrayType
predef_symbols
||
is_predefined_symbol
glob_module
glob_object
PD_UnboxedArrayType
predef_symbols
->
(
unboxable
,
No
,
predef_symbols
)
->
(
unboxable
,
No
,
(
predef_symbols
,
type_heaps
))
SynType
{
at_type
}
#
(
expanded_type
,
type_heaps
)
=
expandTypeSyn
td_args
type_args
at_type
type_heaps
->
try_to_unbox
expanded_type
defs
(
predef_symbols
,
type_heaps
)
_
->
(
False
,
No
,
predef_symbols
)
try_to_unbox
type
_
predef_symbols
=
(
True
,
No
,
predef_symbols
)
->
(
False
,
No
,
(
predef_symbols
,
type_heaps
))
try_to_unbox
type
_
predef_symbols_type_heaps
=
(
True
,
No
,
predef_symbols_type_heaps
)
add_record_to_array_instances
::
!
TypeSymbIdent
!{#
DefinedSymbol
}
!*
SpecialInstances
->
(!{#
DefinedSymbol
},!*
SpecialInstances
)
add_record_to_array_instances
record
members
special_instances
=:{
si_next_array_member_index
,
si_array_instances
}
...
...
@@ -411,18 +412,23 @@ addGlobalTCInstance type_of_TC (next_member_index, [])
tryToExpandTypeSyn
defs
cons_id
=:{
type_name
,
type_index
={
glob_object
,
glob_module
}}
type_args
type_heaps
#
{
td_name
,
td_rhs
,
td_args
}
=
defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
|
is_synonym_typ
e
td_rhs
#
(
SynType
{
at_type
}
)
=
td_rhs
type_heaps
=
fold2St
bind_var
td_args
type_args
type_heaps
(
expanded_type
,
type_heaps
)
=
substitute
at_type
type_heaps
=
(
True
,
expanded_type
,
type_heaps
)
=
(
False
,
TA
cons_id
type_args
,
type_heaps
)
=
cas
e
td_rhs
of
SynType
{
at_type
}
#
(
expanded_type
,
type_heaps
)
=
expandTypeSyn
td_args
type_args
at_type
type_heaps
->
(
True
,
expanded_type
,
type_heaps
)
_
->
(
False
,
TA
cons_id
type_args
,
type_heaps
)
where
is_synonym_type
(
SynType
_)
=
True
is_synonym_type
type_rhs
=
False
expandTypeSyn
td_args
type_args
td_rhs
type_heaps
#
type_heaps
=
fold2St
bind_var
td_args
type_args
type_heaps
(
expanded_type
,
type_heaps
)
=
substitute
td_rhs
type_heaps
=
(
expanded_type
,
type_heaps
)
where
bind_var
{
atv_attribute
=
TA_Var
{
av_info_ptr
},
atv_variable
={
tv_info_ptr
}}
{
at_attribute
,
at_type
}
type_heaps
=:{
th_vars
,
th_attrs
}
=
{
type_heaps
&
th_vars
=
th_vars
<:=
(
tv_info_ptr
,
TVI_Type
at_type
),
th_attrs
=
th_attrs
<:=
(
av_info_ptr
,
AVI_Attr
at_attribute
)
}
bind_var
{
atv_variable
={
tv_info_ptr
}}
{
at_type
}
type_heaps
=:{
th_vars
}
...
...
@@ -529,6 +535,7 @@ where
|
isEmpty
call_ptrs
=
(
contexts
,
coercion_env
,
type_pattern_vars
,
os
)
#
os
=
{
os
&
os_error
=
setErrorAdmin
location
os_error
}
// ---> ("try_to_solve_overloading", call_ptrs)
=
case
fun_context
of
Yes
specified_context
#
(_,
coercion_env
,
type_pattern_vars
,
os
)
...
...
@@ -542,7 +549,10 @@ where
reduce_and_simplify_contexts
::
![
ExprInfoPtr
]
!{#
CommonDefs
}
!
ClassInstanceInfo
!
Bool
![
TypeContext
]
!*
Coercions
![
LocalTypePatternVariable
]
!*
OverloadingState
->
(![
TypeContext
],
!*
Coercions
,
![
LocalTypePatternVariable
],
!*
OverloadingState
)
reduce_and_simplify_contexts
[
over_info_ptr
:
ocs
]
defs
instance_info
has_context
contexts
coercion_env
type_pattern_vars
os
=:{
os_symbol_heap
,
os_type_heaps
}
#
(
EI_Overloaded
{
oc_symbol
,
oc_context
,
oc_specials
},
os_symbol_heap
)
=
readPtr
over_info_ptr
os_symbol_heap
#
(
expr_info
,
os_symbol_heap
)
=
readPtr
over_info_ptr
os_symbol_heap
{
oc_symbol
,
oc_context
,
oc_specials
}
=
case
expr_info
of
EI_Overloaded
over_info
->
over_info
_
->
abort
(
"reduce_and_simplify_contexts"
<<-
expr_info
)
(
glob_fun
,
os_type_heaps
)
=
trySpecializedInstances
oc_context
oc_specials
os_type_heaps
|
FoundObject
glob_fun
#
os_symbol_heap
=
os_symbol_heap
<:=
(
over_info_ptr
,
EI_Instance
{
glob_module
=
glob_fun
.
glob_module
,
glob_object
=
...
...
@@ -1199,7 +1209,7 @@ where
instance
<<<
(
Ptr
x
)
where
(<<<)
file
_
=
file
(<<<)
file
ptr
=
file
<<<
'<'
<<<
ptrToInt
ptr
<<<
'>'
instance
<<<
TypeCodeExpression
where
...
...
frontend/refmark.icl
View file @
4a1abad7
...
...
@@ -130,7 +130,8 @@ where
bind_variable
{
bind_src
,
bind_dst
={
fv_info_ptr
}}
var_heap
#
(
VI_Occurrence
occ
,
var_heap
)
=
readPtr
fv_info_ptr
var_heap
=
var_heap
<:=
(
fv_info_ptr
,
VI_Occurrence
{
occ
&
occ_bind
=
OB_OpenLet
bind_src
})
// = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src })
=
var_heap
<:=
(
fv_info_ptr
,
VI_Occurrence
{
occ
&
occ_ref_count
=
RC_Unused
,
occ_bind
=
OB_OpenLet
bind_src
})
refMark
free_vars
sel
(
Case
{
case_expr
,
case_guards
,
case_default
})
var_heap
=
refMarkOfCase
free_vars
sel
case_expr
case_guards
case_default
var_heap
...
...
frontend/syntax.dcl
View file @
4a1abad7
...
...
@@ -259,7 +259,7 @@ cIsNotAFunction :== False
::
Import
from_symbol
=
{
import_module
::
!
Ident
,
import_symbols
::
![
from_symbol
]
,
import_file_position
::
!(!
FileName
,
!
Int
)
// for error messages
// MW++
,
import_file_position
::
!(!
FileName
,
!
Int
)
// for error messages
}
instance
toString
(
Import
from_symbol
),
AttributeVar
,
TypeAttribute
,
Annotation
...
...
frontend/syntax.icl
View file @
4a1abad7
...
...
@@ -253,7 +253,7 @@ cIsNotAFunction :== False
::
Import
from_symbol
=
{
import_module
::
!
Ident
,
import_symbols
::
![
from_symbol
]
,
import_file_position
::
!(!
FileName
,
!
Int
)
// for error messages
// MW++
,
import_file_position
::
!(!
FileName
,
!
Int
)
// for error messages
}
::
ParsedImport
:==
Import
ImportDeclaration
...
...
@@ -1328,8 +1328,9 @@ where
instance
<<<
Expression
where
(<<<)
file
(
Var
ident
)
=
file
<<<
ident
(<<<)
file
(
App
{
app_symb
,
app_args
})
=
file
<<<
app_symb
<<<
' '
<<<
app_args
(<<<)
file
(
App
{
app_symb
,
app_args
,
app_info_ptr
})
// = file <<< app_symb <<< ' ' <<< app_args
=
file
<<<
app_symb
<<<
" <"
<<<
ptrToInt
app_info_ptr
<<<
"> "
<<<
app_args
(<<<)
file
(
f_exp
@
a_exp
)
=
file
<<<
'('
<<<
f_exp
<<<
" @ "
<<<
a_exp
<<<
')'
(<<<)
file
(
Let
{
let_info_ptr
,
let_binds
,
let_expr
})
=
write_binds
(
file
<<<
"let"
<<<
'\n'
)
let_binds
<<<
"in
\n
"
<<<
let_expr
where
...
...
frontend/transform.icl
View file @
4a1abad7
...
...
@@ -267,24 +267,28 @@ where
unfold
expr
us
=
(
expr
,
us
)
/* Sjaak ... */
instance
unfold
Selection
where
unfold
(
ArraySelection
array_select
expr_ptr
index_expr
)
us
#
(
index_expr
,
us
)
=
unfold
index_expr
us
=
(
ArraySelection
array_select
expr_ptr
index_expr
,
us
)
unfold
(
DictionarySelection
var
selectors
expr_ptr
index_expr
)
us
#
(
index_expr
,
us
)
=
unfold
index_expr
us
unfold
(
ArraySelection
array_select
expr_ptr
index_expr
)
us
=:{
us_symbol_heap
}
#
(
new_ptr
,
us_symbol_heap
)
=
newPtr
EI_Empty
us_symbol_heap
(
index_expr
,
us
)
=
unfold
index_expr
{
us
&
us_symbol_heap
=
us_symbol_heap
}
=
(
ArraySelection
array_select
new_ptr
index_expr
,
us
)
unfold
(
DictionarySelection
var
selectors
expr_ptr
index_expr
)
us
=:{
us_symbol_heap
}
#
(
new_ptr
,
us_symbol_heap
)
=
newPtr
EI_Empty
us_symbol_heap
(
index_expr
,
us
)
=
unfold
index_expr
{
us
&
us_symbol_heap
=
us_symbol_heap
}
(
var_expr
,
us
)
=
unfoldVariable
var
us
=
case
var_expr
of
App
{
app_symb
={
symb_kind
=
SK_Constructor
_
},
app_args
}
#
[
RecordSelection
_
field_index
:_]
=
selectors
(
App
{
app_symb
=
{
symb_name
,
symb_kind
=
SK_Function
array_select
}})
=
app_args
!!
field_index
->
(
ArraySelection
{
array_select
&
glob_object
=
{
ds_ident
=
symb_name
,
ds_arity
=
2
,
ds_index
=
array_select
.
glob_object
}}
expr
_ptr
index_expr
,
us
)
new
_ptr
index_expr
,
us
)
Var
var
->
(
DictionarySelection
var
selectors
expr
_ptr
index_expr
,
us
)
->
(
DictionarySelection
var
selectors
new
_ptr
index_expr
,
us
)
unfold
record_selection
ls
=
(
record_selection
,
ls
)
/* ... Sjaak */
instance
unfold
FreeVar
where
...
...
@@ -308,20 +312,6 @@ where
_
->
(
nilPtr
,
us
)
(
app_args
,
us
)
=
unfold
app_args
us
=
({
app
&
app_args
=
app_args
,
app_info_ptr
=
new_info_ptr
},
us
)
/*
unfold app=:{app_symb, app_args, app_info_ptr} us=:{us_symbol_heap}
# (new_info_ptr, us_symbol_heap)
= case is_function_or_macro app_symb.symb_kind of
True -> newPtr EI_Empty us_symbol_heap
_ -> case (app_symb.symb_kind, isNilPtr app_info_ptr) of
(SK_Constructor _, False)
# (app_info, us_symbol_heap) = readPtr app_info_ptr us_symbol_heap
-> newPtr app_info us_symbol_heap
_ -> (nilPtr, us_symbol_heap)
us = { us & us_symbol_heap = us_symbol_heap }
(app_args, us) = unfold app_args us
= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us)
*/
where
is_function_or_macro
(
SK_Function
_)
=
True
...
...
@@ -331,6 +321,7 @@ where
=
True
is_function_or_macro
_
=
False
substitute_EI_ClassTypes
(
EI_ClassTypes
class_types
)
(
Yes
type_heaps
)
#
(
new_class_types
,
type_heaps
)
=
substitute
class_types
type_heaps
=
(
EI_ClassTypes
new_class_types
,
Yes
type_heaps
)
...
...
@@ -694,7 +685,8 @@ where
=
expandMacrosInBody
fun_info
.
fi_calls
body
fun_and_macro_defs
mod_index
modules
{
es
&
es_error
=
setErrorAdmin
identPos
es
.
es_error
}
fun_def
=
{
fun_def
&
fun_body
=
TransformedBody
{
tb_args
=
tb_args
,
tb_rhs
=
tb_rhs
},
fun_info
=
{
fun_info
&
fi_calls
=
fi_calls
,
fi_local_vars
=
fi_local_vars
}}
=
({
fun_and_macro_defs
&
[
fun_index
]
=
fun_def
},
modules
,
es
)
=
({
fun_and_macro_defs
&
[
fun_index
]
=
fun_def
},
modules
,
es
)
// ---> ("expand_macros", fun_symb, tb_args, tb_rhs)
addFunctionCallsToSymbolTable
calls
fun_defs
symbol_table
=
foldSt
add_function_call_to_symbol_table
calls
([],
fun_defs
,
symbol_table
)
...
...
@@ -721,12 +713,12 @@ expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index modules es=:{es_
([
rhs
:
rhss
],
fun_defs
,
modules
,
(
all_calls
,
es
))
=
expand
cb_rhs
fun_defs
mod_index
modules
(
prev_calls
,
{
es
&
es_symbol_table
=
es_symbol_table
})
(
fun_defs
,
es_symbol_table
)
=
removeFunctionCallsFromSymbolTable
all_calls
fun_defs
es
.
es_symbol_table
(
merge_rhs
,
es_var_heap
,
es_symbol_heap
,
es_error
)
=
mergeCases
rhs
rhss
es
.
es_var_heap
es
.
es_symbol_heap
es
.
es_error
(
merge_rhs
,
cb
_args
,
local_vars
,
{
cos_error
,
cos_var_heap
,
cos_symbol_heap
})
=
determineVariablesAndRefCounts
cb_args
merge_rhs
// (merge_rhs ---> (cb_args, merge_rhs))
(
merge_rhs
,
new
_args
,
local_vars
,
{
cos_error
,
cos_var_heap
,
cos_symbol_heap
})
=
determineVariablesAndRefCounts
cb_args
merge_rhs
{
cos_error
=
es_error
,
cos_var_heap
=
es_var_heap
,
cos_symbol_heap
=
es_symbol_heap
}