Commit fe662306 authored by John van Groningen's avatar John van Groningen
Browse files

add derive class for deriving generic functions in class context (from iTask branch)

parent 43c8b95c
......@@ -982,6 +982,8 @@ where
gen_case_def_to_dcl {gc_gcf=GCF gc_ident _, gc_pos} (decl_index, decls)
= (inc decl_index, [Declaration {decl_ident = gc_ident, decl_pos = gc_pos, decl_kind = STE_GenericCase, decl_index = decl_index} : decls])
gen_case_def_to_dcl {gc_gcf=GCFC gcfc_ident _, gc_pos} (decl_index, decls)
= (inc decl_index, [Declaration {decl_ident = gcfc_ident, decl_pos = gc_pos, decl_kind = STE_GenericDeriveClass, decl_index = decl_index} : decls])
createCommonDefinitions :: (CollectedDefinitions ClassInstance) -> .CommonDefs;
createCommonDefinitions {def_types,def_constructors,def_selectors,def_classes,def_members,def_instances, def_generics,def_generic_cases}
......@@ -1012,8 +1014,8 @@ checkCommonDefinitions opt_icl_info module_index common modules heaps cs
= checkInstanceDefs module_index common.com_instance_defs com_type_defs com_class_defs com_member_defs modules heaps cs
(com_generic_defs, com_type_defs, com_class_defs, modules, heaps, cs)
= checkGenericDefs module_index opt_icl_info common.com_generic_defs com_type_defs com_class_defs modules heaps cs
(com_gencase_defs, com_generic_defs, com_type_defs, modules, heaps, cs)
= checkGenericCaseDefs module_index common.com_gencase_defs com_generic_defs com_type_defs modules heaps cs
(com_gencase_defs, com_generic_defs, com_type_defs, com_class_defs, modules, heaps, cs)
= checkGenericCaseDefs module_index common.com_gencase_defs com_generic_defs com_type_defs com_class_defs modules heaps cs
| cs.cs_error.ea_ok
# (size_com_type_defs,com_type_defs) = usize com_type_defs
(size_com_selector_defs,com_selector_defs) = usize com_selector_defs
......@@ -1059,7 +1061,7 @@ where
= ([Declaration { decl_ident = fun_ident, decl_pos = fun_pos, decl_kind = STE_FunctionOrMacro [], decl_index = decl_index } : defs], fun_defs)
collectDclMacros {ir_from=from_index,ir_to=to_index} fun_defs (sizes, defs)
# (defs, fun_defs) = iFoldSt macro_def_to_dcl from_index to_index (defs, fun_defs)
# (defs, fun_defs) = iFoldSt macro_def_to_dcl from_index to_index (defs, fun_defs)
= (fun_defs, ({ sizes & [cMacroDefs] = to_index - from_index }, defs))
where
macro_def_to_dcl decl_index (defs, fun_defs)
......@@ -2027,7 +2029,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
= (new_table, icl_gencases, error)
build_conversion_table_for_generic_case dcl_index dcl_gencases icl_gencases new_table error
# icl_index = dcl_index
# icl_index = dcl_index
(icl_gencase, icl_gencases) = icl_gencases![icl_index]
dcl_gencase = dcl_gencases.[dcl_index]
= case (dcl_gencase,icl_gencase) of
......@@ -2035,6 +2037,18 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
{gc_gcf=GCF _ {gcf_body = GCB_FunIndex icl_fun}})
#! new_table = { new_table & [dcl_fun] = icl_fun }
-> (new_table, icl_gencases, error)
({gc_gcf=GCFS dcl_gcfs},{gc_gcf=GCFS icl_gcfs})
#! new_table = build_conversion_table_for_generic_superclasses dcl_gcfs icl_gcfs new_table
-> (new_table, icl_gencases, error)
({gc_gcf=GCFS dcl_gcfs},{gc_gcf=GCFC _ _})
// error already reported in checkGenericCaseDefs
-> (new_table, icl_gencases, error)
where
build_conversion_table_for_generic_superclasses [!{gcf_body=GCB_FunIndex dcl_fun}:dcl_gcfs!] [!{gcf_body=GCB_FunIndex icl_fun}:icl_gcfs!] new_table
# new_table = {new_table & [dcl_fun] = icl_fun}
= build_conversion_table_for_generic_superclasses dcl_gcfs icl_gcfs new_table
build_conversion_table_for_generic_superclasses [!!] [!!] new_table
= new_table
build_conversion_table_for_instances dcl_class_inst_index dcl_instances instances_conversion_table_size icl_instances new_table error
| dcl_class_inst_index < instances_conversion_table_size
......@@ -2079,17 +2093,31 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
renumber_members_of_gencases No gencases
= gencases
renumber_members_of_gencases (Yes function_conversion_table) gencases
= renumber 0 gencases
where
renumber gencase_index gencases
= renumber_gencase_members 0 gencases
where
renumber_gencase_members gencase_index gencases
| gencase_index < size gencases
# (gencase,gencases) = gencases![gencase_index]
# {gc_gcf=GCF gc_ident gcf=:{gcf_body=GCB_FunIndex icl_index}} = gencase
# dcl_index = function_conversion_table.[icl_index]
# gencase = {gencase & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunIndex dcl_index}}
# gencases = {gencases & [gencase_index] = gencase}
= renumber (inc gencase_index) gencases
= gencases
= case gencase of
{gc_gcf=GCF gc_ident gcf=:{gcf_body=GCB_FunIndex icl_index}}
# dcl_index = function_conversion_table.[icl_index]
# gencase = {gencase & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunIndex dcl_index}}
# gencases = {gencases & [gencase_index] = gencase}
-> renumber_gencase_members (inc gencase_index) gencases
{gc_gcf=GCFS gcfs}
# gcfs = renumber_gcfs gcfs function_conversion_table
# gencase = {gencase & gc_gcf=GCFS gcfs}
# gencases = {gencases & [gencase_index] = gencase}
-> renumber_gencase_members (gencase_index+1) gencases
= gencases
renumber_gcfs [!gcf=:{gcf_body=GCB_FunIndex icl_index}:gcfs!] function_conversion_table
# dcl_index = function_conversion_table.[icl_index]
# gcf = {gcf & gcf_body=GCB_FunIndex dcl_index}
# gcfs = renumber_gcfs gcfs function_conversion_table
= [!gcf:gcfs!]
renumber_gcfs [!!] function_conversion_table
= [!!]
checkModule :: !ScannedModule !IndexRange ![FunDef] !Bool !Bool !Int !(Optional ScannedModule) ![ScannedModule]
!{#DclModule} !*{#*{#FunDef}} !*PredefinedSymbols !*SymbolTable !*File !*Heaps
......
......@@ -7,11 +7,11 @@ checkGenericDefs :: !Index !(Optional (CopiedDefinitions, Int))
!*{#GenericDef} !*{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#GenericDef},!*{#CheckedTypeDef},!*{#ClassDef},!*{#DclModule},!*Heaps,!*CheckState)
checkGenericCaseDefs :: !Index !*{#GenericCaseDef} !*{#GenericDef} !u:{#CheckedTypeDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#GenericCaseDef},!*{#GenericDef},!u:{#CheckedTypeDef},!*{#DclModule},!.Heaps,!.CheckState)
checkGenericCaseDefs :: !Index !*{#GenericCaseDef} !*{#GenericDef} !u:{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#GenericCaseDef},!*{#GenericDef},!u:{#CheckedTypeDef},!*{#ClassDef},!*{#DclModule},!.Heaps,!.CheckState)
convert_generic_instances :: !Int !Int !*{#GenericCaseDef} !*{#ClassDef} !*SymbolTable !*ErrorAdmin !*{#DclModule}
-> (!.[FunDef],!*{#GenericCaseDef},!*{#ClassDef},!*SymbolTable,!*ErrorAdmin,!*{#DclModule})
create_gencase_funtypes :: !Index !*{#GenericCaseDef} !*Heaps
-> (!Index, ![FunType], !*{#GenericCaseDef},!*Heaps)
-> (!Index,![FunType],!*{#GenericCaseDef},!*Heaps)
......@@ -140,35 +140,105 @@ where
-> (th_vars, cs_error)
_ -> abort ("check_no_generic_vars_in_contexts: wrong TVI" ---> (tv, tv_info))
checkGenericCaseDefs :: !Index !*{#GenericCaseDef} !*{#GenericDef} !u:{#CheckedTypeDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#GenericCaseDef},!*{#GenericDef},!u:{#CheckedTypeDef},!*{#DclModule},!.Heaps,!.CheckState)
checkGenericCaseDefs mod_index gen_case_defs generic_defs type_defs modules heaps cs
= check_instances 0 mod_index gen_case_defs generic_defs type_defs modules heaps cs
checkGenericCaseDefs :: !Index !*{#GenericCaseDef} !*{#GenericDef} !u:{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#GenericCaseDef},!*{#GenericDef},!u:{#CheckedTypeDef},!*{#ClassDef},!*{#DclModule},!.Heaps,!.CheckState)
checkGenericCaseDefs mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
| size gen_case_defs==0
= (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
# {cs_x} = cs
# cs = {cs & cs_x = {cs_x & x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric}}
= check_generic_case_defs 0 mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
where
check_instances index mod_index gen_case_defs generic_defs type_defs modules heaps cs
# (n_gc, gen_inst_defs) = usize gen_case_defs
| index == n_gc
= (gen_case_defs, generic_defs, type_defs, modules, heaps, cs)
# (gen_case_defs, generic_defs, type_defs, modules, heaps, cs)
= check_instance index mod_index gen_case_defs generic_defs type_defs modules heaps cs
= check_instances (inc index) mod_index gen_case_defs generic_defs type_defs modules heaps cs
check_generic_case_defs index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
| index == size gen_case_defs
= (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
# (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
= check_generic_case_def index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
= check_generic_case_defs (inc index) mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
check_instance index mod_index gen_case_defs generic_defs type_defs modules heaps cs
check_generic_case_def index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
# (case_def=:{gc_pos,gc_type,gc_gcf}, gen_case_defs) = gen_case_defs![index]
= case gc_gcf of
GCF gc_ident gcf=:{gcf_gident}
# cs = pushErrorAdmin (newPosition gc_ident gc_pos) cs
# (gc_type, gc_type_cons, type_defs, modules, heaps, cs)
= check_instance_type mod_index gc_type type_defs modules heaps cs
# (generic_gi, cs) = get_generic_index gcf_gident mod_index cs
= check_instance_type mod_index gc_type type_defs modules heaps cs
# (generic_gi, cs) = get_generic_index gcf_gident mod_index cs
| not cs.cs_error.ea_ok
# cs = popErrorAdmin cs
-> (gen_case_defs, generic_defs, type_defs, modules, heaps, cs)
-> (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
# case_def = {case_def & gc_gcf=GCF gc_ident {gcf & gcf_generic = generic_gi}, gc_type=gc_type, gc_type_cons=gc_type_cons}
# gen_case_defs = {gen_case_defs & [index] = case_def}
# (cs=:{cs_x}) = popErrorAdmin cs
# cs = { cs & cs_x = {cs_x & x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric}}
-> (gen_case_defs, generic_defs, type_defs, modules, heaps, cs)
# cs = popErrorAdmin cs
-> (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
GCFS gcfs
# cs = pushErrorAdmin (newPosition {id_name="derive generic superclass",id_info=nilPtr} gc_pos) cs
# (gc_type, gc_type_cons, type_defs, modules, heaps, cs)
= check_instance_type mod_index gc_type type_defs modules heaps cs
| not cs.cs_error.ea_ok
# cs = popErrorAdmin cs
-> (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
# (gcfs,cs) = check_generic_superclasses gcfs mod_index cs
# cs = popErrorAdmin cs
# case_def = {case_def & gc_gcf=GCFS gcfs, gc_type=gc_type, gc_type_cons=gc_type_cons}
# gen_case_defs = {gen_case_defs & [index] = case_def}
-> (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
GCFC _ gcfc_class_ident=:{id_info}
# cs = pushErrorAdmin (newPosition {id_name="derive generic superclass",id_info=nilPtr} gc_pos) cs
# (gc_type, gc_type_cons, type_defs, modules, heaps, cs)
= check_instance_type mod_index gc_type type_defs modules heaps cs
| not cs.cs_error.ea_ok
# cs = popErrorAdmin cs
-> (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
# (entry,symbol_table) = readPtr id_info cs.cs_symbol_table
# cs = {cs & cs_symbol_table=symbol_table}
-> case entry.ste_kind of
STE_Class
# (class_context,class_defs) = class_defs![entry.ste_index].class_context
# (gen_case_defs,cs) = check_generic_superclasses_of_case_def class_context index mod_index gc_type gc_type_cons gen_case_defs cs
# cs = popErrorAdmin cs
-> (gen_case_defs,generic_defs,type_defs,class_defs, modules,heaps,cs)
STE_Imported STE_Class decl_index
# (class_context,modules) = modules![decl_index].dcl_common.com_class_defs.[entry.ste_index].class_context
# (gen_case_defs,cs) = check_generic_superclasses_of_case_def class_context index mod_index gc_type gc_type_cons gen_case_defs cs
# cs = popErrorAdmin cs
-> (gen_case_defs,generic_defs,type_defs,class_defs, modules,heaps,cs)
_
# cs = popErrorAdmin cs
# cs = {cs & cs_error = checkErrorWithPosition gcfc_class_ident gc_pos "class undefined" cs.cs_error}
-> (gen_case_defs,generic_defs,type_defs,class_defs, modules,heaps,cs)
where
check_generic_superclasses_of_case_def class_context index mod_index gc_type gc_type_cons gen_case_defs cs
# gcfs = convert_generic_contexts class_context
(gcfs,cs) = check_generic_superclasses gcfs mod_index cs
case_def = {case_def & gc_gcf=GCFS gcfs, gc_type=gc_type, gc_type_cons=gc_type_cons}
gen_case_defs = {gen_case_defs & [index]=case_def}
= (gen_case_defs,cs)
convert_generic_contexts [{tc_class=TCGeneric {gtc_generic={glob_object={ds_ident}}}}:type_contexts]
# gcf = {
gcf_gident = ds_ident,
gcf_generic = {gi_module=NoIndex,gi_index=NoIndex},
gcf_arity = 0,
gcf_body = GCB_None,
gcf_kind = KindError }
# gcfs = convert_generic_contexts type_contexts
= [!gcf:gcfs!]
convert_generic_contexts [_:type_contexts]
= convert_generic_contexts type_contexts
convert_generic_contexts []
= [!!]
check_generic_superclasses [!gcf=:{gcf_gident}:gcfs!] mod_index cs
# (generic_gi,cs) = get_generic_index gcf_gident mod_index cs
| not cs.cs_error.ea_ok
# (gcfs,cs) = check_generic_superclasses gcfs mod_index cs
= ([!gcf:gcfs!],cs)
# gcf = {gcf & gcf_generic = generic_gi}
# (gcfs,cs) = check_generic_superclasses gcfs mod_index cs
= ([!gcf:gcfs!],cs)
check_generic_superclasses [!!] mod_index cs
= ([!!],cs)
check_instance_type module_index (TA type_cons []) type_defs modules heaps=:{hp_type_heaps} cs
# (entry, cs_symbol_table) = readPtr type_cons.type_ident.id_info cs.cs_symbol_table
......@@ -241,7 +311,48 @@ convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_tabl
(fun_defs,gencase_defs,class_defs,symbol_table,error,dcl_modules)
= convert_generic_instances (gci+1) (next_fun_index+1) gencase_defs class_defs symbol_table error dcl_modules
-> ([fun_def : fun_defs],gencase_defs,class_defs,symbol_table,error,dcl_modules)
gc=:{gc_gcf=GCFC _ gcfc_class_ident=:{id_info},gc_type_cons,gc_pos}
# (entry,symbol_table) = readPtr id_info symbol_table
-> case entry.ste_kind of
STE_Class
# (class_context,class_defs) = class_defs![entry.ste_index].class_context
-> convert_generic_instances_and_superclasses class_context gci next_fun_index gencase_defs class_defs symbol_table error dcl_modules
STE_Imported STE_Class decl_index
# (class_context,dcl_modules) = dcl_modules![decl_index].dcl_common.com_class_defs.[entry.ste_index].class_context
-> convert_generic_instances_and_superclasses class_context gci next_fun_index gencase_defs class_defs symbol_table error dcl_modules
_
# error = checkErrorWithPosition gcfc_class_ident gc_pos "class undefined" error
-> convert_generic_instances (gci+1) next_fun_index gencase_defs class_defs symbol_table error dcl_modules
where
convert_generic_instances_and_superclasses class_context gci next_fun_index gencase_defs class_defs symbol_table error dcl_modules
# (gcfs,next_fun_index,new_fun_defs) = convert_generic_contexts class_context gc_type_cons gc_pos next_fun_index []
gc = {gc & gc_gcf=GCFS gcfs}
gencase_defs = {gencase_defs & [gci]=gc}
(fun_defs,gencase_defs,class_defs,symbol_table,error,dcl_modules)
= convert_generic_instances (gci+1) next_fun_index gencase_defs class_defs symbol_table error dcl_modules
= (new_fun_defs++fun_defs,gencase_defs,class_defs,symbol_table,error,dcl_modules)
= ([],gencase_defs,class_defs,symbol_table,error,dcl_modules)
where
convert_generic_contexts [{tc_class=TCGeneric {gtc_generic={glob_object={ds_ident}}}}:type_contexts] type_cons pos next_fun_index new_fun_defs
# fun_def = {
fun_ident = genericIdentToFunIdent ds_ident.id_name type_cons,
fun_arity = 0, fun_priority = NoPrio,
fun_body = GeneratedBody, fun_type = No,
fun_pos = pos, fun_kind = FK_Unknown,
fun_lifted = 0, fun_info = EmptyFunInfo
}
# gcf = {
gcf_gident = ds_ident,
gcf_generic = {gi_module=NoIndex,gi_index=NoIndex},
gcf_arity = 0,
gcf_body = GCB_FunIndex next_fun_index,
gcf_kind = KindError }
# (gcfs,next_fun_index,new_fun_defs) = convert_generic_contexts type_contexts type_cons pos (next_fun_index+1) new_fun_defs
= ([!gcf:gcfs!],next_fun_index,[fun_def:new_fun_defs])
convert_generic_contexts [_:type_contexts] type_cons pos next_fun_index new_fun_defs
= convert_generic_contexts type_contexts type_cons pos next_fun_index new_fun_defs
convert_generic_contexts [] type_cons pos next_fun_index new_fun_defs
= ([!!],next_fun_index,new_fun_defs)
create_gencase_funtypes :: !Index !*{#GenericCaseDef} !*Heaps
-> (!Index,![FunType],!*{#GenericCaseDef},!*Heaps)
......@@ -260,8 +371,25 @@ where
gencase_defs & [gc_index] = gencase_def
(fun,hp_var_heap) = create_gencase_function_type gc_ident gc_type_cons gc_pos hp_var_heap
#! (fun_index, funs, gencase_defs,hp_var_heap)
= create_funs (inc gc_index) (inc fun_index) gencase_defs hp_var_heap
= create_funs (gc_index+1) (inc fun_index) gencase_defs hp_var_heap
-> (fun_index, [fun:funs], gencase_defs, hp_var_heap)
{gc_gcf=GCFS gcfs,gc_pos,gc_type_cons}
# (gcfs,superclass_funs,fun_index,hp_var_heap)
= create_functions_for_generic_superclasses gcfs gc_type_cons gc_pos fun_index hp_var_heap
gencase_def & gc_gcf=GCFS gcfs
gencase_defs & [gc_index] = gencase_def
(fun_index,funs,gencase_defs,hp_var_heap)
= create_funs (gc_index+1) fun_index gencase_defs hp_var_heap
-> (fun_index,superclass_funs++funs,gencase_defs,hp_var_heap)
where
create_functions_for_generic_superclasses [!gcf=:{gcf_gident}:gcfs!] gc_type_cons gc_pos fun_index hp_var_heap
# (fun,hp_var_heap) = create_gencase_function_type gcf_gident gc_type_cons gc_pos hp_var_heap
# gcf={gcf & gcf_body = GCB_FunIndex fun_index}
# (gcfs,superclass_funs,fun_index,hp_var_heap)
= create_functions_for_generic_superclasses gcfs gc_type_cons gc_pos (fun_index+1) hp_var_heap
= ([!gcf:gcfs!],[fun:superclass_funs],fun_index,hp_var_heap)
create_functions_for_generic_superclasses [!!] gc_type_cons gc_pos fun_index hp_var_heap
= ([!!],[],fun_index,hp_var_heap)
create_gencase_function_type {id_name} gc_type_cons gc_pos var_heap
#! fun_ident = genericIdentToFunIdent id_name gc_type_cons
......
......@@ -4,8 +4,6 @@ import StdEnv, compare_constructor
import syntax, predef, containers
import utilities
//import RWSDebug
cUndef :== -1
instance toInt STE_Kind
......@@ -21,6 +19,7 @@ where
toInt STE_DclFunction = cFunctionDefs
toInt (STE_FunctionOrMacro _) = cMacroDefs
toInt (STE_DclMacroOrLocalMacroFunction _)= cMacroDefs
toInt STE_GenericDeriveClass = cGenericCaseDefs
toInt STE_TypeExtension = cTypeDefs
toInt _ = NoIndex
......
......@@ -41,7 +41,8 @@ ExpressionNameSpaceN:==0
TypeNameSpaceN:==1
ClassNameSpaceN:==2
FieldNameSpaceN:==3
OtherNameSpaceN:==4
GenericNameSpaceN:==4
OtherNameSpaceN:==5
search_qualified_ident :: !Ident {#Char} !NameSpaceN !*CheckState -> (!Bool,!DeclarationRecord,!*CheckState)
search_qualified_import :: !String !SortedQualifiedImports !NameSpaceN -> (!Bool,!DeclarationRecord)
......
......@@ -950,7 +950,8 @@ ExpressionNameSpaceN:==0
TypeNameSpaceN:==1
ClassNameSpaceN:==2
FieldNameSpaceN:==3
OtherNameSpaceN:==4
GenericNameSpaceN:==4
OtherNameSpaceN:==5
ste_kind_to_name_space_n STE_DclFunction = ExpressionNameSpaceN
ste_kind_to_name_space_n STE_Constructor = ExpressionNameSpaceN
......@@ -959,6 +960,7 @@ ste_kind_to_name_space_n (STE_DclMacroOrLocalMacroFunction _) = ExpressionNameSp
ste_kind_to_name_space_n STE_Type = TypeNameSpaceN
ste_kind_to_name_space_n STE_Class = ClassNameSpaceN
ste_kind_to_name_space_n (STE_Field _) = FieldNameSpaceN
ste_kind_to_name_space_n STE_Generic = GenericNameSpaceN
ste_kind_to_name_space_n _ = OtherNameSpaceN
search_qualified_ident :: !Ident {#Char} !NameSpaceN !*CheckState -> (!Bool,!DeclarationRecord,!*CheckState)
......
This diff is collapsed.
......@@ -25,6 +25,7 @@ set_hte_mark :: !Int !*HashTable -> *HashTable
| IC_InstanceMember ![Type]
| IC_Generic
| IC_GenericCase !Type
| IC_GenericDeriveClass !Type
| IC_TypeExtension !{#Char}/*module name*/
| IC_Unknown
......
......@@ -23,6 +23,7 @@ import predef, syntax, compare_types, compare_constructor
| IC_InstanceMember ![Type]
| IC_Generic
| IC_GenericCase !Type
| IC_GenericDeriveClass !Type
| IC_TypeExtension !{#Char}/*module name*/
| IC_Unknown
......@@ -45,6 +46,8 @@ where
= compare_types types1 types2
(=<) (IC_GenericCase type1) (IC_GenericCase type2)
= type1 =< type2
(=<) (IC_GenericDeriveClass type1) (IC_GenericDeriveClass type2)
= type1 =< type2
(=<) (IC_Field typ_id1) (IC_Field typ_id2)
= typ_id1 =< typ_id2
(=<) (IC_TypeExtension module_name1) (IC_TypeExtension module_name2)
......
......@@ -1697,11 +1697,18 @@ wantDeriveDefinition :: !ParseContext !Position !*ParseState -> (!ParsedDefiniti
wantDeriveDefinition parseContext pos pState
| pState.ps_flags bitand PS_SupportGenericsMask==0
= (PD_Erroneous, parseErrorSimple "generic definition" "to enable generics use the command line flag -generics" pState)
# (name, pState) = want_name pState
| name == ""
= (PD_Erroneous, pState)
# (derive_defs, pState) = want_derive_types name pState
= (PD_Derive derive_defs, pState)
# (token, pState) = nextToken TypeContext pState
= case token of
IdentToken name
# (derive_defs, pState) = want_derive_types name pState
-> (PD_Derive derive_defs, pState)
ClassToken
# (class_name, pState) = want pState
# (class_ident, pState) = stringToIdent class_name IC_Class pState
# (derive_defs, pState) = want_derive_class_types class_ident pState
-> (PD_Derive derive_defs, pState)
_
-> (PD_Erroneous, parseError "Generic Definition" (Yes token) "<identifier>" pState)
where
want_name pState
# (token, pState) = nextToken TypeContext pState
......@@ -1711,19 +1718,21 @@ where
want_derive_types :: String !*ParseState -> ([GenericCaseDef], !*ParseState)
want_derive_types name pState
# (derive_def, pState) = want_derive_type name pState
# (token, pState) = nextToken TypeContext pState
# (derive_def, token, pState) = want_derive_type name pState
| token == CommaToken
# (derive_defs, pState) = want_derive_types name pState
= ([derive_def:derive_defs], pState)
# pState = wantEndOfDefinition "derive definition" (tokenBack pState)
= ([derive_def], pState)
want_derive_type :: String !*ParseState -> (GenericCaseDef, !*ParseState)
want_derive_type :: String !*ParseState -> (GenericCaseDef, !Token, !*ParseState)
want_derive_type name pState
# (type, pState) = wantType pState
// # (type, pState) = wantType pState
# (ok, {at_type=type}, pState) = trySimpleType TA_None pState
# (ident, pState) = stringToIdent name (IC_GenericCase type) pState
# (generic_ident, pState) = stringToIdent name IC_Generic pState
# (type_cons, pState) = get_type_cons type pState
# (token, pState) = nextToken GenericContext pState
# derive_def =
{ gc_pos = pos
, gc_type = type
......@@ -1731,7 +1740,25 @@ where
, gc_gcf = GCF ident {gcf_gident = generic_ident, gcf_generic = {gi_module=NoIndex,gi_index=NoIndex}, gcf_arity = 0,
gcf_body = GCB_None, gcf_kind = KindError}
}
= (derive_def, pState)
= (derive_def, token, pState)
want_derive_class_types :: Ident !*ParseState -> ([GenericCaseDef], !*ParseState)
want_derive_class_types class_ident pState
# (derive_def, pState) = want_derive_class_type class_ident pState
# (token, pState) = nextToken TypeContext pState
| token == CommaToken
# (derive_defs, pState) = want_derive_class_types class_ident pState
= ([derive_def:derive_defs], pState)
# pState = wantEndOfDefinition "derive definition" (tokenBack pState)
= ([derive_def], pState)
want_derive_class_type :: Ident !*ParseState -> (GenericCaseDef, !*ParseState)
want_derive_class_type class_ident pState
# (type, pState) = wantType pState
# (ident, pState) = stringToIdent class_ident.id_name (IC_GenericDeriveClass type) pState
# (type_cons, pState) = get_type_cons type pState
# derive_def = { gc_pos = pos, gc_type = type, gc_type_cons = type_cons, gc_gcf = GCFC ident class_ident}
= (derive_def, pState)
get_type_cons :: Type !*ParseState -> (TypeCons, !*ParseState)
get_type_cons (TA type_symb []) pState
......
......@@ -365,6 +365,8 @@ instance collectFunctions GenericCaseDef where
= ({gc & gc_gcf = GCF gc_ident {gcf & gcf_body=GCB_FunDef fun_def}}, ca)
collectFunctions gc=:{gc_gcf=GCF _ {gcf_body=GCB_None}} icl_module ca
= (gc, ca)
collectFunctions gc=:{gc_gcf=GCFC _ _} icl_module ca
= (gc, ca)
instance collectFunctions FunDef where
collectFunctions fun_def=:{fun_body = ParsedBody bodies} icl_module ca
......@@ -1194,7 +1196,7 @@ collectFunctionBodies fun_name fun_arity fun_prio fun_kind defs ca
collectGenericBodies :: ![ParsedDefinition] !Ident !Int !TypeCons !*CollectAdmin -> (![ParsedBody], ![ParsedDefinition],!*CollectAdmin)
collectGenericBodies all_defs=:[PD_GenericCase gc=:{gc_gcf=GCF gc_ident2 gcf} : defs] gc_ident1 gcf_arity1 gc_type_cons1 ca
| gc_ident2==gc_ident1 && gc.gc_type_cons == gc_type_cons1
| gc_ident2==gc_ident1 && gc.gc_type_cons==gc_type_cons1
#! (bodies, rest_defs, ca) = collectGenericBodies defs gc_ident1 gcf_arity1 gc_type_cons1 ca
# (GCF _ {gcf_body=GCB_ParsedBody args rhs,gcf_arity}) = gc.gc_gcf
#! body = {pb_args = args, pb_rhs = rhs, pb_position = gc.gc_pos}
......
......@@ -44,6 +44,7 @@ instance == FunctionOrMacroIndex
| STE_Member
| STE_Generic
| STE_GenericCase
| STE_GenericDeriveClass
| STE_Instance
| STE_Variable !VarInfoPtr
| STE_TypeVariable !TypeVarInfoPtr
......@@ -441,6 +442,8 @@ cNameLocationDependent :== True
:: GenericCaseFunctions
= GCF !Ident !GCF
| GCFS ![!GCF!]
| GCFC !Ident !Ident // IC_GenericDeriveClass IC_Class
:: GCF = {
gcf_gident :: !Ident, // name in IC_GenricCase namespace
......
Supports Markdown
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