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
121bf6b1
Commit
121bf6b1
authored
Sep 21, 2001
by
Sjaak Smetsers
Browse files
*** empty log message ***
parent
2389ad52
Changes
2
Hide whitespace changes
Inline
Side-by-side
frontend/analunitypes.icl
View file @
121bf6b1
...
...
@@ -71,7 +71,7 @@ determineSignClassOfTypeDef type_index module_index td_args {tdi_classification,
->
(
ts_type_sign
,
type_var_heap
,
td_infos
)
No
#
signs_of_group_vars
=
foldSt
(
determine_signs_of_group_var
tdi_cons_vars
hio_signs
)
tdi_group_vars
[]
->
newSignClassOfTypeDefGroup
tdi_group_nr
{
g
lob
_module
=
module_index
,
g
lob_object
=
type_index
}
->
newSignClassOfTypeDefGroup
tdi_group_nr
{
g
i
_module
=
module_index
,
g
i_index
=
type_index
}
// tdi_group (signs_of_group_vars ---> ("determine_signs_of_group_var", (module_index, type_index), signs_of_group_vars, tdi_group_vars)) ci type_var_heap td_infos
tdi_group
signs_of_group_vars
ci
type_var_heap
td_infos
...
...
@@ -107,38 +107,38 @@ where
newGroupSigns
::
!
Int
->
*{#
SignRequirements
}
newGroupSigns
group_size
=
createArray
group_size
{
sr_hio_signs
=
[],
sr_classification
=
BottomSignClass
,
sr_type_applications
=
[]
}
newSignClassOfTypeDefGroup
::
!
Int
!
(
Global
In
t
)
![
Global
In
t
]
![(
Int
,
SignClassification
)]
!{#
CommonDefs
}
!*
TypeVarHeap
!*
TypeDefInfos
newSignClassOfTypeDefGroup
::
!
Int
!
GlobalIn
dex
![
GlobalIn
dex
]
![(
Int
,
SignClassification
)]
!{#
CommonDefs
}
!*
TypeVarHeap
!*
TypeDefInfos
->
*(!
SignClassification
,
!*
TypeVarHeap
,
!*
TypeDefInfos
)
newSignClassOfTypeDefGroup
group_nr
{
g
lob
_module
,
g
lob_object
}
group
signs_of_group_vars
ci
type_var_heap
td_infos
newSignClassOfTypeDefGroup
group_nr
{
g
i
_module
,
g
i_index
}
group
signs_of_group_vars
ci
type_var_heap
td_infos
#
(
group_signs
,
type_var_heap
,
td_infos
)
=
collect_sign_class_of_type_defs
group_nr
group
signs_of_group_vars
ci
(
newGroupSigns
(
length
group
))
type_var_heap
td_infos
group_signs
=
determine_fixed_point
group_signs
td_infos
=
update_sign_class_of_group
group
group_signs
td_infos
(
tdi
=:{
tdi_
tmp_
index
},
td_infos
)
=
td_infos
![
g
lob
_module
].[
g
lob_object
]
=
(
group_signs
.[
tdi_
tmp_
index
].
sr_classification
,
type_var_heap
,
td_infos
)
(
tdi
=:{
tdi_index
_in_group
},
td_infos
)
=
td_infos
![
g
i
_module
].[
g
i_index
]
=
(
group_signs
.[
tdi_index
_in_group
].
sr_classification
,
type_var_heap
,
td_infos
)
where
update_sign_class_of_group
group
group_signs
td_infos
=
foldSt
(
update_sign_class_of_type_def
group_signs
)
group
td_infos
where
update_sign_class_of_type_def
group_signs
{
g
lob
_module
,
g
lob_object
}
td_infos
#
(
tdi
=:{
tdi_classification
,
tdi_
tmp_
index
},
td_infos
)
=
td_infos
![
g
lob
_module
].[
g
lob_object
]
{
sr_hio_signs
,
sr_classification
}
=
group_signs
.[
tdi_
tmp_
index
]
update_sign_class_of_type_def
group_signs
{
g
i
_module
,
g
i_index
}
td_infos
#
(
tdi
=:{
tdi_classification
,
tdi_index
_in_group
},
td_infos
)
=
td_infos
![
g
i
_module
].[
g
i_index
]
{
sr_hio_signs
,
sr_classification
}
=
group_signs
.[
tdi_index
_in_group
]
tdi_classification
=
addSignClassification
sr_hio_signs
sr_classification
tdi_classification
=
{
td_infos
&
[
g
lob
_module
].[
g
lob_object
]
=
{
tdi
&
tdi_classification
=
tdi_classification
}}
=
{
td_infos
&
[
g
i
_module
].[
g
i_index
]
=
{
tdi
&
tdi_classification
=
tdi_classification
}}
collect_sign_class_of_type_defs
group_nr
group
signs_of_group_vars
ci
sign_requirements
type_var_heap
td_infos
=
foldSt
(
collect_sign_class_of_type_def
group_nr
signs_of_group_vars
ci
)
group
(
sign_requirements
,
type_var_heap
,
td_infos
)
where
collect_sign_class_of_type_def
group_nr
signs_of_group_vars
ci
{
g
lob
_module
,
g
lob_object
}
(
sign_requirements
,
type_var_heap
,
td_infos
)
#
({
tdi_group_vars
,
tdi_kinds
,
tdi_
tmp_
index
},
td_infos
)
=
td_infos
![
g
lob
_module
].[
g
lob_object
]
{
td_name
,
td_args
,
td_rhs
}
=
ci
.[
g
lob
_module
].
com_type_defs
.[
g
lob_object
]
collect_sign_class_of_type_def
group_nr
signs_of_group_vars
ci
{
g
i
_module
,
g
i_index
}
(
sign_requirements
,
type_var_heap
,
td_infos
)
#
({
tdi_group_vars
,
tdi_kinds
,
tdi_index
_in_group
},
td_infos
)
=
td_infos
![
g
i
_module
].[
g
i_index
]
{
td_name
,
td_args
,
td_rhs
}
=
ci
.[
g
i
_module
].
com_type_defs
.[
g
i_index
]
// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name, (glob_module, glob_object), tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap)
(
rev_hio_signs
,
type_var_heap
)
=
bind_type_vars_to_signs
td_args
tdi_group_vars
tdi_kinds
signs_of_group_vars
([],
type_var_heap
)
(
sign_env
,
scs
)
=
sign_class_of_type_def
g
lob
_module
td_rhs
group_nr
ci
(
sign_env
,
scs
)
=
sign_class_of_type_def
g
i
_module
td_rhs
group_nr
ci
{
scs_type_var_heap
=
type_var_heap
,
scs_type_def_infos
=
td_infos
,
scs_rec_appls
=
[]
}
type_var_heap
=
foldSt
restore_binds_of_type_var
td_args
scs
.
scs_type_var_heap
=
({
sign_requirements
&
[
tdi_
tmp_
index
]
=
{
sr_hio_signs
=
reverse
rev_hio_signs
,
sr_classification
=
sign_env
,
=
({
sign_requirements
&
[
tdi_index
_in_group
]
=
{
sr_hio_signs
=
reverse
rev_hio_signs
,
sr_classification
=
sign_env
,
sr_type_applications
=
scs
.
scs_rec_appls
}},
type_var_heap
,
scs
.
scs_type_def_infos
)
determine_fixed_point
sign_requirements
...
...
@@ -242,9 +242,9 @@ signClassOfType (TV tv) sign use_top_sign group_nr ci scs
=
(
sign
*+
sign_class
,
type_class
,
scs
)
signClassOfType
(
TA
{
type_index
=
{
glob_module
,
glob_object
}}
types
)
sign
use_top_sign
group_nr
ci
scs
#
(
td_info
=:{
tdi_group_nr
,
tdi_
tmp_
index
,
tdi_kinds
},
scs
)
=
scs
!
scs_type_def_infos
.[
glob_module
].[
glob_object
]
#
(
td_info
=:{
tdi_group_nr
,
tdi_index
_in_group
,
tdi_kinds
},
scs
)
=
scs
!
scs_type_def_infos
.[
glob_module
].[
glob_object
]
|
tdi_group_nr
==
group_nr
=
sign_class_of_type_list_of_rec_type
types
sign
use_top_sign
tdi_
tmp_
index
ci
[]
scs
=
sign_class_of_type_list_of_rec_type
types
sign
use_top_sign
tdi_index
_in_group
ci
[]
scs
#
{
td_args
,
td_arity
}
=
ci
.[
glob_module
].
com_type_defs
.[
glob_object
]
(
sign_classes
,
hio_signs
,
scs
)
=
collect_sign_classes_of_type_list
types
tdi_kinds
group_nr
ci
scs
(
type_class
,
scs_type_var_heap
,
scs_type_def_infos
)
...
...
@@ -326,7 +326,7 @@ determinePropClassOfTypeDef type_index module_index td_args {tdi_classification,
No
#
props_of_group_vars
=
foldSt
(
determine_props_of_group_var
tdi_cons_vars
hio_props
)
tdi_group_vars
[]
->
newPropClassOfTypeDefGroup
tdi_group_nr
{
g
lob
_module
=
module_index
,
g
lob_object
=
type_index
}
->
newPropClassOfTypeDefGroup
tdi_group_nr
{
g
i
_module
=
module_index
,
g
i_index
=
type_index
}
tdi_group
props_of_group_vars
ci
type_var_heap
td_infos
where
...
...
@@ -367,36 +367,36 @@ where
newGroupProps
::
!
Int
->
*{#
PropRequirements
}
newGroupProps
group_size
=
createArray
group_size
{
pr_hio_signs
=
[],
pr_classification
=
NoPropClass
,
pr_type_applications
=
[]
}
newPropClassOfTypeDefGroup
::
!
Int
!
(
Global
In
t
)
![
Global
In
t
]
![(
Int
,
PropClassification
)]
!{#
CommonDefs
}
!*
TypeVarHeap
!*
TypeDefInfos
newPropClassOfTypeDefGroup
::
!
Int
!
GlobalIn
dex
![
GlobalIn
dex
]
![(
Int
,
PropClassification
)]
!{#
CommonDefs
}
!*
TypeVarHeap
!*
TypeDefInfos
->
*(!
PropClassification
,
!*
TypeVarHeap
,
!*
TypeDefInfos
)
newPropClassOfTypeDefGroup
group_nr
{
g
lob
_module
,
g
lob_object
}
group
props_of_group_vars
ci
type_var_heap
td_infos
newPropClassOfTypeDefGroup
group_nr
{
g
i
_module
,
g
i_index
}
group
props_of_group_vars
ci
type_var_heap
td_infos
#
(
group_props
,
type_var_heap
,
td_infos
)
=
collect_prop_class_of_type_defs
group_nr
group
props_of_group_vars
ci
(
newGroupProps
(
length
group
))
type_var_heap
td_infos
group_props
=
determine_fixed_point
group_props
td_infos
=
update_prop_class_of_group
group
group_props
td_infos
(
tdi
=:{
tdi_
tmp_
index
},
td_infos
)
=
td_infos
![
g
lob
_module
].[
g
lob_object
]
=
(
group_props
.[
tdi_
tmp_
index
].
pr_classification
,
type_var_heap
,
td_infos
)
(
tdi
=:{
tdi_index
_in_group
},
td_infos
)
=
td_infos
![
g
i
_module
].[
g
i_index
]
=
(
group_props
.[
tdi_index
_in_group
].
pr_classification
,
type_var_heap
,
td_infos
)
where
update_prop_class_of_group
group
group_props
td_infos
=
foldSt
(
update_prop_class_of_type_def
group_props
)
group
td_infos
where
update_prop_class_of_type_def
group_props
{
g
lob
_module
,
g
lob_object
}
td_infos
#
(
tdi
=:{
tdi_classification
,
tdi_
tmp_
index
},
td_infos
)
=
td_infos
![
g
lob
_module
].[
g
lob_object
]
{
pr_hio_signs
,
pr_classification
}
=
group_props
.[
tdi_
tmp_
index
]
update_prop_class_of_type_def
group_props
{
g
i
_module
,
g
i_index
}
td_infos
#
(
tdi
=:{
tdi_classification
,
tdi_index
_in_group
},
td_infos
)
=
td_infos
![
g
i
_module
].[
g
i_index
]
{
pr_hio_signs
,
pr_classification
}
=
group_props
.[
tdi_index
_in_group
]
tdi_classification
=
addPropClassification
pr_hio_signs
pr_classification
tdi_classification
=
{
td_infos
&
[
g
lob
_module
].[
g
lob_object
]
=
{
tdi
&
tdi_classification
=
tdi_classification
}}
=
{
td_infos
&
[
g
i
_module
].[
g
i_index
]
=
{
tdi
&
tdi_classification
=
tdi_classification
}}
collect_prop_class_of_type_defs
group_nr
group
props_of_group_vars
ci
prop_requirements
type_var_heap
td_infos
=
foldSt
(
collect_sign_class_of_type_def
group_nr
props_of_group_vars
ci
)
group
(
prop_requirements
,
type_var_heap
,
td_infos
)
where
collect_sign_class_of_type_def
group_nr
props_of_group_vars
ci
{
g
lob
_module
,
g
lob_object
}
(
prop_requirements
,
type_var_heap
,
td_infos
)
#
({
tdi_group_vars
,
tdi_kinds
,
tdi_
tmp_
index
},
td_infos
)
=
td_infos
![
g
lob
_module
].[
g
lob_object
]
{
td_name
,
td_args
,
td_rhs
}
=
ci
.[
g
lob
_module
].
com_type_defs
.[
g
lob_object
]
collect_sign_class_of_type_def
group_nr
props_of_group_vars
ci
{
g
i
_module
,
g
i_index
}
(
prop_requirements
,
type_var_heap
,
td_infos
)
#
({
tdi_group_vars
,
tdi_kinds
,
tdi_index
_in_group
},
td_infos
)
=
td_infos
![
g
i
_module
].[
g
i_index
]
{
td_name
,
td_args
,
td_rhs
}
=
ci
.[
g
i
_module
].
com_type_defs
.[
g
i_index
]
(
rev_hio_props
,
type_var_heap
)
=
bind_type_vars_to_props
td_args
tdi_group_vars
tdi_kinds
props_of_group_vars
([],
type_var_heap
)
(
prop_env
,
pcs
)
=
prop_class_of_type_def
g
lob
_module
td_rhs
group_nr
ci
(
prop_env
,
pcs
)
=
prop_class_of_type_def
g
i
_module
td_rhs
group_nr
ci
{
pcs_type_var_heap
=
type_var_heap
,
pcs_type_def_infos
=
td_infos
,
pcs_rec_appls
=
[]
}
type_var_heap
=
foldSt
restore_binds_of_type_var
td_args
pcs
.
pcs_type_var_heap
=
({
prop_requirements
&
[
tdi_
tmp_
index
]
=
{
pr_hio_signs
=
reverse
rev_hio_props
,
pr_classification
=
prop_env
,
=
({
prop_requirements
&
[
tdi_index
_in_group
]
=
{
pr_hio_signs
=
reverse
rev_hio_props
,
pr_classification
=
prop_env
,
pr_type_applications
=
pcs
.
pcs_rec_appls
}},
type_var_heap
,
pcs
.
pcs_type_def_infos
)
determine_fixed_point
sign_requirements
...
...
@@ -490,9 +490,9 @@ propClassOfType (TV tv) _ ci pcs
=
propClassOfTypeVariable
tv
ci
pcs
propClassOfType
(
TA
{
type_name
,
type_index
=
{
glob_module
,
glob_object
}}
types
)
group_nr
ci
pcs
#
(
td_info
=:{
tdi_group_nr
,
tdi_
tmp_
index
,
tdi_kinds
},
pcs
)
=
pcs
!
pcs_type_def_infos
.[
glob_module
].[
glob_object
]
#
(
td_info
=:{
tdi_group_nr
,
tdi_index
_in_group
,
tdi_kinds
},
pcs
)
=
pcs
!
pcs_type_def_infos
.[
glob_module
].[
glob_object
]
|
tdi_group_nr
==
group_nr
=
prop_class_of_type_list_of_rec_type
types
tdi_
tmp_
index
ci
[]
pcs
=
prop_class_of_type_list_of_rec_type
types
tdi_index
_in_group
ci
[]
pcs
#
{
td_args
,
td_arity
}
=
ci
.[
glob_module
].
com_type_defs
.[
glob_object
]
(
prop_classes
,
hio_props
,
pcs
)
=
collect_prop_classes_of_type_list
types
tdi_kinds
group_nr
ci
pcs
(
type_class
,
pcs_type_var_heap
,
pcs_type_def_infos
)
...
...
frontend/generics.icl
View file @
121bf6b1
...
...
@@ -1230,12 +1230,12 @@ where
get_group
::
!
Index
!
Index
!*
GenericState
->
(!
Index
,
!*
GenericState
)
get_group
module_index
type_def_index
gs
=:{
gs_gtd_infos
}
#!
gtd_info
=
gs_gtd_infos
.
[
module_index
,
type_def_index
]
#!
(
gtd_info
,
gs_gtd_infos
)
=
gs_gtd_infos
!
[
module_index
,
type_def_index
]
#!
gt
=
case
gtd_info
of
(
GTDI_Generic
gt
)
->
gt
_
->
abort
"no generic representation for a type
\n
"
|
gt
.
gtr_isomap_group
<>
NoIndex
// group index already allocated
=
(
gt
.
gtr_isomap_group
,
gs
)
=
(
gt
.
gtr_isomap_group
,
{
gs
&
gs_gtd_infos
=
gs_gtd_infos
}
)
//---> ("group for type already exists", module_index, type_def_index, gt.gtr_isomap_group)
#
(
group_index
,
gs
=:{
gs_td_infos
,
gs_gtd_infos
})
=
newGroupIndex
{
gs
&
gs_gtd_infos
=
gs_gtd_infos
}
...
...
@@ -1245,20 +1245,21 @@ where
=
(
group_index
,
{
gs
&
gs_gtd_infos
=
gs_gtd_infos
,
gs_td_infos
=
gs_td_infos
})
//---> ("type group of type ", module_index, type_def_index, type_def_info.tdi_group_nr)
update_group
::
!
Index
![
Global
Index
]
!*
GenericTypeDefInfos
->
!*
GenericTypeDefInfos
// Sjaak ...
update_group
::
!
Index
![
GlobalIndex
]
!*
GenericTypeDefInfos
->
!*
GenericTypeDefInfos
update_group
group_index
[]
gtd_infos
=
gtd_infos
update_group
group_index
[{
g
lob
_module
,
g
lob_object
}:
type_def_global_indexes
]
gtd_infos
#!
(
gtd_info
,
gtd_infos
)
=
gtd_infos
!
[
g
lob
_module
,
g
lob_object
]
update_group
group_index
[{
g
i
_module
,
g
i_index
}:
type_def_global_indexes
]
gtd_infos
#!
(
gtd_info
,
gtd_infos
)
=
gtd_infos
!
[
g
i
_module
,
g
i_index
]
#!
gtd_info
=
case
gtd_info
of
(
GTDI_Generic
gt
)
|
gt
.
gtr_isomap_group
<>
NoIndex
->
abort
"sanity check: updating already updated group
\n
"
->
GTDI_Generic
{
gt
&
gtr_isomap_group
=
group_index
}
_
->
gtd_info
#!
gtd_infos
=
{
gtd_infos
&
[
g
lob
_module
,
g
lob_object
]
=
gtd_info
}
#!
gtd_infos
=
{
gtd_infos
&
[
g
i
_module
,
g
i_index
]
=
gtd_info
}
=
update_group
group_index
type_def_global_indexes
gtd_infos
/// ... Sjaak
buildIsomapsForGenerics
::
!*
GenericState
->
(![
FunDef
],
![
Group
],
!*
GenericState
)
buildIsomapsForGenerics
gs
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment