diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/check.icl | 7 | ||||
| -rw-r--r-- | frontend/checkKindCorrectness.icl | 14 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 92 | ||||
| -rw-r--r-- | frontend/compilerSwitches.dcl | 2 | ||||
| -rw-r--r-- | frontend/compilerSwitches.icl | 2 | ||||
| -rw-r--r-- | frontend/frontend.icl | 15 | ||||
| -rw-r--r-- | frontend/generics.icl | 589 | ||||
| -rw-r--r-- | frontend/overloading.icl | 6 | ||||
| -rw-r--r-- | frontend/parse.icl | 23 | ||||
| -rw-r--r-- | frontend/postparse.icl | 2 | ||||
| -rw-r--r-- | frontend/predef.icl | 2 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/syntax.icl | 30 | ||||
| -rw-r--r-- | frontend/type.icl | 65 | ||||
| -rw-r--r-- | frontend/typesupport.dcl | 5 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 78 | ||||
| -rw-r--r-- | frontend/unitype.icl | 53 |
17 files changed, 668 insertions, 319 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 0a36f56..fe7ed0c 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -26,7 +26,6 @@ checkGenerics # (generic_def=:{gen_name, gen_type, gen_pos}, generic_defs) = generic_defs![gen_index] # position = newPosition gen_name gen_pos # cs_error = setErrorAdmin position cs_error - //---> ("checkGenerics generic type 1", gen_type.gt_type) // add * for kind-star instances and *->* for arrays # kinds = @@ -44,6 +43,11 @@ checkGenerics #! {cs_error} = cs #! (gt_vars, st_vars, cs_error) = split_vars gen_type.gt_vars gt_type.st_vars cs_error + + #! cs_error = case gt_type.st_context of + [] -> cs_error + _ -> checkError "" "class contexts are not supported in generic types" cs_error + #! cs = {cs & cs_error = cs_error} #! gt_type = {gt_type & st_vars = st_vars} @@ -55,7 +59,6 @@ checkGenerics } # generic_defs = {generic_defs & [gen_index] = generic_def} - //---> ("checkGenerics generic type 2", gt_type) = checkGenerics (inc gen_index) module_index generic_defs class_defs type_defs modules type_heaps cs where split_vars [] st_vars error diff --git a/frontend/checkKindCorrectness.icl b/frontend/checkKindCorrectness.icl index b8a038c..0228541 100644 --- a/frontend/checkKindCorrectness.icl +++ b/frontend/checkKindCorrectness.icl @@ -265,6 +265,18 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs error_admin = check_equality_of_kinds arg_nr expected_kind KindConst error_admin = (th_vars, td_infos, error_admin) +//AA.. + check_type expected_kind arg_nr TArrow (th_vars, td_infos, error_admin) + # error_admin + = check_equality_of_kinds arg_nr expected_kind (KindArrow [KindConst,KindConst]) error_admin + = (th_vars, td_infos, error_admin) + + check_type expected_kind arg_nr (TArrow1 arg) state + # (th_vars, td_infos, error_admin) = check_atype KindConst arg_nr arg state + # error_admin + = check_equality_of_kinds arg_nr expected_kind (KindArrow [KindConst]) error_admin + = (th_vars, td_infos, error_admin) +//..AA check_type expected_kind arg_nr ((CV tv) :@: args) state # (th_vars, td_infos, error_admin) = foldSt (check_atype KindConst arg_nr) args state @@ -300,7 +312,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs = case tvi of TVI_Empty -> (writePtr tv_info_ptr (TVI_Kind expected_kind) th_vars, error_admin) - TVI_Kind kind + TVI_Kind kind | expected_kind==kind -> (th_vars, error_admin) -> (th_vars, checkError "cannot consistently assign a kind to type variable" diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 8688713..3d26a06 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -120,6 +120,11 @@ where # (arg_type, _, ts_ti_cs) = bindTypes cti arg_type ts_ti_cs (res_type, _, ts_ti_cs) = bindTypes cti res_type ts_ti_cs = (arg_type --> res_type, TA_Multi, ts_ti_cs) +//AA.. + bindTypes cti (TArrow1 type) ts_ti_cs + # (type, _, ts_ti_cs) = bindTypes cti type ts_ti_cs + = (TArrow1 type, TA_Multi, ts_ti_cs) +//..AA bindTypes cti (CV tv :@: types) ts_ti_cs # (tv, type_attr, ts_ti_cs) = bindTypes cti tv ts_ti_cs (types, _, ts_ti_cs) = bindTypes cti types ts_ti_cs @@ -320,6 +325,11 @@ where # (arg_type, expst) = expand module_index arg_type expst (res_type, expst) = expand module_index res_type expst = (arg_type --> res_type, expst) +// AA.. + expand module_index (TArrow1 type) expst + # (type, expst) = expand module_index type expst + = (TArrow1 type, expst) +// ..AA expand module_index (CV tv :@: types) expst # (type, expst) = expandTypeVariable tv expst (types, expst) = expand module_index types expst @@ -367,6 +377,10 @@ where = look_for_cycles module_index types expst look_for_cycles module_index (arg_type --> res_type) expst = look_for_cycles module_index res_type (look_for_cycles module_index arg_type expst) +//AA.. + look_for_cycles module_index (TArrow1 arg_type) expst + = look_for_cycles module_index arg_type expst +//..AA look_for_cycles module_index (type :@: types) expst = look_for_cycles module_index types expst look_for_cycles module_index type expst @@ -545,6 +559,16 @@ getClassDef class_index type_module module_index class_defs modules class_index = convertIndex class_index (toInt STE_Class) dcl_conversions = (class_def, class_index, class_defs, modules) +getGenericDef :: !Index !Index !Index !u:{# GenericDef} !v:{# DclModule} -> (!GenericDef, !Index , !u:{# GenericDef}, !v:{# DclModule}) +getGenericDef generic_index type_module module_index generic_defs modules + | type_module == module_index + #! si = size generic_defs + # (generic_def, generic_defs) = generic_defs![generic_index] + = (generic_def, generic_index, generic_defs, modules) + # ({dcl_common={com_generic_defs},dcl_conversions}, modules) = modules![type_module] + generic_def = com_generic_defs.[generic_index] + generic_index = convertIndex generic_index (toInt STE_Generic) dcl_conversions + = (generic_def, generic_index, generic_defs, modules) checkTypeVar :: !Level !DemandedAttributeKind !TypeVar !TypeAttribute !(!*OpenTypeInfo, !*CheckState) -> (! TypeVar, !TypeAttribute, !(!*OpenTypeInfo, !*CheckState)) @@ -681,6 +705,12 @@ checkOpenAType mod_index scope dem_attr type=:{at_type = arg_type --> result_typ (result_type, (ots, oti, cs)) = checkOpenAType mod_index scope DAK_None result_type cot_state (new_attr, oti, cs) = newAttribute dem_attr "-->" at_attribute oti cs = ({ type & at_type = arg_type --> result_type, at_attribute = new_attr }, (ots, oti, cs)) +//AA.. +checkOpenAType mod_index scope dem_attr type=:{at_type = TArrow1 arg_type, at_attribute} cot_state + # (arg_type, (ots, oti, cs)) = checkOpenAType mod_index scope DAK_None arg_type cot_state + (new_attr, oti, cs) = newAttribute dem_attr "TArrow1" at_attribute oti cs + = ({ type & at_type = TArrow1 arg_type, at_attribute = new_attr }, (ots, oti, cs)) +//..AA checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_attribute} (ots, oti, cs) # (cons_var, _, (oti, cs)) = checkTypeVar scope DAK_None tv TA_Multi (oti, cs) (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types (ots, oti, cs) @@ -740,6 +770,12 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de = ti1==ti2 && are_equal_accu compare_context_and_instance_type (_ --> _) (_ --> _) are_equal_accu = are_equal_accu +//AA.. + compare_context_and_instance_type TArrow TArrow are_equal_accu + = are_equal_accu + compare_context_and_instance_type (TArrow1 _) (TArrow1 _) are_equal_accu + = are_equal_accu +//..AA compare_context_and_instance_type (CV tv1 :@: _) (CV tv2 :@: _) are_equal_accu = tv1==tv2 && are_equal_accu compare_context_and_instance_type (TB bt1) (TB bt2) are_equal_accu @@ -863,7 +899,61 @@ checkTypeContext mod_index tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ = (tc, (class_defs, ots, oti, cs)) = (tc, (class_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error })) = ({tc & tc_types = []}, (class_defs, ots, oti, { cs & cs_error = checkError id_name "undefined" cs.cs_error })) -where +where + + check_context_types tc_class [] cs=:{cs_error} + = { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error} + check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error} + = cs +// = { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error} + check_context_types tc_class [TV _ : types] cs + = cs + check_context_types tc_class [type : types] cs + = check_context_types tc_class types cs + +checkTypeContext1 :: !Index !TypeContext !(!v:{# ClassDef}, !x:{# GenericDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState) + -> (!TypeContext,!(!v:{# ClassDef}, !x:{# GenericDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)) +checkTypeContext1 mod_index tc (class_defs, generic_defs, ots, oti, cs) + # (entry, cs) = get_entry tc cs + = check_context mod_index entry tc (class_defs, generic_defs, ots, oti, cs) +where + get_entry tc cs=:{cs_symbol_table} + # (entry, cs_symbol_table) = readPtr tc.tc_class.glob_object.ds_ident.id_info cs_symbol_table + = (entry, {cs & cs_symbol_table = cs_symbol_table}) + + check_context + mod_index + entry + tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types} + (class_defs, generic_defs, ots, oti, cs) + # (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index + | class_index <> NotFound + # (class_def, class_index, class_defs, ots_modules) = getClassDef class_index class_module mod_index class_defs ots.ots_modules + ots = { ots & ots_modules = ots_modules } + (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) + cs = check_context_types class_def.class_name tc_types cs + tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types} + | class_def.class_arity == ds_arity + = (tc, (class_defs, generic_defs, ots, oti, cs)) + = (tc, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error })) + = ({tc & tc_types = []}, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "class undefined" cs.cs_error })) + check_context + mod_index + entry + tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types} + (class_defs, generic_defs, ots, oti, cs) + # (generic_index, generic_module) = retrieveGlobalDefinition entry STE_Generic mod_index + | generic_index <> NotFound + # (generic_def, generic_index, generic_defs, ots_modules) = getGenericDef generic_index generic_module mod_index generic_defs ots.ots_modules + ots = { ots & ots_modules = ots_modules } + (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) + //cs = check_context_types generic_def.gen_name tc_types cs + tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = generic_index }, glob_module = generic_module }, tc_types = tc_types} + | ds_arity == 1 + = (tc, (class_defs, generic_defs, ots, oti, cs)) + = (tc, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error })) + = ({tc & tc_types = []}, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "generic undefined" cs.cs_error })) + check_context_types tc_class [] cs=:{cs_error} = { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error} check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error} diff --git a/frontend/compilerSwitches.dcl b/frontend/compilerSwitches.dcl index f0ccb8a..f0683a2 100644 --- a/frontend/compilerSwitches.dcl +++ b/frontend/compilerSwitches.dcl @@ -1,6 +1,6 @@ definition module compilerSwitches -SwitchGenerics on off :== off +SwitchGenerics on off :== on PA_BUG on off :== off diff --git a/frontend/compilerSwitches.icl b/frontend/compilerSwitches.icl index f7ac566..9d65c97 100644 --- a/frontend/compilerSwitches.icl +++ b/frontend/compilerSwitches.icl @@ -1,6 +1,6 @@ implementation module compilerSwitches -SwitchGenerics on off :== off +SwitchGenerics on off :== on PA_BUG on off :== off diff --git a/frontend/frontend.icl b/frontend/frontend.icl index f94a344..415ef80 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -145,8 +145,15 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac heaps hash_table predef_symbols dcl_mods optional_dcl_icl_conversions error_admin) (components, ti_common_defs, fun_defs, {ir_to=0,ir_from=0}, td_infos, heaps, hash_table, predef_symbols, dcl_mods, optional_dcl_icl_conversions, error_admin) - # (icl_common, ti_common_defs) = replace ti_common_defs main_dcl_module_n saved_main_dcl_common + + # (icl_common, ti_common_defs) = replace copied_ti_common_defs main_dcl_module_n saved_main_dcl_common + with + copied_ti_common_defs :: !.{#CommonDefs} // needed for Clean 2.0 to disambiguate overloading of replace + copied_ti_common_defs = {x \\ x <-: ti_common_defs} + # dcl_mods = { {dcl_mod & dcl_common = common} \\ dcl_mod <-: dcl_mods & common <-: ti_common_defs } + + # icl_mod = {icl_mod & icl_common = icl_common} # error = error_admin.ea_file #! ok = error_admin.ea_ok @@ -165,7 +172,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials, generic_range] // (components, fun_defs, error) = showTypes components 0 fun_defs error -// (components, fun_defs, error) = showComponents components 0 True fun_defs error +// (components, fun_defs, out) = showComponents components 0 True fun_defs out // (fun_defs, error) = showFunctions array_instances fun_defs error | upToPhase == FrontEndPhaseTypeCheck @@ -362,4 +369,6 @@ where # file = show_dcl_function dcl_functions.[fun_index] file = show_dcl_functions (inc fun_index) dcl_functions file show_dcl_function {ft_symb, ft_type} file - = file <<< ft_symb <<< " :: " <<< ft_type <<< "\n"
\ No newline at end of file + = file <<< ft_symb <<< " :: " <<< ft_type <<< "\n" + +
\ No newline at end of file diff --git a/frontend/generics.icl b/frontend/generics.icl index dab9b8d..e1bc16c 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -11,7 +11,7 @@ import analtypes // whether to generate CONS // (needed for function that use CONS, like toString) -supportCons :== False +supportCons :== True // whether to bind _cons_info to actual constructor info // (needed for functions that create CONS, like fromString) @@ -125,7 +125,7 @@ convertGenerics #! gs = collectInstanceKinds gs - //---> "*** collect kinds used in generic instances and update generics with them" + //---> "*** collect kinds used in generic instances and store them in the generics" #! (ok,gs) = gs!gs_error.ea_ok | not ok = return gs predefs hash_table @@ -148,6 +148,12 @@ convertGenerics | not ok = return gs predefs hash_table + #! gs = checkConsInstances gs + //---> "*** check that cons instances are provided for all generics" + #! (ok,gs) = gs!gs_error.ea_ok + | not ok + = return gs predefs hash_table + #! (cons_funs, cons_groups, gs) = buildConsInstances gs | not ok //---> "*** bind function for CONS" @@ -317,7 +323,7 @@ where convert_instance module_index instance_index instance_defs gs=:{gs_td_infos, gs_modules, gs_error, gs_fun_defs, gs_predefs, gs_heaps} - #! (instance_def=:{ins_class,ins_ident,ins_pos}, instance_defs) = instance_defs ! [instance_index] + #! (instance_def=:{ins_class,ins_ident}, instance_defs) = instance_defs ! [instance_index] | not instance_def.ins_is_generic # gs = { gs & gs_td_infos = gs_td_infos @@ -396,7 +402,7 @@ where determine_td_index (SynType _) gs_modules gs_error # gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) - "generic instance type cannot be a sysnonym type" + "generic instance type cannot be a synonym type" gs_error = ([], instance_def, gs_modules, gs_error) determine_td_index (AbstractType _) gs_modules gs_error @@ -406,9 +412,31 @@ where "cannot generate an instance for an abstract data type" gs_error = ([], instance_def, gs_modules, gs_error) - = ([], instance_def, gs_modules, gs_error) - determine_type_def_index (TB _) instance_def _ gs_modules gs_error - = ([], instance_def, gs_modules, gs_error) + = ([], instance_def, gs_modules, gs_error) + determine_type_def_index TArrow instance_def=:{ins_generate,ins_ident,ins_pos} _ gs_modules gs_error + | ins_generate + # gs_error = checkErrorWithIdentPos + (newPosition ins_ident ins_pos) + "cannot generate an instance for arrow type" + gs_error + = ([], instance_def, gs_modules, gs_error) + = ([], instance_def, gs_modules, gs_error) + determine_type_def_index (TArrow1 _) instance_def=:{ins_generate,ins_ident,ins_pos} _ gs_modules gs_error + | ins_generate + # gs_error = checkErrorWithIdentPos + (newPosition ins_ident ins_pos) + "cannot generate an instance for arrow type" + gs_error + = ([], instance_def, gs_modules, gs_error) + = ([], instance_def, gs_modules, gs_error) + determine_type_def_index (TB _) instance_def=:{ins_generate,ins_ident,ins_pos} _ gs_modules gs_error + | ins_generate + # gs_error = checkErrorWithIdentPos + (newPosition ins_ident ins_pos) + "cannot generate an instance for a basic type" + gs_error + = ([], instance_def, gs_modules, gs_error) + = ([], instance_def, gs_modules, gs_error) determine_type_def_index _ instance_def=:{ins_ident,ins_pos} _ gs_modules gs_error #! gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) @@ -483,6 +511,41 @@ where = (False, gs_modules, gs_error) = (True, gs_modules, gs_error) +// check that CONS instances are provided for all generics +checkConsInstances :: !*GenericState -> !*GenericState +checkConsInstances gs + | supportConsInfo + = check_cons_instances 0 0 gs + = gs + +where + check_cons_instances module_index generic_index gs=:{gs_modules, gs_heaps, gs_error} + #! size_gs_modules = size gs_modules + | module_index == size_gs_modules + = {gs & gs_modules = gs_modules} + # (generic_defs, gs_modules) = gs_modules ! [module_index].com_generic_defs + #! size_generic_defs = size generic_defs + | generic_index == size_generic_defs + = check_cons_instances (inc module_index) 0 {gs & gs_modules = gs_modules} + + # (gs_heaps, gs_error) = check_generic generic_defs.[generic_index] gs_heaps gs_error + = check_cons_instances + module_index (inc generic_index) + {gs & gs_modules = gs_modules, gs_heaps = gs_heaps, gs_error = gs_error} + + check_generic + {gen_cons_ptr, gen_name, gen_pos} + gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} + gs_error + # (info, th_vars) = readPtr gen_cons_ptr th_vars + # gs_error = case info of + TVI_ConsInstance _ + -> gs_error + _ + -> reportError gen_name gen_pos "instance on CONS must be provided" gs_error + = ({gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}, gs_error) + + collectGenericTypes :: !*GenericState -> (![Type], !*GenericState) collectGenericTypes gs=:{gs_modules} # (types, gs_modules) = collect_in_modules 0 0 gs_modules @@ -681,7 +744,7 @@ where = ([], [], generic_def, class_index, member_index, gs) build_classes [kind:kinds] generic_def module_index class_index member_index gs #! (class_def, member_def, generic_def, gs) = - buildClassDef1 module_index class_index member_index generic_def kind gs + buildClassDef module_index class_index member_index generic_def kind gs #! (class_defs, member_defs, generic_def, class_index, member_index, gs) = build_classes kinds generic_def module_index (inc class_index) (inc member_index) gs = ([class_def:class_defs], [member_def:member_defs], generic_def, class_index, member_index, gs) @@ -726,34 +789,57 @@ where collect_in_type :: !Type !*GenericState -> (![(Global Index, Int)], !*GenericState) - collect_in_type (TA {type_arity=0, type_name} _) gs=:{gs_gtd_infos, gs_td_infos, gs_modules} - // types with no arguments do not need mapping to be built: - // their mapping is identity - = ([], gs) - //---> ("ignore type", type_name) - collect_in_type (TA {type_index, type_name} args) gs=:{gs_gtd_infos, gs_td_infos, gs_modules} - # {glob_module, glob_object} = type_index - #! (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [glob_module, glob_object] - | toBool gtd_info // already marked - = ([], {gs & gs_gtd_infos = gs_gtd_infos}) - //---> ("already marked type", type_name, type_index) - #! gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType} - //---> ("collect in type", type_name.id_name, type_index) - #! (type_def, gs_modules) = getTypeDef glob_module glob_object gs_modules - #! (td_info, gs_td_infos) = gs_td_infos ! [glob_module, glob_object] - # gs = {gs & gs_td_infos = gs_td_infos, gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules} - # (td_indexes, gs) = collect_in_type_def_rhs glob_module type_def gs - = (merge_td_indexes [(type_index, td_info.tdi_group_nr)] td_indexes, gs) - collect_in_type (arg --> res) gs - #! (td_indexes1, gs) = collect_in_type arg.at_type gs - #! (td_indexes2, gs) = collect_in_type res.at_type gs - = (td_indexes1 ++ td_indexes2, gs) + collect_in_type (TA type_symb arg_types) gs + # (td_indexes1, gs) = collect_in_atypes arg_types gs + # (td_indexes2, gs) = collect_in_type_app type_symb gs + = (merge_td_indexes td_indexes1 td_indexes2, gs) + where + collect_in_type_app {type_arity=0} gs + // types with no arguments do not need mapping to be built: + // their mapping is identity + = ([], gs) + collect_in_type_app + {type_index=type_index=:{glob_module, glob_object}, type_name} + gs=:{gs_gtd_infos, gs_td_infos, gs_modules} + # (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [glob_module, glob_object] + | toBool gtd_info // already marked + = ([], {gs & gs_gtd_infos = gs_gtd_infos}) + //---> ("already marked type", type_name, type_index) + | otherwise // not yet marked + # gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType} + # (td_info, gs_td_infos) = gs_td_infos ! [glob_module, glob_object] + # (type_def, gs_modules) = getTypeDef glob_module glob_object gs_modules + # gs = {gs & gs_td_infos = gs_td_infos, gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules} + # (td_indexes1, gs) = collect_in_type_def_rhs glob_module type_def gs + # td_indexes2 = [(type_index, td_info.tdi_group_nr)] + = (merge_td_indexes td_indexes1 td_indexes2, gs) + //---> ("already marked type", type_name, type_index) + + collect_in_type (arg_type --> res_type) gs + #! (td_indexes1, gs) = collect_in_atype arg_type gs + #! (td_indexes2, gs) = collect_in_atype res_type gs + = (merge_td_indexes td_indexes1 td_indexes2, gs) + collect_in_type (TArrow1 arg_type) gs + = collect_in_atype arg_type gs collect_in_type (cons_var :@: args) gs - # types = [ at_type \\ {at_type} <- args] + #! types = [ at_type \\ {at_type} <- args] = collect_in_types types gs collect_in_type _ gs = ([], gs) + collect_in_atype :: !AType !*GenericState + -> (![(Global Index, Int)], !*GenericState) + collect_in_atype {at_type} gs = collect_in_type at_type gs + + collect_in_atypes :: ![AType] !*GenericState + -> (![(Global Index, Int)], !*GenericState) + collect_in_atypes [] gs = ([], gs) + collect_in_atypes [atype:atypes] gs + # (td_indexes1, gs) = collect_in_atype atype gs + # (td_indexes2, gs) = collect_in_atypes atypes gs + # merged_td_indexes = merge_td_indexes td_indexes1 td_indexes2 + = (merged_td_indexes, gs) + collect_in_type_def_rhs :: !Index !CheckedTypeDef !*GenericState -> (![(Global Index, Int)], !*GenericState) collect_in_type_def_rhs mod {td_rhs=(AlgType cons_def_symbols)} gs @@ -763,13 +849,13 @@ where collect_in_type_def_rhs mod {td_rhs=(SynType {at_type})} gs = collect_in_type at_type gs collect_in_type_def_rhs mod {td_rhs=(AbstractType _), td_name, td_pos} gs=:{gs_error} - # gs_error = checkErrorWithIdentPos + #! gs_error = checkErrorWithIdentPos (newPosition td_name td_pos) "cannot build generic type representation for an abstract type" gs_error = ([], {gs & gs_error = gs_error}) //= ([], {gs & gs_error = checkWarning td_name "abstract data type" gs_error}) - + collect_in_conses :: !Index ![DefinedSymbol] !*GenericState -> (![(Global Index, Int)], !*GenericState) collect_in_conses mod [] gs @@ -783,8 +869,8 @@ where = (merge_td_indexes td_indexes1 td_indexes2, gs) collect_in_symbol_type {st_args, st_result} gs - # (td_indexes1, gs) = collect_in_types (map (\x->x.at_type) st_args) gs - # (td_indexes2, gs) = collect_in_type st_result.at_type gs + #! (td_indexes1, gs) = collect_in_types (map (\x->x.at_type) st_args) gs + #! (td_indexes2, gs) = collect_in_type st_result.at_type gs = (merge_td_indexes td_indexes1 td_indexes2, gs) merge_td_indexes x y @@ -795,8 +881,8 @@ buildIsoFunctions :: ![Global Index] !*GenericState -> (![FunDef], ![Group], !*GenericState) buildIsoFunctions [] gs = ([], [], gs) buildIsoFunctions [type_index:type_indexes] gs - # (iso_funs1, iso_groups1, gs) = build_function type_index gs - # (iso_funs2, iso_groups2, gs) = buildIsoFunctions type_indexes gs + #! (iso_funs1, iso_groups1, gs) = build_function type_index gs + #! (iso_funs2, iso_groups2, gs) = buildIsoFunctions type_indexes gs = (iso_funs1 ++ iso_funs2, iso_groups1 ++ iso_groups2, gs) where build_function {glob_module, glob_object} gs @@ -1454,23 +1540,31 @@ where = (fun_def, {gs & gs_heaps = gs_heaps}) build_instance_type ins_type=:{it_vars, it_types, it_context} (KindArrow kinds) class_glob_def_sym heaps - # type_var_names = ["a" +++ toString i \\ i <- [1 .. (length kinds) - 1]] - # (type_vars, heaps) = mapSt buildTypeVar type_var_names heaps - # type_var_types = map TV type_vars - # new_type_args = map (\t->makeAType t TA_Multi) type_var_types + #! type_var_names = ["a" +++ toString i \\ i <- [1 .. (length kinds) - 1]] + #! (type_vars, heaps) = mapSt buildTypeVar type_var_names heaps + #! type_var_types = [TV tv \\ tv <- type_vars] + #! new_type_args = [makeAType t TA_Multi \\ t <- type_var_types] - # (TA type_symb_ident=:{type_arity} type_args) = hd it_types - # new_type = TA {type_symb_ident & type_arity = type_arity + length new_type_args} (type_args ++ new_type_args) + #! new_type = fill_type_args (hd it_types) new_type_args + with + fill_type_args (TA type_symb_ident=:{type_arity} type_args) new_type_args + #! type_arity = type_arity + length new_type_args + #! type_args = type_args ++ new_type_args + = TA {type_symb_ident & type_arity = type_arity} type_args + fill_type_args TArrow [arg_type, res_type] + = arg_type --> res_type + fill_type_args (TArrow1 arg_type) [res_type] + = arg_type --> res_type - # (new_contexts, heaps) = mapSt (build_type_context class_glob_def_sym) type_var_types heaps + #! (new_contexts, heaps) = mapSt (build_type_context class_glob_def_sym) type_var_types heaps - # new_ins_type = { ins_type & + #! new_ins_type = { ins_type & it_vars = it_vars ++ type_vars, it_types = [new_type], it_context = it_context ++ new_contexts } = (new_ins_type, heaps) - //---> new_ins_type + //---> new_ins_type build_type_var name heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars @@ -1482,11 +1576,10 @@ where build_type_context class_glob_def_sym type heaps=:{hp_var_heap} # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - # type_context = { - - tc_class = class_glob_def_sym, - tc_types = [type], - tc_var = var_info_ptr + # type_context = + { tc_class = class_glob_def_sym + , tc_types = [type] + , tc_var = var_info_ptr } = (type_context, {heaps & hp_var_heap = hp_var_heap}) @@ -1496,17 +1589,17 @@ determineMemberTypes :: !Index !Index !*GenericState -> !*GenericState determineMemberTypes module_index ins_index gs=:{gs_modules, gs_fun_defs, gs_heaps=gs_heaps=:{hp_var_heap, hp_type_heaps}, gs_dcl_modules, gs_main_dcl_module_n} - # (num_modules, gs_modules) = usize gs_modules + #! (num_modules, gs_modules) = usize gs_modules | module_index == num_modules = {gs & gs_modules = gs_modules} - # (common_defs=:{com_instance_defs}, gs_modules) = gs_modules![module_index] + #! (common_defs=:{com_instance_defs}, gs_modules) = gs_modules![module_index] | ins_index == size com_instance_defs = determineMemberTypes (inc module_index) 0 {gs & gs_modules = gs_modules} - # (instance_def, com_instance_defs) = com_instance_defs![ins_index] + #! (instance_def, com_instance_defs) = com_instance_defs![ins_index] | not instance_def.ins_is_generic = determineMemberTypes module_index (inc ins_index) {gs & gs_modules = gs_modules} - # gs = determine_member_type module_index ins_index instance_def {gs & gs_modules = gs_modules} + #! gs = determine_member_type module_index ins_index instance_def {gs & gs_modules = gs_modules} = determineMemberTypes module_index (inc ins_index) gs where determine_member_type @@ -1520,30 +1613,30 @@ where gs_main_dcl_module_n, gs_opt_dcl_icl_conversions} - # (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules - # (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules - # {me_type, me_class_vars} = member_def + #! (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules + #! (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules + #! {me_type, me_class_vars} = member_def // determine type of the instance function - # (symbol_type, _, hp_type_heaps, _, _) = + #! (symbol_type, _, hp_type_heaps, _, _) = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps No No - # (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap - # symbol_type = {symbol_type & st_context = st_context} + #! (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap + #! symbol_type = {symbol_type & st_context = st_context} // determine the instance function index (in icl or dcl) - # fun_index = ins_members.[0].ds_index + #! fun_index = ins_members.[0].ds_index | fun_index == NoIndex = abort "no generic instance function\n" // update the instance function | module_index == gs_main_dcl_module_n // icl module - # (fun_def, gs_fun_defs) = gs_fun_defs![fun_index] - # fun_def = { fun_def & fun_type = Yes symbol_type } - # gs_fun_defs = {gs_fun_defs & [fun_index] = fun_def} + #! (fun_def, gs_fun_defs) = gs_fun_defs![fun_index] + #! fun_def = { fun_def & fun_type = Yes symbol_type } + #! gs_fun_defs = {gs_fun_defs & [fun_index] = fun_def} // update corresponding DCL function type, which is empty at the moment - # ({dcl_conversions}, gs_dcl_modules) = gs_dcl_modules ! [gs_main_dcl_module_n] - # (dcl_fun_index, gs_opt_dcl_icl_conversions) + #! ({dcl_conversions}, gs_dcl_modules) = gs_dcl_modules ! [gs_main_dcl_module_n] + #! (dcl_fun_index, gs_opt_dcl_icl_conversions) = find_dcl_fun_index fun_index gs_opt_dcl_icl_conversions// XXX with find_dcl_fun_index icl_fun_index No @@ -1552,16 +1645,16 @@ where #! table1 = {x\\x<-:table} = find_index 0 icl_fun_index table find_index i index table - # (size_table, table) = usize table + #! (size_table, table) = usize table | i == size_table = (NoIndex /*abort ("not found dcl function index " +++ toString index)*/, Yes table) - # (x, table) = table ! [i] + #! (x, table) = table ! [i] | x == index = (i /*abort ("found dcl function index " +++ toString index +++ " " +++ toString i)*/, Yes table) = find_index (inc i) index table - # gs_dcl_modules = case dcl_fun_index of + #! gs_dcl_modules = case dcl_fun_index of NoIndex -> gs_dcl_modules _ -> update_dcl_fun_type gs_main_dcl_module_n dcl_fun_index symbol_type gs_dcl_modules @@ -1575,7 +1668,7 @@ where | otherwise // dcl module //---> ("update dcl instance function", ins_ident, module_index, ins_index, symbol_type) - # gs_dcl_modules = update_dcl_fun_type module_index fun_index symbol_type gs_dcl_modules + #! gs_dcl_modules = update_dcl_fun_type module_index fun_index symbol_type gs_dcl_modules = { gs & gs_modules = gs_modules , gs_dcl_modules = gs_dcl_modules @@ -1597,126 +1690,35 @@ where kindOfTypeDef :: Index Index !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos) kindOfTypeDef module_index td_index td_infos - # ({tdi_kinds}, td_infos) = td_infos![module_index, td_index] + #! ({tdi_kinds}, td_infos) = td_infos![module_index, td_index] | isEmpty tdi_kinds = (KindConst, td_infos) = (KindArrow (tdi_kinds ++ [KindConst]), td_infos) kindOfType :: !Type !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos) kindOfType (TA type_cons args) td_infos - # {glob_object,glob_module} = type_cons.type_index - # ({tdi_kinds}, td_infos) = td_infos![glob_module,glob_object] - # kinds = drop (length args) tdi_kinds + #! {glob_object,glob_module} = type_cons.type_index + #! ({tdi_kinds}, td_infos) = td_infos![glob_module,glob_object] + #! kinds = drop (length args) tdi_kinds | isEmpty kinds = (KindConst, td_infos) = (KindArrow (kinds ++ [KindConst]), td_infos) -kindOfType (TV _) td_infos = (KindConst, td_infos) -kindOfType (GTV _) td_infos = (KindConst, td_infos) -kindOfType (TQV _) td_infos = (KindConst, td_infos) -kindOfType _ td_infos = (KindConst, td_infos) +kindOfType TArrow td_infos + = (KindArrow [KindConst, KindConst, KindConst], td_infos) +kindOfType (TArrow1 _) td_infos + = (KindArrow [KindConst, KindConst], td_infos) +kindOfType (TV _) td_infos + = (KindConst, td_infos) +kindOfType (GTV _) td_infos + = (KindConst, td_infos) +kindOfType (TQV _) td_infos + = (KindConst, td_infos) +kindOfType _ td_infos + = (KindConst, td_infos) -buildClassDef :: /*generic*/!(Global DefinedSymbol) !TypeKind !*GenericState - -> (/*class*/!(Global DefinedSymbol), !*GenericState) -buildClassDef - generic_glob=:{glob_module, glob_object={ds_ident, ds_index}} - kind - gs=:{gs_modules, gs_heaps=gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}, hp_var_heap}} - #! (common_defs=:{com_generic_defs, com_class_defs, com_member_defs}, gs_modules) = gs_modules![glob_module] - #! (generic_def=:{gen_name=gen_name=:{id_name}, gen_type, gen_pos, gen_classes}, com_generic_defs) = com_generic_defs![ds_index] - - // check if the class is already created - # (found, class_symbol) = getGenericClassForKind generic_def kind - | found - = ( {glob_module = glob_module, glob_object = class_symbol}, - {gs & gs_modules = gs_modules}) - - #! id_name = id_name +++ ":" +++ (toString kind) - #! ident = {id_name = id_name, id_info = nilPtr} - - // allocate new class and member - #! class_index = size com_class_defs - #! class_ds = {ds_ident = ident, ds_index = class_index, ds_arity = 1} - #! glob_class = {glob_module = glob_module, glob_object = class_ds} - #! member_index = size com_member_defs - - // class argument - #! (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars - #! class_arg = {tv_name = {id_name = "class_var", id_info = nilPtr}, tv_info_ptr = tv_info_ptr} - - // member - #! (type_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - #! (tc_var_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - #! type_context = { - tc_class = glob_class, - tc_types = [ TV class_arg ], - tc_var = tc_var_ptr // ??? - } - #! hp_type_heaps = {hp_type_heaps & th_vars = th_vars} - #! (member_type, hp_type_heaps) = buildMemberType1 generic_def kind class_arg hp_type_heaps - #! member_type = { member_type & st_context = [type_context : gen_type.gt_type.st_context] } - #! member_def = { - me_symb = ident, - me_class = {glob_module = glob_module, glob_object = class_index}, - me_offset = 0, - me_type = member_type, - me_type_ptr = type_ptr, // empty - me_class_vars = [class_arg], // the same variable as in the class - me_pos = gen_pos, - me_priority = NoPrio - } - - // class - #! class_member = {ds_ident=ident, ds_index = member_index, ds_arity = member_def.me_type.st_arity} - #! class_dictionary = { - ds_ident = {id_name = id_name, id_info = nilPtr}, - ds_arity = 0, - ds_index = NoIndex/*index in the type def table, filled in later*/ - } - #! class_def = { - class_name = ident, - class_arity = 1, - class_args = [class_arg], - class_context = [], - class_pos = gen_pos, - class_members = createArray 1 class_member, - class_cons_vars = case kind of KindConst -> 0; _ -> 1, - class_dictionary = class_dictionary, - class_arg_kinds = [kind] - } - - #! com_class_defs = append_array com_class_defs class_def - #! com_member_defs = append_array com_member_defs member_def - #! generic_def = {generic_def & gen_classes = [{gci_kind = kind, gci_class = class_ds} : gen_classes] } - #! com_generic_defs = {(copy_array com_generic_defs) & [ds_index] = generic_def} - #! common_defs = {common_defs & - com_class_defs = com_class_defs, - com_generic_defs = com_generic_defs, - com_member_defs = com_member_defs} - #! gs_modules = {gs_modules & [glob_module] = common_defs} - #! gs = { gs & - gs_modules = gs_modules, - gs_heaps = { gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} - } - = (glob_class, gs) - //---> ("generated class " +++ id_name) -where - append_array array el -//1.3 - = arrayConcat array {el} -//3.1 -/*2.0 - = r2 - where - r2={r1 & [s]=el} - r1={r0 & [i]=array.[i] \\ i<-[0..s-1]} - r0 = _createArray (s+1) - s = size array -0.2*/ - copy_array array = {x \\ x <-: array} - -buildClassDef1 :: !Index !Index !Index !GenericDef !TypeKind !*GenericState +buildClassDef :: !Index !Index !Index !GenericDef !TypeKind !*GenericState -> (!ClassDef, !MemberDef!, !GenericDef, *GenericState) -buildClassDef1 module_index class_index member_index generic_def=:{gen_name, gen_classes} kind gs=:{gs_heaps} +buildClassDef module_index class_index member_index generic_def=:{gen_name, gen_classes} kind gs=:{gs_heaps} #! ident = makeIdent (gen_name.id_name +++ ":" +++ (toString kind)) #! class_ds={ds_ident=ident, ds_index=class_index, ds_arity=0} #! (class_var, gs_heaps) = build_class_var gs_heaps @@ -1737,12 +1739,12 @@ where heaps=:{hp_var_heap, hp_type_heaps} #! (type_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap #! (tc_var_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - #! type_context = { - tc_class = {glob_module = module_index, glob_object=class_ds}, - tc_types = [ TV class_var ], - tc_var = tc_var_ptr // ??? + #! type_context = + { tc_class = {glob_module = module_index, glob_object=class_ds} + , tc_types = [ TV class_var ] + , tc_var = tc_var_ptr } - #! (member_type, hp_type_heaps) = buildMemberType1 generic_def kind class_var hp_type_heaps + #! (member_type, hp_type_heaps) = buildMemberType generic_def kind class_var hp_type_heaps #! member_type = { member_type & st_context = [type_context : gen_type.gt_type.st_context] } #! member_def = { me_symb = ds_ident, // same name as class @@ -1772,7 +1774,7 @@ where class_context = [], class_pos = gen_pos, class_members = createArray 1 class_member, - class_cons_vars = case kind of KindConst -> 0; _ -> 1, + class_cons_vars = 0, // dotted class variables class_dictionary = class_dictionary, class_arg_kinds = [kind] } @@ -1859,8 +1861,8 @@ where = (cum_attr, [], [], index, th_attrs) -buildMemberType1 :: !GenericDef !TypeKind !TypeVar !*TypeHeaps -> (!SymbolType, !*TypeHeaps) -buildMemberType1 generic_def=:{gen_name,gen_type} kind class_var th +buildMemberType :: !GenericDef !TypeKind !TypeVar !*TypeHeaps -> (!SymbolType, !*TypeHeaps) +buildMemberType generic_def=:{gen_name,gen_type} kind class_var th #! (gen_type, th) = freshGenericType gen_type th @@ -2111,11 +2113,11 @@ where -> ([AlgebraicPattern], [FreeVar], !*GenericState) build_alts i n type_def_mod [] [] gs = ([], [], gs) build_alts i n type_def_mod [cons_def_sym:cons_def_syms] cons_infos gs - # (cons_info, cons_infos) = case supportCons of + #! (cons_info, cons_infos) = case supportCons of True -> (hd cons_infos, tl cons_infos) False -> (EmptyDefinedSymbol, []) - # (alt, fvs, gs) = build_alt i n type_def_mod cons_def_sym cons_info gs - # (alts, free_vars, gs) = build_alts (i+1) n type_def_mod cons_def_syms cons_infos gs + #! (alt, fvs, gs) = build_alt i n type_def_mod cons_def_sym cons_info gs + #! (alts, free_vars, gs) = build_alts (i+1) n type_def_mod cons_def_syms cons_infos gs = ([alt:alts], fvs ++ free_vars, gs) build_alt :: !Int !Int !Int !DefinedSymbol !DefinedSymbol !*GenericState @@ -2123,19 +2125,19 @@ where build_alt i n type_def_mod def_symbol=:{ds_ident, ds_arity} cons_info gs=:{gs_heaps, gs_predefs, gs_main_dcl_module_n} - # names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]] - # (var_exprs, vars, gs_heaps) = buildVarExprs names gs_heaps - # (expr, gs_heaps) = build_prod var_exprs gs_predefs gs_heaps - # (expr, gs_heaps) = case supportCons of + #! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]] + #! (var_exprs, vars, gs_heaps) = buildVarExprs names gs_heaps + #! (expr, gs_heaps) = build_prod var_exprs gs_predefs gs_heaps + #! (expr, gs_heaps) = case supportCons of True //# (cons_info_expr, gs_heaps) = buildUndefFunApp [] gs_predefs gs_heaps # (cons_info_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n cons_info [] gs_heaps -> buildCONS cons_info_expr expr gs_predefs gs_heaps False -> (expr, gs_heaps) - # (expr, gs_heaps) = build_sum i n expr gs_predefs gs_heaps + #! (expr, gs_heaps) = build_sum i n expr gs_predefs gs_heaps - # alg_pattern = { + #! alg_pattern = { ap_symbol = {glob_module = type_def_mod, glob_object = def_symbol}, ap_vars = vars, ap_expr = expr, @@ -2197,55 +2199,55 @@ where build_sum type_def_mod [] predefs heaps error = abort "algebraic type with no constructors!\n" build_sum type_def_mod [def_symbol] predefs heaps error - # (cons_app_expr, cons_args, heaps) = build_cons_app type_def_mod def_symbol heaps - # (alt_expr, free_vars, heaps) = build_prod cons_app_expr cons_args predefs heaps + #! (cons_app_expr, cons_args, heaps) = build_cons_app type_def_mod def_symbol heaps + #! (alt_expr, free_vars, heaps) = build_prod cons_app_expr cons_args predefs heaps = case supportCons of True - # (var_expr, var, heaps) = buildVarExpr "c" heaps - # (info_var, heaps) = buildFreeVar0 "i" heaps - # (alt_expr, heaps) = buildCaseCONSExpr var_expr info_var (hd free_vars) alt_expr predefs heaps + #! (var_expr, var, heaps) = buildVarExpr "c" heaps + #! (info_var, heaps) = buildFreeVar0 "i" heaps + #! (alt_expr, heaps) = buildCaseCONSExpr var_expr info_var (hd free_vars) alt_expr predefs heaps -> (alt_expr, [var, info_var : free_vars], heaps, error) False -> (alt_expr, free_vars, heaps, error) build_sum type_def_mod def_symbols predefs heaps error - # (var_expr, var, heaps) = buildVarExpr "e" heaps - # (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols + #! (var_expr, var, heaps) = buildVarExpr "e" heaps + #! (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols - # (left_expr, left_vars, heaps, error) = build_sum type_def_mod left_def_syms predefs heaps error - # (right_expr, right_vars, heaps, error) = build_sum type_def_mod right_def_syms predefs heaps error + #! (left_expr, left_vars, heaps, error) = build_sum type_def_mod left_def_syms predefs heaps error + #! (right_expr, right_vars, heaps, error) = build_sum type_def_mod right_def_syms predefs heaps error - # (case_expr, heaps) = + #! (case_expr, heaps) = buildCaseEITHERExpr var_expr (hd left_vars, left_expr) (hd right_vars, right_expr) predefs heaps - # vars = [var : left_vars ++ right_vars] + #! vars = [var : left_vars ++ right_vars] = (case_expr, vars, heaps, error) build_prod :: !Expression ![FreeVar] !PredefinedSymbols !*Heaps -> (!Expression, ![FreeVar], !*Heaps) build_prod expr [] predefs heaps - # (var_expr, var, heaps) = buildVarExpr "x" heaps - # (case_expr, heaps) = buildCaseUNITExpr var_expr expr predefs heaps + #! (var_expr, var, heaps) = buildVarExpr "x" heaps + #! (case_expr, heaps) = buildCaseUNITExpr var_expr expr predefs heaps = (case_expr, [var], heaps) build_prod expr [cons_arg_var] predefs heaps = (expr, [cons_arg_var], heaps) build_prod expr cons_arg_vars predefs heaps - # (var_expr, var, heaps) = buildVarExpr "p" heaps - # (left_vars, right_vars) = splitAt ((length cons_arg_vars) /2) cons_arg_vars + #! (var_expr, var, heaps) = buildVarExpr "p" heaps + #! (left_vars, right_vars) = splitAt ((length cons_arg_vars) /2) cons_arg_vars - # (expr, left_vars, heaps) = build_prod expr left_vars predefs heaps - # (expr, right_vars, heaps) = build_prod expr right_vars predefs heaps + #! (expr, left_vars, heaps) = build_prod expr left_vars predefs heaps + #! (expr, right_vars, heaps) = build_prod expr right_vars predefs heaps - # (case_expr, heaps) = buildCasePAIRExpr var_expr (hd left_vars) (hd right_vars) expr predefs heaps + #! (case_expr, heaps) = buildCasePAIRExpr var_expr (hd left_vars) (hd right_vars) expr predefs heaps - # vars = [var : left_vars ++ right_vars] + #! vars = [var : left_vars ++ right_vars] = (case_expr, vars, heaps) build_cons_app :: !Index !DefinedSymbol !*Heaps -> (!Expression, [FreeVar], !*Heaps) build_cons_app cons_mod def_symbol=:{ds_arity} heaps - # names = ["x" +++ toString k \\ k <- [1..ds_arity]] - # (var_exprs, vars, heaps) = buildVarExprs names heaps - # (expr, heaps) = buildConsApp cons_mod def_symbol var_exprs heaps + #! names = ["x" +++ toString k \\ k <- [1..ds_arity]] + #! (var_exprs, vars, heaps) = buildVarExprs names heaps + #! (expr, heaps) = buildConsApp cons_mod def_symbol var_exprs heaps = (expr, vars, heaps) buildIsomapFromTo :: !IsoDirection !DefinedSymbol !Int !Int !Int !*GenericState @@ -2253,17 +2255,17 @@ buildIsomapFromTo :: !IsoDirection !DefinedSymbol !Int !Int !Int !*GenericState buildIsomapFromTo iso_dir def_sym group_index type_def_mod type_def_index gs=:{gs_heaps, gs_modules} - # (type_def=:{td_name, td_index, td_arity, td_pos}, gs_modules) + #! (type_def=:{td_name, td_index, td_arity, td_pos}, gs_modules) = getTypeDef type_def_mod type_def_index gs_modules - # arg_names = [ "isomap" +++ toString n \\ n <- [1 .. td_arity]] - # (isomap_arg_vars, gs_heaps) = buildFreeVars arg_names gs_heaps - # (arg_expr, arg_var, gs_heaps) = buildVarExpr "x" gs_heaps - # gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules} - # (body_expr, free_vars, gs) = + #! arg_names = [ "isomap" +++ toString n \\ n <- [1 .. td_arity]] + #! (isomap_arg_vars, gs_heaps) = buildFreeVars arg_names gs_heaps + #! (arg_expr, arg_var, gs_heaps) = buildVarExpr "x" gs_heaps + #! gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules} + #! (body_expr, free_vars, gs) = build_body iso_dir type_def_mod td_index type_def arg_expr isomap_arg_vars gs - # (fun_type, gs) = build_type iso_dir type_def_mod type_def_index gs - # fun_def = makeFunction def_sym group_index (isomap_arg_vars ++ [arg_var]) body_expr (Yes fun_type) free_vars [] td_pos + #! (fun_type, gs) = build_type iso_dir type_def_mod type_def_index gs + #! fun_def = makeFunction def_sym group_index (isomap_arg_vars ++ [arg_var]) body_expr (Yes fun_type) free_vars [] td_pos = (fun_def, gs) where build_body :: !IsoDirection !Int !Int !CheckedTypeDef !Expression ![FreeVar] !*GenericState @@ -2277,7 +2279,7 @@ where build_body iso_dir type_def_mod type_def_index type_def=:{td_rhs=(AbstractType _),td_name, td_pos} arg_expr isomap_arg_vars gs=:{gs_error} - # gs_error = checkErrorWithIdentPos + #! gs_error = checkErrorWithIdentPos (newPosition td_name td_pos) "cannot build map function for an abstract type" gs_error @@ -2286,17 +2288,17 @@ where build_body iso_dir type_def_mod type_def_index type_def=:{td_rhs=(SynType _), td_name, td_pos} arg_expr isomap_arg_vars gs=:{gs_error} - # gs_error = checkErrorWithIdentPos + #! gs_error = checkErrorWithIdentPos (newPosition td_name td_pos) "cannot build map function for a synonym type" gs_error = (EE, [], {gs & gs_error = gs_error}) build_body1 iso_dir type_def_mod type_def_index type_def def_symbols arg_expr isomap_arg_vars gs - # (case_alts, free_vars, gs=:{gs_heaps}) = + #! (case_alts, free_vars, gs=:{gs_heaps}) = build_alts iso_dir 0 (length def_symbols) type_def_mod def_symbols isomap_arg_vars type_def gs - # case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts - # (case_expr, gs_heaps) = buildCaseExpr arg_expr case_patterns gs_heaps + #! case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts + #! (case_expr, gs_heaps) = buildCaseExpr arg_expr case_patterns gs_heaps = (case_expr, free_vars, {gs & gs_heaps = gs_heaps}) build_alts :: !IsoDirection !Int !Int !Int ![DefinedSymbol] ![FreeVar] !CheckedTypeDef !*GenericState @@ -2304,8 +2306,8 @@ where build_alts iso_dir i n type_def_mod [] arg_vars type_def gs = ([], [], gs) build_alts iso_dir i n type_def_mod [def_symbol:def_symbols] arg_vars type_def gs - # (alt, fvs, gs) = build_alt iso_dir i n type_def_mod def_symbol arg_vars type_def gs - # (alts, free_vars, gs) = build_alts iso_dir (i+1) n type_def_mod def_symbols arg_vars type_def gs + #! (alt, fvs, gs) = build_alt iso_dir i n type_def_mod def_symbol arg_vars type_def gs + #! (alts, free_vars, gs) = build_alts iso_dir (i+1) n type_def_mod def_symbols arg_vars type_def gs = ([alt:alts], fvs ++ free_vars, gs) build_alt :: !IsoDirection !Int !Int !Int !DefinedSymbol ![FreeVar] !CheckedTypeDef !*GenericState @@ -2313,15 +2315,15 @@ where build_alt iso_dir i n type_def_mod def_symbol=:{ds_ident, ds_arity, ds_index} fun_arg_vars type_def gs=:{gs_heaps, gs_modules} - # names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]] - # (cons_arg_vars, gs_heaps) = buildFreeVars names gs_heaps - # (cons_def=:{cons_type}, gs_modules) = getConsDef type_def_mod ds_index gs_modules - # gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules} + #! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]] + #! (cons_arg_vars, gs_heaps) = buildFreeVars names gs_heaps + #! (cons_def=:{cons_type}, gs_modules) = getConsDef type_def_mod ds_index gs_modules + #! gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules} - # (cons_arg_exprs, gs=:{gs_heaps}) = + #! (cons_arg_exprs, gs=:{gs_heaps}) = build_cons_args iso_dir cons_type.st_args cons_arg_vars fun_arg_vars type_def gs - # (expr, gs_heaps) = buildConsApp type_def_mod def_symbol cons_arg_exprs gs_heaps - # alg_pattern = { + #! (expr, gs_heaps) = buildConsApp type_def_mod def_symbol cons_arg_exprs gs_heaps + #! alg_pattern = { ap_symbol = {glob_module = type_def_mod, glob_object = def_symbol}, ap_vars = cons_arg_vars, ap_expr = expr, @@ -2333,20 +2335,20 @@ where -> ([Expression], !*GenericState) build_cons_args iso_dir [] [] fun_arg_vars type_def gs = ([], gs) build_cons_args iso_dir [arg_type:arg_types] [cons_arg_var:cons_arg_vars] fun_arg_vars type_def gs - # (arg_expr, gs) = build_cons_arg iso_dir arg_type cons_arg_var fun_arg_vars type_def gs - # (arg_exprs, gs) = build_cons_args iso_dir arg_types cons_arg_vars fun_arg_vars type_def gs + #! (arg_expr, gs) = build_cons_arg iso_dir arg_type cons_arg_var fun_arg_vars type_def gs + #! (arg_exprs, gs) = build_cons_args iso_dir arg_types cons_arg_vars fun_arg_vars type_def gs = ([arg_expr : arg_exprs], gs) build_cons_arg :: !IsoDirection !AType !FreeVar ![FreeVar] !CheckedTypeDef !*GenericState -> (!Expression, !*GenericState) build_cons_arg iso_dir type cons_arg_var fun_vars type_def gs - # type_def_args = [atv_variable \\ {atv_variable} <- type_def.td_args] - # (iso_expr, gs) = buildIsomapExpr type type_def_args fun_vars gs - # {gs_heaps, gs_predefs} = gs - # sel_expr = case iso_dir of + #! type_def_args = [atv_variable \\ {atv_variable} <- type_def.td_args] + #! (iso_expr, gs) = buildIsomapExpr type type_def_args fun_vars gs + #! {gs_heaps, gs_predefs} = gs + #! sel_expr = case iso_dir of IsoTo -> buildIsoToSelectionExpr iso_expr gs_predefs IsoFrom -> buildIsoFromSelectionExpr iso_expr gs_predefs - # (cons_var_expr, _, gs_heaps) = buildBoundVarExpr cons_arg_var gs_heaps + #! (cons_var_expr, _, gs_heaps) = buildBoundVarExpr cons_arg_var gs_heaps = (sel_expr @ [cons_var_expr], {gs & gs_heaps = gs_heaps}) build_type :: !IsoDirection !Int !Int !*GenericState @@ -2357,11 +2359,11 @@ where #! ({td_arity, td_name}, gs_modules) = getTypeDef module_index type_def_index gs_modules - # (tvs1, gs_heaps) = mapSt (\n->build_type_var ("a"+++toString n)) [1..td_arity] gs_heaps - # (tvs2, gs_heaps) = mapSt (\n->build_type_var ("b"+++toString n)) [1..td_arity] gs_heaps - # (iso_args) = [buildATypeISO t1 t2 gs_predefs \\ t1 <- tvs1 & t2 <- tvs2] + #! (tvs1, gs_heaps) = mapSt (\n->build_type_var ("a"+++toString n)) [1..td_arity] gs_heaps + #! (tvs2, gs_heaps) = mapSt (\n->build_type_var ("b"+++toString n)) [1..td_arity] gs_heaps + #! (iso_args) = [buildATypeISO t1 t2 gs_predefs \\ t1 <- tvs1 & t2 <- tvs2] - # type_symb_ident = { + #! type_symb_ident = { type_name = td_name, type_index = { glob_module = module_index, glob_object = type_def_index }, type_arity = td_arity, @@ -2372,15 +2374,15 @@ where } } - # (av1, gs_heaps) = buildAttrVar "u1" gs_heaps - # (av2, gs_heaps) = buildAttrVar "u2" gs_heaps - # type1 = makeAType (TA type_symb_ident tvs1) (TA_Var av1) - # type2 = makeAType (TA type_symb_ident tvs2) (TA_Var av2) - # (arg_type, res_type) = case iso_dir of + #! (av1, gs_heaps) = buildAttrVar "u1" gs_heaps + #! (av2, gs_heaps) = buildAttrVar "u2" gs_heaps + #! type1 = makeAType (TA type_symb_ident tvs1) (TA_Var av1) + #! type2 = makeAType (TA type_symb_ident tvs2) (TA_Var av2) + #! (arg_type, res_type) = case iso_dir of IsoTo -> (type1, type2) IsoFrom -> (type2, type1) - # symbol_type = { + #! symbol_type = { st_vars = [tv \\ {at_type=(TV tv)} <- tvs1] ++ [tv \\ {at_type=(TV tv)} <- tvs2], @@ -2399,8 +2401,8 @@ where //---> ("isomap to/from type", symbol_type) build_type_var name heaps - # (av, heaps) = buildAttrVar name heaps - # (tv, heaps) = buildTypeVar name heaps + #! (av, heaps) = buildAttrVar name heaps + #! (tv, heaps) = buildTypeVar name heaps = (makeAType (TV tv) (TA_Var av), heaps) buildIsomapForTypeDef :: !DefinedSymbol !Int !Int !CheckedTypeDef !DefinedSymbol !DefinedSymbol !*GenericState @@ -2410,13 +2412,13 @@ buildIsomapForTypeDef type_def=:{td_name, td_index, td_arity, td_pos} from_fun to_fun gs=:{gs_main_dcl_module_n, gs_heaps, gs_predefs} - # arg_names = [ "iso" +++ toString n \\ n <- [1 .. td_arity]] - # (arg_exprs, arg_vars, gs_heaps) = buildVarExprs arg_names gs_heaps + #! arg_names = [ "iso" +++ toString n \\ n <- [1 .. td_arity]] + #! (arg_exprs, arg_vars, gs_heaps) = buildVarExprs arg_names gs_heaps - # (from_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n from_fun arg_exprs gs_heaps - # (to_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n to_fun arg_exprs gs_heaps - # (iso_expr, gs_heaps) = buildISO to_expr from_expr gs_predefs gs_heaps - # fun_def = makeFunction fun_def_sym group_index arg_vars iso_expr No [] [from_fun.ds_index, to_fun.ds_index] td_pos + #! (from_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n from_fun arg_exprs gs_heaps + #! (to_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n to_fun arg_exprs gs_heaps + #! (iso_expr, gs_heaps) = buildISO to_expr from_expr gs_predefs gs_heaps + #! fun_def = makeFunction fun_def_sym group_index arg_vars iso_expr No [] [from_fun.ds_index, to_fun.ds_index] td_pos = (fun_def, {gs & gs_heaps = gs_heaps}) buildIsomapForGeneric :: !DefinedSymbol !Int !GenericDef !*GenericState @@ -2455,13 +2457,13 @@ where # (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [type_index.glob_module, type_index.glob_object] # gt = case gtd_info of (GTDI_Generic gt) -> gt - _ -> abort ("type " +++ type_name.id_name +++ " does not have generic representation\n") + _ -> abort ("(generic.icl) type " +++ type_name.id_name +++ " does not have generic representation\n") # (expr, gs_heaps) = buildFunApp gs_main_dcl_module_n gt.gtr_isomap arg_exprs gs_heaps = (expr, {gs & gs_heaps = gs_heaps, gs_gtd_infos = gs_gtd_infos}) - build_expr (arg --> res) arg_type_vars arg_vars gs - # (arg_expr, gs) = buildIsomapExpr arg arg_type_vars arg_vars gs - # (res_expr, gs) = buildIsomapExpr res arg_type_vars arg_vars gs + build_expr (arg_type --> res_type) arg_type_vars arg_vars gs + # (arg_expr, gs) = buildIsomapExpr arg_type arg_type_vars arg_vars gs + # (res_expr, gs) = buildIsomapExpr res_type arg_type_vars arg_vars gs # {gs_heaps, gs_main_dcl_module_n, gs_predefs} = gs # (expr, gs_heaps) = buildIsomapArrowApp arg_expr res_expr gs_predefs gs_heaps = (expr, {gs & gs_heaps = gs_heaps}) @@ -2484,7 +2486,7 @@ where build_expr (TLifted type_var) arg_type_vars arg_vars gs = build_expr_for_type_var type_var arg_type_vars arg_vars gs build_expr _ arg_type_vars arg_vars gs - = abort "type does not match\n" + = abort "(generics.icl) type does not match\n" build_exprs [] arg_type_vars arg_vars gs = ([], gs) @@ -2546,12 +2548,11 @@ where # instance_type = hd ins_type.it_types # {type_index} = case instance_type of TA type_symb_ident _ -> type_symb_ident - _ -> abort ("instance type is not a type application") - ---> instance_type + _ -> abort ("instance type is not a type application") + ---> instance_type # (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [type_index.glob_module, type_index.glob_object] - //# (type_def, gs_modules) = getTypeDef type_index.glob_module type_index.glob_object gs_modules - # (GTDI_Generic gt) = gtd_info - = (gt, {gs & gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules}) + # (GTDI_Generic gt) = gtd_info + = (gt, {gs & gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules, gs_error=gs_error}) build_adaptor_expr {gtr_iso, gtr_type} gen_isomap gs=:{gs_heaps, gs_main_dcl_module_n, gs_predefs} // create n iso applications @@ -2594,9 +2595,10 @@ where # (kind, gs) = get_kind_of_type_def type_index gs = build_generic_app gen_sym kind arg_exprs cons_infos gs - build_instance_expr1 (arg_type --> res_type) cons_infos type_vars vars gen_sym gs=:{gs_error} - # gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "arrow types are not yet supported" gs_error - = (EE, cons_infos, {gs & gs_error = gs_error}) + build_instance_expr1 (arg_type --> res_type) cons_infos type_vars vars gen_sym gs + #! (arg_expr, cons_infos, gs) = build_instance_expr arg_type cons_infos type_vars vars gen_sym gs + #! (res_expr, cons_infos, gs) = build_instance_expr res_type cons_infos type_vars vars gen_sym gs + = build_generic_app gen_sym (KindArrow [KindConst,KindConst,KindConst]) [arg_expr, res_expr] cons_infos gs build_instance_expr1 (type_cons_var :@: type_args) cons_infos type_vars vars gen_sym gs=:{gs_error} # gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "application of type constructor variable is not supported" gs_error = (EE, cons_infos, {gs & gs_error = gs_error}) @@ -2608,8 +2610,9 @@ where = build_expr_for_type_var type_var type_vars vars cons_infos gs build_instance_expr1 (TQV type_var) cons_infos type_vars vars gen_sym gs = build_expr_for_type_var type_var type_vars vars cons_infos gs - build_instance_expr1 _ _ _ _ _ gs - = abort "build_instance_expr1: type does not match\n" + build_instance_expr1 _ cons_infos _ _ _ gs=:{gs_error} + # gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "can not build instance for the type" gs_error + = (EE, cons_infos, {gs & gs_error = gs_error}) build_expr_for_type_var type_var type_vars vars cons_infos gs=:{gs_predefs, gs_heaps} # (var_expr, gs_heaps) = buildExprForTypeVar type_var type_vars vars gs_predefs gs_heaps @@ -3404,15 +3407,15 @@ copyFunDef :: !FunDef !Index !Index !*Heaps -> (!FunDef, !*Heaps) copyFunDef fun_def=:{fun_symb,fun_arity,fun_body,fun_info} fun_index group_index gs_heaps # (TransformedBody {tb_args, tb_rhs}) = fun_body - #! (fresh_arg_vars, gs_heaps) = copy_vars tb_args gs_heaps - #! (copied_rhs, gs_heaps) = copyExpr tb_rhs gs_heaps + # (fresh_arg_vars, gs_heaps) = copy_vars tb_args gs_heaps + # (copied_rhs, gs_heaps) = copyExpr tb_rhs gs_heaps - #! (copied_rhs, fresh_arg_vars, fresh_local_vars, gs_heaps) = + # (copied_rhs, fresh_arg_vars, fresh_local_vars, gs_heaps) = collect_local_vars copied_rhs fresh_arg_vars gs_heaps - #! gs_heaps = clearVarInfos tb_args gs_heaps + # gs_heaps = clearVarInfos tb_args gs_heaps - #! fun_def = + # fun_def = { fun_def & fun_index = fun_index //, fun_symb = makeIdent "zzzzzzzzzzzz" @@ -3426,9 +3429,9 @@ copyFunDef fun_def=:{fun_symb,fun_arity,fun_body,fun_info} fun_index group_index = (fun_def, gs_heaps) where copy_vars vars heaps - #! (fresh_vars, heaps) = copyVars vars heaps - #! infos = [VI_Variable fv_name fv_info_ptr\\ {fv_name,fv_info_ptr} <- fresh_vars] - #! heaps = setVarInfos vars infos heaps + # (fresh_vars, heaps) = copyVars vars heaps + # infos = [VI_Variable fv_name fv_info_ptr\\ {fv_name,fv_info_ptr} <- fresh_vars] + # heaps = setVarInfos vars infos heaps = (fresh_vars, heaps) collect_local_vars body_expr fun_arg_vars heaps=:{hp_var_heap, hp_expression_heap} @@ -3438,13 +3441,11 @@ where , cos_var_heap = hp_var_heap , cos_symbol_heap = hp_expression_heap , cos_predef_symbols_for_transform = { predef_alias_dummy=dummy_pds, predef_and=dummy_pds, predef_or=dummy_pds } -// MV ... - , cos_used_dynamics = abort "error, please report to Martijn or Artem" -// ... MV + , cos_used_dynamics = {} //abort "error, please report to Martijn or Artem" } - #! (body_expr, fun_arg_vars, local_vars, {cos_symbol_heap, cos_var_heap}) = + # (body_expr, fun_arg_vars, local_vars, {cos_symbol_heap, cos_var_heap}) = determineVariablesAndRefCounts fun_arg_vars body_expr cs - #! heaps = { heaps & hp_var_heap = cos_var_heap, hp_expression_heap = cos_symbol_heap } + # heaps = { heaps & hp_var_heap = cos_var_heap, hp_expression_heap = cos_symbol_heap } = (body_expr, fun_arg_vars, local_vars, heaps) makeIdent :: String -> Ident diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 30b948e..c50e9af 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -531,6 +531,12 @@ where | diff >= 0 = match defs (TV tv, types) (TA { type_cons & type_arity = diff } (take diff cons_args), drop diff cons_args) type_heaps = (False, type_heaps) +//AA.. + match defs TArrow TArrow type_heaps + = (True, type_heaps) + match defs (TArrow1 t1) (TArrow1 t2) type_heaps + = match defs t1 t2 type_heaps +//..AA match defs (TB tb1) (TB tb2) type_heaps = (tb1 == tb2, type_heaps) /* match defs type (TB (BT_String array_type)) type_heaps diff --git a/frontend/parse.icl b/frontend/parse.icl index ca0136d..ed18348 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1290,8 +1290,11 @@ optionalCoercions pState wantGenericDefinition :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState) wantGenericDefinition context pos pState + | SwitchGenerics False True + = (PD_Erroneous, parseError "generic definition" No "support for generics is disabled in the compiler. " pState) # (name, pState) = want_name pState - | name == "" = (PD_Erroneous, pState) + | name == "" + = (PD_Erroneous, pState) # (ident, pState) = stringToIdent name IC_Class pState # (member_ident, pState) = stringToIdent name IC_Expression pState # (arg_vars, pState) = wantList "generic variable(s)" try_variable pState @@ -1740,6 +1743,14 @@ where = (TA { sym & type_arity = length types } types, pState) convert_list_of_types (TV tv) types pState = (CV tv :@: types, pState) +//AA.. + convert_list_of_types TArrow [type1, type2] pState + = (type1 --> type2, pState) + convert_list_of_types TArrow [type1] pState + = (TArrow1 type1, pState) + convert_list_of_types (TArrow1 type1) [type2] pState + = (type1 --> type2, pState) +//..AA convert_list_of_types _ types pState = (TE, parseError "Type" No "ordinary type variable" pState) tryApplicationType _ annot attr pState @@ -1787,7 +1798,13 @@ trySimpleTypeT OpenToken annot attr pState | token == CommaToken # (tup_arity, pState) = determine_arity_of_tuple 2 pState (tuple_symbol, pState) = makeTupleTypeSymbol tup_arity 0 pState - = (True, {at_annotation = annot, at_attribute = attr, at_type = TA tuple_symbol []}, pState) + = (True, {at_annotation = annot, at_attribute = attr, at_type = TA tuple_symbol []}, pState) + | token == ArrowToken + # (token, pState) = nextToken TypeContext pState + | token == CloseToken + = (True, {at_annotation = annot, at_attribute = attr, at_type = TArrow}, pState) + = (False,{at_annotation = annot, at_attribute = attr, at_type = TE}, + parseError "arrow type" (Yes token) ")" pState) // otherwise // token <> CommaToken # (atype, pState) = wantAType (tokenBack pState) (token, pState) = nextToken TypeContext pState @@ -3088,6 +3105,8 @@ wantBeginGroup msg pState // AA.. wantKind :: !ParseState -> !(!TypeKind, ParseState) wantKind pState + | SwitchGenerics False True + = (KindConst, parseError "kind" No "support for generics is disabled in the compiler. " pState) # (token, pState) = nextToken TypeContext pState # (kind, pState) = want_simple_kind token pState # (token, pState) = nextToken TypeContext pState diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 7d9b418..7ae7c1f 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1286,7 +1286,7 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = EmptyRhs propertie = (fun_defs, c_defs, imports, imported_objects, ca) reorganiseDefinitions icl_module [PD_Class class_def=:{class_name,class_arity,class_args} members : defs] cons_count sel_count mem_count type_count ca # type_context = { tc_class = {glob_module = NoIndex, glob_object = {ds_ident = class_name, ds_arity = class_arity, ds_index = NoIndex }}, - tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr } + tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr} (mem_defs, mem_macros, ca) = check_symbols_of_class_members members type_context ca (mem_symbs, mem_defs, class_size) = reorganise_member_defs mem_defs mem_count (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count (mem_count + class_size) type_count ca diff --git a/frontend/predef.icl b/frontend/predef.icl index c618442..4667975 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -363,7 +363,7 @@ where me_type = { st_vars = [], st_args = [], st_arity = 0, st_result = { at_attribute = TA_None, at_annotation = AN_None, at_type = TV class_var }, st_context = [ {tc_class = {glob_module = NoIndex, glob_object = {ds_ident = tc_class_name.pds_ident, ds_arity = 1, ds_index = NoIndex }}, - tc_types = [ TV class_var ], tc_var = nilPtr }], + tc_types = [ TV class_var ], tc_var = nilPtr}], st_attr_vars = [], st_attr_env = [] } member_def = { me_symb = tc_member_name.pds_ident, me_type = me_type, me_pos = NoPos, me_priority = NoPrio, diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 21374fa..e4ffdd9 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -818,6 +818,8 @@ cNonRecursiveAppl :== False :: Type = TA !TypeSymbIdent ![AType] | (-->) infixr 9 !AType !AType + | TArrow /* (->) */ + | TArrow1 !AType /* ((->) a) */ | (:@:) infixl 9 !ConsVariable ![AType] | TB !BasicType diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 3e868c1..1d74e24 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -789,6 +789,8 @@ cNotVarNumber :== -1 :: Type = TA !TypeSymbIdent ![AType] | (-->) infixr 9 !AType !AType + | TArrow /* (->) */ + | TArrow1 !AType /* ((->) a) */ | (:@:) infixl 9 !ConsVariable ![AType] | TB !BasicType @@ -1226,6 +1228,8 @@ where = True needs_brackets (_ :@: _) = True + needs_brackets (TArrow1 _) + = True /* needs_brackets (TFA _ _) = True */ needs_brackets _ @@ -1344,6 +1348,12 @@ where = file <<< consid <<< " " <<< types (<<<) file (arg_type --> res_type) = file <<< arg_type <<< " -> " <<< res_type +//AA.. + (<<<) file TArrow + = file <<< "(->)" + (<<<) file (TArrow1 t) + = file <<< "(->) " <<< t +//..AA (<<<) file (type :@: types) = file <<< type <<< " @" <<< types (<<<) file (TB tb) @@ -1435,11 +1445,13 @@ where instance <<< AlgebraicPattern where - (<<<) file g = file <<< g.ap_symbol <<< g.ap_vars <<< " -> " <<< g.ap_expr + //(<<<) file g = file <<< g.ap_symbol <<< g.ap_vars <<< " -> " <<< g.ap_expr + (<<<) file g = file <<< '\n' <<< g.ap_symbol <<< g.ap_vars <<< "\n\t-> " <<< g.ap_expr instance <<< BasicPattern where - (<<<) file g = file <<< g.bp_value <<< " -> " <<< g.bp_expr + //(<<<) file g = file <<< g.bp_value <<< " -> " <<< g.bp_expr + (<<<) file g = file <<< '\n' <<< g.bp_value <<< "\n\t-> " <<< g.bp_expr instance <<< CasePatterns where @@ -1491,9 +1503,11 @@ where write_binds x file [bind : binds] = write_binds x (file <<< x <<< " " <<< bind <<< '\n') binds (<<<) file (Case {case_expr,case_guards,case_default=No}) - = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards + //= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards + = file <<< "case " <<< case_expr <<< " of" <<< case_guards (<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr}) - = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards <<< "\n\t->" <<< def_expr + //= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards <<< "\n\t->" <<< def_expr + = file <<< "case " <<< case_expr <<< " of" <<< case_guards <<< "\n\t->" <<< def_expr (<<<) file (BasicExpr basic_value basic_type) = file <<< basic_value (<<<) file (Conditional {if_cond,if_then,if_else}) = else_part (file <<< "IF " <<< if_cond <<< "\nTHEN\n" <<< if_then) if_else @@ -1680,11 +1694,11 @@ instance <<< FunDef where (<<<) file {fun_symb,fun_body=ParsedBody bodies} = file <<< fun_symb <<< '.' <<< ' ' <<< bodies (<<<) file {fun_symb,fun_body=CheckedBody {cb_args,cb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '.' - <<< "C " <<< cb_args <<< " = " <<< cb_rhs + <<< "C " <<< cb_args <<< "\n= " <<< cb_rhs // <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< cb_args <<< " = " <<< cb_rhs (<<<) file {fun_symb,fun_index,fun_body=TransformedBody {tb_args,tb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '@' <<< fun_index <<< '.' - <<< "T " <<< tb_args <<< '[' <<< fi_calls <<< ']' <<< " = " <<< tb_rhs + <<< "T " <<< tb_args <<< '[' <<< fi_calls <<< ']' <<< "\n= " <<< tb_rhs // <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< tb_args <<< " = " <<< tb_rhs (<<<) file {fun_symb,fun_index,fun_body=BackendBody body,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '@' <<< fun_index <<< '.' <<< body <<< '\n' @@ -1694,8 +1708,8 @@ where instance <<< FunctionBody where (<<<) file (ParsedBody bodies) = file <<< bodies - (<<<) file (CheckedBody {cb_args,cb_rhs}) = file <<< "C " <<< cb_args <<< " = " <<< cb_rhs - (<<<) file (TransformedBody {tb_args,tb_rhs}) = file <<< "T " <<< tb_args <<< " = " <<< tb_rhs + (<<<) file (CheckedBody {cb_args,cb_rhs}) = file <<< "C " <<< cb_args <<< "\n= " <<< cb_rhs + (<<<) file (TransformedBody {tb_args,tb_rhs}) = file <<< "T " <<< tb_args <<< "\n= " <<< tb_rhs (<<<) file (BackendBody body) = file <<< body <<< '\n' (<<<) file NoBody = file <<< "Array function\n" diff --git a/frontend/type.icl b/frontend/type.icl index 5f60f20..c05e780 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -96,11 +96,20 @@ where | ok -> (True, simplified_type, subst) -> (False, tcv, subst) +//AA.. + arraySubst type=:(TArrow1 arg_type) subst + # (changed, arg_type, subst) = arraySubst arg_type subst + | changed + = (changed, TArrow1 arg_type, subst) + = (False, type, subst) +//..AA + 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) @@ -167,6 +176,10 @@ where = tv_number == var_id containsTypeVariable var_id (arg_type --> res_type) subst = containsTypeVariable var_id arg_type subst || containsTypeVariable var_id res_type subst +//AA.. + containsTypeVariable var_id (TArrow1 arg_type) subst + = containsTypeVariable var_id arg_type subst +//..AA containsTypeVariable var_id (TA cons_id cons_args) subst = containsTypeVariable var_id cons_args subst containsTypeVariable var_id (type :@: types) subst @@ -282,6 +295,12 @@ unifyTypes t1=:(TB tb1) attr1 t2=:(TB tb2) attr2 modules subst heaps = (False, subst, heaps) unifyTypes (arg_type1 --> res_type1) attr1 (arg_type2 --> res_type2) attr2 modules subst heaps = unify (arg_type1,res_type1) (arg_type2,res_type2) modules subst heaps +//AA.. +unifyTypes TArrow attr1 TArrow attr2 modules subst heaps + = (True, subst, heaps) +unifyTypes (TArrow1 t1) attr1 (TArrow1 t2) attr2 modules subst heaps + = unify t1 t2 modules subst heaps +//..AA unifyTypes t1=:(TA cons_id1 cons_args1) attr1 t2=:(TA cons_id2 cons_args2) attr2 modules subst heaps | cons_id1 == cons_id2 = unify cons_args1 cons_args2 modules subst heaps @@ -340,6 +359,12 @@ simplifyTypeApplication (TempV tv_number) type_args = (True, TempCV tv_number :@: type_args) simplifyTypeApplication (TempQV tv_number) type_args = (True, TempQCV tv_number :@: type_args) +//AA.. +simplifyTypeApplication TArrow [type1, type2] + = (True, type1 --> type2) +simplifyTypeApplication (TArrow1 type1) [type2] + = (True, type1 --> type2) +//..AA simplifyTypeApplication type type_args = (False, type) @@ -375,6 +400,19 @@ unifyCVwithType is_exist tv_number type_args type=:(TA type_cons cons_args) modu = unifyTypes (toTV is_exist tv_number) TA_Multi (TA { type_cons & type_arity = diff } (take diff cons_args)) TA_Multi modules subst heaps = (False, subst, heaps) = (False, subst, heaps) + +// AA.. +unifyCVwithType is_exist tv_number [type_arg1, type_arg2] type=:(atype1 --> atype2) modules subst heaps + # (succ, subst, heaps) = unify (type_arg1, type_arg2) (atype1, atype2) modules subst heaps + | succ + = unifyTypes (toTV is_exist tv_number) TA_Multi TArrow TA_Multi modules subst heaps + = (False, subst, heaps) +unifyCVwithType is_exist tv_number [type_arg] type=:(atype1 --> atype2) modules subst heaps + # (succ, subst, heaps) = unify type_arg atype2 modules subst heaps + | succ + = unifyTypes (toTV is_exist tv_number) TA_Multi (TArrow1 atype1) TA_Multi modules subst heaps + = (False, subst, heaps) +// ..AA unifyCVwithType is_exist tv_number type_args type modules subst heaps = (False, subst, heaps) @@ -487,6 +525,11 @@ where # (arg_type, type_heaps) = freshCopy arg_type type_heaps (res_type, type_heaps) = freshCopy res_type type_heaps = (arg_type --> res_type, type_heaps) +//AA.. + freshCopy (TArrow1 arg_type) type_heaps + # (arg_type, type_heaps) = freshCopy arg_type type_heaps + = (TArrow1 arg_type, type_heaps) +//..AA freshCopy (TFA vars type) type_heaps # type_heaps = foldSt bind_var_and_attr vars type_heaps (type, type_heaps) = freshCopy type type_heaps @@ -763,6 +806,11 @@ addPropagationAttributesToType modules (arg_type --> res_type) ps addPropagationAttributesToType modules (type_var :@: types) ps # (types, ps) = addPropagationAttributesToATypes modules types ps = (type_var :@: types, ps) +//AA.. +addPropagationAttributesToType modules (TArrow1 arg_type) ps + # (arg_type, prop_class, ps) = addPropagationAttributesToAType modules arg_type ps + = (TArrow1 arg_type, ps) +//..AA addPropagationAttributesToType modules type ps = (type, ps) @@ -1792,12 +1840,12 @@ where = state check_type_of_constructor_variable ins_pos common_defs type=:(TA {type_index={glob_module,glob_object},type_arity} types) (error, type_var_heap, td_infos) - # {td_arity} = common_defs.[glob_module].com_type_defs.[glob_object] + # {td_arity,td_name} = common_defs.[glob_module].com_type_defs.[glob_object] ({tdi_properties,tdi_cons_vars}, td_infos) = td_infos![glob_module].[glob_object] | tdi_properties bitand cIsNonCoercible == 0 # ({sc_neg_vect}, type_var_heap, td_infos) = signClassification glob_object glob_module [TopSignClass \\ cv <- tdi_cons_vars ] common_defs type_var_heap td_infos - = (check_sign type (sc_neg_vect >> type_arity) (td_arity - type_arity) error, type_var_heap, td_infos) + = (check_sign type (sc_neg_vect >> type_arity) (td_arity - type_arity) error, type_var_heap, td_infos) = (checkErrorWithIdentPos (newPosition empty_id ins_pos) " instance type should be coercible" error, type_var_heap, td_infos) where @@ -1810,6 +1858,17 @@ where check_type_of_constructor_variable ins_pos common_defs type=:(arg_type --> result_type) (error, type_var_heap, td_infos) = (checkErrorWithIdentPos (newPosition empty_id ins_pos) " instance type should be coercible" error, type_var_heap, td_infos) +//AA.. +/* + // ??? not sure if it is correct + check_type_of_constructor_variable ins_pos common_defs TArrow (error, type_var_heap, td_infos) + = (checkErrorWithIdentPos (newPosition empty_id ins_pos) " instance type should be coercible" error, + type_var_heap, td_infos) + check_type_of_constructor_variable ins_pos common_defs type=:(TArrow1 arg_type) (error, type_var_heap, td_infos) + = (checkErrorWithIdentPos (newPosition empty_id ins_pos) " instance type should be coercible" error, + type_var_heap, td_infos) +*/ +//..AA check_type_of_constructor_variable ins_pos common_defs type=:(cv :@: types) (error, type_var_heap, td_infos) = (checkError (newPosition empty_id ins_pos) " instance type should be coercible" error, type_var_heap, td_infos) @@ -2226,7 +2285,7 @@ where instance <<< TypeContext where - (<<<) file co = file <<< "TypeContext: (tc_class)=" <<< co.tc_class <<< " (tc_var)=" <<< ptrToInt co.tc_var <<< " (tc_types)=" <<< " " <<< co.tc_types + (<<<) file co = file <<< "TypeContext: (tc_class)=" <<< co.tc_class <<< " (tc_var)=" <<< ptrToInt co.tc_var <<< " (tc_types)=" <<< " " <<< co.tc_types instance <<< DefinedSymbol where diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index 92cb371..e0ef601 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -148,6 +148,11 @@ foldATypeSt on_atype on_type type st :== fold_atype_st type st #! st = fold_atype_st r (fold_atype_st l st) = on_type type st +//AA.. + fold_type_st type=:(TArrow1 t) st + #! st = fold_atype_st t st + = on_type type st +//..AA fold_type_st type=:(_ :@: args) st #! st = foldSt fold_atype_st args st diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index e3385f8..7a1a282 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -32,6 +32,18 @@ simplifyTypeApplication (CV tv :@: type_args1) type_args2 = (True, CV tv :@: (type_args1 ++ type_args2)) simplifyTypeApplication (TB _) _ = (False, TE) +//AA.. +simplifyTypeApplication TArrow [type1, type2] + = (True, type1 --> type2) +simplifyTypeApplication TArrow [type] + = (True, TArrow1 type) +simplifyTypeApplication (TArrow1 type1) [type2] + = (True, type1 --> type2) +//AA.. +simplifyTypeApplication (TArrow1 _) _ + = (False, TE) + + :: AttributeEnv :== {! TypeAttribute } :: VarEnv :== {! Type } @@ -124,6 +136,11 @@ where # (argtype, cus) = clean_up cui argtype cus (restype, cus) = clean_up cui restype cus = (argtype --> restype, cus) +//AA.. + clean_up cui (TArrow1 argtype) cus + # (argtype, cus) = clean_up cui argtype cus + = (TArrow1 argtype, cus) +//..AA clean_up cui t=:(TB _) cus = (t, cus) clean_up cui (TempCV tempvar :@: types) cus @@ -229,6 +246,11 @@ where cleanUpClosed (argtype --> restype) env # (cur, (argtype,restype), env) = cleanUpClosed (argtype,restype) env = (cur, argtype --> restype, env) +//AA.. + cleanUpClosed (TArrow1 argtype) env + # (cur, argtype, env) = cleanUpClosed argtype env + = (cur, TArrow1 argtype, env) +//..AA cleanUpClosed (TempCV tv_number :@: types) env # (type, env) = env![tv_number] # (cur1, type, env) = cleanUpClosedVariable type env @@ -536,6 +558,10 @@ instance bindInstances Type = bindInstances arg_types1 arg_types2 type_var_heap bindInstances (l1 --> r1) (l2 --> r2) type_var_heap = bindInstances r1 r2 (bindInstances l1 l2 type_var_heap) +//AA.. + bindInstances (TArrow1 x1) (TArrow1 x2) type_var_heap + = bindInstances x1 x2 type_var_heap +//..AA bindInstances (TB _) (TB _) type_var_heap = type_var_heap bindInstances (CV l1 :@: r1) (CV l2 :@: r2) type_var_heap @@ -616,6 +642,12 @@ where substitute (arg_type --> res_type) heaps # (ok, (arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps = (ok, arg_type --> res_type, heaps) +//AA.. + substitute (TArrow1 arg_type) heaps + # (ok, arg_type, heaps) = substitute arg_type heaps + = (ok, TArrow1 arg_type, heaps) + +//..AA substitute (TA cons_id cons_args) heaps # (ok, cons_args, heaps) = substitute cons_args heaps = (ok, TA cons_id cons_args, heaps) @@ -687,6 +719,13 @@ where | rem = (True, arg_type --> res_type) = (False, t) +//AA.. + removeAnnotations t=:(TArrow1 arg_type) + # (rem, arg_type) = removeAnnotations arg_type + | rem + = (True, TArrow1 arg_type) + = (False, t) +//..AA removeAnnotations t=:(TA cons_id cons_args) # (rem, cons_args) = removeAnnotations cons_args | rem @@ -782,6 +821,10 @@ where = equivTypeVars tv var_number heaps equiv (arg_type1 --> restype1) (arg_type2 --> restype2) heaps = equiv (arg_type1,restype1) (arg_type2,restype2) heaps +//AA.. + equiv (TArrow1 arg_type1) (TArrow1 arg_type2) heaps + = equiv arg_type1 arg_type2 heaps +//..AA equiv (TA tc1 types1) (TA tc2 types2) heaps | tc1 == tc2 = equiv types1 types2 heaps @@ -1145,6 +1188,15 @@ where = (file, opt_beautifulizer) writeType file opt_beautifulizer (form, TB tb) = (file <<< tb, opt_beautifulizer) +//AA.. + writeType file opt_beautifulizer (form, TArrow) + = (file <<< "(->)", opt_beautifulizer) + writeType file opt_beautifulizer (form, TArrow1 t) + # file = file <<< "((->)" + # (file, opt_opt_beautifulizer) = writeType file opt_beautifulizer (form, t) + # file = file <<< ")" + = (file, opt_beautifulizer) +//..AA writeType file opt_beautifulizer (form, TQV varid) = (file <<< "E." <<< varid, opt_beautifulizer) writeType file opt_beautifulizer (form, TempQV tv_number) @@ -1334,6 +1386,10 @@ getImplicitAttrInequalities st=:{st_args, st_result} = get_ineqs_of_atype_list args get_ineqs_of_type (l --> r) = Pair (get_ineqs_of_atype l) (get_ineqs_of_atype r) +//AA.. + get_ineqs_of_type (TArrow1 type) + = get_ineqs_of_atype type +//..AA get_ineqs_of_type (cv :@: args) = get_ineqs_of_atype_list args get_ineqs_of_type _ @@ -1523,6 +1579,11 @@ anonymizeAttrVars st=:{st_attr_vars, st_args, st_result, st_attr_env} implicit_i # (l, th_attrs) = anonymize_atype l th_attrs (r, th_attrs) = anonymize_atype r th_attrs = (l --> r, th_attrs) +//AA.. + anonymize_type (TArrow1 type) th_attrs + # (type, th_attrs) = anonymize_atype type th_attrs + = (TArrow1 type, th_attrs) +//..AA anonymize_type (cv :@: args) th_attrs # (args, th_attrs) = mapSt anonymize_atype args th_attrs = (cv :@: args, th_attrs) @@ -1548,6 +1609,10 @@ anonymizeAttrVars st=:{st_attr_vars, st_args, st_result, st_attr_env} implicit_i = foldSt count_attr_vars_of_atype args th_attrs count_attr_vars_of_type (l --> r) th_attrs = count_attr_vars_of_atype l (count_attr_vars_of_atype r th_attrs) +//AA.. + count_attr_vars_of_type (TArrow1 t) th_attrs + = count_attr_vars_of_atype t th_attrs +//..AA count_attr_vars_of_type (_ :@: args) th_attrs = foldSt count_attr_vars_of_atype args th_attrs count_attr_vars_of_type _ th_attrs @@ -1708,6 +1773,10 @@ instance performOnTypeVars Type = performOnTypeVars f args st performOnTypeVars f (at1 --> at2) st = performOnTypeVars f at2 (performOnTypeVars f at1 st) +//AA.. + performOnTypeVars f (TArrow1 at) st + = performOnTypeVars f at st +//..AA performOnTypeVars f (cv :@: at) st = performOnTypeVars f cv (performOnTypeVars f at st) performOnTypeVars f _ st @@ -1750,6 +1819,10 @@ instance performOnAttrVars Type = performOnAttrVars f args st performOnAttrVars f (at1 --> at2) st = performOnAttrVars f at2 (performOnAttrVars f at1 st) +//AA.. + performOnAttrVars f (TArrow1 at) st + = performOnAttrVars f at st +//..AA performOnAttrVars f (_ :@: at) st = performOnAttrVars f at st performOnAttrVars f _ st @@ -1799,6 +1872,11 @@ foldATypeSt on_atype on_type type st :== fold_atype_st type st #! st = fold_atype_st r (fold_atype_st l st) = on_type type st +//AA.. + fold_type_st type=:(TArrow1 t) st + #! st = fold_atype_st t st + = on_type type st +//..AA fold_type_st type=:(_ :@: args) st #! st = foldSt fold_atype_st args st diff --git a/frontend/unitype.icl b/frontend/unitype.icl index a40f0f8..aa77fad 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -246,6 +246,12 @@ typeIsNonCoercible _ (TempQV _) = True typeIsNonCoercible _ (_ --> _) = True +//AA.. +typeIsNonCoercible _ TArrow + = True +typeIsNonCoercible _ (TArrow1 t) + = True +//AA.. typeIsNonCoercible cons_vars (TempCV tmp_var_id :@: _) = not (isPositive tmp_var_id cons_vars) typeIsNonCoercible cons_vars (_ :@: _) @@ -319,9 +325,16 @@ where | changed = (True, arg_type0 --> res_type, subst, ls) = (False, type, subst, ls) +//AA.. + lift modules cons_vars type=:(TArrow1 arg_type) subst ls + # (changed, arg_type, subst, ls) = lift modules cons_vars arg_type subst ls + | changed + = (True, TArrow1 arg_type, subst, ls) + = (False, type, subst, ls) +//..AA lift modules cons_vars type=:(TA cons_id cons_args) subst ls=:{ls_type_heaps} # (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps - = liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps} + = liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps} lift modules cons_vars type=:(TempCV temp_var :@: types) subst ls # (changed, var_type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls (changed_types, types, subst, ls) = lift_list modules cons_vars types subst ls @@ -333,6 +346,15 @@ where -> (True, TempCV tv_number :@: types, subst, ls) cons_var :@: cv_types -> (True, cons_var :@: (cv_types ++ types), subst, ls) +// AA.. + TArrow -> case types of + [t1, t2] -> (True, t1 --> t2, subst, ls) + [t1] -> (True, TArrow1 t1, subst, ls) + _ -> (False, type, subst, ls) + (TArrow1 t1) -> case types of + [t2] -> (True, t1 --> t2, subst, ls) + _ -> (False, type, subst, ls) +// ..AA = (False, type, subst, ls) where lift_list :: !{#CommonDefs} !{# BOOLVECT } ![a] !*{!Type} !*LiftState -> (!Bool,![a], !*{!Type}, !*LiftState) | lift a @@ -426,6 +448,13 @@ where | changed = (True,arg_type0 --> res_type, es) = (False,t0, es) +//AA.. + expandType modules cons_vars type=:(TArrow1 arg_type) es + # (changed,arg_type, es) = expandType modules cons_vars arg_type es + | changed + = (True, TArrow1 arg_type, es) + = (False, type, es) +//..AA expandType modules cons_vars t0=:(TA cons_id=:{type_name, type_index={glob_object,glob_module},type_prop=type_prop0} cons_args) (subst, es) # ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object] (changed,cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es) @@ -487,6 +516,15 @@ where -> (True, TempCV tv_number :@: types, es) cons_var :@: cv_types -> (True, cons_var :@: (cv_types ++ types), es) +// AA.. + TArrow -> case types of + [t1, t2] -> (True, t1 --> t2, es) + [t1] -> (True, TArrow1 t1, es) + _ -> (False, type, es) + (TArrow1 t1) -> case types of + [t2] -> (True, t1 --> t2, es) + _ -> (False, type, es) +//..AA = (False, type, es) expandType modules cons_vars type es = (False, type, es) @@ -723,6 +761,12 @@ where = TopSign adjust_sign sign (_ --> _) cons_vars = TopSign +//AA.. + adjust_sign sign TArrow cons_vars + = TopSign + adjust_sign sign (TArrow1 _) cons_vars + = TopSign +//..AA adjust_sign sign (TempCV tmp_var_id :@: _) cons_vars | isPositive tmp_var_id cons_vars = sign @@ -812,6 +856,13 @@ coerceTypes sign defs cons_vars tpos {at_type = arg_type1 --> res_type1} {at_typ | Success succ = coerce sign defs cons_vars [1 : tpos] res_type1 res_type2 cs = (succ, cs) +//AA.. +coerceTypes sign defs cons_vars tpos {at_type = TArrow} {at_type = TArrow} cs + = (No, cs) // ??? +coerceTypes sign defs cons_vars tpos {at_type = TArrow1 arg_type1} {at_type = TArrow1 arg_type2} cs + # arg_sign = NegativeSign * sign + = coerce arg_sign defs cons_vars [0 : tpos] arg_type1 arg_type2 cs +//..AA coerceTypes sign defs cons_vars tpos {at_type = cons_var :@: types1} {at_type = _ :@: types2} cs # sign = determine_sign_of_arg_types sign cons_var cons_vars = coercions_of_type_list sign defs cons_vars tpos 0 types1 types2 cs |