implementation module convertDynamics import syntax, transform, utilities, convertcases // Optional USE_TUPLES tuple b :== b; // change also StdDynamic.icl and recompile all applications APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES yes no :== no import type_io; :: *ConversionInfo = { ci_predef_symb :: !*PredefinedSymbols , ci_var_heap :: !*VarHeap , ci_expr_heap :: !*ExpressionHeap , ci_new_variables :: ![FreeVar] , ci_new_functions :: ![FunctionInfoPtr] , ci_fun_heap :: !*FunctionHeap , ci_next_fun_nr :: !Index // data needed to generate coercions , ci_placeholders_and_tc_args :: [(!BoundVar,Ptr VarInfo)] , ci_generated_global_tc_placeholders :: !Bool , ci_used_tcs :: [Ptr VarInfo] , ci_symb_ident :: SymbIdent , ci_sel_type_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol)) , ci_sel_value_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol)) } :: ConversionInput = { cinp_glob_type_inst :: !{! GlobalTCType} , cinp_group_index :: !Int , cinp_st_args :: ![FreeVar] } :: OpenedDynamic = { opened_dynamic_expr :: Expression , opened_dynamic_type :: Expression } :: DefaultExpression :== Optional (BoundVar, [IndirectionVar]) //DefaultRecord :: BoundVariables :== [TypedVariable] :: IndirectionVar :== BoundVar pl [] = "" pl [x:xs] = x +++ " , " +++ (pl xs) F :: !a .b -> .b F a b = b //write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File) write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] !*TypeHeaps -> (.Bool,.File,!*TypeHeaps) write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules type_heaps # write_type_info_state2 = { WriteTypeInfoState | wtis_type_heaps = type_heaps , wtis_n_type_vars = 0 }; # (j,tcl_file) = fposition tcl_file // | True // = abort ("TypeVar " +++ toString j) #! (tcl_file,write_type_info_state) = write_type_info common_defs tcl_file write_type_info_state2 #! (tcl_file,write_type_info_state) = write_type_info directly_imported_dcl_modules tcl_file write_type_info_state #! (type_heaps,_) = f write_type_info_state //!type_heaps; #! tcl_file = fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file #! tcl_file = fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file = (True,tcl_file,type_heaps) where f write_type_info_state=:{wtis_type_heaps} = (wtis_type_heaps,{write_type_info_state & wtis_type_heaps = abort "convertDynamics.icl"}); //---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs); convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String] -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File)) convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules // TD ... # (tcl_file,type_heaps) = case tcl_file of No -> (No,type_heaps) (Yes tcl_file) # (ok,tcl_file,type_heaps) = write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules type_heaps | not ok -> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file" -> (Yes tcl_file,type_heaps) // ... TD # ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamics] #! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols) = case (pds_module == (-1) || pds_def == (-1)) of True -> (undef,undef,undef,predefined_symbols) _ -> case (USE_TUPLES True False) /*(pds_module == (-1) || pds_def == (-1))*/ of True # arity = 2 // get tuple arity 2 constructor # ({pds_module, pds_def, pds_ident}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity] # twoTuple_symb = { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity } // get tuple, type and value selectors # ({pds_def, pds_ident}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity] # twotuple = {ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def} # type_selector = TupleSelect twotuple 1 # value_selector = TupleSelect twotuple 0 -> (twoTuple_symb,value_selector,type_selector,predefined_symbols) False # arity = 2 # ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_DynamicTemp] # {td_rhs=RecordType {rt_constructor,rt_fields}} = common_defs.[pds_module1].com_type_defs.[pds_def1] # dynamic_temp_symb_ident = { SymbIdent | symb_name = rt_constructor.ds_ident , symb_kind = SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index} , symb_arity = rt_constructor.ds_arity } // type field # ({pds_module=pds_module2, pds_def=pds_def2} , predefined_symbols) = predefined_symbols![PD_DynamicType] # {sd_field,sd_field_nr} = common_defs.[pds_module2].com_selector_defs.[pds_def2] #! type_defined_symbol = { Global | glob_object = { DefinedSymbol | ds_ident = sd_field , ds_arity = 0 , ds_index = pds_def2 } , glob_module = pds_module2 } #! ci_sel_type_field = (\dynamic_expr -> Selection No dynamic_expr [RecordSelection type_defined_symbol sd_field_nr]) // value field # ({pds_module=pds_module3, pds_def=pds_def3} , predefined_symbols) = predefined_symbols![PD_DynamicValue] # {sd_field=sd_field3,sd_field_nr=sd_field_nr3} = common_defs.[pds_module3].com_selector_defs.[pds_def3] #! value_defined_symbol = { Global | glob_object = { DefinedSymbol | ds_ident = sd_field3 , ds_arity = 0 , ds_index = pds_def3 } , glob_module = pds_module3 } #! ci_sel_value_field = (\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) #! nr_of_funs = size fun_defs # imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs } # (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_fun_heap, ci_new_functions})) = convert_groups 0 groups global_type_instances (fun_defs, { ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap, 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 }) (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) where convert_groups group_nr groups global_type_instances fun_defs_and_ci | group_nr == size groups = (groups, fun_defs_and_ci) # (group, groups) = groups![group_nr] = convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci) convert_function group_nr global_type_instances fun (fun_defs, ci) # (fun_def, fun_defs) = fun_defs![fun] {fun_body, fun_type, fun_info} = fun_def | isEmpty fun_info.fi_dynamics = (fun_defs, ci) # ci = { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False } # (fun_body, ci) = convert_dynamics_in_body {cinp_st_args = [], cinp_glob_type_inst = global_type_instances, cinp_group_index = group_nr} fun_body fun_type ci = ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}}, { ci & ci_new_variables = [] }) // MV .. convert_dynamics_in_body global_type_instances (TransformedBody {tb_args,tb_rhs}) (Yes {st_context, st_args}) ci # vars_with_types = bindVarsToTypes2 st_context tb_args st_args [] common_defs // .. MV (tb_rhs, ci) = convertDynamics {global_type_instances & cinp_st_args = tb_args} vars_with_types No tb_rhs ci = (TransformedBody {tb_args = tb_args,tb_rhs = tb_rhs}, ci) convert_dynamics_in_body global_type_instances other fun_type ci = abort "unexpected value in 'convert dynamics.convert_dynamics_in_body'" // MV .. bindVarsToTypes2 st_context vars types typed_vars common_defs :== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars // .. MV bindVarsToTypes vars types typed_vars = fold2St bind_var_to_type vars types typed_vars where bind_var_to_type var type typed_vars = [{tv_free_var = var, tv_type = type } : typed_vars] class convertDynamics a :: !ConversionInput !BoundVariables !DefaultExpression !a !*ConversionInfo -> (!a, !*ConversionInfo) instance convertDynamics [a] | convertDynamics a where convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression ![a] !*ConversionInfo -> (![a], !*ConversionInfo) | convertDynamics a convertDynamics cinp bound_vars default_expr xs ci = mapSt (convertDynamics cinp bound_vars default_expr) xs ci instance convertDynamics (Optional a) | convertDynamics a where convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Optional a) !*ConversionInfo -> (!Optional a, !*ConversionInfo) | convertDynamics a convertDynamics cinp bound_vars default_expr (Yes x) ci # (x, ci) = convertDynamics cinp bound_vars default_expr x ci = (Yes x, ci) convertDynamics _ _ _ No ci = (No, ci) instance convertDynamics LetBind where convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !LetBind !*ConversionInfo -> (!LetBind, !*ConversionInfo) convertDynamics cinp bound_vars default_expr binding=:{lb_src} ci # (lb_src, ci) = convertDynamics cinp bound_vars default_expr lb_src ci = ({binding & lb_src = lb_src}, ci) instance convertDynamics (Bind a b) | convertDynamics a where convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Bind a b) !*ConversionInfo -> (!Bind a b, !*ConversionInfo) | convertDynamics a convertDynamics cinp bound_vars default_expr binding=:{bind_src} ci # (bind_src, ci) = convertDynamics cinp bound_vars default_expr bind_src ci = ({binding & bind_src = bind_src}, ci) convertDynamicsOfAlgebraicPattern :: !ConversionInput !BoundVariables !DefaultExpression !(!AlgebraicPattern,[AType]) !*ConversionInfo -> (!AlgebraicPattern,!*ConversionInfo) convertDynamicsOfAlgebraicPattern cinp bound_vars default_expr (algebraic_pattern=:{ap_vars, ap_expr}, arg_types_of_conses) ci # (ap_expr, ci) = convertDynamics cinp (bindVarsToTypes ap_vars arg_types_of_conses bound_vars) default_expr ap_expr ci = ({algebraic_pattern & ap_expr = ap_expr}, ci) instance convertDynamics BasicPattern where convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !BasicPattern !*ConversionInfo -> (!BasicPattern, !*ConversionInfo) convertDynamics cinp bound_vars default_expr basic_pattern=:{bp_expr} ci # (bp_expr, ci) = convertDynamics cinp bound_vars default_expr bp_expr ci = ({basic_pattern & bp_expr = bp_expr}, ci) instance convertDynamics Expression where convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !Expression !*ConversionInfo -> (!Expression, !*ConversionInfo) convertDynamics cinp bound_vars default_expr (Var var) ci = (Var var, ci) convertDynamics cinp bound_vars default_expr (App appje=:{app_args}) ci # (app_args,ci) = convertDynamics cinp bound_vars default_expr app_args ci = (App {appje & app_args = app_args}, ci) convertDynamics cinp bound_vars default_expr (expr @ exprs) ci # (expr, ci) = convertDynamics cinp bound_vars default_expr expr ci (exprs, ci) = convertDynamics cinp bound_vars default_expr exprs ci = (expr @ exprs, ci) convertDynamics cinp bound_vars default_expr (Let letje=:{let_strict_binds, let_lazy_binds, let_expr,let_info_ptr}) ci # (let_types, ci) = determine_let_types let_info_ptr ci // MW0 bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars bound_vars = bindVarsToTypes [ bind.lb_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars (let_strict_binds, ci) = convertDynamics cinp bound_vars default_expr let_strict_binds ci (let_lazy_binds, ci) = convertDynamics cinp bound_vars default_expr let_lazy_binds ci (let_expr, ci) = convertDynamics cinp bound_vars default_expr let_expr ci = (Let { letje & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr}, ci) where determine_let_types let_info_ptr ci=:{ci_expr_heap} # (EI_LetType let_types, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap = (let_types, { ci & ci_expr_heap = ci_expr_heap }) convertDynamics cinp bound_vars default_expr (Case keesje=:{case_expr, case_guards, case_default, case_info_ptr}) ci # (case_expr, ci) = convertDynamics cinp bound_vars default_expr case_expr ci (case_default, ci) = convertDynamics cinp bound_vars default_expr case_default ci (this_case_default, nested_case_default, ci) = determine_defaults case_default default_expr ci (EI_CaseType {ct_cons_types, ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap ci = { ci & ci_expr_heap = ci_expr_heap } = case case_guards of (AlgebraicPatterns type algebraic_patterns) # (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default) (zip2 algebraic_patterns ct_cons_types) ci -> (Case {keesje & case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = this_case_default}, ci) (BasicPatterns type basic_patterns) # (basic_patterns, ci) = convertDynamics cinp bound_vars nested_case_default basic_patterns ci -> (Case {keesje & case_expr = case_expr, case_guards = BasicPatterns type basic_patterns, case_default = this_case_default}, ci) (DynamicPatterns dynamic_patterns) # keesje = {keesje & case_expr = case_expr, case_default = this_case_default} -> convertDynamicPatterns cinp bound_vars keesje ci NoPattern -> (Case {keesje & case_expr = case_expr, case_guards = NoPattern, case_default = this_case_default}, ci) _ -> abort "unexpected value in convertDynamics: 'convertDynamics.CasePatterns'" convertDynamics cinp bound_vars default_expr (Selection opt_symb expression selections) ci # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci = (Selection opt_symb expression selections, ci) convertDynamics cinp bound_vars default_expr (Update expression1 selections expression2) ci # (expression1,ci) = convertDynamics cinp bound_vars default_expr expression1 ci # (expression2,ci) = convertDynamics cinp bound_vars default_expr expression2 ci = (Update expression1 selections expression2, ci) convertDynamics cinp bound_vars default_expr (RecordUpdate cons_symbol expression expressions) ci # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci # (expressions,ci) = convertDynamics cinp bound_vars default_expr expressions ci = (RecordUpdate cons_symbol expression expressions, ci) convertDynamics cinp bound_vars default_expr (TupleSelect definedSymbol int expression) ci # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci = (TupleSelect definedSymbol int expression, ci) convertDynamics _ _ _ (BasicExpr basicValue basicType) ci = (BasicExpr basicValue basicType, ci) convertDynamics _ _ _ (AnyCodeExpr codeBinding1 codeBinding2 strings) ci = (AnyCodeExpr codeBinding1 codeBinding2 strings, ci) convertDynamics _ _ _ (ABCCodeExpr strings bool) ci = (ABCCodeExpr strings bool, ci) convertDynamics cinp bound_vars default_expr (MatchExpr opt_symb symb expression) ci # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci = (MatchExpr opt_symb symb expression, ci) convertDynamics cinp bound_vars default_expr (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_uni_vars, dyn_type_code}) ci=:{ci_symb_ident} // # (twoTuple_symb, ci) = getSymbol (GetTupleConsIndex 2) SK_Constructor 2 ci # (let_binds, ci) = createVariables dyn_uni_vars [] ci (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) = convertTypecode cinp dyn_type_code ci = case let_binds of [] -> (App { app_symb = ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident, //twoTuple_symb, app_args = [dyn_expr, dyn_type_code], app_info_ptr = nilPtr }, ci) _ # (let_info_ptr, ci) = let_ptr ci -> ( Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = App { app_symb = ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident, app_args = [dyn_expr, dyn_type_code], app_info_ptr = nilPtr }, // MW0 let_info_ptr = let_info_ptr,}, ci) let_info_ptr = let_info_ptr, let_expr_position = NoPos}, ci) convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci = abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci convertDynamics cinp bound_vars default_expr EE ci = (EE, ci) convertDynamics cinp bound_vars default_expr expression ci = abort "unexpected value in convertDynamics: 'convertDynamics.Expression'" //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 type to their placeholders. Return is a list of (placeholder,argument) list. Each tuple is used later as arguments to the coerce relation. This should be optional */ // ci_placeholders_and_tc_args convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci #! cinp_st_args = filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args | isEmpty cinp_st_args #! (e,binds,placeholders_and_tc_args,ci) = convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci = (False,e,binds,placeholders_and_tc_args,ci) /* ** the TCE_VAR is a TC argument and it is not part of a larger type expression. It ** later suffices to generate a coerce instead of an application. This is an ** optimization. */ = (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci) convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci #! cinp_st_args = filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args | isEmpty cinp_st_args #! (e,binds,placeholders_and_tc_args,ci) = convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci = (False,e,binds,placeholders_and_tc_args,ci) /* ** the TCE_VAR is a TC argument and it is not part of a larger type expression. It ** later suffices to generate a coerce instead of an application. This is an ** optimization. */ = (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci) // = convertTypecode2 cinp t replace_tc_args binds placeholders_and_tc_args ci convertTypecode2 cinp t replace_tc_args binds placeholders_and_tc_args ci #! (e,binds,placeholders_and_tc_args,ci) = convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci = (False,e,binds,placeholders_and_tc_args,ci) convertTypecode cinp TCE_Empty replace_tc_args binds placeholders_and_tc_args ci = (EE,binds,placeholders_and_tc_args,ci) convertTypecode cinp=:{cinp_st_args} (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci=:{ci_placeholders_and_tc_args,ci_var_heap} | not replace_tc_args = (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci) // check if tc_arg has already been replaced by a placeholder #! ci_placeholder_and_tc_arg = filter (\(_,tc_args_ptr) -> tc_args_ptr == var_info_ptr) ci_placeholders_and_tc_args | not (isEmpty ci_placeholder_and_tc_arg) // an tc-arg has been found, add to the list of indirections to be restored and replace it by its placeholder #! placeholder_var = (fst (hd ci_placeholder_and_tc_arg)); #! ci_var_heap = adjust_ref_count placeholder_var.var_info_ptr ci.ci_var_heap = (Var {var_name = v_tc_placeholder_ident, var_info_ptr = placeholder_var.var_info_ptr, var_expr_ptr = nilPtr},binds, [(placeholder_var/*.var_info_ptr*/,var_info_ptr):placeholders_and_tc_args],{ci & ci_var_heap = ci_var_heap} ); //placeholders_and_tc_args, ci) = (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci) where adjust_ref_count var_info_ptr var_heap # (VI_Indirection ref_count, var_heap) = readPtr var_info_ptr var_heap = var_heap <:= (var_info_ptr, VI_Indirection (inc ref_count)) // 1st component of tuple is true iff: // 1. The type is a TCE_Var or TCE_TypeTerm // 2. It is also a argument of the function // Thus a tc argument variable. // This forms a special case: instead of an unify, a coerce can be generated convertTypecode cinp (TCE_TypeTerm var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci /* ** TCE_Var and TCE_TypeTerm are not equivalent. A TCE_TypeTerm is used for an argument which contains ** a type representation. A TCE_Var is an existential quantified type variable. In previous phases no ** clear distinction is made. It should be possible to generate the proper type code expression for ** these two but it would involve changing a lot of small things. */ = 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 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 = (App {app_symb = typecons_symb, app_args = [constructor , typecode_exprs], app_info_ptr = nilPtr},binds,placeholders_and_tc_args,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) = convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci = (Selection No var selections,binds,placeholders_and_tc_args,ci) //convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo -> (Expression,!*ConversionInfo) convertTypecodes _ [] replace_tc_args binds placeholders_and_tc_args ci # (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci = (App { app_symb = nil_symb, app_args = [], app_info_ptr = nilPtr},binds,placeholders_and_tc_args, ci) convertTypecodes cinp [typecode_expr : typecode_exprs] replace_tc_args binds placeholders_and_tc_args ci # (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci # (expr,binds,placeholders_and_tc_args, ci) = convertTypecode cinp typecode_expr replace_tc_args binds placeholders_and_tc_args ci # (exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci = (App { app_symb = cons_symb, app_args = [expr , exprs], app_info_ptr = nilPtr}, binds,placeholders_and_tc_args, ci) determine_defaults :: (Optional Expression) DefaultExpression !*ConversionInfo -> (Optional Expression, DefaultExpression, !*ConversionInfo) /*** determine_defaults :: case_default default_expr varheap -> (this_case_default, nested_case_default, var_heap) this_case_default = IF this case has no default, but there is a surrounding default THEN that is now the default and its reference count must be increased. ELSE it keeps this default nested_case_default = IF this case has no default THEN the default_expr remains default in the nested cases. ELSE nested cases get this default. This is semantically already the case, so nothing has to be changed. ***/ // the case itself has no default but it has a surrounding default /* 1st = default of current case 2nd = directly surrounding default */ determine_defaults No default_expr=:(Yes (var=:{var_info_ptr}, indirection_var_list)) ci=:{ci_var_heap} #! var_info = sreadPtr var_info_ptr ci_var_heap # (expression, ci) = toExpression default_expr {ci & ci_var_heap = ci_var_heap} # expression = expression// ---> expression = case var_info of VI_Default ref_count -> (expression, default_expr, {ci & ci_var_heap = ci.ci_var_heap <:= (var_info_ptr, VI_Default (inc ref_count))} ) _ -> (expression, default_expr, ci ) determine_defaults case_default _ ci = (case_default, No, ci) add_dynamic_bound_vars :: ![DynamicPattern] BoundVariables -> BoundVariables add_dynamic_bound_vars [] bound_vars = bound_vars add_dynamic_bound_vars [{dp_var, dp_type_patterns_vars} : patterns] bound_vars = add_dynamic_bound_vars patterns (foldSt bind_info_ptr dp_type_patterns_vars [ {tv_free_var = dp_var, tv_type = empty_attributed_type } : bound_vars ]) where bind_info_ptr var_info_ptr bound_vars = [{ tv_free_var = {fv_def_level = NotALevel, fv_name = a_ij_var_name, fv_info_ptr = var_info_ptr, fv_count = 0}, tv_type = empty_attributed_type } : bound_vars] open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo) open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field} # (twotuple, ci) = getTupleSymbol 2 ci (dynamicType_var, ci) = newVariable "dt" VI_Empty ci dynamicType_fv = varToFreeVar dynamicType_var 1 // sel_type = Selection No dynamic_expr [RecordSelection type_defined_symbol sd_type_field_nr] // sel_value = Selection No dynamic_expr [RecordSelection value_defined_symbol sd_value_field_nr] = ( { opened_dynamic_expr = ci_sel_value_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 0 dynamic_expr) sel_value*/, opened_dynamic_type = Var dynamicType_var }, // RecordSelection !(Global DefinedSymbol) !Int // MW0 { bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv }, { lb_src = ci_sel_type_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 1 dynamic_expr) sel_type*/, lb_dst = dynamicType_fv, lb_position = NoPos }, { ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]}) /**************************************************************************************************/ convertDynamicPatterns :: !ConversionInput !BoundVariables !Case *ConversionInfo -> (Expression, *ConversionInfo) convertDynamicPatterns cinp bound_vars {case_guards = DynamicPatterns [], case_default} ci = case case_default of (Yes expr) -> (expr, ci) No -> abort "unexpected value in convertDynamics: 'convertDynamicPatterns'" convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards = DynamicPatterns patterns, case_default, case_info_ptr} ci=:{ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args,ci_generated_global_tc_placeholders} # (opened_dynamic, dt_bind, ci) = open_dynamic case_expr ci (ind_0, ci) = newVariable "ind_0" (VI_Indirection 0) ci (c_1, ci) = newVariable "c_1!" (VI_Default 0) ci new_default = newDefault c_1 ind_0 (result_type, ci) = getResultType case_info_ptr ci #! // TC PLACEHOLDERS... (tc_binds,(bound_vars,ci)) = case ci_generated_global_tc_placeholders of True -> ([],(bound_vars,ci)) _ #! (tc_binds,(bound_vars,ci)) = mapSt f cinp_st_args (bound_vars,ci) #! ci = { ci & ci_generated_global_tc_placeholders = True} -> (tc_binds,(bound_vars,ci)) // ...TC PLACEHOLDERS # // MW0 bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type bound_vars = addToBoundVars (freeVarToVar dt_bind.lb_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars))) // c_1 ind_0 (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci (let_info_ptr, ci) = let_ptr ci # ci = { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args} # (tc_binds,ci) = foldSt remove_non_used_arg tc_binds ([],ci) // MW0 = (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci) = (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ci) where // MW0 remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo) remove_non_used_arg :: LetBind ([LetBind],*ConversionInfo) -> ([LetBind],*ConversionInfo) remove_non_used_arg tc_bind=:{lb_dst={fv_info_ptr}} (l,ci=:{ci_var_heap}) # (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap | ref_count > 0 #! tc_bind = { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} } = ([tc_bind:l],{ci & ci_var_heap = ci_var_heap}) = (l,{ci & ci_var_heap = ci_var_heap}) // too many new variables are created because also non-tc args are included; should be improved in the future f st_arg (bound_vars,ci=:{ci_placeholders_and_tc_args}) // create placeholder variable for arg #! v = VI_Indirection 0 #! (placeholder_var, ci) = newVariable v_tc_placeholder v ci //---> st_arg #! (bind,ci) = create_variable v_tc_placeholder_ident_global placeholder_var.var_info_ptr ci // associate newly create placeholder variable with its tc #! ci = { ci & ci_placeholders_and_tc_args = [(placeholder_var,st_arg.fv_info_ptr):ci_placeholders_and_tc_args] } #! bound_vars2 = addToBoundVars placeholder_var empty_attributed_type bound_vars = (bind,(bound_vars2,ci)); where // MW0 create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo) create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo) create_variable var_name var_info_ptr ci # (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} cyclic_fv = varToFreeVar cyclic_var 1 // MW0 = ({ bind_src = App { app_symb = placeholder_symb, = ({ lb_src = App { app_symb = placeholder_symb, app_args = [Var cyclic_var, Var cyclic_var], app_info_ptr = nilPtr }, // MW0 bind_dst = varToFreeVar cyclic_var 1 lb_dst = varToFreeVar cyclic_var 1, lb_position = NoPos }, { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/) add_coercions [] _ _ bound_vars dp_rhs ci = (bound_vars,dp_rhs,ci) add_coercions [({var_info_ptr=a_ij},a_ij_tc):rest] this_default q bound_vars dp_rhs ci // extra # a_ij_var = {var_name = a_ij_var_name, var_info_ptr = a_ij, var_expr_ptr = nilPtr} # a_ij_tc_var = {var_name = a_aij_tc_var_name, var_info_ptr = a_ij_tc, var_expr_ptr = nilPtr} // indirections # (ind_i, ci) = newVariable "ind_1" (VI_Indirection (if (isNo this_default) 0 1)) ci (c_inc_i, ci) = newVariable "c_!" (VI_Indirection 1) ci new_default = newDefault c_inc_i ind_i # (coerce_symb, ci) = getSymbol PD_coerce SK_Function 2 ci (twotuple, ci) = getTupleSymbol 2 ci (let_info_ptr, ci) = let_ptr ci (case_info_ptr, ci) = case_ptr ci (coerce_result_var, ci) = newVariable "result" VI_Empty ci coerce_result_fv = varToFreeVar coerce_result_var 1 (coerce_bool_var, ci) = newVariable "coerce_bool" VI_Empty ci coerce_bool_fv = varToFreeVar coerce_bool_var 1 # (let_binds, ci) = bind_indirection_var ind_i coerce_result_var twotuple ci ind_i_fv = varToFreeVar ind_i 1 c_inc_i_fv = varToFreeVar c_inc_i 1 ci = { ci & ci_new_variables = [ c_inc_i_fv,ind_i_fv : ci.ci_new_variables ] } #! new_default2 = newDefault c_inc_i ind_i # (default_expr, ci) = case (isNo this_default) of False -> toExpression new_default2 ci True -> (No,ci) // extra # (bound_vars,new_dp_rhs,ci) = add_coercions rest (if (isNo this_default) No new_default2) q bound_vars dp_rhs ci #! (opt_expr,ci) = toExpression this_default ci # let_expr = Let { let_strict_binds = [] // MW0 , let_lazy_binds = (if (isNo this_default) [] [ {bind_src = opt opt_expr , bind_dst = c_inc_i_fv }]) ++ [ // MW0 { bind_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr }, // MW0 bind_dst = coerce_result_fv } , let_lazy_binds = (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [ { lb_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr }, lb_dst = coerce_result_fv, lb_position = NoPos } , // MW0 { bind_src = TupleSelect twotuple 0 (Var coerce_result_var), // MW0 bind_dst = coerce_bool_fv } : let_binds { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var coerce_result_var) /*) sel_type*/, lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds ], let_expr = Case { case_expr = Var coerce_bool_var, // MW was: case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}], case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = new_dp_rhs, bp_position = NoPos }], case_default = default_expr, case_ident = No, case_info_ptr = case_info_ptr, case_default_pos= NoPos } // MW4++ , let_info_ptr = let_info_ptr , let_expr_position = NoPos // MW0++ } // dp_rhs = (bound_vars,let_expr,{ ci & ci_new_variables = [coerce_result_fv, coerce_bool_fv : ci.ci_new_variables]}) //let_expr,ci) where opt (Yes x) = x convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo /// MW0 -> (Env Expression FreeVar, Expression, *ConversionInfo) -> ([LetBind], Expression, *ConversionInfo) convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default [{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci # /*** The last case may not have a default ***/ ind_var = getIndirectionVar this_default this_default = if (isEmpty patterns && (isNo last_default)) No this_default /*** 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 // collect ... # (is_last_dynamic_pattern,dp_rhs) = isLastDynamicPattern dp_rhs; # ci = foldSt add_tcs martijn ci // ... collect # // walks through the patterns of the next alternative (dp_rhs, ci) = convertDynamics cinp bound_vars this_default dp_rhs ci // collect ... #! (ci_old_used_tcs,ci) = ci!ci_used_tcs; # ci = { ci & ci_used_tcs = [] } // ... collect /*** recursively convert the other patterns in the other alternatives ***/ #! (binds, ci) = convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci // collect ... # ci = { ci & ci_used_tcs = ci_old_used_tcs } # ci_used_tcs = ci_old_used_tcs #! (dp_rhs,ci) = case ((is_last_dynamic_pattern) /*&& (not generate_coerce)*/) of True // last dynamic pattern of the group of dynamic pattern so coercions must be generated. #! (ci_placeholders_and_tc_args,ci) = ci!ci_placeholders_and_tc_args #! used_ci_placeholders_and_tc_args = filter (\(_,ci_placeholders_and_tc_arg) -> isMember ci_placeholders_and_tc_arg ci_used_tcs) ci_placeholders_and_tc_args #! (bound_vars,dp_rhs,ci) = add_coercions used_ci_placeholders_and_tc_args this_default binds bound_vars dp_rhs ci -> (dp_rhs,ci) False -> (dp_rhs,ci) // ... collect # /*** generate the expression ***/ (unify_symb, ci) = getSymbol (if generate_coerce PD_coerce PD_unify ) SK_Function 2 ci (twotuple, ci) = getTupleSymbol 2 ci (let_info_ptr, ci) = let_ptr ci (case_info_ptr, ci) = case_ptr ci (default_expr, ci) = toExpression this_default ci // was coercions (unify_result_var, ci) = newVariable "result" VI_Empty ci unify_result_fv = varToFreeVar unify_result_var 1 (unify_bool_var, ci) = newVariable (if generate_coerce "coerce_bool" "unify_bool") VI_Empty ci unify_bool_fv = varToFreeVar unify_bool_var 1 (let_binds, ci) = bind_indirection_var ind_var unify_result_var twotuple ci a_ij_binds = add_x_i_bind opened_dynamic.opened_dynamic_expr dp_var a_ij_binds // sel_type = Selection No (Var unify_result_var) [RecordSelection type_defined_symbol sd_type_field_nr] let_expr = Let { let_strict_binds = [], // MW0 let_lazy_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr }, // MW0 bind_dst = unify_result_fv }, // MW0 { bind_src = TupleSelect twotuple 0 (Var unify_result_var), // MW0 bind_dst = unify_bool_fv } : let_binds let_lazy_binds = [{ lb_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr }, lb_dst = unify_result_fv, lb_position = NoPos }, { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var unify_result_var) /*) sel_type*/, lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds ], let_expr = Case { case_expr = Var unify_bool_var, // MW was: case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}], case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }], case_default = default_expr, case_ident = No, case_info_ptr = case_info_ptr, case_default_pos= NoPos }, // MW4++ // MW0 let_info_ptr = let_info_ptr } let_info_ptr = let_info_ptr, let_expr_position = NoPos } = (a_ij_binds ++ binds, let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]}) where // MW0 add_x_i_bind bind_src bind_dst=:{fv_count} binds add_x_i_bind lb_src lb_dst=:{fv_count} binds | fv_count > 0 // MW0 = [ { bind_src = bind_src, bind_dst = bind_dst } : binds ] = [ { lb_src = lb_src, lb_dst = lb_dst, lb_position = NoPos } : binds ] = binds isLastDynamicPattern dp_rhs=:(Case keesje=:{case_guards=DynamicPatterns _}) = (False,dp_rhs); isLastDynamicPattern dp_rhs = (True,dp_rhs); add_tcs (_,tc) ci=:{ci_used_tcs} | isMember tc ci_used_tcs = ci; = {ci & ci_used_tcs = [tc:ci_used_tcs]} // other alternatives convert_other_patterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo // MW0 -> (Env Expression FreeVar, *ConversionInfo) -> ([LetBind], *ConversionInfo) convert_other_patterns _ _ _ _ _ _ No [] ci // no default and no alternatives left = ([], ci) // The last_default is the default used when there are no pattern left convert_other_patterns cinp bound_vars this_default _ _ result_type (Yes last_default_expr) [] ci // default without alternatives left # c_i = getVariable1 this_default (c_bind, ci) = generateBinding cinp bound_vars c_i last_default_expr result_type ci = ([c_bind], ci) convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci # (ind_i, ci) = newVariable ("ind_"+++toString (pattern_number)) (VI_Indirection 0) ci (c_inc_i, ci) = newVariable ("c_"+++toString (inc pattern_number)) (VI_Default 0) ci new_default = newDefault c_inc_i ind_i bound_vars = addToBoundVars ind_i empty_attributed_type (addToBoundVars c_inc_i result_type bound_vars) (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default (inc pattern_number) opened_dynamic result_type last_default patterns ci c_i = getVariable2 this_default (c_bind, ci) = generateBinding cinp bound_vars c_i expr result_type ci = ([c_bind: binds], ci) bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_heap,ci_new_variables} # (VI_Indirection ref_count, ci_var_heap) = readPtr var_info_ptr ci_var_heap | ref_count > 0 # ind_fv = varToFreeVar var ref_count // MW0 = ([{ bind_src = TupleSelect twotuple 1 (Var unify_result_var), bind_dst = ind_fv }], // sel_value = Selection No (Var unify_result_var) [RecordSelection value_defined_symbol sd_value_field_nr] = ([{ lb_src = /*USE_TUPLES (*/TupleSelect twotuple 1 (Var unify_result_var) /*) sel_value*/, lb_dst = ind_fv, lb_position = NoPos }], { ci & ci_var_heap = ci_var_heap, ci_new_variables = [ ind_fv : ci_new_variables ]}) = ([], {ci & ci_var_heap = ci_var_heap}) /* As input an alternative c_i and its associated expression which together form the default expression. If the reference count is zero then there exists only one reference to that expression. In case of multiple references to the expression: it is converted into a function. The references are replaced by an appropriate function application. */ // MW0 generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(Bind Expression FreeVar, *ConversionInfo) generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(LetBind, *ConversionInfo) generateBinding cinp bound_vars var bind_expr result_type ci # (ref_count, ci) = get_reference_count var ci | ref_count == 0 # free_var = varToFreeVar var 1 // MW0 = ({ bind_src = bind_expr, bind_dst = free_var }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]}) = ({ lb_src = bind_expr, lb_dst = free_var, lb_position = NoPos }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]}) # (saved_defaults, ci_var_heap) = foldSt save_default bound_vars ([], ci.ci_var_heap) (act_args, free_typed_vars, local_free_vars, tb_rhs, ci_var_heap) = copyExpression bound_vars bind_expr ci_var_heap # (ci_new_variables, ci_var_heap) = foldSt remove_local_var ci.ci_new_variables ([], ci_var_heap) ci_var_heap = foldSt restore_default saved_defaults ci_var_heap tb_args = [ ftv.tv_free_var \\ ftv <- free_typed_vars ] arg_types = [ ftv.tv_type \\ ftv <- free_typed_vars ] (fun_symb, (ci_next_fun_nr, ci_new_functions, ci_fun_heap)) = newFunction No (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}) local_free_vars arg_types result_type cinp.cinp_group_index (ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap) free_var = varToFreeVar var (inc ref_count) // MW0 = ({ bind_src = App { app_symb = fun_symb, = ({ lb_src = App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr }, // MW0 bind_dst = free_var }, lb_dst = free_var, lb_position = NoPos }, { ci & ci_var_heap = ci_var_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions, ci_fun_heap = ci_fun_heap, ci_new_variables = [ free_var : ci_new_variables ] }) where get_reference_count {var_name,var_info_ptr} ci=:{ci_var_heap} # (info, ci_var_heap) = readPtr var_info_ptr ci_var_heap ci = { ci & ci_var_heap = ci_var_heap } = case info of VI_Default ref_count -> (ref_count, ci) // _ -> (0, ci) ---> ("get_reference_count", var_name) /* A predicted variable always has a ref_count */ save_default {tv_free_var={fv_info_ptr}} (saved_defaults, ci_var_heap) # (info, ci_var_heap) = readPtr fv_info_ptr ci_var_heap = case info of VI_Default ref_count -> ([(fv_info_ptr, info) : saved_defaults] , ci_var_heap) VI_Indirection ref_count -> ([(fv_info_ptr, info) : saved_defaults] , ci_var_heap) _ -> (saved_defaults, ci_var_heap) restore_default (var_info_ptr,info) ci_var_heap = ci_var_heap <:= (var_info_ptr, info) remove_local_var fv=:{fv_info_ptr} (local_vars, var_heap) # (info, var_heap) = readPtr fv_info_ptr var_heap = case info of VI_LocalVar -> (local_vars, var_heap) _ -> ([fv : local_vars], var_heap) /**************************************************************************************************/ // MW0 createVariables :: [VarInfoPtr] !(Env Expression FreeVar) !*ConversionInfo -> (!Env Expression FreeVar, !*ConversionInfo) createVariables :: [VarInfoPtr] ![LetBind] !*ConversionInfo -> (![LetBind], !*ConversionInfo) createVariables var_info_ptrs binds ci = mapAppendSt (create_variable a_ij_var_name) var_info_ptrs binds ci // MW0create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo) create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo) create_variable var_name var_info_ptr ci # (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} cyclic_fv = varToFreeVar cyclic_var 1 // MW0 = ({ bind_src = App { app_symb = placeholder_symb, = ({ lb_src = App { app_symb = placeholder_symb, app_args = [Var cyclic_var, Var cyclic_var], app_info_ptr = nilPtr }, // MW0 bind_dst = varToFreeVar cyclic_var 1 lb_dst = varToFreeVar cyclic_var 1, lb_position = NoPos }, { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]}) /**************************************************************************************************/ newVariable :: String !VarInfo !*ConversionInfo -> *(!BoundVar,!*ConversionInfo) newVariable var_name var_info ci=:{ci_var_heap} # (var_info_ptr, ci_var_heap) = newPtr var_info ci_var_heap = ( { var_name = {id_name = var_name, id_info = nilPtr}, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, { ci & ci_var_heap = ci_var_heap }) newDefault :: BoundVar IndirectionVar -> DefaultExpression newDefault variable indirection_var = Yes (variable, [indirection_var]) getVariable :: DefaultExpression -> BoundVar getVariable (Yes (variable, _)) = variable getVariable No = abort "unexpected value in convertDynamics: 'getVariable'" getVariable1 :: DefaultExpression -> BoundVar getVariable1 (Yes (variable, _)) = variable getVariable1 No = abort "unexpected value in convertDynamics: 'getVariable'" getVariable2 :: DefaultExpression -> BoundVar getVariable2 (Yes (variable, _)) = variable getVariable2 No = abort "unexpected value in convertDynamics: 'getVariable'" getVariable3 :: DefaultExpression -> BoundVar getVariable3 (Yes (variable, _)) = variable getVariable3 No = abort "unexpected value in convertDynamics: 'getVariable'" getIndirectionVar (Yes (_, [ind_var:_])) = ind_var getIndirectionVar No = abort "unexpected value in convertDynamics: 'getIndirectionVar'" toExpression :: DefaultExpression !*ConversionInfo -> (Optional Expression, !*ConversionInfo) toExpression No ci = (No, ci) toExpression (Yes (variable, indirection_var_list)) ci | length indirection_var_list <> 1 = abort "toExpression: meerdere indirectie variables" # (expression, ci) = toExpression2 variable indirection_var_list ci = (Yes expression, ci) where toExpression2 variable [] ci = (Var variable, ci) toExpression2 variable [indirection_var : indirection_vars] ci # (expression, ci) = toExpression2 variable indirection_vars ci (undo_symb, ci) = getSymbol PD_undo_indirections SK_Function 2 ci ci_var_heap = adjust_ref_count indirection_var ci.ci_var_heap = (App { app_symb = undo_symb, app_args = [expression, Var indirection_var], app_info_ptr = nilPtr }, { ci & ci_var_heap = ci_var_heap }) adjust_ref_count {var_info_ptr} var_heap # (VI_Indirection ref_count, var_heap) = readPtr var_info_ptr var_heap = var_heap <:= (var_info_ptr, VI_Indirection (inc ref_count)) varToFreeVar :: BoundVar Int -> FreeVar varToFreeVar {var_name, var_info_ptr} count = {fv_def_level = NotALevel, fv_name = var_name, fv_info_ptr = var_info_ptr, fv_count = count} freeVarToVar :: FreeVar -> BoundVar freeVarToVar {fv_name, fv_info_ptr} = { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} addToBoundVars :: BoundVar AType BoundVariables -> BoundVariables addToBoundVars var type bound_vars = [ { tv_free_var = varToFreeVar var 0, tv_type = type } : bound_vars ] get_constructor :: !{!GlobalTCType} Index -> Expression get_constructor glob_type_inst index = BasicExpr (BVS ("\"" +++ toString glob_type_inst.[index] +++ "\"")) (BT_String TE) instance toString GlobalTCType where toString (GTT_Basic basic_type) = toString basic_type 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) "") instance toString BasicType where toString BT_Int = "Int" toString BT_Char = "Char" toString BT_Real = "Real" toString BT_Bool = "Bool" toString BT_Dynamic = "Dynamic" toString BT_File = "File" toString BT_World = "World" toString (BT_String _) = "String" getResultType :: ExprInfoPtr !*ConversionInfo -> (!AType, !*ConversionInfo) getResultType case_info_ptr ci=:{ci_expr_heap} # (EI_CaseType {ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap = (ct_result_type, {ci & ci_expr_heap = ci_expr_heap}) getSymbol :: Index ((Global Index) -> SymbKind) Int !*ConversionInfo -> (SymbIdent, !*ConversionInfo) getSymbol index symb_kind arity ci=:{ci_predef_symb} # ({pds_module, pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![index] ci = {ci & ci_predef_symb = ci_predef_symb} symbol = { symb_name = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity } = (symbol, ci) getTupleSymbol arity ci=:{ci_predef_symb} # ({pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![GetTupleConsIndex arity] = ( {ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def}, {ci & ci_predef_symb = ci_predef_symb }) getGlobalIndex :: Index !*ConversionInfo -> (Global Index, !*ConversionInfo) getGlobalIndex index ci=:{ci_predef_symb} # ({pds_module, pds_def}, ci_predef_symb) = ci_predef_symb![index] = ( { glob_module = pds_module, glob_object = pds_def} , {ci & ci_predef_symb = ci_predef_symb} ) getConstructor :: Index Int !*ConversionInfo -> (Global DefinedSymbol, !*ConversionInfo) getConstructor index arity ci=:{ci_predef_symb} # ({pds_module, pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![index] defined_symbol = { ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def} = ( {glob_object = defined_symbol, glob_module = pds_module} , {ci & ci_predef_symb = ci_predef_symb} ) a_ij_var_name :== { id_name = "a_ij", id_info = nilPtr } v_tc_name :== { id_name = "convertDynamicsvTC", id_info = nilPtr } v_tc_placeholder_ident :== { id_name = v_tc_placeholder, id_info = nilPtr } v_tc_placeholder_ident_global :== { id_name = v_tc_placeholder +++ "GLOBAL", id_info = nilPtr } v_tc_placeholder :== "tc_placeholder" a_aij_tc_var_name :== { id_name = "a_ij_tc", id_info = nilPtr } case_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo) case_ptr ci=:{ci_expr_heap} # (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType { ct_pattern_type = empty_attributed_type, ct_result_type = empty_attributed_type, ct_cons_types = repeat (repeat empty_attributed_type)}) ci_expr_heap = (expr_info_ptr, {ci & ci_expr_heap = ci_expr_heap}) let_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo) let_ptr ci=:{ci_expr_heap} # (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType (repeat empty_attributed_type)) ci_expr_heap = (expr_info_ptr, {ci & ci_expr_heap = ci_expr_heap}) empty_attributed_type :: AType empty_attributed_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE } isNo :: (Optional a) -> Bool isNo (Yes _) = False isNo No = True zipAppend2 :: [.a] [.b] u:[w:(.a,.b)] -> v:[x:(.a,.b)], [w <= x, u <= v] zipAppend2 [] ys zs = zs zipAppend2 xs [] zs = zs zipAppend2 [x : xs] [y : ys] zs = [ (x,y) : zipAppend2 xs ys zs ] instance <<< (Ptr a) where (<<<) file ptr = file <<< ptrToInt ptr