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

Commit 14874217 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur

enforce consistency of defining symbols in rhs

parent e84e3701
......@@ -34,7 +34,6 @@ Conventions:
- Functions with names containing the character '_' are local functions.
- All functions should consume the tokens taken form the state or given as argument,
or put these tokens back themselves.
*/
:: *ParseErrorAdmin =
......@@ -543,7 +542,7 @@ where
# pState = want_node_def_token pState token
# (ss_useLayout, pState) = accScanState UseLayout pState
localsExpected = ~ ss_useLayout
(rhs, pState) = wantRhs (isRhsStartToken parseContext) localsExpected (tokenBack pState)
(rhs, _, pState) = wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) (tokenBack pState)
| isGlobalContext parseContext
= (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<global definition>" pState)
= (PD_NodeDef pos (combine_args args) rhs, pState)
......@@ -557,22 +556,24 @@ where
want_rhs_of_def parseContext (Yes (name, False), []) token pos pState
| isIclContext parseContext && isLocalContext parseContext && (token == EqualToken || token == DefinesColonToken) &&
/* PK isLowerCaseName name.id_name && */ not (isClassOrInstanceDefsContext parseContext)
# (rhs, pState) = wantRhs (\_ -> True) False (tokenBack pState)
# (rhs, _, pState) = wantRhs False (RhsDefiningSymbolExact token) (tokenBack pState)
= (PD_NodeDef pos (PE_Ident name) rhs, pState)
want_rhs_of_def parseContext (Yes (name, is_infix), args) token pos pState
# (fun_kind, code_allowed, pState) = token_to_fun_kind pState token
# code_allowed = code_block_allowed token
(token, pState) = nextToken FunctionContext pState
| isIclContext parseContext && token == CodeToken
# (rhs, pState) = wantCodeRhs pState
| code_allowed
= (PD_Function pos name is_infix args rhs fun_kind, pState)
= (PD_Function pos name is_infix args rhs (FK_Function cNameNotLocationDependent), pState)
// otherwise // ~ code_allowed
= (PD_Function pos name is_infix args rhs fun_kind, parseError "rhs of def" No "no code" 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
localsExpected = isNotEmpty args || isGlobalContext parseContext || ~ ss_useLayout
(rhs, pState) = wantRhs (isRhsStartToken parseContext) localsExpected pState
(rhs, defining_symbol, pState)
= wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) pState
fun_kind = definingSymbolToFunKind defining_symbol
= case fun_kind of
FK_Function _ | isDclContext parseContext
-> (PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState)
......@@ -580,13 +581,8 @@ where
-> (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)
where
token_to_fun_kind s BarToken = (FK_Function cNameNotLocationDependent, False, s)
token_to_fun_kind s (SeqLetToken _) = (FK_Function cNameNotLocationDependent, False, s)
token_to_fun_kind s EqualToken = (FK_Function cNameNotLocationDependent, True, s)
token_to_fun_kind s ColonDefinesToken = (FK_Macro, False, s)
token_to_fun_kind s DoubleArrowToken = (FK_Function cNameNotLocationDependent, True, s)
token_to_fun_kind s DefinesColonToken = (FK_Caf, False, s)
token_to_fun_kind s token = (FK_Unknown, False, parseError "RHS" (Yes token) "defines token (=, => or =:) or argument" s)
code_block_allowed token
= token == EqualToken || token == DoubleArrowToken
check_name_and_fixity No hasprio pState
= (erroneousIdent, False, parseError "Definition" No "identifier" pState)
......@@ -594,17 +590,19 @@ where
| not is_infix && hasprio
= (name, False, parseError "Definition" No "Infix operator should be inside parentheses; no infix" pState)
= (name, is_infix, pState)
/*
isEqualToken :: !Token -> Bool
isEqualToken EqualToken = True
isEqualToken _ = False
*/
/*
isRhsStartToken :: !ParseContext !Token -> Bool
isRhsStartToken parseContext EqualToken = True
isRhsStartToken parseContext ColonDefinesToken = isGlobalOrClassOrInstanceDefsContext parseContext
isRhsStartToken parseContext DefinesColonToken = True
isRhsStartToken parseContext DoubleArrowToken = True // PK
isRhsStartToken parseContext _ = False
*/
optionalSpecials :: !ParseState -> (!Specials, !ParseState)
optionalSpecials pState
......@@ -751,27 +749,75 @@ where
ExprWithLocals = [ LetBefore ] sep RootExpression endOfDefinition [ LocalFunctionDefs ]
*/
wantRhs :: !(!Token -> Bool) !Bool !ParseState -> (Rhs, !ParseState) // FunctionAltDefRhs
wantRhs separator localsExpected pState
# (alts, pState) = want_LetsFunctionBody pState
isRhsStartToken :: !ParseContext !Token -> Bool
isRhsStartToken parseContext EqualToken = True
isRhsStartToken parseContext ColonDefinesToken = isGlobalOrClassOrInstanceDefsContext parseContext
isRhsStartToken parseContext DefinesColonToken = True
isRhsStartToken parseContext DoubleArrowToken = True // PK
isRhsStartToken parseContext _ = False
:: RhsDefiningSymbol
= RhsDefiningSymbolExact Token
| RhsDefiningSymbolCase // '->' or '='
| RhsDefiningSymbolRule // '=', '=:', '=>'
| RhsDefiningSymbolRuleOrMacro // '=', '=:', '=>', ':=='
ruleDefiningRhsSymbol :: !ParseContext -> RhsDefiningSymbol
ruleDefiningRhsSymbol parseContext
| isGlobalOrClassOrInstanceDefsContext parseContext
= RhsDefiningSymbolRuleOrMacro
// otherwise
= RhsDefiningSymbolRule
isDefiningSymbol :: RhsDefiningSymbol Token -> Bool
isDefiningSymbol (RhsDefiningSymbolExact wanted) observed
= wanted == observed
isDefiningSymbol RhsDefiningSymbolCase observed
= observed == EqualToken || observed == ArrowToken
isDefiningSymbol RhsDefiningSymbolRule observed
= observed == EqualToken || observed == DefinesColonToken || observed == DoubleArrowToken
isDefiningSymbol RhsDefiningSymbolRuleOrMacro observed
= observed == ColonDefinesToken || isDefiningSymbol RhsDefiningSymbolRule observed
definingSymbolToFunKind :: RhsDefiningSymbol -> FunKind
definingSymbolToFunKind (RhsDefiningSymbolExact defining_token)
= token_to_fun_kind defining_token
where
token_to_fun_kind ColonDefinesToken
= FK_Macro
token_to_fun_kind EqualToken
= FK_Function cNameNotLocationDependent
token_to_fun_kind DoubleArrowToken
= FK_Function cNameNotLocationDependent
token_to_fun_kind DefinesColonToken
= FK_Caf
token_to_fun_kind _
= FK_Unknown
definingSymbolToFunKind _
= FK_Unknown
wantRhs :: !Bool !RhsDefiningSymbol !ParseState -> (!Rhs, !RhsDefiningSymbol, !ParseState) // FunctionAltDefRhs
wantRhs localsExpected definingSymbol pState
# (alts, definingSymbol, pState) = want_LetsFunctionBody definingSymbol pState
(locals, pState) = optionalLocals WhereToken localsExpected pState
= ({ rhs_alts = alts, rhs_locals = locals}, pState)
= ({ rhs_alts = alts, rhs_locals = locals}, definingSymbol, pState)
where
want_LetsFunctionBody :: !ParseState -> (!OptGuardedAlts, !ParseState)
want_LetsFunctionBody pState
want_LetsFunctionBody :: !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState)
want_LetsFunctionBody definingSymbol pState
# (token, pState) = nextToken FunctionContext pState
(nodeDefs, token, pState) = want_LetBefores token pState
= want_FunctionBody token nodeDefs [] pState
= want_FunctionBody token nodeDefs [] definingSymbol pState
want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !ParseState -> (!OptGuardedAlts, !ParseState)
want_FunctionBody BarToken nodeDefs alts pState
want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState)
want_FunctionBody BarToken nodeDefs alts definingSymbol pState
// # (lets, pState) = want_StrictLet pState // removed from 2.0
# (file_name, line_nr, pState)= getFileAndLineNr pState
(token, pState) = nextToken FunctionContext pState
| token == OtherwiseToken
# (token, pState) = nextToken FunctionContext pState
(nodeDefs2, token, pState) = want_LetBefores token pState
= want_FunctionBody token (nodeDefs ++ nodeDefs2) alts pState // to allow | otherwise | c1 = .. | c2 = ..
= want_FunctionBody token (nodeDefs ++ nodeDefs2) alts definingSymbol pState // to allow | otherwise | c1 = .. | c2 = ..
/* PK ???
= case token of
BarToken
......@@ -780,60 +826,63 @@ where
_ -> root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState
*/ | token == LetToken True
# pState = parseError "RHS" No "No 'let!' in this version of Clean" pState
= root_expression True token nodeDefs (reverse alts) pState
= root_expression True token nodeDefs (reverse alts) definingSymbol pState
# (guard, pState) = wantRhsExpressionT token pState
(token, pState) = nextToken FunctionContext pState
(nodeDefs2, token, pState) = want_LetBefores token pState
| token == BarToken // nested guard
# (position, pState) = getPosition pState
offside = position.fp_col
(expr, pState) = want_FunctionBody token nodeDefs2 [] pState
(expr, definingSymbol, pState)
= want_FunctionBody token nodeDefs2 [] definingSymbol pState
pState = wantEndNestedGuard (default_found expr) offside pState
alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr }
(token, pState) = nextToken FunctionContext pState
(nodeDefs, token, pState) = want_LetBefores token pState
= want_FunctionBody token nodeDefs [alt:alts] pState
= want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState
// otherwise
# (expr, pState) = root_expression True token nodeDefs2 [] pState
# (expr, definingSymbol, pState)
= root_expression True token nodeDefs2 [] definingSymbol pState
alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr }
(token, pState) = nextToken FunctionContext pState
(nodeDefs, token, pState) = want_LetBefores token pState
= want_FunctionBody token nodeDefs [alt:alts] pState
= want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState
where
guard_ident line_nr
= { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr }
want_FunctionBody token nodeDefs alts pState
= root_expression localsExpected token nodeDefs (reverse alts) pState
want_FunctionBody token nodeDefs alts definingSymbol pState
= root_expression localsExpected token nodeDefs (reverse alts) definingSymbol pState
root_expression :: !Bool !Token ![NodeDefWithLocals] ![GuardedExpr] !ParseState -> (!OptGuardedAlts, !ParseState)
root_expression withExpected token nodeDefs alts pState
# (optional_expr,pState) = want_OptExprWithLocals withExpected token nodeDefs pState
= build_root token optional_expr alts nodeDefs pState
root_expression :: !Bool !Token ![NodeDefWithLocals] ![GuardedExpr] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState)
root_expression withExpected token nodeDefs alts definingSymbol pState
# (optional_expr,definingSymbol,pState) = want_OptExprWithLocals withExpected token nodeDefs definingSymbol pState
= build_root token optional_expr alts nodeDefs definingSymbol pState
where
build_root :: !Token !(Optional ExprWithLocalDefs) ![GuardedExpr] ![NodeDefWithLocals] !ParseState -> (!OptGuardedAlts, !ParseState)
build_root _ (Yes expr) [] _ pState
= ( UnGuardedExpr expr, pState)
build_root _ No alts=:[_:_] [] pState
= (GuardedAlts alts No, pState)
build_root _ optional_expr alts=:[_:_] _ pState
= (GuardedAlts alts optional_expr, pState)
build_root token _ _ _ pState
build_root :: !Token !(Optional ExprWithLocalDefs) ![GuardedExpr] ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState)
build_root _ (Yes expr) [] _ definingSymbol pState
= ( UnGuardedExpr expr, definingSymbol, pState)
build_root _ No alts=:[_:_] [] definingSymbol pState
= (GuardedAlts alts No, definingSymbol, pState)
build_root _ optional_expr alts=:[_:_] _ definingSymbol pState
= (GuardedAlts alts optional_expr, definingSymbol, pState)
build_root token _ _ _ definingSymbol pState
# (file_name, line_nr, pState) = getFileAndLineNr pState
= (UnGuardedExpr {ewl_nodes = [], ewl_expr = PE_Empty, ewl_locals = LocalParsedDefs [],
ewl_position = LinePos file_name line_nr}
, definingSymbol
, parseError "RHS: root expression" (Yes token) "= <ExprWithLocals>" pState
)
default_found (GuardedAlts _ No) = False
default_found _ = True
want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !ParseState -> (!Optional !ExprWithLocalDefs, !ParseState)
want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!Optional !ExprWithLocalDefs, !RhsDefiningSymbol, !ParseState)
// want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs pState
// = want_OptExprWithLocals True EqualToken nodeDefs (replaceToken EqualToken pState)
want_OptExprWithLocals withExpected token nodeDefs pState
| separator token
want_OptExprWithLocals withExpected token nodeDefs definingSymbol pState
| isDefiningSymbol definingSymbol token
# (file_name, line_nr, pState) = getFileAndLineNr pState
(expr, pState) = wantExpression cIsNotAPattern pState
pState = wantEndRootExpression pState
......@@ -843,9 +892,11 @@ where
, ewl_locals = locals
, ewl_position = LinePos file_name line_nr
}
, RhsDefiningSymbolExact token
, pState
)
= (No, tokenBack pState)
= (No, definingSymbol, tokenBack pState)
/* want_StrictLet :: !ParseState -> ([NodeDefWithLocals] , !ParseState) // Removed from the language !?
want_StrictLet pState
......@@ -2659,38 +2710,40 @@ wantCaseExp pState
(case_exp, pState) = wantExpression cIsNotAPattern pState
pState = wantToken FunctionContext "case expression" OfToken pState
pState = wantBeginGroup "case" pState
(case_alts, pState) = parseList tryCaseAlt pState
(found, alt, pState) = tryLastCaseAlt pState
(case_alts, (definingSymbol,pState))
= parseList tryCaseAlt (RhsDefiningSymbolCase, pState)
(found, alt, pState) = tryLastCaseAlt definingSymbol pState
| found
= (PE_Case case_ident case_exp (case_alts++[alt]), wantEndCase pState)
= (PE_Case case_ident case_exp case_alts, wantEndCase pState)
where
tryCaseAlt :: !ParseState -> (!Bool, CaseAlt, !ParseState)
tryCaseAlt pState
tryCaseAlt :: (!RhsDefiningSymbol, !ParseState) -> (!Bool, CaseAlt, (!RhsDefiningSymbol, !ParseState))
tryCaseAlt (definingSymbol, pState)
# (succ, pattern, pState) = try_pattern pState
| succ
# (rhs, pState) = wantRhs caseSeperator True pState
= (True, { calt_pattern = pattern, calt_rhs = rhs }, pState)
# (rhs, definingSymbol, pState) = wantRhs True definingSymbol pState
= (True, { calt_pattern = pattern, calt_rhs = rhs }, (definingSymbol, pState))
// otherwise // ~ succ
= (False, abort "no case alt", pState)
= (False, abort "no case alt", (definingSymbol, pState))
tryLastCaseAlt :: !ParseState -> (!Bool, CaseAlt, !ParseState)
tryLastCaseAlt pState
tryLastCaseAlt :: !RhsDefiningSymbol !ParseState -> (!Bool, CaseAlt, !ParseState)
tryLastCaseAlt definingSymbol pState
# (token, pState) = nextToken FunctionContext pState
| caseSeperator token
| isDefiningSymbol definingSymbol token
# pState = tokenBack pState
(rhs, pState) = wantRhs caseSeperator True pState
(rhs, _, pState)
= wantRhs True definingSymbol pState
= (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState)
| token == OtherwiseToken
# (token, pState) = nextToken FunctionContext pState
pState = tokenBack pState
| caseSeperator token
# (rhs, pState) = wantRhs caseSeperator True pState
| isDefiningSymbol definingSymbol token
# (rhs, _, pState) = wantRhs True definingSymbol pState
= (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState)
= (False, abort "no case alt", pState)
= (False, abort "no case alt", tokenBack pState)
caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.3.x case expressions
// caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.3.x case expressions
try_pattern :: !ParseState -> (!Bool, ParsedExpr, !ParseState)
try_pattern pState
......
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