aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/ChangeLog10
-rw-r--r--src/boot/includer.boot6
-rw-r--r--src/boot/parser.boot58
-rw-r--r--src/boot/pile.boot22
-rw-r--r--src/boot/scanner.boot24
-rw-r--r--src/boot/strap/includer.clisp4
-rw-r--r--src/boot/strap/parser.clisp65
-rw-r--r--src/boot/strap/pile.clisp25
-rw-r--r--src/boot/strap/scanner.clisp23
-rw-r--r--src/boot/strap/tokens.clisp16
-rw-r--r--src/boot/tokens.boot16
-rw-r--r--src/boot/utility.boot2
-rw-r--r--src/interp/sys-utility.boot6
13 files changed, 135 insertions, 142 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 3f7b04b3..76d98aa1 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,15 @@
2012-05-22 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * 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.
+
+2012-05-22 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* interp/lexing.boot (%Token): Now an actual type defined as a
record structure.
(copyToken): Adjust.
diff --git a/src/boot/includer.boot b/src/boot/includer.boot
index 0d85ab14..d36932d5 100644
--- a/src/boot/includer.boot
+++ b/src/boot/includer.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -88,7 +88,7 @@ shoeSpaces n ==
--%
diagnosticLocation tok ==
- pos := shoeTokPosn tok
+ pos := tokenPosition tok
strconc('"line ", toString lineNo pos, '", column ",
toString lineCharacter pos)
@@ -99,7 +99,7 @@ SoftShoeError(posn,key)==
shoeConsole key
bpSpecificErrorAtToken(tok, key) ==
- a := shoeTokPosn tok
+ a := tokenPosition tok
SoftShoeError(a,key)
bpSpecificErrorHere(key) ==
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index e698c359..414f21ca 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -48,17 +48,17 @@ module parser
bpFirstToken()==
$stok:=
- $inputStream = nil => shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok)
+ $inputStream = nil => mk%Token("ERROR","NOMORE",tokenPosition $stok)
first $inputStream
- $ttok := shoeTokPart $stok
+ $ttok := tokenValue $stok
true
bpFirstTok()==
$stok:=
- $inputStream = nil => shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok)
+ $inputStream = nil => mk%Token("ERROR","NOMORE",tokenPosition $stok)
first $inputStream
- $ttok:=shoeTokPart $stok
- $bpParenCount>0 and $stok is ["KEY",:.] =>
+ $ttok := tokenValue $stok
+ $bpParenCount > 0 and tokenClass $stok = "KEY" =>
$ttok is "SETTAB" =>
$bpCount:=$bpCount+1
bpNext()
@@ -244,13 +244,13 @@ bpBacksetElse()==
bpEqKey "ELSE"
bpEqPeek s ==
- $stok is ["KEY",:.] and symbolEq?(s,$ttok)
+ tokenClass $stok = "KEY" and symbolEq?(s,$ttok)
bpEqKey s ==
- $stok is ["KEY",:.] and symbolEq?(s,$ttok) and bpNext()
+ tokenClass $stok = "KEY" and symbolEq?(s,$ttok) and bpNext()
bpEqKeyNextTok s ==
- $stok is ["KEY",:.] and symbolEq?(s,$ttok) and bpNextToken()
+ tokenClass $stok = "KEY" and symbolEq?(s,$ttok) and bpNextToken()
bpPileTrap() == bpMissing "BACKTAB"
bpBrackTrap(x) == bpMissingMate("]",x)
@@ -272,9 +272,9 @@ bpTrap()==
bpRecoverTrap()==
bpFirstToken()
- pos1 := shoeTokPosn $stok
+ pos1 := tokenPosition $stok
bpMoveTo 0
- pos2 := shoeTokPosn $stok
+ pos2 := tokenPosition $stok
bpIgnoredFromTo(pos1, pos2)
bpPush [['"pile syntax error"]]
@@ -352,7 +352,7 @@ bpMoveTo n==
bpQualifiedName() ==
bpEqPeek "COLON-COLON" =>
bpNext()
- $stok is ["ID",:.] and bpPushId() and bpNext()
+ tokenClass $stok = "ID" and bpPushId() and bpNext()
and bpPush bfColonColon(bpPop2(), bpPop1())
false
@@ -360,7 +360,7 @@ bpQualifiedName() ==
++ ID
++ Name :: ID
bpName() ==
- $stok is ["ID",:.] =>
+ tokenClass $stok = "ID" =>
bpPushId()
bpNext()
bpAnyNo function bpQualifiedName
@@ -375,12 +375,12 @@ bpName() ==
++ QUOTE S-Expression
++ STRING
bpConstTok() ==
- shoeTokType $stok in '(INTEGER FLOAT) =>
+ tokenClass $stok in '(INTEGER FLOAT) =>
bpPush $ttok
bpNext()
- $stok is ["LISP",:.] => bpPush %Lisp $ttok and bpNext()
- $stok is ["LISPEXP",:.] => bpPush $ttok and bpNext()
- $stok is ["LINE",:.] => bpPush ["+LINE", $ttok] and bpNext()
+ tokenClass $stok = "LISP" => bpPush %Lisp $ttok and bpNext()
+ tokenClass $stok = "LISPEXP" => bpPush $ttok and bpNext()
+ tokenClass $stok = "LINE" => bpPush ["+LINE", $ttok] and bpNext()
bpEqPeek "QUOTE" =>
bpNext()
bpRequire function bpSexp and
@@ -388,7 +388,7 @@ bpConstTok() ==
bpString() or bpFunction()
bpChar() ==
- $stok is ["ID",:.] and $ttok is "char" =>
+ tokenClass $stok = "ID" and $ttok is "char" =>
a := bpState()
bpApplication() =>
s := bpPop1()
@@ -538,8 +538,8 @@ bpCancel()==
bpAddTokens n==
n=0 => nil
- n>0=> [shoeTokConstruct("KEY","SETTAB",shoeTokPosn $stok),:bpAddTokens(n-1)]
- [shoeTokConstruct("KEY","BACKTAB",shoeTokPosn $stok),:bpAddTokens(n+1)]
+ n>0=> [mk%Token("KEY","SETTAB",tokenPosition $stok),:bpAddTokens(n-1)]
+ [mk%Token("KEY","BACKTAB",tokenPosition $stok),:bpAddTokens(n+1)]
bpExceptions()==
bpEqPeek "DOT" or bpEqPeek "QUOTE" or
@@ -549,17 +549,17 @@ bpExceptions()==
bpSexpKey()==
- $stok is ["KEY",:.] and not bpExceptions() =>
+ tokenClass $stok = "KEY" and not bpExceptions() =>
a := $ttok has SHOEINF
a = nil => bpPush keywordId $ttok and bpNext()
bpPush a and bpNext()
false
bpAnyId()==
- bpEqKey "MINUS" and ($stok is ["INTEGER",:.] or bpTrap()) and
+ bpEqKey "MINUS" and (tokenClass $stok = "INTEGER" or bpTrap()) and
bpPush(-$ttok) and bpNext() or
bpSexpKey() or
- shoeTokType $stok in '(ID INTEGER STRING FLOAT)
+ tokenClass $stok in '(ID INTEGER STRING FLOAT)
and bpPush $ttok and bpNext()
bpSexp()==
@@ -596,11 +596,11 @@ bpPrimary()== bpFirstTok() and (bpPrimary1() or bpPrefixOperator())
bpDot()== bpEqKey "DOT" and bpPush bfDot ()
bpPrefixOperator()==
- $stok is ["KEY",:.] and
+ tokenClass $stok = "KEY" and
$ttok has SHOEPRE and bpPushId() and bpNext()
bpInfixOperator()==
- $stok is ["KEY",:.] and
+ tokenClass $stok = "KEY" and
$ttok has SHOEINF and bpPushId() and bpNext()
bpSelector()==
@@ -636,8 +636,8 @@ bpTagged()==
bpExpt()== bpRightAssoc('(POWER),function bpTagged)
bpInfKey s ==
- $stok is ["KEY",:.] and
- symbolMember?($ttok,s) and bpPushId() and bpNext()
+ tokenClass $stok = "KEY" and
+ symbolMember?($ttok,s) and bpPushId() and bpNext()
bpInfGeneric s==
bpInfKey s and (bpEqKey "BACKSET" or true)
@@ -660,7 +660,7 @@ bpLeftAssoc(operations,parser)==
false
bpString()==
- shoeTokType $stok is "STRING" and
+ tokenClass $stok = "STRING" and
bpPush(quote makeSymbol $ttok) and bpNext()
bpFunction() ==
@@ -668,7 +668,7 @@ bpFunction() ==
and bpPush bfFunction bpPop1()
bpThetaName() ==
- $stok is ["ID",:.] and $ttok has SHOETHETA =>
+ tokenClass $stok = "ID" and $ttok has SHOETHETA =>
bpPushId()
bpNext()
false
@@ -1098,7 +1098,7 @@ bpRegularBVItem() ==
or bpBracketConstruct function bpPatternL
bpBVString()==
- shoeTokType $stok is "STRING" and
+ tokenClass $stok = "STRING" and
bpPush(["BVQUOTE",makeSymbol $ttok]) and bpNext()
bpRegularBVItemL() ==
diff --git a/src/boot/pile.boot b/src/boot/pile.boot
index fa19c102..f789067d 100644
--- a/src/boot/pile.boot
+++ b/src/boot/pile.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2010, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -38,19 +38,19 @@ namespace BOOTTRAN
module pile
shoeFirstTokPosn t ==
- shoeTokPosn CAAR t
+ tokenPosition CAAR t
shoeLastTokPosn t==
- shoeTokPosn second t
+ tokenPosition second t
shoePileColumn t==
- rest shoeTokPosn CAAR t
+ rest tokenPosition CAAR t
-- s is a token-dq-stream
shoePileInsert (s)==
bStreamNull s => [[],:s]
- toktype := shoeTokType CAAAR s
+ toktype := tokenClass CAAAR s
toktype = "LISP" or toktype = "LINE" => [[first s],:rest s]
a:=shoePileTree(-1,s)
[[a.2],:a.3]
@@ -104,11 +104,11 @@ shoePileCforest x==
shoePileCoagulate(a,b)==
b = nil => [a]
c := first b
- shoeTokPart CAAR c = "THEN" or shoeTokPart CAAR c = "ELSE" =>
+ tokenValue CAAR c = "THEN" or tokenValue CAAR c = "ELSE" =>
shoePileCoagulate (dqAppend(a,c),rest b)
d := second a
- e := shoeTokPart d
- d is ["KEY",:.] and
+ e := tokenValue d
+ tokenClass d = "KEY" and
(e has SHOEINF or e = "COMMA" or e = "SEMICOLON") =>
shoePileCoagulate(dqAppend(a,c),rest b)
[a,:shoePileCoagulate(c,rest b)]
@@ -117,11 +117,11 @@ shoeSeparatePiles x==
x = nil => []
rest x = nil => first x
a := first x
- semicolon := dqUnit shoeTokConstruct("KEY", "BACKSET",shoeLastTokPosn a)
+ semicolon := dqUnit mk%Token("KEY", "BACKSET",shoeLastTokPosn a)
dqConcat [a,semicolon,shoeSeparatePiles rest x]
shoeEnPile x==
- dqConcat [dqUnit shoeTokConstruct("KEY","SETTAB",shoeFirstTokPosn x),
+ dqConcat [dqUnit mk%Token("KEY","SETTAB",shoeFirstTokPosn x),
x, _
- dqUnit shoeTokConstruct("KEY","BACKTAB",shoeLastTokPosn x)]
+ dqUnit mk%Token("KEY","BACKTAB",shoeLastTokPosn x)]
diff --git a/src/boot/scanner.boot b/src/boot/scanner.boot
index 05a253a1..f283d08a 100644
--- a/src/boot/scanner.boot
+++ b/src/boot/scanner.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -60,22 +60,6 @@ dqToList s ==
s = nil => nil
first s
-shoeTokConstruct(x,y,z) ==
- [x,y,:z]
-
-shoeConstructToken(lp,b,n) ==
- shoeTokConstruct(b.0,b.1,[lp,:n])
-
-shoeTokType x ==
- first x
-
-shoeTokPart x ==
- second x
-
-shoeTokPosn x ==
- [.,.,:p] := x
- p
-
shoeNextLine s==
bStreamNull s => false
$linepos := s
@@ -104,7 +88,7 @@ shoeLineToks s ==
$n = nil => shoeLineToks $r
stringChar($ln,0) = char ")" =>
command := shoeLine? $ln =>
- dq := dqUnit shoeConstructToken($linepos,shoeLeafLine command,0)
+ dq := dqUnit makeToken($linepos,shoeLeafLine command,0)
[[dq],:$r]
command := shoeLisp? $ln => shoeLispToken($r,command)
shoeLineToks $r
@@ -120,7 +104,7 @@ shoeLispToken(s,string)==
ln := $ln
linepos := $linepos
[r,:st] := shoeAccumulateLines(s,string)
- dq := dqUnit shoeConstructToken(linepos,shoeLeafLisp st,0)
+ dq := dqUnit makeToken(linepos,shoeLeafLisp st,0)
[[dq],:r]
shoeAccumulateLines(s,string)==
@@ -168,7 +152,7 @@ shoeToken() ==
[]
shoeError()
b = nil => nil
- dqUnit shoeConstructToken(linepos,b,n)
+ dqUnit makeToken(linepos,b,n)
-- to pair badge and badgee
shoeLeafId x ==
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|)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index b31eeec3..ac4d665a 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -34,12 +34,26 @@
import utility
namespace BOOTTRAN
-module tokens ($InteractiveMode, char) where
+module tokens ($InteractiveMode, char, subString) where
char: %Symbol -> %Char
++ If true, means the system is in interactive mode.
$InteractiveMode := false
+--%
+
+structure %Token ==
+ Record(cls: %Symbol, val: %Thing, pos: %Position) with
+ tokenClass == (.cls)
+ tokenValue == (.val)
+ tokenPosition == (.pos)
+
+makeToken(lp,b,n) ==
+ mk%Token(first b,second b,[lp,:n])
+
+
+--%
+
++ converts `x', a 1-length symbol, to a character.
char x ==
stringChar(symbolName x, 0)
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 6032f24e..294f9d71 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -1,4 +1,4 @@
--- Copyright (C) 2011, Gabriel Dos Reis.
+-- Copyright (C) 2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
index 7e4e738a..5a527962 100644
--- a/src/interp/sys-utility.boot
+++ b/src/interp/sys-utility.boot
@@ -339,12 +339,6 @@ writeByteToStreamSocket(s,b) ==
makeByteBuffer(n,b == 0) ==
MAKE_-ARRAY(n,KEYWORD::ELEMENT_-TYPE,"%Byte",KEYWORD::INITIAL_-ELEMENT,b)
-++ return the sub-string of `s' starting from `f'.
-++ When non-nil, `n' designates the length of the sub-string.
-subString(s,f,n == nil) ==
- n = nil => subSequence(s,f)
- subSequence(s,f,f + n)
-
++ Return the position of the symbol `s' in the list `l', if present.
++ Otherwise return nil.
symbolPosition(s,l) ==