Commit 2c487bd0 authored by Martijn Vervoort's avatar Martijn Vervoort

bug fixes, ModuleID argument in T_ypeConsSymbol, added _SystemDynamic

parent 73233a80
......@@ -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]
......
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
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
......@@ -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)
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
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......