Updated to remaining lisp; fasl files from source.

Resolves #1286.
2026-02-26 17:03:20 +00:00 · 2018-10-03 19:44:38 -07:00
parent b38f93b254
commit a92bc9d8da
11 changed files with 4596 additions and 3 deletions
--- a/src/lspsrc/vector.75
+++ b/src/lspsrc/vector.75
@@ -0,0 +1,324 @@
+;;;  VECTOR    				-*-Mode:Lisp;Package:SI;Lowercase:T-*-
+;;;  **************************************************************************
+;;;  *** MacLISP ******** VECTOR support **************************************
+;;;  **************************************************************************
+;;;  ******** (c) Copyright 1982 Massachusetts Institute of Technology ********
+;;;  **************************************************************************
+
+(herald VECTOR /74)
+
+;; This file cannot be run interpretively, due to the dependence upon
+;;  the SOURCE-TRANS being expanded while compiling -- if you *must*
+;;  try it interpretively, then just turn the SOURCE-TRANS's into
+;;  ordinary macros.
+
+(eval-when (eval compile)
+  (or (get 'SUBLOAD 'VERSION)
+      (load '((lisp) subload)))
+  (subload MACAID)
+  (subload UMLMAC)
+   ;; Remember, EXTMAC down-loads CERROR
+  (subload EXTMAC)
+  (subload DEFSETF)
+  (subload SUBSEQ)
+  (subload LOOP)
+
+  (setq USE-STRT7 'T MACROS () )
+  (setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED)
+
+ )
+
+
+(eval-when (eval load compile)
+    (subload EXTEND)
+    (cond ((status feature COMPLR) 
+	    (special VECTOR-CLASS)
+	    (*lexpr MAKE-VECTOR)))
+)
+
+(def-or-autoloadable FLUSH-MACROMEMOS DEFMAX)
+
+
+(define-loop-path (vector-elements vector-element)
+		  si:loop-sequence-elements-path
+		  (of from to below above downto in by)
+		  vref vector-length vector notype)
+
+
+;;;; Source-trans's necessary for compiling the subrs
+
+(eval-when (eval compile load)
+
+(defun si:VECTOR-SRCTRNS (x)
+  (let ((winp () )) 
+    (caseq (car x) 
+      (MAKE-VECTOR (if (= (length x) 2)
+		       (setq x `(SI:MAKE-EXTEND ,(cadr x) VECTOR-CLASS)
+			     winp 'T)))
+      ((VREF VSET) (setq x (cons (if (eq (car x) 'VREF)
+				     'SI:XREF
+				     'SI:XSET)
+				 (cdr x))
+			 winp 'T))
+      (VECTOR  (setq x `(SI:EXTEND VECTOR-CLASS ,.(cdr x)) winp 'T))
+      (VECTOR-LENGTH (setq x `(SI:EXTEND-LENGTH ,.(cdr x)) winp 'T)))
+    (values x winp)))
+
+  (and 
+    (status feature COMPLR)
+    (let (y)
+      (mapc '(lambda (x)
+	       (or (memq 'si:VECTOR-SRCTRNS (setq y (get x 'SOURCE-TRANS)))
+		   (putprop x (cons 'si:VECTOR-SRCTRNS y) 'SOURCE-TRANS)))
+	    '(VECTOR VECTOR-LENGTH VREF VSET MAKE-VECTOR))))
+)
+
+
+;;;; VECTORP,VREF,VSET,MAKE-VECTOR,VECTOR,VECTOR-LENGTH,SET-VECTOR-LENGTH
+
+(defun VECTORP (x) (eq (si:class-typep (class-of x)) 'VECTOR))
+
+(defun VREF (seq index)
+  (when *RSET
+	(let ((cnt 1))
+	  (check-subsequence (seq index cnt) 'VECTOR 'VREF)))
+  (vref seq index))
+
+(defsetf VREF ((() seq index) val) ()
+   `(VSET ,seq ,index ,val))
+
+(defun VSET (seq index val)
+  (when *RSET
+	(let ((cnt 1))
+	  (check-subsequence (seq index cnt) 'VECTOR 'VREF)))
+  (vset seq index val)
+  seq)
+
+
+(defun MAKE-VECTOR (n &optional fill) 
+   (when *RSET (check-type n #'SI:MAX-EXTEND-SIZEP 'MAKE-VECTOR))
+   (let ((v (make-vector n)))
+     (if fill 
+	 (do ((i 0 (1+ i)))
+	     ((>= i n))
+	   (vset v i fill)))
+     v))
+
+(defun VECTOR n
+   (when *RSET (check-type n #'SI:MAX-EXTEND-SIZEP 'VECTOR))
+   (let ((v (make-vector n)))
+     (dotimes (i n) (vset v i (arg (1+ i))))
+     v))
+
+
+(defun VECTOR-LENGTH (seq)
+  (when *RSET (check-type seq #'VECTORP 'VECTOR-LENGTH))
+  (vector-length seq))
+
+
+
+(defun SET-VECTOR-LENGTH (seq newsize)
+  (when *RSET
+	(let ((i 0))
+	  (check-subsequence (seq i newsize) 'VECTOR 'SET-VECTOR-LENGTH)))
+   ;; What a crock!
+  (do ((max (1- (hunksize seq)))
+       (i (+ 2 newsize))
+       (crock (munkam #o777777)))
+      ((> i max))
+    (rplacx i seq crock))
+  seq)
+
+
+(defun |&restv-ify/|| (n &aux allp)
+    ;; Cooperates with output of DEFUN& to snarf args off pdl and into a VECTOR
+   (declare (fixnum n arg-offset))
+   (cond ((< n 0) (setq n (- n)))	;Take ABS of 'n'
+	 ('T (setq allp 'T)))		;Are we getting all the args?
+   (let ((v (make-vector n))
+	 (arg-offset (if allp 
+			 1 
+			 (- (arg () ) n -1))))
+     (dotimes (i n) (vset v i (arg (+ i arg-offset))))
+     v))
+
+(defmacro dolist-with-index ((var form index) &rest body &aux dummy decls)
+   (setq decls (cond ((and body 
+			   (not (atom (car body)))
+			   (eq (caar body) 'DECLARE))
+		      (prog2 () (cdar body) (pop body)))))
+   (cond (index (push `(FIXNUM ,INDEX) decls)
+		(setq index (ncons `(,INDEX 0 (1+ ,INDEX)) ))))
+   (and decls (setq decls  (ncons `(DECLARE ,.decls))))
+   (si:gen-local-var dummy)
+   `(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index )
+	((NULL ,DUMMY))
+      ,@decls
+      (SETQ ,VAR (CAR ,DUMMY))  ,.BODY))
+
+
+(defun |#-MACRO-/(| (x) 		;#(...) is VECTOR notation
+   (let ((form (read)) v)
+     (if (or x 
+	     (and form (atom form))
+	     (and (setq x (cdr (last form))) (atom x)))
+	 (error "Not a proper list for #/(" (list x form)))
+     (setq v (make-vector (length form)))
+     (dolist-with-index (item form i) (vset v i item))
+     v))
+
+
+(defvar /#-MACRO-DATALIST () )
+
+;; An open-coding of SETSYNTAX-SHARP-MACRO
+(let ((x (get 'SHARPM 'VERSION))
+      (y '(#/( T MACRO . |#-MACRO-/(| )))
+  (cond ((and x (alphalessp x '/82))
+	  (push y /#-MACRO-DATALIST))
+	('T (if (null (setq x (assoc READTABLE /#-MACRO-DATALIST)))
+		(push (setq x `(,READTABLE . () )) /#-MACRO-DATALIST))
+	    (push y (cdr x)))))
+
+
+;;;; DOVECTOR, VECTOR-POSASSQ, SI:COMPONENT-EQUAL, and SI:SUBST-INTO-EXTEND
+
+(defmacro DOVECTOR ((var form index) &rest body &aux (cntr index) vec vecl)
+   (or cntr (si:gen-local-var cntr))
+   (si:gen-local-var vec)
+   (si:gen-local-var vecl)
+   `(LET ((,vec ,form))
+      (DO ((,cntr 0 (1+ ,cntr))
+	   (,var)
+	   (,vecl (VECTOR-LENGTH ,vec)))
+	  ((= ,cntr ,vecl))
+	(DECLARE (FIXNUM ,cntr ,vecl))
+	,.(and var (symbolp var) `((SETQ ,var (VREF ,vec ,cntr))))
+	,.body)))
+
+(def-or-autoloadable GENTEMP MACAID)
+
+(defun VECTOR-POSASSQ (x v)
+   (dovector (e v i) (and (pairp e) (eq x (car e)) (return i))))
+
+
+;; called by EQUAL->VECTOR-CLASS and EQUAL->STRUCT-CLASS
+(defun SI:COMPONENT-EQUAL (ob other)
+   (let ((l1 (si:extend-length ob)) 
+	 (l2 (si:extend-length other)))
+     (declare (fixnum l1 l2 i))
+     (and (= l1 l2)
+	  (do ((i 0 (1+ i)))
+	      ((= i l1) 'T)
+	    (if (not (equal (si:xref ob i) (si:xref other i)))
+		(return () ))))))
+
+;; called by SUBST->VECTOR-CLASS and SUBST->STRUCT-CLASS
+(defun SI:SUBST-INTO-EXTEND (ob a b)
+   (let ((l1 (si:extend-length ob)))
+     (declare (fixnum l1 i))
+     (do ((i 0 (1+ i))
+	  (newob (si:make-extend l1 (class-of ob))))
+	 ((= i l1) newob)
+       (si:xset newob i (subst a b (si:xref ob i))))))
+
+
+;;;; Some methods
+
+(defmethod* (EQUAL VECTOR-CLASS) (obj other-obj)
+   (cond ((not (vectorp obj)) 
+	   (+internal-lossage 'VECTORP 'EQUAL->VECTOR-CLASS obj))
+	 ((not (vectorp other-obj)) () )
+	 ((si:component-equal obj other-obj))))
+
+(defmethod* (SUBST VECTOR-CLASS) (ob a b)
+   (si:subst-into-extend ob a b))
+
+(DEFVAR VECTOR-PRINLENGTH () )
+(DEFVAR SI:PRINLEVEL-EXCESS '|#|)
+(DEFVAR SI:PRINLENGTH-EXCESS '|...|)
+
+(DEFMETHOD* (:PRINT-SELF VECTOR-CLASS) (OBJ STREAM DEPTH SLASHIFYP)
+  (DECLARE (FIXNUM LEN I DEPTH))	
+    ;Be careful where you put the declaration for LEN!
+  (LET ((LEN (VECTOR-LENGTH OBJ)))
+    (SETQ DEPTH (1+ DEPTH))
+    (SETQ STREAM (SI:NORMALIZE-STREAM STREAM))
+    (COND 
+      ((= LEN 0) (PRINC "#()" STREAM))
+      ((AND PRINLEVEL (NOT (< DEPTH PRINLEVEL))) 
+        (PRINC SI:PRINLEVEL-EXCESS STREAM))
+      ('T (PRINC "#(" STREAM)
+	  (DO ((I 0 (1+ I)) FL)
+	      ((= I LEN) )
+	    (IF FL (TYO #\SPACE  STREAM) (SETQ FL 'T))
+	    (COND ((OR (AND VECTOR-PRINLENGTH (NOT (> VECTOR-PRINLENGTH I)))
+		       (AND PRINLENGTH (NOT (> PRINLENGTH I))))
+		   (PRINC SI:PRINLENGTH-EXCESS STREAM)
+		   (RETURN () )))
+	    (PRINT-OBJECT (VREF OBJ I) DEPTH SLASHIFYP STREAM))
+	  (TYO #/) STREAM)))))
+
+(DEFMETHOD* (FLATSIZE VECTOR-CLASS) (OBJ PRINTP DEPTH SLASHIFYP
+				       &AUX (LEN (VECTOR-LENGTH OBJ)))
+  (AND DEPTH (SETQ DEPTH (1+ DEPTH)))
+  (COND ((ZEROP LEN) 3)
+	((AND DEPTH PRINLEVEL (NOT (< DEPTH PRINLEVEL))) 1)  ;?
+	(PRINTP (+ 2 (FLATSIZE-OBJECT (VREF OBJ 0)
+				      PRINTP
+				      DEPTH
+				      SLASHIFYP)))
+	('T (DO ((I (1- LEN) (1- I))
+		 (CNT 2 (+ CNT
+			   (FLATSIZE-OBJECT (VREF OBJ I)
+					    PRINTP
+					    DEPTH
+					    SLASHIFYP)
+			   1)))
+		((< I 0) CNT)
+		(DECLARE (FIXNUM I CNT))))))
+
+
+
+(DEFMETHOD* (SPRINT VECTOR-CLASS) (SELF N M)
+    (IF (= (VECTOR-LENGTH SELF) 0)
+	(PRINC "#()")
+	(PROGN (SETQ SELF (TO-LIST SELF))
+	       (PRINC '/#)
+	       (SPRINT1 SELF (GRCHRCT) M))))
+
+(DEFMETHOD* (GFLATSIZE VECTOR-CLASS) (OBJ)
+  (DO ((LEN (VECTOR-LENGTH OBJ))
+       (I 0 (1+ I))
+       (SIZE 2 (+ SIZE (GFLATSIZE (VREF OBJ I)))))
+      ((= I LEN)
+       (COND ((= LEN 0) 3)
+	     (T (+ SIZE LEN))))
+      (DECLARE (FIXNUM MAX I SIZE))))
+
+
+(DEFMETHOD* (SXHASH VECTOR-CLASS) (OB)
+   (SI:HASH-Q-EXTEND OB #,(sxhash 'VECTOR)))
+
+;;Someday we'd like this hook, but for now there is just the
+;; complr feature that lets them go out as hunks.  Also, DEFVST
+;; puts out a hunk with a computed value in the CDR which sill
+;; be the value of VECTOR-CLASS if it exists.
+;(DEFMETHOD* (USERATOMS-HOOK VECTOR-CLASS) (self)
+;   (list `(TO-VECTOR ',(to-list self))))
+
+
+(defmethod* (DESCRIBE VECTOR-CLASS) (ob stream level)
+  (declare (special SI:DESCRIBE-MAX-LEVEL))
+  (if (and (not (> level SI:DESCRIBE-MAX-LEVEL)) 
+	   (vectorp ob))
+      (format stream 
+	      "~%~vTThe vector ~S has ~D elements."
+	      level ob (vector-length ob))))
+
+
+(and (status status VECTOR) 
+     (sstatus VECTOR (list (get 'VECTORP 'SUBR) 
+			   (get 'VECTOR-LENGTH 'SUBR)
+			   (get 'VREF 'SUBR))))
+
+