diff options
Diffstat (limited to 'src/boot')
| -rw-r--r-- | src/boot/ast.boot | 1 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 3 | ||||
| -rw-r--r-- | src/boot/strap/tokens.clisp | 35 | ||||
| -rw-r--r-- | src/boot/strap/utility.clisp | 53 | ||||
| -rw-r--r-- | src/boot/utility.boot | 3 |
5 files changed, 54 insertions, 41 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 327dfe30..be52533d 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -720,6 +720,7 @@ bfISReverse(x,a) == bfIS1(lhs,rhs) == rhs = nil => ['NULL,lhs] + rhs = true => ['EQ,lhs,rhs] bfString? rhs => bfAND [['STRINGP,lhs],["STRING=",lhs,rhs]] bfChar? rhs or integer? rhs => ['EQL,lhs,rhs] rhs isnt [.,:.] => ['PROGN,bfLetForm(rhs,lhs),'T] diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 2842cf8a..f074ad0b 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -1053,6 +1053,7 @@ |d| |c| |a|) (RETURN (COND ((NULL |rhs|) (LIST 'NULL |lhs|)) + ((EQ |rhs| T) (LIST 'EQ |lhs| |rhs|)) ((|bfString?| |rhs|) (|bfAND| (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |rhs|)))) ((OR (|bfChar?| |rhs|) (INTEGERP |rhs|)) (LIST 'EQL |lhs| |rhs|)) @@ -3281,7 +3282,7 @@ (CONS |rettype| NIL))))) (COND ((EQ |t| '|string|) - (SETQ |call| (LIST (|bfColonColon| 'CCL 'GET-CSTRING) |call|)))) + (SETQ |call| (LIST (|bfColonColon| 'CCL '%GET-CSTRING) |call|)))) (LET ((|bfVar#14| |aryPairs|) (|arg| NIL)) (LOOP (COND diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp index 4696f676..ea0dabcf 100644 --- a/src/boot/strap/tokens.clisp +++ b/src/boot/strap/tokens.clisp @@ -182,16 +182,15 @@ (LIST '|charUpcase| 'CHAR-UPCASE) (LIST '|charString| 'STRING) (LIST '|char?| 'CHARACTERP) (LIST '|codePoint| 'CHAR-CODE) (LIST '|cons?| 'CONSP) (LIST '|copy| 'COPY) - (LIST '|copyString| 'COPY-SEQ) - (LIST '|copyVector| 'COPY-SEQ) (LIST '|croak| 'CROAK) - (LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|drop| 'DROP) - (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) (LIST '|fifth| 'FIFTH) - (LIST '|first| 'CAR) (LIST '|float?| 'FLOATP) - (LIST '|flushOutput| 'FORCE-OUTPUT) (LIST '|fourth| 'CADDDR) - (LIST '|function| 'FUNCTION) (LIST '|function?| 'FUNCTIONP) - (LIST '|gensym| 'GENSYM) (LIST '|genvar| 'GENVAR) - (LIST '|integer?| 'INTEGERP) (LIST 'LAST '|last|) - (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL) + (LIST '|copyString| 'COPY-SEQ) (LIST '|copyVector| 'COPY-SEQ) + (LIST '|croak| 'CROAK) (LIST '|digit?| 'DIGIT-CHAR-P) + (LIST '|drop| 'DROP) (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) + (LIST '|fifth| 'FIFTH) (LIST '|first| 'CAR) + (LIST '|float?| 'FLOATP) (LIST '|flushOutput| 'FORCE-OUTPUT) + (LIST '|fourth| 'CADDDR) (LIST '|function| 'FUNCTION) + (LIST '|function?| 'FUNCTIONP) (LIST '|gensym| 'GENSYM) + (LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP) + (LIST 'LAST '|last|) (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL) (LIST '|lowerCase?| 'LOWER-CASE-P) (LIST '|makeSymbol| 'INTERN) (LIST '|maxIndex| 'MAXINDEX) (LIST '|mkpf| 'MKPF) (LIST '|newVector| 'MAKE-ARRAY) (LIST '|nil| NIL) @@ -244,13 +243,15 @@ (LIST '|mmCondition| 'CAADR) (LIST '|mmDC| 'CAAR) (LIST '|mmImplementation| 'CADADR) (LIST '|mmSignature| 'CDAR) (LIST '|mmTarget| 'CADAR) (LIST '|mmSource| 'CDDAR) - (LIST '|mapOperation| 'CAAR) (LIST '|mapSignature| 'CADAR) - (LIST '|mapTarget| 'CAADAR) (LIST '|mapSource| 'CDADAR) - (LIST '|mapKind| 'CAADDR) (LIST '|mode| 'CADR) (LIST '|op| 'CAR) - (LIST '|opcode| 'CADR) (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR) - (LIST '|sig| 'CDDR) (LIST '|source| 'CDR) - (LIST '|streamCode| 'CADDDR) (LIST '|streamDef| 'CADDR) - (LIST '|streamName| 'CADR) (LIST '|target| 'CAR))) + (LIST '|mapOpsig| 'CAR) (LIST '|mapOperation| 'CAAR) + (LIST '|mapSignature| 'CADAR) (LIST '|mapTarget| 'CAADAR) + (LIST '|mapSource| 'CDADAR) (LIST '|mapPredicate| 'CADR) + (LIST '|mapImpl| 'CADDR) (LIST '|mapKind| 'CAADDR) + (LIST '|mode| 'CADR) (LIST '|op| 'CAR) (LIST '|opcode| 'CADR) + (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR) (LIST '|sig| 'CDDR) + (LIST '|source| 'CDR) (LIST '|streamCode| 'CADDDR) + (LIST '|streamDef| 'CADDR) (LIST '|streamName| 'CADR) + (LIST '|target| 'CAR))) (|i| NIL)) (LOOP (COND diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index db11171f..457ea66e 100644 --- a/src/boot/strap/utility.clisp +++ b/src/boot/strap/utility.clisp @@ -20,7 +20,7 @@ |lastNode| |append| |append!| |copyList| |substitute| |substitute!| |setDifference| |setUnion| |setIntersection| |symbolAssoc| |applySubst| |applySubst!| |applySubstNQ| - |objectAssoc| |remove| |removeSymbol| |atomic?| + |objectAssoc| |remove| |removeSymbol| |atomic?| |copyTree| |finishLine|))) (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|)) @@ -74,6 +74,8 @@ (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |atomic?|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |copyTree|)) + (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Void|) |finishLine|)) (DECLAIM @@ -84,6 +86,10 @@ (DEFUN |atomic?| (|x|) (OR (NOT (CONSP |x|)) (EQ (CAR |x|) 'QUOTE))) +(DEFUN |copyTree| (|t|) + (COND ((CONSP |t|) (CONS (|copyTree| (CAR |t|)) (|copyTree| (CDR |t|)))) + (T |t|))) + (DEFUN |objectMember?| (|x| |l|) (LOOP (COND ((NULL |l|) (RETURN NIL)) @@ -216,36 +222,37 @@ (DEFUN |applySubst| (|sl| |t|) (PROG (|p| |tl| |hd|) (RETURN - (COND - ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|))) - (SETQ |tl| (|applySubst| |sl| (CDR |t|))) - (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) - (T (CONS |hd| |tl|)))) - ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) - (T |t|))))) + (COND ((NULL |sl|) |t|) + ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|))) + (SETQ |tl| (|applySubst| |sl| (CDR |t|))) + (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) + (T (CONS |hd| |tl|)))) + ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) + (T |t|))))) (DEFUN |applySubst!| (|sl| |t|) (PROG (|p| |tl| |hd|) (RETURN - (COND - ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|))) - (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|) - (RPLACD |t| |tl|)) - ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) - (T |t|))))) + (COND ((NULL |sl|) |t|) + ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|))) + (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|) + (RPLACD |t| |tl|)) + ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) + (T |t|))))) (DEFUN |applySubstNQ| (|sl| |t|) (PROG (|p| |tl| |hd|) (RETURN - (COND - ((AND (CONSP |t|) (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T)) - (COND ((EQ |hd| 'QUOTE) |t|) - (T (SETQ |hd| (|applySubstNQ| |sl| |hd|)) - (SETQ |tl| (|applySubstNQ| |sl| |tl|)) - (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) - (T (CONS |hd| |tl|)))))) - ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) - (T |t|))))) + (COND ((NULL |sl|) |t|) + ((AND (CONSP |t|) + (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T)) + (COND ((EQ |hd| 'QUOTE) |t|) + (T (SETQ |hd| (|applySubstNQ| |sl| |hd|)) + (SETQ |tl| (|applySubstNQ| |sl| |tl|)) + (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) + (T (CONS |hd| |tl|)))))) + ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) + (T |t|))))) (DEFUN |setDifference| (|x| |y|) (PROG (|a| |l| |p|) diff --git a/src/boot/utility.boot b/src/boot/utility.boot index 139e98d0..5b870a6d 100644 --- a/src/boot/utility.boot +++ b/src/boot/utility.boot @@ -214,6 +214,7 @@ substitute(y,x,s) == s applySubst(sl,t) == + sl = nil => t cons? t => hd := applySubst(sl,first t) tl := applySubst(sl,rest t) @@ -223,6 +224,7 @@ applySubst(sl,t) == t applySubst!(sl,t) == + sl = nil => t cons? t => hd := applySubst!(sl,first t) tl := applySubst!(sl,rest t) @@ -233,6 +235,7 @@ applySubst!(sl,t) == ++ Like applySubst, but skip quoted materials. applySubstNQ(sl,t) == + sl = nil => t t is [hd,:tl] => hd is 'QUOTE => t hd := applySubstNQ(sl,hd) |