Commit cddebdcc authored by John van Groningen's avatar John van Groningen

feature, add optional list of ignored generic functions to derive class, e.g....

feature, add optional list of ignored generic functions to derive class, e.g. derive class C \ gEq,gPrint T
parent 3e4911d4
......@@ -683,7 +683,7 @@ where
# error = errorHeading "Error" error
format = {form_properties = cNoProperties, form_attr_position = No}
error & ea_file = error.ea_file
<<< "Specialized type contains incorrect type (" <:: (format, [type:[at_type\\{at_type}<-a_types]], No) <<< ")\n"
<<< " Specialized type contains incorrect type (" <:: (format, [type:[at_type\\{at_type}<-a_types]], No) <<< ")\n"
= report_erroneous_types erroneous_types error
report_erroneous_types [] error
= error
......@@ -1244,6 +1244,8 @@ where
= (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])
gen_case_def_to_dcl {gc_gcf=GCFCExcept 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 (ClassInstanceR member_types_and_functions)) -> *CommonDefsR member_types_and_functions
createCommonDefinitions {def_types,def_constructors,def_selectors,def_classes,def_members,def_instances, def_generics,def_generic_cases}
......@@ -2398,6 +2400,9 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
({gc_gcf=GCFS dcl_gcfs},{gc_gcf=GCFC _ _})
// error already reported in checkGenericCaseDefs
-> (new_table, icl_gencases, error)
({gc_gcf=GCFS dcl_gcfs},{gc_gcf=GCFCExcept _ _ _})
// error already reported in checkGenericCaseDefs
-> (new_table, icl_gencases, error)
where
compare_icl_and_dcl_generic_info :: Int Int GenericInstanceDependencies GenericInstanceDependencies GenericCaseDef GenericCaseDef Int
*{#GenericCaseDef} *ErrorAdmin -> (!*{#GenericCaseDef},!*ErrorAdmin)
......@@ -2684,12 +2689,6 @@ check_module1 cdefs icl_global_function_range fun_defs optional_dcl_mod optional
convert_icl_class_instances1 insams
= [ParsedInstanceToClassInstance sim_pi sim_members {} \\ {sim_pi,sim_members}<-insams]
determine_indexes_of_members [{fun_ident,fun_arity}:members] next_fun_index
#! (member_symbols, last_fun_index) = determine_indexes_of_members members (inc next_fun_index)
= ([{cim_ident = fun_ident, cim_index = next_fun_index, cim_arity = fun_arity} : member_symbols], last_fun_index)
determine_indexes_of_members [] next_fun_index
= ([], next_fun_index)
make_macro_def_array :: *{#*{#FunDef}} *[*{#FunDef}] -> *{#*{#FunDef}}
make_macro_def_array cached_dcl_macros macro_defs
#! size_cached_dcl_macros=size cached_dcl_macros
......
implementation module checkgenerics
import StdOverloadedList
import syntax,checksupport,checktypes,genericsupport,explicitimports,compare_types,typesupport
checkGenericDefs :: !Index !(Optional (CopiedDefinitions, Int))
......@@ -203,6 +204,12 @@ where
check_generic_dep_error ident msg cs = {cs & cs_error = checkError ident msg cs.cs_error}
report_missing_except_class_names [!!] gcfc_class_ident gc_pos error
= error
report_missing_except_class_names [!missing_except_class_name:missing_except_class_names!] gcfc_class_ident gc_pos error
# error = checkErrorWithPosition gcfc_class_ident gc_pos ("no "+++missing_except_class_name+++" in context") error
= report_missing_except_class_names missing_except_class_names gcfc_class_ident gc_pos error
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
......@@ -225,7 +232,7 @@ where
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
= 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
......@@ -254,30 +261,74 @@ where
# 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}
# 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,cs) = check_generic_superclasses_case_defs class_context index mod_index gc_type gc_type_cons gen_case_defs 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,cs) = check_generic_superclasses_case_defs class_context index mod_index gc_type gc_type_cons gen_case_defs 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}
# cs = add_class_undefined_error gcfc_class_ident gc_pos cs
-> (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
check_generic_superclasses_case_defs 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}
case_def & gc_gcf=GCFS gcfs, gc_type=gc_type, gc_type_cons=gc_type_cons
gen_case_defs & [index]=case_def
cs = popErrorAdmin cs
= (gen_case_defs,cs)
GCFCExcept _ gcfc_class_ident=:{id_info} except_class_names
# 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_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_case_defs_except class_context except_class_names index mod_index gc_type gc_type_cons gen_case_defs 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_case_defs_except class_context except_class_names index mod_index gc_type gc_type_cons gen_case_defs cs
-> (gen_case_defs,generic_defs,type_defs,class_defs, modules,heaps,cs)
_
# cs = add_class_undefined_error gcfc_class_ident gc_pos cs
-> (gen_case_defs,generic_defs,type_defs,class_defs, modules,heaps,cs)
where
check_generic_superclasses_case_defs_except class_context except_class_names index mod_index gc_type gc_type_cons gen_case_defs cs
# gcfs = convert_generic_contexts class_context
(gcfs,missing_except_class_names,cs) = check_generic_superclasses_except gcfs except_class_names except_class_names mod_index cs
cs & cs_error = report_missing_except_class_names missing_except_class_names gcfc_class_ident gc_pos cs.cs_error
case_def & gc_gcf=GCFS gcfs, gc_type=gc_type, gc_type_cons=gc_type_cons
gen_case_defs & [index]=case_def
cs = popErrorAdmin cs
= (gen_case_defs,cs)
check_generic_superclasses_except [!gcf=:{gcf_gident}:gcfs!] missing_except_class_names except_class_names mod_index cs
| IsMemberM gcf_gident.id_name except_class_names
# missing_except_class_names = RemoveMemberM gcf_gident.id_name missing_except_class_names
= check_generic_superclasses_except gcfs missing_except_class_names except_class_names mod_index cs
# (generic_gi,cs) = get_generic_index gcf_gident mod_index cs
| not cs.cs_error.ea_ok
# (gcfs,missing_except_class_names,cs)
= check_generic_superclasses_except gcfs missing_except_class_names except_class_names mod_index cs
= ([!gcf:gcfs!],missing_except_class_names,cs)
# gcf & gcf_generic = generic_gi
# (gcfs,missing_except_class_names,cs)
= check_generic_superclasses_except gcfs missing_except_class_names except_class_names mod_index cs
= ([!gcf:gcfs!],missing_except_class_names,cs)
check_generic_superclasses_except [!!] missing_except_class_names except_class_names mod_index cs
= ([!!],missing_except_class_names,cs)
convert_generic_contexts [{tc_class=TCGeneric {gtc_generic={glob_object={ds_ident}}}}:type_contexts]
# gcf = {
gcf_gident = ds_ident,
......@@ -305,6 +356,10 @@ where
check_generic_superclasses [!!] mod_index cs
= ([!!],cs)
add_class_undefined_error gcfc_class_ident gc_pos cs
# cs = popErrorAdmin cs
= {cs & cs_error = checkErrorWithPosition gcfc_class_ident gc_pos "class undefined" cs.cs_error}
check_instance_type module_index (TA type_cons []) type_defs modules heaps cs
# (entry, cs_symbol_table) = readPtr type_cons.type_ident.id_info cs.cs_symbol_table
# cs = {cs & cs_symbol_table = cs_symbol_table}
......@@ -447,8 +502,30 @@ convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_tabl
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}
gc & gc_gcf=GCFS gcfs
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)
gc=:{gc_gcf=GCFCExcept _ gcfc_class_ident=:{id_info} except_class_names,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_except class_context except_class_names 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_except class_context except_class_names 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_except class_context except_class_names gci next_fun_index gencase_defs class_defs symbol_table error dcl_modules
# (gcfs,missing_except_class_names,next_fun_index,new_fun_defs)
= convert_generic_contexts_except class_context except_class_names except_class_names gc_type_cons gc_pos next_fun_index []
gc & gc_gcf=GCFS gcfs
gencase_defs & [gci]=gc
error = report_missing_except_class_names missing_except_class_names gcfc_class_ident gc_pos error
(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)
......@@ -477,6 +554,33 @@ convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_tabl
convert_generic_contexts [] type_cons pos next_fun_index new_fun_defs
= ([!!],next_fun_index,new_fun_defs)
convert_generic_contexts_except [{tc_class=TCGeneric _ {gtc_generic={glob_object={ds_ident}}}}:type_contexts] missing_except_class_names except_class_names type_cons pos next_fun_index new_fun_defs
| IsMemberM ds_ident.id_name except_class_names
# missing_except_class_names = RemoveMemberM ds_ident.id_name missing_except_class_names
= convert_generic_contexts_except type_contexts missing_except_class_names except_class_names 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_generic_info = 0,
gcf_body = GCB_FunIndex next_fun_index,
gcf_kind = KindError,
gcf_generic_instance_deps = AllGenericInstanceDependencies }
# (gcfs,missing_except_class_names,next_fun_index,new_fun_defs)
= convert_generic_contexts_except type_contexts missing_except_class_names except_class_names type_cons pos (next_fun_index+1) new_fun_defs
= ([!gcf:gcfs!],missing_except_class_names,next_fun_index,[fun_def:new_fun_defs])
convert_generic_contexts_except [_:type_contexts] missing_except_class_names except_class_names type_cons pos next_fun_index new_fun_defs
= convert_generic_contexts_except type_contexts missing_except_class_names except_class_names type_cons pos next_fun_index new_fun_defs
convert_generic_contexts_except [] missing_except_class_names except_class_names type_cons pos next_fun_index new_fun_defs
= ([!!],missing_except_class_names,next_fun_index,new_fun_defs)
create_gencase_funtypes :: !Index !*{#GenericCaseDef} !*Heaps
-> (!Index,![FunType],!*{#GenericCaseDef},!*Heaps)
create_gencase_funtypes fun_index gencase_defs heaps
......
......@@ -26,6 +26,7 @@ set_hte_mark :: !Int !*HashTable -> *HashTable
| IC_Generic
| IC_GenericCase !Type
| IC_GenericDeriveClass !Type
| IC_GenericDeriveClassExcept !Type ![!{#Char}!]
| IC_TypeExtension !{#Char}/*module name*/
| IC_Unknown
......
implementation module hashtable
import StdOverloadedList
import predef, syntax, compare_types, compare_constructor
:: HashTableEntry
......@@ -24,6 +25,7 @@ import predef, syntax, compare_types, compare_constructor
| IC_Generic
| IC_GenericCase !Type
| IC_GenericDeriveClass !Type
| IC_GenericDeriveClassExcept !Type ![!{#Char}!]
| IC_TypeExtension !{#Char}/*module name*/
| IC_Unknown
......@@ -40,6 +42,11 @@ set_hte_mark hte_mark ht = {ht & hte_mark=hte_mark}
instance =< IdentClass
where
(=<) ic1 ic2
| not (equal_constructor ic1 ic2)
| less_constructor ic1 ic2
= Smaller
= Greater
(=<) (IC_Instance types1) (IC_Instance types2)
= compareInstances types1 types2
(=<) (IC_InstanceMember types1) (IC_InstanceMember types2)
......@@ -49,21 +56,29 @@ where
| cmp == Equal
= compare_unboxed_array_element_type type1 type2
= cmp
(=<) (IC_Field typ_id1) (IC_Field typ_id2)
= typ_id1 =< typ_id2
(=<) (IC_GenericDeriveClass type1) (IC_GenericDeriveClass type2)
# cmp = type1 =< type2
| cmp == Equal
= compare_unboxed_array_element_type type1 type2
= cmp
(=<) (IC_Field typ_id1) (IC_Field typ_id2)
= typ_id1 =< typ_id2
(=<) (IC_GenericDeriveClassExcept type1 except_class_names1) (IC_GenericDeriveClassExcept type2 except_class_names2)
# cmp = type1 =< type2
| cmp == Equal
# cmp = compare_unboxed_array_element_type type1 type2
| cmp == Equal
| except_class_names1==except_class_names2
= Equal
| except_class_names1<except_class_names2
= Smaller
= Greater
= cmp
= cmp
(=<) (IC_TypeExtension module_name1) (IC_TypeExtension module_name2)
= module_name1=<module_name2
(=<) ic1 ic2
| equal_constructor ic1 ic2
= Equal
| less_constructor ic1 ic2
= Smaller
= Greater
= Equal
compare_types [t1 : t1s] [t2 : t2s]
# cmp = t1 =< t2
......
......@@ -197,20 +197,45 @@ wantSepList msg sep_token scanContext try_fun pState :== want_list msg pState //
# (token, pState) = nextToken GeneralContext pState
= ([tree], parseError ("wantList of "+msg) (Yes token) msg pState)
wantSepSList msg sep_token scanContext try_fun pState :== want_slist msg pState
where
want_slist msg pState
# (succ, tree, pState) = try_fun pState
| succ
# (token, pState) = nextToken scanContext pState
| token == sep_token
# (trees, pState) = optSepSList sep_token scanContext try_fun pState
= ([!tree : trees!], pState)
= ([!tree!], tokenBack pState)
# (token, pState) = nextToken GeneralContext pState
= ([!tree!], parseError ("wantList of "+msg) (Yes token) msg pState)
//optSepList sep_token scanContext try_fun pState = want_list msg pState
optSepList sep_token scanContext try_fun pState :== want_list pState // [ try_fun (sep_token tryfun)* ]
where
want_list pState
# (succ, tree, pState) = try_fun pState
| succ
# (token, pState) = nextToken scanContext pState
| token == sep_token
# (token, pState) = nextToken scanContext pState
| token == sep_token
# (trees, pState) = want_list pState
= ([tree : trees], pState)
// otherwise // token <> sep_token
= ([tree], tokenBack pState)
= ([], pState)
optSepSList sep_token scanContext try_fun pState :== want_slist pState
where
want_slist pState
# (succ, tree, pState) = try_fun pState
| succ
# (token, pState) = nextToken scanContext pState
| token == sep_token
# (trees, pState) = want_slist pState
= ([!tree : trees!], pState)
= ([!tree!], tokenBack pState)
= ([!!], pState)
//wantList msg try_fun pState = want_list msg pState
wantList msg try_fun pState :== want_list msg pState // try_fun +
where
......@@ -2063,6 +2088,12 @@ wantDeriveDefinition parseContext pos pState
ClassToken
# (class_name, pState) = want pState
# (class_ident, pState) = stringToIdent class_name IC_Class pState
# (token, pState) = nextToken TypeContext pState
| token=:BackSlashToken
# (except_class_names, pState) = wantSepSList "generic classes" CommaToken TypeContext try_generic_function_name pState
# (derive_defs, pState) = want_derive_class_except_types class_ident except_class_names pState
-> (PD_Derive derive_defs, pState)
# pState = tokenBack pState
# (derive_defs, pState) = want_derive_class_types class_ident pState
-> (PD_Derive derive_defs, pState)
_
......@@ -2074,6 +2105,14 @@ where
IdentToken name -> (name, pState)
_ -> ("", parseError "Generic Definition" (Yes token) "<identifier>" pState)
try_generic_function_name pState
# (token, pState) = nextToken TypeContext pState
= case token of
IdentToken name
-> (True,name, pState)
_
-> (False, "", parseError "generic function name" (Yes token) "<identifier>" pState)
want_derive_types :: String !*ParseState -> ([GenericCaseDef], !*ParseState)
want_derive_types name pState
# (derive_def, token, pState) = want_derive_type name pState
......@@ -2147,15 +2186,34 @@ where
= ([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)
where
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)
want_derive_class_except_types :: Ident [!{#Char}!] !*ParseState -> ([GenericCaseDef], !*ParseState)
want_derive_class_except_types class_ident except_class_names pState
# (derive_def, pState) = want_derive_class_except_type class_ident except_class_names pState
# (token, pState) = nextToken TypeContext pState
| token =: CommaToken
# (derive_defs, pState) = want_derive_class_except_types class_ident except_class_names pState
= ([derive_def:derive_defs], pState)
# pState = wantEndOfDefinition "derive definition" (tokenBack pState)
= ([derive_def], pState)
where
want_derive_class_except_type :: Ident [!{#Char}!] !*ParseState -> (GenericCaseDef, !*ParseState)
want_derive_class_except_type class_ident except_class_names pState
# (type, pState) = wantType pState
# (ident, pState) = stringToIdent class_ident.id_name (IC_GenericDeriveClassExcept type except_class_names) pState
# (type_cons, pState) = get_type_cons type pState
# derive_def = { gc_pos = pos, gc_type = type, gc_type_cons = type_cons,
gc_gcf = GCFCExcept ident class_ident except_class_names}
= (derive_def, pState)
parse_info_fields "OBJECT" token pState
= parse_OBJECT_info_fields token 0 pState
......@@ -3492,23 +3550,6 @@ optionalExistentialQuantifiedVariables pState
-> (vars, wantToken TypeContext "Existential Quantified Variables" ColonToken pState)
_ -> ([], tokenBack pState)
/* Sjaak 041001
where
try_existential_type_var :: !ParseState -> (Bool,ATypeVar,ParseState)
try_existential_type_var pState
# (token, pState) = nextToken TypeContext pState
= case token of
DotToken
# (typevar, pState) = wantTypeVar pState
-> (True, {atv_attribute = TA_Anonymous, atv_annotation = AN_None, atv_variable = typevar}, pState)
_
# (succ, typevar, pState) = tryTypeVarT token pState
| succ
# atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar}
-> (True,atypevar,pState)
-> (False,abort "no ATypeVar",pState)
*/
optionalUniversalQuantifiedVariables :: !*ParseState -> *(![ATypeVar],!*ParseState)
optionalUniversalQuantifiedVariables pState
# (token, pState) = nextToken TypeContext pState
......
......@@ -377,6 +377,8 @@ instance collectFunctions GenericCaseDef where
= (gc, ca)
collectFunctions gc=:{gc_gcf=GCFC _ _} icl_module ca
= (gc, ca)
collectFunctions gc=:{gc_gcf=GCFCExcept _ _ _} icl_module ca
= (gc, ca)
instance collectFunctions FunDef where
collectFunctions fun_def=:{fun_body = ParsedBody bodies} icl_module ca
......
......@@ -493,6 +493,7 @@ instance == GenericDependency
= GCF !Ident !GCF
| GCFS ![!GCF!]
| GCFC !Ident !Ident // IC_GenericDeriveClass IC_Class
| GCFCExcept !Ident !Ident ![!{#Char}!] // IC_GenericDeriveClassExcept !Type ![!{#Char}!]
:: GCF = {
gcf_gident :: !Ident, // name in IC_Generic namespace
......
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