(FILECREATED "12-Oct-86 17:31:06" {ERIS}<LISPCORE>SOURCES>CMLSEQMAPPERS.;7 28037
changes to: (FUNCTIONS CL:MAP)
previous date: "29-Sep-86 18:47:41" {ERIS}<LISPCORE>SOURCES>CMLSEQMAPPERS.;6)
(* "
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLSEQMAPPERSCOMS)
(RPAQQ CMLSEQMAPPERSCOMS ((DECLARE: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON))
(FUNCTIONS ELT-SLICE MAP-FOR-EFFECT %%MAP-FOR-EFFECT
%%MAP-SINGLE-FOR-EFFECT MAP-TO-LIST %%MAP-TO-LIST
%%MAP-SINGLE-TO-LIST MAP-TO-SIMPLE %%MAP-TO-SIMPLE
%%MAP-SINGLE-TO-SIMPLE CL:MAP)
(OPTIMIZERS %%MAP-FOR-EFFECT %%MAP-TO-LIST %%MAP-TO-SIMPLE CL:MAP)
(FUNCTIONS %%SINGLE-SOME CL:SOME %%SINGLE-EVERY CL:EVERY %%SINGLE-NOTANY
CL:NOTANY %%SINGLE-NOTEVERY CL:NOTEVERY)
(OPTIMIZERS CL:SOME CL:EVERY CL:NOTANY CL:NOTEVERY)
(FUNCTIONS LIST-REDUCE-FROM-END LIST-REDUCE MUMBLE-REDUCE-FROM-END
MUMBLE-REDUCE REDUCE)
(PROP FILETYPE CMLSEQMAPPERS)))
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD CMLSEQCOMMON)
)
(DEFMACRO ELT-SLICE (SEQUENCES N) (BQUOTE (CL:MAPCAR (FUNCTION (CL:LAMBDA (SEQ)
(CL:ELT SEQ (\, N))))
(\, SEQUENCES))))
(DEFMACRO MAP-FOR-EFFECT NIL (BQUOTE (CL:IF (NULL MORE-SEQUENCES)
(SEQ-DISPATCH FIRST-SEQUENCE (MAPC FIRST-SEQUENCE
FUNCTION)
(DOTIMES (I (VECTOR-LENGTH FIRST-SEQUENCE))
(FUNCALL FUNCTION (AREF FIRST-SEQUENCE I)))
)
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(MIN-LENGTH (CL:LENGTH FIRST-SEQUENCE)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX MIN-LENGTH)
NIL)
(CL:APPLY FUNCTION (ELT-SLICE SEQUENCES
INDEX))))
(LET ((LENGTH (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< LENGTH MIN-LENGTH)
(SETQ MIN-LENGTH LENGTH)))))))
(DEFUN %%MAP-FOR-EFFECT (FUNCTION FIRST-SEQUENCE &REST MORE-SEQUENCES) (LET ((SEQUENCES (CONS
FIRST-SEQUENCE
MORE-SEQUENCES
)))
(MAP-FOR-EFFECT)))
(DEFUN %%MAP-SINGLE-FOR-EFFECT (FUNCTION SEQUENCE) (SEQ-DISPATCH SEQUENCE (MAPC SEQUENCE FUNCTION)
(DOTIMES (I (VECTOR-LENGTH SEQUENCE))
(FUNCALL FUNCTION (AREF SEQUENCE I))
)))
(DEFMACRO MAP-TO-LIST NIL (BQUOTE (CL:IF (NULL MORE-SEQUENCES)
(SEQ-DISPATCH FIRST-SEQUENCE (MAPCAR FIRST-SEQUENCE FUNCTION
)
(for I from 0 to (VECTOR-LENGTH FIRST-SEQUENCE)
collect (FUNCALL FUNCTION (AREF I FIRST-SEQUENCE))
))
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(MIN-LENGTH (CL:LENGTH FIRST-SEQUENCE)))
((NULL SEQS)
(FOR INDEX FROM 0 TO (1- MIN-LENGTH)
COLLECT (CL:APPLY FUNCTION (ELT-SLICE SEQUENCES
INDEX))))
(LET ((LENGTH (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< LENGTH MIN-LENGTH)
(SETF MIN-LENGTH LENGTH)))))))
(DEFUN %%MAP-TO-LIST (FUNCTION FIRST-SEQUENCE &REST MORE-SEQUENCES) (LET ((SEQUENCES (CONS
FIRST-SEQUENCE
MORE-SEQUENCES
)))
(MAP-TO-LIST)))
(DEFUN %%MAP-SINGLE-TO-LIST (FUNCTION SEQUENCE) (SEQ-DISPATCH SEQUENCE (MAPCAR SEQUENCE FUNCTION)
(for I from 0 to (VECTOR-LENGTH SEQUENCE)
collect (FUNCALL FUNCTION (AREF I SEQUENCE)
))))
(DEFMACRO MAP-TO-SIMPLE NIL (BQUOTE (CL:IF (NULL (CDR SEQUENCES))
(LET* ((LENGTH (CL:LENGTH FIRST-SEQUENCE))
(RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE LENGTH))
)
(SEQ-DISPATCH
FIRST-SEQUENCE
(for X in (THE LIST FIRST-SEQUENCE) as I
from 0 do (SETF (AREF RESULT I)
(FUNCALL FUNCTION X))
finally (RETURN RESULT))
(DOTIMES (I LENGTH RESULT)
(SETF (AREF RESULT I)
(FUNCALL FUNCTION
(AREF (THE VECTOR
FIRST-SEQUENCE)
I))))))
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(MIN-LENGTH (CL:LENGTH FIRST-SEQUENCE)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX))
(RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE
MIN-LENGTH)))
((= INDEX MIN-LENGTH)
RESULT)
(SETF (AREF RESULT INDEX)
(CL:APPLY FUNCTION (ELT-SLICE
SEQUENCES
INDEX)))))
(LET ((LENGTH (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< LENGTH MIN-LENGTH)
(SETF MIN-LENGTH LENGTH)))))))
(DEFUN %%MAP-TO-SIMPLE (RESULT-TYPE FUNCTION FIRST-SEQUENCE &REST MORE-SEQUENCES)
(LET ((SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
(MAP-TO-SIMPLE)))
(DEFUN %%MAP-SINGLE-TO-SIMPLE (OUTPUT-TYPE-SPEC FUNCTION SEQUENCE)
(LET* ((LENGTH (CL:LENGTH SEQUENCE))
(RESULT (MAKE-SEQUENCE-OF-TYPE OUTPUT-TYPE-SPEC LENGTH)))
(SEQ-DISPATCH SEQUENCE (for X in (THE LIST SEQUENCE) as I from 0
do (SETF (AREF RESULT I)
(FUNCALL FUNCTION X)) finally (RETURN RESULT))
(DOTIMES (I LENGTH RESULT)
(SETF (AREF RESULT I)
(FUNCALL FUNCTION (AREF (THE VECTOR SEQUENCE)
I)))))))
(DEFUN CL:MAP (RESULT-TYPE FUNCTION FIRST-SEQUENCE &REST MORE-SEQUENCES) "FUNCTION must take as many arguments as there are sequences provided. The result is a sequence such that element i is the result of applying FUNCTION to element i of each of the argument sequences."
(LET ((SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
(CASE (TYPE-SPECIFIER RESULT-TYPE)
(NIL (MAP-FOR-EFFECT))
(LIST (MAP-TO-LIST))
((SIMPLE-VECTOR SIMPLE-STRING VECTOR STRING CL:ARRAY SIMPLE-ARRAY BIT-VECTOR
SIMPLE-BIT-VECTOR)
(MAP-TO-SIMPLE))
(T (CL:ERROR "~S: invalid output type specifier." RESULT-TYPE)))))
(DEFOPTIMIZER %%MAP-FOR-EFFECT (FUNCTION SEQUENCE &REST MORE-SEQUENCES)
(COND
((NULL MORE-SEQUENCES)
(BQUOTE (%%MAP-SINGLE-FOR-EFFECT (\, FUNCTION)
(\, SEQUENCE))))
(T (QUOTE COMPILER:PASS))))
(DEFOPTIMIZER %%MAP-TO-LIST (FUNCTION SEQUENCE &REST MORE-SEQUENCES) (COND
((NULL MORE-SEQUENCES)
(BQUOTE (
%%MAP-SINGLE-TO-LIST
(\, FUNCTION)
(\, SEQUENCE))))
(T (QUOTE COMPILER:PASS))))
(DEFOPTIMIZER %%MAP-TO-SIMPLE (OUTPUT-TYPE-SPEC FUNCTION SEQUENCE &REST MORE-SEQUENCES)
(COND
((NULL MORE-SEQUENCES)
(BQUOTE (%%MAP-SINGLE-TO-SIMPLE (\, OUTPUT-TYPE-SPEC)
(\, FUNCTION)
(\, SEQUENCE))))
(T (QUOTE COMPILER:PASS))))
(DEFOPTIMIZER CL:MAP (RESULT-TYPE FUNCTION &REST SEQUENCES &CONTEXT CTX &AUX RES-TYPE)
(COND
((ZEROP (COMPILER:CONTEXT-VALUES-USED CTX))
(BQUOTE (%%MAP-FOR-EFFECT (\, FUNCTION)
(\,@ SEQUENCES))))
((PROG1 (SETQ RES-TYPE (CONSTANTEXPRESSIONP RESULT-TYPE))
(SETQ RES-TYPE (CAR RES-TYPE)))
(CASE RES-TYPE (NIL (BQUOTE (%%MAP-FOR-EFFECT (\, FUNCTION)
(\,@ SEQUENCES))))
(LIST (BQUOTE (%%MAP-TO-LIST (\, FUNCTION)
(\,@ SEQUENCES))))
(OTHERWISE (BQUOTE (%%MAP-TO-SIMPLE (\, RES-TYPE)
(\, FUNCTION)
(\,@ SEQUENCES))))))
(T (QUOTE COMPILER:PASS))))
(DEFUN %%SINGLE-SOME (PREDICATE SEQUENCE)
(SEQ-DISPATCH SEQUENCE (DOLIST (E (THE LIST SEQUENCE)
NIL)
(LET ((X (FUNCALL PREDICATE E)))
(CL:WHEN X (RETURN X))))
(DOTIMES (I (VECTOR-LENGTH SEQUENCE NIL)
(LET ((X (FUNCALL PREDICATE (AREF (THE VECTOR SEQUENCE)
I))))
(CL:WHEN X (RETURN X)))))))
(DEFUN CL:SOME (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. SOME returns the first non-() value encountered, or () if the end of a sequence is reached."
(CL:IF (NULL MORE-SEQUENCES)
(%%SINGLE-SOME PREDICATE FIRST-SEQUENCE)
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(LENGTH (CL:LENGTH FIRST-SEQUENCE))
(SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
NIL)
(LET ((RESULT (CL:APPLY PREDICATE (ELT-SLICE SEQUENCES INDEX))))
(CL:WHEN RESULT (RETURN RESULT)))))
(LET ((THIS (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< THIS LENGTH)
(SETQ LENGTH THIS))))))
(DEFUN %%SINGLE-EVERY (PREDICATE SEQUENCE) (SEQ-DISPATCH SEQUENCE (DOLIST (E (THE LIST SEQUENCE)
T)
(CL:UNLESS (FUNCALL
PREDICATE
E)
(RETURN NIL)))
(DOTIMES (I (VECTOR-LENGTH SEQUENCE)
T)
(DECLARE (VECTOR SEQUENCE))
(CL:UNLESS (FUNCALL PREDICATE
(AREF SEQUENCE I))
(RETURN NIL)))))
(DEFUN CL:EVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. EVERY returns () as soon as any invocation of PREDICATE returns (), or T if every invocation is non-()."
(CL:IF (NULL MORE-SEQUENCES)
(%%SINGLE-EVERY PREDICATE FIRST-SEQUENCE)
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(LENGTH (CL:LENGTH FIRST-SEQUENCE))
(SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
T)
(LET ((RESULT (CL:APPLY PREDICATE (ELT-SLICE SEQUENCES INDEX))))
(CL:UNLESS RESULT (RETURN NIL)))))
(LET ((THIS (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< THIS LENGTH)
(SETQ LENGTH THIS))))))
(DEFUN %%SINGLE-NOTANY (PREDICATE SEQUENCE) (SEQ-DISPATCH SEQUENCE (DOLIST (E (THE LIST SEQUENCE)
T)
(CL:WHEN (FUNCALL PREDICATE
E)
(RETURN NIL)))
(DOTIMES (I (VECTOR-LENGTH SEQUENCE)
T)
(DECLARE (VECTOR SEQUENCE))
(CL:WHEN (FUNCALL PREDICATE
(AREF SEQUENCE I))
(RETURN NIL)))))
(DEFUN CL:NOTANY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. NOTANY returns () as soon as any invocation of PREDICATE returns a non-() value, or T if the end of a sequence is reached."
(CL:IF (NULL MORE-SEQUENCES)
(%%SINGLE-NOTANY PREDICATE FIRST-SEQUENCE)
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(LENGTH (CL:LENGTH FIRST-SEQUENCE))
(SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
T)
(LET ((RESULT (CL:APPLY PREDICATE (ELT-SLICE SEQUENCES INDEX))))
(CL:WHEN RESULT (RETURN NIL)))))
(LET ((THIS (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< THIS LENGTH)
(SETQ LENGTH THIS))))))
(DEFUN %%SINGLE-NOTEVERY (PREDICATE SEQUENCE) (SEQ-DISPATCH
SEQUENCE
(DOLIST (E (THE LIST SEQUENCE)
NIL)
(LET ((X (FUNCALL PREDICATE E)))
(CL:WHEN X (RETURN T))))
(DOTIMES (I (VECTOR-LENGTH SEQUENCE)
NIL)
(DECLARE (VECTOR SEQUENCE))
(LET ((X (FUNCALL PREDICATE (AREF SEQUENCE I)))
)
(CL:WHEN X (RETURN T))))))
(DEFUN CL:NOTEVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. NOTEVERY returns T as soon as any invocation of PREDICATE returns (), or () if every invocation is non-()."
(CL:IF (NULL MORE-SEQUENCES)
(%%SINGLE-NOTEVERY PREDICATE FIRST-SEQUENCE)
(CL:DO ((SEQS MORE-SEQUENCES (CDR SEQS))
(LENGTH (CL:LENGTH FIRST-SEQUENCE))
(SEQUENCES (CONS FIRST-SEQUENCE MORE-SEQUENCES)))
((NULL SEQS)
(CL:DO ((INDEX 0 (1+ INDEX)))
((= INDEX LENGTH)
NIL)
(LET ((RESULT (CL:APPLY PREDICATE (ELT-SLICE SEQUENCES INDEX))))
(CL:UNLESS RESULT (RETURN T)))))
(LET ((THIS (CL:LENGTH (CAR SEQS))))
(CL:WHEN (< THIS LENGTH)
(SETQ LENGTH THIS))))))
(DEFOPTIMIZER CL:SOME (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND
((NULL MORE-SEQUENCES)
(BQUOTE (%%SINGLE-SOME
(\, PREDICATE)
(\, SEQUENCE))))
(T (QUOTE COMPILER:PASS))))
(DEFOPTIMIZER CL:EVERY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND
((NULL MORE-SEQUENCES)
(BQUOTE (%%SINGLE-EVERY
(\, PREDICATE)
(\, SEQUENCE))))
(T (QUOTE COMPILER:PASS))))
(DEFOPTIMIZER CL:NOTANY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND
((NULL MORE-SEQUENCES)
(BQUOTE (%%SINGLE-NOTANY
(\, PREDICATE)
(\, SEQUENCE))))
(T (QUOTE COMPILER:PASS))))
(DEFOPTIMIZER CL:NOTEVERY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND
((NULL MORE-SEQUENCES)
(BQUOTE (%%SINGLE-NOTEVERY
(\, PREDICATE)
(\, SEQUENCE))))
(T (QUOTE COMPILER:PASS))))
(DEFMACRO LIST-REDUCE-FROM-END (FUNCTION SEQUENCE START END INITIAL-VALUE INITIAL-PROVIDED)
(BQUOTE (LET ((SEQUENCE (NTHCDR (- (CL:LENGTH (\, SEQUENCE))
(\, END))
(REVERSE (\, SEQUENCE)))))
(CL:WHEN (\, INITIAL-PROVIDED)
(CL:PUSH (\, INITIAL-VALUE)
SEQUENCE))
(CL:DO* ((COUNT (- (\, END)
(\, START)
(CL:IF (\, INITIAL-PROVIDED)
0 1))
(1- COUNT))
(SEQUENCE SEQUENCE (CDR SEQUENCE))
(VALUE (CAR SEQUENCE)
(FUNCALL (\, FUNCTION)
(CAR SEQUENCE)
VALUE)))
((= COUNT 0)
VALUE)))))
(DEFMACRO LIST-REDUCE (FUNCTION SEQUENCE START END INITIAL-VALUE INITIAL-PROVIDED)
(BQUOTE (LET ((SEQUENCE (NTHCDR (\, START)
(\, SEQUENCE))))
(CL:WHEN (\, INITIAL-PROVIDED)
(CL:PUSH (\, INITIAL-VALUE)
SEQUENCE))
(CL:DO* ((COUNT (- END START (CL:IF (\, INITIAL-PROVIDED)
0 1))
(1- COUNT))
(SEQUENCE SEQUENCE (CDR SEQUENCE))
(VALUE (CAR SEQUENCE)
(FUNCALL (\, FUNCTION)
VALUE
(CAR SEQUENCE))))
((= COUNT 0)
VALUE)))))
(DEFMACRO MUMBLE-REDUCE-FROM-END (FUNCTION SEQUENCE START END INITIAL-VALUE REF)
(BQUOTE (CL:DO ((INDEX (1- (\, END))
(1- INDEX))
(VALUE (\, INITIAL-VALUE))
(TERMINUS (1- (\, START))))
((<= INDEX TERMINUS)
VALUE)
(SETQ VALUE (FUNCALL (\, FUNCTION)
((\, REF)
(\, SEQUENCE)
INDEX)
VALUE)))))
(DEFMACRO MUMBLE-REDUCE (FUNCTION SEQUENCE START END INITIAL-VALUE REF)
(BQUOTE (CL:DO ((INDEX (\, START)
(1+ INDEX))
(VALUE (\, INITIAL-VALUE)))
((>= INDEX (\, END))
VALUE)
(SETQ VALUE (FUNCALL (\, FUNCTION)
VALUE
((\, REF)
(\, SEQUENCE)
INDEX))))))
(DEFUN REDUCE (FUNCTION SEQUENCE &KEY FROM-END (START 0)
END
(INITIAL-VALUE NIL INITIAL-PROVIDED)
&AUX
(LENGTH (CL:LENGTH SEQUENCE))) (CL:UNLESS END (SETQ END LENGTH))
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
(COND
((= END START)
(CL:IF INITIAL-PROVIDED INITIAL-VALUE
(FUNCALL FUNCTION)))
((CL:LISTP SEQUENCE)
(CL:IF FROM-END
(LIST-REDUCE-FROM-END FUNCTION
SEQUENCE START END
INITIAL-VALUE INITIAL-PROVIDED)
(LIST-REDUCE FUNCTION SEQUENCE START
END INITIAL-VALUE
INITIAL-PROVIDED)))
(T (COND
(FROM-END (CL:UNLESS INITIAL-PROVIDED
(CL:SETQ END
(1- END)
INITIAL-VALUE
(AREF SEQUENCE
END)))
(MUMBLE-REDUCE-FROM-END FUNCTION
SEQUENCE START END
INITIAL-VALUE AREF))
(T (CL:UNLESS INITIAL-PROVIDED
(CL:SETQ INITIAL-VALUE
(AREF SEQUENCE START)
START
(1+ START)))
(MUMBLE-REDUCE FUNCTION SEQUENCE
START END INITIAL-VALUE AREF))
))))
(PUTPROPS CMLSEQMAPPERS FILETYPE COMPILE-FILE)
(PUTPROPS CMLSEQMAPPERS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP