aboutsummaryrefslogtreecommitdiff
path: root/src/boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot')
-rw-r--r--src/boot/ast.boot14
-rw-r--r--src/boot/strap/ast.clisp59
-rw-r--r--src/boot/strap/tokens.clisp12
-rw-r--r--src/boot/strap/utility.clisp34
-rw-r--r--src/boot/tokens.boot10
-rw-r--r--src/boot/utility.boot28
6 files changed, 100 insertions, 57 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index e9272af2..961cad8f 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -700,12 +700,18 @@ sequence?(x,pred) ==
++ Generate code for a membership test `x in seq' where `seq'
++ is a sequence (e.g. a list)
bfMember(var,seq) ==
- integer? var or var is ["char",.] or sequence?(seq,function integer?) =>
- ["MEMBER",var,seq,KEYWORD::TEST, ["FUNCTION", "EQL"]]
+ integer? var or sequence?(seq,function integer?) =>
+ seq is ["QUOTE",[x]] => ["EQL",var,x]
+ ["scalarMember?",var,seq]
defQuoteId var or sequence?(seq,function symbol?) =>
+ seq is ["QUOTE",[x]] => ["EQ",var,["QUOTE",x]]
["symbolMember?",var,seq]
- string? var or sequence?(seq,function string?) =>
- ["MEMBER",var,seq,KEYWORD::TEST,["FUNCTION", "STRING="]]
+ bfChar? var or sequence?(seq,function char?) =>
+ seq is ["QUOTE",[x]] => ["CHAR=",var,x]
+ ["charMember?",var,seq]
+ bfString? var or sequence?(seq,function string?) =>
+ seq is ["QUOTE",[x]] => ["STRING=",var,x]
+ ["stringMember?",var,seq]
["MEMBER",var,seq]
bfInfApplication(op,left,right)==
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index b2659f15..4ba335aa 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -1117,20 +1117,57 @@
(SETQ |bfVar#95| (CDR |bfVar#95|))))))))
(DEFUN |bfMember| (|var| |seq|)
- (PROG (|ISTMP#1|)
+ (PROG (|x| |ISTMP#2| |ISTMP#1|)
(RETURN
(COND
- ((OR (INTEGERP |var|)
- (AND (CONSP |var|) (EQ (CAR |var|) '|char|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |var|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))
- (|sequence?| |seq| #'INTEGERP))
- (LIST 'MEMBER |var| |seq| :TEST (LIST 'FUNCTION 'EQL)))
+ ((OR (INTEGERP |var|) (|sequence?| |seq| #'INTEGERP))
+ (COND
+ ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (LIST 'EQL |var| |x|))
+ (T (LIST '|scalarMember?| |var| |seq|))))
((OR (|defQuoteId| |var|) (|sequence?| |seq| #'SYMBOLP))
- (LIST '|symbolMember?| |var| |seq|))
- ((OR (STRINGP |var|) (|sequence?| |seq| #'STRINGP))
- (LIST 'MEMBER |var| |seq| :TEST (LIST 'FUNCTION 'STRING=)))
+ (COND
+ ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (LIST 'EQ |var| (LIST 'QUOTE |x|)))
+ (T (LIST '|symbolMember?| |var| |seq|))))
+ ((OR (|bfChar?| |var|) (|sequence?| |seq| #'CHARACTERP))
+ (COND
+ ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (LIST 'CHAR= |var| |x|))
+ (T (LIST '|charMember?| |var| |seq|))))
+ ((OR (|bfString?| |var|) (|sequence?| |seq| #'STRINGP))
+ (COND
+ ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (LIST 'STRING= |var| |x|))
+ (T (LIST '|stringMember?| |var| |seq|))))
(T (LIST 'MEMBER |var| |seq|))))))
(DEFUN |bfInfApplication| (|op| |left| |right|)
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 15fdfa25..7a032a5f 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -206,8 +206,11 @@
(LIST '|bitmask| 'SBIT)
(LIST '|canonicalFilename| 'PROBE-FILE)
(LIST '|charByName| 'NAME-CHAR)
+ (LIST '|charDowncase| 'CHAR-DOWNCASE)
+ (LIST '|charEq?| 'CHAR=)
+ (LIST '|charUpcase| 'CHAR-UPCASE)
(LIST '|charString| 'STRING)
- (LIST '|char?| 'CHARACTERP) (LIST '|charEq?| 'CHAR=)
+ (LIST '|char?| 'CHARACTERP)
(LIST '|codePoint| 'CHAR-CODE) (LIST '|cons?| 'CONSP)
(LIST '|copy| 'COPY) (LIST '|croak| 'CROAK)
(LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|drop| 'DROP)
@@ -218,6 +221,7 @@
(LIST '|gensym| 'GENSYM) (LIST '|genvar| 'GENVAR)
(LIST '|integer?| 'INTEGERP) (LIST '|lastNode| 'LAST)
(LIST 'LAST '|last|) (LIST '|list| 'LIST)
+ (LIST '|listEq?| 'EQUAL)
(LIST '|lowerCase?| 'LOWER-CASE-P)
(LIST '|makeSymbol| 'INTERN)
(LIST '|maxIndex| 'MAXINDEX) (LIST '|mkpf| 'MKPF)
@@ -240,12 +244,13 @@
(LIST '|setIntersection| 'INTERSECTION)
(LIST '|setPart| 'SETELT) (LIST '|setUnion| 'UNION)
(LIST '|strconc| 'CONCAT) (LIST '|stringChar| 'SCHAR)
+ (LIST '|stringDowncase| 'STRING-DOWNCASE)
(LIST '|string?| 'STRINGP)
(LIST '|stringEq?| 'STRING=)
+ (LIST '|stringUpcase| 'STRING-UPCASE)
(LIST '|subSequence| 'SUBSEQ)
(LIST '|substitute| 'SUBST)
- (LIST '|substitute!| 'NSUBST)
- (LIST '|symbolEqual?| 'EQ)
+ (LIST '|substitute!| 'NSUBST) (LIST '|symbolEq?| 'EQ)
(LIST '|symbolFunction| 'SYMBOL-FUNCTION)
(LIST '|symbolName| 'SYMBOL-NAME)
(LIST '|symbolValue| 'SYMBOL-VALUE)
@@ -253,6 +258,7 @@
(LIST '|third| 'CADDR)
(LIST '|toString| 'WRITE-TO-STRING) (LIST '|true| 'T)
(LIST '|upperCase?| 'UPPER-CASE-P)
+ (LIST '|valueEq?| 'EQUAL)
(LIST '|vector?| 'SIMPLE-VECTOR-P)
(LIST '|vectorRef| 'SVREF)
(LIST '|writeByte| 'WRITE-BYTE)
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index efb7cf0e..e52d92ea 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -6,7 +6,7 @@
(PROVIDE "utility")
(EXPORT '(|objectMember?| |symbolMember?| |stringMember?| |charMember?|
- |scalarMember?|))
+ |scalarMember?| |listMember?|))
(DEFUN |objectMember?| (|x| |l|)
(COND
@@ -14,31 +14,21 @@
(OR (EQ |x| (CAR |l|)) (|objectMember?| |x| (CDR |l|))))
(T (EQ |x| |l|))))
-(DEFUN |symbolMember?| (|x| |l|)
+(DEFUN |genericMember?| (|x| |l| |p|)
(COND
((NULL |l|) NIL)
((CONSP |l|)
- (OR (EQ |x| (CAR |l|)) (|symbolMember?| |x| (CDR |l|))))
- (T (EQ |x| |l|))))
+ (OR (APPLY |p| |x| (CAR |l|) NIL)
+ (|genericMember?| |x| (CDR |l|) |p|)))
+ (T (APPLY |p| |x| |l| NIL))))
-(DEFUN |stringMember?| (|s| |l|)
- (COND
- ((NULL |l|) NIL)
- ((CONSP |l|)
- (OR (STRING= |s| (CAR |l|)) (|stringMember?| |s| (CDR |l|))))
- (T (STRING= |s| |l|))))
+(DEFUN |symbolMember?| (|x| |l|) (|genericMember?| |x| |l| #'EQ))
-(DEFUN |charMember?| (|x| |l|)
- (COND
- ((NULL |l|) NIL)
- ((CONSP |l|)
- (OR (CHAR= |x| (CAR |l|)) (|charMember?| |x| (CDR |l|))))
- (T (CHAR= |x| |l|))))
+(DEFUN |stringMember?| (|s| |l|) (|genericMember?| |s| |l| #'STRING=))
-(DEFUN |scalarMember?| (|x| |l|)
- (COND
- ((NULL |l|) NIL)
- ((CONSP |l|)
- (OR (EQL |x| (CAR |l|)) (|scalarMember?| |x| (CDR |l|))))
- (T (EQL |x| |l|))))
+(DEFUN |charMember?| (|c| |l|) (|genericMember?| |c| |l| #'CHAR=))
+
+(DEFUN |scalarMember?| (|x| |l|) (|genericMember?| |x| |l| #'EQL))
+
+(DEFUN |listMember?| (|x| |l|) (|genericMember?| |x| |l| #'EQUAL))
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index 95011b4a..b12e5991 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -251,9 +251,11 @@ for i in [ _
["bitmask", "SBIT"] , _
["canonicalFilename", "PROBE-FILE"], _
["charByName", "NAME-CHAR"] , _
+ ["charDowncase", "CHAR-DOWNCASE"], _
+ ["charEq?", "CHAR=" ], _
+ ["charUpcase", "CHAR-UPCASE"], _
["charString", "STRING"] , _
["char?", "CHARACTERP"] , _
- ["charEq?", "CHAR=" ], _
["codePoint", "CHAR-CODE"], _
["cons?", "CONSP"] , _
["copy", "COPY"] , _
@@ -273,6 +275,7 @@ for i in [ _
["lastNode", "LAST"] , _
["LAST", "last"] , _
["list", "LIST"] , _
+ ["listEq?", "EQUAL"] , _
["lowerCase?", "LOWER-CASE-P"], _
["makeSymbol", "INTERN"] , _
["maxIndex", "MAXINDEX"] , _
@@ -305,12 +308,14 @@ for i in [ _
["setUnion", "UNION"] , _
["strconc", "CONCAT"] , _
["stringChar", "SCHAR"] , _
+ ["stringDowncase", "STRING-DOWNCASE"] , _
["string?", "STRINGP"] ,_
["stringEq?","STRING="] , _
+ ["stringUpcase", "STRING-UPCASE"] , _
["subSequence", "SUBSEQ"] , _
["substitute", "SUBST"] , _
["substitute!", "NSUBST"] , _
- ["symbolEqual?", "EQ"], _
+ ["symbolEq?", "EQ"], _
["symbolFunction", "SYMBOL-FUNCTION"], _
["symbolName", "SYMBOL-NAME"], _
["symbolValue", "SYMBOL-VALUE"], _
@@ -320,6 +325,7 @@ for i in [ _
["toString", "WRITE-TO-STRING"], _
["true", "T"] , _
["upperCase?", "UPPER-CASE-P"], _
+ ["valueEq?", "EQUAL"] , _
["vector?", "SIMPLE-VECTOR-P"], _
["vectorRef", "SVREF"] , _
["writeByte", "WRITE-BYTE"], _
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 39747fd5..026bcc04 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -33,30 +33,28 @@
import initial_-env
namespace BOOTTRAN
module utility (objectMember?, symbolMember?, stringMember?,
- charMember?, scalarMember?)
+ charMember?, scalarMember?, listMember?)
objectMember?(x,l) ==
cons? l => sameObject?(x,first l) or objectMember?(x,rest l)
sameObject?(x,l)
-symbolMember?(x,l) ==
+genericMember?(x,l,p) ==
l = nil => false
- cons? l => sameObject?(x,first l) or symbolMember?(x,rest l)
- sameObject?(x,l)
+ cons? l => apply(p,x,first l,nil) or genericMember?(x,rest l,p)
+ apply(p,x,l,nil)
+
+symbolMember?(x,l) ==
+ genericMember?(x,l,function symbolEq?)
stringMember?(s,l) ==
- l = nil => false
- cons? l => stringEq?(s,first l) or stringMember?(s,rest l)
- stringEq?(s,l)
+ genericMember?(s,l,function stringEq?)
-charMember?(x,l) ==
- l = nil => false
- cons? l => charEq?(x,first l) or charMember?(x,rest l)
- charEq?(x,l)
+charMember?(c,l) ==
+ genericMember?(c,l,function charEq?)
scalarMember?(x,l) ==
- l = nil => false
- cons? l => scalarEq?(x,first l) or scalarMember?(x,rest l)
- scalarEq?(x,l)
+ genericMember?(x,l,function scalarEq?)
-
+listMember?(x,l) ==
+ genericMember?(x,l,function listEq?)
generated by cgit v1.2.3 (git 2.39.1) at 2024-10-03 01:08:23 +0000