(FILECREATED " 2-Jul-86 18:02:17" {ERIS}<LISPCORE>LIBRARY>CMLSEQBASICS.;1
 18909  

      changes to:  (VARS CMLSEQBASICSCOMS)
                   (PROPS (CMLSEQBASICS FILETYPE)))


(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT CMLSEQBASICSCOMS)

(RPAQQ CMLSEQBASICSCOMS
 ((DECLARE: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON))
                         (FUNCTIONS CHECK-SUBSEQ MAKE-SEQUENCE-OF-TYPE)
                         (COMS (FUNCTIONS CL:ELT %%SETELT)
                               (SETFS CL:ELT))
                         (COMS (FUNCTIONS SUBSEQ LIST-SUBSEQ* VECTOR-SUBSEQ*)
                               (SETFS SUBSEQ))
                         (FUNCTIONS COPY-SEQ LIST-COPY-SEQ LIST-COPY-SEQ* VECTOR-COPY-SEQ 
                                VECTOR-COPY-SEQ*)
                         (FUNCTIONS CL:LENGTH)
                         (FUNCTIONS CL:REVERSE LIST-REVERSE-MACRO VECTOR-REVERSE VECTOR-REVERSE*)
                         (FUNCTIONS CL:NREVERSE LIST-NREVERSE-MACRO LIST-NREVERSE* VECTOR-NREVERSE 
                                VECTOR-NREVERSE*)
                         (FUNCTIONS MAKE-SEQUENCE)
                         (FUNCTIONS CONCATENATE CONCATENATE-TO-LIST CONCAT-TO-LIST* CONCAT-TO-SIMPLE*
                                )
                         (PROPS (CMLSEQBASICS FILETYPE))))
(DECLARE: EVAL@COMPILE DONTCOPY 
(FILESLOAD CMLSEQCOMMON)
)
(DEFUN CHECK-SUBSEQ
 (SEQ START END LENGTH) (COND
                                              ((CL:ZEROP LENGTH))
                                              ((OR (< START 0)
                                                   (>= START LENGTH))
                                               (CL:ERROR "Index out of range: ~D." START))
                                              ((OR (< END 0)
                                                   (> END LENGTH))
                                               (CL:ERROR "Index out of range: ~D." END))
                                              ((< END START)
                                               (CL:ERROR 
                                 "Illegal subsequence:~&START (~D) may not be greater than END (~D)." 
                                                      START END))))

(DEFUN MAKE-SEQUENCE-OF-TYPE
 (TYPE LENGTH) 
                  (* raf "27-Jan-86 17:30")

   (CASE (TYPE-SPECIFIER TYPE)
         (LIST (MAKE-LIST LENGTH))
         ((BIT-VECTOR SIMPLE-BIT-VECTOR)
          (MAKE-ARRAY LENGTH :ELEMENT-TYPE (QUOTE BIT)))
         ((STRING SIMPLE-STRING)
          (MAKE-STRING LENGTH))
         (SIMPLE-VECTOR (MAKE-ARRAY LENGTH))
         ((ARRAY SIMPLE-ARRAY VECTOR)
          (CL:IF (CL:LISTP TYPE)
                 (MAKE-ARRAY LENGTH :ELEMENT-TYPE (CADR TYPE))
                 (MAKE-ARRAY LENGTH)))
         (T (CL:ERROR "~S is a bad type specifier for sequence functions." TYPE))))

(DEFUN CL:ELT
 (SEQUENCE INDEX) 
                              (* amd " 5-Jun-86 17:48")

   (CL:WHEN (< INDEX 0)
          (CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
                 :NAME SEQUENCE :INDEX INDEX))
   (SEQ-DISPATCH SEQUENCE (CL:DO ((COUNT
 INDEX (1- COUNT)))
                                 ((= COUNT 0)
                                  (CL:IF (ENDP SEQUENCE)
                                         (CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
                                                :NAME SEQUENCE :INDEX INDEX)
                                         (CAR SEQUENCE)))
                                 (CL:IF (ENDP SEQUENCE)
                                        (CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
                                               :NAME SEQUENCE :INDEX INDEX)
                                        (CL:POP SEQUENCE)))
          (CL:IF (>= INDEX (CL:LENGTH (THE VECTOR SEQUENCE)))
                 (CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
                        :NAME SEQUENCE :INDEX INDEX)
                 (AREF SEQUENCE INDEX))))

(DEFUN %%SETELT
 (SEQUENCE INDEX NEWVAL) 
                     (* raf "27-Jan-86 17:30")

   (CL:WHEN (< INDEX 0)
          (CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
                 :NAME SEQUENCE :INDEX INDEX))
   (SEQ-DISPATCH SEQUENCE (CL:DO ((COUNT
 INDEX (1- COUNT))
                                  (SEQ SEQUENCE))
                                 ((= COUNT 0)
                                  (CL:IF (ENDP SEQ)
                                         (CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
                                                :NAME SEQUENCE :INDEX INDEX)
                                         (RPLACA SEQ NEWVAL))
                                  NEWVAL)
                                 (CL:IF (ENDP (CDR SEQ))
                                        (CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
                                               :NAME SEQUENCE :INDEX INDEX)
                                        (CL:POP SEQ)))
          (CL:IF (>= INDEX (CL:LENGTH (THE VECTOR SEQUENCE)))
                 (CL:ERROR (QUOTE INDEX-BOUNDS-ERROR)
                        :NAME SEQUENCE :INDEX INDEX)
                 (SETF (AREF SEQUENCE INDEX)
                       NEWVAL))))

(DEFSETF CL:ELT
 %%SETELT)

(DEFUN SUBSEQ
 (SEQUENCE START &OPTIONAL END) 
                (* amd " 2-May-86 13:41")

   (CL:IF (< START 0)
          (CL:ERROR "Index out of range: ~D." START)
          (SEQ-DISPATCH SEQUENCE (LIST-SUBSEQ* SEQUENCE START END)
                 (VECTOR-SUBSEQ* SEQUENCE START END))))

(DEFUN LIST-SUBSEQ*
 (SEQUENCE START END)
   (DECLARE
 (TYPE LIST SEQUENCE))
                            (* amd " 2-May-86 13:40")

   (COND
      ((AND END (> START END))
       (CL:ERROR "Illegal subsequence:~&START (~D) may not be greater than END (~D)." START END))
      ((NULL SEQUENCE)
       NIL)
      ((AND END (= START END))
       (CL:IF (>= START (CL:LENGTH SEQUENCE))
              (CL:ERROR "Index out of range: ~D." START)
              (RETURN-FROM LIST-SUBSEQ* NIL)))
      (T (LET* ((GROVELED (NTHCDR START SEQUENCE))
                (RESULT (LIST (CAR GROVELED))))
               (CL:IF GROVELED (CL:DO ((LIST (CDR GROVELED)
                                             (CDR LIST))
                                       (SPLICE RESULT (CDR (RPLACD SPLICE (LIST (CAR LIST)))))
                                       (INDEX (1+ START)
                                              (1+ INDEX)))
                                      ((OR (ENDP LIST)
                                           (AND END (>= INDEX END)))
                                       (CL:IF (OR (NULL END)
                                                  (= INDEX END))
                                              RESULT
                                              (CL:ERROR "Index out of range: ~D." END))))
                      (CL:ERROR "Index out of range: ~D." START))))))

(DEFUN VECTOR-SUBSEQ*
 (SEQUENCE START END &AUX (LENGTH (CL:LENGTH SEQUENCE)))
   (DECLARE
 (TYPE VECTOR SEQUENCE))
                          (* amd " 2-May-86 13:40")

   (CL:UNLESS END (SETQ END LENGTH))
   (COND
      ((< END START)
       (CL:ERROR "Illegal subsequence:~&START (~D) may not be greater than END (~D)." START END))
      ((CL:ZEROP LENGTH)
       (COPY-SEQ SEQUENCE))
      ((>= START LENGTH)
       (CL:ERROR "Index out of range: ~D." START))
      (T (CL:DO ((OLD-INDEX START (1+ OLD-INDEX))
                 (NEW-INDEX 0 (1+ NEW-INDEX))
                 (COPY (MAKE-SEQUENCE-LIKE SEQUENCE (- END START))))
                ((>= OLD-INDEX END)
                 COPY)
                (SETF (AREF COPY NEW-INDEX)
                      (AREF SEQUENCE OLD-INDEX))))))

(DEFSETF SUBSEQ
 (SEQUENCE START &OPTIONAL END) (NEW-SEQUENCE)
                                               (BQUOTE (PROGN (CL:REPLACE (\, SEQUENCE)
                                                                     (\, NEW-SEQUENCE)
                                                                     :START1
                                                                     (\, START)
                                                                     :END1
                                                                     (\, END))
                                                              (\, NEW-SEQUENCE))))

(DEFUN COPY-SEQ
 (SEQUENCE) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ."
   (SEQ-DISPATCH SEQUENCE (LIST-COPY-SEQ* SEQUENCE)
          (VECTOR-COPY-SEQ* SEQUENCE)))

(DEFMACRO LIST-COPY-SEQ
 (LIST) (BQUOTE (APPEND (\, LIST))))

(DEFUN LIST-COPY-SEQ*
 (SEQUENCE) (LIST-COPY-SEQ SEQUENCE))

(DEFMACRO VECTOR-COPY-SEQ
 (SEQUENCE TYPE) (BQUOTE (LET ((LENGTH (CL:LENGTH (THE VECTOR (\, SEQUENCE))
                                                                       )))
                                                       (CL:DO ((INDEX 0 (1+ INDEX))
                                                               (COPY (MAKE-SEQUENCE-OF-TYPE
                                                                      (\, TYPE)
                                                                      LENGTH)))
                                                              ((= INDEX LENGTH)
                                                               COPY)
                                                              (SETF (AREF COPY INDEX)
                                                                    (AREF (\, SEQUENCE)
                                                                          INDEX))))))

(DEFUN VECTOR-COPY-SEQ*
 (SEQUENCE) (VECTOR-COPY-SEQ SEQUENCE (TYPE-OF SEQUENCE)))

(DEFUN CL:LENGTH
 (SEQUENCE) 
                                 (* lmm "25-Feb-86 13:06")

   (SEQ-DISPATCH SEQUENCE (LENGTH SEQUENCE)
          (CL:IF (ARRAY-HAS-FILL-POINTER-P (THE VECTOR SEQUENCE))
                 (FILL-POINTER SEQUENCE)
                 (CAR (ARRAY-DIMENSIONS SEQUENCE)))))

(DEFUN CL:REVERSE
 (SEQUENCE) 
                          "Returns a new sequence containing the same elements but in reverse order."
   (SEQ-DISPATCH SEQUENCE (REVERSE SEQUENCE)
          (VECTOR-REVERSE* SEQUENCE)))

(DEFMACRO LIST-REVERSE-MACRO
 (SEQUENCE) (BQUOTE (CL:DO ((NEW-LIST NIL))
                                                       ((ENDP (\, SEQUENCE))
                                                        NEW-LIST)
                                                       (CL:PUSH (CL:POP (\, SEQUENCE))
                                                              NEW-LIST))))

(DEFMACRO VECTOR-REVERSE
 (SEQUENCE TYPE) (BQUOTE (LET ((LENGTH (CL:LENGTH (\, SEQUENCE))))
                                                      (CL:DO ((FORWARD-INDEX 0 (1+ FORWARD-INDEX))
                                                              (BACKWARD-INDEX (1- LENGTH)
                                                                     (1- BACKWARD-INDEX))
                                                              (NEW-SEQUENCE (MAKE-SEQUENCE-OF-TYPE
                                                                             (\, TYPE)
                                                                             LENGTH)))
                                                             ((= FORWARD-INDEX LENGTH)
                                                              NEW-SEQUENCE)
                                                             (SETF (AREF NEW-SEQUENCE FORWARD-INDEX)
                                                                   (AREF (\, SEQUENCE)
                                                                         BACKWARD-INDEX))))))

(DEFUN VECTOR-REVERSE*
 (SEQUENCE) 
                           (* raf "18-Dec-85 00:07")

   (VECTOR-REVERSE SEQUENCE (TYPE-OF SEQUENCE)))

(DEFUN CL:NREVERSE
 (SEQUENCE) 
              "Returns a sequence of the same elements in reverse order (the argument is destroyed)."
   
                                                          (* kbr: "31-Aug-85 17:57")

   (SEQ-DISPATCH SEQUENCE (DREVERSE SEQUENCE)
          (VECTOR-NREVERSE* SEQUENCE)))

(DEFMACRO LIST-NREVERSE-MACRO
 (LIST) (BQUOTE (CL:DO ((1ST (CDR (\, LIST))
                                                          (COND
                                                             ((ENDP 1ST)
                                                              1ST)
                                                             (T (CDR 1ST))))
                                                     (2ND (\, LIST)
                                                          1ST)
                                                     (3RD (QUOTE NIL)
                                                          2ND))
                                                    ((ENDP 2ND)
                                                     3RD)
                                                    (RPLACD 2ND 3RD))))

(DEFUN LIST-NREVERSE*
 (SEQUENCE) (LIST-NREVERSE-MACRO SEQUENCE))

(DEFMACRO VECTOR-NREVERSE
 (SEQUENCE) (BQUOTE (LET ((LENGTH (CL:LENGTH (THE VECTOR (\, SEQUENCE)))))
                                                  (CL:DO ((LEFT-INDEX 0 (1+ LEFT-INDEX))
                                                          (RIGHT-INDEX (1- LENGTH)
                                                                 (1- RIGHT-INDEX))
                                                          (HALF-LENGTH (IQUOTIENT LENGTH 2)))
                                                         ((= LEFT-INDEX HALF-LENGTH)
                                                          (\, SEQUENCE))
                                                         (ROTATEF (AREF (\, SEQUENCE)
                                                                        LEFT-INDEX)
                                                                (AREF (\, SEQUENCE)
                                                                      RIGHT-INDEX))))))

(DEFUN VECTOR-NREVERSE*
 (SEQUENCE) (VECTOR-NREVERSE SEQUENCE))

(DEFUN MAKE-SEQUENCE
 (TYPE LENGTH &KEY INITIAL-ELEMENT) 
     (* raf "27-Jan-86 17:30")

   (CASE (TYPE-SPECIFIER TYPE)
         (LIST (MAKE-LIST LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT))
         ((SIMPLE-STRING STRING)
          (LET ((STRING (MAKE-STRING LENGTH)))
               (CL:WHEN INITIAL-ELEMENT (CL:DO ((INDEX 0 (1+ INDEX)))
                                               ((= INDEX LENGTH)
                                                STRING)
                                               (SETF (CHAR (THE SIMPLE-STRING STRING)
                                                           INDEX)
                                                     INITIAL-ELEMENT)))
               STRING))
         (SIMPLE-VECTOR (MAKE-ARRAY LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT))
         ((ARRAY VECTOR SIMPLE-ARRAY)
          (CL:IF (CL:LISTP TYPE)
                 (MAKE-ARRAY LENGTH :ELEMENT-TYPE (CADR TYPE)
                        :INITIAL-ELEMENT INITIAL-ELEMENT)
                 (MAKE-ARRAY LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT)))
         ((BIT-VECTOR SIMPLE-BIT-VECTOR)
          (MAKE-ARRAY LENGTH :ELEMENT-TYPE (QUOTE (MOD 2))
                 :INITIAL-ELEMENT INITIAL-ELEMENT))
         (T (CL:ERROR "~S is a bad type specifier for sequences." TYPE))))

(DEFUN CONCATENATE
 (RESULT-TYPE &REST SEQUENCES) 
            (* kbr: "31-Aug-85 19:50")

                                                             (* 

                                                    "This should be (subtypep result-type 'sequence)")

   (CASE (TYPE-SPECIFIER RESULT-TYPE)
         (LIST (CL:APPLY (FUNCTION CONCAT-TO-LIST*)
                      SEQUENCES))
         ((SIMPLE-VECTOR SIMPLE-STRING VECTOR STRING ARRAY SIMPLE-ARRAY BIT-VECTOR SIMPLE-BIT-VECTOR)
          (CL:APPLY (FUNCTION CONCAT-TO-SIMPLE*)
                 RESULT-TYPE SEQUENCES))
         (T (CL:ERROR "~S: invalid output type specification." RESULT-TYPE))))

(DEFMACRO CONCATENATE-TO-LIST
 (SEQUENCES)
   (BQUOTE (LET ((RESULT (LIST NIL)))
                (CL:DO ((SEQUENCES (\, SEQUENCES)
                               (CDR SEQUENCES))
                        (SPLICE RESULT))
                       ((NULL SEQUENCES)
                        (CDR RESULT))
                       (LET ((SEQUENCE (CAR SEQUENCES)))
                            (SEQ-DISPATCH SEQUENCE (CL:DO ((SEQUENCE SEQUENCE (CDR SEQUENCE)))
                                                          ((ENDP SEQUENCE))
                                                          (SETQ SPLICE
                                                           (CDR (RPLACD SPLICE (CONS (CAR SEQUENCE)
                                                                                     NIL)))))
                                   (CL:DO ((INDEX 0 (1+ INDEX))
                                           (LENGTH (CL:LENGTH SEQUENCE)))
                                          ((= INDEX LENGTH))
                                          (SETQ SPLICE (CDR (RPLACD SPLICE (CONS (AREF SEQUENCE INDEX
                                                                                       )
                                                                                 NIL)))))))))))

(DEFUN CONCAT-TO-LIST*
 (&REST SEQUENCES) (CONCATENATE-TO-LIST SEQUENCES))

(DEFUN CONCAT-TO-SIMPLE*
 (RESULT-TYPE &REST SEQUENCES) 
      (* kbr: " 1-Sep-85 19:21")

   (CL:DO ((SEQS SEQUENCES (CDR SEQS))
           (TOTAL-LENGTH 0)
           (LENGTHS NIL))
          ((NULL SEQS)
           (CL:DO ((SEQUENCES SEQUENCES (CDR SEQUENCES))
                   (LENGTHS (REVERSE LENGTHS)
                          (CDR LENGTHS))
                   (INDEX 0)
                   (RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE TOTAL-LENGTH)))
                  ((= INDEX TOTAL-LENGTH)
                   RESULT)
                  (LET ((SEQUENCE (CAR SEQUENCES)))
                       (SEQ-DISPATCH SEQUENCE (CL:DO ((SEQUENCE SEQUENCE (CDR SEQUENCE)))
                                                     ((ENDP SEQUENCE))
                                                     (SETF (AREF RESULT INDEX)
                                                           (CAR SEQUENCE))
                                                     (INCF INDEX))
                              (CL:DO ((JNDEX 0 (1+ JNDEX)))
                                     ((= JNDEX (CAR LENGTHS)))
                                     (SETF (AREF RESULT INDEX)
                                           (AREF SEQUENCE JNDEX))
                                     (INCF INDEX))))))
          (LET ((LENGTH (CL:LENGTH (CAR SEQS))))
               (CL:PUSH LENGTH LENGTHS)
               (INCF TOTAL-LENGTH LENGTH))))


(PUTPROPS CMLSEQBASICS FILETYPE
 COMPILE-FILE)
(PUTPROPS CMLSEQBASICS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL)))
STOP