diff options
| -rw-r--r-- | frontend/check.icl | 12 | ||||
| -rw-r--r-- | frontend/compilerSwitches.dcl | 9 | ||||
| -rw-r--r-- | frontend/compilerSwitches.icl | 9 | ||||
| -rw-r--r-- | frontend/convertDynamics.dcl | 4 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 95 | ||||
| -rw-r--r-- | frontend/generics.icl | 28 | ||||
| -rw-r--r-- | frontend/main.icl | 8 | ||||
| -rw-r--r-- | frontend/overloading.icl | 90 | ||||
| -rw-r--r-- | frontend/predef.dcl | 72 | ||||
| -rw-r--r-- | frontend/predef.icl | 76 | ||||
| -rw-r--r-- | frontend/type_io_common.dcl | 3 | ||||
| -rw-r--r-- | frontend/type_io_common.icl | 3 |
12 files changed, 287 insertions, 122 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 0482532..1dcf5ad 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1615,7 +1615,7 @@ check_module1 {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cde <=< adjust_predefined_module_symbol PD_StdArray <=< adjust_predefined_module_symbol PD_StdEnum <=< adjust_predefined_module_symbol PD_StdBool - <=< adjust_predefined_module_symbol PD_StdDynamics + <=< adjust_predefined_module_symbol PD_StdDynamic <=< adjust_predefined_module_symbol PD_StdGeneric // AA <=< adjust_predefined_module_symbol PD_StdMisc // AA <=< adjust_predefined_module_symbol PD_PredefinedModule @@ -2115,7 +2115,7 @@ check_needed_modules_are_imported mod_name extension cs=:{cs_x={x_needed_modules //..AA # cs = case x_needed_modules bitand cNeedStdDynamics of 0 -> cs - _ -> check_it PD_StdDynamics mod_name "" extension cs + _ -> check_it PD_StdDynamic mod_name "" extension cs # cs = case x_needed_modules bitand cNeedStdArray of 0 -> cs _ -> check_it PD_StdArray mod_name " (needed for array denotations)" extension cs @@ -2685,7 +2685,7 @@ where = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols} <=< adjust_predef_symbol PD_AndOp mod_index STE_DclFunction <=< adjust_predef_symbol PD_OrOp mod_index STE_DclFunction) - # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdDynamics] + # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdDynamic] | pre_mod.pds_def == mod_index = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols} <=< adjust_predef_symbol PD_TypeObjectType mod_index STE_Type @@ -2697,8 +2697,10 @@ where // MV ... <=< adjust_predef_symbol PD_DynamicTemp mod_index STE_Type <=< adjust_predef_symbol PD_DynamicType mod_index (STE_Field unused) - <=< adjust_predef_symbol PD_DynamicValue mod_index (STE_Field unused)) - + <=< adjust_predef_symbol PD_DynamicValue mod_index (STE_Field unused) + + <=< adjust_predef_symbol PD_TypeID mod_index STE_Type + <=< adjust_predef_symbol PD_ModuleID mod_index STE_Constructor) // ... MV // AA.. # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdGeneric] diff --git a/frontend/compilerSwitches.dcl b/frontend/compilerSwitches.dcl index f0683a2..4bded90 100644 --- a/frontend/compilerSwitches.dcl +++ b/frontend/compilerSwitches.dcl @@ -1,6 +1,6 @@ definition module compilerSwitches -SwitchGenerics on off :== on +SwitchGenerics on off :== off PA_BUG on off :== off @@ -10,3 +10,10 @@ switch_import_syntax one_point_three two_point_zero :== one_point_three SwitchFusion fuse dont_fuse :== dont_fuse SwitchPreprocessor preprocessor no_preprocessor :== preprocessor + +// MV... +// - change T_ypeObjectType in StdDynamic (remove DummyModuleName-argument of T_ypeConsSymbol) +// - the (ModuleID _)-constructor is *not* yet shared + +USE_DummyModuleName yes no :== yes +// ...MV diff --git a/frontend/compilerSwitches.icl b/frontend/compilerSwitches.icl index 9d65c97..ef175a3 100644 --- a/frontend/compilerSwitches.icl +++ b/frontend/compilerSwitches.icl @@ -1,6 +1,6 @@ implementation module compilerSwitches -SwitchGenerics on off :== on +SwitchGenerics on off :== off PA_BUG on off :== off @@ -10,3 +10,10 @@ switch_import_syntax one_point_three two_point_zero :== one_point_three SwitchFusion fuse dont_fuse :== dont_fuse SwitchPreprocessor preprocessor no_preprocessor :== preprocessor + +// MV... +// - change T_ypeObjectType in StdDynamic (remove DummyModuleName-argument of T_ypeConsSymbol) +// - the (ModuleID _)-constructor is *not* yet shared + +USE_DummyModuleName yes no :== yes +// ...MV diff --git a/frontend/convertDynamics.dcl b/frontend/convertDynamics.dcl index fd17a4d..835a0fd 100644 --- a/frontend/convertDynamics.dcl +++ b/frontend/convertDynamics.dcl @@ -13,4 +13,6 @@ convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Gr */ instance toString GlobalTCType -instance toString BasicType
\ No newline at end of file +instance toString BasicType + +get_module_id_app :: !*PredefinedSymbols -> (App,Expression,!*PredefinedSymbols) diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 76e25dc..c5f7ed0 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -1,13 +1,14 @@ implementation module convertDynamics -import syntax, transform, utilities, convertcases +import syntax, transform, utilities, convertcases /* MV ... */, compilerSwitches /* ... MV */ +from type_io_common import PredefinedModuleName // Optional USE_TUPLES tuple b :== b; // change also StdDynamic.icl and recompile all applications extended_unify_and_coerce no yes :== no; // change also _unify and _coerce in StdDynamic //import pp; -APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES yes no :== no +APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES yes no :== yes import type_io; //import RWSDebug; @@ -28,6 +29,8 @@ import type_io; , ci_sel_type_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol)) , ci_sel_value_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol)) , ci_module_id_symbol :: Expression + , ci_internal_type_id :: Expression + , ci_module_id :: Optional LetBind } :: ConversionInput = @@ -106,7 +109,7 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_ // ... TD - # ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamics] + # ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic] #! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols) = case (pds_module == (-1) || pds_def == (-1)) of True @@ -174,13 +177,8 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_ = (\dynamic_expr -> Selection No dynamic_expr [RecordSelection value_defined_symbol sd_field_nr3]) -> (dynamic_temp_symb_ident, ci_sel_value_field, ci_sel_type_field,predefined_symbols) - // get module id symbol - # ({pds_module, pds_def, pds_ident}, predefined_symbols) = predefined_symbols![PD_ModuleConsSymbol] - # module_symb = - { app_symb = { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 0 } - , app_args = [] - , app_info_ptr = nilPtr - } + # (module_symb,module_id_app,predefined_symbols) + = get_module_id_app predefined_symbols #! nr_of_funs = size fun_defs # imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs } @@ -190,7 +188,9 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_ ci_new_functions = [], ci_new_variables = [], ci_fun_heap = newHeap, ci_next_fun_nr = nr_of_funs, ci_placeholders_and_tc_args = [], ci_generated_global_tc_placeholders = False, ci_used_tcs = [],ci_symb_ident = dynamic_temp_symb_ident , ci_sel_type_field = ci_sel_type_field, ci_sel_value_field = ci_sel_value_field, - ci_module_id_symbol = App module_symb }) + ci_module_id_symbol = App module_symb, + ci_internal_type_id = module_id_app, + ci_module_id = No }) (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap) = addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap = (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap, tcl_file) @@ -395,7 +395,9 @@ where /* Sjaak ... */ convertDynamics cinp bound_vars default_expr (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_type_code}) ci=:{ci_symb_ident} # (dyn_expr, ci) = convertDynamics cinp bound_vars default_expr dyn_expr ci - (_,dyn_type_code, _, _, ci) = convertTypecode2 cinp dyn_type_code False [] [] ci + (_,dyn_type_code, _, _, ci) = convertTypecode2 cinp dyn_type_code False [] [] {ci & ci_module_id = No} + # (dyn_type_code,ci) + = build_type_identification dyn_type_code ci = (App { app_symb = ci_symb_ident, app_args = [dyn_expr, dyn_type_code], app_info_ptr = nilPtr }, ci) @@ -427,8 +429,21 @@ where convertDynamics cinp bound_vars default_expr expression ci = abort "unexpected value in convertDynamics: 'convertDynamics.Expression'" - - +// identification of types generated by the compiler. If there is no TypeConsSymbol, then +// no identification is necessary. +build_type_identification dyn_type_code ci=:{ci_module_id=No} + = (dyn_type_code,ci) +build_type_identification dyn_type_code ci=:{ci_module_id=Yes let_bind} + # (let_info_ptr, ci) = let_ptr 1 ci + # letje + = Let { let_strict_binds = [], + let_lazy_binds = [let_bind], + let_expr = dyn_type_code, + let_info_ptr = let_info_ptr, + let_expr_position = NoPos + } + = (letje,ci) + //convertTypecode :: !ConversionInput TypeCodeExpression !*ConversionInfo -> (Expression,!*ConversionInfo) /* replace all references in a type code expression which refer to an argument i.e. the argument contains a @@ -529,13 +544,36 @@ convertTypecode cinp (TCE_TypeTerm var_info_ptr) replace_tc_args binds placehold */ = convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci -convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args binds placeholders_and_tc_args ci - # (typecons_symb, ci) = getSymbol PD_TypeConsSymbol SK_Constructor 2 ci +convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args binds placeholders_and_tc_args ci=:{ci_internal_type_id} + # (typecons_symb, ci) = getSymbol PD_TypeConsSymbol SK_Constructor (USE_DummyModuleName 3 2) ci constructor = get_constructor cinp.cinp_glob_type_inst index (typecode_exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci + # (ci_internal_type_id,ci) + = get_module_id ci = (App {app_symb = typecons_symb, - app_args = [constructor , typecode_exprs], + app_args = USE_DummyModuleName [constructor , ci_internal_type_id, typecode_exprs] [constructor , typecode_exprs] , app_info_ptr = nilPtr},binds,placeholders_and_tc_args,ci) +where + get_module_id ci=:{ci_module_id=Yes {lb_dst}} + = (Var (freeVarToVar lb_dst),ci) + + get_module_id ci + # (dst=:{var_info_ptr},ci) + = newVariable "module_id" VI_Empty ci + # dst_fv + = varToFreeVar dst 1 + + # let_bind + = { lb_src = ci_internal_type_id + , lb_dst = dst_fv + , lb_position = NoPos + } + # ci + = { ci & + ci_new_variables = [ dst_fv : ci.ci_new_variables ] + , ci_module_id = Yes let_bind + } + = (Var dst,ci) convertTypecode cinp (TCE_Selector selections var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci #! (var,binds,placeholders_and_tc_args,ci) @@ -800,7 +838,9 @@ where /*** convert the elements of this pattern ***/ (a_ij_binds, ci) = createVariables dp_type_patterns_vars [] ci - (generate_coerce,type_code,_,martijn, ci) = convertTypecode2 cinp dp_type_code True /* should be changed to True for type dependent functions */ /* WAS: a_ij_binds*/ [] [] ci + (generate_coerce,type_code,_,martijn, ci) = convertTypecode2 cinp dp_type_code True /* should be changed to True for type dependent functions */ /* WAS: a_ij_binds*/ [] [] {ci & ci_module_id = No} // ci + # (type_code,ci) + = build_type_identification type_code ci // collect ... # (is_last_dynamic_pattern,dp_rhs) @@ -1122,7 +1162,7 @@ get_constructor glob_type_inst index instance toString GlobalTCType where - toString (GTT_Basic basic_type) = toString basic_type + toString (GTT_Basic basic_type) = toString basic_type +++ (APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES ("'" +++ PredefinedModuleName ) "") toString GTT_Function = " -> " toString (GTT_Constructor type_symb_indent mod_name) = type_symb_indent.type_name.id_name +++ (APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES ("'" +++ mod_name) "") @@ -1228,5 +1268,20 @@ instance <<< (Ptr a) where (<<<) file ptr = file <<< ptrToInt ptr +get_module_id_app :: !*PredefinedSymbols -> (App,Expression,!*PredefinedSymbols) +get_module_id_app predef_symbols + // get module id symbol + # ({pds_module, pds_def, pds_ident}, predef_symbols) = predef_symbols![PD_ModuleConsSymbol] + # module_symb = + { app_symb = { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 0 } + , app_args = [] + , app_info_ptr = nilPtr + } - + # ({pds_module, pds_def, pds_ident}, predef_symbols) = predef_symbols![PD_ModuleID] + # module_id_symb = + { app_symb = { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 1 } + , app_args = [App module_symb] + , app_info_ptr = nilPtr + } + = (module_symb,App module_id_symb,predef_symbols)
\ No newline at end of file diff --git a/frontend/generics.icl b/frontend/generics.icl index e1bc16c..3c5476f 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -323,6 +323,8 @@ where convert_instance module_index instance_index instance_defs gs=:{gs_td_infos, gs_modules, gs_error, gs_fun_defs, gs_predefs, gs_heaps} + = abort "generics; convert_instance" +/* #! (instance_def=:{ins_class,ins_ident}, instance_defs) = instance_defs ! [instance_index] | not instance_def.ins_is_generic # gs = { gs @@ -350,7 +352,7 @@ where } #! (is_partial, gs_fun_defs) = check_if_partial instance_def gs_predefs gs_fun_defs - #! (ok, gs_modules, gs_error) = check_instance_args instance_def gs_modules gs_error + # (ok, gs_modules, gs_error) = check_instance_args instance_def gs_modules gs_error | not ok #! instance_defs = { instance_defs & [instance_index] = instance_def} #! gs = { gs @@ -362,11 +364,11 @@ where } = ([], instance_defs, gs) - #! gs_heaps = check_cons_instance generic_def instance_def it_type gs_predefs gs_heaps + # gs_heaps = check_cons_instance generic_def instance_def it_type gs_predefs gs_heaps - #! (maybe_td_index, instance_def, gs_modules, gs_error) = + # (maybe_td_index, instance_def, gs_modules, gs_error) = determine_type_def_index it_type instance_def is_partial gs_modules gs_error - #! gs = { gs + # gs = { gs & gs_td_infos = gs_td_infos , gs_modules = gs_modules , gs_fun_defs = gs_fun_defs @@ -374,7 +376,7 @@ where , gs_error = gs_error } #! instance_defs = { instance_defs & [instance_index] = instance_def} = (maybe_td_index, instance_defs, gs) - +*/ determine_type_def_index (TA {type_index, type_name} _) instance_def=:{ins_generate, ins_ident, ins_pos} @@ -1863,7 +1865,8 @@ where buildMemberType :: !GenericDef !TypeKind !TypeVar !*TypeHeaps -> (!SymbolType, !*TypeHeaps) buildMemberType generic_def=:{gen_name,gen_type} kind class_var th - + = abort "generics; buildMemberType" +/* #! (gen_type, th) = freshGenericType gen_type th // Collect attributes of generic variables. @@ -1879,10 +1882,10 @@ buildMemberType generic_def=:{gen_name,gen_type} kind class_var th // substitute generic variables for types // all non-generic variables must be left intact - #! th = clearSymbolType gen_type.gt_type th - #! th = build_generic_var_substs gen_vars_with_attrs class_var atvss kind th - #! th = build_attr_var_substs gen_type.gt_type.st_attr_vars generic_avs kind th - #! (st, th) = substituteInSymbolType gen_type.gt_type th + # th = clearSymbolType gen_type.gt_type th + # th = build_generic_var_substs gen_vars_with_attrs class_var atvss kind th + # th = build_attr_var_substs gen_type.gt_type.st_attr_vars generic_avs kind th + # (st, th) = substituteInSymbolType gen_type.gt_type th // update generated fields #! instantiation_tvs = [atv_variable \\ {atv_variable} <- (flatten atvss)] @@ -1895,6 +1898,7 @@ buildMemberType generic_def=:{gen_name,gen_type} kind class_var th } = (st, th) //---> ("member type", gen_name, kind, st) +*/ where collect_generic_var_attrs {gt_type, gt_vars} th @@ -1927,8 +1931,8 @@ where build_generic_var_substs [] class_var [] kind th = th build_generic_var_substs [gv:gvs] class_var [tvs:tvss] kind th - #! th = build_generic_var_subst gv class_var tvs kind th - #! th = build_generic_var_substs gvs class_var tvss kind th + # th = build_generic_var_subst gv class_var tvs kind th + # th = build_generic_var_substs gvs class_var tvss kind th = th build_generic_var_subst {atv_variable={tv_info_ptr}} class_var [] KindConst th=:{th_vars} diff --git a/frontend/main.icl b/frontend/main.icl index a796406..89b74dd 100644 --- a/frontend/main.icl +++ b/frontend/main.icl @@ -20,14 +20,18 @@ Start world = fclose ms_out world CommandLoop proj ms=:{ms_io} - # (answer, ms_io) = freadline (ms_io <<< "> ") +// # (answer, ms_io) = freadline (ms_io <<< "> ") + # (answer, ms_io) = ("c backendconvert",ms_io) //("c test",ms_io) //("c Loader",ms_io) +// # (answer, ms_io) = ("c gentest",ms_io) //("c test",ms_io) //("c Loader",ms_io) (command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer)) | command == [] = CommandLoop proj { ms & ms_io = ms_io} # (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io} | ready = ms - = CommandLoop proj ms +// = CommandLoop proj ms + = ms + :: MainStateDefs funs funtypes types conses classes instances members selectors = { msd_funs :: !funs diff --git a/frontend/overloading.icl b/frontend/overloading.icl index c50e9af..a4def34 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -3,7 +3,7 @@ implementation module overloading import StdEnv import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, convertDynamics -import generics +import generics, compilerSwitches :: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty @@ -900,6 +900,10 @@ where # {fi_group_index, fi_dynamics, fi_local_vars} = fun_info | isEmpty fi_dynamics = update_dynamics funs type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols +// MV ... + # (_,module_id_app,predef_symbols) + = get_module_id_app predef_symbols +// ... MV # (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) = convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) (TransformedBody tb) = fun_body @@ -908,11 +912,15 @@ where = updateExpression fi_group_index tb.tb_rhs { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs, ui_local_vars = fi_local_vars, ui_fun_env = fun_env, ui_var_heap = var_heap, ui_error = error, - ui_x = {x_type_code_info=type_code_info, x_predef_symbols=predef_symbols,x_main_dcl_module_n=main_dcl_module_n}} +// MV ... + ui_x = {x_type_code_info=type_code_info, x_predef_symbols=predef_symbols,x_main_dcl_module_n=main_dcl_module_n,x_internal_type_id = module_id_app,x_module_id = No}} +// ... MV +// WAS: ui_x = {x_type_code_info=type_code_info, x_predef_symbols=predef_symbols,x_main_dcl_module_n=main_dcl_module_n}} + fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}, fun_info = { fun_info & fi_local_vars = ui_local_vars}} = update_dynamics funs type_pattern_vars ({ ui_fun_defs & [fun] = fun_def }) ui_fun_env ui_symbol_heap x_type_code_info ui_var_heap ui_error predef_symbols - + removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int!*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} -> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol}) @@ -923,6 +931,10 @@ removeOverloadedFunctions group type_pattern_vars main_dcl_module_n fun_defs fun = (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) where remove_overloaded_function type_pattern_vars fun_index (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) +// MV ... + # (_,module_id_app,predef_symbols) + = get_module_id_app predef_symbols +// ... MV # (fun_def, fun_defs) = fun_defs![fun_index] (CheckedType st=:{st_context}, fun_env) = fun_env![fun_index] {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb,fun_pos} = fun_def @@ -934,7 +946,10 @@ where (tb_rhs, {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error, ui_x = {x_type_code_info = type_code_info, x_predef_symbols = predef_symbols}}) = updateExpression fun_info.fi_group_index tb_rhs { ui_instance_calls = [], ui_local_vars = fun_info.fi_local_vars, ui_symbol_heap = symbol_heap, ui_var_heap = var_heap, ui_fun_defs = fun_defs, ui_fun_env = fun_env, ui_error = error, - ui_x = {x_type_code_info = type_code_info, x_predef_symbols = predef_symbols,x_main_dcl_module_n=main_dcl_module_n}} +// MV ... + ui_x = {x_type_code_info=type_code_info, x_predef_symbols=predef_symbols,x_main_dcl_module_n=main_dcl_module_n,x_internal_type_id = module_id_app,x_module_id = No}} +// ... MV +// WAS: ui_x = {x_type_code_info=type_code_info, x_predef_symbols=predef_symbols,x_main_dcl_module_n=main_dcl_module_n}} (tb_args, var_heap) = foldSt retrieve_class_argument rev_variables (tb_args, ui_var_heap) fun_def = { fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_arity = length tb_args, fun_info = { fun_info & fi_calls = fun_info.fi_calls ++ ui_instance_calls, fi_local_vars = ui_local_vars } } @@ -1131,6 +1146,10 @@ where { x_type_code_info :: !.TypeCodeInfo , x_predef_symbols :: !.{#PredefinedSymbol} , x_main_dcl_module_n :: !Int +// MV ... + , x_internal_type_id :: Expression + , x_module_id :: Optional LetBind +// ... MV } class updateExpression e :: !Index !e !*UpdateInfo -> (!e, !*UpdateInfo) @@ -1389,8 +1408,28 @@ where # (expr, ui) = adjustClassExpression symb_name expr ui = (Selection opt_type expr selectors, ui) adjustClassExpression symb_name (TypeCodeExpression type_code_expression) ui - = convertTypecode type_code_expression ui +// MV ... + # (type_code,ui) + = convertTypecode type_code_expression ui + = build_type_identification type_code ui +// ... MV where + // MV ... + // identification of types generated by the compiler. If there is no TypeConsSymbol, then + // no identification is necessary. + build_type_identification dyn_type_code ui=:{ui_x={x_module_id=No}} + = (dyn_type_code,ui) + build_type_identification dyn_type_code ui=:{ui_x={x_module_id=Yes let_bind}} + # (let_info_ptr, ui) = let_ptr ui + # letje + = Let { let_strict_binds = [], + let_lazy_binds = [let_bind], + let_expr = dyn_type_code, + let_info_ptr = let_info_ptr, + let_expr_position = NoPos + } + = (letje,ui) + // ... MV convertTypecode TCE_Empty ui = (EE, ui) @@ -1399,13 +1438,48 @@ where convertTypecode (TCE_TypeTerm var_info_ptr) ui=:{ui_var_heap,ui_error} # (var_info_ptr, (ui_var_heap,ui_error)) = getTCDictionary symb_name var_info_ptr (ui_var_heap, ui_error) = (Var {var_name = v_tc_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, { ui & ui_var_heap = ui_var_heap, ui_error = ui_error}) - convertTypecode (TCE_Constructor index typecode_exprs) ui - # (typecons_symb,ui) = getSymbol PD_TypeConsSymbol SK_Constructor 2 ui +// MV ... + convertTypecode (TCE_Constructor index typecode_exprs) ui=:{ui_x={x_internal_type_id}} + # (typecons_symb,ui) = getSymbol PD_TypeConsSymbol SK_Constructor (USE_DummyModuleName 3 2) ui (constructor,ui) = get_constructor index ui (typecode_exprs, ui) = convertTypecodes typecode_exprs ui + # (ui_internal_type_id,ui) + = get_module_id ui = (App {app_symb = typecons_symb, - app_args = [constructor , typecode_exprs ], + app_args = USE_DummyModuleName [constructor , ui_internal_type_id, typecode_exprs] [constructor , typecode_exprs] , app_info_ptr = nilPtr}, ui) + where + get_module_id ui=:{ui_x={x_module_id=Yes {lb_dst}}} + = (Var (freeVarToVar lb_dst),ui) + + get_module_id ui + # (dst=:{var_info_ptr},ui) + = newVariable "module_id" VI_Empty ui + # dst_fv + = varToFreeVar dst 1 + + # let_bind + = { lb_src = x_internal_type_id + , lb_dst = dst_fv + , lb_position = NoPos + } + # ui + = { ui & + ui_local_vars = [ dst_fv : ui.ui_local_vars ] + , ui_x = { ui.ui_x & x_module_id = Yes let_bind} + } + = (Var dst,ui) + + freeVarToVar :: FreeVar -> BoundVar + freeVarToVar {fv_name, fv_info_ptr} + = { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} + + newVariable :: String !VarInfo !*UpdateInfo -> *(!BoundVar,!*UpdateInfo) + newVariable var_name var_info ui=:{ui_var_heap} + # (var_info_ptr, ui_var_heap) = newPtr var_info ui_var_heap + = ( { var_name = {id_name = var_name, id_info = nilPtr}, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, + { ui & ui_var_heap = ui_var_heap }) +// ... MV convertTypecode (TCE_Selector selections var_info_ptr) ui = (Selection No (Var { var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }) selections, ui) convertTypecode (TCE_UniType uni_vars type_code) ui diff --git a/frontend/predef.dcl b/frontend/predef.dcl index 66a5d97..5a431be 100644 --- a/frontend/predef.dcl +++ b/frontend/predef.dcl @@ -86,52 +86,54 @@ PD_unify :== 131 // MV .. PD_coerce :== 132 PD_variablePlaceholder :== 133 -PD_StdDynamics :== 134 +PD_StdDynamic :== 134 PD_undo_indirections :== 135 // MV ... -//PD_ModuleType :== 136 -PD_ModuleConsSymbol :== 137 +PD_TypeID :== 136 +PD_ModuleID :== 137 +PD_ModuleConsSymbol :== 138 // ... MV /* Generics */ -PD_StdGeneric :== 138 -PD_TypeISO :== 139 -PD_ConsISO :== 140 -PD_iso_to :== 141 -PD_iso_from :== 142 - -PD_TypeUNIT :== 143 -PD_ConsUNIT :== 144 -PD_TypeEITHER :== 145 -PD_ConsLEFT :== 146 -PD_ConsRIGHT :== 147 -PD_TypePAIR :== 148 -PD_ConsPAIR :== 149 -PD_TypeARROW :== 150 -PD_ConsARROW :== 151 - -PD_TypeConsDefInfo :== 152 -PD_ConsConsDefInfo :== 153 -PD_TypeTypeDefInfo :== 154 -PD_ConsTypeDefInfo :== 155 -PD_cons_info :== 156 -PD_TypeCONS :== 157 -PD_ConsCONS :== 158 - -PD_isomap_ARROW_ :== 159 -PD_isomap_ID :== 160 +PD_StdGeneric :== 139 +PD_TypeISO :== 140 +PD_ConsISO :== 141 +PD_iso_to :== 142 +PD_iso_from :== 143 + +PD_TypeUNIT :== 144 +PD_ConsUNIT :== 145 +PD_TypeEITHER :== 146 +PD_ConsLEFT :== 147 +PD_ConsRIGHT :== 148 +PD_TypePAIR :== 149 +PD_ConsPAIR :== 150 +PD_TypeARROW :== 151 +PD_ConsARROW :== 152 + +PD_TypeConsDefInfo :== 153 +PD_ConsConsDefInfo :== 154 +PD_TypeTypeDefInfo :== 155 +PD_ConsTypeDefInfo :== 156 +PD_cons_info :== 157 +PD_TypeCONS :== 158 +PD_ConsCONS :== 159 + +PD_isomap_ARROW_ :== 160 +PD_isomap_ID :== 161 /* StdMisc */ -PD_StdMisc :== 161 -PD_abort :== 162 -PD_undef :== 163 +PD_StdMisc :== 162 +PD_abort :== 163 +PD_undef :== 164 -PD_Start :== 164 +PD_Start :== 165 -PD_DummyForStrictAliasFun :== 165 +PD_DummyForStrictAliasFun :== 166 + +PD_NrOfPredefSymbols :== 167 -PD_NrOfPredefSymbols :== 166 GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2 GetTupleTypeIndex tup_arity :== PD_Arity2TupleType + tup_arity - 2 diff --git a/frontend/predef.icl b/frontend/predef.icl index 90becaf..f721497 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -85,52 +85,53 @@ PD_unify :== 131 // MV .. PD_coerce :== 132 PD_variablePlaceholder :== 133 -PD_StdDynamics :== 134 +PD_StdDynamic :== 134 PD_undo_indirections :== 135 // MV ... -//PD_ModuleType :== 136 -PD_ModuleConsSymbol :== 137 +PD_TypeID :== 136 +PD_ModuleID :== 137 +PD_ModuleConsSymbol :== 138 // ... MV /* Generics */ -PD_StdGeneric :== 138 -PD_TypeISO :== 139 -PD_ConsISO :== 140 -PD_iso_to :== 141 -PD_iso_from :== 142 - -PD_TypeUNIT :== 143 -PD_ConsUNIT :== 144 -PD_TypeEITHER :== 145 -PD_ConsLEFT :== 146 -PD_ConsRIGHT :== 147 -PD_TypePAIR :== 148 -PD_ConsPAIR :== 149 -PD_TypeARROW :== 150 -PD_ConsARROW :== 151 - -PD_TypeConsDefInfo :== 152 -PD_ConsConsDefInfo :== 153 -PD_TypeTypeDefInfo :== 154 -PD_ConsTypeDefInfo :== 155 -PD_cons_info :== 156 -PD_TypeCONS :== 157 -PD_ConsCONS :== 158 - -PD_isomap_ARROW_ :== 159 -PD_isomap_ID :== 160 +PD_StdGeneric :== 139 +PD_TypeISO :== 140 +PD_ConsISO :== 141 +PD_iso_to :== 142 +PD_iso_from :== 143 + +PD_TypeUNIT :== 144 +PD_ConsUNIT :== 145 +PD_TypeEITHER :== 146 +PD_ConsLEFT :== 147 +PD_ConsRIGHT :== 148 +PD_TypePAIR :== 149 +PD_ConsPAIR :== 150 +PD_TypeARROW :== 151 +PD_ConsARROW :== 152 + +PD_TypeConsDefInfo :== 153 +PD_ConsConsDefInfo :== 154 +PD_TypeTypeDefInfo :== 155 +PD_ConsTypeDefInfo :== 156 +PD_cons_info :== 157 +PD_TypeCONS :== 158 +PD_ConsCONS :== 159 + +PD_isomap_ARROW_ :== 160 +PD_isomap_ID :== 161 /* StdMisc */ -PD_StdMisc :== 161 -PD_abort :== 162 -PD_undef :== 163 +PD_StdMisc :== 162 +PD_abort :== 163 +PD_undef :== 164 -PD_Start :== 164 +PD_Start :== 165 -PD_DummyForStrictAliasFun :== 165 +PD_DummyForStrictAliasFun :== 166 -PD_NrOfPredefSymbols :== 166 +PD_NrOfPredefSymbols :== 167 (<<=) infixl (<<=) state val @@ -201,12 +202,13 @@ where <<- ("P_laceholder", IC_Expression, PD_variablePlaceholder) <<- ("_unify", IC_Expression, PD_unify) <<- ("_coerce", IC_Expression, PD_coerce) /* MV */ - <<- ("StdDynamic", IC_Module, PD_StdDynamics) + <<- ("_SystemDynamic", IC_Module, PD_StdDynamic) <<- ("_undo_indirections", IC_Expression, PD_undo_indirections) // MV.. <<- ("DynamicTemp", IC_Type, PD_DynamicTemp) -// <<- ("Module", IC_Type, PD_ModuleType) <<- ("__Module", IC_Expression, PD_ModuleConsSymbol) + <<- ("T_ypeID", IC_Type, PD_TypeID) + <<- ("ModuleID", IC_Expression, PD_ModuleID) // ..MV // AA.. diff --git a/frontend/type_io_common.dcl b/frontend/type_io_common.dcl index ef22a29..032f9a1 100644 --- a/frontend/type_io_common.dcl +++ b/frontend/type_io_common.dcl @@ -43,3 +43,6 @@ BT_StringCode :== (toChar 24) ConsVariableCVCode :== (toChar 25) ConsVariableTempCVCode :== (toChar 26) ConsVariableTempQCVCode :== (toChar 27) + +// used by {compiler,dynamic rts} +PredefinedModuleName :== "_predefined"
\ No newline at end of file diff --git a/frontend/type_io_common.icl b/frontend/type_io_common.icl index 209dc2d..1782b95 100644 --- a/frontend/type_io_common.icl +++ b/frontend/type_io_common.icl @@ -44,3 +44,6 @@ BT_StringCode :== (toChar 24) ConsVariableCVCode :== (toChar 25) ConsVariableTempCVCode :== (toChar 26) ConsVariableTempQCVCode :== (toChar 27) + +// used by {compiler,dynamic rts} +PredefinedModuleName :== "_predefined"
\ No newline at end of file |