From bcfcdb424a8d450f76f74bbc0a1674fd596f113a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Wed, 29 Dec 2010 19:18:38 +0000 Subject: More character cleanup --- src/boot/ast.boot | 4 ++-- src/boot/includer.boot | 4 ++-- src/boot/initial-env.lisp | 3 --- src/boot/scanner.boot | 43 +++++++++++++++++++++++++++++---------- src/boot/strap/ast.clisp | 9 ++++++--- src/boot/strap/includer.clisp | 7 ++++--- src/boot/strap/scanner.clisp | 45 +++++++++++++++++++++++++++++++---------- src/boot/strap/tokens.clisp | 29 +++++--------------------- src/boot/strap/translator.clisp | 4 ++-- src/boot/tokens.boot | 28 +++++-------------------- src/boot/translator.boot | 4 ++-- 11 files changed, 94 insertions(+), 86 deletions(-) (limited to 'src/boot') 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 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() -- cgit v1.2.3