Commit 4aa1883e authored by John van Groningen's avatar John van Groningen

add deriving a local function in the top level where of an instance member definition using derive

parent 5b8c6c29
......@@ -25,7 +25,7 @@ where
(class_args, class_context, type_defs, class_defs, modules, type_heaps, cs)
= checkSuperClasses class_args class_context module_index type_defs class_defs modules type_heaps cs
class_defs = { class_defs & [class_index] = { class_def & class_context = class_context, class_args = class_args }}
member_defs = set_classes_in_member_defs 0 class_members {glob_object = class_index, glob_module = module_index} member_defs
member_defs = set_classes_in_member_defs 0 class_members {glob_object = class_index, glob_module = module_index} member_defs
= (class_defs, member_defs, type_defs, modules, type_heaps, cs)
= (class_defs, member_defs, type_defs, modules, type_heaps, cs)
......@@ -38,8 +38,8 @@ where
| mem_offset == size class_members
= member_defs
# {ds_index} = class_members.[mem_offset]
# (member_def, member_defs) = member_defs![ds_index]
= set_classes_in_member_defs (inc mem_offset) class_members glob_class_index { member_defs & [ds_index] = { member_def & me_class = glob_class_index }}
# member_defs & [ds_index].me_class = glob_class_index
= set_classes_in_member_defs (inc mem_offset) class_members glob_class_index member_defs
checkSpecial :: !Index !FunType !Index !SpecialSubstitution !(!Index, ![FunType], !*Heaps,!*PredefinedSymbols,!*ErrorAdmin)
-> (!Special, !(!Index, ![FunType], !*Heaps,!*PredefinedSymbols, !*ErrorAdmin))
......@@ -122,7 +122,7 @@ where
= check_function_types fun_types module_index type_defs class_defs modules heaps cs
= ([fun_type:fun_types], type_defs, class_defs, modules, heaps, cs)
check_function_types NoDclInstanceMemberTypes module_index type_defs class_defs modules heaps cs
= ( [], type_defs, class_defs, modules, heaps, cs)
= ([], type_defs, class_defs, modules, heaps, cs)
checkSpecialsOfInstances :: !Index !Index ![ClassInstance] !Index ![ClassInstance] ![FunType] {# FunType} *{! [Special] } !*Heaps !*PredefinedSymbols !*ErrorAdmin
-> (!Index, ![ClassInstance], ![FunType], !*{! [Special]}, !*Heaps, !*PredefinedSymbols,!*ErrorAdmin)
......@@ -281,6 +281,51 @@ where
# cs = {cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ci_arity) cs.cs_error}
= (ins, is, type_heaps, cs)
check_derived_local_functions_in_member :: !Int !Int !Int !DclInstanceMemberTypeAndFunctions !*{#FunDef} !*CheckState
-> (!DclInstanceMemberTypeAndFunctions,!*{#FunDef},!*CheckState)
check_derived_local_functions_in_member member_function_index class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
# ({fun_body},icl_functions) = icl_functions![member_function_index]
= case fun_body of
ParsedBody parsed_bodies
-> check_derived_local_functions_in_pbs parsed_bodies class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
_
-> (ins_member_types_and_functions,icl_functions,cs)
where
check_derived_local_functions_in_pbs :: ![ParsedBody] !Int !Int !DclInstanceMemberTypeAndFunctions !*{#FunDef} !*CheckState
-> (!DclInstanceMemberTypeAndFunctions,!*{#FunDef},!*CheckState)
check_derived_local_functions_in_pbs [{pb_rhs={rhs_locals=NoCollectedLocalDefs}}:pbs] class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
= check_derived_local_functions_in_pbs pbs class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
check_derived_local_functions_in_pbs [{pb_rhs={rhs_locals=CollectedLocalDefs {loc_functions={ir_from,ir_to}}}}:pbs] class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
| ir_from==ir_to
= check_derived_local_functions_in_pbs pbs class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
# (ins_member_types_and_functions,icl_functions,cs) = check_derived_local_functions ir_from ir_to class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
= check_derived_local_functions_in_pbs pbs class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
check_derived_local_functions_in_pbs [_:pbs] class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
= check_derived_local_functions_in_pbs pbs class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
check_derived_local_functions_in_pbs [] class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
= (ins_member_types_and_functions,icl_functions,cs)
check_derived_local_functions :: !Int !Int !Int !Int !DclInstanceMemberTypeAndFunctions !*{#FunDef} !*CheckState
-> (!DclInstanceMemberTypeAndFunctions,!*{#FunDef},!*CheckState)
check_derived_local_functions fun_i fun_end class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
| fun_i<fun_end
| icl_functions.[fun_i].fun_body=:GenerateInstanceBody _ _
# ({fun_body=GenerateInstanceBody generic_ident optional_member_ident},icl_functions) = icl_functions![fun_i]
#! x_main_dcl_module_n = cs.cs_x.x_main_dcl_module_n
# (generic_index,cs) = get_generic_index generic_ident x_main_dcl_module_n cs
optional_member_ident_global_index
= case optional_member_ident of
No -> No
Yes member_ident -> Yes {igi_ident=member_ident,igi_g_index={gi_module=0,gi_index=0}}
fun_body = GenerateInstanceBodyChecked generic_ident generic_index optional_member_ident_global_index
ins_member_types_and_functions = GenerateInstanceMember class_member_n fun_i ins_member_types_and_functions
(fun,icl_functions) = icl_functions![fun_i];
fun & fun_body = fun_body, fun_arity = class_member_arity, fun_priority = NoPrio
icl_functions & [fun_i] = fun
= check_derived_local_functions (fun_i+1) fun_end class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
= check_derived_local_functions (fun_i+1) fun_end class_member_arity class_member_n ins_member_types_and_functions icl_functions cs
= (ins_member_types_and_functions,icl_functions,cs)
checkIclInstances :: ![IndexRange] !*CommonDefs !*{#FunDef} !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
-> (![(Index,SymbolType)], ![IndexRange],!*CommonDefs,!*{#FunDef},!u:{# DclModule},!*VarHeap,!*TypeHeaps,!*CheckState)
checkIclInstances icl_instances_ranges icl_common=:{com_instance_defs,com_class_defs,com_member_defs,com_generic_defs,com_type_defs}
......@@ -356,6 +401,8 @@ where
# (instance_type,type_defs,modules,var_heap,type_heaps,cs)
= make_class_member_instance_type ins_type me_type me_class_vars type_defs modules var_heap type_heaps cs
instance_types = [ (ins_member.cim_index, instance_type) : instance_types ]
(ins_member_types_and_functions,icl_functions,cs)
= check_derived_local_functions_in_member ins_member.cim_index class_member.ds_arity class_member_n ins_member_types_and_functions icl_functions cs
= check_icl_instance_members (class_member_n+1) (instance_member_n+1) member_mod_index ins_members ins_member_types_and_functions class_members class_ident ins_pos ins_type
instance_types n_icl_functions new_instance_members member_defs type_defs icl_functions modules var_heap type_heaps cs
| ins_member.cim_ident.id_name < class_member.ds_ident.id_name
......
......@@ -245,6 +245,8 @@ ClassDefsContext :== 4
InstanceDefsContext :== 8
GlobalOrClassDefsContext :== 6 // cGlobalContext bitor ClassDefsContext
ClassOrInstanceDefsContext :== 12 // ClassDefsContext bitor InstanceDefsContext
WhereOfMemberDefsContext :== 16
MemberOrWhereOfMemberDefsContext :== 28 // ClassOrInstanceDefsContext bitor WhereOfMemberDefsContext
/*
A cClassOrInstanceDefsContext is a further restriction on a
local context, because no local node defs are allowed
......@@ -272,6 +274,7 @@ isClassOrInstanceDefsContext parseContext :== parseContext bitand ClassOrInstanc
isGlobalOrClassDefsContext parseContext :== parseContext bitand GlobalOrClassDefsContext <> 0
isInstanceDefsContext parseContext :== parseContext bitand InstanceDefsContext <> 0
isNotClassDefsContext parseContext :== parseContext bitand ClassDefsContext == 0
isMemberOrWhereOfMemberDefsContext parseContext :== parseContext bitand MemberOrWhereOfMemberDefsContext <> 0
cWantIclFile :== True
cWantDclFile :== False
......@@ -456,7 +459,7 @@ try_definition parseContext DeriveToken pos pState
| isGlobalContext parseContext
# (gendef, pState) = wantDeriveDefinition parseContext pos pState
= (True, gendef, pState)
| isClassOrInstanceDefsContext parseContext
| isMemberOrWhereOfMemberDefsContext parseContext
# (derive_instance_def, pState) = wantDeriveInstanceDefinition parseContext pos pState
= (True, derive_instance_def, pState)
= (False,abort "no def(2)",parseError "definition" No "derive declarations are only at the global level" pState)
......@@ -479,6 +482,84 @@ try_definition parseContext token pos pState
= (True, def, pState)
= (False, abort "no def(1)", tokenBack pState)
wantMemberDefinitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState)
wantMemberDefinitions parseContext pState
= parseList (tryMemberDefinition parseContext) pState
where
tryMemberDefinition :: !ParseContext !ParseState -> (!Bool, ParsedDefinition, !ParseState)
tryMemberDefinition parseContext pState
# (token, pState) = nextToken GeneralContext pState
(fname, linenr, pState) = getFileAndLineNr pState
= try_class_or_instance_definition parseContext token (LinePos fname linenr) pState
try_class_or_instance_definition :: !ParseContext !Token !Position !ParseState -> (!Bool, ParsedDefinition, !ParseState)
try_class_or_instance_definition parseContext (IdentToken name) pos pState
# (lhs, pState) = want_lhs_of_def (IdentToken name) pState
(token, pState) = nextToken FunctionContext pState
(def, pState) = want_rhs_of_class_or_instance_def parseContext lhs token (determine_position lhs pos) pState
= (True, def, pState)
try_class_or_instance_definition parseContext DeriveToken pos pState
# (derive_instance_def, pState) = wantDeriveInstanceDefinition parseContext pos pState
= (True, derive_instance_def, pState)
try_class_or_instance_definition parseContext token pos pState
| isLhsStartToken token
# (lhs, pState) = want_lhs_of_def token pState
(token, pState) = nextToken FunctionContext pState
(def, pState) = want_rhs_of_class_or_instance_def parseContext lhs token (determine_position lhs pos) pState
= (True, def, pState)
= try_definition parseContext token pos pState
want_rhs_of_class_or_instance_def :: !ParseContext !(Optional (Ident, Bool), [ParsedExpr]) !Token !Position !ParseState -> (ParsedDefinition, !ParseState)
want_rhs_of_class_or_instance_def parseContext lhs definingToken=:DoubleColonToken pos pState
= want_rhs_of_def parseContext lhs definingToken pos pState
want_rhs_of_class_or_instance_def parseContext lhs definingToken=:(PriorityToken prio) pos pState
= want_rhs_of_def parseContext lhs definingToken pos pState
want_rhs_of_class_or_instance_def parseContext (Yes (name, is_infix), args) token pos pState
# code_allowed = token =: EqualToken || token =: DoubleArrowToken
(token, pState) = nextToken FunctionContext pState
| isIclContext parseContext && token =: CodeToken
# (rhs, pState) = wantCodeRhs pState
| code_allowed
= (PD_Function pos name is_infix args rhs (FK_Function cNameNotLocationDependent), pState)
= (PD_Function pos name is_infix args rhs (FK_Function cNameNotLocationDependent), parseError "rhs of def" No "no code" pState)
# pState = tokenBack (tokenBack pState)
(ss_useLayout, pState) = accScanState UseLayout pState
has_args = isNotEmpty args
localsExpected = has_args || isGlobalContext parseContext || ~ ss_useLayout
(rhs, defining_symbol, pState)
= wantMemberRhs localsExpected (ruleDefiningRhsSymbol parseContext has_args) pState
fun_kind = definingSymbolToFunKind defining_symbol
= case fun_kind of
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)
_ -> (PD_Function pos name is_infix args rhs fun_kind, pState)
want_rhs_of_class_or_instance_def parseContext lhs definingToken pos pState
= want_rhs_of_def parseContext lhs definingToken pos pState
wantMemberRhs :: !Bool !RhsDefiningSymbol !ParseState -> (!Rhs, !RhsDefiningSymbol, !ParseState) // FunctionAltDefRhs
wantMemberRhs localsExpected definingSymbol pState
# (alts, definingSymbol, pState) = want_LetsFunctionBody definingSymbol localsExpected pState
(locals, pState) = optionalMemberLocals WhereToken localsExpected pState
= ({ rhs_alts = alts, rhs_locals = locals}, definingSymbol, pState)
where
optionalMemberLocals :: !Token !Bool !ParseState -> (!LocalDefs, !ParseState)
optionalMemberLocals dem_token localsExpected pState
# (off_token, pState) = nextToken FunctionContext pState
| dem_token == off_token
= wantMemberLocals pState
# (ss_useLayout, pState) = accScanState UseLayout pState
| off_token =: CurlyOpenToken && ~ ss_useLayout && localsExpected
= wantMemberLocals (tokenBack pState)
= (LocalParsedDefs [], tokenBack pState)
wantMemberLocals :: !ParseState -> (LocalDefs, !ParseState)
wantMemberLocals pState
# pState = wantBeginGroup "local definitions" pState
(defs, pState) = wantDefinitions (cLocalContext bitor WhereOfMemberDefsContext) pState
= (LocalParsedDefs defs, wantEndLocals pState)
determine_position (Yes (name, _), _) (LinePos f l) = FunPos f l name.id_name
determine_position lhs pos = pos
......@@ -1552,7 +1633,6 @@ cIsNotAGlobalContext :== False
cMightBeAClass :== True
cIsNotAClass :== False
wantClassDefinition :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState)
wantClassDefinition parseContext pos pState
......@@ -1704,7 +1784,7 @@ wantInstanceDeclaration parseContext pi_pos pState
# pState = wantEndOfDefinition "instance declaration" (tokenBack pState)
= (PD_Instance {pim_pi = pi, pim_members = []}, pState)
# (pi_members, pState) = wantDefinitions (SetInstanceDefsContext parseContext) pState
# (pi_members, pState) = wantMemberDefinitions (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},
......
......@@ -289,11 +289,9 @@ where
reorganiseLocalDefinitions [PD_NodeDef pos pattern {rhs_alts,rhs_locals} : defs] ca
# (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
= (fun_defs, [{ nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals, nd_position = pos } : node_defs], ca)
reorganiseLocalDefinitions [PD_Function pos name is_infix [] {rhs_alts, rhs_locals} FK_NodeDefOrFunction : defs] ca
# (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
= (fun_defs, [{ nd_dst = PE_Ident name, nd_alts = rhs_alts, nd_locals = rhs_locals, nd_position = pos } : node_defs], ca)
reorganiseLocalDefinitions [PD_Function pos name is_infix args rhs fun_kind : defs] ca
# prio = if is_infix DefaultPriority NoPrio
fun_arity = length args
......@@ -329,6 +327,12 @@ where
where
arity (Yes {st_arity}) = st_arity
arity No = 2 // it was specified as infix
reorganiseLocalDefinitions [PD_DeriveInstanceMember pos member_ident generic_ident optional_member_ident : defs] ca
# fun_body = GenerateInstanceBody generic_ident optional_member_ident
fun_def = {fun_ident = member_ident, fun_arity = 0, fun_priority = NoPrio, fun_type = No, fun_kind = FK_Function False,
fun_body = fun_body, fun_pos = pos, fun_lifted = 0, fun_info = EmptyFunInfo }
(fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
= ([fun_def:fun_defs], node_defs, ca)
reorganiseLocalDefinitions [] ca
= ([], [], ca)
......
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