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

add default instance members,

add function compare_members_of_exported_classes to compare
number of members of class definitions in definition and implementation module earlier,
stop checking after checkIclInstances if an error has occurred,
both to prevent compiler crashes for incorrect programs
parent c5b5b1a0
This diff is collapsed.
......@@ -121,6 +121,7 @@ local_declaration_for_import :: !u:Declaration .Index -> v:Declaration, [u <= v]
= BS_Constructors ![DefinedSymbol]
| BS_Fields !{#FieldSymbol}
| BS_Members !{#DefinedSymbol}
| BS_MembersAndMacros !{#DefinedSymbol} !{#MacroMember} !{#Int} !{!MacroMember}
| BS_Nothing
getBelongingSymbols :: !Declaration !v:{#DclModule} -> (!BelongingSymbols, !v:{#DclModule})
......
......@@ -144,9 +144,41 @@ getBelongingSymbols (Declaration {decl_kind=STE_Imported STE_Type def_mod_index,
_
-> (BS_Nothing, dcl_modules)
getBelongingSymbols (Declaration {decl_kind=STE_Imported STE_Class def_mod_index, decl_index}) dcl_modules
# ({class_members}, dcl_modules)
= dcl_modules![def_mod_index].dcl_common.com_class_defs.[decl_index]
= (BS_Members class_members, dcl_modules)
# ({class_members,class_macro_members},dcl_modules) = dcl_modules![def_mod_index].dcl_common.com_class_defs.[decl_index]
# (members,dcl_modules) = add_default_class_member_macros 0 dcl_modules
with
add_default_class_member_macros class_member_n dcl_modules
| class_member_n<size class_members
# member_index=class_members.[class_member_n].ds_index
({me_default_implementation},dcl_modules)
= dcl_modules![def_mod_index].dcl_common.com_member_defs.[member_index]
= case me_default_implementation of
No
-> add_default_class_member_macros (class_member_n+1) dcl_modules
Yes default_class_member_macro_ident_and_index
#! n_members = size class_members
# default_member_indexes = createArray n_members -1
default_member_indexes & [class_member_n] = 0
-> add_more_default_class_member_macros (class_member_n+1) [|default_class_member_macro_ident_and_index] 1 default_member_indexes dcl_modules
| size class_macro_members==0
= (BS_Members class_members,dcl_modules)
= (BS_MembersAndMacros class_members class_macro_members {} {},dcl_modules)
add_more_default_class_member_macros class_member_n default_class_members default_member_n default_member_indexes dcl_modules
| class_member_n<size class_members
# member_index=class_members.[class_member_n].ds_index
({me_default_implementation}, dcl_modules)
= dcl_modules![def_mod_index].dcl_common.com_member_defs.[member_index]
= case me_default_implementation of
No
-> add_more_default_class_member_macros (class_member_n+1) default_class_members default_member_n default_member_indexes dcl_modules
Yes default_class_member_macro_ident_and_index
# default_class_members = [|default_class_member_macro_ident_and_index:default_class_members]
default_member_indexes & [class_member_n] = default_member_n
-> add_more_default_class_member_macros (class_member_n+1) default_class_members (default_member_n+1) default_member_indexes dcl_modules
# default_class_members = {default_class_member\\default_class_member<-reverse default_class_members}
= (BS_MembersAndMacros class_members class_macro_members default_member_indexes default_class_members,dcl_modules)
= (members,dcl_modules)
getBelongingSymbols _ dcl_modules
= (BS_Nothing, dcl_modules)
......@@ -157,6 +189,8 @@ nrOfBelongingSymbols (BS_Fields fields)
= size fields
nrOfBelongingSymbols (BS_Members members)
= size members
nrOfBelongingSymbols (BS_MembersAndMacros members macro_members _ default_macros)
= size members+size macro_members+size default_macros
nrOfBelongingSymbols BS_Nothing
= 0
......
......@@ -2,6 +2,8 @@ definition module comparedefimp
import syntax, checksupport
compare_members_of_exported_classes :: !(Optional {#{#Int}}) !Int !Int !*(CommonDefsR b) !*{#DclModule} !*CheckState -> (!*(CommonDefsR b),!*{#DclModule},!*CheckState)
// compare definition and implementation module
compareDefImp :: !Int !DclModule !(Optional {#Index}) !CopiedDefinitions !Int !*IclModule !*{#*{#FunDef}} !*Heaps !*ErrorAdmin
......
......@@ -3,6 +3,55 @@ implementation module comparedefimp
from StdFunc import return
import syntax, checksupport, compare_constructor, utilities, compare_types
compare_members_of_exported_classes :: !(Optional {#{#Int}}) !Int !Int !*(CommonDefsR b) !*{#DclModule} !*CheckState -> (!*(CommonDefsR b),!*{#DclModule},!*CheckState)
compare_members_of_exported_classes (Yes conversion_table) n_specified_icl_classes n_specified_icl_members icl_common=:{com_class_defs} dcl_modules cs
| n_specified_icl_classes==0
= (icl_common,dcl_modules,cs)
#! main_dcl_module_n=cs.cs_x.x_main_dcl_module_n
# class_conversion_table = conversion_table.[cClassDefs]
member_conversion_table = conversion_table.[cMemberDefs]
({com_class_defs=dcl_class_defs},dcl_modules) = dcl_modules![main_dcl_module_n].dcl_common
(com_class_defs,cs) = check_members_of_exported_classes 0 class_conversion_table member_conversion_table n_specified_icl_classes n_specified_icl_members com_class_defs dcl_class_defs cs
= (icl_common,dcl_modules,cs)
where
check_members_of_exported_classes :: !Int !{#Int} !{#Int} !Int !Int !{#ClassDef} !{#ClassDef} !*CheckState -> (!{#ClassDef},!*CheckState)
check_members_of_exported_classes dcl_class_index class_conversion_table member_conversion_table n_specified_icl_classes n_specified_icl_members com_class_defs dcl_class_defs cs
| dcl_class_index<size class_conversion_table
# icl_class_index = class_conversion_table.[dcl_class_index]
| icl_class_index>=0 && icl_class_index<n_specified_icl_classes
# cs = check_members_of_exported_class icl_class_index dcl_class_index com_class_defs dcl_class_defs n_specified_icl_members member_conversion_table cs
= check_members_of_exported_classes (dcl_class_index+1) class_conversion_table member_conversion_table n_specified_icl_classes n_specified_icl_members com_class_defs dcl_class_defs cs
= check_members_of_exported_classes (dcl_class_index+1) class_conversion_table member_conversion_table n_specified_icl_classes n_specified_icl_members com_class_defs dcl_class_defs cs
= (com_class_defs,cs)
check_members_of_exported_class :: !Int !Int !{#ClassDef} !{#ClassDef} !Int !{#Int} !*CheckState -> *CheckState
check_members_of_exported_class icl_class_index dcl_class_index com_class_defs dcl_class_defs n_specified_icl_members member_conversion_table cs
# dcl_class = dcl_class_defs.[dcl_class_index]
# icl_class = com_class_defs.[icl_class_index]
| size icl_class.class_members<>size dcl_class.class_members
# cs_error = checkError "different number of members in class definitions in implementation and definition module" "" (setErrorAdmin (newPosition icl_class.class_ident icl_class.class_pos) cs.cs_error)
= {cs & cs_error=cs_error}
| size icl_class.class_macro_members<>size dcl_class.class_macro_members
# cs_error = checkError "different number of macro members in class definitions in implementation and definition module" "" (setErrorAdmin (newPosition icl_class.class_ident icl_class.class_pos) cs.cs_error)
= {cs & cs_error=cs_error}
= check_member_names_of_exported_class 0 icl_class.class_members dcl_class.class_members icl_class.class_pos n_specified_icl_members member_conversion_table cs
check_member_names_of_exported_class :: !Int !{#DefinedSymbol} !{#DefinedSymbol} Position !Int !{#Int} !*CheckState -> *CheckState
check_member_names_of_exported_class member_n icl_class_members dcl_class_members icl_class_pos n_specified_icl_members member_conversion_table cs
| member_n<size icl_class_members
# dcl_index = dcl_class_members.[member_n].ds_index
| dcl_index<0 || dcl_index>=size member_conversion_table
= check_member_names_of_exported_class (member_n+1) icl_class_members dcl_class_members icl_class_pos n_specified_icl_members member_conversion_table cs
# converted_dcl_index = member_conversion_table.[dcl_index];
| converted_dcl_index<0 || converted_dcl_index>=n_specified_icl_members
# dcl_ident = dcl_class_members.[member_n].ds_ident
# cs & cs_error = checkError "member of exported class missing in implementation module" "" (setErrorAdmin (newPosition dcl_ident icl_class_pos) cs.cs_error)
= check_member_names_of_exported_class (member_n+1) icl_class_members dcl_class_members icl_class_pos n_specified_icl_members member_conversion_table cs
= check_member_names_of_exported_class (member_n+1) icl_class_members dcl_class_members icl_class_pos n_specified_icl_members member_conversion_table cs
= cs
compare_members_of_exported_classes No n_specified_icl_classes n_specified_icl_members icl_common dcl_modules cs
= (icl_common,dcl_modules,cs)
:: CompareState =
{ comp_type_var_heap :: !.TypeVarHeap
, comp_attr_var_heap :: !.AttrVarHeap
......@@ -143,12 +192,20 @@ where
# comp_type_var_heap = initialyseTypeVars dcl_class_def.class_args icl_class_def.class_args comp_type_var_heap
comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap }
# (ok, comp_st) = compare dcl_class_def.class_context icl_class_def.class_context comp_st
| ok
# nr_of_dcl_members = size dcl_class_def.class_members
| nr_of_dcl_members == size icl_class_def.class_members
= compare_array_of_class_members nr_of_dcl_members dcl_class_def.class_members icl_class_def.class_members dcl_member_defs icl_member_defs comp_st
= (False, icl_member_defs, comp_st)
| not ok
= (False, icl_member_defs, comp_st)
# nr_of_dcl_members = size dcl_class_def.class_members
| nr_of_dcl_members <> size icl_class_def.class_members
= (False, icl_member_defs, comp_st)
# (ok, icl_member_defs, comp_st) = compare_array_of_class_members nr_of_dcl_members dcl_class_def.class_members icl_class_def.class_members dcl_member_defs icl_member_defs comp_st
| not ok
= (False, icl_member_defs, comp_st)
# n_dcl_class_macro_members = size dcl_class_def.class_macro_members
| n_dcl_class_macro_members <> size icl_class_def.class_macro_members
= (False, icl_member_defs, comp_st)
| sort_clas_macro_members dcl_class_def.class_macro_members <> sort_clas_macro_members icl_class_def.class_macro_members
= (False, icl_member_defs, comp_st)
= (True, icl_member_defs, comp_st)
compare_array_of_class_members loc_member_index dcl_members icl_members dcl_member_defs icl_member_defs comp_st
| loc_member_index == 0
......@@ -162,10 +219,18 @@ where
(icl_member_def, icl_member_defs) = icl_member_defs![glob_member_index]
(ok, comp_st) = compare dcl_member_def.me_type icl_member_def.me_type comp_st
| ok && dcl_member_def.me_priority == icl_member_def.me_priority
&& compare_default_implementations dcl_member_def.me_default_implementation icl_member_def.me_default_implementation
= compare_array_of_class_members loc_member_index dcl_members icl_members dcl_member_defs icl_member_defs comp_st
= (False, icl_member_defs, comp_st)
= (False, icl_member_defs, comp_st)
compare_default_implementations No No = True
compare_default_implementations (Yes _) (Yes _) = True
compare_default_implementations _ _ = False
sort_clas_macro_members class_macro_members
= sort [id_name \\ {mm_ident={id_name}}<-:class_macro_members]
compareInstanceDefs :: !{# Int} !{# ClassInstance} !u:{# ClassInstance} !*{#FunDef} !*CompareState
-> (!u:{# ClassInstance},!*{#FunDef},!*CompareState)
compareInstanceDefs dcl_sizes dcl_instance_defs icl_instance_defs icl_functions comp_st
......@@ -182,10 +247,10 @@ where
# comp_st = instance_def_conflicts_error icl_instance_def.ins_ident icl_instance_def.ins_pos comp_st
= (icl_instance_defs,icl_functions, comp_st)
# (icl_functions,comp_st)
= member_types_equal dcl_instance_def.ins_member_types icl_instance_def.ins_members 0 icl_functions comp_st
= member_types_equal dcl_instance_def.ins_member_types_and_functions icl_instance_def.ins_members 0 icl_functions comp_st
= (icl_instance_defs,icl_functions,comp_st)
member_types_equal :: [FunType] {#ClassInstanceMember} Int *{#FunDef} *CompareState -> (!*{#FunDef},!*CompareState)
member_types_equal :: [DclInstanceMemberTypeAndFunction] {#ClassInstanceMember} Int *{#FunDef} *CompareState -> (!*{#FunDef},!*CompareState)
member_types_equal [] icl_instance_members icl_member_n icl_functions comp_st
| icl_member_n<size icl_instance_members
# function_index = icl_instance_members.[icl_member_n].cim_index
......@@ -195,7 +260,7 @@ where
= member_types_equal [] icl_instance_members (icl_member_n+1) icl_functions comp_st
= member_types_equal [] icl_instance_members (icl_member_n+1) icl_functions comp_st
= (icl_functions,comp_st)
member_types_equal [instance_member_type:instance_member_types] icl_instance_members icl_member_n icl_functions comp_st
member_types_equal [{dim_type=instance_member_type,dim_function_index}:instance_member_types] icl_instance_members icl_member_n icl_functions comp_st
= member_type_and_types_equal instance_member_type instance_member_types icl_instance_members icl_member_n icl_functions comp_st
where
member_type_and_types_equal instance_member_type=:{ft_ident,ft_type,ft_pos} instance_member_types icl_instance_members icl_member_n icl_functions comp_st
......
......@@ -106,15 +106,17 @@ foldlBelongingSymbols f bs st
-> foldlArraySt (\{fs_ident} st -> f fs_ident st) fields st
BS_Members members
-> foldlArraySt (\{ds_ident} st -> f ds_ident st) members st
BS_MembersAndMacros members macro_members _ default_macros
# st = foldlArraySt (\{ds_ident} st -> f ds_ident st) members st
# st = foldlArraySt (\{mm_ident} st -> f mm_ident st) macro_members st
-> foldlArraySt (\{mm_ident} st -> f mm_ident st) default_macros st
BS_Nothing
-> st
/*
imp_decl_to_string (ID_Function {ii_ident={id_name}}) = "ID_Function "+++toString id_name
imp_decl_to_string (ID_Class {ii_ident={id_name}} _) = "ID_Class "+++toString id_name
imp_decl_to_string (ID_Type {ii_ident={id_name}} _) = "ID_Type "+++toString id_name
imp_decl_to_string (ID_Record {ii_ident={id_name}} _) = "ID_Record "+++toString id_name
imp_decl_to_string (ID_Instance {ii_ident={id_name}} _ _ ) = "ID_Instance "+++toString id_name
*/
FoldSt op l st :== fold_st l st
where
fold_st [|] st = st
fold_st [|a:x] st = fold_st x (op a st)
getBelongingSymbolsFromImportDeclaration :: !ImportDeclaration -> Optional [Ident]
getBelongingSymbolsFromImportDeclaration (ID_Class _ x) = x
......@@ -238,8 +240,8 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod
eimi (bitvectResetAll visited_modules)
| found
# eii_declaring_modules = foldSt (store_belonging belong_nr) path eii_declaring_modules
(belong_decl, dcl_modules) = get_nth_belonging_decl belong_nr belonging_declaration belonging_symbols position dcl_modules
= ([belong_decl:decls_accu], dcl_modules, eii_declaring_modules, visited_modules, cs_error)
(decls_accu, dcl_modules) = add_nth_belonging_decls position belong_nr belonging_declaration decls_accu dcl_modules
= (decls_accu, dcl_modules, eii_declaring_modules, visited_modules, cs_error)
| need_all
# (module_name,dcl_modules)=dcl_modules![imported_mod].dcl_name.id_name
cs_error = pushErrorAdmin (newPosition import_ident position) cs_error
......@@ -256,20 +258,52 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod
= abort "sanity check failed in module explicitimports"
= eii_declaring_modules
get_nth_belonging_decl :: Int Declaration BelongingSymbols Position v:{#DclModule} -> (!Declaration,!v:{#DclModule})
get_nth_belonging_decl belong_nr (Declaration {decl_kind=STE_Imported _ def_mod_index}) (BS_Constructors constructors) position dcl_modules
# {ds_ident, ds_index} = constructors!!belong_nr
decl_kind = STE_Imported STE_Constructor def_mod_index
= (Declaration {decl_ident=ds_ident, decl_pos=position, decl_kind=decl_kind, decl_index=ds_index}, dcl_modules)
get_nth_belonging_decl belong_nr (Declaration {decl_kind=STE_Imported _ def_mod_index}) (BS_Fields rt_fields) position dcl_modules
# {fs_ident, fs_index} = rt_fields.[belong_nr]
({sd_ident}, dcl_modules) = dcl_modules![def_mod_index].dcl_common.com_selector_defs.[fs_index]
decl_kind = STE_Imported (STE_Field sd_ident) def_mod_index
= (Declaration {decl_ident = fs_ident, decl_pos=position, decl_kind=decl_kind, decl_index=fs_index}, dcl_modules)
get_nth_belonging_decl belong_nr (Declaration {decl_kind=STE_Imported _ def_mod_index}) (BS_Members class_members) position dcl_modules
# {ds_ident, ds_index} = class_members.[belong_nr]
decl_kind = STE_Imported STE_Member def_mod_index
= (Declaration {decl_ident=ds_ident, decl_pos=position, decl_kind=decl_kind, decl_index=ds_index}, dcl_modules)
add_nth_belonging_decls position belong_nr decl=:(Declaration {decl_kind,decl_ident}) decls_accu dcl_modules
# (STE_Imported _ def_mod_index) = decl_kind
(belongin_symbols, dcl_modules) = getBelongingSymbols decl dcl_modules
= case belongin_symbols of
BS_Constructors constructors
# {ds_ident, ds_index} = constructors!!belong_nr
-> ([Declaration { decl_ident = ds_ident, decl_pos = position,
decl_kind = STE_Imported STE_Constructor def_mod_index,
decl_index = ds_index } : decls_accu], dcl_modules)
BS_Fields rt_fields
# {fs_ident, fs_index} = rt_fields.[belong_nr]
({sd_ident}, dcl_modules)
= dcl_modules![def_mod_index].dcl_common.com_selector_defs.[fs_index]
-> ([Declaration { decl_ident = fs_ident, decl_pos = position,
decl_kind = STE_Imported (STE_Field sd_ident) def_mod_index,
decl_index = fs_index } : decls_accu], dcl_modules)
BS_Members class_members
# {ds_ident, ds_index} = class_members.[belong_nr]
-> ([Declaration { decl_ident = ds_ident, decl_pos = position,
decl_kind = STE_Imported STE_Member def_mod_index,
decl_index = ds_index } : decls_accu], dcl_modules)
BS_MembersAndMacros class_members macro_members default_member_indexes default_macros
| belong_nr<size class_members
# {ds_ident, ds_index} = class_members.[belong_nr]
# decl = Declaration { decl_ident = ds_ident, decl_pos = position,
decl_kind = STE_Imported STE_Member def_mod_index,
decl_index = ds_index }
| belong_nr>=size default_member_indexes
-> ([decl : decls_accu], dcl_modules)
# default_macros_index = default_member_indexes.[belong_nr]
| default_macros_index<0
-> ([decl : decls_accu], dcl_modules)
#! {mm_ident,mm_index} = default_macros.[default_macros_index]
# macro_decl = Declaration { decl_ident = mm_ident, decl_pos = position,
decl_kind = STE_Imported (STE_DclMacroOrLocalMacroFunction []) def_mod_index,
decl_index = mm_index }
-> ([decl,macro_decl : decls_accu], dcl_modules)
| belong_nr<size class_members+size macro_members
# {mm_ident,mm_index} = macro_members.[belong_nr-size class_members]
-> ([Declaration { decl_ident = mm_ident, decl_pos = position,
decl_kind = STE_Imported (STE_DclMacroOrLocalMacroFunction []) def_mod_index,
decl_index = mm_index } : decls_accu], dcl_modules)
# {mm_ident,mm_index} = default_macros.[belong_nr-(size class_members+size macro_members)]
-> ([Declaration { decl_ident = mm_ident, decl_pos = position,
decl_kind = STE_Imported (STE_DclMacroOrLocalMacroFunction []) def_mod_index,
decl_index = mm_index } : decls_accu], dcl_modules)
get_all_belongs :: Declaration v:{#DclModule} -> (![Ident],!BelongingSymbols,!v:{#DclModule})
get_all_belongs decl=:(Declaration {decl_kind,decl_index}) dcl_modules
......@@ -281,6 +315,10 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod
-> ([fs_ident \\ {fs_ident}<-:rt_fields], belonging_symbols, dcl_modules)
BS_Members class_members
-> ([ds_ident \\ {ds_ident}<-:class_members], belonging_symbols, dcl_modules)
BS_MembersAndMacros class_members macro_members _ default_macros
-> ([ds_ident \\ {ds_ident}<-:class_members]
++[mm_ident\\{mm_ident}<-:macro_members]
++[mm_ident\\{mm_ident}<-:default_macros], belonging_symbols, dcl_modules)
BS_Nothing
-> ([], belonging_symbols, dcl_modules)
......@@ -771,6 +809,9 @@ instance check_completeness Let where
) ccs
instance check_completeness MemberDef where
check_completeness {me_type,me_default_implementation=Yes {mm_index},me_class} cci ccs
# (macro,ccs) = ccs!box_ccs.ccs_macro_defs.[me_class.glob_module,mm_index];
= check_completeness macro cci (check_completeness me_type cci ccs)
check_completeness {me_type} cci ccs
= check_completeness me_type cci ccs
......
......@@ -1723,7 +1723,8 @@ where
me_type_ptr = type_ptr, // empty
me_class_vars = [class_var], // the same variable as in the class
me_pos = gen_pos,
me_priority = NoPrio
me_priority = NoPrio,
me_default_implementation = No
}
= (member_def, gs)
......@@ -1745,6 +1746,7 @@ where
class_context = [],
class_pos = gen_pos,
class_members = createArray 1 class_member,
class_macro_members = {},
class_cons_vars = 0, // dotted class variables
class_dictionary = class_dictionary
}
......@@ -2156,7 +2158,7 @@ where
, ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1}
, ins_ident = class_ident
, ins_type = ins_type
, ins_member_types = []
, ins_member_types_and_functions = []
, ins_members = {{cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}}
, ins_specials = SP_None
, ins_pos = gc_pos
......@@ -2289,7 +2291,7 @@ where
, ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1}
, ins_ident = class_ident
, ins_type = ins_type
, ins_member_types = []
, ins_member_types_and_functions = []
, ins_members = {class_instance_member}
, ins_specials = SP_None
, ins_pos = gc_pos
......
......@@ -267,6 +267,7 @@ isIclContext parseContext :== parseContext bitand cICLContext <> 0 // not (isDcl
isNotClassOrInstanceDefsContext parseContext :== parseContext bitand ClassOrInstanceDefsContext == 0
isGlobalOrClassDefsContext parseContext :== parseContext bitand GlobalOrClassDefsContext <> 0
isInstanceDefsContext parseContext :== parseContext bitand InstanceDefsContext <> 0
isNotClassDefsContext parseContext :== parseContext bitand ClassDefsContext == 0
cWantIclFile :== True
cWantDclFile :== False
......@@ -562,7 +563,7 @@ where
= wantRhs localsExpected (ruleDefiningRhsSymbol parseContext has_args) pState
fun_kind = definingSymbolToFunKind defining_symbol
= case fun_kind of
FK_Function _ | isDclContext parseContext
FK_Function _ | isDclContext parseContext && isNotClassDefsContext parseContext
-> (PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState)
FK_Caf | isNotEmpty args
-> (PD_Function pos name is_infix [] rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState)
......@@ -1486,6 +1487,7 @@ wantClassDefinition parseContext pos pState
(members, pState) = wantDefinitions (SetClassDefsContext parseContext) pState
class_def = { class_ident = class_id, class_arity = class_arity, class_args = class_args,
class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars,
class_macro_members = {},
class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex}
}
pState = wantEndGroup "class" pState
......@@ -1497,6 +1499,7 @@ wantClassDefinition parseContext pos pState
(class_id, pState) = stringToIdent class_or_member_name IC_Class pState
class_def = { class_ident = class_id, class_arity = class_arity, class_args = class_args,
class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars,
class_macro_members = {},
class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }
}
pState = wantEndOfDefinition "class definition" pState
......@@ -1546,7 +1549,8 @@ wantClassDefinition parseContext pos pState
member = PD_TypeSpec pos member_id prio (Yes tspec) FSP_None
class_def = { class_ident = class_id, class_arity = class_arity, class_args = class_args,
class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars,
class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }
class_macro_members = {},
class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }
}
pState = wantEndOfDefinition "overloaded function" pState
= (PD_Class class_def [member], pState)
......@@ -1587,12 +1591,17 @@ wantInstanceDeclaration parseContext pi_pos pState
(pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState
# (token, pState) = nextToken TypeContext pState
| isIclContext parseContext
# pState = want_begin_group token pState
(pi_members, pState) = wantDefinitions (SetInstanceDefsContext parseContext) pState
pState = wantEndGroup "instance" pState
= (PD_Instance {pim_pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_specials = SP_None, pi_pos = pi_pos},
pim_members = pi_members}, pState)
# (begin_members, pState) = begin_member_group token pState
| not begin_members
# pState = wantEndOfDefinition "instance declaration" (tokenBack pState)
= (PD_Instance {pim_pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_specials = SP_None, pi_pos = pi_pos},
pim_members = []}, pState)
# (pi_members, pState) = wantDefinitions (SetInstanceDefsContext parseContext) pState
pState = wantEndGroup "instance" pState
= (PD_Instance {pim_pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_specials = SP_None, pi_pos = pi_pos},
pim_members = pi_members}, pState)
// otherwise // ~ (isIclContext parseContext)
| token == CommaToken
# (pi_types_and_contexts, pState) = want_instance_types pState
......@@ -1612,24 +1621,6 @@ wantInstanceDeclaration parseContext pi_pos pState
pi_context = pi_context, pi_specials = specials, pi_pos = pi_pos}
= want_optional_member_types pim_pi pState
want_begin_group token pState // For JvG layout
# // (token, pState) = nextToken TypeContext pState PK
(token, pState)
= case token of
SemicolonToken -> nextToken TypeContext pState
_ -> (token, pState)
= case token of
WhereToken -> wantBeginGroup "instance declaration" pState
CurlyOpenToken
# (ss_useLayout, pState) = accScanState UseLayout pState
| ss_useLayout
-> parseError "instance declaration" (Yes token) "where" pState
-> pState
_ # (ss_useLayout, pState) = accScanState UseLayout pState
| ss_useLayout
-> parseError "instance declaration" (Yes token) "where" pState
-> parseError "instance declaration" (Yes token) "where or {" pState
want_optional_member_types pim_pi pState
# (token, pState) = nextToken TypeContext pState
# (begin_members, pState) = begin_member_group token pState
......
......@@ -1499,49 +1499,101 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = MoreConses type_ex
reorganiseDefinitions icl_module [PD_Class class_def=:{class_ident,class_arity,class_args} members : defs] def_counts=:{mem_count,macro_count} ca
# type_context = { tc_class = TCClass {glob_module = NoIndex, glob_object = {ds_ident = class_ident, ds_arity = class_arity, ds_index = NoIndex }},
tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr}
(mem_defs, mem_macros, ca) = check_symbols_of_class_members members type_context ca
(mem_defs,mem_macros,default_members_without_type,macro_members,macro_count,ca)
= check_symbols_of_class_members members type_context macro_count ca
(mem_defs,ca) = add_default_members_without_type default_members_without_type mem_defs ca
(mem_symbs, mem_defs, class_size) = reorganise_member_defs mem_defs mem_count
def_counts & mem_count=mem_count + class_size, macro_count=macro_count + length mem_macros
def_counts & mem_count=mem_count + class_size, macro_count=macro_count
(fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca
class_def = { class_def & class_members = { member \\ member <- mem_symbs }}
class_def = { class_def & class_members = { member \\ member <- mem_symbs}
, class_macro_members = {macro_member \\ macro_member<|-macro_members}
}
c_defs = { c_defs & def_classes = [class_def : c_defs.def_classes], def_macros = mem_macros ++ c_defs.def_macros,
def_members = mem_defs ++ c_defs.def_members }
= (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca)
where
check_symbols_of_class_members :: ![ParsedDefinition] !TypeContext !*CollectAdmin -> (![MemberDef], ![FunDef], !*CollectAdmin)
check_symbols_of_class_members [PD_TypeSpec pos name prio opt_type=:(Yes type=:{st_context,st_arity}) specials : defs] type_context ca
check_symbols_of_class_members :: ![ParsedDefinition] !TypeContext !Int !*CollectAdmin
-> (![MemberDef],![FunDef],![(Ident,MacroMember,Position)],[!MacroMember!],!Int,!*CollectAdmin)
check_symbols_of_class_members [PD_TypeSpec pos name prio opt_type=:(Yes type=:{st_context,st_arity}) specials : defs] type_context macro_count ca
# (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca
| isEmpty bodies
# mem_def = { me_ident = name, me_type = { type & st_context = [type_context : st_context ]}, me_pos = pos, me_priority = prio,
me_default_implementation = No,
me_offset = NoIndex, me_class_vars = [], me_class = { glob_module = NoIndex, glob_object = NoIndex}, me_type_ptr = nilPtr }
( mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca
= ([mem_def : mem_defs], mem_macros, ca)
(mem_defs,mem_macros,default_members_without_type,macro_members,new_macro_count,ca)
= check_symbols_of_class_members defs type_context macro_count ca
= ([mem_def : mem_defs],mem_macros,default_members_without_type,macro_members,new_macro_count,ca)
= case fun_kind of
FK_Macro
# macro = MakeNewImpOrDefFunction name st_arity bodies FK_Macro prio opt_type pos
(mem_defs, mem_macros,ca) = check_symbols_of_class_members defs type_context ca
= (mem_defs, [macro : mem_macros], ca)
check_symbols_of_class_members [PD_TypeSpec fun_pos fun_name prio No specials : defs] type_context ca
(mem_defs,mem_macros,default_members_without_type,macro_members,new_macro_count,ca)
= check_symbols_of_class_members defs type_context (macro_count+1) ca
macro_member = {mm_ident=name,mm_index=macro_count}
= (mem_defs,[macro : mem_macros],default_members_without_type,[|macro_member : macro_members],new_macro_count,ca)
FK_Function _
# macro_name = class_ident.id_name+++"_"+++name.id_name
# ({boxed_ident=macro_ident}, ca_hash_table) = putIdentInHashTable macro_name IC_Expression ca.ca_hash_table
# ca = { ca & ca_hash_table = ca_hash_table }
# macro = MakeNewImpOrDefFunction macro_ident st_arity bodies FK_Macro prio opt_type pos
# mem_def = { me_ident = name, me_type = { type & st_context = [type_context : st_context ]}, me_pos = pos, me_priority = prio,
me_offset = NoIndex, me_class_vars = [], me_class = { glob_module = NoIndex, glob_object = NoIndex},
me_default_implementation = Yes {mm_ident=macro_ident,mm_index=macro_count}, me_type_ptr = nilPtr }
(mem_defs,mem_macros,default_members_without_type,macro_members,macro_count,ca)
= check_symbols_of_class_members defs type_context (macro_count+1) ca
= ([mem_def : mem_defs],[macro : mem_macros],default_members_without_type,macro_members,macro_count,ca)
check_symbols_of_class_members [PD_TypeSpec fun_pos fun_name prio No specials : defs] type_context macro_count ca
= case defs of
[PD_Function pos name is_infix args rhs fun_kind : defs]
| belongsToTypeSpec fun_name prio name is_infix
# fun_arity = length args
(bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
(mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca
(mem_defs,mem_macros,default_members_without_type,macro_members,new_macro_count,ca)
= check_symbols_of_class_members defs type_context macro_count ca
macro = MakeNewImpOrDefFunction name fun_arity bodies FK_Macro prio No fun_pos
-> (mem_defs, [macro : mem_macros], ca)
-> check_symbols_of_class_members defs type_context (postParseError fun_pos "macro body expected" ca)
-> (mem_defs,[macro : mem_macros],default_members_without_type,macro_members,new_macro_count,ca)
-> check_symbols_of_class_members defs type_context macro_count (postParseError fun_pos "macro body expected" ca)
_
-> check_symbols_of_class_members defs type_context (postParseError fun_pos "macro body expected" ca)
check_symbols_of_class_members [PD_Function fun_pos name is_infix args rhs fun_kind : defs] type_context ca
-> check_symbols_of_class_members defs type_context macro_count (postParseError fun_pos "macro body expected" ca)
check_symbols_of_class_members [PD_Function fun_pos name is_infix args rhs fun_kind : defs] type_context macro_count ca
# prio = if is_infix (Prio NoAssoc 9) NoPrio
fun_arity = length args
(bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
(mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca
macro = MakeNewImpOrDefFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = fun_pos } : bodies] FK_Macro prio No fun_pos
= (mem_defs, [macro : mem_macros], ca)
check_symbols_of_class_members [def : _] type_context ca
bodies = [{ pb_args = args, pb_rhs = rhs, pb_position = fun_pos } : bodies]
(mem_defs,mem_macros,default_members_without_type,macro_members,new_macro_count,ca)
= check_symbols_of_class_members defs type_context (macro_count+1) ca
= case fun_kind of
FK_Macro
# macro = MakeNewImpOrDefFunction name fun_arity bodies FK_Macro prio No fun_pos
macro_member = {mm_ident=name,mm_index=macro_count}
-> (mem_defs,[macro : mem_macros],default_members_without_type,[|macro_member : macro_members],new_macro_count,ca)