(FILECREATED "17-Sep-86 17:07:36" {ERIS}<LISPCORE>LIBRARY>CMLLIST.;32
 61639  

      changes to:  (FNS CL:APPEND %%APPEND)
                   (VARS CMLLISTCOMS)

      previous date: " 5-Sep-86 17:35:48" {ERIS}<LISPCORE>LIBRARY>CMLLIST.;31)


(* 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))
              (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)
              (* Common Lisp APPEND is different from Interlisp APPEND because Interlisp APPEND 
                 copies its last arg while Common Lisp APPEND does not. See page 268 of the silver 
                 book. *)
              (FNS CL:APPEND %%APPEND)
              (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))))
        (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 
                            CL:APPEND 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)
(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)))))))
)



(* Common Lisp APPEND is different from Interlisp APPEND because Interlisp APPEND copies its 
last arg while Common Lisp APPEND does not. See page 268 of the silver book. *)


(DEFINEQ

(CL:APPEND

  [LAMBDA L
                                                  (* kbr: "17-Sep-86 17:05")

          
          (* The result is a list that is the concatenation of the arguments.

          The arguments are not destroyed. Note that APPEND copies the top-level list 

          structure of each of its arguments except the last.

          *)


    (PROG (VAL N)
          (COND
             ((EQ L 0)
              (RETURN NIL))
             ((EQ L 1)
              (RETURN (ARG L 1))))
          (SETQ VAL (ARG L L))
          (for
 N from
 (SUB1 L) to
 1 by
 -1 do
 (SETQ VAL (%%APPEND
 (ARG L N)
                                                              VAL)))
          (RETURN VAL])

(%%APPEND

  [LAMBDA (L1 L2)
                                            (* kbr: "17-Sep-86 17:03")

    (PROG (ANSWER TAIL)
          (COND
             ((ENDP
 L1)
              (RETURN L2)))
          (SETQ ANSWER (LIST (pop
 L1)))
          (SETQ TAIL ANSWER)
      LOOP
          (COND
             ((ENDP
 L1)
              (SETF (CDR TAIL)
                    L2)
              (RETURN ANSWER)))
          (SETF (CDR TAIL)
                (LIST (pop
 L1)))
          (SETQ TAIL (CDR TAIL))
          (GO LOOP])
)
(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: "27-Aug-86 13:36")

                                                             (* 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)))
               (COND
                  ((%%TEST
 OLD (CAR TAIL)
                          TEST TEST-NOT KEY)
                   (SETF (CAR TAIL)
                         NEW))
                  (T (%%NSUBST
 NEW OLD (CAR TAIL)
                            TEST TEST-NOT KEY)))
               (COND
                  ((%%TEST
 OLD (CDR TAIL)
                          TEST TEST-NOT KEY)
                   (SETF (CDR TAIL)
                         NEW)
                   (RETURN TREE)))
               (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: "27-Aug-86 13:08")

                                                             (* Substitutes from alist into tree 

                                                             nondestructively. *)

         (LET ((BUCKET (%%ASSOC
 (FUNCALL KEY TREE)
                              ALIST TEST TEST-NOT (CL:FUNCTION IDENTITY))))
              (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: "27-Aug-86 13:08")

         (PROG (BUCKET)
               (COND
                  ((SETQ BUCKET (%%ASSOC
 (FUNCALL KEY TREE)
                                       ALIST TEST TEST-NOT (CL:FUNCTION IDENTITY)))
                   (RETURN (CDR BUCKET)))
                  ((CL:ATOM TREE)
                   (RETURN TREE)))
               (CL:DO* ((LAST NIL TREE)
                        (TREE TREE (CDR TREE)))
                      ((CL:ATOM TREE)
                       (COND
                          ((SETQ BUCKET (%%ASSOC
 (FUNCALL KEY TREE)
                                               ALIST TEST TEST-NOT (CL:FUNCTION IDENTITY)))
                           (SETF (CDR LAST)
                                 (CDR BUCKET)))
                          (T NIL)))
                      (COND
                         ((SETQ BUCKET (%%ASSOC
 (FUNCALL KEY TREE)
                                              ALIST TEST TEST-NOT (CL:FUNCTION IDENTITY)))
                          (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: "27-Aug-86 18:38")

                                                             (* Returns the union of LIST1 and 

                                                             LIST2 *)

         (TEST-KEYS-SUPPLIED)
         (LET ((RES LIST1))
              (DOLIST (ELEMENT LIST2)
                     (CL:IF (NOT (%%MEMBER
 (FUNCALL KEY ELEMENT)
                                        LIST1 TEST TEST-NOT KEY))
                            (CL:PUSH ELEMENT RES)))
              RES)))

(NUNION

  (CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY)
            (* kbr: "27-Aug-86 18:39")

         (TEST-KEYS-SUPPLIED)
         (LET ((RES LIST1))
              (CL:DO NIL ((ENDP
 LIST2))
                     (COND
                        ((NOT (%%MEMBER
 (FUNCALL KEY (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: "27-Aug-86 18:39")

                                                             (* Returns the intersection of LIST1 

                                                             and LIST2 *)

         (TEST-KEYS-SUPPLIED)
         (LET ((RES NIL))
              (DOLIST (ELEMENT LIST1)
                     (CL:IF (%%MEMBER
 (FUNCALL KEY ELEMENT)
                                   LIST2 TEST TEST-NOT KEY)
                            (CL:PUSH ELEMENT RES)))
              RES)))

(NINTERSECTION

  (CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY)
            (* kbr: "27-Aug-86 18:39")

         (TEST-KEYS-SUPPLIED)
         (LET ((RES NIL))
              (CL:DO NIL ((ENDP
 LIST1))
                     (COND
                        ((%%MEMBER
 (FUNCALL KEY (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: "27-Aug-86 18:40")

         (TEST-KEYS-SUPPLIED)
         (LET ((RES NIL))
              (DOLIST (ELEMENT LIST1)
                     (COND
                        ((NOT (%%MEMBER
 (FUNCALL KEY ELEMENT)
                                     LIST2 TEST TEST-NOT KEY))
                         (CL:PUSH ELEMENT RES))
                        (T NIL)))
              RES)))

(NSET-DIFFERENCE

  (CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY)
            (* kbr: "27-Aug-86 18:41")

         (TEST-KEYS-SUPPLIED)
         (LET ((RES NIL))
              (CL:DO NIL ((ENDP
 LIST1))
                     (COND
                        ((NOT (%%MEMBER
 (FUNCALL KEY (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: "27-Aug-86 18:41")

                                                             (* Returns new list of elements 

                                                             appearing exactly once in LIST1 and 

                                                             LIST2 *)

         (TEST-KEYS-SUPPLIED)
         (LET ((RESULT NIL))
              (DOLIST (ELEMENT LIST1)
                     (COND
                        ((NOT (%%MEMBER
 (FUNCALL KEY ELEMENT)
                                     LIST2 TEST TEST-NOT KEY))
                         (SETQ RESULT (CONS ELEMENT RESULT)))))
              (DOLIST (ELEMENT LIST2)
                     (COND
                        ((NOT (%%MEMBER
 (FUNCALL KEY ELEMENT)
                                     LIST1 TEST TEST-NOT KEY))
                         (SETQ RESULT (CONS ELEMENT RESULT)))))
              RESULT)))

(NSET-EXCLUSIVE-OR

  (CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY)
            (* kbr: "31-Aug-86 21:05")

         (TEST-KEYS-SUPPLIED)
         (PROG (MATCHED KEYX KEYY SPLICEX SPLICEY)
          
          (* Each element that LIST1 and LIST2 have in common are cut out of LIST1 and 

          LIST2. Then what is left of LIST1 and LIST2 is NCONCed together to form the 

          ANSWER. SPLICEX and SPLICEY are the cells if any just preceding tails X and Y 

          on LIST1 and LIST2. *)

          
          (* No attempt is made to setify the answer if LIST1 and LIST2 contain 

          duplicates, but this algorithm can guarantee that the answer will not have 

          duplicates if LIST1 and LIST2 do not. *)


               (for X on LIST1 do (SETQ MATCHED NIL)
                    (SETQ KEYX (FUNCALL KEY (CAR X)))
                    (SETQ SPLICEY NIL)
                    (for Y on LIST2 do (SETQ KEYY (FUNCALL KEY (CAR Y)))
                         (COND
                            ((COND
                                (TEST-NOT (NOT (FUNCALL TEST-NOT KEYX KEYY)))
                                (T (FUNCALL TEST KEYX KEYY)))(* (CAR X) matches (CAR Y) Splice

                                                             (CAR Y) out of LIST2.

                                                             *)

                             (SETQ MATCHED T)
                             (RPLACD X (CL:DELETE KEYX (CDR X)
                                              :TEST TEST :TEST-NOT TEST-NOT :KEY KEY))
                             (RPLACD Y (CL:DELETE KEYX (CDR Y)
                                              :TEST TEST :TEST-NOT TEST-NOT :KEY KEY))
                             (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)))                      (* No match, so advance SPLICEY 

                                                             pointer to next cell of LIST2.

                                                             *)

                         (SETQ SPLICEY Y))
                    (COND
                       ((NOT MATCHED)                        (* No match, so advance SPLICEX 

                                                             pointer to next cell of LIST1.

                                                             *)

                        (SETQ SPLICEX X))))                  (* NCONC remainder of LIST1 and 

                                                             remainders of LIST2 to form answer.

                                                             *)

               (COND
                  ((NULL SPLICEX)
                   (SETQ LIST1 LIST2))
                  (T (RPLACD SPLICEX LIST2)))
               (RETURN LIST1))))
)
(DEFINEQ

(SUBSETP

  (CL:LAMBDA (LIST1 LIST2 &KEY TEST TEST-NOT KEY)
            (* kbr: "27-Aug-86 18:42")

         (TEST-KEYS-SUPPLIED)
         (for ELEMENT in LIST1 always (%%MEMBER
 (FUNCALL KEY ELEMENT)
                                             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))
(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 CL:APPEND 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))
              (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)
              (* Common Lisp APPEND is different from Interlisp APPEND because Interlisp APPEND 
                 copies its last arg while Common Lisp APPEND does not. See page 268 of the silver 
                 book. *)
              (FNS CL:APPEND %%APPEND)
              (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))))
        (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 
                            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 CL:APPEND MAKE-LIST 
                            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 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 CL:APPEND MAKE-LIST TREE-EQUAL)
)
(PUTPROPS CMLLIST COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (5144 6726 (TREE-EQUAL 5154 . 5708) (%%TREE-EQUAL-TEST 5710 . 6201) (
%%TREE-EQUAL-TEST-NOT 6203 . 6724)) (6761 7827 (ENDP 6771 . 7001) (LIST-LENGTH 7003 . 7825)) (7828 
8811 (CL:NTH 7838 . 7982) (%%SETNTH 7984 . 8809)) (8850 9696 (CL:FIRST 8860 . 8990) (SECOND 8992 . 
9121) (THIRD 9123 . 9177) (FOURTH 9179 . 9235) (FIFTH 9237 . 9298) (SIXTH 9300 . 9362) (SEVENTH 9364
 . 9429) (EIGHTH 9431 . 9496) (NINTH 9498 . 9568) (TENTH 9570 . 9641) (REST 9643 . 9694)) (10556 11141
 (NTHCDR 10566 . 11139)) (11180 11727 (MAKE-LIST 11190 . 11725)) (11910 13206 (CL:APPEND 11920 . 12664
) (%%APPEND 12666 . 13204)) (13207 16157 (COPY-LIST 13217 . 13752) (COPY-ALIST 13754 . 15291) (
COPY-TREE 15293 . 15760) (REVAPPEND 15762 . 16155)) (16185 16355 (NRECONC 16195 . 16353)) (16466 18400
 (BUTLAST 16476 . 17284) (NBUTLAST 17286 . 17997) (CL:LDIFF 17999 . 18398)) (19655 19955 (%%TEST 19665
 . 19953)) (19956 27627 (CL:SUBST 19966 . 20460) (%%SUBST 20462 . 21507) (SUBST-IF 21509 . 21854) (
%%SUBST-IF 21856 . 22690) (SUBST-IF-NOT 22692 . 23111) (%%SUBST-IF-NOT 23113 . 24031) (NSUBST 24033 . 
24227) (%%NSUBST 24229 . 25369) (NSUBST-IF 25371 . 25528) (%%NSUBST-IF 25530 . 26480) (NSUBST-IF-NOT 
26482 . 26647) (%%NSUBST-IF-NOT 26649 . 27625)) (27628 30579 (CL:SUBLIS 27638 . 28021) (%%SUBLIS 28023
 . 29014) (NSUBLIS 29016 . 29210) (%%NSUBLIS 29212 . 30577)) (31167 32684 (CL:MEMBER 31177 . 31483) (
%%MEMBER 31485 . 31760) (MEMBER-IF 31762 . 32216) (MEMBER-IF-NOT 32218 . 32682)) (35196 35655 (ADJOIN 
35206 . 35653)) (35656 36747 (CL:UNION 35666 . 36253) (NUNION 36255 . 36745)) (36748 37834 (
CL:INTERSECTION 36758 . 37346) (NINTERSECTION 37348 . 37832)) (37835 38814 (SET-DIFFERENCE 37845 . 
38313) (NSET-DIFFERENCE 38315 . 38812)) (38815 42980 (SET-EXCLUSIVE-OR 38825 . 39815) (
NSET-EXCLUSIVE-OR 39817 . 42978)) (42981 43278 (SUBSETP 42991 . 43276)) (43325 45607 (ACONS 43335 . 
43698) (PAIRLIS 43700 . 45605)) (45608 49039 (CL:ASSOC 45618 . 45811) (%%ASSOC 45813 . 46207) (
ASSOC-IF 46209 . 46754) (ASSOC-IF-NOT 46756 . 47384) (RASSOC 47386 . 47858) (RASSOC-IF 47860 . 48406) 
(RASSOC-IF-NOT 48408 . 49037)) (49077 53147 (CL:MAPCAR 49087 . 49275) (CL:MAPLIST 49277 . 49741) (
CL:MAPC 49743 . 50129) (MAPL 50131 . 50511) (MAPCAN 50513 . 50978) (CL:MAPCON 50980 . 51446) (%%MAP 
51448 . 53145)) (53369 54238 (DELQ 53379 . 54236)))))
STOP