We planned to upgrade GitLab and Mattermost to the latest version this Friday morning (early). You may experience some downtime!

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