* boot/tokens.boot (%Token): New datatype.

	(makeToken): New.
	* boot/includer.boot: Use %token accessors.
	* boot/parser.boot: Likewise.
	* boot/pile.boot: Likewise.
	* boot/scanner.boot: Likewise.
	* boot/utility.boot: Export subString.

5 files changed, 62 insertions, 71 deletions

diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp
index f087ddb7..7dce3190 100644
--- a/src/boot/strap/includer.clisp
+++ b/src/boot/strap/includer.clisp
@@ -27,7 +27,7 @@
 (DEFUN |diagnosticLocation| (|tok|)
   (LET* (|pos|)
     (PROGN
-     (SETQ |pos| (|shoeTokPosn| |tok|))
+     (SETQ |pos| (|tokenPosition| |tok|))
      (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column "
              (WRITE-TO-STRING (|lineCharacter| |pos|))))))
 
@@ -40,7 +40,7 @@
 
 (DEFUN |bpSpecificErrorAtToken| (|tok| |key|)
   (LET* (|a|)
-    (PROGN (SETQ |a| (|shoeTokPosn| |tok|)) (|SoftShoeError| |a| |key|))))
+    (PROGN (SETQ |a| (|tokenPosition| |tok|)) (|SoftShoeError| |a| |key|))))
 
 (DEFUN |bpSpecificErrorHere| (|key|)
   (DECLARE (SPECIAL |$stok|))
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index fa16a127..53eb4f53 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -15,9 +15,9 @@
    (SETQ |$stok|
            (COND
             ((NULL |$inputStream|)
-             (|shoeTokConstruct| 'ERROR 'NOMORE (|shoeTokPosn| |$stok|)))
+             (|mk%Token| 'ERROR 'NOMORE (|tokenPosition| |$stok|)))
             (T (CAR |$inputStream|))))
-   (SETQ |$ttok| (|shoeTokPart| |$stok|))
+   (SETQ |$ttok| (|tokenValue| |$stok|))
    T))
 
 (DEFUN |bpFirstTok| ()
@@ -26,11 +26,11 @@
    (SETQ |$stok|
            (COND
             ((NULL |$inputStream|)
-             (|shoeTokConstruct| 'ERROR 'NOMORE (|shoeTokPosn| |$stok|)))
+             (|mk%Token| 'ERROR 'NOMORE (|tokenPosition| |$stok|)))
             (T (CAR |$inputStream|))))
-   (SETQ |$ttok| (|shoeTokPart| |$stok|))
+   (SETQ |$ttok| (|tokenValue| |$stok|))
    (COND
-    ((AND (PLUSP |$bpParenCount|) (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY))
+    ((AND (PLUSP |$bpParenCount|) (EQ (|tokenClass| |$stok|) 'KEY))
      (COND ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|))
            ((EQ |$ttok| 'BACKTAB) (SETQ |$bpCount| (- |$bpCount| 1))
             (|bpNext|))
@@ -243,16 +243,15 @@
 
 (DEFUN |bpEqPeek| (|s|)
   (DECLARE (SPECIAL |$ttok| |$stok|))
-  (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|)))
+  (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|)))
 
 (DEFUN |bpEqKey| (|s|)
   (DECLARE (SPECIAL |$ttok| |$stok|))
-  (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNext|)))
+  (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNext|)))
 
 (DEFUN |bpEqKeyNextTok| (|s|)
   (DECLARE (SPECIAL |$ttok| |$stok|))
-  (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|)
-       (|bpNextToken|)))
+  (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNextToken|)))
 
 (DEFUN |bpPileTrap| () (|bpMissing| 'BACKTAB))
 
@@ -284,9 +283,9 @@
     (DECLARE (SPECIAL |$stok|))
     (PROGN
      (|bpFirstToken|)
-     (SETQ |pos1| (|shoeTokPosn| |$stok|))
+     (SETQ |pos1| (|tokenPosition| |$stok|))
      (|bpMoveTo| 0)
-     (SETQ |pos2| (|shoeTokPosn| |$stok|))
+     (SETQ |pos2| (|tokenPosition| |$stok|))
      (|bpIgnoredFromTo| |pos1| |pos2|)
      (|bpPush| (LIST (LIST "pile syntax error"))))))
 
@@ -352,27 +351,26 @@
   (DECLARE (SPECIAL |$stok|))
   (COND
    ((|bpEqPeek| 'COLON-COLON) (|bpNext|)
-    (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (|bpPushId|) (|bpNext|)
+    (AND (EQ (|tokenClass| |$stok|) 'ID) (|bpPushId|) (|bpNext|)
          (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|)))))
    (T NIL)))
 
 (DEFUN |bpName| ()
   (DECLARE (SPECIAL |$stok|))
   (COND
-   ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID)) (|bpPushId|) (|bpNext|)
+   ((EQ (|tokenClass| |$stok|) 'ID) (|bpPushId|) (|bpNext|)
     (|bpAnyNo| #'|bpQualifiedName|))
    (T NIL)))
 
 (DEFUN |bpConstTok| ()
   (DECLARE (SPECIAL |$ttok| |$stok|))
   (COND
-   ((|symbolMember?| (|shoeTokType| |$stok|) '(INTEGER FLOAT))
+   ((|symbolMember?| (|tokenClass| |$stok|) '(INTEGER FLOAT))
     (|bpPush| |$ttok|) (|bpNext|))
-   ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISP))
+   ((EQ (|tokenClass| |$stok|) 'LISP)
     (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|)))
-   ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISPEXP))
-    (AND (|bpPush| |$ttok|) (|bpNext|)))
-   ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LINE))
+   ((EQ (|tokenClass| |$stok|) 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|)))
+   ((EQ (|tokenClass| |$stok|) 'LINE)
     (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|)))
    ((|bpEqPeek| 'QUOTE) (|bpNext|)
     (AND (|bpRequire| #'|bpSexp|) (|bpPush| (|bfSymbol| (|bpPop1|)))))
@@ -382,7 +380,7 @@
   (LET* (|ISTMP#1| |s| |a|)
     (DECLARE (SPECIAL |$ttok| |$stok|))
     (COND
-     ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (EQ |$ttok| '|char|))
+     ((AND (EQ (|tokenClass| |$stok|) 'ID) (EQ |$ttok| '|char|))
       (SETQ |a| (|bpState|))
       (COND
        ((|bpApplication|) (SETQ |s| (|bpPop1|))
@@ -496,10 +494,10 @@
   (DECLARE (SPECIAL |$stok|))
   (COND ((EQL |n| 0) NIL)
         ((PLUSP |n|)
-         (CONS (|shoeTokConstruct| 'KEY 'SETTAB (|shoeTokPosn| |$stok|))
+         (CONS (|mk%Token| 'KEY 'SETTAB (|tokenPosition| |$stok|))
                (|bpAddTokens| (- |n| 1))))
         (T
-         (CONS (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeTokPosn| |$stok|))
+         (CONS (|mk%Token| 'KEY 'BACKTAB (|tokenPosition| |$stok|))
                (|bpAddTokens| (+ |n| 1))))))
 
 (DEFUN |bpExceptions| ()
@@ -511,7 +509,7 @@
   (LET* (|a|)
     (DECLARE (SPECIAL |$ttok| |$stok|))
     (COND
-     ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (NOT (|bpExceptions|)))
+     ((AND (EQ (|tokenClass| |$stok|) 'KEY) (NOT (|bpExceptions|)))
       (SETQ |a| (GET |$ttok| 'SHOEINF))
       (COND ((NULL |a|) (AND (|bpPush| (|keywordId| |$ttok|)) (|bpNext|)))
             (T (AND (|bpPush| |a|) (|bpNext|)))))
@@ -520,11 +518,10 @@
 (DEFUN |bpAnyId| ()
   (DECLARE (SPECIAL |$ttok| |$stok|))
   (OR
-   (AND (|bpEqKey| 'MINUS)
-        (OR (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'INTEGER)) (|bpTrap|))
+   (AND (|bpEqKey| 'MINUS) (OR (EQ (|tokenClass| |$stok|) 'INTEGER) (|bpTrap|))
         (|bpPush| (- |$ttok|)) (|bpNext|))
    (|bpSexpKey|)
-   (AND (|symbolMember?| (|shoeTokType| |$stok|) '(ID INTEGER STRING FLOAT))
+   (AND (|symbolMember?| (|tokenClass| |$stok|) '(ID INTEGER STRING FLOAT))
         (|bpPush| |$ttok|) (|bpNext|))))
 
 (DEFUN |bpSexp| ()
@@ -559,13 +556,13 @@
 
 (DEFUN |bpPrefixOperator| ()
   (DECLARE (SPECIAL |$ttok| |$stok|))
-  (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE)
-       (|bpPushId|) (|bpNext|)))
+  (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|)
+       (|bpNext|)))
 
 (DEFUN |bpInfixOperator| ()
   (DECLARE (SPECIAL |$ttok| |$stok|))
-  (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEINF)
-       (|bpPushId|) (|bpNext|)))
+  (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|)
+       (|bpNext|)))
 
 (DEFUN |bpSelector| ()
   (AND (|bpEqKey| 'DOT)
@@ -599,7 +596,7 @@
 
 (DEFUN |bpInfKey| (|s|)
   (DECLARE (SPECIAL |$ttok| |$stok|))
-  (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (|symbolMember?| |$ttok| |s|)
+  (AND (EQ (|tokenClass| |$stok|) 'KEY) (|symbolMember?| |$ttok| |s|)
        (|bpPushId|) (|bpNext|)))
 
 (DEFUN |bpInfGeneric| (|s|) (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T)))
@@ -632,7 +629,7 @@
 
 (DEFUN |bpString| ()
   (DECLARE (SPECIAL |$ttok| |$stok|))
-  (AND (EQ (|shoeTokType| |$stok|) 'STRING)
+  (AND (EQ (|tokenClass| |$stok|) 'STRING)
        (|bpPush| (|quote| (INTERN |$ttok|))) (|bpNext|)))
 
 (DEFUN |bpFunction| ()
@@ -642,8 +639,8 @@
 (DEFUN |bpThetaName| ()
   (DECLARE (SPECIAL |$ttok| |$stok|))
   (COND
-   ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (GET |$ttok| 'SHOETHETA))
-    (|bpPushId|) (|bpNext|))
+   ((AND (EQ (|tokenClass| |$stok|) 'ID) (GET |$ttok| 'SHOETHETA)) (|bpPushId|)
+    (|bpNext|))
    (T NIL)))
 
 (DEFUN |bpReduceOperator| ()
@@ -1038,7 +1035,7 @@
 
 (DEFUN |bpBVString| ()
   (DECLARE (SPECIAL |$ttok| |$stok|))
-  (AND (EQ (|shoeTokType| |$stok|) 'STRING)
+  (AND (EQ (|tokenClass| |$stok|) 'STRING)
        (|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|)))
 
 (DEFUN |bpRegularBVItemL| ()
diff --git a/src/boot/strap/pile.clisp b/src/boot/strap/pile.clisp
index 516327d2..6eb0c938 100644
--- a/src/boot/strap/pile.clisp
+++ b/src/boot/strap/pile.clisp
@@ -7,16 +7,16 @@
 
 (PROVIDE "pile")
 
-(DEFUN |shoeFirstTokPosn| (|t|) (|shoeTokPosn| (CAAR |t|)))
+(DEFUN |shoeFirstTokPosn| (|t|) (|tokenPosition| (CAAR |t|)))
 
-(DEFUN |shoeLastTokPosn| (|t|) (|shoeTokPosn| (CADR |t|)))
+(DEFUN |shoeLastTokPosn| (|t|) (|tokenPosition| (CADR |t|)))
 
-(DEFUN |shoePileColumn| (|t|) (CDR (|shoeTokPosn| (CAAR |t|))))
+(DEFUN |shoePileColumn| (|t|) (CDR (|tokenPosition| (CAAR |t|))))
 
 (DEFUN |shoePileInsert| (|s|)
   (LET* (|a| |toktype|)
     (COND ((|bStreamNull| |s|) (CONS NIL |s|))
-          (T (SETQ |toktype| (|shoeTokType| (CAAAR |s|)))
+          (T (SETQ |toktype| (|tokenClass| (CAAAR |s|)))
            (COND
             ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE))
              (CONS (LIST (CAR |s|)) (CDR |s|)))
@@ -93,12 +93,12 @@
     (COND ((NULL |b|) (LIST |a|))
           (T (SETQ |c| (CAR |b|))
            (COND
-            ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN)
-                 (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE))
+            ((OR (EQ (|tokenValue| (CAAR |c|)) 'THEN)
+                 (EQ (|tokenValue| (CAAR |c|)) 'ELSE))
              (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
-            (T (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|))
+            (T (SETQ |d| (CADR |a|)) (SETQ |e| (|tokenValue| |d|))
              (COND
-              ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY)
+              ((AND (EQ (|tokenClass| |d|) 'KEY)
                     (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA)
                         (EQ |e| 'SEMICOLON)))
                (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
@@ -110,15 +110,12 @@
           (T (SETQ |a| (CAR |x|))
            (SETQ |semicolon|
                    (|dqUnit|
-                    (|shoeTokConstruct| 'KEY 'BACKSET
-                                        (|shoeLastTokPosn| |a|))))
+                    (|mk%Token| 'KEY 'BACKSET (|shoeLastTokPosn| |a|))))
            (|dqConcat|
             (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|))))))))
 
 (DEFUN |shoeEnPile| (|x|)
   (|dqConcat|
-   (LIST (|dqUnit| (|shoeTokConstruct| 'KEY 'SETTAB (|shoeFirstTokPosn| |x|)))
-         |x|
-         (|dqUnit|
-          (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeLastTokPosn| |x|))))))
+   (LIST (|dqUnit| (|mk%Token| 'KEY 'SETTAB (|shoeFirstTokPosn| |x|))) |x|
+         (|dqUnit| (|mk%Token| 'KEY 'BACKTAB (|shoeLastTokPosn| |x|))))))
 
diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp
index 958f768b..3c056e11 100644
--- a/src/boot/strap/scanner.clisp
+++ b/src/boot/strap/scanner.clisp
@@ -23,19 +23,6 @@
 
 (DEFUN |dqToList| (|s|) (COND ((NULL |s|) NIL) (T (CAR |s|))))
 
-(DEFUN |shoeTokConstruct| (|x| |y| |z|) (CONS |x| (CONS |y| |z|)))
-
-(DEFUN |shoeConstructToken| (|lp| |b| |n|)
-  (|shoeTokConstruct| (ELT |b| 0) (ELT |b| 1) (CONS |lp| |n|)))
-
-(DEFUN |shoeTokType| (|x|) (CAR |x|))
-
-(DEFUN |shoeTokPart| (|x|) (CADR |x|))
-
-(DEFUN |shoeTokPosn| (|x|)
-  (LET* (|p|)
-    (PROGN (SETQ |p| (CDDR |x|)) |p|)))
-
 (DEFUN |shoeNextLine| (|s|)
   (LET* (|s1| |a|)
     (DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|))
@@ -72,8 +59,7 @@
             ((SETQ |command| (|shoeLine?| |$ln|))
              (SETQ |dq|
                      (|dqUnit|
-                      (|shoeConstructToken| |$linepos|
-                                            (|shoeLeafLine| |command|) 0)))
+                      (|makeToken| |$linepos| (|shoeLeafLine| |command|) 0)))
              (CONS (LIST |dq|) |$r|))
             ((SETQ |command| (|shoeLisp?| |$ln|))
              (|shoeLispToken| |$r| |command|))
@@ -97,9 +83,7 @@
      (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|))
      (SETQ |r| (CAR |LETTMP#1|))
      (SETQ |st| (CDR |LETTMP#1|))
-     (SETQ |dq|
-             (|dqUnit|
-              (|shoeConstructToken| |linepos| (|shoeLeafLisp| |st|) 0)))
+     (SETQ |dq| (|dqUnit| (|makeToken| |linepos| (|shoeLeafLisp| |st|) 0)))
      (CONS (LIST |dq|) |r|))))
 
 (DEFUN |shoeAccumulateLines| (|s| |string|)
@@ -146,8 +130,7 @@
                    ((CHAR= |ch| (|char| '_)) (|shoeEscape|))
                    ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL)
                    (T (|shoeError|))))
-     (COND ((NULL |b|) NIL)
-           (T (|dqUnit| (|shoeConstructToken| |linepos| |b| |n|)))))))
+     (COND ((NULL |b|) NIL) (T (|dqUnit| (|makeToken| |linepos| |b| |n|)))))))
 
 (DEFUN |shoeLeafId| (|x|) (LIST 'ID (INTERN |x|)))
 
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index d75c74a2..abb77212 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -6,12 +6,26 @@
 (PROVIDE "tokens")
 
 (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
-  (EXPORT '(|$InteractiveMode| |char|)))
+  (EXPORT '(|$InteractiveMode| |char| |subString|)))
 
 (DECLAIM (FTYPE (FUNCTION (|%Symbol|) |%Char|) |char|))
 
 (DEFPARAMETER |$InteractiveMode| NIL)
 
+(DEFSTRUCT (|%Token| (:COPIER |copy%Token|)) |cls| |val| |pos|)
+
+(DEFMACRO |mk%Token| (|cls| |val| |pos|)
+  (LIST '|MAKE-%Token| :|cls| |cls| :|val| |val| :|pos| |pos|))
+
+(DEFMACRO |tokenClass| (|bfVar#1|) (LIST '|%Token-cls| |bfVar#1|))
+
+(DEFMACRO |tokenValue| (|bfVar#1|) (LIST '|%Token-val| |bfVar#1|))
+
+(DEFMACRO |tokenPosition| (|bfVar#1|) (LIST '|%Token-pos| |bfVar#1|))
+
+(DEFUN |makeToken| (|lp| |b| |n|)
+  (|mk%Token| (CAR |b|) (CADR |b|) (CONS |lp| |n|)))
+
 (DEFUN |char| (|x|) (SCHAR (SYMBOL-NAME |x|) 0))
 
 (DEFUN |shoeStartsId| (|x|)