(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