Commit 4937e9ed authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl
Browse files

add inline abc code specified in system modules by adding :== code { .. } to...

add inline abc code specified in system modules by adding :== code { .. } to types of functions or instances
parent 2b9600c5
......@@ -211,6 +211,8 @@ beDeclareRuleType functionIndex moduleIndex name
:== beApFunction0 (BEDeclareRuleType functionIndex moduleIndex name)
beDefineRuleType functionIndex moduleIndex
:== beApFunction1 (BEDefineRuleType functionIndex moduleIndex)
beDefineRuleTypeWithCode functionIndex moduleIndex
:== beApFunction2 (BEDefineRuleTypeWithCode functionIndex moduleIndex)
beCodeAlt lineNumber
:== beFunction3 (BECodeAlt lineNumber)
beStringList string strings
......@@ -697,12 +699,19 @@ declareFunTypes moduleIndex funTypes ranges
= foldStateWithIndexA (declareFunType moduleIndex ranges) funTypes
declareFunType :: ModuleIndex [IndexRange] Int FunType -> BackEnder
declareFunType moduleIndex ranges functionIndex {ft_ident, ft_type_ptr}
declareFunType moduleIndex ranges functionIndex {ft_ident,ft_type_ptr,ft_specials}
= \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in
(case vi of
VI_ExpandedType expandedType
-> beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex ranges)
o` beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
| not ft_specials=:FSP_ABCCode _
-> beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex ranges)
o` beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
-> be_f ft_specials with
be_f (FSP_ABCCode abc_code) be
# be = beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex ranges) be
= beDefineRuleTypeWithCode functionIndex moduleIndex
(convertTypeAlt functionIndex moduleIndex expandedType)
(beAbcCodeBlock False (convertStrings abc_code)) be
_
-> identity) be
where
......
......@@ -83,12 +83,14 @@ where
check_specials :: !Index !FunType !Index !FunSpecials !Index ![FunType] !*Heaps !*PredefinedSymbols !*ErrorAdmin
-> (!FunSpecials,!Index,![FunType],!*Heaps,!*PredefinedSymbols,!*ErrorAdmin)
check_specials mod_index fun_type fun_index FSP_None next_inst_index all_instances heaps predef_symbols error
= (FSP_None, next_inst_index, all_instances, heaps, predef_symbols,error)
check_specials mod_index fun_type fun_index fsp=:(FSP_ABCCode _) next_inst_index all_instances heaps predef_symbols error
= (fsp, next_inst_index, all_instances, heaps, predef_symbols,error)
check_specials mod_index fun_type fun_index (FSP_Substitutions substs) next_inst_index all_instances heaps predef_symbols error
# (list_of_specials, (next_inst_index, all_instances, heaps, cs_predef_symbols,cs_error))
= mapSt (checkSpecial mod_index fun_type fun_index) substs (next_inst_index, all_instances, heaps, predef_symbols,error)
= (FSP_ContextTypes list_of_specials, next_inst_index, all_instances, heaps, cs_predef_symbols,cs_error)
check_specials mod_index fun_type fun_index FSP_None next_inst_index all_instances heaps predef_symbols error
= (FSP_None, next_inst_index, all_instances, heaps, predef_symbols,error)
checkDclInstanceMemberTypes :: !*{#ClassInstance} !ModuleIndex !v:{#CheckedTypeDef} !w:{#ClassDef} !v:{#DclModule} !*Heaps !*CheckState
-> (!*{#ClassInstance},!v:{#CheckedTypeDef},!w:{#ClassDef},!v:{#DclModule},!*Heaps,!*CheckState)
......@@ -715,6 +717,7 @@ where
= if_instance_member_type_specified_compare_and_use tl_member_types instance_type specials me_ident modules type_heaps cs_error
| ft_ident.id_name<>me_ident.id_name
= (instance_type, specials, member_types, modules, type_heaps, cs_error)
# specials = if (ft_specials=:FSP_ABCCode _) ft_specials specials
| ft_arity<>instance_type.st_arity
# cs_error = specified_member_type_incorrect_error CEC_NrArgsNotOk cs_error
= (instance_type, specials, member_types, modules, type_heaps, cs_error)
......@@ -3352,13 +3355,14 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
= create_gencase_funtypes nr_of_dcl_funs_insts_and_specs {d \\ d<-:dcl_common.com_gencase_defs} heaps
# dcl_functions
= arrayPlusList dcl_functions
( [ { mem_inst & ft_specials = if (isEmpty spec_types) FSP_None (FSP_ContextTypes spec_types) }
\\ mem_inst <- memb_inst_defs & spec_types <-: all_spec_types
= arrayPlusList dcl_functions
( [ { mem_inst & ft_specials
= if (isEmpty spec_types) ft_specials (FSP_ContextTypes spec_types) }
\\ mem_inst=:{ft_specials} <- memb_inst_defs & spec_types <-: all_spec_types
]
++ reverse rev_special_defs
++ gen_funs
)
)
# cs & cs_predef_symbols=cs_predef_symbols, cs_error=cs_error
# (com_instance_defs, cs)
......
......@@ -1468,11 +1468,13 @@ checkSpecialTypeVars SP_GenerateRecordInstances cs
= (SP_GenerateRecordInstances, cs)
checkFunSpecialTypeVars :: !FunSpecials !*CheckState -> (!FunSpecials, !*CheckState)
checkFunSpecialTypeVars FSP_None cs
= (FSP_None, cs)
checkFunSpecialTypeVars fsp=:(FSP_ABCCode _) cs
= (fsp, cs)
checkFunSpecialTypeVars (FSP_ParsedSubstitutions env) cs
# (env, cs) = mapSt check_type_vars env cs
= (FSP_ParsedSubstitutions env, cs)
checkFunSpecialTypeVars FSP_None cs
= (FSP_None, cs)
check_type_vars [] cs
= ([],cs)
......@@ -1508,12 +1510,12 @@ checkSpecialTypes mod_index SP_GenerateRecordInstances type_defs modules heaps c
checkFunSpecialTypes :: !Index !FunSpecials !v:{#CheckedTypeDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!FunSpecials,!x:{#CheckedTypeDef},!w:{#DclModule},!.TypeHeaps,!.CheckState), [u v <= w, v u <= x];
checkFunSpecialTypes mod_index FSP_None type_defs modules heaps cs
= (FSP_None, type_defs, modules, heaps, cs)
checkFunSpecialTypes mod_index (FSP_ParsedSubstitutions envs) type_defs modules heaps cs
# ots = { ots_type_defs = type_defs, ots_modules = modules }
(specials, (heaps, ots, cs)) = mapSt (check_environment mod_index) envs (heaps, ots, cs)
= (FSP_Substitutions specials, ots.ots_type_defs, ots.ots_modules, heaps, cs)
checkFunSpecialTypes mod_index FSP_None type_defs modules heaps cs
= (FSP_None, type_defs, modules, heaps, cs)
check_environment :: Int (Env Type TypeVar) *(*TypeHeaps,u:OpenTypeSymbols,*CheckState) -> *(SpecialSubstitution,(*TypeHeaps,u:OpenTypeSymbols,*CheckState))
check_environment mod_index env (heaps, ots, cs)
......
......@@ -501,7 +501,14 @@ where
(tspec, pState) = wantSymbolType pState
| isDclContext parseContext
# (specials, pState) = optionalFunSpecials pState
= (PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) specials, wantEndOfDefinition "type definition" pState)
#! def = PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) specials;
| not specials=:FSP_ABCCode _
= (def, wantEndOfDefinition "type definition" pState)
# (ss_useLayout, pState) = accScanState UseLayout pState
| ss_useLayout
= (def, wantEndOfDefinition "type definition" pState)
// } must be at end of line, make ; optional
= (def, optional_semicolon_without_layout_rule pState)
= (PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
want_rhs_of_def parseContext (opt_name, args) (PriorityToken prio) pos pState
# (name, _, pState) = check_name_and_fixity opt_name cHasPriority pState
......@@ -510,7 +517,14 @@ where
# (tspec, pState) = wantSymbolType pState
| isDclContext parseContext
# (specials, pState) = optionalFunSpecials pState
= (PD_TypeSpec pos name prio (Yes tspec) specials, wantEndOfDefinition "type definition" pState)
#! def = PD_TypeSpec pos name prio (Yes tspec) specials
| not specials=:FSP_ABCCode _
= (def, wantEndOfDefinition "type definition" pState)
# (ss_useLayout, pState) = accScanState UseLayout pState
| ss_useLayout
= (def, wantEndOfDefinition "type definition" pState)
// } must be at end of line, make ; optional
= (def, optional_semicolon_without_layout_rule pState)
= (PD_TypeSpec pos name prio (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
= (PD_TypeSpec pos name prio No FSP_None, wantEndOfDefinition "type definition" (tokenBack pState))
want_rhs_of_def parseContext (No, args) token pos pState
......@@ -766,6 +780,17 @@ generic_info_of_FIELD_geninfo_arg (PE_Record PE_Empty NoRecordName field_assignm
generic_info_of_FIELD_geninfo_arg _
= -1
optional_semicolon_without_layout_rule pState
# (token, pState) = nextToken FunctionContext pState
= case token of
NewDefinitionToken -> pState
SemicolonToken
# (token, pState) = nextToken FunctionContext pState
| token=:NewDefinitionToken
-> pState
-> tokenBack pState
_ -> tokenBack pState
want_instance_type_definitions :: ![Type] !ParseState -> (![ParsedDefinition], !ParseState)
want_instance_type_definitions instance_type pState
= parseList want_instance_type_definition pState
......@@ -821,13 +846,31 @@ where
want_rhs_of_instance_member_def opt_name DoubleColonToken pos pState
# (name, priority, pState) = check_name opt_name pState
(tspec, pState) = wantSymbolType pState
= (PD_TypeSpec pos name priority (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
(token, pState) = nextToken TypeContext pState
(fun_specials,pState) = optionalCode token pState
#! def = PD_TypeSpec pos name priority (Yes tspec) fun_specials
| not fun_specials=:FSP_ABCCode _
= (def, wantEndOfDefinition "type definition" pState)
# (ss_useLayout, pState) = accScanState UseLayout pState
| ss_useLayout
= (def, wantEndOfDefinition "type definition" pState)
// } must be at end of line, make ; optional
= (def, optional_semicolon_without_layout_rule pState)
want_rhs_of_instance_member_def opt_name (PriorityToken prio) pos pState
# (name,_,pState) = check_name_and_fixity opt_name cHasPriority pState
(token, pState) = nextToken TypeContext pState
| token == DoubleColonToken
# (tspec, pState) = wantSymbolType pState
= (PD_TypeSpec pos name prio (Yes tspec) FSP_None, wantEndOfDefinition "type definition" pState)
(token, pState) = nextToken TypeContext pState
(fun_specials,pState) = optionalCode token pState
#! def = PD_TypeSpec pos name prio (Yes tspec) fun_specials
| not fun_specials=:FSP_ABCCode _
= (def, wantEndOfDefinition "type definition" pState)
# (ss_useLayout, pState) = accScanState UseLayout pState
| ss_useLayout
= (def, wantEndOfDefinition "type definition" pState)
// } must be at end of line, make ; optional
= (def, optional_semicolon_without_layout_rule pState)
# pState = parseError "type definition" (Yes token) "::" pState
= (PD_TypeSpec pos name prio No FSP_None, wantEndOfDefinition "type defenition" pState)
want_rhs_of_instance_member_def opt_name token pos pState
......@@ -852,10 +895,24 @@ optionalSpecials pState
optionalFunSpecials :: !ParseState -> (!FunSpecials, !ParseState)
optionalFunSpecials pState
# (token, pState) = nextToken TypeContext pState
| token == SpecialToken
| token=:SpecialToken
# (specials, pState) = wantSpecials pState
= (FSP_ParsedSubstitutions specials, pState)
= (FSP_None, tokenBack pState)
= optionalCode token pState
optionalCode :: !Token !ParseState -> (!FunSpecials, !ParseState)
optionalCode ColonDefinesToken pState
# (token, pState) = nextToken FunctionContext pState
| token=:CodeToken
# (token, pState) = nextToken CodeContext pState
= case token of
CodeBlockToken the_code
-> (FSP_ABCCode the_code, pState)
token
-> (FSP_None, parseError "code rhs" (Yes token) "<code rhs>" pState)
= (FSP_None, parseError "code rhs" (Yes token) "code" pState)
optionalCode token pState
= (FSP_None, tokenBack pState)
wantSpecials :: !ParseState -> (![Env Type TypeVar], !ParseState)
wantSpecials pState
......@@ -1662,10 +1719,18 @@ wantInstanceDeclaration parseContext pi_pos pState
# (fname, linenr, pState) = getFileAndLineNr pState
pos = LinePos fname linenr
(tspec, pState) = wantSymbolType pState
(token, pState) = nextToken TypeContext pState
(fun_specials,pState) = optionalCode token pState
(instance_member_ident, pState) = stringToIdent pim_pi.pi_ident.id_name (IC_InstanceMember pim_pi.pi_types) pState
instance_member_type = PD_TypeSpec pos instance_member_ident NoPrio (Yes tspec) FSP_None
instance_member_type = PD_TypeSpec pos instance_member_ident NoPrio (Yes tspec) fun_specials
#! def = PD_Instance {pim_pi = pim_pi, pim_members = [instance_member_type]}
= (def, wantEndOfDefinition "instance declaration" pState)
| not fun_specials=:FSP_ABCCode _
= (def, wantEndOfDefinition "instance declaration" pState)
# (ss_useLayout, pState) = accScanState UseLayout pState
| ss_useLayout
= (def, wantEndOfDefinition "instance declaration" pState)
// } must be at end of line, make ; optional
= (def, optional_semicolon_without_layout_rule pState)
# pState = wantEndOfDefinition "instance declaration" (tokenBack pState)
= (PD_Instance {pim_pi = pim_pi, pim_members = []}, pState)
......
......@@ -349,6 +349,7 @@ cNameLocationDependent :== True
| FSP_Substitutions ![SpecialSubstitution]
| FSP_ContextTypes ![Special]
| FSP_FunIndex !Index
| FSP_ABCCode ![{#Char}]
| FSP_None
:: SpecialSubstitution =
......@@ -1351,7 +1352,7 @@ cIsNotStrict :== False
| UniqueSingleArraySelector
| UniqueSingleArraySelectorUniqueElementResult
:: Expression = Var !BoundVar
:: Expression = Var !BoundVar
| App !App
| (@) infixl 9 !Expression ![Expression]
| Let !Let
......
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