aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog5
-rw-r--r--src/boot/includer.boot18
-rw-r--r--src/boot/parser.boot161
-rw-r--r--src/boot/strap/includer.clisp21
-rw-r--r--src/boot/strap/parser.clisp208
-rw-r--r--src/boot/strap/translator.clisp4
-rw-r--r--src/boot/translator.boot1
7 files changed, 220 insertions, 198 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index fff7015d..742c67d0 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,10 @@
2012-05-30 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * boot/parser.boot (%ParserState): Add field for current token.
+ Replace references to $stok.
+
+2012-05-30 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* boot/ast.boot (bfSpecificErrorHere): New.
(bfISReverse) Use it. Don't use bpTrap.
(bfIS1): Likewise.
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 := []