diff options
Diffstat (limited to 'src/boot/strap')
| -rw-r--r-- | src/boot/strap/ast.clisp | 59 | ||||
| -rw-r--r-- | src/boot/strap/tokens.clisp | 12 | ||||
| -rw-r--r-- | src/boot/strap/utility.clisp | 34 |
3 files changed, 69 insertions, 36 deletions
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)) |