aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/check.icl7
-rw-r--r--frontend/checkKindCorrectness.icl14
-rw-r--r--frontend/checktypes.icl92
-rw-r--r--frontend/compilerSwitches.dcl2
-rw-r--r--frontend/compilerSwitches.icl2
-rw-r--r--frontend/frontend.icl15
-rw-r--r--frontend/generics.icl589
-rw-r--r--frontend/overloading.icl6
-rw-r--r--frontend/parse.icl23
-rw-r--r--frontend/postparse.icl2
-rw-r--r--frontend/predef.icl2
-rw-r--r--frontend/syntax.dcl2
-rw-r--r--frontend/syntax.icl30
-rw-r--r--frontend/type.icl65
-rw-r--r--frontend/typesupport.dcl5
-rw-r--r--frontend/typesupport.icl78
-rw-r--r--frontend/unitype.icl53
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