add merge in Ron's 11/21/2020 lispcore
This commit is contained in:
Larry Masinter
198
CLTL2/CMLSEQBASICS
Normal file
198
CLTL2/CMLSEQBASICS
Normal file
@@ -0,0 +1,198 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "18-Oct-93 14:37:58" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSEQBASICS.;2" 10546
|
||||
|
||||
previous date%: "29-Aug-91 16:36:55" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSEQBASICS.;1"
|
||||
)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLSEQBASICSCOMS)
|
||||
|
||||
(RPAQQ CMLSEQBASICSCOMS
|
||||
((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON))
|
||||
(FUNCTIONS LISP:CONCATENATE LISP:COPY-SEQ LISP:ELT LISP:LENGTH LISP:MAKE-SEQUENCE
|
||||
LISP:NREVERSE LISP:REVERSE LISP:SUBSEQ %%SETELT)
|
||||
(FUNCTIONS MAKE-SEQUENCE-OF-TYPE)
|
||||
(SETFS LISP:ELT LISP:SUBSEQ)
|
||||
(PROPS (CMLSEQBASICS FILETYPE))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T))))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD CMLSEQCOMMON)
|
||||
)
|
||||
|
||||
(LISP:DEFUN LISP:CONCATENATE (RESULT-TYPE &REST SEQUENCES)
|
||||
[LET [(RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE (LET ((CNT 0))
|
||||
(LISP:DOLIST (SEQ SEQUENCES CNT)
|
||||
(SETQ CNT (+ CNT (LISP:LENGTH
|
||||
SEQ))))]
|
||||
(SEQ-DISPATCH RESULT [LET ((TAIL RESULT))
|
||||
(LISP:DOLIST (SEQUENCE SEQUENCES RESULT)
|
||||
[SEQ-DISPATCH SEQUENCE (LISP:DOLIST (ELEMENT SEQUENCE)
|
||||
(RPLACA TAIL ELEMENT)
|
||||
(SETQ TAIL (CDR TAIL)))
|
||||
(LISP:DOTIMES (I (VECTOR-LENGTH SEQUENCE))
|
||||
(RPLACA TAIL (LISP:AREF SEQUENCE I))
|
||||
(SETQ TAIL (CDR TAIL)))])]
|
||||
(LET ((INDEX 0))
|
||||
(LISP:DOLIST (SEQUENCE SEQUENCES RESULT)
|
||||
[SEQ-DISPATCH SEQUENCE (LISP:DOLIST (ELEMENT SEQUENCE)
|
||||
(LISP:SETF (LISP:AREF RESULT INDEX)
|
||||
ELEMENT)
|
||||
(SETQ INDEX (LISP:1+ INDEX)))
|
||||
(LISP:DOTIMES (I (VECTOR-LENGTH SEQUENCE))
|
||||
(LISP:SETF (LISP:AREF RESULT INDEX)
|
||||
(LISP:AREF SEQUENCE I))
|
||||
(SETQ INDEX (LISP:1+ INDEX)))])])
|
||||
|
||||
(LISP:DEFUN LISP:COPY-SEQ (SEQUENCE)
|
||||
"Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ."
|
||||
[LET ((LENGTH (LISP:LENGTH SEQUENCE)))
|
||||
(SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT COPY TAIL)
|
||||
COPY
|
||||
(COLLECT-ITEM CURRENT COPY TAIL))
|
||||
(LET [(COPY (MAKE-VECTOR LENGTH :ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE SEQUENCE]
|
||||
(COPY-VECTOR-SUBSEQ SEQUENCE 0 LENGTH COPY 0 LENGTH])
|
||||
|
||||
(LISP:DEFUN LISP:ELT (SEQUENCE INDEX)
|
||||
(* amd " 5-Jun-86 17:48")
|
||||
(LISP:IF (NOT (< -1 INDEX (LISP:LENGTH SEQUENCE)))
|
||||
(LISP:ERROR 'INDEX-BOUNDS-ERROR :NAME SEQUENCE :INDEX INDEX))
|
||||
(SEQ-DISPATCH SEQUENCE (LISP:NTH INDEX SEQUENCE)
|
||||
(LISP:AREF SEQUENCE INDEX)))
|
||||
|
||||
(LISP:DEFUN LISP:LENGTH (SEQUENCE)
|
||||
(SEQ-DISPATCH SEQUENCE [LET ((SIZE 0)
|
||||
(REST SEQUENCE))
|
||||
(LISP:LOOP (LISP:IF (NOT (LISP:CONSP REST))
|
||||
(RETURN SIZE))
|
||||
(SETQ REST (CDR REST))
|
||||
(SETQ SIZE (LISP:1+ SIZE]
|
||||
(VECTOR-LENGTH SEQUENCE)))
|
||||
|
||||
(LISP:DEFUN LISP:MAKE-SEQUENCE (TYPE LENGTH &KEY (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P))
|
||||
"Make a sequnce of the specified type"
|
||||
(LISP:IF (EQ TYPE 'LIST)
|
||||
(LISP:MAKE-LIST LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT)
|
||||
(LET ((VECTOR (MAKE-SEQUENCE-OF-TYPE TYPE LENGTH)))
|
||||
(LISP:IF INITIAL-ELEMENT-P (FILL-VECTOR-SUBSEQ VECTOR 0 LENGTH INITIAL-ELEMENT))
|
||||
VECTOR)))
|
||||
|
||||
(LISP:DEFUN LISP:NREVERSE (SEQUENCE)
|
||||
"Returns a sequence of the same elements in reverse order (the argument is destroyed)."
|
||||
[SEQ-DISPATCH SEQUENCE [LET ((REST SEQUENCE)
|
||||
LIST-HEAD RESULT)
|
||||
(LISP:LOOP (LISP:IF (NOT (LISP:CONSP (SETQ LIST-HEAD REST)))
|
||||
(RETURN RESULT))
|
||||
(SETQ REST (CDR REST))
|
||||
(SETQ RESULT (RPLACD LIST-HEAD RESULT]
|
||||
(LET ((LENGTH (VECTOR-LENGTH SEQUENCE)))
|
||||
(LISP:DO ((LEFT-INDEX 0 (LISP:1+ LEFT-INDEX))
|
||||
(RIGHT-INDEX (LISP:1- LENGTH)
|
||||
(LISP:1- RIGHT-INDEX))
|
||||
(HALF-LENGTH (LRSH LENGTH 1)))
|
||||
((EQL LEFT-INDEX HALF-LENGTH)
|
||||
SEQUENCE)
|
||||
(LISP:ROTATEF (LISP:AREF SEQUENCE LEFT-INDEX)
|
||||
(LISP:AREF SEQUENCE RIGHT-INDEX)))])
|
||||
|
||||
(LISP:DEFUN LISP:REVERSE (SEQUENCE)
|
||||
"Returns a new sequence containing the same elements but in reverse order."
|
||||
[SEQ-DISPATCH SEQUENCE [LET ((REST SEQUENCE)
|
||||
RESULT)
|
||||
(LISP:LOOP (LISP:IF (NOT (LISP:CONSP REST))
|
||||
(RETURN RESULT))
|
||||
(LISP:PUSH (CAR REST)
|
||||
RESULT)
|
||||
(SETQ REST (CDR REST]
|
||||
(LET ((LENGTH (VECTOR-LENGTH SEQUENCE)))
|
||||
(LISP:DO ((RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE SEQUENCE)
|
||||
))
|
||||
(FORWARD-INDEX 0 (LISP:1+ FORWARD-INDEX))
|
||||
(BACKWARD-INDEX (LISP:1- LENGTH)
|
||||
(LISP:1- BACKWARD-INDEX)))
|
||||
((EQL FORWARD-INDEX LENGTH)
|
||||
RESULT)
|
||||
(LISP:SETF (LISP:AREF RESULT FORWARD-INDEX)
|
||||
(LISP:AREF SEQUENCE BACKWARD-INDEX)))])
|
||||
|
||||
(LISP:DEFUN LISP:SUBSEQ (SEQUENCE START &OPTIONAL END)
|
||||
[LET ((LENGTH (LISP:LENGTH SEQUENCE)))
|
||||
(LISP:IF (NULL END)
|
||||
(SETQ END LENGTH))
|
||||
(CHECK-SUBSEQ SEQUENCE START END LENGTH)
|
||||
(SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT COPY TAIL)
|
||||
COPY
|
||||
(COLLECT-ITEM CURRENT COPY TAIL))
|
||||
(LET [(COPY (MAKE-VECTOR (- END START)
|
||||
:ELEMENT-TYPE
|
||||
(LISP:ARRAY-ELEMENT-TYPE SEQUENCE]
|
||||
(COPY-VECTOR-SUBSEQ SEQUENCE START END COPY 0])
|
||||
|
||||
(LISP:DEFUN %%SETELT (SEQUENCE INDEX NEWVAL)
|
||||
(LISP:IF (NOT (< -1 INDEX (LISP:LENGTH SEQUENCE)))
|
||||
(LISP:ERROR 'INDEX-BOUNDS-ERROR :NAME SEQUENCE :INDEX INDEX))
|
||||
(SEQ-DISPATCH SEQUENCE (LISP:SETF (LISP:NTH INDEX SEQUENCE)
|
||||
NEWVAL)
|
||||
(LISP:SETF (LISP:AREF SEQUENCE INDEX)
|
||||
NEWVAL)))
|
||||
|
||||
(LISP:DEFUN MAKE-SEQUENCE-OF-TYPE (TYPE LENGTH)
|
||||
[LET ((BROAD-TYPE (TYPE-SPECIFIER TYPE))
|
||||
TYPE-LENGTH)
|
||||
(LISP:IF (EQ BROAD-TYPE 'LIST)
|
||||
(LISP:MAKE-LIST LENGTH)
|
||||
[LET [(ELEMENT-TYPE (CASE BROAD-TYPE
|
||||
((LISP:SIMPLE-STRING STRING)
|
||||
(SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
|
||||
(LISP:SECOND TYPE)))
|
||||
'LISP:STRING-CHAR)
|
||||
((LISP:SIMPLE-BIT-VECTOR LISP:BIT-VECTOR)
|
||||
(SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
|
||||
(LISP:SECOND TYPE)))
|
||||
'BIT)
|
||||
(LISP:SIMPLE-VECTOR
|
||||
(SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
|
||||
(LISP:SECOND TYPE)))
|
||||
T)
|
||||
((LISP:ARRAY LISP:VECTOR LISP:SIMPLE-ARRAY)
|
||||
(LISP:IF (LISP:CONSP TYPE)
|
||||
(LET ((ELT-TYPE (CADR TYPE)))
|
||||
(SETQ TYPE-LENGTH (LISP:THIRD TYPE))
|
||||
(LISP:IF (LISP:CONSP TYPE-LENGTH)
|
||||
(SETQ TYPE-LENGTH (CAR TYPE-LENGTH)))
|
||||
(LISP:IF [AND ELT-TYPE (NOT (EQ ELT-TYPE 'LISP:*]
|
||||
ELT-TYPE
|
||||
T))
|
||||
T)))]
|
||||
(LISP:IF (AND (LISP:INTEGERP TYPE-LENGTH)
|
||||
(NOT (EQUAL TYPE-LENGTH LENGTH)))
|
||||
(LISP:ERROR "~D is not the length of type ~s" LENGTH TYPE))
|
||||
(LISP:IF ELEMENT-TYPE
|
||||
(MAKE-VECTOR LENGTH :ELEMENT-TYPE ELEMENT-TYPE)
|
||||
(LET ((EXPANDER (LISP::TYPE-EXPANDER BROAD-TYPE)))
|
||||
(LISP:IF EXPANDER
|
||||
(MAKE-SEQUENCE-OF-TYPE (LISP::TYPE-EXPAND TYPE EXPANDER)
|
||||
LENGTH)
|
||||
(LISP:ERROR "~S is a bad type specifier for sequences." TYPE))))])])
|
||||
|
||||
(LISP:DEFSETF LISP:ELT %%SETELT)
|
||||
|
||||
(LISP:DEFSETF LISP:SUBSEQ (SEQUENCE START &OPTIONAL END) (NEW-SEQUENCE)
|
||||
`(PROGN (LISP:REPLACE ,SEQUENCE ,NEW-SEQUENCE :START1 ,START :END1 ,END)
|
||||
,NEW-SEQUENCE))
|
||||
|
||||
(PUTPROPS CMLSEQBASICS FILETYPE LISP:COMPILE-FILE)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(LOCALVARS . T)
|
||||
)
|
||||
)
|
||||
(PUTPROPS CMLSEQBASICS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
Reference in New Issue
Block a user