diff options
| -rw-r--r-- | frontend/convertDynamics.icl | 27 | ||||
| -rw-r--r-- | frontend/overloading.dcl | 2 | ||||
| -rw-r--r-- | frontend/overloading.icl | 412 | ||||
| -rw-r--r-- | frontend/refmark.icl | 45 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 24 | ||||
| -rw-r--r-- | frontend/syntax.icl | 62 | ||||
| -rw-r--r-- | frontend/type.dcl | 3 | ||||
| -rw-r--r-- | frontend/type.icl | 41 | ||||
| -rw-r--r-- | frontend/typesupport.dcl | 2 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 35 | ||||
| -rw-r--r-- | frontend/unitype.icl | 2 |
11 files changed, 341 insertions, 314 deletions
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 8777dda..d22f5ab 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -390,12 +390,20 @@ where 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) +/* 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 + = (App { app_symb = ci_symb_ident, + app_args = [dyn_expr, dyn_type_code], + app_info_ptr = nilPtr }, ci) + +/* ... Sjaak */ +/* WAS ... 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], @@ -406,9 +414,9 @@ where 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 @@ -426,6 +434,19 @@ where */ + +/* Sjaak ... */ +convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args binds placeholders_and_tc_args ci + # (let_binds, ci) = createVariables uni_vars [] ci + (let_info_ptr, ci) = let_ptr ci + (e, type_code_expr, binds, placeholders_and_tc_args, ci) = convertTypecode2 cinp type_code False [] [] ci + = (e, Let { let_strict_binds = [], + let_lazy_binds = let_binds, + let_expr = type_code_expr, + let_info_ptr = let_info_ptr, + let_expr_position = NoPos}, binds, placeholders_and_tc_args, ci) +/* ... Sjaak */ + // 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 diff --git a/frontend/overloading.dcl b/frontend/overloading.dcl index 71328fd..5fa9850 100644 --- a/frontend/overloading.dcl +++ b/frontend/overloading.dcl @@ -43,9 +43,7 @@ tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Ind { tci_next_index :: !Index , tci_instances :: ![GlobalTCInstance] , tci_type_var_heap :: !.TypeVarHeap -// MV ... , tci_dcl_modules :: !{# DclModule} -// ... MV } removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 696e58a..30b948e 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -2,8 +2,8 @@ implementation module overloading import StdEnv -import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, convertDynamics // ,RWSDebug -import generics // AA +import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, convertDynamics +import generics :: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty @@ -150,23 +150,26 @@ where try_to_reduce_context :: !TypeContext !{# CommonDefs} !ClassInstanceInfo ![TypeContext] !*SpecialInstances ![LocalTypePatternVariable] !(!*VarHeap, !*TypeHeaps) !*Coercions !*PredefinedSymbols !*ErrorAdmin -> *(!ClassApplication, ![TypeContext], !*SpecialInstances, ![LocalTypePatternVariable], !(!*VarHeap, !*TypeHeaps), !*Coercions, !*PredefinedSymbols, !*ErrorAdmin) - try_to_reduce_context tc=:{tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs instance_info new_contexts - special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error + try_to_reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error | context_is_reducible tc predef_symbols - | is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols - # (red_context, (new_contexts, special_instances, type_pattern_vars, var_heap)) - = reduce_TC_context class_symb (hd tc_types) new_contexts special_instances type_pattern_vars var_heap - = (red_context, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) - # (class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) - = reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars - (var_heap, type_heaps) coercion_env predef_symbols error - = (CA_Instance class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) - | containsContext tc new_contexts - = (CA_Context tc, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) - # (tc_var, var_heap) = newPtr VI_Empty var_heap - = (CA_Context tc, [{ tc & tc_var = tc_var } : new_contexts], special_instances, - type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) - + = reduce_any_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error + | containsContext tc new_contexts + = (CA_Context tc, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) + # (var_heap, type_heaps) = heaps + (tc_var, var_heap) = newPtr VI_Empty var_heap + = (CA_Context tc, [{ tc & tc_var = tc_var } : new_contexts], special_instances, + type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) + + reduce_any_context tc=:{tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs instance_info new_contexts + special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error + | is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols + # (red_context, (new_contexts, special_instances, type_pattern_vars, var_heap)) + = reduce_TC_context class_symb (hd tc_types) new_contexts special_instances type_pattern_vars var_heap + = (red_context, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) + # (class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) + = reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars + (var_heap, type_heaps) coercion_env predef_symbols error + = (CA_Instance class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) reduce_context {tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error @@ -417,34 +420,27 @@ where = reduce_tc_context type_code_class tc_type (new_contexts, special_instances, type_pattern_vars, var_heap) where reduce_tc_context type_code_class (TA cons_id=:{type_index={glob_module}} cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap) -// MV ... # defining_module_name = dcl_modules.[glob_module].dcl_name.id_name -// ... MV # (inst_index, (si_next_TC_member_index, si_TC_instances)) = addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (si_next_TC_member_index, si_TC_instances) (rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap) = (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances) - reduce_tc_context type_code_class (TB basic_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap) # (inst_index, (si_next_TC_member_index, si_TC_instances)) = addGlobalTCInstance (GTT_Basic basic_type) (si_next_TC_member_index, si_TC_instances) = (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = [] }, (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)) - reduce_tc_context type_code_class (arg_type --> result_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap) # (inst_index, (si_next_TC_member_index, si_TC_instances)) = addGlobalTCInstance GTT_Function (si_next_TC_member_index, si_TC_instances) (rc_red_contexts, instances) = reduce_TC_contexts type_code_class [arg_type, result_type] (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap) = (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances) - - reduce_tc_context type_code_class (TempQV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap) # (inst_var, (type_pattern_vars, var_heap)) = addLocalTCInstance var_number (type_pattern_vars, var_heap) = (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap)) - reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap) // MV ... // was: # (tc_var, var_heap) = newPtr VI_Empty var_heap @@ -731,6 +727,7 @@ convertOverloadedCall defs contexts symbol=:{symb_kind = SK_Generic gen_glob kin = abort "convertOverloadedCall: no class for kind" = convertOverloadedCall defs contexts {symbol & symb_kind = SK_OverloadedFunction member_glob} expr_ptr class_appls heaps_and_ptrs // ..AA + convertOverloadedCall defs contexts {symb_name,symb_kind = SK_TypeCode} expr_info_ptr class_appls heaps_and_ptrs # (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts class_appls heaps_and_ptrs = ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))}, ptrs) @@ -740,10 +737,7 @@ convertOverloadedCall defs contexts {symb_name} expr_info_ptr appls heaps_and_pt expressionToTypeCodeExpression (TypeCodeExpression texpr) = texpr -expressionToTypeCodeExpression (ClassVariable var_info_ptr) = TCE_TypeTerm var_info_ptr // MV was TCE_Var var_info_ptr -/* -expressionToTypeCodeExpression (Var {var_info_ptr}) = TCE_Var var_info_ptr -*/ +expressionToTypeCodeExpression (ClassVariable var_info_ptr) = TCE_TypeTerm var_info_ptr expressionToTypeCodeExpression expr = abort "expressionToTypeCodeExpression (overloading.icl)" // <<- expr) generateClassSelection address last_selectors @@ -790,7 +784,6 @@ where | isEmpty let_binds = (dict_expr, ({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, class_ptrs)) # (let_info_ptr, hp_expression_heap) = newPtr (EI_LetType let_types) hp_expression_heap -// MW0 = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr }, = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, [let_info_ptr : class_ptrs])) # dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module expressions context_size dictionary_args @@ -826,7 +819,6 @@ where (var_info_ptr, var_heap) = newPtr VI_Empty var_heap fv = { fv_name = symb_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = nr_of_members } var = { var_name = symb_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } -// MW0 = ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) = ([{lb_src = dict, lb_dst = fv, lb_position = NoPos } : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) bind_shared_dictionary nr_of_members dict=:(App {app_symb={symb_name}, app_info_ptr}) (binds, types, rev_dicts, var_heap, expr_heap) @@ -834,7 +826,6 @@ where (var_info_ptr, var_heap) = newPtr VI_Empty var_heap fv = { fv_name = symb_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = nr_of_members } var = { var_name = symb_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } -// MW0 = ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) = ([{lb_src = dict, lb_dst = fv, lb_position = NoPos} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) bind_shared_dictionary nr_of_members dict (binds, types, rev_dicts, var_heap, expr_heap) = (binds, types, [dict : rev_dicts], var_heap, expr_heap) @@ -898,29 +889,23 @@ where update_dynamics [] type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols = (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) update_dynamics [fun:funs] type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols - #! fun_def = fun_defs.[fun] - # {fun_body,fun_symb,fun_info/* MV ={fi_group_index, fi_dynamics}*/} = fun_def - # {fi_group_index, fi_dynamics} = fun_info + # (fun_def, fun_defs) = fun_defs![fun] + # {fun_body,fun_symb,fun_info} = fun_def + # {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 # (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) /* MV */ [] + = convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) (TransformedBody tb) = fun_body - (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error /* MV */, ui_x={x_type_code_info = type_code_info, x_predef_symbols = predef_symbols} /*, ui_new_variables */}) + (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, x_predef_symbols = predef_symbols}}) = updateExpression fi_group_index tb.tb_rhs - { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs, ui_local_vars = [], - ui_fun_env = fun_env, ui_var_heap = var_heap, ui_error = error , /*ui_new_variables = [],*/ - 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} - } -// /* MV */ , fun_info = { fun_info & fi_local_vars = ui_new_variables ++ fun_info.fi_local_vars }} - - - // = ({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 }}}, - - + { 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}} + 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 type_code_info ui_var_heap ui_error predef_symbols + 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} @@ -935,17 +920,15 @@ where # (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 - (rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap) -// ---> ("determine_class_argument", st_context) error = setErrorAdmin (newPosition fun_symb fun_pos) error (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) - = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) /* MV */ rev_variables + = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) - (tb_rhs, {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error /* MV */, ui_x={x_type_code_info = type_code_info, x_predef_symbols = predef_symbols}}) //, ui_new_variables }) + (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 - /* MV */, ui_x={x_type_code_info = type_code_info, x_predef_symbols = predef_symbols,x_main_dcl_module_n=main_dcl_module_n}} + 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}} (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 } } @@ -960,6 +943,7 @@ where VI_Empty # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap -> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name id_name) new_info_ptr 0)) +// ---> ("determine_class_argument (VI_ForwardClassVar)", ptrToInt tc_var, ptrToInt var_info_ptr) _ -> abort "determine_class_argument (overloading.icl)" @@ -967,6 +951,7 @@ where # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap var_heap = var_heap -> ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name id_name) new_info_ptr 0)) +// ---> ("determine_class_argument (VI_Empty)", ptrToInt tc_var) _ -> abort "determine_class_argument (overloading.icl)" @@ -977,7 +962,7 @@ where # (VI_ClassVar var_name new_info_ptr count, var_heap) = readPtr var_info_ptr var_heap = ([{fv_name = var_name, fv_info_ptr = new_info_ptr, fv_def_level = NotALevel, fv_count = count } : args], var_heap <:= (var_info_ptr, VI_Empty)) -convertDynamicTypes dyn_ptrs update_info rev_variables +convertDynamicTypes dyn_ptrs update_info = foldSt update_dynamic dyn_ptrs update_info where update_dynamic dyn_ptr (type_code_info, expr_heap, type_pattern_vars, var_heap, error) @@ -987,161 +972,143 @@ where # (expr_info, expr_heap) = readPtr expr_ptr expr_heap -> case expr_info of EI_TypeCodes type_codes - // MV .. - # (type_var_heap,var_heap,error) = fold2St (f symb_name) - dt_global_vars type_codes (type_code_info.tci_type_var_heap,var_heap,error) - // .. MV - (uni_vars, (type_var_heap, var_heap)) = new_type_variables dt_uni_vars (type_var_heap, var_heap) - (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name rev_variables dt_type ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap,error) + # (type_var_heap, var_heap, error) + = bind_type_vars_to_type_codes symb_name dt_global_vars type_codes type_code_info.tci_type_var_heap var_heap error + (uni_vars, (type_var_heap, var_heap)) = newTypeVariables dt_uni_vars (type_var_heap, var_heap) + (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name (add_universal_vars_to_type dt_uni_vars dt_type) + ({ type_code_info & tci_type_var_heap = type_var_heap }, var_heap, error) -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap, error) -/* -ORIGINAL: - - # type_var_heap = fold2St (\{tv_info_ptr} type_code -> writePtr tv_info_ptr (TVI_TypeCode type_code)) - dt_global_vars type_codes type_code_info.tci_type_var_heap - (uni_vars, (type_var_heap, var_heap)) = new_type_variables dt_uni_vars (type_var_heap, var_heap) - (type_code_expr, (type_code_info, var_heap, error)) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap } - -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap, error) -*/ EI_Empty - # (uni_vars, (type_var_heap, var_heap)) = new_type_variables dt_uni_vars (type_code_info.tci_type_var_heap, var_heap) - (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name rev_variables dt_type ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap,error) + # (uni_vars, (type_var_heap, var_heap)) = newTypeVariables dt_uni_vars (type_code_info.tci_type_var_heap, var_heap) + (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name (add_universal_vars_to_type dt_uni_vars dt_type) + ({ type_code_info & tci_type_var_heap = type_var_heap }, var_heap, error) -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap, error) EI_TempDynamicType No _ _ expr_ptr {symb_name} # (expr_info, expr_heap) = readPtr expr_ptr expr_heap -> case expr_info of EI_TypeCode type_expr - # (type_expr, (free_vars, var_heap, rev_variables, error)) = retrieve_free_vars symb_name type_expr ([], var_heap, rev_variables, error) - var_heap = foldSt mark_free_var free_vars var_heap - -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic free_vars type_expr), type_pattern_vars, var_heap, error) + # (type_expr, (var_heap, error)) = updateFreeVarsOfTCE symb_name type_expr (var_heap, error) + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] type_expr), type_pattern_vars, var_heap, error) EI_Selection selectors record_var _ # (_, var_info_ptr, var_heap, error) = getClassVariable symb_name record_var var_heap error - -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] (convert_selectors selectors var_info_ptr /* MPM */ record_var)), type_pattern_vars, var_heap, error) - EI_TempDynamicPattern type_vars {dt_global_vars, dt_type} loc_dynamics temp_local_vars _ _ expr_ptr {symb_name} + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] (convert_selectors selectors var_info_ptr)), type_pattern_vars, var_heap, error) + EI_TempDynamicPattern type_vars {dt_global_vars, dt_uni_vars, dt_type} loc_dynamics temp_local_vars _ _ expr_ptr {symb_name} # (expr_info, expr_heap) = readPtr expr_ptr expr_heap -> case expr_info of EI_TypeCodes type_codes -// # type_var_heap = fold2St (\{tv_info_ptr} type_code -> writePtr tv_info_ptr (TVI_TypeCode type_code)) dt_global_vars type_codes type_code_info.tci_type_var_heap - // MV .. - # (type_var_heap,var_heap,error) = fold2St (f symb_name) - dt_global_vars type_codes (type_code_info.tci_type_var_heap,var_heap,error) - // .. MV + # (type_var_heap, var_heap, error) + = bind_type_vars_to_type_codes symb_name dt_global_vars type_codes type_code_info.tci_type_var_heap var_heap error (var_ptrs, (type_pattern_vars, var_heap)) = mapSt addLocalTCInstance temp_local_vars (type_pattern_vars, var_heap) - type_var_heap = fold2St (\{tv_info_ptr} var_ptr -> writePtr tv_info_ptr (TVI_TypeCode (TCE_Var var_ptr))) type_vars var_ptrs type_var_heap - (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name rev_variables dt_type ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap,error) + type_var_heap = bind_type_vars_to_type_var_codes type_vars var_ptrs type_var_heap + (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name (add_universal_vars_to_type dt_uni_vars dt_type) ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap, error) -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap, error) EI_Empty # (var_ptrs, (type_pattern_vars, var_heap)) = mapSt addLocalTCInstance temp_local_vars (type_pattern_vars, var_heap) - type_var_heap = fold2St (\{tv_info_ptr} var_ptr -> writePtr tv_info_ptr (TVI_TypeCode (TCE_Var var_ptr))) type_vars var_ptrs type_code_info.tci_type_var_heap - (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name rev_variables dt_type ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap,error) + type_var_heap = bind_type_vars_to_type_var_codes type_vars var_ptrs type_code_info.tci_type_var_heap + (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name (add_universal_vars_to_type dt_uni_vars dt_type) ({ type_code_info & tci_type_var_heap = type_var_heap }, var_heap, error) -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap, error) where - f symb_name {tv_info_ptr} type_code (type_var_heap,var_heap,error) - # (type_code,(_,var_heap,_,error)) - = retrieve_free_vars symb_name type_code ([],var_heap,rev_variables,error) - # type_var_heap - = writePtr tv_info_ptr (TVI_TypeCode type_code) type_var_heap - = (type_var_heap,var_heap,error) + bind_type_vars_to_type_codes symb_name type_vars type_codes type_var_heap var_heap error + = fold2St (bind_type_var_to_type_code symb_name) type_vars type_codes (type_var_heap, var_heap, error) + where + bind_type_var_to_type_code symb_name {tv_name,tv_info_ptr} type_code (type_var_heap, var_heap, error) + # (type_code, (var_heap, error)) = updateFreeVarsOfTCE symb_name type_code (var_heap, error) + = (type_var_heap <:= (tv_info_ptr, TVI_TypeCode type_code), var_heap, error) + bind_type_vars_to_type_var_codes type_vars var_ptrs type_var_heap + = fold2St bind_type_var_to_type_var_code type_vars var_ptrs type_var_heap + where + bind_type_var_to_type_var_code {tv_name,tv_info_ptr} var_ptr type_var_heap + = type_var_heap <:= (tv_info_ptr, TVI_TypeCode (TCE_Var var_ptr)) + + add_universal_vars_to_type [] at + = at + add_universal_vars_to_type uni_vars at=:{at_type} + = { at & at_type = TFA uni_vars at_type } + + convert_local_dynamics loc_dynamics state = foldSt update_dynamic loc_dynamics state - convert_selectors [type_code_selector] var_info_ptr record_var - // MV .. - | isMember record_var rev_variables - = TCE_TypeTerm var_info_ptr - // .. MV - = TCE_Var var_info_ptr - convert_selectors selectors var_info_ptr _ + convert_selectors [type_code_selector] var_info_ptr + = TCE_TypeTerm var_info_ptr + convert_selectors selectors var_info_ptr = TCE_Selector (init selectors) var_info_ptr - new_type_variables uni_vars heaps - = mapSt new_type_variable uni_vars heaps - - new_type_variable {atv_variable = {tv_info_ptr}} (type_var_heap, var_heap) - # (new_var_ptr, var_heap) = newPtr VI_Empty var_heap - = (new_var_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeCode (TCE_Var new_var_ptr)), var_heap)) +newTypeVariables uni_vars heaps + = mapSt new_type_variable uni_vars heaps +where + new_type_variable {atv_variable = {tv_info_ptr}} (type_var_heap, var_heap) + # (new_var_ptr, var_heap) = newPtr VI_Empty var_heap + = (new_var_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeCode (TCE_Var new_var_ptr)), var_heap)) - mark_free_var var_info_ptr var_heap - = var_heap <:= (var_info_ptr, VI_LocallyDefined) - -retrieve_free_vars :: !Ident !TypeCodeExpression *([Ptr VarInfo],*Heap VarInfo,u:[Ptr VarInfo],*ErrorAdmin) -> *(TypeCodeExpression,*([Ptr VarInfo],*Heap VarInfo,[Ptr VarInfo],*ErrorAdmin)); -retrieve_free_vars symb_name (TCE_Var var_info_ptr1) free_vars_and_var_heap - # (var_info_ptr, (free_vars, var_heap, rev_variables, error)) = retrieve_var symb_name var_info_ptr1 free_vars_and_var_heap -// MV .. - | isMember var_info_ptr1 rev_variables - = (TCE_TypeTerm var_info_ptr, (free_vars, var_heap, rev_variables, error)) -// .. MV - = (TCE_Var var_info_ptr, (free_vars, var_heap, rev_variables, error)) -retrieve_free_vars symb_name (TCE_Constructor type_index type_args) free_vars_and_var_heap - # (type_args, free_vars_and_var_heap) = mapSt (retrieve_free_vars symb_name) type_args free_vars_and_var_heap - = (TCE_Constructor type_index type_args, free_vars_and_var_heap) -retrieve_free_vars symb_name (TCE_Selector selections var_info_ptr) free_vars_and_var_heap - # (var_info_ptr, free_vars_and_var_heap) = retrieve_var symb_name var_info_ptr free_vars_and_var_heap - = (TCE_Selector selections var_info_ptr, free_vars_and_var_heap) -retrieve_free_vars symb_name TCE_Empty free_vars_and_var_heap - = (TCE_Empty, free_vars_and_var_heap) - -// MV .. -retrieve_free_vars symb_name (TCE_TypeTerm var_info_ptr1) free_vars_and_var_heap - # (var_info_ptr, (free_vars, var_heap, rev_variables, error)) = retrieve_var symb_name var_info_ptr1 free_vars_and_var_heap - | isMember var_info_ptr1 rev_variables - = (TCE_TypeTerm var_info_ptr, (free_vars, var_heap, rev_variables, error)) - = (TCE_Var var_info_ptr, (free_vars, var_heap, rev_variables, error)) -// MV .. - -retrieve_var symb_name var_info_ptr (free_vars, var_heap, rev_variables, error) - = case (readPtr var_info_ptr var_heap) of - (VI_ClassVar var_name new_info_ptr count, var_heap) - -> (new_info_ptr, (free_vars, var_heap <:= (var_info_ptr, VI_ClassVar var_name new_info_ptr (inc count)), rev_variables, error)) - (VI_Defined, var_heap) - -> (var_info_ptr, (free_vars, var_heap, rev_variables, error)) - (VI_LocallyDefined, var_heap) - -> (var_info_ptr, (free_vars, var_heap, rev_variables, overloadingError symb_name error)) - (_, var_heap) - -> (var_info_ptr, ([var_info_ptr : free_vars], var_heap <:= (var_info_ptr, VI_Defined), rev_variables, error)) +updateFreeVarsOfTCE :: !Ident !TypeCodeExpression (!*VarHeap, !*ErrorAdmin) -> (!TypeCodeExpression, !(!*VarHeap, *ErrorAdmin)) +updateFreeVarsOfTCE symb_name (TCE_Constructor type_index type_args) var_heap_and_error + # (type_args, var_heap_and_error) = mapSt (updateFreeVarsOfTCE symb_name) type_args var_heap_and_error + = (TCE_Constructor type_index type_args, var_heap_and_error) +updateFreeVarsOfTCE symb_name (TCE_Selector selections var_info_ptr) var_heap_and_error + # (var_info_ptr, var_heap_and_error) = getTCDictionary symb_name var_info_ptr var_heap_and_error + = (TCE_Selector selections var_info_ptr, var_heap_and_error) +updateFreeVarsOfTCE symb_name (TCE_TypeTerm var_info_ptr) var_heap_and_error + # (var_info_ptr, var_heap_and_error) = getTCDictionary symb_name var_info_ptr var_heap_and_error + = (TCE_TypeTerm var_info_ptr, var_heap_and_error) +updateFreeVarsOfTCE symb_name tce var_heap_and_error + = (tce, var_heap_and_error) + +getTCDictionary symb_name var_info_ptr (var_heap, error) + # (var_info, var_heap) = readPtr var_info_ptr var_heap + = case var_info of + VI_ClassVar var_name new_info_ptr count + -> (new_info_ptr, (var_heap <:= (var_info_ptr, VI_ClassVar var_name new_info_ptr (inc count)), error)) + _ + -> (var_info_ptr, (var_heap, overloadingError symb_name error)) + +// import RWSDebug :: TypeCodeInfo = { tci_next_index :: !Index , tci_instances :: ![GlobalTCInstance] , tci_type_var_heap :: !.TypeVarHeap -// MV ... , tci_dcl_modules :: !{# DclModule} -// ... MV } -class toTypeCodeExpression type :: !Ident ![Ptr VarInfo] type !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin) -> (!TypeCodeExpression, !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin)) +class toTypeCodeExpression type :: !Ident type !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin) -> (!TypeCodeExpression, !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin)) instance toTypeCodeExpression Type where - toTypeCodeExpression symb_name rev_variables (TA cons_id=:{type_index={glob_module}} type_args) (tci=:{tci_next_index,tci_instances,tci_dcl_modules},var_heap,error) -// MV ... + toTypeCodeExpression symb_name (TA cons_id=:{type_index={glob_module}} type_args) (tci=:{tci_next_index,tci_instances,tci_dcl_modules},var_heap,error) # defining_module_name = tci_dcl_modules.[glob_module].dcl_name.id_name -// ... MV # (inst_index, (tci_next_index, tci_instances)) = addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (tci_next_index, tci_instances) - (type_code_args, tci) = mapSt (toTypeCodeExpression symb_name rev_variables) type_args ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error) + (type_code_args, tci) = mapSt (toTypeCodeExpression symb_name) type_args ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error) = (TCE_Constructor inst_index type_code_args, tci) - toTypeCodeExpression symb_name rev_variables (TB basic_type) (tci=:{tci_next_index,tci_instances},var_heap,error) + toTypeCodeExpression symb_name (TB basic_type) (tci=:{tci_next_index,tci_instances},var_heap,error) # (inst_index, (tci_next_index, tci_instances)) = addGlobalTCInstance (GTT_Basic basic_type) (tci_next_index, tci_instances) = (TCE_Constructor inst_index [], ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error)) - toTypeCodeExpression symb_name rev_variables (arg_type --> result_type) (tci=:{tci_next_index,tci_instances},var_heap,error) + toTypeCodeExpression symb_name (arg_type --> result_type) (tci=:{tci_next_index,tci_instances},var_heap,error) # (inst_index, (tci_next_index, tci_instances)) = addGlobalTCInstance GTT_Function (tci_next_index, tci_instances) - (type_code_args, tci) = mapSt (toTypeCodeExpression symb_name rev_variables) [arg_type, result_type] ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error) + (type_code_args, tci) = mapSt (toTypeCodeExpression symb_name) [arg_type, result_type] ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error) = (TCE_Constructor inst_index type_code_args, tci) - toTypeCodeExpression symb_name rev_variables (TV {tv_info_ptr}) (tci=:{tci_type_var_heap},var_heap,error) - # (TVI_TypeCode type_code, tci_type_var_heap) = readPtr tv_info_ptr tci_type_var_heap - (type_code,(_,var_heap,_,error)) = retrieve_free_vars symb_name type_code ([],var_heap,rev_variables,error) - = (type_code, ({ tci & tci_type_var_heap = tci_type_var_heap },var_heap,error)) + toTypeCodeExpression symb_name (TV {tv_name,tv_info_ptr}) (tci=:{tci_type_var_heap}, var_heap, error) + # (type_info, tci_type_var_heap) = readPtr tv_info_ptr tci_type_var_heap + tci = { tci & tci_type_var_heap = tci_type_var_heap } + = case type_info of + TVI_TypeCode type_code + -> (type_code, (tci,var_heap,error)) + _ + -> abort ("toTypeCodeExpression (TV)" ---> ((ptrToInt tv_info_ptr, tv_name))) + toTypeCodeExpression symb_name (TFA vars type) (tci=:{tci_type_var_heap}, var_heap, error) + # (new_vars, (tci_type_var_heap, var_heap)) = newTypeVariables vars (tci_type_var_heap, var_heap) + (type_code, tci) = toTypeCodeExpression symb_name type ({tci & tci_type_var_heap = tci_type_var_heap}, var_heap, error) + = (TCE_UniType new_vars type_code, tci) - instance toTypeCodeExpression AType where - toTypeCodeExpression symb_ident rev_variables {at_type} tci = toTypeCodeExpression symb_ident rev_variables at_type tci + toTypeCodeExpression symb_ident {at_type} tci_and_var_heap_and_error = toTypeCodeExpression symb_ident at_type tci_and_var_heap_and_error :: UpdateInfo = { ui_instance_calls :: ![FunCall] @@ -1151,11 +1118,11 @@ where , ui_fun_defs :: !.{# FunDef} , ui_fun_env :: !.{! FunctionType} , ui_error :: !.ErrorAdmin - , ui_x :: !.UpdateInfoX + , ui_x :: !.UpdateInfoX } -:: UpdateInfoX = { - x_type_code_info :: !.TypeCodeInfo +:: UpdateInfoX = + { x_type_code_info :: !.TypeCodeInfo , x_predef_symbols :: !.{#PredefinedSymbol} , x_main_dcl_module_n :: !Int } @@ -1249,7 +1216,6 @@ where = ui new_call mod_index symb_index ui=:{ui_instance_calls,ui_fun_defs} -// | mod_index == cIclModIndex && symb_index < size ui_fun_defs | mod_index == ui.ui_x.UpdateInfoX.x_main_dcl_module_n && symb_index < size ui_fun_defs # ui_instance_calls = add_call symb_index ui_instance_calls = { ui & ui_instance_calls = ui_instance_calls } @@ -1274,9 +1240,6 @@ where = foldSt (examine_calls_bind) let_lazy_binds (examine_calls_in_expr let_expr ui) examine_calls_in_expr _ ui = ui - -// MW0 examine_calls_bind {bind_src,bind_dst} ui=:{ui_local_vars} -// MW0 = examine_calls_in_expr bind_src { ui & ui_local_vars = [bind_dst : ui_local_vars ]} examine_calls_bind {lb_src,lb_dst} ui=:{ui_local_vars} = examine_calls_in_expr lb_src { ui & ui_local_vars = [lb_dst : ui_local_vars ]} @@ -1310,7 +1273,10 @@ where updateExpression group_index (DynamicExpr dyn=:{dyn_expr,dyn_info_ptr}) ui # (dyn_expr, ui) = updateExpression group_index dyn_expr ui (EI_TypeOfDynamic uni_vars type_code, ui_symbol_heap) = readPtr dyn_info_ptr ui.ui_symbol_heap - = (DynamicExpr { dyn & dyn_expr = dyn_expr, dyn_type_code = type_code, dyn_uni_vars = uni_vars }, { ui & ui_symbol_heap = ui_symbol_heap }) + ui = { ui & ui_symbol_heap = ui_symbol_heap } + | isEmpty uni_vars + = (DynamicExpr { dyn & dyn_expr = dyn_expr, dyn_type_code = type_code }, ui) + = (DynamicExpr { dyn & dyn_expr = dyn_expr, dyn_type_code = TCE_UniType uni_vars type_code }, ui) updateExpression group_index (MatchExpr opt_tuple cons_symbol expr) ui # (expr, ui) = updateExpression group_index expr ui = (MatchExpr opt_tuple cons_symbol expr, ui) @@ -1416,66 +1382,49 @@ where adjustClassExpression symb_name (Selection opt_type expr selectors) ui # (expr, ui) = adjustClassExpression symb_name expr ui = (Selection opt_type expr selectors, ui) -// MV ... - adjustClassExpression symb_name l=:(TypeCodeExpression type_code_expression) ui - # (expr,free_type_vars_at_runtime,ui) - = convertTypecode type_code_expression [] ui - | not (isEmpty free_type_vars_at_runtime) - # (let_binds,ui) = createVariables free_type_vars_at_runtime ui + adjustClassExpression symb_name (TypeCodeExpression type_code_expression) ui + = convertTypecode type_code_expression ui + where + + convertTypecode TCE_Empty ui + = (EE, ui) + convertTypecode (TCE_Var var_info_ptr) ui + = (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, ui) + 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 + (constructor,ui) = get_constructor index ui + (typecode_exprs, ui) = convertTypecodes typecode_exprs ui + = (App {app_symb = typecons_symb, + app_args = [constructor , typecode_exprs ], + app_info_ptr = nilPtr}, ui) + 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 + # (let_binds, ui) = createVariables uni_vars ui + (let_expr, ui) = convertTypecode type_code ui (let_info_ptr,ui) = let_ptr ui = ( Let { let_strict_binds = [] , let_lazy_binds = let_binds - , let_expr = expr + , let_expr = let_expr , let_info_ptr = let_info_ptr - , let_expr_position = NoPos} // MW0++ - , ui) - = (expr, ui) - where - add_free_type_var var_info_ptr free_type_vars_at_runtime ui=:{ui_var_heap} - # (var_info,ui_var_heap) - = readPtr var_info_ptr ui_var_heap - # ui - = { ui & ui_var_heap = ui_var_heap} - = case var_info of - VI_FreeTypeVarAtRuntime - -> ([var_info_ptr:free_type_vars_at_runtime],ui) - _ - -> (free_type_vars_at_runtime,ui) - - // similar to equally named function in convertDynamics.icl - convertTypecode TCE_Empty free_type_vars_at_runtime ui - = (EE,free_type_vars_at_runtime,ui) - convertTypecode (TCE_Var var_info_ptr) free_type_vars_at_runtime ui=:{ui_var_heap} - # (free_type_vars_at_runtime,ui) - = add_free_type_var var_info_ptr free_type_vars_at_runtime ui - = (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},free_type_vars_at_runtime,ui) - convertTypecode (TCE_TypeTerm var_info_ptr) free_type_vars_at_runtime ui=:{ui_var_heap} - # (free_type_vars_at_runtime,ui) - = add_free_type_var var_info_ptr free_type_vars_at_runtime ui - = (Var {var_name = v_tc_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},free_type_vars_at_runtime,ui) - - convertTypecode (TCE_Constructor index typecode_exprs) free_type_vars_at_runtime ui - # (typecons_symb,ui) = getSymbol PD_TypeConsSymbol SK_Constructor 2 ui - (constructor,ui) = get_constructor index ui - (typecode_exprs, free_type_vars_at_runtime,ui) = convertTypecodes typecode_exprs free_type_vars_at_runtime ui - = (App {app_symb = typecons_symb, - app_args = [constructor , typecode_exprs ], - app_info_ptr = nilPtr}, free_type_vars_at_runtime, ui) - convertTypecode (TCE_Selector selections var_info_ptr) free_type_vars_at_runtime ui - = (Selection No (Var { var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }) selections,free_type_vars_at_runtime,ui) - - convertTypecodes [] free_type_vars_at_runtime ui + , let_expr_position = NoPos + }, ui) + convertTypecodes [] ui # (nil_symb, ui) = getSymbol PD_NilSymbol SK_Constructor 0 ui = (App { app_symb = nil_symb, app_args = [], - app_info_ptr = nilPtr}, free_type_vars_at_runtime, ui) - convertTypecodes [typecode_expr : typecode_exprs] free_type_vars_at_runtime ui - # (cons_symb, ui) = getSymbol PD_ConsSymbol SK_Constructor 2 ui - (expr,free_type_vars_at_runtime, ui) = convertTypecode typecode_expr free_type_vars_at_runtime ui - (exprs,free_type_vars_at_runtime,ui) = convertTypecodes typecode_exprs free_type_vars_at_runtime ui + app_info_ptr = nilPtr}, ui) + convertTypecodes [typecode_expr : typecode_exprs] ui + # (cons_symb, ui) = getSymbol PD_ConsSymbol SK_Constructor 2 ui + (expr, ui) = convertTypecode typecode_expr ui + (exprs, ui) = convertTypecodes typecode_exprs ui = (App { app_symb = cons_symb, app_args = [expr , exprs], - app_info_ptr = nilPtr}, free_type_vars_at_runtime, ui) + app_info_ptr = nilPtr}, ui) + createVariables var_info_ptrs ui = mapSt create_variable var_info_ptrs ui where @@ -1483,26 +1432,22 @@ where # (placeholder_symb, ui) = getSymbol PD_variablePlaceholder SK_Constructor 3 ui cyclic_var = {var_name = v_tc_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 + app_args = [Var cyclic_var, Var cyclic_var], + app_info_ptr = nilPtr }, lb_dst = varToFreeVar cyclic_var 1, lb_position = NoPos }, { ui & ui_local_vars = [cyclic_fv : ui.ui_local_vars]}) - + getSymbol :: !Int !(!(Global !Int) -> !SymbKind) !Int !*UpdateInfo -> (SymbIdent,*UpdateInfo) - getSymbol index symb_kind arity ui=:{ui_x=ui_x=:{x_predef_symbols}} - # ({pds_module, pds_def, pds_ident}, x_predef_symbols) = x_predef_symbols![index] - ui_x = { ui_x & x_predef_symbols = x_predef_symbols} - ui={ui & ui_x=ui_x} + getSymbol index symb_kind arity ui=:{ui_x} + # ({pds_module, pds_def, pds_ident}, ui_x) = ui_x!x_predef_symbols.[index] symbol = { symb_name = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity } - = (symbol,ui) - + = (symbol, { ui & ui_x = ui_x}) + get_constructor :: !Int !*UpdateInfo -> !(!Expression,!*UpdateInfo) - get_constructor index ui=:{ui_x={x_type_code_info={tci_instances}}} + get_constructor index ui=:{ui_x = {x_type_code_info={tci_instances}}} /* ** MV ** Inefficiency. The correct gtci_type referred to by index has to be selected from the list of @@ -1519,8 +1464,8 @@ where = BasicExpr (BVS ("\"" +++ toString tci_instance +++ "\"")) (BT_String TE) = (cons_expr,ui) - a_ij_var_name = { id_name = "a_ij", id_info = nilPtr } - v_tc_name = { id_name = "overloadingvTC", id_info = nilPtr } + a_ij_var_name = { id_name = "a_ij", id_info = nilPtr } + v_tc_name = { id_name = "overloadingvTC", id_info = nilPtr } varToFreeVar :: BoundVar Int -> FreeVar @@ -1533,7 +1478,6 @@ where where empty_attributed_type :: AType empty_attributed_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE } -// .. MV adjustClassExpression symb_name expr ui = (expr, ui) diff --git a/frontend/refmark.icl b/frontend/refmark.icl index 6911fc2..c73df63 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -506,22 +506,17 @@ where where initial_occurrence {fv_name,fv_info_ptr} (subst, type_def_infos, var_heap, expr_heap) # (var_info, var_heap) = readPtr fv_info_ptr var_heap - = case var_info of - VI_Type {at_type,at_attribute} _ - -> case at_type of - TempV tv_number - #! is_oberving = has_observing_type type_def_infos subst.[tv_number] - -> (subst, type_def_infos, var_heap <:= (fv_info_ptr, - VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], - occ_observing = is_oberving, occ_bind = OB_Empty }), expr_heap) -// ---> ("initial_occurrence",fv_name, fv_info_ptr, is_oberving) - _ - -> (subst, type_def_infos, var_heap <:= (fv_info_ptr, - VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], - occ_observing = False, occ_bind = OB_Empty }), expr_heap) - _ - -> abort ("initial_occurrence (refmark.icl)" ---> ((fv_name,fv_info_ptr) ))//<<- var_info)) - + #! occ_observing = has_observing_base_type var_info type_def_infos subst + = (subst, type_def_infos, + var_heap <:= (fv_info_ptr, VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], + occ_observing = occ_observing, occ_bind = OB_Empty }), expr_heap) + + has_observing_base_type (VI_Type {at_type} _) type_def_infos subst + = has_observing_type at_type type_def_infos subst + has_observing_base_type (VI_FAType _ {at_type}) type_def_infos subst + = has_observing_type at_type type_def_infos subst + has_observing_base_type _ type_def_infos subst + = abort "has_observing_base_type (refmark.icl)" make_shared_vars_non_unique vars coercion_env var_heap expr_heap error = foldl make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) vars @@ -555,16 +550,22 @@ where make_selection_non_unique fv {su_multiply} cee = make_shared_occurrences_non_unique fv su_multiply cee +/* has_observing_type type_def_infos TE = True - has_observing_type type_def_infos (TB basic_type) - = True - has_observing_type type_def_infos (TempV var_number) +*/ + has_observing_type (TB basic_type) type_def_infos subst = True - has_observing_type type_def_infos (TA {type_index = {glob_object,glob_module}} type_args) + has_observing_type (TempV var_number) type_def_infos subst + = case subst.[var_number] of + TE + -> True + subst_type + -> has_observing_type subst_type type_def_infos subst + has_observing_type (TA {type_index = {glob_object,glob_module}} type_args) type_def_infos subst # {tdi_properties} = type_def_infos.[glob_module].[glob_object] - = foldSt (\ {at_type} ok -> ok && has_observing_type type_def_infos at_type) type_args (tdi_properties bitand cIsHyperStrict <> 0) - has_observing_type type_def_infos type + = foldSt (\ {at_type} ok -> ok && has_observing_type at_type type_def_infos subst) type_args (tdi_properties bitand cIsHyperStrict <> 0) + has_observing_type type type_def_infos subst = False diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 24dea25..107a1f3 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -860,6 +860,7 @@ cNonRecursiveAppl :== False :: TypeVarInfo = TVI_Empty | TVI_Type !Type + | TVI_TypeVar !TypeVarInfoPtr // Sjaak: to collect universally quantified type variables | TVI_Forward !TempVarId | TVI_TypeKind !KindInfoPtr | TVI_SignClass !Index !SignClassification !TypeVarInfo | TVI_PropClass !Index !PropClassification !TypeVarInfo | TVI_Attribute TypeAttribute @@ -876,7 +877,10 @@ cNonRecursiveAppl :== False :: TypeVarInfoPtr :== Ptr TypeVarInfo :: TypeVarHeap :== Heap TypeVarInfo -:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId +:: AttrVarInfo = AVI_Empty + | AVI_Attr !TypeAttribute + | AVI_AttrVar !AttrVarInfoPtr // Sjaak: to collect universally quantified attribute variables + | AVI_Forward !TempAttrId | AVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */ | AVI_Used | AVI_Count !Int /* auxiliary used in module typesupport */ @@ -1154,7 +1158,7 @@ cIsNotStrict :== False { dyn_expr :: !Expression , dyn_opt_type :: !Optional DynamicType , dyn_info_ptr :: !ExprInfoPtr - , dyn_uni_vars :: ![VarInfoPtr] /* filled after type checking */ +// , dyn_uni_vars :: ![VarInfoPtr] /* filled after type checking */ , dyn_type_code :: !TypeCodeExpression /* filled after type checking */ } @@ -1167,19 +1171,15 @@ cIsNotStrict :== False | ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression | DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression -//:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr -:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr /* MV */ | TCE_TypeTerm !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr +:: TypeCodeExpression = TCE_Empty + | TCE_Var !VarInfoPtr + | TCE_TypeTerm !VarInfoPtr + | TCE_Constructor !Index ![TypeCodeExpression] + | TCE_Selector ![Selection] !VarInfoPtr + | TCE_UniType ![VarInfoPtr] !TypeCodeExpression :: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent !String | GTT_Function -/* -:: PatternExpression = - { guard_pattern :: !GuardPattern - , guard_expr :: !Expression - } - -:: GuardPattern = BasicPattern !BasicValue | AlgebraicPattern !(Global DefinedSymbol) ![FreeVar] | VariablePattern !FreeVar -*/ :: FunctionPattern = FP_Basic !BasicValue !(Optional FreeVar) | FP_Algebraic !(Global DefinedSymbol) ![FunctionPattern] !(Optional FreeVar) diff --git a/frontend/syntax.icl b/frontend/syntax.icl index c46ffeb..f6900f9 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -831,12 +831,15 @@ cNotVarNumber :== -1 | KI_NormVar !Int -:: TypeVarInfo = TVI_Empty | TVI_Type !Type | TVI_Forward !TempVarId | TVI_TypeKind !KindInfoPtr +:: TypeVarInfo = TVI_Empty + | TVI_Type !Type + | TVI_TypeVar !TypeVarInfoPtr // Sjaak: to collect universally quantified type variables + | TVI_Forward !TempVarId | TVI_TypeKind !KindInfoPtr | TVI_SignClass !Index !SignClassification !TypeVarInfo | TVI_PropClass !Index !PropClassification !TypeVarInfo | TVI_Attribute TypeAttribute | TVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */ | TVI_AType !AType /* auxiliary used in module comparedefimp */ - | TVI_Used /* to adminster that this variable is encountered (in checkOpenTypes) */ + | TVI_Used /* to administer that this variable is encountered (in checkOpenTypes) */ | TVI_TypeCode !TypeCodeExpression | TVI_CPSLocalTypeVar !Int /* MdM - the index of the variable as generated by the theorem prover */ | TVI_Kinds ![TypeKind] // AA: used to collect kinds during checking @@ -847,10 +850,14 @@ cNotVarNumber :== -1 :: TypeVarInfoPtr :== Ptr TypeVarInfo :: TypeVarHeap :== Heap TypeVarInfo -:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId +:: AttrVarInfo = AVI_Empty + | AVI_Attr !TypeAttribute + | AVI_AttrVar !AttrVarInfoPtr // Sjaak: to collect universally quantified attribute variables + | AVI_Forward !TempAttrId | AVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */ | AVI_Used | AVI_Count !Int /* auxiliary used in module typesupport */ + :: AttrVarInfoPtr :== Ptr AttrVarInfo :: AttrVarHeap :== Heap AttrVarInfo @@ -1101,7 +1108,7 @@ cIsNotStrict :== False { dyn_expr :: !Expression , dyn_opt_type :: !Optional DynamicType , dyn_info_ptr :: !ExprInfoPtr - , dyn_uni_vars :: ![VarInfoPtr] /* filled after type checking */ +// , dyn_uni_vars :: ![VarInfoPtr] /* filled after type checking */ , dyn_type_code :: !TypeCodeExpression /* filled after type checking */ } @@ -1114,7 +1121,12 @@ cIsNotStrict :== False | ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression | DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression -:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr /* MV */ | TCE_TypeTerm !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr +:: TypeCodeExpression = TCE_Empty + | TCE_Var !VarInfoPtr + | TCE_TypeTerm !VarInfoPtr + | TCE_Constructor !Index ![TypeCodeExpression] + | TCE_Selector ![Selection] !VarInfoPtr + | TCE_UniType ![VarInfoPtr] !TypeCodeExpression :: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent !String | GTT_Function @@ -1254,11 +1266,11 @@ where instance <<< TypeVar where (<<<) file varid = file <<< varid.tv_name -// (<<<) file varid = file <<< varid.tv_name <<< "<" <<< ptrToInt (varid.tv_info_ptr) <<< ">" +// (<<<) file varid = file <<< varid.tv_name <<< "<" <<< varid.tv_info_ptr <<< ">" instance <<< AttributeVar where -// (<<<) file {av_name,av_info_ptr} = file <<< av_name <<< "[" <<< ptrToInt av_info_ptr <<< "]" +// (<<<) file {av_name,av_info_ptr} = file <<< av_name <<< "[" <<< av_info_ptr <<< "]" (<<<) file {av_name,av_info_ptr} = file <<< av_name instance toString AttributeVar @@ -1336,9 +1348,9 @@ where = file <<< type <<< " @" <<< types (<<<) file (TB tb) = file <<< tb -/* (<<<) file (TFA vars types) + (<<<) file (TFA vars types) = file <<< "A." <<< vars <<< ':' <<< types -*/ (<<<) file (TQV varid) + (<<<) file (TQV varid) = file <<< "E." <<< varid (<<<) file (TempQV tv_number) = file <<< "E." <<< tv_number <<< ' ' @@ -1388,7 +1400,7 @@ where instance <<< TypeContext where - (<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< ptrToInt co.tc_var <<< '>' + (<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< co.tc_var <<< '>' instance <<< SymbIdent where @@ -1414,7 +1426,7 @@ where instance <<< BoundVar where (<<<) file {var_name,var_info_ptr,var_expr_ptr} - = file <<< var_name <<< "<I" <<< ptrToInt var_info_ptr <<< ", E" <<< ptrToInt var_expr_ptr <<< '>' + = file <<< var_name <<< "<I" <<< var_info_ptr <<< ", E" <<< var_expr_ptr <<< '>' instance <<< (Bind a b) | <<< a & <<< b where @@ -1507,7 +1519,8 @@ where (<<<) file (MatchExpr _ cons expr) = file <<< cons <<< " =: " <<< expr (<<<) file EE = file <<< "** E **" (<<<) file (NoBind _) = file <<< "** NB **" - (<<<) file (DynamicExpr {dyn_expr,dyn_uni_vars,dyn_type_code}) = writeVarPtrs (file <<< "dynamic " <<< dyn_expr <<< " :: dyn_uni_vars") dyn_uni_vars <<< "dyn_type_code=" <<< dyn_type_code + (<<<) file (DynamicExpr {dyn_expr,dyn_type_code}) = file <<< "dynamic " <<< dyn_expr <<< " :: " <<< dyn_type_code +// (<<<) file (DynamicExpr {dyn_expr,dyn_uni_vars,dyn_type_code}) = writeVarPtrs (file <<< "dynamic " <<< dyn_expr <<< " :: dyn_uni_vars") dyn_uni_vars <<< "dyn_type_code=" <<< dyn_type_code // (<<<) file (TypeCase type_case) = file <<< type_case (<<<) file (TypeCodeExpression type_code) = file <<< type_code (<<<) file (Constant symb _ _ _) = file <<< "** Constant **" <<< symb @@ -1516,7 +1529,7 @@ where (<<<) file (AnyCodeExpr input output code_sequence) = file <<< "code\n" <<< input <<< "\n" <<< output <<< "\n" <<< code_sequence (<<<) file (FreeVar {fv_name}) = file <<< fv_name - (<<<) file (ClassVariable info_ptr) = file <<< "ClassVariable " <<< ptrToInt info_ptr + (<<<) file (ClassVariable info_ptr) = file <<< "ClassVariable " <<< info_ptr (<<<) file expr = abort ("<<< (Expression) [line 1290]" )//<<- expr) @@ -1542,9 +1555,9 @@ writeVarPtrs file vars = write_var_ptrs (file <<< '<') vars <<< '>' where write_var_ptrs file [var] - = file <<< ptrToInt var + = file <<< var write_var_ptrs file [var : vars] - = write_var_ptrs (file <<< ptrToInt var <<< '.') vars + = write_var_ptrs (file <<< var <<< '.') vars instance <<< TypeCodeExpression @@ -1552,15 +1565,20 @@ where (<<<) file TCE_Empty = file (<<<) file (TCE_Var info_ptr) - = file <<< "TCE_Var " <<< ptrToInt info_ptr -// MV .. + = file <<< "TCE_Var " <<< info_ptr (<<<) file (TCE_TypeTerm info_ptr) - = file <<< "TCE_TypeTerm " <<< ptrToInt info_ptr -// .. MV + = file <<< "TCE_TypeTerm " <<< info_ptr (<<<) file (TCE_Constructor index exprs) = file <<< "TCE_Constructor " <<< index <<< ' ' <<< exprs (<<<) file (TCE_Selector selectors info_ptr) - = file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< ptrToInt info_ptr + = file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< info_ptr + (<<<) file (TCE_UniType vars type_code) + = file <<< "TCE_UniType " <<< vars <<< " " <<< type_code + +instance <<< (Ptr a) +where + (<<<) file ptr + = file <<< ptrToInt ptr instance <<< Selection where @@ -1688,7 +1706,7 @@ where instance <<< FreeVar where - (<<<) file {fv_name,fv_info_ptr,fv_count} = file <<< fv_name <<< '.' <<< fv_count <<< '<' <<< ptrToInt fv_info_ptr <<< '>' + (<<<) file {fv_name,fv_info_ptr,fv_count} = file <<< fv_name <<< '.' <<< fv_count <<< '<' <<< fv_info_ptr <<< '>' instance <<< DynamicType where @@ -1951,7 +1969,7 @@ where instance <<< Declaration where (<<<) file (Declaration { decl_ident, decl_kind }) - = file <<< decl_ident <<< '<' <<< ptrToInt decl_ident.id_info <<< '>' <<< '(' <<< decl_kind <<< ')' + = file <<< decl_ident <<< '<' <<< decl_ident.id_info <<< '>' <<< '(' <<< decl_kind <<< ')' instance <<< STE_Kind where diff --git a/frontend/type.dcl b/frontend/type.dcl index 28d8252..de2a22a 100644 --- a/frontend/type.dcl +++ b/frontend/type.dcl @@ -5,8 +5,7 @@ import syntax, check typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) -//typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} -// -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !.TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) + addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState); diff --git a/frontend/type.icl b/frontend/type.icl index b65fcb4..5f60f20 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -96,6 +96,11 @@ where | ok -> (True, simplified_type, subst) -> (False, tcv, subst) + arraySubst tfa_type=:(TFA vars type) subst + # (changed, type, subst) = arraySubst type subst + | changed + = (changed, TFA vars type, subst) + = (False, tfa_type, subst) arraySubst type subst = (False, type, subst) @@ -470,7 +475,7 @@ where # (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute th_attrs (fresh_type, type_heaps) = freshCopy at_type { type_heaps & th_attrs = th_attrs } = ({ type & at_type = fresh_type, at_attribute = fresh_attribute }, type_heaps) - + instance freshCopy Type where freshCopy (TV tv) type_heaps @@ -485,6 +490,7 @@ where freshCopy (TFA vars type) type_heaps # type_heaps = foldSt bind_var_and_attr vars type_heaps (type, type_heaps) = freshCopy type type_heaps + # type_heaps = clearBindings vars type_heaps = (TFA vars type, type_heaps) where bind_var_and_attr {atv_attribute, atv_variable = tv=:{tv_info_ptr}} type_heaps=:{th_vars,th_attrs} @@ -617,7 +623,6 @@ freshSymbolType fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_ = vars = [var_id : add_variable new_var_id var_ids] -// JVG: added type: freshInequality :: AttrInequality *(Heap AttrVarInfo) -> (!AttrCoercion,!.Heap AttrVarInfo); freshInequality {ai_demanded,ai_offered} attr_heap # (av_dem_info, attr_heap) = readPtr ai_demanded.av_info_ptr attr_heap @@ -958,8 +963,8 @@ where where bind_var_and_attr {atv_attribute, atv_variable = {tv_info_ptr}} ts=:{ts_var_store, ts_type_heaps} = { ts & ts_var_store = inc ts_var_store, ts_type_heaps = - { ts_type_heaps & th_vars = ts_type_heaps.th_vars <:= (tv_info_ptr, TVI_Type (TempQV ts_var_store)), - th_attrs = bind_attr atv_attribute ts_type_heaps.th_attrs }} + { ts_type_heaps & th_vars = ts_type_heaps.th_vars <:= (tv_info_ptr, TVI_Type (TempV ts_var_store)), + th_attrs = bind_attr atv_attribute ts_type_heaps.th_attrs }} where bind_attr (TA_Var {av_info_ptr}) attr_heap = attr_heap <:= (av_info_ptr, AVI_Attr TA_TempExVar) @@ -1069,7 +1074,7 @@ where requirements_of_dynamic_pattern dyn_type dyn_context dyn_expr_ptr type_code_symbol ti goal_type {dp_var={fv_info_ptr},dp_rhs} (reqs, ts=:{ts_expr_heap, ts_var_heap}) - # ts_var_heap = ts_var_heap <:= (fv_info_ptr, VI_Type dyn_type No) + # ts_var_heap = addToBase fv_info_ptr dyn_type No ts_var_heap (dp_rhs_type, opt_expr_ptr, (reqs, ts)) = requirements ti dp_rhs (reqs, { ts & ts_expr_heap = ts_expr_heap, ts_var_heap = ts_var_heap }) ts_expr_heap = storeAttribute opt_expr_ptr dp_rhs_type.at_attribute ts.ts_expr_heap type_coercion = { tc_demanded = goal_type, tc_offered = dp_rhs_type, tc_position = CP_Expression dp_rhs, tc_coercible = True } @@ -1395,13 +1400,13 @@ makeBase _ _ [] [] ts_var_heap = ts_var_heap makeBase fun_or_cons_ident arg_nr [{fv_name, fv_info_ptr} : vars] [type : types] ts_var_heap | is_rare_name fv_name - = makeBase fun_or_cons_ident (arg_nr+1) vars types (bind_type fv_info_ptr type (Yes (CP_FunArg fun_or_cons_ident arg_nr)) ts_var_heap) - = makeBase fun_or_cons_ident (arg_nr+1) vars types (bind_type fv_info_ptr type No ts_var_heap) - where - bind_type info_ptr atype=:{at_type = TFA atvs type} _ ts_var_heap - = ts_var_heap <:= (info_ptr, VI_FAType atvs { atype & at_type = type}) - bind_type info_ptr type optional_position ts_var_heap - = ts_var_heap <:= (info_ptr, VI_Type type optional_position) + = makeBase fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type (Yes (CP_FunArg fun_or_cons_ident arg_nr)) ts_var_heap) + = makeBase fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type No ts_var_heap) + +addToBase info_ptr atype=:{at_type = TFA atvs type} _ ts_var_heap + = ts_var_heap <:= (info_ptr, VI_FAType atvs { atype & at_type = type}) +addToBase info_ptr type optional_position ts_var_heap + = ts_var_heap <:= (info_ptr, VI_Type type optional_position) attributedBasicType (BT_String string_type) ts=:{ts_attr_store} = ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = string_type}, {ts & ts_attr_store = inc ts_attr_store}) @@ -1515,10 +1520,11 @@ where (expr_ptr, expr_heap) = newPtr EI_Empty expr_heap //---> ("^EI_Dynamic No=" +++ toString var_store) -> (inc var_store, type_heaps, var_heap, expr_heap <:= (dyn_ptr, EI_TempDynamicType No tdt_type [context] expr_ptr tc_member_symb), predef_symbols) - EI_DynamicTypeWithVars loc_type_vars dt=:{dt_type,dt_global_vars} loc_dynamics + EI_DynamicTypeWithVars loc_type_vars dt=:{dt_uni_vars,dt_type,dt_global_vars} loc_dynamics # (fresh_vars, (th_vars, var_store)) = fresh_existential_variables loc_type_vars (type_heaps.th_vars, var_store) +// ---> ("fresh_dynamic (EI_DynamicTypeWithVars)", dt_uni_vars) (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store) - (tdt_type, type_heaps) = freshCopy dt_type { type_heaps & th_vars = th_vars } + (tdt_type, type_heaps) = freshCopy (add_universal_vars_to_type dt_uni_vars dt_type) { type_heaps & th_vars = th_vars } (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols)) = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, type_heaps.th_vars, predef_symbols) -> fresh_local_dynamics loc_dynamics (var_store, { type_heaps & th_vars = type_var_heap }, var_heap, @@ -1577,6 +1583,10 @@ where (new_var_ptr, var_heap) = newPtr VI_Empty var_heap = ({tc_class = tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}, (var_heap, type_var_heap)) + add_universal_vars_to_type [] at + = at + add_universal_vars_to_type uni_vars at=:{at_type} + = { at & at_type = TFA uni_vars at_type } specification_error type type1 err # err = errorHeading "Type error" err @@ -1760,10 +1770,7 @@ where update_instances_of_class common_defs mod_index ins_index (dummy, error, class_instances, type_var_heap, td_infos) #!{ins_class={glob_object={ds_ident={id_name}, ds_index},glob_module},ins_type={it_types},ins_pos} = common_defs.[mod_index].com_instance_defs.[ins_index] - id_name = id_name ---> ("update_instances_of_class" +++ id_name +++ " " +++ (toString glob_module) +++ - " " +++ toString (size class_instances)) (mod_instances, class_instances) = replace class_instances glob_module dummy - id_name = id_name ---> "done" (instances, mod_instances) = replace mod_instances ds_index IT_Empty (error, instances) = insert it_types ins_index mod_index common_defs error instances (_, mod_instances) = replace mod_instances ds_index instances diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index 052965a..92cb371 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -75,6 +75,8 @@ instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | su instance <<< TempSymbolType +clearBindings :: ![ATypeVar] !*TypeHeaps -> !*TypeHeaps + removeInequality :: !Int !Int !*Coercions -> .Coercions flattenCoercionTree :: !u:CoercionTree -> (![Int], !u:CoercionTree) // retrieve all numbers from a coercion tree diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index e074357..e3385f8 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -62,6 +62,7 @@ where (at_type, cus) = clean_up cui at_type cus = ({atype & at_attribute = at_attribute, at_type = at_type, at_annotation = AN_None}, cus) + attrIsUndefined TA_None = True attrIsUndefined _ = False @@ -105,6 +106,9 @@ where = (attr, { cus & cus_appears_in_lifted_part = cus_appears_in_lifted_part, cus_error = cus_error }) = (TA_Multi, cus) + clean_up cui (TA_Var av=:{av_info_ptr}) cus=:{cus_heaps} + # (AVI_AttrVar new_info_ptr, th_attrs) = readPtr av_info_ptr cus_heaps.th_attrs + = (TA_Var { av & av_info_ptr = new_info_ptr }, { cus & cus_heaps = { cus_heaps & th_attrs = th_attrs }}) clean_up cui TA_TempExVar cus = PA_BUG (TA_Multi, cus) (abort "clean_up cui (TA_TempExVar)") @@ -137,6 +141,26 @@ where | cui.cui_top_level = cleanUpVariable True type qv_number {cus & cus_error = existentialError cus_error} = cleanUpVariable False type qv_number cus + clean_up cui (TV tv=:{tv_info_ptr}) cus=:{cus_heaps} + # (TVI_TypeVar new_info_ptr, th_vars) = readPtr tv_info_ptr cus_heaps.th_vars + = (TV { tv & tv_info_ptr = new_info_ptr }, { cus & cus_heaps = { cus_heaps & th_vars = th_vars }}) + clean_up cui (TFA vars type) cus=:{cus_heaps} + # (new_vars, cus_heaps) = mapSt refresh_var_and_attr vars cus_heaps + (type, cus) = clean_up cui type { cus & cus_heaps = cus_heaps } + cus_heaps = clearBindings vars cus.cus_heaps + = (TFA vars type, { cus & cus_heaps = cus_heaps }) + where + refresh_var_and_attr atv=:{atv_attribute, atv_variable = tv=:{tv_info_ptr}} type_heaps=:{th_vars,th_attrs} + # (new_info_ptr, th_vars) = newPtr TVI_Empty th_vars + (atv_attribute, th_attrs) = refresh_attr atv_attribute th_attrs + = ( { atv & atv_attribute = atv_attribute, atv_variable = { tv & tv_info_ptr = new_info_ptr }}, + { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_TypeVar new_info_ptr), th_attrs = th_attrs }) + where + refresh_attr (TA_Var av=:{av_info_ptr}) attr_heap + # (new_info_ptr, attr_heap) = newPtr AVI_Empty attr_heap + = (TA_Var {av & av_info_ptr = new_info_ptr}, attr_heap <:= (av_info_ptr, AVI_AttrVar new_info_ptr)) + refresh_attr attr attr_heap + = (attr, attr_heap) clean_up cui TE cus = abort "unknown pattern in function clean_up" @@ -156,6 +180,17 @@ cleanUpVariable top_level (TLifted var) tv_number cus=:{cus_error} cleanUpVariable _ type tv_number cus = (type, cus) +clearBindings :: ![ATypeVar] !*TypeHeaps -> !*TypeHeaps +clearBindings atvs type_heaps + = foldSt clear_binding_of_var_and_attr atvs type_heaps +where + clear_binding_of_var_and_attr {atv_attribute, atv_variable = tv=:{tv_info_ptr}} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Empty), th_attrs = clear_attr atv_attribute th_attrs } + + clear_attr var=:(TA_Var {av_info_ptr}) attr_heap + = attr_heap <:= (av_info_ptr, AVI_Empty) + clear_attr attr attr_heap + = attr_heap :: CleanUpResult :== BITVECT diff --git a/frontend/unitype.icl b/frontend/unitype.icl index c8926dd..a40f0f8 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -347,6 +347,8 @@ where | changed = (True, [t0:ts], subst, ls) = (False, ts0, subst, ls) + lift modules cons_vars (TFA vars type) subst ls + = abort "lift (TFA) (unitype.icl)" lift modules cons_vars type subst ls = (False, type, subst, ls) |