Commit b1991e2c authored by Artem Alimarine's avatar Artem Alimarine

higher-order kinded types in generics

parent 1de7b2c5
......@@ -419,6 +419,24 @@ where
(combineCoercionProperties arg_type_props res_type_props bitor cIsNonCoercible)
(combineCoercionProperties arg_type_props res_type_props)
= (KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
// AA..
analTypes has_root_attr modules form_tvs TArrow conds_as
# type_props = if has_root_attr
(cIsHyperStrict bitor cIsNonCoercible)
cIsHyperStrict
= (KI_Arrow KI_Const (KI_Arrow KI_Const KI_Const), type_props, conds_as)
analTypes has_root_attr modules form_tvs (TArrow1 arg_type) conds_as
# (arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as
# (conds, as=:{as_kind_heap,as_error}) = conds_as
# type_props = if has_root_attr
(arg_type_props bitor cIsNonCoercible)
arg_type_props
# {uki_kind_heap, uki_error} = unifyKinds arg_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}
= (KI_Arrow KI_Const KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error}))
// ..AA
analTypes has_root_attr modules form_tvs (CV tv :@: types) conds_as
# (type_kind, cv_props, (conds, as)) = analTypes has_root_attr modules form_tvs tv conds_as
(kind_var, as_kind_heap) = freshKindVar as.as_kind_heap
......@@ -846,8 +864,11 @@ where
= check_kinds_of_class_instances common_defs (inc instance_index) instance_defs class_infos as
where
check_kinds_of_class_instance :: !{#CommonDefs} !ClassInstance !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState)
check_kinds_of_class_instance common_defs {ins_class,ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
check_kinds_of_class_instance common_defs {ins_is_generic, ins_class,ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
as=:{as_type_var_heap,as_kind_heap,as_error}
| ins_is_generic
// generic instances are cheched in the generic phase
= (class_infos, as)
# as_error = pushErrorAdmin (newPosition ins_ident ins_pos) as_error
(as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars it_vars as_type_var_heap as_kind_heap
as = { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap, as_error = as_error }
......
......@@ -28,7 +28,7 @@ checkGenerics
// add * for kind-star instances and *->* for arrays
# kinds =
[ KindConst
, KindArrow [KindConst, KindConst]
, KindArrow [KindConst]
]
# (kinds_ptr, th_vars) = newPtr (TVI_Kinds kinds) th_vars
# (cons_ptr, th_vars) = newPtr (TVI_Empty) th_vars
......
......@@ -7,6 +7,8 @@ switch_import_syntax one_point_three two_point_zero :== one_point_three
SwitchPreprocessor preprocessor no_preprocessor :== preprocessor
SwitchGenerics on off :== off
// MV...
// - change T_ypeObjectType in StdDynamic (remove DummyModuleName-argument of T_ypeConsSymbol)
// - the (ModuleID _)-constructor is *not* yet shared
......
......@@ -7,6 +7,8 @@ switch_import_syntax one_point_three two_point_zero :== one_point_three
SwitchPreprocessor preprocessor no_preprocessor :== preprocessor
SwitchGenerics on off :== off
// MV...
// - change T_ypeObjectType in StdDynamic (remove DummyModuleName-argument of T_ypeConsSymbol)
// - the (ModuleID _)-constructor is *not* yet shared
......
......@@ -6,7 +6,7 @@ implementation module frontend
import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics,
convertimportedtypes, /*checkKindCorrectness, */ compilerSwitches, analtypes, generics
SwitchGenerics on off :== off
//import print
:: FrontEndOptions
= { feo_up_to_phase :: !FrontEndPhase
......@@ -129,6 +129,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an
ti_common_defs fun_defs dcl_mods td_infos class_infos th_vars error_admin
type_heaps = { type_heaps & th_vars = th_vars }
# heaps = { heaps & hp_type_heaps = type_heaps }
# (saved_main_dcl_common, ti_common_defs) = replace (dcl_common_defs dcl_mods) main_dcl_module_n icl_common
with
......@@ -142,7 +143,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an
True ->
convertGenerics
components main_dcl_module_n ti_common_defs fun_defs td_infos
heaps hash_table predef_symbols dcl_mods undef error_admin
heaps hash_table predef_symbols dcl_mods error_admin
False ->
(components, ti_common_defs, fun_defs, {ir_to=0,ir_from=0}, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin)
)
......@@ -157,6 +158,14 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an
# icl_mod = {icl_mod & icl_common = icl_common}
# error = error_admin.ea_file
/*
# (_,genout,files) = fopen "c:\\Generics\\genout.icl" FWriteText files
# (fun_defs, genout) = printFunDefs fun_defs genout
# (ok,files) = fclose genout files
| not ok = abort "could not write genout.icl"
*/
#! ok = error_admin.ea_ok
| not ok
= (No,{},{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
......
......@@ -3,8 +3,8 @@ definition module generics
import checksupport
from transform import Group
convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} !(Optional {#Index}) !*ErrorAdmin
-> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, !(Optional {#Index}), !*ErrorAdmin)
convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} /*!(Optional {#Index})*/ !*ErrorAdmin
-> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, /*!(Optional {#Index}),*/ !*ErrorAdmin)
getGenericMember :: !(Global Index) !TypeKind !{#CommonDefs} -> (Bool, Global Index)
\ No newline at end of file
This diff is collapsed.
......@@ -1328,8 +1328,10 @@ optionalCoercions pState
wantGenericDefinition :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState)
wantGenericDefinition parseContext pos pState
| SwitchGenerics False True
= (PD_Erroneous, parseError "generic definition" No "generics are not supported" pState)
| not pState.ps_support_generics
= (PD_Erroneous, parseError "generic definition" No "support for generics is disabled in the compiler. " pState)
= (PD_Erroneous, parseError "generic definition" No "to enable generics use the command line flag -generics" pState)
# (name, pState) = want_name pState
| name == ""
= (PD_Erroneous, pState)
......@@ -3357,8 +3359,10 @@ wantBeginGroup msg pState
// AA..
wantKind :: !ParseState -> !(!TypeKind, !ParseState)
wantKind pState
| SwitchGenerics False True
= (KindConst, parseError "kind" No "generics are not supported" pState)
| not pState.ps_support_generics
= (KindConst, parseError "kind" No "support for generics is disabled in the compiler. " pState)
= (KindConst, parseError "kind" No "to enable generics use -generics command line flag" pState)
# (token, pState) = nextToken TypeContext pState
# (kind, pState) = want_simple_kind token pState
# (token, pState) = nextToken TypeContext pState
......@@ -3368,7 +3372,7 @@ wantKind pState
want_simple_kind (IntToken str) pState
# n = toInt str
| n == 0 = (KindConst, pState)
| n > 0 = (KindArrow (repeatn (n+1) KindConst), pState)
| n > 0 = (KindArrow (repeatn n KindConst), pState)
| otherwise = (KindConst, parseError "invalid kind" No "positive integer expected" pState)
want_simple_kind OpenToken pState = wantKind pState
want_simple_kind GenericOpenToken pState = wantKind pState
......@@ -3379,7 +3383,8 @@ wantKind pState
# (rhs, pState) = wantKind pState
= case rhs of
(KindArrow ks) -> (KindArrow [kind : ks], pState)
_ -> (KindArrow [kind, rhs], pState)
KindConst -> (KindArrow [kind], pState)
//_ -> (KindArrow [kind, rhs], pState)
want_kind kind CloseToken pState = (kind, pState)
want_kind kind GenericCloseToken pState = (kind, pState)
want_kind kind token pState
......
......@@ -1816,8 +1816,7 @@ instance toString TypeKind
where
toString (KindVar _) = "**"
toString KindConst = "*"
// toString (KindArrow args) = toString (length args)
toString (KindArrow args) = "{" +++ (to_string args) +++ "}"
toString (KindArrow args) = "{" +++ (to_string args) +++ "->*}"
where
to_string [] = "??????"
to_string [k] = toString k
......@@ -2000,6 +1999,9 @@ where
(<<<) file (TVI_TypeKind _) = file <<< "TVI_TypeKind"
(<<<) file (TVI_SignClass _ _ _) = file <<< "TVI_SignClass"
(<<<) file (TVI_PropClass _ _ _) = file <<< "TVI_PropClass"
(<<<) file (TVI_TypeKind kind_info_ptr) = file <<< "TVI_TypeKind " <<< (ptrToInt kind_info_ptr)
(<<<) file (TVI_Kind kind) = file <<< "TVI_Kind" <<< kind
instance <<< (Import from_symbol) | <<< from_symbol
where
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment