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
cdc21bb4
Commit
cdc21bb4
authored
Feb 07, 2000
by
Sjaak Smetsers
Browse files
commit for Sjaak by RWS
parent
eafb678b
Changes
11
Hide whitespace changes
Inline
Side-by-side
frontend/Heap.icl
View file @
cdc21bb4
implementation
module
Heap
;
import
StdOverloaded
;
import
StdOverloaded
,
StdMisc
;
::
Heap
v
=
{
heap
::!.(
HeapN
v
)};
::
HeapN
v
=
Heap
!
Int
;
...
...
@@ -78,7 +78,13 @@ sreadPtr p h = code {
}
;
writePtr
::
!(
Ptr
v
)
!
v
!*(
Heap
v
)
->
.
Heap
v
;
writePtr
p
v
h
=
code {
writePtr
p
v
h
|
isNilPtr
p
=
abort
"writePtr: Nil pointer encountered
\n
"
;
=
writePtr2
p
v
h
;
writePtr2
::
!(
Ptr
v
)
!
v
!*(
Heap
v
)
->
.
Heap
v
;
writePtr2
p
v
h
=
code {
push_a_b
2
push_r_args_b
0
1
1
1
1
eqI
...
...
@@ -101,7 +107,13 @@ writePtr p v h = code {
}
ptrToInt
::
!(
Ptr
v
)
->
Int
;
ptrToInt
p
=
code {
ptrToInt
p
|
isNilPtr
p
=
0
;
=
ptrToInt2
p
;
ptrToInt2
::
!(
Ptr
v
)
->
Int
;
ptrToInt2
p
=
code {
push_a_b
0
pop_a
1
build
_Nil
0
_hnf
...
...
frontend/analunitypes.icl
View file @
cdc21bb4
...
...
@@ -246,7 +246,7 @@ determinePropClassOfTypeDef type_index module_index td_args {tdi_classification,
(
ts_type_prop
,
type_var_heap
,
td_infos
)
=
newPropClassOfTypeDefGroup
type_index
module_index
tdi_group
hio_props
tdi_group_nr
ci
type_var_heap
td_infos
->
(
ts_type_prop
,
foldSt
restore_binds_of_type_var
td_args
type_var_heap
,
td_infos
)
// ---> ("determinePropClassOfTypeDef", ci.[module_index].com_type_defs.[type_index].td_name, ts_type_prop)
// ---> ("determinePropClassOfTypeDef", ci.[module_index].com_type_defs.[type_index].td_name, ts_type_prop
, hio_props
)
where
bind_type_vars_to_props
[{
atv_variable
={
tv_info_ptr
}}
:
tvs
]
[
gv
:
gvs
]
cons_vars
hio_props
type_var_heap
#!
old_info
=
sreadPtr
tv_info_ptr
type_var_heap
...
...
frontend/checktypes.icl
View file @
cdc21bb4
...
...
@@ -1012,11 +1012,16 @@ where
=
(
TA_Unique
,
error
)
check_attribute
TA_Anonymous
root_attr
name
error
=
case
root_attr
of
TA_Var
var
->
(
TA_RootVar
var
,
error
)
_
->
(
TA_RootVar
undef
,
error
)
/* = case root_attr of
TA_Var var
-> (TA_RootVar var, error)
_
-> (root_attr, error)
check_attribute
attr
root_attr
name
error
*/
check_attribute
attr
root_attr
name
error
=
(
TA_Multi
,
checkError
name
"specified attribute not allowed"
error
)
retrieveKinds
::
![
ATypeVar
]
*
TypeVarHeap
->
(![
TypeKind
],
!*
TypeVarHeap
)
...
...
frontend/frontend.icl
View file @
cdc21bb4
...
...
@@ -16,7 +16,7 @@ import RWSDebug
// trace macro
(-*->)
infixl
(-*->)
value
trace
:==
value
//
---> trace
:==
value
--->
trace
frontEndInterface
::
!
Ident
!
SearchPaths
!*
PredefinedSymbols
!*
HashTable
!*
Files
!*
File
!*
File
!*
File
->
(!*
PredefinedSymbols
,
!*
HashTable
,
!*
Files
,
!*
File
,
!*
File
,
!*
File
,
!
Optional
*
FrontEndSyntaxTree
)
frontEndInterface
mod_ident
search_paths
predef_symbols
hash_table
files
error
io
out
...
...
@@ -41,8 +41,8 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i
|
not
ok
=
(
predef_symbols
,
hash_table
,
files
,
error
,
io
,
out
,
No
)
#
(
components
,
fun_defs
)
=
partitionateFunctions
(
fun_defs
-*->
"partitionateFunctions"
)
[
{
ir_from
=
0
,
ir_to
=
nr_of_global_funs
},
icl_instances
,
icl_specials
]
//
(components, fun_defs, io)
= showTypes components 0 fun_defs io
#
(
components
,
fun_defs
)
=
partitionateFunctions
(
fun_defs
-*->
"partitionateFunctions"
)
[
{
ir_from
=
0
,
ir_to
=
nr_of_global_funs
},
icl_instances
,
icl_specials
]
(
components
,
fun_defs
,
io
)
=
showTypes
components
0
fun_defs
io
// (components, fun_defs, out) = showComponents components 0 True fun_defs out
...
...
frontend/main.icl
View file @
cdc21bb4
...
...
@@ -154,67 +154,6 @@ loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_o
->
(
Yes
(
buildInterMod
mod_ident
fe_dcls
icl_functions
fe_dclIclConversions
fe_iclDclConversions
),
predef_symbols
,
hash_table
,
ms
)
No
->
(
No
,
predef_symbols
,
hash_table
,
ms
)
/* RWS
# (ok, mod, hash_table, ms_error, predef_symbols, ms_files)
= wantModule cWantIclFile mod_ident (hash_table ---> ("Parsing:", mod_ident)) ms_error ms_paths predef_symbols ms_files
| not ok
= (No, predef_symbols, hash_table, { ms & ms_files = ms_files, ms_io = ms_io, ms_error = ms_error })
# (ok, mod, nr_of_global_funs, mod_functions, dcl_mod, predef_mod, modules, hash_table, ms_error, predef_symbols, ms_files)
= scanModule (mod ---> "Scanning") hash_table ms_error ms_paths predef_symbols ms_files
| not ok
= (No, predef_symbols, hash_table, { ms & ms_files = ms_files, ms_io = ms_io, ms_error = ms_error })
# symbol_table = hash_table.hte_symbol_heap
(ok, icl_mod, dcl_mods, components, dcl_icl_conversions, heaps, predef_symbols, symbol_table, ms_error)
= checkModule mod nr_of_global_funs mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table ---> "Checking") ms_error
| not ok
= (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io })
# {icl_functions,icl_instances,icl_specials,icl_common,icl_declared={dcls_import}} = icl_mod
(components, icl_functions, ms_error) = showComponents components 0 True icl_functions ms_error
(ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, ms_error)
= typeProgram (components ---> "Typing") icl_functions icl_specials icl_common dcls_import dcl_mods heaps predef_symbols ms_error
| not ok
= (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out })
# (components, fun_defs) = partitionateFunctions (fun_defs ---> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials]
(components, fun_defs, ms_io) = showTypes components 0 fun_defs ms_io
(components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
(components, fun_defs, predef_symbols, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap)
= convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols
heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap
(components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
(cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
= analyseGroups common_defs (components ---> "Transform") fun_defs var_heap expression_heap
(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics var_heap type_heaps expression_heap
/*
(cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
= analyseGroups common_defs (components ---> "Transform") fun_defs heaps.hp_var_heap heaps.hp_expression_heap
(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs var_heap heaps.hp_type_heaps expression_heap
(components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
*/
(dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps
(dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps
/*
(components, fun_defs, predef_symbols, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols
dcl_types used_conses var_heap type_heaps expression_heap
(components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
*/
(used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses
var_heap type_heaps expression_heap
(dcl_types, var_heap, type_heaps)
= convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap
(components, fun_defs, ms_out) = showComponents components 0 False fun_defs ms_out
= (Yes (buildInterMod mod_ident dcl_mods fun_defs dcl_icl_conversions), predef_symbols,
{ hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out })
*/
makeProject
(
Yes
proj
=:{
proj_main_module
,
proj_hash_table
,
proj_predef_symbols
})
ms
#
(
main_mod
,
proj_predef_symbols
,
proj_hash_table
,
ms
)
=
loadModule
proj_main_module
proj_predef_symbols
proj_hash_table
ms
...
...
frontend/syntax.dcl
View file @
cdc21bb4
...
...
@@ -833,8 +833,8 @@ cNonRecursiveAppl :== False
,
atv_variable
::
!
TypeVar
}
::
TypeAttribute
=
TA_Unique
|
TA_Multi
|
TA_Var
!
AttributeVar
|
TA_RootVar
!
AttributeVar
|
TA_TempVar
!
Int
/*
| TA_TempExVar
!Int */
|
TA_Anonymous
|
TA_None
|
TA_List
!
Int
!
TypeAttribute
|
TA_Omega
::
TypeAttribute
=
TA_Unique
|
TA_Multi
|
TA_Var
!
AttributeVar
|
TA_RootVar
AttributeVar
|
TA_TempVar
!
Int
|
TA_TempExVar
|
TA_Anonymous
|
TA_None
|
TA_List
!
Int
!
TypeAttribute
::
AttributeVar
=
{
av_name
::
!
Ident
...
...
frontend/syntax.icl
View file @
cdc21bb4
...
...
@@ -772,8 +772,8 @@ cNotVarNumber :== -1
,
atv_variable
::
!
TypeVar
}
::
TypeAttribute
=
TA_Unique
|
TA_Multi
|
TA_Var
!
AttributeVar
|
TA_RootVar
!
AttributeVar
|
TA_TempVar
!
Int
|
TA_Anonymous
|
TA_None
|
TA_List
!
Int
!
TypeAttribute
|
TA_Omega
::
TypeAttribute
=
TA_Unique
|
TA_Multi
|
TA_Var
!
AttributeVar
|
TA_RootVar
AttributeVar
|
TA_TempVar
!
Int
|
TA_TempExVar
|
TA_Anonymous
|
TA_None
|
TA_List
!
Int
!
TypeAttribute
::
AttributeVar
=
{
av_name
::
!
Ident
...
...
@@ -1152,11 +1152,8 @@ where
=
"u"
+
toString
tav_number
+
": "
toString
(
TA_Var
avar
)
=
toString
avar
+
": "
/* toString (TA_TempExVar tav_number)
= "e" + toString tav_number + ": "
toString (TA_ExVar avar)
= toString avar + "': "
*/
toString
TA_TempExVar
=
"E"
toString
(
TA_RootVar
avar
)
=
toString
avar
+
": "
toString
(
TA_Anonymous
)
...
...
@@ -1165,8 +1162,6 @@ where
=
""
toString
TA_Multi
=
"o "
toString
TA_Omega
=
"w "
toString
(
TA_List
_
_)
=
"??? "
...
...
frontend/type.icl
View file @
cdc21bb4
...
...
@@ -32,7 +32,7 @@ import RWSDebug
}
::
SharedAttribute
=
{
sa_attr_nr
::
!
Int
{
sa_attr_nr
::
!
Int
,
sa_position
::
!
Expression
}
...
...
@@ -316,7 +316,7 @@ unifyTypeApplications cons_var type_args type modules subst heaps
::
CopyState
=
{
copy_heaps
::
!.
TypeHeaps
{
copy_heaps
::
!.
TypeHeaps
}
instance
fromInt
TypeAttribute
...
...
@@ -352,10 +352,16 @@ freshCopyOfAttributeVar {av_name,av_info_ptr} attr_var_heap
_
->
abort
(
"freshCopyOfAttributeVar (type,icl)"
--->
av_name
)
freshCopyOfTypeAttribute
(
TA_Var
avar
)
attr_var_heap
=
freshCopyOfAttributeVar
avar
attr_var_heap
/* A temporary hack to handle the new Object IO lib */
/* Should be removed !!!!!!!!!! */
freshCopyOfTypeAttribute
(
TA_RootVar
avar
)
attr_var_heap
=
freshCopyOfAttributeVar
avar
attr_var_heap
// = freshCopyOfAttributeVar avar attr_var_heap
=
(
TA_TempExVar
,
attr_var_heap
)
freshCopyOfTypeAttribute
TA_None
attr_var_heap
=
(
TA_Multi
,
attr_var_heap
)
freshCopyOfTypeAttribute
TA_Unique
attr_var_heap
...
...
@@ -363,6 +369,7 @@ freshCopyOfTypeAttribute TA_Unique attr_var_heap
freshCopyOfTypeAttribute
attr
attr_var_heap
=
(
attr
,
attr_var_heap
)
cIsExistential
:==
True
cIsNotExistential
:==
False
...
...
@@ -418,30 +425,27 @@ freshAlgebraicType {glob_module, glob_object} patterns common_defs ts=:{ts_var_s
#
{
td_rhs
,
td_args
,
td_attrs
,
td_name
,
td_attribute
}
=
common_defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
#
(
th_vars
,
ts_var_store
)
=
fresh_type_variables
td_args
(
ts_type_heaps
.
th_vars
,
ts_var_store
)
(
th_attrs
,
ts_attr_store
)
=
fresh_attributes
td_attrs
(
ts_type_heaps
.
th_attrs
,
ts_attr_store
)
cs
=
{
copy_heaps
=
{
ts_type_heaps
&
th_vars
=
th_vars
,
th_attrs
=
th_attrs
}
}
(
cons_types
,
alg_type
,
ts_var_store
,
ts_attr_store
,
attr_env
,
cs
)
=
fresh_symbol_types
patterns
common_defs
.[
glob_module
].
com_cons_defs
ts_var_store
ts_attr_store
c
s
=
(
cons_types
,
alg_type
,
attr_env
,
{
ts
&
ts_var_store
=
ts_var_store
,
ts_attr_store
=
ts_attr_store
,
ts_type_heaps
=
cs
.
copy_heaps
})
copy_heaps
=
{
ts_type_heaps
&
th_vars
=
th_vars
,
th_attrs
=
th_attrs
}
(
cons_types
,
alg_type
,
ts_var_store
,
attr_env
,
c
opy_heap
s
)
=
fresh_symbol_types
patterns
common_defs
.[
glob_module
].
com_cons_defs
ts_var_store
copy_heap
s
=
(
cons_types
,
alg_type
,
attr_env
,
{
ts
&
ts_var_store
=
ts_var_store
,
ts_attr_store
=
ts_attr_store
,
ts_type_heaps
=
copy_heaps
})
// ---> ("freshAlgebraicType", alg_type, cons_types)
where
fresh_symbol_types
[{
ap_symbol
={
glob_object
}}]
cons_defs
var_store
attr_store
cs
=:{
copy_heaps
}
fresh_symbol_types
[{
ap_symbol
={
glob_object
}}]
cons_defs
var_store
copy_heaps
#
{
cons_type
=
{
st_args
,
st_attr_env
,
st_result
},
cons_index
,
cons_exi_vars
,
cons_exi_attrs
}
=
cons_defs
.[
glob_object
.
ds_index
]
(
th_vars
,
var_store
)
=
freshExistentialVariables
cons_exi_vars
(
copy_heaps
.
th_vars
,
var_store
)
// (th_attrs, attr_store) = fresh_existential_attributes cons_exi_attrs (copy_heaps.th_attrs, attr_store)
(
attr_env
,
th_attrs
)
=
fresh_environment
st_attr_env
([],
copy_heaps
.
th_attrs
)
(
result_type
,
cs
)
=
freshCopy
st_result
{
cs
&
copy_heaps
=
{
copy_heaps
&
th_attrs
=
th_attrs
,
th_vars
=
th_vars
}
}
(
result_type
,
cs
)
=
freshCopy
st_result
{
copy_heaps
=
{
copy_heaps
&
th_attrs
=
th_attrs
,
th_vars
=
th_vars
}
}
(
fresh_args
,
cs
)
=
freshCopy
st_args
cs
=
([
fresh_args
],
result_type
,
var_store
,
attr_store
,
attr_env
,
cs
)
fresh_symbol_types
[{
ap_symbol
={
glob_object
}}
:
patterns
]
cons_defs
var_store
attr_store
cs
#
(
cons_types
,
result_type
,
var_store
,
attr_store
,
attr_env
,
cs
=:{
copy_heaps
})
=
fresh_symbol_types
patterns
cons_defs
var_store
attr_store
cs
// {cons_type = {st_args,st_attr_env}, cons_index, cons_exi_vars, cons_exi_attrs} = cons_defs.[glob_object.ds_index]
=
([
fresh_args
],
result_type
,
var_store
,
attr_env
,
cs
.
copy_heaps
)
fresh_symbol_types
[{
ap_symbol
={
glob_object
}}
:
patterns
]
cons_defs
var_store
copy_heaps
#
(
cons_types
,
result_type
,
var_store
,
attr_env
,
copy_heaps
)
=
fresh_symbol_types
patterns
cons_defs
var_store
copy_heaps
{
cons_type
=
{
st_args
,
st_attr_env
},
cons_index
,
cons_exi_vars
}
=
cons_defs
.[
glob_object
.
ds_index
]
(
th_vars
,
var_store
)
=
freshExistentialVariables
cons_exi_vars
(
copy_heaps
.
th_vars
,
var_store
)
// (th_attrs, attr_store) = fresh_existential_attributes cons_exi_attrs (copy_heaps.th_attrs, attr_store)
(
attr_env
,
th_attrs
)
=
fresh_environment
st_attr_env
(
attr_env
,
copy_heaps
.
th_attrs
)
(
fresh_args
,
cs
)
=
freshCopy
st_args
{
cs
&
copy_heaps
=
{
copy_heaps
&
th_attrs
=
th_attrs
,
th_vars
=
th_vars
}}
=
([
fresh_args
:
cons_types
],
result_type
,
var_store
,
attr_
store
,
attr_env
,
c
s
)
(
fresh_args
,
cs
)
=
freshCopy
st_args
{
copy_heaps
=
{
copy_heaps
&
th_attrs
=
th_attrs
,
th_vars
=
th_vars
}}
=
([
fresh_args
:
cons_types
],
result_type
,
var_store
,
attr_
env
,
cs
.
copy_heap
s
)
fresh_type_variables
type_variables
state
...
...
@@ -450,11 +454,6 @@ where
fresh_attributes
attributes
state
=
foldSt
(\{
av_info_ptr
}
(
attr_heap
,
attr_store
)
->
(
attr_heap
<:=
(
av_info_ptr
,
AVI_Attr
(
TA_TempVar
attr_store
)),
inc
attr_store
))
attributes
state
/*
fresh_existential_attributes attributes state
= foldSt (\{av_info_ptr} (attr_heap, attr_store) -> (attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempExVar attr_store)), inc attr_store))
attributes state
*/
fresh_environment
inequalities
(
attr_env
,
attr_heap
)
=
foldSt
fresh_inequality
inequalities
(
attr_env
,
attr_heap
)
...
...
@@ -480,8 +479,8 @@ where
freshSymbolType
st
=:{
st_vars
,
st_args
,
st_result
,
st_context
,
st_attr_vars
,
st_attr_env
,
st_arity
}
common_defs
ts
=:{
ts_var_store
,
ts_attr_store
,
ts_type_heaps
,
ts_td_infos
}
#
(
th_vars
,
var_store
)
=
fresh_type_variables
st_vars
(
ts_type_heaps
.
th_vars
,
ts_var_store
)
(
th_attrs
,
attr_store
)
=
fresh_attributes
st_attr_vars
(
ts_type_heaps
.
th_attrs
,
ts_attr_store
)
#
(
th_vars
,
ts_
var_store
)
=
fresh_type_variables
st_vars
(
ts_type_heaps
.
th_vars
,
ts_var_store
)
(
th_attrs
,
ts_
attr_store
)
=
fresh_attributes
st_attr_vars
(
ts_type_heaps
.
th_attrs
,
ts_attr_store
)
(
attr_env
,
th_attrs
)
=
freshEnvironment
st_attr_env
th_attrs
cs
=
{
copy_heaps
=
{
ts_type_heaps
&
th_vars
=
th_vars
,
th_attrs
=
th_attrs
}}
(
tst_args
,
cs
)
=
freshCopy
st_args
cs
...
...
@@ -489,7 +488,7 @@ freshSymbolType st=:{st_vars,st_args,st_result,st_context,st_attr_vars,st_attr_e
(
tst_context
,
{
copy_heaps
})
=
freshTypeContexts
st_context
cs
cons_variables
=
foldSt
(
collect_cons_variables_in_tc
common_defs
)
tst_context
[]
=
({
tst_args
=
tst_args
,
tst_result
=
tst_result
,
tst_context
=
tst_context
,
tst_attr_env
=
attr_env
,
tst_arity
=
st_arity
,
tst_lifted
=
0
},
cons_variables
,
{
ts
&
ts_var_store
=
var_store
,
ts_attr_store
=
attr_store
,
ts_type_heaps
=
copy_heaps
})
{
ts
&
ts_var_store
=
ts_
var_store
,
ts_attr_store
=
ts_
attr_store
,
ts_type_heaps
=
copy_heaps
})
// ---> ("freshSymbolType", tst_args, tst_result)
where
fresh_type_variables
type_variables
state
...
...
@@ -1507,7 +1506,8 @@ where
=
(
True
,
fun_defs
,
predef_symbols
,
special_instances
,
create_erroneous_function_types
comp
{
ts
&
ts_type_heaps
=
ts_type_heaps
,
ts_error
=
{
ts_error
&
ea_ok
=
True
},
ts_var_store
=
0
,
ts_attr_store
=
FirstAttrVar
})
#
{
ts_attr_store
,
ts_var_heap
,
ts_var_store
,
ts_expr_heap
,
ts_td_infos
}
=
ts
(
subst
,
nr_of_attr_vars
,
th_vars
,
ts_td_infos
)
=
liftSubstitution
subst
ti_common_defs
ts_attr_store
ts_type_heaps
.
th_vars
ts_td_infos
(
cons_var_vects
,
subst
)
=
determine_cons_variables
cons_variables
(
createArray
(
inc
(
BITINDEX
nr_of_type_variables
))
0
,
subst
)
(
subst
,
nr_of_attr_vars
,
th_vars
,
ts_td_infos
)
=
liftSubstitution
subst
ti_common_defs
cons_var_vects
ts_attr_store
ts_type_heaps
.
th_vars
ts_td_infos
coer_demanded
={{
CT_Empty
\\
i
<-
[
0
..
nr_of_attr_vars
-
1
]
}
&
[
AttrUni
]
=
CT_Unique
}
coer_offered
=
{{
CT_Empty
\\
i
<-
[
0
..
nr_of_attr_vars
-
1
]
}
&
[
AttrMulti
]
=
CT_NonUnique
}
coercion_env
=
build_initial_coercion_env
fun_reqs
{
coer_demanded
=
coer_demanded
,
coer_offered
=
coer_offered
}
...
...
@@ -1524,7 +1524,6 @@ where
ts_td_infos
=
ts_td_infos
,
ts_expr_heap
=
os_symbol_heap
,
ts_var_heap
=
os_var_heap
})
#
(
fun_defs
,
coercion_env
,
subst
,
os_var_heap
,
os_symbol_heap
,
os_error
)
=
makeSharedReferencesNonUnique
comp
fun_defs
coercion_env
subst
ti_common_defs
os_var_heap
os_symbol_heap
os_error
(
cons_var_vects
,
subst
)
=
determine_cons_variables
cons_variables
(
createArray
(
inc
(
BITINDEX
nr_of_type_variables
))
0
,
subst
)
(
subst
,
{
coer_offered
,
coer_demanded
},
ts_td_infos
,
ts_type_heaps
,
ts_error
)
=
build_coercion_env
fun_reqs
subst
coercion_env
ti_common_defs
cons_var_vects
ts_td_infos
os_type_heaps
os_error
(
attr_partition
,
coer_demanded
)
=
partitionateAttributes
coer_offered
coer_demanded
...
...
frontend/typesupport.icl
View file @
cdc21bb4
...
...
@@ -66,6 +66,8 @@ varIsDefined _ = True
instance
clean_up
TypeAttribute
where
clean_up
cui
TA_TempExVar
cus
=
(
TA_Multi
,
cus
)
clean_up
cui
TA_Unique
cus
=
(
TA_Unique
,
cus
)
clean_up
cui
TA_Multi
cus
...
...
frontend/unitype.dcl
View file @
cdc21bb4
...
...
@@ -9,7 +9,8 @@ import syntax, analunitypes
AttrUni
:==
0
AttrMulti
:==
1
FirstAttrVar
:==
2
AttrExi
:==
2
FirstAttrVar
:==
3
instance
toInt
TypeAttribute
...
...
@@ -44,7 +45,7 @@ tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions)
uniquenessError
::
!
CoercionPosition
!
String
!*
ErrorAdmin
->
*
ErrorAdmin
liftSubstitution
::
!*{!
Type
}
!{#
CommonDefs
}
!
Int
!*
TypeVarHeap
!*
TypeDefInfos
->
(*{!
Type
},
!
Int
,
!*
TypeVarHeap
,
!*
TypeDefInfos
)
liftSubstitution
::
!*{!
Type
}
!{#
CommonDefs
}!{#
BOOLVECT
}
!
Int
!*
TypeVarHeap
!*
TypeDefInfos
->
(*{!
Type
},
!
Int
,
!*
TypeVarHeap
,
!*
TypeDefInfos
)
instance
<<<
CoercionPosition
frontend/unitype.icl
View file @
cdc21bb4
...
...
@@ -12,7 +12,11 @@ import cheat
AttrUni
:==
0
AttrMulti
:==
1
/*
FirstAttrVar :== 2
*/
AttrExi
:==
2
FirstAttrVar
:==
3
::
CoercionTree
=
CT_Node
!
Int
!
CoercionTree
!
CoercionTree
|
CT_Empty
|
CT_Unique
|
CT_NonUnique
...
...
@@ -65,8 +69,6 @@ determineAttributeCoercions off_type dem_type coercible position subst coercions
->
(
subst
,
crc_coercions
,
crc_td_infos
,
crc_type_heaps
,
error
)
/*
No
# (crc_coercions, copy_crc_coercions) = uniqueCopy crc_coercions
format = { form_properties = cMarkAttribute, form_attr_position = Yes ([], copy_crc_coercions) }
| file_to_true (stderr <:: (format, exp_off_type) <:: (format, exp_dem_type) <<< '\n')
...
...
@@ -189,16 +191,16 @@ where
::
CoercionTreeRecord
=
{
tree
::
!.
CoercionTree
}
liftSubstitution
::
!*{!
Type
}
!{#
CommonDefs
}
!
Int
!*
TypeVarHeap
!*
TypeDefInfos
->
(*{!
Type
},
!
Int
,
!*
TypeVarHeap
,
!*
TypeDefInfos
)
liftSubstitution
subst
modules
attr_store
type_var_heap
td_infos
liftSubstitution
::
!*{!
Type
}
!{#
CommonDefs
}
!{#
BOOLVECT
}
!
Int
!*
TypeVarHeap
!*
TypeDefInfos
->
(*{!
Type
},
!
Int
,
!*
TypeVarHeap
,
!*
TypeDefInfos
)
liftSubstitution
subst
modules
cons_vars
attr_store
type_var_heap
td_infos
#
ls
=
{
ls_next_attr
=
attr_store
,
ls_td_infos
=
td_infos
,
ls_type_var_heap
=
type_var_heap
}
=
lift_substitution
0
modules
subst
ls
=
lift_substitution
0
modules
cons_vars
subst
ls
where
lift_substitution
var_index
modules
subst
ls
lift_substitution
var_index
modules
cons_vars
subst
ls
|
var_index
<
size
subst
#!
type
=
subst
.[
var_index
]
#
(
type
,
_,
_,
subst
,
ls
)
=
lift
modules
type
subst
ls
=
lift_substitution
(
inc
var_index
)
modules
{
subst
&
[
var_index
]
=
type
}
ls
#
(
type
,
subst
,
ls
)
=
lift
modules
cons_vars
type
subst
ls
=
lift_substitution
(
inc
var_index
)
modules
cons_vars
{
subst
&
[
var_index
]
=
type
}
ls
=
(
subst
,
ls
.
ls_next_attr
,
ls
.
ls_type_var_heap
,
ls
.
ls_td_infos
)
adjustSignClass
::
!
SignClassification
!
Int
->
SignClassification
...
...
@@ -215,55 +217,78 @@ adjustPropClass prop_class arity :== prop_class >> arity
}
liftTempTypeVariable
::
!{#
CommonDefs
}
!
TempVarId
!*{!
Type
}
!*
LiftState
->
(!
Type
,
!
SignClassification
,
!
PropClassification
,
!*{!
Type
},
!*
LiftState
)
liftTempTypeVariable
modules
tv_number
subst
ls
liftTempTypeVariable
::
!{#
CommonDefs
}
!{#
BOOLVECT
}
!
TempVarId
!*{!
Type
}
!*
LiftState
->
(!
Type
,
!*{!
Type
},
!*
LiftState
)
liftTempTypeVariable
modules
cons_vars
tv_number
subst
ls
#!
type
=
subst
.[
tv_number
]
=
case
type
of
TE
->
(
TempV
tv_number
,
TopSignClass
,
PropClass
,
subst
,
ls
)
_
->
lift
modules
type
subst
ls
TE
->
(
TempV
tv_number
,
subst
,
ls
)
_
->
lift
modules
cons_vars
type
subst
ls
class
lift
a
::
!{#
CommonDefs
}
!
a
!*{!
Type
}
!*
LiftState
->
(!
a
,
!
SignClassification
,
!
PropClassification
,
!*{!
Type
},
!*
LiftState
)
class
lift
a
::
!{#
CommonDefs
}
!{#
BOOLVECT
}
!
a
!*{!
Type
}
!*
LiftState
->
(!
a
,
!*{!
Type
},
!*
LiftState
)
instance
lift
Type
where
lift
modules
(
TempV
tv_number
)
subst
ls
=
liftTempTypeVariable
modules
tv_number
subst
ls
lift
modules
(
arg_type
-->
res_type
)
subst
ls
#
(
arg_type
,
_,
_,
subst
,
ls
)
=
lift
modules
arg_type
subst
ls
(
res_type
,
_,
_,
subst
,
ls
)
=
lift
modules
res_type
subst
ls
=
(
arg_type
-->
res_type
,
BottomSignClass
,
NoPropClass
,
subst
,
ls
)
lift
modules
(
TA
cons_id
=:{
type_index
={
glob_object
,
glob_module
},
type_arity
}
cons_args
)
subst
ls
#
(
cons_args
,
sign_classes
,
prop_classes
,
subst
,
ls
)
=
lift_list
modules
cons_args
subst
ls
lift
modules
cons_vars
(
TempV
tv_number
)
subst
ls
=
liftTempTypeVariable
modules
cons_vars
tv_number
subst
ls
lift
modules
cons_vars
(
arg_type
-->
res_type
)
subst
ls
#
(
arg_type
,
subst
,
ls
)
=
lift
modules
cons_vars
arg_type
subst
ls
(
res_type
,
subst
,
ls
)
=
lift
modules
cons_vars
res_type
subst
ls
=
(
arg_type
-->
res_type
,
subst
,
ls
)
lift
modules
cons_vars
(
TA
cons_id
=:{
type_
name
,
type_
index
={
glob_object
,
glob_module
},
type_arity
}
cons_args
)
subst
ls
#
(
cons_args
,
sign_classes
,
prop_classes
,
subst
,
ls
)
=
lift_list
modules
cons_vars
cons_args
subst
ls
(
type_prop
,
ls_type_var_heap
,
ls_td_infos
)
=
typeProperties
glob_object
glob_module
sign_classes
prop_classes
modules
ls
.
ls_type_var_heap
ls
.
ls_td_infos
=
(
TA
{
cons_id
&
type_prop
=
type_prop
}
cons_args
,
adjustSignClass
type_prop
.
tsp_sign
type_arity
,
adjustPropClass
type_prop
.
tsp_propagation
type_arity
,
subst
,
{
ls
&
ls_td_infos
=
ls_td_infos
,
ls_type_var_heap
=
ls_type_var_heap
})
lift
modules
(
TempCV
temp_var
:@:
types
)
subst
ls
#
(
type
,
sign_class
,
prop_class
,
subst
,
ls
)
=
liftTempTypeVariable
modules
temp_var
subst
ls
(
types
,
_,
_,
subst
,
ls
)
=
lift_list
modules
types
subst
ls
=
(
TA
{
cons_id
&
type_prop
=
type_prop
}
cons_args
,
subst
,
{
ls
&
ls_td_infos
=
ls_td_infos
,
ls_type_var_heap
=
ls_type_var_heap
})
where
lift_list
::
!{#
CommonDefs
}
!{#
BOOLVECT
}
![
AType
]
!*{!
Type
}
!*
LiftState
->
(![
AType
],
![
SignClassification
],
![
PropClassification
],
!*{!
Type
},
!*
LiftState
)
lift_list
modules
cons_vars
[]
subst
ls
=
([],
[],
[],
subst
,
ls
)
lift_list
modules
cons_vars
[
t
:
ts
]
subst
ls
#
(
t
,
subst
,
ls
)
=
lift
modules
cons_vars
t
subst
ls
(
ts
,
sign_classes
,
prop_classes
,
subst
,
ls
)
=
lift_list
modules
cons_vars
ts
subst
ls
=
case
t
.
at_type
of
TA
{
type_arity
,
type_prop
}
_
->
([
t
:
ts
],
[
adjustSignClass
type_prop
.
tsp_sign
type_arity
:
sign_classes
],
[
adjustPropClass
type_prop
.
tsp_propagation
type_arity
:
prop_classes
],
subst
,
ls
)
TempV
tmp_var_id
|
isPositive
tmp_var_id
cons_vars
->
([
t
:
ts
],
[
PosSignClass
:
sign_classes
],
[
PropClass
:
prop_classes
],
subst
,
ls
)
->
([
t
:
ts
],
[
TopSignClass
:
sign_classes
],
[
NoPropClass
:
prop_classes
],
subst
,
ls
)
_
->
([
t
:
ts
],
[
TopSignClass
:
sign_classes
],
[
PropClass
:
prop_classes
],
subst
,
ls
)
lift
modules
cons_vars
(
TempCV
temp_var
:@:
types
)
subst
ls
#
(
type
,
subst
,
ls
)
=
liftTempTypeVariable
modules
cons_vars
temp_var
subst
ls
(
types
,
subst
,
ls
)
=
lift_list
modules
cons_vars
types
subst
ls
=
case
type
of
TA
type_cons
cons_args
#
nr_of_new_args
=
length
types
->
(
TA
{
type_cons
&
type_arity
=
type_cons
.
type_arity
+
nr_of_new_args
}
(
cons_args
++
types
),
adjustSignClass
sign_class
nr_of_new_args
,
adjustPropClass
prop_class
nr_of_new_args
,
subst
,
ls
)
->
(
TA
{
type_cons
&
type_arity
=
type_cons
.
type_arity
+
nr_of_new_args
}
(
cons_args
++
types
),
subst
,
ls
)
TempV
tv_number
->
(
TempCV
tv_number
:@:
types
,
TopSignClass
,
PropClass
,
subst
,
ls
)
->
(
TempCV
tv_number
:@:
types
,
subst
,
ls
)
cons_var
:@:
cv_types
->
(
cons_var
:@:
(
cv_types
++
types
),
TopSignClass
,
PropClass
,
subst
,
ls
)
lift
modules
type
subst
ls
=
(
type
,
BottomSignClass
,
NoPropClass
,
subst
,
ls
)
->
(
cons_var
:@:
(
cv_types
++
types
),
subst
,
ls
)
where
lift_list
::
!{#
CommonDefs
}
!{#
BOOLVECT
}
![
a
]
!*{!
Type
}
!*
LiftState
->
(![
a
],
!*{!
Type
},
!*
LiftState
)
|
lift
a
lift_list
modules
cons_vars
[]
subst
ls
=
([],
subst
,
ls
)
lift_list
modules
cons_vars
[
t
:
ts
]
subst
ls
#
(
t
,
subst
,
ls
)
=
lift
modules
cons_vars
t
subst
ls
(
ts
,
subst
,
ls
)
=
lift_list
modules
cons_vars
ts
subst
ls
=
([
t
:
ts
],
subst
,
ls
)
lift
modules
cons_vars
type
subst
ls
=
(
type
,
subst
,
ls
)
instance
lift
AType
where
lift
modules
attr_type
=:{
at_attribute
,
at_type
}
subst
ls
#
(
at_type
,
sign_class
,
prop_class
,
subst
,
ls
)
=
lift
modules
at_type
subst
ls
lift
modules
cons_vars
attr_type
=:{
at_attribute
,
at_type
}
subst
ls
#
(
at_type
,
subst
,
ls
)
=
lift
modules
cons_vars
at_type
subst
ls
|
type_is_non_coercible
at_type
=
({
attr_type
&
at_type
=
at_type
},
sign_class
,
prop_class
,
subst
,
ls
)
=
({
attr_type
&
at_attribute
=
TA_TempVar
ls
.
ls_next_attr
,
at_type
=
at_type
},
sign_class
,
prop_class
,
subst
,
{
ls
&
ls_next_attr
=
inc
ls
.
ls_next_attr
})
=
({
attr_type
&
at_type
=
at_type
},
subst
,
ls
)
=
({
attr_type
&
at_attribute
=
TA_TempVar
ls
.
ls_next_attr
,
at_type
=
at_type
},
subst
,
{
ls
&
ls_next_attr
=
inc
ls
.
ls_next_attr
})
where
type_is_non_coercible
(
TempV
_)
=
True
...
...
@@ -277,15 +302,6 @@ where
=
False
lift_list
::
!{#
CommonDefs
}
![
a
]
!*{!
Type
}
!*
LiftState
->
(![
a
],
![
SignClassification
],
![
PropClassification
],
!*{!
Type
},
!*
LiftState
)
|
lift
a
lift_list
modules
[]
subst
ls
=
([],
[],
[],
subst
,
ls
)
lift_list
modules
[
t
:
ts
]
subst
ls
#
(
t
,
sign_class
,
prop_class
,
subst
,
ls
)
=
lift
modules
t
subst
ls
(
ts
,
sign_classes
,
prop_classes
,
subst
,
ls
)
=
lift_list
modules
ts
subst
ls
=
([
t
:
ts
],
[
sign_class
:
sign_classes
],
[
prop_class
:
prop_classes
],
subst
,
ls
)
::
ExpansionState
=
{
es_type_heaps
::
!.
TypeHeaps
,
es_td_infos
::
!.
TypeDefInfos
...
...
@@ -324,12 +340,13 @@ where
#
(
arg_type
,
es
)
=
expandType
modules
cons_vars
arg_type
es
(
res_type
,
es
)
=
expandType
modules
cons_vars
res_type
es
=
(
arg_type
-->
res_type
,
es
)
expandType
modules
cons_vars
(
TA
cons_id
=:{
type_index
={
glob_object
,
glob_module
}}
cons_args
)
es
expandType
modules
cons_vars
(
TA
cons_id
=:{
type_name
,
type_index
={
glob_object
,
glob_module
}}
cons_args
)
es
#
(
cons_args
,
sign_classes
,
prop_classes
,
(
subst
,
es
=:{
es_td_infos
,
es_type_heaps
}))
=
expand_type_list
modules
cons_vars
cons_args
es
(
type_prop
,
th_vars
,
es_td_infos
)
=
typeProperties
glob_object
glob_module
sign_classes
prop_classes
modules
es_type_heaps
.
th_vars
es_td_infos
=
(
TA
{
cons_id
&
type_prop
=
type_prop
}
cons_args
,
(
subst
,
{
es
&
es_td_infos
=
es_td_infos
,
es_type_heaps
=
{
es_type_heaps
&
th_vars
=
th_vars
}}))
// ---> ("expandType", type_name, type_prop.tsp_propagation)
where
expand_type_list
::
!{#
CommonDefs
}
!{#
BOOLVECT
}
![
AType
]
!*(!
u
:{!
Type
},
!*
ExpansionState
)
->
(![
AType
],
![
SignClassification
],
![
PropClassification
],
!*(!
u
:{!
Type
},
!*
ExpansionState
))
...
...
@@ -373,6 +390,7 @@ where
toInt
(
TA_TempVar
av_number
)
=
av_number
toInt
TA_Multi
=
AttrMulti
toInt
TA_None
=
AttrMulti
toInt
TA_TempExVar
=
AttrExi
instance
*
Bool
...
...
@@ -400,6 +418,14 @@ offered_attribute according to sign. Failure is indicated by returning False as