From 68441ed372470b7d3eb3d24178b61dc16bc6978e Mon Sep 17 00:00:00 2001 From: dos-reis Date: Wed, 29 Dec 2010 22:47:45 +0000 Subject: More char cleanups --- src/boot/strap/scanner.clisp | 184 ++++++++++++++++++------------------------- 1 file changed, 77 insertions(+), 107 deletions(-) (limited to 'src/boot/strap/scanner.clisp') 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)))) -- cgit v1.2.3