(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")

(FILECREATED " 6-Sep-91 14:19:03" {DSK}<new>venue>sources>CMLSEQCOMMON.;3
 5402   

      changes to%:  (OPTIMIZERS CL:COMPLEMENT) (VARS CMLSEQCOMMONCOMS) (FUNCTIONS CL:COMPLEMENT)

      previous date%: "16-May-90 14:28:05" {DSK}<new>sources>lispcore>sources>CMLSEQCOMMON.;1)


(* ; "
Copyright (c) 1986, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CMLSEQCOMMONCOMS)

(RPAQQ CMLSEQCOMMONCOMS ((FUNCTIONS CHECK-SUBSEQ COLLECT-ITEM COPY-VECTOR-SUBSEQ FILL-VECTOR-SUBSEQ MAKE-SEQUENCE-LIKE SEQ-DISPATCH TYPE-SPECIFIER) (FUNCTIONS BACKWARD-LIST-LOOP BACKWARD-VECTOR-LOOP FORWARD-LIST-LOOP FORWARD-VECTOR-LOOP) (FUNCTIONS CL:COMPLEMENT) (OPTIMIZERS CL:COMPLEMENT) (PROP FILETYPE CMLSEQCOMMON) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T))))

(DEFMACRO CHECK-SUBSEQ (SEQ START END LENGTH) (BQUOTE (CL:IF (NOT (<= 0 (\, START) (\, END) (\, LENGTH))) (CL:ERROR "Illegal subsequence for ~S.~%%Start is ~D. End is ~D" (\, SEQ) (\, START) (\, END)))))

(DEFMACRO COLLECT-ITEM (ITEM HEAD TAIL) (BQUOTE (CL:IF (\, TAIL) (RPLACD (\, TAIL) (SETQ (\, TAIL) (LIST (\, ITEM)))) (SETQ (\, HEAD) (SETQ (\, TAIL) (LIST (\, ITEM)))))))

(DEFMACRO COPY-VECTOR-SUBSEQ (FROM-VECTOR START-FROM END-FROM TO-VECTOR START-TO END-TO) "Copy one vector subsequence to another" (BQUOTE (CL:DO ((FROM-INDEX (\, START-FROM) (CL:1+ FROM-INDEX)) (TO-INDEX (\, START-TO) (CL:1+ TO-INDEX))) ((\, (CL:IF END-FROM (BQUOTE (EQL FROM-INDEX (\, END-FROM))) (BQUOTE (EQL TO-INDEX (\, END-TO))))) (\, TO-VECTOR)) (CL:SETF (CL:AREF (\, TO-VECTOR) TO-INDEX) (CL:AREF (\, FROM-VECTOR) FROM-INDEX)))))

(DEFMACRO FILL-VECTOR-SUBSEQ (VECTOR START END NEWVALUE) (BQUOTE (CL:DO ((INDEX (\, START) (CL:1+ INDEX))) ((EQL INDEX (\, END)) (\, VECTOR)) (CL:SETF (CL:AREF (\, VECTOR) INDEX) (\, NEWVALUE)))))

(DEFMACRO MAKE-SEQUENCE-LIKE (SEQUENCE LENGTH) "Returns a sequence of the same type as SEQUENCE and the given LENGTH." (BQUOTE (LET ((SEQ (\, SEQUENCE))) (CL:ETYPECASE SEQ (LIST (CL:MAKE-LIST (\, LENGTH))) (STRING (CL:MAKE-STRING (\, LENGTH))) (CL:VECTOR (MAKE-VECTOR (\, LENGTH) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQ)))))))

(DEFMACRO SEQ-DISPATCH (SEQUENCE LIST-FORM VECTOR-FORM) (BQUOTE (CL:ETYPECASE (\, SEQUENCE) (LIST (\, LIST-FORM)) (CL:VECTOR (\, VECTOR-FORM)))))

(DEFMACRO TYPE-SPECIFIER (TYPE) "Returns the broad class of which TYPE is a specific subclass." (BQUOTE (CL:IF (CL:ATOM (\, TYPE)) (\, TYPE) (CAR (\, TYPE)))))

(DEFMACRO BACKWARD-LIST-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (CL:1- (\, END)) (CL:1- (\, INDEX-VAR))) %%SUBSEQ (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((< (\, INDEX-VAR) (\, START)) (\, RETURN-FORM)) (SETQ %%SUBSEQ (CL:NTHCDR (\, INDEX-VAR) (\, SEQUENCE))) (SETQ (\, CURRENT-ELEMENT-VAR) (CAR %%SUBSEQ)) (\,@ BODY)))))

(DEFMACRO BACKWARD-VECTOR-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (CL:1- (\, END)) (CL:1- (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((< (\, INDEX-VAR) (\, START)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CL:AREF (\, SEQUENCE) (\, INDEX-VAR))) (\,@ BODY)))))

(DEFMACRO FORWARD-LIST-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO ((%%SUBSEQ (CL:NTHCDR (\, START) (\, SEQUENCE)) (CDR %%SUBSEQ)) ((\, INDEX-VAR) (\, START) (CL:1+ (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((EQL (\, INDEX-VAR) (\, END)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CAR %%SUBSEQ)) (\,@ BODY)))))

(DEFMACRO FORWARD-VECTOR-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) "Canonical forward loop for vectors" (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (\, START) (CL:1+ (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((EQL (\, INDEX-VAR) (\, END)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CL:AREF (\, SEQUENCE) (\, INDEX-VAR))) (\,@ BODY)))))

(CL:DEFUN CL:COMPLEMENT (CL::FN) (CL:FUNCTION (CL:LAMBDA (&REST CL::ARGUMENTS) (NOT (CL:APPLY CL::FN CL::ARGUMENTS)))))

(DEFOPTIMIZER CL:COMPLEMENT (CL::FN &ENVIRONMENT CL::ENV) (* ;; "If we can find the argument list for FN and it's a simple one (it will be 99%% of the time), we can build a decent COMPLEMENT that doesn't do the extra &REST and APPLY") (LET (CL::FN-NAME CL::FN-ARG-LIST) (CL:IF (AND (CL:CONSP CL::FN) (OR (EQ (CAR CL::FN) (QUOTE QUOTE)) (EQ (CAR CL::FN) (QUOTE CL:FUNCTION))) (CL:SYMBOLP (CL:SETQ CL::FN-NAME (CADR CL::FN))) (CL:CONSP (CL:SETQ CL::FN-ARG-LIST (CAR (NLSETQ (SMARTARGLIST CL::FN-NAME)))))) (BQUOTE (CL:FUNCTION (CL:LAMBDA (\, CL::FN-ARG-LIST) (NOT ((\, CL::FN-NAME) (\,@ CL::FN-ARG-LIST)))))) (QUOTE COMPILER:PASS))))

(PUTPROPS CMLSEQCOMMON FILETYPE CL:COMPILE-FILE)
(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
)
(PUTPROPS CMLSEQCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP