diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/bootlex.lisp | 22 | ||||
| -rw-r--r-- | src/interp/fnewmeta.lisp | 114 | ||||
| -rw-r--r-- | src/interp/lexing.boot | 98 | ||||
| -rw-r--r-- | src/interp/metalex.lisp | 176 | ||||
| -rw-r--r-- | src/interp/parsing.lisp | 22 |
5 files changed, 224 insertions, 208 deletions
diff --git a/src/interp/bootlex.lisp b/src/interp/bootlex.lisp index c3e5d4c0..bda374de 100644 --- a/src/interp/bootlex.lisp +++ b/src/interp/bootlex.lisp @@ -183,7 +183,7 @@ Otherwise, get a .. identifier." nil (let ((token-type (boot-token-lookahead-type (current-char)))) (case token-type - (eof (token-install nil '*eof token nonblank)) + (eof (|tokenInstall| nil '*eof token |$nonblank|)) (escape (advance-char) (get-boot-identifier-token token t)) (argument-designator (get-argument-designator-token token)) @@ -194,11 +194,11 @@ Otherwise, get a .. identifier." (t (get-gliph-token token token-type)))))) (defun boot-skip-blanks () - (setq nonblank t) + (setq |$nonblank| t) (loop (let ((cc (current-char))) (if (not cc) (return nil)) (if (eq (boot-token-lookahead-type cc) 'white) - (progn (setq nonblank nil) (if (not (advance-char)) (return nil))) + (progn (setq |$nonblank| nil) (if (not (advance-char)) (return nil))) (return t))))) (defun boot-token-lookahead-type (char) @@ -221,8 +221,8 @@ Otherwise, get a .. identifier." (defun get-argument-designator-token (token) (advance-char) (get-number-token token) - (token-install (intern (strconc "#" (format nil "~D" (token-symbol token)))) - 'argument-designator token nonblank)) + (|tokenInstall| (intern (strconc "#" (format nil "~D" (|tokenSymbol| token)))) + 'argument-designator token |$nonblank|)) (defun get-boot-identifier-token (token &optional (escaped? nil)) @@ -258,13 +258,13 @@ or the chracters ?, !, ' or %" (setq buf (concatenate 'string default-package "'" buf) default-package nil)) (setq buf (intern buf (or default-package "BOOT"))) - (return (token-install + (return (|tokenInstall| buf (if (and (not escaped?) (member buf Keywords :test #'eq)) 'keyword 'identifier) token - nonblank)))) + |$nonblank|)))) (defun get-gliph-token (token gliph-list) (prog ((buf (make-adjustable-string 0))) @@ -277,8 +277,8 @@ or the chracters ?, !, ' or %" (advance-char) (go loop)) (let ((new-token (intern buf))) - (return (token-install (or (get new-token 'renametok) new-token) - 'gliph token nonblank)))))) + (return (|tokenInstall| (or (get new-token 'renametok) new-token) + 'gliph token |$nonblank|)))))) (defun get-SPADSTRING-token (token) "With TOK=\" and ABC\" on IN-STREAM, extracts and stacks string ABC" @@ -294,7 +294,7 @@ or the chracters ?, !, ' or %" (PROGN (|sayBrightly| "Close quote inserted") (RETURN nil))) ) (advance-char) - (return (token-install (copy-seq buf) ;should make a simple string + (return (|tokenInstall| (copy-seq buf) ;should make a simple string 'spadstring token)))) ;; -*- Parse an integer number -*- @@ -345,7 +345,7 @@ or the chracters ?, !, ' or %" (when (is-radix-char (current-char)) (setq val (get-integer-in-radix buf val)) (advance-char)) - (token-install val 'number token (size buf)))) + (|tokenInstall| val 'number token (size buf)))) ; **** 4. BOOT token parsing actions diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp index 44650661..658bc9f3 100644 --- a/src/interp/fnewmeta.lisp +++ b/src/interp/fnewmeta.lisp @@ -48,12 +48,12 @@ (DEFPARAMETER LABLASOC NIL) (defun |isTokenDelimiter| () - (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL))) + (MEMBER (|currentSymbol|) '(\) END\_UNIT NIL))) (DEFUN |PARSE-NewExpr| () (OR (AND (MATCH-STRING ")") (ACTION (|processSynonyms|)) (MUST (|PARSE-Command|))) - (AND (ACTION (SETQ DEFINITION_NAME (CURRENT-SYMBOL))) + (AND (ACTION (SETQ DEFINITION_NAME (|currentSymbol|))) (|PARSE-Statement|)))) @@ -64,9 +64,9 @@ (DEFUN |PARSE-SpecialKeyWord| () - (AND (MATCH-CURRENT-TOKEN 'IDENTIFIER) - (ACTION (SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) - (|unAbbreviateKeyword| (CURRENT-SYMBOL)))))) + (AND (|matchCurrentToken| 'IDENTIFIER) + (ACTION (SETF (|tokenSymbol| (|currentToken|)) + (|unAbbreviateKeyword| (|currentSymbol|)))))) (DEFUN |PARSE-SpecialCommand| () @@ -78,9 +78,9 @@ (|pushReduction| '|PARSE-SpecialCommand| (CONS '|show| (CONS (|popStack1|) NIL))) (MUST (|PARSE-CommandTail|))) - (AND (MEMBER (CURRENT-SYMBOL) |$noParseCommands|) - (ACTION (FUNCALL (CURRENT-SYMBOL)))) - (AND (MEMBER (CURRENT-SYMBOL) |$tokenCommands|) + (AND (MEMBER (|currentSymbol|) |$noParseCommands|) + (ACTION (FUNCALL (|currentSymbol|)))) + (AND (MEMBER (|currentSymbol|) |$tokenCommands|) (|PARSE-TokenList|) (MUST (|PARSE-TokenCommandTail|))) (AND (STAR REPEATOR (|PARSE-PrimaryOrQM|)) (MUST (|PARSE-CommandTail|))))) @@ -89,8 +89,8 @@ (DEFUN |PARSE-TokenList| () (STAR REPEATOR (AND (NOT (|isTokenDelimiter|)) - (|pushReduction| '|PARSE-TokenList| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN))))) + (|pushReduction| '|PARSE-TokenList| (|currentSymbol|)) + (ACTION (|advanceToken|))))) (DEFUN |PARSE-TokenCommandTail| () @@ -194,7 +194,7 @@ (DEFUN |PARSE-Expression| () (AND (|PARSE-Expr| - (|PARSE-rightBindingPowerOf| (MAKE-SYMBOL-OF PRIOR-TOKEN) + (|PARSE-rightBindingPowerOf| (|makeSymbolOf| |$priorToken|) |ParseMode|)) (|pushReduction| '|PARSE-Expression| (|popStack1|)))) @@ -272,8 +272,8 @@ (CONS (|popStack1|) NIL))))))) (DEFUN |PARSE-Infix| () - (AND (|pushReduction| '|PARSE-Infix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (AND (|pushReduction| '|PARSE-Infix| (|currentSymbol|)) + (ACTION (|advanceToken|)) (OPTIONAL (|PARSE-TokTail|)) (MUST (|PARSE-Expression|)) (|pushReduction| '|PARSE-Infix| (CONS (|popStack2|) @@ -281,16 +281,16 @@ (DEFUN |PARSE-Prefix| () - (AND (|pushReduction| '|PARSE-Prefix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (AND (|pushReduction| '|PARSE-Prefix| (|currentSymbol|)) + (ACTION (|advanceToken|)) (OPTIONAL (|PARSE-TokTail|)) (MUST (|PARSE-Expression|)) (|pushReduction| '|PARSE-Prefix| (CONS (|popStack2|) (CONS (|popStack1|) NIL))))) (DEFUN |PARSE-Suffix| () - (AND (|pushReduction| '|PARSE-Suffix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (AND (|pushReduction| '|PARSE-Suffix| (|currentSymbol|)) + (ACTION (|advanceToken|)) (OPTIONAL (|PARSE-TokTail|)) (|pushReduction| '|PARSE-Suffix| (CONS (|popStack1|) (CONS (|popStack1|) NIL))))) @@ -298,13 +298,13 @@ (DEFUN |PARSE-TokTail| () (PROG (G1) (RETURN - (AND (EQ (CURRENT-SYMBOL) '$) + (AND (EQ (|currentSymbol|) '$) (OR (ALPHA-CHAR-P (CURRENT-CHAR)) (CHAR-EQ (CURRENT-CHAR) "$") (CHAR-EQ (CURRENT-CHAR) "%") (CHAR-EQ (CURRENT-CHAR) "(")) - (ACTION (SETQ G1 (COPY-TOKEN PRIOR-TOKEN))) - (|PARSE-Qualification|) (ACTION (SETQ PRIOR-TOKEN G1)))))) + (ACTION (SETQ G1 (|copyToken| |$priorToken|))) + (|PARSE-Qualification|) (ACTION (SETQ |$priorToken| G1)))))) (DEFUN |PARSE-Qualification| () @@ -335,8 +335,8 @@ (DEFUN |PARSE-Catch| () (AND (MATCH-SPECIAL ";") (MATCH-KEYWORD-NEXT "catch") - (ACTION (ADVANCE-TOKEN)) - (ACTION (ADVANCE-TOKEN)) + (ACTION (|advanceToken|)) + (ACTION (|advanceToken|)) (MUST (|PARSE-GlyphTok| "(")) (MUST (|PARSE-QuantifiedVariable|)) (MUST (MATCH-ADVANCE-SPECIAL ")")) @@ -349,8 +349,8 @@ (DEFUN |PARSE-Finally| () (AND (MATCH-SPECIAL ";") (MATCH-KEYWORD-NEXT "finally") - (ACTION (ADVANCE-TOKEN)) - (ACTION (ADVANCE-TOKEN)) + (ACTION (|advanceToken|)) + (ACTION (|advanceToken|)) (MUST (|PARSE-Expression|)))) (DEFUN |PARSE-Try| () @@ -377,9 +377,9 @@ (DEFUN |PARSE-Jump| () - (LET ((S (CURRENT-SYMBOL))) + (LET ((S (|currentSymbol|))) (AND S - (ACTION (ADVANCE-TOKEN)) + (ACTION (|advanceToken|)) (|pushReduction| '|PARSE-Jump| S)))) @@ -421,7 +421,7 @@ (DEFUN |PARSE-ElseClause| () - (OR (AND (EQ (CURRENT-SYMBOL) '|if|) (|PARSE-Conditional|)) + (OR (AND (EQ (|currentSymbol|) '|if|) (|PARSE-Conditional|)) (|PARSE-Expression|))) @@ -512,8 +512,8 @@ (DEFUN |PARSE-Operation| (|ParseMode| RBP) (DECLARE (SPECIAL |ParseMode| RBP)) - (AND (NOT (MATCH-CURRENT-TOKEN 'IDENTIFIER)) - (GETL (SETQ |tmptok| (CURRENT-SYMBOL)) |ParseMode|) + (AND (NOT (|matchCurrentToken| 'IDENTIFIER)) + (GETL (SETQ |tmptok| (|currentSymbol|)) |ParseMode|) (LT RBP (|PARSE-leftBindingPowerOf| |tmptok| |ParseMode|)) (ACTION (SETQ RBP (|PARSE-rightBindingPowerOf| |tmptok| |ParseMode|))) @@ -545,10 +545,10 @@ (DEFUN |PARSE-ReductionOp| () - (AND (GETL (CURRENT-SYMBOL) '|Led|) - (MATCH-NEXT-TOKEN 'GLIPH '/) - (|pushReduction| '|PARSE-ReductionOp| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (ACTION (ADVANCE-TOKEN)))) + (AND (GETL (|currentSymbol|) '|Led|) + (|matchNextToken| 'GLIPH '/) + (|pushReduction| '|PARSE-ReductionOp| (|currentSymbol|)) + (ACTION (|advanceToken|)) (ACTION (|advanceToken|)))) (DEFUN |PARSE-Form| () @@ -576,7 +576,7 @@ (DEFUN |PARSE-Selector| () - (OR (AND NONBLANK (EQ (CURRENT-SYMBOL) '|.|) + (OR (AND |$nonblank| (EQ (|currentSymbol|) '|.|) (CHAR-NE (CURRENT-CHAR) '| |) (MATCH-ADVANCE-STRING ".") (MUST (|PARSE-PrimaryNoFloat|)) (MUST (|pushReduction| '|PARSE-Selector| @@ -599,7 +599,7 @@ (DEFUN |PARSE-Primary1| () (OR (AND (|PARSE-VarForm|) (OPTIONAL - (AND NONBLANK (EQ (CURRENT-SYMBOL) '|(|) + (AND |$nonblank| (EQ (|currentSymbol|) '|(|) (MUST (|PARSE-Primary1|)) (|pushReduction| '|PARSE-Primary1| (CONS (|popStack2|) (CONS (|popStack1|) NIL)))))) @@ -613,7 +613,7 @@ (DEFUN |PARSE-Float| () (AND (|PARSE-FloatBase|) - (MUST (OR (AND NONBLANK (|PARSE-FloatExponent|)) + (MUST (OR (AND |$nonblank| (|PARSE-FloatExponent|)) (|pushReduction| '|PARSE-Float| 0))) (|pushReduction| '|PARSE-Float| (MAKE-FLOAT (|popStack4|) (|popStack2|) (|popStack2|) @@ -621,14 +621,14 @@ (DEFUN |PARSE-FloatBase| () - (OR (AND (INTEGERP (CURRENT-SYMBOL)) (CHAR-EQ (CURRENT-CHAR) ".") + (OR (AND (INTEGERP (|currentSymbol|)) (CHAR-EQ (CURRENT-CHAR) ".") (CHAR-NE (NEXT-CHAR) ".") (|PARSE-IntegerTok|) (MUST (|PARSE-FloatBasePart|))) - (AND (INTEGERP (CURRENT-SYMBOL)) + (AND (INTEGERP (|currentSymbol|)) (CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) 'E) (|PARSE-IntegerTok|) (|pushReduction| '|PARSE-FloatBase| 0) (|pushReduction| '|PARSE-FloatBase| 0)) - (AND (DIGITP (CURRENT-CHAR)) (EQ (CURRENT-SYMBOL) '|.|) + (AND (DIGITP (CURRENT-CHAR)) (EQ (|currentSymbol|) '|.|) (|pushReduction| '|PARSE-FloatBase| 0) (|PARSE-FloatBasePart|)))) @@ -637,7 +637,7 @@ (AND (MATCH-ADVANCE-STRING ".") (MUST (OR (AND (DIGITP (CURRENT-CHAR)) (|pushReduction| '|PARSE-FloatBasePart| - (TOKEN-NONBLANK (CURRENT-TOKEN))) + (|tokenNonblank?| (|currentToken|))) (|PARSE-IntegerTok|)) (AND (|pushReduction| '|PARSE-FloatBasePart| 0) (|pushReduction| '|PARSE-FloatBasePart| 0)))))) @@ -646,8 +646,8 @@ (DEFUN |PARSE-FloatExponent| () (PROG (G1) (RETURN - (OR (AND (MEMBER (CURRENT-SYMBOL) '(E |e|)) - (FIND (CURRENT-CHAR) "+-") (ACTION (ADVANCE-TOKEN)) + (OR (AND (MEMBER (|currentSymbol|) '(E |e|)) + (FIND (CURRENT-CHAR) "+-") (ACTION (|advanceToken|)) (MUST (OR (|PARSE-IntegerTok|) (AND (MATCH-ADVANCE-STRING "+") (MUST (|PARSE-IntegerTok|))) @@ -656,9 +656,9 @@ (|pushReduction| '|PARSE-FloatExponent| (MINUS (|popStack1|)))) (|pushReduction| '|PARSE-FloatExponent| 0)))) - (AND (IDENTP (CURRENT-SYMBOL)) - (SETQ G1 (FLOATEXPID (CURRENT-SYMBOL))) - (ACTION (ADVANCE-TOKEN)) + (AND (IDENTP (|currentSymbol|)) + (SETQ G1 (FLOATEXPID (|currentSymbol|))) + (ACTION (|advanceToken|)) (|pushReduction| '|PARSE-FloatExponent| G1)))))) @@ -724,7 +724,7 @@ (DEFUN |PARSE-Scripts| () - (AND NONBLANK (MATCH-ADVANCE-STRING "[") (MUST (|PARSE-ScriptItem|)) + (AND |$nonblank| (MATCH-ADVANCE-STRING "[") (MUST (|PARSE-ScriptItem|)) (MUST (MATCH-ADVANCE-STRING "]")))) @@ -754,7 +754,7 @@ (DEFUN |PARSE-Sexpr| () - (AND (ACTION (ADVANCE-TOKEN)) (|PARSE-Sexpr1|))) + (AND (ACTION (|advanceToken|)) (|PARSE-Sexpr1|))) (DEFUN |PARSE-Sexpr1| () @@ -791,21 +791,21 @@ (DEFUN |PARSE-NBGliphTok| (|tok|) (DECLARE (SPECIAL |tok|)) - (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) NONBLANK - (ACTION (ADVANCE-TOKEN)))) + (AND (|matchCurrentToken| 'GLIPH |tok|) |$nonblank| + (ACTION (|advanceToken|)))) (DEFUN |PARSE-GlyphTok| (|tok|) (DECLARE (SPECIAL |tok|)) - (AND (MATCH-CURRENT-TOKEN 'GLIPH (INTERN |tok|)) - (ACTION (ADVANCE-TOKEN)))) + (AND (|matchCurrentToken| 'GLIPH (INTERN |tok|)) + (ACTION (|advanceToken|)))) (DEFUN |PARSE-AnyId| () (OR (|PARSE-Name|) (OR (AND (MATCH-STRING "$") - (|pushReduction| '|PARSE-AnyId| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN))) + (|pushReduction| '|PARSE-AnyId| (|currentSymbol|)) + (ACTION (|advanceToken|))) (PARSE-KEYWORD) (|PARSE-OperatorFunctionName|)))) @@ -833,7 +833,7 @@ (DEFUN |PARSE-OpenBracket| () - (LET ((G1 (CURRENT-SYMBOL))) + (LET ((G1 (|currentSymbol|))) (AND (EQ (|getToken| G1) '[) (MUST (OR (AND (EQCAR G1 '|elt|) (|pushReduction| '|PARSE-OpenBracket| @@ -841,11 +841,11 @@ (CONS (CADR G1) (CONS '|construct| NIL))))) (|pushReduction| '|PARSE-OpenBracket| '|construct|))) - (ACTION (ADVANCE-TOKEN))))) + (ACTION (|advanceToken|))))) (DEFUN |PARSE-OpenBrace| () - (LET ((G1 (CURRENT-SYMBOL))) + (LET ((G1 (|currentSymbol|))) (AND (EQ (|getToken| G1) '{) (MUST (OR (AND (EQCAR G1 '|elt|) (|pushReduction| '|PARSE-OpenBrace| @@ -853,7 +853,7 @@ (CONS (CADR G1) (CONS '|brace| NIL))))) (|pushReduction| '|PARSE-OpenBrace| '|construct|))) - (ACTION (ADVANCE-TOKEN))))) + (ACTION (|advanceToken|))))) (DEFUN |PARSE-IteratorTail| () diff --git a/src/interp/lexing.boot b/src/interp/lexing.boot index d26ef72d..f0378625 100644 --- a/src/interp/lexing.boot +++ b/src/interp/lexing.boot @@ -41,6 +41,104 @@ namespace BOOT module lexing --% +--% Token abstract datatype. +--% Operational semantics: +--% structure Token == +--% Record(symbol: Identifier, type: TokenType, nonBlank?: Boolean) +--% +--% type in '(NUMBER IDENTIFIER SPECIAL_-CHAR) +--% nonBlank? if token is not preceded by a blank. +--% +makeToken(sym == nil, typ == nil, blnk? == true) == + [sym,typ,blnk?] + +macro copyToken t == + copyList t + +macro tokenSymbol t == + first t + +macro tokenType t == + second t + +macro tokenNonblank? t == + third t + +++ Last seen token +$priorToken := makeToken() + +++ Is there no blank in front of current token? +$nonblank := true + +++ First token in input stream +$currentToken := makeToken() + +++ Next token in input stream +$nextToken := makeToken() + +++ Number of token in the buffer (0, 1, 2) +$validTokens := 0 + +tokenInstall(sym,typ,tok,nonblank == true) == + tokenSymbol(tok) := sym + tokenType(tok) := typ + tokenNonblank?(tok) := nonblank + tok + +tryGetToken tok == + GET_-BOOT_-TOKEN tok => + $validTokens := $validTokens + 1 + tok + nil + +++ Returns the current token or gets a new one if necessary +currentToken() == + $validTokens > 0 => $currentToken + tryGetToken $currentToken + +++ Returns the token after the current token, or nil if there is none after +nextToken() == + currentToken() + $validTokens > 1 => $nextToken + tryGetToken $nextToken + +matchToken(tok,typ,sym == false) == + tok ~= nil and symbolEq?(tokenType tok,typ) and + (sym = nil or symbolEq?(sym,tokenSymbol tok)) and tok + +++ Return the current token if it has type `typ', and possibly the +++ same spelling as `sym'. +matchCurrentToken(typ,sym == nil) == + matchToken(currentToken(),typ,sym) + +++ Return the next token if it has type `typ;, and possibly the same +++ spelling as `sym'. +matchNextToken(typ,sym == nil) == + matchToken(nextToken(),typ,sym) + +++ Makes the next token be the current token. +advanceToken() == + $validTokens = 0 => tryGetToken $currentToken + $validTokens = 1 => + $validTokens := $validTokens - 1 + $priorToken := copyToken $currentToken + tryGetToken $currentToken + $validTokens = 2 => + $priorToken := copyToken $currentToken + $currentToken := copyToken $nextToken + $validTokens := $validTokens - 1 + nil + +makeSymbolOf tok == + tok = nil => nil + tokenSymbol tok = nil => nil + char? tokenSymbol tok => makeSymbol charString tokenSymbol tok + tokenSymbol tok + +currentSymbol() == + makeSymbolOf currentToken() + +--% --% Stack abstract datatype. --% Operational semantics: --% structure Stack == diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp index 532ed9e6..aeb493d1 100644 --- a/src/interp/metalex.lisp +++ b/src/interp/metalex.lisp @@ -38,7 +38,6 @@ ; ; 1. META File Handling ; 2. META Line Handling -; 3. META Token Handling ; 4. META Token Parsing Actions ; 5. META Error Handling @@ -56,7 +55,6 @@ ; 1. Data structure declarations (defstructs) for parsing objects ; ; A. Line Buffer -; C. Token ; 1A. A Line Buffer ; @@ -237,87 +235,9 @@ is a token separator, which blank is equivalent to." ((return nil))))) ; 1C. Token - -; FUNCTIONS DEFINED IN THIS SECTION: -; -; Make-Token, Token-Symbol, Token-Type, Token-Install, Token-Print - -(defstruct Token - "A token is a Symbol with a Type. -The type is either NUMBER, IDENTIFIER or SPECIAL-CHAR. -NonBlank is true if the token is not preceded by a blank." - (Symbol nil) - (Type nil) - (NonBlank t)) - -(defparameter Prior-Token (make-token) "What did I see last") -(defparameter nonblank t "Is there no blank in front of the current token.") -(defparameter Current-Token (make-token) "Token at head of input stream.") -(defparameter Next-Token (make-token) "Next token in input stream.") -(defparameter Valid-Tokens 0 "Number of tokens in buffer (0, 1 or 2)") - -(defun Token-Install (symbol type token &optional (nonblank t)) - (setf (token-symbol token) symbol - (token-type token) type - (token-nonblank token) nonblank) - token) - -; *** Match Token - -(defun match-token (token type &optional (symbol nil)) - (if (and token (eq (token-type token) type)) - (if symbol (if (equal symbol (token-symbol token)) token) token))) - -(defun match-current-token (type &optional (symbol nil)) - "Returns the current token if it has EQ type and (optionally) equal symbol." - (match-token (current-token) type symbol)) - -(defun match-next-token (type &optional (symbol nil)) - "Returns the next token if it has equal type and (optionally) equal symbol." - (match-token (next-token) type symbol)) - -; *** Current Token, Next Token, Advance Token - -(defun try-get-token (token) - (let ((tok (get-boot-token token))) - (if tok (progn (incf Valid-Tokens) token)))) - -(defun current-symbol () (make-symbol-of (current-token))) - -(defun make-symbol-of (token) - (let ((u (and token (token-symbol token)))) - (cond ((not u) nil) - ((characterp u) (intern (string u))) - (u)))) - (defun Token-Print (token) (format out-stream "(token (symbol ~S) (type ~S))~%" - (Token-Symbol token) (Token-Type token))) - -(defun current-token () - "Returns the current token getting a new one if necessary." - (if (> Valid-Tokens 0) - Current-Token - (try-get-token Current-Token))) - -(defun next-token () - "Returns the token after the current token, or NIL if there is none after." - (current-token) - (if (> Valid-Tokens 1) - Next-Token - (try-get-token Next-Token))) - -(defun advance-token () - "Makes the next token be the current token." - (case Valid-Tokens - (0 (try-get-token Current-Token)) - (1 (decf Valid-Tokens) - (setq Prior-Token (copy-token Current-Token)) - (try-get-token Current-Token)) - (2 (setq Prior-Token (copy-token Current-Token)) - (setq Current-Token (copy-token Next-Token)) - (decf Valid-Tokens)))) - + (|tokenSymbol| token) (|tokenType| token))) (defun reduce-stack-show () (let ((store (|stackStore| |$reduceStack|)) @@ -373,62 +293,62 @@ NonBlank is true if the token is not preceded by a blank." ; Tokens are acquired from a stream of characters. Lexical analysis is performed ; by the functiond Get Token. One-token lookahead is maintained in variables -; Current-Token and Next-Token by procedures Current Token, Next Token, and +; |$CurrentToken| and |$NextToken| by procedures Current Token, Next Token, and ; Advance Token. The functions Match Current Token and Match Next Token recognize ; classes of tokens, by type, or by type and symbol. The current and next tokens ; can be shoved back on the input stream (to the current line) with Unget-Tokens. (defmacro Defun-Parse-Token (token) `(defun ,(intern (concatenate 'string "PARSE-" (string token))) () - (let* ((tok (match-current-token ',token)) - (symbol (if tok (token-symbol tok)))) + (let* ((tok (|matchCurrentToken| ',token)) + (symbol (if tok (|tokenSymbol| tok)))) (if tok (progn (|pushReduction| ',(intern (concatenate 'string (string token) "-TOKEN")) (copy-tree symbol)) - (advance-token) + (|advanceToken|) t))))) (defun token-stack-show () - (if (= Valid-Tokens 0) (format t "~%There are no valid tokens.~%") - (format t "~%The number of valid tokens is ~S.~%" Valid-Tokens)) - (if (> Valid-Tokens 0) + (if (= |$validTokens| 0) (format t "~%There are no valid tokens.~%") + (format t "~%The number of valid tokens is ~S.~%" |$validTokens|)) + (if (> |$validTokens| 0) (progn (format t "The current token is~%") - (describe current-token))) - (if (> Valid-Tokens 1) + (describe |$currentToken|))) + (if (> |$validTokens| 1) (progn (format t "The next token is~%") - (describe next-token))) - (if (token-type prior-token) + (describe |$nextToken|))) + (if (|tokenType| |$priorToken|) (progn (format t "The prior token was~%") - (describe prior-token)))) + (describe |$priorToken|)))) (defmacro token-stack-clear () - `(progn (setq valid-tokens 0) - (token-install nil nil current-token nil) - (token-install nil nil next-token nil) - (token-install nil nil prior-token nil))) + `(progn (setq |$validTokens| 0) + (|tokenInstall| nil nil |$currentToken| nil) + (|tokenInstall| nil nil |$nextToken| nil) + (|tokenInstall| nil nil |$priorToken| nil))) ; Unget-Tokens (defun quote-if-string (token) - (if token ;only use token-type on non-null tokens - (case (token-type token) - (bstring (strconc "[" (token-symbol token) "]*")) - (string (strconc "'" (token-symbol token) "'")) - (spadstring (strconc "\"" (underscore (token-symbol token)) "\"")) - (number (format nil "~v,'0D" (token-nonblank token) - (token-symbol token))) - (special-char (string (token-symbol token))) - (identifier (let ((id (symbol-name (token-symbol token))) + (if token ;only use |tokenType| on non-null tokens + (case (|tokenType| token) + (bstring (strconc "[" (|tokenSymbol| token) "]*")) + (string (strconc "'" (|tokenSymbol| token) "'")) + (spadstring (strconc "\"" (underscore (|tokenSymbol| token)) "\"")) + (number (format nil "~v,'0D" (|tokenNonblank?| token) + (|tokenSymbol| token))) + (special-char (string (|tokenSymbol| token))) + (identifier (let ((id (symbol-name (|tokenSymbol| token))) (pack (package-name (symbol-package - (token-symbol token))))) + (|tokenSymbol| token))))) (if $SPAD (if (equal pack "BOOT") - (escape-keywords (underscore id) (token-symbol token)) + (escape-keywords (underscore id) (|tokenSymbol| token)) (concatenate 'string (underscore pack) "'" (underscore id))) id))) - (t (token-symbol token))) + (t (|tokenSymbol| token))) nil)) @@ -466,25 +386,25 @@ as keywords.") out-string))) (defun Unget-Tokens () - (case Valid-Tokens + (case |$validTokens| (0 t) - (1 (let* ((cursym (quote-if-string current-token)) + (1 (let* ((cursym (quote-if-string |$currentToken|)) (curline (line-current-segment current-line)) (revised-line (strconc cursym curline (copy-seq " ")))) (line-new-line revised-line current-line (line-number current-line)) - (setq NonBlank (token-nonblank current-token)) - (setq Valid-Tokens 0))) - (2 (let* ((cursym (quote-if-string current-token)) - (nextsym (quote-if-string next-token)) + (setq |$nonblank| (|tokenNonblank?| |$currentToken|)) + (setq |$validTokens| 0))) + (2 (let* ((cursym (quote-if-string |$currentToken|)) + (nextsym (quote-if-string |$nextToken|)) (curline (line-current-segment current-line)) (revised-line - (strconc (if (token-nonblank current-token) "" " ") + (strconc (if (|tokenNonblank?| |$currentToken|) "" " ") cursym - (if (token-nonblank next-token) "" " ") + (if (|tokenNonblank?| |$nextToken|) "" " ") nextsym curline " "))) - (setq NonBlank (token-nonblank current-token)) + (setq |$nonblank| (|tokenNonblank?| |$currentToken|)) (line-new-line revised-line current-line (line-number current-line)) - (setq Valid-Tokens 0))) + (setq |$validTokens| 0))) (t (error "How many tokens do you think you have?")))) (defun-parse-token STRING) @@ -499,12 +419,12 @@ as keywords.") (defun-parse-token ARGUMENT-DESIGNATOR) (defun |PARSE-OperatorFunctionName| () - (let ((id (make-symbol-of (or (match-current-token 'keyword) - (match-current-token 'gliph) - (match-current-token 'special-char))))) + (let ((id (|makeSymbolOf| (or (|matchCurrentToken| 'keyword) + (|matchCurrentToken| 'gliph) + (|matchCurrentToken| 'special-char))))) (when (and id (member id |$OperatorFunctionNames|)) (|pushReduction| '|PARSE-OperatorFunctionName| id) - (action (advance-token))))) + (action (|advanceToken|))))) ; Meta tokens fall into the following categories: ; @@ -569,7 +489,7 @@ as keywords.") (suffix (current-char) buf) (if (not (advance-char)) (go bye)) (go id)))) - bye (return (token-install (intern buf) 'identifier token)))) + bye (return (|tokenInstall| (intern buf) 'identifier token)))) (defun get-string-token (token) "With 'ABC' on IN-STREAM, extracts and stacks String 'ABC'." @@ -578,7 +498,7 @@ as keywords.") (progn (advance-char) (loop (case (current-char) (#\' (advance-char) - (return (token-install buf 'string token))) + (return (|tokenInstall| buf 'string token))) (#\\ (advance-char) (suffix (current-char) buf) (advance-char)) @@ -599,7 +519,7 @@ as keywords.") (#\] (if (char= (next-char) #\*) (progn (advance-char) (advance-char) - (return (token-install buf 'bstring token))) + (return (|tokenInstall| buf 'bstring token))) (progn (suffix (current-char) buf) (advance-char)))) (#\\ (advance-char) @@ -618,7 +538,7 @@ as keywords.") special character be the atom whose print name is the character itself." (let ((symbol (current-char))) (advance-char) - (token-install symbol 'special-char token))) + (|tokenInstall| symbol 'special-char token))) (defun get-number-token (token) "Take a number off the input stream." @@ -630,7 +550,7 @@ special character be the atom whose print name is the character itself." (advance-char) (go nu1)))) (advance-char) - (return (token-install (read-from-string buf) + (return (|tokenInstall| (read-from-string buf) 'number token (size buf) ;used to keep track of digit count )))) diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp index ae0b83f4..9aaf86ed 100644 --- a/src/interp/parsing.lisp +++ b/src/interp/parsing.lisp @@ -187,7 +187,7 @@ the stack, then stack a NIL. Return the value of prod." (defun Match-Advance-String (x) "Same as MATCH-STRING except if successful, advance inputstream past X." (let ((y (if (>= (length (string x)) - (length (string (quote-if-string (current-token))))) + (length (string (quote-if-string (|currentToken|))))) (Match-String x) nil))) ; must match at least the current token (if y (progn (incf (Line-Current-Index Current-Line) y) @@ -196,25 +196,23 @@ the stack, then stack a NIL. Return the value of prod." (elt (Line-Buffer Current-Line) (Line-Current-Index Current-Line))) (setf (Line-Current-Char Current-Line) #\Space)) - (setq prior-token - (make-token :Symbol (intern (string x)) - :Type 'identifier - :nonBlank nonblank)) + (setq |$priorToken| + (|makeToken| (intern (string x)) 'identifier |$nonblank|)) t)))) (defun match-advance-keyword (str) - (and (match-token (current-token) 'keyword (intern str)) - (action (advance-token)))) + (and (|matchToken| (|currentToken|) 'keyword (intern str)) + (action (|advanceToken|)))) (defun match-advance-special (str) - (and (match-token (current-token) 'special-char (character str)) - (action (advance-token)))) + (and (|matchToken| (|currentToken|) 'special-char (character str)) + (action (|advanceToken|)))) (defun match-special (str) - (match-token (current-token) 'special-char (character str))) + (|matchToken| (|currentToken|) 'special-char (character str))) (defun match-keyword-next (str) - (match-token (next-token) 'keyword (intern str))) + (|matchToken| (|nextToken|) 'keyword (intern str))) (defun initial-substring-p (part whole) "Returns length of part if part matches initial segment of whole." @@ -239,7 +237,7 @@ the stack, then stack a NIL. Return the value of prod." (defun conversation1 (firstfun procfun) (prog nil top(cond ((not (Current-Char)) (return nil)) - ((and (current-token) (next-token)) (go top)) + ((and (|currentToken|) (|nextToken|)) (go top)) ((compfin) (return 't)) ((and (funcall firstfun) (or (funcall procfun (|popStack1|)))) |