diff options
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 20 | ||||
| -rw-r--r-- | frontend/parse.icl | 99 | ||||
| -rw-r--r-- | frontend/postparse.icl | 7 | ||||
| -rw-r--r-- | frontend/scanner.dcl | 4 | ||||
| -rw-r--r-- | frontend/scanner.icl | 34 |
5 files changed, 97 insertions, 67 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 6ad9d59..e50d91a 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -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 diff --git a/frontend/parse.icl b/frontend/parse.icl index 5bc8aef..8dbce55 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -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} diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 1e3ce71..25fe1d9 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -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 diff --git a/frontend/scanner.dcl b/frontend/scanner.dcl index 47038ad..d083ee5 100644 --- a/frontend/scanner.dcl +++ b/frontend/scanner.dcl @@ -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 diff --git a/frontend/scanner.icl b/frontend/scanner.icl index 2dcd002..d266b21 100644 --- a/frontend/scanner.icl +++ b/frontend/scanner.icl @@ -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 } ) |