(FILECREATED "29-Jan-86 17:47:53" {ERIS}<LISPCORE>LIBRARY>CMLLIST.;15 28200
changes to: (FNS ENDP MEMBER-IF MEMBER-IF-NOT)
previous date: "24-Jan-86 12:19:34" {ERIS}<LISPCORE>LIBRARY>CMLLIST.;13)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLLISTCOMS)
(RPAQQ CMLLISTCOMS [(* * Various list functions. *)
(MACROS ASSOC-GUTS NSUBLIS-MACRO WITH-SET-KEYS ELEMENTS-MATCH-P
SATISFIES-THE-TEST STEVE-SPLICE)
(COMS (FNS CL:FIRST REST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH
TENTH)
(* macros make SETF work and code optimize too)
(MACROS CL:FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH
REST))
(FNS TREE-EQUAL TREE-EQUAL-TEST-NOT TREE-EQUAL-TEST ENDP LIST-LENGTH CL:NTH
NTHCDR MAKE-LIST COPY-ALIST COPY-TREE REVAPPEND NRECONC BUTLAST NBUTLAST
CL:LDIFF \SETNTH CL:SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF
NSUBST-IF-NOT NSUBLIS MEMBER-IF MEMBER-IF-NOT ADJOIN NUNION NINTERSECTION
SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP
ACONS PAIRLIS CL:ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT
MAP1 CL:MAPC CL:MAPCAR MAPCAN MAPL CL:MAPLIST CL:MAPCON DELQ)
(PROP SETFN NTH)
(FNS)
(P (MOVD (QUOTE ASSOC)
(QUOTE ASSQ))
(MOVD (QUOTE FMEMB)
(QUOTE MEMQ)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA DELQ CL:MAPCON CL:MAPLIST MAPL MAPCAN CL:MAPCAR CL:MAPC
RASSOC CL:ASSOC PAIRLIS SUBSETP NSET-EXCLUSIVE-OR
SET-EXCLUSIVE-OR NSET-DIFFERENCE SET-DIFFERENCE NINTERSECTION
NUNION ADJOIN NSUBLIS NSUBST-IF-NOT NSUBST-IF NSUBST
SUBST-IF-NOT SUBST-IF CL:SUBST NBUTLAST MAKE-LIST TREE-EQUAL
MEMBER-IF-NOT MEMBER-IF])
(* * Various list functions. *)
(DECLARE: EVAL@COMPILE
[DEFMACRO ASSOC-GUTS (TEST-GUY)
(BQUOTE (CL:DO ((ALIST ALIST (CDR ALIST)))
((ENDP ALIST))
(CL:IF (CAR ALIST)
(CL:IF (\, TEST-GUY)
(RETURN (CAR ALIST]
[DEFMACRO NSUBLIS-MACRO NIL (QUOTE (CL:IF NOTP (ASSOC (FUNCALL KEY SUBTREE)
ALIST :TEST-NOT TEST-NOT)
(ASSOC (FUNCALL KEY SUBTREE)
ALIST :TEST TEST]
[DEFMACRO WITH-SET-KEYS (FUNCALL)
(BQUOTE (COND ((AND TESTP NOTP)
(CL:ERROR "Test and test-not both supplied."))
[NOTP (\, (APPEND FUNCALL (QUOTE (:KEY KEY :TEST-NOT TEST-NOT]
(T (\, (APPEND FUNCALL (QUOTE (:KEY KEY :TEST TEST]
[DEFMACRO ELEMENTS-MATCH-P (ELT1 ELT2)
(BQUOTE (OR [AND TESTP (FUNCALL TEST (FUNCALL KEY (\, ELT1))
(FUNCALL KEY (\, ELT2]
[AND NOTP (NOT (FUNCALL TEST-NOT (FUNCALL KEY (\, ELT1))
(FUNCALL KEY (\, ELT2]
(EQL (FUNCALL KEY (\, ELT1))
(FUNCALL KEY (\, ELT2]
[DEFMACRO SATISFIES-THE-TEST (ITEM CL:ELT)
(BQUOTE (OR [AND TESTP (FUNCALL TEST (\, ITEM)
(FUNCALL KEY (\, CL:ELT]
[AND NOTP (NOT (FUNCALL TEST-NOT (\, ITEM)
(FUNCALL KEY (\, CL:ELT]
(FUNCALL TEST (\, ITEM)
(FUNCALL KEY (\, CL:ELT]
[DEFMACRO STEVE-SPLICE (SOURCE DESTINATION)
(BQUOTE (LET ((TEMP (\, SOURCE)))
(SETF (\, SOURCE)
(CDR (\, SOURCE))
(CDR TEMP)
(\, DESTINATION)
(\, DESTINATION)
TEMP]
)
(DEFINEQ
(CL:FIRST
(CL:LAMBDA (LIST) (* lmm
"20-Jan-86 20:58")
(CAR LIST)))
(REST
(CL:LAMBDA (LIST)
(CDR 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])
)
(* macros make SETF work and code optimize too)
(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
(TREE-EQUAL
[CL:LAMBDA (X Y &KEY (TEST (FUNCTION EQL))
TEST-NOT)
"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-NOT
(CL:LAMBDA (X Y TEST-NOT)
(COND
((NOT (FUNCALL TEST-NOT X Y))
T)
((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)))
(T NIL))))
(TREE-EQUAL-TEST
(CL:LAMBDA (X Y TEST)
(COND
((FUNCALL TEST X Y)
T)
((CONSP X)
(AND (CONSP Y)
(TREE-EQUAL-TEST (CAR X)
(CAR Y)
TEST)
(TREE-EQUAL-TEST (CDR X)
(CDR Y)
TEST)))
(T NIL))))
(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)
"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])
(CL:NTH
[CL:LAMBDA (N LIST) (* raf " 5-Dec-85 02:29")
(CAR (NTH LIST (1+ N])
(NTHCDR
(CL:LAMBDA (N LIST)
(NTH LIST (1+ N))))
(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])
(COPY-ALIST
[CL:LAMBDA (ALIST) (* kbr: "31-Aug-85 15:22")
(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)
"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)
"Returns (append (reverse x) y)"
(CL:DO ((TOP X (CDR TOP))
(RESULT Y (CONS (CAR TOP)
RESULT)))
((ENDP TOP)
RESULT))))
(NRECONC
(CL:LAMBDA (X Y) (* kbr: "31-Aug-85 15:19")
(NCONC (NREVERSE X)
Y)))
(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])
(\SETNTH
[CL:LAMBDA (N LIST NEWVAL) (* raf " 5-Dec-85 04: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])
(CL:SUBST
(CL:LAMBDA (NEW OLD TREE &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL)
TESTP)
(TEST-NOT NIL NOTP))
"Substitutes new for subtrees matching old."
(LABELS [(S (SUBTREE)
(COND
((SATISFIES-THE-TEST OLD SUBTREE)
NEW)
((CL:ATOM SUBTREE)
SUBTREE)
(T (LET [(CAR (S (CAR SUBTREE)))
(CDR (S (CDR SUBTREE]
(COND
((AND (EQ CAR (CAR SUBTREE))
(EQ CDR (CDR SUBTREE)))
SUBTREE)
(T (CONS CAR CDR]
(S TREE))))
(SUBST-IF
(CL:LAMBDA (NEW TEST TREE &KEY (KEY (FUNCTION IDENTITY)))
"Substitutes new for subtrees for which test is true."
(LABELS [(S (SUBTREE)
(COND
((FUNCALL TEST (FUNCALL KEY SUBTREE))
NEW)
((CL:ATOM SUBTREE)
SUBTREE)
(T (LET [(CAR (S (CAR SUBTREE)))
(CDR (S (CDR SUBTREE]
(COND
((AND (EQ CAR (CAR SUBTREE))
(EQ CDR (CDR SUBTREE)))
SUBTREE)
(T (CONS CAR CDR]
(S TREE))))
(SUBST-IF-NOT
(CL:LAMBDA (NEW TEST TREE &KEY (KEY (FUNCTION IDENTITY)))
"Substitutes new for subtrees for which test is false."
(LABELS [(S (SUBTREE)
(COND
((NOT (FUNCALL TEST (FUNCALL KEY SUBTREE)))
NEW)
((CL:ATOM SUBTREE)
SUBTREE)
(T (LET [(CAR (S (CAR SUBTREE)))
(CDR (S (CDR SUBTREE]
(COND
((AND (EQ CAR (CAR SUBTREE))
(EQ CDR (CDR SUBTREE)))
SUBTREE)
(T (CONS CAR CDR]
(S TREE))))
(NSUBST
(CL:LAMBDA (NEW OLD TREE &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL)
TESTP)
(TEST-NOT NIL NOTP)) (* raf " 5-Dec-85 04:36")
(LABELS [(S (SUBTREE)
(COND
((SATISFIES-THE-TEST OLD SUBTREE)
NEW)
((CL:ATOM SUBTREE)
SUBTREE)
(T [CL:DO* ((LAST NIL SUBTREE)
(SUBTREE SUBTREE (CDR SUBTREE)))
((CL:ATOM SUBTREE)
(COND
((SATISFIES-THE-TEST OLD SUBTREE)
(SETF (CDR LAST)
NEW))
(T NIL)))
(COND
((SATISFIES-THE-TEST OLD SUBTREE)
(RETURN (SETF (CDR LAST)
NEW)))
(T (SETF (CAR SUBTREE)
(S (CAR SUBTREE]
SUBTREE]
(S TREE))))
(NSUBST-IF
(CL:LAMBDA (NEW TEST TREE &KEY (KEY (FUNCTION IDENTITY)))
(* raf " 5-Dec-85 04:36")
(LABELS [(S (SUBTREE)
(COND
((FUNCALL TEST (FUNCALL KEY SUBTREE))
NEW)
((CL:ATOM SUBTREE)
SUBTREE)
(T [CL:DO* ((LAST NIL SUBTREE)
(SUBTREE SUBTREE (CDR SUBTREE)))
((CL:ATOM SUBTREE)
(COND
((FUNCALL TEST (FUNCALL KEY SUBTREE))
(SETF (CDR LAST)
NEW))
(T NIL)))
(COND
((FUNCALL TEST (FUNCALL KEY SUBTREE))
(RETURN (SETF (CDR LAST)
NEW)))
(T (SETF (CAR SUBTREE)
(S (CAR SUBTREE]
SUBTREE]
(S TREE))))
(NSUBST-IF-NOT
(CL:LAMBDA (NEW TEST TREE &KEY (KEY (FUNCTION IDENTITY)))
(* raf " 5-Dec-85 04:36")
(LABELS [(S (SUBTREE)
(COND
((NOT (FUNCALL TEST (FUNCALL KEY SUBTREE)))
NEW)
((CL:ATOM SUBTREE)
SUBTREE)
(T [CL:DO* ((LAST NIL SUBTREE)
(SUBTREE SUBTREE (CDR SUBTREE)))
((CL:ATOM SUBTREE)
(COND
((NOT (FUNCALL TEST (FUNCALL KEY SUBTREE)))
(SETF (CDR LAST)
NEW))
(T NIL)))
(COND
((NOT (FUNCALL TEST (FUNCALL KEY SUBTREE)))
(RETURN (SETF (CDR LAST)
NEW)))
(T (SETF (CAR SUBTREE)
(S (CAR SUBTREE]
SUBTREE]
(S TREE))))
(NSUBLIS
[CL:LAMBDA (ALIST TREE &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL))
(TEST-NOT NIL NOTP)) (* raf " 5-Dec-85 04:36")
(LET (TEMP)
(LABELS [(S (SUBTREE)
(COND
((SETQ TEMP (NSUBLIS-MACRO))
(CDR TEMP))
((CL:ATOM SUBTREE)
SUBTREE)
(T [CL:DO* ((LAST NIL SUBTREE)
(SUBTREE SUBTREE (CDR SUBTREE)))
((CL:ATOM SUBTREE)
(COND
((SETQ TEMP (NSUBLIS-MACRO))
(SETF (CDR LAST)
(CDR TEMP)))
(T NIL)))
(COND
[(SETQ TEMP (NSUBLIS-MACRO))
(RETURN (SETF (CDR LAST)
(CDR TEMP]
(T (SETF (CAR SUBTREE)
(S (CAR SUBTREE]
SUBTREE]
(S TREE])
(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])
(ADJOIN
[CL:LAMBDA (ITEM LIST &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL))
(TEST-NOT NIL NOTP))
"Add item to list unless it is already a member"
(COND
((COND
(NOTP (CL:MEMBER ITEM LIST :TEST-NOT TEST-NOT :KEY KEY))
(T (CL:MEMBER ITEM LIST :TEST TEST :KEY KEY)))
LIST)
(T (CONS ITEM LIST])
(NUNION
(CL:LAMBDA (LIST1 LIST2 &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL)
TESTP)
(TEST-NOT NIL NOTP))
(COND
((AND TESTP NOTP)
(CL:ERROR "Test and test-not both supplied."))
(T NIL))
(LET ((RES LIST1))
[CL:DO NIL ((ENDP LIST2))
(COND
((NOT (WITH-SET-KEYS (CL:MEMBER (FUNCALL KEY (CAR LIST2))
LIST1)))
(STEVE-SPLICE LIST2 RES))
(T (SETQ LIST2 (CDR LIST2]
RES)))
(NINTERSECTION
(CL:LAMBDA (LIST1 LIST2 &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL)
TESTP)
(TEST-NOT NIL NOTP))
(COND
((AND TESTP NOTP)
(CL:ERROR "Test and test-not both supplied."))
(T NIL))
(LET ((RES NIL))
[CL:DO NIL ((ENDP LIST1))
(COND
((WITH-SET-KEYS (CL:MEMBER (FUNCALL KEY (CAR LIST1))
LIST2))
(STEVE-SPLICE LIST1 RES))
(T (SETQ LIST1 (CDR LIST1]
RES)))
(SET-DIFFERENCE
(CL:LAMBDA (LIST1 LIST2 &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL)
TESTP)
(TEST-NOT NIL NOTP))
(COND
((AND TESTP NOTP)
(CL:ERROR "Test and test-not both supplied."))
(T NIL))
(LET ((RES NIL))
(DOLIST (CL:ELT LIST1)
(COND
((NOT (WITH-SET-KEYS (CL:MEMBER (FUNCALL KEY CL:ELT)
LIST2)))
(PUSH RES CL:ELT))
(T NIL)))
RES)))
(NSET-DIFFERENCE
(CL:LAMBDA (LIST1 LIST2 &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL)
TESTP)
(TEST-NOT NIL NOTP))
(COND
((AND TESTP NOTP)
(CL:ERROR "Test and test-not both supplied."))
(T NIL))
(LET ((RES NIL))
[CL:DO NIL ((ENDP LIST1))
(COND
((NOT (WITH-SET-KEYS (CL:MEMBER (FUNCALL KEY (CAR LIST1))
LIST2)))
(STEVE-SPLICE LIST1 RES))
(T (SETQ LIST1 (CDR LIST1]
RES)))
(SET-EXCLUSIVE-OR
(CL:LAMBDA (LIST1 LIST2 &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL)
TESTP)
(TEST-NOT NIL NOTP))
"Returns new list of elements appearing exactly once in List1 and List2."
(LET ((RESULT NIL))
[DOLIST (CL:ELT LIST1)
(COND
((NOT (WITH-SET-KEYS (CL:MEMBER (FUNCALL KEY CL:ELT)
LIST2)))
(SETQ RESULT (CONS CL:ELT RESULT]
[DOLIST (CL:ELT LIST2)
(COND
((NOT (WITH-SET-KEYS (CL:MEMBER (FUNCALL KEY CL:ELT)
LIST1)))
(SETQ RESULT (CONS CL:ELT RESULT]
RESULT)))
(NSET-EXCLUSIVE-OR
[CL:LAMBDA (LIST1 LIST2 &KEY (TEST (FUNCTION EQL))
(TEST-NOT NIL NOTP)
(KEY (FUNCTION IDENTITY))) (* raf "18-Dec-85 17:38")
(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
[NOTP (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])
(SUBSETP
(CL:LAMBDA (LIST1 LIST2 &KEY (KEY (FUNCTION IDENTITY))
(TEST (FUNCTION EQL)
TESTP)
(TEST-NOT NIL NOTP))
[DOLIST (CL:ELT LIST1)
(COND
((NOT (WITH-SET-KEYS (CL:MEMBER (FUNCALL KEY CL:ELT)
LIST2)))
(RETURN-FROM SUBSETP NIL]
T))
(ACONS
(CL:LAMBDA (KEY DATUM ALIST)
"Construct a new alist by adding the pair (key . datum) to alist"
(CONS (CONS KEY DATUM)
ALIST)))
(PAIRLIS
[CL:LAMBDA (KEYS DATA &OPTIONAL (ALIST (QUOTE NIL)))
"Construct an association list from keys and data (adding to alist)"
(CL:DO ((X KEYS (CDR X))
(Y DATA (CDR Y)))
((AND (ENDP X)
(ENDP Y))
ALIST)
(COND
((OR (ENDP X)
(ENDP Y))
(CL:ERROR "The lists of keys and data are of unequal length."))
(T NIL))
(SETQ ALIST (ACONS (CAR X)
(CAR Y)
ALIST])
(CL:ASSOC
[CL:LAMBDA (ITEM ALIST &KEY TEST TEST-NOT)
"Returns the cons in alist whose car is equal (by a given test or EQL) to
the Item."
(COND
[TEST (ASSOC-GUTS (FUNCALL TEST ITEM (CAAR ALIST]
[TEST-NOT (ASSOC-GUTS (NOT (FUNCALL TEST-NOT ITEM (CAAR ALIST]
(T (ASSOC-GUTS (EQL ITEM (CAAR ALIST])
(ASSOC-IF
[CL:LAMBDA (PREDICATE ALIST)
"Returns the first cons in alist whose car satisfies the Predicate."
(ASSOC-GUTS (FUNCALL PREDICATE (CAAR ALIST])
(ASSOC-IF-NOT
[CL:LAMBDA (PREDICATE ALIST)
"Returns the first cons in alist whose car does not satisfy the Predicate."
(ASSOC-GUTS (NOT (FUNCALL PREDICATE (CAAR ALIST])
(RASSOC
[CL:LAMBDA (ITEM ALIST &KEY TEST TEST-NOT)
(DECLARE (TYPE LIST ALIST)) (* raf " 5-Dec-85 16:30")
(COND
[TEST (ASSOC-GUTS (FUNCALL TEST ITEM (CDAR ALIST]
[TEST-NOT (ASSOC-GUTS (NOT (FUNCALL TEST ITEM (CDAR ALIST]
(T (ASSOC-GUTS (EQL ITEM (CDAR ALIST])
(RASSOC-IF
[CL:LAMBDA (PREDICATE ALIST)
"Returns the first cons in alist whose cdr satisfies the Predicate."
(ASSOC-GUTS (FUNCALL PREDICATE (CDAR ALIST])
(RASSOC-IF-NOT
[CL:LAMBDA (PREDICATE ALIST)
"Returns the first cons in alist whose cdr does not satisfy the Predicate."
(ASSOC-GUTS (NOT (FUNCALL PREDICATE (CDAR ALIST])
(MAP1
[CL:LAMBDA (FUNCTION ORIGINAL-ARGLISTS ACCUMULATE TAKE-CAR)
"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])
(CL:MAPC
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS)
"Applies fn to successive elements of lists, returns ()."
(MAP1 FUNCTION (CONS LIST MORE-LISTS)
NIL T)))
(CL:MAPCAR
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS) (* raf "18-Dec-85 17:28")
(MAP1 FUNCTION (CONS LIST MORE-LISTS)
:LIST T)))
(MAPCAN
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS)
"Applies fn to successive elements of list, returns NCONC of results."
(MAP1 FUNCTION (CONS LIST MORE-LISTS)
:NCONC T)))
(MAPL
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS)
"Applies fn to successive CDRs of list, returns ()."
(MAP1 FUNCTION (CONS LIST MORE-LISTS)
NIL NIL)))
(CL:MAPLIST
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS)
"Applies fn to successive CDRs of list, returns list of results."
(MAP1 FUNCTION (CONS LIST MORE-LISTS)
:LIST NIL)))
(CL:MAPCON
(CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS)
"Applies fn to successive CDRs of lists, returns NCONC of results."
(MAP1 FUNCTION (CONS LIST MORE-LISTS)
:NCONC NIL)))
(DELQ
[CL:LAMBDA (ITEM LIST &OPTIONAL (N 0 NP)) (* raf " 5-Dec-85 04:35")
(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])
)
(PUTPROPS NTH SETFN \SETNTH)
(MOVD (QUOTE ASSOC)
(QUOTE ASSQ))
(MOVD (QUOTE FMEMB)
(QUOTE MEMQ))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA DELQ CL:MAPCON CL:MAPLIST MAPL MAPCAN CL:MAPCAR CL:MAPC RASSOC CL:ASSOC PAIRLIS
SUBSETP NSET-EXCLUSIVE-OR SET-EXCLUSIVE-OR NSET-DIFFERENCE SET-DIFFERENCE
NINTERSECTION NUNION ADJOIN NSUBLIS NSUBST-IF-NOT NSUBST-IF NSUBST SUBST-IF-NOT
SUBST-IF CL:SUBST NBUTLAST MAKE-LIST TREE-EQUAL MEMBER-IF-NOT MEMBER-IF)
)
(PUTPROPS CMLLIST COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4525 5430 (CL:FIRST 4535 . 4738) (REST 4740 . 4782) (SECOND 4784 . 4986) (THIRD 4988 .
5033) (FOURTH 5035 . 5082) (FIFTH 5084 . 5136) (SIXTH 5138 . 5191) (SEVENTH 5193 . 5249) (EIGHTH 5251
. 5307) (NINTH 5309 . 5367) (TENTH 5369 . 5428)) (6264 27519 (TREE-EQUAL 6274 . 6532) (
TREE-EQUAL-TEST-NOT 6534 . 6886) (TREE-EQUAL-TEST 6888 . 7186) (ENDP 7188 . 7493) (LIST-LENGTH 7495 .
7929) (CL:NTH 7931 . 8072) (NTHCDR 8074 . 8139) (MAKE-LIST 8141 . 8570) (COPY-ALIST 8572 . 9474) (
COPY-TREE 9476 . 9710) (REVAPPEND 9712 . 9910) (NRECONC 9912 . 10059) (BUTLAST 10061 . 10716) (
NBUTLAST 10718 . 11273) (CL:LDIFF 11275 . 11636) (\SETNTH 11638 . 12216) (CL:SUBST 12218 . 12816) (
SUBST-IF 12818 . 13376) (SUBST-IF-NOT 13378 . 13951) (NSUBST 13953 . 14730) (NSUBST-IF 14732 . 15525)
(NSUBST-IF-NOT 15527 . 16354) (NSUBLIS 16356 . 17192) (MEMBER-IF 17194 . 17669) (MEMBER-IF-NOT 17671
. 18153) (ADJOIN 18155 . 18522) (NUNION 18524 . 19031) (NINTERSECTION 19033 . 19535) (SET-DIFFERENCE
19537 . 20015) (NSET-DIFFERENCE 20017 . 20531) (SET-EXCLUSIVE-OR 20533 . 21183) (NSET-EXCLUSIVE-OR
21185 . 22173) (SUBSETP 22175 . 22489) (ACONS 22491 . 22651) (PAIRLIS 22653 . 23143) (CL:ASSOC 23145
. 23507) (ASSOC-IF 23509 . 23687) (ASSOC-IF-NOT 23689 . 23887) (RASSOC 23889 . 24246) (RASSOC-IF
24248 . 24427) (RASSOC-IF-NOT 24429 . 24628) (MAP1 24630 . 25775) (CL:MAPC 25777 . 25965) (CL:MAPCAR
25967 . 26140) (MAPCAN 26142 . 26345) (MAPL 26347 . 26529) (CL:MAPLIST 26531 . 26734) (CL:MAPCON 26736
. 26941) (DELQ 26943 . 27517)))))
STOP