aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog8
-rw-r--r--src/interp/bootlex.lisp22
-rw-r--r--src/interp/fnewmeta.lisp114
-rw-r--r--src/interp/lexing.boot98
-rw-r--r--src/interp/metalex.lisp176
-rw-r--r--src/interp/parsing.lisp22
6 files changed, 232 insertions, 208 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 31d4aa5d..2b59d00f 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,13 @@
2011-10-04 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/lexing.boot: Add support for Token abstract datatype.
+ * interp/bootlex.lisp: Use it.
+ * interp/fnewmeta.lisp: Likewise.
+ * interp/metalex.lisp: Likewise. Remove old token structure and
+ associated functions.
+
+2011-10-04 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* interp/lexing.boot (stackClear!): Fix typo.
Add new grammar reduction abstract datatype facility.
* interp/fnewmeta.lisp: Use it.
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|))))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 00:08:49 +0000