aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot/strap')
-rw-r--r--src/boot/strap/scanner.clisp184
-rw-r--r--src/boot/strap/tokens.clisp6
2 files changed, 79 insertions, 111 deletions
diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp
index 06cfc59d..2df8e320 100644
--- a/src/boot/strap/scanner.clisp
+++ b/src/boot/strap/scanner.clisp
@@ -7,27 +7,7 @@
(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)
+(DEFCONSTANT |shoeTAB| (CODE-CHAR 9))
(DEFUN |double| (|x|) (FLOAT |x| 1.0))
@@ -71,7 +51,7 @@
(SETQ |$sz| (LENGTH |$ln|))
(COND
((NULL |$n|) T)
- ((EQL (QENUM |$ln| |$n|) |shoeTAB|)
+ ((CHAR= (SCHAR |$ln| |$n|) |shoeTAB|)
(SETQ |a| (MAKE-FULL-CVEC (- 7 (REM |$n| 8)) " "))
(SETF (ELT |$ln| |$n|) (|char| '| |))
(SETQ |$ln| (CONCAT |a| |$ln|))
@@ -81,7 +61,7 @@
(DEFUN |shoeLineToks| (|s|)
(PROG (|$linepos| |$floatok| |$sz| |$n| |$ln| |$r| |$f| |toks| |a|
- |dq| |command| |fst|)
+ |dq| |command|)
(DECLARE (SPECIAL |$floatok| |$f| |$sz| |$linepos| |$ln| |$r| |$n|))
(RETURN
(PROGN
@@ -95,35 +75,32 @@
(COND
((NOT (|shoeNextLine| |s|)) (CONS NIL NIL))
((NULL |$n|) (|shoeLineToks| |$r|))
- (T (SETQ |fst| (QENUM |$ln| 0))
+ ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
+ (COND
+ ((SETQ |command| (|shoeLine?| |$ln|))
+ (SETQ |dq|
+ (|dqUnit|
+ (|shoeConstructToken| |$ln| |$linepos|
+ (|shoeLeafLine| |command|) 0)))
+ (CONS (LIST |dq|) |$r|))
+ ((SETQ |command| (|shoeLisp?| |$ln|))
+ (|shoeLispToken| |$r| |command|))
+ ((SETQ |command| (|shoePackage?| |$ln|))
+ (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")"))
+ (SETQ |dq|
+ (|dqUnit|
+ (|shoeConstructToken| |$ln| |$linepos|
+ (|shoeLeafLisp| |a|) 0)))
+ (CONS (LIST |dq|) |$r|))
+ (T (|shoeLineToks| |$r|))))
+ (T (SETQ |toks| NIL)
+ (LOOP
+ (COND
+ ((NOT (< |$n| |$sz|)) (RETURN NIL))
+ (T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|))))))
(COND
- ((EQL |fst| |shoeCLOSEPAREN|)
- (COND
- ((SETQ |command| (|shoeLine?| |$ln|))
- (SETQ |dq|
- (|dqUnit|
- (|shoeConstructToken| |$ln| |$linepos|
- (|shoeLeafLine| |command|) 0)))
- (CONS (LIST |dq|) |$r|))
- ((SETQ |command| (|shoeLisp?| |$ln|))
- (|shoeLispToken| |$r| |command|))
- ((SETQ |command| (|shoePackage?| |$ln|))
- (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")"))
- (SETQ |dq|
- (|dqUnit|
- (|shoeConstructToken| |$ln| |$linepos|
- (|shoeLeafLisp| |a|) 0)))
- (CONS (LIST |dq|) |$r|))
- (T (|shoeLineToks| |$r|))))
- (T (SETQ |toks| NIL)
- (LOOP
- (COND
- ((NOT (< |$n| |$sz|)) (RETURN NIL))
- (T (SETQ |toks|
- (|dqAppend| |toks| (|shoeToken|))))))
- (COND
- ((NULL |toks|) (|shoeLineToks| |$r|))
- (T (CONS (LIST |toks|) |$r|)))))))))))
+ ((NULL |toks|) (|shoeLineToks| |$r|))
+ (T (CONS (LIST |toks|) |$r|)))))))))
(DEFUN |shoeLispToken| (|s| |string|)
(PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|)
@@ -133,7 +110,7 @@
(SETQ |string|
(COND
((OR (EQL (LENGTH |string|) 0)
- (EQL (QENUM |string| 0) (QENUM ";" 0)))
+ (CHAR= (SCHAR |string| 0) (|char| '|;|)))
"")
(T |string|)))
(SETQ |ln| |$ln|)
@@ -148,42 +125,38 @@
(CONS (LIST |dq|) |r|)))))
(DEFUN |shoeAccumulateLines| (|s| |string|)
- (PROG (|a| |command| |fst|)
+ (PROG (|a| |command|)
(DECLARE (SPECIAL |$ln| |$r| |$n|))
(RETURN
(COND
((NOT (|shoeNextLine| |s|)) (CONS |s| |string|))
((NULL |$n|) (|shoeAccumulateLines| |$r| |string|))
((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|))
- (T (SETQ |fst| (QENUM |$ln| 0))
- (COND
- ((EQL |fst| |shoeCLOSEPAREN|)
- (SETQ |command| (|shoeLisp?| |$ln|))
- (COND
- ((AND |command| (PLUSP (LENGTH |command|)))
+ ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
+ (SETQ |command| (|shoeLisp?| |$ln|))
+ (COND
+ ((AND |command| (PLUSP (LENGTH |command|)))
+ (COND
+ ((CHAR= (SCHAR |command| 0) (|char| '|;|))
+ (|shoeAccumulateLines| |$r| |string|))
+ (T (SETQ |a| (STRPOS ";" |command| 0 NIL))
(COND
- ((EQL (QENUM |command| 0) (QENUM ";" 0))
- (|shoeAccumulateLines| |$r| |string|))
- (T (SETQ |a| (STRPOS ";" |command| 0 NIL))
- (COND
- (|a| (|shoeAccumulateLines| |$r|
- (CONCAT |string|
- (|subString| |command| 0
- (- |a| 1)))))
- (T (|shoeAccumulateLines| |$r|
- (CONCAT |string| |command|)))))))
- (T (|shoeAccumulateLines| |$r| |string|))))
- (T (CONS |s| |string|))))))))
+ (|a| (|shoeAccumulateLines| |$r|
+ (CONCAT |string|
+ (|subString| |command| 0 (- |a| 1)))))
+ (T (|shoeAccumulateLines| |$r|
+ (CONCAT |string| |command|)))))))
+ (T (|shoeAccumulateLines| |$r| |string|))))
+ (T (CONS |s| |string|))))))
(DEFUN |shoeCloser| (|t|) (MEMQ (|shoeKeyWord| |t|) '(CPAREN CBRACK)))
(DEFUN |shoeToken| ()
- (PROG (|b| |ch| |n| |linepos| |c| |ln|)
- (DECLARE (SPECIAL |$linepos| |$n| |$ln|))
+ (PROG (|b| |ch| |n| |linepos| |ln|)
+ (DECLARE (SPECIAL |$n| |$linepos| |$ln|))
(RETURN
(PROGN
(SETQ |ln| |$ln|)
- (SETQ |c| (QENUM |$ln| |$n|))
(SETQ |linepos| |$linepos|)
(SETQ |n| |$n|)
(SETQ |ch| (SCHAR |$ln| |$n|))
@@ -191,14 +164,14 @@
(COND
((|shoeStartsComment|) (|shoeComment|) NIL)
((|shoeStartsNegComment|) (|shoeNegComment|) NIL)
- ((EQUAL |c| |shoeLispESCAPE|) (|shoeLispEscape|))
- ((|shoePunctuation| |c|) (|shoePunct|))
+ ((CHAR= |ch| (|char| '!)) (|shoeLispEscape|))
+ ((|shoePunctuation| (CHAR-CODE |ch|)) (|shoePunct|))
((|shoeStartsId| |ch|) (|shoeWord| NIL))
- ((EQUAL |c| |shoeSPACE|) (|shoeSpace|) NIL)
- ((EQUAL |c| |shoeSTRINGCHAR|) (|shoeString|))
- ((|shoeDigit| |ch|) (|shoeNumber|))
- ((EQUAL |c| |shoeESCAPE|) (|shoeEscape|))
- ((EQUAL |c| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL)
+ ((CHAR= |ch| (|char| '| |)) (|shoeSpace|) NIL)
+ ((CHAR= |ch| (|char| '|"|)) (|shoeString|))
+ ((DIGIT-CHAR-P |ch|) (|shoeNumber|))
+ ((CHAR= |ch| (|char| '_)) (|shoeEscape|))
+ ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL)
(T (|shoeError|))))
(COND
((NULL |b|) NIL)
@@ -291,11 +264,11 @@
(COND
((< |$n| |$sz|)
(COND
- ((EQL (QENUM |$ln| |$n|) |shoePLUSCOMMENT|)
+ ((CHAR= (SCHAR |$ln| |$n|) (|char| '+))
(SETQ |www| (+ |$n| 1))
(COND
((NOT (< |www| |$sz|)) NIL)
- (T (EQL (QENUM |$ln| |www|) |shoePLUSCOMMENT|))))
+ (T (CHAR= (SCHAR |$ln| |www|) (|char| '+)))))
(T NIL)))
(T NIL)))))
@@ -306,11 +279,11 @@
(COND
((< |$n| |$sz|)
(COND
- ((EQL (QENUM |$ln| |$n|) |shoeMINUSCOMMENT|)
+ ((CHAR= (SCHAR |$ln| |$n|) (|char| '-))
(SETQ |www| (+ |$n| 1))
(COND
((NOT (< |www| |$sz|)) NIL)
- (T (EQL (QENUM |$ln| |www|) |shoeMINUSCOMMENT|))))
+ (T (CHAR= (SCHAR |$ln| |www|) (|char| '-)))))
(T NIL)))
(T NIL)))))
@@ -351,7 +324,7 @@
(DEFUN |shoePossFloat| (|w|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
(COND
- ((OR (NOT (< |$n| |$sz|)) (NOT (|shoeDigit| (SCHAR |$ln| |$n|))))
+ ((OR (NOT (< |$n| |$sz|)) (NOT (DIGIT-CHAR-P (SCHAR |$ln| |$n|))))
(|shoeLeafKey| |w|))
(T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|))))
@@ -412,8 +385,6 @@
(T (SETQ |n| (+ |n| 1)))))
|n|))
-(DEFUN |shoeDigit| (|x|) (DIGIT-CHAR-P |x|))
-
(DEFUN |shoeW| (|b|)
(PROG (|bb| |a| |str| |endid| |l| |n1|)
(DECLARE (SPECIAL |$ln| |$sz| |$n|))
@@ -425,7 +396,7 @@
(SETQ |endid| (|shoeIdEnd| |$ln| |$n|))
(COND
((OR (EQUAL |endid| |l|)
- (NOT (EQL (QENUM |$ln| |endid|) |shoeESCAPE|)))
+ (NOT (CHAR= (SCHAR |$ln| |endid|) (|char| '_))))
(SETQ |$n| |endid|)
(LIST |b| (|subString| |$ln| |n1| (- |endid| |n1|))))
(T (SETQ |str| (|subString| |$ln| |n1| (- |endid| |n1|)))
@@ -458,12 +429,12 @@
(SETQ |l| |$sz|)
(LOOP
(COND
- ((NOT (AND (< |$n| |l|) (|shoeDigit| (SCHAR |$ln| |$n|))))
+ ((NOT (AND (< |$n| |l|) (DIGIT-CHAR-P (SCHAR |$ln| |$n|))))
(RETURN NIL))
(T (SETQ |$n| (+ |$n| 1)))))
(COND
((OR (EQUAL |$n| |l|)
- (NOT (EQL (QENUM |$ln| |$n|) |shoeESCAPE|)))
+ (NOT (CHAR= (SCHAR |$ln| |$n|) (|char| '_))))
(COND
((AND (EQUAL |n| |$n|) |zro|) "0")
(T (|subString| |$ln| |n| (- |$n| |n|)))))
@@ -495,10 +466,11 @@
(SETQ |a| (|shoeInteger|))
(COND
((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|))
- ((AND |$floatok| (EQL (QENUM |$ln| |$n|) |shoeDOT|))
+ ((AND |$floatok| (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
(SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1))
(COND
- ((AND (< |$n| |$sz|) (EQL (QENUM |$ln| |$n|) |shoeDOT|))
+ ((AND (< |$n| |$sz|)
+ (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
(SETQ |$n| |n|) (|shoeLeafInteger| |a|))
(T (SETQ |w| (|shoeInteger1| T)) (|shoeExponent| |a| |w|))))
(T (|shoeLeafInteger| |a|)))))))
@@ -509,33 +481,31 @@
(RETURN
(COND
((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0))
- (T (SETQ |n| |$n|) (SETQ |c| (QENUM |$ln| |$n|))
+ (T (SETQ |n| |$n|) (SETQ |c| (SCHAR |$ln| |$n|))
(COND
- ((OR (EQUAL |c| |shoeEXPONENT1|)
- (EQUAL |c| |shoeEXPONENT2|))
+ ((OR (CHAR= |c| (|char| 'E)) (CHAR= |c| (|char| '|e|)))
(SETQ |$n| (+ |$n| 1))
(COND
((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
(|shoeLeafFloat| |a| |w| 0))
- ((|shoeDigit| (SCHAR |$ln| |$n|))
+ ((DIGIT-CHAR-P (SCHAR |$ln| |$n|))
(SETQ |e| (|shoeInteger|))
(SETQ |e| (|shoeIntValue| |e|))
(|shoeLeafFloat| |a| |w| |e|))
- (T (SETQ |c1| (QENUM |$ln| |$n|))
+ (T (SETQ |c1| (SCHAR |$ln| |$n|))
(COND
- ((OR (EQUAL |c1| |shoePLUSCOMMENT|)
- (EQUAL |c1| |shoeMINUSCOMMENT|))
+ ((OR (CHAR= |c1| (|char| '+))
+ (CHAR= |c1| (|char| '-)))
(SETQ |$n| (+ |$n| 1))
(COND
((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
(|shoeLeafFloat| |a| |w| 0))
- ((|shoeDigit| (SCHAR |$ln| |$n|))
+ ((DIGIT-CHAR-P (SCHAR |$ln| |$n|))
(SETQ |e| (|shoeInteger|))
(SETQ |e| (|shoeIntValue| |e|))
(|shoeLeafFloat| |a| |w|
(COND
- ((EQUAL |c1| |shoeMINUSCOMMENT|)
- (- |e|))
+ ((CHAR= |c1| (|char| '-)) (- |e|))
(T |e|))))
(T (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0))))))))
(T (|shoeLeafFloat| |a| |w| 0))))))))
@@ -549,7 +519,7 @@
(SETQ |$n| (+ |$n| 1))
(|SoftShoeError| (CONS |$linepos| |n|)
(CONCAT "The character whose number is "
- (WRITE-TO-STRING (QENUM |$ln| |n|))
+ (WRITE-TO-STRING (CHAR-CODE (SCHAR |$ln| |n|)))
" is not a Boot character"))
(|shoeLeafError| (SCHAR |$ln| |n|))))))
@@ -566,7 +536,7 @@
(PROG (|eql| |ls| |s| |s1| |done| |ll| |u| |h|)
(RETURN
(PROGN
- (SETQ |h| (QENUM |l| |i|))
+ (SETQ |h| (CHAR-CODE (SCHAR |l| |i|)))
(SETQ |u| (ELT |d| |h|))
(SETQ |ll| (LENGTH |l|))
(SETQ |done| NIL)
@@ -589,8 +559,8 @@
(RETURN NIL))
(T
(SETQ |eql|
- (EQL (QENUM |s| |k|)
- (QENUM |l| (+ |k| |i|))))))
+ (CHAR= (SCHAR |s| |k|)
+ (SCHAR |l| (+ |k| |i|))))))
(SETQ |k| (+ |k| 1))))
(COND (|eql| (SETQ |s1| |s|) T) (T NIL))))))))
(SETQ |j| (+ |j| 1))))
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index b3c11228..f1421813 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -20,8 +20,6 @@
((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)
@@ -71,7 +69,7 @@
(RETURN
(PROGN
(SETQ |l| (LENGTH |s|))
- (SETQ |h| (QENUM |s| 0))
+ (SETQ |h| (CHAR-CODE (SCHAR |s| 0)))
(SETQ |u| (ELT |d| |h|))
(SETQ |n| (LENGTH |u|))
(SETQ |k| 0)
@@ -145,7 +143,7 @@
(RETURN NIL))
(T (COND
((NOT (|shoeStartsId| (ELT |k| 0)))
- (BVEC-SETELT |a| (QENUM |k| 0) 1)))))
+ (BVEC-SETELT |a| (CHAR-CODE (SCHAR |k| 0)) 1)))))
(SETQ |bfVar#6| (CDR |bfVar#6|))))
|a|))))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 05:02:21 +0000