diff options
| -rw-r--r-- | frontend/check.icl | 6 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 7 | ||||
| -rw-r--r-- | frontend/overloading.icl | 194 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 9 | ||||
| -rw-r--r-- | frontend/syntax.icl | 10 | ||||
| -rw-r--r-- | frontend/trans.icl | 4 | ||||
| -rw-r--r-- | frontend/transform.icl | 2 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 4 | ||||
| -rw-r--r-- | frontend/unitype.icl | 28 |
9 files changed, 156 insertions, 108 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index a0ca8dc..8380695 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1537,7 +1537,7 @@ where checkExpression free_vars (PE_Ident id) e_input e_state e_info cs = checkIdentExpression cIsNotInExpressionList free_vars id e_input e_state e_info cs checkExpression free_vars expr e_input e_state e_info cs - = abort "checkExpression (check.icl, line 1433)" <<- expr + = abort "checkExpression (check.icl, line 1433)" // <<- expr :: LastSelection = LS_Update | LS_Selction | LS_UniqueSelection @@ -2128,7 +2128,7 @@ where = (fun_defs, symbol_table) get_calls (STE_FunctionOrMacro [x:xs]) = (x,xs) - get_calls ste_kind = abort "get_calls (check.icl)" <<- ste_kind + get_calls ste_kind = abort "get_calls (check.icl)" // <<- ste_kind checkFunctions :: !Index !Level !Index !Index !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState) @@ -2375,7 +2375,7 @@ where # ({ste_kind,ste_index}, cs_symbol_table) = readPtr ds_ident.id_info cs.cs_symbol_table | ste_kind == req_kind = ({ ds & ds_index = ste_index }, { cs & cs_symbol_table = cs_symbol_table }) - # cs_error = checkError "definition module" ("conflicting definition in implementation module"->>("ste_kind",ste_kind,ptrToInt ds_ident.id_info)) + # cs_error = checkError "definition module" "conflicting definition in implementation module" (setErrorAdmin (newPosition ds_ident pos) cs.cs_error) = ({ ds & ds_index = ste_index }, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 377420f..e472dad 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -50,7 +50,7 @@ where # ((let_binds,let_expr), ci) = convertCases (addLetVars let_binds let_type bound_vars) group_index common_defs (let_binds,let_expr) ci -> ({ lad & let_binds = let_binds, let_expr = let_expr }, ci) _ - -> abort "convertCases [Let] (convertcases 53)" <<- let_info + -> abort "convertCases [Let] (convertcases 53)" // <<- let_info addLetVars [{bind_dst} : binds] [bind_type : bind_types] bound_vars = addLetVars binds bind_types [ (bind_dst, bind_type) : bound_vars ] @@ -760,7 +760,7 @@ where { cp_info & cp_free_vars = [ (var_info_ptr, type) : cp_info.cp_free_vars ], cp_var_heap = cp_var_heap <:= (var_info_ptr, VI_FreeVar var_name new_info_ptr 1 type) }) _ - -> abort "copy [BoundVar] (convertcases, 612)" <<- (var_info ---> (var_name, ptrToInt var_info_ptr)) + -> abort "copy [BoundVar] (convertcases, 612)" // <<- (var_info ---> (var_name, ptrToInt var_info_ptr)) instance copy Expression where @@ -1274,9 +1274,8 @@ where # (let_info, di_expr_heap) = readPtr let_info_ptr di_expr_heap ok = case let_info of EI_LetTypeAndRefCounts let_type ref_counts -> True - x -> abort ("abort [distributeLets (EI_LetTypeAndRefCounts)]" ->> x) + x -> abort ("abort [distributeLets (EI_LetTypeAndRefCounts)]") // ->> x) | ok - // ---> ("distributeLets", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_binds]) # (EI_LetTypeAndRefCounts let_type ref_counts) = let_info di_var_heap = set_let_expression_info depth let_strict let_binds ref_counts let_type di_var_heap (let_expr, dl_info) = distributeLets depth let_expr { dl_info & di_var_heap = di_var_heap, di_expr_heap = di_expr_heap } diff --git a/frontend/overloading.icl b/frontend/overloading.icl index d0e1417..6b839b4 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -2,7 +2,7 @@ implementation module overloading import StdEnv -import syntax, check, type, typesupport, utilities, unitype, predef, RWSDebug +import syntax, check, type, typesupport, utilities, unitype, predef // , RWSDebug :: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty @@ -582,6 +582,7 @@ getDictionaryConstructor {glob_module, glob_object = {ds_ident,ds_index}} defs (RecordType {rt_constructor}) = defs.[glob_module].com_type_defs.[class_dictionary.ds_index].td_rhs = rt_constructor + simplifyOverloadedCall {symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} expr_info_ptr [class_appl:class_appls] defs has_context contexts type_heaps var_heap symbol_heap error # mem_def = defs.[glob_module].com_member_defs.[glob_object] @@ -603,7 +604,7 @@ where = determineContextAddress tc has_context contexts defs type_heaps var_heap error {class_dictionary={ds_index}} = defs.[glob_module].com_class_defs.[glob_object] selector = selectFromDictionary glob_module ds_index me_offset defs - = (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) (createBoundVar class_context) class_exprs, + = (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs, contexts, (type_heaps, var_heap, symbol_heap), error) adjust_member_application _ _ (CA_GlobalTypeCode {tci_index,tci_contexts}) _ defs has_context contexts heaps error @@ -655,8 +656,8 @@ where # (class_context, context_address, contexts, type_heaps, var_heap, error) = determineContextAddress tc has_context contexts defs type_heaps var_heap error | isEmpty context_address - = (Var (createBoundVar class_context), (contexts, (type_heaps, var_heap, expr_heap), error)) - = (Selection No (Var (createBoundVar class_context)) (generateClassSelection context_address []), (contexts, (type_heaps, var_heap, expr_heap), error)) + = (ClassVariable class_context.tc_var, (contexts, (type_heaps, var_heap, expr_heap), error)) + = (Selection No (ClassVariable class_context.tc_var) (generateClassSelection context_address []), (contexts, (type_heaps, var_heap, expr_heap), error)) convert_class_appl_to_expression defs has_context (CA_LocalTypeCode new_var_ptr) contexts_heaps_error = (TypeCodeExpression (TCE_Var new_var_ptr), contexts_heaps_error) convert_class_appl_to_expression defs has_context (CA_GlobalTypeCode {tci_index,tci_contexts}) contexts_heaps_error @@ -689,19 +690,18 @@ where (app_info_ptr, expr_heap) = newPtr (EI_ClassTypes instance_types) expr_heap rc_record = App { app_symb = record_symbol, app_args = rc_exprs ++ rcs_exprs, app_info_ptr = app_info_ptr } = (rc_record, (contexts, (type_heaps, var_heap, expr_heap), error)) - + +/* createBoundVar :: !TypeContext -> BoundVar createBoundVar {tc_class={glob_object={ds_ident}}, tc_var} -/* | isNilPtr tc_var - = abort ("createBoundVar : NIL ptr" ---> ds_ident) -*/ = { var_name = { id_name = "_v" +++ ds_ident.id_name, id_info = nilPtr }, var_info_ptr = tc_var, var_expr_ptr = nilPtr } + = { var_name = { id_name = "_v" +++ ds_ident.id_name, id_info = nilPtr }, var_info_ptr = tc_var, var_expr_ptr = nilPtr } createFreeVar :: !TypeContext -> FreeVar createFreeVar {tc_class={glob_object={ds_ident}}, tc_var} | isNilPtr tc_var = abort ("createFreeVar : NIL ptr" ---> ds_ident) = { fv_name = { id_name = "_v" +++ ds_ident.id_name, id_info = nilPtr }, fv_info_ptr = tc_var, fv_def_level = NotALevel, fv_count = -1 } - +*/ determineContextAddress :: !TypeContext !Bool ![TypeContext] !{#CommonDefs} !*TypeHeaps !*VarHeap !*ErrorAdmin -> (!TypeContext, ![(Int, Global DefinedSymbol)], ![TypeContext], !*TypeHeaps, !*VarHeap, !*ErrorAdmin) @@ -750,6 +750,10 @@ where No -> find_super_instance context tcs (inc tc_index) address dict_mod dict_index defs type_heaps +getClassVariable var_info_ptr var_heap + # (VI_ClassVar var_name new_info_ptr count, var_heap) = readPtr var_info_ptr var_heap + = (var_name, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar var_name new_info_ptr (inc count))) + updateDynamics :: ![Int] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin -> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin) updateDynamics funs type_contexts type_pattern_vars fun_defs symbol_heap type_code_info var_heap error @@ -766,46 +770,63 @@ where = update_dynamics funs type_contexts fun_defs symbol_heap type_code_info ltp error # (type_code_info, symbol_heap, ltp) = convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, ltp) (TransformedBody tb) = fun_body - (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_fun_defs}) - = updateExpression fi_group_index [] tb.tb_rhs { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs } + (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs}) = updateExpression fi_group_index [] tb.tb_rhs + { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs, ui_var_heap = ltp.ltp_var_heap } fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}} - = update_dynamics funs type_contexts { ui_fun_defs & [fun] = fun_def } ui_symbol_heap type_code_info ltp error + = update_dynamics funs type_contexts { ui_fun_defs & [fun] = fun_def } ui_symbol_heap type_code_info { ltp & ltp_var_heap = ui_var_heap } error removeOverloadedFunctions :: ![Int] ![(Optional [TypeContext], IdentPos)] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin -> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin) removeOverloadedFunctions funs opt_spec_contexts type_contexts type_pattern_vars fun_defs symbol_heap type_code_info var_heap error | error.ea_ok - = remove_overloaded_functions funs opt_spec_contexts type_contexts fun_defs symbol_heap type_code_info - { ltp_var_heap = var_heap, ltp_variables = type_pattern_vars} error - = (fun_defs, symbol_heap, type_code_info, var_heap, error) -where - remove_overloaded_functions :: ![Int] ![(Optional [TypeContext], IdentPos)] ![TypeContext] !*{#FunDef} !*ExpressionHeap !*TypeCodeInfo - !*LocalTypePatternVariables !*ErrorAdmin - -> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin) - remove_overloaded_functions [] opt_contexts type_contexts fun_defs symbol_heap type_code_info ltp error - = (fun_defs, symbol_heap, type_code_info, ltp.ltp_var_heap, error) - remove_overloaded_functions [fun:funs] [(opt_context, location):opt_contexts] type_contexts fun_defs symbol_heap type_code_info ltp error - #! fun_def = fun_defs.[fun] - # {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb} = fun_def + # (_, fun_defs, symbol_heap, type_code_info, ltp, error) + = fold2St (remove_overloaded_function type_contexts) funs opt_spec_contexts + (False, fun_defs, symbol_heap, type_code_info, { ltp_var_heap = var_heap, ltp_variables = type_pattern_vars}, error) + = (fun_defs, symbol_heap, type_code_info, ltp.ltp_var_heap, error) +where + remove_overloaded_function derived_context fun_index (opt_context, location) + (refresh_variables, fun_defs, symbol_heap, type_code_info, ltp, error) + # (fun_def, fun_defs) = fun_defs![fun_index] + {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb} = fun_def + (refresh_variables, rev_variables, ltp_var_heap) = determine_class_arguments refresh_variables opt_context derived_context ltp.ltp_var_heap error = setErrorAdmin location error - (type_code_info, symbol_heap, ltp) = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, ltp) - tb_args = determine_class_arguments opt_context type_contexts tb_args - (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_fun_defs}) = updateExpression fun_info.fi_group_index type_contexts tb_rhs - { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs } + (type_code_info, symbol_heap, ltp) = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, { ltp & ltp_var_heap = ltp_var_heap }) + (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs}) = updateExpression fun_info.fi_group_index rev_variables tb_rhs + { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_var_heap = ltp.ltp_var_heap, ui_fun_defs = fun_defs } + (tb_args, ltp_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 } } - = remove_overloaded_functions funs opt_contexts type_contexts { ui_fun_defs & [fun] = fun_def } ui_symbol_heap type_code_info ltp error - - determine_class_arguments (Yes spec_context) _ tb_args - = mapAppend (\tc -> createFreeVar tc) spec_context tb_args - determine_class_arguments No type_contexts tb_args - = mapAppend (\tc -> createFreeVar tc) type_contexts tb_args + = (refresh_variables, { ui_fun_defs & [fun_index] = fun_def }, ui_symbol_heap, type_code_info, { ltp & ltp_var_heap = ltp_var_heap }, error) + + determine_class_arguments fresh_variables (Yes spec_context) _ var_heap + # (rev_variables, var_heap) = foldSt set_variable spec_context ([], var_heap) + = (fresh_variables, rev_variables, var_heap) + determine_class_arguments fresh_variables No derived_context var_heap + | fresh_variables + # (rev_variables, var_heap) = foldSt set_fresh_variable derived_context ([], var_heap) + = (True, rev_variables, var_heap) + # (rev_variables, var_heap) = foldSt set_variable derived_context ([], var_heap) + = (True, rev_variables, var_heap) + + set_fresh_variable {tc_class={glob_object={ds_ident={id_name}}}, tc_var} (variables, var_heap) + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + = ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name id_name) new_info_ptr 0)) + + set_variable {tc_class={glob_object={ds_ident={id_name}}}, tc_var} (variables, var_heap) + = ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name id_name) tc_var 0)) + + build_var_name id_name + = { id_name = "_v" +++ id_name, id_info = nilPtr } + + retrieve_class_argument var_info_ptr (args, var_heap) + # (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) convertDynamicTypes dyn_ptrs update_info = foldSt update_dynamic dyn_ptrs update_info where - update_dynamic dyn_ptr (type_code_info, expr_heap, local_type_pattern_vars) + update_dynamic dyn_ptr (type_code_info, expr_heap, ltp) # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap = case dyn_info of EI_TempDynamicType (Yes {dt_global_vars, dt_uni_vars, dt_type}) _ _ expr_ptr _ @@ -814,47 +835,43 @@ where 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 - (uni_vars, (type_var_heap, ltp_var_heap)) = new_type_variables dt_uni_vars (type_var_heap, local_type_pattern_vars.ltp_var_heap) + (uni_vars, (type_var_heap, ltp_var_heap)) = new_type_variables dt_uni_vars (type_var_heap, ltp.ltp_var_heap) (type_code_expr, type_code_info) = 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), {local_type_pattern_vars & ltp_var_heap = ltp_var_heap}) + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), { ltp & ltp_var_heap = ltp_var_heap}) EI_Empty - # (uni_vars, (type_var_heap, ltp_var_heap)) = new_type_variables dt_uni_vars (type_code_info.tci_type_var_heap, local_type_pattern_vars.ltp_var_heap) + # (uni_vars, (type_var_heap, ltp_var_heap)) = new_type_variables dt_uni_vars (type_code_info.tci_type_var_heap, ltp.ltp_var_heap) (type_code_expr, type_code_info) = 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), {local_type_pattern_vars & ltp_var_heap = ltp_var_heap}) + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), {ltp & ltp_var_heap = ltp_var_heap}) EI_TempDynamicType No _ _ expr_ptr _ # (expr_info, expr_heap) = readPtr expr_ptr expr_heap -> case expr_info of EI_TypeCode type_expr - -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] type_expr), local_type_pattern_vars) + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] type_expr), ltp) EI_Selection selectors record_var _ - -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] (convert_selectors selectors record_var)), local_type_pattern_vars) + # (_, var_info_ptr, ltp_var_heap) = getClassVariable record_var ltp.ltp_var_heap + -> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] (convert_selectors selectors var_info_ptr)), { ltp & ltp_var_heap = ltp_var_heap }) EI_TempDynamicPattern type_vars {dt_global_vars, dt_type} loc_dynamics temp_local_vars _ _ expr_ptr _ # (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 - (var_ptrs, local_type_pattern_vars) = mapSt addLocalTCInstance temp_local_vars local_type_pattern_vars + (var_ptrs, ltp) = mapSt addLocalTCInstance temp_local_vars ltp 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) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap } - -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), local_type_pattern_vars) + -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), ltp) EI_Empty - # (var_ptrs, local_type_pattern_vars) = mapSt addLocalTCInstance temp_local_vars local_type_pattern_vars + # (var_ptrs, ltp) = mapSt addLocalTCInstance temp_local_vars ltp 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) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap } - -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), local_type_pattern_vars) + -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), ltp) where convert_local_dynamics loc_dynamics state = foldSt update_dynamic loc_dynamics state -/* - convert_local_dynamics (Yes loc_dynamics) state - = update_dynamic loc_dynamics state - convert_local_dynamics No state - = state -*/ - convert_selectors [type_code_selector] {var_info_ptr} + + convert_selectors [type_code_selector] var_info_ptr = TCE_Var var_info_ptr - convert_selectors selectors {var_info_ptr} + convert_selectors selectors var_info_ptr = TCE_Selector (init selectors) var_info_ptr new_type_variables uni_vars heaps @@ -900,10 +917,12 @@ where :: UpdateInfo = { ui_instance_calls :: ![FunCall] , ui_symbol_heap :: !.ExpressionHeap + , ui_var_heap :: !.VarHeap , ui_fun_defs :: !.{# FunDef} } -class updateExpression e :: !Index ![TypeContext] !e !*UpdateInfo -> (!e, !*UpdateInfo) +class updateExpression e :: !Index ![VarInfoPtr] !e !*UpdateInfo -> (!e, !*UpdateInfo) + instance updateExpression Expression where @@ -915,24 +934,32 @@ where = case symb_info of EI_Empty | is_recursive_call group_index symb_kind ui.ui_fun_defs - # app_args = strictMapAppend (\tc -> Var (createBoundVar tc)) type_contexts app_args - -> (App { app & app_symb = { symb & symb_arity = length type_contexts + symb_arity }, app_args = app_args }, ui) + # (symb_arity, app_args, ui_var_heap) = foldSt build_context_arg type_contexts (symb_arity, app_args, ui.ui_var_heap) + -> (App { app & app_symb = { symb & symb_arity = symb_arity }, app_args = app_args }, { ui & ui_var_heap = ui_var_heap }) -> (App { app & app_args = app_args }, ui) EI_Instance inst_symbol context_args + # (context_args, ui_var_heap) = adjustClassExpressions context_args [] ui.ui_var_heap -> (build_application inst_symbol context_args app_args symb_arity app_info_ptr, - examine_calls context_args (new_call inst_symbol.glob_module inst_symbol.glob_object.ds_index ui)) + examine_calls context_args (new_call inst_symbol.glob_module inst_symbol.glob_object.ds_index + { ui & ui_var_heap = ui_var_heap })) EI_Selection selectors record_var context_args - # all_args = context_args ++ app_args - select_expr = Selection No (Var record_var) selectors + # (all_args, ui_var_heap) = adjustClassExpressions context_args app_args ui.ui_var_heap + (var_name, var_info_ptr, ui_var_heap) = getClassVariable record_var ui_var_heap + select_expr = Selection No (Var { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }) selectors | isEmpty all_args - -> (select_expr, ui) - -> (select_expr @ all_args, examine_calls context_args ui) + -> (select_expr, { ui & ui_var_heap = ui_var_heap }) + -> (select_expr @ all_args, examine_calls context_args { ui & ui_var_heap = ui_var_heap }) EI_Context context_args - # app = { app & app_symb = { symb & symb_arity = length context_args + symb_arity }, app_args = context_args ++ app_args} - -> (App app, examine_calls context_args ui) + # (app_args, ui_var_heap) = adjustClassExpressions context_args app_args ui.ui_var_heap + # app = { app & app_symb = { symb & symb_arity = length context_args + symb_arity }, app_args = app_args} + -> (App app, examine_calls context_args { ui & ui_var_heap = ui_var_heap }) where + build_context_arg var_info_ptr (arity, args, var_heap) + # (var_name, var_info_ptr, var_heap) = getClassVariable var_info_ptr var_heap + = (inc arity, [ Var { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } : args ], var_heap) + is_recursive_call group_index (SK_Function {glob_module,glob_object}) fun_defs | glob_module == cIclModIndex #! fun_def = fun_defs.[glob_object] @@ -991,25 +1018,6 @@ where # (expr, ui) = updateExpression group_index type_contexts expr ui (selectors, ui) = updateExpression group_index type_contexts selectors ui = (Selection is_unique expr selectors, ui) -/* - where - update_selections group_index type_contexts is_unique selectors ui - = foldl (update_selection group_index type_contexts is_unique) state selectors - - update_selection group_index type_contexts is_unique (expr, ui) (ArraySelection selector expr_ptr index_expr) - # (index_expr, ui) = updateExpression group_index type_contexts index_expr ui - #! symb_info = sreadPtr expr_ptr ui.ui_symbol_heap - = case symb_info of - EI_Instance array_select [] - -> (App {app_symb = { symb_name = glob_object.ds_ident, - symb_kind = SK_Function { glob_module = glob_module, glob_object = glob_object.ds_index }, - symb_arity = glob_object.ds_arity + 2 }, - app_args = context_args ++ [expr,index_expr], app_info_ptr = expr_ptr }, ui) - EI_Selection selectors record context_args - -> (Selection is_unique record selectors @ [expr,index_expr], ui) - update_selection group_index type_contexts is_unique (expr, ui) (RecordSelection selector field_nr) - = (Selection is_unique expr [RecordSelection selector field_nr], ui) -*/ updateExpression group_index type_contexts (Update expr1 selectors expr2) ui # (expr1, ui) = updateExpression group_index type_contexts expr1 ui (selectors, ui) = updateExpression group_index type_contexts selectors ui @@ -1078,8 +1086,10 @@ where = case symb_info of EI_Instance array_select [] -> (ArraySelection array_select expr_ptr index_expr, ui) - EI_Selection selectors record context_args - -> (DictionarySelection record selectors expr_ptr index_expr, ui) + EI_Selection selectors record_var context_args + # (var_name, var_info_ptr, ui_var_heap) = getClassVariable record_var ui.ui_var_heap + -> (DictionarySelection { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } selectors expr_ptr index_expr, + { ui & ui_var_heap = ui_var_heap }) updateExpression group_index type_contexts selection ui = (selection, ui) @@ -1106,7 +1116,21 @@ instance updateExpression [e] | updateExpression e where updateExpression group_index type_contexts l ui = mapSt (updateExpression group_index type_contexts) l ui - + +adjustClassExpressions exprs tail_exprs var_heap + = mapAppendSt adjustClassExpression exprs tail_exprs var_heap + +adjustClassExpression (App app=:{app_args}) var_heap + # (app_args, var_heap) = adjustClassExpressions app_args [] var_heap + = (App { app & app_args = app_args }, var_heap) +adjustClassExpression (ClassVariable var_info_ptr) var_heap + # (var_name, var_info_ptr, var_heap) = getClassVariable var_info_ptr var_heap + = (Var { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }, var_heap) +adjustClassExpression (Selection opt_type expr selectors) var_heap + # (expr, var_heap) = adjustClassExpression expr var_heap + = (Selection opt_type expr selectors, var_heap) +adjustClassExpression expr var_heap + = (expr, var_heap) class equalTypes a :: !a !a !*TypeVarHeap -> (!Bool, !*TypeVarHeap) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 944a0a2..23a8728 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -471,6 +471,7 @@ cIsALocalVar :== False VI_Alias !BoundVar /* used for resolving aliases just before type checking (in transform) */ | /* used during elimination and lifting of cases */ VI_FreeVar !Ident !VarInfoPtr !Int !AType | VI_BoundVar !AType | VI_LocalVar | + VI_ClassVar !Ident !VarInfoPtr !Int /* used to hold dictionary variables during overloading */ | VI_Forward !BoundVar | VI_LetVar !LetVarInfo | VI_LetExpression !LetExpressionInfo | VI_CaseVar !VarInfoPtr | VI_CorrespondenceNumber !Int | VI_SequenceNumber !Int | VI_Used | /* for indicating that an imported function has been used */ @@ -601,7 +602,8 @@ cNonRecursiveAppl :== False | EI_Overloaded !OverloadedCall /* initial, set by the type checker */ | EI_Instance !(Global DefinedSymbol) ![Expression] /* intermedediate, used during resolving of overloading */ - | EI_Selection ![Selection] !BoundVar ![Expression] /* intermedediate, used during resolving of overloading */ +// | EI_Selection ![Selection] !BoundVar ![Expression] /* intermedediate, used during resolving of overloading */ + | EI_Selection ![Selection] !VarInfoPtr ![Expression] /* intermedediate, used during resolving of overloading */ | EI_Context ![Expression] /* intermedediate, used during resolving of overloading */ /* For handling dynamics */ @@ -983,8 +985,6 @@ cIsNotStrict :== False | (@) infixl 9 !Expression ![Expression] | Let !Let | Case !Case -// | RecordSelect !SelectorKind !(Global DefinedSymbol) !Int !Expression -// | ArraySelect !SelectorKind !ArraySelector !Expression !Expression | Selection !(Optional (Global DefinedSymbol)) !Expression ![Selection] | Update !Expression ![Selection] Expression | RecordUpdate !(Global DefinedSymbol) !Expression ![Bind Expression (Global FieldSymbol)] @@ -999,7 +999,8 @@ cIsNotStrict :== False | MatchExpr !(Optional (Global DefinedSymbol)) !(Global DefinedSymbol) !Expression | FreeVar FreeVar - | Constant !SymbIdent !Int !Priority !Bool /* auxiliary clause used during checking */ + | Constant !SymbIdent !Int !Priority !Bool /* auxiliary clause used during checking */ + | ClassVariable !VarInfoPtr /* auxiliary clause used during overloading */ | DynamicExpr !DynamicExpr // | TypeCase !TypeCase diff --git a/frontend/syntax.icl b/frontend/syntax.icl index b25b345..6623652 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -427,6 +427,7 @@ cIsALocalVar :== False VI_Alias !BoundVar /* used for resolving aliases just before type checking (in transform) */ | /* used during elimination and lifting of cases */ VI_FreeVar !Ident !VarInfoPtr !Int !AType | VI_BoundVar !AType | VI_LocalVar | + VI_ClassVar !Ident !VarInfoPtr !Int /* used to hold dictionary variables during overloading */ | VI_Forward !BoundVar | VI_LetVar !LetVarInfo | VI_LetExpression !LetExpressionInfo | VI_CaseVar !VarInfoPtr | VI_CorrespondenceNumber !Int | VI_SequenceNumber !Int | VI_Used | /* for indicating that an imported function has been used */ @@ -547,7 +548,7 @@ cNotVarNumber :== -1 | EI_Overloaded !OverloadedCall /* initial, set by the type checker */ | EI_Instance !(Global DefinedSymbol) ![Expression] /* intermedediate, used during resolving of overloading */ - | EI_Selection ![Selection] !BoundVar ![Expression] /* intermedediate, used during resolving of overloading */ + | EI_Selection ![Selection] !VarInfoPtr ![Expression] /* intermedediate, used during resolving of overloading */ | EI_Context ![Expression] /* intermedediate, used during resolving of overloading */ /* For handling dynamics */ @@ -936,7 +937,8 @@ cIsNotStrict :== False | MatchExpr !(Optional (Global DefinedSymbol)) !(Global DefinedSymbol) !Expression | FreeVar FreeVar - | Constant !SymbIdent !Int !Priority !Bool /* auxiliary clause used during checking */ + | Constant !SymbIdent !Int !Priority !Bool /* auxiliary clause used during checking */ + | ClassVariable !VarInfoPtr /* auxiliary clause used during overloading */ | DynamicExpr !DynamicExpr // | TypeCase !TypeCase @@ -1375,7 +1377,9 @@ where (<<<) file (AnyCodeExpr input output code_sequence) = file <<< "code\n" <<< input <<< "\n" <<< output <<< "\n" <<< code_sequence (<<<) file (FreeVar {fv_name}) = file <<< "FREEVAR " <<< fv_name - (<<<) file expr = abort ("<<< (Expression) [line 1290]" <<- expr) + (<<<) file (ClassVariable _) = file <<< "ClassVariable " + + (<<<) file expr = abort ("<<< (Expression) [line 1290]" )//<<- expr) instance <<< TypeCase where diff --git a/frontend/trans.icl b/frontend/trans.icl index 4ea972a..cd4eef8 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -207,7 +207,7 @@ where ai_cur_ref_counts = { ai_cur_ref_counts & [arg_position]=min (ref_count+1) 2 } = (temp_var, False, { ai & ai_cur_ref_counts=ai_cur_ref_counts }) continuation var_info ai=:{ai_cur_ref_counts} - = abort ("consumerRequirements" ---> (var_name <<- var_info)) + = abort ("consumerRequirements" ---> (var_name))// <<- var_info)) // continuation vi ai // = (cPassive, ai) @@ -280,7 +280,7 @@ instance consumerRequirements Expression where consumerRequirements EE _ ai = (cPassive, False, ai) consumerRequirements expr _ ai - = abort ("consumerRequirements " <<- expr) + = abort ("consumerRequirements ") // <<- expr) requirementsOfSelectors selectors common_defs ai = foldSt (reqs_of_selector common_defs) selectors ai diff --git a/frontend/transform.icl b/frontend/transform.icl index a60978a..58185f5 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -1373,7 +1373,7 @@ where -> (var, [{fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0} : free_vars ], { cos & cos_var_heap = writePtr var_info_ptr (VI_Count 1 is_global) cos.cos_var_heap }) _ - -> abort "collectVariables [BoundVar] (transform, 1227)" <<- (var_info ---> var_name) + -> abort "collectVariables [BoundVar] (transform, 1227)" // <<- (var_info ---> var_name) // XXX instance <<< FreeVar diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 1890ac0..7d859b5 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -1,7 +1,7 @@ implementation module typesupport import StdEnv, StdCompare -import syntax, parse, check, unitype, utilities, RWSDebug +import syntax, parse, check, unitype, utilities // , RWSDebug // MW: this switch is used to en(dis)able the fusion algorithm SwitchFusion fuse dont_fuse :== dont_fuse @@ -799,7 +799,7 @@ where = file <<< '*' | isNonUniqueAttribute av_number coercions = file - = file <<< '.' + = file <<< '.' <<< "[[" <<< av_number <<< "]]" instance <:: Type where diff --git a/frontend/unitype.icl b/frontend/unitype.icl index f56fa7e..cf204be 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -2,7 +2,7 @@ implementation module unitype import StdEnv -import syntax, analunitypes, type, utilities +import syntax, analunitypes, type, utilities // , RWSDebug import cheat @@ -64,6 +64,16 @@ determineAttributeCoercions off_type dem_type coercible position subst coercions No -> (subst, crc_coercions, crc_td_infos, crc_type_heaps, error) +/* + No + + # (crc_coercions, copy_crc_coercions) = uniqueCopy crc_coercions + format = { form_properties = cMarkAttribute, form_attr_position = Yes ([], copy_crc_coercions) } + | file_to_true (stderr <:: (format, exp_off_type) <:: (format, exp_dem_type) <<< '\n') + ---> ("determineAttributeCoercions", exp_off_type, exp_dem_type) + -> (subst, crc_coercions, crc_td_infos, crc_type_heaps, error) + -> undef +*/ NotChecked :== -1 DummyAttrNumber :== -1 :: AttributeGroups :== {! [Int]} @@ -525,6 +535,7 @@ makeNonUnique attr {coer_demanded, coer_offered} # (dem_coercions, coer_demanded) = replace coer_demanded attr CT_Empty coer_offered = { coer_offered & [attr] = CT_NonUnique } = make_non_unique dem_coercions {coer_offered = coer_offered, coer_demanded = coer_demanded} +// ---> ("makeNonUnique", attr) where make_non_unique (CT_Node this_attr ct_less ct_greater) coercions # coercions = makeNonUnique this_attr coercions @@ -549,8 +560,8 @@ Success (Yes _) = False instance coerce AType where coerce sign defs cons_vars tpos at1=:{at_attribute=attr1,at_type=type1} at2=:{at_attribute=attr2,at_type=type2} cs=:{crc_coercions} - # sign = adjust_sign sign type1 cons_vars - (succ, crc_coercions) = coerceAttributes attr1 attr2 sign crc_coercions + # attr_sign = adjust_sign sign type1 cons_vars + (succ, crc_coercions) = coerceAttributes attr1 attr2 attr_sign crc_coercions | succ # (succ, cs) = coerce sign defs cons_vars tpos type1 type2 { cs & crc_coercions = crc_coercions } | Success succ @@ -651,7 +662,8 @@ where = coerce sign defs cons_vars tpos dem_type off_type { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } = (No, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }) coerce sign defs cons_vars tpos (arg_type1 --> res_type1) (arg_type2 --> res_type2) cs - # (succ, cs) = coerce (NegativeSign * sign) defs cons_vars [0 : tpos] arg_type1 arg_type2 cs + # arg_sign = NegativeSign * sign + # (succ, cs) = coerce arg_sign defs cons_vars [0 : tpos] arg_type1 arg_type2 cs | Success succ = coerce sign defs cons_vars [1 : tpos] res_type1 res_type2 cs = (succ, cs) @@ -731,4 +743,12 @@ where | del_char == ident.[del_pos] = del_pos = find_delimiter del_char (inc del_pos) ident + +file_to_true :: !File -> Bool +file_to_true file = code { + .inline file_to_true + pop_b 2 + pushB TRUE + .end + } |