aboutsummaryrefslogtreecommitdiff
path: root/src/interp/spad-parser.boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/spad-parser.boot')
-rw-r--r--src/interp/spad-parser.boot604
1 files changed, 578 insertions, 26 deletions
diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot
index a7780674..43e04256 100644
--- a/src/interp/spad-parser.boot
+++ b/src/interp/spad-parser.boot
@@ -42,15 +42,26 @@
-- -- gdr/2007-11-02
--
-import parsing
+import preparse
import parse
-import fnewmeta
namespace BOOT
--%
macro compulsorySyntax s ==
s or SPAD__SYNTAX__ERROR()
+repeatedSyntax(l,p) ==
+ n := stackSize $reduceStack
+ once := false
+ while apply(p,nil) repeat
+ once := true
+ not once => nil
+ x := nil
+ for i in (n+1)..stackSize $reduceStack repeat
+ x := [popStack1(),:x]
+ x = nil => true
+ pushReduction(l,x)
+
--%
parseToken tt ==
@@ -60,14 +71,77 @@ parseToken tt ==
true
false
+parseGlyph s ==
+ matchCurrentToken('GLIPH,s) =>
+ advanceToken()
+ true
+ false
+
+parseNBGlyph tok ==
+ matchCurrentToken('GLIPH,tok) and $nonblank =>
+ advanceToken()
+ true
+ false
+
parseString() ==
parseToken 'SPADSTRING
parseInteger() ==
parseToken 'NUMBER
+parseFloatBasePart() ==
+ matchAdvanceGlyph "." =>
+ $nonblank and (t := matchCurrentToken 'NUMBER) =>
+ t := copyToken t
+ advanceToken()
+ pushReduction('parseFloatBasePart,tokenNonblank? t)
+ pushReduction('parseFloatBasePart,tokenSymbol t)
+ pushReduction('parseFloatBasePart,0)
+ pushReduction('parseFloatBasePart,0)
+ nil
+
+parseFloatBase() ==
+ integer? currentSymbol() and currentChar() = char "." and
+ nextChar() ~= char "." and parseInteger() =>
+ compulsorySyntax parseFloatBasePart()
+ integer? currentSymbol() and charUpcase currentChar() = char "E"
+ and parseInteger() =>
+ pushReduction('parseBase,0)
+ pushReduction('parseBase,0)
+ digit? currentChar() and currentSymbol() is "." =>
+ pushReduction('parseBase,0)
+ pushReduction('parseBase,0)
+ nil
+
+parseFloatExponent() ==
+ not ident? currentSymbol() => nil
+ symbolMember?(currentSymbol(),'(e E)) and
+ charMember?(currentChar(),[char "+",char "-"]) =>
+ advanceToken()
+ parseInteger() => true
+ matchAdvanceGlyph "+" => compulsorySyntax parseInteger()
+ matchAdvanceGlyph "-" =>
+ compulsorySyntax parseInteger()
+ pushReduction('parseFloatExponent,-popStack1())
+ pushReduction('parseFloatExponent,0)
+ g := FLOATEXPID currentSymbol() =>
+ advanceToken()
+ pushReduction('parseFloatExponent,g)
+ nil
+
+parseFloat() ==
+ parseFloatBase() =>
+ $nonblank and parseFloatExponent()
+ or pushReduction('parseFloat,0)
+ pushReduction('parseFloat,
+ MAKE_-FLOAT(popStack4(),popStack2(),popStack2(),popStack1()))
+ nil
+
parseName() ==
parseToken 'IDENTIFIER and pushReduction('parseName,popStack1())
+
+parseKeyword() ==
+ parseToken 'KEYWORD and pushReduction('parseKeyword,popStack1())
parseFormalParameter() ==
parseToken 'ARGUMENT_-DESIGNATOR
@@ -84,6 +158,7 @@ parseOperatorFunctionName() ==
parseAnyId() ==
parseName() => true
+ parseKeyword() => true
matchString '"$" =>
pushReduction('parseAnyId,currentSymbol())
advanceToken()
@@ -93,8 +168,26 @@ parseAnyId() ==
parseQuad() ==
matchAdvanceString '"$" and pushReduction('parseQuad,"$")
+parsePrimary1() ==
+ parseName() =>
+ $nonblank and currentSymbol() is "(" =>
+ compulsorySyntax parsePrimary1()
+ pushReduction('parsePrimary1,[popStack2(),popStack1()])
+ true
+ parseQuad() or parseString() or parseInteger() or
+ parseFormalParameter() => true
+ matchSpecial char "'" =>
+ compulsorySyntax parseData()
+ pushReduction('parsePrimary1,popStack1())
+ parseSequence() or parseEnclosure()
+
+parsePrimaryNoFloat() ==
+ parsePrimary1() =>
+ parseTokenTail() or true
+ false
+
parsePrimary() ==
- PARSE_-Float() or PARSE_-PrimaryNoFloat()
+ parseFloat() or parsePrimaryNoFloat()
parsePrimaryOrQM() ==
matchAdvanceString '"?" => pushReduction('parsePrimaryOrQM,"?")
@@ -105,8 +198,46 @@ parseSpecialKeyWord() ==
tokenSymbol(currentToken()) := unAbbreviateKeyword currentSymbol()
nil
+parseSexpr1() ==
+ parseInteger() or parseString() => true
+ parseAnyId() =>
+ parseNBGlyph "=" =>
+ compulsorySyntax parseSexpr1()
+ SETQ(LABLASOC,[[popStack2(),:nthStack 1],:LABLASOC])
+ true
+ true
+ matchAdvanceSpecial char "'" =>
+ compulsorySyntax parseSexpr1()
+ pushReduction('parseSexpr1,["QUOTE",popStack1()])
+ matchAdvanceGlyph "[" =>
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('parseSexpr1,function PARSE_-Sexpr1)
+ if not stackUpdated? $reduceStack then
+ pushReduction('parseSexpr1,nil)
+ compulsorySyntax matchAdvanceGlyph "]"
+ pushReduction('parseSexpr1,LIST2VEC popStack1())
+ matchAdvanceGlyph "(" =>
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('parseSexpr1,function PARSE_-Sexpr1)
+ if parseGlyph "." then
+ compulsorySyntax parseSexpr1()
+ pushReduction('parseSexpr1,append!(popStack2(),popStack1()))
+ if not stackUpdated? $reduceStack then
+ pushReduction('parseSexpr1,nil)
+ compulsorySyntax matchAdvanceGlyph ")"
+ nil
+
+parseSexpr() ==
+ advanceToken()
+ parseSexpr1()
+
+parseData() ==
+ SETQ(LABLASOC,nil)
+ parseSexpr() and
+ pushReduction('parseData,["QUOTE",TRANSLABEL(popStack1(),LABLASOC)])
+
parseCommand() ==
- matchAdvanceString '")" =>
+ matchAdvanceString '")" => --FIXME: remove matchAdvanceString
compulsorySyntax parseSpecialKeyWord()
compulsorySyntax parseSpecialCommand()
pushReduction('parseStatement,nil)
@@ -117,7 +248,7 @@ parseTokenOption() ==
parseQualification() ==
matchAdvanceString '"$" =>
- compulsorySyntax PARSE_-Primary1()
+ compulsorySyntax parsePrimary1()
pushReduction('parseQualification,dollarTran(popStack1(),popStack1()))
nil
@@ -130,23 +261,137 @@ parseTokenTail() ==
$priorToken := tok
nil
+parseSelector() ==
+ $nonblank and currentSymbol() is "." and currentChar() ~= char " "
+ and matchAdvanceGlyph "." =>
+ compulsorySyntax parsePrimaryNoFloat()
+ pushReduction('parseSelector,[popStack2(),popStack1()])
+ parseFloat()
+ or matchAdvanceGlyph "." and compulsorySyntax parsePrimary() =>
+ pushReduction('parseSelector,[popStack2(),popStack1()])
+ nil
+
+parseApplication() ==
+ parsePrimary() =>
+ repeatedSyntax('selectors,function parseSelector)
+ parseApplication() and
+ pushReduction('parseApplication,[popStack2(),popStack1()])
+ true
+ nil
+
+parseOperation($ParseMode,rbp) ==
+ matchCurrentToken 'IDENTIFIER => nil
+ s := currentSymbol()
+ not symbol? s or property(s,$ParseMode) = nil => nil
+ rbp >= parseLeftBindingPowerOf(s,$ParseMode) => nil
+ parseGetSemanticForm(s,$ParseMode,ELEMN(property(s,$ParseMode),5,nil))
+
+parseLedPart rbp ==
+ parseOperation('Led,rbp) and
+ pushReduction('parseLedPart,popStack1())
+
+parseNudPart rbp ==
+ parseOperation('Nud,rbp) or parseReduction() or parseForm() =>
+ pushReduction('parseNudPart,popStack1())
+
+parseExpr rbp ==
+ parseNudPart rbp =>
+ repeatedSyntax('parseExpr,function(() +-> parseLedPart rbp))
+ pushReduction('parseExpr,popStack1())
+ nil
+
parseInfix() ==
pushReduction('parseInfix,currentSymbol())
advanceToken()
parseTokenTail()
- compulsorySyntax PARSE_-Expression()
+ compulsorySyntax parseExpression()
pushReduction('parseInfix,[popStack2(),popStack2(),popStack1()])
parsePrefix() ==
pushReduction('parsePrefix,currentSymbol())
advanceToken()
parseTokenTail()
- compulsorySyntax PARSE_-Expression()
+ compulsorySyntax parseExpression()
pushReduction('parsePrefix,[popStack2(),popStack1()])
+parseLeftBindingPowerOf(x,p) ==
+ y := property(x,p) => ELEMN(y,3,0)
+ 0
+
+parseRightBindingPowerOf(x,p) ==
+ y := property(x,p) => ELEMN(y,4,105)
+ 105
+
+parseGetSemanticForm(x,p,y) ==
+ z := EVAL y => z -- FIXME get rid of EVAL.
+ p = "Nud" => parsePrefix()
+ p = "Led" => parseInfix()
+ nil
+
+parseExpression() ==
+ parseExpr parseRightBindingPowerOf(makeSymbolOf $priorToken,$ParseMode)
+ and pushReduction('parseExpression,popStack1())
+
+parseSegmentTail() ==
+ parseGlyph ".." =>
+ stackUpdated?($reduceStack) := false
+ parseExpression()
+ if not stackUpdated? $reduceStack then
+ pushReduction('segmentTail,nil)
+ pushReduction('parseSegmentTail,["SEGMENT",popStack2(),popStack1()])
+ nil
+
+parseReductionOp() ==
+ s := currentSymbol()
+ if string? s then
+ s := makeSymbol s -- FIXME: abolish string-quoted operators
+ ident? s and property(s,'Led) and matchNextToken('GLIPH,"/") =>
+ pushReduction('parseReductionOp,s)
+ advanceToken()
+ advanceToken()
+ true
+ false
+
+parseReduction() ==
+ parseReductionOp() =>
+ compulsorySyntax parseExpr 1000
+ pushReduction('parseReduction,["%Reduce",popStack2(),popStack1()])
+ nil
+
+parseCategory() ==
+ matchAdvanceKeyword "if" =>
+ compulsorySyntax parseExpression()
+ compulsorySyntax matchAdvanceKeyword "then"
+ compulsorySyntax parseCategory()
+ stackUpdated?($reduceStack) := false
+ matchAdvanceKeyword "else" and compulsorySyntax parseCategory()
+ if not stackUpdated? $reduceStack then
+ pushReduction('alternateCategory,nil)
+ pushReduction('parseCategory,["if",popStack3(),popStack2(),popStack1()])
+ matchAdvanceGlyph "(" =>
+ compulsorySyntax parseCategory()
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('unnamedCategory,function(() +->
+ matchAdvanceSpecial char ";" and compulsorySyntax parseCategory()))
+ if not stackUpdated? $reduceStack then
+ pushReduction('unnamedCategory,nil)
+ compulsorySyntax matchAdvanceSpecial char ")"
+ pushReduction('parseCategory,["CATEGORY",popStack2(),:popStack1()])
+ g := lineNumber $spadLine
+ parseApplication() or parseOperatorFunctionName() =>
+ matchAdvanceGlyph ":" =>
+ compulsorySyntax parseExpression()
+ pushReduction('parseCategory,["%Signature",popStack2(),popStack1()])
+ recordSignatureDocumentation(nthStack 1,g)
+ true
+ pushReduction('parseCategory,["%Attribute",popStack1()])
+ recordAttributeDocumentation(nthStack 1,g)
+ true
+ nil
+
parseWith() ==
matchAdvanceKeyword "with" =>
- compulsorySyntax PARSE_-Category()
+ compulsorySyntax parseCategory()
pushReduction('parseWith,["with",popStack1()])
nil
@@ -155,17 +400,8 @@ parseInfixWith() ==
pushReduction('parseInfixWith,["Join",popStack2(),popStack1()])
parseElseClause() ==
- currentSymbol() is "if" => PARSE_-Conditional()
- PARSE_-Expression()
-
-++ domain inlining. Same syntax as import directive; except
-++ deliberate restriction on naming one type at a time.
-++ -- gdr, 2009-02-28.
-parseInline() ==
- matchAdvanceKeyword "inline" =>
- compulsorySyntax PARSE_-Expr 1000
- pushReduction('parseInline,["%Inline",popStack1()])
- nil
+ currentSymbol() is "if" => parseConditional()
+ parseExpression()
parseQuantifier() ==
matchAdvanceKeyword "forall" =>
@@ -176,28 +412,68 @@ parseQuantifier() ==
parseQuantifiedVariable() ==
parseName() =>
- compulsorySyntax matchAdvanceString '":"
- compulsorySyntax PARSE_-Application()
+ compulsorySyntax matchAdvanceGlyph ":"
+ compulsorySyntax parseApplication()
pushReduction('parseQuantifiedVariable,[":",popStack2(),popStack1()])
nil
+parseQuantifiedVariableList() ==
+ matchAdvanceGlyph "(" =>
+ compulsorySyntax parseQuantifiedVariable()
+ repeatedSyntax('repeatedVars,function(() +->
+ matchAdvanceSpecial char "," and parseQuantifiedVariable()))
+ and pushReduction('parseQuantifiedVariableList,
+ ["%Sequence",popStack2(),:popStack1()])
+ compulsorySyntax matchAdvanceSpecial char ")"
+ nil
+
+++ quantified types. At the moment, these are used only in
+++ pattern-mathing cases.
+++ -- gdr, 2009-06-14.
+parseScheme() ==
+ parseQuantifier() =>
+ compulsorySyntax parseQuantifiedVariableList()
+ compulsorySyntax matchAdvanceGlyph "."
+ compulsorySyntax parseExpr 200
+ pushReduction('parseScheme,[popStack3(),popStack2(),popStack1()])
+ parseApplication()
+
+parseConditional() ==
+ matchAdvanceKeyword "if" =>
+ compulsorySyntax parseExpression()
+ compulsorySyntax matchAdvanceKeyword "then"
+ compulsorySyntax parseExpression()
+ stackUpdated?($reduceStack) := false
+ if matchAdvanceKeyword "else" then
+ parseElseClause()
+ if not stackUpdated? $reduceStack then
+ pushReduction('elseBranch,nil)
+ pushReduction('parseConditional,["if",popStack3(),popStack2(),popStack1()])
+ nil
+
+parseSemicolon() ==
+ matchAdvanceSpecial char ";" =>
+ parseExpr 82 or pushReduction('parseSemicolon,"/throwAway")
+ pushReduction('parseSemicolon,[";",popStack2(),popStack1()])
+ nil
+
++ We should factorize these boilerplates
parseReturn() ==
matchAdvanceKeyword "return" =>
- compulsorySyntax PARSE_-Expression()
+ compulsorySyntax parseExpression()
pushReduction('parseReturn,["return",popStack1()])
nil
parseThrow() ==
matchAdvanceKeyword "throw" =>
- compulsorySyntax PARSE_-Expression()
+ compulsorySyntax parseExpression()
pushReduction('parseReturn,["%Throw",popStack1()])
nil
parseExit() ==
matchAdvanceKeyword "exit" =>
x :=
- PARSE_-Expression() => popStack1()
+ parseExpression() => popStack1()
"$NoValue"
pushReduction('parseExit,["exit",x])
nil
@@ -205,7 +481,7 @@ parseExit() ==
parseLeave() ==
matchAdvanceKeyword "leave" =>
x :=
- PARSE_-Expression() => popStack1()
+ parseExpression() => popStack1()
"$NoValue"
pushReduction('parseLeave,["leave",x])
nil
@@ -216,12 +492,256 @@ parseJump() ==
pushReduction('parseJump,s)
nil
+parseForm() ==
+ matchAdvanceKeyword "iterate" =>
+ pushReduction('parseForm,["iterate"])
+ matchAdvanceKeyword "yield" =>
+ compulsorySyntax parseApplication()
+ pushReduction('parseForm,["yield",popStack1()])
+ parseApplication()
+
+parseVariable() ==
+ parseName() =>
+ matchAdvanceGlyph ":" =>
+ compulsorySyntax parseApplication()
+ pushReduction('parseVariable,[":",popStack2(),popStack1()])
+ true
+ parsePrimary()
+
+parseIterator() ==
+ matchAdvanceKeyword "for" =>
+ compulsorySyntax parseVariable()
+ compulsorySyntax matchAdvanceKeyword "in"
+ compulsorySyntax parseExpression()
+ matchAdvanceKeyword "by" and compulsorySyntax parseExpr 200 and
+ pushReduction('parseIterator,["INBY",popStack3(),popStack2(),popStack1()])
+ or pushReduction('parseIterator,["IN",popStack2(),popStack1()])
+ matchAdvanceGlyph "|" and compulsorySyntax parseExpr 111 and
+ pushReduction('parseIterator,["|",popStack1()])
+ true
+ matchAdvanceKeyword "while" =>
+ compulsorySyntax parseExpr 190
+ pushReduction('parseIterator,["WHILE",popStack1()])
+ matchAdvanceKeyword "until" =>
+ compulsorySyntax parseExpr 190
+ pushReduction('parseIterator,["UNTIL",popStack1()])
+ nil
+
+parseIteratorTails() ==
+ matchAdvanceKeyword "repeat" =>
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('parseIteratorTails,function parseIterator)
+ if not stackUpdated? $reduceStack then
+ pushReduction('crossIterators,nil)
+ repeatedSyntax('parseIteratorTails,function parseIterator)
+
+parseLoop() ==
+ repeatedSyntax('iterators,function parseIterator) =>
+ compulsorySyntax matchAdvanceKeyword "repeat"
+ compulsorySyntax parseExpr 110
+ pushReduction('parseLoop,["REPEAT",:popStack2(),popStack1()])
+ matchAdvanceKeyword "repeat" =>
+ compulsorySyntax parseExpr 110
+ pushReduction('parseLoop,["REPEAT",popStack1()])
+ nil
+
+parseOpenBracket() ==
+ s := currentSymbol()
+ getToken s is "[" =>
+ do
+ s is ["elt",:.] =>
+ pushReduction('parseOpenBracket,["elt",second s,"construct"])
+ pushReduction('parseOpenBracket,"construct")
+ advanceToken()
+ true
+ false
+
+parseOpenBrace() ==
+ s := currentSymbol()
+ getToken s is "{" =>
+ do
+ s is ["elt",:.] =>
+ pushReduction('parseOpenBracket,["elt",second s,"brace"])
+ pushReduction('parseOpenBracket,"construct") --FIXME: should be brace
+ advanceToken()
+ true
+ false
+
+parseSequence1() ==
+ do
+ parseExpression() =>
+ pushReduction('parseSequence1,[popStack2(),popStack1()])
+ pushReduction('parseSequence1,[popStack1()])
+ parseIteratorTails() and
+ pushReduction('parseSequence1,["COLLECT",:popStack1(),popStack1()])
+ true
+
+parseSequence() ==
+ parseOpenBracket() =>
+ compulsorySyntax parseSequence1()
+ compulsorySyntax matchAdvanceSpecial char "]"
+ parseOpenBrace() =>
+ compulsorySyntax parseSequence1()
+ compulsorySyntax matchAdvanceSpecial char "}"
+ pushReduction('parseSequence,["brace",popStack1()])
+ nil
+
+parseEnclosure() ==
+ matchAdvanceGlyph "(" =>
+ parseExpr 6 =>
+ compulsorySyntax matchAdvanceSpecial char ")"
+ matchAdvanceSpecial char ")" =>
+ pushReduction('parseEnclosure,["%Comma"])
+ SPAD__SYNTAX__ERROR()
+ matchAdvanceGlyph "{" =>
+ parseExpr 6 =>
+ compulsorySyntax matchAdvanceSpecial char "}"
+ pushReduction('parseEnclosure,["brace",["construct",popStack1()]])
+ matchAdvanceSpecial char "}" =>
+ pushReduction('parseEnclosure,["brace"])
+ SPAD__SYNTAX__ERROR()
+ matchAdvanceGlyph "[|" =>
+ parseStatement() =>
+ compulsorySyntax matchAdvanceGlyph "|]"
+ pushReduction('parseEnclosure,["[||]",popStack1()])
+ SPAD__SYNTAX__ERROR()
+ nil
+
+parseCatch() ==
+ matchSpecial char ";" and matchKeywordNext "catch" =>
+ advanceToken()
+ advanceToken()
+ compulsorySyntax parseGlyph "("
+ compulsorySyntax parseQuantifiedVariable()
+ compulsorySyntax matchAdvanceSpecial char ")"
+ compulsorySyntax parseGlyph "=>"
+ compulsorySyntax parseExpression()
+ pushReduction('parseCatch,[popStack2(),popStack1()])
+ nil
+
+parseFinally() ==
+ matchSpecial char ";" and matchKeywordNext "finally" =>
+ advanceToken()
+ advanceToken()
+ compulsorySyntax parseExpression()
+ nil
+
+parseTry() ==
+ matchAdvanceKeyword "try" =>
+ compulsorySyntax parseExpression()
+ -- exception handlers: either a finally-expression, or
+ -- a series of catch-expressions optionally followed by
+ -- a finally-expression.
+ parseFinally() =>
+ pushReduction('parseTry,["%Try",popStack2(),nil,popStack1()])
+ compulsorySyntax repeatedSyntax('handlers,function parseCatch) =>
+ stackUpdated?($reduceStack) := false
+ parseFinally()
+ if not stackUpdated? $reduceStack then
+ pushReduction('finalizer,nil)
+ pushReduction('parseTry,["%Try",popStack3(),popStack2(),popStack1()])
+ SPAD__SYNTAX__ERROR()
+ nil
+
+parseMatch() ==
+ matchAdvanceKeyword "case" =>
+ compulsorySyntax parseExpr 400
+ compulsorySyntax matchAdvanceKeyword "is"
+ compulsorySyntax parseExpr 110
+ pushReduction('parseMatch,["%Match",popStack2(),popStack1()])
+ nil
+
+++ domain inlining. Same syntax as import directive; except
+++ deliberate restriction on naming one type at a time.
+++ -- gdr, 2009-02-28.
+parseInline() ==
+ matchAdvanceKeyword "inline" =>
+ compulsorySyntax parseExpr 1000
+ pushReduction('parseInline,["%Inline",popStack1()])
+ nil
+
+parseImport() ==
+ matchAdvanceKeyword "import" =>
+ compulsorySyntax parseExpr 1000
+ matchAdvanceGlyph ":" =>
+ compulsorySyntax parseExpression()
+ compulsorySyntax matchAdvanceKeyword "from"
+ compulsorySyntax parseExpr 1000
+ pushReduction('parseImport,
+ ["%SignatureImport",popStack3(),popStack2(),popStack1()])
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('imports,function(() +-> matchAdvanceSpecial char ","
+ and compulsorySyntax parseExpr 1000))
+ if not stackUpdated? $reduceStack then
+ pushReduction('imports,nil)
+ pushReduction('parseImport,["import",popStack2(),:popStack1()])
+ nil
+
+parseStatement() ==
+ parseExpr 0 =>
+ repeatedSyntax('statements,function(() +-> matchAdvanceGlyph ","
+ and compulsorySyntax parseExpr 0)) =>
+ pushReduction('parseStatement,["Series",popStack2(),:popStack1()])
+ true
+ false
+
parseNewExpr() ==
matchString '")" =>
processSynonyms()
compulsorySyntax parseCommand()
SETQ(DEFINITION__NAME,currentSymbol())
- PARSE_-Statement()
+ parseStatement()
+
+--%
+
+isTokenDelimiter() ==
+ symbolMember?(currentSymbol(),[")","END__UNIT","NIL"])
+
+parseTokenList() ==
+ repeatedSyntax('tokenList,function(() +->
+ (isTokenDelimiter() => nil; pushReduction('parseTokenList,currentSymbol());
+ advanceToken(); true)))
+
+parseCommandTail() ==
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('options,function parseTokenOption)
+ if not stackUpdated? $reduceStack then
+ pushReduction('options,nil)
+ atEndOfLine() and
+ pushReduction('parseCommandTail,[popStack2(),:popStack1()])
+ systemCommand popStack1()
+ true
+
+parseOption() ==
+ matchAdvanceString '")" => --FIXME: kill matchAdvanceString
+ compulsorySyntax repeatedSyntax('options,function parsePrimaryOrQM)
+
+parseTokenCommandTail() ==
+ stackUpdated?($reduceStack) := false
+ repeatedSyntax('options,function parseOption)
+ if not stackUpdated? $reduceStack then
+ pushReduction('options,nil)
+ atEndOfLine() and
+ pushReduction('parseCommandTail,[popStack2(),:popStack1()])
+ systemCommand popStack1()
+ true
+
+parseSpecialCommand() ==
+ matchAdvanceString '"show" => --FIXME: kill matchAdvanceString
+ stackUpdated?($reduceStack) := true
+ repeatedSyntax('commands,function(() +-> matchAdvanceString '"?"
+ or parseExpression()))
+ if not stackUpdated? $reduceStack then
+ pushReduction('commdnds,nil)
+ pushReduction('parseSpecialCommand,["show",popStack1()])
+ compulsorySyntax parseCommandTail()
+ symbolMember?(currentSymbol(),$noParseCommands) =>
+ apply(currentSymbol(),nil)
+ true
+ symbolMember?(currentSymbol(),$tokenCommands) and parseTokenList() =>
+ compulsorySyntax parseTokenCommandTail()
+ repeatedSyntax('parseSpecialCommand,function parsePrimaryOrQM) and
+ compulsorySyntax parseCommandTail()
--%
@@ -267,3 +787,35 @@ parseSpadFile sourceFile ==
-- we accumulated the parse trees in reverse order
reverse! asts
+--%
+
+++ Gliphs are symbol clumps. The gliph property of a symbol gives
+++ the tree describing the tokens which begin with that symbol.
+++ The token reader uses the gliph property to determine the longest token.
+++ Thus `:=' is read as one token not as `:' followed by `='.
+for x in [
+ ["|", [")"], ["]"]],_
+ ["*", ["*"]],_
+ ["(", ["|"]],_
+ ["+", ["-", [">"]]],_
+ ["-", [">"]],_
+ ["<", ["="], ["<"]],
+ ["/", ["\"]],_
+ ["\", ["/"]],_
+ [">", ["="], [">"]],_
+ ["=", ["=", [">"]] ,[">"]],_
+ [".", ["."]],_
+ ["^", ["="]],_
+ ["~", ["="]],_
+ ["[", ["|"]],_
+ [":", ["="], ["-"], [":"]]_
+ ] repeat
+ property(first x,'GLIPH) := rest x
+
+++ Generic infix operators
+for x in ["-", "=", "*", "rem", "mod", "quo", "div", "/", "^",
+ "**", "exquo", "+", "-", "<", ">", "<=", ">=", "~=",
+ "and", "or", "/\", "\/", "<<", ">>"] _
+ repeat
+ property(x,'GENERIC) := true
+