Skip to content
GitLab
Commit cdc21bb4 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

commit for Sjaak by RWS

parent eafb678b
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 cs
= (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, copy_heaps)
= fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store copy_heaps
= (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, cs)
(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_heaps)
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