Updated to remaining lisp; fasl files from source.

Resolves #1286.

src/lspsrc/exthuk.34

@@ -0,0 +1,121 @@
+;;;   EXTHUK			-*-Mode:Lisp;Package:SI;Lowercase:T-*-
+;;;   ****************************************************************
+;;;   *** MACLISP **** EXTended datatype scheme, compiler helper *****
+;;;   ****************************************************************
+;;;   ** (c) Copyright 1981 Massachusetts Institute of Technology ****
+;;;   ****************************************************************
+
+(herald EXTHUK /33)
+
+(eval-when (eval compile)
+  (or (get 'SUBLOAD 'VERSION)
+      (load '((lisp) subload)))
+  (subload EXTMAC)
+ )
+
+(declare #.`(SPECIAL ,.si:extstr-setup-classes))
+
+(defvar SI:SKELETAL-CLASSES () "At least it wont be unbound in Old lisps")
+
+(declare (own-symbol SI:XREF SI:XSET SI:EXTEND-LENGTH 
+		     SI:EXTEND SI:MAKE-EXTEND))
+
+
+
+(eval-when (eval compile load)
+   ;;COMPLR should already have MACAID pre-loaded
+(defun SI:INDEX+2-EXAMINE (h n &aux cnstntp)
+   ;;A helper function for running the SI:XREF/SI:XSET macroexpansions
+   ;;Presumes that arguments 'h' and 'n' have already been macroexpanded
+   ;;Also needs the function 'si:evaluate-number?' from SRCTRN file
+  (cond ((setq cnstntp (si:evaluate-number? n))
+	   ;;Constant numerical index
+	 (+ #.si:extend-q-overhead cnstntp))
+	((or (|constant-p/|| h) 
+	     (and (not (|side-effectsp/|| n)) 
+		  (not (|side-effectsp/|| h))))
+	 `(+ #.si:extend-q-overhead ,n))))
+)
+
+(defun SI:XSTUFF-expander (x)
+ (values 
+  (caseq (car x)
+    ((SI:XREF SI:XSET)
+      (if (< (length x) (if (eq (car x) 'SI:XREF) 3 4))
+	  (error "Wrong no args -- source-tran-expander" x))
+      (let ((h (macroexpand (cadr x)))
+	    (n (macroexpand (caddr x)))
+	    tmp)
+	(cond ((setq tmp (si:index+2-examine h n))
+	        (if (eq (car x) 'SI:XREF) 
+		    `(CXR ,tmp ,h) 
+		    `(RPLACX ,tmp ,h ,(cadddr x))))
+	      ((let* ((htmp (si:gen-local-var () "EX"))
+		      (ntmp (si:gen-local-var () "I"))
+		      (indx `(+ #.si:extend-q-overhead ,ntmp))
+		      (body (if (eq (car x) 'SI:XREF) 
+				`(CXR ,indx ,htmp)
+				`(RPLACX ,indx ,htmp ,(cadddr x)))))
+		 `((LAMBDA (,htmp ,ntmp) 
+		     (DECLARE (FIXNUM ,ntmp))
+		     ,body)
+		   ,h ,n))))))
+    ((SI:MAKE-EXTEND SI:MAKE-RANDOM-EXTEND) 
+       ;; This function MUST be open-compilable so that the 
+       ;;  output of DEFVST doesn't require the whole world!
+      (let ((size (cadr x))
+	    (clss (caddr x))
+	    (v (si:gen-local-var () "EX")))
+	`(LET ((,v (MAKHUNK (+ ,size #.si:extend-q-overhead))))
+	   (SETF #%(SI:EXTEND-CLASS-OF ,v) ,clss)
+	   (SETF #%(SI:EXTEND-MARKER-OF ,v) '**SELF-EVAL**) 
+	   ,v)))
+    ((EXTEND-LENGTH SI:EXTEND-LENGTH)
+      `(- (HUNKSIZE ,(cadr x)) #.si:extend-q-overhead))
+    (SI:EXTEND  `(HUNK '**SELF-EVAL** ,@(cddr x) ,(cadr x)))
+    (T (+internal-lossage 'SI:XSTUFF-expander 'SI:XSTUFF-expander x)))
+  'T))
+
+
+(let (z)
+  (mapc #'(lambda (x)
+	    (or (memq #'SI:XSTUFF-expander (setq z (get x 'SOURCE-TRANS)))
+		(putprop x (cons #'SI:XSTUFF-expander z) 'SOURCE-TRANS)))
+	'(SI:XREF SI:XSET SI:EXTEND-LENGTH EXTEND-LENGTH 
+	  SI:MAKE-EXTEND SI:MAKE-RANDOM-EXTEND SI:EXTEND)))
+ 
+
+
+
+;;Watch out for bootstrapping problems if SI:CLASS-INSTANCE-SIZE should 
+;;  ever change, or if ever EXTSTR-USERATOMS-HOOK is to be applicable
+;;  to objects other than hunks
+
+(defun EXTSTR-USERATOMS-HOOK (obj)
+  (declare (special SI:SKELETAL-CLASSES))
+  (cond ((not (hunkp obj)) () )		;all EXTENDs are hunks!!
+	((and (eq (si:extend-marker-of obj) SI:CLASS-MARKER)
+	      (= (hunksize obj) 
+		 #.(+ si:class-instance-size si:extend-q-overhead))
+	      (if (fboundp 'CLASSP) 
+		  (and (classp obj)
+		       (memq (si:class-name obj) '#.si:extstr-setup-classes))
+		  #.`(OR ,.(mapcar #'(lambda (x) `(EQ OBJ ,x)) 
+				   si:extstr-setup-classes))))
+	   ;;Special case for referencing class objects
+	 `((GET ',(si:class-name obj) 'CLASS)))
+	((and SI:SKELETAL-CLASSES (assq obj SI:SKELETAL-CLASSES))
+	   ;; Do we ever really want to get ourselves in this predicament?
+	  (let ((frob (assq obj SI:SKELETAL-CLASSES)))
+	    `((OR (GET ',(si:class-name obj) 'CLASS)
+		  (AND (GET 'EXTSTR 'VERSION)
+		       (SI:DEFCLASS*-2 ',(si:class-name obj)
+				       ',(si:class-typep obj)
+				       ',(si:class-var obj)
+				       ',(cadr frob)))))))
+	((and (fboundp 'EXTENDP) (extendp obj)) (send obj 'USERATOMS-HOOK))))
+
+(and (boundp 'USERATOMS-HOOKS)
+     (or (memq 'EXTSTR-USERATOMS-HOOK USERATOMS-HOOKS)
+	 (push 'EXTSTR-USERATOMS-HOOK USERATOMS-HOOKS)))
+

src/lspsrc/extmdf.29

@@ -0,0 +1,49 @@
+; -*-MIDAS-*-
+TITLE EXTMDF -- Midas definitions for CLASS fields
+
+DEFINE CDEF index,prefix,parity,long,short
+  prefix!short==index
+  DEFINE %!long ac1,obj
+    h!parity!rz ac1,prefix!short obj
+  TERMIN
+  DEFINE $!long ac1,obj
+    hr!parith!m ac1,prefix!short obj
+  TERMIN
+TERMIN
+
+IRPW SYMS,,[
+CLASS,CLS        ;; CLASS of this CLASS
+MARKER,MRK	 ;; Marker to distinguish classes from hunks
+SENDI,SND	 ;; LSUBR-like function to jump to for SENDs to instances
+SENDSYM,SNS	 ;; Original symbol or LAMBDA the LSUBR came from
+CALLI,CLI	 ;; Similar to SENDI but for function calling
+CALLSYM,CLS	 ;; ditto
+MAPMTH,MMT	 ;; MAP-OVER-METHODS SUBR
+MAPMSYM,MMS	 ;; MAP-OVER-METHODS SUBR's Symbol
+MAPCLS,MCL	 ;; MAP-OVER-CLASS SUBR
+MAPCSYM,MCL	 ;; MAP-OVER-CLASS SUBR's Symbol
+ADMTH,ADM	 ;; Add method routine.  FUNCALLed
+TYPEP,TYP	 ;; What to return to TYPEP (except in BD MacLisp)
+SUPER,SUP	 ;; List of superiors, in order of search
+NAME,NAM	 ;; Name of this class, short form of the var
+METHD,MTH	 ;; Table (or list) of Methods.  Interpreted by SENDI slot.
+ATTRI,ATR	 ;; PLIST of random information
+]
+IFE .irpcnt&1,	   CDEF \<.irpcnt/2>,CR$,R,SYMS	 ;Don't delete this comment
+.ELSE		   CDEF \<.irpcnt/2>,CL$,L,SYMS	 ;Or this one either!
+TERMIN
+
+IRPW SYMS,,[
+MNEXT,NXT	 ;; Next method in bucket chain
+MNAME,NAM	 ;; Method symbol, name of method
+MSUBR,SRB	 ;; LSUBR property for method, or trampoline to interpreted
+MFSYM,FSY	 ;; Name of method function, for reference or trampoline
+]
+IFE .irpcnt&1,	   CDEF \<.irpcnt/2>,MR$,R,SYMS	 ;This comment required
+.ELSE		   CDEF \<.irpcnt/2>,ML$,L,SYMS	 ;Do to MIDAS parsing stuff
+TERMIN
+
+;Local Modes: :::
+;Comment Column:17 :::
+;Comment Start:;;  :::
+;End: :::

src/lspsrc/gcdemn.14

@@ -0,0 +1,307 @@
+;;;   GCDEMN   				  		  -*-LISP-*-
+;;;   **************************************************************
+;;;   ***** MACLISP ******* Standard GC-DAEMON function ************
+;;;   **************************************************************
+;;;   ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
+;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
+;;;   **************************************************************
+
+;; Note that "HERALD" call is below, to insure that the addition
+;;  to GC-DAEMON has occured before the VERSION property is put
+;;  (HERALD GCDEMN /14)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This is a dynamic garbage collector daemon which tries to predict
+;;; consing in the various spaces based on past performance and thus to
+;;; set space sizes such that garbage collection is minimized.
+;;; 
+;;; The algorithm is from Henry Baker and the program is his with minor
+;;; modifications.  JONL maintained Baker's code between 1978 and 1980,
+;;; and PSZ made significant modifications on July 12, 1980.  GSB added
+;;; some type-declarations, and added a separater gc-statistics print
+;;; switch on Feb 6, 1981;  GSB and JONL added some efficiency hacks
+;;; to do less consing on Feb 6-7, 1981, and to use HERALD
+;;; GSB hacked the gc-statistics print switch to be more usable Feb. 19,
+;;; 1981;  the variable GC-DAEMON-PRINT should have as its value a variable
+;;; which will be SYMEVALed to see if the gc-daemon should print statistics.
+;;; By default its value is ^D, causing the gc-daemon to print statistics
+;;; when the Lisp gc does.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; For historical purposes, the original CGOL code is reproduced
+;;; here as commentary.  All running code is now in LISP
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (cgol)
+;; 
+;; declare(muzzled(t))	% Shut up about closed compilation. %
+;; 
+;; %	GC-daemon for optimal allocation.			%
+;; %	Described in AI Working Paper #142.			%
+;; %	set "alloc-mark-ratio" to a flonum between 0.2 and 5.0.	%
+;; 
+;; sstatus(who1,42.,"%",118.,0.)	% Set up "who" line on tv's.  %
+;; sstatus(gcwho,3.)
+;; who3 := "GCDEMN"
+;; 
+;; % Initialize property lists of space names.  %
+;; let gc_daemon=
+;;     '\spacelist;
+;;      (let alloct=nil.alloc(t);
+;;       for element in spacelist
+;; 	  do (let space = car(element),
+;; 		  freebefore = cadr(element),
+;; 		  freeafter = caddr(element),
+;; 		  sizebefore = cadddr(element),
+;; 		  sizeafter = car(cddddr(element));
+;; 	      % Initialize state of each space for gc-daemon.  %
+;; 	      accessible ofq space := sizeafter-freeafter;
+;; 	      % Make sure that we don't get a gc-overflow interrupt.  %
+;; 	      alloc([space,[max(512.,car(space of alloct) or sizeafter),
+;; 			    262143.,
+;; 			    if sizeafter>0 then 32. else 0.]])))'
+;;     in gc()
+;; 
+;; alloc_mark_ratio := 1.0 
+;; 
+;; special alloc_mark_ratio
+;; 
+;; define "GC-DAEMON" (spacelist);
+;;   let total_accessible = 0.0,
+;;       total_consed = 0.0;
+;;   % Go through spaces and accumulate consed and accessible
+;;     information.  %
+;;   for element in spacelist	    % Argument is "alist" of spaces. %
+;;       do (let space = car(element),	% Give names to parameters.  %
+;; 	      freebefore = cadr(element),
+;; 	      freeafter = caddr(element),
+;; 	      sizebefore = cadddr(element),
+;; 	      sizeafter = car(cddddr(element));
+;;  % Compute consed since last gc and accessible now for this space.  %
+;; 	 consed ofq space := sizebefore-freebefore-accessible ofq space;
+;; 	 total_consed := total_consed + consed ofq space;
+;; 	 accessible ofq space := sizeafter-freeafter;
+;; 	 total_accessible := total_accessible + accessible ofq space);
+;;   % Store total consed, total accessible and compute total free.  %
+;;   consed ofq 'total_storage' := total_consed;
+;;   accessible ofq 'total_storage' := total_accessible;
+;;   let total_free = alloc_mark_ratio * total_accessible;
+;;   free ofq 'total_storage' := total_free;
+;;   % Go through spaces and re-allocate where necessary.  %
+;;   for element in spacelist
+;;       do (let space = car element;
+;; 	  alloc_rate ofq space := consed ofq space / total_consed;
+;; 	  free ofq space := fix(total_free * alloc_rate ofq space);
+;; 	  let spcsize = accessible ofq space + free ofq space + 511.;
+;; 	     if spcsize>511. then alloc([space,[spcsize,262143.,32.]]))
+;; 
+;; gc_daemon := 'gc_daemon'
+;; 
+;; =exit
+ 
+
+(declare (setq USE-STRT7 T)
+	 (special GCDEMN-SETUP-1/|) )
+
+(defvar ALLOC-MARK-RATIO 1.0)
+(defvar FILL-STORAGE-FRACTION 0.5)
+; We SYMEVAL this to see if we want to print statistics.
+(defvar GC-DAEMON-PRINT '^D)
+
+(eval-when (eval compile)
+    (defmacro fix-to-float (x)
+	      `(float (fixnum-identity ,x)))
+    (defmacro float-to-fix (x)
+	      `(ifix (flonum-identity ,x)))
+    (defmacro defmaxmin (max-name min-name type
+			 &aux (v1 (gensym)) (v2 (gensym)))
+	
+	`(progn 'compile
+	   (defmacro ,max-name (arg1 arg2)
+		(list '(lambda (,v1 ,v2)
+			  (declare (,type ,v1 ,v2))
+			  (cond ((> ,v1 ,v2) ,v1) (t ,v2)))
+		      arg1 arg2))
+	   (defmacro ,min-name (arg1 arg2)
+		(list '(lambda (,v1 ,v2)
+			  (declare (,type ,v1 ,v2))
+			  (cond ((< ,v1 ,v2) ,v1) (t ,v2)))
+		      arg1 arg2))))
+    (defmaxmin max$ min$ flonum)
+    (defmaxmin max% min% fixnum)
+    )
+
+
+(defun GC-DAEMON-PRINT (space cons-rate oldgcsize marked gcsize spcsize)
+   ;; We print for each non-empty space the following information:
+   ;;  CONS-RATE	The % of conses since the last GC which were for
+   ;; 			this space.
+   ;;  OLDGCSIZE	Size of the space in words before GC.
+   ;;  MARKED		Number of words marked as "in use" by GC.
+   ;;  GCSIZE		Size in words recommended by daemon.
+   ;;  SPCSIZE (if present) Actual size of space if different from size.
+   ((lambda (base *nopoint f)
+       (setq cons-rate (fix (*$ cons-rate 100.0)))
+       (and (< (linel f)
+	       (+ (flatc space) (flatc cons-rate) (flatc oldgcsize)
+		  (flatc marked) (flatc gcsize) (flatc spcsize) 10.
+		  (charpos f)))
+	    (princ '|
+; | msgfiles))
+       (princ space msgfiles)
+       (princ '| | msgfiles)
+       (princ cons-rate msgfiles)
+       (princ '|%[| msgfiles)
+       (princ oldgcsize msgfiles)
+       (princ '|->| msgfiles)
+       (princ marked msgfiles)
+       (princ '|//| msgfiles)
+       (princ gcsize msgfiles)
+       (cond ((not (= spcsize gcsize))
+	      (princ '|//| msgfiles) (princ spcsize msgfiles)))
+       (princ '|]  | msgfiles))
+    10. t (cond ((or (memq tyo msgfiles) (and (not ^w) (memq t msgfiles)))
+		   tyo)
+		((car (delq t (append msgfiles nil))))
+		(t tyo))))
+
+
+
+(DEFUN BAKER-GC-DAEMON (SPACELIST)
+ ((LAMBDA (RUNTIME TOTAL-ACCESSIBLE TOTAL-CONSED MEMFREE)
+   (declare (fixnum runtime) (flonum total-accessible total-consed))
+   (MAPC
+    (FUNCTION
+     (LAMBDA (ELEMENT)
+      ((LAMBDA (SPACE FREEBEFORE FREEAFTER SIZEBEFORE SIZEAFTER)
+	; No point in declarations, they only pessimize the compiler,
+	; in this case.
+	(PUTPROP SPACE (- SIZEBEFORE FREEBEFORE (GET SPACE 'ACCESSIBLE))
+		 'CONSED)
+	(SETQ TOTAL-CONSED (+$ TOTAL-CONSED (fix-to-float (GET SPACE 'CONSED))))
+	(PUTPROP SPACE (- SIZEAFTER FREEAFTER) 'ACCESSIBLE)
+	(SETQ TOTAL-ACCESSIBLE (+$ TOTAL-ACCESSIBLE
+				   (fix-to-float (GET SPACE 'ACCESSIBLE)))))
+       (CAR ELEMENT) (CADR ELEMENT) (CADDR ELEMENT)
+       (CADDDR ELEMENT) (CAR (CDDDDR ELEMENT)))))
+    SPACELIST)
+   (PUTPROP 'TOTAL-STORAGE TOTAL-CONSED 'CONSED)
+   (PUTPROP 'TOTAL-STORAGE TOTAL-ACCESSIBLE 'ACCESSIBLE)
+   ((LAMBDA (TOTAL-FREE alloct ALLOC-LIST 
+	     ALLOC-LIST-1 SPACE-HACK SPACE-HACK-1)
+     (declare (flonum total-free))
+     (PUTPROP 'TOTAL-STORAGE TOTAL-FREE 'FREE)
+     (and (symeval gc-daemon-print)
+      ((lambda (base *nopoint)
+	; Kludge:  if the GC printed, we do NOT want an extra newline;  but
+	; if it do not, we need to print one ourselves.
+	(or ^d (terpri msgfiles))
+	(princ '|;GC-DAEMON: cons-rate%[oldgcsize->marked//gcsize//spcsize]
+; Consed=|
+	       msgfiles)
+	(princ (fix total-consed) msgfiles)
+	(princ '|, Marked=| msgfiles)
+	(princ (fix total-accessible) msgfiles)
+	(princ '|, Allocated//Marked=| msgfiles)
+	(princ alloc-mark-ratio msgfiles)
+	(princ '|, Memfree= | msgfiles)
+	(princ memfree msgfiles)
+	(princ '|
+; | msgfiles))
+       10. t))
+     (MAPC
+      (FUNCTION
+       (LAMBDA (ELEMENT)
+	((LAMBDA (SPACE)
+	  ((lambda (alloc-rate)
+	       (declare (flonum alloc-rate))
+	       (putprop space alloc-rate 'alloc-rate)
+	       (putprop space (fix (*$ total-free alloc-rate)) 'free))
+	   (//$ (fix-to-float (get space 'consed)) total-consed))
+	  ((LAMBDA (SPCSIZE)
+	    (declare (fixnum spcsize))
+	    (and (symeval gc-daemon-print)
+		 (get alloct space)
+		 (gc-daemon-print
+		  space
+		  (get space 'alloc-rate)
+		  (car (get alloct space))
+		  (get space 'accessible)
+		  (* 512. (// spcsize 512.))
+		  (status spcsize space)))
+	    (COND ((GREATERP SPCSIZE 511.)
+		   (OR ALLOC-LIST
+		       (SETQ ALLOC-LIST
+			     (LIST NIL (SETQ ALLOC-LIST-1
+					     (LIST NIL 262143. NIL)))
+			     SPACE-HACK
+			     (LIST 'SPCSIZE
+				   (CONS 'QUOTE (SETQ SPACE-HACK-1
+						      (LIST NIL))))))
+		   (rplaca space-hack-1 space)
+		   (RPLACA
+		      (CDDR (RPLACA ALLOC-LIST-1
+				    (max% SPCSIZE
+					  (apply 'status space-hack))))
+		      (cond ((eq space 'list) 200.) (t 32.)))
+		   (ALLOC (RPLACA ALLOC-LIST SPACE)))))
+	   (+ (GET SPACE 'ACCESSIBLE) (GET SPACE 'FREE) 511.)))
+	 (CAR ELEMENT))))
+      SPACELIST)
+     (and (symeval gc-daemon-print) (terpri msgfiles)))
+    (min$ (*$ ALLOC-MARK-RATIO TOTAL-ACCESSIBLE)
+	  (*$ (fix-to-float memfree) fill-storage-fraction))
+    (cons nil (alloc t)) NIL NIL NIL NIL)
+   ; Finally, add our runtime into the total gc-time.
+   (setq runtime (- (status gctime) runtime))
+   (sstatus gctime (+ (runtime) runtime))
+   )
+  (runtime) 0.0 0.0 (status memfree))) 
+
+
+
+
+;; This function takes relatively little space, in comparison to all that
+;;  needed for the names of the variables used.  If run as expr code,
+;;  these symbols would never go away.
+
+(defun GCDEMN-SETUP-1/| (x)
+  (let (((space freebefore freeafter sizebefore sizeafter) x))
+    ;;The variable GCDEMN-SETUP-1/| has been set to `(() ,.(alloc t))
+    (putprop space (- sizeafter freeafter) 'ACCESSIBLE)
+    (let ((spacesize (or (car (get GCDEMN-SETUP-1/| space))
+			 sizeafter))
+	  (spacemin (cond ((not (> sizeafter 0)) () )
+			  ((eq space 'LIST) 200.)
+			  (32.))))
+      (if (< spacesize 512.) (setq spacesize 512.))
+      (alloc `(,space (,spacesize 262143. ,spacemin))))))
+
+(cond 
+     ;;If this file is loaded more than once, then don't 'push' onto
+     ;; the GC-DAEMON variable again.
+  ((or (get 'GCDEMN 'VERSION) (eq gc-daemon 'baker-gc-daemon)))
+  (T (cond ((status SSTATUS GCWHO)
+	    (sstatus WHO1 42. '% 118. 0.) 
+	    (sstatus GCWHO 3.) 
+	    (sstatus WHO3 'GCDEMN) ))
+       ;;; Initially set things up
+     (let ((GCDEMN-SETUP-1/| `(() ,.(alloc t)))
+	   (GC-DAEMON #'(lambda (z) (mapc #'GCDEMN-SETUP-1/| z))) )
+       (gc))
+     (setq GC-DAEMON 
+	   (cond ((null GC-DAEMON)  'BAKER-GC-DAEMON)
+		 ((let ((x (gensym)))
+		    `(LAMBDA (,x) 
+			(,.(cond ((or (symbolp gc-daemon)
+				      (and (not (atom gc-daemon))
+					   (eq (car gc-daemon) 'LAMBDA)))
+				  `(,gc-daemon))
+				 (`(FUNCALL ',gc-daemon)))
+			   ,x)
+			(BAKER-GC-DAEMON ,x)))))) ))
+
+(herald GCDEMN /14)

src/lspsrc/gfile.422

@@ -0,0 +1,335 @@
+
+
+;;;   -*-LISP-*-
+;;;   ***********************************************************************
+;;;   ***** Maclisp ****** S-expression formatter for files (grind) *********
+;;;   ***********************************************************************
+;;;   ** (c) Copyright 1980 Massachusetts Institute of Technology ***********
+;;;   ****** this is a read-only file! (all writes reserved) ****************
+;;;   ***********************************************************************
+;;; This version of Grind works in both ITS Maclisp and Multics Maclisp
+;;; GFILE - fns for pretty-printing and grinding files.
+
+(eval-when (eval compile)
+	   (or (status nofeature MACLISP)
+	       (status macro /#)
+	       (load '((LISP) SHARPM)))
+)
+
+(herald GRIND /422)
+
+(declare (array* (notype (gtab/| 128.)))
+	 (special merge readtable grindreadtable remsemi ~r
+		  grindpredict grindproperties grindef predict
+		  grindfn grindmacro programspace topwidth 
+		  grindlinct global-lincnt /; /;/; user-paging form
+		  prog? n m l h arg chrct linel pagewidth gap comspace
+		  grindfill nomerge comnt /;/;? ^d macro unbnd-vrbl
+		  cnvrgrindflag outfiles infile stringp)
+	 (*expr form topwidth programspace pagewidth comspace
+		nomerge remsemi stringp)
+	 (*fexpr trace slashify unslashify grindfn grindmacro
+		 unreadmacro readmacro grindef)
+	 (*lexpr merge predict user-paging grindfill testl)
+	 (mapex t)
+	 (genprefix gr+)
+	 (fixnum nn
+		 mm
+		 (grchrct)
+		 (newlinel-set fixnum)
+		 (prog-predict notype fixnum fixnum)
+		 (block-predict notype fixnum fixnum)
+		 (setq-predict notype fixnum fixnum)
+		 (panmax notype fixnum fixnum)
+		 (maxpan notype fixnum fixnum)
+		 (gflatsize))) 
+
+
+
+
+(prog () 							       ;some initializations
+      (and (not (boundp 'grind-use-original-readtable))
+	   (setq grind-use-original-readtable t))
+      (and (or (not (boundp 'grindreadtable))			       ;readtable (default).
+	       (null grindreadtable))
+	   ((lambda (readtable) (setsyntax 12. 'single ())	       ;^l made noticeable.
+				(setsyntax '/;
+					   'splicing 
+					   'semi-comment)) 
+	        (setq grindreadtable
+		      (*array ()
+			      'readtable
+			      grind-use-original-readtable))))
+      (setq macro '/; 
+	    /; (copysymbol '/; ()) 
+	    /;/; (copysymbol '/;/; ()))
+      (setq grindlinct 8. global-lincnt 59. comnt () /;/;? ())
+      (setq stringp (status feature string))
+)
+
+
+;;; Grinds and files file.
+(defun grind fexpr (file)
+      ((lambda (x) 
+	  (cond ((and stringp (stringp (car file))))	;already filed.
+		(t (cond ((not (status feature its))
+			  (cond ((status feature DEC20)
+				 (setq x (append (namelist x) () ))
+				 (rplacd (cddr x) () ))
+				((probef x) (deletef x)))))
+		   (apply 'ufile x)))
+	   file)
+	 (apply 'grind0 file)))
+
+ (defun grind0 fexpr (file) 					       ;grinds file and returns file
+	      (or (status feature grindef)
+		  (funcall autoload (cons 'grindef (get 'grindef 'autoload))))
+	(prog (remsemi linel *nopoint readtable base l ^q ^r ^w ^d 
+	       outfiles eof n /;/;? comnt terpri) 
+	      (setq base 10. linel programspace 
+		    readtable grindreadtable remsemi t)
+	      (cond
+	       ((and stringp (stringp (car file)))
+		(inpush (openi (car file)))
+		(setq 
+		 outfiles
+		 (list
+		  (openo
+		   (mergef
+		    (cond ((null (cdr file))
+			   (princ '|/îFiling as !GRIND OUTPUT |)
+			   '(* /!GRIND OUTPUT))
+			  ((cadr file)))
+		    (cons (car (namelist ())) '*) )))))
+	       ('t (apply (cond ((status feature sail) 'eread) ('uread))
+			  (cond ((and (null (cdr file)) (symbolp (car file)))
+				 (car file))
+				((and (status feature sail) 
+				      (cadr file)
+				      (eq (cadr file) 'dsk))
+				 (cons (car file) (cons  '| | (cdr file))))
+				('t file)))
+		   (uwrite)))
+	      (setq eof (list ()) n topwidth)
+	      (setq ^q t ^r t ^w t grindlinct global-lincnt)
+	 read (and (= (tyipeek 47791616. -1) 
+		      59.)			  ;catch top-level splicing macro
+		   (readch)
+		   (cond ((eq (car (setq l (car (semi-comment)))) /;)
+			  (rem/;)
+			  (go read))
+			 (t (go read1))))
+	      (and (null ^q) (setq l eof) (go read1))		       ;catch eof in tyipeek
+	      (and (eq (car (setq l (read eof))) /;)		       ;store /; strings of /; comments.
+		   (rem/;)
+		   (go read))
+	 read1(prinallcmnt)					       ;print stored /; comments
+	      (or (eq eof l) (go process))
+	 exit (terpri)
+	      (setq ~r ())
+	      (and stringp 
+		   (stringp (car file))
+		   (close (car outfiles)))			       ;won't get ufile'd
+	      (return file)
+	 process
+	      (cond ((eq l (ascii 12.))				       ;formfeed read in ppage mode
+		     (or user-paging (go read))			       ;ignore ^l except in user-paging mode.
+		     (and (< (tyipeek 50167296. -1) 0)
+			  (go exit))					;any non-trivial characters before eof?
+		     (terpri)
+		     (grindpage)
+		     (setq /;/;? t)
+		     (go read))
+		    ((eq (car l) /;/;)				       ;toplevel ;;... comment
+		     (newlinel-set topwidth)
+		     (or /;/;? (= linel (grchrct)) (turpri) (turpri))  ;produces  blank line preceding new
+		     (rem/;/;)					       ;block of /;/; comments. (turpri is
+		     (newlinel-set programspace)		       ;already in rem/;/;).  a total of 3
+		     (go read)))				       ;turpri's are necessary if initially
+	      (fillarray 'gtab/| '(()))				       ;chrct is not linel, ie we have just
+	      (cond (user-paging (turpri) (turpri))		       ;finished a line and have not yet cr.
+		    ((< (turpri)
+			(catch (\ (panmax l (grchrct) 0.) 60.)))       ;clear hash array
+		     (grindpage))
+		    ((turpri)))
+	      (cond ((eq (car l) 'lap) (lap-grind))
+		    ((sprint1 l linel 0.) (prin1 l)))
+	      (tyo 32.)							 ;prevents toplevel atoms from being
+	      (go read))) 					       ;accidentally merged by being separated only by
+								       ;cr.
+
+
+(defun newlinel-set (x) 
+    (setq chrct (+ chrct (- x linel))
+	  linel x))
+
+(putprop /; '(lambda (l n m) 0.) 'grindpredict) 
+
+(putprop /;/; '(lambda (l n m) 1.) 'grindpredict) 
+
+;;semi-colon comments
+
+(defun rem/; () 
+       (prog (c retval) 
+	a    (cond ((atom l) (return retval))
+		   ((eq (car l) /;)
+		    (setq c (cdr l))
+		    (setq retval 'car)
+		    (setq l ()))
+		   ((and (null (atom (car l))) (eq (caar l) /;))
+		    (setq c (cdar l))
+		    (setq retval 'caar)
+		    (setq l (cdr l)))
+		   (t (cond ((and (eq retval 'caar)		       ;look ahead to separate comments.
+				  (cdr l)
+				  (null (atom (cdr l)))
+				  (null (atom (cadr l)))
+				  (eq (caadr l) /;))
+			     (prinallcmnt)
+			     (indent-to n)))
+		      (return retval)))
+	b    (cond ((null comnt) (setq comnt c))
+		   ((< comspace (length comnt)) (turpri) (go b))
+		   ((nconc comnt (cons '/  c))))
+	     (go a))) 
+
+
+(defun rem/;/; () 
+       (prog (c retval) 
+	a    (cond ((atom l)
+		    (and (eq retval 'caar) (indent-to n))
+		    (return retval))
+		   ((eq (car l) /;/;)
+		    (setq c (cdr l))
+		    (setq retval 'car)
+		    (setq l ()))
+		   ((and (null (atom (car l))) (eq (caar l) /;/;))
+		    (setq c (cdar l))
+		    (setq retval 'caar)
+		    (setq l (cdr l)))
+		   (t (and (eq retval 'caar) (indent-to n))	       ;restore indentation for upcoming code
+		      (return retval)))
+	     (prinallcmnt)
+	     (and (null /;/;?) (turpri))
+	     (prog (comnt pagewidth comspace macro) 
+		   (setq comnt c)
+		   (and (or (memq (car c) '(/; *))
+			    (null merge))			       ;nomerge.  update pagewidth, comspace
+			(setq /;/;? '/;/;/;)			       ;appropriate for a total line of
+			(setq pagewidth topwidth 		       ;topwidth
+			      comspace (+ n (- topwidth linel)))
+			(go prinall))
+		   (setq pagewidth linel)
+		   (cond ((eq /;/;? /;/;)			       ;preceding comnt.  merge.
+			  (setq comnt (cons '/  comnt))
+			  (setq macro (ascii 0.))
+			  (setq comspace (grchrct))
+			  (prin50com))
+			 ((setq /;/;? /;/;)))
+		   (setq comspace n)
+	      prinall
+		   (setq macro /;/;)
+		   (prinallcmnt))
+	     (tj6 c)
+	     (go a))) 
+
+(defun tj6 (x) 							       ;tj6 commands: ;;*--- or ;;*(...) (...)
+       (and
+	(eq (car x) '*)
+	(setq x (cdr x))
+	(turpri)
+	(cond
+	 ((errset
+	   (cond ((atom (car (setq x
+				   (readlist (cons '/(
+						   (nconc x
+							  '(/))))))))
+		  (eval x))
+		 ((mapc 'eval x)))))
+	 ((error '/;/;*/ error x 11.))))) 
+
+
+(defun prin50com () 						       ;prints one line of ; comment
+       (prog (next)
+	   (newlinel-set pagewidth)				       ;update linel, chrct for space of pagewidth.
+	   (prog (comnt) (indent-to comspace))
+	   (princ macro)
+	   pl
+	   (cond ((null comnt) (return ()))
+		 ((eq (car comnt) '/ )
+		  (setq comnt (cdr comnt))
+		  (setq next
+			(do ((x comnt (cdr x)) (num 2. (1+ num)))      ;number of characters till next space.
+			    ((or (null x) (eq (car x) '/ ))
+			     num)))
+		  (cond ((and (or (eq macro /;) (eq /;/;? /;/;))
+			      grindfill 
+			      (= next 2.)
+			      (go pl)))
+			((and (not (eq macro (ascii 0.)))
+			      (> next comspace)))
+			((< (grchrct) next) (return ())))
+		  (tyo 32.)
+		  (go pl))
+		 ((> (grchrct) 0.)
+		  (princ (car comnt))
+		  (and (or (eq macro /;) (eq /;/;? /;/;))
+		       grindfill
+		       (eq (car comnt) '/.)
+		       (eq (cadr comnt) '/ )
+		       (tyo 32.)))
+		 (t (return ())))
+	   (setq comnt (cdr comnt))
+	   (go pl))
+		(newlinel-set programspace)) 		       ;may restore chrct to be negative.
+
+(defun prinallcmnt () (cond (comnt (prin50com) (prinallcmnt))))       ;prints \ of ; comment
+
+(defun semi-comment () 					       ;converts ; and ;; comments to exploded
+       (prog (com last char) 					       ;lists
+	     (setq com (cons /; ()) last com)
+	     (setq char (readch))				       ;decide type of semi comment
+	     (cond ((eq char '/
+) (return (list com)))
+		   ((eq char '/;) (rplaca last /;/;))
+		   ((rplacd last (cons char ()))
+		    (setq last (cdr last))))
+	a    (setq char (readch))
+	     (cond ((eq char '/
+) (return (list com)))
+		   ((rplacd last (cons char ()))
+		    (setq last (cdr last))
+		    (go a))))) 
+
+
+(defun grindcolmac () (list ': (read))) 
+
+(defun grindcommac () (list '/, (read))) 
+
+(defun grindatmac () (cons '@ (read))) 
+
+(defun grindexmac () 
+       (prog (c f) 
+	     (setq c (grindnxtchr))
+	ta   (cond ((setq f (assq c '((" /!") (@ /!@) ($ /!$))))
+		    (tyi)
+		    (return (cons (cadr f) (read))))
+		   ((setq f (assq c
+				  '((? /!?) (/' /!/') (> /!>) (/, /!/,)
+				    (< /!<) (/; /!/;))))
+		    (tyi)
+		    (setq f (cadr f)))
+		   (t (setq c (error 'bad/ /!/ macro
+				     c
+				     'wrng-type-arg))
+		      (go ta)))
+	     (return (cond ((grindseparator (grindnxtchr))
+			    (list f ()))
+			   ((atom (setq c (read))) (list f c))
+			   (t (cons f c)))))) 
+
+(defun grindnxtchr () (ascii (tyipeek))) 
+
+(defun grindseparator (char) (memq char '(| | |	| |)|)))	;space, tab, rparens	
+
+(sstatus feature grind)

src/lspsrc/querio.51

@@ -0,0 +1,213 @@
+;;; QUERIO    					    -*-Mode:Lisp;Package:SI-*-
+;;; **************************************************************************
+;;; ***** MACLISP ****** Build a Bi-directional SFA for Queries to User ******
+;;; **************************************************************************
+;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
+;;; ************ this is a read-only file! (all writes reserved) *************
+;;; **************************************************************************
+
+
+(herald QUERIO /51)
+
+
+(include ((lisp) subload lsp))
+
+(eval-when (eval compile)
+  (subload UMLMAC)
+  )
+
+
+;; Used also by CERROR file
+(defun si:FRESH-LINIFY (stream)
+  (if (and (sfap stream)
+	   (memq 'FRESH-LINE (sfa-call stream 'WHICH-OPERATIONS () )))
+       ;; If the command can be "passed down", then do so
+      (sfa-call stream 'FRESH-LINE () )
+       ;; Otherwise, just try a cursorpos 'A.
+      (cursorpos 'A stream)))
+
+(defun si:SPREAD-CURSORPOS (data out)
+  (caseq (length data)
+    (0 (cursorpos out))		 ;0 extra arg: Read pos
+    (1 (cursorpos (car data) out))	 	;1 more arg : Hac some
+    (T (cursorpos (car data) (cadr data) out))	; Set pos
+    ))
+
+
+
+(defvar SI:QUERY-IO-EXTRA-OPTIONS () 
+  "Used to communicate to the SFA-function whether or not there are
+   certain methods in the real file arrays (CURSORPOS, RUBOUT, ??)")
+(defvar SI:QUERY-IO-NEW-LISP (ALPHALESSP "2090" (STATUS LISPV))) 
+
+
+(defun GEN-QUERY-SLOTS macro (l)
+  (pop l)
+  (setq no-of-QUERY-IO-slots (length l))
+  `(PROGN 'COMPILE 
+	  ,.(do ((ll l (cdr ll)) (i 0 (1+ i)) (z))
+		((null ll) z)
+	      (push `(DEFUN ,(symbolconc '|QUERY-IO-| (car ll)) MACRO (X)
+			       `(SFA-GET ,(CADR X) ,,i))
+		    z))))
+
+ ;; makes things like   (defmacro QUERY-IO-input (x) `(SFA-GET ,x 1))
+(gen-query-slots output input omode imode whichops putbacklist) 
+
+(defun BI-DIRECTIONAL-CORRESPONDENT macro (x) `(SFA-GET ,(cadr x) 'XCONS))
+
+(defun cons-a-QUERY-IO macro (l)
+  (pop l)
+  (let ((x (or (get l 'IN) 
+	       '(IF (STATUS STATUS TTYIFA) (STATUS TTYIFA) TYI)))
+	(y (get l 'OUT))
+	z setout in out)
+    (si:gen-local-var in "in")
+    (si:gen-local-var out "out")
+    (si:gen-local-var z)
+    (setq setout `(SETQ ,out (STATUS TTYCONS ,in)))
+    (if y (setq setout `(OR ,out ,setout)))
+    `(LET ((,in ,x) (,out ,y) ,z)
+       ,setout 
+       (SETQ SI:QUERY-IO-EXTRA-OPTIONS 
+	     (APPEND (CDR (STATUS FILEMODE ,out))
+		      ;; FILEPOS currently only gets you the output data
+		     (DELQ 'FILEPOS (APPEND (CDR (STATUS FILEMODE ,in)) () ))))
+       (SETQ ,z (SFA-CREATE 'QUERY-IO-HANDLER ,no-of-QUERY-IO-slots 'QUERY-IO))
+       (SETF (QUERY-IO-input ,z) ,in)
+       (SETF (QUERY-IO-output ,z) ,out)
+       (SETF (QUERY-IO-omode ,z) (STATUS FILEMODE ,out))
+       (SETF (QUERY-IO-imode ,z) (STATUS FILEMODE ,in))
+        ;; For newer lisps, this permits the LISP toplevel routines to know
+        ;;  that it's a bi-directional device, and probably the echo of a 
+        ;;  <cr> inputted will suffice instead of also doing a (TERPRI).
+       (AND SI:QUERY-IO-NEW-LISP 
+	    (SETF (BI-DIRECTIONAL-CORRESPONDENT ,z) ,z))
+       ,z)))
+
+
+
+
+(defun QUERY-IO-HANDLER (self op data &aux (in   (QUERY-IO-input self))
+					   (out  (QUERY-IO-output self))
+					   (bufl (QUERY-IO-putbacklist self)))
+  (cond 
+    ((eq op 'UNTYI) 
+       ;; For old lisps, without the UNTYI function, we support UNTYI by just
+       ;;  keeping a list of the characters sent back.  Note that we could 
+       ;;  support a msg to store and retrieve this slot, and thus facilitate
+       ;;  a user writing a TTYBUFFER function which could keep separate from
+       ;;  the base-level TYI.
+      (if (not SI:QUERY-IO-NEW-LISP) 
+	  (setf (QUERY-IO-putbacklist self) (cons data bufl))
+	  (untyi data in)))
+    ((eq op 'TYI) 
+      (if (and (not SI:QUERY-IO-NEW-LISP) bufl)
+	  (progn (pop bufl data) 
+		 (setf (QUERY-IO-putbacklist self) bufl)
+		 data)
+	  (tyi data in)))
+    ((cond ((memq op '(TYO PRINT PRINC)))
+	   ((memq op '(READ READLINE))
+	     (setq out in)
+	     'T))
+       ;; Several trivial operations are just "passed down" directly to 
+       ;;  the appropriate part of the sfa.
+      (funcall op data out))
+    ((caseq op 
+	(CURSORPOS  
+		(if (memq 'CURSORPOS (cdr (QUERY-IO-omode self)))
+		    (si:spread-cursorpos data out)
+		     ;; Just do nothing now if output side can't do CURSORPOS
+		    ))
+	(TYIPEEK    (if (and (not SI:QUERY-IO-NEW-LISP) bufl)
+			(car bufl)
+			(tyipeek data in -1)))
+	(OPEN       (open in data) (open out data))
+	(CLOSE      (close in) (close out))
+	(RUBOUT     (if (memq 'RUBOUT (cdr (QUERY-IO-omode self)))
+			(rubout data out)))
+	(FRESH-LINE (SI:FRESH-LINIFY out))
+	((CHARPOS LINEL PAGEL PAGENUM FILEPOS 
+	  CLEAR-OUTPUT FORCE-OUTPUT) 
+	   ;; Notice how these funtions only pay attention to the output side
+	   ;;  of the bi-directional sfa.  Also, The latter 2 better have had
+	   ;;  the third sfa argument ("data") sent as ().
+	  (lexpr-funcall op out data))
+	(LISTEN 
+	  (+ (cond ((and (not SI:QUERY-IO-NEW-LISP) bufl)
+		     (length bufl))
+		   (0))
+	     (listen in)))
+	(CLEAR-INPUT 
+	  (if (and (not SI:QUERY-IO-NEW-LISP) bufl) 
+	      (setf (QUERY-IO-putbacklist self) () ))
+	  (CLEAR-INPUT in))
+	((TTY TTYSCAN TTYINT TTYTYPE TTYSIZE OSPEED TERPRI LINMOD)
+	   ;; Wow, look at all these [S]STATUS options!
+	   ;; Remember, 'data' = () means STATUS, otherwise a list of args 
+	   ;;  for SSTATUS to use.
+	  (let (sstatusp operation-list)
+	    (cond ((eq op 'TTYINT)  
+		    (desetq (operation-list . sstatusp) data)
+		    (let (((char-no . fun?) operation-list)
+			  quotifyp)
+		      (if fun? (setq fun? `(',(car fun?)) quotifyp 'T))
+		      (if (not (numberp char-no))
+			  (setq char-no `',char-no quotifyp 'T))
+		      (if quotifyp (setq operation-list `(,char-no . ,fun?)))))
+		  ('T (cond ((eq op 'TERPRI) (setq in out))
+			    ((not (memq op '(TTY TTYSCAN LINMOD)))
+			     (if data  
+				  ;; Can't SSTATUS on TTYTYPE, TTYSIZE, OSPEED
+				 (+internal-lossage 'SSTATUS 
+						    'QUERY-IO-HANDLER 
+						    data))
+			     (setq in out)))
+		      (setq operation-list data 
+			    sstatusp data)))
+	      ;; Note that "in" and the items in the list "data" should be
+	      ;;  evaluative constants by now -- probably fixnums, or T or ().
+	    (setq operation-list `(,op ,@operation-list ,in))
+	    (if sstatusp
+		(apply #'SSTATUS operation-list)
+		(apply #'STATUS operation-list))))
+	(FILEMODE 
+	  ;;(status FILEMODE ...) sends () as "data", so we get the file mode
+	  ;;  of the "output" side of the SFA.
+	  ;;If user does (SFA-CALL <foo> 'FILEMODE 'IN), he gets input mode,
+	  ;; and (SFA-CALL <foo> 'FILEMODE 'OUT) likewise gets the output mode.
+	 (cond ((memq data '(() OUT))  (QUERY-IO-omode self))
+	       ((eq data 'IN)          (QUERY-IO-imode self))
+	       ('T (+internal-lossage 'FILEMODE 'QUERY-IO-HANDLER data))))
+	 ;(TTYCONS ...)	;Is a system slot in the SFA, the "XCONS" slot and thus
+			;  this status call does not send a message.
+	(+INTERNAL-TTYSCAN-SUBR 
+	   ;; Well, can you imagine (funcall (status ttyscan <foo>) <bar> ...)
+	   ;;  so just "pass it down".
+	  (+INTERNAL-TTYSCAN-SUBR in (car data) (cadr data)))
+	(WHICH-OPERATIONS 
+	   ;; Notice that (SFA-CALL <foo> 'WHICH-OPERATIONS <non-null-list>)
+	   ;;  will store into the WHICH-OPERATIONS slot
+	  (if data (setf (QUERY-IO-whichops self) data))
+	  (if (null (QUERY-IO-whichops self))
+	      (setf (QUERY-IO-whichops self) 
+		    `(,@SI:QUERY-IO-EXTRA-OPTIONS 
+		      TYI UNTYI TYIPEEK TYO READ READLINE PRINT PRINC 
+		      OPEN CLOSE LISTEN CHARPOS LINEL PAGEL PAGENUM 
+		      TTY TTYSCAN TTYTYPE TTYSIZE TTYINT OSPEED LINMOD 
+		      FRESH-LINE CLEAR-OUTPUT FORCE-OUTPUT CLEAR-INPUT 
+		      FILEMODE WHICH-OPERATIONS)))
+	  (QUERY-IO-whichops self))
+	(T (sfa-unclaimed-message self op data))))))
+
+
+(defvar QUERY-IO 'T 
+  "Where to ask questions from.  Bidirectional. SFA-form is unaffected by ^W.")
+
+(and (eq QUERY-IO 'T)
+     (status feature SFA)
+     (setq QUERY-IO (cons-a-QUERY-IO)))
+
+
+

src/lspsrc/sendi.107

@@ -0,0 +1,297 @@
+; -*- MIDAS -*-
+TITLE SENDI -- Standard Send Interpreter
+.INSRT SYS:.FASL DEFS
+.FASL
+
+SVERPRT SENDI,107
+
+.INSRT LSPSRC;EXTMDF >
+
+.SXEVAL 
+ (OR (STATUS STATUS SENDI)
+     (ERROR (QUOTE EXTEND/s/ /c/a/n/'/t/ /p/o/s/s/i/b/l/y/ /w/o/r/k/ /i/n/ /a/n/c/i/e/n/t/ LISP/s!))) 
+
+
+
+;; (SI:MAP-OVER-CLASSES FUNCTION CLASS)
+.entry SI:MAP-OVER-CLASSES SUBR 003
+	movei r,[%mapcls tt,(c)]
+	movei f,(CALL 2,)	   ;2 args
+	jrst imapit
+
+; (SI:MAP-OVER-METHODS FUNCTION CLASS)
+.entry SI:MAP-OVER-METHODS SUBR 003
+	movei r,[%mapmth tt,(c)]
+	movei f,(CALL 3,)	   ;3 args
+imapit:	push fxp,flp		   ;Save the state of the stacks for
+	push fxp,p		   ;quick return
+	hrli a,(f)		   ;prepare to XCT-call the function
+	push fxp,a		   ;put on FXP so can be snapped.
+	push p,a
+	push p,b
+	move a,b		   ;let's check the second arg
+mclp:	pushj p,classp		   ;is this a class?
+	jumpe a,mclper
+	pop p,c			   ;Recover the class, now in C
+	pop p,a			   ;Get our function to balance the stack
+	setz a,			   ;SI:MAP-OVER-CLASSES expects () in A
+	xct (r)			   ;Get the map-method/class method
+	jumpe tt,mclper
+	pushj p,(tt)		   ;call it
+	pop fxp,a		   ;restore the state
+	pop fxp,p		   ;of our various PDL's
+	pop fxp,flp
+false:	setz a,			   ;Return ()
+cpopj:	popj p,
+
+
+mclper:	push p,[mclp]
+mclpr0:	move a,(p)	   ;recover the non-class
+	WTA [NOT A CLASS OR, MAP-METHOD/CLASS IS MISSING!]
+	movem a,(p)
+	popj p,
+
+
+.entry SI:STANDARD-MAP-OVER-METHODS MAP-METHODS 003
+	%methd ar1,(c)		   ;Get methods
+	jumpe ar1,irecur	   ;If null, don't.  Look at superiors instead
+	push p,c
+mmsear:	move a,(p)		   ;First arg is the class method is in
+	%mname b,(ar1)		   ;Get the method symbol
+	%mfsym c,(ar1)		   ;Get the method function
+	push p,ar1		   ;save our state
+	xct (fxp)		   ;Invoke the user's function
+	jumpn a,mmret		   ;if non-nil return, go return result
+	pop p,ar1		   ;recover state
+	%mnext ar1,(ar1)	   ;Get the next one
+	jumpn ar1,mmsear	   ;loop until end
+	pop p,c			   ;recover class being hacked.
+	movei r,[%mapmth tt,(c)]   ;Pass in how to get recursion
+	jrst irecur
+
+.entry SI:STANDARD-MAP-OVER-CLASSES MAP-CLASSES 000
+	move b,a		   ;Second arg:  Previous class, or ()
+        movei a,(c)		   ;First arg:  Class
+	push p,c		   ;Don't forget what class we are
+	xct (fxp)		   ;Invoke the user's function
+	jumpn a,mmret		   ;If non-null, time to return.
+	pop p,c			   ;Recover class
+	movei a,(c)		   ;In super-classes, tell this is inferior of
+				   ;Interest.
+	movei r,[%mapcls tt,(c)]   ;How to get next level's routine.
+
+irecur:	%super ar1,(c)		   ;Get list of superiors
+	jumpe ar1,cpopj		   ;no such luck
+ircur0:	hlrz c,(ar1)		   ;look at first
+	xct (r)			   ;Get in TT the frob to call
+	push p,ar1		   ;Save our state
+	push flp,r		   ;Can't use FXP, has P on it.
+	skipe tt
+	 pushj p,(tt)		   ;Call it
+	pop flp,r
+	pop p,ar1
+	hrrz ar1,(ar1)		   ;He failed, look at next
+	jumpn ar1,ircur0	   ;loop until end
+	popj p,			   ;Return our failure
+
+mmret:	pop fxp,t		   ;flush the instruction
+	pop fxp,p		   ;restore the stack
+	pop fxp,flp		   ;Restore FLP
+	popj p,			   ;and return
+
+.entry SEND-AS LSUBR 004777
+	movei r,(p)
+	addi r,(t)		   ;Get address of return address
+	movei c,cpopj
+	aos r			   ;Skip over this return address for now
+	exch c,(r)		   ;1st arg becomes CPOPJ, pick up class
+	hrrz a,1(r)		   ;Get object for sending
+	hrrz b,2(r)		   ;Get method name
+	aoja t,sndit		   ;one less argument
+
+
+.entry SEND LSUBR 003777
+send:	movei r,(p) 
+	addi r,(t)		   ;Get address of return address
+	hrrz a,1(r)		   ;Get object for sending
+	movem a,1(r)		   ;Clear its left half! --RLB
+	hrrz b,2(r)		   ;Get method name
+	jsp d,getcls		   ;get the class
+sndit:	push fxp,p		   ;remember size of stack so can restore
+	%sendi tt,(c)		   ;get the send interpreter
+	skipe tt
+	 pushj p,(tt)		   ;invoke it
+				   ;Send interpreters return on failure
+	pop fxp,p		   ;balance the PDL's
+	jcall 16,.function SI:LOST-MESSAGE-HANDLER
+
+
+.ENTRY TYPE-OF SUBR 002		   ;Better than TYPEP!
+	jsp d,getcls
+	%typep a,(c)		   ;Fetch the type from whatever class
+	popj p,
+
+
+.entry CLASSP SUBR 002
+classp:	movei tt,(a)
+	lsh tt,-seglog
+	skipge tt,st(tt)	   ;Must be some kind of HUNK
+	  tlnn tt,hnk
+	    jrst false
+	%marker tt,(a)		   ;With the marker in the CAR
+	came tt,.special SI:CLASS-MARKER
+	  jrst false
+	hrrz a,(a)		   ;Get the "class pointer"
+	movei tt,(a)		   ;The class pointer must also
+	lsh tt,-seglog		   ;pass the same two tests
+	skipge tt,st(tt)
+	  tlnn tt,hnk
+	    jrst false
+	%marker tt,(a)		   ;Get the marker
+	came tt,.special SI:CLASS-MARKER
+	  jrst false
+truth:	movei a,.atom T		   ;Passed all the tests, it's a class!
+	popj p,
+
+.entry CLASS-OF SUBR 002
+	jsp d,getcls
+	move a,c		   ;GETCLS returns in C for SI:SEND
+	popj p,
+
+getcls:	jumpe a,nilcls		   ;+ETERNAL-SPECIAL-CASE-CROCK
+	movei tt,(a)		   ;copy
+	lsh tt,-seglog		   ;get index into segment table
+	hrrz tt,st(tt)		   ;get the type
+	subi tt,.atom LIST	   ;get the type code number
+	xct clstab(tt)
+	jrst (d)
+nilcls:	move c,.special NULL-CLASS
+	jrst (d)
+
+clstab:	  
+	move c,.special PAIR-CLASS
+  IRPS x,,[FIXNUM FLONUM BIGNUM SYMBOL]
+	  move c,.special x!-CLASS
+TERMIN
+REPEAT hnklog,	jrst snhnk
+	move c,.special RANDOM-CLASS
+	jrst snary
+
+snary:	move c,.special ARRAY-CLASS  ;An array; check for special cases
+	move tt,ASAR(a)		   ;Get the ASAR bitss
+	tlne tt,as.sfa		   ;Is it an SFA?
+	  move c,.special SFA-CLASS
+	tlne tt,as.fil		   ;Is it a file?
+	  move c,.special FILE-CLASS
+	tlne tt,as.job		   ;Heh heh, is it a JOB?
+	  move c,.special JOB-CLASS
+	jrst (d)
+
+snhnk:	hrrz tt,(a)		   ;get the class of this object
+	lsh tt,-seglog		   ;check it out
+	move tt,st(tt)
+	tlnn tt,HNK		   ;Is this a hunk?
+	  jrst symul		   ;  No, hack as random system datum
+	%class c,(a)
+	%marker tt,(c)		   ;Get the marker of this class
+	came tt,.special SI:CLASS-MARKER
+symul:	  move c,.special HUNK-CLASS
+	jrst (d)
+
+;; SEND interpreters expect:
+;; In A, the object
+;; In B, the method name
+;; In C, the class from which the SEND interpreter was extracted
+;; In R, the address of the return address on the stack.
+;; On FXP, the saved P to restore before calling method, to flush the
+;; saved state from the SEND interpreters
+;; An arbitrary amount of cruft on the stack beyond point saved on FXP
+;; For the sake of trampolines, they should leave the method bucket in
+;; AR2A
+
+.entry SI:DEFAULT-SENDI SENDI 000   ;not to be called, just need property
+	%methd ar2a,(c)		   ;get the dispatch list
+	jumpe ar2a,sndup	   ;if NIL, try superiors
+mthlp:	%mname ar1,(ar2a)	   ;get the method name
+	cain ar1,(b)		   ;is it this one? (symbol in right half)
+	  jrst sndgo		   ;  yes, do it up!
+	%mnext ar2a(ar2a)	   ;next method
+	jumpn ar2a,mthlp	   ;(unless end)
+
+sndup:	%super ar1,(c)		   ;get superiors
+	jumpe ar1,sndfail	   ;failed if none
+suplp:	hlrz c,(ar1)		   ;get the class to hack
+	push p,ar1		   ;save our state
+	%sendi tt,(c)		   ;get the send interpreter
+	skipe tt
+	 pushj p,(tt)		   ;invoke it
+	pop p,ar1		   ;it failed, recover our state
+	hrrz ar1,(ar1)		   ;throw that class away
+	jumpn ar1,suplp		   ;try next
+sndfail:
+	popj p,			   ;foo, we failed too.
+
+sndgo:	pop fxp,p		   ;restore our stack to initial state
+	%msubr tt,(ar2a)	   ;get the LSUBR part of the method
+	jumpn tt,(tt)		   ;and invoke it if found
+				   ;Not compiled (or undefined...)
+	%mfsym tt,(ar2a)	   ;Get the symbol or lambda or whatever
+	jcall 16,(tt)		   ;(closure!?)
+
+.entry SI:SFA-SENDI SENDI 000
+	pop fxp,p		   ;Flush all the cruft
+	move ar1,a		   ;Save the SFA
+	setzb a,b		   ;Start with NIL
+	move tt,t		   ;T is clobbered by JSP T,%CONS
+	aos tt			   ;We don't want the SFA consed in
+sfasnl:	pop p,a
+	jsp t,%cons
+	aojl tt,sfasnl		   ;Terminates when we cons the message
+				   ;onto the list
+	move c,a		   ;Get the result
+	movei b,.atom :SEND
+	pop p,a			   ;Get the SFA
+	jcall 3,.function SFA-CALL
+
+;; CALLI frobs are called with the stack in IAPPLY format
+
+.entry SI:DEFAULT-CALLI CALLI 000   ;not to be called, just need property
+	movei tt,(p)
+	addi tt,1(t)		   ;get address of first arg
+	hrli tt,-1(t)		   ;Make it into an AOBJN ptr to args
+	push p,NIL		   ;Make room for additional arg
+	movei b,.atom CALL	   ;First arg comes out of the blue
+	hrrzs (tt)		   ;Flush left-half
+dcloop:	exch b,(tt)		   ;swap! previous goes in this slot, save this
+	aobjn tt,dcloop		   ;for next time around
+	subi t,2		   ;count 2 additional arguments, self and CALL
+	jrst send		   ;go send the message
+
+.entry SI:CALLI-TRANSFER CALLI 000
+	move tt,t		   ;copy number of args
+	addi tt,(p)		   ;get loc of function
+	hrrz a,(tt)		   ;get "function"
+	hrrz a,(a)		   ;get class
+	%calli tt,(a)		   ;get CALLI interpreter from the class
+	jrst (tt)		   ;Invoke it
+
+.entry EXTENDP SUBR 002
+.entry SI:EXTENDP SUBR 002
+	movei tt,(a)		;copy
+	lsh tt,-seglog
+	move tt,st(tt)
+	tlnn tt,HNK
+	  jrst false
+	hrrz a,(a)		;CDR
+	movei tt,(a)
+	lsh tt,-seglog
+	move tt,st(tt)
+	tlnn tt,hnk
+	  jrst false
+	%marker b,(a)		;Get the marker
+	movei a,.atom T
+	came b,.special SI:CLASS-MARKER
+	  setz a,
+	popj p,
+
+FASEND

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))))
+
+