Commit 24cde797 authored by John van Groningen's avatar John van Groningen
Browse files

expand newtypes during fusion

parent bf1ad85c
......@@ -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"
......
......@@ -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)
......
......@@ -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}
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment