(FILECREATED " 1-Jul-86 20:52:07" {ERIS}<LISPCORE>LIBRARY>CMLLIST.;23 57988
changes to: (FNS %%TREE-EQUAL-TEST %%TREE-EQUAL-TEST-NOT)
previous date: "30-Jun-86 13:52:10" {ERIS}<LISPCORE>LIBRARY>CMLLIST.;22)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLLISTCOMS)
(RPAQQ CMLLISTCOMS
((* * CMLLIST. Common Lisp Lists Covers all of chapter 15 -- By Kelly Roach, Larry Masinter,
and Ron Fischer. *)
(COMS (* Section 15.1 Conses. *)
(* CAR, CDR, ..., CDDDDR (all functions on pages 262-263)
are OK. *)
(* CONS is OK. *)
(FNS TREE-EQUAL %%TREE-EQUAL-TEST %%TREE-EQUAL-TEST-NOT))
(COMS (* Section 15.2 Lists. *)
(FNS ENDP LIST-LENGTH)
(COMS (FNS CL:NTH %%SETNTH)
(PROP SETFN CL:NTH)
(P (* MOVD in case of old references. *)
(MOVD (QUOTE %%SETNTH)
(QUOTE \SETNTH))))
(COMS (FNS CL:FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST)
(* Macros to make SETF work and code optimize *)
(MACROS CL:FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST)
)
(FNS NTHCDR)
(* LAST LIST LIST* are OK. *)
(FNS MAKE-LIST)
(* APPEND is OK. *)
(FNS COPY-LIST COPY-ALIST COPY-TREE REVAPPEND)
(* NCONC is OK. *)
(FNS NRECONC)
(* CL:PUSH and CL:PUSHNEW are macros defined somewhere else. Don't know where that is.
POP is OK. *)
(FNS BUTLAST NBUTLAST CL:LDIFF))
(COMS (* Section 15.3 Alteration of List Structure. *)
(* RPLACA RPLACD are OK. *))
(COMS (* Section 15.4 Substitution of Expressions. *)
(DECLARE: DONTCOPY DOEVAL@COMPILE (FUNCTIONS SPLICE TEST-KEYS-SUPPLIED))
(FNS %%TEST)
(FNS CL:SUBST %%SUBST SUBST-IF %%SUBST-IF SUBST-IF-NOT %%SUBST-IF-NOT NSUBST %%NSUBST
NSUBST-IF %%NSUBST-IF NSUBST-IF-NOT %%NSUBST-IF-NOT)
(FNS CL:SUBLIS %%SUBLIS NSUBLIS %%NSUBLIS))
(COMS (* Section 15.5 Usng Lists as Sets. *)
(DECLARE: DONTCOPY DOEVAL@COMPILE (FUNCTIONS SPLICE))
(FNS CL:MEMBER %%MEMBER MEMBER-IF MEMBER-IF-NOT)
(PROP DMACRO CL:MEMBER)
(* TAILP is OK. *)
(FNS ADJOIN)
(FNS CL:UNION NUNION)
(FNS CL:INTERSECTION NINTERSECTION)
(FNS SET-DIFFERENCE NSET-DIFFERENCE)
(FNS SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR)
(FNS SUBSETP))
(COMS (* Section 15.6 Association Lists. *)
(FNS ACONS PAIRLIS)
(FNS CL:ASSOC %%ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT))
(COMS (* Section 7.8.4 Mapping *)
(FNS CL:MAPCAR CL:MAPLIST CL:MAPC MAPL MAPCAN CL:MAPCON %%MAP))
(COMS (* Stuff I'm not sure where to place yet. *)
(* It seems that DELQ ASSQ MEMQ aren't part of Common Lisp but part of Spice Lisp. What
functions in the system are currently depending on these functions? *)
(FNS DELQ)
(* CL:EVERY should be in CMLSEQ. *)
(PROP DMACRO CL:EVERY)
(P (MOVD (QUOTE ASSOC)
(QUOTE ASSQ))
(MOVD (QUOTE FMEMB)
(QUOTE MEMQ))
(* NREVERSE should be in CMLSEQ. *)
(MOVD (QUOTE DREVERSE)
(QUOTE NREVERSE))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA DELQ %%MAP CL:MAPCON MAPCAN MAPL CL:MAPC CL:MAPLIST CL:MAPCAR
RASSOC-IF-NOT RASSOC-IF RASSOC ASSOC-IF-NOT ASSOC-IF %%ASSOC CL:ASSOC
PAIRLIS ACONS SUBSETP NSET-EXCLUSIVE-OR SET-EXCLUSIVE-OR NSET-DIFFERENCE
SET-DIFFERENCE NINTERSECTION CL:INTERSECTION NUNION CL:UNION ADJOIN
MEMBER-IF-NOT MEMBER-IF %%MEMBER CL:MEMBER %%NSUBLIS NSUBLIS %%SUBLIS
CL:SUBLIS %%NSUBST-IF-NOT NSUBST-IF-NOT %%NSUBST-IF NSUBST-IF %%NSUBST
NSUBST %%SUBST-IF-NOT SUBST-IF-NOT %%SUBST-IF SUBST-IF %%SUBST CL:SUBST
%%TEST CL:LDIFF NBUTLAST BUTLAST NRECONC REVAPPEND COPY-TREE COPY-ALIST
MAKE-LIST NTHCDR REST TENTH NINTH EIGHTH SEVENTH SIXTH FIFTH FOURTH THIRD
SECOND CL:FIRST %%SETNTH CL:NTH LIST-LENGTH %%TREE-EQUAL-TEST-NOT
%%TREE-EQUAL-TEST TREE-EQUAL)))))
(* * CMLLIST. Common Lisp Lists Covers all of chapter 15 -- By Kelly Roach, Larry Masinter, and
Ron Fischer. *)
(* Section 15.1 Conses. *)
(* CAR, CDR, ..., CDDDDR (all functions on pages 262-263) are OK. *)
(* CONS is OK. *)
(DEFINEQ
(TREE-EQUAL
(CL:LAMBDA (X Y &KEY (TEST (FUNCTION EQL))
TEST-NOT) (* kbr: " 4-Jun-86 23:32")
(* Returns T if X and Y are isomorphic
trees with identical leaves.
*)
(COND
(TEST-NOT (%%TREE-EQUAL-TEST-NOT X Y TEST-NOT))
(T (%%TREE-EQUAL-TEST X Y TEST)))))
(%%TREE-EQUAL-TEST
(CL:LAMBDA (X Y TEST) (* kbr: " 1-Jul-86 20:47")
(COND
((CONSP X)
(AND (CONSP Y)
(%%TREE-EQUAL-TEST (CAR X)
(CAR Y)
TEST)
(%%TREE-EQUAL-TEST (CDR X)
(CDR Y)
TEST)))
((CONSP Y)
NIL)
(T (FUNCALL TEST X Y)))))
(%%TREE-EQUAL-TEST-NOT
(CL:LAMBDA (X Y TEST-NOT) (* kbr: " 1-Jul-86 20:47")
(COND
((CONSP X)
(AND (CONSP Y)
(%%TREE-EQUAL-TEST-NOT (CAR X)
(CAR Y)
TEST-NOT)
(%%TREE-EQUAL-TEST-NOT (CDR X)
(CDR Y)
TEST-NOT)))
((CONSP Y)
NIL)
(T (NOT (FUNCALL TEST-NOT X Y))))))
)
(* Section 15.2 Lists. *)
(DEFINEQ
(ENDP
(LAMBDA (OBJECT) (* raf "29-Jan-86 17:46")
(COND
((NULL OBJECT)
T)
((CL:LISTP OBJECT)
NIL)
(T (ERROR "Arg not list" OBJECT)))))
(LIST-LENGTH
(CL:LAMBDA (LIST) (* kbr: "24-Jun-86 23:09")
(* Returns the length of the given
LIST or NIL if the LIST is circular.
*)
(CL:DO ((N 0 (+ N 2))
(Y LIST (CDDR Y))
(Z LIST (CDR Z)))
(NIL)
(COND
((ENDP Y)
(RETURN N)))
(COND
((ENDP (CDR Y))
(RETURN (+ N 1))))
(COND
((AND (EQ Y Z)
(> N 0))
(RETURN NIL))))))
)
(DEFINEQ
(CL:NTH
(CL:LAMBDA (N LIST) (* kbr: "25-Jun-86 23:03")
(CAR (NTHCDR N LIST))))
(%%SETNTH
(CL:LAMBDA (N LIST NEWVAL) (* kbr: " 4-Jun-86 23:35")
(DECLARE (TYPE FIXNUM N)) (* Sets the Nth element of LIST
(zero based) to NEWVAL *)
(COND
((< N 0)
(CL:ERROR "~S is an illegal N for SETF of NTH." N))
(T (CL:DO ((COUNT N (1- COUNT)))
((ZEROP COUNT)
(RPLACA LIST NEWVAL)
NEWVAL)
(DECLARE (TYPE FIXNUM COUNT))
(COND
((ENDP (CDR LIST))
(CL:ERROR "~S is too large an index for SETF of NTH." N))
(T (SETQ LIST (CDR LIST)))))))))
)
(PUTPROPS CL:NTH SETFN %%SETNTH)
(* MOVD in case of old references. *)
(MOVD (QUOTE %%SETNTH)
(QUOTE \SETNTH))
(DEFINEQ
(CL:FIRST
(CL:LAMBDA (LIST) (* lmm "20-Jan-86 20:58")
(CAR LIST)))
(SECOND
(CL:LAMBDA (LIST) (* lmm "20-Jan-86 20:58")
(CADR LIST)))
(THIRD
(CL:LAMBDA (LIST)
(CADDR LIST)))
(FOURTH
(CL:LAMBDA (LIST)
(CADDDR LIST)))
(FIFTH
(CL:LAMBDA (LIST)
(CAR (CDDDDR LIST))))
(SIXTH
(CL:LAMBDA (LIST)
(CADR (CDDDDR LIST))))
(SEVENTH
(CL:LAMBDA (LIST)
(CADDR (CDDDDR LIST))))
(EIGHTH
(CL:LAMBDA (LIST)
(CADDDR (CDDDDR LIST))))
(NINTH
(CL:LAMBDA (LIST)
(CAR (CDDDDR (CDDDDR LIST)))))
(TENTH
(CL:LAMBDA (LIST)
(CADR (CDDDDR (CDDDDR LIST)))))
(REST
(CL:LAMBDA (LIST)
(CDR LIST)))
)
(* Macros to make SETF work and code optimize *)
(DECLARE: EVAL@COMPILE
(PUTPROPS CL:FIRST DMACRO (= . CAR))
(PUTPROPS SECOND DMACRO (= . CADR))
(PUTPROPS THIRD DMACRO ((LIST)
(CADDR LIST)))
(PUTPROPS FOURTH DMACRO ((LIST)
(CADDDR LIST)))
(PUTPROPS FIFTH DMACRO ((LIST)
(CAR (CDDDDR LIST))))
(PUTPROPS SIXTH DMACRO ((LIST)
(CADR (CDDDDR LIST))))
(PUTPROPS SEVENTH DMACRO ((LIST)
(CADDR (CDDDDR LIST))))
(PUTPROPS EIGHTH DMACRO ((LIST)
(CADDDR (CDDDDR LIST))))
(PUTPROPS NINTH DMACRO ((LIST)
(CAR (CDDDDR (CDDDDR LIST)))))
(PUTPROPS TENTH DMACRO ((LIST)
(CADR (CDDDDR (CDDDDR LIST)))))
(PUTPROPS REST DMACRO ((LIST)
(CDR LIST)))
)
(DEFINEQ
(NTHCDR
(CL:LAMBDA (N LIST) (* kbr: "25-Jun-86 23:05")
(CL:IF (NOT (AND (INTEGERP N)
(>= N 0)))
(CL:ERROR "N = ~S is illegal for NTHCDR." N)
(PROG NIL
LP (COND
((= N 0)
(RETURN LIST))
((ENDP LIST)
(RETURN NIL)))
(SETQ LIST (CDR LIST))
(SETQ N (1- N))
(GO LP)))))
)
(* LAST LIST LIST* are OK. *)
(DEFINEQ
(MAKE-LIST
(CL:LAMBDA (SIZE &KEY INITIAL-ELEMENT)
(DECLARE (TYPE FIXNUM SIZE)) (* raf " 5-Dec-85 04:32")
(COND
((< SIZE 0)
(CL:ERROR "~S is an illegal size for MAKE-LIST." SIZE))
(T (CL:DO ((COUNT SIZE (1- COUNT))
(RESULT (QUOTE NIL)
(CONS INITIAL-ELEMENT RESULT)))
((ZEROP COUNT)
RESULT)
(DECLARE (TYPE FIXNUM COUNT)))))))
)
(* APPEND is OK. *)
(DEFINEQ
(COPY-LIST
(LAMBDA (L) (* lmm " 6-May-86 23:02")
(COND
((LISTP L)
(PROG ((VAL (CONS (CAR L)
NIL))
TAIL)
(SETQ TAIL VAL)
LP (RPLACD TAIL (SETQ TAIL (LIST (CAR (OR (LISTP (SETQ L (CDR L)))
(PROGN (AND L (RPLACD TAIL L))
(RETURN VAL)))))))
(GO LP)))
(T L))))
(COPY-ALIST
(CL:LAMBDA (ALIST) (* kbr: " 4-Jun-86 23:33")
(COND
((CL:ATOM ALIST)
(COND
(ALIST (CL:ERROR "~S is not a list." ALIST))
(T NIL)))
(T (LET ((RESULT (CONS (COND
((CL:ATOM (CAR ALIST))
(CAR ALIST))
(T (CONS (CAAR ALIST)
(CDAR ALIST))))
(QUOTE NIL))))
(CL:DO ((X (CDR ALIST)
(CDR X))
(SPLICE RESULT (CDR (RPLACD SPLICE (CONS (COND
((CL:ATOM (CAR X))
(CAR X))
(T (CONS (CAAR X)
(CDAR X))))
(QUOTE NIL))))))
((CL:ATOM X) (* Non-null terminated alist done
here. *)
(COND
((NOT (NULL X))
(RPLACD SPLICE X)))
RESULT)))))))
(COPY-TREE
(CL:LAMBDA (OBJECT) (* kbr: " 4-Jun-86 23:34")
(* COPY-TREE recursively copys trees
of conses. *)
(COND
((NOT (CONSP OBJECT))
OBJECT)
(T (CONS (COPY-TREE (CAR OBJECT))
(COPY-TREE (CDR OBJECT)))))))
(REVAPPEND
(CL:LAMBDA (X Y) (* kbr: " 4-Jun-86 23:34")
(* Returns (APPEND (REVERSE X) Y) *)
(CL:DO ((TOP X (CDR TOP))
(RESULT Y (CONS (CAR TOP)
RESULT)))
((ENDP TOP)
RESULT))))
)
(* NCONC is OK. *)
(DEFINEQ
(NRECONC
(CL:LAMBDA (X Y) (* kbr: "31-Aug-85 15:19")
(NCONC (NREVERSE X)
Y)))
)
(* CL:PUSH and CL:PUSHNEW are macros defined somewhere else. Don't know where that is. POP is
OK. *)
(DEFINEQ
(BUTLAST
(CL:LAMBDA (LIST &OPTIONAL (N 1))
(DECLARE (TYPE FIXNUM N)) (* raf " 5-Dec-85 04:33")
(COND
((< N 0)
(SETQ N 0))
(T NIL))
(LET ((LENGTH (1- (LENGTH (THE LIST LIST)))))
(DECLARE (TYPE FIXNUM LENGTH))
(COND
((< LENGTH N)
NIL)
(T (CL:DO* ((TOP (CDR LIST)
(CDR TOP))
(RESULT (LIST (CAR LIST)))
(SPLICE RESULT)
(COUNT LENGTH (1- COUNT)))
((= COUNT N)
RESULT)
(SETQ SPLICE (CDR (RPLACD SPLICE (LIST (CAR TOP)))))))))))
(NBUTLAST
(CL:LAMBDA (LIST &OPTIONAL (N 1))
(DECLARE (TYPE FIXNUM N)) (* raf " 5-Dec-85 04:33")
(COND
((< N 0)
(SETQ N 0))
(T NIL))
(LET ((LENGTH (1- (LENGTH (THE LIST LIST)))))
(DECLARE (TYPE FIXNUM LENGTH))
(COND
((< LENGTH N)
NIL)
(T (CL:DO ((1ST (CDR LIST)
(CDR 1ST))
(2ND LIST 1ST)
(COUNT LENGTH (1- COUNT)))
((= COUNT N)
(RPLACD 2ND NIL)
LIST)))))))
(CL:LDIFF
(CL:LAMBDA (LIST SUBLIST) (* raf " 5-Dec-85 04:36")
(CL:DO* ((LIST LIST (CDR LIST))
(RESULT (LIST NIL))
(SPLICE RESULT))
((OR (NULL LIST)
(EQ LIST SUBLIST))
(CDR RESULT))
(SETQ SPLICE (CDR (RPLACD SPLICE (LIST (CAR LIST))))))))
)
(* Section 15.3 Alteration of List Structure. *)
(* RPLACA RPLACD are OK. *)
(* Section 15.4 Substitution of Expressions. *)
(DECLARE: DONTCOPY DOEVAL@COMPILE
(DEFMACRO SPLICE (SOURCE DESTINATION) (BQUOTE (LET ((TEMP (\, SOURCE)))
(SETF (\, SOURCE)
(CDR (\, SOURCE))
(CDR TEMP)
(\, DESTINATION)
(\, DESTINATION)
TEMP))))
(DEFMACRO TEST-KEYS-SUPPLIED NIL (QUOTE (PROGN (COND ((AND TEST TEST-NOT)
(CL:ERROR "Both TEST and TEST-NOT supplied."))
((AND (NULL TEST)
(NULL TEST-NOT))
(SETQ TEST (FUNCTION EQL))))
(COND ((NULL KEY)
(SETQ KEY (FUNCTION IDENTITY)))))))
)
(DEFINEQ
(%%TEST
(CL:LAMBDA (ITEM KEYITEM TEST TEST-NOT KEY) (* kbr: "28-Jun-86 22:11")
(COND
(TEST (FUNCALL TEST ITEM (FUNCALL KEY KEYITEM)))
(TEST-NOT (NOT (FUNCALL TEST-NOT ITEM (FUNCALL KEY KEYITEM))))
(T (SHOULDNT)))))
)
(DEFINEQ
(CL:SUBST
(CL:LAMBDA (NEW OLD TREE &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:34")
(* Make copy of TREE substituting NEW
for every subtree such that OLD and
the subtree satisfy TEST *)
(TEST-KEYS-SUPPLIED)
(%%SUBST NEW OLD TREE TEST TEST-NOT KEY)))
(%%SUBST
(CL:LAMBDA (NEW OLD TREE TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:50")
(* Make copy of TREE substituting NEW
for every subtree such that OLD and
the subtree satisfy TEST
(usually EQL) *)
(COND
((%%TEST OLD TREE TEST TEST-NOT KEY)
NEW)
((CL:ATOM TREE)
TREE)
(T (LET ((CAR (%%SUBST NEW OLD (CAR TREE)
TEST TEST-NOT KEY))
(CDR (%%SUBST NEW OLD (CDR TREE)
TEST TEST-NOT KEY)))
(COND
((AND (EQ CAR (CAR TREE))
(EQ CDR (CDR TREE)))
TREE)
(T (CONS CAR CDR))))))))
(SUBST-IF
(CL:LAMBDA (NEW TEST TREE &KEY (KEY (FUNCTION IDENTITY))) (* kbr: "25-Jun-86 15:33")
(* Substitutes new for subtrees for
which test is true. *)
(%%SUBST-IF NEW TEST TREE KEY)))
(%%SUBST-IF
(CL:LAMBDA (NEW TEST TREE KEY) (* kbr: "25-Jun-86 16:18")
(* Substitutes new for subtrees for
which test is true. *)
(COND
((FUNCALL TEST (FUNCALL KEY TREE))
NEW)
((CL:ATOM TREE)
TREE)
(T (LET ((CAR (%%SUBST-IF NEW TEST (CAR TREE)
KEY))
(CDR (%%SUBST-IF NEW TEST (CDR TREE)
KEY)))
(COND
((AND (EQ CAR (CAR TREE))
(EQ CDR (CDR TREE)))
TREE)
(T (CONS CAR CDR))))))))
(SUBST-IF-NOT
(CL:LAMBDA (NEW TEST TREE &KEY (KEY (FUNCTION IDENTITY))) (* kbr: "25-Jun-86 15:51")
(* Substitutes new for subtrees for
which test is false.
*)
(%%SUBST-IF-NOT NEW TEST TREE KEY)))
(%%SUBST-IF-NOT
(CL:LAMBDA (NEW TEST TREE KEY) (* kbr: "25-Jun-86 16:19")
(* Substitutes new for subtrees for
which test is false.
*)
(COND
((NOT (FUNCALL TEST (FUNCALL KEY TREE)))
NEW)
((CL:ATOM TREE)
TREE)
(T (LET ((CAR (%%SUBST-IF-NOT NEW TEST (CAR TREE)
KEY))
(CDR (%%SUBST-IF-NOT NEW TEST (CDR TREE)
KEY)))
(COND
((AND (EQ CAR (CAR TREE))
(EQ CDR (CDR TREE)))
TREE)
(T (CONS CAR CDR))))))))
(NSUBST
(CL:LAMBDA (NEW OLD TREE &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:38")
(TEST-KEYS-SUPPLIED)
(%%NSUBST NEW OLD TREE TEST TEST-NOT KEY)))
(%%NSUBST
(CL:LAMBDA (NEW OLD TREE TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:51")
(* Conditionally destructively
substitute NEW for OLD in TREE *)
(PROG (TAIL)
(COND
((%%TEST OLD TREE TEST TEST-NOT KEY)
(RETURN NEW)))
(SETQ TAIL TREE)
LOOP
(COND
((CL:ATOM TAIL)
(RETURN TREE))
((%%TEST OLD (CAR TAIL)
TEST TEST-NOT KEY)
(SETF (CAR TAIL)
NEW))
(T (%%NSUBST NEW OLD (CAR TAIL)
TEST TEST-NOT KEY)))
(SETQ TAIL (CDR TAIL))
(GO LOOP))))
(NSUBST-IF
(CL:LAMBDA (NEW TEST TREE &KEY (KEY (FUNCTION IDENTITY))) (* kbr: "25-Jun-86 15:54")
(%%NSUBST-IF NEW TEST TREE KEY)))
(%%NSUBST-IF
(CL:LAMBDA (NEW TEST TREE KEY) (* kbr: "25-Jun-86 16:20")
(COND
((FUNCALL TEST (FUNCALL KEY TREE))
NEW)
((CL:ATOM TREE)
TREE)
(T (CL:DO* ((LAST NIL TREE)
(TREE TREE (CDR TREE)))
((CL:ATOM TREE)
(COND
((FUNCALL TEST (FUNCALL KEY TREE))
(SETF (CDR LAST)
NEW))
(T NIL)))
(COND
((FUNCALL TEST (FUNCALL KEY TREE))
(RETURN (SETF (CDR LAST)
NEW)))
(T (SETF (CAR TREE)
(%%NSUBST-IF NEW TEST (CAR TREE)
KEY)))))
TREE))))
(NSUBST-IF-NOT
(CL:LAMBDA (NEW TEST TREE &KEY (KEY (FUNCTION IDENTITY))) (* kbr: "25-Jun-86 15:55")
(%%NSUBST-IF-NOT NEW TEST TREE KEY)))
(%%NSUBST-IF-NOT
(CL:LAMBDA (NEW TEST TREE KEY) (* kbr: "25-Jun-86 16:21")
(COND
((NOT (FUNCALL TEST (FUNCALL KEY TREE)))
NEW)
((CL:ATOM TREE)
TREE)
(T (CL:DO* ((LAST NIL TREE)
(TREE TREE (CDR TREE)))
((CL:ATOM TREE)
(COND
((NOT (FUNCALL TEST (FUNCALL KEY TREE)))
(SETF (CDR LAST)
NEW))
(T NIL)))
(COND
((NOT (FUNCALL TEST (FUNCALL KEY TREE)))
(RETURN (SETF (CDR LAST)
NEW)))
(T (SETF (CAR TREE)
(%%NSUBST-IF-NOT NEW TEST (CAR TREE)
KEY)))))
TREE))))
)
(DEFINEQ
(CL:SUBLIS
(CL:LAMBDA (ALIST TREE &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:39")
(* Substitutes from ALIST into TREE
nondestructively. *)
(TEST-KEYS-SUPPLIED)
(%%SUBLIS ALIST TREE TEST TEST-NOT KEY)))
(%%SUBLIS
(CL:LAMBDA (ALIST TREE TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:51")
(* Substitutes from alist into tree
nondestructively. *)
(LET ((BUCKET (%%ASSOC TREE ALIST TEST TEST-NOT KEY)))
(COND
(BUCKET (CDR BUCKET))
((CL:ATOM TREE)
TREE)
(T (LET ((CAR (%%SUBLIS ALIST (CAR TREE)
TEST TEST-NOT KEY))
(CDR (%%SUBLIS ALIST (CDR TREE)
TEST TEST-NOT KEY)))
(CL:IF (AND (EQ CAR (CAR TREE))
(EQ CDR (CDR TREE)))
TREE
(CONS CAR CDR))))))))
(NSUBLIS
(CL:LAMBDA (ALIST TREE &KEY KEY TEST TEST-NOT) (* kbr: "28-Jun-86 21:39")
(TEST-KEYS-SUPPLIED)
(%%NSUBLIS ALIST TREE TEST TEST-NOT KEY)))
(%%NSUBLIS
(CL:LAMBDA (ALIST TREE TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:52")
(PROG (BUCKET)
(COND
((SETQ BUCKET (%%ASSOC TREE ALIST TEST TEST-NOT KEY))
(RETURN (CDR BUCKET)))
((CL:ATOM TREE)
(RETURN TREE)))
(CL:DO* ((LAST NIL TREE)
(TREE TREE (CDR TREE)))
((CL:ATOM TREE)
(COND
((SETQ BUCKET (%%ASSOC TREE ALIST TEST TEST-NOT KEY))
(SETF (CDR LAST)
(CDR BUCKET)))
(T NIL)))
(COND
((SETQ BUCKET (%%ASSOC TREE ALIST TEST TEST-NOT KEY))
(RETURN (SETF (CDR LAST)
(CDR BUCKET))))
(T (SETF (CAR TREE)
(%%NSUBLIS ALIST (CAR TREE)
TEST TEST-NOT KEY)))))
(RETURN TREE))))
)
(* Section 15.5 Usng Lists as Sets. *)
(DECLARE: DONTCOPY DOEVAL@COMPILE
(DEFMACRO SPLICE (SOURCE DESTINATION) (BQUOTE (LET ((TEMP (\, SOURCE)))
(SETF (\, SOURCE)
(CDR (\, SOURCE))
(CDR TEMP)
(\, DESTINATION)
(\, DESTINATION)
TEMP))))
)
(DEFINEQ
(CL:MEMBER
(CL:LAMBDA (ITEM LIST &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:40")
(TEST-KEYS-SUPPLIED)
(for TAIL on LIST when (%%TEST ITEM (CAR TAIL)
TEST TEST-NOT KEY) do (RETURN TAIL))))
(%%MEMBER
(CL:LAMBDA (ITEM LIST TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:52")
(for TAIL on LIST when (%%TEST ITEM (CAR TAIL)
TEST TEST-NOT KEY) do (RETURN TAIL))))
(MEMBER-IF
(CL:LAMBDA (TEST LIST &KEY (KEY (FUNCTION IDENTITY))) (* raf "29-Jan-86 17:36")
(COND
((NOT (CL:LISTP LIST))
(CL:ERROR "~S is not a list." LIST)))
(CL:DO ((LIST LIST (CDR LIST)))
((ENDP LIST)
NIL)
(COND
((FUNCALL TEST (FUNCALL KEY (CAR LIST)))
(RETURN LIST))
(T NIL)))))
(MEMBER-IF-NOT
(CL:LAMBDA (TEST LIST &KEY (KEY (FUNCTION IDENTITY))) (* raf "29-Jan-86 17:37")
(COND
((NOT (CL:LISTP LIST))
(CL:ERROR "~S is not a list." LIST)))
(CL:DO ((LIST LIST (CDR LIST)))
((ENDP LIST)
NIL)
(COND
((NOT (FUNCALL TEST (FUNCALL KEY (CAR LIST))))
(RETURN LIST))
(T NIL)))))
)
(PUTPROPS CL:MEMBER DMACRO
(DEFMACRO (ITEM LIST &KEY (TEST (QUOTE (FUNCTION EQL))
TESTSUPPLIED)
(TEST-NOT NIL TESTNOTSUPPLIED)
(KEY (QUOTE (FUNCTION IDENTITY)))) (* optimize simple cases)
(LET ((TESTC (CONSTANTEXPRESSIONP TEST))
(KEYC (CONSTANTEXPRESSIONP KEY))
(TESTNOTC (CONSTANTEXPRESSIONP TEST-NOT))
(LISTC (CONSTANTEXPRESSIONP LIST)))
(COND
((AND LISTC KEYC (EQ (CAR TESTC)
(QUOTE EQL))
(EVERY (CAR LISTC)
(FUNCTION (LAMBDA (X)
(NOT (NUMBERP (APPLY* (CAR KEYC)
X)))))))
(SETQ TESTC (QUOTE (EQ)))))
(COND
((AND TESTC KEYC TESTNOTC)
(if (AND (EQ (CAR TESTC)
(QUOTE EQ))
(EQ (CAR KEYC)
(QUOTE IDENTITY))
(NOT TESTNOTSUPPLIED))
then (LIST (QUOTE FMEMB)
ITEM LIST)
else (LET ((ITERVAR (GENSYM "MEMBER"))
(ITEMVAR (GENSYM "MEMBER-ITEM")))
(BQUOTE (LET ((, ITEMVAR , ITEM))
(for , ITERVAR
on , LIST , (if TESTNOTSUPPLIED
then (QUOTE unless)
else (QUOTE when))
(, (if TESTNOTSUPPLIED
then (CAR TESTNOTC)
else (CAR TESTC))
(, (CAR KEYC)
(CAR , ITERVAR))
, ITEMVAR) do (RETURN , ITERVAR)))))))
(T (QUOTE IGNOREMACRO)))))
)
(* TAILP is OK. *)
(DEFINEQ
(ADJOIN
(CL:LAMBDA (ITEM LIST &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:52")
(* Add ITEM to LIST unless it is
already a member *)
(TEST-KEYS-SUPPLIED)
(COND
((%%MEMBER ITEM LIST TEST TEST-NOT KEY)
LIST)
(T (CONS ITEM LIST)))))
)
(DEFINEQ
(CL:UNION
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:41")
(* Returns the union of LIST1 and
LIST2 *)
(TEST-KEYS-SUPPLIED)
(LET ((RES LIST1))
(DOLIST (CL:ELT LIST2)
(CL:IF (NOT (%%MEMBER CL:ELT LIST1 TEST TEST-NOT KEY))
(CL:PUSH CL:ELT RES)))
RES)))
(NUNION
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:42")
(TEST-KEYS-SUPPLIED)
(LET ((RES LIST1))
(CL:DO NIL ((ENDP LIST2))
(COND
((NOT (%%MEMBER (CAR LIST2)
LIST1 TEST TEST-NOT KEY))
(SPLICE LIST2 RES))
(T (SETQ LIST2 (CDR LIST2)))))
RES)))
)
(DEFINEQ
(CL:INTERSECTION
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:42")
(* Returns the intersection of LIST1
and LIST2 *)
(TEST-KEYS-SUPPLIED)
(LET ((RES NIL))
(DOLIST (CL:ELT LIST1)
(CL:IF (%%MEMBER CL:ELT LIST2 TEST TEST-NOT KEY)
(CL:PUSH CL:ELT RES)))
RES)))
(NINTERSECTION
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:42")
(TEST-KEYS-SUPPLIED)
(LET ((RES NIL))
(CL:DO NIL ((ENDP LIST1))
(COND
((%%MEMBER (CAR LIST1)
LIST2 TEST TEST-NOT KEY)
(SPLICE LIST1 RES))
(T (SETQ LIST1 (CDR LIST1)))))
RES)))
)
(DEFINEQ
(SET-DIFFERENCE
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:43")
(TEST-KEYS-SUPPLIED)
(LET ((RES NIL))
(DOLIST (CL:ELT LIST1)
(COND
((NOT (%%MEMBER CL:ELT LIST2 TEST TEST-NOT KEY))
(CL:PUSH CL:ELT RES))
(T NIL)))
RES)))
(NSET-DIFFERENCE
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:44")
(TEST-KEYS-SUPPLIED)
(LET ((RES NIL))
(CL:DO NIL ((ENDP LIST1))
(COND
((NOT (%%MEMBER (CAR LIST1)
LIST2 TEST TEST-NOT KEY))
(SPLICE LIST1 RES))
(T (SETQ LIST1 (CDR LIST1)))))
RES)))
)
(DEFINEQ
(SET-EXCLUSIVE-OR
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:44")
(* Returns new list of elements
appearing exactly once in LIST1 and
LIST2 *)
(TEST-KEYS-SUPPLIED)
(LET ((RESULT NIL))
(DOLIST (CL:ELT LIST1)
(COND
((NOT (%%MEMBER CL:ELT LIST2 TEST TEST-NOT KEY))
(SETQ RESULT (CONS CL:ELT RESULT)))))
(DOLIST (CL:ELT LIST2)
(COND
((NOT (%%MEMBER CL:ELT LIST1 TEST TEST-NOT KEY))
(SETQ RESULT (CONS CL:ELT RESULT)))))
RESULT)))
(NSET-EXCLUSIVE-OR
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:45")
(TEST-KEYS-SUPPLIED)
(CL:DO ((X LIST1 (CDR X))
(SPLICEX NIL))
((ENDP X)
(COND
((NULL SPLICEX)
(SETQ LIST1 LIST2))
(T (RPLACD SPLICEX LIST2)))
LIST1)
(CL:DO ((Y LIST2 (CDR Y))
(SPLICEY NIL))
((ENDP Y)
(SETQ SPLICEX X))
(COND
((COND
(TEST-NOT (NOT (FUNCALL TEST-NOT (FUNCALL KEY (CAR X))
(FUNCALL KEY (CAR Y)))))
(T (FUNCALL TEST (FUNCALL KEY (CAR X))
(FUNCALL KEY (CAR Y)))))
(COND
((NULL SPLICEX)
(SETQ LIST1 (CDR X)))
(T (RPLACD SPLICEX (CDR X))))
(COND
((NULL SPLICEY)
(SETQ LIST2 (CDR Y)))
(T (RPLACD SPLICEY (CDR Y))))
(RETURN NIL))
(T (SETQ SPLICEY Y)))))))
)
(DEFINEQ
(SUBSETP
(CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:45")
(TEST-KEYS-SUPPLIED)
(for CL:ELT in LIST1 always (%%MEMBER CL:ELT LIST2 TEST TEST-NOT KEY))))
)
(* Section 15.6 Association Lists. *)
(DEFINEQ
(ACONS
(CL:LAMBDA (KEY DATUM ALIST) (* kbr: " 4-Jun-86 23:40")
(* Construct a new alist by adding the
pair (KEY . DATUM) to ALIST *)
(CONS (CONS KEY DATUM)
ALIST)))
(PAIRLIS
(CL:LAMBDA (KEYS DATA &OPTIONAL ALIST) (* kbr: "30-Jun-86 13:41")
(* Construct an association list from
KEYS and DATA (adding to ALIST) *)
(PROG (K D CELL ANSWER) (* Note: This implementation has the
feature that the alist comes out in
the same order that KEYS and DATA are
input. *)
(SETQ K KEYS)
(SETQ D DATA)
(COND
((AND (ENDP K)
(ENDP D))
(RETURN ALIST))
((OR (ENDP K)
(ENDP D))
(GO ERROR)))
(SETQ ANSWER (LIST (CONS (CAR K)
(CAR D)))) (* CELL is the last cons cell in
ANSWER. *)
(SETQ CELL ANSWER)
LOOP
(SETQ K (CDR K))
(SETQ D (CDR D))
(COND
((AND (ENDP K)
(ENDP D))
(SETF (CDR CELL)
ALIST)
(RETURN ANSWER))
((OR (ENDP K)
(ENDP D))
(GO ERROR)))
(SETF (CDR CELL)
(LIST (CONS (CAR K)
(CAR D))))
(SETQ CELL (CDR CELL))
(GO LOOP)
ERROR
(CL:ERROR "PAIRLIS keys and data have different length."))))
)
(DEFINEQ
(CL:ASSOC
(CL:LAMBDA (ITEM ALIST &KEY TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:46")
(TEST-KEYS-SUPPLIED)
(%%ASSOC ITEM ALIST TEST TEST-NOT KEY)))
(%%ASSOC
(CL:LAMBDA (ITEM ALIST TEST TEST-NOT KEY) (* kbr: "28-Jun-86 21:52")
(CL:DO ((ALIST ALIST (CDR ALIST)))
((ENDP ALIST))
(CL:IF (CAR ALIST)
(CL:IF (%%TEST ITEM (CAAR ALIST)
TEST TEST-NOT KEY)
(RETURN (CAR ALIST)))))))
(ASSOC-IF
(CL:LAMBDA (PREDICATE ALIST) (* kbr: "25-Jun-86 17:46")
(* Returns the first cons in ALIST
whose car satisfies the PREDICATE *)
(CL:DO ((ALIST ALIST (CDR ALIST)))
((ENDP ALIST))
(CL:IF (CAR ALIST)
(CL:IF (FUNCALL PREDICATE (CAAR ALIST))
(RETURN (CAR ALIST)))))))
(ASSOC-IF-NOT
(CL:LAMBDA (PREDICATE ALIST) (* kbr: "25-Jun-86 17:47")
(* Returns the first cons in ALIST
whose car does not satisfy the
PREDICATE *)
(CL:DO ((ALIST ALIST (CDR ALIST)))
((ENDP ALIST))
(CL:IF (CAR ALIST)
(CL:IF (NOT (FUNCALL PREDICATE (CAAR ALIST)))
(RETURN (CAR ALIST)))))))
(RASSOC
(CL:LAMBDA (ITEM ALIST &KEY TEST TEST-NOT KEY)
(DECLARE (TYPE LIST ALIST)) (* kbr: "28-Jun-86 21:47")
(TEST-KEYS-SUPPLIED)
(CL:DO ((ALIST ALIST (CDR ALIST)))
((ENDP ALIST))
(CL:IF (CAR ALIST)
(CL:IF (%%TEST ITEM (CDAR ALIST)
TEST TEST-NOT KEY)
(RETURN (CAR ALIST)))))))
(RASSOC-IF
(CL:LAMBDA (PREDICATE ALIST) (* kbr: "25-Jun-86 17:51")
(* Returns the first cons in ALIST
whose cdr satisfies the PREDICATE *)
(CL:DO ((ALIST ALIST (CDR ALIST)))
((ENDP ALIST))
(CL:IF (CAR ALIST)
(CL:IF (FUNCALL PREDICATE (CDAR ALIST))
(RETURN (CAR ALIST)))))))
(RASSOC-IF-NOT
(CL:LAMBDA (PREDICATE ALIST) (* kbr: "25-Jun-86 17:52")
(* Returns the first cons in ALIST
whose cdr does not satisfy the
PREDICATE *)
(CL:DO ((ALIST ALIST (CDR ALIST)))
((ENDP ALIST))
(CL:IF (CAR ALIST)
(CL:IF (NOT (FUNCALL PREDICATE (CDAR ALIST)))
(RETURN (CAR ALIST)))))))
)
(* Section 7.8.4 Mapping *)
(DEFINEQ
(CL:MAPCAR
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS) (* raf "18-Dec-85 17:28")
(%%MAP FUNCTION (CONS LIST MORE-LISTS)
:LIST T)))
(CL:MAPLIST
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS) (* kbr: " 4-Jun-86 23:47")
(* Applies FUNCTION to successive CDRs
of list, returns list of results.
*)
(%%MAP FUNCTION (CONS LIST MORE-LISTS)
:LIST NIL)))
(CL:MAPC
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS) (* kbr: " 4-Jun-86 23:46")
(* Applies FUNCTION to successive
elements of lists, returns NIL . *)
(%%MAP FUNCTION (CONS LIST MORE-LISTS)
NIL T)))
(MAPL
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS) (* kbr: " 4-Jun-86 23:47")
(* Applies FUNCTION to successive CDRs
of list, returns NIL . *)
(%%MAP FUNCTION (CONS LIST MORE-LISTS)
NIL NIL)))
(MAPCAN
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS) (* kbr: " 4-Jun-86 23:47")
(* Applies FUNCTION to successive
elements of list, returns NCONC of
results. *)
(%%MAP FUNCTION (CONS LIST MORE-LISTS)
:NCONC T)))
(CL:MAPCON
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS) (* kbr: " 4-Jun-86 23:48")
(* Applies FUNCTION to successive CDRs
of lists, returns NCONC of results.
*)
(%%MAP FUNCTION (CONS LIST MORE-LISTS)
:NCONC NIL)))
(%%MAP
(CL:LAMBDA (FUNCTION ORIGINAL-ARGLISTS ACCUMULATE TAKE-CAR)(* kbr: " 4-Jun-86 23:46")
(* This function is called by MAPC, MAPCAR, MAPCAN, MAPL, MAPLIST, and MAPCON.
It maps function over the arglists in the appropriate way.
It is done when any of the arglists runs out.
Until then, it CDRs down the arglists calling the FUNCTION and accumulating
results as desired. *)
(LET* ((ARGLISTS (COPY-LIST ORIGINAL-ARGLISTS))
(RET-LIST (LIST NIL))
(TEMP RET-LIST))
(CL:DO ((RES NIL)
(ARGS (QUOTE NIL)
(QUOTE NIL)))
((DOLIST (X ARGLISTS NIL)
(COND
((NULL X)
(RETURN T))
(T NIL)))
(COND
(ACCUMULATE (CDR RET-LIST))
(T (CAR ORIGINAL-ARGLISTS))))
(CL:DO ((L ARGLISTS (CDR L)))
((NULL L))
(push ARGS (COND
(TAKE-CAR (CAAR L))
(T (CAR L))))
(SETF (CAR L)
(CDAR L)))
(SETQ RES (APPLY FUNCTION (NREVERSE ARGS)))
(CASE ACCUMULATE (:NCONC (SETQ TEMP (LAST (NCONC TEMP RES))))
(:LIST (RPLACD TEMP (LIST RES))
(SETQ TEMP (CDR TEMP))))))))
)
(* Stuff I'm not sure where to place yet. *)
(* It seems that DELQ ASSQ MEMQ aren't part of Common Lisp but part of Spice Lisp. What
functions in the system are currently depending on these functions? *)
(DEFINEQ
(DELQ
(CL:LAMBDA (ITEM LIST &OPTIONAL (N 0 NP)) (* kbr: " 4-Jun-86 23:48")
(DECLARE (TYPE FIXNUM N)) (* Returns list with all
(up to N) elements with all elements
EQ to ITEM deleted *)
(CL:DO ((X LIST (CDR X))
(SPLICE (QUOTE NIL)))
((OR (ENDP X)
(AND NP (ZEROP N)))
LIST)
(COND
((EQ ITEM (CAR X))
(SETQ N (1- N))
(COND
((NULL SPLICE)
(SETQ LIST (CDR X)))
(T (RPLACD SPLICE (CDR X)))))
(T (SETQ SPLICE X))))))
)
(* CL:EVERY should be in CMLSEQ. *)
(PUTPROPS CL:EVERY DMACRO
(DEFMACRO (FUNCTION &REST LISTS) (LET
((GENSYM (GENSYM))
(TAIL-VARS (for X in LISTS collect (GENSYM))))
(BQUOTE
(LET
(((\, GENSYM)
T))
(CL:DO
((\,@ (for X in LISTS as TAIL-VAR in TAIL-VARS collect
(LIST TAIL-VAR X (BQUOTE
(CDR (\, TAIL-VAR)))))))
((NOT (AND (\,@ TAIL-VARS)))
(\, GENSYM))
(OR
(SETQ
(\, GENSYM)
(AND
(\, GENSYM)
(FUNCALL
(\, FUNCTION)
(\,@ (for X in TAIL-VARS collect
(BQUOTE (CAR (\, X))))))))
(RETURN NIL)))))) )
)
(MOVD (QUOTE ASSOC)
(QUOTE ASSQ))
(MOVD (QUOTE FMEMB)
(QUOTE MEMQ))
(* NREVERSE should be in CMLSEQ. *)
(MOVD (QUOTE DREVERSE)
(QUOTE NREVERSE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA
DELQ %%MAP CL:MAPCON MAPCAN MAPL CL:MAPC CL:MAPLIST CL:MAPCAR RASSOC-IF-NOT RASSOC-IF
RASSOC ASSOC-IF-NOT ASSOC-IF %%ASSOC CL:ASSOC PAIRLIS ACONS SUBSETP NSET-EXCLUSIVE-OR
SET-EXCLUSIVE-OR NSET-DIFFERENCE SET-DIFFERENCE NINTERSECTION CL:INTERSECTION NUNION
CL:UNION ADJOIN MEMBER-IF-NOT MEMBER-IF %%MEMBER CL:MEMBER %%NSUBLIS NSUBLIS %%SUBLIS
CL:SUBLIS %%NSUBST-IF-NOT NSUBST-IF-NOT %%NSUBST-IF NSUBST-IF %%NSUBST NSUBST
%%SUBST-IF-NOT SUBST-IF-NOT %%SUBST-IF SUBST-IF %%SUBST CL:SUBST %%TEST CL:LDIFF
NBUTLAST BUTLAST NRECONC REVAPPEND COPY-TREE COPY-ALIST MAKE-LIST NTHCDR REST TENTH
NINTH EIGHTH SEVENTH SIXTH FIFTH FOURTH THIRD SECOND CL:FIRST %%SETNTH CL:NTH
LIST-LENGTH %%TREE-EQUAL-TEST-NOT %%TREE-EQUAL-TEST TREE-EQUAL)
)
(PRETTYCOMPRINT CMLLISTCOMS)
(RPAQQ CMLLISTCOMS
((* * CMLLIST. Common Lisp Lists Covers all of chapter 15 -- By Kelly Roach, Larry Masinter,
and Ron Fischer. *)
(COMS (* Section 15.1 Conses. *)
(* CAR, CDR, ..., CDDDDR (all functions on pages 262-263)
are OK. *)
(* CONS is OK. *)
(FNS TREE-EQUAL %%TREE-EQUAL-TEST %%TREE-EQUAL-TEST-NOT))
(COMS (* Section 15.2 Lists. *)
(FNS ENDP LIST-LENGTH)
(COMS (FNS CL:NTH %%SETNTH)
(PROP SETFN CL:NTH)
(P (* MOVD in case of old references. *)
(MOVD (QUOTE %%SETNTH)
(QUOTE \SETNTH))))
(COMS (FNS CL:FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST)
(* Macros to make SETF work and code optimize *)
(MACROS CL:FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST)
)
(FNS NTHCDR)
(* LAST LIST LIST* are OK. *)
(FNS MAKE-LIST)
(* APPEND is OK. *)
(FNS COPY-LIST COPY-ALIST COPY-TREE REVAPPEND)
(* NCONC is OK. *)
(FNS NRECONC)
(* CL:PUSH and CL:PUSHNEW are macros defined somewhere else. Don't know where that is.
POP is OK. *)
(FNS BUTLAST NBUTLAST CL:LDIFF))
(COMS (* Section 15.3 Alteration of List Structure. *)
(* RPLACA RPLACD are OK. *))
(COMS (* Section 15.4 Substitution of Expressions. *)
(DECLARE: DONTCOPY DOEVAL@COMPILE (FUNCTIONS SPLICE TEST-KEYS-SUPPLIED))
(FNS %%TEST)
(FNS CL:SUBST %%SUBST SUBST-IF %%SUBST-IF SUBST-IF-NOT %%SUBST-IF-NOT NSUBST %%NSUBST
NSUBST-IF %%NSUBST-IF NSUBST-IF-NOT %%NSUBST-IF-NOT)
(FNS CL:SUBLIS %%SUBLIS NSUBLIS %%NSUBLIS))
(COMS (* Section 15.5 Usng Lists as Sets. *)
(DECLARE: DONTCOPY DOEVAL@COMPILE (FUNCTIONS SPLICE))
(FNS CL:MEMBER %%MEMBER MEMBER-IF MEMBER-IF-NOT)
(PROP DMACRO CL:MEMBER)
(* TAILP is OK. *)
(FNS ADJOIN)
(FNS CL:UNION NUNION)
(FNS CL:INTERSECTION NINTERSECTION)
(FNS SET-DIFFERENCE NSET-DIFFERENCE)
(FNS SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR)
(FNS SUBSETP))
(COMS (* Section 15.6 Association Lists. *)
(FNS ACONS PAIRLIS)
(FNS CL:ASSOC %%ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT))
(COMS (* Section 7.8.4 Mapping *)
(FNS CL:MAPCAR CL:MAPLIST CL:MAPC MAPL MAPCAN CL:MAPCON %%MAP))
(COMS (* Stuff I'm not sure where to place yet. *)
(* It seems that DELQ ASSQ MEMQ aren't part of Common Lisp but part of Spice Lisp. What
functions in the system are currently depending on these functions? *)
(FNS DELQ)
(* CL:EVERY should be in CMLSEQ. *)
(PROP DMACRO CL:EVERY)
(P (MOVD (QUOTE ASSOC)
(QUOTE ASSQ))
(MOVD (QUOTE FMEMB)
(QUOTE MEMQ))
(* NREVERSE should be in CMLSEQ. *)
(MOVD (QUOTE DREVERSE)
(QUOTE NREVERSE))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA DELQ CL:MAPCON MAPCAN MAPL CL:MAPC CL:MAPLIST CL:MAPCAR RASSOC CL:ASSOC
PAIRLIS SUBSETP NSET-EXCLUSIVE-OR SET-EXCLUSIVE-OR NSET-DIFFERENCE
SET-DIFFERENCE NINTERSECTION CL:INTERSECTION NUNION CL:UNION ADJOIN
MEMBER-IF-NOT MEMBER-IF CL:MEMBER NSUBLIS CL:SUBLIS NSUBST-IF-NOT
NSUBST-IF NSUBST SUBST-IF-NOT SUBST-IF CL:SUBST NBUTLAST BUTLAST
MAKE-LIST %%TREE-EQUAL-TEST-NOT %%TREE-EQUAL-TEST TREE-EQUAL)))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA
DELQ CL:MAPCON MAPCAN MAPL CL:MAPC CL:MAPLIST CL:MAPCAR RASSOC CL:ASSOC PAIRLIS SUBSETP
NSET-EXCLUSIVE-OR SET-EXCLUSIVE-OR NSET-DIFFERENCE SET-DIFFERENCE NINTERSECTION
CL:INTERSECTION NUNION CL:UNION ADJOIN MEMBER-IF-NOT MEMBER-IF CL:MEMBER NSUBLIS
CL:SUBLIS NSUBST-IF-NOT NSUBST-IF NSUBST SUBST-IF-NOT SUBST-IF CL:SUBST NBUTLAST
BUTLAST MAKE-LIST %%TREE-EQUAL-TEST-NOT %%TREE-EQUAL-TEST TREE-EQUAL)
)
(PUTPROPS CMLLIST COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5176 6758 (TREE-EQUAL 5186 . 5740) (%%TREE-EQUAL-TEST 5742 . 6233) (
%%TREE-EQUAL-TEST-NOT 6235 . 6756)) (6793 7859 (ENDP 6803 . 7033) (LIST-LENGTH 7035 . 7857)) (7860
8855 (CL:NTH 7870 . 8014) (%%SETNTH 8016 . 8853)) (8978 9824 (CL:FIRST 8988 . 9118) (SECOND 9120 .
9249) (THIRD 9251 . 9305) (FOURTH 9307 . 9363) (FIFTH 9365 . 9426) (SIXTH 9428 . 9490) (SEVENTH 9492
. 9557) (EIGHTH 9559 . 9624) (NINTH 9626 . 9696) (TENTH 9698 . 9769) (REST 9771 . 9822)) (10684 11269
(NTHCDR 10694 . 11267)) (11308 11867 (MAKE-LIST 11318 . 11865)) (11896 14850 (COPY-LIST 11906 . 12441
) (COPY-ALIST 12443 . 13984) (COPY-TREE 13986 . 14453) (REVAPPEND 14455 . 14848)) (14878 15048 (
NRECONC 14888 . 15046)) (15159 17125 (BUTLAST 15169 . 15993) (NBUTLAST 15995 . 16722) (CL:LDIFF 16724
. 17123)) (18384 18684 (%%TEST 18394 . 18682)) (18685 26133 (CL:SUBST 18695 . 19189) (%%SUBST 19191
. 20240) (SUBST-IF 20242 . 20587) (%%SUBST-IF 20589 . 21427) (SUBST-IF-NOT 21429 . 21848) (
%%SUBST-IF-NOT 21850 . 22772) (NSUBST 22774 . 22968) (%%NSUBST 22970 . 23875) (NSUBST-IF 23877 . 24034
) (%%NSUBST-IF 24036 . 24986) (NSUBST-IF-NOT 24988 . 25153) (%%NSUBST-IF-NOT 25155 . 26131)) (26134
28799 (CL:SUBLIS 26144 . 26527) (%%SUBLIS 26529 . 27465) (NSUBLIS 27467 . 27661) (%%NSUBLIS 27663 .
28797)) (29391 30884 (CL:MEMBER 29401 . 29695) (%%MEMBER 29697 . 29960) (MEMBER-IF 29962 . 30416) (
MEMBER-IF-NOT 30418 . 30882)) (33408 33867 (ADJOIN 33418 . 33865)) (33868 34896 (CL:UNION 33878 .
34412) (NUNION 34414 . 34894)) (34897 35925 (CL:INTERSECTION 34907 . 35447) (NINTERSECTION 35449 .
35923)) (35926 36845 (SET-DIFFERENCE 35936 . 36354) (NSET-DIFFERENCE 36356 . 36843)) (36846 39158 (
SET-EXCLUSIVE-OR 36856 . 37742) (NSET-EXCLUSIVE-OR 37744 . 39156)) (39159 39407 (SUBSETP 39169 . 39405
)) (39454 41736 (ACONS 39464 . 39827) (PAIRLIS 39829 . 41734)) (41737 45172 (CL:ASSOC 41747 . 41940) (
%%ASSOC 41942 . 42336) (ASSOC-IF 42338 . 42883) (ASSOC-IF-NOT 42885 . 43513) (RASSOC 43515 . 43991) (
RASSOC-IF 43993 . 44539) (RASSOC-IF-NOT 44541 . 45170)) (45209 49283 (CL:MAPCAR 45219 . 45407) (
CL:MAPLIST 45409 . 45873) (CL:MAPC 45875 . 46261) (MAPL 46263 . 46643) (MAPCAN 46645 . 47110) (
CL:MAPCON 47112 . 47578) (%%MAP 47580 . 49281)) (49505 50378 (DELQ 49515 . 50376)))))
STOP