Commit f4c1d4e4 authored by Artem Alimarine's avatar Artem Alimarine

Added "curried" arrow types (->) and ((->) a)

Fixed some bugs in generics
parent 0b7ccffb
......@@ -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
......
......@@ -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"
......
......@@ -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}
......
definition module compilerSwitches
SwitchGenerics on off :== off
SwitchGenerics on off :== on
PA_BUG on off :== off
......
implementation module compilerSwitches
SwitchGenerics on off :== off
SwitchGenerics on off :== on
PA_BUG on off :== off
......
......@@ -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
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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,
......
......@@ -818,6 +818,8 @@ cNonRecursiveAppl :== False
:: Type = TA !TypeSymbIdent ![AType]
| (-->) infixr 9 !AType !AType
| TArrow /* (->) */
| TArrow1 !AType /* ((->) a) */
| (:@:) infixl 9 !ConsVariable ![AType]
| TB !BasicType
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -32,6 +32,18 @@ simplifyTypeApplication (CV tv :@: type_args1) type_args2
= (True, CV tv :@: (type_args1 ++ type_args2))
simplifyTypeApplication (TB _) _
= (False, TE)