(FILECREATED "29-Sep-86 19:26:14" {ERIS}<LISPCORE>SOURCES>CMLSEQ.;3 20553
changes to: (VARS CMLSEQCOMS)
(FUNCTIONS %%COERCE-SEQUENCE)
previous date: " 2-Jul-86 18:18:40" {ERIS}<LISPCORE>SOURCES>CMLSEQ.;2)
(* "
Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLSEQCOMS)
(RPAQQ CMLSEQCOMS ((FUNCTIONS CONCATENATE-TO-MUMBLE %%COERCE-SEQUENCE)
(FNS 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)))))
(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)))))
(DEFUN %%COERCE-SEQUENCE (OBJECT OUTPUT-TYPE-SPEC) (ETYPECASE 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)))
)))
(DEFINEQ
(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)
(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)
)
(PRETTYCOMPRINT CMLSEQCOMS)
(RPAQQ CMLSEQCOMS ((FUNCTIONS CONCATENATE-TO-MUMBLE %%COERCE-SEQUENCE)
(FNS 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*)))))
(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*)
)
(PUTPROPS CMLSEQ COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (14410 18533 (LIST-TO-STRING* 14420 . 14823) (LIST-TO-BIT-VECTOR* 14825 . 15314) (
LIST-TO-VECTOR* 15316 . 15733) (VECTOR-TO-LIST* 15735 . 16100) (VECTOR-TO-VECTOR* 16102 . 16524) (
VECTOR-TO-STRING* 16526 . 16934) (VECTOR-TO-BIT-VECTOR* 16936 . 17430) (STRING-TO-SIMPLE-STRING* 17432
. 17956) (BIT-VECTOR-TO-SIMPLE-BIT-VECTOR* 17958 . 18531)))))
STOP