diff options
| -rw-r--r-- | src/ChangeLog | 10 | ||||
| -rw-r--r-- | src/boot/ast.boot | 15 | ||||
| -rw-r--r-- | src/boot/parser.boot | 117 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 14 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 126 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 3 | ||||
| -rw-r--r-- | src/boot/translator.boot | 2 |
7 files changed, 160 insertions, 127 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index a0b0ff8b..fff7015d 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,15 @@ 2012-05-30 Gabriel Dos Reis <gdr@cs.tamu.edu> + * boot/ast.boot (bfSpecificErrorHere): New. + (bfISReverse) Use it. Don't use bpTrap. + (bfIS1): Likewise. + (bfParameterList): Likewise. + (bfHandlers): Likewise. + * boot/parser.boot (bpTrap): Take a parser state argument. + Adjust callers. + +2012-05-30 Gabriel Dos Reis <gdr@cs.tamu.edu> + * boot/parser.boot: Remove references to $bpCount. * boot/translator.boot (shoeOutParse): Likewise. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 6fef514a..4a84bf87 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -123,6 +123,9 @@ $inDefIS := false quote x == ['QUOTE,x] +bfSpecificErrorHere msg == + throw msg : BootSpecificError + --% bfGenSymbol: () -> %Symbol @@ -721,8 +724,7 @@ bfISReverse(x,a) == y := bfISReverse(third x, nil) y.rest.rest.first := ['CONS,second x,a] y - bpSpecificErrorHere '"Error in bfISReverse" - bpTrap() + bfSpecificErrorHere '"Error in bfISReverse" bfIS1(lhs,rhs) == rhs = nil => ['NULL,lhs] @@ -768,13 +770,12 @@ bfIS1(lhs,rhs) == l2 := [l2,:nil] a is "DOT" => bfAND [rev,:l2] bfAND [rev,:l2,['PROGN,bfLetForm(a,['reverse!,a]),'T]] - bpSpecificErrorHere '"bad IS code is generated" - bpTrap() + bfSpecificErrorHere '"bad IS code is generated" bfHas(expr,prop) == symbol? prop => ["GET",expr, quote prop] - bpSpecificErrorHere('"expected identifier as property name") + bfSpecificErrorHere('"expected identifier as property name") bfKeyArg(k,x) == ['%Key,k,x] @@ -969,7 +970,7 @@ shoeComp x== bfParameterList(p1,p2) == p2=nil and p1 is [.,:.] => p1 p1 is ["&OPTIONAL",:.] => - p2 isnt ["&OPTIONAL",:.] => bpSpecificErrorHere '"default value required" + p2 isnt ["&OPTIONAL",:.] => bfSpecificErrorHere '"default value required" [first p1,:rest p1,:rest p2] p2 is ["&OPTIONAL",:.] => [p1,first p2,:rest p2] [p1,:p2] @@ -1367,7 +1368,7 @@ bfHandlers(n,e,hs) == main(n,e,hs,nil) where symbol? t => quote [t] -- instantiate niladic type ctor quote t main(n,e,hs',[[bfQ(["CAR",e],t),["LET",[[v,["CDR",e]]],s]],:xs]) - bpTrap() + bfSpecificErrorHere '"invalid handler message" codeForCatchHandlers(g,e,cs) == ehTest := ['AND,['CONSP,g], diff --git a/src/boot/parser.boot b/src/boot/parser.boot index 7ec02edf..ccf73528 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -111,7 +111,7 @@ bpNextToken ps == bpFirstToken ps bpRequire(ps,f) == - apply(f,ps,nil) or bpTrap() + apply(f,ps,nil) or bpTrap ps bpState ps == [parserTokens ps,parserTrees ps,parserNesting ps,parserScope ps] @@ -151,11 +151,11 @@ bpIndentParenthesized(ps,f) == try parserScope(ps) := 0 a:=$stok - bpEqPeek "OPAREN" => + bpEqPeek(ps,"OPAREN") => parserNesting(ps) := parserNesting ps + 1 bpNext ps apply(f,ps,nil) and bpFirstTok ps and - (bpEqPeek "CPAREN" or bpParenTrap(a)) => + (bpEqPeek(ps,"CPAREN") or bpParenTrap(a)) => parserNesting(ps) := parserNesting ps - 1 bpNextToken ps parserScope ps = 0 => true @@ -165,7 +165,7 @@ bpIndentParenthesized(ps,f) == bpCancel ps true true - bpEqPeek "CPAREN" => + bpEqPeek(ps,"CPAREN") => bpPush(ps,bfTuple []) parserNesting(ps) := parserNesting ps - 1 bpNextToken ps @@ -279,7 +279,7 @@ bpBacksetElse ps == bpEqKey(ps,"BACKSET") => bpEqKey(ps,"ELSE") bpEqKey(ps,"ELSE") -bpEqPeek s == +bpEqPeek(ps,s) == tokenClass $stok = "KEY" and symbolEq?(s,$ttok) bpEqKey(ps,s) == @@ -303,7 +303,7 @@ bpMissing s== bpCompMissing(ps,s) == bpEqKey(ps,s) or bpMissing s -bpTrap()== +bpTrap ps == bpGeneralErrorHere() throw 'TRAPPED : BootParserException @@ -337,14 +337,14 @@ bpListAndRecover(ps,f)== if bpEqKey(ps,"BACKSET") then c := parserTokens ps - else if bpEqPeek "BACKTAB" or parserTokens ps = nil + else if bpEqPeek(ps,"BACKTAB") or parserTokens ps = nil then done := true else parserTokens(ps) := c bpGeneralErrorHere() bpRecoverTrap ps - if bpEqPeek "BACKTAB" or parserTokens ps = nil + if bpEqPeek(ps,"BACKTAB") or parserTokens ps = nil then done:=true else bpNext ps @@ -355,23 +355,23 @@ bpListAndRecover(ps,f)== bpMoveTo(ps,n) == parserTokens ps = nil => true - bpEqPeek "BACKTAB" => + bpEqPeek(ps,"BACKTAB") => n=0 => true bpNextToken ps parserScope(ps) := parserScope ps - 1 bpMoveTo(ps,n-1) - bpEqPeek "BACKSET" => + bpEqPeek(ps,"BACKSET") => n=0 => true bpNextToken ps bpMoveTo(ps,n) - bpEqPeek "SETTAB" => + bpEqPeek(ps,"SETTAB") => bpNextToken ps bpMoveTo(ps,n+1) - bpEqPeek "OPAREN" => + bpEqPeek(ps,"OPAREN") => bpNextToken ps parserNesting(ps) := parserNesting(ps) + 1 bpMoveTo(ps,n) - bpEqPeek "CPAREN" => + bpEqPeek(ps,"CPAREN") => bpNextToken ps parserNesting(ps) := parserNesting ps - 1 bpMoveTo(ps,n) @@ -387,7 +387,7 @@ bpMoveTo(ps,n) == -- reduced a '::' and a name, or nothing. In either case, a -- symbol is present on the stack. bpQualifiedName ps == - bpEqPeek "COLON-COLON" => + bpEqPeek(ps,"COLON-COLON") => bpNext ps tokenClass $stok = "ID" and bpPushId ps and bpNext ps and bpPush(ps,bfColonColon(bpPop2 ps, bpPop1 ps)) @@ -418,7 +418,7 @@ bpConstTok 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 - bpEqPeek "QUOTE" => + bpEqPeek(ps,"QUOTE") => bpNext ps bpRequire(ps,function bpSexp) and bpPush(ps,bfSymbol bpPop1 ps) @@ -448,10 +448,10 @@ bpExportItemTail ps == ++ Signature := Where ++ Signature == Where bpExportItem ps == - bpEqPeek "STRUCTURE" => bpStruct ps + bpEqPeek(ps,"STRUCTURE") => bpStruct ps a := bpState ps bpName ps => - bpEqPeek "COLON" => + bpEqPeek(ps,"COLON") => bpRestore(ps,a) bpRequire(ps,function bpSignature) bpExportItemTail ps or true @@ -471,7 +471,7 @@ bpModuleInterface ps == bpEqKey(ps,"WHERE") => bpPileBracketed(ps,function bpExportItemList) or (bpExportItem ps and bpPush(ps,[bpPop1 ps])) - or bpTrap() + or bpTrap ps bpPush(ps,nil) ++ ModuleExports: @@ -501,13 +501,13 @@ bpImport ps == bpEqKey(ps,"NAMESPACE") => bpLeftAssoc(ps,'(DOT),function bpName) and bpPush(ps,%Import bfNamespace bpPop1 ps) - or bpTrap() + or bpTrap ps a := bpState ps bpRequire(ps,function bpName) - bpEqPeek "COLON" => + bpEqPeek(ps,"COLON") => bpRestore(ps,a) bpRequire(ps,function bpSignature) and - (bpEqKey(ps,"FOR") or bpTrap()) and + (bpEqKey(ps,"FOR") or bpTrap ps) and bpRequire(ps,function bpName) and bpPush(ps,%ImportSignature(bpPop1 ps, bpPop1 ps)) bpPush(ps,%Import bpPop1 ps) @@ -524,7 +524,7 @@ bpNamespace ps == -- type-alias-definition: -- identifier <=> logical-expression bpTypeAliasDefition ps == - (bpTerm(ps,function bpIdList) or bpTrap()) and + (bpTerm(ps,function bpIdList) or bpTrap ps) and bpEqKey(ps,"TDEF") and bpLogical ps and bpPush(ps,%TypeAlias(bpPop2 ps, bpPop1 ps)) @@ -578,22 +578,22 @@ bpAddTokens n== n>0=> [mk%Token("KEY","SETTAB",tokenPosition $stok),:bpAddTokens(n-1)] [mk%Token("KEY","BACKTAB",tokenPosition $stok),:bpAddTokens(n+1)] -bpExceptions()== - bpEqPeek "DOT" or bpEqPeek "QUOTE" or - bpEqPeek "OPAREN" or bpEqPeek "CPAREN" or - bpEqPeek "SETTAB" or bpEqPeek "BACKTAB" - or bpEqPeek "BACKSET" +bpExceptions ps == + bpEqPeek(ps,"DOT") or bpEqPeek(ps,"QUOTE") or + bpEqPeek(ps,"OPAREN") or bpEqPeek(ps,"CPAREN") or + bpEqPeek(ps,"SETTAB") or bpEqPeek(ps,"BACKTAB") + or bpEqPeek(ps,"BACKSET") bpSexpKey ps == - tokenClass $stok = "KEY" and not bpExceptions() => + tokenClass $stok = "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()) and + 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) @@ -660,7 +660,7 @@ bpApplication ps== bpTyping ps == bpEqKey(ps,"FORALL") => bpRequire(ps,function bpVariable) - (bpDot ps and bpPop1 ps) or bpTrap() + (bpDot ps and bpPop1 ps) or bpTrap ps bpRequire(ps,function bpTyping) bpPush(ps,%Forall(bpPop2 ps, bpPop1 ps)) bpMapping ps or bpSimpleMapping ps @@ -690,7 +690,7 @@ bpInfGeneric(ps,s) == bpRightAssoc(ps,o,p)== a := bpState ps apply(p,ps,nil) => - while bpInfGeneric(ps,o) and (bpRightAssoc(ps,o,p) or bpTrap()) repeat + while bpInfGeneric(ps,o) and (bpRightAssoc(ps,o,p) or bpTrap ps) repeat bpPush(ps,bfInfApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps)) true bpRestore(ps,a) @@ -724,7 +724,7 @@ bpReduceOperator ps == bpReduce ps == a := bpState ps bpReduceOperator ps and bpEqKey(ps,"SLASH") => - bpEqPeek "OBRACK" => + bpEqPeek(ps,"OBRACK") => bpRequire(ps,function bpDConstruct) and bpPush(ps,bfReduceCollect(bpPop2 ps,bpPop1 ps)) bpRequire(ps,function bpApplication) and @@ -789,13 +789,13 @@ bpTry ps == bpHandler(ps,"FINALLY") => bpFinally ps and bpPush(ps,bfTry(bpPop2 ps,reverse! [bpPop1 ps,:cs])) - cs = nil => bpTrap() -- missing handlers + cs = nil => bpTrap ps -- missing handlers bpPush(ps,bfTry(bpPop1 ps,reverse! cs)) nil bpCatchItem ps == bpRequire(ps,function bpExceptionVariable) and - (bpEqKey(ps,"EXIT") or bpTrap()) and + (bpEqKey(ps,"EXIT") or bpTrap ps) and bpRequire(ps,function bpAssign) and bpPush(ps,%Catch(bpPop2 ps,bpPop1 ps)) @@ -804,7 +804,7 @@ bpExceptionVariable ps == bpEqKey(ps,"OPAREN") and bpRequire(ps,function bpSignature) and (bpEqKey(ps,"CPAREN") or bpMissing t) - or bpTrap() + or bpTrap ps bpFinally ps == bpRequire(ps,function bpAssign) and @@ -853,7 +853,7 @@ bpLogical ps == bpExpression ps == bpEqKey(ps,"COLON") and (bpLogical ps and bpPush(ps,bfApplication ("COLON",bpPop1 ps)) - or bpTrap()) or bpLogical ps + or bpTrap ps) or bpLogical ps bpStatement ps == bpConditional(ps,function bpWhere) or bpLoop ps @@ -911,13 +911,13 @@ bpIterators ps == bpAssign ps == a := bpState ps bpStatement ps => - bpEqPeek "BEC" => + bpEqPeek(ps,"BEC") => bpRestore(ps,a) bpRequire(ps,function bpAssignment) - bpEqPeek "GIVES" => + bpEqPeek(ps,"GIVES") => bpRestore(ps,a) bpRequire(ps,function bpLambda) - bpEqPeek "LARROW" => + bpEqPeek(ps,"LARROW") => bpRestore(ps,a) bpRequire(ps,function bpKeyArg) true @@ -953,13 +953,13 @@ bpDefinition ps == bpEqKey(ps,"MACRO") => bpName ps and bpStoreName ps and bpCompoundDefinitionTail(ps,function %Macro) - or bpTrap() + or bpTrap ps a := bpState ps bpExit ps => - bpEqPeek "DEF" => + bpEqPeek(ps,"DEF") => bpRestore(ps,a) bpDef ps - bpEqPeek "TDEF" => + bpEqPeek(ps,"TDEF") => bpRestore(ps,a) bpTypeAliasDefition ps true @@ -1085,7 +1085,7 @@ bpPattern ps == bpEqual ps == bpEqKey(ps,"SHOEEQ") and (bpApplication ps or bpConstTok ps or - bpTrap()) and bpPush(ps,bfEqual bpPop1 ps) + bpTrap ps) and bpPush(ps,bfEqual bpPop1 ps) bpRegularPatternItem ps == bpEqual ps or @@ -1115,7 +1115,7 @@ bpPatternList ps == while (bpEqKey(ps,"COMMA") and (bpRegularPatternItemL ps or (bpPatternTail ps and bpPush(ps,append(bpPop2 ps,bpPop1 ps)) - or bpTrap();false) )) repeat + or bpTrap ps;false) )) repeat bpPush(ps,append(bpPop2 ps,bpPop1 ps)) true bpPatternTail ps @@ -1157,7 +1157,7 @@ bpRegularBVItemL ps == bpRegularBVItem ps and bpPush(ps,[bpPop1 ps]) bpColonName ps == - bpEqKey(ps,"COLON") and (bpName ps or bpBVString ps or bpTrap()) + bpEqKey(ps,"COLON") and (bpName ps or bpBVString ps or bpTrap ps) -- at most one colon at end @@ -1166,7 +1166,7 @@ bpBoundVariablelist ps == while (bpEqKey(ps,"COMMA") and (bpRegularBVItemL ps or (bpColonName ps and bpPush(ps,bfColonAppend(bpPop2 ps,bpPop1 ps)) - or bpTrap();false) )) repeat + or bpTrap ps;false) )) repeat bpPush(ps,append(bpPop2 ps,bpPop1 ps)) true bpColonName ps and bpPush(ps,bfColonAppend(nil,bpPop1 ps)) @@ -1187,9 +1187,9 @@ bpAssignLHS ps == bpRequire(ps,function bpApplication) bpPush(ps,bfLocal(bpPop2 ps,bpPop1 ps)) bpArgumentList ps and - (bpEqPeek "DOT" - or (bpEqPeek "BEC" and bpPush(ps,bfPlace bpPop1 ps)) - or bpTrap()) + (bpEqPeek(ps,"DOT") + or (bpEqPeek(ps,"BEC") and bpPush(ps,bfPlace bpPop1 ps)) + or bpTrap ps) bpEqKey(ps,"DOT") => -- field path bpList(ps,function bpPrimary,"DOT") and bpChecknull ps and @@ -1198,13 +1198,13 @@ bpAssignLHS ps == bpChecknull ps == a := bpPop1 ps - a = nil => bpTrap() + a = nil => bpTrap ps bpPush(ps,a) bpStruct ps == bpEqKey(ps,"STRUCTURE") and bpRequire(ps,function bpName) and - (bpEqKey(ps,"DEF") or bpTrap()) and + (bpEqKey(ps,"DEF") or bpTrap ps) and (bpRecord ps or bpTypeList ps) and bpPush(ps,%Structure(bpPop2 ps,bpPop1 ps)) @@ -1213,7 +1213,7 @@ bpStruct ps == bpRecord ps == s := bpState ps bpName ps and bpPop1 ps is "Record" => - (bpParenthesized(ps,function bpFieldList) or bpTrap()) and + (bpParenthesized(ps,function bpFieldList) or bpTrap ps) and bpGlobalAccessors ps and bpPush(ps,%Record(bfUntuple bpPop2 ps,bpPop1 ps)) bpRestore(ps,s) @@ -1227,7 +1227,7 @@ bpFieldList ps == bpGlobalAccessors ps == bpEqKey(ps,"WITH") => - bpPileBracketed(ps,function bpAccessorDefinitionList) or bpTrap() + bpPileBracketed(ps,function bpAccessorDefinitionList) or bpTrap ps bpPush(ps,nil) bpAccessorDefinitionList ps == @@ -1237,7 +1237,7 @@ bpAccessorDefinitionList ps == ++ Name DEF FieldSection bpAccessorDefinition ps == bpRequire(ps,function bpName) and - (bpEqKey(ps,"DEF") or bpTrap()) and + (bpEqKey(ps,"DEF") or bpTrap ps) and bpRequire(ps,function bpFieldSection) and bpPush(ps,%AccessorDef(bpPop2 ps,bpPop1 ps)) @@ -1289,8 +1289,8 @@ bpCasePatternVarList ps == bpTuple(ps,function bpCasePatternVar) bpCaseItem ps == - (bpTerm(ps,function bpCasePatternVarList) or bpTrap()) and - (bpEqKey(ps,"EXIT") or bpTrap()) and + (bpTerm(ps,function bpCasePatternVarList) or bpTrap ps) and + (bpEqKey(ps,"EXIT") or bpTrap ps) and bpRequire(ps,function bpWhere) and bpPush(ps,bfCaseItem(bpPop2 ps,bpPop1 ps)) @@ -1299,7 +1299,10 @@ bpCaseItem ps == bpOutItem ps == $op: local := nil $GenVarCounter: local := 0 - bpRequire(ps,function bpComma) + try bpRequire(ps,function bpComma) + catch(e: BootSpecificError) => + bpSpecificErrorHere e + bpTrap ps b := bpPop1 ps t := b is ["+LINE",:.] => [ b ] diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index ec55fefc..f00bb570 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -148,6 +148,10 @@ (DEFUN |quote| (|x|) (LIST 'QUOTE |x|)) +(DEFUN |bfSpecificErrorHere| (|msg|) + (THROW :OPEN-AXIOM-CATCH-POINT + (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootSpecificError|) |msg|)))) + (DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfGenSymbol|)) (DEFUN |bfGenSymbol| () @@ -1042,7 +1046,7 @@ (COND ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|)) (T (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) (RPLACA (CDR (CDR |y|)) (LIST 'CONS (CADR |x|) |a|)) |y|))) - (T (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|))))) + (T (|bfSpecificErrorHere| "Error in bfISReverse"))))) (DEFUN |bfIS1| (|lhs| |rhs|) (LET* (|l2| @@ -1152,11 +1156,11 @@ (LIST '|reverse!| |a|)) 'T) NIL))))))) - (T (|bpSpecificErrorHere| "bad IS code is generated") (|bpTrap|))))) + (T (|bfSpecificErrorHere| "bad IS code is generated"))))) (DEFUN |bfHas| (|expr| |prop|) (COND ((SYMBOLP |prop|) (LIST 'GET |expr| (|quote| |prop|))) - (T (|bpSpecificErrorHere| "expected identifier as property name")))) + (T (|bfSpecificErrorHere| "expected identifier as property name")))) (DEFUN |bfKeyArg| (|k| |x|) (LIST '|%Key| |k| |x|)) @@ -1579,7 +1583,7 @@ ((AND (CONSP |p1|) (EQ (CAR |p1|) '&OPTIONAL)) (COND ((NOT (AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL))) - (|bpSpecificErrorHere| "default value required")) + (|bfSpecificErrorHere| "default value required")) (T (CONS (CAR |p1|) (|append| (CDR |p1|) (CDR |p2|)))))) ((AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL)) (CONS |p1| (CONS (CAR |p2|) (CDR |p2|)))) @@ -2617,7 +2621,7 @@ (LIST 'LET (LIST (LIST |v| (LIST 'CDR |e|))) |s|)) |xs|))) - (T (|bpTrap|))))) + (T (|bfSpecificErrorHere| "invalid handler message"))))) (DEFUN |codeForCatchHandlers| (|g| |e| |cs|) (LET* (|ehTest|) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index 620207d2..105fe06f 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -93,7 +93,7 @@ (SETF (|parserTokens| |ps|) (CDR (|parserTokens| |ps|))) (|bpFirstToken| |ps|))) -(DEFUN |bpRequire| (|ps| |f|) (OR (APPLY |f| |ps| NIL) (|bpTrap|))) +(DEFUN |bpRequire| (|ps| |f|) (OR (APPLY |f| |ps| NIL) (|bpTrap| |ps|))) (DEFUN |bpState| (|ps|) (LIST (|parserTokens| |ps|) (|parserTrees| |ps|) (|parserNesting| |ps|) @@ -146,12 +146,12 @@ (SETF (|parserScope| |ps|) 0) (SETQ |a| |$stok|) (COND - ((|bpEqPeek| 'OPAREN) + ((|bpEqPeek| |ps| 'OPAREN) (SETF (|parserNesting| |ps|) (+ (|parserNesting| |ps|) 1)) (|bpNext| |ps|) (COND ((AND (APPLY |f| |ps| NIL) (|bpFirstTok| |ps|) - (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|))) + (OR (|bpEqPeek| |ps| 'CPAREN) (|bpParenTrap| |a|))) (SETF (|parserNesting| |ps|) (- (|parserNesting| |ps|) 1)) (|bpNextToken| |ps|) (COND ((EQL (|parserScope| |ps|) 0) T) @@ -162,7 +162,7 @@ (|bpFirstToken| |ps|) (COND ((EQL (|parserNesting| |ps|) 0) (|bpCancel| |ps|) T) (T T))))) - ((|bpEqPeek| 'CPAREN) (|bpPush| |ps| (|bfTuple| NIL)) + ((|bpEqPeek| |ps| 'CPAREN) (|bpPush| |ps| (|bfTuple| NIL)) (SETF (|parserNesting| |ps|) (- (|parserNesting| |ps|) 1)) (|bpNextToken| |ps|) T) (T (|bpParenTrap| |a|)))) @@ -320,7 +320,7 @@ (COND ((|bpEqKey| |ps| 'BACKSET) (|bpEqKey| |ps| 'ELSE)) (T (|bpEqKey| |ps| 'ELSE)))) -(DEFUN |bpEqPeek| (|s|) +(DEFUN |bpEqPeek| (|ps| |s|) (DECLARE (SPECIAL |$ttok| |$stok|)) (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|))) @@ -351,7 +351,7 @@ (DEFUN |bpCompMissing| (|ps| |s|) (OR (|bpEqKey| |ps| |s|) (|bpMissing| |s|))) -(DEFUN |bpTrap| () +(DEFUN |bpTrap| (|ps|) (PROGN (|bpGeneralErrorHere|) (THROW :OPEN-AXIOM-CATCH-POINT @@ -398,12 +398,14 @@ ((NOT |found|) (SETF (|parserTokens| |ps|) |c|) (|bpGeneralErrorHere|) (|bpRecoverTrap| |ps|))) (COND ((|bpEqKey| |ps| 'BACKSET) (SETQ |c| (|parserTokens| |ps|))) - ((OR (|bpEqPeek| 'BACKTAB) (NULL (|parserTokens| |ps|))) + ((OR (|bpEqPeek| |ps| 'BACKTAB) + (NULL (|parserTokens| |ps|))) (SETQ |done| T)) (T (SETF (|parserTokens| |ps|) |c|) (|bpGeneralErrorHere|) (|bpRecoverTrap| |ps|) (COND - ((OR (|bpEqPeek| 'BACKTAB) (NULL (|parserTokens| |ps|))) + ((OR (|bpEqPeek| |ps| 'BACKTAB) + (NULL (|parserTokens| |ps|))) (SETQ |done| T)) (T (|bpNext| |ps|) (SETQ |c| (|parserTokens| |ps|)))))) (SETQ |b| (CONS (|bpPop1| |ps|) |b|))))) @@ -412,18 +414,19 @@ (DEFUN |bpMoveTo| (|ps| |n|) (COND ((NULL (|parserTokens| |ps|)) T) - ((|bpEqPeek| 'BACKTAB) + ((|bpEqPeek| |ps| 'BACKTAB) (COND ((EQL |n| 0) T) (T (|bpNextToken| |ps|) (SETF (|parserScope| |ps|) (- (|parserScope| |ps|) 1)) (|bpMoveTo| |ps| (- |n| 1))))) - ((|bpEqPeek| 'BACKSET) + ((|bpEqPeek| |ps| 'BACKSET) (COND ((EQL |n| 0) T) (T (|bpNextToken| |ps|) (|bpMoveTo| |ps| |n|)))) - ((|bpEqPeek| 'SETTAB) (|bpNextToken| |ps|) (|bpMoveTo| |ps| (+ |n| 1))) - ((|bpEqPeek| 'OPAREN) (|bpNextToken| |ps|) + ((|bpEqPeek| |ps| 'SETTAB) (|bpNextToken| |ps|) + (|bpMoveTo| |ps| (+ |n| 1))) + ((|bpEqPeek| |ps| 'OPAREN) (|bpNextToken| |ps|) (SETF (|parserNesting| |ps|) (+ (|parserNesting| |ps|) 1)) (|bpMoveTo| |ps| |n|)) - ((|bpEqPeek| 'CPAREN) (|bpNextToken| |ps|) + ((|bpEqPeek| |ps| 'CPAREN) (|bpNextToken| |ps|) (SETF (|parserNesting| |ps|) (- (|parserNesting| |ps|) 1)) (|bpMoveTo| |ps| |n|)) (T (|bpNextToken| |ps|) (|bpMoveTo| |ps| |n|)))) @@ -431,7 +434,7 @@ (DEFUN |bpQualifiedName| (|ps|) (DECLARE (SPECIAL |$stok|)) (COND - ((|bpEqPeek| 'COLON-COLON) (|bpNext| |ps|) + ((|bpEqPeek| |ps| 'COLON-COLON) (|bpNext| |ps|) (AND (EQ (|tokenClass| |$stok|) 'ID) (|bpPushId| |ps|) (|bpNext| |ps|) (|bpPush| |ps| (|bfColonColon| (|bpPop2| |ps|) (|bpPop1| |ps|))))) (T NIL))) @@ -454,7 +457,7 @@ (AND (|bpPush| |ps| |$ttok|) (|bpNext| |ps|))) ((EQ (|tokenClass| |$stok|) 'LINE) (AND (|bpPush| |ps| (LIST '+LINE |$ttok|)) (|bpNext| |ps|))) - ((|bpEqPeek| 'QUOTE) (|bpNext| |ps|) + ((|bpEqPeek| |ps| 'QUOTE) (|bpNext| |ps|) (AND (|bpRequire| |ps| #'|bpSexp|) (|bpPush| |ps| (|bfSymbol| (|bpPop1| |ps|))))) (T (OR (|bpString| |ps|) (|bpFunction| |ps|))))) @@ -485,12 +488,12 @@ (DEFUN |bpExportItem| (|ps|) (LET* (|a|) - (COND ((|bpEqPeek| 'STRUCTURE) (|bpStruct| |ps|)) + (COND ((|bpEqPeek| |ps| 'STRUCTURE) (|bpStruct| |ps|)) (T (SETQ |a| (|bpState| |ps|)) (COND ((|bpName| |ps|) (COND - ((|bpEqPeek| 'COLON) (|bpRestore| |ps| |a|) + ((|bpEqPeek| |ps| 'COLON) (|bpRestore| |ps| |a|) (|bpRequire| |ps| #'|bpSignature|) (OR (|bpExportItemTail| |ps|) T)) (T (|bpRestore| |ps| |a|) (|bpTypeAliasDefition| |ps|)))) @@ -503,7 +506,7 @@ ((|bpEqKey| |ps| 'WHERE) (OR (|bpPileBracketed| |ps| #'|bpExportItemList|) (AND (|bpExportItem| |ps|) (|bpPush| |ps| (LIST (|bpPop1| |ps|)))) - (|bpTrap|))) + (|bpTrap| |ps|))) (T (|bpPush| |ps| NIL)))) (DEFUN |bpModuleExports| (|ps|) @@ -529,12 +532,12 @@ (OR (AND (|bpLeftAssoc| |ps| '(DOT) #'|bpName|) (|bpPush| |ps| (|%Import| (|bfNamespace| (|bpPop1| |ps|))))) - (|bpTrap|))) + (|bpTrap| |ps|))) (T (SETQ |a| (|bpState| |ps|)) (|bpRequire| |ps| #'|bpName|) (COND - ((|bpEqPeek| 'COLON) (|bpRestore| |ps| |a|) + ((|bpEqPeek| |ps| 'COLON) (|bpRestore| |ps| |a|) (AND (|bpRequire| |ps| #'|bpSignature|) - (OR (|bpEqKey| |ps| 'FOR) (|bpTrap|)) + (OR (|bpEqKey| |ps| 'FOR) (|bpTrap| |ps|)) (|bpRequire| |ps| #'|bpName|) (|bpPush| |ps| (|%ImportSignature| (|bpPop1| |ps|) @@ -547,7 +550,7 @@ (|bpPush| |ps| (|bfNamespace| (|bpPop1| |ps|))))) (DEFUN |bpTypeAliasDefition| (|ps|) - (AND (OR (|bpTerm| |ps| #'|bpIdList|) (|bpTrap|)) (|bpEqKey| |ps| 'TDEF) + (AND (OR (|bpTerm| |ps| #'|bpIdList|) (|bpTrap| |ps|)) (|bpEqKey| |ps| 'TDEF) (|bpLogical| |ps|) (|bpPush| |ps| (|%TypeAlias| (|bpPop2| |ps|) (|bpPop1| |ps|))))) @@ -594,16 +597,16 @@ (CONS (|mk%Token| 'KEY 'BACKTAB (|tokenPosition| |$stok|)) (|bpAddTokens| (+ |n| 1)))))) -(DEFUN |bpExceptions| () - (OR (|bpEqPeek| 'DOT) (|bpEqPeek| 'QUOTE) (|bpEqPeek| 'OPAREN) - (|bpEqPeek| 'CPAREN) (|bpEqPeek| 'SETTAB) (|bpEqPeek| 'BACKTAB) - (|bpEqPeek| 'BACKSET))) +(DEFUN |bpExceptions| (|ps|) + (OR (|bpEqPeek| |ps| 'DOT) (|bpEqPeek| |ps| 'QUOTE) (|bpEqPeek| |ps| 'OPAREN) + (|bpEqPeek| |ps| 'CPAREN) (|bpEqPeek| |ps| 'SETTAB) + (|bpEqPeek| |ps| 'BACKTAB) (|bpEqPeek| |ps| 'BACKSET))) (DEFUN |bpSexpKey| (|ps|) (LET* (|a|) (DECLARE (SPECIAL |$ttok| |$stok|)) (COND - ((AND (EQ (|tokenClass| |$stok|) 'KEY) (NOT (|bpExceptions|))) + ((AND (EQ (|tokenClass| |$stok|) 'KEY) (NOT (|bpExceptions| |ps|))) (SETQ |a| (GET |$ttok| 'SHOEINF)) (COND ((NULL |a|) (AND (|bpPush| |ps| (|keywordId| |$ttok|)) (|bpNext| |ps|))) @@ -614,7 +617,7 @@ (DECLARE (SPECIAL |$ttok| |$stok|)) (OR (AND (|bpEqKey| |ps| 'MINUS) - (OR (EQ (|tokenClass| |$stok|) 'INTEGER) (|bpTrap|)) + (OR (EQ (|tokenClass| |$stok|) 'INTEGER) (|bpTrap| |ps|)) (|bpPush| |ps| (- |$ttok|)) (|bpNext| |ps|)) (|bpSexpKey| |ps|) (AND (|symbolMember?| (|tokenClass| |$stok|) '(ID INTEGER STRING FLOAT)) @@ -683,7 +686,7 @@ (DEFUN |bpTyping| (|ps|) (COND ((|bpEqKey| |ps| 'FORALL) (|bpRequire| |ps| #'|bpVariable|) - (OR (AND (|bpDot| |ps|) (|bpPop1| |ps|)) (|bpTrap|)) + (OR (AND (|bpDot| |ps|) (|bpPop1| |ps|)) (|bpTrap| |ps|)) (|bpRequire| |ps| #'|bpTyping|) (|bpPush| |ps| (|%Forall| (|bpPop2| |ps|) (|bpPop1| |ps|)))) (T (OR (|bpMapping| |ps|) (|bpSimpleMapping| |ps|))))) @@ -719,7 +722,7 @@ (COND ((NOT (AND (|bpInfGeneric| |ps| |o|) - (OR (|bpRightAssoc| |ps| |o| |p|) (|bpTrap|)))) + (OR (|bpRightAssoc| |ps| |o| |p|) (|bpTrap| |ps|)))) (RETURN NIL)) (T (|bpPush| |ps| @@ -769,7 +772,7 @@ (COND ((AND (|bpReduceOperator| |ps|) (|bpEqKey| |ps| 'SLASH)) (COND - ((|bpEqPeek| 'OBRACK) + ((|bpEqPeek| |ps| 'OBRACK) (AND (|bpRequire| |ps| #'|bpDConstruct|) (|bpPush| |ps| (|bfReduceCollect| (|bpPop2| |ps|) (|bpPop1| |ps|))))) @@ -841,13 +844,14 @@ (|bpPush| |ps| (|bfTry| (|bpPop2| |ps|) (|reverse!| (CONS (|bpPop1| |ps|) |cs|)))))) - ((NULL |cs|) (|bpTrap|)) + ((NULL |cs|) (|bpTrap| |ps|)) (T (|bpPush| |ps| (|bfTry| (|bpPop1| |ps|) (|reverse!| |cs|)))))) (T NIL)))) (DEFUN |bpCatchItem| (|ps|) (AND (|bpRequire| |ps| #'|bpExceptionVariable|) - (OR (|bpEqKey| |ps| 'EXIT) (|bpTrap|)) (|bpRequire| |ps| #'|bpAssign|) + (OR (|bpEqKey| |ps| 'EXIT) (|bpTrap| |ps|)) + (|bpRequire| |ps| #'|bpAssign|) (|bpPush| |ps| (|%Catch| (|bpPop2| |ps|) (|bpPop1| |ps|))))) (DEFUN |bpExceptionVariable| (|ps|) @@ -858,7 +862,7 @@ (OR (AND (|bpEqKey| |ps| 'OPAREN) (|bpRequire| |ps| #'|bpSignature|) (OR (|bpEqKey| |ps| 'CPAREN) (|bpMissing| |t|))) - (|bpTrap|))))) + (|bpTrap| |ps|))))) (DEFUN |bpFinally| (|ps|) (AND (|bpRequire| |ps| #'|bpAssign|) @@ -901,7 +905,7 @@ (OR (AND (|bpLogical| |ps|) (|bpPush| |ps| (|bfApplication| 'COLON (|bpPop1| |ps|)))) - (|bpTrap|))) + (|bpTrap| |ps|))) (|bpLogical| |ps|))) (DEFUN |bpStatement| (|ps|) @@ -966,11 +970,11 @@ (COND ((|bpStatement| |ps|) (COND - ((|bpEqPeek| 'BEC) (|bpRestore| |ps| |a|) + ((|bpEqPeek| |ps| 'BEC) (|bpRestore| |ps| |a|) (|bpRequire| |ps| #'|bpAssignment|)) - ((|bpEqPeek| 'GIVES) (|bpRestore| |ps| |a|) + ((|bpEqPeek| |ps| 'GIVES) (|bpRestore| |ps| |a|) (|bpRequire| |ps| #'|bpLambda|)) - ((|bpEqPeek| 'LARROW) (|bpRestore| |ps| |a|) + ((|bpEqPeek| |ps| 'LARROW) (|bpRestore| |ps| |a|) (|bpRequire| |ps| #'|bpKeyArg|)) (T T))) (T (|bpRestore| |ps| |a|) NIL))))) @@ -1003,12 +1007,12 @@ (OR (AND (|bpName| |ps|) (|bpStoreName| |ps|) (|bpCompoundDefinitionTail| |ps| #'|%Macro|)) - (|bpTrap|))) + (|bpTrap| |ps|))) (T (SETQ |a| (|bpState| |ps|)) (COND ((|bpExit| |ps|) - (COND ((|bpEqPeek| 'DEF) (|bpRestore| |ps| |a|) (|bpDef| |ps|)) - ((|bpEqPeek| 'TDEF) (|bpRestore| |ps| |a|) + (COND ((|bpEqPeek| |ps| 'DEF) (|bpRestore| |ps| |a|) (|bpDef| |ps|)) + ((|bpEqPeek| |ps| 'TDEF) (|bpRestore| |ps| |a|) (|bpTypeAliasDefition| |ps|)) (T T))) (T (|bpRestore| |ps| |a|) NIL)))))) @@ -1126,7 +1130,7 @@ (DEFUN |bpEqual| (|ps|) (AND (|bpEqKey| |ps| 'SHOEEQ) - (OR (|bpApplication| |ps|) (|bpConstTok| |ps|) (|bpTrap|)) + (OR (|bpApplication| |ps|) (|bpConstTok| |ps|) (|bpTrap| |ps|)) (|bpPush| |ps| (|bfEqual| (|bpPop1| |ps|))))) (DEFUN |bpRegularPatternItem| (|ps|) @@ -1164,7 +1168,7 @@ (AND (|bpPatternTail| |ps|) (|bpPush| |ps| (|append| (|bpPop2| |ps|) (|bpPop1| |ps|)))) - (|bpTrap|)) + (|bpTrap| |ps|)) NIL)))) (RETURN NIL)) (T (|bpPush| |ps| (|append| (|bpPop2| |ps|) (|bpPop1| |ps|)))))) @@ -1204,7 +1208,7 @@ (DEFUN |bpColonName| (|ps|) (AND (|bpEqKey| |ps| 'COLON) - (OR (|bpName| |ps|) (|bpBVString| |ps|) (|bpTrap|)))) + (OR (|bpName| |ps|) (|bpBVString| |ps|) (|bpTrap| |ps|)))) (DEFUN |bpBoundVariablelist| (|ps|) (COND @@ -1220,7 +1224,7 @@ (|bpPush| |ps| (|bfColonAppend| (|bpPop2| |ps|) (|bpPop1| |ps|)))) - (|bpTrap|)) + (|bpTrap| |ps|)) NIL)))) (RETURN NIL)) (T (|bpPush| |ps| (|append| (|bpPop2| |ps|) (|bpPop1| |ps|)))))) @@ -1245,10 +1249,10 @@ (|bpPush| |ps| (|bfLocal| (|bpPop2| |ps|) (|bpPop1| |ps|)))) (T (AND (|bpArgumentList| |ps|) - (OR (|bpEqPeek| 'DOT) - (AND (|bpEqPeek| 'BEC) + (OR (|bpEqPeek| |ps| 'DOT) + (AND (|bpEqPeek| |ps| 'BEC) (|bpPush| |ps| (|bfPlace| (|bpPop1| |ps|)))) - (|bpTrap|))) + (|bpTrap| |ps|))) (COND ((|bpEqKey| |ps| 'DOT) (AND (|bpList| |ps| #'|bpPrimary| 'DOT) (|bpChecknull| |ps|) @@ -1260,11 +1264,11 @@ (LET* (|a|) (PROGN (SETQ |a| (|bpPop1| |ps|)) - (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |ps| |a|)))))) + (COND ((NULL |a|) (|bpTrap| |ps|)) (T (|bpPush| |ps| |a|)))))) (DEFUN |bpStruct| (|ps|) (AND (|bpEqKey| |ps| 'STRUCTURE) (|bpRequire| |ps| #'|bpName|) - (OR (|bpEqKey| |ps| 'DEF) (|bpTrap|)) + (OR (|bpEqKey| |ps| 'DEF) (|bpTrap| |ps|)) (OR (|bpRecord| |ps|) (|bpTypeList| |ps|)) (|bpPush| |ps| (|%Structure| (|bpPop2| |ps|) (|bpPop1| |ps|))))) @@ -1274,7 +1278,7 @@ (SETQ |s| (|bpState| |ps|)) (COND ((AND (|bpName| |ps|) (EQ (|bpPop1| |ps|) '|Record|)) - (AND (OR (|bpParenthesized| |ps| #'|bpFieldList|) (|bpTrap|)) + (AND (OR (|bpParenthesized| |ps| #'|bpFieldList|) (|bpTrap| |ps|)) (|bpGlobalAccessors| |ps|) (|bpPush| |ps| (|%Record| (|bfUntuple| (|bpPop2| |ps|)) @@ -1286,14 +1290,14 @@ (DEFUN |bpGlobalAccessors| (|ps|) (COND ((|bpEqKey| |ps| 'WITH) - (OR (|bpPileBracketed| |ps| #'|bpAccessorDefinitionList|) (|bpTrap|))) + (OR (|bpPileBracketed| |ps| #'|bpAccessorDefinitionList|) (|bpTrap| |ps|))) (T (|bpPush| |ps| NIL)))) (DEFUN |bpAccessorDefinitionList| (|ps|) (|bpListAndRecover| |ps| #'|bpAccessorDefinition|)) (DEFUN |bpAccessorDefinition| (|ps|) - (AND (|bpRequire| |ps| #'|bpName|) (OR (|bpEqKey| |ps| 'DEF) (|bpTrap|)) + (AND (|bpRequire| |ps| #'|bpName|) (OR (|bpEqKey| |ps| 'DEF) (|bpTrap| |ps|)) (|bpRequire| |ps| #'|bpFieldSection|) (|bpPush| |ps| (|%AccessorDef| (|bpPop2| |ps|) (|bpPop1| |ps|))))) @@ -1336,8 +1340,9 @@ (DEFUN |bpCasePatternVarList| (|ps|) (|bpTuple| |ps| #'|bpCasePatternVar|)) (DEFUN |bpCaseItem| (|ps|) - (AND (OR (|bpTerm| |ps| #'|bpCasePatternVarList|) (|bpTrap|)) - (OR (|bpEqKey| |ps| 'EXIT) (|bpTrap|)) (|bpRequire| |ps| #'|bpWhere|) + (AND (OR (|bpTerm| |ps| #'|bpCasePatternVarList|) (|bpTrap| |ps|)) + (OR (|bpEqKey| |ps| 'EXIT) (|bpTrap| |ps|)) + (|bpRequire| |ps| #'|bpWhere|) (|bpPush| |ps| (|bfCaseItem| (|bpPop2| |ps|) (|bpPop1| |ps|))))) (DEFUN |bpOutItem| (|ps|) @@ -1346,7 +1351,16 @@ (LET* ((|$op| NIL) (|$GenVarCounter| 0)) (DECLARE (SPECIAL |$op| |$GenVarCounter|)) (PROGN - (|bpRequire| |ps| #'|bpComma|) + (LET ((#1=#:G721 + (CATCH :OPEN-AXIOM-CATCH-POINT (|bpRequire| |ps| #'|bpComma|)))) + (COND + ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) + (COND + ((EQUAL (CAR #2=(CDR #1#)) '(|BootSpecificError|)) + (LET ((|e| (CDR #2#))) + (PROGN (|bpSpecificErrorHere| |e|) (|bpTrap| |ps|)))) + (T (THROW :OPEN-AXIOM-CATCH-POINT #1#)))) + (T #1#))) (SETQ |b| (|bpPop1| |ps|)) (SETQ |t| (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|)) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index c9d4a9d5..c7567e89 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -563,7 +563,8 @@ (EQ (CAR |ISTMP#2|) '|Foreign|)))))) (COND ((|%hasFeature| :SBCL) 'SB-ALIEN) ((|%hasFeature| :ECL) 'FFI) (T (RETURN NIL)))) - ((|ident?| |ns|) |ns|) (T (|bpTrap|)))) + ((|ident?| |ns|) |ns|) + (T (|bfSpecificErrorHere| "invalid namespace")))) (CONS 'USE-PACKAGE (CONS (SYMBOL-NAME |z|) |user|))))) ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)) (CONS (CAR |x|) diff --git a/src/boot/translator.boot b/src/boot/translator.boot index bcfc5856..9079167f 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -427,7 +427,7 @@ packageBody(x,p) == %hasFeature KEYWORD::ECL => 'FFI return nil ident? ns => ns - bpTrap() + bfSpecificErrorHere '"invalid namespace" ['USE_-PACKAGE,symbolName z,:user] x is ['PROGN,:.] => [x.op,:[packageBody(y,p) for y in x.args]] x |