Commit 7a3e3a39 authored by Artem Alimarine's avatar Artem Alimarine
Browse files

Generics are added, but are disabled.

Tested with compiling Object IO and butstrapping.
parent fe32f6bc
......@@ -4,4 +4,3 @@ import checksupport, typesupport
analTypeDefs :: !{#CommonDefs} !NumberSet !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin)
instance <<< TypeKind
......@@ -10,21 +10,6 @@ import syntax, checksupport, checktypes, check, typesupport, utilities, analunit
AS_NotChecked :== -1
instance <<< TypeKind
where
(<<<) file tk = file <<< toString (toKindInfo tk)
instance toString KindInfo
where
toString (KI_Var ptr) = "*" +++ toString (ptrToInt ptr)
toString (KI_Const) = "*"
toString (KI_Arrow kinds) = kind_list_to_string kinds
where
kind_list_to_string [] = " ?????? "
kind_list_to_string [k] = "* -> *"
kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks
kindError kind1 kind2 error
= checkError "conflicting kinds: " (toString kind1 +++ " and " +++ toString kind2) error
......@@ -70,8 +55,8 @@ where
= KI_Var info_ptr
toKindInfo KindConst
= KI_Const
toKindInfo (KindArrow arity)
= KI_Arrow [ KI_Const \\ i <- [1 .. arity]]
toKindInfo (KindArrow ks)
= KI_Arrow [ toKindInfo k \\ k <- ks]
// ---> ("toKindInfo", arity)
......@@ -373,7 +358,8 @@ where
determine_kind (KI_Indirection kind)
= determine_kind kind
determine_kind (KI_Arrow kinds)
= KindArrow (length kinds)
//AA: = KindArrow (length kinds)
= KindArrow [determine_kind k \\ k <- kinds]
determine_kind kind
= KindConst
......
......@@ -14,3 +14,5 @@ determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials
arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x]
makeElemTypeOfArrayFunctionStrict :: !SymbolType !Index !{# Index} -> SymbolType
initializeContextVariables :: ![TypeContext] !*VarHeap -> (![TypeContext], !*VarHeap)
This diff is collapsed.
......@@ -860,9 +860,39 @@ where
checkExpression free_vars (PE_Ident id) e_input e_state e_info cs
= checkIdentExpression cIsNotInExpressionList free_vars id e_input e_state e_info cs
// AA..
checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_state e_info cs=:{cs_symbol_table, cs_x}
//= checkIdentExpression cIsNotInExpressionList free_vars id e_input e_state e_info cs
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
= check_generic_expr free_vars entry id kind e_input e_state e_info {cs & cs_symbol_table = cs_symbol_table}
where
check_generic_expr :: ![FreeVar] !SymbolTableEntry !Ident !TypeKind !ExpressionInput !*ExpressionState !*ExpressionInfo !*CheckState
-> (!Expression, ![FreeVar], !*ExpressionState, !*ExpressionInfo, !*CheckState)
check_generic_expr
free_vars entry=:{ste_kind=STE_Generic,ste_index} id kind
e_input=:{ei_mod_index} e_state e_info cs
= check_it free_vars ei_mod_index ste_index id kind e_input e_state e_info cs
check_generic_expr
free_vars entry=:{ste_kind=STE_Imported STE_Generic mod_index, ste_index} id kind
e_input e_state e_info cs
= check_it free_vars mod_index ste_index id kind e_input e_state e_info cs
check_generic_expr free_vars entry=:{ste_kind=STE_Empty} id kind e_input e_state e_info cs=:{cs_error}
= (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "undefined generic" cs_error })
check_generic_expr free_vars entry id kind e_input e_state e_info cs=:{cs_error}
= (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "not a generic" cs_error })
check_it free_vars mod_index gen_index id kind e_input e_state=:{es_expr_heap} e_info cs
#! symb_kind = SK_Generic { glob_object = gen_index, glob_module = mod_index} kind
#! symbol = { symb_name = id, symb_kind = symb_kind, symb_arity = 0 }
#! (new_info_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
#! app = { app_symb = symbol, app_args = [], app_info_ptr = new_info_ptr }
#! e_state = { e_state & es_expr_heap = es_expr_heap }
#! cs = { cs & cs_x.x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric }
= (App app, free_vars, e_state, e_info, cs)
// ..AA
checkExpression free_vars expr e_input e_state e_info cs
= abort "checkExpression (check.icl, line 1433)" // <<- expr
= abort "checkExpression (checkFunctionBodies.icl, line 868)" // <<- expr
checkIdentExpression :: !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState
......
......@@ -15,6 +15,7 @@ cIsADclModule :== True
cNeedStdArray :== 1
cNeedStdEnum :== 2
cNeedStdDynamics:== 4
cNeedStdGeneric :== 8 // AA
:: VarHeap :== Heap VarInfo
......@@ -41,11 +42,12 @@ cConstructorDefs :== 1
cSelectorDefs :== 2
cClassDefs :== 3
cMemberDefs :== 4
cInstanceDefs :== 5
cFunctionDefs :== 6
cMacroDefs :== 7
cGenericDefs :== 5 // AA
cInstanceDefs :== 6
cFunctionDefs :== 7
cMacroDefs :== 8
cConversionTableSize :== 8
cConversionTableSize :== 9 // AA
:: CommonDefs =
{ com_type_defs :: !.{# CheckedTypeDef}
......@@ -55,6 +57,7 @@ cConversionTableSize :== 8
, com_member_defs :: !.{# MemberDef}
, com_instance_defs :: !.{# ClassInstance}
// , com_instance_types :: !.{ SymbolType}
, com_generic_defs :: !.{# GenericDef} // AA
}
:: Declarations = {
......@@ -135,6 +138,7 @@ instance <<< IdentPos, ExplImpInfo, DeclarationInfo
, ef_cons_defs :: !.{# ConsDef}
, ef_member_defs :: !.{# MemberDef}
, ef_class_defs :: !.{# ClassDef}
, ef_generic_defs :: !.{# GenericDef} // AA
, ef_modules :: !.{# DclModule}
, ef_is_macro_fun :: !Bool
}
......
......@@ -22,6 +22,7 @@ cIsADclModule :== True
cNeedStdArray :== 1
cNeedStdEnum :== 2
cNeedStdDynamics:== 4
cNeedStdGeneric :== 8 // AA
:: Heaps =
{ hp_var_heap ::!.VarHeap
......@@ -42,11 +43,12 @@ cConstructorDefs :== 1
cSelectorDefs :== 2
cClassDefs :== 3
cMemberDefs :== 4
cInstanceDefs :== 5
cFunctionDefs :== 6
cMacroDefs :== 7
cGenericDefs :== 5 // AA
cInstanceDefs :== 6
cFunctionDefs :== 7
cMacroDefs :== 8
cConversionTableSize :== 8
cConversionTableSize :== 9 // AA
instance toInt STE_Kind
where
......@@ -54,8 +56,9 @@ where
toInt STE_Constructor = cConstructorDefs
toInt (STE_Field _) = cSelectorDefs
toInt STE_Class = cClassDefs
toInt STE_Generic = cGenericDefs
toInt STE_Member = cMemberDefs
toInt (STE_Instance _) = cInstanceDefs
toInt (STE_Instance _) = cInstanceDefs
toInt STE_DclFunction = cFunctionDefs
toInt (STE_FunctionOrMacro _) = cMacroDefs
toInt _ = NoIndex
......@@ -67,6 +70,7 @@ where
, com_class_defs :: !.{# ClassDef}
, com_member_defs :: !.{# MemberDef}
, com_instance_defs :: !.{# ClassInstance}
, com_generic_defs :: !.{# GenericDef} // AA
}
:: Declarations = {
......@@ -206,6 +210,7 @@ where
, ef_cons_defs :: !.{# ConsDef}
, ef_member_defs :: !.{# MemberDef}
, ef_class_defs :: !.{# ClassDef}
, ef_generic_defs :: !.{# GenericDef} // AA
, ef_modules :: !.{# DclModule}
, ef_is_macro_fun :: !Bool
}
......
......@@ -29,3 +29,5 @@ decodeTopConsVar cv :== ~(inc cv)
expandSynonymTypes :: !.Index !*{#CheckedTypeDef} !*{#.DclModule} !*TypeHeaps !*ErrorAdmin
-> (!.{#CheckedTypeDef},!.{#DclModule},!.TypeHeaps,!.ErrorAdmin)
removeVariablesFromSymbolTable :: !Int ![TypeVar] !*SymbolTable -> *SymbolTable
......@@ -400,25 +400,6 @@ expandSynType mod_index type_index expst=:{exp_type_defs}
_
-> { expst & exp_marks = { expst.exp_marks & [type_index] = CS_Checked }}
instance toString KindInfo
where
toString (KI_Var ptr) = "*" +++ toString (ptrToInt ptr)
toString (KI_Const) = "*"
toString (KI_Arrow kinds) = kind_list_to_string kinds
where
kind_list_to_string [k] = "* -> *"
kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks
/*
instance toString TypeKind
where
toString (KindVar var_num) = "*" +++ toString var_num
toString (KindConst) = "*"
toString (KindArrow [k:ks]) = toString k +++ kind_list_to_string ks +++ " -> *"
where
kind_list_to_string [] = ""
kind_list_to_string [k:ks] = " -> " +++ toString k +++ kind_list_to_string ks
*/
checkTypeDefs :: /* TD */ !Bool !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
-> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState)
checkTypeDefs /* TD */ is_dcl_module is_main_dcl type_defs module_index cons_defs selector_defs modules var_heap type_heaps cs
......@@ -1171,6 +1152,8 @@ where
= create_class_dictionaries mod_index (inc class_index) class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
= (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs)
create_class_dictionary :: !Index !Index !*{#ClassDef} !w:{#DclModule} !v:[SymbolPtr] !u:Indexes !*TypeVarHeap !*VarHeap !*CheckState
-> (!*{#ClassDef}, !w:{#DclModule}, !v:[SymbolPtr], !u:Indexes, !*TypeVarHeap, !*VarHeap, !*CheckState)
create_class_dictionary mod_index class_index class_defs =:{[class_index] = class_def } modules rev_dictionary_list
indexes type_var_heap var_heap cs=:{cs_symbol_table,cs_error}
# {class_name,class_args,class_arity,class_members,class_context,class_dictionary=ds=:{ds_ident={id_info}}} = class_def
......@@ -1241,6 +1224,7 @@ where
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })
<:= (cons_id_info, { ste_kind = STE_DictCons cons_def, ste_index = index_cons,
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })})
# ({ste_kind}, cs_symbol_table) = readPtr id_info cs_symbol_table
| ste_kind == STE_Empty
= (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap,
......
......@@ -547,6 +547,7 @@ instance toString STE_Kind where
toString STE_Constructor = "constructor"
toString (STE_Field _) = "field"
toString STE_Class = "class"
toString STE_Generic = "generic" //AA
toString STE_Member = "class member"
toString (STE_Instance _) = "instance"
......@@ -623,7 +624,7 @@ instance check_completeness CheckedBody where
instance check_completeness ClassDef where
check_completeness {class_context} cci ccs
= check_completeness class_context cci ccs
instance check_completeness ClassInstance where
check_completeness {ins_class, ins_type} cci ccs
= check_completeness ins_type cci
......
......@@ -2,6 +2,8 @@ implementation module frontend
import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics
//import RWSDebug
import analtypes
import generics
:: FrontEndSyntaxTree
= { fe_icl :: !IclModule
......@@ -121,17 +123,37 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
| upToPhase == FrontEndPhaseCheck
= frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
// AA..
# error_admin = {ea_file = error, ea_loc = [], ea_ok = True }
# ti_common_defs = {{dcl_common \\ {dcl_common} <-: dcl_mods } & [main_dcl_module_n] = icl_common }
# (td_infos, type_heaps, error_admin) = analTypeDefs ti_common_defs icl_used_module_numbers type_heaps error_admin
# heaps = { heaps & hp_type_heaps = type_heaps }
#! (components, ti_common_defs, fun_defs, generic_range, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) =
case False of
True -> convertGenerics
components main_dcl_module_n ti_common_defs fun_defs td_infos
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)
# icl_common = ti_common_defs.[main_dcl_module_n]
# error = error_admin.ea_file
// ..AA
# (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out)
= typeProgram (components -*-> "Typing") main_dcl_module_n icl_functions icl_specials list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers heaps predef_symbols error out dcl_mods
= typeProgram (components -*-> "Typing") main_dcl_module_n fun_defs/*icl_functions*/ icl_specials list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers td_infos heaps predef_symbols error out dcl_mods
| not ok
= (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
# (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials]
# (fun_def_size, fun_defs) = usize fun_defs
# (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
// (fun_defs, error) = showFunctions array_instances fun_defs error
| upToPhase == FrontEndPhaseTypeCheck
= frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
......@@ -242,8 +264,7 @@ where
= show_component funs show_types fun_defs (file <<< fun_def.fun_type <<< '\n' <<< fun_def)
= show_component funs show_types fun_defs (file <<< fun_def)
// = show_component funs show_types fun_defs (file <<< fun_def.fun_symb)
showComponents2 :: !{! Group} !Int !*{# FunDef} !{! ConsClasses} !*File -> (!*{# FunDef},!*File)
showComponents2 comps comp_index fun_defs acc_args file
| comp_index >= (size comps)
......
definition module generics
import checksupport
from transform import Group
convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} !*ErrorAdmin
-> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, !*ErrorAdmin)
getGenericMember :: !(Global Index) !TypeKind !{#CommonDefs} -> (Bool, Global Index)
\ No newline at end of file
This diff is collapsed.
......@@ -3,6 +3,7 @@ implementation module overloading
import StdEnv
import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, convertDynamics // ,RWSDebug
import generics // AA
:: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty
......@@ -711,6 +712,13 @@ where
= find_instance_of_member me_class me_offset {rcs & rcs_constraints_contexts = rcs_constraints_contexts ++ rcss}
find_instance_of_member_in_constraints me_class me_offset []
= abort "Error in module overloading: find_instance_of_member_in_constraints\n"
// AA..
convertOverloadedCall defs contexts symbol=:{symb_kind = SK_Generic gen_glob kind} expr_ptr class_appls heaps_and_ptrs
# (found, member_glob) = getGenericMember gen_glob kind defs
| not found
= abort "convertOverloadedCall: no class for kind"
= convertOverloadedCall defs contexts {symbol & symb_kind = SK_OverloadedFunction member_glob} expr_ptr class_appls heaps_and_ptrs
// ..AA
convertOverloadedCall defs contexts {symb_name,symb_kind = SK_TypeCode} expr_info_ptr class_appls heaps_and_ptrs
# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts class_appls heaps_and_ptrs
= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))}, ptrs)
......@@ -868,7 +876,6 @@ getClassVariable symb var_info_ptr var_heap error
(_, var_heap)
-> (symb, var_info_ptr, var_heap, overloadingError symb error)
updateDynamics :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol}
-> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol})
updateDynamics funs type_pattern_vars main_dcl_module_n fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols
......
......@@ -287,7 +287,7 @@ where
(defs, pState) = want_definitions (SetGlobalContext iclmodule) pState
{ps_scanState,ps_hash_table,ps_error,ps_pre_def_symbols}
= pState
defs = if (ParseOnly && id_name <> "StdOverloaded" && id_name <> "StdArray" && id_name <> "StdEnum" && id_name <> "StdBool" && id_name <> "StdDynamics")
defs = if (ParseOnly && id_name <> "StdOverloaded" && id_name <> "StdArray" && id_name <> "StdEnum" && id_name <> "StdBool" && id_name <> "StdDynamics" && id_name <> "StdGeneric")
[PD_Import imports \\ PD_Import imports <- defs]
defs
mod = { mod_name = mod_ident, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = defs }
......@@ -413,6 +413,13 @@ where
= (False,abort "no def(2)",parseError "definition" No "class definitions are only at the global level" pState)
# (classdef, pState) = wantClassDefinition context pos pState
= (True, classdef, pState)
// AA..
try_definition context GenericToken pos pState
| ~(isGlobalContext context)
= (False,abort "no def(2)",parseError "definition" No "generic definitions are only at the global level" pState)
# (gendef, pState) = wantGenericDefinition context pos pState
= (True, gendef, pState)
// ..AA
try_definition context InstanceToken pos pState
| ~(isGlobalContext context)
= (False,abort "no def(2)",parseError "definition" No "instance declarations are only at the global level" pState)
......@@ -1062,22 +1069,30 @@ wantInstanceDeclaration context pi_pos pState
(pi_class, pState) = stringToIdent class_name IC_Class pState
((pi_types, pi_context), pState) = want_instance_type pState
(pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState
// AA..
# (token, pState) = nextToken TypeContext pState
| token == GenericToken
# pState = wantEndOfDefinition "generic instance declaration" pState
= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_members = [], pi_specials = SP_None, pi_pos = pi_pos, pi_generate = True}, pState)
// ..AA
| isIclContext context
# pState = want_begin_group pState
# pState = tokenBack pState // AA
pState = want_begin_group pState
(pi_members, pState) = wantDefinitions context pState
pState = wantEndGroup "instance" pState
= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos }, pState)
pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos, pi_generate = False }, pState)
// otherwise // ~ (isIclContext context)
# (token, pState) = nextToken TypeContext pState
| token == CommaToken
// AA: # (token, pState) = nextToken TypeContext pState
# (pi_types_and_contexts, pState) = want_instance_types pState
(idents, pState) = seqList [stringToIdent class_name (IC_Instance type) \\ (type,context) <- pi_types_and_contexts] pState
= (PD_Instances
// [ { pi_class = pi_class, pi_ident = pi_ident, pi_types = type, pi_context = context // voor martin
[ { pi_class = pi_class, pi_ident = ident, pi_types = type, pi_context = context
, pi_members = [], pi_specials = SP_None, pi_pos = pi_pos}
, pi_members = [], pi_specials = SP_None, pi_pos = pi_pos, pi_generate = False}
\\ (type,context) <- [ (pi_types, pi_context) : pi_types_and_contexts ]
& ident <- [ pi_ident : idents ]
]
......@@ -1087,7 +1102,8 @@ wantInstanceDeclaration context pi_pos pState
# (specials, pState) = optionalSpecials (tokenBack pState)
pState = wantEndOfDefinition "instance declaration" pState
= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_members = [], pi_specials = specials, pi_pos = pi_pos}, pState)
pi_members = [], pi_specials = specials, pi_pos = pi_pos, pi_generate = False}, pState)
where
want_begin_group pState // For JvG layout
# (token, pState) = nextToken TypeContext pState
......@@ -1186,6 +1202,48 @@ optionalCoercions pState
, parseError "Function type: optional coercions" (Yes token) "<attribute variable>" pState
)
// AA..
/*
Generic definitions
*/
wantGenericDefinition :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState)
wantGenericDefinition context pos pState
# (name, pState) = want_name 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
# pState = wantToken TypeContext "generic definition" DoubleColonToken pState
# (type, pState) = want_type pState // SymbolType
# pState = wantEndOfDefinition "generic definition" pState
# gen_def = {
gen_name = ident,
gen_member_name = member_ident,
gen_type = type,
gen_args = arg_vars,
gen_arity = length arg_vars,
gen_pos = pos,
gen_classes = [],
gen_isomap = MakeDefinedSymbol {id_name="",id_info=nilPtr} NoIndex 0
}
= (PD_Generic gen_def, pState)
where
want_name pState
# (token, pState) = nextToken TypeContext pState
= case token of
IdentToken name -> (name, pState)
_ -> ("", parseError "Generic Definition" (Yes token) "<identifier>" pState)
want_type :: !ParseState -> (!SymbolType, !ParseState)
want_type pState = want pState // SymbolType
try_variable pState
# (token, pState) = nextToken TypeContext pState
= tryTypeVarT token pState
// ..AA
/*
Type definitions
*/
......@@ -1949,6 +2007,10 @@ trySimpleExpression is_pattern pState
= trySimpleRhsExpression pState
trySimpleExpressionT :: !Token !Bool !ParseState -> (!Bool, !ParsedExpr, !ParseState)
// AA..
/*
trySimpleExpressionT (IdentToken name) is_pattern pState
| isLowerCaseName name
# (id, pState) = stringToIdent name IC_Expression pState
......@@ -1967,6 +2029,38 @@ trySimpleExpressionT (IdentToken name) is_pattern pState
// | isUpperCaseName name || ~ is_pattern
# (id, pState) = stringToIdent name IC_Expression pState
= (True, PE_Ident id, pState)
*/
trySimpleExpressionT (IdentToken name) is_pattern pState
| isLowerCaseName name
# (id, pState) = stringToIdent name IC_Expression pState
| is_pattern
# (token, pState) = nextToken FunctionContext pState
| token == DefinesColonToken
# (succ, expr, pState) = trySimpleExpression is_pattern pState
| succ
= (True, PE_Bound { bind_dst = id, bind_src = expr }, pState)
= (True, PE_Empty, parseError "simple expression" No "expression" pState)
// token <> DefinesColonToken
= (True, PE_Ident id, tokenBack pState)
// not is_pattern
# (token, pState) = nextToken FunctionContext pState
| token == GenericOpenToken
# (kind, pState) = wantKind pState
= (True, PE_Generic id kind, pState)
= (True, PE_Ident id, tokenBack pState)
trySimpleExpressionT (IdentToken name) is_pattern pState
// | isUpperCaseName name || ~ is_pattern
# (id, pState) = stringToIdent name IC_Expression pState
# (token, pState) = nextToken FunctionContext pState
| token == GenericOpenToken
# (kind, pState) = wantKind pState
= (True, PE_Generic id kind, pState)
= (True, PE_Ident id, tokenBack pState)
// ..AA
trySimpleExpressionT SquareOpenToken is_pattern pState
# (list_expr, pState) = wantListExp is_pattern pState
= (True, list_expr, pState)
......@@ -2844,6 +2938,36 @@ wantBeginGroup msg pState
-> pState
_ -> parseError msg (Yes token) "begin group without layout, {," pState
// AA..
wantKind :: !ParseState -> !(!TypeKind, ParseState)
wantKind pState
# (token, pState) = nextToken TypeContext pState
# (kind, pState) = want_simple_kind token pState
# (token, pState) = nextToken TypeContext pState
= want_kind kind token pState
where
want_simple_kind AsteriskToken pState = (KindConst, pState)
want_simple_kind (IntToken str) pState
# n = toInt str
| n == 0 = (KindConst, pState)
| n > 0 = (KindArrow (repeatn (n+1) 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
want_simple_kind token pState
= (KindConst, parseError "invalid kind" (Yes token) "* or (" pState)
want_kind kind ArrowToken pState
# (rhs, pState) = wantKind pState
= case rhs of
(KindArrow ks) -> (KindArrow [kind : ks], pState)
_ -> (KindArrow [kind, rhs], pState)
want_kind kind CloseToken pState = (kind, pState)
want_kind kind GenericCloseToken pState = (kind, pState)
want_kind kind token pState
= (kind, parseError "invalid kind" (Yes token) ")" pState)
// ..AA
/*
Functions on the parse pState
*/
......
......@@ -725,7 +725,7 @@ where
MakeEmptyModule name :== { mod_name = name, mod_type = MK_None, mod_imports = [], mod_imported_objects = [],
mod_defs = { def_types = [], def_constructors = [], def_selectors = [], def_classes = [], def_macros = { ir_from = 0, ir_to = 0 },
def_members = [], def_funtypes = [], def_instances = [] } }
def_members = [], def_funtypes = [], def_instances = [], /* AA */ def_generics = [] } }