From 1fd6a63bbce9234ba3b8efa12c9a91643f0a87a1 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Wed, 28 Dec 2011 04:03:36 +0000 Subject: * boot/tokens.boot: Do not rewrite drop and take. * boot/utility.boot (drop): Define and export. (take): Likewise. * interp/br-con.boot: Use take, not TAKE; use drop, not DROP. * interp/br-data.boot: Likewise. * interp/br-op1.boot: Likewise. * interp/br-saturn.boot: Likewise. * interp/c-doc.boot: Likewise. * interp/c-util.boot: Likewise. * interp/cattable.boot: Likewise. * interp/clammed.boot: Likewise. * interp/compiler.boot: Likewise. * interp/database.boot: Likewise. * interp/define.boot: Likewise. * interp/guess.boot: Likewise. * interp/htsetvar.boot: Likewise. * interp/i-analy.boot: Likewise. * interp/i-eval.boot: Likewise. * interp/i-funsel.boot: Likewise. * interp/i-map.boot: Likewise. * interp/i-output.boot: Likewise. * interp/i-special.boot: Likewise. * interp/i-syscmd.boot: Likewise. * interp/i-toplev.boot: Likewise. * interp/i-util.boot: Likewise. * interp/nruncomp.boot: Likewise. * interp/parse.boot: Likewise. * interp/record.boot: Likewise. * interp/setvars.boot: Likewise. * interp/slam.boot: Likewise. * interp/trace.boot: Likewise. * interp/word.boot: Likewise. * interp/macros.lisp (DROP): Remove. (TAKE): Likewise. --- src/boot/strap/tokens.clisp | 37 ++++++++++++++++++------------------- src/boot/strap/utility.clisp | 39 ++++++++++++++++++++++++++++++++++++++- src/boot/tokens.boot | 2 -- src/boot/utility.boot | 21 +++++++++++++++++++-- 4 files changed, 75 insertions(+), 24 deletions(-) (limited to 'src/boot') 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|)) @@ -82,12 +82,18 @@ (FTYPE (FUNCTION ((FUNCTION (|%Thing|) |%Thing|) (|%List| |%Thing|)) |%Thing|) |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|))) diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot index b45cb669..77b29cb2 100644 --- a/src/boot/tokens.boot +++ b/src/boot/tokens.boot @@ -256,7 +256,6 @@ for i in [ _ ["copyVector", "COPY-SEQ"] , _ ["croak", "CROAK"] , _ ["digit?", "DIGIT-CHAR-P"] , _ - ["drop", "DROP"] , _ ["exit", "EXIT"] , _ ["false", 'NIL] , _ ["fifth", "FIFTH"] , _ @@ -307,7 +306,6 @@ for i in [ _ ["symbolName", "SYMBOL-NAME"], _ ["symbolValue", "SYMBOL-VALUE"], _ ["symbol?", "SYMBOLP"] , _ - ["take", "TAKE"] , ["third", "CADDR"] , _ ["toString", "WRITE-TO-STRING"], _ ["true", "T"] , _ diff --git a/src/boot/utility.boot b/src/boot/utility.boot index 6e08acb5..52593e5d 100644 --- a/src/boot/utility.boot +++ b/src/boot/utility.boot @@ -48,8 +48,8 @@ module utility (objectMember?, symbolMember?, stringMember?, lastNode, append, append!, copyList, substitute, substitute!, setDifference, setUnion, setIntersection, symbolAssoc, applySubst, applySubst!, applySubstNQ, objectAssoc, - remove, removeSymbol, atomic?, every?, any?, takeWhile, copyTree, - finishLine) where + remove, removeSymbol, atomic?, every?, any?, take, takeWhile, drop, + copyTree, finishLine) where substitute: (%Thing,%Thing,%Thing) -> %Thing substitute!: (%Thing,%Thing,%Thing) -> %Thing append: (%List %Thing,%List %Thing) -> %List %Thing @@ -66,7 +66,9 @@ module utility (objectMember?, symbolMember?, stringMember?, atomic?: %Thing -> %Boolean every?: (%Thing -> %Thing, %List %Thing) -> %Thing any?: (%Thing -> %Thing, %List %Thing) -> %Thing + take: (%Short,%List %Thing) -> %List %Thing takeWhile: (%Thing -> %Thing, %List %Thing) -> %List %Thing + drop: (%Short,%List %Thing) -> %List %Thing copyTree: %Thing -> %Thing finishLine: %Thing -> %Void --FIXME: Next signature commented out because of GCL bugs @@ -90,10 +92,25 @@ every?(f,l) == any?(f,l) == or/[apply(f,x,nil) for x in l] +++ Return the `n' node prefixes of the list `l'. If `n' is negative, +++ take from the end of the list. +take(n,l) == + n >= 0 => [x for x in l for . in 1..n] + drop(#l+n,l) + ++ Return the sublist of `l' whose elements have non-nil image by `f'. takeWhile(f,l) == [x for x in l while apply(f,x,nil)] +++ Return the `n+1'th node and its successors of the list `l'. +++ If `n' is negative, drop from the end. +drop(n,l) == + n >= 0 => + while n > 0 and l is [.,:l] repeat + n := n - 1 + l + take(#l+n,l) + copyTree t == t is [.,:.] => [copyTree first t,:copyTree rest t] t -- cgit v1.2.3