Skip to content

GitLab

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
Expand all Hide whitespace changes
Inline Side-by-side
frontend/analtypes.dcl
View file @ 7a3e3a39
......@@ -4,4 +4,3 @@ import checksupport, typesupport
analTypeDefs :: !{#CommonDefs} !NumberSet !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin)
instance <<< TypeKind
frontend/analtypes.icl
View file @ 7a3e3a39
......@@ -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
......
frontend/check.dcl
View file @ 7a3e3a39
......@@ -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)
frontend/check.icl
View file @ 7a3e3a39
This diff is collapsed.
frontend/checkFunctionBodies.icl
View file @ 7a3e3a39
......@@ -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
......
frontend/checksupport.dcl
View file @ 7a3e3a39
......@@ -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
}
......
frontend/checksupport.icl
View file @ 7a3e3a39
......@@ -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
}
......
frontend/checktypes.dcl
View file @ 7a3e3a39
......@@ -29,3 +29,5 @@ decodeTopConsVar cv :== ~(inc cv)
expandSynonymTypes :: !.Index !*{#CheckedTypeDef} !*{#.DclModule} !*TypeHeaps !*ErrorAdmin
-> (!.{#CheckedTypeDef},!.{#DclModule},!.TypeHeaps,!.ErrorAdmin)
removeVariablesFromSymbolTable :: !Int ![TypeVar] !*SymbolTable -> *SymbolTable
frontend/checktypes.icl
View file @ 7a3e3a39
......@@ -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,
......
frontend/explicitimports.icl
View file @ 7a3e3a39
......@@ -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
......
frontend/frontend.icl
View file @ 7a3e3a39
......@@ -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)
......
frontend/generics.dcl 0 → 100644
View file @ 7a3e3a39
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
frontend/generics.icl 0 → 100644
View file @ 7a3e3a39
This diff is collapsed.
frontend/overloading.icl
View file @ 7a3e3a39
......@@ -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
......
frontend/parse.icl
View file @ 7a3e3a39
......@@ -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
*/
......
frontend/postparse.icl
View file @ 7a3e3a39
......@@ -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 = [] } }