(FILECREATED " 2-Jul-86 18:18:40" {ERIS}<LISPCORE>LIBRARY>CMLSEQ.;32 13717
changes to: (SETFS CL:ELT)
(FUNCTIONS SEQ-DISPATCH MAKE-SEQUENCE-OF-TYPE CL:REPLACE)
(VARS CMLSEQCOMS)
(FNS LIST-TO-STRING* LIST-TO-BIT-VECTOR* LIST-TO-VECTOR*)
previous date: " 1-Jul-86 18:39:59" {ERIS}<LISPCORE>LIBRARY>CMLSEQ.;31)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSEQCOMS)
(RPAQQ CMLSEQCOMS ((FUNCTIONS CONCATENATE-TO-MUMBLE)
(* "Not used.")
(FNS CL:COERCE LIST-TO-STRING* LIST-TO-BIT-VECTOR* LIST-TO-VECTOR* VECTOR-TO-LIST*
VECTOR-TO-VECTOR* VECTOR-TO-STRING* VECTOR-TO-BIT-VECTOR*
STRING-TO-SIMPLE-STRING* BIT-VECTOR-TO-SIMPLE-BIT-VECTOR*)
(* "Left over.")
(FILES CMLSEQCOMMON CMLSEQBASICS CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT)
(PROP FILETYPE CMLSEQ)))
(DEFMACRO CONCATENATE-TO-MUMBLE (OUTPUT-TYPE-SPEC SEQUENCES)
(BQUOTE (CL:DO ((SEQS (\, SEQUENCES)
(CDR SEQS))
(TOTAL-LENGTH 0)
(LENGTHS NIL))
((NULL SEQS)
(CL:DO ((SEQUENCES (\, SEQUENCES)
(CDR SEQUENCES))
(LENGTHS LENGTHS (CDR LENGTHS))
(INDEX 0)
(RESULT (MAKE-SEQUENCE-OF-TYPE (\, OUTPUT-TYPE-SPEC)
TOTAL-LENGTH)))
((= INDEX TOTAL-LENGTH)
RESULT)
(LET ((SEQUENCE (CAR SEQUENCES)))
(SEQ-DISPATCH SEQUENCE (CL:DO ((SEQUENCE SEQUENCE (CDR SEQUENCE)))
((CL:ATOM 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))))
(SETQ LENGTHS (NCONC LENGTHS (LIST LENGTH)))
(INCF TOTAL-LENGTH LENGTH)))))
(* "Not used.")
(DEFINEQ
(CL:COERCE
(CL:LAMBDA (OBJECT OUTPUT-TYPE-SPEC) (* amd " 9-Jun-86 17:32")
(COND
((TYPEP OBJECT OUTPUT-TYPE-SPEC)
OBJECT)
((EQ OUTPUT-TYPE-SPEC (QUOTE CHARACTER))
(CHARACTER OBJECT))
((NUMBERP OBJECT)
(CASE OUTPUT-TYPE-SPEC ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
(FLOAT OBJECT))
(COMPLEX (CL:ERROR "Complex numbers not supported in current implementation."))
(T (CL:ERROR "~S can't be converted to type ~S." OBJECT OUTPUT-TYPE-SPEC))))
(T (TYPECASE OBJECT (LIST (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
((SIMPLE-STRING STRING)
(LIST-TO-STRING* OBJECT))
((SIMPLE-BIT-VECTOR BIT-VECTOR)
(LIST-TO-BIT-VECTOR* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(LIST-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(SIMPLE-STRING (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(SIMPLE-BIT-VECTOR (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(SIMPLE-VECTOR (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
((SIMPLE-STRING STRING)
(VECTOR-TO-STRING* OBJECT))
((SIMPLE-BIT-VECTOR BIT-VECTOR)
(VECTOR-TO-BIT-VECTOR* OBJECT))
((VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(STRING (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
(SIMPLE-STRING (STRING-TO-SIMPLE-STRING* OBJECT))
((SIMPLE-VECTOR VECTOR SIMPLE-ARRAY ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(BIT-VECTOR (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
(SIMPLE-BIT-VECTOR (BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(VECTOR (CASE (TYPE-SPECIFIER OUTPUT-TYPE-SPEC)
(LIST (VECTOR-TO-LIST* OBJECT))
((SIMPLE-STRING STRING)
(VECTOR-TO-STRING* OBJECT))
((SIMPLE-BIT-VECTOR BIT-VECTOR)
(VECTOR-TO-BIT-VECTOR* OBJECT))
((SIMPLE-VECTOR VECTOR ARRAY SIMPLE-ARRAY)
(VECTOR-TO-VECTOR* OBJECT OUTPUT-TYPE-SPEC))
(T (CL:ERROR "Can't coerce ~S to type ~S." OBJECT
OUTPUT-TYPE-SPEC))))
(T (CL:ERROR "~S is an inappropriate type of object for coerce." OBJECT)))))))
(LIST-TO-STRING*
(CL:LAMBDA (OBJECT) (* amd " 1-Jul-86 18:38")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-STRING CL:LENGTH)))
((= INDEX CL:LENGTH)
RESULT)
(SETF (SCHAR RESULT INDEX)
(pop OBJECT)))))
(LIST-TO-BIT-VECTOR*
(CL:LAMBDA (OBJECT) (* amd " 1-Jul-86 18:38")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-ARRAY CL:LENGTH :ELEMENT-TYPE (QUOTE (MOD 2)))))
((= INDEX CL:LENGTH)
RESULT)
(DECLARE (TYPE FIXNUM CL:LENGTH))
(SETF (SBIT RESULT INDEX)
(pop OBJECT)))))
(LIST-TO-VECTOR*
(CL:LAMBDA (OBJECT TYPE) (* amd " 1-Jul-86 18:38")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-SEQUENCE-OF-TYPE TYPE CL:LENGTH)))
((= INDEX CL:LENGTH)
RESULT)
(SETF (AREF RESULT INDEX)
(pop OBJECT)))))
(VECTOR-TO-LIST*
(CL:LAMBDA (OBJECT)
(LET ((RESULT (LIST NIL))
(CL:LENGTH (CL:LENGTH OBJECT)))
(CL:DO ((INDEX 0 (1+ INDEX))
(SPLICE RESULT (CDR SPLICE)))
((= INDEX CL:LENGTH)
(CDR RESULT))
(RPLACD SPLICE (LIST (AREF OBJECT INDEX)))))))
(VECTOR-TO-VECTOR*
(CL:LAMBDA (OBJECT TYPE) (* raf "17-Dec-85 22:42")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-SEQUENCE-OF-TYPE TYPE CL:LENGTH)))
((= INDEX CL:LENGTH)
RESULT)
(SETF (AREF RESULT INDEX)
(AREF OBJECT INDEX)))))
(VECTOR-TO-STRING*
(CL:LAMBDA (OBJECT) (* raf "17-Dec-85 22:42")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-STRING CL:LENGTH)))
((= INDEX CL:LENGTH)
RESULT)
(SETF (SCHAR RESULT INDEX)
(AREF OBJECT INDEX)))))
(VECTOR-TO-BIT-VECTOR*
(CL:LAMBDA (OBJECT) (* raf "17-Dec-85 22:43")
(CL:DO* ((INDEX 0 (1+ INDEX))
(CL:LENGTH (CL:LENGTH OBJECT))
(RESULT (MAKE-ARRAY CL:LENGTH :ELEMENT-TYPE (QUOTE (MOD 2)))))
((= INDEX CL:LENGTH)
RESULT)
(DECLARE (TYPE FIXNUM CL:LENGTH))
(SETF (SBIT RESULT INDEX)
(AREF OBJECT INDEX)))))
(STRING-TO-SIMPLE-STRING*
(CL:LAMBDA (OBJECT) (* raf "18-Dec-85 01:52")
(COND
((SIMPLE-STRING-P OBJECT)
OBJECT)
(T (CL:DO* ((LENGTH (CL:LENGTH OBJECT))
(SIMPLE-STRING (ALLOCSTRING LENGTH))
(I 0 (1+ I)))
((= I LENGTH)
SIMPLE-STRING)
(SETF (AREF OBJECT I)
(AREF SIMPLE-STRING I)))))))
(BIT-VECTOR-TO-SIMPLE-BIT-VECTOR*
(CL:LAMBDA (OBJECT) (* raf "18-Dec-85 01:53")
(COND
((SIMPLE-BIT-VECTOR-P OBJECT)
OBJECT)
(T (CL:DO* ((LENGTH (CL:LENGTH OBJECT))
(SIMPLE-BIT-VECTOR (MAKE-ARRAY LENGTH :ELEMENT-TYPE (QUOTE BIT)))
(I 0 (1+ I)))
((= I LENGTH)
SIMPLE-BIT-VECTOR)
(SETF (AREF OBJECT I)
(AREF SIMPLE-BIT-VECTOR I)))))))
)
(* "Left over.")
(FILESLOAD CMLSEQCOMMON CMLSEQBASICS CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT)
(PUTPROPS CMLSEQ FILETYPE COMPILE-FILE)
(PRETTYCOMPRINT CMLSEQCOMS)
(RPAQQ CMLSEQCOMS ((FUNCTIONS CONCATENATE-TO-MUMBLE)
(* "Not used.")
(FNS CL:COERCE LIST-TO-STRING* LIST-TO-BIT-VECTOR* LIST-TO-VECTOR* VECTOR-TO-LIST*
VECTOR-TO-VECTOR* VECTOR-TO-STRING* VECTOR-TO-BIT-VECTOR*
STRING-TO-SIMPLE-STRING* BIT-VECTOR-TO-SIMPLE-BIT-VECTOR*)
(* "Left over.")
(FILES CMLSEQCOMMON CMLSEQBASICS CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT)
(PROP FILETYPE CMLSEQ)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* STRING-TO-SIMPLE-STRING*
VECTOR-TO-BIT-VECTOR* VECTOR-TO-STRING* VECTOR-TO-VECTOR*
VECTOR-TO-LIST* LIST-TO-VECTOR* LIST-TO-BIT-VECTOR*
LIST-TO-STRING* CL:COERCE)))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* STRING-TO-SIMPLE-STRING* VECTOR-TO-BIT-VECTOR*
VECTOR-TO-STRING* VECTOR-TO-VECTOR* VECTOR-TO-LIST* LIST-TO-VECTOR*
LIST-TO-BIT-VECTOR* LIST-TO-STRING* CL:COERCE)
)
(PUTPROPS CMLSEQ COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2736 12019 (CL:COERCE 2746 . 7904) (LIST-TO-STRING* 7906 . 8309) (LIST-TO-BIT-VECTOR*
8311 . 8800) (LIST-TO-VECTOR* 8802 . 9219) (VECTOR-TO-LIST* 9221 . 9586) (VECTOR-TO-VECTOR* 9588 .
10010) (VECTOR-TO-STRING* 10012 . 10420) (VECTOR-TO-BIT-VECTOR* 10422 . 10916) (
STRING-TO-SIMPLE-STRING* 10918 . 11442) (BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* 11444 . 12017)))))
STOP