add merge in Ron's 11/21/2020 lispcore

CLTL2/CMLSEQCOMMON

@@ -0,0 +1,53 @@
+(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