aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/boot/ast.boot4
-rw-r--r--src/boot/includer.boot4
-rw-r--r--src/boot/initial-env.lisp3
-rw-r--r--src/boot/scanner.boot43
-rw-r--r--src/boot/strap/ast.clisp9
-rw-r--r--src/boot/strap/includer.clisp7
-rw-r--r--src/boot/strap/scanner.clisp45
-rw-r--r--src/boot/strap/tokens.clisp29
-rw-r--r--src/boot/strap/translator.clisp4
-rw-r--r--src/boot/tokens.boot28
-rw-r--r--src/boot/translator.boot4
11 files changed, 94 insertions, 86 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 46d5a589..0d8bd1b5 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -200,7 +200,7 @@ bfColonAppend(x,y) ==
bfBeginsDollar: %Thing -> %Boolean
bfBeginsDollar x ==
- (PNAME x).0 = char "$"
+ stringChar(PNAME x,0) = char "$"
compFluid id ==
["FLUID",id]
@@ -745,7 +745,7 @@ defQuoteId x==
x is ["QUOTE",:.] and symbol? second x
bfChar? x ==
- char? x or cons? x and first x in '(char abstractChar)
+ char? x or cons? x and first x in '(char CODE_-CHAR SCHAR)
bfSmintable x==
integer? x or cons? x and first x in '(SIZE LENGTH QENUM)
diff --git a/src/boot/includer.boot b/src/boot/includer.boot
index 3f976b28..62cc6456 100644
--- a/src/boot/includer.boot
+++ b/src/boot/includer.boot
@@ -259,13 +259,13 @@ shoePrefix?(prefix,whole) ==
#prefix > #whole => false
good:=true
for i in 0..#prefix-1 for j in 0.. while good repeat
- good:= prefix.i = whole.j
+ good := stringChar(prefix,i) = stringChar(whole,j)
good => subString(whole,#prefix)
good
shoePlainLine?(s) ==
#s = 0 => true
- s.0 ~= char ")"
+ stringChar(s,0) ~= char ")"
shoeSay? s == shoePrefix?('")say", s)
shoeEval? s == shoePrefix?('")eval", s)
diff --git a/src/boot/initial-env.lisp b/src/boot/initial-env.lisp
index 5a1041cb..dc767443 100644
--- a/src/boot/initial-env.lisp
+++ b/src/boot/initial-env.lisp
@@ -138,9 +138,6 @@
(defun HPUT (table key value)
(setf (gethash key table) value))
-(defun QENUM (cvec ind)
- (char-code (char cvec ind)))
-
(defun strpos (what in start dontcare)
(setq what (string what) in (string in))
(if dontcare
diff --git a/src/boot/scanner.boot b/src/boot/scanner.boot
index 9745bae6..96dd03f6 100644
--- a/src/boot/scanner.boot
+++ b/src/boot/scanner.boot
@@ -38,6 +38,27 @@ import includer
namespace BOOTTRAN
module scanner
+shoeSPACE == QENUM('" ", 0)
+
+shoeESCAPE == QENUM('"__ ", 0)
+shoeLispESCAPE := QENUM('"! ", 0)
+
+shoeSTRING_CHAR == QENUM('"_" ", 0)
+
+shoePLUSCOMMENT == QENUM('"+ ", 0)
+
+shoeMINUSCOMMENT == QENUM('"- ", 0)
+
+shoeDOT == QENUM('". ", 0)
+
+shoeEXPONENT1 == QENUM('"E ", 0)
+
+shoeEXPONENT2 == QENUM('"e ", 0)
+
+shoeCLOSEPAREN == QENUM('") ", 0)
+
+shoeTAB == 9
+
-- converts X to double-float.
double x ==
FLOAT(x, 1.0)
@@ -159,7 +180,7 @@ shoeToken () ==
c:=QENUM($ln,$n)
linepos:=$linepos
n:=$n
- ch:=$ln.$n
+ ch := stringChar($ln,$n)
b:=
shoeStartsComment() =>
shoeComment()
@@ -226,11 +247,11 @@ shoeLispEscape()==
$n:=$n+1
$n >= $sz =>
SoftShoeError([$linepos,:$n],'"lisp escape error")
- shoeLeafError ($ln.$n)
+ shoeLeafError stringChar($ln,$n)
a:=shoeReadLispString($ln,$n)
a = nil =>
SoftShoeError([$linepos,:$n],'"lisp escape error")
- shoeLeafError ($ln.$n)
+ shoeLeafError stringChar($ln,$n)
[exp,n]:=a
n = nil =>
$n:= $sz
@@ -300,7 +321,7 @@ shoeKeyTr w==
shoeLeafKey w
shoePossFloat (w)==
- $n>=$sz or not shoeDigit $ln.$n => shoeLeafKey w
+ $n>=$sz or not shoeDigit stringChar($ln,$n) => shoeLeafKey w
w := shoeInteger()
shoeExponent('"0",w)
@@ -338,7 +359,7 @@ shoeS()==
a := shoeEsc()
b :=
a =>
- str := strconc(str,$ln.$n)
+ str := strconc(str,charString stringChar($ln,$n))
$n := $n+1
shoeS()
shoeS()
@@ -348,7 +369,7 @@ shoeS()==
shoeIdEnd(line,n)==
- while n<#line and shoeIdChar line.n repeat
+ while n<#line and shoeIdChar stringChar(line,n) repeat
n := n+1
n
@@ -388,7 +409,7 @@ shoeInteger() ==
shoeInteger1(zro) ==
n := $n
l := $sz
- while $n <l and shoeDigit($ln.$n) repeat
+ while $n <l and shoeDigit stringChar($ln,$n) repeat
$n := $n+1
$n=l or QENUM($ln,$n)~=shoeESCAPE =>
n = $n and zro => '"0"
@@ -403,7 +424,7 @@ shoeIntValue(s) ==
ns := #s
ival := 0
for i in 0..ns-1 repeat
- d := shoeOrdToNum s.i
+ d := shoeOrdToNum stringChar(s,i)
ival := 10*ival + d
ival
@@ -429,7 +450,7 @@ shoeExponent(a,w)==
$n >= $sz =>
$n := n
shoeLeafFloat(a,w,0)
- shoeDigit($ln.$n) =>
+ shoeDigit stringChar($ln,$n) =>
e := shoeInteger()
e := shoeIntValue e
shoeLeafFloat(a,w,e)
@@ -439,7 +460,7 @@ shoeExponent(a,w)==
$n >= $sz =>
$n := n
shoeLeafFloat(a,w,0)
- shoeDigit($ln.$n) =>
+ shoeDigit stringChar($ln,$n) =>
e := shoeInteger()
e := shoeIntValue e
shoeLeafFloat(a,w,(c1=shoeMINUSCOMMENT => MINUS e; e))
@@ -454,7 +475,7 @@ shoeError()==
SoftShoeError([$linepos,:n],
strconc( '"The character whose number is ",
toString QENUM($ln,n),'" is not a Boot character"))
- shoeLeafError ($ln.n)
+ shoeLeafError stringChar($ln,n)
shoeOrdToNum x==
digit? x
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 6053c6b8..6a947261 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -228,7 +228,8 @@
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |bfBeginsDollar|))
-(DEFUN |bfBeginsDollar| (|x|) (CHAR= (ELT (PNAME |x|) 0) (|char| '$)))
+(DEFUN |bfBeginsDollar| (|x|)
+ (CHAR= (SCHAR (PNAME |x|) 0) (|char| '$)))
(DEFUN |compFluid| (|id|) (LIST 'FLUID |id|))
@@ -1206,7 +1207,7 @@
(DEFUN |bfChar?| (|x|)
(OR (CHARACTERP |x|)
- (AND (CONSP |x|) (MEMQ (CAR |x|) '(|char| |abstractChar|)))))
+ (AND (CONSP |x|) (MEMQ (CAR |x|) '(|char| CODE-CHAR SCHAR)))))
(DEFUN |bfSmintable| (|x|)
(OR (INTEGERP |x|)
@@ -1215,7 +1216,8 @@
(DEFUN |bfString?| (|x|)
(OR (STRINGP |x|)
(AND (CONSP |x|)
- (MEMQ (CAR |x|) '(|charString| |symbolName| |toString|)))))
+ (MEMQ (CAR |x|)
+ '(|charString| |symbolName| |toString| |subString|)))))
(DEFUN |bfQ| (|l| |r|)
(COND
@@ -1233,6 +1235,7 @@
((EQL |l| 0) (LIST 'PLUSP |r|))
((EQL |r| 0) (LIST 'MINUSP |l|))
((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR< |l| |r|))
+ ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING< |l| |r|))
(T (LIST '< |l| |r|))))
(DEFUN |bfLambda| (|vars| |body|)
diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp
index 0956df6b..323a23a9 100644
--- a/src/boot/strap/includer.clisp
+++ b/src/boot/strap/includer.clisp
@@ -96,7 +96,7 @@
((< (LENGTH |a|) |sz|)
(|shoePackageStartsAt| |lines| |sz| |name|
(CDR |stream|)))
- ((AND (EQUAL (|subString| |a| 0 |sz|) |name|)
+ ((AND (STRING= (|subString| |a| 0 |sz|) |name|)
(< |sz| (LENGTH |a|))
(NOT (|shoeIdChar| (ELT |a| |sz|))))
(LIST |lines| |stream|))
@@ -242,7 +242,8 @@
(COND
((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL))
(T (SETQ |good|
- (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|)))))
+ (CHAR= (SCHAR |prefix| |i|)
+ (SCHAR |whole| |j|)))))
(SETQ |i| (+ |i| 1))
(SETQ |j| (+ |j| 1))))
(COND
@@ -252,7 +253,7 @@
(DEFUN |shoePlainLine?| (|s|)
(COND
((EQL (LENGTH |s|) 0) T)
- (T (NOT (CHAR= (ELT |s| 0) (|char| '|)|))))))
+ (T (NOT (CHAR= (SCHAR |s| 0) (|char| '|)|))))))
(DEFUN |shoeSay?| (|s|) (|shoePrefix?| ")say" |s|))
diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp
index 15ae2e96..06cfc59d 100644
--- a/src/boot/strap/scanner.clisp
+++ b/src/boot/strap/scanner.clisp
@@ -7,6 +7,28 @@
(PROVIDE "scanner")
+(DEFCONSTANT |shoeSPACE| (QENUM " " 0))
+
+(DEFCONSTANT |shoeESCAPE| (QENUM "_ " 0))
+
+(DEFPARAMETER |shoeLispESCAPE| (QENUM "! " 0))
+
+(DEFCONSTANT |shoeSTRINGCHAR| (QENUM "\" " 0))
+
+(DEFCONSTANT |shoePLUSCOMMENT| (QENUM "+ " 0))
+
+(DEFCONSTANT |shoeMINUSCOMMENT| (QENUM "- " 0))
+
+(DEFCONSTANT |shoeDOT| (QENUM ". " 0))
+
+(DEFCONSTANT |shoeEXPONENT1| (QENUM "E " 0))
+
+(DEFCONSTANT |shoeEXPONENT2| (QENUM "e " 0))
+
+(DEFCONSTANT |shoeCLOSEPAREN| (QENUM ") " 0))
+
+(DEFCONSTANT |shoeTAB| 9)
+
(DEFUN |double| (|x|) (FLOAT |x| 1.0))
(DEFUN |dqUnit| (|s|)
@@ -164,7 +186,7 @@
(SETQ |c| (QENUM |$ln| |$n|))
(SETQ |linepos| |$linepos|)
(SETQ |n| |$n|)
- (SETQ |ch| (ELT |$ln| |$n|))
+ (SETQ |ch| (SCHAR |$ln| |$n|))
(SETQ |b|
(COND
((|shoeStartsComment|) (|shoeComment|) NIL)
@@ -223,13 +245,13 @@
(COND
((NOT (< |$n| |$sz|))
(|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error")
- (|shoeLeafError| (ELT |$ln| |$n|)))
+ (|shoeLeafError| (SCHAR |$ln| |$n|)))
(T (SETQ |a| (|shoeReadLispString| |$ln| |$n|))
(COND
((NULL |a|)
(|SoftShoeError| (CONS |$linepos| |$n|)
"lisp escape error")
- (|shoeLeafError| (ELT |$ln| |$n|)))
+ (|shoeLeafError| (SCHAR |$ln| |$n|)))
(T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|))
(COND
((NULL |n|) (SETQ |$n| |$sz|)
@@ -329,7 +351,7 @@
(DEFUN |shoePossFloat| (|w|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
(COND
- ((OR (NOT (< |$n| |$sz|)) (NOT (|shoeDigit| (ELT |$ln| |$n|))))
+ ((OR (NOT (< |$n| |$sz|)) (NOT (|shoeDigit| (SCHAR |$ln| |$n|))))
(|shoeLeafKey| |w|))
(T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|))))
@@ -374,7 +396,8 @@
(SETQ |b|
(COND
(|a| (SETQ |str|
- (CONCAT |str| (ELT |$ln| |$n|)))
+ (CONCAT |str|
+ (STRING (SCHAR |$ln| |$n|))))
(SETQ |$n| (+ |$n| 1)) (|shoeS|))
(T (|shoeS|))))
(CONCAT |str| |b|))))))))
@@ -384,7 +407,7 @@
(LOOP
(COND
((NOT (AND (< |n| (LENGTH |line|))
- (|shoeIdChar| (ELT |line| |n|))))
+ (|shoeIdChar| (SCHAR |line| |n|))))
(RETURN NIL))
(T (SETQ |n| (+ |n| 1)))))
|n|))
@@ -435,7 +458,7 @@
(SETQ |l| |$sz|)
(LOOP
(COND
- ((NOT (AND (< |$n| |l|) (|shoeDigit| (ELT |$ln| |$n|))))
+ ((NOT (AND (< |$n| |l|) (|shoeDigit| (SCHAR |$ln| |$n|))))
(RETURN NIL))
(T (SETQ |$n| (+ |$n| 1)))))
(COND
@@ -459,7 +482,7 @@
(COND
((> |i| |bfVar#1|) (RETURN NIL))
(T (PROGN
- (SETQ |d| (|shoeOrdToNum| (ELT |s| |i|)))
+ (SETQ |d| (|shoeOrdToNum| (SCHAR |s| |i|)))
(SETQ |ival| (+ (* 10 |ival|) |d|)))))
(SETQ |i| (+ |i| 1))))
|ival|))))
@@ -494,7 +517,7 @@
(COND
((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
(|shoeLeafFloat| |a| |w| 0))
- ((|shoeDigit| (ELT |$ln| |$n|))
+ ((|shoeDigit| (SCHAR |$ln| |$n|))
(SETQ |e| (|shoeInteger|))
(SETQ |e| (|shoeIntValue| |e|))
(|shoeLeafFloat| |a| |w| |e|))
@@ -506,7 +529,7 @@
(COND
((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
(|shoeLeafFloat| |a| |w| 0))
- ((|shoeDigit| (ELT |$ln| |$n|))
+ ((|shoeDigit| (SCHAR |$ln| |$n|))
(SETQ |e| (|shoeInteger|))
(SETQ |e| (|shoeIntValue| |e|))
(|shoeLeafFloat| |a| |w|
@@ -528,7 +551,7 @@
(CONCAT "The character whose number is "
(WRITE-TO-STRING (QENUM |$ln| |n|))
" is not a Boot character"))
- (|shoeLeafError| (ELT |$ln| |n|))))))
+ (|shoeLeafError| (SCHAR |$ln| |n|))))))
(DEFUN |shoeOrdToNum| (|x|) (DIGIT-CHAR-P |x|))
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 01f54c47..b3c11228 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -5,7 +5,7 @@
(PROVIDE "tokens")
-(DEFUN |char| (|x|) (CHAR (SYMBOL-NAME |x|) 0))
+(DEFUN |char| (|x|) (SCHAR (SYMBOL-NAME |x|) 0))
(DEFUN |shoeStartsId| (|x|)
(OR (ALPHA-CHAR-P |x|)
@@ -20,6 +20,8 @@
((NULL |n|) (SUBSEQ |s| |f|))
(T (SUBSEQ |s| |f| (+ |f| |n|)))))
+(DEFUN QENUM (|s| |i|) (CHAR-CODE (SCHAR |s| |i|)))
+
(DEFCONSTANT |shoeKeyWords|
(LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE)
(LIST "catch" 'CATCH) (LIST "cross" 'CROSS)
@@ -64,28 +66,6 @@
(DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|))
-(DEFCONSTANT |shoeSPACE| (QENUM " " 0))
-
-(DEFCONSTANT |shoeESCAPE| (QENUM "_ " 0))
-
-(DEFPARAMETER |shoeLispESCAPE| (QENUM "! " 0))
-
-(DEFCONSTANT |shoeSTRINGCHAR| (QENUM "\" " 0))
-
-(DEFCONSTANT |shoePLUSCOMMENT| (QENUM "+ " 0))
-
-(DEFCONSTANT |shoeMINUSCOMMENT| (QENUM "- " 0))
-
-(DEFCONSTANT |shoeDOT| (QENUM ". " 0))
-
-(DEFCONSTANT |shoeEXPONENT1| (QENUM "E " 0))
-
-(DEFCONSTANT |shoeEXPONENT2| (QENUM "e " 0))
-
-(DEFCONSTANT |shoeCLOSEPAREN| (QENUM ") " 0))
-
-(DEFCONSTANT |shoeTAB| 9)
-
(DEFUN |shoeInsert| (|s| |d|)
(PROG (|v| |k| |n| |u| |h| |l|)
(RETURN
@@ -252,7 +232,8 @@
(LIST '|setDifference| 'SETDIFFERENCE)
(LIST '|setIntersection| 'INTERSECTION)
(LIST '|setPart| 'SETELT) (LIST '|setUnion| 'UNION)
- (LIST '|strconc| 'CONCAT) (LIST '|string?| 'STRINGP)
+ (LIST '|strconc| 'CONCAT) (LIST '|stringChar| 'SCHAR)
+ (LIST '|string?| 'STRINGP)
(LIST '|subSequence| 'SUBSEQ)
(LIST '|substitute| 'SUBST)
(LIST '|substitute!| 'NSUBST)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index e37043e5..5800bc33 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -1230,7 +1230,7 @@
(COND
(|b| (SETQ |stream| *TERMINAL-IO*)
(PSTTOMC (|bRgen| |stream|)) (BOOTLOOP))
- ((CHAR= (ELT |a| 0) (|char| '])) NIL)
+ ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
(T (PSTTOMC (LIST |a|)) (BOOTLOOP)))))))))
(DEFUN BOOTPO ()
@@ -1245,7 +1245,7 @@
(COND
(|b| (SETQ |stream| *TERMINAL-IO*)
(PSTOUT (|bRgen| |stream|)) (BOOTPO))
- ((CHAR= (ELT |a| 0) (|char| '])) NIL)
+ ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
(T (PSTOUT (LIST |a|)) (BOOTPO)))))))))
(DEFUN PSTOUT (|string|)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index 6247a0b3..b3e98204 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -38,7 +38,7 @@ module tokens
++ converts `x', a 1-length symbol, to a character.
char x ==
- CHAR(symbolName x, 0)
+ stringChar(symbolName x, 0)
shoeStartsId x ==
alphabetic? x or x in [char "$", char "?", char "%"]
@@ -52,6 +52,9 @@ subString(s,f,n == nil) ==
n = nil => subSequence(s,f)
subSequence(s,f,f + n)
+QENUM(s,i) ==
+ codePoint stringChar(s,i)
+
++ Table of Boot keywords and their token name.
shoeKeyWords == [ _
['"and","AND"] , _
@@ -131,28 +134,6 @@ shoeKeyTableCons()==
shoeKeyTable:=shoeKeyTableCons()
-shoeSPACE == QENUM('" ", 0)
-
-shoeESCAPE == QENUM('"__ ", 0)
-shoeLispESCAPE := QENUM('"! ", 0)
-
-shoeSTRING_CHAR == QENUM('"_" ", 0)
-
-shoePLUSCOMMENT == QENUM('"+ ", 0)
-
-shoeMINUSCOMMENT == QENUM('"- ", 0)
-
-shoeDOT == QENUM('". ", 0)
-
-shoeEXPONENT1 == QENUM('"E ", 0)
-
-shoeEXPONENT2 == QENUM('"e ", 0)
-
-shoeCLOSEPAREN == QENUM('") ", 0)
-
---shoeCLOSEANGLE == QENUM('"> ", 0)
-shoeTAB == 9
-
shoeInsert(s,d) ==
l := #s
h := QENUM(s,0)
@@ -312,6 +293,7 @@ for i in [ _
["setPart", "SETELT"] , _
["setUnion", "UNION"] , _
["strconc", "CONCAT"] , _
+ ["stringChar", "SCHAR"] , _
["string?", "STRINGP"] ,_
["subSequence", "SUBSEQ"] , _
["substitute", "SUBST"] , _
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index c8d9452f..0b4a196c 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -706,7 +706,7 @@ BOOTLOOP() ==
stream:= _*TERMINAL_-IO_*
PSTTOMC bRgen stream
BOOTLOOP()
- a.0 = char "]" => nil
+ stringChar(a,0) = char "]" => nil
PSTTOMC [a]
BOOTLOOP()
@@ -720,7 +720,7 @@ BOOTPO() ==
stream:= _*TERMINAL_-IO_*
PSTOUT bRgen stream
BOOTPO()
- a.0 = char "]" => nil
+ stringChar(a,0) = char "]" => nil
PSTOUT [a]
BOOTPO()
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-17 17:30:54 +0000