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/ChangeLog | 37 +++++++++++++++++++++++++++++++++++++ src/boot/strap/tokens.clisp | 37 ++++++++++++++++++------------------- src/boot/strap/utility.clisp | 39 ++++++++++++++++++++++++++++++++++++++- src/boot/tokens.boot | 2 -- src/boot/utility.boot | 21 +++++++++++++++++++-- src/interp/br-con.boot | 2 +- src/interp/br-data.boot | 8 ++++---- src/interp/br-op1.boot | 2 +- src/interp/br-saturn.boot | 2 +- src/interp/c-doc.boot | 2 +- src/interp/c-util.boot | 8 ++++---- src/interp/cattable.boot | 2 +- src/interp/clammed.boot | 2 +- src/interp/compiler.boot | 6 +++--- src/interp/database.boot | 2 +- src/interp/define.boot | 14 +++++++------- src/interp/guess.boot | 4 ++-- src/interp/htsetvar.boot | 4 ++-- src/interp/i-analy.boot | 2 +- src/interp/i-eval.boot | 2 +- src/interp/i-funsel.boot | 2 +- src/interp/i-map.boot | 6 +++--- src/interp/i-output.boot | 6 +++--- src/interp/i-special.boot | 2 +- src/interp/i-syscmd.boot | 4 ++-- src/interp/i-toplev.boot | 2 +- src/interp/i-util.boot | 2 +- src/interp/macros.lisp | 14 -------------- src/interp/nruncomp.boot | 2 +- src/interp/parse.boot | 2 +- src/interp/preparse.lisp | 4 ++-- src/interp/record.boot | 4 ++-- src/interp/setvars.boot | 2 +- src/interp/slam.boot | 2 +- src/interp/trace.boot | 2 +- src/interp/word.boot | 16 ++++++++-------- 36 files changed, 172 insertions(+), 98 deletions(-) (limited to 'src') diff --git a/src/ChangeLog b/src/ChangeLog index e60a0264..59992dbb 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,40 @@ +2011-12-27 Gabriel Dos Reis + + * 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. + 2011-12-27 Gabriel Dos Reis * interp/g-opt.boot (coagulateWhenSeries): Simplify. 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 diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot index 739332b2..61c27086 100644 --- a/src/interp/br-con.boot +++ b/src/interp/br-con.boot @@ -510,7 +510,7 @@ augmentHasArgs(alist,conform) == n := #args [[name,:pred] for [name,:p] in alist] where pred() == extractHasArgs p is [a,:b] => p - quickAnd(p,['hasArgs,:TAKE(n,KDR getConstructorForm opOf name)]) + quickAnd(p,['hasArgs,:take(n,KDR getConstructorForm opOf name)]) kcdePage(htPage,junk) == [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) diff --git a/src/interp/br-data.boot b/src/interp/br-data.boot index dbc7eb16..54a8021e 100644 --- a/src/interp/br-data.boot +++ b/src/interp/br-data.boot @@ -127,7 +127,7 @@ buildLibdbString [x,:u] == libConstructorSig [conname,:argl] == [[.,:sig],:.] := getConstructorModemap conname - formals := TAKE(#argl,$FormalMapVariableList) + formals := take(#argl,$FormalMapVariableList) sig := applySubst(pairList($TriangleVariableList,formals),sig) keys := [g(f,sig,i) for f in formals for i in 1..] where g(x,u,i) == --does x appear in any but i-th element of u? @@ -496,7 +496,7 @@ getImports conname == --called by mkUsersHashTable getParentsFor(db,formalParams) == --called by compDefineFunctor1 acc := nil - formals := TAKE(#formalParams,$TriangleVariableList) + formals := take(#formalParams,$TriangleVariableList) constructorForm := dbConstructorForm db for x in folks dbCategory db repeat x := applySubst(pairList(formals,formalParams),x) @@ -653,7 +653,7 @@ domainsOf(conform,domname,:options) == | key is [anc,: =conname]] --u is list of pairs (a . b) where b() = conname --we sort u then replace each b by the predicate for which this is true - s := listSort(function GLESSEQP,COPY u) + s := listSort(function GLESSEQP,copyTree u) s := [[first pair,:constructorHasCategoryFromDB pair] for pair in s] transKCatAlist(conform,domname,listSort(function GLESSEQP,s)) @@ -696,7 +696,7 @@ transKCatAlist(conform,domname,s) == main where --no domname, so look for special argument combinations acc := nil KDR conform => - farglist := TAKE(#rest conform,$FormalMapVariableList) + farglist := take(#rest conform,$FormalMapVariableList) for pair in s repeat --pair has form [con,[conargs,:pred],...]] leftForm := getConstructorForm first pair for (ap := [args,:pred]) in rest pair repeat diff --git a/src/interp/br-op1.boot b/src/interp/br-op1.boot index adc1403f..c31af10f 100644 --- a/src/interp/br-op1.boot +++ b/src/interp/br-op1.boot @@ -530,7 +530,7 @@ dbShowOpAllDomains(htPage,opAlist,which) == pred := simpOrDumb(predicate,symbolTarget(conname,domOriginAlist) or true) domOriginAlist := insertAlist(conname,pred,domOriginAlist) --the following is similar to "domainsOf" but do not sort immediately - u := [COPY key for [key,:.] in entries _*HASCATEGORY_-HASH_* + u := [copyTree key for [key,:.] in entries _*HASCATEGORY_-HASH_* | symbolTarget(rest key,catOriginAlist)] for pair in u repeat [dom,:cat] := pair diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot index 6a2dcb6b..d320facc 100644 --- a/src/interp/br-saturn.boot +++ b/src/interp/br-saturn.boot @@ -1235,7 +1235,7 @@ displayDomainOp(htPage,which,origin,op,sig,predicate, --RDJ: this next line is necessary until compiler bug is fixed --that forgets to substitute #variables for t#variables; --check the signature for SegmentExpansionCategory, e.g. - tvarlist := TAKE(# $conargs,$TriangleVariableList) + tvarlist := take(# $conargs,$TriangleVariableList) $signature := applySubst(pairList(tvarlist,$FormalMapVariableList),$signature) $sig := which = '"attribute" or which = '"constructor" => sig diff --git a/src/interp/c-doc.boot b/src/interp/c-doc.boot index ffad1b3b..485f28fe 100644 --- a/src/interp/c-doc.boot +++ b/src/interp/c-doc.boot @@ -182,7 +182,7 @@ finalizeDocumentation ctor == hn [[:fn(sig,$e,form.args),:doc] for [sig,:doc] in docList] where fn(x,e,args) == x isnt [.,:.] => [x,nil] - if #x > 2 then x := TAKE(2,x) + if #x > 2 then x := take(2,x) applySubst(pairList(args,$FormalMapVariableList),macroExpand(x,e)) hn u == -- ((op,sig,doc), ...) --> ((op ((sig doc) ...)) ...) diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 83220eb8..e09772c6 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -421,7 +421,7 @@ displayComp level == nil mkErrorExpr level == - bracket ASSOCLEFT DROP(level-#$s,$s) where + bracket ASSOCLEFT drop(level-#$s,$s) where bracket l == #l<2 => l l is [a,b] => @@ -668,7 +668,7 @@ printEnv E == printString ": " PRETTYPRINT tran(rest u,first u) where tran(val,prop) == - prop="value" => DROP(-1,val) + prop="value" => drop(-1,val) val prEnv E == @@ -683,7 +683,7 @@ prEnv E == printString ": " PRETTYPRINT tran(rest u,first u) where tran(val,prop) == - prop="value" => DROP(-1,val) + prop="value" => drop(-1,val) val prModemaps E == @@ -1180,7 +1180,7 @@ displayModemaps E == --% General object traversal functions -GCOPY ob == COPY ob -- for now +GCOPY ob == copyTree ob -- for now --% ++ format the set of candidate operations. diff --git a/src/interp/cattable.boot b/src/interp/cattable.boot index c56c9c17..3ed51a32 100644 --- a/src/interp/cattable.boot +++ b/src/interp/cattable.boot @@ -381,7 +381,7 @@ categoryParts(conform,category,:options) == main where if addCtor? then res := [listSort(function GLESSEQP,$conslist),:res] if getConstructorKindFromDB conname is "category" then - tvl := TAKE(#rest conform,$TriangleVariableList) + tvl := take(#rest conform,$TriangleVariableList) res := applySubst(pairList(tvl,$FormalMapVariableList),res) res build(item,pred) == diff --git a/src/interp/clammed.boot b/src/interp/clammed.boot index 80b4a8db..033ddcd8 100644 --- a/src/interp/clammed.boot +++ b/src/interp/clammed.boot @@ -113,7 +113,7 @@ isValidType form == null (sig := getConstructorSignature op) => nil [.,:cl] := sig -- following line is needed to deal with mutable domains - if # cl ~= # argl and GENSYMP last argl then argl:= DROP(-1,argl) + if # cl ~= # argl and GENSYMP last argl then argl:= drop(-1,argl) # cl ~= # argl => nil cl:= replaceSharps(cl,form) and/[isValid for x in argl for c in cl] where isValid() == diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index a76987d9..f57066f3 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1225,7 +1225,7 @@ compExit(["exit",level,x],m,e) == modifyModeStack(m,index) == $reportExitModeStack => - SAY("exitModeStack: ",COPY $exitModeStack," ====> ", + SAY("exitModeStack: ",copyTree $exitModeStack," ====> ", ($exitModeStack.index:= resolve(m,$exitModeStack.index); $exitModeStack)) $exitModeStack.index:= resolve(m,$exitModeStack.index) @@ -1363,7 +1363,7 @@ compHas(pred is ["has",a,b],m,e) == compHasFormat(pred is ["has",olda,b],e) == argl := $form.args - formals := TAKE(#argl,$FormalMapVariableList) + formals := take(#argl,$FormalMapVariableList) a := applySubst(pairList(formals,argl),olda) [a,.,e] := comp(a,$EmptyMode,e) or return nil a := applySubst(pairList(argl,formals),a) @@ -1871,7 +1871,7 @@ coerceExtraHard(T is [x,m',e],m) == -- FIXME: inherently difficult to comprehend and likely broken. T' := autoCoerceByModemap(T,m) => T' m' is ['Record,:.] and m = $OutputForm => - [['coerceRe2E,x,['ELT,COPY m',0]],m,e] + [['coerceRe2E,x,['ELT,copyTree m',0]],m,e] -- Domain instantiations are first class objects m = $Domain => m' = $Category => nil diff --git a/src/interp/database.boot b/src/interp/database.boot index e4c71bf6..867c40c0 100644 --- a/src/interp/database.boot +++ b/src/interp/database.boot @@ -410,7 +410,7 @@ interactiveModemapForm mm == -- create modemap form for use by the interpreter. This function -- replaces all specific domains mentioned in the modemap with pattern -- variables, and predicates - mm := replaceVars(COPY mm,$PatternVariableList,$FormalMapVariableList) + mm := replaceVars(copyTree mm,$PatternVariableList,$FormalMapVariableList) [pattern := [dc,:sig],pred] := mm pred := [fn x for x in pred] where fn x == x is [a,b,c] and a isnt 'isFreeFunction and c isnt [.,:.] => [a,b,[c]] diff --git a/src/interp/define.boot b/src/interp/define.boot index 089613b1..8edc4da2 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -947,8 +947,8 @@ compDefineCategory1(df is ['DEF,form,sig,body],m,e,fal) == [d,m,e] makeCategoryPredicates(form,u) == - $tvl: local := TAKE(#rest form,$TriangleVariableList) - $mvl: local := TAKE(#rest form,rest $FormalMapVariableList) + $tvl: local := take(#rest form,$TriangleVariableList) + $mvl: local := take(#rest form,rest $FormalMapVariableList) fn(u,nil) where fn(u,pl) == u is ['Join,:.,a] => fn(a,pl) @@ -1084,7 +1084,7 @@ compDefineCategory2(form,signature,body,m,e,$formalArgList) == -- 3. replace arguments by $1,..., substitute into body, -- and introduce declarations into environment - sargl:= TAKE(# form.args, $TriangleVariableList) + sargl:= take(# form.args, $TriangleVariableList) $functorForm:= $form:= [$op,:sargl] $formalArgList:= [:sargl,:$formalArgList] formalBody := dbSubstituteFormals(db,body) @@ -2308,11 +2308,11 @@ doItConditionally(item,predl) == doItConditionally(item,predl) p is ["and",p',p''] => item.rest.first := p' - item.rest.rest.first := ["IF",p'',x,COPY y] + item.rest.rest.first := ["IF",p'',x,copyTree y] doItConditionally(item,predl) p is ["or",p',p''] => item.rest.first := p' - item.rest.rest.rest.first := ["IF",p'',COPY x,y] + item.rest.rest.rest.first := ["IF",p'',copyTree x,y] doItConditionally(item,predl) doItIf(item,predl,$e) @@ -2476,9 +2476,9 @@ compCategoryItem(x,predl,env,sigs,atts) == x is ["IF",a,b,c] => a is ["not",p] => compCategoryItem(["IF",p,c,b],predl,env,sigs,atts) a is ["and",p,q] => - compCategoryItem(["IF",p,["IF",q,b,c],COPY c],predl,env,sigs,atts) + compCategoryItem(["IF",p,["IF",q,b,c],copyTree c],predl,env,sigs,atts) a is ["or",p,q] => - compCategoryItem(["IF",p,b,["IF",q,COPY b,c]],predl,env,sigs,atts) + compCategoryItem(["IF",p,b,["IF",q,copyTree b,c]],predl,env,sigs,atts) predl':= [a,:predl] if b~="%noBranch" then b is ["PROGN",:l] => diff --git a/src/interp/guess.boot b/src/interp/guess.boot index c4956afc..43cd1384 100644 --- a/src/interp/guess.boot +++ b/src/interp/guess.boot @@ -65,7 +65,7 @@ removeDupOrderedAlist u == wordsOfString(s) == [stringUpcase x for x in wordsOfStringKeepCase s] -wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] +wordsOfStringKeepCase s == wordsOfString1(s,0) or [copyTree s] wordsOfString1(s,j) == k := or/[i for i in j..(maxIndex(s)-1) | upperCase? stringChar(s,i)] => @@ -149,7 +149,7 @@ moreWords(word,table) == findApproximateWords(word,table) == count := $countThreshold words:= wordsOfString word - upperWord:= UPCASE COPY word + upperWord:= UPCASE copyTree word n := #words threshold:= n = 1 => count diff --git a/src/interp/htsetvar.boot b/src/interp/htsetvar.boot index 1a8001a9..4c84f827 100644 --- a/src/interp/htsetvar.boot +++ b/src/interp/htsetvar.boot @@ -46,7 +46,7 @@ htSetVars() == htShowSetTree($setOptions) htShowSetTree(setTree) == - $path := TAKE(- LASTATOM setTree,$path) + $path := take(- LASTATOM setTree,$path) page := htInitPage(mkSetTitle(),nil) htpSetProperty(page, 'setTree, setTree) links := nil @@ -100,7 +100,7 @@ listOfStrings2String u == htShowSetPage(htPage, branch) == setTree := htpProperty(htPage, 'setTree) - $path := [branch,:TAKE(- LASTATOM setTree,$path)] + $path := [branch,:take(- LASTATOM setTree,$path)] setData := assoc(branch, setTree) null setData => systemError('"No Set Data") diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot index 4a66b64b..e0624236 100644 --- a/src/interp/i-analy.boot +++ b/src/interp/i-analy.boot @@ -513,7 +513,7 @@ bottomUpForm(t,op,opName,argl,argModeSetList) == bottomUpForm2(t,op,opName,argl,argModeSetList) bottomUpForm3(t,op,opName,argl,argModeSetList) == - $origArgModeSetList:local := COPY argModeSetList + $origArgModeSetList:local := copyTree argModeSetList bottomUpForm2(t,op,opName,argl,argModeSetList) bottomUpForm2(t,op,opName,argl,argModeSetList) == diff --git a/src/interp/i-eval.boot b/src/interp/i-eval.boot index fc92a6db..0ccb74a6 100644 --- a/src/interp/i-eval.boot +++ b/src/interp/i-eval.boot @@ -243,7 +243,7 @@ evalForm(op,opName,argl,mmS) == ['SPADCALL,:form,freeFun] fun is ['XLAM,xargs,:xbody] => rec := first form - ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] + ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:take(#xargs, form)] dcVector := evalDomain dc fun0 := newType? CAAR mm => diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot index 12daa636..611882e2 100644 --- a/src/interp/i-funsel.boot +++ b/src/interp/i-funsel.boot @@ -924,7 +924,7 @@ matchMmSig(mm,tar,args1,args2) == -- then the modemap condition is evaluated [sig,:.]:= mm if CONTAINED('_#, sig) then - sig := [replaceSharpCalls COPY t for t in sig] + sig := [replaceSharpCalls copyTree t for t in sig] args1 = nil => matchMmSigTar(tar,first sig) a:= rest sig arg:= nil diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot index d654e787..2ee7de1c 100644 --- a/src/interp/i-map.boot +++ b/src/interp/i-map.boot @@ -302,7 +302,7 @@ makePattern(args,pred) == pred is ["=","#1",n] => n addPatternPred("#1",pred) u:= canMakeTuple(nargs,pred) => u - addPatternPred(["tuple",:TAKE(nargs,$FormalMapVariableList)],pred) + addPatternPred(["tuple",:take(nargs,$FormalMapVariableList)],pred) addPatternPred(arg,pred) == pred=true => arg @@ -375,7 +375,7 @@ putDependencies (op, dependencies) == putFlag ("$dependencies", newDependencies) clearDependencies(x,clearLocalModemapsIfTrue) == - $dependencies: local:= COPY getFlag "$dependencies" + $dependencies: local:= copyTree getFlag "$dependencies" clearDep1(x,nil,nil,$dependencies) clearDep1(x,toDoList,doneList,depList) == @@ -659,7 +659,7 @@ interpMap(opName,tar) == $mapName : local := opName $mapTarget : local := tar body:= get(opName,'mapBody,$e) - savedTimerStack := COPY $timedNameStack + savedTimerStack := copyTree $timedNameStack catchName := mapCatchName $mapName c := CATCH(catchName, interpret1(body,tar,nil)) -- $interpMapTag and $interpMapTag ~= mapCatchName $mapName => diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot index d734fbc1..20028fc4 100644 --- a/src/interp/i-output.boot +++ b/src/interp/i-output.boot @@ -1121,7 +1121,7 @@ outformWidth u == --WIDTH as called from OUTFORM to do a COPY (stringChar(u,1) = char "b" or stringChar(u,1) = char "d") => 1 #u u isnt [.,:.] => # atom2String u - WIDTH COPY u + WIDTH copyTree u WIDTH u == string? u => @@ -1913,7 +1913,7 @@ charyElse(u,v,start,linelength) == scylla(n,v) == y := LASSOC(n,v) null y => nil - if string?(y) then y := DROPTRAILINGBLANKS COPY y + if string?(y) then y := DROPTRAILINGBLANKS copyTree y if $collectOutput then $outputLines := [y, :$outputLines] else @@ -2646,7 +2646,7 @@ maPrin u == null u => nil --> if $runTestFlag or $mkTestFlag then - $mkTestOutputStack := [COPY u, :$mkTestOutputStack] + $mkTestOutputStack := [copyTree u, :$mkTestOutputStack] $highlightDelta := 0 c := CATCH('outputFailure,charybdis(u, $MARGIN, $LINELENGTH)) c ~= 'outputFailure => c diff --git a/src/interp/i-special.boot b/src/interp/i-special.boot index a573b0f8..053f6b75 100644 --- a/src/interp/i-special.boot +++ b/src/interp/i-special.boot @@ -1707,7 +1707,7 @@ isPatMatch(l,pats) == m<0 => $subs:="failed" ZEROP n => $subs:=[[var,:l],:$subs] $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] - isPatMatch(DROP(m,l),restPats) + isPatMatch(drop(m,l),restPats) isPatMatch(first l,pat) = "failed" => "failed" isPatMatch(rest l,restPats) keyedSystemError("S2GE0016",['"isPatMatch", diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot index 7ee5c2e4..d9cd3197 100644 --- a/src/interp/i-syscmd.boot +++ b/src/interp/i-syscmd.boot @@ -2440,7 +2440,7 @@ undoSteps(m,beforeOrAfter) == writeInputLines('redo,$IOindex - m) recordFrame('normal) --do NOT mark this as a system command change --do this undo FIRST (i=0 case) - env := COPY CAAR $InteractiveFrame + env := copyTree CAAR $InteractiveFrame for i in 0..m for framelist in tails $frameRecord repeat env := undoSingleStep(first framelist,env) framelist is [.,['systemCommand,:systemDelta],:.] => @@ -2672,7 +2672,7 @@ filterListOfStringsWithFn(patterns,names,fn) == satisfiesRegularExpressions(name,patterns) == -- this is a first cut nf := true - dname := DOWNCASE COPY name + dname := DOWNCASE copyTree name for pattern in patterns while nf repeat -- use @ as a wildcard STRPOS(pattern,dname,0,'"@") => nf := nil diff --git a/src/interp/i-toplev.boot b/src/interp/i-toplev.boot index 073666b8..56b01266 100644 --- a/src/interp/i-toplev.boot +++ b/src/interp/i-toplev.boot @@ -267,7 +267,7 @@ printStatisticsSummary() == interpretTopLevel(x, posnForm) == -- Top level entry point from processInteractive1. Sets up catch -- for a thrown result - savedTimerStack := COPY $timedNameStack + savedTimerStack := copyTree $timedNameStack c := CATCH('interpreter,interpret(x, posnForm)) while savedTimerStack ~= $timedNameStack repeat stopTimingProcess peekTimedName() diff --git a/src/interp/i-util.boot b/src/interp/i-util.boot index 634ea05d..4ff153c7 100644 --- a/src/interp/i-util.boot +++ b/src/interp/i-util.boot @@ -140,7 +140,7 @@ Undef(:u) == throwKeyedMsg("S2IF0008",[formatOpSignature(op,sig),domain]) makeInitialModemapFrame() == - COPY $InitialModemapFrame + copyTree $InitialModemapFrame isCapitalWord x == (y := PNAME x) and and/[upperCase? y.i for i in 0..maxIndex y] diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp index 7e0690fa..15dd7678 100644 --- a/src/interp/macros.lisp +++ b/src/interp/macros.lisp @@ -186,20 +186,6 @@ (DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L)))) -(defun DROP (N X &aux m) - "Return a pointer to the Nth cons of X, counting 0 as the first cons." - (COND ((EQL N 0) X) - ((> N 0) (DROP (1- N) (CDR X))) - ((>= (setq m (+ (length x) N)) 0) (take m x)) - ((CROAK (list "Bad args to DROP" N X))))) - -(DEFUN TAKE (N X &aux m) - "Returns a list of the first N elements of list X." - (COND ((EQL N 0) NIL) - ((> N 0) (CONS (CAR X) (TAKE (1- N) (CDR X)))) - ((>= (setq m (+ (length x) N)) 0) (drop m x)) - ((CROAK (list "Bad args to DROP" N X))))) - (DEFUN NUMOFNODES (X) (if (ATOM X) 0 (+ 1 (NUMOFNODES (CAR X)) (NUMOFNODES (CDR X))))) (DEFUN TRUNCLIST (L TL) "Truncate list L at the point marked by TL." diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 852e5729..adedec63 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -660,7 +660,7 @@ NRTputInLocalReferences(db,bod) == NRTputInHead(db,bod) == bod isnt [.,:.] => bod bod is ['SPADCALL,:args,fn] => - NRTputInTail(db,rest bod) --NOTE: args = COPY of rest bod + NRTputInTail(db,rest bod) --NOTE: args = copyTree of rest bod -- The following test allows function-returning expressions fn is [elt,dom,ind] and dom ~='$ and elt in '(ELT CONST) => k := assocIndex(db,dom) => lastNode(bod).first := ['%vref,'_$,k] diff --git a/src/interp/parse.boot b/src/interp/parse.boot index beb9901a..b4c77d10 100644 --- a/src/interp/parse.boot +++ b/src/interp/parse.boot @@ -328,7 +328,7 @@ parseIf t == p="true" => a p="false" => b p is ["not",p'] => ifTran(p',b,a) - p is ["IF",p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) + p is ["IF",p',a',b'] => ifTran(p',ifTran(a',copyTree a,copyTree b),ifTran(b',a,b)) p is ["SEQ",:l,["exit",1,p']] => ["SEQ",:l,["exit",1,ifTran(p',incExitLevel a,incExitLevel b)]] --this assumes that l has no exits diff --git a/src/interp/preparse.lisp b/src/interp/preparse.lisp index aff89033..94187b94 100644 --- a/src/interp/preparse.lisp +++ b/src/interp/preparse.lisp @@ -374,7 +374,7 @@ ((and (eq next-column start-column) (rplaca nlocs (- (car nlocs))) (not (infixtok next-line))) - (setq next-lines (drop (1- i) slines)) + (setq next-lines (|drop| (1- i) slines)) (rplaca next-lines (addclose (car next-lines) #\;)) (setq count (1+ count)))))))) @@ -383,7 +383,7 @@ (progn (setf (char (car slines) (1- (nonblankloc (car slines)))) #\( ) - (setq slines (drop (1- i) slines)) + (setq slines (|drop| (1- i) slines)) (rplaca slines (addclose (car slines) #\) )))))))) (defun INFIXTOK (S) (MEMBER (STRING2ID-N S 1) '(|then| |else|) :test #'eq)) diff --git a/src/interp/record.boot b/src/interp/record.boot index e334d210..6b36af77 100644 --- a/src/interp/record.boot +++ b/src/interp/record.boot @@ -118,7 +118,7 @@ testPrin(u,w) == --same as maPrin but lines are stored in $testOutputLineList $mkTestFlag: local := nil $testOutputLineFlag: local := true $testOutputLineList: local := nil - maPrin COPY u + maPrin copyTree u res := reverse $testOutputLineList for x in res repeat sayBrightly x res @@ -131,7 +131,7 @@ hyperize(u,w) == $mkTestFlag: local := nil $testOutputLineFlag: local := true $testOutputLineList: local := nil - maPrin COPY u + maPrin copyTree u res := reverse $testOutputLineList null res => '"" null rest res => first res diff --git a/src/interp/setvars.boot b/src/interp/setvars.boot index 20e5b14b..493c5ced 100644 --- a/src/interp/setvars.boot +++ b/src/interp/setvars.boot @@ -109,7 +109,7 @@ $InitialCommandSynonymAlist == [ ] $CommandSynonymAlist := - COPY $InitialCommandSynonymAlist + copyTree $InitialCommandSynonymAlist -- The `set' function in this file handles the top level `)set' -- command line functions. diff --git a/src/interp/slam.boot b/src/interp/slam.boot index 664aa18e..11816e99 100644 --- a/src/interp/slam.boot +++ b/src/interp/slam.boot @@ -144,7 +144,7 @@ reportFunctionCompilation(op,nam,argl,body,isRecursive) == minivectorName := makeInternalMapMinivectorName nam body := substitute(["%dynval",MKQ minivectorName],"$$$",body) symbolValue(minivectorName) := vector $minivector - argl := COPY argl -- play it safe for optimization + argl := copyTree argl -- play it safe for optimization init := not(isRecursive and $compileRecurrence and #argl = 1) => nil isRecurrenceRelation(nam,body,minivectorName) diff --git a/src/interp/trace.boot b/src/interp/trace.boot index 64ddbcc8..5e3c0b43 100644 --- a/src/interp/trace.boot +++ b/src/interp/trace.boot @@ -290,7 +290,7 @@ genDomainTraceName y == --this is now called from trace with the )off option untrace l == $lastUntraced:= - null l => COPY _/TRACENAMES + null l => copyTree _/TRACENAMES l untraceList:= [transTraceItem x for x in l] _/UNTRACE_,0 [lassocSub(funName,$mapSubNameAlist) for diff --git a/src/interp/word.boot b/src/interp/word.boot index ac9132ed..195ce156 100644 --- a/src/interp/word.boot +++ b/src/interp/word.boot @@ -105,7 +105,7 @@ getListOfFunctionNames(fnames) == wordsOfString(s) == [stringUpcase x for x in wordsOfStringKeepCase s] -wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] +wordsOfStringKeepCase s == wordsOfString1(s,0) or [copyTree s] wordsOfString1(s,j) == k := or/[i for i in j..(maxIndex(s)-1) | isBreakCharacter stringChar(s,i)] => @@ -169,8 +169,8 @@ pickANumber(word,list) == REMAINDER(length := # short,2) ~= 0 => 1 0 halfLength:= length/2 - firstList:= TAKE(halfLength,short) - secondList:= TAKE(-halfLength,short) + firstList:= take(halfLength,short) + secondList:= take(-halfLength,short) secondStartIndex:= halfLength + extra shortList:= "append"/[[[:bright i,fillerSpaces(xx-WIDTH i,char " "),x], @@ -198,15 +198,15 @@ bootSearch word == pattern := patternTran key -- converts * to & pattern.0 ~= char "&" => [x for [x,:.] in tableValue($functionTable,UPCASE pattern.0)| - match?(pattern,COPY x)] - "append"/[[x for [x,:.] in v | match?(pattern,COPY x)] + match?(pattern,copyTree x)] + "append"/[[x for [x,:.] in v | match?(pattern,copyTree x)] for [k,:v] in entries $functionTable] findApproximateWords(PNAME word,$functionTable) list findApproximateWords(word,table) == words:= wordsOfString word - upperWord:= UPCASE COPY word + upperWord:= UPCASE copyTree word n := #words threshold:= n = 1 => 3 @@ -272,7 +272,7 @@ findApproximateWords(word,table) == lastThreshold := MAX(3,wordSize/2) vec := GETREFV lastThreshold for [x,:.] in alist repeat - k := deltaWordEntry(upperWord,UPCASE COPY x) + k := deltaWordEntry(upperWord,UPCASE copyTree x) k < lastThreshold => vec.k := [x,:vec.k] or/[vec.k for k in 0..maxIndex vec] @@ -399,5 +399,5 @@ obSearch x == vec:= OBARRAY() pattern:= PNAME x [y for i in 0..maxIndex OBARRAY() | - (ident? (y := vec.i) or CVEC y) and match?(pattern,COPY y)] + (ident? (y := vec.i) or CVEC y) and match?(pattern,copyTree y)] -- cgit v1.2.3