(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