aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2010-12-10 13:13:10 +0000
committerdos-reis <gdr@axiomatics.org>2010-12-10 13:13:10 +0000
commit5e866b934c19a52da052a4cb97f972c7968968cc (patch)
treef6a9ba15a003246aba206bc15f8ca978b4ed1a03
parent1d9f6f94a8e8edc6b8a597ed62ee210e1147b0e1 (diff)
downloadopen-axiom-5e866b934c19a52da052a4cb97f972c7968968cc.tar.gz
-rw-r--r--src/boot/ast.boot12
-rw-r--r--src/boot/strap/ast.clisp58
2 files changed, 38 insertions, 32 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 50edc59c..5822f3d9 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -689,15 +689,19 @@ bfReName x==
a := x has SHOERENAME => first a
x
+sequence?(x,pred) ==
+ x is ["QUOTE",seq] and cons? seq and
+ "and"/[apply(pred,y,nil) for y in seq]
++ Generate code for a membership test `x in seq' where `seq'
++ is a sequence (e.g. a list)
bfMember(var,seq) ==
- seq is ["QUOTE",seq'] and "and"/[symbol? x for x in seq'] =>
+ var is ["char",.] or sequence?(seq,function integer?) =>
+ ["MEMBER",var,seq,KEYWORD::TEST,"EQL"]
+ defQuoteId var or sequence?(seq,function symbol?) =>
["MEMQ",var,seq]
- var is ["QUOTE",var'] and symbol? var' =>
- ["MEMQ",var,seq]
- var is ["char",.] => ["MEMBER",var,seq,KEYWORD::TEST,"EQL"]
+ sequence?(seq,function string?) =>
+ ["MEMBER",var,seq,KEYWORD::TEST,"STRING="]
["MEMBER",var,seq]
bfInfApplication(op,left,right)==
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 2a14fe82..54e3f4f5 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -1079,38 +1079,40 @@
(RETURN
(COND ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) (T |x|)))))
+(DEFUN |sequence?| (|x| |pred|)
+ (PROG (|seq| |ISTMP#1|)
+ (RETURN
+ (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |seq| (CAR |ISTMP#1|)) T)))
+ (CONSP |seq|)
+ (LET ((|bfVar#91| T) (|bfVar#90| |seq|) (|y| NIL))
+ (LOOP
+ (COND
+ ((OR (ATOM |bfVar#90|)
+ (PROGN (SETQ |y| (CAR |bfVar#90|)) NIL))
+ (RETURN |bfVar#91|))
+ (T (PROGN
+ (SETQ |bfVar#91| (APPLY |pred| |y| NIL))
+ (COND ((NOT |bfVar#91|) (RETURN NIL))))))
+ (SETQ |bfVar#90| (CDR |bfVar#90|))))))))
+
(DEFUN |bfMember| (|var| |seq|)
- (PROG (|var'| |seq'| |ISTMP#1|)
+ (PROG (|ISTMP#1|)
(RETURN
(COND
- ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
- (PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |seq'| (CAR |ISTMP#1|)) T)))
- (LET ((|bfVar#91| T) (|bfVar#90| |seq'|) (|x| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#90|)
- (PROGN (SETQ |x| (CAR |bfVar#90|)) NIL))
- (RETURN |bfVar#91|))
- (T (PROGN
- (SETQ |bfVar#91| (SYMBOLP |x|))
- (COND ((NOT |bfVar#91|) (RETURN NIL))))))
- (SETQ |bfVar#90| (CDR |bfVar#90|)))))
- (LIST 'MEMQ |var| |seq|))
- ((AND (CONSP |var|) (EQ (CAR |var|) 'QUOTE)
- (PROGN
- (SETQ |ISTMP#1| (CDR |var|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |var'| (CAR |ISTMP#1|)) T)))
- (SYMBOLP |var'|))
- (LIST 'MEMQ |var| |seq|))
- ((AND (CONSP |var|) (EQ (CAR |var|) '|char|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |var|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))
+ ((OR (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 'EQL))
+ ((OR (|defQuoteId| |var|) (|sequence?| |seq| #'SYMBOLP))
+ (LIST 'MEMQ |var| |seq|))
+ ((|sequence?| |seq| #'STRINGP)
+ (LIST 'MEMBER |var| |seq| :TEST 'STRING=))
(T (LIST 'MEMBER |var| |seq|))))))
(DEFUN |bfInfApplication| (|op| |left| |right|)