diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/Heap.icl | 18 | ||||
| -rw-r--r-- | frontend/analunitypes.icl | 2 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 7 | ||||
| -rw-r--r-- | frontend/frontend.icl | 6 | ||||
| -rw-r--r-- | frontend/main.icl | 61 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 4 | ||||
| -rw-r--r-- | frontend/syntax.icl | 13 | ||||
| -rw-r--r-- | frontend/type.icl | 55 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 2 | ||||
| -rw-r--r-- | frontend/unitype.dcl | 5 | ||||
| -rw-r--r-- | frontend/unitype.icl | 128 |
11 files changed, 140 insertions, 161 deletions
diff --git a/frontend/Heap.icl b/frontend/Heap.icl index a50b10a..3a99c89 100644 --- a/frontend/Heap.icl +++ b/frontend/Heap.icl @@ -1,6 +1,6 @@ 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 diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl index 08cb748..fec92d1 100644 --- a/frontend/analunitypes.icl +++ b/frontend/analunitypes.icl @@ -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 diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 5fb1791..49651fb 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -1015,8 +1015,13 @@ where 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) diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 2786862..267d59b 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -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 diff --git a/frontend/main.icl b/frontend/main.icl index b561d53..5f4c7d0 100644 --- a/frontend/main.icl +++ b/frontend/main.icl @@ -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 diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index a2ec1ba..3ac7259 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -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 diff --git a/frontend/syntax.icl b/frontend/syntax.icl index a7f9d7b..667eb07 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -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 _ _) = "??? " diff --git a/frontend/type.icl b/frontend/type.icl index 5b28349..b0d2c31 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -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 diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 84e5344..3f4c904 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -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 diff --git a/frontend/unitype.dcl b/frontend/unitype.dcl index 83065d1..197dec5 100644 --- a/frontend/unitype.dcl +++ b/frontend/unitype.dcl @@ -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 diff --git a/frontend/unitype.icl b/frontend/unitype.icl index bb9302b..5665d83 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -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 */ +/* Just Temporary */ + +coerceAttributes TA_TempExVar dem_attr _ coercions + = (True, coercions) +coerceAttributes _ TA_TempExVar _ coercions + = (True, coercions) +/* ... remove this !!!! */ + coerceAttributes TA_Unique dem_attr {neg_sign} coercions | not neg_sign = (True, coercions) @@ -595,7 +621,7 @@ where adjust_sign sign _ cons_vars = sign - add_propagation_inequalities attr (TA {type_prop={tsp_propagation}} cons_args) coercions + add_propagation_inequalities attr (TA {type_name,type_prop={tsp_propagation}} cons_args) coercions = add_inequalities tsp_propagation attr cons_args coercions where add_inequalities prop_class attr [] coercions |