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
24cde797
Commit
24cde797
authored
Nov 29, 2017
by
John van Groningen
Browse files
expand newtypes during fusion
parent
bf1ad85c
Changes
4
Hide whitespace changes
Inline
Side-by-side
frontend/trans.icl
View file @
24cde797
...
...
@@ -1901,7 +1901,7 @@ where
coerce_types
common_defs
cons_vars
{
ur_offered
,
ur_demanded
}
(
subst
,
coercions
,
ti_type_def_infos
,
ti_type_heaps
)
#
(
opt_error_info
,
subst
,
coercions
,
ti_type_def_infos
,
ti_type_heaps
)
=
determineAttributeCoercions
ur_offered
ur_demanded
True
subst
coercions
common_defs
cons_vars
ti_type_def_infos
ti_type_heaps
=
determineAttributeCoercions
ur_offered
ur_demanded
True
True
subst
coercions
common_defs
cons_vars
ti_type_def_infos
ti_type_heaps
=
case
opt_error_info
of
Yes
_
->
abort
"Error in compiler: determineAttributeCoercions failed in module trans"
...
...
frontend/type.icl
View file @
24cde797
...
...
@@ -2849,7 +2849,7 @@ where
add_to_coercion_env
[{
tc_offered
,
tc_demanded
,
tc_coercible
,
tc_position
}
:
attr_coercions
]
subst
coercion_env
common_defs
cons_var_vects
type_signs
type_var_heap
error
#
(
opt_error_info
,
subst
,
coercion_env
,
type_signs
,
type_var_heap
)
=
determineAttributeCoercions
tc_offered
tc_demanded
tc_coercible
=
determineAttributeCoercions
tc_offered
tc_demanded
tc_coercible
False
subst
coercion_env
common_defs
cons_var_vects
type_signs
type_var_heap
(
coercion_env
,
error
)
...
...
frontend/unitype.dcl
View file @
24cde797
...
...
@@ -29,8 +29,8 @@ BITINDEX temp_var_id :== temp_var_id >> 5
BITNUMBER
temp_var_id
:==
temp_var_id
bitand
31
set_bit
::
!
Int
!*{#
BOOLVECT
}
->
.{#
BOOLVECT
}
determineAttributeCoercions
::
!
AType
!
AType
!
Bool
!
u
:{!
Type
}
!*
Coercions
!{#
CommonDefs
}
!{#
BOOLVECT
}
!*
TypeDefInfos
!*
TypeHeaps
->
(!
Optional
(
TypePosition
,
AType
),
!
u
:{!
Type
},
!*
Coercions
,
!*
TypeDefInfos
,
!*
TypeHeaps
)
determineAttributeCoercions
::
!
AType
!
AType
!
Bool
!
Bool
!
u
:{!
Type
}
!*
Coercions
!{#
CommonDefs
}
!{#
BOOLVECT
}
!*
TypeDefInfos
!*
TypeHeaps
->
(!
Optional
(
TypePosition
,
AType
),!
u
:{!
Type
},!*
Coercions
,!*
TypeDefInfos
,!*
TypeHeaps
)
::
AttributePartition
:==
{#
Int
}
...
...
frontend/unitype.icl
View file @
24cde797
...
...
@@ -34,14 +34,14 @@ isPositive :: !TempVarId !{# BOOLVECT } -> Bool
isPositive
var_id
cons_vars
=
cons_vars
.[
BITINDEX
var_id
]
bitand
(
1
<<
BITNUMBER
var_id
)
<>
0
::
CoerceInfo
=
!
{
ci_common_defs
::
!{#
CommonDefs
},
ci_cons_vars
::
!{#
BOOLVECT
}
}
::
CoerceInfo
=
!
{
ci_common_defs
::
!{#
CommonDefs
},
ci_cons_vars
::
!{#
BOOLVECT
}
,
ci_expand_newtypes
::
!
Bool
}
determineAttributeCoercions
::
!
AType
!
AType
!
Bool
!
u
:{!
Type
}
!*
Coercions
!{#
CommonDefs
}
!{#
BOOLVECT
}
!*
TypeDefInfos
!*
TypeHeaps
->
(!
Optional
(
TypePosition
,
AType
),
!
u
:{!
Type
},
!*
Coercions
,
!*
TypeDefInfos
,
!*
TypeHeaps
)
determineAttributeCoercions
off_type
dem_type
coercible
subst
coercions
defs
cons_vars
td_infos
type_heaps
determineAttributeCoercions
::
!
AType
!
AType
!
Bool
!
Bool
!
u
:{!
Type
}
!*
Coercions
!{#
CommonDefs
}
!{#
BOOLVECT
}
!*
TypeDefInfos
!*
TypeHeaps
->
(!
Optional
(
TypePosition
,
AType
),!
u
:{!
Type
},!*
Coercions
,!*
TypeDefInfos
,!*
TypeHeaps
)
determineAttributeCoercions
off_type
dem_type
coercible
expand_newtypes
subst
coercions
defs
cons_vars
td_infos
type_heaps
#
(_,
exp_off_type
,
es
)
=
expandType
defs
cons_vars
off_type
(
subst
,
{
es_type_heaps
=
type_heaps
,
es_td_infos
=
td_infos
})
(_,
exp_dem_type
,
(
subst
,
{
es_td_infos
,
es_type_heaps
}))
=
expandType
defs
cons_vars
dem_type
es
ci
=
{
ci_common_defs
=
defs
,
ci_cons_vars
=
cons_vars
}
ci
=
{
ci_common_defs
=
defs
,
ci_cons_vars
=
cons_vars
,
ci_expand_newtypes
=
expand_newtypes
}
(
result
,
{
crc_type_heaps
,
crc_coercions
,
crc_td_infos
})
=
coerce
(
if
coercible
PositiveSign
TopSign
)
ci
[]
exp_off_type
exp_dem_type
{
crc_type_heaps
=
es_type_heaps
,
crc_coercions
=
coercions
,
crc_td_infos
=
es_td_infos
}
=
case
result
of
...
...
@@ -587,7 +587,7 @@ expand_and_coerce_type common_defs cons_vars atype (coercions, subst, ti_type_he
(_,
btype
,
(
subst
,
{
es_type_heaps
,
es_td_infos
}))
=
expandType
common_defs
cons_vars
atype
(
subst
,
es
)
cs
=
{
crc_type_heaps
=
es_type_heaps
,
crc_coercions
=
coercions
,
crc_td_infos
=
es_td_infos
}
ci
=
{
ci_common_defs
=
common_defs
,
ci_cons_vars
=
cons_vars
}
ci
=
{
ci_common_defs
=
common_defs
,
ci_cons_vars
=
cons_vars
,
ci_expand_newtypes
=
True
}
(_,
{
crc_type_heaps
,
crc_coercions
,
crc_td_infos
})
=
coerce
PositiveSign
ci
[]
btype
btype
cs
=
(
btype
,
(
crc_coercions
,
subst
,
crc_type_heaps
,
crc_td_infos
))
...
...
@@ -931,7 +931,7 @@ coercions_of_arg_types sign ci tpos [] [] _ _ cs
tryToExpandTypeSyn
::
!
CoerceInfo
!
Type
!
TypeSymbIdent
![
AType
]
!
TypeAttribute
!*
TypeHeaps
!*
TypeDefInfos
->
(!
Bool
,
!
Type
,
!*
TypeHeaps
,
!*
TypeDefInfos
)
tryToExpandTypeSyn
{
ci_common_defs
,
ci_cons_vars
}
type
cons_id
=:
{
type_index
={
glob_object
,
glob_module
}}
type_args
attribute
type_heaps
td_infos
tryToExpandTypeSyn
{
ci_common_defs
,
ci_cons_vars
,
ci_expand_newtypes
}
type
{
type_index
={
glob_object
,
glob_module
}}
type_args
attribute
type_heaps
td_infos
#
{
td_rhs
,
td_args
,
td_attribute
,
td_ident
}
=
ci_common_defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
=
case
td_rhs
of
SynType
{
at_type
}
...
...
@@ -939,6 +939,13 @@ tryToExpandTypeSyn {ci_common_defs,ci_cons_vars} type cons_id=:{type_index={glob
(_,
expanded_type
,
(_,
{
es_type_heaps
,
es_td_infos
}))
=
expandType
ci_common_defs
ci_cons_vars
at_type
({},
{
es_type_heaps
=
type_heaps
,
es_td_infos
=
td_infos
})
->
(
True
,
expanded_type
,
clearBindingsOfTypeVarsAndAttributes
attribute
td_args
es_type_heaps
,
es_td_infos
)
NewType
{
ds_index
}
|
ci_expand_newtypes
#
{
cons_type
={
st_args
=[{
at_type
}:_]}}
=
ci_common_defs
.[
glob_module
].
com_cons_defs
.[
ds_index
];
type_heaps
=
bindTypeVarsAndAttributes
td_attribute
attribute
td_args
type_args
type_heaps
(_,
expanded_type
,
(_,
{
es_type_heaps
,
es_td_infos
}))
=
expandType
ci_common_defs
ci_cons_vars
at_type
({},
{
es_type_heaps
=
type_heaps
,
es_td_infos
=
td_infos
})
->
(
True
,
expanded_type
,
clearBindingsOfTypeVarsAndAttributes
attribute
td_args
es_type_heaps
,
es_td_infos
)
_
->
(
False
,
type
,
type_heaps
,
td_infos
)
...
...
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