Commit 384bd625 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur

assorted parse/scan bug fixes

parent 1ee2910d
......@@ -2109,12 +2109,30 @@ checkLhssOfLocalDefs def_level mod_index (CollectedLocalDefs {loc_functions={ir_
= (loc_defs, accus, { e_state & es_fun_defs = ps_fun_defs, es_var_heap = ps_var_heap }, {e_info & ef_macro_defs=macro_defs}, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })
where
check_patterns [ node_def : node_defs ] p_input accus var_store e_info cs
# (pattern, accus, var_store, e_info, cs) = checkPattern node_def.nd_dst No p_input accus var_store e_info cs
# (pattern, accus, var_store, e_info, cs) = check_local_lhs_pattern node_def.nd_dst No p_input accus var_store e_info cs
(patterns, accus, var_store, e_info, cs) = check_patterns node_defs p_input accus var_store e_info cs
= ([{ node_def & nd_dst = pattern } : patterns], accus, var_store, e_info, cs)
check_patterns [] p_input accus var_store e_info cs
= ([], accus, var_store, e_info, cs)
/* RWS: FIXME
This is a patch for the case
...
where
X = 10
in which X should be a node-id (a.k.a. AP_Variable) and not a pattern.
I think the distinction between node-ids and constructors should be done
in an earlier phase, but this will need a larger rewrite.
*/
check_local_lhs_pattern (PE_Ident id=:{id_name, id_info}) opt_var {pi_def_level, pi_mod_index} accus=:(var_env, array_patterns)
ps e_info cs=:{cs_symbol_table}
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
cs = checkPatternVariable pi_def_level entry id new_info_ptr { cs & cs_symbol_table = cs_symbol_table }
= (AP_Variable id new_info_ptr opt_var, ([ id : var_env ], array_patterns), { ps & ps_var_heap = ps_var_heap}, e_info, cs)
check_local_lhs_pattern pattern opt_var p_input accus var_store e_info cs
= checkPattern pattern opt_var p_input accus var_store e_info cs
addArraySelections [] rhs_expr free_vars e_input e_state e_info cs
= (rhs_expr, free_vars, e_state, e_info, cs)
addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
......
......@@ -489,7 +489,7 @@ where
# (lhs, pState) = want_lhs_of_def token pState
(token, pState) = nextToken FunctionContext pState
(def, pState) = want_rhs_of_def parseContext lhs token (determine_position lhs pos) pState
= (True, def, pState) -->> def
= (True, def, pState)
with
determine_position (Yes (name, _), _) (LinePos f l) = FunPos f l name.id_name
determine_position lhs pos = pos
......@@ -544,20 +544,20 @@ where
# pState = want_node_def_token pState token
# (ss_useLayout, pState) = accScanState UseLayout pState
localsExpected = ~ ss_useLayout
(rhs, pState) = wantRhs isEqualToken localsExpected (tokenBack pState)
(rhs, pState) = wantRhs (isRhsStartToken parseContext) localsExpected (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)
where
want_node_def_token s EqualToken = s
want_node_def_token s DefinesColonToken = replaceToken EqualToken s
want_node_def_token s DefinesColonToken = s // PK replaceToken EqualToken s
want_node_def_token s token = parseError "RHS" (Yes token) "defines token (= or =:)" s
combine_args [arg] = arg
combine_args args = PE_List args
want_rhs_of_def parseContext (Yes (name, False), []) token pos pState
| isIclContext parseContext && isLocalContext parseContext && token == EqualToken &&
isLowerCaseName name.id_name && not (isClassOrInstanceDefsContext parseContext)
| isIclContext parseContext && isLocalContext parseContext && (token == EqualToken || token == DefinesColonToken) &&
/* PK isLowerCaseName name.id_name && */ not (isClassOrInstanceDefsContext parseContext)
# (rhs, pState) = wantRhs (\_ -> True) False (tokenBack pState)
= (PD_NodeDef pos (PE_Ident name) rhs, pState)
......@@ -567,9 +567,9 @@ where
| isIclContext parseContext && token == CodeToken
# (rhs, pState) = wantCodeRhs pState
| code_allowed
= (PD_Function pos name is_infix args rhs fun_kind, 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 fun_kind, pState)
// otherwise // ~ code_allowed
= (PD_Function pos name is_infix args rhs fun_kind, 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
......@@ -579,7 +579,7 @@ where
-> (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)
_ -> (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)
......@@ -602,8 +602,9 @@ isEqualToken _ = False
isRhsStartToken :: !ParseContext !Token -> Bool
isRhsStartToken parseContext EqualToken = True
isRhsStartToken parseContext ColonDefinesToken = True
isRhsStartToken parseContext DefinesColonToken = True // RWS test isGlobalContext parseContext
isRhsStartToken parseContext ColonDefinesToken = isGlobalOrClassOrInstanceDefsContext parseContext
isRhsStartToken parseContext DefinesColonToken = True
isRhsStartToken parseContext DoubleArrowToken = True // PK
isRhsStartToken parseContext _ = False
optionalSpecials :: !ParseState -> (!Specials, !ParseState)
......@@ -753,25 +754,25 @@ where
wantRhs :: !(!Token -> Bool) !Bool !ParseState -> (Rhs, !ParseState) // FunctionAltDefRhs
wantRhs separator localsExpected pState
# (alts, pState) = want_LetsFunctionBody separator pState
# (alts, pState) = want_LetsFunctionBody pState
(locals, pState) = optionalLocals WhereToken localsExpected pState
= ({ rhs_alts = alts, rhs_locals = locals}, pState)
where
want_LetsFunctionBody :: !(!Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState)
want_LetsFunctionBody sep pState
want_LetsFunctionBody :: !ParseState -> (!OptGuardedAlts, !ParseState)
want_LetsFunctionBody pState
# (token, pState) = nextToken FunctionContext pState
(nodeDefs, token, pState) = want_LetBefores token pState
= want_FunctionBody token nodeDefs [] sep pState
= want_FunctionBody token nodeDefs [] pState
want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState)
want_FunctionBody BarToken nodeDefs alts sep pState
want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !ParseState -> (!OptGuardedAlts, !ParseState)
want_FunctionBody BarToken nodeDefs alts 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 sep pState // to allow | otherwise | c1 = .. | c2 = ..
= want_FunctionBody token (nodeDefs ++ nodeDefs2) alts pState // to allow | otherwise | c1 = .. | c2 = ..
/* PK ???
= case token of
BarToken
......@@ -780,36 +781,36 @@ 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) sep pState
= root_expression True token nodeDefs (reverse alts) 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 [] sep pState
(expr, pState) = want_FunctionBody token nodeDefs2 [] 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] sep pState
= want_FunctionBody token nodeDefs [alt:alts] pState
// otherwise
# (expr, pState) = root_expression True token nodeDefs2 [] sep pState
# (expr, pState) = root_expression True token nodeDefs2 [] 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] sep pState
= want_FunctionBody token nodeDefs [alt:alts] pState
where
guard_ident line_nr
= { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr }
want_FunctionBody token nodeDefs alts sep pState
= root_expression localsExpected token nodeDefs (reverse alts) sep pState
want_FunctionBody token nodeDefs alts pState
= root_expression localsExpected token nodeDefs (reverse alts) pState
root_expression :: !Bool !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState)
root_expression withExpected token nodeDefs alts sep pState
# (optional_expr,pState) = want_OptExprWithLocals withExpected token nodeDefs sep 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
where
build_root :: !Token !(Optional ExprWithLocalDefs) ![GuardedExpr] ![NodeDefWithLocals] !ParseState -> (!OptGuardedAlts, !ParseState)
......@@ -829,11 +830,11 @@ where
default_found (GuardedAlts _ No) = False
default_found _ = True
want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !(Token -> Bool) !ParseState -> (!Optional !ExprWithLocalDefs, !ParseState)
want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs sep pState
= want_OptExprWithLocals True EqualToken nodeDefs sep (replaceToken EqualToken pState)
want_OptExprWithLocals withExpected token nodeDefs sep pState
| sep token
want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !ParseState -> (!Optional !ExprWithLocalDefs, !ParseState)
// want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs pState
// = want_OptExprWithLocals True EqualToken nodeDefs (replaceToken EqualToken pState)
want_OptExprWithLocals withExpected token nodeDefs pState
| separator token
# (file_name, line_nr, pState) = getFileAndLineNr pState
(expr, pState) = wantExpression cIsNotAPattern pState
pState = wantEndRootExpression pState
......@@ -899,6 +900,14 @@ where
)
// otherwise // ~ succ
= (False, abort "no definition", pState)
try_let_lhs pState
# (succ, lhs_exp, pState) = trySimpleLhsExpression pState
| succ
= (True, lhs_exp, pState)
# (token,pState) = nextToken FunctionContext pState
= case token of
_ -> (False, lhs_exp, tokenBack pState)
optionalLocals :: !Token !Bool !ParseState -> (!LocalDefs, !ParseState)
optionalLocals dem_token localsExpected pState
......@@ -2352,21 +2361,21 @@ wantListExp is_pattern pState
# pState=appScanState setNoNewOffsideForSeqLetBit pState
# (token, pState) = nextToken FunctionContext pState
# pState=appScanState clearNoNewOffsideForSeqLetBit pState
# (head_strictness,token,pState) = wantHeadStrictness token pState
# (head_strictness,token,pState) = want_head_strictness token pState
with
wantHeadStrictness :: Token *ParseState -> *(!Int,!Token,!*ParseState)
wantHeadStrictness ExclamationToken pState
want_head_strictness :: Token *ParseState -> *(!Int,!Token,!*ParseState)
want_head_strictness ExclamationToken pState
# (token,pState) = nextToken FunctionContext pState
= (HeadStrict,token,pState)
wantHeadStrictness (SeqLetToken strict) pState
want_head_strictness (SeqLetToken strict) pState
# (token,pState) = nextToken FunctionContext pState
| strict
= (HeadUnboxedAndTailStrict,token,pState);
= (HeadUnboxed,token,pState)
wantHeadStrictness BarToken pState
want_head_strictness BarToken pState
# (token,pState) = nextToken FunctionContext pState
= (HeadOverloaded,token,pState)
wantHeadStrictness token pState
want_head_strictness token pState
= (HeadLazy,token,pState)
| token==ExclamationToken && (head_strictness<>HeadOverloaded && head_strictness<>HeadUnboxedAndTailStrict)
# (token, pState) = nextToken FunctionContext pState
......@@ -2426,7 +2435,9 @@ wantListExp is_pattern pState
| token==ExclamationToken && head_strictness<>HeadOverloaded
# pState = wantToken FunctionContext "list" SquareCloseToken pState
-> gen_tail_strict_cons_nodes acc exp pState
# pState = parseError "list" (Yes token) (toString SquareCloseToken) pState
| token==ColonToken // to allow [1:2:[]] etc.
-> want_list [exp:acc] (tokenBack pState)
# pState = parseError "list" (Yes token) "] or :" pState
-> gen_cons_nodes acc exp pState
DotDotToken
| is_pattern
......@@ -2468,7 +2479,7 @@ wantListExp is_pattern pState
gen_cons_nodes [e:r] exp pState
# (exp, pState) = makeConsExpression head_strictness is_pattern e exp pState
= gen_cons_nodes r exp pState
gen_tail_strict_cons_nodes [] exp pState
= (exp, pState)
gen_tail_strict_cons_nodes [e:r] exp pState
......@@ -2638,7 +2649,7 @@ where
= (False, abort "no case alt", pState)
= (False, abort "no case alt", tokenBack pState)
caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.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
......@@ -3289,11 +3300,11 @@ where
instance currentToken ParseState
where
currentToken pState = accScanState currentToken pState
*/
instance replaceToken ParseState
where
replaceToken t pState = appScanState (replaceToken t) pState
*/
instance tokenBack ParseState
where
tokenBack pState=:{ps_skipping}
......
......@@ -2,7 +2,7 @@ implementation module postparse
import StdEnv
import syntax, parse, utilities, StdCompare
// import RWSDebug
//import RWSDebug
:: *CollectAdmin =
{ ca_error :: !*ParseErrorAdmin
......@@ -303,7 +303,10 @@ where
= ([ fun : fun_defs ], node_defs, ca)
reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca
= case defs of
[PD_Function pos name is_infix args rhs fun_kind : _]
[PD_Function pos name is_infix args rhs fun_kind : othe] // PK ..
| fun_kind == FK_Caf
# ca = postParseError pos "No typespecification for local graph definitions allowed" ca // .. PK
-> reorganiseLocalDefinitions (tl defs) ca
| belongsToTypeSpec name1 prio name is_infix
# fun_arity = determineArity args type
# (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca
......
......@@ -134,13 +134,13 @@ instance nextToken ScanState
class currentToken state :: !*state -> (!Token, !*state)
instance currentToken ScanState
/*
class insertToken state :: !Token !ScanContext !*state -> *state
instance insertToken ScanState
class replaceToken state :: !Token !*state -> *state
instance replaceToken ScanState
*/
class getPosition state :: !*state -> (!FilePosition,!*state) // Position of current Token (or Char)
instance getPosition ScanState
......
......@@ -46,7 +46,7 @@ where
currentToken (ScanState scan_state)
# (token,scan_state) = currentToken scan_state
= (token,ScanState scan_state)
/*
instance insertToken ScanState
where
insertToken token context (ScanState scan_state) = ScanState (insertToken token context scan_state)
......@@ -54,7 +54,7 @@ where
instance replaceToken ScanState
where
replaceToken token (ScanState scan_state) = ScanState (replaceToken token scan_state)
*/
instance getPosition ScanState
where
getPosition (ScanState scan_state)
......@@ -396,7 +396,7 @@ where currentToken scanState=:{ss_tokenBuffer}
| isEmptyBuffer ss_tokenBuffer
= (ErrorToken "dummy", scanState)
= ((head ss_tokenBuffer).lt_token, scanState)
/*
class insertToken state :: !Token !ScanContext !*state -> *state
instance insertToken RScanState
......@@ -412,7 +412,7 @@ where
}
ss_input
}
*/
notContextDependent :: !Token -> Bool
notContextDependent token
= case token of
......@@ -438,7 +438,7 @@ notContextDependent token
WhereToken -> True
WithToken -> True
_ -> False
/*
class replaceToken state :: !Token !*state -> *state
instance replaceToken RScanState
......@@ -448,7 +448,7 @@ where
= { scanState
& ss_tokenBuffer = store { longToken & lt_token = tok } buffer
}
*/
SkipWhites :: !Input -> (!Optional String, !Char, !Input)
SkipWhites {inp_stream=OldLine i line stream,inp_pos={fp_line,fp_col},inp_tabsize,inp_filename}
| i<size line
......@@ -608,11 +608,11 @@ Scan c0=:'#' input co
// otherwise
= (SeqLetToken strict, charBack input)
Scan '*' input TypeContext = (AsteriskToken, input)
Scan c0=:'&' input co
# (eof, c1, input) = ReadNormalChar input
Scan c0=:'&' input co = possibleKeyToken AndToken [c0] co input
/* # (eof, c1, input) = ReadNormalChar input
| eof = (AndToken, input)
| isSpecialChar c1 = ScanOperator 1 input [c1, c0] co
= (AndToken, charBack input)
= (AndToken, charBack input) */
Scan c0=:'.' input co // PK incorrect ?
= case co of
TypeContext
......@@ -723,7 +723,7 @@ Scan c0=:':' input co
| c1 == ':'
# (eof, c2, input) = ReadNormalChar input
| eof = (DoubleColonToken, input)
| isSpecialChar c2 && ~(c2=='!' || c2=='*') // for type rules and the like
| isSpecialChar c2 && ~(c2=='!' || c2=='*' || c2=='.') // for type rules and the like
= ScanOperator 2 input [c2, c1, c0] co
= (DoubleColonToken, charBack input)
| c1 == '='
......@@ -758,7 +758,7 @@ possibleKeyToken :: !Token ![Char] !ScanContext !Input -> (!Token, !Input)
possibleKeyToken token reversedPrefix context input
# (eof, c, input) = ReadNormalChar input
| eof = (token, input)
| isSpecialChar c = ScanOperator 2 input [c : reversedPrefix] context
| isSpecialChar c = ScanOperator (length reversedPrefix) input [c : reversedPrefix] context
= (token, charBack input)
new_exp_char ',' = True
......@@ -1003,7 +1003,7 @@ ScanOctNumeral n input
ScanChar :: !Input ![Char] -> (!Token, !Input)
ScanChar input chars
# (eof, c, input) = ReadNormalChar input
# (eof, c, input) = ReadChar input // PK: was ReadNormalChar input
| eof = (ErrorToken "End of file inside Char denotation", input)
| '\'' == c = (CharListToken "", input)
| '\\' == c = ScanBSChar 0 chars input ScanEndOfChar
......@@ -1226,17 +1226,15 @@ ReadChar {inp_stream = OldLine i line stream,inp_pos,inp_tabsize,inp_filename}
# pos = NextPos c inp_pos inp_tabsize
(c,stream) = correctNewline_OldLine c i inp_tabsize line stream
= ( False, c
, {
inp_filename=inp_filename,inp_tabsize=inp_tabsize,
inp_stream = stream
, { inp_filename = inp_filename, inp_tabsize = inp_tabsize
, inp_stream = stream
, inp_pos = pos
}
)
# pos = {inp_pos & fp_col = inp_pos.fp_col + 1}
= ( False, c
, {
inp_filename=inp_filename,inp_tabsize=inp_tabsize,
inp_stream = OldLine (i+1) line stream
, { inp_filename = inp_filename, inp_tabsize = inp_tabsize
, inp_stream = OldLine (i+1) line stream
, inp_pos = pos
}
)
......
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