diff options
Diffstat (limited to 'src/boot/strap')
| -rw-r--r-- | src/boot/strap/tokens.clisp | 37 | ||||
| -rw-r--r-- | src/boot/strap/utility.clisp | 39 |
2 files changed, 56 insertions, 20 deletions
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp index ceecbce5..3d170958 100644 --- a/src/boot/strap/tokens.clisp +++ b/src/boot/strap/tokens.clisp @@ -184,13 +184,13 @@ (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 '|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) @@ -211,18 +211,17 @@ (LIST '|symbolFunction| 'SYMBOL-FUNCTION) (LIST '|symbolName| 'SYMBOL-NAME) (LIST '|symbolValue| 'SYMBOL-VALUE) (LIST '|symbol?| 'SYMBOLP) - (LIST '|take| 'TAKE) (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) (LIST '|writeChar| 'WRITE-CHAR) - (LIST '|writeInteger| 'PRINC) (LIST '|writeLine| 'WRITE-LINE) - (LIST '|writeNewline| 'TERPRI) (LIST '|writeString| 'WRITE-STRING) - (LIST 'PLUS '+) (LIST 'MINUS '-) (LIST 'TIMES '*) - (LIST 'POWER 'EXPT) (LIST 'REM 'REM) (LIST 'QUO 'TRUNCATE) - (LIST 'SLASH '/) (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=) - (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL) (LIST 'SHOENE '/=) - (LIST 'T 'T$))) + (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) + (LIST '|writeChar| 'WRITE-CHAR) (LIST '|writeInteger| 'PRINC) + (LIST '|writeLine| 'WRITE-LINE) (LIST '|writeNewline| 'TERPRI) + (LIST '|writeString| 'WRITE-STRING) (LIST 'PLUS '+) + (LIST 'MINUS '-) (LIST 'TIMES '*) (LIST 'POWER 'EXPT) + (LIST 'REM 'REM) (LIST 'QUO 'TRUNCATE) (LIST 'SLASH '/) + (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=) (LIST 'GE '>=) + (LIST 'SHOEEQ 'EQUAL) (LIST 'SHOENE '/=) (LIST 'T 'T$))) (|i| NIL)) (LOOP (COND diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index 73e14218..83ee8844 100644 --- a/src/boot/strap/utility.clisp +++ b/src/boot/strap/utility.clisp @@ -21,7 +21,7 @@ |substitute!| |setDifference| |setUnion| |setIntersection| |symbolAssoc| |applySubst| |applySubst!| |applySubstNQ| |objectAssoc| |remove| |removeSymbol| |atomic?| |every?| - |any?| |takeWhile| |copyTree| |finishLine|))) + |any?| |take| |takeWhile| |drop| |copyTree| |finishLine|))) (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|)) @@ -83,11 +83,17 @@ |any?|)) (DECLAIM + (FTYPE (FUNCTION (|%Short| (|%List| |%Thing|)) (|%List| |%Thing|)) |take|)) + +(DECLAIM (FTYPE (FUNCTION ((FUNCTION (|%Thing|) |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|)) |takeWhile|)) +(DECLAIM + (FTYPE (FUNCTION (|%Short| (|%List| |%Thing|)) (|%List| |%Thing|)) |drop|)) + (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |copyTree|)) (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Void|) |finishLine|)) @@ -120,6 +126,26 @@ (COND (|bfVar#2| (RETURN |bfVar#2|))))) (SETQ |bfVar#1| (CDR |bfVar#1|))))) +(DEFUN |take| (|n| |l|) + (COND + ((NOT (MINUSP |n|)) + (LET ((|bfVar#3| NIL) + (|bfVar#4| NIL) + (|bfVar#1| |l|) + (|x| NIL) + (|bfVar#2| 1)) + (LOOP + (COND + ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL) + (> |bfVar#2| |n|)) + (RETURN |bfVar#3|)) + ((NULL |bfVar#3|) (SETQ |bfVar#3| #1=(CONS |x| NIL)) + (SETQ |bfVar#4| |bfVar#3|)) + (T (RPLACD |bfVar#4| #1#) (SETQ |bfVar#4| (CDR |bfVar#4|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)) + (SETQ |bfVar#2| (+ |bfVar#2| 1))))) + (T (|drop| (+ (LENGTH |l|) |n|) |l|)))) + (DEFUN |takeWhile| (|f| |l|) (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) (|x| NIL)) (LOOP @@ -132,6 +158,17 @@ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))) (SETQ |bfVar#1| (CDR |bfVar#1|))))) +(DEFUN |drop| (|n| |l|) + (COND + ((NOT (MINUSP |n|)) + (LOOP + (COND + ((NOT (AND (PLUSP |n|) (CONSP |l|) (PROGN (SETQ |l| (CDR |l|)) T))) + (RETURN NIL)) + (T (SETQ |n| (- |n| 1))))) + |l|) + (T (|take| (+ (LENGTH |l|) |n|) |l|)))) + (DEFUN |copyTree| (|t|) (COND ((CONSP |t|) (CONS (|copyTree| (CAR |t|)) (|copyTree| (CDR |t|)))) (T |t|))) |