diff options
Diffstat (limited to 'src/boot')
| -rw-r--r-- | src/boot/includer.boot | 18 | ||||
| -rw-r--r-- | src/boot/parser.boot | 161 | ||||
| -rw-r--r-- | src/boot/strap/includer.clisp | 21 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 208 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 4 | ||||
| -rw-r--r-- | src/boot/translator.boot | 1 |
6 files changed, 215 insertions, 198 deletions
diff --git a/src/boot/includer.boot b/src/boot/includer.boot index d6b98584..090add87 100644 --- a/src/boot/includer.boot +++ b/src/boot/includer.boot @@ -98,24 +98,6 @@ SoftShoeError(posn,key)== shoeConsole strconc(shoeSpaces lineCharacter posn,'"|") shoeConsole key -bpSpecificErrorAtToken(tok, key) == - a := tokenPosition tok - SoftShoeError(a,key) - -bpSpecificErrorHere(key) == - bpSpecificErrorAtToken($stok, key) - -bpGeneralErrorHere() == - bpSpecificErrorHere('"syntax error") - -bpIgnoredFromTo(pos1, pos2) == - shoeConsole strconc('"ignored from line ", toString lineNo pos1) - shoeConsole lineString pos1 - shoeConsole strconc(shoeSpaces lineCharacter pos1,'"|") - shoeConsole strconc('"ignored through line ", toString lineNo pos2) - shoeConsole lineString pos2 - shoeConsole strconc(shoeSpaces lineCharacter pos2,'"|") - --% structure %SourceLine == Record(str: %String, num: %Short) with diff --git a/src/boot/parser.boot b/src/boot/parser.boot index ccf73528..d6b72f83 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -50,15 +50,28 @@ module parser --% structure %ParserState == - Record(toks: %List %Tokens, trees: %List %Ast, pren: %Short, scp: %Short) - with + Record(toks: %List %Tokens, trees: %List %Ast, pren: %Short, scp: %Short, + cur: %Token) with parserTokens == (.toks) -- remaining token sequence parserTrees == (.trees) -- list of successful parse trees parserNesting == (.pren) -- parenthesis nesting level parserScope == (.scp) -- scope nesting level + parserCurrentToken == (.cur) -- current token makeParserState toks == - mk%ParserState(toks,nil,0,0) + mk%ParserState(toks,nil,0,0,nil) + +++ Access the value of the current token +macro parserTokenValue ps == + tokenValue parserCurrentToken ps + +++ Access the class of the current token +macro parserTokenClass ps == + tokenClass parserCurrentToken ps + +++ Access the position of the current token +macro parserTokenPosition ps == + tokenPosition parserCurrentToken ps --% --% Translator global state @@ -79,18 +92,18 @@ makeTranslator ip == bpFirstToken ps == - $stok:= - parserTokens ps = nil => mk%Token("ERROR","NOMORE",tokenPosition $stok) + parserCurrentToken(ps) := + parserTokens ps = nil => mk%Token("ERROR","NOMORE",parserTokenPosition ps) first parserTokens ps - $ttok := tokenValue $stok + $ttok := parserTokenValue ps true bpFirstTok ps == - $stok:= - parserTokens ps = nil => mk%Token("ERROR","NOMORE",tokenPosition $stok) + parserCurrentToken(ps) := + parserTokens ps = nil => mk%Token("ERROR","NOMORE",parserTokenPosition ps) first parserTokens ps - $ttok := tokenValue $stok - parserNesting ps > 0 and tokenClass $stok = "KEY" => + $ttok := parserTokenValue ps + parserNesting ps > 0 and parserTokenClass ps = "KEY" => $ttok is "SETTAB" => parserScope(ps) := parserScope ps + 1 bpNext ps @@ -150,16 +163,16 @@ bpIndentParenthesized(ps,f) == scope := parserScope ps try parserScope(ps) := 0 - a:=$stok + a := parserCurrentToken ps bpEqPeek(ps,"OPAREN") => parserNesting(ps) := parserNesting ps + 1 bpNext ps apply(f,ps,nil) and bpFirstTok ps and - (bpEqPeek(ps,"CPAREN") or bpParenTrap(a)) => + (bpEqPeek(ps,"CPAREN") or bpParenTrap(ps,a)) => parserNesting(ps) := parserNesting ps - 1 bpNextToken ps parserScope ps = 0 => true - parserTokens(ps) := append(bpAddTokens parserScope ps,parserTokens ps) + parserTokens(ps) := append(bpAddTokens(ps,parserScope ps),parserTokens ps) bpFirstToken ps parserNesting ps = 0 => bpCancel ps @@ -170,33 +183,33 @@ bpIndentParenthesized(ps,f) == parserNesting(ps) := parserNesting ps - 1 bpNextToken ps true - bpParenTrap(a) + bpParenTrap(ps,a) false finally parserScope(ps) := scope bpParenthesized(ps,f) == - a := $stok + a := parserCurrentToken ps bpEqKey(ps,"OPAREN") => - apply(f,ps,nil) and (bpEqKey(ps,"CPAREN") or bpParenTrap(a)) => true + apply(f,ps,nil) and (bpEqKey(ps,"CPAREN") or bpParenTrap(ps,a)) => true bpEqKey(ps,"CPAREN") => bpPush(ps,bfTuple []) true - bpParenTrap(a) + bpParenTrap(ps,a) false bpBracket(ps,f) == - a := $stok + a := parserCurrentToken ps bpEqKey(ps,"OBRACK") => - apply(f,ps,nil) and (bpEqKey(ps,"CBRACK") or bpBrackTrap(a)) => + apply(f,ps,nil) and (bpEqKey(ps,"CBRACK") or bpBrackTrap(ps,a)) => bpPush(ps,bfBracket bpPop1 ps) bpEqKey(ps,"CBRACK") => bpPush(ps,[]) - bpBrackTrap(a) + bpBrackTrap(ps,a) false bpPileBracketed(ps,f) == bpEqKey(ps,"SETTAB") => bpEqKey(ps,"BACKTAB") => true - apply(f,ps,nil) and (bpEqKey(ps,"BACKTAB") or bpPileTrap()) => + apply(f,ps,nil) and (bpEqKey(ps,"BACKTAB") or bpPileTrap ps) => bpPush(ps,bfPile bpPop1 ps) false false @@ -262,9 +275,9 @@ bpConditional(ps,f) == bpEqKey(ps,"SETTAB") => bpEqKey(ps,"THEN") => bpRequire(ps,f) and bpElse(ps,f) and bpEqKey(ps,"BACKTAB") - bpMissing "THEN" + bpMissing(ps,"THEN") bpEqKey(ps,"THEN") => bpRequire(ps,f) and bpElse(ps,f) - bpMissing "then" + bpMissing(ps,"then") false bpElse(ps,f)== @@ -280,38 +293,56 @@ bpBacksetElse ps == bpEqKey(ps,"ELSE") bpEqPeek(ps,s) == - tokenClass $stok = "KEY" and symbolEq?(s,$ttok) + parserTokenClass ps = "KEY" and symbolEq?(s,$ttok) bpEqKey(ps,s) == - tokenClass $stok = "KEY" and symbolEq?(s,$ttok) and bpNext ps + parserTokenClass ps = "KEY" and symbolEq?(s,$ttok) and bpNext ps bpEqKeyNextTok(ps,s) == - tokenClass $stok = "KEY" and symbolEq?(s,$ttok) and bpNextToken ps + parserTokenClass ps = "KEY" and symbolEq?(s,$ttok) and bpNextToken ps -bpPileTrap() == bpMissing "BACKTAB" -bpBrackTrap(x) == bpMissingMate("]",x) -bpParenTrap(x) == bpMissingMate(")",x) +bpPileTrap ps == bpMissing(ps,"BACKTAB") +bpBrackTrap(ps,x) == bpMissingMate(ps,"]",x) +bpParenTrap(ps,x) == bpMissingMate(ps,")",x) -bpMissingMate(close,open)== +bpSpecificErrorHere(ps,key) == + bpSpecificErrorAtToken(parserCurrentToken ps, key) + +bpSpecificErrorAtToken(tok, key) == + a := tokenPosition tok + SoftShoeError(a,key) + +bpGeneralErrorHere ps == + bpSpecificErrorHere(ps,'"syntax error") + +bpIgnoredFromTo(pos1, pos2) == + shoeConsole strconc('"ignored from line ", toString lineNo pos1) + shoeConsole lineString pos1 + shoeConsole strconc(shoeSpaces lineCharacter pos1,'"|") + shoeConsole strconc('"ignored through line ", toString lineNo pos2) + shoeConsole lineString pos2 + shoeConsole strconc(shoeSpaces lineCharacter pos2,'"|") + +bpMissingMate(ps,close,open)== bpSpecificErrorAtToken(open, '"possibly missing mate") - bpMissing close + bpMissing(ps,close) -bpMissing s== - bpSpecificErrorHere strconc(PNAME s,'" possibly missing") +bpMissing(ps,s) == + bpSpecificErrorHere(ps,strconc(PNAME s,'" possibly missing")) throw 'TRAPPED : BootParserException bpCompMissing(ps,s) == - bpEqKey(ps,s) or bpMissing s + bpEqKey(ps,s) or bpMissing(ps,s) bpTrap ps == - bpGeneralErrorHere() + bpGeneralErrorHere ps throw 'TRAPPED : BootParserException bpRecoverTrap ps == bpFirstToken ps - pos1 := tokenPosition $stok + pos1 := parserTokenPosition ps bpMoveTo(ps,0) - pos2 := tokenPosition $stok + pos2 := parserTokenPosition ps bpIgnoredFromTo(pos1, pos2) bpPush(ps,[['"pile syntax error"]]) @@ -332,7 +363,7 @@ bpListAndRecover(ps,f)== else if not found then parserTokens(ps) := c - bpGeneralErrorHere() + bpGeneralErrorHere ps bpRecoverTrap ps if bpEqKey(ps,"BACKSET") then @@ -342,7 +373,7 @@ bpListAndRecover(ps,f)== done := true else parserTokens(ps) := c - bpGeneralErrorHere() + bpGeneralErrorHere ps bpRecoverTrap ps if bpEqPeek(ps,"BACKTAB") or parserTokens ps = nil then done:=true @@ -389,7 +420,7 @@ bpMoveTo(ps,n) == bpQualifiedName ps == bpEqPeek(ps,"COLON-COLON") => bpNext ps - tokenClass $stok = "ID" and bpPushId ps and bpNext ps + parserTokenClass ps = "ID" and bpPushId ps and bpNext ps and bpPush(ps,bfColonColon(bpPop2 ps, bpPop1 ps)) false @@ -397,7 +428,7 @@ bpQualifiedName ps == ++ ID ++ Name :: ID bpName ps == - tokenClass $stok = "ID" => + parserTokenClass ps = "ID" => bpPushId ps bpNext ps bpAnyNo(ps,function bpQualifiedName) @@ -412,12 +443,12 @@ bpName ps == ++ QUOTE S-Expression ++ STRING bpConstTok ps == - tokenClass $stok in '(INTEGER FLOAT) => + parserTokenClass ps in '(INTEGER FLOAT) => bpPush(ps,$ttok) bpNext ps - tokenClass $stok = "LISP" => bpPush(ps,%Lisp $ttok) and bpNext ps - tokenClass $stok = "LISPEXP" => bpPush(ps,$ttok) and bpNext ps - tokenClass $stok = "LINE" => bpPush(ps,["+LINE", $ttok]) and bpNext ps + parserTokenClass ps = "LISP" => bpPush(ps,%Lisp $ttok) and bpNext ps + parserTokenClass ps = "LISPEXP" => bpPush(ps,$ttok) and bpNext ps + parserTokenClass ps = "LINE" => bpPush(ps,["+LINE", $ttok]) and bpNext ps bpEqPeek(ps,"QUOTE") => bpNext ps bpRequire(ps,function bpSexp) and @@ -425,7 +456,7 @@ bpConstTok ps == bpString ps or bpFunction ps bpChar ps == - tokenClass $stok = "ID" and $ttok is "char" => + parserTokenClass ps = "ID" and $ttok is "char" => a := bpState ps bpApplication ps => s := bpPop1 ps @@ -573,10 +604,10 @@ bpCancel ps == false false -bpAddTokens n== +bpAddTokens(ps,n) == n=0 => nil - n>0=> [mk%Token("KEY","SETTAB",tokenPosition $stok),:bpAddTokens(n-1)] - [mk%Token("KEY","BACKTAB",tokenPosition $stok),:bpAddTokens(n+1)] + n>0=> [mk%Token("KEY","SETTAB",parserTokenPosition ps),:bpAddTokens(ps,n-1)] + [mk%Token("KEY","BACKTAB",parserTokenPosition ps),:bpAddTokens(ps,n+1)] bpExceptions ps == bpEqPeek(ps,"DOT") or bpEqPeek(ps,"QUOTE") or @@ -586,18 +617,18 @@ bpExceptions ps == bpSexpKey ps == - tokenClass $stok = "KEY" and not bpExceptions ps => + parserTokenClass ps = "KEY" and not bpExceptions ps => a := $ttok has SHOEINF a = nil => bpPush(ps,keywordId $ttok) and bpNext ps bpPush(ps,a) and bpNext ps false bpAnyId ps == - bpEqKey(ps,"MINUS") and (tokenClass $stok = "INTEGER" or bpTrap ps) and - bpPush(ps,-$ttok) and bpNext ps or - bpSexpKey ps or - tokenClass $stok in '(ID INTEGER STRING FLOAT) - and bpPush(ps,$ttok) and bpNext ps + bpEqKey(ps,"MINUS") and (parserTokenClass ps = "INTEGER" or bpTrap ps) and + bpPush(ps,-$ttok) and bpNext ps + or bpSexpKey ps + or parserTokenClass ps in '(ID INTEGER STRING FLOAT) and + bpPush(ps,$ttok) and bpNext ps bpSexp ps == bpAnyId ps or @@ -635,11 +666,11 @@ bpDot ps == bpEqKey(ps,"DOT") and bpPush(ps,bfDot()) bpPrefixOperator ps == - tokenClass $stok = "KEY" and + parserTokenClass ps = "KEY" and $ttok has SHOEPRE and bpPushId ps and bpNext ps bpInfixOperator ps == - tokenClass $stok = "KEY" and + parserTokenClass ps = "KEY" and $ttok has SHOEINF and bpPushId ps and bpNext ps bpSelector ps == @@ -681,7 +712,7 @@ bpTyped ps == bpExpt ps == bpRightAssoc(ps,'(POWER),function bpTyped) bpInfKey(ps,s) == - tokenClass $stok = "KEY" and + parserTokenClass ps = "KEY" and symbolMember?($ttok,s) and bpPushId ps and bpNext ps bpInfGeneric(ps,s) == @@ -705,7 +736,7 @@ bpLeftAssoc(ps,operations,parser)== false bpString ps == - tokenClass $stok = "STRING" and + parserTokenClass ps = "STRING" and bpPush(ps,quote makeSymbol $ttok) and bpNext ps bpFunction ps == @@ -713,7 +744,7 @@ bpFunction ps == and bpPush(ps,bfFunction bpPop1 ps) bpThetaName ps == - tokenClass $stok = "ID" and $ttok has SHOETHETA => + parserTokenClass ps = "ID" and $ttok has SHOETHETA => bpPushId ps bpNext ps false @@ -800,10 +831,10 @@ bpCatchItem ps == bpPush(ps,%Catch(bpPop2 ps,bpPop1 ps)) bpExceptionVariable ps == - t := $stok + t := parserCurrentToken ps bpEqKey(ps,"OPAREN") and bpRequire(ps,function bpSignature) and - (bpEqKey(ps,"CPAREN") or bpMissing t) + (bpEqKey(ps,"CPAREN") or bpMissing(ps,t)) or bpTrap ps bpFinally ps == @@ -1150,7 +1181,7 @@ bpRegularBVItem ps == or bpBracketConstruct(ps,function bpPatternL) bpBVString ps == - tokenClass $stok = "STRING" and + parserTokenClass ps = "STRING" and bpPush(ps,["BVQUOTE",makeSymbol $ttok]) and bpNext ps bpRegularBVItemL ps == @@ -1272,7 +1303,7 @@ bpIdList ps == bpCase ps == bpEqKey(ps,"CASE") and bpRequire(ps,function bpWhere) and - (bpEqKey(ps,"OF") or bpMissing "OF") and + (bpEqKey(ps,"OF") or bpMissing(ps,"OF")) and bpPiledCaseItems ps bpPiledCaseItems ps == @@ -1301,7 +1332,7 @@ bpOutItem ps == $GenVarCounter: local := 0 try bpRequire(ps,function bpComma) catch(e: BootSpecificError) => - bpSpecificErrorHere e + bpSpecificErrorHere(ps,e) bpTrap ps b := bpPop1 ps t := diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index 3ecb4580..e2cf37f2 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -40,27 +40,6 @@ (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|")) (|shoeConsole| |key|))) -(DEFUN |bpSpecificErrorAtToken| (|tok| |key|) - (LET* (|a|) - (PROGN (SETQ |a| (|tokenPosition| |tok|)) (|SoftShoeError| |a| |key|)))) - -(DEFUN |bpSpecificErrorHere| (|key|) - (DECLARE (SPECIAL |$stok|)) - (|bpSpecificErrorAtToken| |$stok| |key|)) - -(DEFUN |bpGeneralErrorHere| () (|bpSpecificErrorHere| "syntax error")) - -(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|) - (PROGN - (|shoeConsole| - (CONCAT "ignored from line " (WRITE-TO-STRING (|lineNo| |pos1|)))) - (|shoeConsole| (|lineString| |pos1|)) - (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|")) - (|shoeConsole| - (CONCAT "ignored through line " (WRITE-TO-STRING (|lineNo| |pos2|)))) - (|shoeConsole| (|lineString| |pos2|)) - (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|")))) - (DEFSTRUCT (|%SourceLine| (:COPIER |copy%SourceLine|)) |str| |num|) (DEFMACRO |mk%SourceLine| (|str| |num|) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index 105fe06f..c8fd9105 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -13,11 +13,12 @@ |toks| |trees| |pren| - |scp|) + |scp| + |cur|) -(DEFMACRO |mk%ParserState| (|toks| |trees| |pren| |scp|) +(DEFMACRO |mk%ParserState| (|toks| |trees| |pren| |scp| |cur|) (LIST '|MAKE-%ParserState| :|toks| |toks| :|trees| |trees| :|pren| |pren| - :|scp| |scp|)) + :|scp| |scp| :|cur| |cur|)) (DEFMACRO |parserTokens| (|bfVar#1|) (LIST '|%ParserState-toks| |bfVar#1|)) @@ -27,7 +28,18 @@ (DEFMACRO |parserScope| (|bfVar#1|) (LIST '|%ParserState-scp| |bfVar#1|)) -(DEFUN |makeParserState| (|toks|) (|mk%ParserState| |toks| NIL 0 0)) +(DEFMACRO |parserCurrentToken| (|bfVar#1|) (LIST '|%ParserState-cur| |bfVar#1|)) + +(DEFUN |makeParserState| (|toks|) (|mk%ParserState| |toks| NIL 0 0 NIL)) + +(DEFMACRO |parserTokenValue| (|ps|) + (LIST '|tokenValue| (LIST '|parserCurrentToken| |ps|))) + +(DEFMACRO |parserTokenClass| (|ps|) + (LIST '|tokenClass| (LIST '|parserCurrentToken| |ps|))) + +(DEFMACRO |parserTokenPosition| (|ps|) + (LIST '|tokenPosition| (LIST '|parserCurrentToken| |ps|))) (DEFSTRUCT (|%Translator| (:COPIER |copy%Translator|)) |ipath| @@ -54,27 +66,27 @@ (DEFUN |makeTranslator| (|ip|) (|mk%Translator| |ip| NIL NIL NIL NIL)) (DEFUN |bpFirstToken| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$ttok|)) (PROGN - (SETQ |$stok| + (SETF (|parserCurrentToken| |ps|) (COND ((NULL (|parserTokens| |ps|)) - (|mk%Token| 'ERROR 'NOMORE (|tokenPosition| |$stok|))) + (|mk%Token| 'ERROR 'NOMORE (|parserTokenPosition| |ps|))) (T (CAR (|parserTokens| |ps|))))) - (SETQ |$ttok| (|tokenValue| |$stok|)) + (SETQ |$ttok| (|parserTokenValue| |ps|)) T)) (DEFUN |bpFirstTok| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$ttok|)) (PROGN - (SETQ |$stok| + (SETF (|parserCurrentToken| |ps|) (COND ((NULL (|parserTokens| |ps|)) - (|mk%Token| 'ERROR 'NOMORE (|tokenPosition| |$stok|))) + (|mk%Token| 'ERROR 'NOMORE (|parserTokenPosition| |ps|))) (T (CAR (|parserTokens| |ps|))))) - (SETQ |$ttok| (|tokenValue| |$stok|)) + (SETQ |$ttok| (|parserTokenValue| |ps|)) (COND - ((AND (PLUSP (|parserNesting| |ps|)) (EQ (|tokenClass| |$stok|) 'KEY)) + ((AND (PLUSP (|parserNesting| |ps|)) (EQ (|parserTokenClass| |ps|) 'KEY)) (COND ((EQ |$ttok| 'SETTAB) (SETF (|parserScope| |ps|) (+ (|parserScope| |ps|) 1)) (|bpNext| |ps|)) @@ -138,65 +150,63 @@ (DEFUN |bpIndentParenthesized| (|ps| |f|) (LET* (|a| |scope|) - (DECLARE (SPECIAL |$stok|)) (PROGN (SETQ |scope| (|parserScope| |ps|)) (UNWIND-PROTECT (PROGN (SETF (|parserScope| |ps|) 0) - (SETQ |a| |$stok|) + (SETQ |a| (|parserCurrentToken| |ps|)) (COND ((|bpEqPeek| |ps| 'OPAREN) (SETF (|parserNesting| |ps|) (+ (|parserNesting| |ps|) 1)) (|bpNext| |ps|) (COND ((AND (APPLY |f| |ps| NIL) (|bpFirstTok| |ps|) - (OR (|bpEqPeek| |ps| 'CPAREN) (|bpParenTrap| |a|))) + (OR (|bpEqPeek| |ps| 'CPAREN) (|bpParenTrap| |ps| |a|))) (SETF (|parserNesting| |ps|) (- (|parserNesting| |ps|) 1)) (|bpNextToken| |ps|) (COND ((EQL (|parserScope| |ps|) 0) T) (T (SETF (|parserTokens| |ps|) - (|append| (|bpAddTokens| (|parserScope| |ps|)) - (|parserTokens| |ps|))) + (|append| + (|bpAddTokens| |ps| (|parserScope| |ps|)) + (|parserTokens| |ps|))) (|bpFirstToken| |ps|) (COND ((EQL (|parserNesting| |ps|) 0) (|bpCancel| |ps|) T) (T T))))) ((|bpEqPeek| |ps| 'CPAREN) (|bpPush| |ps| (|bfTuple| NIL)) (SETF (|parserNesting| |ps|) (- (|parserNesting| |ps|) 1)) (|bpNextToken| |ps|) T) - (T (|bpParenTrap| |a|)))) + (T (|bpParenTrap| |ps| |a|)))) (T NIL))) (SETF (|parserScope| |ps|) |scope|))))) (DEFUN |bpParenthesized| (|ps| |f|) (LET* (|a|) - (DECLARE (SPECIAL |$stok|)) (PROGN - (SETQ |a| |$stok|) + (SETQ |a| (|parserCurrentToken| |ps|)) (COND ((|bpEqKey| |ps| 'OPAREN) (COND ((AND (APPLY |f| |ps| NIL) - (OR (|bpEqKey| |ps| 'CPAREN) (|bpParenTrap| |a|))) + (OR (|bpEqKey| |ps| 'CPAREN) (|bpParenTrap| |ps| |a|))) T) ((|bpEqKey| |ps| 'CPAREN) (|bpPush| |ps| (|bfTuple| NIL)) T) - (T (|bpParenTrap| |a|)))) + (T (|bpParenTrap| |ps| |a|)))) (T NIL))))) (DEFUN |bpBracket| (|ps| |f|) (LET* (|a|) - (DECLARE (SPECIAL |$stok|)) (PROGN - (SETQ |a| |$stok|) + (SETQ |a| (|parserCurrentToken| |ps|)) (COND ((|bpEqKey| |ps| 'OBRACK) (COND ((AND (APPLY |f| |ps| NIL) - (OR (|bpEqKey| |ps| 'CBRACK) (|bpBrackTrap| |a|))) + (OR (|bpEqKey| |ps| 'CBRACK) (|bpBrackTrap| |ps| |a|))) (|bpPush| |ps| (|bfBracket| (|bpPop1| |ps|)))) ((|bpEqKey| |ps| 'CBRACK) (|bpPush| |ps| NIL)) - (T (|bpBrackTrap| |a|)))) + (T (|bpBrackTrap| |ps| |a|)))) (T NIL))))) (DEFUN |bpPileBracketed| (|ps| |f|) @@ -204,7 +214,7 @@ ((|bpEqKey| |ps| 'SETTAB) (COND ((|bpEqKey| |ps| 'BACKTAB) T) ((AND (APPLY |f| |ps| NIL) - (OR (|bpEqKey| |ps| 'BACKTAB) (|bpPileTrap|))) + (OR (|bpEqKey| |ps| 'BACKTAB) (|bpPileTrap| |ps|))) (|bpPush| |ps| (|bfPile| (|bpPop1| |ps|)))) (T NIL))) (T NIL))) @@ -298,9 +308,9 @@ ((|bpEqKey| |ps| 'THEN) (AND (|bpRequire| |ps| |f|) (|bpElse| |ps| |f|) (|bpEqKey| |ps| 'BACKTAB))) - (T (|bpMissing| 'THEN)))) + (T (|bpMissing| |ps| 'THEN)))) ((|bpEqKey| |ps| 'THEN) (AND (|bpRequire| |ps| |f|) (|bpElse| |ps| |f|))) - (T (|bpMissing| '|then|)))) + (T (|bpMissing| |ps| '|then|)))) (T NIL))) (DEFUN |bpElse| (|ps| |f|) @@ -321,50 +331,71 @@ (T (|bpEqKey| |ps| 'ELSE)))) (DEFUN |bpEqPeek| (|ps| |s|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|))) + (DECLARE (SPECIAL |$ttok|)) + (AND (EQ (|parserTokenClass| |ps|) 'KEY) (EQ |s| |$ttok|))) (DEFUN |bpEqKey| (|ps| |s|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNext| |ps|))) + (DECLARE (SPECIAL |$ttok|)) + (AND (EQ (|parserTokenClass| |ps|) 'KEY) (EQ |s| |$ttok|) (|bpNext| |ps|))) (DEFUN |bpEqKeyNextTok| (|ps| |s|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNextToken| |ps|))) + (DECLARE (SPECIAL |$ttok|)) + (AND (EQ (|parserTokenClass| |ps|) 'KEY) (EQ |s| |$ttok|) + (|bpNextToken| |ps|))) + +(DEFUN |bpPileTrap| (|ps|) (|bpMissing| |ps| 'BACKTAB)) + +(DEFUN |bpBrackTrap| (|ps| |x|) (|bpMissingMate| |ps| '] |x|)) -(DEFUN |bpPileTrap| () (|bpMissing| 'BACKTAB)) +(DEFUN |bpParenTrap| (|ps| |x|) (|bpMissingMate| |ps| '|)| |x|)) -(DEFUN |bpBrackTrap| (|x|) (|bpMissingMate| '] |x|)) +(DEFUN |bpSpecificErrorHere| (|ps| |key|) + (|bpSpecificErrorAtToken| (|parserCurrentToken| |ps|) |key|)) -(DEFUN |bpParenTrap| (|x|) (|bpMissingMate| '|)| |x|)) +(DEFUN |bpSpecificErrorAtToken| (|tok| |key|) + (LET* (|a|) + (PROGN (SETQ |a| (|tokenPosition| |tok|)) (|SoftShoeError| |a| |key|)))) + +(DEFUN |bpGeneralErrorHere| (|ps|) (|bpSpecificErrorHere| |ps| "syntax error")) -(DEFUN |bpMissingMate| (|close| |open|) +(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|) + (PROGN + (|shoeConsole| + (CONCAT "ignored from line " (WRITE-TO-STRING (|lineNo| |pos1|)))) + (|shoeConsole| (|lineString| |pos1|)) + (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|")) + (|shoeConsole| + (CONCAT "ignored through line " (WRITE-TO-STRING (|lineNo| |pos2|)))) + (|shoeConsole| (|lineString| |pos2|)) + (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|")))) + +(DEFUN |bpMissingMate| (|ps| |close| |open|) (PROGN (|bpSpecificErrorAtToken| |open| "possibly missing mate") - (|bpMissing| |close|))) + (|bpMissing| |ps| |close|))) -(DEFUN |bpMissing| (|s|) +(DEFUN |bpMissing| (|ps| |s|) (PROGN - (|bpSpecificErrorHere| (CONCAT (PNAME |s|) " possibly missing")) + (|bpSpecificErrorHere| |ps| (CONCAT (PNAME |s|) " possibly missing")) (THROW :OPEN-AXIOM-CATCH-POINT (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootParserException|) 'TRAPPED))))) -(DEFUN |bpCompMissing| (|ps| |s|) (OR (|bpEqKey| |ps| |s|) (|bpMissing| |s|))) +(DEFUN |bpCompMissing| (|ps| |s|) + (OR (|bpEqKey| |ps| |s|) (|bpMissing| |ps| |s|))) (DEFUN |bpTrap| (|ps|) (PROGN - (|bpGeneralErrorHere|) + (|bpGeneralErrorHere| |ps|) (THROW :OPEN-AXIOM-CATCH-POINT (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootParserException|) 'TRAPPED))))) (DEFUN |bpRecoverTrap| (|ps|) (LET* (|pos2| |pos1|) - (DECLARE (SPECIAL |$stok|)) (PROGN (|bpFirstToken| |ps|) - (SETQ |pos1| (|tokenPosition| |$stok|)) + (SETQ |pos1| (|parserTokenPosition| |ps|)) (|bpMoveTo| |ps| 0) - (SETQ |pos2| (|tokenPosition| |$stok|)) + (SETQ |pos2| (|parserTokenPosition| |ps|)) (|bpIgnoredFromTo| |pos1| |pos2|) (|bpPush| |ps| (LIST (LIST "pile syntax error")))))) @@ -396,13 +427,13 @@ ((EQ |found| 'TRAPPED) (SETF (|parserTokens| |ps|) |c|) (|bpRecoverTrap| |ps|)) ((NOT |found|) (SETF (|parserTokens| |ps|) |c|) - (|bpGeneralErrorHere|) (|bpRecoverTrap| |ps|))) + (|bpGeneralErrorHere| |ps|) (|bpRecoverTrap| |ps|))) (COND ((|bpEqKey| |ps| 'BACKSET) (SETQ |c| (|parserTokens| |ps|))) ((OR (|bpEqPeek| |ps| 'BACKTAB) (NULL (|parserTokens| |ps|))) (SETQ |done| T)) - (T (SETF (|parserTokens| |ps|) |c|) (|bpGeneralErrorHere|) - (|bpRecoverTrap| |ps|) + (T (SETF (|parserTokens| |ps|) |c|) + (|bpGeneralErrorHere| |ps|) (|bpRecoverTrap| |ps|) (COND ((OR (|bpEqPeek| |ps| 'BACKTAB) (NULL (|parserTokens| |ps|))) @@ -432,30 +463,28 @@ (T (|bpNextToken| |ps|) (|bpMoveTo| |ps| |n|)))) (DEFUN |bpQualifiedName| (|ps|) - (DECLARE (SPECIAL |$stok|)) (COND ((|bpEqPeek| |ps| 'COLON-COLON) (|bpNext| |ps|) - (AND (EQ (|tokenClass| |$stok|) 'ID) (|bpPushId| |ps|) (|bpNext| |ps|) + (AND (EQ (|parserTokenClass| |ps|) 'ID) (|bpPushId| |ps|) (|bpNext| |ps|) (|bpPush| |ps| (|bfColonColon| (|bpPop2| |ps|) (|bpPop1| |ps|))))) (T NIL))) (DEFUN |bpName| (|ps|) - (DECLARE (SPECIAL |$stok|)) (COND - ((EQ (|tokenClass| |$stok|) 'ID) (|bpPushId| |ps|) (|bpNext| |ps|) + ((EQ (|parserTokenClass| |ps|) 'ID) (|bpPushId| |ps|) (|bpNext| |ps|) (|bpAnyNo| |ps| #'|bpQualifiedName|)) (T NIL))) (DEFUN |bpConstTok| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$ttok|)) (COND - ((|symbolMember?| (|tokenClass| |$stok|) '(INTEGER FLOAT)) + ((|symbolMember?| (|parserTokenClass| |ps|) '(INTEGER FLOAT)) (|bpPush| |ps| |$ttok|) (|bpNext| |ps|)) - ((EQ (|tokenClass| |$stok|) 'LISP) + ((EQ (|parserTokenClass| |ps|) 'LISP) (AND (|bpPush| |ps| (|%Lisp| |$ttok|)) (|bpNext| |ps|))) - ((EQ (|tokenClass| |$stok|) 'LISPEXP) + ((EQ (|parserTokenClass| |ps|) 'LISPEXP) (AND (|bpPush| |ps| |$ttok|) (|bpNext| |ps|))) - ((EQ (|tokenClass| |$stok|) 'LINE) + ((EQ (|parserTokenClass| |ps|) 'LINE) (AND (|bpPush| |ps| (LIST '+LINE |$ttok|)) (|bpNext| |ps|))) ((|bpEqPeek| |ps| 'QUOTE) (|bpNext| |ps|) (AND (|bpRequire| |ps| #'|bpSexp|) @@ -464,9 +493,9 @@ (DEFUN |bpChar| (|ps|) (LET* (|ISTMP#1| |s| |a|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$ttok|)) (COND - ((AND (EQ (|tokenClass| |$stok|) 'ID) (EQ |$ttok| '|char|)) + ((AND (EQ (|parserTokenClass| |ps|) 'ID) (EQ |$ttok| '|char|)) (SETQ |a| (|bpState| |ps|)) (COND ((|bpApplication| |ps|) (SETQ |s| (|bpPop1| |ps|)) @@ -587,15 +616,14 @@ ((|bpEqKeyNextTok| |ps| 'BACKTAB) T) (T (|bpRestore| |ps| |a|) NIL))) (T NIL))))) -(DEFUN |bpAddTokens| (|n|) - (DECLARE (SPECIAL |$stok|)) +(DEFUN |bpAddTokens| (|ps| |n|) (COND ((EQL |n| 0) NIL) ((PLUSP |n|) - (CONS (|mk%Token| 'KEY 'SETTAB (|tokenPosition| |$stok|)) - (|bpAddTokens| (- |n| 1)))) + (CONS (|mk%Token| 'KEY 'SETTAB (|parserTokenPosition| |ps|)) + (|bpAddTokens| |ps| (- |n| 1)))) (T - (CONS (|mk%Token| 'KEY 'BACKTAB (|tokenPosition| |$stok|)) - (|bpAddTokens| (+ |n| 1)))))) + (CONS (|mk%Token| 'KEY 'BACKTAB (|parserTokenPosition| |ps|)) + (|bpAddTokens| |ps| (+ |n| 1)))))) (DEFUN |bpExceptions| (|ps|) (OR (|bpEqPeek| |ps| 'DOT) (|bpEqPeek| |ps| 'QUOTE) (|bpEqPeek| |ps| 'OPAREN) @@ -604,9 +632,9 @@ (DEFUN |bpSexpKey| (|ps|) (LET* (|a|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$ttok|)) (COND - ((AND (EQ (|tokenClass| |$stok|) 'KEY) (NOT (|bpExceptions| |ps|))) + ((AND (EQ (|parserTokenClass| |ps|) 'KEY) (NOT (|bpExceptions| |ps|))) (SETQ |a| (GET |$ttok| 'SHOEINF)) (COND ((NULL |a|) (AND (|bpPush| |ps| (|keywordId| |$ttok|)) (|bpNext| |ps|))) @@ -614,13 +642,13 @@ (T NIL)))) (DEFUN |bpAnyId| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$ttok|)) (OR (AND (|bpEqKey| |ps| 'MINUS) - (OR (EQ (|tokenClass| |$stok|) 'INTEGER) (|bpTrap| |ps|)) + (OR (EQ (|parserTokenClass| |ps|) 'INTEGER) (|bpTrap| |ps|)) (|bpPush| |ps| (- |$ttok|)) (|bpNext| |ps|)) (|bpSexpKey| |ps|) - (AND (|symbolMember?| (|tokenClass| |$stok|) '(ID INTEGER STRING FLOAT)) + (AND (|symbolMember?| (|parserTokenClass| |ps|) '(ID INTEGER STRING FLOAT)) (|bpPush| |ps| |$ttok|) (|bpNext| |ps|)))) (DEFUN |bpSexp| (|ps|) @@ -657,13 +685,13 @@ (DEFUN |bpDot| (|ps|) (AND (|bpEqKey| |ps| 'DOT) (|bpPush| |ps| (|bfDot|)))) (DEFUN |bpPrefixOperator| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE) + (DECLARE (SPECIAL |$ttok|)) + (AND (EQ (|parserTokenClass| |ps|) 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId| |ps|) (|bpNext| |ps|))) (DEFUN |bpInfixOperator| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEINF) + (DECLARE (SPECIAL |$ttok|)) + (AND (EQ (|parserTokenClass| |ps|) 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId| |ps|) (|bpNext| |ps|))) (DEFUN |bpSelector| (|ps|) @@ -705,8 +733,8 @@ (DEFUN |bpExpt| (|ps|) (|bpRightAssoc| |ps| '(POWER) #'|bpTyped|)) (DEFUN |bpInfKey| (|ps| |s|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'KEY) (|symbolMember?| |$ttok| |s|) + (DECLARE (SPECIAL |$ttok|)) + (AND (EQ (|parserTokenClass| |ps|) 'KEY) (|symbolMember?| |$ttok| |s|) (|bpPushId| |ps|) (|bpNext| |ps|))) (DEFUN |bpInfGeneric| (|ps| |s|) @@ -747,8 +775,8 @@ (T NIL))) (DEFUN |bpString| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'STRING) + (DECLARE (SPECIAL |$ttok|)) + (AND (EQ (|parserTokenClass| |ps|) 'STRING) (|bpPush| |ps| (|quote| (INTERN |$ttok|))) (|bpNext| |ps|))) (DEFUN |bpFunction| (|ps|) @@ -756,9 +784,9 @@ (|bpPush| |ps| (|bfFunction| (|bpPop1| |ps|))))) (DEFUN |bpThetaName| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) + (DECLARE (SPECIAL |$ttok|)) (COND - ((AND (EQ (|tokenClass| |$stok|) 'ID) (GET |$ttok| 'SHOETHETA)) + ((AND (EQ (|parserTokenClass| |ps|) 'ID) (GET |$ttok| 'SHOETHETA)) (|bpPushId| |ps|) (|bpNext| |ps|)) (T NIL))) @@ -856,12 +884,11 @@ (DEFUN |bpExceptionVariable| (|ps|) (LET* (|t|) - (DECLARE (SPECIAL |$stok|)) (PROGN - (SETQ |t| |$stok|) + (SETQ |t| (|parserCurrentToken| |ps|)) (OR (AND (|bpEqKey| |ps| 'OPAREN) (|bpRequire| |ps| #'|bpSignature|) - (OR (|bpEqKey| |ps| 'CPAREN) (|bpMissing| |t|))) + (OR (|bpEqKey| |ps| 'CPAREN) (|bpMissing| |ps| |t|))) (|bpTrap| |ps|))))) (DEFUN |bpFinally| (|ps|) @@ -1199,8 +1226,8 @@ (|bpBracketConstruct| |ps| #'|bpPatternL|))) (DEFUN |bpBVString| (|ps|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'STRING) + (DECLARE (SPECIAL |$ttok|)) + (AND (EQ (|parserTokenClass| |ps|) 'STRING) (|bpPush| |ps| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext| |ps|))) (DEFUN |bpRegularBVItemL| (|ps|) @@ -1327,7 +1354,8 @@ (DEFUN |bpCase| (|ps|) (AND (|bpEqKey| |ps| 'CASE) (|bpRequire| |ps| #'|bpWhere|) - (OR (|bpEqKey| |ps| 'OF) (|bpMissing| 'OF)) (|bpPiledCaseItems| |ps|))) + (OR (|bpEqKey| |ps| 'OF) (|bpMissing| |ps| 'OF)) + (|bpPiledCaseItems| |ps|))) (DEFUN |bpPiledCaseItems| (|ps|) (AND (|bpPileBracketed| |ps| #'|bpCaseItemList|) @@ -1358,7 +1386,7 @@ (COND ((EQUAL (CAR #2=(CDR #1#)) '(|BootSpecificError|)) (LET ((|e| (CDR #2#))) - (PROGN (|bpSpecificErrorHere| |e|) (|bpTrap| |ps|)))) + (PROGN (|bpSpecificErrorHere| |ps| |e|) (|bpTrap| |ps|)))) (T (THROW :OPEN-AXIOM-CATCH-POINT #1#)))) (T #1#))) (SETQ |b| (|bpPop1| |ps|)) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index c7567e89..99469d72 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -433,11 +433,9 @@ (DEFUN |shoeOutParse| (|toks|) (LET* (|found| |ps|) - (DECLARE - (SPECIAL |$returns| |$typings| |$wheredefs| |$op| |$ttok| |$stok|)) + (DECLARE (SPECIAL |$returns| |$typings| |$wheredefs| |$op| |$ttok|)) (PROGN (SETQ |ps| (|makeParserState| |toks|)) - (SETQ |$stok| NIL) (SETQ |$ttok| NIL) (SETQ |$op| NIL) (SETQ |$wheredefs| NIL) diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 9079167f..35eb7761 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -356,7 +356,6 @@ shoeAddComment l== shoeOutParse toks == ps := makeParserState toks - $stok := nil $ttok := nil $op :=nil $wheredefs := [] |