diff --git a/Makefile b/Makefile
index b30d87d9..929fa5d3 100644
--- a/Makefile
+++ b/Makefile
@@ -4,7 +4,7 @@ EMULATOR ?= simh
 SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa	\
       midas _teco_ emacs emacs1 rms klh syshst sra mrc ksc eak gren	\
       bawden _mail_ l lisp liblsp libdoc comlap lspsrc nilcom rwk	\
-      inquir acount gz sys decsys ecc
+      inquir acount gz sys decsys ecc alan
 DOC = info _info_ sysdoc kshack _teco_ emacs emacs1
 BIN = sysbin device emacs _teco_ inquir
 
diff --git a/build/build.tcl b/build/build.tcl
index 9579be62..0e8d4fb5 100644
--- a/build/build.tcl
+++ b/build/build.tcl
@@ -656,6 +656,7 @@ respond "*" ":link sys;atsign lisp,sys;purqio >\r"
 respond "*" ":link sys;ts l,sys;ts lisp\r"
 
 respond "*" ":link .info.;lisp step,.info.;step info\r"
+respond "*" ":link libdoc;struct 280,alan;struct >\r"
 respond "*" ":link libdoc;struct doc,alan;struct doc\r"
 respond "*" ":link .info.;lisp struct,libdoc;struct doc\r"
 respond "*" ":link l;-read- -this-,lisp;-read- -this-\r"
@@ -690,6 +691,7 @@ respond "*" ":link sys;.fasl defs,lisp;.fasl defs\r"
 respond "*" ":midas inquir;_lsrrtn\r"
 expect ":KILL"
 respond "*" ":link liblsp;debug fasl,liblsp;dbg fasl\r"
+respond "*" ":link lisp;debug fasl,liblsp;debug fasl\r"
 respond "*" "complr\013"
 respond "_" "liblsp;_libdoc;tty\r"
 respond "_" "inquir;reader\r"
@@ -702,11 +704,13 @@ respond "_" "lisp;_nilcom;evonce\r"
 respond "_" "inquir;inquir\r"
 respond "_" "\032"
 type ":kill\r"
+
 respond "*" "complr\013"
 respond "_" "liblsp;_libdoc;dbg rwk1\r"
 respond "_" "liblsp;_libdoc;comrd kmp1\r"
 respond "_" "\032"
 type ":kill\r"
+
 respond "*" ":lisp inquir;inquir (dump)\r"
 respond "*" ":link inquir;ts inquir,inquir;inqbin >\r"
 respond "*" ":link sys;ts inquir,inquir;ts inquir\r"
@@ -759,8 +763,89 @@ respond "*" ":link sys1;ts s,sys;ts send\r"
 respond "*" ":link sys3;ts snd,sys;ts send\r"
 respond "*" ":link sys3;ts sned,sys;ts send\r"
 
-# NICNAM
+# more lisp packages
+respond "*" ":link lisp;tty fasl,liblsp;tty fasl\r"
+respond "*" "complr\013"
+respond "_" "\007"
+respond "*" "(load '((lisp) subloa lsp))"
+respond "T" "(maklap)"
+respond "_" "lisp;_lspsrc;funcel\r"
+respond "_" "lisp;_lspsrc;bits\r"
+respond "_" "lisp;_lspsrc;reap\r"
+respond "_" "lisp;_lspsrc;lexprf\r"
+respond "_" "lisp;_lspsrc;ldbhlp\r"
+respond "_" "lisp;_nilcom;subloa\r"
+respond "_" "\032"
+type ":kill\r"
 
+respond "*" "complr\013"
+respond "_" "lisp;_nilcom;sharpa\r"
+respond "_" "lisp;_nilcom;sharpc\r"
+respond "_" "lisp;_nilcom;lsets\r"
+respond "_" "lisp;_nilcom;drammp\r"
+respond "(Y or N)" "Y"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" "complr\013"
+respond "_" "\007"
+respond "*" "(load '((lisp) subloa lsp))"
+respond "T" "(maklap)"
+respond "_" "lisp;_lspsrc;nilaid\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" "complr\013"
+respond "_" "lisp;_libdoc;sharab\r"
+respond "_" "lisp;_libdoc;bs\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" "complr\013"
+respond "_" "\007"
+respond "*" "(load '((lisp) subloa lsp))"
+respond "T" "(maklap)"
+respond "_" "lisp;_nilcom;thread\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":midas lisp;_l;lchnsp\r"
+expect ":KILL"
+respond "*" ":midas lisp;_l;purep\r"
+expect ":KILL"
+
+# struct
+
+respond "*" ":link alan;dprint fasl,liblsp;dprint fasl\r"
+respond "*" ":link alan;struct 9,alan;nstruc 280\r"
+respond "*" ":copy liblsp;struct fasl,alan;struct boot\r"
+respond "*" ":link alan;struct fasl,liblsp;struct fasl\r"
+respond "*" "complr\013"
+respond "_" "alan;lspcom\r"
+respond "_" "alan;lspenv\r"
+respond "_" "alan;lspint\r"
+respond "_" "alan;setf\r"
+respond "_" "alan;binda\r"
+respond "_" "alan;crawl\r"
+respond "_" "alan;nstruc 280\r"
+respond "_" "\032"
+type ":kill\r"
+respond "*" ":copy alan;nstruc fasl,liblsp;struct fasl\r"
+respond "*" ":link lisp;struct fasl,liblsp;struct fasl\r"
+
+respond "*" ":midas liblsp;_alan;macits\r"
+expect ":KILL"
+
+#respond "*" "complr\013"
+#respond "_" "alan;ljob\r"
+#respond "_" "liblsp;_libdoc;gprint rcw3\r"
+#respond "_" "alan;lspgub\r"
+##source file is damaged
+##respond "_" "alan;dprint\r"
+#respond "_" "\032"
+#type ":kill\r"
+
+# NICNAM
 respond "*" ":midas sys2;ts nicnam_sysen3;nicnam\r"
 expect ":KILL"
 
diff --git a/src/alan/binda.46 b/src/alan/binda.46
new file mode 100755
index 00000000..56b8507d
--- /dev/null
+++ b/src/alan/binda.46
@@ -0,0 +1,221 @@
+;;;-*- Mode:Lisp; Package:SI -*-
+
+(declare (and (status feature maclisp)
+	      (load '((alan) lspenv init))))
+
+(declare (special *rest* *normal* *optional*))
+
+(defun bind-arguments-&parse (pattern body)
+  (prog (pat x)
+	(setq pat pattern)
+   norm (cond ((atom pat)
+	       (setq *rest* pat)
+	       (return body)))
+	(setq x (car pat))
+	(cond ((eq x '&optional)
+	       (go opt))
+	      ((memq x '(&rest &body))
+	       (go rst))
+	      ((eq x '&aux)
+	       (go ax)))
+	(push x *normal*)
+	(setq pat (cdr pat))
+	(go norm)
+    opt (cond ((atom (setq pat (cdr pat)))
+	       (setq *rest* pat)
+	       (return body)))
+	(setq x (car pat))
+	(cond ((eq x '&optional)
+	       (go barf))
+	      ((memq x '(&rest &body))
+	       (go rst))
+	      ((eq x '&aux)
+	       (go ax)))
+	(push (if (atom x) (list x) x) *optional*)
+	(go opt)
+    rst (if (atom (setq pat (cdr pat)))
+	    (go barf))
+	(setq *rest* (car pat))
+	(if (null (setq pat (cdr pat)))
+	    (return body))
+	(if (or (atom pat)
+		(not (eq (car pat) '&aux)))
+	    (go barf))
+     ax (return
+	  (do ((l (reverse (cdr pat)) (cdr l))
+	       (var) (val)
+	       (body body `(((lambda (,var) ,@body) ,val))))
+	      ((null l) body)
+	    (if (atom (car l))
+		(setq var (car l) val nil)
+		(setq var (caar l) val (cadar l)))))
+   barf (ferror "Bad pattern: ~S" pattern)))
+
+(eval-when (eval compile)
+(defmacro bind-arguments-ignorable (x)
+  `(memq ,x '(ignore ignored))))
+
+(defun bind-arguments/ macro (x)
+  (bind-arguments (((pattern form &optional barf) &body body) (cdr x)
+		    (error '|-- bad format.| x))
+    (let ((body (bind-arguments-internal pattern form barf body)))
+      (if (null (cdr body))
+	  (car body)
+	  `(progn ,@body)))))
+
+(defun bind-arguments-internal (pattern form barf body)
+  (cond
+    ((bind-arguments-ignorable pattern) `(,form ,@body))
+    ((null pattern) `((or (null ,form) ,barf) ,@body))
+    ((atom pattern) `(((lambda (,pattern) ,@body) ,form)))
+    (t
+     (let* ((*normal* nil)
+	    (*optional* nil)
+	    (*rest* nil)
+	    (body (bind-arguments-&parse pattern body))
+	    (lst? (if (null *normal*)
+		      (or (null *optional*)
+			  (and (atom form)
+			       (null *rest*)
+			       (null (cdr *optional*))))
+		      (and (null *optional*)
+			   (atom form)
+			   (null *rest*)
+			   (null (cdr *normal*)))))
+	    (lst (if lst? form (gensym)))
+	    (len? (or (null *optional*)
+		      (and (null (cdr *optional*))
+			   (null *normal*)
+			   (not (null *rest*)))))
+	    (len (if len? `(length ,lst) (gensym)))
+	    (barf (or barf `(ferror '|~S doesn't match pattern ~S|
+				    ,lst ',pattern))))
+       (setq body `(,@(bind-arguments-error-check len barf)
+		    ,@(bind-arguments-internal-1 barf body lst len
+						 #'bind-arguments-nth
+						 #'bind-arguments-nthcdr)))
+       (or len?
+	   (setq body `(((lambda (,len) ,@body) (length ,lst)))))
+       (if lst?
+	   body
+	   `(((lambda (,lst) ,@body) ,form)))))))
+
+(defun bind-arguments-internal-1 (barf body lst len ref-one ref-rest)
+  (let ((n (+ (length *normal*) (length *optional*))))
+    (or (null *rest*)
+	(setq body
+	      (bind-arguments-internal *rest* (funcall ref-rest n lst)
+				       barf body)))
+    (dolist (opt *optional*)
+      (setq n (1- n))
+      (cond ((cddr opt)
+	     (setq body
+		   `(((lambda (,(caddr opt))
+			,@(if (bind-arguments-ignorable (car opt))
+			      body
+			      (bind-arguments-internal
+				(car opt)
+				`(cond (,(caddr opt) ,(funcall ref-one n lst))
+				       (t ,(cadr opt)))
+				barf
+				body)))
+		      (> ,len ,n)))))
+	    ((not (bind-arguments-ignorable (car opt)))
+	     (setq body
+		   (bind-arguments-internal
+		     (car opt)
+		     `(cond ((> ,len ,n) ,(funcall ref-one n lst))
+			    (t ,(cadr opt)))
+		     barf
+		     body)))))
+    (dolist (pat *normal*)
+      (setq n (1- n))
+      (or (bind-arguments-ignorable pat)
+	  (setq body
+		(bind-arguments-internal pat (funcall ref-one n lst)
+					 barf body))))
+    body))
+
+(defun bind-arguments-error-check (len barf)
+  (let ((nlen (length *normal*))
+	(olen (length *optional*)))
+    (if (null *rest*)
+	(if (null *optional*)
+	    `((or (= ,len ,nlen)
+		  ,barf))
+	    (if (null *normal*)
+		`((and (> ,len ,olen)
+		       ,barf))
+		`((and (or (< ,len ,nlen)
+			   (> ,len ,(+ olen nlen)))
+		       ,barf))))
+	(if (null *normal*)
+	    `()
+	    `((and (< ,len ,nlen)
+		   ,barf))))))
+
+(defun bind-arguments-nth (n v)
+  (caseq n
+    (0 `(car ,v))
+    (1 `(cadr ,v))
+    (2 `(caddr ,v))
+    (3 `(cadddr ,v))
+    (t (bind-arguments-nth (- n 4) `(cddddr ,v)))))
+
+(defun bind-arguments-nthcdr (n v)
+  (caseq n
+    (0 v)
+    (1 `(cdr ,v))
+    (2 `(cddr ,v))
+    (3 `(cdddr ,v))
+    (t (bind-arguments-nthcdr (- n 4) `(cddddr ,v)))))
+
+#+maclisp
+(defun (defun& macro) (x)
+  (let ((name (cadr x))
+	(pattern (caddr x))
+	(body (cdddr x)))
+    (cond ((memq pattern '(fexpr macro))
+	   (ferror "Cannot mix &-keywords and ~S definitions: ~S"
+		   pattern x))
+	  ((eq pattern 'expr)
+	   (setq pattern (pop body)))
+	  ((not (symbolp pattern)))
+	  ((memq name '(fexpr macro))
+	   (ferror "Cannot mix &-keywords and ~S definitions: ~S"
+		   pattern x))
+	  ((eq name 'expr)
+	   (setq name pattern)
+	   (setq pattern (pop body))))
+    (if (bind-arguments-ignorable pattern)
+	(let ((n (gensym)))
+	  `(defun ,name ,n ,n ,@body))
+	(let* ((*normal* nil)
+	       (*optional* nil)
+	       (*rest* nil)
+	       (body (bind-arguments-&parse pattern body))
+	       (len (gensym))
+	       (barf `(ferror '|~S doesn't match pattern ~S|
+			      (listify ,len) ',pattern)))
+	  `(defun ,name ,len
+	     ,@(bind-arguments-error-check len barf)
+	     ,@(bind-arguments-internal-1 barf body len len
+					  #'bind-arguments-arg
+					  #'bind-arguments-listify))))))
+
+#+maclisp
+(defun bind-arguments-arg (n v)
+  v	;ignored
+  `(arg ,(1+ n)))
+
+#+maclisp
+(defun bind-arguments-listify (n v)
+  (if (zerop n)
+      `(listify ,v)
+      `(listify (- ,n ,v))))
+
+#+maclisp
+(defprop bind-arguments bind-arguments/ macro macro)
+
+#+lispm
+(fdefine 'bind-arguments '(macro . bind-arguments/ macro) t)
diff --git a/src/alan/binda.fasl b/src/alan/binda.fasl
new file mode 100755
index 00000000..7c4541e7
Binary files /dev/null and b/src/alan/binda.fasl differ
diff --git a/src/alan/crawl.18 b/src/alan/crawl.18
new file mode 100755
index 00000000..305ed0b2
--- /dev/null
+++ b/src/alan/crawl.18
@@ -0,0 +1,152 @@
+;;;-*-Lisp-*-
+
+(declare (load '((alan) lspenv init)))
+
+(defstruct (frame default-pointer conc-name
+		  (eval-when (eval compile)))
+	   n
+	   evf
+	   (up nil)
+	   (down nil))
+
+(eval-when (eval compile)
+
+(defmacro frame-type (&optional (frame 'frame))
+	  `(car (frame-evf ,frame)))
+
+(defmacro frame-pdl (&optional (frame 'frame))
+	  `(cadr (frame-evf ,frame)))
+
+(defmacro frame-stuff (&optional (frame 'frame))
+	  `(caddr (frame-evf ,frame)))
+
+(defmacro frame-env (&optional (frame 'frame))
+	  `(cadddr (frame-evf ,frame)))
+
+)
+
+(defun crawl ()
+       (do ((prev nil frame)
+	    (evf (evalframe nil)
+		 (evalframe (cadr evf)))
+	    (n 0 (1+ n))
+	    (top)
+	    (frame))
+	   ((null evf) (crawl-loop top frame))
+	   (setq frame (make-frame n n
+				   up prev
+				   evf evf))
+	   (if (null prev)
+	       (setq top frame)
+	       (setf (frame-down prev) frame))))
+
+(defun crawl-loop (top bottom)
+  (let ((frame top))
+       (print-crawl-frame frame)
+       (do ((flag nil))
+	   (())
+	   (terpri)
+	   (tyo #/.)
+   forgive (setq flag nil)
+ next-char (caseq (tyi)
+		  ((#/d #/D)
+		   (setq frame (crawl-new-frame frame (frame-down))))
+		  ((#/u #/U)
+		   (setq frame (crawl-new-frame frame (frame-up))))
+		  ((#/r #/R)
+		   (terpri)
+		   (princ "Form to evaluate and return: ")
+		   (errset (freturn (frame-pdl) (eval (read) (frame-env)))))
+		  ((#/e #/E)
+		   (terpri)
+		   (princ "Form to evaluate: ")
+		   (errset (print (eval (read) (frame-env)))))
+		  ((#/c #/C)
+		   (fretry (frame-pdl)
+			   (frame-evf)))
+		  ((#/g #/G)
+		   (or (get 'gprint1 'lsubr)
+		       (load '((liblsp) gprint fasl)))
+		   (terpri)
+		   (gprint1 (frame-stuff) nil nil nil nil nil nil))
+		  ((#/t #/T)
+		   (setq frame (crawl-new-frame frame top)))
+		  ((#/b #/B)
+		   (setq frame (crawl-new-frame frame bottom)))
+		  ((#/j #/J)
+		   (princ " -> ")
+		   (setq frame (crawl-find-numbered-frame frame top (read))))
+		  ((#\form #/l #/L)
+		   (print-crawl-frame frame))
+		  ((#/q #/Q)
+		   (return 'done))
+		  ((#/i #/I)
+		   (cond (flag (inspect (frame-stuff)))
+			 (t
+			  (terpri)
+			  (princ "Form to evaluate and inspect: ")
+			  (errset (inspect (eval (read) (frame-env)))))))
+		  ((#/p #/P)
+		   (cond (flag (describe (frame-stuff)))
+			 (t
+			  (terpri)
+			  (princ "Form to evaluate and describe: ")
+			  (errset (describe (eval (read) (frame-env)))))))
+		  ((#\alt) (setq flag t) (go next-char))
+		  ((#/? #//)
+		   (princ "
+CRAWL Commands:
+
+U - Up a frame
+D - Down a frame
+T - go to Top frame
+B - go to Bottom frame
+J - Jump to a numbered frame
+E - Evaluate a form in current frame
+R - Return from current frame
+C - Continue current frame (start over)
+G - Grind stuff in current frame
+I - Inspect
+<alt>I - Inspect contents of current frame
+P - describe (Print cute)
+<alt>P - describe contents of current frame
+Q - Quit"))
+		  ((#\space #\cr #\lf)
+		   (go forgive))
+		  (t
+		   (princ " ???"))))))
+
+(defun crawl-new-frame (old new)
+       (cond ((null new)
+	      (princ " No more.")
+	      old)
+	     (t
+	      (print-crawl-frame new)
+	      new)))
+
+(defun print-crawl-frame (frame)
+  (let ((prinlength 4)
+	(prinlevel 3))
+    (caseq (frame-type)
+	   (eval
+	    (terpri)
+	    (princ (frame-n))
+	    (princ " Evaluating ")
+	    (prin1 (frame-stuff)))
+	   (apply
+	    (terpri)
+	    (princ (frame-n))
+	    (princ " Applying ")
+	    (prin1 (car (frame-stuff)))
+	    (terpri)
+	    (princ "To ")
+	    (prin1 (cadr (frame-stuff))))
+	   (t (error "-- wierd evalframe." (frame-type))))))
+
+(defun crawl-find-numbered-frame (old top n)
+       (do ((frame top (frame-down)))
+	   ((null frame)
+	    (princ " Not found.")
+	    old)
+	   (and (= n (frame-n))
+		(return (crawl-new-frame old frame)))))
\ No newline at end of file
diff --git a/src/alan/crawl.fasl b/src/alan/crawl.fasl
new file mode 100755
index 00000000..5e6023d4
Binary files /dev/null and b/src/alan/crawl.fasl differ
diff --git a/src/alan/dprint.142 b/src/alan/dprint.142
new file mode 100755
index 00000000..68583dc2
Binary files /dev/null and b/src/alan/dprint.142 differ
diff --git a/src/alan/ljob.74 b/src/alan/ljob.74
new file mode 100755
index 00000000..0fbc8541
--- /dev/null
+++ b/src/alan/ljob.74
@@ -0,0 +1,291 @@
+; -*- Lisp -*-
+
+(declare (load '((alan) lspenv init)))
+
+(declare ;; HUMBLE
+	 (*expr select-job kill-job load-job
+		deposit-job examine-job
+		job-uset-write job-uset-read
+		*atty *dtty)
+	 (*lexpr create-job)
+	 (special current-job)
+	 ;; MACITS
+	 (*expr %getsys %sixbit %unsixbit %squoze %unsquoze)
+	 (fixnum (%sixbit notype) (%squoze notype))
+	 )
+
+(eval-when (eval compile load)
+
+(or (fboundp '%getsys) (fasload (liblsp) macits))
+
+(defvar *uset-vars*
+  (do ((l (%getsys 'usyms) (cddr l))
+       (a nil (cons (cons (logand #o37777777777 (car l)) (cadr l)) a)))
+      ((null l) a)))
+
+(defmacro *uset (var &optional (val nil write?))
+  (let ((num (cdr (or (assoc (%squoze var) *uset-vars*)
+		      (error "-- unknown .USET variable" var)))))
+    (if write?
+	`(job-uset-write ,(+ #o400000 num) ,val)
+	`(job-uset-read ,num))))
+
+) ;end (eval-when (eval compile load) ...)
+
+(eval-when (eval compile)
+
+(defun convert-flonum-to-bit (f)
+  (or (floatp f) (error "-- non flonum argument to BIT or BITS." f))
+  (do ((x (-$ f .05))
+       (y 1.1 (+$ y .1))
+       (n 1 (1+ n))
+       (i 1 (lsh i 1)))
+      ((zerop i) (error "-- bad flonum to BIT or BITS." f))
+    (and (zerop (\ n 10.))
+	 (setq y (+$ y .1))
+	 (setq n (1+ n)))
+    (and (< x y) (return i))))
+
+(defmacro bit (x)
+  `',(convert-flonum-to-bit x))
+
+(defmacro bits l
+  `',(do ((l l (cdr l))
+	  (x 0 (logior x (convert-flonum-to-bit (car l)))))
+	 ((null l) x)))
+
+) ;end (eval-when (eval compile) ...)
+
+(defvar *value-handler '*value-handler)
+(defvar *break-handler '*break-handler)
+(defvar ljob-job-jcl nil)
+(defvar ljob-debug-p nil)
+(defvar ljob-search-rules
+  (let ((sr (cons (status homedir) '(sys sys1 sys2 sys3)))
+	(udir (status udir)))
+    (if (eq udir (car sr))
+	sr
+	(cons udir sr))))
+(defvar ljob-hang 'finished)
+(defconst ljob-start-addr-addr
+  (or (getddtsym 'j*stadr) #o71))	;educated guess!
+
+(defun ljob-interrupt-handler (job)
+  (*dtty)
+  (select-job job)
+  (let* ((pirqc (*uset *pirqc))
+	 (xpirqc (logand pirqc (bits 1.2 1.8 2.2 3.1 4.4)))
+	 (npirqc (logxor pirqc xpirqc)))
+    (cond ((= xpirqc (bit 1.2))		;%pic.z (call)
+	   (*uset *pirqc npirqc)
+	   (stop-job "^Z"))
+	  ((= xpirqc (bit 1.8))		;%pival (.value)
+	   (*uset *pirqc npirqc)
+	   (funcall *value-handler
+		    (logand #o777777 (*uset *sv40))))
+	  ((= xpirqc (bit 2.2))		;%pibrk (.break)
+	   (*uset *pirqc npirqc)
+	   (let ((x (*uset *sv40)))
+	     (funcall *break-handler
+		      (lsh x -27.)		;not necessarily .break!
+		      (logand #o17 (lsh x -23.))
+		      (logand #o777777 x))))
+	  ((= xpirqc (bit 3.1))		;%pilos (.lose)
+	   (*uset *pirqc npirqc)
+	   (error-job ".lose"))
+	  ((= xpirqc (bit 4.4))		;%pidcl (defered call)
+	   (*uset *pirqc npirqc)
+	   (stop-job "^_D"))
+	  (t
+	   (error-job pirqc)))))
+
+(defun ljob-channel-interrupt-handler n
+  n	;ignored (what is it anyway?)
+  (*dtty)
+  (error-job "channel interrupt"))
+
+(defun J (name)
+  (create-job #'ljob-interrupt-handler
+	      #'ljob-channel-interrupt-handler
+	      name))
+
+(defun L (file)
+  (let ((v (load-job file)))
+    (and ljob-job-jcl
+	 (*uset *option (logior (bit 4.6) (*uset *option))))
+    (*uset *sname (%sixbit (status udir)))
+    v))
+
+(defun gzp ()
+  (*uset *upc (+ (boole 2 #o777777 (*uset *upc))
+		 (logand #o777777 (arraycall fixnum current-job
+					     ljob-start-addr-addr))))
+  (^P))
+
+(defun ^P ()
+  (*uset *ustp 0))
+
+(defun P ()
+  (^P)
+  (pass-tty))
+
+(defun G ()
+  (gzp)
+  (pass-tty))
+
+(defun pass-tty ()
+  (setq ljob-hang nil)
+  (terpri)
+  (*atty)
+  (ljob-hang)
+  (*dtty)		;doesn't work to .dtty while interrupting sometimes?
+  '*)
+
+(defun ljob-set-jcl (jcl)
+  (cond ((null jcl)
+	 (setq ljob-job-jcl nil)
+	 (*uset *option (boole 2 (bit 4.6) (*uset *option))))
+	(t
+	 (setq ljob-job-jcl (maknam (nconc (explodec jcl) '(#\cr))))
+	 (*uset *option (logior (bit 4.6) (*uset *option))))))
+
+(defun *value-handler (loc)
+  (cond ((zerop loc)
+	 (error-job ".value"))
+	(t
+	 (stop-job ".value"))))
+
+(defun get-valret-string ()
+  (let ((loc (logand #o777777 (*uset *sv40)))
+	l)
+    (do ((loc (1+ loc) (1+ loc))
+	 (cs (examine-job loc) (examine-job loc))
+	 (c)
+	 (i 5 5))
+	(())
+    L (setq cs (rot cs 7))
+      (and (zerop (setq c (logand #o177 cs)))
+	   (return t))
+      (push c l)
+      (or (zerop (setq i (1- i)))
+	  (go L)))
+    (implode (nreverse l))))
+
+(defun finish-job (why)
+  (terpri)
+  (princ ";finished")
+  (cond (ljob-debug-p
+	 (princ " (")
+	 (princ why)
+	 (tyo #/))))
+  (princ ": ")
+  (print-job)
+  (terpri)
+  (kill-job)
+  (setq ljob-hang 'finished))
+
+(defun stop-job (why)
+  (terpri)
+  (princ ";stopped")
+  (cond (ljob-debug-p
+	 (princ " (")
+	 (princ why)
+	 (tyo #/))))
+  (princ ": ")
+  (print-job)
+  (terpri)
+  (setq ljob-hang 'stopped))
+
+(defun error-job (why)
+  (terpri)
+  (princ ";error (")
+  (princ why)
+  (princ "): ")
+  (print-job)
+  (terpri)
+  (setq ljob-hang 'error))
+
+(defun print-job ()
+  (princ (shortnamestring current-job)))
+
+(defun *break-handler (op ac loc)
+  (cond ((not (= op #o45))			;.break
+	 (cond ((and (= op #o42) (= loc #o33))	;.logout
+		(finish-job ".logout"))
+	       (t
+		(error-job ".break???"))))
+	((= ac #o16)
+	 (if (zerop (logand (bits 2.5 2.6) loc))
+	     (stop-job ".break")
+	     (finish-job ".break")))
+	((= ac #o12)
+	 (let ((req (examine-job loc))
+	       type)
+	   (cond ((not (zerop (logand req (bit 4.8))))
+		  (do ((aobjn (examine-job (logand #o777777 req))
+			      (+ (bits 1.1 3.1) aobjn)))
+		      ((> aobjn 0))
+		    (*break-handler op ac (logand #o777777 aobjn))))
+		 ((or (not (zerop (logand req (bit 4.9))))
+		      (not (= (setq type (logand #o177777
+						 (lsh req -18.))) 5)))
+		  (error-job ".break 12,??"))
+		 (t
+		  (or (null ljob-job-jcl)
+		      (do ((l (pnget ljob-job-jcl 7) (cdr l))
+			   (loc (logand #o777777 req) (1+ loc)))
+			  ((not (zerop (examine-job loc))))
+			(and (null l)
+			     (return (deposit-job loc 0)))
+			(deposit-job loc (car l))))
+		  (^P)
+		  (*atty)))))
+	(t
+	 (error-job ".break ??,"))))
+
+;;;(ljob-hang) hangs until the value of ljob-hang is non-null.
+(deflap (ljob-hang subr 0)
+	(skipn 0 (special ljob-hang))
+	 (*hang)
+	(popj p))
+
+(defun ljob-run-job (xname file jcl)
+  (do ((name xname)
+       (x (J xname) (J name)))
+      ((cond ((null x) (error "-- couldn't create job." xname))
+	     ((eq (car x) 'inferior)
+	      (let ((file (or file (ljob-search-for xname))))
+		(cond ((null (L file))
+		       (*uset *xjname (%sixbit xname))
+		       (ljob-set-jcl jcl)
+		       (G)
+		       t)
+		      (t (error "-- can't load file." file)))))
+	     ((eq (car x) 'reowned)
+	      (P)
+	      t)
+	     (t nil)))
+    (let ((l (exploden name)))
+      (cond ((> (length l) 5)
+	     (setf (caddr (cdddr l))
+		   (1+ (caddr (cdddr l)))))
+	    (t (rplacd (last l) (list #/'))))
+      (setq name (implode l))))
+  '*)
+
+(defun ljob-search-for (name)
+  (do ((l ljob-search-rules (cdr l))
+       (rest (list 'ts name))
+       (file))
+      ((null l)
+       (error "-- can't find file to load." name))
+    (and (probef (setq file (cons (if (symbolp (car l))
+				      (list 'dsk (car l))
+				      (car l))
+				  rest)))
+	 (return file))))
+
+(defun ljob-expand-run-macro (x)
+  (bind-arguments ((name &optional (jcl `nil)) x
+		    (error "-- wrong format." x))
+    `(ljob-run-job ',name ',(get name 'ljob-filename) ,jcl)))
diff --git a/src/alan/ljob.fasl b/src/alan/ljob.fasl
new file mode 100755
index 00000000..615a5aff
Binary files /dev/null and b/src/alan/ljob.fasl differ
diff --git a/src/alan/lspcom.20 b/src/alan/lspcom.20
new file mode 100755
index 00000000..1ea337d4
--- /dev/null
+++ b/src/alan/lspcom.20
@@ -0,0 +1,60 @@
+;;;-*-lisp-*-
+
+(declare (load '((alan) lspenv init)))
+
+(*expr *make-array *rem *del ass mem listp copyalist copytree apropos
+       defstruct-examine defstruct-deposit y-or-n-p
+       macroexpand macroexpand-1)
+
+(*lexpr format ?format ferror cerror describe inspect
+	gprint gprint1 gprinc pl gexplode gexplodec)
+
+(unspecial args symbols car cdr)
+
+(setq use-strt7 t)
+
+(defmacro xcar (x) `(car ,x))
+(defmacro xrplaca (x v) `(rplaca ,x ,v))
+(defmacro xcdr (x) `(cdr ,x))
+(defmacro xrplacd (x v) `(rplacd ,x ,v))
+(defmacro xcxr (n x) `(cxr ,n ,x))
+(defmacro xrplacx (n x v) `(rplacx ,n ,x ,v))
+(defmacro vcell (sym) `(cdar ,sym))
+(defmacro pname (sym) `(cxr 2 (car ,sym)))
+
+(defmacro ldb (ppss x)
+  (setq ppss (macroexpand ppss))
+  (setq x (macroexpand x))
+  (if (not (fixp ppss))
+      `(*ldb (lsh ,ppss #o30) ,x)			;ugh!
+      (let ((mask (1- (lsh 1 (boole 1 #o77 ppss))))
+	    (shift (- (lsh ppss -6))))
+	(cond ((fixp x)
+	       (boole 1 mask (lsh x shift)))
+	      ((zerop shift)
+	       `(boole 1 ,mask ,x))
+	      (t
+	       `(boole 1 ,mask (lsh ,x ,shift)))))))
+
+(defmacro dpb (v ppss x)
+  (setq v (macroexpand v))
+  (setq ppss (macroexpand ppss))
+  (setq x (macroexpand x))
+  (if (not (fixp ppss))
+      `(*dpb ,v (lsh ,ppss #o30) ,x)			;ugh!
+      (let* ((shift (lsh ppss -6))
+	     (mask (lsh (1- (lsh 1 (boole 1 #o77 ppss))) shift)))
+	(let ((vp (cond ((fixp v)
+			 (boole 1 mask (lsh v shift)))
+			((zerop shift)
+			 `(boole 1 ,mask ,v))
+			(t
+			 `(boole 1 ,mask (lsh ,v ,shift)))))
+	      (xp (if (fixp x)
+		      (boole 4 x mask)
+		      `(boole 4 ,x ,mask))))
+	  (if (and (fixp vp) (fixp xp))
+	      (boole 7 vp xp)
+	      `(boole 7 ,vp ,xp))))))
+
+(sstatus feature alan/;lspcom)
diff --git a/src/alan/lspcom.fasl b/src/alan/lspcom.fasl
new file mode 100755
index 00000000..48526e62
Binary files /dev/null and b/src/alan/lspcom.fasl differ
diff --git a/src/alan/lspenv.259 b/src/alan/lspenv.259
new file mode 100755
index 00000000..21321694
--- /dev/null
+++ b/src/alan/lspenv.259
@@ -0,0 +1,895 @@
+;;;-*-Lisp-*-
+
+(declare (load '((alan) lspenv init)))
+
+(setq flush '(defmax backq let defmacro lodbyt mlmac defvst defsetf
+	      setf sharpm macaid cgol subseq string extmac extend
+	      cerror yesnop errck extstr defvsy extbas defvsx cerror
+	      mlsub describe extsfa grindef))
+
+(mapatoms
+  #'(lambda (x)
+      ((lambda (p)
+	 (and (not (atom p))
+	      (memq (cadr p) flush)
+	      (remprop x 'autoload)))
+       (get x 'autoload))))
+
+(defun |forget-macromemos/|| (()) nil)
+
+(defun flush-macromemos (() ()) nil)
+
+(defun macrofetch (()) nil)
+
+(defun macromemo (x y ()) (displace x y))
+
+;;;In case of fire, break glass:
+;;;(defun (macroexpanded macro) (x) (displace x (car (cddddr x))))
+
+(defun define-autoloads (file l)
+  (dolist (name l)
+    (putprop name file 'autoload)))
+
+(defun define-autoload-macros (file l)
+  (define-autoloads file l)
+  (when (status feature complr)
+    (dolist (name l)
+      (putprop name 'autoload-macro 'macro))))
+
+(defun autoload-macro (x)
+  (remprop (car x) 'macro)
+  (load (or (get (car x) 'autoload)
+	    (error "-- autoload-macro without autoload property." x)))
+  x)
+
+;;;BACKQUOTE:
+;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
+;;;
+;;;   |`,|: [a] => a
+;;;    NIL: [a] => a			;the NIL flag is used only when a is NIL
+;;;      T: [a] => a			;the T flag is used when a is self-evaluating
+;;;  QUOTE: [a] => (QUOTE a)
+;;; APPEND: [a] => (APPEND . a)
+;;;  NCONC: [a] => (NCONC . a)
+;;;   LIST: [a] => (LIST . a)
+;;;  LIST*: [a] => (LIST* . a)
+;;;
+;;; The flags are combined according to the following set of rules:
+;;;  ([a] means that a should be converted according to the previous table)
+;;;
+;;;    \ car   ||    otherwise    |    QUOTE or     |     |`,@|      |     |`,.|      |
+;;;  cdr \     ||		  |    T or NIL     |                |		      |
+;;;====================================================================================
+;;;    |`,|    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a [d]) |
+;;;    NIL     || LIST    ([a])   | QUOTE    (a)    | <hair>    a    | <hair>    a    |
+;;; QUOTE or T || LIST* ([a] [d]) | QUOTE  (a . d)  | APPEND (a [d]) | NCONC  (a [d]) |
+;;;   APPEND   || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC  (a [d]) |
+;;;   NCONC    || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC  (a . d) |
+;;;    LIST    || LIST  ([a] . d) | LIST  ([a] . d) | APPEND (a [d]) | NCONC  (a [d]) |
+;;;    LIST*   || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC  (a [d]) |
+;;;
+;;;<hair> involves starting over again pretending you had read ".,a)" instead of ",@a)"
+
+(setsyntax '/` 'macro 'xr-backquote-macro)
+
+(setsyntax '/, 'macro 'xr-comma-macro)
+
+(declare (special **backquote-count** **backquote-flag**
+		  **backquote-/,-flag** **backquote-/,/@-flag** **backquote-/,/.-flag**))
+
+(setq **backquote-count** 0
+      **backquote-/,-flag** (copysymbol '|`,| nil)
+      **backquote-/,/@-flag** (copysymbol '|`,@| nil)
+      **backquote-/,/.-flag** (copysymbol '|`,.| nil)
+      )
+
+(defun xr-backquote-macro ()
+  ((lambda (**backquote-count** **backquote-flag** thing)
+     (setq thing (backquotify (read)))
+     (cond ((eq **backquote-flag** **backquote-/,/@-flag**)
+	    (error '|-- ",@" right after a "`".| thing))
+	   ((eq **backquote-flag** **backquote-/,/.-flag**)
+	    (error '|-- ",." right after a "`".| thing))
+	   (t
+	    (backquotify-1 **backquote-flag** thing))))
+   (1+ **backquote-count**)
+   nil
+   nil))
+
+(defun xr-comma-macro ()
+  (or (> **backquote-count** 0)
+      (error "Comma not inside a backquote."))
+  ((lambda (c **backquote-count**)
+     (cond ((= c #/@)
+	    (tyi)
+	    (cons **backquote-/,/@-flag** (read)))
+	   ((= c #/.)
+	    (tyi)
+	    (cons **backquote-/,/.-flag** (read)))
+	   (t (cons **backquote-/,-flag** (read)))))
+   (tyipeek)
+   (1- **backquote-count**)))
+
+(defun backquotify (code)
+  (prog (aflag a dflag d)
+	(cond ((atom code)
+	       (cond ((null code)
+		      (setq **backquote-flag** nil)
+		      (return nil))
+		     ((or (numberp code)
+			  (eq code t))
+		      (setq **backquote-flag** t)
+		      (return code))
+		     (t (setq **backquote-flag** 'quote)
+			(return code))))
+	      ((eq (car code) **backquote-/,-flag**)
+	       (setq code (cdr code))
+	       (go comma))
+	      ((eq (car code) **backquote-/,/@-flag**)
+	       (setq **backquote-flag** **backquote-/,/@-flag**)
+	       (return (cdr code)))
+	      ((eq (car code) **backquote-/,/.-flag**)
+	       (setq **backquote-flag** **backquote-/,/.-flag**)
+	       (return (cdr code))))
+	(setq a (backquotify (car code)))
+	(setq aflag **backquote-flag**)
+	(setq d (backquotify (cdr code)))
+	(setq dflag **backquote-flag**)
+	(and (eq dflag **backquote-/,/@-flag**)
+	     (error '|-- ",@" after a ".".| code))
+	(and (eq dflag **backquote-/,/.-flag**)
+	     (error '|-- ",." after a ".".| code))
+	(cond ((eq aflag **backquote-/,/@-flag**)
+	       (cond ((null dflag)
+		      (setq code a)
+		      (go comma)))
+	       (setq **backquote-flag** 'append)
+	       (return (cond ((eq dflag 'append)
+			      (cons a d))
+			     (t (list a (backquotify-1 dflag d))))))
+	      ((eq aflag **backquote-/,/.-flag**)
+	       (cond ((null dflag)
+		      (setq code a)
+		      (go comma)))
+	       (setq **backquote-flag** 'nconc)
+	       (return (cond ((eq dflag 'nconc)
+			      (cons a d))
+			     (t (list a (backquotify-1 dflag d))))))
+	      ((null dflag)
+	       (cond ((memq aflag '(quote t nil))
+		      (setq **backquote-flag** 'quote)
+		      (return (list a)))
+		     (t (setq **backquote-flag** 'list)
+			(return (list (backquotify-1 aflag a))))))
+	      ((memq dflag '(quote t))
+	       (cond ((memq aflag '(quote t nil))
+		      (setq **backquote-flag** 'quote)
+		      (return (cons a d)))
+		     (t (setq **backquote-flag** 'list*)
+			(return (list (backquotify-1 aflag a)
+				      (backquotify-1 dflag d)))))))
+	(setq a (backquotify-1 aflag a))
+	(and (memq dflag '(list list*))
+	     (setq **backquote-flag** dflag)
+	     (return (cons a d)))
+	(setq **backquote-flag** 'list*)
+	(return (list a (backquotify-1 dflag d)))
+
+  comma (cond ((atom code)
+	       (cond ((null code)
+		      (setq **backquote-flag** nil)
+		      (return nil))
+		     ((or (numberp code)
+			  (eq code 't))
+		      (setq **backquote-flag** t)
+		      (return code))
+		     (t (setq **backquote-flag**
+			      **backquote-/,-flag**)
+			(return code))))
+	      ((eq (car code) 'quote)
+	       (setq **backquote-flag** 'quote)
+	       (return (cadr code)))
+	      ((memq (car code) '(append list list* nconc))
+	       (setq **backquote-flag** (car code))
+	       (return (cdr code)))
+	      ((eq (car code) 'cons)
+	       (setq **backquote-flag** 'list*)
+	       (return (cdr code)))
+	      (t (setq **backquote-flag** **backquote-/,-flag**)
+		 (return code)))))
+
+(defun backquotify-1 (flag thing)
+  (cond ((or (eq flag **backquote-/,-flag**)
+	     (memq flag '(t nil)))
+	 thing)
+	((eq flag 'quote)
+	 (list 'quote thing))
+	((eq flag 'list*)
+	 (cond ((null (cddr thing))
+		(cons 'cons thing))
+	       (t (cons 'list* thing))))
+	(t (cons flag thing))))
+
+(setsyntax '/: (ascii #^J) nil)
+
+(setsyntax '/" 'macro 'hack-strings)
+
+(defun hack-strings ()
+  (do ((l nil (cons c l))
+       (c (tyi) (tyi)))
+      ((= c #/")
+       (list 'quote (maknam (nreverse l))))
+    (declare (fixnum c))
+    (cond ((= c #//)
+	   (setq c (tyi))))))
+
+(setsyntax '/# 'splicing '/#-macro)
+
+(declare (special /#-macro-arg))
+
+(defun /#-macro ()
+  (do ((c (tyi) (tyi))
+       (n nil (cond ((null n) (- c #/0))
+		    (t (+ (* 10. n)
+			  (- c #/0))))))
+      ((or (< c #/0)
+	   (> c #/9))
+       (or (< c #/a)
+	   (> c #/z)
+	   (setq c (- c #.(- #/a #/A))))
+       ((lambda (ch /#-macro-arg)
+	  ((lambda (chf)
+	     (cond (chf (if (eq (car chf) '/#-macro)
+			    (list (funcall (cadr chf)))
+			    (list (subrcall t (cadr chf)))))
+		   ((setq chf (getl ch '(/#-splicing /#-splicing-subr)))
+		    (if (eq (car chf) '/#-splicing)
+			(funcall (cadr chf))
+			(subrcall t (cadr chf))))
+		   (t (error "-- unknown character to #" ch))))
+	   (getl ch '(/#-macro /#-macro-subr))))
+	(ascii c)
+	n))
+    (declare (fixnum c))))
+
+(defun (// /#-macro /#-macro-subr) ()
+  (tyi))
+
+(defun (/\ /#-macro /#-macro-subr) ()
+  (let ((frob (read)))
+    (cdr (or (assq frob /#/\-alist)
+	     (error "-- unknown frob to #\" frob)))))
+
+(defconst /#/\-alist
+  #O '((sp . 40) (cr . 15) (lf . 12) (line . 12)
+       (bs . 10) (alt . 33) (altmode . 33)
+       (vt . 13) (newline . 15) (help . 4110)
+       (return . 15) (space . 40) (tab . 11)
+       (form . 14) (ff . 14) (rubout . 177)))
+
+(defun (/' /#-macro /#-macro-subr) ()
+  (list 'function (read)))
+
+(declare (special squid))
+
+(defun (/, /#-macro /#-macro-subr) ()
+  (cond ((status feature complr)
+	 (list squid (read)))
+	(t (eval (read)))))
+
+(defun (/. /#-macro /#-macro-subr) () (eval (read)))
+
+(defun (/_ /#-macro /#-macro-subr) () (munkam (read)))
+
+(defun (/B /#-macro /#-macro-subr) () ((lambda (ibase) (read)) 2.))
+
+(defun (/O /#-macro /#-macro-subr) () ((lambda (ibase) (read)) 8.))
+
+(defun (/D /#-macro /#-macro-subr) () ((lambda (ibase) (read)) 10.))
+
+(defun (/X /#-macro /#-macro-subr) ()
+  ((lambda (old ibase)
+     (prog2 (sstatus + t)
+	    (read)
+	    (sstatus + old)))
+   (status +)
+   16.))
+
+(defun (/R /#-macro /#-macro-subr) ()
+  (cond ((fixp /#-macro-arg)
+	 ((lambda (ibase) (read)) /#-macro-arg))
+	(t
+	 (error "-- #<digits>r please!" /#-macro-arg))))
+
+(defun (/^ /#-macro /#-macro-subr) ()
+  ((lambda (c)
+     (declare (fixnum c))
+     (or (< c #/a)
+	 (> c #/z)
+	 (setq c (- c 40)))
+     (logxor #o100 c))
+   (tyi)))
+
+(defun (/| /#-splicing /#-splicing-subr) ()
+  (prog (n)
+        (setq n 0)
+        (go home)
+  sharp (caseq (tyi)
+	  (#/# (go sharp))
+	  (#/| (setq n (1+ n)))
+	  (#// (tyi))
+	  (-1 (go eof)))
+   home (caseq (tyi)
+	  (#/| (go bar))
+	  (#/# (go sharp))
+	  (#// (tyi) (go home))
+	  (-1 (go eof))
+	  (t (go home)))
+    bar (caseq (tyi)
+	  (#/# (cond ((zerop n)
+		      (return nil))
+		     (t
+		      (setq n (1- n))
+		      (go home))))
+	  (#/| (go bar))
+	  (#// (tyi) (go home))
+	  (-1 (go eof))
+	  (t (go home)))
+    eof (error "End of file while parsing /#/| comment.")))
+
+(defun (/Q /#-splicing /#-splicing-subr) () (read) nil)
+
+(defun (/M /#-splicing /#-splicing-subr) () (list (read)))
+
+(defun (/N /#-splicing /#-splicing-subr) () (read) nil)
+
+(defun (/+ /#-splicing /#-splicing-subr) ()
+  ((lambda (test form)
+     (cond ((feature-test test (status features)) (list form))
+	   (t nil)))
+   (read)
+   (read)))
+
+(defun (/- /#-splicing /#-splicing-subr) ()
+  ((lambda (test form)
+     (cond ((feature-test test (status features)) nil)
+	   (t (list form))))
+   (read)
+   (read)))
+
+(defun (defmacro macro) (x)
+  (bind-arguments ((name pattern &body body) (cdr x)
+		      (error '|-- bad format.| x))
+    (let ((x (gensym)))
+      `(defun (,name macro) (,x)
+	 (bind-arguments (,pattern (cdr ,x)
+			     (error '|-- bad format.| ,x))
+	   ,@body)))))
+
+(defmacro let (pairs &body body)
+  (do ((pairs pairs (cdr pairs))
+       (vars nil)
+       (vals nil))
+      ((atom pairs)
+       `((lambda ,(nreverse vars) ,@body) ,@(nreverse vals)))
+    (cond ((atom (car pairs))
+	   (push (car pairs) vars)
+	   (push nil vals))
+	  (t
+	   (bind-arguments ((var &optional (init `nil))
+			    (car pairs)
+			    (error "-- bad variable spec in LET." (car pairs)))
+	     (push var vars)
+	     (push init vals))))))
+
+(defmacro let* (pairs &body body)
+  (cond ((atom pairs) `(progn ,@body))
+	((atom (car pairs))
+	 `((lambda (,(car pairs))
+	     (let* ,(cdr pairs) ,@body))
+	   nil))
+	(t
+	 (bind-arguments ((var &optional (init `nil))
+			  (car pairs)
+			  (error "-- bad variable spec in LET*." (car pairs)))
+	   `((lambda (,var)
+	       (let* ,(cdr pairs) ,@body))
+	     ,init)))))
+
+(defmacro push (item list)
+  `(setf ,list (cons ,item ,list)))
+
+(defmacro pop (x)
+  `(prog1 (car ,x) (setf ,x (cdr ,x))))
+
+(defmacro if (a b &optional (c nil c?))
+  (cond (c? `(cond (,a ,b) (t ,c)))
+	(t `(and ,a ,b))))
+
+(defmacro defvar (var &optional (init nil init?) (doc nil doc?))
+  `(progn 'compile
+	  (comment **special** ,var)
+	  (eval-when (eval load compile)
+	    (and (fboundp 'special) (special ,var)))
+	  ,@(and doc? `((putprop ',var ,doc 'variable-documentation)))
+	  ,@(and init? `((or (boundp ',var) (setq ,var ,init))))
+	  ',var))
+
+(defmacro defconst (var &optional (init nil init?) (doc nil doc?))
+  `(progn 'compile
+	  (comment **special** ,var)
+	  (eval-when (eval load compile)
+	    (and (fboundp 'special) (special ,var)))
+	  ,@(and doc? `((putprop ',var ,doc 'variable-documentation)))
+	  ,@(and init? `((setq ,var ,init)))
+	  ',var))
+
+(defmacro defparameter (var init &optional (doc nil doc?))
+  `(progn 'compile
+	  (comment **special** ,var)
+	  (eval-when (eval load compile)
+	    (and (fboundp 'special) (special ,var)))
+	  ,@(and doc? `((putprop ',var ,doc 'variable-documentation)))
+	  (setq ,var ,init)
+	  ',var))
+
+(defmacro defconstant (var init &optional (doc nil doc?))
+  `(progn 'compile
+	  (comment **special** ,var)
+	  (eval-when (eval load compile)
+	    (and (fboundp 'special) (special ,var))
+	    (defprop ,var t defconstant))
+	  ,@(and doc? `((putprop ',var ,doc 'variable-documentation)))
+	  (setq ,var ,init)
+	  ',var))
+
+(defmacro lambda (bvl &body body)
+  `(function (lambda ,bvl ,@body)))
+
+(defmacro selectq (op &rest stuff)
+  (do ((arg (cond ((atom op) op)
+		  (t (gensym))))
+       (l stuff (cdr l))
+       (r nil (cons `(,(cond ((memq (caar l) '(otherwise t)) 't)
+			     ((atom (caar l)) `(eq ,arg ',(caar l)))
+			     ((null (cdaar l)) `(eq ,arg ',(caaar l)))
+			     (t `(memq ,arg ',(caar l))))
+		      ,@(cdar l))
+		    r)))
+      ((null l) ((lambda (l) (cond ((atom op) l)
+				   (t `((lambda (,arg) ,l) ,op))))
+		 `(cond ,@(nreverse r))))))
+
+(defmacro select (op &rest stuff)
+  (do ((arg (cond ((atom op) op)
+		  (t (gensym))))
+       (l stuff (cdr l))
+       (r nil (cons `(,(cond ((memq (caar l) '(otherwise t)) 't)
+			     (t `(equal ,arg ,(caar l))))
+		      ,@(cdar l))
+		    r)))
+      ((null l) ((lambda (l) (cond ((atom op) l)
+				   (t `((lambda (,arg) ,l) ,op))))
+		 `(cond ,@(nreverse r))))))
+
+(defmacro grindef (&rest args)
+  `(plp ,@args))
+
+(defmacro first (x) `(car ,x))
+(defmacro second (x) `(cadr ,x))
+(defmacro third (x) `(caddr ,x))
+(defmacro fourth (x) `(cadddr ,x))
+(defmacro fifth (x) `(car (cddddr ,x)))
+(defmacro sixth (x) `(cadr (cddddr ,x)))
+(defmacro seventh (x) `(caddr (cddddr ,x)))
+(defmacro eighth (x) `(cadddr (cddddr ,x)))
+
+(defmacro rest (x) `(cdr ,x))
+
+(defmacro <= (a b) `(not (> ,a ,b)))
+(defmacro >= (a b) `(not (< ,a ,b)))
+(defmacro / (a b) `(not (> ,a ,b)))
+(defmacro / (a b) `(not (< ,a ,b)))
+(defmacro / (a b) `(not (= ,a ,b)))
+
+(defmacro neq (x y) `(not (eq ,x ,y)))
+
+(defmacro logand x `(boole #b0001 . ,x))
+(defmacro logior x `(boole #b0111 . ,x))
+(defmacro logxor x `(boole #b0110 . ,x))
+(defmacro logeqv x `(boole #b1001 . ,x))
+
+(defmacro lognand  (x y) `(boole #b1110 ,x ,y))
+(defmacro lognor   (x y) `(boole #b1000 ,x ,y))
+(defmacro logandc1 (x y) `(boole #b0010 ,x ,y))
+(defmacro logandc2 (x y) `(boole #b0100 ,x ,y))
+(defmacro logorc1  (x y) `(boole #b1011 ,x ,y))
+(defmacro logorc2  (x y) `(boole #b1101 ,x ,y))
+
+(defmacro lognot (x) `(boole #b0110 -1 ,x))
+
+(defmacro logtest (x y) `(not (zerop (boole #b0001 ,x ,y))))
+
+(defmacro logbitp (i x) `(not (zerop (boole #b0001 (lsh 1 ,i) ,x))))
+
+(defmacro dotimes ((var form) &body body)
+  (let ((dum (gensym)))
+    `(do ((,var 0 (1+ ,var))
+	  (,dum ,form))
+	 ((not (< ,var ,dum)))
+       (declare (fixnum ,var ,dum))
+       . ,body)))
+
+(defmacro dolist ((var form) &body body)
+  (let ((dum (gensym)))
+    `(do ((,dum ,form (cdr ,dum))
+	  (,var))
+	 ((null ,dum))
+       (setq ,var (car ,dum))
+       . ,body)))
+
+(defmacro arrayp (object) `(eq (typep ,object) 'array))
+
+(defmacro rem (pred item list &optional (n #.(lognot (rot 1 -1))))
+  `(*rem ,pred ,item ,list ,n))
+
+(defmacro remove (item list &optional (n #.(lognot (rot 1 -1))))
+  `(*rem #'equal ,item ,list ,n))
+
+(defmacro remq (item list &optional (n #.(lognot (rot 1 -1))))
+  `(*rem #'eq ,item ,list ,n))
+
+(defmacro del (pred item list &optional (n #.(lognot (rot 1 -1))))
+  `(*del ,pred ,item ,list ,n))
+
+(defmacro aref (array &rest coords)
+  `(arraycall t ,array ,@coords))
+
+(defmacro aset (data array &rest coords)
+  (let ((g (gensym)))
+    `((lambda (,g)
+	(store (arraycall t ,array ,@coords) ,g))
+      ,data)))
+
+(defmacro byte (size &optional (position 0))
+  (setq size (macroexpand size))
+  (setq position (macroexpand position))
+  (if (fixp size)
+      (if (fixp position)
+	  (dpb position #o0606 (logand size #o77))
+	  `(dpb ,position #o0606 ,(logand size #o77)))
+      (if (fixp position)
+	  (let ((pp00 (dpb position #o0606 0)))
+	    (if (zerop pp00)
+		`(logand ,size #o77)
+		`(dpb ,size #o0006 ,pp00)))
+	  `(dpb ,position #o0606 (logand ,size #o77)))))
+
+(defmacro byte-size (byte-spec)
+  `(logand ,byte-spec #o77))
+
+(defmacro byte-position (byte-spec)
+  `(ldb #o0606 ,byte-spec))
+
+;;;In incf and decf we assume that the user is not using bignums.  Also we
+;;;promote the use of 1+ and 1- for no good reason...
+(defmacro incf (ref &optional (inc 1))
+  (if (equal inc 1)
+      `(setf ,ref (1+ ,ref))
+      `(setf ,ref (+ ,ref ,inc))))
+
+(defmacro decf (ref &optional (dec 1))
+  (if (equal dec 1)
+      `(setf ,ref (1- ,ref))
+      `(setf ,ref (- ,ref ,dec))))
+
+(defmacro copylist (l)
+  `(append ,l nil))
+
+(defmacro copylist* (l)
+  `(append ,l nil))
+
+(defmacro when (test &body body)
+  `(cond (,test (progn ,@body))))
+
+(defmacro unless (test &body body)
+  `(cond ((not ,test) (progn ,@body))))
+
+(defmacro with-open-stream ((var stream) &body body)
+  `((lambda (,var)
+      (unwind-protect (progn ,@body)
+		      (close ,var)))
+    ,stream))
+
+(defmacro with-open-file ((var &rest openargs) &body body)
+  `((lambda (,var)
+      (unwind-protect (progn ,@body)
+		      (close ,var)))
+    (open ,@openargs)))
+
+(defmacro deflap ((name type &optional (arg1 nil args-p) (arg2 arg1 arg2-p))
+		  &body lap)
+  `(progn 'compile
+	  (lap-a-list
+	    '((lap ,name ,type)
+	      ,@(and args-p
+		     `((args ,name
+			     ,(cond ((or (not (atom arg1)) (eq type 'subr))
+				     (when arg2-p
+				       (error "-- self-contradictory deflap."
+					      name))
+				     (if (atom arg1)
+					 `(nil . ,arg1)
+					 arg1))
+				    (t `(,arg1 . ,arg2))))))
+	      ,@lap
+	      ()))
+	  ',name))
+
+(defmacro make-array (dims &rest rest)
+  (do ((l rest (cddr l))
+       (type t))
+      ((null l)
+       (cond ((fixp dims)
+	      `(array nil ,type ,dims))
+	     ((or (atom dims)
+		  (not (memq (car dims) '(quote list))))
+	      `(*make-array ,dims '(type ,type)))
+	     ((eq (car dims) 'list)
+	      `(array nil ,type ,@(cdr dims)))
+	     ((fixp (cadr dims))
+	      `(array nil ,type ,(cadr dims)))
+	     (t
+	      `(array nil ,type ,@(cadr dims)))))
+    (let ((i (car l))
+	  (p (cadr l)))
+      (and (or (fixp p)
+	       (memq p '(t nil)))
+	   (setq p (list 'quote p)))
+      (if (or (atom i)
+	      (not (eq (car i) 'quote))
+	      (caseq (cadr i)
+		((type /:type)
+		 (or (atom p)
+		     (not (eq (car p) 'quote))
+		     (progn
+		      (setq type
+			    (caseq (cadr p)
+			      ((art-q t) t)
+			      ((art-32b art-16b art-8b art-4b
+				art-2b art-1b fixnum)
+			       'fixnum)
+			      ((art-float flonum) 'flonum)
+			      ((nil) nil)
+			      (t (error "-- unsupported make-array type."
+					(cadr p)))))
+		      nil)))
+		((area /:area named-structure /:named-structure) nil)
+		((initial-value /:initial-value) t)
+		(t (error "-- unsupported make-array option." (cadr i)))))
+	   (return `(*make-array ,dims (list ,@rest)))))))
+
+(defmacro feature-case (&body clauses)
+  (let ((name (if (atom (car clauses))
+		  (pop clauses)
+		  'feature-case)))
+    (do ((clauses clauses (cdr clauses))
+	 (features (status features)))
+	((null clauses)
+	 (error "-- no matching features found." name))
+      (when (feature-test (caar clauses) features)
+	(return (if (null (cddar clauses))
+		    (cadar clauses)
+		    `(progn 'compile
+			    ,@(cdar clauses))))))))
+
+(defun feature-test (feature features)
+  (cond ((atom feature)
+	 (memq feature features))
+	((eq (car feature) 'not)
+	 (not (feature-test (cadr feature) features)))
+	((eq (car feature) 'and)
+	 (loop for feature in (cdr feature)
+	       always (feature-test feature features)))
+	((eq (car feature) 'or)
+	 (loop for feature in (cdr feature)
+	       thereis (feature-test feature features)))
+	(t (error "-- unknown feature form." feature))))
+
+(defmacro append-symbols args
+  (do ((l (reverse args) (cdr l))
+       (x)
+       (a nil (if (or (atom x)
+		      (not (eq (car x) 'quote)))
+		  (if (null a)
+		      `(exploden ,x)
+		      `(nconc (exploden ,x) ,a))
+		  (let ((l (exploden (cadr x))))
+		    (cond ((null a) `',l)
+			  ((= 1 (length l)) `(cons ,(car l) ,a))
+			  (t `(append ',l ,a)))))))
+      ((null l) `(implode ,a))
+    (setq x (car l))))
+
+;;;first arg is ALWAYS a symbol or a quoted symbol:
+(defmacro transgression (message &rest args)
+  (let* ((chars (nconc (exploden (if (atom message)
+				     message
+				     (cadr message)))
+		       '(#/.)))		;"Bad frob" => "Bad frob."
+	 (new-message
+	  (maknam (if (null args)
+		      chars
+		      (let ((c (car chars)))	;"Bad frob." => "-- bad frob."
+			(or (< c #/A)
+			    (> c #/Z)
+			    (rplaca chars (+ c #o40)))
+			(append '(#/- #/- #\space) chars))))))
+  `(error ',new-message
+	  ,@(cond ((null args) `())
+		  ((null (cdr args)) `(,(car args)))
+		  (t `((list ,@args)))))))
+
+(defvar *val2*)
+(defvar *val3*)
+(defvar *val4*)
+(defvar *val5*)
+(defvar *val6*)
+(defvar *val7*)
+(defvar *val8*)
+(defvar *val9*)
+(defconst *values-vars* '(*val2* *val3* *val4* *val5*
+			  *val6* *val7* *val8* *val9*))
+
+(defmacro values (first &rest rest)
+  (unless (<= (length rest) (length *values-vars*))
+    (error "-- too many values." rest))
+  `(prog1 ,first
+	  ,@(loop for var in *values-vars*
+		  for val in rest
+		  collecting `(setq ,var ,val))))
+
+(defmacro with-values (((first &rest rest) form) &body body)
+  (unless (<= (length rest) (length *values-vars*))
+    (error "-- too many values." rest))
+  `((lambda (,first ,@rest) ,@body)
+    ,form
+    ,@(loop for foo in rest
+	    for var in *values-vars*
+	    collecting var)))
+
+;;;third arg is ALWAYS a symbol or a quoted symbol:
+(defmacro check-arg (place predicate description)
+  (let ((test (if (symbolp predicate)
+		  `(,predicate ,place)
+		  predicate))
+	(msg (append-symbols "-- is not "
+			     (if (atom description)
+				 description
+				 (cadr description))
+			     ".")))
+    `(do ()
+	 (,test)
+       (setf ,place (error ',msg ,place 'wrng-type-arg)))))
+
+(declare (or (get 'defstruct-description-predicate 'macro)
+	     (load '((alan) struct))))
+
+;;;second arg is ALWAYS a symbol
+;;;third arg, if given, is ALWAYS a symbol or a quoted symbol:
+(defmacro check-arg-type (place type-name &optional description)
+  (let ((description (or description
+			 (get type-name 'check-arg-type-description)
+			 (append-symbols "a " type-name)))
+	(predicate (or (get type-name 'check-arg-type-predicate)
+		       (let ((desc (get type-name 'defstruct-description)))
+			 (and (not (null desc))
+			      (defstruct-description-predicate desc)))
+		       (append-symbols type-name "?"))))
+    `(check-arg ,place ,predicate ,description)))
+
+(defprop :symbol symbolp check-arg-type-predicate)
+(defprop :list |a cons| check-arg-type-description)
+(defprop :list list-check-arg-type check-arg-type-predicate)
+(defmacro list-check-arg-type (x) `(eq 'list (typep ,x)))
+(defprop :array |an array| check-arg-type-description)
+(defprop :array arrayp check-arg-type-predicate)
+(defprop :atom |an atom| check-arg-type-description)
+(defprop :atom atom check-arg-type-predicate)
+(defprop :hunk hunkp check-arg-type-predicate)
+(defprop :file filep check-arg-type-predicate)
+(defprop :sfa |an SFA| check-arg-type-description)
+(defprop :sfa sfap check-arg-type-predicate)
+(defprop :list-or-nil |a cons or nil| check-arg-type-description)
+(defprop :list-or-nil list-or-nil-check-arg-type check-arg-type-predicate)
+(defmacro list-or-nil-check-arg-type (x) `(or (null ,x) (eq 'list (typep ,x))))
+(defprop :number numberp check-arg-type-predicate)
+(defprop :fix |an integer| check-arg-type-description)
+(defprop :fix fixp check-arg-type-predicate)
+(defprop :fixnum fixnum-check-arg-type check-arg-type-predicate)
+(defmacro fixnum-check-arg-type (x) `(and (fixp ,x) (not (bigp ,x))))
+(defprop :bignum bigp check-arg-type-predicate)
+(defprop :float floatp check-arg-type-predicate)
+(defprop :float |a floating point number| check-arg-type-description)
+(defprop :flonum floatp check-arg-type-predicate)
+
+; So who needs a code walker?
+
+(defun macrolet-process-body (defs body)
+  (if (atom body)
+      body
+      (cons (macrolet-process-expr defs (car body))
+	    (macrolet-process-body defs (cdr body)))))
+
+(defun macrolet-process-expr (defs expr)
+  (if (atom expr)
+      expr
+      (let ((def (assq (car expr) defs)))
+	(if (null def)
+	    (macrolet-process-body defs expr)
+	    (macrolet-process-expr defs (funcall (cdr def) (cdr expr)))))))
+
+(defmacro macrolet (defs &body body)
+  (let ((var (gensym)))
+    `(progn
+       ,@(macrolet-process-body
+	   (loop for def in defs
+		 collecting (cons (car def)
+				  `(lambda (,var)
+				     (bind-arguments (,(cadr def) ,var)
+				       ,@(cddr def)))))
+	   body))))
+
+(defmacro defsubst (name vars expr)
+  `(progn 'compile
+	  (defun ,name ,vars ,expr)
+	  (defprop ,name (,vars . ,expr) defsubst)
+	  (defprop ,name expand-defsubst macro)))
+
+(declare (special dumper-info-list))
+
+(defun lspenv-dumper (dump-name init-name)
+  (let ((f #'(lambda (x) (list (+ #/0 (// x 10.)) (+ #/0 (\ x 10.)))))
+	(ti (status daytime))
+	(d (status date))
+	(*nopoint t)
+	(base 10.))
+    (setq dumper-info-list
+	  (list
+	   (status xuname)
+	   (implode (nconc (exploden (cadr d))
+			   (cons #//
+				 (nconc (exploden (caddr d))
+					(cons #// (exploden (car d)))))))
+	   (implode (nconc (exploden (car ti))
+			   (cons #/:
+				 (nconc (funcall f (cadr ti))
+					(cons #/: (funcall f (caddr ti)))))))
+	   dump-name
+	   init-name)))
+  (sstatus flush t)
+  (gc)
+  (cond ((status feature ITS)
+	 (suspend #o160000 dump-name))
+	((status feature TOPS-20)
+	 (suspend dump-name))
+	(t
+	 (error "Unknown site for dumping.")))
+  (sstatus gctime 0)
+  (defaultf (list (list (status udir))))
+  (cond ((status feature ITS)
+	 (let ((init (let ((jcl (status jcl)))
+		       (if (not (null jcl))
+			   (implode (nreverse (cdr (nreverse jcl))))
+			   `((DSK ,(status hsname))
+			     ,(status xuname)
+			     ,init-name)))))
+	   (if (probef init)
+	       (load init))))
+	((status feature TOPS-20)
+	 (let ((init `((PS ,(status hsname)) ,init-name INI)))
+	   (if (probef init)
+	       (load init)))))
+  '*)
+
+(sstatus feature alan/;lspenv)
diff --git a/src/alan/lspenv.fasl b/src/alan/lspenv.fasl
new file mode 100755
index 00000000..1c54c530
Binary files /dev/null and b/src/alan/lspenv.fasl differ
diff --git a/src/alan/lspenv.init b/src/alan/lspenv.init
new file mode 100755
index 00000000..e50be634
--- /dev/null
+++ b/src/alan/lspenv.init
@@ -0,0 +1,68 @@
+;;;-*-Lisp-*-
+
+(cond ((and (status feature complr)
+	    (not (boundp 'alan/;flushed)))
+       (own-symbol let let* defmacro setf defsetf push pop incf decf if
+		   defvar defconst selectq first second third fourth fifth
+		   sixth seventh eighth rest <= >= / / / logand
+		   logior logxor lognot dotimes dolist arrayp rem
+		   remove remq del ass mem listp create-array aref aset
+		   make-array ldb dpb y-or-n-p yes-or-no-p
+		   ferror cerror describe inspect byte byte-size byte-position
+		   macroexpand macroexpand-1)
+       (setq alan/;flushed t)))
+
+(cond ((status feature ITS)
+       (defprop lspenv (dsk alan) ppn))
+      ((status feature OZ)
+       (defprop lspenv (ps alan/.maclisp) ppn))
+      ((status feature EE)
+       (defprop liblsp (ps maclisp) ppn)
+       (defprop lspenv (ps alan) ppn))
+      ((status feature SCRC-TENEX)
+       (defprop liblsp (dsk maclisp) ppn)
+       (defprop lspenv (dsk alan) ppn))
+      (t (error '|Unknown site for lisp environment.|)))
+
+((lambda (fasload noldmsg)
+   (sstatus feature noldmsg)
+   (or (status feature alan/;lspint)
+       (load '((lspenv) lspint)))
+   (cond ((status feature complr)
+	  (or (status feature alan/;lspcom)
+	      (load '((lspenv) lspcom)))))
+   (or (status feature alan/;binda)
+       (load '((lspenv) binda)))
+   (or (status feature alan/;lspenv)
+       (load '((lspenv) lspenv)))
+   (or (status feature alan/;setf)
+       (load '((lspenv) setf)))
+   (cond ((not (status feature complr))
+	  (or (get 'gcdemn 'version)
+	      (load '((lisp) gcdemn)))
+	  (or (status feature alan/;dprint)
+	      (load '((lspenv) dprint)))
+	  (or (status usrhu)
+	      (dprint t))))
+   (defprop step ((liblsp) step fasl) autoload)
+   (defprop dribble ((liblsp) dribbl fasl) autoload)
+   (defprop apropos ((liblsp) apropo fasl) autoload)
+   (defprop crawl ((lspenv) crawl fasl) autoload)
+   (putprop '?format (get 'format 'autoload) 'autoload)
+   (defprop faslist ((lspenv) faslro fasl) autoload)
+   (cond ((not (status feature defstruct))
+	  (define-autoload-macros '((lspenv) struct fasl)
+	    '(defstruct defstruct-define-type))
+	  (define-autoloads '((lspenv) struct fasl)
+	    '(defstruct-expand-ref-macro defstruct-expand-cons-macro
+	      defstruct-expand-alter-macro defstruct-expand-size-macro))))
+   (cond ((not (get 'gprint 'version))
+	  (define-autoload-macros '((liblsp) gprint fasl)
+	    '(gformat gf))
+	  (define-autoloads '((liblsp) gprint fasl)
+	    '(gprint gprint1 gprinc pl gexplode gexplodec
+	      plp gset-up-printer))))
+   (or noldmsg
+       (sstatus nofeature noldmsg)))
+ nil
+ (status feature nodlmsg))
diff --git a/src/alan/lspgub.71 b/src/alan/lspgub.71
new file mode 100755
index 00000000..3f4f436d
--- /dev/null
+++ b/src/alan/lspgub.71
@@ -0,0 +1,458 @@
+;;;-*-Lisp-*-
+
+(declare (load '((alan) lspenv init)))
+
+(setq base 8)
+(setq ibase 8)
+(setq *nopoint t)
+
+(setq pure 1)
+(setq fasload nil)
+
+(sstatus _ nil)
+
+(sstatus feature noldmsg)
+
+(setq gc-daemon-print nil)
+
+(cond ((status feature ITS)
+
+(defprop ljob-expand-run-macro ((alan) ljob fasl) autoload)
+(setq ljob-search-rules '(alan sys sys1 sys2 sys3 bawden))
+(let ((udir (status udir))
+      (homedir (status homedir)))
+  (or (memq homedir ljob-search-rules)
+      (push homedir ljob-search-rules))
+  (or (memq udir ljob-search-rules)
+      (push udir ljob-search-rules)))
+(mapc '(lambda (x) (putprop x 'ljob-expand-run-macro 'macro))
+      '(peek p os sn chater vv vj tty fretty dskuse
+	oldjob probe pb % who%
+	what j k ddt spell tags 
+	lisp l q ol xlisp xl xq
+	complr c oc xc qc xqc faslis faslist fl
+	finger f name whois who whoj w lookup u inquir
+	mail bug qsend send s lmsend reply
+        supdup ai ml mc oz ee xx
+	pty sty telnet tn chtn mul mult multic multics 
+	midas m find dover /@ ftp cftp
+	macsym macsyma a srccom ttloc ttyloc lsc info tctyp tctype
+	e emacs
+	memo %tiful chat cli clu conkil its jade prime rfc
+	))
+
+(sstatus who1 #o52 #/% #o166 0)
+(sstatus who3 0)
+(sstatus gcwho 3)
+
+(defprop *uset ((liblsp) lusets fasl) autoload)
+
+)) ;;end (cond ((status feature ITS) ...))
+
+(defun y-or-n-p ()
+  (do ((ch (tyi t) (tyi t)))
+      (nil)
+    (declare (fixnum ch))
+    (cond ((or (= ch #/Y) (= ch #/y))
+	   (princ "es" t) (return t))
+	  ((or (= ch #/N) (= ch #/n))
+	   (princ "o" t) (return  nil))
+	  ((= ch #\sp)
+	   (princ "Yes" t) (return t))
+	  ((= ch #\rubout)
+	   (princ "No" t) (return nil))
+	  (t (tyo 7 t)))))
+
+(declare (special load-file))
+
+(defun loadf n
+  (do ((ar (and (> n 0) (arg 1)))
+       (to-load)
+       (default (namelist nil)))
+      (())
+    (terpri t)
+    (and (null ar) (cond ((boundp 'load-file)
+			  (setq ar load-file)
+			  (go l))
+			 (t (go r))))
+    (or (eq ar 't) (go l))
+  R (princ ";File to load: " t)
+    (setq ar (readline t))
+  L (setq ar (mergef ar default))
+    (cond ((setq to-load (probef ar))
+	   (princ ";Loading " t)
+	   (princ (namestring to-load) t)
+	   (setq load-file ar)
+	   (load to-load)
+	   (return t))
+	  (t
+	   (princ ";No such file as " t)
+	   (princ (namestring ar) t)
+	   (princ "  Try again? " t)
+	   (cond ((y-or-n-p)
+		  (terpri t)
+		  (setq default ar)
+		  (go r)))
+	   (return nil)))))
+
+(defun dbug (x)
+  (cond (x (nouuo t)
+	   (sstatus uuolinks))
+	(t (nouuo nil))))
+
+(defun base (n)
+  (setq base n)
+  (setq ibase n)
+  *)
+
+(defmacro bind-nointerrupt-nil (&body body)
+  (let ((old (gensym)))
+    `((lambda (,old)
+	(unwind-protect (progn (nointerrupt nil)
+			       ,@body)
+			(nointerrupt ,old)))
+      (status nointerrupt))))
+
+(defun 20X-^f-function (() ())
+  (bind-nointerrupt-nil
+    (loadf)
+    (princ " Done." t)
+    (terpri t)))
+
+(defun ITS-^f-function (f ())
+  (syscall #o1_22 'ttyfls f)
+  (bind-nointerrupt-nil
+    (loadf)
+    (princ " Done." t)
+    (terpri t)))
+
+(defvar *elisp-^e-valret*
+  (cond ((status feature ITS) "E")
+	(t "EMACSî/
")))
+
+(defun elisp-20X-^e-function (() ())
+  (valret *elisp-^e-valret*)
+  (elisp-tty-return '^e))
+
+(defun elisp-20X-^z-function (() ())
+  (valret)
+  (elisp-tty-return '^z))
+
+(defun elisp-ITS-^e-function (f ())
+  (syscall #o1_22 'ttyfls f)
+  (valret *elisp-^e-valret*)
+  (elisp-welcome-back))
+
+(defun elisp-ITS-^z-function (f ())
+  (syscall #o1_22 'ttyfls f)
+  (valret 0)
+  (elisp-welcome-back))
+
+(defun elisp-tty-return (state)
+  (check-for-elisp-turds)
+  (unless (null state)
+    (elisp-welcome-back)))
+
+(defun elisp-welcome-back ()
+  (cursorpos 'A t)
+  (princ ";Back to Lispî/
" t))
+
+(defvar *elisp-filename* nil)
+
+(defun check-for-elisp-turds ()
+  (let ((name (probef (or *elisp-filename*
+			  (setq *elisp-filename*
+				(cond ((status feature ITS)
+				       `((DSK ,(status hsname))
+					 _ELISP ,(status uname)))
+				      (t
+				       `((TEMP) ELISP TMP))))))))
+    (unless (null name)
+      (cursorpos 'A t)
+      (princ ";Reading... " t)
+      (let ((f (open name)))
+	(unwind-protect (progn (deletef name)
+			       (bind-nointerrupt-nil (elisp-load f)))
+			(close f)))
+      (sstatus uuolinks)
+      (princ "î/
;Done.î/
" t))
+    name))
+
+(defun elisp-load (f)
+  (loop for form = (read f f)
+	until (eq form f)
+	for value = (eval form)
+	do (when (atom value)
+	     (prin1 value t)
+	     (princ " " t))))
+
+(defun print-runtimes (f)
+  (terpri f)
+  (princ "R=" f)
+  (princ-time (runtime) f)
+  (princ " GC=" f)
+  (princ-time (status gctime) f))
+
+(defun princ-time (r f)
+  (declare (fixnum r))
+  (let ((base 10.)
+	(*nopoint t))
+    (prog (m s d)
+      (declare (fixnum m s d))
+      (setq r (// r 100000.))
+      (setq d (\ r 10.))
+      (setq r (// r 10.))
+      (setq s (\ r 60.))
+      (setq r (// r 60.))
+      (if (zerop r) (go S))
+      (setq m (\ r 60.))
+      (setq r (// r 60.))
+      (if (zerop r) (go M))
+      (princ r f)
+      (princ ":" f)
+      (if (< m 10.)
+	  (princ "0" f))
+    M (princ m f)
+      (princ ":" f)
+      (if (< s 10.)
+	  (princ "0" f))
+    S (princ s f)
+      (princ "." f)
+      (princ d f))))
+
+(push '(print-runtimes t) errlist)
+
+(defun 20X-^t-function (() ())
+  (print-runtimes t)
+  (terpri t)
+  (check-for-elisp-turds))
+
+(defun ITS-^t-function (f ())
+  (syscall #o1_22 'ttyfls f)
+  (print-runtimes t)
+  (terpri t)
+  (check-for-elisp-turds))
+
+(declare (special gc-daemon-print))
+
+(defun 20X-^d-function (() ())
+  (if (setq gc-daemon-print (not gc-daemon-print))
+      (princ "î/
;GC Printing On.î/
" t)
+      (princ "î/
;GC Printing Off.î/
" t)))
+
+(defun ITS-^d-function (f ())
+  (syscall #o1_22 'ttyfls f)
+  (if (setq gc-daemon-print (not gc-daemon-print))
+      (princ "î/
;GC Printing On.î/
" t)
+      (princ "î/
;GC Printing Off.î/
" t)))
+
+(cond ((status feature ITS)
+       (setq tty-return 'elisp-tty-return)
+       (sstatus ttyint #^e 'elisp-ITS-^e-function)
+       (sstatus ttyint #^z 'elisp-ITS-^z-function)
+       (sstatus ttyint #^t #'ITS-^t-function)
+       (sstatus ttyint #^d #'ITS-^d-function)
+       (sstatus ttyint #^f #'ITS-^f-function))
+      (t
+       (sstatus ttyint #^e 'elisp-20X-^e-function)
+       (sstatus ttyint #^z 'elisp-20X-^z-function)
+       (sstatus ttyint #^t #'20X-^t-function)
+       (sstatus ttyint #^d #'20X-^d-function)
+       (sstatus ttyint #^f #'20X-^f-function)))
+
+(defvar **-manager nil)
+(defvar ** nil)
+(defvar *** nil)
+
+(defun **-manager (val)
+  (setq *** **)
+  (setq ** **-manager)
+  (setq **-manager val)
+  val)
+
+(setq read-eval-*-print '**-manager)
+
+(defvar ++-manager nil)
+(defvar -- nil)
+(defvar ++ nil)
+(defvar +++ nil)
+
+(defun ++-manager (form)
+  (unless (eq form '+)
+    (setq +++ ++)
+    (setq ++ --)
+    (setq -- ++-manager)
+    (setq ++-manager form))
+  form)
+
+(setq read-*-eval-print '++-manager)
+
+(setq miser-width 20)
+(setq major-width 20)
+(setq plp-properties
+      '(convert xmacro defstruct-name defstruct-slot /:function /:value))
+(setq gprint-array-contents nil)
+(setq gsymbol-car-format '/:G1block)
+(setq gnon-symbol-car-format '/:G1block)
+
+(defun (bind-arguments /:gformat) (x)
+  (GF |(2*_(1%gformat-bvl -*!*)<!*>)| x))
+
+(defprop caseq gformat-caseq /:gformat)
+(defprop selectq gformat-caseq /:gformat)
+(defun gformat-caseq (x)
+  (GF |(2*_*<!(2(1<*,>)<-*>)>)| x))
+
+(defprop block gformat-catch /:gformat)
+(defprop catch gformat-catch /:gformat)
+(defprop *catch gformat-catch /:gformat)
+(defun gformat-catch (x)
+  (GF |(2*_<*->)| x))
+
+(defun (defun /:gformat) (x)
+  (GF |(2*_*_%gformat-bvl <!*>)| x))
+
+;;;Do this even better someday:
+(defun gformat-bvl (x)
+  (cond ((null x) (GF |'()'|))
+	((atom x) (GF |*| x))
+	(t (GF |(1<*,>)| x))))
+
+(defun (feature-case /:gformat) (x)
+  (GF |{2'('*| (car x))
+  (when (atom (cadr x))
+    (setq x (cdr x))
+    (GF |_*| (car x)))
+  (GF |[<!(2(1<*,>)<-*>)>]')'}| (cdr x)))
+
+(defun (iterate /:gformat) (x)
+  (GF |(2*_*_(1<*->)<!*>)| x))
+
+(defvar *gformat-loop-keywords*		;Use these if LOOP isn't loaded:
+  '((for) (as) (repeat) (initially) (finally) (do) (doing) (return) (collect)
+    (collecting) (append) (appending) (nconc) (nconcing) (count) (counting)
+    (sum) (summing) (maximize) (minimize) (always) (never) (thereis) (while)
+    (until) (when) (if) (unless) (with)))
+
+(defun (loop /:gformat) (x)
+  (let ((*gformat-loop-keywords*
+	  (if (and (boundp 'loop-keyword-alist)
+		   (boundp 'loop-iteration-keyword-alist))
+	      (append loop-iteration-keyword-alist loop-keyword-alist)
+	      *gformat-loop-keywords*)))
+    (GF |(+2*_*<%gformat-loop-element >)| x)))
+
+(defun gformat-loop-element (x)
+  (if (assq x *gformat-loop-keywords*)
+      (GF |!~-2*| x)
+      (GF |,*| x)))
+
+(defprop kappa gformat-lambda /:gformat)
+(defprop lambda gformat-lambda /:gformat)
+(defun gformat-lambda (x)
+  (GF |(2*_%gformat-bvl <-*>)| x))
+
+(defprop named-kappa gformat-named-lambda /:gformat)
+(defprop named-lambda gformat-named-lambda /:gformat)
+(defun gformat-named-lambda (x)
+  (GF |(2*_*_%gformat-bvl <-*>)| x))
+
+(defun (labels /:gformat) (x)
+  (GF |(2*_(1<$gformat-definition !>)<!*>)| x))
+
+(defun (perform /:gformat) (x)
+  (GF |(2*_*<!$gformat-definition >)| x))
+
+(defun gformat-definition (def)
+  (GF |{2'('*| (car def))
+  (if (symbolp (car def))	;should call gformat-bvl sometimes.
+      (GF |_*| (cadr def))
+      (GF |-*| (cadr def)))
+  (GF |[<-*>]')'}| (cddr def)))
+
+;;;Disarming this kludge once again.
+(defun (macroexpanded /:gformat) (x)
+  (GF |(2*<!*>)| x))
+
+;;;Can't make PROGN (PROG1, PROG2) choose between:
+;;;	(progn foo
+;;;	       bar
+;;;	       baz)
+;;;and:
+;;;	(progn
+;;;	  foo
+;;;	  bar
+;;;	  baz)
+
+;;;TAGBODY?  Ugh!
+
+(defprop unwind-protect gformat-when /:gformat)
+(defprop when gformat-when /:gformat)
+(defprop unless gformat-when /:gformat)
+(defun gformat-when (x)
+  (GF |(2*_*<!*>)| x))
+
+(defun (with-open-file /:gformat) (x)
+  (GF |(2*_(*_*-*)<!*>)| x))
+
+(defun (with-values /:gformat) (x)
+  (GF |(2*_(1%gformat-bvl -*)<!*>)| x))
+
+(defmacro try (f)
+  (let ((g (gensym)))
+    (or (get 'gprint1 'lsubr)
+	(load '((liblsp) gprint fasl)))
+    `(do ((,g '* (,f (read))))
+	 (nil)
+       (terpri)
+       (gprint1 ,g nil nil nil nil nil nil)
+       (terpri))))
+
+(declare (special ++))
+
+(defun unbound-variable-break (args)
+  (declare (special args))
+  (errprint nil msgfiles)
+  (let ((obarray (get 'obarray 'array))
+	(readtable (get 'readtable 'array)))
+    (setq ++ (car args))
+    (bind-nointerrupt-nil (break unbound-variable))
+    args))
+
+(defun undefined-function-break (args)
+  (declare (special args))
+  (errprint nil msgfiles)
+  (let ((obarray (get 'obarray 'array))
+	(readtable (get 'readtable 'array)))
+    (setq ++ (car args))
+    (bind-nointerrupt-nil (break undefined-function))
+    args))
+
+(defun wrong-type-argument-break (args)
+  (declare (special args))
+  (errprint nil msgfiles)
+  (let ((obarray (get 'obarray 'array))
+	(readtable (get 'readtable 'array)))
+    (setq ++ (car args))
+    (rplaca args
+	    (bind-nointerrupt-nil (break wrong-type-argument)))
+    args))
+
+(declare (special flush))
+(or (boundp 'flush) (setq flush t))
+
+(defun autoload-warn (x)
+  (cond ((or (eq flush 't)
+	     (atom (cdr x))
+	     (memq (caddr x) flush))
+	 (terpri t)
+	 (princ ";AutoLoading " t)
+	 (prin1 x t)
+	 (terpri t)))
+      (+internal-autoload x))
+
+(setq unbnd-vrbl 'unbound-variable-break
+      undf-fnctn 'undefined-function-break
+      wrng-type-arg 'wrong-type-argument-break
+      autoload 'autoload-warn
+      )
diff --git a/src/alan/lspgub.fasl b/src/alan/lspgub.fasl
new file mode 100755
index 00000000..6b1f6097
Binary files /dev/null and b/src/alan/lspgub.fasl differ
diff --git a/src/alan/lspint.46 b/src/alan/lspint.46
new file mode 100755
index 00000000..4bcee100
--- /dev/null
+++ b/src/alan/lspint.46
@@ -0,0 +1,205 @@
+;;;-*-Lisp-*-
+
+(declare (load '((alan) lspenv init)))
+
+(defun *make-array (dims opts)
+  (do ((opts opts (cddr opts))
+       (type t)
+       (ival nil)
+       (ival-p nil))
+      ((null opts)       
+       (let ((a (cond ((fixp dims)
+		       (*array nil type dims))
+		      ((atom dims)
+		       (error '|-- bad dimension list to make-array.| dims))
+		      (t
+		       (lexpr-funcall '*array nil type dims)))))
+	 (if ival-p
+	     (fillarray a (list ival)))
+	 a))
+    (caseq (car opts)
+      ((type /:type)
+       (setq type
+	     (caseq (cadr opts)
+	       ((art-q t) t)
+	       ((art-32b art-16b art-8b art-4b art-2b art-1b fixnum) 'fixnum)
+	       ((art-float flonum) 'flonum)
+	       ((nil) nil)
+	       (t (error '|-- unsupported make-array type.| opts)))))
+      ((area /:area named-structure /:named-structure))
+      ((initial-value /:initial-value)
+       (setq ival (cadr opts))
+       (setq ival-p t))
+      (t (error '|-- unsupported make-array option.| opts)))))
+
+(defun expand-defsubst (form)
+  (let ((def (get (car form) 'defsubst)))
+    (do ((vars (car def) (cdr vars))
+	 (exprs (cdr form) (cdr exprs))
+	 (alist '() (cons (cons (car vars) (car exprs)) alist)))
+	((null vars)
+	 (unless (null exprs)
+	   (error "-- too many arguments." form))
+	 (sublis alist (cdr def)))
+      (when (null exprs)
+	(error "-- too few arguments." form)))))
+
+(defun copyalist (l)
+  (do ((l l (cdr l))
+       (a nil (cons (if (atom (car l))
+			(car l)
+			(cons (caar l) (cdar l)))
+		    a)))
+      ((atom l) (nreconc a l))))
+
+(defun copytree (l)
+  (do ((l l (cdr l))
+       (a nil (cons (copytree (car l)) a)))
+      ((atom l) (nreconc a l))))
+
+(defun *rem (pred item list n)
+  (declare (fixnum n))
+  (do ((list list (cdr list))
+       (l nil))
+      ((or (null list)
+	   (not (plusp n)))
+       (nreconc l list))
+    (cond ((funcall pred item (car list))
+	   (setq n (1- n)))
+	  (t
+	   (setq l (cons (car list) l))))))
+
+(defun *del (pred item list n)
+  (declare (fixnum n))
+  (do ((l list)
+       (last nil))
+      ((or (null l)
+	   (not (plusp n)))
+       list)
+    (cond ((funcall pred item (car l))
+	   (setq n (1- n))
+	   (setq l (cdr l))
+	   (cond ((null last)
+		  (setq list l))
+		 (t (rplacd last l))))
+	  (t (setq last l)
+	     (setq l (cdr l))))))
+
+(defun ass (pred item list)
+  (do ((list list (cdr list)))
+      ((null list) nil)
+    (and (funcall pred item (caar list))
+	 (return (car list)))))
+
+(defun mem (pred item list)
+  (do ((list list (cdr list)))
+      ((null list) nil)
+    (and (funcall pred item (car list))
+	 (return list))))
+
+(defun listp (x)
+  (or (not (atom x))
+      (null x)))
+
+(defun ferror n
+  (ferror-cerror-hack nil nil (arg 1) (listify (- 1 n))))
+
+(args 'ferror '(1 . 776))
+
+(defun cerror n
+  (ferror-cerror-hack (arg 1) (arg 2) (arg 3) (listify (- 3 n))))
+
+(args 'cerror '(4 . 776))
+
+(defun ferror-cerror-hack
+		(proceedable restartable format-string-or-nil format-args)
+  (format msgfiles "~2&Error: ")
+  (if (null format-string-or-nil)
+      (lexpr-funcall #'format msgfiles format-args)
+      (lexpr-funcall #'format msgfiles format-string-or-nil format-args))
+  (or (null *rset)
+      (let ((bl (cdddr (baklist)))
+	    (prinlevel 2))
+	(cond ((not (null bl))
+	       (format msgfiles "~&While in the function ~S"
+		       (caar bl))
+	       (do ((i 0 (1+ i))
+		    (bl (cdr bl) (cdr bl)))
+		   ((or (null bl)
+			(= i 3)))
+		 (declare (fixnum i))
+		 (format msgfiles " <- ~S" (caar bl)))))))
+  (cond (proceedable (format msgfiles "~&(proceedable)"))
+	(restartable (format msgfiles "~&(restartable)")))
+  (terpri msgfiles)
+  (let ((v (break error)))
+    (cond (proceedable v)
+	  (restartable (*throw 'error-restart v))
+	  (t (error "Can't proceed or restart.")))))
+
+(defun get-macro-definition (sym)
+  (let ((p (or (getl sym '(macro subr lsubr expr
+			   fsubr fexpr array))
+	       (let ((f (get sym 'autoload)))
+		 (cond ((null f) nil)
+		       (t
+			(load f)
+			(or (getl sym '(macro subr lsubr expr
+					fsubr fexpr array))
+			    (ferror "Autoloading failed to define: ~S"
+				    sym))))))))
+    (if (eq (car p) 'macro)
+	(cadr p)
+	nil)))
+
+(defun macroexpand (form)
+  (do ()
+      ((or (atom form)
+	   (not (symbolp (car form))))
+       form)
+    (let ((f (get-macro-definition (car form))))
+      (when (null f)
+	(return form))
+      (setq form (funcall f form)))))
+
+(defun macroexpand-1 (form)
+  (if (or (atom form)
+	  (not (symbolp (car form))))
+      form
+      (let ((f (get-macro-definition (car form))))
+	(if (null f)
+	    form
+	    (funcall f form)))))
+
+(defun mexp ()
+  (or (get 'gprint1 'lsubr)
+      (load '((liblsp) gprint fasl)))
+  (terpri)
+  (princ '|>|)
+  (do ((x (read) (read)))
+      ((eq x t))
+    (do ()
+	((or (atom x)
+	     (not (symbolp (car x)))))
+      (let ((f (get-macro-definition (car x))))
+	(when (null f)
+	  (return nil))
+	(terpri)
+	(princ '|==> |)
+	(gprint1 (setq x (funcall f x)) nil nil nil nil nil nil)))
+    (terpri)
+    (princ '|>|))
+  'done)
+
+(defun r-p () (do x '(r-p) (read) (eq x t) (print x) (terpri)) 'done)
+
+(defun xcar (x) (car x))
+(defun xrplaca (x v) (rplaca x v))
+(defun xcdr (x) (cdr x))
+(defun xrplacd (x v) (rplacd x v))
+(defun xcxr (n x) (cxr n x))
+(defun xrplacx (n x v) (rplacx n x v))
+(defun vcell (sym) (cdar sym))
+(defun pname (sym) (cxr 2 (car sym)))
+
+(sstatus feature alan/;lspint)
diff --git a/src/alan/lspint.fasl b/src/alan/lspint.fasl
new file mode 100755
index 00000000..2cc80c8f
Binary files /dev/null and b/src/alan/lspint.fasl differ
diff --git a/src/alan/macits.13 b/src/alan/macits.13
new file mode 100755
index 00000000..02e39c06
--- /dev/null
+++ b/src/alan/macits.13
@@ -0,0 +1,110 @@
+; -*- Midas -*-
+
+title MacITS - Library of MacLisp/ITS interface routines
+
+.fasl
+
+if1, .insrt sys:.fasl defs
+
+maxpush==10			; Largest n for which 0PUSH-n will work.
+
+; (%GETSYS name) returns a list of fixnums representing the data returned by
+; .GETSYS for SIXBIT /name/.
+.entry %GETSYS SUBR 2		; 1 arg
+	pushj p,sixmak		; TT: sixbit argument
+	move r,tt		; R=D+1: area name
+	setzi a,		; A: accumulate list of answers
+	jsp t,0push-maxpush	; Make room for data area on FXPDL
+	hrrzi d,1-maxpush(fxp)
+	hrli d,-maxpush		; D: aobjn to data area
+	.getsys d,
+	 jrst getsy2
+	subi d,1-maxpush(fxp)	; RH(D): # of words of data
+	hlre tt,d
+	imul tt,[-<1,,1>]
+	sub fxp,tt		; Discard extra words from FXPDL
+	hrrzi f,(d)		; F: # of words of data
+	jumple f,cpopj		; No words => all done
+getsy1:	movei b,(a)
+	pop fxp,tt
+	jsp t,fxcons
+	jsp t,%cons
+	sojg f,getsy1
+	popj p,
+
+getsy2:	sub fxp,r70+maxpush
+	jumpe r,cpopj
+	hlre tt,d		; TT: -# words needed
+	movn f,tt		; F: # words delivered
+	push fxp,[0]		; allocate that many on FXPDL
+	aojl tt,.-1
+	.getsys d,
+	 .lose			; Can't happen.
+	jrst getsy1
+
+; (%EVAL name) looks up the name in Exec DDT's symbol table.  Returns NIL
+; if the symbol isn't found.
+.entry %EVAL SUBR 2		; 1 arg
+	pushj p,squeeze
+	.eval tt,
+	 tdza a,a
+	  jrst fix1
+	popj p,
+
+; (%GETLOC addr) return the contents addr in the system.
+.entry %GETLOC SUBR 2		; 1 arg
+	push p,cfix1		; NCALLable
+	jsp t,fxnv1
+	hrlzi t,(tt)
+	hrri t,tt
+	.getloc t,
+	popj p,
+
+; (%SIXBIT name) returns a number.
+.entry %SIXBIT SUBR 2		; 1 arg
+	push p,cfix1		; NCALLable
+	jrst sixmak
+
+; (%UNSIXBIT num) returns a symbol.
+.entry %UNSIXBIT SUBR 2		; 1 arg
+	jsp t,fxnv1
+	jrst sixatm
+
+;  SQUOZE			 SIXBIT
+;  0
+;  1 - 12	"0" - "9"	20 - 31
+; 13 - 44	"A" - "Z"	41 - 72
+; 45		"*"		12
+; 46		"$"		04
+; 47		"%"		05
+
+; (%SQUOZE name) returns a number.
+.entry %SQUOZE SUBR 2		; 1 arg
+	push p,cfix1		; NCALLable
+	jrst squeeze
+
+; (%UNSQUOZE num) returns a symbol.
+; Works by converting to SIXBIT because MacLisp lacks a built-in routine to
+; do this properly.
+.entry %UNSQUOZE SUBR 2		; 1 arg
+	jsp t,fxnv1
+	ldb d,[004000,,tt]	; D: squoze number less flags
+	setzi f,
+unsqu1:	idivi d,50
+	jumpe r,unsqu3
+	cail r,45
+	 jrst unsqu2
+	addi r,'A-13
+	caige r,'A
+	 subi r,<'A-1>-'9
+unsqu3:	lshc r,-6
+	jumpn d,unsqu1
+	move tt,f
+	jrst sixatm
+
+unsqu2:	subi r,45-'*
+	caie r,'*
+	 subi r,<'*+1>-'$
+	jrst unsqu3
+
+fasend
diff --git a/src/alan/nstruc.280 b/src/alan/nstruc.280
new file mode 100755
index 00000000..d7acbe3d
--- /dev/null
+++ b/src/alan/nstruc.280
@@ -0,0 +1,1875 @@
+;;; -*- Mode:Lisp; Package:SI; Lowercase:True -*-
+;;;	** (c) Copyright 1980 Massachusetts Institute of Technology **
+;;;	** (c) Copyright 1981 Massachusetts Institute of Technology **
+
+;The master copy of this file is in MC:ALAN;NSTRUCT >
+;The current PDP10 MacLisp copy is in MC:ALAN;STRUCT >
+;The current Lisp machine copy is in AI:LISPM2;STRUCT >
+;The current Multics MacLisp copy is in >udd>Mathlab>Bawden>defstruct.lisp
+;  on MIT-Multics
+;The current VMS-NIL copy is in [NIL.SRC.SPEC]STRUCT.LSP on HTJR
+
+;*****  READ THIS PLEASE!  *****
+;If you are thinking of munging anything in this file you might want to
+;consider finding me (ALAN) and asking me to mung it for you.  There is more
+;than one copy of this file in the world (it runs in PDP10 and Multics MacLisp,
+;NIL, Franz, PSL and on LispMachines) and whatever amazing features you are
+;considering adding might be usefull to those people as well.  If you still
+;cannot contain yourself long enough to find me, AT LEAST send me a piece of
+;mail describing what you did and why.  Thanks for reading this flame.
+;				Alan Bawden (ALAN@MC)
+
+(eval-when (eval compile)
+  (cond ((and (status feature MacLisp) (status feature PDP10))
+	 (sstatus feature MacLisp-10))
+	(t (sstatus nofeature MacLisp-10))))
+
+(eval-when (compile)
+  (cond ((status feature ITS)
+	 (load '|alan;lspenv init|))
+	((status feature Multics)
+	 (load '|>udd>Mathlab>Bawden>lspenv.lisp|))))
+
+#+MacLisp-10
+(cond ((status nofeature noldmsg)
+       (terpri msgfiles)
+       (princ '#.(and (status feature MacLisp-10)
+		      (maknam (nconc (exploden ";Loading DEFSTRUCT ")
+				     (exploden (caddr (truename infile))))))
+	      msgfiles)))
+
+#+NIL
+(herald defstruct)
+
+#+Multics
+(declare (genprefix defstruct-internal-)
+	 (macros t))
+
+#+MacLisp
+(eval-when (eval compile)
+  (setsyntax #/: (ascii #\space) nil))
+
+(eval-when (eval)
+  ;;So we may run the thing interpreted we need the simple
+  ;;defstruct that lives here:
+  (cond ((status feature ITS)
+	 (load '|alan;struct initial|))
+	((status feature Multics)
+	 (load '|>udd>Mathlab>Bawden>initial_defstruct|))))
+
+(eval-when (compile)
+  ;;To compile the thing this probably is an old fasl: (!)
+  (cond ((status feature ITS)
+	 (load '|alan;struct boot|))
+	((status feature Multics)
+	 (load '|>udd>Mathlab>Bawden>boot_defstruct|))))
+
+#+Multics
+(defun nth (n l)
+  (do ((n n (1- n))
+       (l l (cdr l)))
+      ((zerop n) (car l))))
+
+#+Multics
+(defun nthcdr (n l)
+  (do ((n n (1- n))
+       (l l (cdr l)))
+      ((zerop n) l)))
+
+#+Multics
+(defun displace (x y)
+  (cond ((atom y)
+	 (rplaca x 'progn)
+	 (rplacd x (list y)))
+	(t
+	 (rplaca x (car y))
+	 (rplacd x (cdr y))))
+  x)
+
+(eval-when (eval compile load)
+
+#+MacLisp
+(defun defstruct-retry-keyword (x)
+  (let ((l (exploden x)))
+    (if (= (car l) #/:)
+	(implode (cdr l))
+	x)))
+
+#+LispM
+(defun defstruct-retry-keyword (x)
+  (intern (get-pname x) si:pkg-user-package))
+
+#+NIL
+(defmacro defstruct-retry-keyword (x)
+  `(to-keyword ,x))
+
+);End of eval-when (eval compile load)
+
+;;; Eval this before attempting incremental compilation
+(eval-when (eval compile)
+
+#+MacLisp-10
+(defmacro append-symbols args
+  (do ((l (reverse args) (cdr l))
+       (x)
+       (a nil (if (or (atom x)
+		      (not (eq (car x) 'quote)))
+		  (if (null a)
+		      `(exploden ,x)
+		      `(nconc (exploden ,x) ,a))
+		  (let ((l (exploden (cadr x))))
+		    (cond ((null a) `',l)
+			  ((= 1 (length l)) `(cons ,(car l) ,a))
+			  (t `(append ',l ,a)))))))
+      ((null l) `(implode ,a))
+    (setq x (car l))))
+
+#+Multics
+(defmacro append-symbols args
+  `(make_atom (catenate ,@args)))
+
+#+LispM
+(defmacro append-symbols args
+  `(intern (string-append ,@args)))
+
+#+NIL
+(defmacro append-symbols args
+  `(symbolconc ,@args))
+
+(defmacro defstruct-putprop (sym val ind)
+  `(push `(defprop ,,sym ,,val ,,ind) returns))
+
+#+Multics
+;;;lcp gobbles (defprop ... macro) at compile time, so we have to use
+;;;putprop to be certain macro definitions make it into the object:
+(defmacro defstruct-put-macro (sym fcn)
+  `(push `(putprop ',,sym ',,fcn 'macro) returns))
+
+#+MacLisp-10
+(defmacro defstruct-put-macro (sym fcn)
+  `(push `(defprop ,,sym ,,fcn macro) returns))
+
+#+LispM
+(defmacro defstruct-put-macro (sym fcn)
+  (setq fcn (if (and (not (atom fcn))
+		     (eq (car fcn) 'quote))
+		`'(macro . ,(cadr fcn))
+		`(cons 'macro ,fcn)))
+  `(push `(fdefine ',,sym ',,fcn t) returns))
+
+#+NIL
+(defmacro defstruct-put-macro (sym fcn)
+  `(push `(add-macro-definition ',,sym ',,fcn) returns))
+							
+(defmacro make-empty () `'%%defstruct-empty%%)
+
+(defmacro emptyp (x) `(eq ,x '%%defstruct-empty%%))
+
+;;;Here we must deal with the fact that error reporting works
+;;;differently everywhere!
+
+#+MacLisp-10
+;;;first arg is ALWAYS a symbol or a quoted symbol:
+(defmacro defstruct-error (message &rest args)
+  (let* ((chars (nconc (exploden (if (atom message)
+				     message
+				     (cadr message)))
+		       '(#/.)))		;"Bad frob" => "Bad frob."
+	 (new-message
+	  (maknam (if (null args)
+		      chars
+		      (let ((c (car chars)))	;"Bad frob." => "-- bad frob."
+			(or (< c #/A)
+			    (> c #/Z)
+			    (rplaca chars (+ c #o40)))
+			(append '(#/- #/- #\space) chars))))))
+  `(error ',new-message
+	  ,@(cond ((null args) `())
+		  ((null (cdr args)) `(,(car args)))
+		  (t `((list ,@args)))))))
+
+#+Multics
+;;;first arg is ALWAYS a string:
+(defmacro defstruct-error (message &rest args)
+  `(error ,(catenate "defstruct: "
+		     message
+		     (if (null args)
+			 "."
+			 ": "))
+	  ,@(cond ((null args) `())
+		  ((null (cdr args)) `(,(car args)))
+		  (t `((list ,@args))))))
+
+#+(or LispM NIL)
+;;;first arg is ALWAYS a string:
+(defmacro defstruct-error (message &rest args)
+  (do ((l args (cdr l))
+       (fs "")
+       (na nil))
+      ((null l)
+      `(ferror nil
+	       ,(string-append message
+			       (if (null args)
+				   "."
+				   (string-append ":" fs)))
+	       ,.(nreverse na)))
+    (cond ((and (not (atom (car l)))
+		(eq (caar l) 'quote)
+		(symbolp (cadar l)))
+	   (setq fs (string-append fs " " (string-downcase (cadar l)))))
+	  (t
+	   (push (car l) na)
+	   (setq fs (string-append fs " ~S"))))))
+
+);End of eval-when (eval compile)
+
+;;;If you mung the the ordering af any of the slots in this structure,
+;;;be sure to change the version slot and the definition of the function
+;;;get-defstruct-description.  Munging the defstruct-slot-description 
+;;;structure should also cause you to change the version "number" in this
+;;;manner.
+(defstruct (defstruct-description
+	     (:type :list)
+	     (:default-pointer description)
+	     (:conc-name defstruct-description-)
+	     (:alterant ())
+	  #+stingy-defstruct
+	     (:eval-when (eval compile)))
+  (version 'one)
+  type
+  dummy ;used to be the displace function
+  slot-alist
+  named-p
+  constructors
+  (default-pointer nil)
+  (but-first nil)
+  size
+  (property-alist nil)
+  ;;end of "expand-time" slots
+  name
+  include
+  (initial-offset 0)
+  (eval-when '(eval compile load))
+  alterant
+  (conc-name nil)
+  (callable-accessors #-(or LispM NIL) nil #+(or LispM NIL) t)
+  (size-macro nil)
+  (size-symbol nil)
+  (predicate nil)
+  (copier nil)
+  (print nil)
+  )
+
+(defun get-defstruct-description (name)
+  (let ((description (get name 'defstruct-description)))
+    (cond ((null description)
+	   (defstruct-error
+	     "A structure with this name has not been defined" name))
+	  ((not (eq (defstruct-description-version) 'one))
+	   (defstruct-error "The internal description of this structure is
+incompatible with the currently loaded version of defstruct,
+you will need to recompile its definition"
+		  name))
+	  (t description))))
+
+;;;See note above defstruct-description structure before munging this one.
+(defstruct (defstruct-slot-description
+	     (:type :list)
+	     (:default-pointer slot-description)
+	     (:conc-name defstruct-slot-description-)
+	     (:alterant ())
+	  #+stingy-defstruct
+	     (:eval-when (eval compile)))
+  number
+  (ppss nil)
+  init-code
+  (type 'notype)
+  (property-alist nil)
+  ref-macro-name
+  )
+
+;;;Perhaps this structure wants a version slot too?
+(defstruct (defstruct-type-description
+	     (:type :list)
+	     (:default-pointer type-description)
+	     (:conc-name defstruct-type-description-)
+	     (:alterant ())
+	  #+stingy-defstruct
+	     (:eval-when (eval compile)))
+  ref-expander
+  ref-no-args
+  cons-expander
+  cons-flavor
+  (cons-keywords nil)
+  (named-type nil)
+  (overhead 0)
+  (defstruct-expander nil)
+  (predicate nil)
+  (copier nil)
+  )
+
+;; (DEFSTRUCT (<name> . <options>) . <slots>) or (DEFSTRUCT <name> . <slots>)
+;;
+;; <options> is of the form (<option> <option> (<option> <val>) ...)
+;;
+;; <slots> is of the form (<slot> (<slot> <initial-value>) ...)
+;;
+;; Options:
+;;   :TYPE defaults to HUNK
+;;   :CONSTRUCTOR defaults to "MAKE-<name>"
+;;   :DEFAULT-POINTER defaults to empty (if no <val> given defaults to "<name>")
+;;   :CONC-NAME defaults to empty (if no <val> given defaults to "<name>-")
+;;   :SIZE-SYMBOL defaults to empty (if no <val> given defaults to "<name>-SIZE")
+;;   :SIZE-MACRO defaults to empty (if no <val> given defaults to "<name>-SIZE")
+;;   :ALTERANT defaults to "ALTER-<name>"
+;;   :BUT-FIRST must have a <val> given
+;;   :INCLUDE must have a <val> given
+;;   :PROPERTY (:property foo bar) gives the structure a foo
+;;     property of bar.  (:property foo) gives a foo property of T.
+;;   :INITIAL-OFFSET can cause defstruct to skip over that many slots.
+;;   :NAMED takes no value.  Tries to make the structure a named type.
+;;   :CALLABLE-ACCESSORS defaults to true on the LispMachine and NIL.  False
+;;     elsewhere. 
+;;   :EVAL-WHEN defaults to (eval compile load).  <val> must be given.
+;;   :PREDICATE defaults to empty (if no <val> given defaults
+;;     to "<name>-P").  Generates a predicate if possible.
+;;   :COPIER defaults to empty (if no <val> given defaults to
+;;     "COPY-<name>").  Generates a function to copy this structure.
+;;   :PRINT (:print "#<spaceship at ~S by ~S>" (x-pos spaceship)
+;;     (y-pos spaceship))  The name of the structure is used as
+;;     the variable.
+;;   <type> any type name can be used without a <val> instead of
+;;     saying (:TYPE <type>) 
+;;   <other> any symbol with a non-nil :defstruct-option property.  You say
+;;     (<other> <val>) and the effect is that of (:property <other> <val>)
+;;
+;; Symbol properties used:
+;;   DEFSTRUCT-TYPE-DESCRIPTION each type has one, it is a type-description.
+;;   DEFSTRUCT-NAME each constructor, alterant and size macro
+;;     has one, it is a name. 
+;;   DEFSTRUCT-DESCRIPTION each name has one, it is a description (see below).
+;;   DEFSTRUCT-SLOT each accesor has one, it is of the form: (<name> . <slot>)
+;;   :DEFSTRUCT-OPTION if a symbol FOO has this property then it can be used as
+;;     an option giving the structure a FOO property of the value (or T).
+
+#+LispM
+(defprop defstruct "Structure" definition-type-name)
+
+;;;The order of forms returned by defstruct is sometimes critical.  Keep this
+;;;in mind when munging this code:
+(defmacro defstruct (options &body items)
+  (let* ((description (defstruct-parse-options options))
+	 (type-description (get (defstruct-description-type)
+				'defstruct-type-description))
+	 (name (defstruct-description-name))
+	 (new-slots (defstruct-parse-items items description))
+	 (returns nil))
+    (push `',name returns)
+    ;;This must be last, since to compile it might require that the structure
+    ;;already be operable:
+    (cond ((defstruct-description-print)
+	   (push (defstruct-define-printer name (defstruct-description-print))
+		 returns)))
+    ;;Keep this as close to last as possible:
+    (cond ((defstruct-type-description-defstruct-expander)
+	   (setq returns (append (funcall (defstruct-type-description-defstruct-expander)
+					  description)
+				 returns))))
+ #+LispM
+    (push `(record-source-file-name ',name 'defstruct) returns)
+    (let ((alterant (defstruct-description-alterant))
+	  (size-macro (defstruct-description-size-macro))
+	  (size-symbol (defstruct-description-size-symbol))
+	  (predicate (defstruct-description-predicate))
+	  (copier (defstruct-description-copier)))
+      (cond (predicate
+	     (push (funcall (or (defstruct-type-description-predicate)
+				(defstruct-error
+				  "This defstruct type cannot produce a predicate"
+				  (defstruct-description-type) 'in name))
+			    description
+			    predicate)
+		   returns)))
+      (cond (copier
+	     (push
+	       (let ((copy-fun (defstruct-type-description-copier)))
+		 (cond (copy-fun
+			(funcall copy-fun description copier))
+		       ((not (= 1 (defstruct-type-description-ref-no-args)))
+			(defstruct-error
+			  "This defstruct type cannot produce a copying function"
+			  (defstruct-description-type) 'in name))
+		       (t (do ((i (1- (defstruct-description-size)) (1- i))
+			       (l nil (cons (cons i (funcall (defstruct-type-description-ref-expander)
+							     i description 'x))
+					    l)))
+			      ((< i 0)
+			       `(defun ,copier (x)
+				  ,(invoke-defstruct-constructor-expander
+				     description type-description l nil)))))))
+	       returns)))
+      (cond (alterant
+	     (defstruct-put-macro alterant 'defstruct-expand-alter-macro)
+	     (defstruct-putprop alterant name 'defstruct-name)))
+      (cond (size-macro
+	     (defstruct-put-macro size-macro 'defstruct-expand-size-macro)
+	     (defstruct-putprop size-macro name 'defstruct-name)))
+      (cond (size-symbol
+	     (push `(defconst ,size-symbol
+		      ,(+ (defstruct-description-size)
+			  (defstruct-type-description-overhead)))
+		   returns))))
+    (defstruct-putprop name description 'defstruct-description)
+    (do ((cs (defstruct-description-constructors) (cdr cs)))
+	((null cs))
+      (defstruct-put-macro (caar cs) 'defstruct-expand-cons-macro)
+      (defstruct-putprop (caar cs) name 'defstruct-name))
+    `(eval-when ,(defstruct-description-eval-when)
+		,.(defstruct-define-ref-macros new-slots description)
+		,.returns)))
+
+;;;General philosophy on the :print option is to not bother the
+;;;user if printing cannot be controled.  This allows for
+;;;portability without pain.  This may prove to be a bogus philoshphy.
+#+MacLisp-10
+(defun defstruct-define-printer (name rest)
+  (let ((stream (gensym)))
+    `(defun (,name named-hunk-printer) (,name ,stream)
+       (?format ,stream ,@rest))))
+
+#+LispM
+(defun defstruct-define-printer (name rest)
+  (let ((op (gensym))
+	(args (gensym)))
+    `(defun (,name named-structure-invoke) (,op ,name &rest ,args)
+       (selectq ,op
+	 (:print-self
+	   (if print-readably (print-not-readable ,name))
+	   (format (car ,args) ,@rest))
+	 (:which-operations '(:print-self))
+	 (t (ferror nil "Illegal operation ~S" ,op))))))
+
+#+NIL
+(defun defstruct-define-printer (name rest)
+  (let ((method-function-name (symbolconc name "->PRINT-SELF#METHOD"))
+	(stream-var (gensym))
+	(gubble (gensym)))
+    `(progn 'compile
+	(defun ,method-function-name (,name () () ,stream-var &rest ,gubble)
+	  ,gubble	;ignored
+	  (format ,stream-var ,@rest))
+	(add-flavor-method-info ',name ':print-self ',method-function-name))))
+
+#-(or LispM MacLisp-10 NIL)
+(defun defstruct-define-printer (name rest)
+  `(comment ,name ,@rest))
+
+(defun defstruct-parse-options (options)
+  (let ((name (if (atom options) options (car options)))
+	(type nil)
+	(constructors (make-empty))
+	(alterant (make-empty))
+	(included nil)
+	(named-p nil)
+	(but-first nil)
+	(description (make-defstruct-description)))
+    (setf (defstruct-description-name) name)
+    (do ((op) (val) (vals)
+	 (options (if (atom options) nil (cdr options))
+		  (cdr options)))
+	((null options))
+      (if (atom (setq op (car options)))
+	  (setq vals nil)
+	  (setq op (prog1 (car op) (setq vals (cdr op)))))
+      (setq val (if (null vals) (make-empty) (car vals)))
+AGAIN (selectq op
+	(:type
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The type option to defstruct must have a value given"
+	       name))
+	 (setq type val))
+	(:named
+	 (or (emptyp val)
+	     (defstruct-error
+	       "The named option to defstruct doesn't take a value" name))
+	 (setq named-p t))
+	(:default-pointer
+	 (setf (defstruct-description-default-pointer)
+	       (if (emptyp val) name val)))
+	(:conc-name
+	 (setf (defstruct-description-conc-name)
+	       (if (emptyp val)
+		   (append-symbols name '-)
+		   val)))
+	(:print
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The print option to defstruct requires a value"
+	       name))
+	 (setf (defstruct-description-print) vals))
+	(:include
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The include option to defstruct requires a value"
+	       name))
+	 (setq included val)
+	 (setf (defstruct-description-include) vals))
+	(:predicate
+	 (setf (defstruct-description-predicate)
+	       (if (emptyp val)
+		   (append-symbols name '-p)
+		   val)))
+	(:constructor
+	 (cond ((null val)
+		(setq constructors nil))
+	       (t
+		(and (emptyp val)
+		     (setq val (append-symbols 'make- name)))
+		(setq val (cons val (cdr vals)))
+		(if (emptyp constructors)
+		    (setq constructors (list val))
+		    (push val constructors)))))
+	(:copier
+	 (setf (defstruct-description-copier)
+	       (if (emptyp val)
+		   (append-symbols 'copy- name)
+		   val)))
+	(:eval-when
+	 (and (emptyp val)
+	      (defstruct-error
+		"The eval-when option to defstruct requires a value"
+		name))
+	 (setf (defstruct-description-eval-when) val))
+	(:alterant
+	 (setq alterant val))
+	(:but-first
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The but-first option to defstruct must have a value given"
+	       name))
+	 (setq but-first val)
+	 (setf (defstruct-description-but-first) val))
+	(:size-macro
+	 (setf (defstruct-description-size-macro)
+	       (if (emptyp val)
+		   (append-symbols name '-size)
+		   val)))
+	(:size-symbol
+	 (setf (defstruct-description-size-symbol)
+	       (if (emptyp val)
+		   (append-symbols name '-size)
+		   val)))
+	(:callable-accessors
+	 (setf (defstruct-description-callable-accessors)
+	       (if (emptyp val) t val)))
+	(:property
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The property option to defstruct requires a value"
+	       name))
+	 (push (cons val (if (null (cdr vals)) t (cadr vals)))
+	       (defstruct-description-property-alist)))
+	(:initial-offset
+	 (and (or (emptyp val)
+		  (not (fixp val)))
+	      (defstruct-error
+		"The initial-offset option to defstruct requires a fixnum"
+		name))
+	 (setf (defstruct-description-initial-offset) val))
+	(t
+	 (cond ((get op 'defstruct-type-description)
+		(or (emptyp val)
+		    (defstruct-error
+		      "defstruct type used as an option with a value"
+		      op 'in name))
+		(setq type op))
+	       ((get op ':defstruct-option)
+		(push (cons op (if (emptyp val) t val))
+		      (defstruct-description-property-alist)))
+	       (t
+		(let ((new (defstruct-retry-keyword op)))
+		  (cond ((not (eq new op))
+			 (setq op new)
+			 (go AGAIN)))
+		  (defstruct-error
+		    "defstruct doesn't understand this option"
+		    op 'in name)))))))
+    (cond ((emptyp constructors)
+	   (setq constructors
+		 (list (cons (append-symbols 'make- name)
+			     nil)))))
+    (setf (defstruct-description-constructors) constructors)
+    (cond ((emptyp alterant)
+	   (setq alterant
+		 (append-symbols 'alter- name))))
+    (setf (defstruct-description-alterant) alterant)
+    (cond ((not (null type))
+	   (let ((type-description
+		  (or (get type 'defstruct-type-description)
+		      (let ((new (defstruct-retry-keyword type)))
+			(cond ((eq type new) nil)
+			      (t
+			       (setq type new)
+			       (get type 'defstruct-type-description))))
+		      (defstruct-error
+			"Unknown type in defstruct"
+			type 'in name))))
+	     (if named-p
+		 (setq type
+		       (or (defstruct-type-description-named-type)
+			   (defstruct-error
+			    "There is no way to make this defstruct type named"
+			    type 'in name)))))))
+    (cond (included
+	   (let ((d (get-defstruct-description included)))
+	     (if (null type)
+		 (setq type (defstruct-description-type d))
+		 (or (eq type (defstruct-description-type d))
+		     (defstruct-error
+		       "defstruct types must agree for include option"
+		       included 'included 'by name)))
+	     (and named-p
+		  (not (eq type (defstruct-type-description-named-type
+				  (or (get type 'defstruct-type-description)
+				      (defstruct-error
+					"Unknown type in defstruct"
+					type 'in name 'including included)))))
+		  (defstruct-error
+		    "Included defstruct's type isn't a named type"
+		    included 'included 'by name))
+	     (if (null but-first)
+		 (setf (defstruct-description-but-first)
+		       (defstruct-description-but-first d))
+		 (or (equal but-first (defstruct-description-but-first d))
+		     (defstruct-error
+		       "but-first options must agree for include option"
+		       included 'included 'by name)))))
+	  ((null type)
+	   (setq type
+	     (cond (named-p
+		    #+MacLisp-10 ':named-hunk
+		    #+Multics ':named-list
+		    #+LispM ':named-array
+		    #+NIL ':extend)
+		   (t
+		    #+MacLisp-10 ':hunk
+		    #+Multics ':list
+		    #+LispM ':array
+		    #+NIL ':vector)))))
+    (let ((type-description (or (get type 'defstruct-type-description)
+				(defstruct-error
+				  "Undefined defstruct type"
+				  type 'in name))))
+      (setf (defstruct-description-type) type)
+      (setf (defstruct-description-named-p)
+	    (eq (defstruct-type-description-named-type) type)))
+    description))
+
+(defun defstruct-parse-items (items description)
+  (let ((name (defstruct-description-name))
+	(offset (defstruct-description-initial-offset))
+	(include (defstruct-description-include))
+	(o-slot-alist nil)
+	(conc-name (defstruct-description-conc-name)))
+    (or (null include)
+	(let ((d (get (car include) 'defstruct-description)))
+	  (setq offset (+ offset (defstruct-description-size d))) 
+	  (setq o-slot-alist
+		(subst nil nil (defstruct-description-slot-alist d)))
+	  (do ((l (cdr include) (cdr l))
+	       (it) (val))
+	      ((null l))
+	    (cond ((atom (setq it (car l)))
+		   (setq val (make-empty)))
+		  (t
+		   (setq val (cadr it))
+		   (setq it (car it))))
+	    (let ((slot-description (cdr (assq it o-slot-alist))))
+	      (and (null slot-description)
+		   (defstruct-error
+		     "Unknown slot in included defstruct"
+		     it 'in include 'included 'by name))
+	      (setf (defstruct-slot-description-init-code) val)))))
+    (do ((i offset (1+ i))
+	 (l items (cdr l))
+	 (slot-alist nil)
+	 #+MacLisp-10 (chars (exploden conc-name)))
+	((null l)
+	 (setq slot-alist (nreverse slot-alist))
+	 (setf (defstruct-description-size) i)
+	 (setf (defstruct-description-slot-alist)
+	       (nconc o-slot-alist slot-alist))
+	 slot-alist)
+      (cond ((atom (car l))
+	     (push (defstruct-parse-one-field
+		     (car l) i nil nil conc-name #+MacLisp-10 chars)
+		   slot-alist))
+	    ((atom (caar l))
+	     (push (defstruct-parse-one-field
+		     (caar l) i nil (cdar l) conc-name #+MacLisp-10 chars)
+		   slot-alist))
+	    (t
+	     (do ((ll (car l) (cdr ll)))
+		 ((null ll))
+	       (push (defstruct-parse-one-field
+		       (caar ll) i (cadar ll)
+		       (cddar ll) conc-name #+MacLisp-10 chars)
+		     slot-alist)))))))
+
+(defun defstruct-parse-one-field (it number ppss rest conc-name #+MacLisp-10 chars)
+  (let ((mname (if conc-name #+MacLisp-10 (implode (append chars (exploden it)))
+			     #-MacLisp-10 (append-symbols conc-name it)
+		   it)))
+    (cons it (make-defstruct-slot-description
+	       number number
+	       ppss ppss
+	       init-code (if (null rest) (make-empty) (car rest))
+	       ref-macro-name mname))))
+
+(defun defstruct-define-ref-macros (new-slots description)
+  (let ((name (defstruct-description-name))
+	(returns nil))
+    (if (not (defstruct-description-callable-accessors))
+	(do ((l new-slots (cdr l))
+	     (mname))
+	    ((null l))
+	  (setq mname (defstruct-slot-description-ref-macro-name (cdar l)))
+	  (defstruct-put-macro mname 'defstruct-expand-ref-macro)
+	  (defstruct-putprop mname (cons name (caar l)) 'defstruct-slot))
+	(let ((type-description
+		(get (defstruct-description-type)
+		     'defstruct-type-description)))
+	  (let ((code (defstruct-type-description-ref-expander))
+		(n (defstruct-type-description-ref-no-args))
+	     #+LispM
+		(parent `(,name defstruct))
+		(but-first (defstruct-description-but-first))
+		(default-pointer (defstruct-description-default-pointer)))
+	    (do ((args nil (cons (gensym) args))
+		 (i n (1- i)))
+		((< i 2)
+		 ;;Last arg (if it exists) is name of structure,
+		 ;; for documentation purposes.
+		 (and (= i 1)
+		      (setq args (cons name args)))
+		 (let ((body (cons (if but-first
+				       `(,but-first ,(car args))
+				       (car args))
+				   (cdr args))))
+		   (and default-pointer
+			(setq args `((,(car args) ,default-pointer)
+				     &optional ,@(cdr args))))
+		   (setq args (reverse args))
+		   (setq body (reverse body))
+		   (do ((l new-slots (cdr l))
+			(mname))
+		       ((null l))
+		     (setq mname (defstruct-slot-description-ref-macro-name
+				   (cdar l)))
+		     #+MacLisp 
+		     ;;This must come BEFORE the defun. THINK!
+		     (defstruct-put-macro mname 'defstruct-expand-ref-macro)
+		     (let ((ref (lexpr-funcall
+				  code
+				  (defstruct-slot-description-number (cdar l))
+				  description
+				  body))
+			   (ppss (defstruct-slot-description-ppss (cdar l))))
+		       (push `(#+LispM defsubst-with-parent
+			       #+NIL defsubst
+			       #-(or LispM NIL) defun
+			         ,mname #+LispM ,parent ,args
+				 ,(if (null ppss) ref `(ldb ,ppss ,ref)))
+			   returns))
+		     (defstruct-putprop mname
+					(cons name (caar l))
+					'defstruct-slot))))))))
+    returns))
+
+#+LispM 
+(defprop defstruct-expand-cons-macro
+	 defstruct-function-parent
+	 macroexpander-function-parent)
+
+#+LispM 
+(defprop defstruct-expand-size-macro
+	 defstruct-function-parent
+	 macroexpander-function-parent)
+
+#+LispM 
+(defprop defstruct-expand-alter-macro
+	 defstruct-function-parent
+	 macroexpander-function-parent)
+
+#+LispM 
+(defprop defstruct-expand-ref-macro 
+	 defstruct-function-parent
+	 macroexpander-function-parent)
+
+#+LispM
+(defun defstruct-function-parent (sym)
+  (values (or (get sym 'defstruct-name)
+	      (car (get sym 'defstruct-slot)))
+	  'defstruct))
+
+(defun defstruct-expand-size-macro (x)
+  (let ((description (get-defstruct-description (get (car x) 'defstruct-name))))
+    (let ((type-description (or (get (defstruct-description-type)
+				     'defstruct-type-description)
+				(defstruct-error
+				  "Unknown defstruct type"
+				  (defstruct-description-type)))))
+      (+ (defstruct-description-size)
+	 (defstruct-type-description-overhead)))))
+
+(defun defstruct-expand-ref-macro (x)
+  (let* ((pair (get (car x) 'defstruct-slot))
+	 (description (get-defstruct-description (car pair)))
+	 (type-description (or (get (defstruct-description-type)
+				    'defstruct-type-description)
+			       (defstruct-error
+				 "Unknown defstruct type"
+				 (defstruct-description-type))))
+	 (code (defstruct-type-description-ref-expander))
+	 (n (defstruct-type-description-ref-no-args))
+	 (args (reverse (cdr x)))
+	 (nargs (length args))
+	 (default (defstruct-description-default-pointer))
+	 (but-first (defstruct-description-but-first)))
+    (cond ((= n nargs)
+	   (and but-first
+		(rplaca args `(,but-first ,(car args)))))
+	  ((and (= n (1+ nargs)) default)
+	   (setq args (cons (if but-first
+				`(,but-first ,default)
+				default)
+			    args)))
+	  (t
+	   (defstruct-error
+	     "Wrong number of args to an accessor macro" x)))
+    (let* ((slot-description 
+	     (cdr (or (assq (cdr pair)
+			    (defstruct-description-slot-alist))
+		      (defstruct-error
+			"This slot no longer exists in this structure"
+			(cdr pair) 'in (car pair)))))
+	    (ref (lexpr-funcall
+		   code
+		   (defstruct-slot-description-number)
+		   description
+		   (nreverse args)))
+	    (ppss (defstruct-slot-description-ppss)))
+      (if (null ppss)
+	  ref
+	  `(ldb ,ppss ,ref)))))
+
+(defun defstruct-parse-setq-style-slots (l slots others x)
+  (do ((l l (cddr l))
+       (kludge (cons nil nil)))
+      ((null l) kludge)
+    (or (and (cdr l)
+	     (symbolp (car l)))
+	(defstruct-error
+	  "Bad argument list to constructor or alterant macro" x))
+    (defstruct-make-init-dsc kludge (car l) (cadr l) slots others x)))
+
+(defun defstruct-make-init-dsc (kludge name code slots others x)
+  (let ((p (assq name slots)))
+    (if (null p)
+	(if (memq name others)
+	    (push (cons name code) (cdr kludge))
+	    (let ((new (defstruct-retry-keyword name)))
+	      (if (memq new others)
+		  (push (cons new code) (cdr kludge))
+		  (defstruct-error
+		    "Unknown slot to constructor or alterant macro"
+		    name 'in x))))
+	(let* ((slot-description (cdr p))
+	       (number (defstruct-slot-description-number))
+	       (ppss (defstruct-slot-description-ppss))
+	       (dsc (assoc number (car kludge))))
+	  (cond ((null dsc)
+		 (setq dsc (list* number nil (make-empty) 0 0 nil))
+		 (push dsc (car kludge))))
+	  (cond ((null ppss)
+		 (setf (car (cddr dsc)) code)
+		 (setf (cadr dsc) t))
+		(t (cond ((and (numberp ppss) (numberp code))
+			  (setf (ldb ppss (cadr (cddr dsc))) -1)
+			  (setf (ldb ppss (caddr (cddr dsc))) code))
+			 (t
+			  (push (cons ppss code) (cdddr (cddr dsc)))))
+		   (or (eq t (cadr dsc))
+		       (push name (cadr dsc)))))))))
+
+(defun defstruct-code-from-dsc (dsc)
+  (let ((code (car (cddr dsc)))
+	(mask (cadr (cddr dsc)))
+	(bits (caddr (cddr dsc))))
+    (if (emptyp code)
+	(setq code bits)
+	(or (zerop mask)
+	    (setq code (if (numberp code)
+			   (boole 7 bits (boole 2 mask code))
+			   (if (zerop (logand mask
+					      (1+ (logior mask (1- mask)))))
+			       (let ((ss (haulong (boole 2 mask (1- mask)))))
+				 `(dpb ,(lsh bits (- ss))
+				       ,(logior (lsh ss 6)
+						(logand #o77
+							(- (haulong mask) ss)))
+				       ,code))
+			       `(boole 7 ,bits (boole 2 ,mask ,code)))))))
+    (do ((l (cdddr (cddr dsc)) (cdr l)))
+	((null l))
+      (setq code `(dpb ,(cdar l) ,(caar l) ,code)))
+    code))
+
+(defun defstruct-expand-cons-macro (x)
+  (let* ((description (get-defstruct-description (get (car x) 'defstruct-name)))
+	 (type-description (or (get (defstruct-description-type)
+				    'defstruct-type-description)
+			       (defstruct-error
+				 "Unknown defstruct type"
+				 (defstruct-description-type))))
+	 (slot-alist (defstruct-description-slot-alist))
+	 (cons-keywords (defstruct-type-description-cons-keywords))
+	 (kludge nil)
+	 (constructor-description 
+	   (cdr (or (assq (car x) (defstruct-description-constructors))
+		    (defstruct-error
+		      "This constructor is no longer defined for this structure"
+		      (car x) 'in (defstruct-description-name)))))
+	 (aux nil)
+	 (aux-init nil))
+     (if (null constructor-description)
+	 (setq kludge (defstruct-parse-setq-style-slots (cdr x)
+							slot-alist
+							cons-keywords
+							x))
+	 (prog (args l)
+	       (setq kludge (cons nil nil))
+	       (setq args (cdr x))
+	       (setq l (car constructor-description))
+	     R (cond ((null l)
+		      (if (null args)
+			  (return nil)
+			  (go barf-tma)))
+		     ((atom l) (go barf))
+		     ((eq (car l) '&optional) (go O))
+		     ((eq (car l) '&rest) (go S))
+		     ((eq (car l) '&aux) (go A))
+		     ((null args) (go barf-tfa)))
+	       (defstruct-make-init-dsc kludge
+					(pop l)
+					(pop args)
+					slot-alist
+					cons-keywords
+					x)
+	       (go R)
+	     O (and (null args) (go OD))
+	       (pop l)
+	       (cond ((null l) (go barf-tma))
+		     ((atom l) (go barf))
+		     ((eq (car l) '&optional) (go barf))
+		     ((eq (car l) '&rest) (go S))
+		     ((eq (car l) '&aux) (go barf-tma)))
+	       (defstruct-make-init-dsc kludge
+					(if (atom (car l)) (car l) (caar l))
+					(pop args)
+					slot-alist
+					cons-keywords
+					x)
+	       (go O)
+	    OD (pop l)
+	       (cond ((null l) (return nil))
+		     ((atom l) (go barf))
+		     ((eq (car l) '&optional) (go barf))
+		     ((eq (car l) '&rest) (go S))
+		     ((eq (car l) '&aux) (go A)))
+	       (or (atom (car l))
+		   (defstruct-make-init-dsc kludge
+					    (caar l)
+					    (cadar l)
+					    slot-alist
+					    cons-keywords
+					    x))
+	       (go OD)
+	     S (and (atom (cdr l)) (go barf))
+	       (defstruct-make-init-dsc kludge
+					(cadr l)
+					`(list ,@args)
+					slot-alist
+					cons-keywords
+					x)
+	       (setq l (cddr l))
+	       (and (null l) (return nil))
+	       (and (atom l) (go barf))
+	       (or (eq (car l) '&aux) (go barf))
+	     A (pop l)
+	       (cond ((null l) (return nil))
+		     ((atom l) (go barf))
+		     ((atom (car l))
+		      (push (car l) aux)
+		      (push (make-empty) aux-init))
+		     (t
+		      (push (caar l) aux)
+		      (push (cadar l) aux-init)))
+	       (go A)
+	  barf (defstruct-error
+		 "Bad format for defstruct constructor arglist"
+		 `(,(car x) ,@(car constructor-description)))
+      barf-tfa (defstruct-error "Too few arguments to constructor macro" x)
+      barf-tma (defstruct-error "Too many arguments to constructor macro" x)))
+     (do ((l slot-alist (cdr l)))
+	 ((null l))
+       (let* ((name (caar l))
+	      (slot-description (cdar l))
+	      (code (do ((aux aux (cdr aux))
+			 (aux-init aux-init (cdr aux-init)))
+			((null aux) (defstruct-slot-description-init-code))
+		      (and (eq name (car aux)) (return (car aux-init)))))
+	      (ppss (defstruct-slot-description-ppss)))
+	 (or (and (emptyp code) (null ppss))
+	     (let* ((number (defstruct-slot-description-number))
+		    (dsc (assoc number (car kludge))))
+	       (cond ((null dsc)
+		      (setq dsc (list* number nil (make-empty) 0 0 nil))
+		      (push dsc (car kludge))))
+	       (cond ((emptyp code))
+		     ((eq t (cadr dsc)))
+		     ((null ppss)
+		      (and (emptyp (car (cddr dsc)))
+			   (setf (car (cddr dsc)) code)))
+		     ((memq name (cadr dsc)))
+		     ((and (numberp ppss) (numberp code))
+		      (setf (ldb ppss (cadr (cddr dsc))) -1)
+		      (setf (ldb ppss (caddr (cddr dsc))) code))
+		     (t
+		      (push (cons ppss code) (cdddr (cddr dsc)))))))))
+     (do ((l (car kludge) (cdr l)))
+	 ((null l))
+       (rplacd (car l) (defstruct-code-from-dsc (car l))))
+     (invoke-defstruct-constructor-expander
+       description type-description
+       (car kludge) (cdr kludge))))
+
+(defun invoke-defstruct-constructor-expander (description type-description arg etc)
+  (funcall (defstruct-type-description-cons-expander)
+	   (selectq (defstruct-type-description-cons-flavor)
+	     (:list
+	      (do ((l nil (cons nil l))
+		   (i (defstruct-description-size) (1- i)))
+		  ((= i 0)
+		   (do ((arg arg (cdr arg)))
+		       ((null arg))
+		     (setf (nth (caar arg) l) (cdar arg)))
+		   l)))
+	     (:alist arg)
+	     (t
+	      (defstruct-error
+		"Unknown constructor kind in this defstruct type"
+		(defstruct-description-type))))
+	   description etc))
+
+(defun defstruct-expand-alter-macro (x)
+  (let* ((description (get-defstruct-description (get (car x) 'defstruct-name)))
+	 (type-description (or (get (defstruct-description-type)
+				    'defstruct-type-description)
+			       (defstruct-error
+				 "Unknown defstruct type"
+				 (defstruct-description-type))))
+	 (ref-code (defstruct-type-description-ref-expander))
+	 (ref-nargs (defstruct-type-description-ref-no-args)))
+    (do ((l (car (defstruct-parse-setq-style-slots 
+		   (nthcdr (1+ ref-nargs) x)
+		   (defstruct-description-slot-alist)
+		   nil
+		   x))
+	    (cdr l))
+	 (but-first (defstruct-description-but-first))
+	 (body nil)
+	 (avars (do ((i 0 (1+ i))
+		     (l nil (cons (gensym) l)))
+		    ((= i ref-nargs) l)))
+	 (vars nil)
+	 (vals nil))
+	((null l)
+	 `((lambda ,avars
+	     ,@(if (null vars)
+		   body
+		   `(((lambda ,vars ,@body) ,.vals))))
+	   ,@(do ((i (1- ref-nargs) (1- i))
+		  (l `(,(if but-first
+			    `(,but-first ,(nth ref-nargs x))
+			    (nth ref-nargs x)))
+		     (cons (nth i x) l)))
+		 ((= i 0) l))))
+      (let ((ref (lexpr-funcall ref-code (caar l) description avars)))
+	(and (emptyp (car (cddr (car l))))
+	     (setf (car (cddr (car l))) ref))
+	(let ((code (defstruct-code-from-dsc (car l))))
+	  (if (null (cdr l))
+	      (push `(setf ,ref ,code) body)
+	      (let ((sym (gensym)))
+		(push `(setf ,ref ,sym) body)
+		(push sym vars)
+		(push code vals))))))))
+
+(defmacro defstruct-define-type (type &body options)
+  (do ((options options (cdr options))
+       (op) (args)
+       (type-description (make-defstruct-type-description))
+       (cons-expander nil)
+       (ref-expander nil)
+       (returns `(',type)))
+      ((null options)
+       (or cons-expander
+	   (defstruct-error "No cons option in defstruct-define-type" type))
+       (or ref-expander
+	   (defstruct-error "No ref option in defstruct-define-type" type))
+       `(progn 'compile
+	       ,cons-expander
+	       ,ref-expander
+	       (defprop ,type ,type-description defstruct-type-description)
+	       ,@returns))
+    (cond ((atom (setq op (car options)))
+	   (setq args nil))
+	  (t
+	   (setq args (cdr op))
+	   (setq op (car op))))
+ AGAIN
+    (selectq op
+      (:cons
+        (or (> (length args) 2)
+	    (defstruct-error
+	      "Bad cons option in defstruct-define-type"
+	      (car options) 'in type))
+	(let ((n (length (car args)))
+	      (name (append-symbols type '-defstruct-cons)))
+	  (or (= n 3)
+	      (defstruct-error
+		"Bad cons option in defstruct-define-type"
+		(car options) 'in type))
+	  (setf (defstruct-type-description-cons-flavor)
+		(defstruct-retry-keyword (cadr args)))
+	  (setf (defstruct-type-description-cons-expander) name)
+	  (setq cons-expander `(defun ,name ,(car args)
+				 ,@(cddr args)))))
+      (:ref
+        (or (> (length args) 1)
+	    (defstruct-error
+	      "Bad ref option in defstruct-define-type"
+	      (car options) 'in type))
+	(let ((n (length (car args)))
+	      (name (append-symbols type '-defstruct-ref)))
+	  (or (> n 2)
+	      (defstruct-error
+		"Bad ref option in defstruct-define-type"
+		(car options) 'in type))
+	  (setf (defstruct-type-description-ref-no-args) (- n 2))
+	  (setf (defstruct-type-description-ref-expander) name)
+	  (setq ref-expander `(defun ,name ,(car args)
+				,@(cdr args)))))
+      (:predicate
+        (or (> (length args) 1)
+	    (defstruct-error
+	      "Bad predicate option in defstruct-define-type"
+	      (car options) 'in type))
+        (let ((name (append-symbols type '-defstruct-predicate)))
+	  (setf (defstruct-type-description-predicate) name)
+	  (push `(defun ,name ,(car args)
+		   ,@(cdr args))
+		returns)))
+      (:copier
+        (or (> (length args) 1)
+	    (defstruct-error
+	      "Bad copier option in defstruct-define-type"
+	      (car options) 'in type))
+        (let ((name (append-symbols type '-defstruct-copier)))
+	  (setf (defstruct-type-description-copier) name)
+	  (push `(defun ,name ,(car args)
+		   ,@(cdr args))
+		returns)))
+      (:overhead
+        (setf (defstruct-type-description-overhead)
+	      (if (null args)
+		  (defstruct-error
+		    "Bad option to defstruct-define-type"
+		    (car options) 'in type)
+		  (car args))))
+      (:named
+        (setf (defstruct-type-description-named-type)
+	      (if (null args)
+		  type
+		  (car args))))
+      (:keywords
+        (setf (defstruct-type-description-cons-keywords) args))
+      (:defstruct
+        (or (> (length args) 1)
+	    (defstruct-error
+	      "Bad defstruct option in defstruct-define-type"
+	      (car options) 'in type))
+	(let ((name (append-symbols type '-defstruct-expand)))
+	  (setf (defstruct-type-description-defstruct-expander) name)
+	  (push `(defun ,name ,@args) returns)))
+      (t
+       (let ((new (defstruct-retry-keyword op)))
+	 (cond ((not (eq op new))
+		(setq op new)
+		(go AGAIN)))
+	 (defstruct-error
+	   "Unknown option to defstruct-define-type"
+	   op 'in type))))))
+
+#+LispM
+(defprop :make-array t :defstruct-option)
+
+#+LispM
+(defstruct-define-type :array
+  (:named :named-array)
+  (:keywords :make-array)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
+			       description etc nil nil nil 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,n)))
+
+#+MacLisp
+(defstruct-define-type :array
+  (:cons (arg description etc) :alist
+    etc
+    (maclisp-array-for-defstruct arg description 't))
+  (:ref (n description arg)
+    description		;ignored
+    `(arraycall t ,arg ,n)))
+
+#+NIL
+(defstruct-define-type :array
+  (:cons (arg description etc) :alist
+    etc
+    (NIL-array-for-defstruct arg description))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,n)))
+
+#+LispM
+(defstruct-define-type :named-array
+  (:keywords :make-array)
+  :named (:overhead 1)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,(1+ i)))
+			       description etc nil t nil 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,(1+ n)))
+  (:predicate (description name)
+    `(defsubst ,name (x)
+       (typep x ',(defstruct-description-name)))))
+
+#+LispM
+(defstruct-define-type :fixnum-array
+  (:keywords :make-array)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
+			       description etc 'art-32b nil nil 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,n)))
+
+#+MacLisp
+(defstruct-define-type :fixnum-array
+  (:cons (arg description etc) :alist
+    etc
+    (maclisp-array-for-defstruct arg description 'fixnum))
+  (:ref (n description arg)
+    description		;ignored
+    `(arraycall fixnum ,arg ,n)))
+
+#+LispM
+(defstruct-define-type :flonum-array
+  (:keywords :make-array)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
+			       description etc 'art-float nil nil 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,n)))
+
+#+MacLisp
+(defstruct-define-type :flonum-array
+  (:cons (arg description etc) :alist
+    etc
+    (maclisp-array-for-defstruct arg description 'flonum))
+  (:ref (n description arg)
+    description		;ignored
+    `(arraycall flonum ,arg ,n)))
+
+#+MacLisp-10
+(defstruct-define-type :un-gc-array
+  (:cons (arg description etc) :alist
+    etc			;ignored
+    (maclisp-array-for-defstruct arg description nil))
+  (:ref (n description arg)
+    description		;ignored
+    `(arraycall nil ,arg ,n)))
+
+#+LispM
+(defstruct-define-type :array-leader
+  (:named :named-array-leader)
+  (:keywords :make-array)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i)
+				       `(store-array-leader ,v ,a ,i))
+			       description etc nil nil t 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(array-leader ,arg ,n)))
+
+#+LispM
+(defstruct-define-type :named-array-leader
+  (:keywords :make-array)
+  :named (:overhead 1)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct
+      arg
+      #'(lambda (v a i)
+	  `(store-array-leader ,v ,a ,(if (zerop i)
+					  0
+					  (1+ i))))
+      description etc nil t t 1))
+  (:ref (n description arg)
+    description		;ignored
+    (if (zerop n)
+	`(array-leader ,arg 0)
+	`(array-leader ,arg ,(1+ n))))
+  (:predicate (description name)
+    `(defsubst ,name (x)
+       (typep x ',(defstruct-description-name)))))
+
+#+LispM
+(defprop :times t :defstruct-option)
+
+#+LispM
+(defstruct-define-type :grouped-array
+  (:keywords :make-array :times)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct
+      arg
+      #'(lambda (v a i) `(aset ,v ,a ,i))
+      description etc nil nil nil
+      (or (cdr (or (assq ':times etc)
+		   (assq ':times (defstruct-description-property-alist))))
+	  1)))
+  (:ref (n description index arg)
+    description		;ignored
+    (cond ((numberp index)
+	   `(aref ,arg ,(+ n index)))
+	  ((zerop n)
+	   `(aref ,arg ,index))
+	  (t `(aref ,arg (+ ,n ,index))))))
+
+#+LispM
+(defun lispm-array-for-defstruct (arg cons-init description etc type named-p leader-p times)
+  (let ((p (cons nil nil))
+	(no-op nil))
+    (defstruct-grok-make-array-args
+      (cdr (assq ':make-array (defstruct-description-property-alist)))
+      p)
+    (defstruct-grok-make-array-args
+      (cdr (assq ':make-array etc))
+      p)
+    (and type (putprop p type ':type))
+    (and named-p (putprop p `',(defstruct-description-name) ':named-structure-symbol))
+    (putprop p
+	     (let ((size (if named-p
+			     (1+ (defstruct-description-size))
+			     (defstruct-description-size))))
+	       (if (numberp times)
+		   (* size times)
+		   `(* ,size ,times)))	     
+	     (if leader-p ':leader-length ':dimensions))
+    (or leader-p
+	(if (get p ':initial-value)
+	    (setq no-op (make-empty))
+	    (let ((type (get p ':type)))
+	      (or (atom type)
+		  (not (eq (car type) 'quote))
+		  (setq type (cadr type)))
+	      (caseq type
+		((nil art-q art-q-list))
+		((art-32b art-16b art-8b art-4b art-2b art-1b art-string)
+		 (setq no-op 0))
+		((art-float) (setq no-op 0.0))
+		(t (setq no-op (make-empty)))))))
+    (do ((creator
+	   (let ((dims (remprop p ':dimensions)))
+	     (do ((l (cdr p) (cddr l)))
+		 ((null l))
+	       (rplaca l `',(car l)))
+	     `(make-array ,(if (null dims) 0 (car dims)) ,@(cdr p))))
+	 (var (gensym))
+	 (set-ups nil (if (equal (cdar l) no-op)
+			  set-ups
+			  (cons (funcall cons-init (cdar l) var (caar l))
+				set-ups)))
+	 (l arg (cdr l)))
+	((null l)
+	 (if set-ups
+	     `((lambda (,var)
+		 ,@(nreverse set-ups)
+		 ,var)
+	       ,creator)
+	     creator)))))
+
+#+LispM
+(defun defstruct-grok-make-array-args (args p)
+  (do ((l args (cddr l)))
+      ((null l) p)
+    (if (or (null (cdr l))
+	    (not (memq (car l) '(:area :type :displaced-to :leader-list
+				 :leader-length :displaced-index-offset
+				 :named-structure-symbol :dimensions
+				 :length :initial-value))))
+	(defstruct-error
+	  "defstruct can't grok these make-array arguments"
+	  args))
+    (putprop p
+	     (cadr l)
+	     (if (eq (car l) ':length)
+		 ':dimensions
+		 (car l)))))
+
+#+NIL
+(defun NIL-array-for-defstruct (arg description)
+  (do ((creator `(make-array ',(defstruct-description-size)))
+       (var (gensym))
+       (set-ups nil (if (null (cdar l))
+			set-ups
+			(cons `(aset ,(cdar l) ,var ,(caar l))
+			      set-ups)))
+       (l arg (cdr l)))
+      ((null l)
+       (if set-ups
+	   `((lambda (,var)
+	       ,@(nreverse set-ups)
+	       ,var)
+	     ,creator)
+	   creator))))
+
+#+MacLisp
+(defun maclisp-array-for-defstruct (arg description type)
+  (do ((creator `(array nil ,type ,(defstruct-description-size)))
+       (var (gensym))
+       (no-op (caseq type
+		(fixnum 0)
+		(flonum 0.0)
+		((t nil) nil)))
+       (set-ups nil (if (equal (cdar l) no-op)
+			set-ups
+			(cons `(store (arraycall ,type ,var ,(caar l))
+				      ,(cdar l))
+			      set-ups)))
+       (l arg (cdr l)))
+      ((null l)
+       (if set-ups
+	   `((lambda (,var)
+	       ,@(nreverse set-ups)
+	       ,var)
+	     ,creator)
+	   creator))))
+
+#+(or MacLisp-10 NIL)
+(defprop :sfa-function t :defstruct-option)
+
+#+(or MacLisp-10 NIL)
+(defprop :sfa-name t :defstruct-option)
+
+#+(or MacLisp-10 NIL)
+(defstruct-define-type :sfa
+  (:keywords :sfa-function :sfa-name)
+  (:cons (arg description etc) :alist
+    (do ((creator `(sfa-create ,(or (cdr (or (assq ':sfa-function etc)
+					     (assq ':sfa-function (defstruct-description-property-alist))))
+				     `',(defstruct-description-name))
+			       ,(defstruct-description-size)
+			       ,(or (cdr (or (assq ':sfa-name etc)
+					     (assq ':sfa-name (defstruct-description-property-alist))))
+				    `',(defstruct-description-name))))
+	 (l arg (cdr l))
+	 (var (gensym))
+	 (set-ups nil (if (null (cdar l))
+			  set-ups
+			  (cons `(sfa-store ,var ,(caar l)
+					    ,(cdar l))
+				set-ups))))
+	((null l)
+	 (if set-ups
+	     `((lambda (,var)
+		 ,@(nreverse set-ups)
+		 ,var)
+	       ,creator)
+	     creator))))
+  (:ref (n description arg)
+    description		;ignored
+    `(sfa-get ,arg ,n))
+  (:predicate (description name)
+    `(defun ,name (x)
+       (and (sfap x)
+	    (eq (sfa-get x 'pname)
+		,(or (cdr (assq ':sfa-name (defstruct-description-property-alist)))
+		     `',(defstruct-description-name)))))))
+
+#+MacLisp-10
+(defstruct-define-type :hunk
+  (:named :named-hunk)
+  (:cons (arg description etc) :list
+    description		;ignored
+    etc			;ignored
+    (if arg
+	`(hunk ,.(nconc (cdr arg) (ncons (car arg))))
+	(defstruct-error "No slots in hunk type defstruct")))
+  (:ref (n description arg)
+    description		;ignored
+    `(cxr ,n ,arg)))
+
+#+MacLisp-10
+(defstruct-define-type :named-hunk
+  :named (:overhead 1)
+  (:cons (arg description etc) :list
+    etc			;ignored
+    (if arg
+	`(hunk ',(defstruct-description-name)
+	       ,.(nconc (cdr arg) (ncons (car arg))))
+	`(hunk ',(defstruct-description-name) nil)))
+  (:ref (n description arg)
+    description		;ignored
+    (cond ((= n 0) `(cxr 0 ,arg))
+	  (t `(cxr ,(1+ n) ,arg))))
+  (:predicate (description name)
+    `(defun ,name (x)
+       (and (hunkp x)
+	    (eq (car x) ',(defstruct-description-name))))))
+
+#+(or MacLisp-10 NIL)
+(defstruct-define-type :vector
+  (:named :named-vector)
+  (:cons (arg description etc) :list
+    description		;ignored
+    etc			;ignored
+    `(vector ,@arg))
+  (:ref (n description arg)
+    description		;ignored
+    `(vref ,arg ,n)))
+
+#+(or MacLisp-10 NIL)
+(defstruct-define-type :named-vector
+  :named (:overhead 1)
+  (:cons (arg description etc) :list
+    etc			;ignored
+    `(vector ',(defstruct-description-name) ,@arg))
+  (:ref (n description arg)
+    description		;ignored
+    `(vref ,arg ,(1+ n)))
+  (:predicate (description name)
+    `(defun ,name (x)
+       (and (vectorp x)
+	    (eq (vref x 0) ',(defstruct-description-name))))))
+
+#+NIL
+(defprop :class-symbol t :defstruct-option)
+
+#+NIL
+(defstruct-define-type :extend
+  :named
+  (:defstruct (description)
+    (if (assq ':class-symbol (defstruct-description-property-alist))
+	;; if class-symbol is given then assume user is setting up
+	;; his own class.
+	()
+	(let* ((name (defstruct-description-name))
+	       (class-symbol (append-symbols name '-class)))
+	  (push (cons ':class-symbol class-symbol)
+		(defstruct-description-property-alist))
+	  `((defstruct-class-setup ,name ,class-symbol)))))
+  (:cons (arg description etc) :alist
+    etc			;ignored
+    (do ((l arg (cdr l))
+	 (creator `(si:make-extend
+		    ,(defstruct-description-size)
+		    ,(cdr (assq ':class-symbol
+				(defstruct-description-property-alist)))))
+	 (var (gensym))
+	 (set-ups () (if (null (cdar l))
+			 set-ups
+			 (cons `(si:xset ,var ,(caar l) ,(cdar l))
+			       set-ups))))
+	((null l)
+	 (if set-ups
+	     `((lambda (,var)
+		 ,.(nreverse set-ups)
+		 ,var)
+	       ,creator)
+	     creator))))
+  (:ref (n description arg)
+    description		;ignored
+    `(si:xref ,arg ,n))
+  (:predicate (description name)
+    `(defsubst ,name (x)
+       (of-type x ',(defstruct-description-name)))))
+
+(defstruct-define-type :list
+  (:named :named-list)
+  (:cons (arg description etc) :list
+    description		;ignored
+    etc			;ignored
+    `(list ,.arg))
+  (:ref (n description arg)
+    description		;ignored
+ #+Multics
+    `(,(let ((i (\ n 4)))
+	 (cond ((= i 0) 'car)
+	       ((= i 1) 'cadr)
+	       ((= i 2) 'caddr)
+	       (t 'cadddr)))
+      ,(do ((a arg `(cddddr ,a))
+	    (i (// n 4) (1- i)))
+	   ((= i 0) a)))
+ #-Multics
+    `(nth ,n ,arg))
+  (:copier (description name)
+    (do ((l `((car x)) (cons `(prog1 (car x) (setq x (cdr x))) l))
+	 (i (defstruct-description-size) (1- i)))
+	((<= i 1)
+	 `(defun ,name (x)
+	    (list ,@l))))))
+
+(defstruct-define-type :named-list
+  :named (:overhead 1)
+  (:cons (arg description etc) :list
+    etc			;ignored
+    `(list ',(defstruct-description-name) ,.arg))
+  (:ref (n description arg)
+    description		;ignored
+ #+Multics
+    `(,(let ((i (\ (1+ n) 4)))
+	 (cond ((= i 0) 'car)
+	       ((= i 1) 'cadr)
+	       ((= i 2) 'caddr)
+	       (t 'cadddr)))
+      ,(do ((a arg `(cddddr ,a))
+	    (i (// (1+ n) 4) (1- i)))
+	   ((= i 0) a)))
+ #-Multics
+    `(nth ,(1+ n) ,arg))
+  (:predicate (description name)
+    `(defun ,name (x)
+       (and
+      #-MacLisp-10
+	 (not (atom x))
+      #+MacLisp-10	;Watch out for hunks!
+         (eq (typep x) 'list)
+	 (eq (car x) ',(defstruct-description-name)))))
+  (:copier (description name)
+    (do ((l `((car x)) (cons `(prog1 (car x) (setq x (cdr x))) l))
+	 (i (defstruct-description-size) (1- i)))
+	((<= i 1)
+	 `(defun ,name (x)
+	    (setq x (cdr x))
+	    (list ',(defstruct-description-name) ,@l))))))
+
+(defstruct-define-type :list*
+  (:cons (arg description etc) :list
+    description		;ignored
+    etc			;ignored
+    `(list* ,.arg))
+  (:ref (n description arg)
+    (let ((size (1- (defstruct-description-size))))
+   #+Multics
+      (do ((a arg `(cddddr ,a))
+	   (i (// n 4) (1- i)))
+	  ((= i 0)
+	   (let* ((i (\ n 4))
+		  (a (cond ((= i 0) a)
+			   ((= i 1) `(cdr ,a))
+			   ((= i 2) `(cddr ,a))
+			   (t `(cdddr ,a)))))
+	     (if (< n size) `(car ,a) a))))
+   #-Multics
+      (if (< n size)
+	  `(nth ,n ,arg)
+	  `(nthcdr ,n ,arg))))
+  (:defstruct (description)
+    (and (defstruct-description-include)
+	 (defstruct-error
+	   "Structure of type list* cannot include another"
+	   (defstruct-description-name)))
+    nil)
+  (:copier (description name)
+    (do ((l `(x) (cons `(prog1 (car x) (setq x (cdr x))) l))
+	 (i (defstruct-description-size) (1- i)))
+	((<= i 1)
+	 `(defun ,name (x)
+	    (list* ,@l))))))
+
+(defstruct-define-type :tree
+  (:cons (arg description etc) :list
+    etc			;ignored
+    (if (null arg) (defstruct-error
+		     "defstruct cannot make an empty tree"
+		     (defstruct-description-name)))
+    (make-tree-for-defstruct arg (defstruct-description-size)))
+  (:ref (n description arg)
+    (do ((size (defstruct-description-size))
+	 (a arg)
+	 (tem))
+	(nil)
+      (cond ((= size 1) (return a))
+	    ((< n (setq tem (// size 2)))
+	     (setq a `(car ,a))
+	     (setq size tem))
+	    (t (setq a `(cdr ,a))
+	       (setq size (- size tem))
+	       (setq n (- n tem))))))
+  (:defstruct (description)
+    (and (defstruct-description-include)
+	 (defstruct-error
+	   "Structure of type tree cannot include another"
+	   (defstruct-description-name)))
+    nil)
+  (:copier (description name)
+    `(defun ,name (x)
+       ,(copy-tree-for-defstruct nil (defstruct-description-size)))))
+
+(defun make-tree-for-defstruct (arg size)
+  (cond ((= size 1) (car arg))
+	((= size 2) `(cons ,(car arg) ,(cadr arg)))
+	(t (do ((a (cdr arg) (cdr a))
+		(m (// size 2))
+		(n (1- (// size 2)) (1- n)))
+	       ((zerop n)
+		`(cons ,(make-tree-for-defstruct arg m)
+		       ,(make-tree-for-defstruct a (- size m))))))))
+
+(defun copy-tree-for-defstruct (popx? size)
+  (cond ((= size 1)
+	 (if popx?
+	     `(prog1 (car x) (setq x (cdr x)))
+	     `x))
+	((= size 2)
+	 (if popx?
+	     `((lambda (x) (cons (car x) (cdr x)))
+	       (prog1 (car x) (setq x (cdr x))))
+	     `(cons (car x) (cdr x))))
+	(popx?
+	 `((lambda (x)
+	     (cons ,(copy-tree-for-defstruct t (// size 2))
+		   ,(copy-tree-for-defstruct nil (- size (// size 2)))))
+	   (prog1 (car x) (setq x (cdr x)))))
+	(t
+	 `(cons ,(copy-tree-for-defstruct t (// size 2))
+		,(copy-tree-for-defstruct nil (- size (// size 2)))))))
+
+(defstruct-define-type :fixnum
+  (:cons (arg description etc) :list
+    etc			;ignored
+    (and (or (null arg)
+	     (not (null (cdr arg))))
+	 (defstruct-error
+	   "Structure of type fixnum must have exactly 1 slot to be constructable"
+	   (defstruct-description-name)))
+    (car arg))
+  (:ref (n description arg)
+    n			;ignored
+    description		;ignored
+    arg))
+
+#+Multics
+(defprop :external-ptr t :defstruct-option)
+
+#+Multics
+(defstruct-define-type :external
+  (:keywords :external-ptr)
+  (:cons (arg description etc) :alist
+    (let ((ptr (cdr (or (assq ':external-ptr etc)
+			(assq ':external-ptr
+			      (defstruct-description-property-alist))
+			(defstruct-error
+			  "No pointer given for external array"
+			  (defstruct-description-name))))))
+      (do ((creator `(array nil external ,ptr ,(defstruct-description-size)))
+	   (var (gensym))
+	   (alist arg (cdr alist))
+	   (inits nil (cons `(store (arraycall fixnum ,var ,(caar alist))
+				    ,(cdar alist))
+			    inits)))
+	  ((null alist)
+	   (if (null inits)
+	       creator
+	       `((lambda (,var) ,.inits ,var)
+		 ,creator))))))
+  (:ref (n description arg)
+    description	;ignored
+    `(arraycall fixnum ,arg ,n)))
+
+(defvar *defstruct-examine&deposit-arg*)
+
+(defun defstruct-examine (*defstruct-examine&deposit-arg*
+			  name slot-name)
+  (eval (list (defstruct-slot-description-ref-macro-name
+		(defstruct-examine&deposit-find-slot-description
+		  name slot-name))
+	      '*defstruct-examine&deposit-arg*)))
+
+(defvar *defstruct-examine&deposit-val*)
+
+(defun defstruct-deposit (*defstruct-examine&deposit-val*
+			  *defstruct-examine&deposit-arg*
+			  name slot-name)
+  (eval (list 'setf
+	      (list (defstruct-slot-description-ref-macro-name
+		     (defstruct-examine&deposit-find-slot-description
+		       name slot-name))
+		    '*defstruct-examine&deposit-arg*)
+	      '*defstruct-examine&deposit-val*)))
+
+#+LispM
+(defun defstruct-get-locative (*defstruct-examine&deposit-arg*
+			       name slot-name)
+  (let ((slot-description (defstruct-examine&deposit-find-slot-description
+			    name slot-name)))
+    (or (null (defstruct-slot-description-ppss))
+	(defstruct-error
+	  "You cannot get a locative to a byte field"
+	  slot-name 'in name))
+    (eval (list 'locf
+		(list (defstruct-slot-description-ref-macro-name)
+		      '*defstruct-examine&deposit-arg*)))))
+
+(defun defstruct-examine&deposit-find-slot-description (name slot-name)
+  (let ((description (get-defstruct-description name)))
+    (let ((slot-description
+	    (cdr (or (assq slot-name (defstruct-description-slot-alist))
+		     (defstruct-error
+		       "No such slot in this structure"
+		       slot-name 'in name))))
+	  (type-description
+	    (or (get (defstruct-description-type) 'defstruct-type-description)
+		(defstruct-error
+		  "Undefined defstruct type"
+		  (defstruct-description-type)))))
+      (or (= (defstruct-type-description-ref-no-args) 1)
+	  (defstruct-error
+	    "defstruct-examine and defstruct-deposit cannot handle structures of this type"
+	    (defstruct-description-type)))
+      slot-description)))
+
+#+MacLisp-10
+(defprop defstruct
+	 #.(and (status feature MacLisp-10)
+		(caddr (truename infile)))
+	 version)
+
+(sstatus feature defstruct)
diff --git a/src/alan/nstruc.294 b/src/alan/nstruc.294
new file mode 100755
index 00000000..f038d033
--- /dev/null
+++ b/src/alan/nstruc.294
@@ -0,0 +1,1969 @@
+;;; -*- Mode:Lisp; Package:SI; Lowercase:True -*-
+;;;	** (c) Copyright 1980 Massachusetts Institute of Technology **
+;;;	** (c) Copyright 1981 Massachusetts Institute of Technology **
+;;;	** (c) Copyright 1982 Massachusetts Institute of Technology **
+
+;The master copy of this file is in MC:ALAN;NSTRUCT >
+;The current PDP10 MacLisp copy is in MC:ALAN;STRUCT >
+;The current Lisp machine copy is in SYS:SYS2;STRUCT.LISP.NEWEST
+;The current Multics MacLisp copy is someplace on MIT-Multics
+;The current VMS-NIL copy is in [NIL.SRC.SPEC]STRUCT.LSP on HTJR
+
+;*****  READ THIS PLEASE!  *****
+;If you are thinking of munging anything in this file you might want to
+;consider finding me (ALAN) and asking me to mung it for you.  There is more
+;than one copy of this file in the world (it runs in PDP10 and Multics MacLisp,
+;NIL, Franz, PSL and on LispMachines) and whatever amazing features you are
+;considering adding might be usefull to those people as well.  If you still
+;cannot contain yourself long enough to find me, AT LEAST send me a piece of
+;mail describing what you did and why.  Thanks for reading this flame.
+;				Alan Bawden (Alan@MIT-MC)
+
+(eval-when (compile)
+  (cond ((status feature ITS)
+	 (load '|alan;lspenv init|))
+	((status feature OZ)
+	 (load '|<alan>lspenv.init|))
+	((status feature Multics)
+	 (load '|>udd>Mathlab>Bawden>lspenv.lisp|))))
+
+(eval-when (eval)
+  ;;So we may run the thing interpreted we need the simple defstruct that lives
+  ;;here:
+  (cond ((status feature ITS)
+	 (load '|alan;struct initial|))
+	((status feature OZ)
+	 (load '|<alan>initial-defstruct|))
+	((status feature Multics)
+	 (load '|>udd>Mathlab>Bawden>initial_defstruct|))))
+
+(eval-when (compile)
+  ;;To compile the thing this probably is an old fasl: (!)
+  (cond ((status feature ITS)
+	 (load '|alan;struct boot|))
+	((status feature OZ)
+	 (load '|<alan>boot-defstruct|))
+	((status feature Multics)
+	 (load '|>udd>Mathlab>Bawden>boot_defstruct|))))
+
+(eval-when (eval compile)
+  (cond ((and (status feature MacLisp) (status feature PDP10))
+	 (sstatus feature MacLisp-10))
+	(t (sstatus nofeature MacLisp-10)))
+  (cond ((status feature NIL)
+	 ;;The answer to (status feature stingy-defstruct) isn't nil by default
+	 ;;in NIL.  Of course this makes the stingy-defstruct hack worthless in
+	 ;;NIL.  I wonder if there is a RIGHT way to do this there?
+	 (sstatus nofeature stingy-defstruct))))
+
+;;;On the LispMachine you need to evaluate this before incremental compilation:
+(eval-when (eval compile)
+(defmacro feature-case clauses
+  (let* ((name clauses)
+	 (body (cdar (do ((l (cond ((atom (car clauses))
+				    (setq name (car clauses))
+				    (cdr clauses))
+				   (t clauses))
+			     (cdr l))
+			  (features (status features)))
+			 ((null l)
+			  (error "feature-case: no matching feature found " name))
+		       (let ((test (caar l)))
+			 (cond ((memq test '(otherwise t :otherwise :t))
+				(return l))
+			       ((atom test)
+				(if (memq test features)
+				    (return l)))
+			       ((do ((k test (cdr k)))
+				    ((null k) nil)
+				  (if (memq (car k) features)
+				      (return t)))
+				(return l))))))))
+    (if (null (cdr body))
+	(car body)
+	`(progn 'compile ,@body)))))
+
+(feature-case	;announce ourselves
+ (MacLisp-10
+  (cond ((status nofeature noldmsg)
+	 (terpri msgfiles)
+	 (princ '#.(and (status feature MacLisp-10)
+			(maknam (nconc (exploden ";Loading DEFSTRUCT ")
+				       (exploden (caddr (truename infile))))))
+		msgfiles))))
+ (NIL
+  (herald defstruct))
+ (t))
+
+(feature-case	;On Multics (defun (foo bar) ...) needs a name
+ (Multics	;to call the function.
+  (declare (genprefix defstruct-internal-)
+	   (macros t)))
+ (t))
+
+(feature-case	;In MacLisp ignore colons.  Notice that this is NOT for
+ (MacLisp	;runtime.  We have another hack to cover that.
+  (eval-when (eval compile)
+    (setsyntax #/: (ascii #\space) nil)))
+ (t))
+
+(eval-when (eval compile load)
+(feature-case defstruct-retry-keyword
+
+(MacLisp
+(defun defstruct-retry-keyword (x)
+  (let ((l (exploden x)))
+    (if (= (car l) #/:)
+	(implode (cdr l))
+	x))))
+
+(LispM
+(defun defstruct-retry-keyword (x)
+  (intern (get-pname x) si:pkg-user-package)))
+
+(NIL
+(defmacro defstruct-retry-keyword (x)
+  `(to-keyword ,x)))
+
+)) ;end (eval-when (eval compile load) (feature-case defstruct-retry-keyword ...))
+
+;;;On the LispMachine you need to evaluate this before incremental compilation:
+(eval-when (eval compile)
+
+(feature-case append-symbols
+
+(MacLisp-10
+(defmacro append-symbols args
+  (do ((l (reverse args) (cdr l))
+       (x)
+       (a nil (if (or (atom x)
+		      (not (eq (car x) 'quote)))
+		  (if (null a)
+		      `(exploden ,x)
+		      `(nconc (exploden ,x) ,a))
+		  (let ((l (exploden (cadr x))))
+		    (cond ((null a) `',l)
+			  ((= 1 (length l)) `(cons ,(car l) ,a))
+			  (t `(append ',l ,a)))))))
+      ((null l) `(implode ,a))
+    (setq x (car l)))))
+
+(Multics
+(defmacro append-symbols args
+  `(make_atom (catenate ,@args))))
+
+(LispM
+(defmacro append-symbols args
+  `(intern (string-append ,@args))))
+
+(NIL
+(defmacro append-symbols args
+  `(symbolconc ,@args)))
+
+) ;end (feature-case append-symbols ...)
+
+(defmacro defstruct-putprop (sym val ind)
+  `(push `(defprop ,,sym ,,val ,,ind) returns))
+
+(feature-case defstruct-put-macro
+
+(Multics
+;;;lcp gobbles (defprop ... macro) at compile time, so we have to use
+;;;putprop to be certain macro definitions make it into the object:
+(defmacro defstruct-put-macro (sym fcn)
+  `(push `(putprop ',,sym ',,fcn 'macro) returns)))
+
+(MacLisp-10
+(defmacro defstruct-put-macro (sym fcn)
+  `(push `(defprop ,,sym ,,fcn macro) returns)))
+
+(LispM
+(defmacro defstruct-put-macro (sym fcn)
+  (setq fcn (if (and (not (atom fcn))
+		     (eq (car fcn) 'quote))
+		`'(macro . ,(cadr fcn))
+		`(cons 'macro ,fcn)))
+  `(push `(fdefine ',,sym ',,fcn t) returns)))
+
+(NIL
+(defmacro defstruct-put-macro (sym fcn)
+  `(push `(add-macro-definition ',,sym ',,fcn) returns)))
+
+) ;end (feature-case defstruct-put-macro ...)
+							
+(defmacro make-empty () `'%%defstruct-empty%%)
+
+(defmacro emptyp (x) `(eq ,x '%%defstruct-empty%%))
+
+;;;Here we must deal with the fact that error reporting works
+;;;differently everywhere!
+
+(feature-case defstruct-error
+
+(MacLisp-10
+;;;first arg is ALWAYS a symbol or a quoted symbol:
+(defmacro defstruct-error (message &rest args)
+  (let* ((chars (nconc (exploden (if (atom message)
+				     message
+				     (cadr message)))
+		       '(#/.)))		;"Bad frob" => "Bad frob."
+	 (new-message
+	  (maknam (if (null args)
+		      chars
+		      (let ((c (car chars)))	;"Bad frob." => "-- bad frob."
+			(or (< c #/A)
+			    (> c #/Z)
+			    (rplaca chars (+ c #o40)))
+			(append '(#/- #/- #\space) chars))))))
+  `(error ',new-message
+	  ,@(cond ((null args) `())
+		  ((null (cdr args)) `(,(car args)))
+		  (t `((list ,@args))))))))
+
+(Multics
+;;;first arg is ALWAYS a string:
+(defmacro defstruct-error (message &rest args)
+  `(error ,(catenate "defstruct: "
+		     message
+		     (if (null args)
+			 "."
+			 ": "))
+	  ,@(cond ((null args) `())
+		  ((null (cdr args)) `(,(car args)))
+		  (t `((list ,@args)))))))
+
+((LispM NIL)
+;;;first arg is ALWAYS a string:
+(defmacro defstruct-error (message &rest args)
+  (do ((l args (cdr l))
+       (fs "")
+       (na nil))
+      ((null l)
+      `(ferror nil
+	       ,(string-append message
+			       (if (null args)
+				   "."
+				   (string-append ":" fs)))
+	       ,.(nreverse na)))
+    (cond ((and (not (atom (car l)))
+		(eq (caar l) 'quote)
+		(symbolp (cadar l)))
+	   (setq fs (string-append fs " " (string-downcase (cadar l)))))
+	  (t
+	   (push (car l) na)
+	   (setq fs (string-append fs " ~S")))))))
+
+) ;end (feature-case defstruct-error ...)
+
+) ;end (eval-when (eval compile) ...)
+
+;;;If you mung the the ordering af any of the slots in this structure,
+;;;be sure to change the version slot and the definition of the function
+;;;get-defstruct-description.  Munging the defstruct-slot-description 
+;;;structure should also cause you to change the version "number" in this
+;;;manner.
+(defstruct (defstruct-description
+	     (:type :list)
+	     (:default-pointer description)
+	     (:conc-name defstruct-description-)
+	     (:alterant ())	;NIL's fault
+	  #+stingy-defstruct
+	     (:eval-when (eval compile)))
+  (version 'two)
+  type
+  (logldbp nil) ;used to be the displace function
+  slot-alist
+  named-p
+  constructors
+  (default-pointer nil)
+  (but-first nil)
+  size
+  (property-alist nil)
+  ;;end of "expand-time" slots
+  name
+  include
+  (initial-offset 0)
+  (eval-when '(eval compile load))
+  alterant
+  (conc-name nil)
+  (callable-accessors (feature-case ((LispM NIL) t) (t nil)))
+  (size-macro nil)
+  (size-symbol nil)
+  (predicate nil)
+  (copier nil)
+  (print nil)
+  )
+
+(defun get-defstruct-description (name)
+  (let ((description (get name 'defstruct-description)))
+    (cond ((null description)
+	   (defstruct-error
+	     "A structure with this name has not been defined" name))
+	  ;;Versions ONE and TWO are acceptable to us, but we aren't downward
+	  ;;compatible.  The defstructs dumped in older systems should be have
+	  ;;their error messages patched to read like this one.
+	  ((not (or (eq (defstruct-description-version) 'two)
+		    (eq (defstruct-description-version) 'one)))
+	   (defstruct-error "The internal description of this structure is incompatible 
+with the currently loaded version of defstruct.  You will
+need to recompile its definition, or load the version of
+defstruct that it was compiled with."
+		  name))
+	  (t description))))
+
+;;;See note above defstruct-description structure before munging this one.
+(defstruct (defstruct-slot-description
+	     (:type :list)
+	     (:default-pointer slot-description)
+	     (:conc-name defstruct-slot-description-)
+	     (:alterant ())	;NIL's fault
+	  #+stingy-defstruct
+	     (:eval-when (eval compile)))
+  number
+  (ppss nil)
+  init-code
+  (type 'notype)
+  (property-alist nil)
+  ref-macro-name
+  )
+
+;;;Perhaps this structure wants a version slot too?
+(defstruct (defstruct-type-description
+	     (:type :list)
+	     (:default-pointer type-description)
+	     (:conc-name defstruct-type-description-)
+	     (:alterant ())	;NIL's fault
+	  #+stingy-defstruct
+	     (:eval-when (eval compile)))
+  ref-expander
+  ref-no-args
+  cons-expander
+  cons-flavor
+  (cons-keywords nil)
+  (named-type nil)
+  (overhead 0)
+  (defstruct-expander nil)
+  (predicate nil)
+  (copier nil)
+  )
+
+;; (DEFSTRUCT (<name> . <options>) . <slots>) or (DEFSTRUCT <name> . <slots>)
+;;
+;; <options> is of the form (<option> <option> (<option> <val>) ...)
+;;
+;; <slots> is of the form (<slot> (<slot> <initial-value>) ...)
+;;
+;; Options:
+;;   :TYPE defaults to HUNK
+;;   :CONSTRUCTOR defaults to "MAKE-<name>"
+;;   :DEFAULT-POINTER defaults to empty (if no <val> given defaults to "<name>")
+;;   :CONC-NAME defaults to empty (if no <val> given defaults to "<name>-")
+;;   :SIZE-SYMBOL defaults to empty (if no <val> given defaults to "<name>-SIZE")
+;;   :SIZE-MACRO defaults to empty (if no <val> given defaults to "<name>-SIZE")
+;;   :ALTERANT defaults to "ALTER-<name>"
+;;   :BUT-FIRST must have a <val> given
+;;   :INCLUDE must have a <val> given
+;;   :PROPERTY (:property foo bar) gives the structure a foo
+;;     property of bar.  (:property foo) gives a foo property of T.
+;;   :INITIAL-OFFSET can cause defstruct to skip over that many slots.
+;;   :NAMED takes no value.  Tries to make the structure a named type.
+;;   :CALLABLE-ACCESSORS defaults to true on the LispMachine and NIL.  False
+;;     elsewhere. 
+;;   :EVAL-WHEN defaults to (eval compile load).  <val> must be given.
+;;   :PREDICATE defaults to empty (if no <val> given defaults
+;;     to "<name>-P").  Generates a predicate if possible.
+;;   :COPIER defaults to empty (if no <val> given defaults to
+;;     "COPY-<name>").  Generates a function to copy this structure.
+;;   :PRINT (:print "#<spaceship at ~S by ~S>" (x-pos spaceship)
+;;     (y-pos spaceship))  The name of the structure is used as
+;;     the variable.
+;;   <type> any type name can be used without a <val> instead of
+;;     saying (:TYPE <type>) 
+;;   <other> any symbol with a non-nil :defstruct-option property.  You say
+;;     (<other> <val>) and the effect is that of (:property <other> <val>)
+;;
+;; Symbol properties used:
+;;   DEFSTRUCT-TYPE-DESCRIPTION each type has one, it is a type-description.
+;;   DEFSTRUCT-NAME each constructor, alterant and size macro
+;;     has one, it is a name. 
+;;   DEFSTRUCT-DESCRIPTION each name has one, it is a description (see below).
+;;   DEFSTRUCT-SLOT each accesor has one, it is of the form: (<name> . <slot>)
+;;   :DEFSTRUCT-OPTION if a symbol FOO has this property then it can be used as
+;;     an option giving the structure a FOO property of the value (or T).
+
+(feature-case (LispM
+(defprop defstruct "Structure" definition-type-name)
+) (t))
+
+;;;The order of forms returned by defstruct is sometimes critical.  Keep this
+;;;in mind when munging this code:
+(defmacro defstruct (options &body items)
+  (let* ((description (defstruct-parse-options options))
+	 (type-description (get (defstruct-description-type)
+				'defstruct-type-description))
+	 (name (defstruct-description-name))
+	 (new-slots (defstruct-parse-items items description))
+	 (returns nil))
+    (push `',name returns)
+    ;;This must be last, since to compile it might require that the structure
+    ;;already be operable:
+    (cond ((defstruct-description-print)
+	   (push (defstruct-define-printer name (defstruct-description-print))
+		 returns)))
+    ;;Keep this as close to last as possible:
+    (cond ((defstruct-type-description-defstruct-expander)
+	   (setq returns (append (funcall (defstruct-type-description-defstruct-expander)
+					  description)
+				 returns))))
+    (let ((alterant (defstruct-description-alterant))
+	  (size-macro (defstruct-description-size-macro))
+	  (size-symbol (defstruct-description-size-symbol))
+	  (predicate (defstruct-description-predicate))
+	  (copier (defstruct-description-copier)))
+      (cond (predicate
+	     (push (funcall (or (defstruct-type-description-predicate)
+				(defstruct-error
+				  "This defstruct type cannot produce a predicate"
+				  (defstruct-description-type) 'in name))
+			    description
+			    predicate)
+		   returns)))
+      (cond (copier
+	     (push
+	       (let ((copy-fun (defstruct-type-description-copier)))
+		 (cond (copy-fun
+			(funcall copy-fun description copier))
+		       ((not (= 1 (defstruct-type-description-ref-no-args)))
+			(defstruct-error
+			  "This defstruct type cannot produce a copying function"
+			  (defstruct-description-type) 'in name))
+		       (t (do ((i (1- (defstruct-description-size)) (1- i))
+			       (l nil (cons (cons i (funcall (defstruct-type-description-ref-expander)
+							     i description 'x))
+					    l)))
+			      ((< i 0)
+			       `(defun ,copier (x)
+				  ,(invoke-defstruct-constructor-expander
+				     description type-description l nil)))))))
+	       returns)))
+      (cond (alterant
+	     (defstruct-put-macro alterant 'defstruct-expand-alter-macro)
+	     (defstruct-putprop alterant name 'defstruct-name)))
+      (cond (size-macro
+	     (defstruct-put-macro size-macro 'defstruct-expand-size-macro)
+	     (defstruct-putprop size-macro name 'defstruct-name)))
+      (cond (size-symbol
+	     (push `(defconst ,size-symbol
+		      ,(+ (defstruct-description-size)
+			  (defstruct-type-description-overhead)))
+		   returns))))
+    (defstruct-putprop name description 'defstruct-description)
+    (do ((cs (defstruct-description-constructors) (cdr cs)))
+	((null cs))
+      (defstruct-put-macro (caar cs) 'defstruct-expand-cons-macro)
+      (defstruct-putprop (caar cs) name 'defstruct-name))
+    `(eval-when ,(defstruct-description-eval-when)
+	     #+LispM
+		(record-source-file-name ',name 'defstruct)
+		,.(defstruct-define-ref-macros new-slots description)
+		,.returns)))
+
+(feature-case defstruct-define-printer
+;;;General philosophy on the :print option is to not bother the
+;;;user if printing cannot be controled.  This allows for
+;;;portability without pain.  This may prove to be a bogus philoshphy.
+(MacLisp-10
+(defun defstruct-define-printer (name rest)
+  (let ((stream (gensym)))
+    `(defun (,name named-hunk-printer) (,name ,stream)
+       (?format ,stream ,@rest)))))
+
+(LispM
+(defun defstruct-define-printer (name rest)
+  (let ((op (gensym))
+	(args (gensym)))
+    `(defun (,name named-structure-invoke) (,op ,name &rest ,args)
+       (selectq ,op
+	 (:print-self
+	   (if print-readably (print-not-readable ,name))
+	   (format (car ,args) ,@rest))
+	 (:which-operations '(:print-self))
+	 (t (ferror nil "Illegal operation ~S" ,op)))))))
+
+(NIL
+(defun defstruct-define-printer (name rest)
+  (let ((method-function-name (symbolconc name "->PRINT-SELF#METHOD"))
+	(stream-var (gensym)))
+    `(progn 'compile
+	(defun ,method-function-name (,name () () ,stream-var () &optional ())
+	  (format ,stream-var ,@rest))
+	(add-flavor-method-info ',name ':print-self ',method-function-name)))))
+
+(t
+(defun defstruct-define-printer (name rest)
+  `(comment ,name ,@rest)))
+
+) ;end (feature-case defstruct-define-printer ...)
+
+(defun defstruct-parse-options (options)
+  (let ((name (if (atom options) options (car options)))
+	(type nil)
+	(constructors (make-empty))
+	(alterant (make-empty))
+	(included nil)
+	(named-p nil)
+	(but-first nil)
+	(description (make-defstruct-description)))
+    (setf (defstruct-description-name) name)
+    (do ((op) (val) (vals)
+	 (options (if (atom options) nil (cdr options))
+		  (cdr options)))
+	((null options))
+      (if (atom (setq op (car options)))
+	  (setq vals nil)
+	  (setq op (prog1 (car op) (setq vals (cdr op)))))
+      (setq val (if (null vals) (make-empty) (car vals)))
+AGAIN (selectq op
+	(:type
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The type option to defstruct must have a value given"
+	       name))
+	 (setq type val))
+	(:named
+	 (or (emptyp val)
+	     (defstruct-error
+	       "The named option to defstruct doesn't take a value" name))
+	 (setq named-p t))
+	(:default-pointer
+	 (setf (defstruct-description-default-pointer)
+	       (if (emptyp val) name val)))
+	(:conc-name
+	 (setf (defstruct-description-conc-name)
+	       (if (emptyp val)
+		   (append-symbols name '-)
+		   val)))
+	(:print
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The print option to defstruct requires a value"
+	       name))
+	 (setf (defstruct-description-print) vals))
+	(:include
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The include option to defstruct requires a value"
+	       name))
+	 (setq included val)
+	 (setf (defstruct-description-include) vals))
+	(:predicate
+	 (setf (defstruct-description-predicate)
+	       (if (emptyp val)
+		   (append-symbols name '-p)
+		   val)))
+	(:constructor
+	 (cond ((null val)
+		(setq constructors nil))
+	       (t
+		(and (emptyp val)
+		     (setq val (append-symbols 'make- name)))
+		(setq val (cons val (cdr vals)))
+		(if (emptyp constructors)
+		    (setq constructors (list val))
+		    (push val constructors)))))
+	(:copier
+	 (setf (defstruct-description-copier)
+	       (if (emptyp val)
+		   (append-symbols 'copy- name)
+		   val)))
+	(:eval-when
+	 (and (emptyp val)
+	      (defstruct-error
+		"The eval-when option to defstruct requires a value"
+		name))
+	 (setf (defstruct-description-eval-when) val))
+	(:alterant
+	 (setq alterant val))
+	(:but-first
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The but-first option to defstruct must have a value given"
+	       name))
+	 (setq but-first val)
+	 (setf (defstruct-description-but-first) val))
+	(:size-macro
+	 (setf (defstruct-description-size-macro)
+	       (if (emptyp val)
+		   (append-symbols name '-size)
+		   val)))
+	(:size-symbol
+	 (setf (defstruct-description-size-symbol)
+	       (if (emptyp val)
+		   (append-symbols name '-size)
+		   val)))
+	(:callable-accessors
+	 (setf (defstruct-description-callable-accessors)
+	       (if (emptyp val) t val)))
+	(:property
+	 (if (emptyp val)
+	     (defstruct-error
+	       "The property option to defstruct requires a value"
+	       name))
+	 (push (cons val (if (null (cdr vals)) t (cadr vals)))
+	       (defstruct-description-property-alist)))
+	(:initial-offset
+	 (and (or (emptyp val)
+		  (not (fixp val)))
+	      (defstruct-error
+		"The initial-offset option to defstruct requires a fixnum"
+		name))
+	 (setf (defstruct-description-initial-offset) val))
+	(t
+	 (cond ((get op 'defstruct-type-description)
+		(or (emptyp val)
+		    (defstruct-error
+		      "defstruct type used as an option with a value"
+		      op 'in name))
+		(setq type op))
+	       ((get op ':defstruct-option)
+		(push (cons op (if (emptyp val) t val))
+		      (defstruct-description-property-alist)))
+	       (t
+		(let ((new (defstruct-retry-keyword op)))
+		  (cond ((not (eq new op))
+			 (setq op new)
+			 (go AGAIN)))
+		  (defstruct-error
+		    "defstruct doesn't understand this option"
+		    op 'in name)))))))
+    (cond ((emptyp constructors)
+	   (setq constructors
+		 (list (cons (append-symbols 'make- name)
+			     nil)))))
+    (setf (defstruct-description-constructors) constructors)
+    (cond ((emptyp alterant)
+	   (setq alterant
+		 (append-symbols 'alter- name))))
+    (setf (defstruct-description-alterant) alterant)
+    (cond ((not (null type))
+	   (let ((type-description
+		  (or (get type 'defstruct-type-description)
+		      (let ((new (defstruct-retry-keyword type)))
+			(cond ((eq type new) nil)
+			      (t
+			       (setq type new)
+			       (get type 'defstruct-type-description))))
+		      (defstruct-error
+			"Unknown type in defstruct"
+			type 'in name))))
+	     (if named-p
+		 (setq type
+		       (or (defstruct-type-description-named-type)
+			   (defstruct-error
+			    "There is no way to make this defstruct type named"
+			    type 'in name)))))))
+    (cond (included
+	   (let ((d (get-defstruct-description included)))
+	     (if (null type)
+		 (setq type (defstruct-description-type d))
+		 (or (eq type (defstruct-description-type d))
+		     (defstruct-error
+		       "defstruct types must agree for include option"
+		       included 'included 'by name)))
+	     (and named-p
+		  (not (eq type (defstruct-type-description-named-type
+				  (or (get type 'defstruct-type-description)
+				      (defstruct-error
+					"Unknown type in defstruct"
+					type 'in name 'including included)))))
+		  (defstruct-error
+		    "Included defstruct's type isn't a named type"
+		    included 'included 'by name))
+	     (if (null but-first)
+		 (setf (defstruct-description-but-first)
+		       (defstruct-description-but-first d))
+		 (or (equal but-first (defstruct-description-but-first d))
+		     (defstruct-error
+		       "but-first options must agree for include option"
+		       included 'included 'by name)))))
+	  ((null type)
+	   (setq type
+		 (if named-p
+		     (feature-case
+		      (MacLisp-10 ':named-hunk)
+		      (Multics ':named-list)
+		      (LispM ':named-array)
+		      (NIL ':extend))
+		     (feature-case
+		      (MacLisp-10 ':hunk)
+		      (Multics ':list)
+		      (LispM ':array)
+		      (NIL ':vector))))))
+    (let ((type-description (or (get type 'defstruct-type-description)
+				(defstruct-error
+				  "Undefined defstruct type"
+				  type 'in name))))
+      (setf (defstruct-description-type) type)
+      (setf (defstruct-description-named-p)
+	    (eq (defstruct-type-description-named-type) type)))
+    description))
+
+(defun defstruct-parse-items (items description)
+  (let ((name (defstruct-description-name))
+	(offset (defstruct-description-initial-offset))
+	(include (defstruct-description-include))
+	(o-slot-alist nil)
+	(conc-name (defstruct-description-conc-name)))
+    (or (null include)
+	(let ((d (get (car include) 'defstruct-description)))
+	  (setq offset (+ offset (defstruct-description-size d))) 
+	  (setq o-slot-alist
+		(subst nil nil (defstruct-description-slot-alist d)))
+	  (do ((l (cdr include) (cdr l))
+	       (it) (val))
+	      ((null l))
+	    (cond ((atom (setq it (car l)))
+		   (setq val (make-empty)))
+		  (t
+		   (setq val (cadr it))
+		   (setq it (car it))))
+	    (let ((slot-description (cdr (assq it o-slot-alist))))
+	      (and (null slot-description)
+		   (defstruct-error
+		     "Unknown slot in included defstruct"
+		     it 'in include 'included 'by name))
+	      (setf (defstruct-slot-description-init-code) val)))))
+    (do ((i offset (1+ i))
+	 (l items (cdr l))
+	 (slot-alist nil)
+      #+MacLisp-10
+	 (chars (exploden conc-name)))
+	((null l)
+	 (setq slot-alist (nreverse slot-alist))
+	 (setf (defstruct-description-size) i)
+	 (setf (defstruct-description-slot-alist)
+	       (nconc o-slot-alist slot-alist))
+	 slot-alist)
+      (cond ((atom (car l))
+	     (push (defstruct-parse-one-field
+		     (car l) i nil nil conc-name #+MacLisp-10 chars)
+		   slot-alist))
+	    ((atom (caar l))
+	     (push (defstruct-parse-one-field
+		     (caar l) i nil (cdar l) conc-name #+MacLisp-10 chars)
+		   slot-alist))
+	    (t
+	     (do ((ll (car l) (cdr ll)))
+		 ((null ll))
+	       (push (defstruct-parse-one-field
+		       (caar ll) i (cadar ll)
+		       (cddar ll) conc-name #+MacLisp-10 chars)
+		     slot-alist)))))))
+
+(defun defstruct-parse-one-field (it number ppss rest conc-name #+MacLisp-10 chars)
+  (let ((mname (if conc-name
+		   (feature-case
+		    (MacLisp-10 (implode (append chars (exploden it))))
+		    (t (append-symbols conc-name it)))
+		   it)))
+    (cons it (make-defstruct-slot-description
+	       number number
+	       ppss ppss
+	       init-code (if (null rest) (make-empty) (car rest))
+	       ref-macro-name mname))))
+
+(defun defstruct-define-ref-macros (new-slots description)
+  (let ((name (defstruct-description-name)))
+    (if (not (defstruct-description-callable-accessors))
+	(do ((l new-slots (cdr l))
+	     (returns nil)
+	     (mname))
+	    ((null l) returns)
+	  (setq mname (defstruct-slot-description-ref-macro-name (cdar l)))
+	  (defstruct-put-macro mname 'defstruct-expand-ref-macro)
+	  (defstruct-putprop mname (cons name (caar l)) 'defstruct-slot))
+	(let ((type-description
+		(get (defstruct-description-type)
+		     'defstruct-type-description)))
+	  (let ((code (defstruct-type-description-ref-expander))
+		(n (defstruct-type-description-ref-no-args))
+	     #+LispM
+		(parent `(,name defstruct))
+		(but-first (defstruct-description-but-first))
+		(default-pointer (defstruct-description-default-pointer)))
+	    (do ((args nil (cons (gensym) args))
+		 (i n (1- i)))
+		((< i 2)
+		 ;;Last arg (if it exists) is name of structure,
+		 ;; for documentation purposes.
+		 (and (= i 1)
+		      (setq args (cons name args)))
+		 (let ((body (cons (if but-first
+				       `(,but-first ,(car args))
+				       (car args))
+				   (cdr args))))
+		   (and default-pointer
+			(setq args `((,(car args) ,default-pointer)
+				     &optional ,@(cdr args))))
+		   (setq args (reverse args))
+		   (setq body (reverse body))
+		   (do ((l new-slots (cdr l))
+			(mname)
+			(returns nil))
+		       ((null l)
+			(feature-case
+			 (LispM
+			  ;;On the LispMachine defsubsts get compiled so we
+			  ;;need this special declaration (ignoring the kludgey
+			  ;;fix in system 86).  What is NIL's solution anyway?
+			  (if default-pointer
+			      `((local-declare ((special ,default-pointer))
+					       ,.returns))
+			      returns))
+			 (t returns)))
+		     (setq mname (defstruct-slot-description-ref-macro-name
+				   (cdar l)))
+		     ;;This must come BEFORE the defun. THINK!
+		     (feature-case
+		      (MacLisp 
+		       (defstruct-put-macro mname 'defstruct-expand-ref-macro))
+		      (t))
+		     (let ((ref (lexpr-funcall
+				  code
+				  (defstruct-slot-description-number (cdar l))
+				  description
+				  body))
+			   (ppss (defstruct-slot-description-ppss (cdar l))))
+		       (or (null ppss)
+			   (setq ref `(,(if (defstruct-description-logldbp)
+					    `%logldb
+					    `ldb)
+				       ,ppss
+				       ,ref)))
+		       (push (feature-case
+			      (LispM `(defsubst-with-parent ,mname ,parent ,args ,ref))
+			      (NIL `(defsubst ,mname ,args ,ref))
+			      (t `(defun ,mname ,args ,ref)))
+			     returns))
+		     (defstruct-putprop mname
+					(cons name (caar l))
+					'defstruct-slot))))))))))
+
+(feature-case (LispM
+
+(defprop defstruct-expand-cons-macro
+	 defstruct-function-parent
+	 macroexpander-function-parent)
+
+(defprop defstruct-expand-size-macro
+	 defstruct-function-parent
+	 macroexpander-function-parent)
+
+(defprop defstruct-expand-alter-macro
+	 defstruct-function-parent
+	 macroexpander-function-parent)
+
+(defprop defstruct-expand-ref-macro 
+	 defstruct-function-parent
+	 macroexpander-function-parent)
+
+(defun defstruct-function-parent (sym)
+  (values (or (get sym 'defstruct-name)
+	      (car (get sym 'defstruct-slot)))
+	  'defstruct))
+
+) (t)) ;end (feature-case (LispM ...))
+
+(defun defstruct-expand-size-macro (x)
+  (let ((description (get-defstruct-description (get (car x) 'defstruct-name))))
+    (let ((type-description (or (get (defstruct-description-type)
+				     'defstruct-type-description)
+				(defstruct-error
+				  "Unknown defstruct type"
+				  (defstruct-description-type)))))
+      (+ (defstruct-description-size)
+	 (defstruct-type-description-overhead)))))
+
+(defun defstruct-expand-ref-macro (x)
+  (let* ((pair (get (car x) 'defstruct-slot))
+	 (description (get-defstruct-description (car pair)))
+	 (type-description (or (get (defstruct-description-type)
+				    'defstruct-type-description)
+			       (defstruct-error
+				 "Unknown defstruct type"
+				 (defstruct-description-type))))
+	 (code (defstruct-type-description-ref-expander))
+	 (n (defstruct-type-description-ref-no-args))
+	 (args (reverse (cdr x)))
+	 (nargs (length args))
+	 (default (defstruct-description-default-pointer))
+	 (but-first (defstruct-description-but-first)))
+    (cond ((= n nargs)
+	   (and but-first
+		(rplaca args `(,but-first ,(car args)))))
+	  ((and (= n (1+ nargs)) default)
+	   (setq args (cons (if but-first
+				`(,but-first ,default)
+				default)
+			    args)))
+	  (t
+	   (defstruct-error
+	     "Wrong number of args to an accessor macro" x)))
+    (let* ((slot-description 
+	     (cdr (or (assq (cdr pair)
+			    (defstruct-description-slot-alist))
+		      (defstruct-error
+			"This slot no longer exists in this structure"
+			(cdr pair) 'in (car pair)))))
+	    (ref (lexpr-funcall
+		   code
+		   (defstruct-slot-description-number)
+		   description
+		   (nreverse args)))
+	    (ppss (defstruct-slot-description-ppss)))
+      (if (null ppss)
+	  ref
+	  `(,(if (defstruct-description-logldbp)
+		 `%logldb
+		 `ldb)
+	    ,ppss
+	    ,ref)))))
+
+(defun defstruct-parse-setq-style-slots (l slots others x logldbp)
+  (do ((l l (cddr l))
+       (kludge (cons nil nil)))
+      ((null l) kludge)
+    (or (and (cdr l)
+	     (symbolp (car l)))
+	(defstruct-error
+	  "Bad argument list to constructor or alterant macro" x))
+    (defstruct-make-init-dsc kludge (car l) (cadr l) slots others x logldbp)))
+
+(defun defstruct-make-init-dsc (kludge name code slots others x logldbp)
+  (let ((p (assq name slots)))
+    (if (null p)
+	(if (memq name others)
+	    (push (cons name code) (cdr kludge))
+	    (let ((new (defstruct-retry-keyword name)))
+	      (if (memq new others)
+		  (push (cons new code) (cdr kludge))
+		  (defstruct-error
+		    "Unknown slot to constructor or alterant macro"
+		    name 'in x))))
+	(let* ((slot-description (cdr p))
+	       (number (defstruct-slot-description-number))
+	       (ppss (defstruct-slot-description-ppss))
+	       (dsc (assoc number (car kludge))))
+	  (cond ((null dsc)
+		 (setq dsc (list* number nil (make-empty) 0 0 nil))
+		 (push dsc (car kludge))))
+	  (cond ((null ppss)
+		 (setf (car (cddr dsc)) code)
+		 (setf (cadr dsc) t))
+		(t (cond ((not (and (numberp ppss) (numberp code)))
+			  (push (cons ppss code) (cdddr (cddr dsc))))
+			 (logldbp
+			  (setf (%logldb ppss (cadr (cddr dsc))) -1)
+			  (setf (%logldb ppss (caddr (cddr dsc))) code))
+			 (t
+			  (setf (ldb ppss (cadr (cddr dsc))) -1)
+			  (setf (ldb ppss (caddr (cddr dsc))) code)))
+		   (or (eq t (cadr dsc))
+		       (push name (cadr dsc)))))))))
+
+(defun defstruct-code-from-dsc (dsc logldbp)
+  (let ((code (car (cddr dsc)))
+	(mask (cadr (cddr dsc)))
+	(bits (caddr (cddr dsc))))
+    (if (emptyp code)
+	(setq code bits)
+	(or (zerop mask)
+	    (setq code (if (numberp code)
+			   (boole 7 bits (boole 2 mask code))
+			   (if (zerop (logand mask
+					      (1+ (logior mask (1- mask)))))
+			       (let ((ss (haulong (boole 2 mask (1- mask)))))
+				 `(,(if logldbp `%logdpb `dpb)
+				   ,(lsh bits (- ss))
+				   ,(logior (lsh ss 6)
+					    (logand #o77
+						    (- (haulong mask) ss)))
+				   ,code))
+			       `(boole 7 ,bits (boole 2 ,mask ,code)))))))
+    (do ((l (cdddr (cddr dsc)) (cdr l)))
+	((null l))
+      (setq code `(,(if logldbp `%logdpb `dpb) ,(cdar l) ,(caar l) ,code)))
+    code))
+
+(defun defstruct-expand-cons-macro (x)
+  (let* ((description (get-defstruct-description (get (car x) 'defstruct-name)))
+	 (type-description (or (get (defstruct-description-type)
+				    'defstruct-type-description)
+			       (defstruct-error
+				 "Unknown defstruct type"
+				 (defstruct-description-type))))
+	 (slot-alist (defstruct-description-slot-alist))
+	 (cons-keywords (defstruct-type-description-cons-keywords))
+	 (kludge nil)
+	 (constructor-description 
+	   (cdr (or (assq (car x) (defstruct-description-constructors))
+		    (defstruct-error
+		      "This constructor is no longer defined for this structure"
+		      (car x) 'in (defstruct-description-name)))))
+	 (aux nil)
+	 (aux-init nil)
+	 (logldbp (defstruct-description-logldbp)))
+     (if (null constructor-description)
+	 (setq kludge (defstruct-parse-setq-style-slots (cdr x)
+							slot-alist
+							cons-keywords
+							x
+							logldbp))
+	 (prog (args l)
+	       (setq kludge (cons nil nil))
+	       (setq args (cdr x))
+	       (setq l (car constructor-description))
+	     R (cond ((null l)
+		      (if (null args)
+			  (return nil)
+			  (go barf-tma)))
+		     ((atom l) (go barf))
+		     ((eq (car l) '&optional) (go O))
+		     ((eq (car l) '&rest) (go S))
+		     ((eq (car l) '&aux) (go A))
+		     ((null args) (go barf-tfa)))
+	       (defstruct-make-init-dsc kludge
+					(pop l)
+					(pop args)
+					slot-alist
+					cons-keywords
+					x
+					logldbp)
+	       (go R)
+	     O (and (null args) (go OD))
+	       (pop l)
+	       (cond ((null l) (go barf-tma))
+		     ((atom l) (go barf))
+		     ((eq (car l) '&optional) (go barf))
+		     ((eq (car l) '&rest) (go S))
+		     ((eq (car l) '&aux) (go barf-tma)))
+	       (defstruct-make-init-dsc kludge
+					(if (atom (car l)) (car l) (caar l))
+					(pop args)
+					slot-alist
+					cons-keywords
+					x
+					logldbp)
+	       (go O)
+	    OD (pop l)
+	       (cond ((null l) (return nil))
+		     ((atom l) (go barf))
+		     ((eq (car l) '&optional) (go barf))
+		     ((eq (car l) '&rest) (go S))
+		     ((eq (car l) '&aux) (go A)))
+	       (or (atom (car l))
+		   (defstruct-make-init-dsc kludge
+					    (caar l)
+					    (cadar l)
+					    slot-alist
+					    cons-keywords
+					    x
+					    logldbp))
+	       (go OD)
+	     S (and (atom (cdr l)) (go barf))
+	       (defstruct-make-init-dsc kludge
+					(cadr l)
+					`(list ,@args)
+					slot-alist
+					cons-keywords
+					x
+					logldbp)
+	       (setq l (cddr l))
+	       (and (null l) (return nil))
+	       (and (atom l) (go barf))
+	       (or (eq (car l) '&aux) (go barf))
+	     A (pop l)
+	       (cond ((null l) (return nil))
+		     ((atom l) (go barf))
+		     ((atom (car l))
+		      (push (car l) aux)
+		      (push (make-empty) aux-init))
+		     (t
+		      (push (caar l) aux)
+		      (push (cadar l) aux-init)))
+	       (go A)
+	  barf (defstruct-error
+		 "Bad format for defstruct constructor arglist"
+		 `(,(car x) ,@(car constructor-description)))
+      barf-tfa (defstruct-error "Too few arguments to constructor macro" x)
+      barf-tma (defstruct-error "Too many arguments to constructor macro" x)))
+     (do ((l slot-alist (cdr l)))
+	 ((null l))
+       (let* ((name (caar l))
+	      (slot-description (cdar l))
+	      (code (do ((aux aux (cdr aux))
+			 (aux-init aux-init (cdr aux-init)))
+			((null aux) (defstruct-slot-description-init-code))
+		      (and (eq name (car aux)) (return (car aux-init)))))
+	      (ppss (defstruct-slot-description-ppss)))
+	 (or (and (emptyp code) (null ppss))
+	     (let* ((number (defstruct-slot-description-number))
+		    (dsc (assoc number (car kludge))))
+	       (cond ((null dsc)
+		      (setq dsc (list* number nil (make-empty) 0 0 nil))
+		      (push dsc (car kludge))))
+	       (cond ((emptyp code))
+		     ((eq t (cadr dsc)))
+		     ((null ppss)
+		      (and (emptyp (car (cddr dsc)))
+			   (setf (car (cddr dsc)) code)))
+		     ((memq name (cadr dsc)))
+		     ((not (and (numberp ppss) (numberp code)))
+		      (push (cons ppss code) (cdddr (cddr dsc))))
+		     (logldbp
+		      (setf (%logldb ppss (cadr (cddr dsc))) -1)
+		      (setf (%logldb ppss (caddr (cddr dsc))) code))
+		     (t
+		      (setf (ldb ppss (cadr (cddr dsc))) -1)
+		      (setf (ldb ppss (caddr (cddr dsc))) code)))))))
+     (do ((l (car kludge) (cdr l)))
+	 ((null l))
+       (rplacd (car l) (defstruct-code-from-dsc (car l) logldbp)))
+     (invoke-defstruct-constructor-expander
+       description type-description
+       (car kludge) (cdr kludge))))
+
+(defun invoke-defstruct-constructor-expander (description type-description arg etc)
+  (funcall (defstruct-type-description-cons-expander)
+	   (selectq (defstruct-type-description-cons-flavor)
+	     (:list
+	      (do ((l nil (cons nil l))
+		   (i (defstruct-description-size) (1- i)))
+		  ((= i 0)
+		   (do ((arg arg (cdr arg)))
+		       ((null arg))
+		     (setf (nth (caar arg) l) (cdar arg)))
+		   l)))
+	     (:alist arg)
+	     (t
+	      (defstruct-error
+		"Unknown constructor kind in this defstruct type"
+		(defstruct-description-type))))
+	   description etc))
+
+(defun defstruct-expand-alter-macro (x)
+  (let* ((description (get-defstruct-description (get (car x) 'defstruct-name)))
+	 (type-description (or (get (defstruct-description-type)
+				    'defstruct-type-description)
+			       (defstruct-error
+				 "Unknown defstruct type"
+				 (defstruct-description-type))))
+	 (ref-code (defstruct-type-description-ref-expander))
+	 (ref-nargs (defstruct-type-description-ref-no-args))
+	 (logldbp (defstruct-description-logldbp)))
+    (do ((l (car (defstruct-parse-setq-style-slots 
+		   (nthcdr (1+ ref-nargs) x)
+		   (defstruct-description-slot-alist)
+		   nil
+		   x
+		   logldbp))
+	    (cdr l))
+	 (but-first (defstruct-description-but-first))
+	 (body nil)
+	 (avars (do ((i 0 (1+ i))
+		     (l nil (cons (gensym) l)))
+		    ((= i ref-nargs) l)))
+	 (vars nil)
+	 (vals nil))
+	((null l)
+	 `((lambda ,avars
+	     ,@(if (null vars)
+		   body
+		   `(((lambda ,vars ,@body) ,.vals))))
+	   ,@(do ((i (1- ref-nargs) (1- i))
+		  (l `(,(if but-first
+			    `(,but-first ,(nth ref-nargs x))
+			    (nth ref-nargs x)))
+		     (cons (nth i x) l)))
+		 ((= i 0) l))))
+      (let ((ref (lexpr-funcall ref-code (caar l) description avars)))
+	(and (emptyp (car (cddr (car l))))
+	     (setf (car (cddr (car l))) ref))
+	(let ((code (defstruct-code-from-dsc (car l) logldbp)))
+	  (if (null (cdr l))
+	      (push `(setf ,ref ,code) body)
+	      (let ((sym (gensym)))
+		(push `(setf ,ref ,sym) body)
+		(push sym vars)
+		(push code vals))))))))
+
+(defmacro defstruct-define-type (type &body options)
+  (do ((options options (cdr options))
+       (op) (args)
+       (type-description (make-defstruct-type-description))
+       (cons-expander nil)
+       (ref-expander nil)
+       (returns `(',type)))
+      ((null options)
+       (or cons-expander
+	   (defstruct-error "No cons option in defstruct-define-type" type))
+       (or ref-expander
+	   (defstruct-error "No ref option in defstruct-define-type" type))
+       `(eval-when (eval load compile)
+	  ,cons-expander
+	  ,ref-expander
+	  (defprop ,type ,type-description defstruct-type-description)
+	  ,@returns))
+    (cond ((atom (setq op (car options)))
+	   (setq args nil))
+	  (t
+	   (setq args (cdr op))
+	   (setq op (car op))))
+ AGAIN
+    (selectq op
+      (:cons
+        (or (> (length args) 2)
+	    (defstruct-error
+	      "Bad cons option in defstruct-define-type"
+	      (car options) 'in type))
+	(let ((n (length (car args)))
+	      (name (append-symbols type '-defstruct-cons)))
+	  (or (= n 3)
+	      (defstruct-error
+		"Bad cons option in defstruct-define-type"
+		(car options) 'in type))
+	  (setf (defstruct-type-description-cons-flavor)
+		(defstruct-retry-keyword (cadr args)))
+	  (setf (defstruct-type-description-cons-expander) name)
+	  (setq cons-expander `(defun ,name ,(car args)
+				 ,@(cddr args)))))
+      (:ref
+        (or (> (length args) 1)
+	    (defstruct-error
+	      "Bad ref option in defstruct-define-type"
+	      (car options) 'in type))
+	(let ((n (length (car args)))
+	      (name (append-symbols type '-defstruct-ref)))
+	  (or (> n 2)
+	      (defstruct-error
+		"Bad ref option in defstruct-define-type"
+		(car options) 'in type))
+	  (setf (defstruct-type-description-ref-no-args) (- n 2))
+	  (setf (defstruct-type-description-ref-expander) name)
+	  (setq ref-expander `(defun ,name ,(car args)
+				,@(cdr args)))))
+      (:implementations
+        (if (do ((l args (cdr l))
+		 (features (status features)))
+		((null l) t)
+	      (if (memq (car args) features)
+		  (return nil)))
+	    (return nil)))
+      (:named
+        (setf (defstruct-type-description-named-type)
+	      (if (null args)
+		  type
+		  (car args))))
+      (:predicate
+        (or (> (length args) 1)
+	    (defstruct-error
+	      "Bad predicate option in defstruct-define-type"
+	      (car options) 'in type))
+        (let ((name (append-symbols type '-defstruct-predicate)))
+	  (setf (defstruct-type-description-predicate) name)
+	  (push `(defun ,name ,(car args)
+		   ,@(cdr args))
+		returns)))
+      (:overhead
+        (setf (defstruct-type-description-overhead)
+	      (if (null args)
+		  (defstruct-error
+		    "Bad option to defstruct-define-type"
+		    (car options) 'in type)
+		  (car args))))
+      (:keywords
+        (setf (defstruct-type-description-cons-keywords) args))
+      (:defstruct-options
+        (do ((l args (cdr l)))
+	    ((null l))
+	  (push `(defprop ,(car l) t :defstruct-option) returns)))
+      (:defstruct
+        (or (> (length args) 1)
+	    (defstruct-error
+	      "Bad defstruct option in defstruct-define-type"
+	      (car options) 'in type))
+	(let ((name (append-symbols type '-defstruct-expand)))
+	  (setf (defstruct-type-description-defstruct-expander) name)
+	  (push `(defun ,name ,@args) returns)))
+      (:copier
+        (or (> (length args) 1)
+	    (defstruct-error
+	      "Bad copier option in defstruct-define-type"
+	      (car options) 'in type))
+        (let ((name (append-symbols type '-defstruct-copier)))
+	  (setf (defstruct-type-description-copier) name)
+	  (push `(defun ,name ,(car args)
+		   ,@(cdr args))
+		returns)))
+      (t
+       (let ((new (defstruct-retry-keyword op)))
+	 (cond ((not (eq op new))
+		(setq op new)
+		(go AGAIN)))
+	 (defstruct-error
+	   "Unknown option to defstruct-define-type"
+	   op 'in type))))))
+
+(defstruct-define-type :array
+  (:implementations LispM)
+  (:defstruct-options :make-array)
+  (:named :named-array)
+  (:keywords :make-array)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
+			       description etc nil nil nil 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,n)))
+
+(defstruct-define-type :array
+  (:implementations MacLisp)
+  (:cons (arg description etc) :alist
+    etc
+    (maclisp-array-for-defstruct arg description 't))
+  (:ref (n description arg)
+    description		;ignored
+    `(arraycall t ,arg ,n)))
+
+(defstruct-define-type :array
+  (:implementations NIL)
+  (:defstruct-options :make-array)
+  (:cons (arg description etc) :alist
+    etc
+    (NIL-array-for-defstruct arg description))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,n)))
+
+(defstruct-define-type :named-array
+  (:implementations LispM)
+  (:defstruct-options :make-array)
+  (:keywords :make-array)
+  :named (:overhead 1)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,(1+ i)))
+			       description etc nil t nil 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,(1+ n)))
+  (:predicate (description name)
+    `(defsubst ,name (x)
+       (typep x ',(defstruct-description-name)))))
+
+(defstruct-define-type :fixnum-array
+  (:implementations LispM)
+  (:defstruct-options :make-array)
+  (:keywords :make-array)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
+			       description etc 'art-32b nil nil 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,n)))
+
+(defstruct-define-type :fixnum-array
+  (:implementations MacLisp)
+  (:cons (arg description etc) :alist
+    etc
+    (maclisp-array-for-defstruct arg description 'fixnum))
+  (:ref (n description arg)
+    description		;ignored
+    `(arraycall fixnum ,arg ,n)))
+
+(defstruct-define-type :flonum-array
+  (:implementations LispM)
+  (:defstruct-options :make-array)
+  (:keywords :make-array)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i))
+			       description etc 'art-float nil nil 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(aref ,arg ,n)))
+
+(defstruct-define-type :flonum-array
+  (:implementations MacLisp)
+  (:cons (arg description etc) :alist
+    etc
+    (maclisp-array-for-defstruct arg description 'flonum))
+  (:ref (n description arg)
+    description		;ignored
+    `(arraycall flonum ,arg ,n)))
+
+(defstruct-define-type :un-gc-array
+  (:implementations MacLisp-10)
+  (:cons (arg description etc) :alist
+    etc			;ignored
+    (maclisp-array-for-defstruct arg description nil))
+  (:ref (n description arg)
+    description		;ignored
+    `(arraycall nil ,arg ,n)))
+
+(defstruct-define-type :array-leader
+  (:implementations LispM)
+  (:defstruct-options :make-array)
+  (:named :named-array-leader)
+  (:keywords :make-array)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct arg #'(lambda (v a i)
+				       `(store-array-leader ,v ,a ,i))
+			       description etc nil nil t 1))
+  (:ref (n description arg)
+    description		;ignored
+    `(array-leader ,arg ,n)))
+
+(defstruct-define-type :named-array-leader
+  (:implementations LispM)
+  (:defstruct-options :make-array)
+  (:keywords :make-array)
+  :named (:overhead 1)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct
+      arg
+      #'(lambda (v a i)
+	  `(store-array-leader ,v ,a ,(if (zerop i)
+					  0
+					  (1+ i))))
+      description etc nil t t 1))
+  (:ref (n description arg)
+    description		;ignored
+    (if (zerop n)
+	`(array-leader ,arg 0)
+	`(array-leader ,arg ,(1+ n))))
+  (:predicate (description name)
+    `(defsubst ,name (x)
+       (typep x ',(defstruct-description-name)))))
+
+(defstruct-define-type :grouped-array
+  (:implementations LispM)
+  (:defstruct-options :times)
+  (:keywords :make-array :times)
+  (:cons (arg description etc) :alist
+    (lispm-array-for-defstruct
+      arg
+      #'(lambda (v a i) `(aset ,v ,a ,i))
+      description etc nil nil nil
+      (or (cdr (or (assq ':times etc)
+		   (assq ':times (defstruct-description-property-alist))))
+	  1)))
+  (:ref (n description index arg)
+    description		;ignored
+    (cond ((numberp index)
+	   `(aref ,arg ,(+ n index)))
+	  ((zerop n)
+	   `(aref ,arg ,index))
+	  (t `(aref ,arg (+ ,n ,index))))))
+
+(feature-case (LispM
+
+(defun lispm-array-for-defstruct (arg cons-init description etc type named-p leader-p times)
+  (let ((p (cons nil nil))
+	(no-op nil))
+    (defstruct-grok-make-array-args
+      (cdr (assq ':make-array (defstruct-description-property-alist)))
+      p)
+    (defstruct-grok-make-array-args
+      (cdr (assq ':make-array etc))
+      p)
+    (and type (putprop p type ':type))
+    (and named-p (putprop p `',(defstruct-description-name) ':named-structure-symbol))
+    (putprop p
+	     (let ((size (if named-p
+			     (1+ (defstruct-description-size))
+			     (defstruct-description-size))))
+	       (if (numberp times)
+		   (* size times)
+		   `(* ,size ,times)))	     
+	     (if leader-p ':leader-length ':dimensions))
+    (or leader-p
+	(if (get p ':initial-value)
+	    (setq no-op (make-empty))
+	    (let ((type (get p ':type)))
+	      (or (atom type)
+		  (not (eq (car type) 'quote))
+		  (setq type (cadr type)))
+	      (caseq type
+		((nil art-q art-q-list))
+		((art-32b art-16b art-8b art-4b art-2b art-1b art-string)
+		 (setq no-op 0))
+		((art-float) (setq no-op 0.0))
+		(t (setq no-op (make-empty)))))))
+    (do ((creator
+	   (let ((dims (remprop p ':dimensions)))
+	     (do ((l (cdr p) (cddr l)))
+		 ((null l))
+	       (rplaca l `',(car l)))
+	     `(make-array ,(if (null dims) 0 (car dims)) ,@(cdr p))))
+	 (var (gensym))
+	 (set-ups nil (if (equal (cdar l) no-op)
+			  set-ups
+			  (cons (funcall cons-init (cdar l) var (caar l))
+				set-ups)))
+	 (l arg (cdr l)))
+	((null l)
+	 (if set-ups
+	     `((lambda (,var)
+		 ,@(nreverse set-ups)
+		 ,var)
+	       ,creator)
+	     creator)))))
+
+(defun defstruct-grok-make-array-args (args p)
+  (do ((l args (cddr l)))
+      ((null l) p)
+    (if (or (null (cdr l))
+	    (not (memq (car l) '(:area :type :displaced-to :leader-list
+				 :leader-length :displaced-index-offset
+				 :named-structure-symbol :dimensions
+				 :length :initial-value))))
+	(defstruct-error
+	  "defstruct can't grok these make-array arguments"
+	  args))
+    (putprop p
+	     (cadr l)
+	     (if (eq (car l) ':length)
+		 ':dimensions
+		 (car l)))))
+
+) (t)) ;end (feature-case (LispM ...))
+
+(feature-case (NIL
+(defun NIL-array-for-defstruct (arg description)
+  (do ((creator `(make-array ',(defstruct-description-size)))
+       (var (gensym))
+       (set-ups nil (if (null (cdar l))
+			set-ups
+			(cons `(aset ,(cdar l) ,var ,(caar l))
+			      set-ups)))
+       (l arg (cdr l)))
+      ((null l)
+       (if set-ups
+	   `((lambda (,var)
+	       ,@(nreverse set-ups)
+	       ,var)
+	     ,creator)
+	   creator))))
+) (t))
+
+(feature-case (MacLisp
+(defun maclisp-array-for-defstruct (arg description type)
+  (do ((creator `(array nil ,type ,(defstruct-description-size)))
+       (var (gensym))
+       (no-op (caseq type
+		(fixnum 0)
+		(flonum 0.0)
+		((t nil) nil)))
+       (set-ups nil (if (equal (cdar l) no-op)
+			set-ups
+			(cons `(store (arraycall ,type ,var ,(caar l))
+				      ,(cdar l))
+			      set-ups)))
+       (l arg (cdr l)))
+      ((null l)
+       (if set-ups
+	   `((lambda (,var)
+	       ,@(nreverse set-ups)
+	       ,var)
+	     ,creator)
+	   creator))))
+) (t))
+
+(defstruct-define-type :sfa
+  (:implementations MacLisp-10 NIL)
+  (:defstruct-options :sfa-name :sfa-function)
+  (:keywords :sfa-function :sfa-name)
+  (:cons (arg description etc) :alist
+    (do ((creator `(sfa-create ,(or (cdr (or (assq ':sfa-function etc)
+					     (assq ':sfa-function (defstruct-description-property-alist))))
+				     `',(defstruct-description-name))
+			       ,(defstruct-description-size)
+			       ,(or (cdr (or (assq ':sfa-name etc)
+					     (assq ':sfa-name (defstruct-description-property-alist))))
+				    `',(defstruct-description-name))))
+	 (l arg (cdr l))
+	 (var (gensym))
+	 (set-ups nil (if (null (cdar l))
+			  set-ups
+			  (cons `(sfa-store ,var ,(caar l)
+					    ,(cdar l))
+				set-ups))))
+	((null l)
+	 (if set-ups
+	     `((lambda (,var)
+		 ,@(nreverse set-ups)
+		 ,var)
+	       ,creator)
+	     creator))))
+  (:ref (n description arg)
+    description		;ignored
+    `(sfa-get ,arg ,n))
+  (:predicate (description name)
+    `(defun ,name (x)
+       (and (sfap x)
+	    (eq (sfa-get x 'pname)
+		,(or (cdr (assq ':sfa-name (defstruct-description-property-alist)))
+		     `',(defstruct-description-name)))))))
+
+(defstruct-define-type :hunk
+  (:implementations MacLisp-10)
+  (:named :named-hunk)
+  (:cons (arg description etc) :list
+    description		;ignored
+    etc			;ignored
+    (if arg
+	`(hunk ,.(nconc (cdr arg) (ncons (car arg))))
+	(defstruct-error "No slots in hunk type defstruct")))
+  (:ref (n description arg)
+    description		;ignored
+    `(cxr ,n ,arg)))
+
+(defstruct-define-type :named-hunk
+  (:implementations MacLisp-10)
+  :named (:overhead 1)
+  (:cons (arg description etc) :list
+    etc			;ignored
+    (if arg
+	`(hunk ',(defstruct-description-name)
+	       ,.(nconc (cdr arg) (ncons (car arg))))
+	`(hunk ',(defstruct-description-name) nil)))
+  (:ref (n description arg)
+    description		;ignored
+    (cond ((= n 0) `(cxr 0 ,arg))
+	  (t `(cxr ,(1+ n) ,arg))))
+  (:predicate (description name)
+    `(defun ,name (x)
+       (and (hunkp x)
+	    (eq (car x) ',(defstruct-description-name))))))
+
+(defstruct-define-type :vector
+  (:implementations MacLisp-10 NIL)
+  (:named :named-vector)
+  (:cons (arg description etc) :list
+    description		;ignored
+    etc			;ignored
+    `(vector ,@arg))
+  (:ref (n description arg)
+    description		;ignored
+    `(vref ,arg ,n)))
+
+(defstruct-define-type :named-vector
+  (:implementations MacLisp-10 NIL)
+  :named (:overhead 1)
+  (:cons (arg description etc) :list
+    etc			;ignored
+    `(vector ',(defstruct-description-name) ,@arg))
+  (:ref (n description arg)
+    description		;ignored
+    `(vref ,arg ,(1+ n)))
+  (:predicate (description name)
+    `(defun ,name (x)
+       (and (vectorp x)
+	    (eq (vref x 0) ',(defstruct-description-name))))))
+
+(defstruct-define-type :extend
+  (:implementations NIL)
+  (:defstruct-options :class-symbol)
+  :named
+  (:defstruct (description)
+    (if (assq ':class-symbol (defstruct-description-property-alist))
+	;; if class-symbol is given then assume user is setting up
+	;; his own class.
+	()
+	(let* ((name (defstruct-description-name))
+	       (class-symbol (append-symbols name '-class)))
+	  (push (cons ':class-symbol class-symbol)
+		(defstruct-description-property-alist))
+	  `((defstruct-class-setup ,name ,class-symbol)))))
+  (:cons (arg description etc) :alist
+    etc			;ignored
+    (do ((l arg (cdr l))
+	 (creator `(si:make-extend
+		    ,(defstruct-description-size)
+		    ,(cdr (assq ':class-symbol
+				(defstruct-description-property-alist)))))
+	 (var (gensym))
+	 (set-ups () (if (null (cdar l))
+			 set-ups
+			 (cons `(si:xset ,var ,(caar l) ,(cdar l))
+			       set-ups))))
+	((null l)
+	 (if set-ups
+	     `((lambda (,var)
+		 ,.(nreverse set-ups)
+		 ,var)
+	       ,creator)
+	     creator))))
+  (:ref (n description arg)
+    description		;ignored
+    `(si:xref ,arg ,n))
+  (:predicate (description name)
+    `(defsubst ,name (x)
+       (of-type x ',(defstruct-description-name)))))
+
+(defstruct-define-type :list
+  (:named :named-list)
+  (:cons (arg description etc) :list
+    description		;ignored
+    etc			;ignored
+    `(list ,.arg))
+  (:ref (n description arg)
+    description		;ignored
+    (feature-case
+     (Multics
+      `(,(let ((i (\ n 4)))
+	   (cond ((= i 0) 'car)
+		 ((= i 1) 'cadr)
+		 ((= i 2) 'caddr)
+		 (t 'cadddr)))
+	,(do ((a arg `(cddddr ,a))
+	      (i (// n 4) (1- i)))
+	     ((= i 0) a))))
+     (t `(nth ,n ,arg))))
+  (:copier (description name)
+    (do ((l `((car x)) (cons `(prog1 (car x) (setq x (cdr x))) l))
+	 (i (defstruct-description-size) (1- i)))
+	((<= i 1)
+	 `(defun ,name (x)
+	    (list ,@l))))))
+
+(defstruct-define-type :named-list
+  :named (:overhead 1)
+  (:cons (arg description etc) :list
+    etc			;ignored
+    `(list ',(defstruct-description-name) ,.arg))
+  (:ref (n description arg)
+    description		;ignored
+    (feature-case
+     (Multics
+      `(,(let ((i (\ (1+ n) 4)))
+	   (cond ((= i 0) 'car)
+		 ((= i 1) 'cadr)
+		 ((= i 2) 'caddr)
+		 (t 'cadddr)))
+	,(do ((a arg `(cddddr ,a))
+	      (i (// (1+ n) 4) (1- i)))
+	     ((= i 0) a))))
+     (t `(nth ,(1+ n) ,arg))))
+  (:predicate (description name)
+    (feature-case
+     (MacLisp-10	;Watch out for hunks!
+      `(defun ,name (x)
+	 (and (eq (typep x) 'list)
+	 (eq (car x) ',(defstruct-description-name)))))
+     (t
+      `(defun ,name (x)
+	 (and (not (atom x))
+	      (eq (car x) ',(defstruct-description-name)))))))
+  (:copier (description name)
+    (do ((l `((car x)) (cons `(prog1 (car x) (setq x (cdr x))) l))
+	 (i (defstruct-description-size) (1- i)))
+	((<= i 1)
+	 `(defun ,name (x)
+	    (setq x (cdr x))
+	    (list ',(defstruct-description-name) ,@l))))))
+
+(defstruct-define-type :list*
+  (:cons (arg description etc) :list
+    description		;ignored
+    etc			;ignored
+    `(list* ,.arg))
+  (:ref (n description arg)
+    (let ((size (1- (defstruct-description-size))))
+      (feature-case
+       (Multics
+	(do ((a arg `(cddddr ,a))
+	     (i (// n 4) (1- i)))
+	    ((= i 0)
+	     (let* ((i (\ n 4))
+		    (a (cond ((= i 0) a)
+			     ((= i 1) `(cdr ,a))
+			     ((= i 2) `(cddr ,a))
+			     (t `(cdddr ,a)))))
+	       (if (< n size) `(car ,a) a)))))
+       (t
+	(if (< n size)
+	    `(nth ,n ,arg)
+	    `(nthcdr ,n ,arg))))))
+  (:defstruct (description)
+    (and (defstruct-description-include)
+	 (defstruct-error
+	   "Structure of type list* cannot include another"
+	   (defstruct-description-name)))
+    nil)
+  (:copier (description name)
+    (do ((l `(x) (cons `(prog1 (car x) (setq x (cdr x))) l))
+	 (i (defstruct-description-size) (1- i)))
+	((<= i 1)
+	 `(defun ,name (x)
+	    (list* ,@l))))))
+
+(defstruct-define-type :tree
+  (:cons (arg description etc) :list
+    etc			;ignored
+    (if (null arg) (defstruct-error
+		     "defstruct cannot make an empty tree"
+		     (defstruct-description-name)))
+    (make-tree-for-defstruct arg (defstruct-description-size)))
+  (:ref (n description arg)
+    (do ((size (defstruct-description-size))
+	 (a arg)
+	 (tem))
+	(nil)
+      (cond ((= size 1) (return a))
+	    ((< n (setq tem (// size 2)))
+	     (setq a `(car ,a))
+	     (setq size tem))
+	    (t (setq a `(cdr ,a))
+	       (setq size (- size tem))
+	       (setq n (- n tem))))))
+  (:defstruct (description)
+    (and (defstruct-description-include)
+	 (defstruct-error
+	   "Structure of type tree cannot include another"
+	   (defstruct-description-name)))
+    nil)
+  (:copier (description name)
+    `(defun ,name (x)
+       ,(copy-tree-for-defstruct nil (defstruct-description-size)))))
+
+(defun make-tree-for-defstruct (arg size)
+  (cond ((= size 1) (car arg))
+	((= size 2) `(cons ,(car arg) ,(cadr arg)))
+	(t (do ((a (cdr arg) (cdr a))
+		(m (// size 2))
+		(n (1- (// size 2)) (1- n)))
+	       ((zerop n)
+		`(cons ,(make-tree-for-defstruct arg m)
+		       ,(make-tree-for-defstruct a (- size m))))))))
+
+(defun copy-tree-for-defstruct (popx? size)
+  (cond ((= size 1)
+	 (if popx?
+	     `(prog1 (car x) (setq x (cdr x)))
+	     `x))
+	((= size 2)
+	 (if popx?
+	     `((lambda (x) (cons (car x) (cdr x)))
+	       (prog1 (car x) (setq x (cdr x))))
+	     `(cons (car x) (cdr x))))
+	(popx?
+	 `((lambda (x)
+	     (cons ,(copy-tree-for-defstruct t (// size 2))
+		   ,(copy-tree-for-defstruct nil (- size (// size 2)))))
+	   (prog1 (car x) (setq x (cdr x)))))
+	(t
+	 `(cons ,(copy-tree-for-defstruct t (// size 2))
+		,(copy-tree-for-defstruct nil (- size (// size 2)))))))
+
+(defstruct-define-type :fixnum
+  (:cons (arg description etc) :list
+    etc			;ignored
+    (and (or (null arg)
+	     (not (null (cdr arg))))
+	 (defstruct-error
+	   "Structure of type fixnum must have exactly 1 slot to be constructable"
+	   (defstruct-description-name)))
+    (car arg))
+  (:ref (n description arg)
+    n			;ignored
+    description		;ignored
+    arg))
+
+(defstruct-define-type :external
+  (:implementations Multics)
+  (:defstruct-options :external-ptr)
+  (:keywords :external-ptr)
+  (:cons (arg description etc) :alist
+    (let ((ptr (cdr (or (assq ':external-ptr etc)
+			(assq ':external-ptr
+			      (defstruct-description-property-alist))
+			(defstruct-error
+			  "No pointer given for external array"
+			  (defstruct-description-name))))))
+      (do ((creator `(array nil external ,ptr ,(defstruct-description-size)))
+	   (var (gensym))
+	   (alist arg (cdr alist))
+	   (inits nil (cons `(store (arraycall fixnum ,var ,(caar alist))
+				    ,(cdar alist))
+			    inits)))
+	  ((null alist)
+	   (if (null inits)
+	       creator
+	       `((lambda (,var) ,.inits ,var)
+		 ,creator))))))
+  (:ref (n description arg)
+    description	;ignored
+    `(arraycall fixnum ,arg ,n)))
+
+(defvar *defstruct-examine&deposit-arg*)
+
+(defun defstruct-examine (*defstruct-examine&deposit-arg*
+			  name slot-name)
+  (eval (list (defstruct-slot-description-ref-macro-name
+		(defstruct-examine&deposit-find-slot-description
+		  name slot-name))
+	      '*defstruct-examine&deposit-arg*)))
+
+(defvar *defstruct-examine&deposit-val*)
+
+(defun defstruct-deposit (*defstruct-examine&deposit-val*
+			  *defstruct-examine&deposit-arg*
+			  name slot-name)
+  (eval (list 'setf
+	      (list (defstruct-slot-description-ref-macro-name
+		     (defstruct-examine&deposit-find-slot-description
+		       name slot-name))
+		    '*defstruct-examine&deposit-arg*)
+	      '*defstruct-examine&deposit-val*)))
+
+(feature-case (LispM
+(defun defstruct-get-locative (*defstruct-examine&deposit-arg*
+			       name slot-name)
+  (let ((slot-description (defstruct-examine&deposit-find-slot-description
+			    name slot-name)))
+    (or (null (defstruct-slot-description-ppss))
+	(defstruct-error
+	  "You cannot get a locative to a byte field"
+	  slot-name 'in name))
+    (eval (list 'locf
+		(list (defstruct-slot-description-ref-macro-name)
+		      '*defstruct-examine&deposit-arg*)))))
+) (t))
+
+(defun defstruct-examine&deposit-find-slot-description (name slot-name)
+  (let ((description (get-defstruct-description name)))
+    (let ((slot-description
+	    (cdr (or (assq slot-name (defstruct-description-slot-alist))
+		     (defstruct-error
+		       "No such slot in this structure"
+		       slot-name 'in name))))
+	  (type-description
+	    (or (get (defstruct-description-type) 'defstruct-type-description)
+		(defstruct-error
+		  "Undefined defstruct type"
+		  (defstruct-description-type)))))
+      (or (= (defstruct-type-description-ref-no-args) 1)
+	  (defstruct-error
+	    "defstruct-examine and defstruct-deposit cannot handle structures of this type"
+	    (defstruct-description-type)))
+      slot-description)))
+
+(feature-case
+ (MacLisp-10
+  (defprop defstruct
+	   #.(and (status feature MacLisp-10)
+		  (caddr (truename infile)))
+    version))
+ (t))
+
+(sstatus feature defstruct)
diff --git a/src/alan/setf.23 b/src/alan/setf.23
new file mode 100755
index 00000000..67e244ec
--- /dev/null
+++ b/src/alan/setf.23
@@ -0,0 +1,156 @@
+;;;-*-Lisp-*-
+
+(declare (load '((alan) lspenv init)))
+
+;A winning macro to store things anywhere:
+(defmacro setf (expr val)
+    (prog (head y)
+	  (go A)
+   expand (setq expr (funcall (cadr y) expr))
+	A (cond ((atom expr)
+		 (or (symbolp expr) (go barf))
+		 (return `(setq ,expr ,val))))
+	  (setq head (car expr))
+	  (or (symbolp head) (go barf))
+	  (and (setq y (getl head '(setf setf-subr))) (go call))
+	  (setq y (getl head '(macro subr lsubr expr fsubr fexpr array)))
+	  (and (eq (car y) 'macro) (go expand))
+	  (and (or (not (null y))
+		   (null (setq y (get head 'autoload))))
+	       (go barf))
+	  (load y)
+	  (and (setq y (getl head '(setf setf-subr))) (go call))
+	  (setq y (getl head '(macro subr lsubr expr fsubr fexpr array)))
+	  (and (eq (car y) 'macro) (go expand))
+     barf (error '|-- SETF can't handle this.| expr)
+     call (return (if (eq (car y) 'setf)
+		      (funcall (cadr y) expr val)
+		      (subrcall t (cadr y) expr val)))))
+
+(defmacro defsetf (name pat var &body body)
+  (let ((sym (gensym)))
+    `(eval-when (eval compile load)
+       (defun (,name setf setf-subr) (,sym ,var)
+	 (bind-arguments (,pat (cdr ,sym)
+			   (error '|-- SETF can't handle this.| ,sym))
+	   ,@body)))))
+
+(defun car-cdr/ setf (x v)
+  (or (= 2 (length x))
+      (error '|-- SETF can't handle this.|  x))
+  (let ((p (get (car x) 'car-cdr/ setf)))
+    `(,(car p) (,(cdr p) ,(cadr x)) ,v)))
+
+(setq car-cdr/ setf (get 'car-cdr/ setf 'subr))
+
+(mapc '(lambda (x) (putprop x car-cdr/ setf 'setf-subr))
+      '(caar cdar cadr cddr caaar cdaar cadar cddar caadr
+	cdadr caddr cdddr caaaar cdaaar cadaar cddaar caadar
+	cdadar caddar cdddar caaadr cdaadr cadadr cddadr caaddr
+	cdaddr cadddr cddddr))
+
+(putprop 'caar '(rplaca . car) 'car-cdr/ setf)
+(putprop 'cdar '(rplacd . car) 'car-cdr/ setf)
+(putprop 'cadr '(rplaca . cdr) 'car-cdr/ setf)
+(putprop 'cddr '(rplacd . cdr) 'car-cdr/ setf)
+(putprop 'caaar '(rplaca . caar) 'car-cdr/ setf)
+(putprop 'cdaar '(rplacd . caar) 'car-cdr/ setf)
+(putprop 'cadar '(rplaca . cdar) 'car-cdr/ setf)
+(putprop 'cddar '(rplacd . cdar) 'car-cdr/ setf)
+(putprop 'caadr '(rplaca . cadr) 'car-cdr/ setf)
+(putprop 'cdadr '(rplacd . cadr) 'car-cdr/ setf)
+(putprop 'caddr '(rplaca . cddr) 'car-cdr/ setf)
+(putprop 'cdddr '(rplacd . cddr) 'car-cdr/ setf)
+(putprop 'caaaar '(rplaca . caaar) 'car-cdr/ setf)
+(putprop 'cdaaar '(rplacd . caaar) 'car-cdr/ setf)
+(putprop 'cadaar '(rplaca . cdaar) 'car-cdr/ setf)
+(putprop 'cddaar '(rplacd . cdaar) 'car-cdr/ setf)
+(putprop 'caadar '(rplaca . cadar) 'car-cdr/ setf)
+(putprop 'cdadar '(rplacd . cadar) 'car-cdr/ setf)
+(putprop 'caddar '(rplaca . cddar) 'car-cdr/ setf)
+(putprop 'cdddar '(rplacd . cddar) 'car-cdr/ setf)
+(putprop 'caaadr '(rplaca . caadr) 'car-cdr/ setf)
+(putprop 'cdaadr '(rplacd . caadr) 'car-cdr/ setf)
+(putprop 'cadadr '(rplaca . cdadr) 'car-cdr/ setf)
+(putprop 'cddadr '(rplacd . cdadr) 'car-cdr/ setf)
+(putprop 'caaddr '(rplaca . caddr) 'car-cdr/ setf)
+(putprop 'cdaddr '(rplacd . caddr) 'car-cdr/ setf)
+(putprop 'cadddr '(rplaca . cdddr) 'car-cdr/ setf)
+(putprop 'cddddr '(rplacd . cdddr) 'car-cdr/ setf)
+
+(defsetf car (x) v `(rplaca ,x ,v))
+
+(defsetf cdr (x) v `(rplacd ,x ,v))
+
+(defsetf cxr (n x) v `(rplacx ,n ,x ,v))
+
+(defsetf nth (n x) v `(rplaca (nthcdr ,n ,x) ,v))
+
+(defsetf nthcdr (n x) v `(rplacd (nthcdr (1- ,n) ,x) ,v))
+
+(defsetf arraycall tail v `(store (arraycall . ,tail) ,v))
+
+(defsetf get (sym ind) v `(putprop ,sym ,v ,ind))
+
+(defsetf plist (x) v `(setplist ,x ,v))
+
+(defsetf symeval (x) v `(set ,x ,v))
+
+(defsetf arg (x) v `(setarg ,x ,v))
+
+(defsetf args (x) v `(args ,x ,v))
+
+(defsetf sfa-get (sfa n) v `(sfa-store ,sfa ,n ,v))
+
+(defsetf ldb (ppss x) v `(setf ,x (dpb ,v ,ppss ,x)))
+
+(defsetf byte-size (byte-spec) ss
+  `(setf ,byte-spec (dpb ,ss #o0006 ,byte-spec)))
+
+(defsetf byte-position (byte-spec) ss
+  `(setf ,byte-spec (dpb ,ss #o0606 ,byte-spec)))
+
+(defsetf fixnum-identity (x) v
+  `(setf ,x (fixnum-identity ,v)))
+
+(defsetf flonum-identity (x) v
+  `(setf ,x (flonum-identity ,v)))
+
+(defsetf examine (x) v
+  `(deposit ,x ,v))
+
+(defsetf defstruct-examine (x name slot) v
+  `(defstruct-deposit ,v ,x ,name ,slot))
+
+(defsetf examine-job (x) v
+  `(deposit-job ,x ,v))
+
+(defsetf xcar (x) v `(xrplaca ,x ,v))
+
+(defsetf xcdr (x) v `(xrplacd ,x ,v))
+
+(defsetf xcxr (n x) v `(xrplacx ,n ,x ,v))
+
+;;;Pretty random:
+(defsetf progn (first &rest rest) v
+  (if (null rest)
+      `(setf ,first ,v)
+      `(progn ,first
+	      (setf (progn ,@rest) ,v))))
+
+;;;Completely random:
+(defsetf if (if then else) v
+  `(if ,if
+       (setf ,then ,v)
+       (setf ,else ,v)))
+
+(defsetf prog1 (first &rest rest) v
+  `(progn (setf ,first ,v)
+	  ,@rest))
+
+(defsetf prog2 (first second &rest rest) v
+  `(progn ,first
+	  (setf ,second ,v)
+	  ,@rest))
+
+(sstatus feature alan/;setf)
diff --git a/src/alan/setf.fasl b/src/alan/setf.fasl
new file mode 100755
index 00000000..f5ba0145
Binary files /dev/null and b/src/alan/setf.fasl differ
diff --git a/src/alan/struct.doc b/src/alan/struct.doc
new file mode 100755
index 00000000..e263c242
--- /dev/null
+++ b/src/alan/struct.doc
@@ -0,0 +1,1422 @@
+.c -*-Bolio-*-
+
+.chapter "Defstruct"
+.setq defstruct-page page
+
+.section "Introduction"
+
+	The features of 3defstruct* differ slightly from one Lisp
+implementation to another.  However, 3defstruct* makes it fairly
+easy to write compatible code if the user doesn't try to exercise any
+of the more esoteric features of his particular Lisp implementation.
+The differences will be pointed out as they occur.
+
+	One difference that we must deal with immediately is the
+'cindex packages
+question of packages.  3defstruct* makes use of a large number of
+keywords, and on the Lisp Machine and in NIL those keywords are all
+interned on the keyword package and thus should be typed with a leading
+colon.  However, in PDP-10 and Multics MacLisp these keywords are just
+ordinary symbols and no colon is necessary.  For the purposes of
+compatibility, in Lisp Machine Lisp and in NIL 3defstruct* will allow the
+keywords to appear in any package, while in PDP-10 and Multics MacLisp,
+3defstruct* will also check for symbols that have a leading ":" in their
+names.  Users should probably stick to the accepted style of their
+own Lisp dialect, and thus MacLisp users are invited to pretend that
+the rest of the colons in this document are invisible and Lisp Machine and
+NIL users are invited to ignore this paragraph.
+
+.section "A Simple Example"
+.setq example-section-page section-page
+
+.defmac defstruct
+3defstruct* is a macro defining macro.  The best way to explain
+how it works is to show a sample call to 3defstruct*, and then to show
+what macros are defined and what each of them does.
+.end_defmac
+
+Sample call to 3defstruct*:
+.lisp
+(defstruct (elephant (:type :list))
+  color
+  (size 17.)
+  (name (gensym)))
+.end_lisp
+This form expands into a whole rat's nest of stuff, but the effect is
+to define five macros: 3color*, 3size*, 3name*, 3make-elephant*
+and 3alter-elephant*.  Note that there were no symbols 3make-elephant* or
+3alter-elephant* in the original form, they were created by
+3defstruct*.  The definitions of 3color*, 3size* and 3name*
+are easy, they expand as follows:
+.lisp
+(color x) ==> (car x)
+(size x)  ==> (cadr x)
+(name x)  ==> (caddr x)
+.end_lisp
+
+You can see that 3defstruct* has decided to implement an elephant as a
+list of three things; its color, its size and its name.  The
+expansion of 3make-elephant* is
+somewhat harder to explain, let's look at a few cases: 
+.lisp
+(make-elephant)			    ==> (list nil 17. (gensym))
+(make-elephant color 'pink)	    ==> (list 'pink 17. (gensym))
+(make-elephant name 'fred size 100) ==> (list nil 100 'fred)
+.end_lisp
+
+	As you can see, 3make-elephant* takes a "setq-style" list of
+part names and forms, and expands into a call to 3list* that
+constructs such an elephant.  Note that the unspecified parts get defaulted
+to pieces of code specified in the original call to 3defstruct*.
+Note also that the order of the setq-style arguments is ignored in
+constructing the call to 3list*.  (In the example, 3100* is
+evaluated before 3'fred* even though 3'fred* came first in the
+3make-elephant* form.)  Care should thus be taken in using code with
+side effects within the scope of a 3make-elephant*.  Finally, take note
+of the fact that the 3(gensym)* is evaluated 2every time* a new
+elephant is created (unless you override it).
+
+	The explanation of what 3alter-elephant* does is delayed until
+(alterant-section-page).
+
+	So now you know how to construct a new elephant and how to examine
+the parts of an elephant, but how do you change the parts of an already
+existing elephant?  The answer is to use the 3setf* macro
+((setf-section-page)).
+.lisp
+(setf (name x) 'bill)	==> (rplaca (cddr x) 'bill)
+.end_lisp
+which is what you want.
+
+	And that is just about all there is to 3defstruct*; you now know
+enough to use it in your code, but if you want to know about all its
+interesting features, then read on.
+
+.section "Syntax of defstruct"
+.setq syntax-section-page section-page
+
+	The general form of a 3defstruct* form is:
+.lisp
+(defstruct (2name* 2option-1* 2option-2* ... 2option-n*)
+  2slot-description-1*
+  2slot-description-2*
+  ...
+  2slot-description-m*)
+.end_lisp
+
+	2name* must be a symbol, it is used in constructing names
+(such as "make-elephant") and it is given a 3defstruct-description* property
+of a structure that describes the structure completely.
+
+	Each 2option-i* is either the atomic name of an option, or a
+list of the form 3(2option-name* 2arg* . 2rest*)*.  Some
+options have defaults for 2arg*; some will complain if they are
+present without an argument; some options complain if they are present
+2with* an argument.  The interpretation of 2rest* is up to the option
+in question, but usually it is expected to be 3nil*.
+
+	Each 2slot-description-j* is either the atomic name of a
+slot in the structure, or a list of the form 3(2slot-name*
+2init-code*)*, or a list of byte field specifications.
+2init-code* is used by constructor macros (such as 3make-elephant*) to
+initialize slots not specified in the call to the constructor.  If the
+2init-code* is not specified, then the slot is initialized to
+whatever is most convenient. (In the 3elephant* example, since the
+structure was a list, 3nil* was used.  If the structure had been a
+fixnum array, such slots would be filled with zeros.)
+
+	A byte field specification looks like: 3(2field-name*
+2ppss*)* or 3(2field-name* 2ppss* 2init-code*)*.
+Note that
+since a byte field specification is always a list, a list of byte
+field specifications can never be confused with the other cases of a
+slot description.  The byte field feature of 3defstruct* is
+explained in detail in (byte-field-section-page).
+
+.section "Options to defstruct"
+.setq options-section-page section-page
+
+	The following sections document each of the options
+3defstruct* understands in detail.
+
+	On the Lisp Machine and in NIL, all these 3defstruct* options are
+'cindex packages
+interned on the keyword package.
+
+.subsection ":type"
+.setq type-section-page section-page
+
+	The 3:type* option specifies what kind of lisp object
+3defstruct* is going to use to implement your structure, and
+how that implementation is going to be carried out.  The
+3:type* option is illegal without an argument.  If the 3:type*
+option is not specified, then 3defstruct* will choose an appropriate
+default (hunks in PDP-10 MacLisp, arrays on Lisp Machines and lists on
+Multics).  It is possible for the user to teach 3defstruct* new ways
+to implement structures, the interested reader is referred to
+(extension-section-page), for more information.  Many useful types
+have already been defined for the user.  A table of these "built in"
+types follows: (On the Lisp Machine and in NIL all defstruct type
+names are interned
+'cindex packages
+on the keyword package.)
+
+.defstruct_type :list "All implementations"
+Uses a list.  This is the default on Multics.
+.end_defstruct_type
+
+.defstruct_type :named-list "All implementations"
+Like 3:list,* except the car of each instance of this structure will
+be the name symbol of the structure.  This is the only "named"
+structure type defined on Multics and is the default named type there.
+(See the 3:named* option
+documented in (named-section-page).)
+.end_defstruct_type
+
+.defstruct_type :tree "All implementations"
+Creates a binary tree out of conses with the slots as leaves.  The
+theory is to reduce car-cdring to a minimum.  The 3:include*
+option ((include-section-page)) does not work with
+structures of this type.
+.end_defstruct_type
+
+.defstruct_type :list* "All implementations"
+Similar to 3:list*, but the last slot in the structure will be
+placed in the cdr of the final cons of the list.  Some people call
+objects of this type "dotted lists".  The 3:include*
+option ((include-section-page)) does not work with
+structures of this type.
+.end_defstruct_type
+
+.defstruct_type :array "All implementations"
+Uses an array object (2not* a symbol with an array property).  This
+is the default on Lisp Machines.  Lisp Machine users may want to see
+the 3:make-array* option documented in (make-array-section-page).
+.end_defstruct_type
+
+.defstruct_type :fixnum-array "All implementations"
+Like 3:array*, except it uses a fixnum array and thus your structure
+can only contain fixnums.  On Lisp Machines 3defstruct* uses an
+3art-32b* type array for this type.
+.end_defstruct_type
+
+.defstruct_type :flonum-array "All implementations"
+Analogous to 3:fixnum-array*.  On Lisp Machines 3defstruct*
+uses an 3art-float* type array for this type.
+.end_defstruct_type
+
+.defstruct_type :un-gc-array "PDP-10 MacLisp only"
+Uses a 3nil* type array instead of a 3t* type.
+Note that this type does not exist on Lisp Machines or Multics,
+because un-garbage-collected arrays do not work in those implementations.
+.end_defstruct_type
+
+.defstruct_type :hunk "PDP-10 MacLisp only"
+Uses a hunk.  This is the default in
+PDP-10 MacLisp.
+.end_defstruct_type
+
+.defstruct_type :named-hunk "PDP-10 MacLisp only"
+Like 3hunk*, except the car of each instance of this structure will
+be the name symbol of the structure.  This is the default named
+type in PDP-10 MacLisp.  This 2can* be used with the
+3(status usrhunk)* feature of PDP-10 Maclisp to give the user
+Lisp Machine-like named structures.  (See the 3:named* option
+documented in (named-section-page).)
+.end_defstruct_type
+
+.defstruct_type :sfa "PDP-10 MacLisp and NIL"
+Uses an SFA.  The constructor macros for this type accept the keywords
+3:sfa-function* and 3:sfa-name*.  Their arguments (evaluated, of
+course) are used, respectively, as the function and the printed
+representation of the SFA.  See also the 3:sfa-function*
+((sfa-function-section-page)) and 3:sfa-name*
+((sfa-name-section-page)) options.  (SFAs are available in NIL for
+compatibility with PDP-10 MacLisp.)
+.end_defstruct_type
+
+.defstruct_type :vector "PDP-10 MacLisp and NIL"
+Uses an vector.  This is the default type in NIL.
+Since PDP-10 MacLisp doesn't really have vectors, using type
+vector there will simply use whatever vector package the user has loaded.
+.end_defstruct_type
+
+.defstruct_type :named-vector "PDP-10 MacLisp and NIL"
+Like vector, except element number 0 always contains the name symbol of the
+structure.  Note that this is 2not* the default 2named* type in NIL,
+3:extend* is.
+.end_defstruct_type
+
+.defstruct_type :extend "NIL only"
+.setq defstruct-extend-type-section-page section-page
+This is the default named type in NIL.  It
+uses the NIL flavor system to define the structure.  The effect of
+this is that the structure will have a type name of the name symbol,
+which will work with 3typep*, and can otherwise be treated as a
+flavor defined with 3defflavor*, except that the existence of
+instance variables is not defined:  one may use 3defmethod* to
+define methods, and access the slots with the 3defstruct*-defined
+accessor macros.  The type defined by 3defstruct* will inherit
+methods for printing, 3describe*, and 3inspect*.
+.c Someday also the name will be changed do something more
+.c meaningful, and perhaps it 2should* define instance variables.
+.c @@@ Glenn wrote something here.
+See also the 3:class-symbol*
+option ((class-symbol-section-page)).
+.end_defstruct_type
+
+.defstruct_type :named-array "Lisp Machine only"
+Uses an array with the named structure bit set and stores the name
+symbol of the structure in the first element.  This is the default named
+type on the Lisp Machine.  (See the 3:make-array*
+option documented in (make-array-section-page).)
+.end_defstruct_type
+
+.defstruct_type :array-leader "Lisp Machine only"
+Uses an array with a leader.  (See the 3:make-array*
+option documented in (make-array-section-page).)
+.end_defstruct_type
+
+.defstruct_type :named-array-leader "Lisp Machine only"
+Uses an array with a leader, sets the named structure bit, and stores
+the name symbol in element 1 of the leader.  (See the 3:make-array*
+option documented in (make-array-section-page).)
+.end_defstruct_type
+
+.defstruct_type :fixnum "All implementations"
+This type allows one to use the byte field feature of 3defstruct* to
+deal symbolically with fixnums that aren't actually stored in any
+structure at all.  Essenti vector, except element number 0 always contains the name symbol of the
+structure.  Note that this is 2not* the default 2named* type in NIL,
+3:extend* is.
+.end_defstruct_type
+
+.defstruct_type :extend "NIL only"
+.setq defstruct-extend-type-section-page section-page
+This is the default named type in NIL.  It
+uses the NIL flavor system to define the structure.  The effect of
+this is that the structure will have a type name of the name symbol,
+which will work with 3typep*, and can otherwise be treated as a
+flavor defined with 3defflavor*, except that the existence of
+instance variables is not defined:  one may use 3defmethod* to
+define methods, and access the slots with the 3defstruct*-defined
+accessor macros.  The type defined by 3defstruct* will inherit
+methods for printing, 3describe*, and 3inspect*.
+.c Someday also the name will be changed do something more
+.c meaningful, and perhaps it 2should* define instance variables.
+.c @@@ Glenn wrote something here.
+See also the 3:class-symbol*
+option ((class-symbol-section-page)).
+.end_defstruct_type
+
+.defstruct_type :named-array "Lisp Machine only"
+Uses an array with the named structure bit set and stores the name
+symbol of the structure in the first element.  This is the default named
+type on the Lisp Machine.  (See the 3:make-array*
+option documented in (make-array-section-page).)
+.end_defstruct_type
+
+.defstruct_type :array-leader "Lisp Machine only"
+Uses an array with a leader.  (See the 3:make-array*
+option documented in (make-array-section-page).)
+.end_defstruct_type
+
+.defstruct_type :named-array-leader "Lisp Machine only"
+Uses an array with a leader, sets the named structure bit, and stores
+the name symbol in element 1 of the leader.  (See the 3:make-array*
+option documented in (make-array-section-page).)
+.end_defstruct_type
+
+.defstruct_type :fixnum "All implementations"
+This type allows one to use the byte field feature of 3defstruct* to
+deal symbolically with fixnums that aren't actually stored in any
+structure at all.  Essentially, a structure of type 3:fixnum* has exactly
+one slot.  This allows the operation of retrieving the contents of
+that slot to be optimized away into the identity operation.  See
+(byte-field-section-page) for more information about byte
+fields.
+.end_defstruct_type
+
+.defstruct_type :external "Multics only"
+Uses an array of type 3external* (only Multics MacLisp has these).
+Constructor macros for structures of this kind take the
+3:external-ptr* keyword to tell them where the array is to be
+allocated.  (See (constructor-section-page), for an explanation of
+constructor macro keywords.)  See also the 3:external-ptr* option
+described in (external-ptr-section-page).
+.end_defstruct_type
+
+.subsection ":constructor"
+.setq constructor-section-page section-page
+
+	The 3:constructor* option specifies the name to be given to the
+constructor macro.  Without an argument, or if the option is not
+present, the name defaults to the concatenation of "make-" with the
+name of the structure.  If the option is given with an argument of
+3nil*, then no constructor is defined.  Otherwise the argument is the
+name of the constructor to define.  Normally the syntax of the
+constructor 3defstruct* defines is:
+.lisp
+(2constructor-name*
+    2keyword-1* 2code-1*
+    2keyword-2* 2code-2*
+    ...
+    2keyword-n* 2code-n*)
+.end_lisp
+
+	Each 2keyword-i* must be the name of a slot in the structure
+(not necessarily the name of an accessor macro; see the 3:conc-name*
+option, (conc-name-section-page)), or one of the special
+keywords allowed for the particular type of structure being
+constructed.  For each keyword that is the name of a slot, the
+constructor expands into code to make an instance of the structure
+using 2code-i* to initialize slot 2keyword-i*.  Unspecified slots
+default to the forms given in the original 3defstruct* form, or, if
+none was given there, to some convenient value such as 3nil* or
+30*.
+
+	For keywords that are not names of slots, the use of the
+corresponding code varies.  Usually it controls some aspect of the
+instance being constructed that is not otherwise constrained.  See,
+for example, the 3:make-array* option ((make-array-section-page)),
+the 3:sfa-function* option ((sfa-function-section-page), or
+the 3:external-ptr* option ((external-ptr-section-page)).
+
+	On the Lisp Machine and in NIL all such constructor macro keywords
+(those that are 2not* the names of slots) are interned on the keyword
+'cindex packages
+package.
+
+	If the 3:constructor* option is given as
+3(:constructor 2name* 2arglist*)*, then instead of making a keyword
+driven constructor, 3defstruct* defines a "function style" constructor.
+The 2arglist* is used to describe what the arguments to the
+constructor will be.  In the simplest case something like
+3(:constructor make-foo (a b c))* defines 3make-foo* to be a three
+argument constructor macro whose arguments are used to initialize the
+slots named 3a*, 3b* and 3c*.
+
+	In addition, the keywords 3&optional*, 3&rest* and
+3&aux* are recognized in the argument list.  They work in the way
+you might expect, but there are a few fine points worthy of
+explanation:
+.lisp
+(:constructor make-foo
+	(a &optional b (c 'sea) &rest d &aux e (f 'eff)))
+.end_lisp
+This defines 3make-foo* to be a constructor of one or more
+arguments.  The first argument is used to initialize the 3a* slot.
+The second argument is used to initialize the 3b* slot.  If there
+isn't any second argument, then the default value given in the body of
+the 3defstruct* (if given) is used instead.  The third argument is
+used to initialize the 3c* slot.  If there isn't any third argument,
+then the symbol 3sea* is used instead.  The arguments from the
+fourth one on are collected into a list and used to initialize the
+3d* slot.  If there are three or less arguments, then 3nil* is
+placed in the 3d* slot.  The 3e* slot is 2not initialized*.
+It's value will be something convenient like 3nil* or 30*.  And
+finally the 3f* slot is initialized to contain the symbol 3eff*.
+
+	The 3b* and 3e* cases were carefully chosen to allow the
+user to specify all possible behaviors.  Note that the 3&aux*
+"variables" can be used to completely override the default
+initializations given in the body.
+
+	Since there is so much freedom in defining constructors this
+way, it would be cruel to only allow the 3:constructor* option to be
+given once.  So, by special dispensation, you are allowed to give the
+3:constructor* option more than once, so that you can define several
+different constructors, each with a different syntax.
+
+	Note that even these "function style" constructors do not currently
+guarantee that their arguments will be evaluated in the order that you
+wrote them.
+
+.subsection ":alterant"
+.setq alterant-section-page section-page
+
+	The 3:alterant* option defines a macro that can be used to
+change the value of several slots in a structure together.  Without an
+argument, or if the option is not present, the name of the alterant
+macro defaults to the concatenation of "alter-" with the name of the
+structure.  If the option is given with an argument of 3nil,* then
+no alterant is defined.  Otherwise the argument is the name of the
+alterant to define.  The syntax of the alterant macro 3defstruct*
+defines is:
+.lisp
+(2alterant-name* 2code*
+   2slot-name-1* 2code-1*
+   2slot-name-2* 2code-2*
+   ...
+   2slot-name-n* 2code-n*)
+.end_lisp
+2code* should evaluate to an instance of the structure, each
+2code-i* is evaluated and the result is made to be the value of slot
+2slot-name-i* of that structure.  The slots are all altered in
+parallel after all code has been evaluated.  (Thus you can use an
+alterant macro to exchange the contents to two slots.)
+.break
+Example:
+.lisp
+(defstruct (lisp-hacker (:type :list)
+			:conc-name
+			:default-pointer
+			:alterant)
+  (favorite-macro-package nil)
+  (unhappy? t)
+  (number-of-friends 0))
+
+(setq lisp-hacker (make-lisp-hacker))
+.end_lisp
+Now we can perform a transformation:
+.lisp
+(alter-lisp-hacker lisp-hacker
+	favorite-macro-package 'defstruct
+	number-of-friends 23.
+	unhappy? nil)
+
+==> ((lambda (G0009)
+       ((lambda (G0011 G0010)
+	  (setf (car G0009) 'defstruct)
+	  (setf (caddr G0009) G0011)
+	  (setf (cadr G0009) G0010))
+	23.
+	nil))
+     lisp-hacker)
+.end_lisp
+
+	Although it appears from this example that your forms will be
+evaluated in the order in which you wrote them, this is not currently
+guaranteed.
+
+	Alterant macros are particularly good at simultaneously
+modifying several byte fields that are allocated from the same word.
+They produce better code than you can by simply writing consecutive
+3setf*s.  They also produce better code when modifying several slots of
+a structure that uses the 3:but-first* option
+((but-first-section-page)).
+
+	For 3defstruct* types whose accessors take more than one
+argument, all of those arguments must be supplied to the alterant
+macro in place of just the usual one.
+(See (multi-arg-accessors-section-page) for how accessors
+with more than one argument can come to be, there are no built-in
+3defstruct* types with this property.)
+
+.subsection ":named"
+.setq named-section-page section-page
+
+	This option tells 3defstruct* that you desire your structure to
+be a "named structure".  In PDP-10 MacLisp this means you want your
+structure implemented with a 3:named-hunk*, 3:named-list* or
+3:named-vector*.  On a Lisp Machine this indicates that you desire either
+a 3:named-array* or a 3:named-array-leader* or a 3:named-list*.  On
+Multics this indicates that you desire a 3:named-list*.  In NIL this
+indicates that you desire an 3:extend* a 3:named-vector* or a
+3:named-list*.  3defstruct* bases its decision as to what named type to
+use on whatever value you did or didn't give to the 3:type* option.
+
+	It is an error to use this option with an argument.
+
+.subsection ":predicate"
+.setq predicate-section-page section-page
+
+	The 3:predicate* option causes 3defstruct* to generate a
+predicate to recognize instances of the structure.  Naturally it only
+works for some 3defstruct* types.  Currently it works for all the
+named types as well as the types 3:sfa* (PDP-10 MacLisp and NIL
+only) and 3:extend* (NIL only).  The argument to the 3:predicate*
+option is the name of the predicate.  If it is present without an
+argument, then the name is formed by concatenating "-p" to the end of
+the name symbol of the structure.  If the option is not present, then
+no predicate is generated.  Example:
+.lisp
+(defstruct (foo :named :predicate)
+  foo-a
+  foo-b)
+.end_lisp
+defines a single argument function, 3foo-p*, that is true only of
+instances of this structure.
+
+.subsection ":print"
+.setq print-section-page section-page
+
+	The 3:print* option allows the user to control the printed
+representation of his structure in an implementation independent way:
+.lisp
+(defstruct (pair :named
+		 (:print "{~S . ~S}"
+			 (pair-first pair)
+			 (pair-second pair)))
+  pair-first
+  pair-second)
+.end_lisp
+
+	The arguments to the 3:print* option are used as if they were
+arguments to the 3format* function ((format-fun)), except that the
+first argument (the stream) is omitted.  They are evaluated in an
+environment where the name symbol of the structure (3pair* in this
+case) is bound to the instance of the structure to be printed.
+
+	This option presently only works on Lisp Machines and in NIL,
+using the 3defstruct* types 3:named-array* and 3:extend*
+respectively.  We hope to make it work in PDP-10 MacLisp for the
+3:named-hunk* type soon.  In Multics MacLisp, this option is
+ignored.  Notice that if you just specify the 3:named* option without
+giving an explicit 3:type* option, each 3defstruct* implementation
+will default to a named type that can control printing if at all
+possible.
+
+.subsection ":default-pointer"
+.setq default-pointer-section-page section-page
+
+	Normally the accessors are defined to be macros of exactly one
+argument.  (They check!)  But if the 3:default-pointer* option is present
+then they will accept zero or one argument.  When used with one
+argument, they behave as before, but given no arguments, they expand
+as if they had been called on the argument to the 3:default-pointer*
+option.  An example is probably called for:
+.lisp
+(defstruct (room (:type :tree)
+		 (:default-pointer **current-room**))
+  (room-name 'y2)
+  (room-contents-list nil))
+.end_lisp
+Now the accessors expand as follows:
+.lisp
+(room-name x)		==> (car x)
+(room-name)		==> (car **current-room**)
+.end_lisp
+
+If no argument is given to the 3:default-pointer* option, then the
+name of the structure is used as the "default pointer".
+3:default-pointer* is most often used in this fashion.
+
+.subsection ":conc-name"
+.setq conc-name-section-page section-page
+
+	Frequently all the accessor macros of a structure will want to
+have names that begin the same way; usually with the name of the
+structure followed by a dash.  The 3:conc-name* option allows the
+user to specify this prefix.  Its argument should be a symbol whose
+print name will be concatenated onto the front of the slot names when
+forming the accessor macro names.  If the argument is not given, then
+the name of the structure followed by a dash is used.  If the
+3:conc-name* option is not present, then no prefix is used.  An
+example illustrates a common use of the 3:conc-name* option along
+with the 3:default-pointer* option:
+.lisp
+(defstruct (location :default-pointer
+		     :conc-name)
+  (x 0)
+  (y 0)
+  (z 0))
+.end_lisp
+Now if you say
+.lisp
+(setq location (make-location x 1 y 34 z 5))
+.end_lisp
+it will be the case that
+.lisp
+(location-y)
+.end_lisp
+will return 34.  Note well that the name of the slot ("y") and the
+name of the accessor macro for that slot ("location-y") are
+different.
+
+.subsection ":include"
+.setq include-section-page section-page
+
+	The 3:include* option inserts the definition of its argument
+at the head of the new structure's definition.  In other words, the
+first slots of the new structure are equivalent to (i.e. have the same
+names as, have the same inits as, etc.) the slots of the argument to
+the 3:include* option.  The argument to the 3:include* option must
+be the name of a previously defined structure of the same type as the
+new one.  If no type is specified in the new structure, then it is
+defaulted to that of the included one.  It is an error for the
+3:include* option to be present without an argument.  Note that
+3:include* does not work on certain types of structures (e.g.
+structures of type 3:tree* or 3:list**).  Note also that the
+3:conc-name*, 3:default-pointer*, 3:but-first* and
+3:callable-accessors* options only apply to the accessors defined in
+the current 3defstruct*; no new accessors are defined for the
+included slots.
+
+.group
+	An example:
+.lisp
+(defstruct (person (:type :list)
+		   :conc-name)
+  name
+  age
+  sex)
+
+(defstruct (spaceman (:include person)
+		     :default-pointer)
+  helmet-size
+  (favorite-beverage 'tang))
+.end_lisp
+Now we can make a spaceman like this:
+.lisp
+(setq spaceman (make-spaceman name 'buzz
+			      age 45.
+			      sex t
+			      helmet-size 17.5))
+.end_lisp
+To find out interesting things about spacemen:
+.lisp
+(helmet-size)		==> (cadddr spaceman)
+(person-name spaceman)	==> (car spaceman)
+(favorite-beverage x)	==> (car (cddddr x))
+.end_lisp
+.end_group
+
+	As you can see the accessors defined for the 3person*
+structure have names that start with "person-" and they only take one
+argument.  The names of the accessors for the last two slots of the
+3spaceman* structure are the same as the slot names, but they allow
+their argument to be omitted.  The accessors for the first three slots
+of the 3spaceman* structure are the same as the accessors for the
+3person* structure.
+
+	Often, when one structure includes another, the default
+initial values supplied by the included structure will be undesirable.
+These default initial values can be modified at the time of inclusion
+by giving the 3:include* option as:
+.lisp
+(:include 2name* 2new-init-1* ... 2new-init-n*)
+.end_lisp
+Each 2new-init-i* is either the name of an included slot or of the
+form 3(2included-slot-name* 2new-init*)*.  If it is just a slot
+name, then in the new structure (the one doing the including) that
+slot will have no initial value.  If a new initial value is given,
+then that code replaces the old initial value code for that slot in
+the new structure.  The included structure is unmodified.
+
+.subsection ":copier"
+.setq copier-section-page section-page
+
+	This option causes 3defstruct* to generate a single argument
+function that will copy instances of this structure.  The argument to
+the 3:copier* option is the name of the copying function.  If this
+option is present without an argument, then the name is formed by
+concatenating "copy-" with the name of the structure.  
+
+	Example:
+.lisp
+(defstruct (coat-hanger (:type :list) :copier)
+  current-closet
+  wire-p)
+.end_lisp
+Generates a function approximately like:
+.lisp
+(defun copy-coat-hanger (x)
+  (list (car x) (cadr x)))
+.end_lisp
+
+.subsection ":make-array"
+.setq make-array-section-page section-page
+
+	Available only on Lisp Machines, this option allows the user to
+control those aspects of the array used to implement the structure
+that are not otherwise constrained by 3defstruct* (such as the area it
+is to be allocated in).  
+
+	The argument to the 3:make-array* option should be a list of
+alternating keyword symbols to the Lisp Machine 3make-array* function
+(see the Lisp Machine manual), and forms whose values are to be the
+arguments to those keywords.  For example, 3(:make-array (:type
+'art-4b))* would request that the type of the array be 3art-4b*.
+Note that the keyword symbols are 2not* evaluated.
+
+	Constructor macros for structures implemented as
+arrays all allow the keyword 3:make-array* to be supplied.
+Its argument is of the same form as the 3:make-array*
+option, and attributes specified there (in the constructor
+form) will override those given in the 3defstruct* form.
+
+	Since it is sometimes necessary to be able to specify the
+dimensions of the array that 3defstruct* is going to construct (for
+structures of type 3:array-leader* for example), the 3:make-array*
+option or constructor keyword accepts the additional keywords
+3:length* and 3:dimension* (they mean the same thing).  The
+argument to this pseudo 3make-array* keyword will be supplied as the
+first argument to the 3make-array* function when the constructor is
+expanded.
+
+	3defstruct* chooses appropriate defaults for those attributes
+not specified in the 3defstruct* form or in the constructor form,
+and 3defstruct* overrides any specified attributes that it has to.
+
+.subsection ":class-symbol"
+.setq class-symbol-section-page section-page
+
+	For use with the 3:extend* 3defstruct* type available
+only in NIL ((defstruct-extend-type-section-page)), this option
+allows the user to control 2how* the flavor definition is
+performed.  This option 2must* be given a variable name as an
+argument;  the value of that variable is used as the flavor (class)
+object of the object which the 3defstruct*-defined constructor
+will create.  3defstruct* will not define the flavor.
+
+	This option was originally implemented for bootstrapping
+purposes, so that typed objects in NIL could be created before the
+flavor system was fully loaded.  Eventually it will be fully outmoded
+by extensions to the flavor system, which already has the capability
+of defining accessor macros for instance variables.
+.c @@@ Glenn wrote this!
+
+.subsection ":sfa-function"
+.setq sfa-function-section-page section-page
+
+	Available in PDP-10 MacLisp and in NIL, this option allows the user to
+specify the function that will be used in structures of type 3:sfa*.
+Its argument should be a piece of code that evaluates to the desired
+function.  Constructor macros for this type of structure will take
+3:sfa-function* as a keyword whose argument is also the code to
+evaluate to get the function, overriding any supplied in the original
+3defstruct* form.
+
+	If 3:sfa-function* is not present anywhere, then the
+constructor will use the name-symbol of the structure as the function.
+
+.subsection ":sfa-name"
+.setq sfa-name-section-page section-page
+
+	Available only in PDP-10 MacLisp, this option allows the user to
+specify the object that will be used in the printed representation of
+structures of type 3:sfa*.  Its argument should be a piece of code
+that evaluates to that object.  Constructor macros for this type of
+structure will take 3:sfa-name* as a keyword whose argument is also
+the code to evaluate to get the object to use, overriding any supplied
+in the original 3defstruct* form.
+
+	If 3:sfa-name* is not present anywhere, then the constructor
+will use the name-symbol of the structure as the function.
+
+.subsection ":external-ptr"
+.setq external-ptr-section-page section-page
+
+	Available only in Multics MacLisp, this option is used with
+structures of type 3:external*.  Its argument should be a piece of code
+that evaluates to a fixnum "packed pointer" pointing to the first word of
+the external array that 3defstruct* is allocate as a structure.
+Constructor macros for this type of structure will take 3:external-ptr* as
+a keyword whose argument overrides any supplied in the original
+3defstruct* form.
+
+	If 3:external-ptr* is not present anywhere, then the
+constructor signals an error when it expands.
+
+.subsection ":size-symbol"
+.setq size-symbol-section-page section-page
+
+	The 3:size-symbol* option allows a user to specify a symbol
+whose value will be the "size" of the structure.  The exact meaning of
+this varies, but in general this number is the one you would need to
+know if you were going to allocate one of these structures yourself.
+The symbol will have this value both at compile time and at run time.
+If this option is present without an argument, then the name of the
+structure is concatenated with "-size" to produce the symbol.
+
+.subsection ":size-macro"
+.setq size-macro-section-page section-page
+
+	Similar to 3:size-symbol*.  A macro of no arguments is defined
+that expands into the size of the structure.  The name of this macro
+defaults as with 3:size-symbol*.
+
+.subsection ":initial-offset"
+.setq initial-offset-section-page section-page
+
+	This option allows you to tell 3defstruct* to skip
+over a certain number of slots before it starts allocating
+the slots described in the body.  This option requires an
+argument, which must be a fixnum, which is the number of
+slots you want 3defstruct* to skip.  To make use of this
+option requires that you have some familiarity with how
+3defstruct* is implementing you structure, otherwise you
+will be unable to make use of the slots that 3defstruct*
+has left unused.
+
+.subsection ":but-first"
+.setq but-first-section-page section-page
+
+	This option is best explained by example:
+.lisp
+(defstruct (head (:type :list)
+		 (:default-pointer person)
+		 (:but-first person-head))
+  nose
+  mouth
+  eyes)
+.end_lisp
+So now the accessors expand like this:
+.lisp
+(nose x)	==> (car (person-head x))
+(nose)		==> (car (person-head person))
+.end_lisp
+
+The theory is that 3:but-first*'s argument will likely be an
+accessor from some other structure, and it is never expected that this
+structure will be found outside of that slot of that other structure.
+(In the example I had in mind that there was a 3person* structure
+which had a slot accessed by 3person-head*.)  It is an error for the
+3:but-first* option to be used without an argument.
+
+.subsection ":callable-accessors"
+.setq callable-accessors-section-page section-page
+
+	This option controls whether the accessors defined by 3defstruct*
+will work as "functional arguments".  (As the first argument to 3mapcar*,
+for example.)  On the Lisp Machine and in NIL accessors are callable by
+default, but in PDP-10 MacLisp it is expensive to make this work, so they
+are only callable if you ask for it.  (Currently on Multics the feature
+doesn't work at all...)  The argument to this option is 3nil* to indicate
+that the feature should be turned off, and 3t* to turn the feature on.
+If the option is present with no argument, then the feature is turned on.
+
+.subsection ":eval-when"
+.setq eval-when-section-page section-page
+
+	Normally the macros defined by 3defstruct* are defined at
+eval-time, compile-time and at load-time.  This option allows the user
+to control this behavior.  3(:eval-when (eval compile))*, for example,
+will cause the macros to be defined only when the code is running
+interpreted and inside the compiler, no trace of 3defstruct* will be
+found when running compiled code.
+
+	Using the 3:eval-when* option is preferable to wrapping an
+3eval-when* around a 3defstruct* form, since nested
+3eval-when*s can interact in unexpected ways.
+
+.subsection ":property"
+.setq property-section-page section-page
+
+	For each structure defined by 3defstruct*, a property list is
+maintained for the recording of arbitrary properties about that
+structure.
+
+	The 3:property* option can be used to give a 3defstruct*
+an arbitrary property.  3(:property 2property-name* 2value*)*
+gives the 3defstruct* a 2property-name* property of 2value*.
+Neither argument is evaluated.  To access the property list, the user
+will have to look inside the 3defstruct-description* structure
+himself, he is referred to (defstruct-description-section-page), for
+more information.
+
+.subsection "A Type Used As An Option"
+.setq type-as-option-section-page section-page
+
+	In addition to the options listed above, any currently defined
+type (a legal argument to the 3:type* option) can be used as a
+option.  This is mostly for compatibility with the old Lisp Machine
+3defstruct*.  It allows you to say just 2type* when you should be
+saying 3(:type 2type*)*.  Use of this feature in new code is
+discouraged.  It is an error to give an argument to a type used as an
+option in this manner.
+
+.subsection "Other Options"
+.setq other-options-section-page section-page
+
+	Finally, if an option isn't found among those listed above,
+3defstruct* checks the property list of the name of the option to
+see if it has a non-null 3:defstruct-option* property.  If is does
+have such a property, then if the option was of the form
+3(2option-name* 2value*)*, it is treated just like 3(:property
+2option-name* 2value*)*.  That is, the 3defstruct* is given an
+2option-name* property of 2value*.  If such an option is used
+without an argument, it is treated just like 3(:property
+2option-name* t)*.  That is, it is treated as if the argument was
+3t*.
+
+	This provides a primitive way for the user to define his own
+options to 3defstruct*.  Several of the options listed above are
+actually implemented using this mechanism.
+
+.section "Byte Fields"
+.setq byte-field-section-page section-page
+
+	On Multics, the byte field feature will not work unless the
+user has arranged to define the functions 3ldb* and 3dpb*
+((byte-hacking-section-page)).  They are not yet present in the
+default environment, but they are available as part of the extension
+library ((multics-library-section-page)).
+
+	The byte field feature of 3defstruct* allows the user to specify
+that several slots of his structure are bytes in a fixed point number
+stored in one element of the structure.  For example, suppose we had
+the following structure:
+.lisp
+(defstruct (phone-book-entry (:type :list))
+  name
+  address
+  (area-code 617.)
+  exchange
+  line-number)
+.end_lisp
+This will work just fine.  Except you notice that an 3area-code* and
+an 3exchange* are both always less than 1000., and so both can
+easily fit in 10. bits, and the 3line-number* is always less than
+10000. and can thus fit in 14. bits.  Thus you can pack all three
+parts of a phone number in 34. bits.  If you have a lisp with 36. bit
+fixnums, then you should be able to put the entire phone number in one
+fixnum in a structure.  3defstruct* allows you to do this as
+follows:
+.lisp
+(defstruct (phone-book-entry (:type :list))
+  name
+  address
+  ((area-code #o3012 617.)
+   (exchange #o1612)
+   (line-number #o0016)))
+.end_lisp
+The magic numbers 3#o3012*, 3#o1612* and 3#o0016* are byte specifiers
+suitable for use with the functions 3ldb* and 3dpb* ((ldb-fun)).
+Things will expand as follows:
+.lisp
+(area-code pbe)	==> (ldb #o3012 (caddr pbe))
+(exchange pbe)	==> (ldb #o1612 (caddr pbe))
+
+(make-phone-book-entry
+	name '|Fred Derf|
+	address '|259 Octal St.|
+	exchange ex
+	line-number 7788.)
+
+==> (list '|Fred Derf| '|259 Octal St.|
+	  (dpb ex #o1612 #o115100017154))
+
+(alter-phone-book-entry pbe
+			exchange ex
+			line-number ln)
+
+==> ((lambda (G0003) 
+       (setf (caddr G0003)
+	     (dpb ex #o1612 (dpb ln #o0016 (caddr G0003)))))
+     pbe)
+.end_lisp
+
+3defstruct* tries to be maximally clever about constructing and altering
+structures with byte fields.
+
+	The byte specifiers are actually pieces of code that are
+expected to evaluate to byte specifiers, but 3defstruct* will try
+and understand fixnums if you supply them.  (In the
+3make-phone-book* example, 3defstruct* was able to make use of its
+knowledge of the 3line-number* and 3area-code* byte specifiers to
+assemble the constant number 3#o115100017154* and produce code to just
+deposit in the 3exchange*.)
+
+	A 3nil* in the place of the byte specifier code means to define
+an accessor for the entire word.  So we could say:
+.lisp
+(defstruct (phone-book-entry (:type :list))
+  name
+  address
+  ((phone-number nil)
+   (area-code #o3012 617.)
+   (exchange #o1612)
+   (line-number #o0016)))
+.end_lisp
+to enable us to do things like:
+.lisp
+(setf (phone-number pbe1) (phone-number pbe2))
+.end_lisp
+to cause two entries to
+have the same phone numbers.
+
+	We could also have said just: 3((phone-number) ...)* in that
+last 3defstruct*, but the feature of 3nil* byte specifiers allows
+you to supply initial values for the entire slot by saying:
+3((2name* nil 2init*) ...)*.
+
+	Constructor macros initialize words divided into byte fields
+as if they were deposited in the following order:
+
+ 1) Initializations for the entire word given in the 3defstruct* form.
+
+ 2) Initializations for the byte fields given in the 3defstruct* form.
+
+ 3) Initializations for the entire word given in the constructor macro form. 
+
+ 4) Initializations for the byte fields given in the constructor macro form. 
+
+Alterant macros operate in a similar manner.  That is, as if the
+entire word was modified first, and then the byte fields were
+deposited.  Results will be unpredictable in constructing and altering
+if byte fields that overlap are given.
+
+.section "About Autoloading"
+.setq autoloading-section-page section-page
+
+	This section only applies to PDP-10 and Multics MacLisp.
+
+	If you look at the property lists of the macros defined by
+3defstruct*, you will find that they are all have macro properties of one
+of four functions: 3defstruct-expand-ref-macro*,
+3defstruct-expand-cons-macro*, 3defstruct-expand-alter-macro* and
+3defstruct-expand-size-macro*.  These functions figure out how to expand
+the macro by examining the property list of the car of the form they
+are asked to expand.  3defstruct-expand-ref-macro*, for example, looks
+for a 3defstruct-slot* property, which should be a cons of the form
+3(2structure-name* . 2slot-name*)*.
+
+	Since the 3defstruct* form only expands into 3putprop*s of the
+desired functions (instead of actually constructing a full-fledged
+definition), loading a compiled file containing a 3defstruct* merely
+adds a few properties to some symbols.  The run time environment is
+not needlessly cluttered with unwanted list structure or subr objects.
+If the user thinks he may wish to use any of the macros defined by
+3defstruct* after compiling his file, he need only give the four
+expanding functions autoload properties of the name of the file
+containing 3defstruct* itself.
+
+	For purposes of using 3defstruct* interpreted, the two
+symbols 3defstruct* and 3defstruct-define-type* should be given
+similar autoload properties.  Thus six symbols with autoload
+properties suffice to make 3defstruct* appear loaded at all times.
+
+.section "The defstruct-description Structure"
+.setq defstruct-description-section-page section-page
+
+	This section discusses the internal structures used by
+3defstruct* that might be useful to programs that want to interface
+to 3defstruct* nicely.  The information in this section is also
+necessary for anyone who is thinking of defining his own structure
+types ((extension-section-page)).  Lisp Machine and NIL programmers
+'cindex packages
+will find that the symbols found only in this section are all interned
+in the "systems-internals" package ("SI" for short).
+
+	Whenever the user defines a new structure using 3defstruct*,
+3defstruct* creates an instance of the 3defstruct-description*
+structure.  This structure can be found as the
+3defstruct-description* property of the name of the structure; it
+contains such useful information as the name of the structure, the
+number of slots in the structure, etc.
+
+	The 3defstruct-description* structure is defined something
+like this:  (This is a bowdlerized version of the real thing, I have
+left out a lot of things you don't need to know unless you are
+actually reading the code.)
+.lisp
+(defstruct (defstruct-description
+	     (:default-pointer description)
+	     (:conc-name defstruct-description-))
+  name
+  size
+  property-alist
+  slot-alist)
+.end_lisp
+
+	The 3name* slot contains the symbol supplied by the user to be
+the name of his structure, something like 3spaceship* or
+3phone-book-entry*.
+
+	The 3size* slot contains the total number of slots in an
+instance of this kind of structure.  This is 2not* the same number
+as that obtained from the 3:size-symbol* or 3:size-macro* options
+to 3defstruct*.  A named structure, for example, usually uses up an
+extra location to store the name of the structure, so the 3:size-macro*
+option will get a number one larger than that stored in the
+3defstruct* description.
+
+	The 3property-alist* slot contains an alist with pairs of
+the form 3(2property-name* . 2property*)* containing properties
+placed there by the 3:property* option to 3defstruct* or by
+property names used as options to 3defstruct* (see
+(property-section-page), and (other-options-section-page)).
+
+	The 3slot-alist* slot contains an alist of pairs of the form
+3(2slot-name* . 2slot-description*)*.  A 2slot-description* is
+an instance of the 3defstruct-slot-description* structure.  The
+3defstruct-slot-description* structure is defined something like
+this: (another bowdlerized 3defstruct*)
+.lisp
+(defstruct (defstruct-slot-description
+	     (:default-pointer slot-description)
+	     (:conc-name defstruct-slot-description-))
+  number
+  ppss
+  init-code
+  ref-macro-name)
+.end_lisp
+
+	The 3number* slot contains the number of the location of this
+slot in an instance of the structure.  Locations are numbered
+starting with 0, and continuing up to one less than the size of the
+structure.  The actual location of the slot is determined by the
+reference consing code associated with the type of the structure.  See
+(extension-section-page).
+
+	The 3ppss* slot contains the byte specifier code for this slot if
+this slot is a byte field of its location.  If this slot is the entire
+location, then the 3ppss* slot contains 3nil*.
+
+	The 3init-code* slot contains the initialization code supplied
+for this slot by the user in his 3defstruct* form.  If there is no
+initialization code for this slot then the 3init-code* slot contains the
+symbol 3%%defstruct-empty%%*.
+
+	The 3ref-macro-name* slot contains the symbol that is defined as
+an accessor that references this slot.
+
+.section "Extensions to defstruct"
+.setq extension-section-page section-page
+
+.defmac defstruct-define-type
+The macro 3defstruct-define-type* can be used to teach
+3defstruct* about new types it can use to implement structures.
+.end_defmac
+
+.subsection "A Simple Example"
+
+	Let us start by examining a sample call to
+3defstruct-define-type*.  This is how the 3:list* type of
+structure might have been defined:
+.lisp
+(defstruct-define-type :list
+  (:cons (initialization-list description keyword-options) :list
+	 (cons 'list initialization-list))
+  (:ref (slot-number description argument)
+	(list 'nth slot-number argument)))
+.end_lisp
+
+This is the minimal example.  We have provided 3defstruct* with two
+pieces of code, one for consing up forms to construct instances of the
+structure, the other to cons up forms to reference various elements of
+the structure.  
+
+	From the example we can see that the constructor consing code
+is going to be run in an environment where the variable
+3initialization-list* is bound to a list which is the
+initializations to the slots of the structure arranged in order.  The
+variable 3description* will be bound to the
+3defstruct-description* structure for the structure we are consing a
+constructor for.  (See (defstruct-description-section-page).)
+The binding of the variable 3keyword-options* will be described later.
+Also the symbol 3:list* appears after the argument list, this conveys
+some information to 3defstruct* about how the constructor consing
+code wants to get called.
+
+	The reference consing code gets run with the variable
+3slot-number* bound to the number of the slot that is to be
+referenced and the variable 3argument* bound to the code that
+appeared as the argument to the accessor macro.  The variable
+3description* is again bound to the appropriate instance of the
+3defstruct-description* structure.
+
+	This simple example probably tells you enough to be able to go
+ahead and implement other structure types, but more details follow.
+
+.subsection "Syntax of defstruct-define-type"
+
+	The syntax of defstruct-define-type is
+.lisp
+(defstruct-define-type 2type*
+  2option-1*
+  ...
+  2option-n*)
+.end_lisp
+where each 2option-i* is either the symbolic name of an option or a
+list of the form 3(2option-i* . 2rest*)*.  (Actually
+2option-i* is the same as 3(2option-i*)*.)  Different options
+interpret 2rest* in different ways.
+
+	The symbol 2type* is given a 3defstruct-type-description*
+property of a structure that describes the type completely.
+
+.subsection "Options to defstruct-define-type"
+
+	This section is a catalog of all the options currently known
+about by 3defstruct-define-type*.
+
+.subsubsection ":cons"
+.setq cons-option-section-page section-page
+
+	The 3:cons* option to 3defstruct-define-type* is how the user
+supplies 3defstruct* with the necessary code that it needs to cons up a
+form that will construct an instance of a structure of this type.
+
+	The 3:cons* option has the syntax:
+.lisp
+(:cons (2inits* 2description* 2keywords*) 2kind*
+       2body*)
+.end_lisp
+
+	2body* is some code that should construct and return a piece
+of code that will construct, initialize and return an instance of a
+structure of this type.
+
+	The symbol 2inits* will be bound to the code that the
+constructor conser should use to initialize the slots of the
+structure.  The exact form of this argument is determined by the
+symbol 2kind*.  There are currently two kinds of initialization.
+There is the 3:list* kind, where 2inits* is bound to a list of
+initializations, in the correct order, with 3nil*s in uninitialized
+slots.  And there is the 3:alist* kind, where 2inits* is bound to an
+alist with pairs of the form 3(2slot-number* .
+2init-code*)*.
+
+	The symbol 2description* will be bound to the instance of
+the 3defstruct-description* structure
+((defstruct-description-section-page)) that 3defstruct* maintains
+for this particular structure.  This is so that the constructor conser
+can find out such things as the total size of the structure it is supposed
+to create.
+
+	The symbol 2keywords* will be bound to a alist with pairs of
+the form 3(2keyword* . 2value*)*, where each 2keyword* was a
+keyword supplied to the constructor macro that wasn't the name of a
+slot, and 2value* was the "code" that followed the keyword.  (See
+(keywords-section-page), and (constructor-section-page).)
+
+	It is an error not to supply the 3:cons* option to
+3defstruct-define-type*.
+
+.subsubsection ":ref"
+
+	The 3:ref* option to 3defstruct-define-type* is how the user
+supplies 3defstruct* with the necessary code that it needs to cons up a
+form that will reference an instance of a structure of this type.
+
+	The 3:ref* option has the syntax:
+.lisp
+(:ref (2number* 2description* 2arg-1* ... 2arg-n*)
+      2body*)
+.end_lisp
+
+	2body* is some code that should construct and return a piece
+of code that will reference an instance of a structure of this type.
+	The symbol 2number* will be bound to the location of the slot
+that the is to be referenced.  This is the same number that is found
+in the 3number* slot of the 3defstruct-slot-description* structure
+((defstruct-description-section-page)).
+
+	The symbol 2description* will be bound to the instance of the
+3defstruct-description* structure that 3defstruct* maintains for this
+particular structure.
+
+	The symbols 2arg-i* are bound to the forms supplied to the
+accessor as arguments.  Normally there should be only one of these.  
+'setq multi-arg-accessors-section-page section-page
+The 2last* argument is the one that will be defaulted by the
+3:default-pointer* option ((default-pointer-section-page)).
+3defstruct* will check that the user has supplied exactly n
+arguments to the accessor macro before calling the reference consing
+code.
+
+	It is an error not to supply the 3:ref* option to
+3defstruct-define-type*. 
+
+.subsubsection ":predicate"
+
+	The 3:predicate* option to 3defstruct-define-type* is how
+3defstruct* is told how to produce predicates for a particular type
+when the 3:predicate* option to 3defstruct* is used
+((predicate-section-page)).  Its syntax is:
+.lisp
+(:predicate (2description* 2name*)
+	    2body*)
+.end_lisp
+
+	The variable 2description* will be bound to the
+3defstruct-description* structure maintained for the structure we
+are to generate a predicate for.  The variable 2name* is bound to
+the symbol that is to be defined as a predicate.  2body* is a piece
+of code to evaluate to return the defining form for the predicate.  A
+typical use of this option might look like:
+.lisp
+(:predicate (description name)
+	    `(defun ,name (x)
+	       (and (frobbozp x)
+		    (eq (frobbozref x 0)
+			',(defstruct-description-name)))))
+.end_lisp
+
+.subsubsection ":overhead"
+
+	The 3:overhead* option to 3defstruct-define-type* is how
+the user declares to 3defstruct* that the implementation of this
+particular type of structure "uses up" some number of slots locations
+in the object actually constructed.  This option is used by various
+"named" types of structures that store the name of the structure in
+one location.
+
+	The syntax of 3:overhead* is:
+.lisp
+(:overhead 2n*)
+.end_lisp
+where 2n* is a
+fixnum that says how many locations of overhead this type needs.
+
+	This number is only used by the 3:size-macro* and
+3:size-symbol* options to 3defstruct*.  (See
+(size-macro-section-page), and (size-symbol-section-page).)
+
+.subsubsection ":named"
+
+	The 3:named* option to 3defstruct-define-type* controls
+the use of the 3:named* option to 3defstruct*.  With no argument
+the 3:named* option means that this type is an acceptable "named
+structure".  With an argument, as in 3(:named 2type-name*)*, the
+symbol 2type-name* should be that name of some other structure type
+that 3defstruct* should use if someone asks for the named version of
+this type.  (For example, in the definition of the 3:list* type the
+3:named* option is used like this: 3(:named :named-list)*.)
+
+.subsubsection ":keywords"
+.setq keywords-section-page section-page
+
+	The 3:keywords* option to 3defstruct-define-type* allows
+the user to define constructor keywords
+((constructor-section-page)) for this type of structure.
+(For example the 3:make-array* constructor keyword for structures of
+type 3:array* on Lisp Machines.)  The syntax is:
+.lisp
+(:keywords 2keyword-1* ... 2keyword-n*)
+.end_lisp
+where each 2keyword-i* is a
+symbol that the constructor conser expects to find in the 2keywords*
+alist ((cons-option-section-page)).
+
+.subsubsection ":defstruct-options"
+
+	The 3:defstruct-options* option to 3defstruct-define-type*
+is similar to the 3:keywords* option.  It is used to define new
+options that may appear in the options part of a 3defstruct* for a
+structure of this type.  Its syntax is:
+.lisp
+(:defstruct-options 2option-1* ... 2option-n*)
+.end_lisp
+This defines each 2option-i* to be a option to 3defstruct*
+that can be used with structures of this type.  For example, the
+3:array* 3defstruct* type for the Lisp Machine uses the 
+3:defstruct-options* option as follows:
+.lisp
+(:defstruct-options :make-array)
+.end_lisp
+
+	Currently this just works by giving each 2option-i* a
+non-null 3:defstruct-option* property (see
+(other-options-section-page)), but soon it will check to be sure that
+each 2option-i* is 2only* used as an option with structures of
+this type.
+
+.subsubsection ":defstruct"
+
+	The 3:defstruct* option to 3defstruct-define-type* allows
+the user to run some code and return some forms as part of the
+expansion of the 3defstruct* macro.
+
+	The 3:defstruct* option has the syntax:
+.lisp
+(:defstruct (2description*)
+	    2body*)
+.end_lisp
+
+	2body* is a piece of code that will be run whenever 3defstruct*
+is expanding a 3defstruct* form that defines a structure of this type.
+The symbol 2description* will be bound to the insta
\ No newline at end of file
diff --git a/src/l/lchnsp.35 b/src/l/lchnsp.35
new file mode 100755
index 00000000..12f80d57
--- /dev/null
+++ b/src/l/lchnsp.35
@@ -0,0 +1,328 @@
+;-*-MIDAS-*-
+
+TITLE LISP CHAOS NETWORK SUPPORT PACKAGE
+
+;;; This is the low-level chaos-net handling package for LISP.
+;;; All functions in this file are prefixed with %CHAOS-
+;;; A CHAOS net connection data structure is a cons containing
+;;; an input file array and an output file array open on the CHAOS device.
+
+;;; Note: packet buffers are allocated specially as GC protected arrays
+;;;    to allow interrupts while in a PKTIOT call.
+
+;;; TODO:  Make %CHAOS-ALLOCATE-BUFFER more clever for subsequent allocations
+;;;        Fix up OPEN and CLOSE routines
+
+;;; Insert CHAOS network definitions and FASL defs.
+
+IF1, .INSRT SYSTEM;CHSDEF >
+IF1, .INSRT LISP;.FASL DEFS
+.FASL
+
+VERPRT LCHNSP
+
+; note: this form of syscal does not allow LH stuff in last arg, e.g. indirect bit, etc.
+DEFINE SYSCAL NAME,ARGS
+	.CALL [SETZ ? SIXBIT/NAME/ ? ARGS ((SETZ))]
+	 .LOSE 1000
+TERMIN
+
+;;; (%CHAOS-OPEN-CHANNELS <receive-window-size>)
+;;; Creates the a pair of file arrays, returns a cons of them, and
+;;; a CHAOS connection is created in the ITS NCP by a call to CHAOSO.
+;;; <receive-window-size> is optional and defaults to the value of
+;;; CHAOS-DEFAULT-RECEIVE-WINDOW.
+;;; Note: this cons must be saved to protect the file arrays from GC.
+
+;.SXEVAL (SETQ CHAOS-DEFAULT-RECEIVE-WINDOW 5.)
+
+.ENTRY %CHAOS-OPEN-CHANNELS LSUBR 001002	;lsubr 0 or 1 arg
+	SKIPE T			;if no args, use the default
+ 	 SKIPA TT,@(P)		;pick up arg 1
+	  MOVE TT,@.SPECIAL CHAOS-DEFAULT-RECEIVE-WINDOW
+	ADD P,T			;clean up the pdl
+	PUSH FXP,TT		;save window size on the fxpdl
+	MOVE TT,[SIXBIT /CHAOS/]	;get a file array on the CHAOS device
+	PUSHJ P,ALFILE		;allocate a channel
+	 JRST OPNLOS		;couldn't get it
+	PUSH P,A		;save this file array
+	MOVE TT,[SIXBIT /CHAOS/]	;get another file array on the CHAOS device
+	PUSHJ P,ALFILE		;allocate again
+	 JRST OPNLO1		;couldn't
+	HLLZ TT,TTSAR(A)	;pick up the LH of the TTSAR
+	TLO TT,TTS.IO		;set the output bit
+	HLLM TT,TTSAR(A)	;store it
+	MOVE B,A		;save the output array in B
+	POP P,A			;get back the input array into A
+	POP FXP,R		;get the receive window size in R
+	MOVEI TT,F.CHAN		;index into the file array channel number slot
+	SYSCAL CHAOSO,[	@TTSAR(A) ? @TTSAR(B) ? R] ; in, out, rcv window
+	JCALL 2,.FUNCTION CONS	;return a cons of the file arrays
+
+OPNLO1:	POP P,A
+OPNLOS:	POP FXP,TT
+	SETZ A,
+	POPJ P,
+
+;;; (%CHAOS-CLOSE-CHANNELS <connection>)
+;;; Takes a cons which is a connection as returned by %CHAOS-OPEN-CHANNELS.
+;;; Forces output and closes the channels, but does not send a CLS packet
+;;; (do this first if the connection should be closed cleanly).
+;;; Note: this routine has to be fixed up to allow LISP I/O to work.
+
+.ENTRY %CHAOS-CLOSE-CHANNELS SUBR 0002	;subr 1 arg
+	MOVEI TT,F.CHAN		;index into the file array channel slot
+	HRRZ B,(A)		;B gets the CDR (output file array)
+	HLRZ A,(A)		;A gets the CAR (input file array)
+	.CALL [	SETZ ? 'FINISH ? SETZ @TTSAR(B) ]	;force out any queued packets
+	JFCL			;no-op if this fails (connection was closed)
+	.CALL [	SETZ ? SIXBIT/CLOSE/ ? SETZ @TTSAR(A) ]
+	JFCL
+	.CALL [	SETZ ? SIXBIT/CLOSE/ ? SETZ @TTSAR(B) ]
+	JFCL
+; should we bother to turn on the close bit in the file arrays? so channels get reused
+	POPJ P,
+
+;;; (%CHAOS-EOF <connection>)
+;;; Sends a %COEOF packet.
+
+.ENTRY	%CHAOS-EOF SUBR 0002	;subr of 1 arg
+	MOVE TT,.SPECIAL CHAOS-INTERNAL-PKT-BUFFER	;pointer to pk buffer ttsar
+	HRRZ TT,TTSAR(TT)	;pointer to actual data area (array is GC protected).
+	MOVEI T,%COEOF		;set the packet opcode to RFC
+	DPB T,[$CPKOP (TT)]
+	SETZ T,			;0 byte count
+	DPB T,[$CPKNB (TT)]
+	HRRZ A,(A)		;get output file array
+	MOVE B,-2(TT)		;get pointer to the asar of the packet array
+	JCALL 2,.FUNCTION %CHAOS-PKTIOT	;send the packet
+
+;;; (%CHAOS-PKTIOT <file array> <packet array>)
+;;; <file array> is a file array open on the CHAOS device.
+;;; <packet array> is an array pointer to a GC protected array.
+;;; Thus it is usually passed one of the buffers created by %CHAOS-ALLOCATE-BUFFER.
+;;; If an IOC error occurs, a THROW will be done to CHAOS-PKTIOT-ERROR.
+
+.ENTRY %CHAOS-PKTIOT SUBR 0003	;subr 2 args
+	PUSH FXP,D		;don't clobber D
+	MOVEI D,IOTLOS
+	JSP T,SPECBIND		;bind the IOCINS location
+	 D_5,,IOCINS
+	POP FXP,D
+	MOVEI TT,F.CHAN
+PKIOTC:	SYSCAL PKTIOT,[@TTSAR(A) ? TTSAR(B)]
+	JRST UNBIND		;unbind IOCINS
+
+;;; Ioc error interrupt routine for the PKTIOT
+
+IOTLOS:	HRRI R,PKTLS1		;process the error here
+	HRLI R,PKTERR
+	TLO R,400000
+	AOS (FLP)
+	POPJ FLP,		;YES, its FLP!!!! (super crock...)
+PKTERR:	0
+
+;;; This is called at non interrupt level. Error code in CHAOS-PKTIOT-ERROR-CODE
+
+PKTLS1:	UNLOCKI
+	MOVE TT,PKTERR		;pick up the error code
+	JSP T,FXCONS		;make a fixnum (guaranteed to be an inum, so no GC)
+	MOVEM A,.SPECIAL CHAOS-PKTIOT-ERROR-CODE
+	MOVEI A,.ATOM CHAOS-PKTIOT-ERROR
+	SETZ B,
+	JCALL 2,.FUNCTION *THROW
+
+;;; Allocate a GC protected, immoveable packet-buffer array
+;;; (gag, using a whole page for this poor little buffer - should
+;;;  hack something more efficient one of these days...)
+
+.ENTRY %CHAOS-ALLOCATE-BUFFER SUBR 0001	;subr 0 args
+	JSP T,SACONS		;allocate an array header
+	MOVEI TT,1		;get a page of core
+	PUSHJ P,GETCOR
+	SKIPN TT
+	 JRST [	SETZ A ? POPJ P,]
+	HRR T,TT		;stuff in array prefix info
+	HRLI T,AHEAD
+	BLT T,4(TT)
+	HRLI T,TTS<1D>+TT	;1D array, indexed by TT
+	HRLI TT,AS.FX		;fixnum type array
+	MOVEM T,TTSAR(A)
+	MOVEM TT,ASAR(A)
+	MOVEM A,-2(T)		;backward pointer in the array prefix
+	HRRM T,(TT)		;and pointer to data area.
+	POPJ P,
+
+AHEAD:	-200,,0
+	PUSHJ P,CFIX1
+	JSP T,1DIMF
+	0
+	200
+
+;;; might as well do this at load time...
+.SXEVAL (SETQ CHAOS-INTERNAL-PKT-BUFFER (%CHAOS-ALLOCATE-BUFFER))
+
+	
+;;; (%CHAOS-REQUEST-CONNECTION <connection> <destination host> <contact-name>
+;;;			 <request-or-listen-flag> <netblk-time>)
+;;; Open the chaos net channel. Arguments are:
+;;; <connection> is a cons as returned byt %CHAOS-OPEN-CHANNELS.
+;;; <destination host> is a fixnum 16 bit host address 
+;;;                    (host number + subnet number).
+;;; <contact-name> is a symbol or a list of fixnums which is considered to be
+;;;                the contact name optionally followed by a space and JCL.
+;;; <request-or-listen-flag> is T if this is a RFC or NIL if a LSN.
+;;; <netblk-time> is the amount of time to wait for a response.
+;;; Uses CHAOS-INTERNAL-PKT-BUFFER for the buffer.
+;;; Returns a connection state as a fixnum.
+
+.ENTRY %CHAOS-REQUEST-CONNECTION SUBR 0006	;subr 5 args
+	PUSH P,[FIX1]		;make it NCALLable
+	PUSH P,AR1		;save request/listen flag
+	PUSH P,AR2A		;save netblk time
+	MOVE TT,.SPECIAL CHAOS-INTERNAL-PKT-BUFFER	;pointer to pk buffer ttsar
+	HRRZ TT,TTSAR(TT)	;pointer to actual data area (array is GC protected).
+	MOVEI T,%CORFC		;set the packet opcode to RFC
+	SKIPN AR1
+	 MOVEI T,%COLSN
+	DPB T,[$CPKOP (TT)]
+	MOVE T,(B)		;get destination host number arg
+	DPB T,[$CPKDA (TT)]	;deposit it
+	SETZ T,			;zero destination index
+	DPB T,[$CPKDI (TT)]	;depost it
+	MOVEI T,(C)		;check TYPEP of contact name = SYMBOL
+	LSH T,-11		;standard hack (don't bother checking for NIL)
+	MOVE T,ST(T)		;look it up in the segment table
+	TLNE T,ST.SY		;SYMBOL?
+	 PUSHJ P,EXPSYM		;yes, go exploden it
+
+	SETZ T,			;loop for copying contact name, jcl.  T is byte cnt.
+	MOVE D,[441000,,%CPKDT(TT)]	;8-bit bytes, place to put data bytes
+CNAMLP:	HLR B,(C)		;get the car of the list (a fixnum)
+	MOVE F,(B)		;turn into a machine number
+	IDPB F,D		;deposit it into the packet
+	HRR C,(C)		;CDR the list
+	AOS T			;increment the byte count
+	JUMPN C,CNAMLP		;loop if we didn't CDR off the end of the list
+
+	DPB T,[$CPKNB (TT)]	;deposit the byte count into the packet
+	PUSH P,A		;save A (the connection)
+	HRRZ A,(A)		;get output file array
+	MOVE B,-2(TT)		;get pointer to the asar of the packet array
+	CALL 2,.FUNCTION %CHAOS-PKTIOT	;send the packet
+	POP P,A			;get A back
+	MOVEI TT,F.CHAN
+	HLRZ A,(A)		;CAR is the input file array
+	POP P,B			;get the netblk time-out time off the stack
+	POP P,C			;get request/listen flag back
+	MOVEI R,%CSRFS		;assume RFC
+	SKIPN C			;if T, then it was
+	 MOVEI R, %CSLSN	;otherwise listening
+	MOVE T,(B)		;time-out time
+	SYSCAL NETBLK,[ MOVE @TTSAR(A)	;CHAOS input channel
+			MOVE R		;current state
+			MOVE T		;time-out time
+			MOVEM TT]	;new state returned here
+	POPJ P,			;TT gets converted at FIX1 if needed
+
+;;; explode a symbol pointed to by C
+EXPSYM:	PUSH P,A		;save A, TT, AR1
+	PUSH P,TT
+	PUSH P,AR1
+	MOVEI A,(C)
+	CALL 1,.FUNCTION EXPLODEN
+	MOVEI C,(A)		;back into C
+	POP P,AR1
+	POP P,TT
+	POP P,A
+	POPJ P,
+
+;;; (%CHAOS-OPEN-CONNECTION <connection>)
+;;; Sends an OPN packet (pretty useless since easy to do with %CHAOS-PKTIOT)
+
+.ENTRY %CHAOS-OPEN-CONNECTION SUBR 0002	;subr 1 arg
+	MOVE TT,.SPECIAL CHAOS-INTERNAL-PKT-BUFFER
+	HRRZ TT,TTSAR(TT)	;get pointer to array data
+	MOVEI T,%COOPN		;OPN opcode
+	DPB T,[ $CPKOP (TT)]	;deposit it in the opcode field
+	HRRZ A,(A)		;CDR is the output file array
+	MOVE B,-2(TT)		;pointer to asar
+	JCALL 2,.FUNCTION %CHAOS-PKTIOT	;send the packet
+
+;;; MISC utility functions
+
+;;; (%CHAOS-SET-PKT-OPCODE <array> <opcode>)
+;;; Sets the opcode field in a packet buffer array pointed to by <array>.
+;;; <opcode> is a fixnum.
+
+.ENTRY %CHAOS-SET-PKT-OPCODE SUBR 0003	;subr 2 args
+	HRRZ TT,TTSAR(A)	;get pointer to array data
+	MOVE T,(B)		;get the number
+	DPB T,[$CPKOP (TT)]	;deposit it in the opcode field
+	MOVEI A,.ATOM T
+	POPJ P,
+
+;;; (%CHAOS-GET-PKT-OPCODE <array>)
+;;; Gets the opcode field in a packet buffer array pointed to by <array>.
+
+.ENTRY %CHAOS-GET-PKT-OPCODE SUBR 0002	;subr 1 arg
+	HRRZ TT,TTSAR(A)	;get pointer to array data
+	LDB TT,[$CPKOP (TT)]	;load from the opcode field
+	JSP T,FXCONS		;convert number in TT to a fixnum
+	POPJ P,
+
+;;; (%CHAOS-SET-PKT-LENGTH <array> <length>)
+;;; Sets the byte count for a packet.
+
+.ENTRY %CHAOS-SET-PKT-LENGTH SUBR 0003	;subr 2 args
+	HRRZ TT,TTSAR(A)	;get pointer to array data
+	MOVE T,(B)		;get the fixnum count
+	DPB T,[$CPKNB (TT)]	;deposit it in the byte count field
+	MOVEI A,.ATOM T
+	POPJ P,
+
+;;; (%CHAOS-GET-PKT-LENGTH <array>)
+;;; Gets the byte count for a packet.
+
+.ENTRY %CHAOS-GET-PKT-LENGTH SUBR 0002	;subr 1 arg
+	HRRZ TT,TTSAR(A)	;get pointer to array data
+	LDB TT,[$CPKNB (TT)]	;load from the byte count field
+	JSP T,FXCONS		;convert number in TT into a FIXNUM
+	POPJ P,
+
+;;; (%CHAOS-GET-BYTE <array> <index>)
+;;; Gets data byte specified by <index> from packet in <array>.
+.ENTRY	%CHAOS-GET-BYTE SUBR 0003	;subr 2 args
+	HRRZ TT,TTSAR(A)	;get pointer to array data
+	MOVE R,(B)		;get fixnum index 
+	IDIVI R,4		;compute word offset and remainder
+	ADD TT,R
+	IMULI F,8		;compute byte position
+	MOVEI T,28.
+	SUB T,F
+ 	LSH T,30.		;and position it
+	IOR T,[001000,,%CPKDT(TT)]
+	LDB TT,T
+	JSP T,FXCONS
+	POPJ P,
+
+;;; (%CHAOS-PUT-BYTE <array> <byte>)
+;;; Puts <byte> at the end of the packet and updates the packet length.
+.ENTRY	%CHAOS-PUT-BYTE SUBR 0003	;subr 2 args
+	HRRZ TT,TTSAR(A)	;get pointer to array data
+	LDB R,[$CPKNB(TT)]	;get the number of bytes
+	MOVEI T,1(R)
+	DPB T,[$CPKNB(TT)]	;increment and redeposit
+	IDIVI R,4		;compute word offset and remainder
+	ADD TT,R
+	IMULI F,8		;compute byte position
+	MOVEI T,28.
+	SUB T,F
+ 	LSH T,30.		;and position it
+	IOR T,[001000,,%CPKDT(TT)]
+	MOVE R,(B)
+	DPB R,T
+	MOVEI A,.ATOM T
+	POPJ P,
+
+FASEND
diff --git a/src/l/purep.5 b/src/l/purep.5
new file mode 100755
index 00000000..a9c2d1ea
--- /dev/null
+++ b/src/l/purep.5
@@ -0,0 +1,27 @@
+;-*-MIDAS-*-
+TITLE PUREP/WRITEABLEP
+.insrt sys:.fasl defs
+.fasl
+
+; This is a file with two primitives, WRITEABLEP and PUREP
+; Note labels 'purep' and 'writeablep' exist only for the sake of TAGS
+
+.entry PUREP SUBR 002
+purep:	hrrz tt,a		   ;find the entry in the segment table
+	lsh tt,-seglog
+	move tt,st(tt)		   ;(we want the left half too)
+	tlnn tt,st.pur
+	  jrst false
+true:	movei a,.atom T
+	popj p,
+
+.entry WRITEABLEP SUBR 002
+writeablep:	hrrz tt,a
+	lsh tt,-12
+	.call [setz ? sixbit /CORTYP/ ? tt ? %clout,,tt ((SETZ)) ]
+	  caia
+	jumpl tt,true
+false:	setz a,
+	popj p,
+
+FASEND
\ No newline at end of file
diff --git a/src/libdoc/bs.jonl9 b/src/libdoc/bs.jonl9
new file mode 100755
index 00000000..e2d9001d
--- /dev/null
+++ b/src/libdoc/bs.jonl9
@@ -0,0 +1,105 @@
+;;; -*-lisp-*-
+
+;Debugging Aids - BS, FS, B-BS  help in looking back the stack - see below.
+;		- TIMIT and NTIMIT are little timers.  Say "(TIMIT foo)"
+;		  to get the execution time of "foo" in microseconds; saying
+;		  "(NTIMIT n foo)" will minimize over n trials.
+
+
+;;;Variable "BS" holds a current frame.  One can use it in order to
+;;;  direct EVALFRAME to go back down the PDL, or forward up the PDL.
+;;;  [pdls push upwards, and pop downwards]
+
+;;; Basic two functions are "BS", and "FS", which are acronymic for 
+;;;   "Back-down-the-Stack", AND "Forward-up-the-Stack".  See below
+
+;;; Function "B-BS" will run a break loop in the environment indicated 
+;;;   by the frame in "BS"
+
+
+(DECLARE (*FEXPR TIMIT NTIMIT BS FS)
+	 (*EXPR B-BS)
+	 (SPECIAL BS TIMIT)
+	 (FLONUM (TIMIT)))
+
+
+(DEFUN BS FEXPR (L)
+;;;Go back one frame by (BS)
+;;;Go back N frames by (BS <N>)  where <N> is an integer
+;;;Go back to application of function BAR by (BS BAR)
+;;;Go back to nth application back of BAR with (BS BAR <N>)
+;;;Initialize BS to top [current] frame and then go back by
+;;;  saying (BS NIL), (BS NIL <N>), (BS NIL BAR), or (BS NIL BAR <N>)
+    (DECLARE (FIXNUM I N))
+    (SETQ BS (COND ((AND L (NULL (CAR L))) 
+		    (SETQ L (CDR L))
+		    (EVALFRAME NIL))
+		   ((AND BS (FIXP (CADR BS))) (EVALFRAME (CADR BS)))
+		   (T (EVALFRAME NIL))))
+    (COND ((NULL L) BS) 
+	  (T (DO ((Z BS (EVALFRAME (CADR Z)))
+		  (I (COND ((FIXP (CAR L)) (CAR L)) (-1)) (1- I))
+		  (N (COND ((AND (CDR L) (FIXP (CADR L))) (CADR L)) (1))))
+		 ((OR (NULL Z) 
+		      (ZEROP I)
+		      (COND ((> I 0) NIL) 
+			    ((NOT (EQ (CAADDR Z) (CAR L))) NIL)
+			    ((ZEROP (SETQ N (1- N))))))
+		  (SETQ BS Z))))))
+
+(AND (NOT (BOUNDP 'BS)) (SETQ BS NIL))
+
+
+(DEFUN FS FEXPR (TEM)
+;;;Go forward [up] one frame by (FS)
+;;;Go forward N frames by (FS <N>)
+;;;Initialize to bottom of PDL, and go forward by 
+;;;	(FS NIL) OR (FS NIL <N>)
+  (COND ((AND TEM 
+	      (NULL (CAR TEM))
+	      (SETQ BS (EVALFRAME 0))
+	      (NULL (CDR TEM)))
+	   BS)
+	((AND BS 
+	      ((LAMBDA  (Z)
+			(AND Z
+			     (NUMBERP (SETQ Z (CADR Z))) 
+			     (> Z (CADR BS))))
+		(EVALFRAME NIL)))
+	  (DO I (COND (TEM (CAR TEM)) (1)) (1- I) (NOT (> I 0)) 
+	      (DECLARE (FIXNUM I))
+		(SETQ BS (EVALFRAME (- (CADR BS)))))
+	   BS)))
+
+
+(DEFUN B-BS NIL (EVAL '(BREAK B-BS) (CADDDR BS)))
+
+
+;(COMMENT ## HELPS USE RUNTIMER)
+
+(SETQ TIMIT 0)			;THE OVERHEAD CONSTANT
+
+(defun TIMIT FEXPR (l)		
+    ;;To time the computation (FOO X), do (TIMIT (FOO X))
+   (let ((n (runtime)))
+     (eval (car l))
+     (//$ (float (- (runtime) n timit)) 1.0E6)))
+
+(defun NTIMIT FEXPR (l)
+    (declare (fixnum n) (flonum f s))
+    (do ((n (fix (car l)) (1- n))
+	 (s 0.0) 
+	 (f 1.0E35)) 
+	((zerop n) f)
+      (and (< (setq s (subrcall T #,(get 'TIMIT 'FSUBR) (cdr l))) f)
+	   (setq f s))))
+
+(lap-a-list '((lap |timit-nop/|| subr)
+	      (popj p)
+	      () ))
+ 
+(let (NOUUO *RSET) 
+  (timit nil)		;SNAP LINKS?
+  (setq timit (fix (times 1.0e6 (ntimit 10. (|timit-nop/|| 'T))))))
+
+
diff --git a/src/libdoc/gprint.rcw3 b/src/libdoc/gprint.rcw3
new file mode 100755
index 00000000..e27abf08
--- /dev/null
+++ b/src/libdoc/gprint.rcw3
@@ -0,0 +1,1700 @@
+;-*- Mode:LISP; Package: (GPRINT GLOBAL 1000) ; base:10.; -*-
+
+;The master version of this file is oz:<dick.pgms>gprint.lsp.  Changes can
+;only be made through requests to BUG-GPRINT
+
+;This file implements a pretty printer.  All bugs and suggestions should
+;be sent to BUG-GPRINT@MIT-OZ.  all internal functions and symbols are
+;in the package GPRINT on lispm.
+
+;The basic documentation for this GPRINT is in MIT/AIM-611a.  The documentation
+;in this file is only of an internal nature and does not duplicate that
+;documentation.
+
+#M(herald gprint)
+#M(declare (macros nil) (fixnum i j k spaces default-spaces indent max))
+#Q(eval-when (eval load compile)
+    (mapc #'globalize   ;note user may have typed one of these already.
+	   '(Gcheckrecursion prinmode prinlevel prinlength prinendline
+	     miser-width major-width prinstartline prinmargin
+	     Gfn-format Gapply-format Gforce-mores Gshow-errors
+	     grind-macroexpanded Gsymbol-car-format Gnon-symbol-car-format
+	     Gspecial-formatters Glist-formatters Garray-formatters
+	     Goverriding-list-formatters Gatom-pcode Gprinlevel-abbrev
+	     Gset-up-printer Gprint1 Gprintc Gprint Gexplode Gexplodec
+	     deformat Gformat Gcheck-indentation Gdispatch
+	     GF-next GF-next-period GF-initial Ginspecting Gloc |gf-var|
+	     plp pl GF GQ defGF Gfunction)))
+
+;These are the basic user control variables (see aim611a).
+
+(defvar GRIND-MACROEXPANDED nil)
+#M(defvar PRINLEVEL)
+#M(defvar PRINLENGTH)
+(defvar GSHOW-ERRORS nil "T/NIL controls GPRINT's error handling")
+(defvar GFORCE-MORES T "T/NIL always forces mores when GPRINTing")
+(defvar PRINENDLINE 4 "+#/NIL truncates GPRINTing after # lines")
+(defvar PRINSTARTLINE nil "+#/NIL GPRINTing is supressed before # line")
+(defvar PRINMARGIN nil "+#/NIL the right margin for printing")
+(defvar MISER-WIDTH 40 "Misering starts when there is less than this width")
+(defvar MAJOR-WIDTH 20 "Major units left shift if there isn't this much width")
+(defvar GCHECKRECURSION T "T/NIL causes GPRINT to check for circularity")
+(defvar PLP-PROPERTIES '(:function :value) "the properties printed by PLP")
+(defvar GSPECIAL-FORMATTERS nil "list of format fns for arbitrary things")
+#M(defvar GHUNK-FORMATTERS nil "list of format fns for hunks")
+(defvar GARRAY-FORMATTERS nil "list of format fns for arrays")
+(defvar GPRINT-ARRAY-CONTENTS T "T/NIL causes GPRINTing of array contents")
+(defvar GOVERRIDING-LIST-FORMATTERS nil "list of format fns for lists")
+(defvar GLIST-FORMATTERS nil "list of format fns for lists")
+(defvar GSYMBOL-CAR-FORMAT ':G1Tblock "format for atom car data lists")
+(defvar GNON-SYMBOL-CAR-FORMAT ':G1Tblock "format for non-atom car data lists")
+(defvar GAPPLY-FORMAT ':Gapply-format "format for literal LAMBDA applications")
+(defvar GFN-FORMAT ':Gfn-format "format for function applications")
+;The following describes some internal system variables.  You should
+;never ever change any of their values.  The system rebinds all of
+;these variables so that it is reentrant.  It will work right if you
+;use it to print something when it was interrupted in the middle of
+;printing something else.
+
+(defvar GPRINLEVEL-ABBREV #M'|#| #Q'|**| "the thing to print when abbreving")
+(defvar PLP nil "saves the last argument to the fn PLP")
+#M(defvar ^R) #M(defvar ^W) #M(defvar OUTFILES) #M(defvar TYO)
+#Q(declare (special TERMINAL-IO STANDARD-OUTPUT))
+(defvar GSUGGESTED-FORMAT)
+(defvar GINSPECTING NIL "FN if creating locatives for inspector.")
+ ;   to use this with the inspector bind this to the locative 
+ ;   notification function (fn #/(-#/)-atom locative atom-p) and Gloc
+ ;   to an appropriate top level locative and call Gprint!
+(defvar GLOC nil "Locative for current thing being dispatched.")
+
+;These encode the arguments and environment input to
+;the fn GFORMAT-OBJ.  They control the form of the printing process.
+
+(defvar GPRINLEVEL) (defvar GPRINLENGTH) 
+(defvar GPRINENDLINE) (defvar GPRINSTARTLINE) 
+ ;   +# - these reflect the values of the corresponding user control variables.
+ ;   They are kept seperate for 2 reasons.  1- it is easier to deal
+ ;   with them because they are always numbers.  2- they are insulated
+ ;   from any changes to the user control variables during a single
+ ;   call to the printer.
+(defvar GATOM-PCODE)
+ ;   :PRIN1/:PRINC - specifies how to print atoms encountered in
+ ;   the object printed.
+(defvar GEXPLODING)
+ ;   If non nil, then this keeps a growing list of the result
+ ;   created when the printer is used to explode something instead of
+ ;   print it.
+(defvar GOUT)
+ ;   This specifies where the output is going to go.
+(defvar Gmainfile)
+ ;   This is the primary output (on the Lispm this is the same as GOUT).
+(defvar GLINELEN)
+ ;   +# - the line length of the output device minus 5.  (This
+ ;   reduction is a fudge factor that leaves room for trailing parens.)
+(defvar GINITIAL-CHARPOS)
+ ;   +# - this is the character position where printing
+ ;   is to begin.  The printer will NEVER go left of this position
+ ;   while printing.
+(defvar GNOWPRINTING nil "T if GPRINT is in operation")
+ ;   T/NIL - if T this signifies that the printer is being reentered.
+(defvar |gf-var| nil "used by the formatters made with GF")
+
+;These variables are used to control the fn Gredo.
+(defvar GABBREVED)
+ ;   T/NIL - this is set to T if the object being printed was
+ ;   abbreviated in any way.
+(defvar GTRUNCATED nil)
+ ;   If GABBREVED is T, then this variable is set to record
+ ;   the state of the printing process so that it can be continued, or
+ ;   redone.  Note that this information for an incomplete print will
+ ;   be saved until another incomplete print occures.
+
+;These variables are used when checking for circularity.
+(defvar GPARENTS nil)
+ ;   Array - this is used to remember the objects which have beed
+ ;   visited already.  It acts as a stack.
+(defvar GRPTR)
+ ;   +#/-1 - this points to the top of the above stack.  It is
+ ;   repeatedly bound and unbound as well as incremented, so that the
+ ;   stack pushes and pops in occordance with the nested structure of
+ ;   the object being printed.
+;Next there are several variables which are used by GQ as it queues up
+;the stuff to be printed.  Primary amoung these is the queue itself.
+;Note that by managing storage in this queue itself, the printer does
+;virtually no consing at all under normal operation.
+(defvar GQUEUE nil)
+ ;   array - this holds a queue of the formatting entries as they
+ ;   are produced.  The queue holds three pieces of information about
+ ;   each entry.  (note that there are special macros below to make
+ ;   referencing these fields more mnemoinic.)
+ ;1. Gtype - :START/:END/:PRIN1/:PRINC/:SPECIAL/:SPACE/:TAB/:IND/:NEWLINE/:EVAL
+ ;    this specifies the type of the entry.
+ ;2. Gobj - some item of information.  what it means depends on the type.
+ ;    :START NIL - ignored
+ ;    :END NIL - ignored.
+ ;    :PRIN1 - object to prin1.
+ ;    :PRINC - object to princ.
+ ;    :SPECIAL - object to princ, but not counted as part of the number of
+ ;               items printed at this level.
+ ;    :SPACE # - Number of spaces to print if not at end of a line.
+ ;    :TAB +#/NIL - the tab size (estimated by the system if NIL).
+ ;    :IND #/NIL - Amount to change the indentation in this substructure.
+ ;          (Computed based on the next item in the substructure if NIL.)
+ ;    :NEWLINE :ALWAYS/:NORMAL/:BLOCK/:MISER - (says when to newline).
+ ;    :EVAL - a sexpr which is evaluated.  the printer first makes sure that
+ ;            all pending output is performed and then evaluates the sexpr.
+ ;            This makes it possible for you to make free form extensions to
+ ;            the printer.  However, you should realize that you are playing 
+ ;            with fire if you do this.
+ ;3. Gsize #/NIL - the print length of the associated structure or NIL if this 
+ ;    length is not known.  (In general printing will be delayed until the
+ ;    length is known.)  For :PRINC, :PRIN1, :SPECIAL, :SPACE
+ ;    this is just the print size of the object.  For :END, :TAB then
+ ;    this is set to 0 and is just ignored.  For :START this starts out
+ ;    as NIL indicating that the print length is unknown, and is set to
+ ;    the length of the whole substructure when the corresponding end
+ ;    is reached.  For :NEWLINE, if the obj is :ALWAYS or :NORMAL then
+ ;    the size is set to 0 and ignored.  If the obj is
+ ;    :BLOCK, then it starts as NIL, and is not updated to the
+ ;    corrected size until the size of the :PRINC, :PRIN1, :SPECIAL,
+ ;    :SPACE, :END, :START following it is known.
+(defvar GQL)
+ ;   +# - this points to the next entry to dequeue
+(defvar GQR)
+ ;   +# - this points to the spot where the next entry should be put
+ ;   (the queue is empty when (= GQL GQR)).
+(defvar GTSIZE)
+ ;   +# - the total size of everything in GQUEUE up to GQR.
+(defvar GLSIZE)
+ ;   +# - the total size of everything in GQUEUE up to GQL (ie
+ ;   everything that has been poped off).  The total size of the stuff
+ ;   that is queued but not yet processed is (- GTSIZE GRSIZE).
+(defvar GQS nil)
+ ;   array - this holds things you need to remember while the subparts
+ ;   of a structure are being queued up.  
+ ;1. Gbegin +#/-1 - the place in Gq where the corresponding substructure starts
+ ;            (-1 if this spot is no longer in the queue.)
+ ;2. Glevel +# - the depth of this structure in the overall structure. (note
+ ;            that start entries with indentations of 0 are not
+ ;            counted)  (This is used to control PRINLEVEL abbreviation.)
+ ;3. Glength +# - the number of PRIN1, PRINC, and substructure items in this
+ ;             substructure so far.  (this is used to control PRINLENGTH
+ ;             abbreviation.) 
+ ;4. Gsave-Gtsize +# - a saved value of Gtsize.  (Used when computing
+ ;                     the actual length of a substructure.)
+(defvar GQSP)
+ ;   +# - stack pointer for GQS.
+
+;Then there are a group of variables that hold the state of the output
+;actually being produced.
+
+(defvar GLINENO)
+ ;   +# - this counts the lines printed, with the
+ ;   line the print was initiated on as line 0.  (Therefore the first
+ ;   line printed by a Gprint1 is line 0 and the first one printed by a
+ ;   Gprint is line 1.)
+(defvar GFREELEN)
+ ;   +# - this keeps track of how much space is left at the end
+ ;   of the current line.  The charcter position is (- GLINELEN GFREELEN).
+(defvar GPENDING)
+ ;   +# - this is the number of spaces (caused by (GQ ':SPACE #)
+ ;   and (GQ ':TAB #) requests) which have been logically
+ ;   printed, but have not actually been printed yet.  They will not be
+ ;   printed until some non blank object must be printed, and their
+ ;   printing will be aborted if a new line is forced before then.  (Ie
+ ;   trailing blanks are never printed.)
+(defvar GPENDING-NEWLINE)
+ ;   T/NIL - if T then a new line must be done before
+ ;   anything more can be printed out.  It will not actually be done
+ ;   until some non blank thing has to be printed.
+(defvar GWENT-UP)
+ ;   This is T if and only if more structures have been exited than entered
+ ;   on the current line.  
+(defvar GDEPTH)
+ ;   This records the relative depth of the item on the top of the queue
+ ;   in the most deeply embedded structure which has been broken up
+ ;   accross multiple lines.
+ ;      As an example of this consider the following:
+ ;   (A (B
+ ;       C -1- D) (E -2- F))
+ ;   Suppose that the printer is at the point marked "-1-" in printing out 
+ ;   the above.  At that moment, GDEPTH=0, GWENT-UP=NIL.
+ ;   At the point "-2-" GDEPTH=1, GWENT-UP=T.
+
+(defvar GPS nil)
+ ;   array - this is a stack which is used to hold information that
+ ;   must be remebered when the printout fn goes down a level and
+ ;   breaks up a substructure.  It has two coponents:
+ ;1. Gtabsize +#/-1 - the appropriate tab size to use.  (-1 if not yet known.)
+ ;2. Gpindent +# - the appropriate indentation to use for the next thing.
+(defvar GPSP)
+ ;   +# - this is the stack pointer for GPS.
+(defvar GF-ARGS)
+ ;   This is used by the macro GF.
+
+;an important issue to note is that on the LISPM, at least Gqueue, Gqs, Gps, 
+;Gparents, and Gtruncated should be bound seperately in each lisp listener.
+;in fact probably many of the other control variables probably should be too.
+;The problem is that as things stand now, they aren't bound anywhere!
+
+;For debugging, this lets you see easily what is in the various vectors
+
+(eval-when (eval)
+  (defun sq ()
+    (terpri) (princ '|type            obj     size|)
+    (do ((i gql (1+ i))
+	 (k 0 (cond ((zerop k) 2) (t (1- k)))))
+	((= i (+ gqr 3)))
+	(cond ((zerop k) (terpri)))
+	(prin1 (arraycall nil Gqueue i))
+	(cond ((zerop k) (princ '|     |)))
+	(tyo #M9. #Q137.)))
+  (defun sqs ()
+    (print `(Gtsize ,Gtsize Glsize ,Glsize Grptr ,Grptr))
+    (terpri) (princ '|begin   level   length  tsize|)
+    (do ((i 0 (1+ i))
+	 (k 0 (cond ((zerop k) 3) (t (1- k)))))
+	((= i (+ Gqsp 4)))
+	(cond ((zerop k) (terpri)))
+	(prin1 (arraycall fixnum Gqs i)) (tyo #M9. #Q137.)))
+  (defun sps ()
+    (print `(Glineno ,Glineno Gfreelen ,Gfreelen Gdepth ,Gdepth Gwent-up
+	     ,Gwent-up Gpending ,Gpending Gpending-newline ,Gpending-newline))
+    (terpri) (princ '|tab     indent|)
+    (do ((i 0 (1+ i))
+	 (k 0 (cond ((zerop k) 1 ) (t (1- k)))))
+	((= i (+ Gpsp 2)))
+	(cond ((zerop k) (terpri)))
+	(prin1 (arraycall fixnum Gps i)) (tyo #M9. #Q137.))))
+
+;these macros just make accessing the above things easier.
+
+(defun Gtype macro (body) `(Gaccess .,body))
+(defun Gobj macro (body) `(Gaccess .,body))
+(defun Gsize macro (body) `(Gaccess .,body))
+(defun Gbegin macro (body) `(Gaccess .,body))
+(defun Glevel macro (body) `(Gaccess .,body))
+(defun Glength macro (body) `(Gaccess .,body))
+(defun Gsave-Gtsize macro (body) `(Gaccess .,body))
+(defun Gtabsize macro (body) `(Gaccess .,body))
+(defun Gpindent macro (body) `(Gaccess .,body))
+
+(defun Gaccess macro (whole-body)
+ (let ((body (cdr whole-body)))
+  (displace body
+   (let* ((field (car body))
+	  (vect (caseq field
+		  ((Gtype Gobj Gsize) 'Gqueue)
+		  ((Gbegin Glevel Glength Gsave-Gtsize) 'Gqs)
+		  ((Gtabsize Gpindent) 'Gps)
+		  (T (error '|GACCCESS -- bad field name| body))))
+	  (type (cdr (assq vect '((Gqueue)(Gqs . fixnum)(Gps . fixnum)))))
+	  (offset (cdr (assq field '((Gtype . 0)(Gobj . 1)(Gsize . 2)
+				     (Gbegin . 0)(Glevel . 1)
+				     (Glength . 2)(Gsave-Gtsize . 3)
+				     (Gtabsize . 0)(Gpindent . 1)))))
+	  (index (cond ((null (cdr body))
+			(cdr (assq vect '((Gqueue . Gql)(Gqs . Gqsp)
+					  (Gps . Gpsp)))))
+		       (T (cadr body))))
+	  (spot (cond ((zerop offset) index)
+		      ((equal index 0) offset)
+		      (T `(+ ,index ,offset)))))
+     `(arraycall ,type ,vect ,spot)))))
+
+(defun Gpush macro (body)
+ (displace body
+  (let* ((vector (cadr body))
+	 (info (cdr (assq vector '((Gqueue Gqr 3. nil)(Gqs Gqsp 4. fixnum)
+				   (Gps Gpsp 2. fixnum))))))
+    `(cond (;note that it is vital that the dimension is congruent to
+	    ;zero mod the step size so that this test actually works.
+	    (not (> (array-dimension-n 1 ,vector)
+		    (setf ,(car info) (+ ,(car info) ,(cadr info)))))
+	    (*rearray ,vector ',(caddr info)
+		      (+ ,(car info) ,(* (cadr info) 20.))))))))
+
+(defun Gpop macro (body)
+ (displace body
+  (let* ((vector (cadr body))
+	 (info (cdr (assq vector '((Gqueue Gql -3.)(Gqs Gqsp 4.)
+				   (Gps Gpsp 2.))))))
+    `(progn (setf ,(car info) (- ,(car info) ,(cadr info)))
+	    (cond ((minusp ,(car info))
+		   (error "Too many }s in format")))))))
+
+;this is for lisp machine compatability
+#M
+(defun Glinel macro (body) (displace body `(linel ,(cadr body))))
+#Q
+(defun Glinel macro (body) 
+  `(cond ((memq ':size-in-characters
+		(funcall ,(cadr body) ':which-operations))
+	  (funcall ,(cadr body) ':size-in-characters))
+	 (T 94.)))
+
+#M
+(defun Gcursorpos macro (body)
+  (displace body
+   `(cond ((memq 'cursorpos (status filemode ,(car (last body))))
+	   (cursorpos .,(cdr body))))))
+#Q
+(defun Gcursorpos macro (body)
+  (cond ((null (cddr body))
+	 `(cond ((memq ':read-cursorpos
+		       (funcall ,(cadr body) ':which-operations))
+		 (multiple-value-bind (x y)
+		     (funcall ,(cadr body) ':read-cursorpos ':character)
+		   (cons y x)))))
+	(T `(cond ((memq ':set-cursorpos
+			 (funcall ,(car (last body)) ':which-operations))
+		   (cursorpos .,(cdr body)))))))
+
+#M
+(defun Gcharpos macro (body) (displace body `(charpos ,(cadr body))))
+#Q
+(defun Gcharpos macro (body) `(or (cdr (Gcursorpos ,(cadr body))) 0))
+
+#Q
+(defun *rearray macro (body)
+  `(adjust-array-size ,(cadr body) ,(cadddr body)))
+ 
+;this macros are at the center of the formatting system.  They make
+;it easy to define simple formatting functions.
+
+(eval-when (eval load compile)
+
+(defun (GF macro) (body)
+  (displace body
+    `(progn .,(GF-code (GF-group (GF-parse3 (GF-parse2 (GF-parse1 (cadr body)))
+					    (cddr body)))))))
+
+(defun (deformat macro) (body)
+  (displace body `(defun (,(cadr body) :Gformat) ,(caddr body)
+		    .,(cdddr body))))
+
+(defun (defGF macro) (body)
+  (displace body `(defun (,(cadr body) :Gformat) (|gf-var|)
+		    (GF ,(caddr body) |gf-var|))))
+
+(defun (Gfunction macro) (body)
+  (displace body `(function (lambda (|gf-var|) (GF ,(cadr body) |gf-var|)))))
+
+;Note must always make list of args so that dispatcher will use
+;specified format function.
+
+(defun (Gformat macro) (body)
+  (displace body
+    (let* ((file (cadr body))
+	   (template (caddr body))
+	   (args (cdddr body))
+	   (params (do ((i 0 (1+ i))
+			(l args (cdr l))
+			(res nil (cons `(nth ,i stuff) res)))
+		       ((null l) (nreverse res))))
+	   (arg (cond (args `(list ., args)) (T '(ncons nil))))
+	   (gf `(function (lambda (stuff) (GF ,template ., params)))))
+      (cond (file `(Gprint1 ,arg ,file ,gf nil nil nil nil))
+	    (T `(implode (Gexplode ,arg nil ,gf nil nil nil nil)))))))
+
+;this is an example showing how the macro expansion works.
+
+;(GF-parse1 "(*<~(*)B>)")
+;(OPEN NIL * < ~ NIL OPEN NIL * CLOSE B > CLOSE) 
+;
+;(GF-parse2 *)
+;(START IND NIL QUOTE '|(| GO-IN * < ~ NIL
+; START-SUB START IND NIL QUOTE '|(| GO-IN * GO-OUT QUOTE '|)| END END-SUB
+; B > GO-OUT QUOTE '|)| END) 
+;
+;(GF-parse3 * '(item))
+;(START IND NIL QUOTE '|(| GO-IN ITEM * (CAR |gf-var|) X < ~ NIL
+; START-SUB (CAR |gf-var|) START
+;   IND NIL QUOTE '|(| GO-IN |gf-var| * (CAR |gf-var|) X GO-OUT QUOTE '|)|
+; END END-SUB
+; X B > GO-OUT QUOTE '|)| END) 
+;
+;(GF-group *)
+;(START IND NIL QUOTE '|(| GO-IN ITEM (* (CAR |gf-var|) X < ~ NIL
+; START-SUB (CAR |gf-var|) (START IND NIL QUOTE '|(| GO-IN |gf-var| (* (CAR |gf-var|) X) QUOTE '|)| END)
+; X B >) QUOTE '|)| END) 
+;
+;(GF-code *)
+;((GQ ':START NIL)
+; (GQ ':IND NIL)
+; (GQ ':SPECIAL '|(|)
+; (LET ((|gf-var| ITEM))
+;   (PROG NIL
+;       (COND ((GF-INITIAL) (RETURN NIL)))
+;       (GDISPATCH NIL (CAR |gf-var|))
+;       (COND ((GF-NEXT) (RETURN NIL)))
+;     L (GQ ':SPACE 1)
+;       (GDISPATCH #'(LAMBDA (|gf-var|)
+;		       (GQ ':START NIL)
+;                      (GQ ':IND NIL)
+;		       (GQ ':SPECIAL '|(|)
+;		       (LET ((|gf-var| |gf-var|))
+;			 (PROG NIL
+;			    (COND ((GF-INITIAL) (RETURN NIL)))
+; 	 	 	    (GDISPATCH NIL (CAR |gf-var|))
+;			    (COND ((GF-NEXT) (RETURN NIL)))))
+;		       (GQ ':SPECIAL '|)|)
+;		       (GQ ':END NIL))
+;		    (CAR |gf-var|))
+;       (COND ((GF-NEXT) (RETURN NIL)))
+;       (GQ ':NEWLINE ':BLOCK)
+;       (GO L)))
+; (GQ ':SPECIAL '|)|)
+; (GQ ':END NIL)) 
+
+;This scans the template string and produces a sequence of tokens.
+;each command is converted to an atom (case ignored) and the
+;parameters are parsed.  Some of the commands are renamed so that
+;emacs will be happier with the file; their character codes are
+;refered to directly in octal.
+; (=50 -> open    )=51 -> close     {=173 -> start     }=175 -> end
+; [=133 -> go-in  ]=135 -> go-out   $/" -> start-sub   /" -> end-sub
+; ' -> quote      . -> period
+
+(declare (special GF-chars))
+
+(defun GF-parse1 (string)
+  (prog (GF-chars result n codes)
+      (setq GF-chars (exploden string))
+    L (cond ((null GF-chars) (return (nreverse result))))
+      (setq n (pop GF-chars))
+      (cond ((and GF-chars (= (car GF-chars) #/") (equal n #/$))
+	     (pop GF-chars)
+	     (setq n 'start-sub)))
+      (setq codes
+	    (assoc n `((#o133 GO-IN) (#o135 GO-OUT)
+		       (#o56 PERIOD) (#/< <) (#/> >)
+		       (#/P P) (#/p P) (#/C C) (#/c C)
+		       (#/S S) (#/s S) (#/I I) (#/i I)
+		       (#/' QUOTE quote-arg)
+		       (#/~ ~ number-arg) (#/T T number-arg) (#/t T number-arg)
+		       (#/* *)
+		       (#/$ $ string-arg) (#/% % string-arg) (#/& & string-arg)
+		       (start-sub START-SUB) (#/" END-SUB)
+		       (#o173 START IND number-arg) (#o175 END)
+		       (#/+ + number-arg)
+		       (#o50 OPEN START IND number-arg QUOTE '|(| GO-IN)
+		       (#o51 GO-OUT QUOTE '|)| END CLOSE)
+		       (#/A A) (#/a A) (#/! A)
+		       (#/N N) (#/n N) (#/- ~ number-arg N)
+		       (#/B B) (#/b B)
+		       (#/, ~ number-arg B) (#/; ~ NIL T number-arg B)
+		       (#/M M) (#/m M) (#/_ ~ number-arg M)
+		       (#/E E)(#/e E)
+		       (#\sp) (#\tab) (#\cr) (#\lf))))
+      (cond ((null codes) (error '|GF - unknown character| (list n string))))
+      (do ((cs (cdr codes) (cdr cs)) (c)) ((null cs))
+	(setq c (car cs))
+	(push (cond ((eq c 'quote-arg) (GFP-quote-arg n string))
+		    ((eq c 'string-arg) (GFP-string-arg n))
+		    ((eq c 'number-arg) (GFP-number-arg))
+		    (T (car cs)))
+	      result))
+      (go L)))
+
+(defun GFP-quote-arg (n string)
+  (prog (temp)
+    L (cond ((null GF-chars) (error '|GF - unmatched '| string))
+	    ((= (car GF-chars) n) (pop GF-chars)
+	     (cond ((or (null (cdr GF-chars))
+			(not (= (car GF-chars) n)))
+		    (return `',(implode (nreverse temp)))))))
+      (push (pop GF-chars) temp)
+      (go L)))
+
+(defun GFP-string-arg (n)
+  (prog (temp)
+      (cond ((= (car GF-chars) #o43) (pop GF-chars) (return '|#|)))
+    L (cond ((or (null GF-chars)
+		 (= (car GF-chars) n) (= (car GF-chars) #\space))
+	     (pop GF-chars)
+	     (return `',(readlist (nreverse temp)))))
+      (push (pop GF-chars) temp)
+      (go L)))
+
+(defun GFP-number-arg ()
+  (prog (temp)
+	(cond ((null GF-chars) (go E)))
+	(cond ((= (car GF-chars) #o43) (pop GF-chars) (return '|#|)))
+	(cond ((member (car GF-chars) '#.(exploden "-01234567890"))
+	       (push (pop GF-chars) temp))
+	      (T (go E)))
+      L (cond ((member (car GF-chars) '#.(exploden "01234567890."))
+	       (push (pop GF-chars) temp) (go L)))
+      E (return (cond (temp (readlist (nreverse temp)))))))
+
+;this takes the output list from gf-parse1 and does some second order
+;processing on it.  The sequence is checked to see that all of the
+;commands which appear in pairs are properly nested.  It checks to see
+;whether thins in parentheses have to forced into subtempaltes.
+;Commands that can only appear in certain contexts (such as <, >) are
+;checked to see that they are in the right place.
+
+(defun GF-parse2 (list)
+  (prog (result c balance)
+    L (cond ((null list) (return (nreverse result))))
+      (setq c (pop list))
+      (cond ((and (memq c '(< PERIOD)) (not (eq (car balance) 'GO-IN)))
+	     (error '|GF - < and . must be immediately in [] or ()| nil)))
+      (cond ((and (memq c '(START END)) (eq (car balance) 'GO-IN))
+	     (error '|GF - { and } unsafe immediately in [] or ()| nil)))
+      (cond ((and (memq c '(CLOSE GO-OUT END-SUB >))
+		  (not (eq c (cdr (assq (pop balance)
+					'((OPEN . CLOSE) (GO-IN . GO-OUT)
+				          (START-SUB . END-SUB) (< . >)))))))
+	     (error '|GF - unmatched brackets| c)))
+      (caseq c
+	(OPEN
+	 (cond ((Gfirst '(GO-IN OPEN) '(START-SUB) balance)
+		(push 'START-SUB result))))
+	(CLOSE
+	 (cond ((Gfirst '(GO-IN OPEN) '(START-SUB) balance)
+		(push 'END-SUB result))))
+	((QUOTE & % $ IND + ~ T) (push c result) (push (pop list) result))
+	(T (push c result)))
+      (cond ((memq c '(OPEN GO-IN START-SUB <))
+	     (push c balance)))
+      (go L)))
+
+;This returns T if it finds an element of HITS in the LIST before an element
+;of MISSES.  NIL if it doesn't find either.
+
+(defun Gfirst (hits misses list)
+  (do ((l list (cdr l)))
+      ((null l) nil)
+    (cond ((memq (car l) hits) (return T))
+	  ((memq (car l) misses) (return nil)))))
+;This passes over the token list a third time, adding in the
+;appropriate information from the args.  Each # is replaced by an arg,
+;and each thing that requires an input (ie [] P C S I % $ E) gets an
+;input.  Note that this input precedes the parameter for % and $.
+;Also note that if the format is nested inside [] then it doesn't use
+;up an input but rather an internal variable (except for E which still
+;uses an input).  The commands NEXT and NEXTP are inserted at the
+;proper points where the internal stepping variables should be
+;advanced.
+;  The length of the list stored in the variable NESTED shows how far
+;deep in [] you are.  This variable also stores saved values of period
+;which says whether or not you have encountered a period command.
+
+(defun GF-parse3 (list args)
+  (prog (period nested result c)
+    L (cond ((null list)
+	     (cond (args (error "GF - too many args" args)))
+	     (return (nreverse result))))
+      (setq c (pop list))
+      (push c result)
+      (cond ((memq c '(GO-IN P C S I * % $ START-SUB))
+	     (cond (nested (push (cond (period '|gf-var|)
+				       (T '(car |gf-var|))) result))
+		   ((null args) (error "GF - Too few args" nil))
+		   (T (push (pop args) result)))))
+      (cond ((memq c '(QUOTE & % $ IND + ~ T))
+	     (cond ((not (eq (car list) '|#|)) (push (pop list) result))
+		   ((null args) (error "GF - Too few args" nil))
+		   (T (pop list) (push (pop args) result)))))
+      (cond ((eq c 'E)
+	     (cond ((null args) (error "GF - Too few args" nil))
+		   (T (push (pop args) result)))))	     
+      (cond ((memq c '(GO-OUT END-SUB)) (setq period (pop nested))))
+      (cond ((and (memq c '(GO-OUT P C S I * % $ END-SUB)) nested (not period))
+	     (cond ((Gfirst '(PERIOD)
+			    '(GO-IN GO-OUT P C S I * % $ START-SUB END-SUB)
+			    list)
+		    (push 'XP result))
+		   (T (push 'X result)))))
+      (caseq c
+	(PERIOD (setq period T))
+	(GO-IN (push period nested) (setq period nil))
+	(START-SUB (push period nested) (setq period T)))
+      (go L)))
+
+;This groups the [] and subtemplates up into sublists.  The end marker is
+;discarded, and the entire subgroup becomes a list after the head.  Note that
+;the argument is not included and stays seperate.  Note that we already know
+;that everything matches up.
+(declare (special GF-group-list))
+
+(defun GF-group (GF-group-list) (GF-group1))
+(defun GF-group1 ()
+  (prog (result c)
+    L (cond ((null GF-group-list) (return (nreverse result))))
+      (setq c (pop GF-group-list))
+      (caseq c
+	((GO-OUT END-SUB) (return (nreverse result)))
+	((GO-IN START-SUB)
+	 (push c result) (push (pop GF-group-list) result)
+	 (push (GF-group1) result))
+	((P C S I QUOTE * & IND + ~ T)
+	 (push c result) (push (pop GF-group-list) result))
+	((% $)
+	 (push c result) (push (pop GF-group-list) result)
+	 (push (pop GF-group-list) result))
+	(T (push c result)))
+      (go L)))
+;This produces the code.  There is a simple code template for each
+;kind of command.  Note the way it recurses.
+
+(defun GF-code (list)
+  (prog (result)
+    L (cond ((null list) (return (nreverse result))))
+      (push
+       (caseq (pop list)
+	 (GO-IN `(let ((|gf-var| ,(pop list)))
+		   (prog ()
+		     (cond ((GF-initial) (return nil)))
+		     .,(GF-code (pop list)))))
+	 (X `(cond ((GF-next) (return nil))))
+	 (XP `(GF-next-period))
+	 (PERIOD 'PERIOD)
+	 (< `L)
+	 (> `(go L))
+	 (P `(GQ Gatom-pcode ,(pop list)))
+	 (C `(GQ ':princ ,(pop list)))
+	 (S `(GQ ':special ,(pop list)))
+	 (I (pop list))
+	 (QUOTE `(GQ ':special ,(pop list)))
+	 (* `(Gdispatch nil ,(pop list)))
+	 (& `(funcall ,(pop list)))
+	 (% (let ((arg (pop list)) (fn (pop list)))
+	      `(funcall ,fn ,arg)))
+	 ($ (let ((arg (pop list)) (fn (pop list))) `(Gdispatch ,fn ,arg)))
+	 (START-SUB (let ((arg (pop list)) (code (GF-code (pop list))))
+		      `(Gdispatch #'(lambda (|gf-var|) .,code) ,arg)))
+	 (START `(GQ ':start nil)) 
+	 (IND `(GQ ':ind ,(pop list)))
+	 (+ `(GQ ':ind ,(or (pop list) 1)))
+	 (END `(GQ ':end nil))
+	 (A `(GQ ':newline ':always))
+	 (N `(GQ ':newline ':normal))
+	 (B `(GQ ':newline ':block))
+	 (M `(GQ ':newline ':miser))
+	 (~ `(GQ ':space ,(or (pop list) 1)))
+	 ((T) `(GQ ':tab ,(pop list)))
+	 (E `(GQ ':eval ,(pop list)))
+	 (T (error "GF - internal bug GF-code" nil)))
+       result)
+      (go L)))   )
+
+;this implements the standard end test used in the functions produced
+;by GF.
+
+(defun GF-next ()
+#Q(setq Gloc (locf (cdr |gf-var|)))
+  (setq |gf-var| (cdr |gf-var|))
+  (cond ((null |gf-var|))
+	((not (listp |gf-var|))
+	 (GF ",{0'. '*}" |gf-var|) T)
+	((Gabbrev-length (null (cdr |gf-var|)) (car |gf-var|)))
+	(T #Q(cond (Ginspecting (setq Gloc (locf (car |gf-var|))))) nil)))
+
+;this tests whether the length abbreviation limit has been exceeded.
+
+(defun Gabbrev-length (is-last next-item)
+  (cond ((let ((len (cond ((= Gprinlevel (Glevel)) 2) (t Gprinlength))))
+	   (cond ((> (Glength) len))
+		 ((< (Glength) len) nil)
+		 ((null is-last))
+		 ((= Gprinlevel (Glevel)) nil)
+		 ((or (symbolp next-item) (numberp next-item)) nil)
+		 (T T)))
+	 (setq Gabbreved T)
+	 (GF "~'...'") T)))
+
+(defun GF-next-period ()
+  #Q(setq Gloc (locf (cdr |gf-var|)))
+    (setq |gf-var| (cdr |gf-var|)))
+
+(defun GF-initial ()
+  (cond ((not (#Mpairp #Qlistp |gf-var|)))
+      #Q(Ginspecting (setq GLoc (locf (car |gf-var|))) nil)))
+
+;this saves you from having to make a lot of declarations in MacLisp
+
+#M(cond ((fboundp '*fexpr)
+	 (*fexpr plp)
+	 (*lexpr Gprint1 Gprintc Gprint Gexplode Gexplodec)
+	 (*expr Gdispatch GQ GF-next GF-next-period GF-initial)
+	 (special Gcheckrecursion prinstartline prinendline Gatom-pcode)))
+
+;this is a macro used only on this page to make the definitions easier
+
+(defun defGprin macro (body)
+  (let ((name (cadr body))
+	(pcode (caddr body))
+	(exploding (cadddr body))
+	(print-like (cadddr (cdr body))))
+    `(defun ,name (obj &optional (file-or-stream nil)
+		                 (format nil)
+				 (Gprinlevel prinlevel)
+				 (Gprinlength prinlength)
+				 (Gprinendline prinendline)
+				 (Gprinstartline prinstartline)
+		       &aux (Gatom-pcode ',pcode)
+		            (Gexploding ,exploding))
+       (Gformat-obj ,print-like format obj file-or-stream))))
+
+;the following are the main user functions for calling the Gprinter
+;they are all in the form of a call on Gformat-obj.
+
+(defGprin Gprint1 :prin1 nil nil)
+(defGprin Gprintc :princ nil nil)
+(defGprin Gprint :prin1 nil T)
+(defGprin Gexplode :prin1 (ncons nil) nil)
+(defGprin Gexplodec :princ (ncons nil) nil)
+
+;this is an incompatable version of an obsolete function.  it is useful
+;for printing something out with no abbreviation.
+
+(defun pl (obj &optional (file-or-stream #Mnil #Qstandard-output) (format nil))
+  (Gprint obj file-or-stream format nil nil nil nil) #Q(values))
+
+;this is available for setting up the suggested printing environment. it MUST
+;BE CALLED BY THE USER if you want it to happen.
+;The next page shows the definitions of all this for the LISPM.
+#M
+(defun Gset-up-printer ()
+  (sstatus ttyint #^S 'Gprintabort)
+  (cond ((memq 'tops-20 (status features))
+	 (sstatus ttyint #^R 'Gcontinue))
+	(T (sstatus ttyint #^C 'Gcontinue)))
+  (sstatus ttyint #^P 'Greprint)
+  (setq prin1 'Gprint1))
+
+;this sets things up on the LISPM.  (see TV:KBD-ESC in
+;LMWIN;BASSTR > to learn about TV:*ESCAPE-KEYS*).
+#Q
+(cond ((not (assoc #o220 TV:*ESCAPE-KEYS*))
+       (push '(#o220 gprint:Gprintabort "Stop Gprinting" :keyboard-process)
+	     TV:*ESCAPE-KEYS*)
+       (push '(#o222 gprint:Greprint
+	       "Continue Gprinting; arg re-Gprints in full"
+	       :keyboard-process)
+	      TV:*ESCAPE-KEYS*)))
+#Q
+(defun Gset-up-printer ()
+  (setq prin1 'Gprint1))
+
+;FORMAT interface. This makes ~N (~G is taken already) be GPRINT1 and
+;~:N be GPRINTC.  Numeric pre-arguments are taken to be prinlevel, 
+;prinlength, etc.  Note there is a possible bug here if you use FORMAT NIL
+;with a long thing because you are going to get crlfs in your output.
+
+(declare (special colon-flag standard-output))
+
+(defun (#Q format: n #Q format: format-ctl-one-arg
+	             #M format-ctl-one-arg)
+    (obj args)
+  (apply (cond (#Q format: colon-flag 'Gprintc) (T 'Gprint1))
+	 (list* obj standard-output nil args)))
+
+;this function prints out parts of plists and function cells.  It fills
+;the same cultural niche as GRINDEF but is simpler and incompatable.
+;it takes in a sequence of arguments unevaluated.  each one is either
+;an atom in which case all of the properties and other aspects of the atom
+;are printed out, or a list where the car is an atom, and the cdr is a list of
+;properties to be printed (:VALUE means the value cell, :FUNCTION means the
+;function cell (most recent functional deffn for MACLISP)).  If you give it
+;no arguments at all it does whatever it did last again.
+
+(defun plp fexpr (arg)
+  (setq plp (or arg plp))
+  (prog (list arg)
+     (setq list plp)
+   L (cond ((null list) (return nil)))
+     (setq arg (pop list))
+     (cond ((cdr plp) (terpri) (princ "   ;for the symbol ")
+		      (prin1 (cond ((atom arg) arg) (T (car arg))))))
+     (let* ((symbol (cond ((atom arg) arg) (T (car arg))))
+	    (props (cond ((atom arg) plp-properties) (T (cdr arg))))
+	    (print-header (or (atom props) (cdr props)))
+	    (save))
+       (cond ((and (or (atom props) (memq ':value props)) (boundp symbol))
+	      (plp2 symbol nil (symeval symbol) 'value print-header)))
+       (cond ((and (or (atom props) (memq ':function props)) (fboundp symbol))
+	    #Q(let ((fn (fsymeval symbol)))
+		(cond ((and (listp fn) (eq (car fn) 'macro))
+		       (plp2 symbol 'macro (cdr fn) 'fncell print-header))
+		      (T (plp2 symbol 'expr fn 'fncell print-header))))
+	    #M(setq save (getl symbol '(expr fexpr macro subr lsubr fsubr)))
+	    #M(plp2 symbol (car save) (cadr save) 'prop print-header)))
+       (do ((p (plist symbol) (cddr p)))
+	   ((null p))
+	 (cond ((eq p save))
+	       ((or (atom props) (memq (car p) props))
+	        (plp2 symbol (car p) (cadr p) 'prop print-header)))))
+     (go L))
+  #Q(values))
+
+(defun plp2 (symbol prop val type print-header)
+  (cond ((and (not (eq type 'value)) (listp val)
+	      (memq (car val) '(lambda named-lambda named-subst)))
+	 (setq type (cond ((eq (car val) 'named-subst) 'defsubst) (T 'defun)))
+	 (setq val
+	  `(defun ,(cond ((eq prop 'expr) symbol) (T `(,symbol ,prop)))
+	    .,(cond ((eq (car val) 'lambda) (cdr val))
+		    (T (cddr val)))))))
+  (terpri)
+  (cond ((or (null print-header) (eq type 'defun))
+	 (Gprint1 val nil nil nil nil nil nil))
+	((eq type 'value) (Gformat T "{1';Value -'_*}" val))
+	((eq type 'fncell) (Gformat T "{1';Function cell -'_*}" val))
+	((eq type 'prop) (Gformat T "{1';'*' property -'_*}" prop val))))
+
+;this should be put on an interrupt character i.e. (sstatus ttyint 19.
+;'Gprintabort) it enables you to stop printing in the middle of
+;something.
+#M
+(defun Gprintabort (ignore ignore-ch)
+  (nointerrupt nil)
+  (or (memq 'tops-20 (status features)) (tyi tyi))
+  (cond (Gnowprinting (*throw 'Gprintabort '|aborted|))))
+
+;this allows you to continue output which was truncated because it was
+;too many lines long.  It is only intended to work for tty output
+#M
+(defun Gcontinue (ignore ignore-ch)
+  (nointerrupt nil)
+  (or (memq 'tops-20 (status features)) (tyi tyi))
+  (Gredo nil))
+#M
+(defun Greprint (ignore ignore-ch)
+  (nointerrupt nil)
+  (or (memq 'tops-20 (status features)) (tyi tyi))
+  (Gredo T))
+
+;this does the actual reprinting.  note that if you ask for a full 
+;reprinting, and you are ABOVE the place where the printing happended
+;last time, it just does the printing at the plae where you are instead
+;of going back to the old spot.
+
+(defun Gredo (all?)
+  (cond ((and Gtruncated (car Gtruncated))
+	 (let* ((initial-line (nth 0 Gtruncated))
+		(final-line (nth 1 Gtruncated))
+		(initial-charpos (nth 2 Gtruncated))
+		(mainfile (nth 3 Gtruncated))
+		(params (nth 4 Gtruncated))
+		(form (nth 5 Gtruncated))
+		(current-line (car (Gcursorpos mainfile)))
+		(start-line (cond (all? (min current-line initial-line))
+				  (T final-line))))
+	   (Gcursorpos start-line initial-charpos mainfile)
+	   (Gcursorpos 'l mainfile)
+	   (let ((Gprinlevel (cond (all? 6400.) (T (nth 0 params))))
+		 (Gprinlength (cond (all? 6400.) (T (nth 1 params))))
+		 (Gprinendline (cond (all? 6400.) (T (nth 2 params))))
+		 (Gprinstartline (cond (all? 0) (T (nth 3 params))))
+		 (Gatom-pcode (nth 4 params))
+		 (Gexploding nil))
+	     (eval form))
+	   (cond ((not (= final-line current-line)) (terpri mainfile)))
+	   (cond ((not all?)  ;so can ^P after ^C
+		  (rplaca Gtruncated initial-line)))
+	 #Q(funcall terminal-io ':refresh-rubout-handler)))))
+#Q
+(defun Ginterrupt-current-process (form)
+  (let ((p (and tv:selected-window
+		(funcall tv:selected-window ':process))))
+    (cond (p (funcall p ':interrupt 'eval form)))))
+#Q
+(defun Gprintabort (ignore)
+  (Ginterrupt-current-process
+    '(cond (Gnowprinting (*throw 'Gprintabort '|aborted|)))))
+#Q
+(defun Greprint (all?)
+  (Ginterrupt-current-process (list 'gredo all?)))
+
+;this is the main entry function into the internals of the printer.
+;it sets up the initial values of all of the internal globals and fires up the
+;format functions.
+
+(defun Gformat-obj (print-like format obj file-or-stream)
+  (setq Gprinlevel (or Gprinlevel 64000.)
+	Gprinlength (or Gprinlength 64000.)
+	Gprinendline (or Gprinendline 64000.)
+	Gprinstartline (or Gprinstartline 0.))
+#Q(cond ((null file-or-stream) (setq file-or-stream standard-output))
+	((eq file-or-stream T) (setq file-or-stream terminal-io)))
+#M(cond ((not (or (null file-or-stream) (eq (typep file-or-stream) 'list)))
+	 (setq file-or-stream (ncons file-or-stream))))
+#M(setq file-or-stream (subst tyo t file-or-stream))
+  (cond ((and print-like (null Gexploding) (not (plusp Gprinstartline))
+	      (plusp Gprinendline))
+	 (terpri file-or-stream)))
+  (let* ((Gout file-or-stream)
+         (Gmainfile #M(or (car Gout) (and ^r ^w (car outfiles)) tyo) #QGout)
+	 (initial-cursorpos (Gcursorpos Gmainfile))
+	 (Ginitial-charpos (cond (print-like 0) (T (Gcharpos Gmainfile))))
+	 (Glinelen (- (or prinmargin (Glinel Gmainfile)) Ginitial-charpos 5))
+	 (Gfreelen Glinelen)
+	 (Glineno 0)
+	 (Gpending 0)
+	 (Gpending-newline nil)
+	 (Gdepth 0)
+	 (Gwent-up nil)
+	 (Gqueue (cond (Gnowprinting (array nil nil 60.))
+		       (Gqueue)
+		       ((setq Gqueue (array nil nil 300.)))))
+	 (Gql 0)
+	 (Gqr 0)
+    	 (Gqs (cond (Gnowprinting (array nil fixnum 20.))
+		    (Gqs)
+		    ((setq Gqs (array nil fixnum 120.)))))
+	 (Gqsp 0)
+	 (Gps (cond (Gnowprinting (array nil fixnum 10.))
+		    (Gps)
+		    ((setq Gps (array nil fixnum 60.)))))
+	 (Gpsp 0)
+	 (Gparents (cond (Gnowprinting (array nil nil 10.))
+			 (Gparents)
+			 ((setq Gparents (array nil nil 50.)))))
+	 (Gabbreved nil)
+	 (Grptr -1)
+	 (Gtsize 0)
+	 (Glsize 0))
+    (setf (Gbegin) -1)
+    (setf (Glevel) 0)
+    (setf (Glength) 0)
+    (setf (Gsave-Gtsize) 0)
+    (setf (Gtabsize) -1)
+    (setf (Gpindent) 0)
+
+    (cond (#MGforce-mores
+	   #Q(and Gforce-mores
+		  (memq ':home-cursor (funcall Gmainfile ':which-operations)))
+	   (Gcursorpos 't Gmainfile)
+	   (Gcursorpos (car initial-cursorpos)
+		       (cdr initial-cursorpos)
+		       Gmainfile)))
+    (cond (Gshow-errors (Gformat-obj1 obj print-like format))
+	  ((errset (Gformat-obj1 obj print-like format)))
+	  ((errset (progn (princ '|error while GPRINTing:|) (print obj))))
+	  (T (terpri) (princ '|error while PRINTing |)
+	   #M(princ '|MUNKAM of |) #M(princ (maknum obj))))
+    (cond ((and Gabbreved (null Gexploding) initial-cursorpos)
+	   (setq Gtruncated
+		 `(,(car initial-cursorpos) ,(car (Gcursorpos Gmainfile))
+		   ,Ginitial-charpos ,Gmainfile
+		   (,Gprinlevel ,Gprinlength 64000. ,Glineno ,Gatom-pcode)
+		   (Gformat-obj nil ',format ',obj ',Gmainfile)))))
+    (cond (Gexploding (cdr (nreverse Gexploding)))
+	  (T #MT #Q(values)))))
+
+(defun Gformat-obj1 (obj print-like format)
+  (or (null (*catch 'Gprintabort
+	      (let* ((Gnowprinting T)
+		     (prin1 nil))
+		(GF "$#" obj format)
+		(cond ((or (not (zerop Gqsp)) (not (zerop Gpsp)))
+		       (error "Note enough }s in format")))
+		(cond (print-like (GF "' '"))))))
+      (setq Gabbreved T)))
+
+
+;this is a local macro used only in the next function.
+;this checks to see if any of a list of special formatters is appropriate.
+
+(defun Gselect macro (body)
+  (let ((list (cadr body)) (default (caddr body)))
+   (displace body
+    `(cond ((do ((fns ,list (cdr fns)))
+	     ((null fns) ,(cond ((null default) nil)
+				((atom default) `(,default obj))
+				(T `(funcall ,default obj))))
+	   (cond ((funcall (car fns) obj) (return T)))))))))
+
+(defmacro Ginspect-atom (form)
+  #Mform
+  #Q`(progn (cond ((and Ginspecting loc)
+		   (GQ ':eval `(funcall ',Ginspecting ',obj ',loc T))))
+	    ,form))
+
+(defmacro Ginspect (form)
+  #Mform
+  #Q`(progn (cond ((and Ginspecting loc)
+		   (GQ ':eval `(funcall ',Ginspecting #/( ',loc nil))))
+	    ,form
+	    (cond ((and Ginspecting loc)
+		   (GQ ':eval `(funcall ',Ginspecting #/) ',loc nil))))))
+
+;this is the basic dispatch routine that decides what to do based on the
+;type of the object to print.  (It takes care of depth abbreviation, and 
+;checks for circularity abbreviation.)  Special format functions can be put
+;on the variables Gspecial-formatters, Glist-formatters, Ghunk-formatters, and 
+;Garray-formatters.  They should return T when they succeed.
+;all of the standard tests are inline coded for speed.
+
+(defun Gdispatch (Gsuggested-format obj)
+  (let ((Grptr Grptr) #Q(loc Gloc) #QGloc)
+    (cond (Gcheckrecursion (setq obj (Gcheckrecursion obj))))
+    (cond ((not (or (< (Glevel) Gprinlevel) (symbolp obj) (numberp obj)))
+	   (setq Gabbreved T) (GQ ':PRINC Gprinlevel-abbrev))
+	  ((Gselect Gspecial-formatters nil))
+	  ((or (symbolp obj) (numberp obj) #Q(stringp obj))
+	   (Ginspect-atom (GQ Gatom-pcode obj)))
+	  ((listp obj)
+	   (Ginspect
+	     (cond ((Gselect Goverriding-list-formatters nil))
+		   (Gsuggested-format (funcall Gsuggested-format obj))
+		   (T (Gselect Glist-formatters
+			(let* ((head (car obj)))
+			  (cond ((symbolp head)
+				 (cond ((get head ':Gformat))
+				       ((fboundp head) Gfn-format)
+				       (T Gsymbol-car-format)))
+				((and (listp head)
+				      (memq (car head)
+					'(lambda named-lambda named-subst)))
+				 Gapply-format)
+				(T Gnon-symbol-car-format))))))))
+	#M((hunkp obj)
+	   (let* ((usrhunk (status usrhunk))
+		  (sendi (status sendi))
+		  (ops (and usrhunk (funcall usrhunk obj)
+			    (funcall sendi obj ':which-operations))))
+	     (cond ((memq ':Gformat-self ops)
+		    (funcall sendi obj ':Gformat-self obj))
+		   ((or (memq ':print-self ops) (memq 'print ops))
+		    (GQ Gatom-pcode obj))
+		   ((Gselect Ghunk-formatters Gformat-hunk)))))
+	#Q((named-structure-p obj)
+	   (cond ((let ((name (named-structure-symbol obj)))
+		    (and (symbolp name)
+			 (get name 'named-structure-invoke)
+			 (memq ':Gformat-self
+			   (named-structure-invoke obj ':which-operations))))
+		  (Ginspect (named-structure-invoke obj ':Gformat-self obj)))
+		 (T (Ginspect-atom (GQ Gatom-pcode obj)))))
+        #Q((and (or (typep obj ':entity) (typep obj ':instance))
+		(memq ':Gformat-self (funcall obj ':which-operations)))
+	   (Ginspect (funcall obj ':Gformat-self obj)))
+	  ((eq (typep obj) #M'array #Q':array)
+	   (Ginspect (Gselect Garray-formatters Gformat-array)))
+	  (T (Ginspect-atom (GQ Gatom-pcode obj))))))
+
+;this checks to see if the thing has been encountered before.
+;note lists are treated specially because they are the only data
+;structure which has a horizontal structure which can be circular.
+;(Due to the fact that each list is treated as an indivisable structure,
+;if some element of a list points to some internal cdr of a list it is
+;inside, the circularity will not be detected as soon as you might think,
+;but the printer won't blow up.)
+;Note that Gdispatch is the only place where circularity is checked.
+;if you following any pointers without calling Gdispatch on EACH new
+;structure, all bets are off circularity-wise.
+
+(defun Gcheckrecursion (thing)
+  (setq Grptr (1+ Grptr))
+  (cond ((not (< Grptr (array-dimension-n 1 Gparents)))
+	 (*rearray Gparents nil (+ Grptr 20))))
+  (store (arraycall nil Gparents Grptr) thing)
+  (cond ((Gcheckrecursion1 thing))
+	((#Mpairp #Qlistp thing) (Gcheckrecursion-list thing))
+	(T thing)))
+
+;note that this works hard so that there is no consing when there
+;is no circularity.  Note that when there is cicularity this copying
+;will confuse the inspector a little.
+
+(defun Gcheckrecursion-list (thing)
+  (do ((lst (cdr thing) (cdr lst))
+       (n 1 (1+ n)))
+      ((not (#Mpairp #Qlistp lst)) thing)
+    (let ((rec (or (Gcheckrecursion1 lst)
+		   (Gcrl1 lst thing n))))	  
+      (cond (rec (return (do ((l (cdr thing) (cdr l))
+			      (r (ncons (car thing)) (cons (car l) r))
+			      (i (1- n) (1- i)))
+			     ((zerop i)
+			      (prog1 (nreverse r) (rplacd r rec))))))))))
+
+(defun Gcrl1 (lst thing n)
+  (do ((l thing (cdr l))
+       (i n (1- i)))
+      ((zerop i) nil)
+    (cond ((eq l lst)
+	   (return (let ((*nopoint T))
+		     (intern (format nil "%~a" i))))))))
+
+(defun Gcheckrecursion1 (thing)
+  (do ((i (1- Grptr) (1- i)))
+      ((minusp i) nil)
+    (cond ((eq thing (arraycall nil Gparents i))
+	   (return (let ((*nopoint T))
+		     (intern (format nil "^~a" (- Grptr i)))))))))
+
+;this prints out a hunk in the standard MacLisp way.
+#M
+(defun Gformat-hunk (hunk)
+  (GF "{1'('")
+  (prog (j end)
+     (setq end (hunksize hunk)
+	   j (cond ((= end 1) 0) (T 1)))
+   L (GF "B*' .'" (cxr j hunk))
+     (cond ((zerop j) (return nil)))
+     (setq j (1+ j))
+     (cond ((= j end) (setq j 0)))
+     (GF "~")
+     (cond ((Gabbrev-length (= j 0) (cxr j hunk)) (return nil)))
+     (go L))
+  (GF "')'}"))
+
+;this prints out an array by printing out what is in it.  It first
+;just prints out what the normal printer would, and then prints out
+;the things inside (if GPRINT-ARRAY-CONTENTS is T), using sublists if
+;the array is multi-dimensional.  This only does fancy stuff for single and
+;double dimensioned arrays at the current time.
+
+(defun Gformat-array (array)
+  (GF "{2")
+  (GQ Gatom-pcode array)
+  (cond ((null Gprint-array-contents))
+	(T (let ((dims (arraydims array)))
+	     (and #M(memq (car dims) '(fixnum flonum T nil))
+		  (not (zerop (cadr dims)))
+		  (caseq (length (cdr dims))
+		    (1 (Gformat-array-1 array dims))
+		    (2 (Gformat-array-2 array dims)))))))
+  (GF "}"))
+
+(defun Gformat-array-1 (array dims)
+  (GF "' contains'-")
+  (cond ((not (< (Glevel) Gprinlevel))
+	 (setq Gabbreved T)
+	 (GQ ':PRINC Gprinlevel-abbrev))
+	(T (GF "{1'['")
+	   (prog (j end type)
+	       (setq type (car dims)
+		     end (1- (cadr dims))
+		     j 0)
+	     L #Q(cond (Ginspecting (setq Gloc (locf (aref array j)))))
+	       (GF "TB*" #Q(aref array j)
+		         #M(caseq type
+			     (fixnum (arraycall fixnum array j))
+			     (flonum (arraycall flonum array j))
+			     (T (arraycall nil array j))))
+	       (setq j (1+ j))
+	       (cond ((> j end) (return nil)))
+	       (cond ((Gabbrev-length (= j end) '(nil)) (return nil)))
+	       (GF "~")
+	       (go L))
+	   (GF "']'}"))))
+
+(defun Gformat-array-2 (array dims)
+  (GF "' contains'-")
+  (cond ((not (< (Glevel) Gprinlevel))
+	 (setq Gabbreved T)
+	 (GQ ':PRINC Gprinlevel-abbrev))
+	(T (GF "{1'['")
+	   (prog (j end)
+	       (setq end (1- (cadr dims))
+		     j 0)
+	     L (Gformat-array-2-1 array j dims)
+	       (setq j (1+ j))
+	       (cond ((> j end) (return nil)))
+	       (cond ((Gabbrev-length (= j end) '(nil)) (return nil)))
+	       (GF "-")
+	       (go L))
+           (GF "']'}"))))
+
+(defun Gformat-array-2-1 (array i dims)
+  (cond ((not (< (Glevel) Gprinlevel))
+	 (setq Gabbreved T)
+	 (GQ ':PRINC Gprinlevel-abbrev))
+	(T (GF "{1'['")
+	   (prog (j end type)
+	       (setq type (car dims)
+		     end (1- (caddr dims))
+		     j 0)
+	     L #Q(cond (Ginspecting (setq Gloc (locf (aref array i j)))))
+	       (GF "TB*" #Q(aref array i j)
+		         #M(caseq type
+			     (fixnum (arraycall fixnum array i j))
+			     (flonum (arraycall flonum array i j))
+			     (T (arraycall nil array i j))))
+	       (setq j (1+ j))
+	       (cond ((> j end) (return nil)))
+	       (cond ((Gabbrev-length (= j end) '(nil)) (return nil)))
+	       (GF "~")
+	       (go L))
+	   (GF "']'}"))))
+
+;this section contains list formatters.
+;note that most of these templates are effecient but obscure!
+
+;this macro defines a format, but only if you haven't defined one yet!
+;this is so that loading Gprint won't overwrite formats you write.
+
+(defmacro defun-default-Gformat (atom args . body)
+  (let ((fn (intern (format nil "~a-:Gformat" atom))))
+    `(eval-when (eval load)
+       (defun ,fn ,args .,body)
+       (defprop-default-Gformat ',atom ',fn))))
+
+(defun defprop-default-Gformat (atom fn)
+  (cond ((null (get atom ':Gformat))
+	 (putprop atom fn ':Gformat))))
+
+;first we have some of general utilities that you can use
+;inside formats you create or as the format argument of GPRINT.
+
+(defun :Gfn-format (x) (GF "(*_<*->)" x))
+(defun :GTblock (x) (GF "(1<TB$:GTblock ~>)" x))
+(defun :G1Tblock (x) (GF "(1<TB*~>)" x))
+(defun :Gblock (x) (GF "(1<$:Gblock ,>)" x))
+(defun :G1block (x) (GF "(1<*,>)" x))
+(defun :Gmiser (x) (GF "(1<$:Gmiser ->)" x))
+(defun :G1miser (x) (GF "(1<*->)" x))
+(defun-default-Gformat :Gnothing (ignore) nil)
+(defun-default-Gformat :Gunterpri (ignore) (GQ ':eval '(:Gunterpri Gmainfile)))
+(defun :Gunterpri (file)
+  (let ((pos (car (Gcursorpos file))))
+    (cond ((and pos (> pos 0))
+	   (Gcursorpos (1- pos) (1- (Glinel file)) file)))))
+
+(defun :Gsetq-format (x) (GF "(*_<*+1,*+-1!>)" x))
+(defun-default-Gformat setq (x) (:Gsetq-format x))
+(defun-default-Gformat psetq (x) (:Gsetq-format x))
+(defun-default-Gformat setf (x) (:Gsetq-format x))
+
+(defun :Gquote-format (key list)
+  (cond ((and (#Qlistp #Mpairp (cdr list)) (null (cddr list)))
+	 (GF "{0S[I*]}" key list))
+	(T (:Gfn-format list))))
+(defun-default-Gformat quote (x) (:Gquote-format '|'| x))
+(defun-default-Gformat function (x) (:Gquote-format '|#'| x))
+
+(defun :Gback-quote-format (key list)
+  (GF "{0S[I.*]}" key list))
+(defun-default-Gformat |`-expander/|| (x) (:Gback-quote-format '|`| x))
+(defun-default-Gformat |`,/|| (x) (:Gback-quote-format '|,| x))
+(defun-default-Gformat |`,@/|| (x) (:Gback-quote-format '|,@| x))
+(defun-default-Gformat |`,./|| (x) (:Gback-quote-format '|,.| x))
+(defun-default-Gformat |`.,/|| (x) (:Gback-quote-format '|.,| x))
+;Note that in maclisp, '`(a .,d) doesn't print right because 
+;the marker is not a list car.
+
+(defun-default-Gformat defselect (x) 
+  (GF "(2*_$:G1block <!(2*_$:Gblock <!*>)>)" x))
+(defun-default-Gformat progw (x) (GF "(2*_<*!>)" x))
+(defun-default-Gformat progv (x) (GF "(*_*-*+-5<!*>)" x))
+(defun-default-Gformat multiple-value-bind (x)
+  (GF "(4*_$:G1block !*+-2<!*>)" x))
+
+;this makes the Gprinter obay the grind-macroexpanded flag from the
+;file DEFMAX so that macro expansions print pretty.
+
+(defun-default-Gformat macroexpanded (obj)
+  (GF "*" (cond (grind-macroexpanded (cadddr (cdr obj)))
+		(t (cadddr obj)))))
+
+;This makes si:displaced things come out right.
+#Q
+(defun-default-Gformat si:displaced (obj)
+  (GF "*" (cond (grind-macroexpanded (caddr obj))
+		(t (cadr obj)))))
+
+;this makes defun print out right by checking whether it is of the one or two
+;keyword form.
+
+(defun-default-Gformat defun (obj)
+  (cond ((or (memq (cadr obj) '(expr fexpr macro))
+	     (memq (caddr obj) '(expr fexpr macro)))
+	 (GF "(2*_*_*_$:Gblock <-*>)" obj))
+	(T (GF "(2*_$:G1block _$:Gblock <-*>)" obj))))
+
+(defun-default-Gformat defunS (obj)
+  (GF "(2*~*~$:Gblock <-*>)" obj))
+
+;the following fns just check for indentation changes and then print 
+;out the forms
+
+(defun :Gapply-format (list)
+  (GF "(1*-<*,>)" list))
+(defun-default-Gformat lambda (list)
+  (Gcheck-indentation list
+    #'(lambda (x) (GF "(2*_$:Gblock <-*>)" x))))
+(defun-default-Gformat named-lambda (list)
+  (Gcheck-indentation list
+    #'(lambda (x) (GF "(*~*,$:Gblock +-12<-*>)" x))))
+(defun-default-Gformat named-subst (list)
+  (Gcheck-indentation list
+    #'(lambda (x) (GF "(*~*,$:Gblock +-11 <-*>)" x))))
+(defun-default-Gformat let (list)
+  (Gcheck-indentation list
+    #'(lambda (x) (GF "(2*~$Gformat-bind-list <-*>)" x))))
+(defun-default-Gformat let* (list)
+  (Gcheck-indentation list
+    #'(lambda (x) (GF "(2*~$Gformat-bind-list <-*>)" x))))
+(defun-default-Gformat letS (list)
+  (Gcheck-indentation list
+    #'(lambda (x) (GF "(2*~$Gformat-bind-list <-*>)" x))))
+
+(defun Gformat-bind-list (list)
+  (cond ((do ((l list (cdr l))) ((null l) T)
+	   (cond ((not (symbolp (car l))) (return nil))))
+	 (GF "(1<*,>)" list))
+	(T  (GF "(1(1$:Gblock <,*>) <-$/"!(1$:Gblock <,*>)/" >)" list))))
+
+;This makes cond come out right, and makes T clauses look good.
+
+(defun-default-Gformat cond (x) (GF "(*_<$Gcond-format2 ->)" x))
+
+(defun Gcond-format2 (list)
+  (cond ((eq (car list) T)
+	 (GF "(*_<*->)" list))
+	(T (GF "(1<*->)" list))))
+
+;this takes care of making the tags come out right in a prog.  It works
+;even if there are two or more tags in a row.
+
+(declare (special Gwas-label))
+
+(defun-default-Gformat prog (list)
+  (cond ((and (listp (cdr list)) (cadr list) (symbolp (cadr list)))
+	 (Gnamed-prog-format list))
+	(T (Gprog-format list))))
+
+(defun-default-Gformat prog* (list)
+  (cond ((and (listp (cdr list)) (cadr list) (symbolp (cadr list)))
+	 (Gnamed-prog-format list))
+	(T (Gprog-format list))))
+
+(defun Gprog-format (list)
+  (let* (Gwas-label)
+    (Gcheck-indentation list 
+      #'(lambda (x) (GF "(*_$Gformat-bind-list <%Gprog-format2 >)" x)))))
+
+(defun Gnamed-prog-format (list)
+  (let* (Gwas-label)
+    (Gcheck-indentation list 
+      #'(lambda (x) (GF "(*~*_$Gformat-bind-list <%Gprog-format2 >)" x)))))
+
+(defun Gprog-format2 (item)
+  (cond ((not Gwas-label) (GF "!")))
+  (cond ((atom item) (setq Gwas-label T)
+	 (GF "~#*~" (- -1 (flatsize item)) item))
+	(T (GF "*" item) (setq Gwas-label nil))))
+
+;DO must be handled much like PROG in case there are any labels.
+
+(defun-default-Gformat do (list)
+  (let* (Gwas-label)
+    (Gcheck-indentation list 
+      #'(lambda (x) (GF "(*_(1<$:G1block !>)!(1<*->)+-2
+			   <%Gprog-format2 >)" x)))))
+
+(defun-default-Gformat do-named (list)
+  (let* (Gwas-label)
+    (Gcheck-indentation list
+      #'(lambda (x)
+	  (GF "{2'('*~*_{0(1<$:G1block !>)!(1<*->)}[<%Gprog-format2 >]')'}"
+	      (nth 0 x) (nth 1 x) (nth 2 x) (nth 3 x) (nthcdr 4 x))))))
+
+(defun-default-Gformat dolist (list) (GF "(2*_<*->)" list))
+(defun-default-Gformat dotimes (list) (GF "(2*_<*->)" list))
+#Q
+(defGF loop "(*_*<%Gloop-format >)")
+#Q
+(defun Gloop-format (item)
+  (if (or (si:loop-tassoc item si:loop-keyword-alist)
+	  (si:loop-tassoc item si:loop-iteration-keyword-alist))
+      (gf "-*" item)
+      (gf "_*" item)))
+
+;The following is almost more kludge than it is worth, but it works.
+
+;this checks to see if the maximum reasonable indentation has been
+;exceeded, and if so reduces the indentation.  Note the  cludge so
+;that it will work even if we are misering.
+
+(defun Gcheck-indentation (list format-fn)
+  (let ((ind (Gestimate-indent)))
+    (cond ((> (- Glinelen ind) major-width) (GF "%#" list format-fn))
+	  (T (GF "!~#';----------'~#'|'!" (- ind) (- ind 11.))
+	     (GF "~#%#" (- 5 ind) list format-fn)
+	     (GF "!~#';----------'~#'|'!" (- ind) (- ind 11.))))))
+
+;This looks down the queue, and estimates what the indentation will be
+;when everything now in the queue is printed if the substructures have
+;to be broken up.
+
+(defun Gestimate-indent ()
+  (let ((indent (Gpindent))
+	(Gql Gql)
+	(count 0)
+	(misering (Gmisering)))
+    (prog ()
+     L (cond ((not (< Gql Gqr)) (return nil)))
+       (caseq (Gtype)
+	 (:ind (cond ((and (zerop count) (not misering))
+		      (setq indent (max (+ indent (or (Gobj) (Gget-indent)))
+					0)))))
+	 (:end (setq count (1- count)))
+	 (:start (cond ((and (zerop count) (null (Gsize)))
+			(cond ((< Glinelen (+ indent miser-width))
+			       (setq misering T)
+			       (setq indent (1+ indent)))))
+		       (T (setq count (1+ count))))))
+       (Gpop Gqueue)
+       (go L))
+    indent))
+
+;this makes backquote grind right on the LISPM. 
+;[Won't work right with locatives.]
+
+#Q(defun-default-Gformat si:xr-bq-cons (obj)
+    (:Gback-quote-format '|`| (cons '|`-expander/|| (Gunbackquotify obj))))
+#Q(defun-default-Gformat si:xr-bq-list (obj)
+    (:Gback-quote-format '|`| (cons '|`-expander/|| (Gunbackquotify obj))))
+#Q(defun-default-Gformat si:xr-bq-list* (obj)
+    (:Gback-quote-format '|`| (cons '|`-expander/|| (Gunbackquotify obj))))
+#Q(defun-default-Gformat si:xr-bq-append (obj)
+    (:Gback-quote-format '|`| (cons '|`-expander/|| (Gunbackquotify obj))))
+#Q(defun-default-Gformat si:xr-bq-nconc (obj)
+    (:Gback-quote-format '|`| (cons '|`-expander/|| (Gunbackquotify obj))))
+
+;Convert the backquote form to a list resembling what the user typed in,
+;with "calls" to |`,/||, etc., representing the commas.
+;Lifted from lmio;grind.
+#Q
+(defun Gunbackquotify (exp)
+  (cond ((or (numberp exp) (eq exp t) (null exp) (stringp exp)) exp)
+	((symbolp exp) `(|`,/|| . ,exp))
+	((atom exp) exp)
+	((eq (car exp) 'quote) (cadr exp))
+	((eq (car exp) 'si:xr-bq-cons)
+	 (cons (Gunbackquotify (cadr exp))
+	       (Gunbackquotify-segment (cddr exp) nil t)))
+	((eq (car exp) 'si:xr-bq-list)
+	 (mapcar 'Gunbackquotify (cdr exp)))
+	((eq (car exp) 'si:xr-bq-list*)
+	 (nconc (mapcar 'Gunbackquotify (butlast (cdr exp)))
+		(Gunbackquotify-segment (last exp) nil t)))
+	((eq (car exp) 'si:xr-bq-append)
+	 (mapcon 'Gunbackquotify-segment (cdr exp)
+		 (circular-list t) (circular-list nil)))
+	((eq (car exp) 'si:xr-bq-nconc)
+	 (mapcon 'Gunbackquotify-segment (cdr exp)
+		 (circular-list nil) (circular-list nil)))
+	(t `(|`,/|| . ,exp))))
+
+;Convert a thing in a backquote-form which should appear as a segment,
+;not an element.  The argument is the list whose car is the
+;segment-form, and the value is the segment to be appended into the
+;resulting list.
+#Q
+(defun Gunbackquotify-segment (loc copy-p tail-p)
+  (cond ((and tail-p (atom (cdr loc)))
+	 (let ((tem (Gunbackquotify (car loc))))
+	   (cond ((and (listp tem) (eq (car tem) '|`,/||))
+		  (list `(|`.,/|| . ,(car loc))))
+		 (t tem))))
+	((and (listp (car loc))
+	      (eq (caar loc) 'quote)
+	      (listp (cadar loc)))
+	 (cadar loc))
+	(t (list (cons (if copy-p '|`,@/|| '|`,./||)
+		       (car loc))))))
+
+;this creates queue entries.
+
+(defun GQ (type obj)
+;make a new entry in the queue.
+  (setf (Gtype Gqr) type)
+  (setf (Gobj Gqr) obj)
+  (setf (Gsize Gqr)
+	(caseq type
+	  (:start nil)
+	  (:newline (cond ((memq obj '(:always :normal :miser)) 0)))
+	  (:prin1 (flatsize obj))
+	  ((:princ :special) (flatc obj))
+	  (:space obj)
+	  ((:ind :end :tab :eval) 0)
+	  (T (error "GPRINT -- bad type to GQ" type))))
+;do special processing for start and end of a substructure.
+  (caseq type
+    (:start (let ((i (Glevel)))
+	     (Gpush Gqs)
+	     (setf (Gbegin) Gqr)
+	     (setf (Gsave-Gtsize) Gtsize)
+	     (setf (Glevel) (cond ((equal obj 0) i) (T (1+ i))))
+	     (setf (Glength) 0)))
+    (:end (cond ((not (minusp (Gbegin)))
+		 (setf (Gsize (Gbegin)) (- Gtsize (Gsave-Gtsize)))
+		 (Gupdate-sizes (Gbegin))))
+	  (Gpop Gqs)))
+;update the total size
+  (cond ((memq type '(:princ :prin1 :special :space))
+	 (setf Gtsize (+ Gtsize (Gsize Gqr)))))
+;update Glength
+  (cond ((memq type '(:princ :prin1 :end)) (setf (Glength) (1+ (Glength)))))
+;if this is a real printing thing then propagate the size to waiting newlines.
+  (cond ((memq type '(:princ :prin1 :special)) (Gupdate-sizes Gqr)))
+;entry is now completely processed.
+  (Gpush Gqueue)
+;check if we can now process any queue entries.
+  (prog ()
+   L (cond (Gexploding (Gexplode-it))
+	   ((Gsize) (Gprintout))
+	   ((or (and (eq type ':newline) (eq obj ':always))
+		(> (- Gtsize Glsize) Glinelen)) ;gives extra look ahead
+	    (setf (Gsize) 64000.)
+	    (Gprintout))
+	   (T (return nil)))
+     (cond ((memq (Gtype) '(:prin1 :princ :special :space))
+	    (setq Glsize (+ Glsize (Gsize)))))
+     (Gpop Gqueue)
+     (cond ((< Gql Gqr) (go L))))
+;if the queue was emptied reset it, setting any hanging begins to -1.
+  (cond ((= Gql Gqr)
+	 (setq Gql 0 Gqr 0 Gtsize 0 Glsize 0)
+	 (let ((Gqsp Gqsp))
+	   (prog ()
+	    L (setf (Gbegin) -1)
+	      (cond ((not (zerop Gqsp)) (Gpop Gqs) (go L))))))))
+
+;this copies a size back to any newline entries that are waiting.
+
+(defun Gupdate-sizes (ptr)
+  (do ((i (- ptr 3) (- i 3)))
+    ((or (< i Gql) (not (memq (Gtype i)
+			      '(:newline :tab :space :eval :ind)))))
+    (cond ((null (Gsize i)) (setf (Gsize i) (Gsize ptr))))))
+
+(defun Gprintout ()
+  (cond ((and (zerop Gdepth)
+	      (or (and (eq (Gtype) ':newline)		  
+		       (caseq (Gobj)
+			 ((:always :normal) T)
+			 (:miser (Gmisering))
+			 (:block (or Gwent-up
+				     (and (< (Gpindent) (- Glinelen Gfreelen))
+					  (> (Gsize) Gfreelen))))))
+		  (and (memq (Gtype) '(:princ :prin1 :special))
+		       (> (Gsize) (+ Gfreelen 5))
+		       (< (Gpindent) (- Glinelen Gfreelen)))))
+	 (setq Gpending (Gpindent)
+	       Gfreelen (- Glinelen Gpending)
+	       Gwent-up nil
+	       Gpending-newline T)))
+  (caseq (Gtype)
+   (:start (cond ((and (zerop Gdepth) (> (Gsize) Gfreelen))
+		  (Gpush Gps)
+		  (setf (Gpindent) (- Glinelen Gfreelen))
+		  (cond ((Gmisering) (setf (Gpindent) (1+ (Gpindent)))))
+		  (setf (Gtabsize) -1))
+		 (T (setq Gdepth (1+ Gdepth)))))
+   (:ind (cond ((and (zerop Gdepth) (not (Gmisering)))
+		(setf (Gpindent)
+		      (max (+ (Gpindent) (or (Gobj) (Gget-indent))) 0)))))
+   (:end (cond ((zerop Gdepth)
+		(setq Gwent-up T)
+		(Gpop Gps))
+	       (T (setq Gdepth (1- Gdepth)))))
+   ((:princ :prin1 :special :eval)
+    (cond (Gpending-newline ;print pending newline if any
+	   (cond ((not (< Glineno Gprinendline))
+		  (cond ((plusp Gfreelen) (princ '| ---| Gout)))
+		  (*throw 'Gprintabort '|prinendline exceeded|)))
+	   (cond ((not (< Glineno Gprinstartline))
+		  (terpri Gout)
+		  (setq Gpending (+ Gpending Ginitial-charpos))))
+	   (setq Glineno (1+ Glineno)
+		 Gpending-newline nil)))
+    (cond ((not (< Glineno Gprinstartline)) ;print pending blanks
+	   (do ((i Gpending (1- i))) ((not (plusp i))) (tyo 32. Gout))))
+    (cond ((eq (Gtype) ':eval) (eval (Gobj))))
+    (cond ((not (< Glineno Gprinstartline)) ;print stuff
+	   (caseq (Gtype)
+	     (:prin1 (prin1 (Gobj) Gout))
+	     ((:princ :special) (princ (Gobj) Gout)))))
+    (setq Gfreelen (- Gfreelen (Gsize)))
+    (setq Gpending 0))
+   (:space (let ((space (Gobj))) ;set up spaces as pending
+	     (cond ((minusp space) (setq space (max (- Gpending) space))))
+	     (setq Gpending (+ Gpending space)
+		   Gfreelen (- Gfreelen space))))
+   (:tab (cond ((and (zerop Gdepth)
+		     (not Gpending-newline))
+		(let* ((tab (cond ((Gobj))
+				  ((not (minusp (Gtabsize))) (Gtabsize))
+				  (T (setf (Gtabsize) (Gestimate-Gtabsize))
+				     (Gtabsize))))
+		       (offset (\ (- (- Glinelen Gfreelen) (Gpindent)) tab)))
+		   (cond ((not (zerop offset)) (setq offset (- tab offset))))
+		   (setq Gpending (+ Gpending offset)
+			 Gfreelen (- Gfreelen offset))))))))
+
+;Note that there is a gross abstraction violation here when we
+;refer to the last indentation level.
+
+(defun Gmisering ()
+  (cond ((plusp Gpsp)
+	 (< Glinelen (+ (arraycall fixnum Gps (1- Gpsp)) miser-width)))
+	(T (< Glinelen miser-width))))
+
+;this looks down the queue and calculates an indentation increment as the sum
+;of the sizes of everything up to and including the first :PRIN1 or
+;:PRINC, and any :SPACE after it.  Note that if there isn't enough stuff 
+;queued up, then this will get an indentation which is too small.
+;this only happens when you are printing right up against the margin.
+
+(defun Gget-indent ()
+  (let ((indent 0)
+        (found-print nil)
+	(Gql Gql))
+    (prog ()
+     L (Gpop Gqueue)
+       (cond ((not (< Gql Gqr)) (return nil)))
+       (caseq (Gtype)
+	 ((:prin1 :princ) (cond (found-print (return nil))
+				(T (setq indent (+ indent (Gsize))
+					 found-print T))))
+	 (:space (setq indent (+ indent (Gsize))))
+	 (:special (cond (found-print (return nil))
+			 (T (setq indent (+ indent (Gsize)))))))
+       (go L))
+    indent))
+
+;this looks down the queue and estimates what the Gtabsize should be.
+;Note that it always returns at least a size big enough to accomodate
+;one element.
+
+(defun Gestimate-Gtabsize ()
+  (let ((max 2)
+	(i 0)
+	(space (- Glinelen (Gpindent)))
+	(Gql Gql))
+    (prog () 
+     L (cond ((and (zerop i) (numberp (Gsize))) (setq max (max max (Gsize)))))
+       (caseq (Gtype)
+	 (:start (setq i (1+ i)))
+	 (:end (setq i (1- i))))
+       (Gpop Gqueue)
+       (cond ((not (< Gql Gqr)) (return nil)))
+       (go L))
+    (setq max (1+ max)) ;to allow for spaces between items.
+    (setq max (+ max (// max 5))) ;to allow for possible bigger items to come.
+    (cond ((> space max) (setq max (// space (// space max))))) ;use all space.
+    max))
+
+;This explodes a thing adding it to Gexploding.
+
+(defun Gexplode-it ()
+  (caseq (Gtype)
+    (:space (do ((i (Gobj) (1- 1))) ((zerop i))
+	      (setq Gexploding (cons '| | Gexploding))))
+    (:prin1 (setq Gexploding (nreconc (explode (Gobj)) Gexploding)))
+    ((:special :princ)
+     (setq Gexploding (nreconc (explodec (Gobj)) Gexploding)))))
+
+
+
+
\ No newline at end of file
diff --git a/src/libdoc/sharab.jonl47 b/src/libdoc/sharab.jonl47
new file mode 100755
index 00000000..8715226e
--- /dev/null
+++ b/src/libdoc/sharab.jonl47
@@ -0,0 +1,747 @@
+;;;   SHARAB 						  -*-LISP-*-
+;;;   **************************************************************
+;;;   ***** MACLISP ****** Sharable Extensions to LISP *************
+;;;   **************************************************************
+;;;   ** (C) Copyright 1981 Massachusetts Institute of Technology **
+;;;   ****** This is a read-only file! (All writes reserved) *******
+;;;   **************************************************************
+
+
+(eval-when (eval compile)
+  (or (get 'SUBLOAD 'VERSION)
+      (load  '((lisp) subload)))
+  (setq defmacro-for-compiling ()  defmacro-displace-call () )
+  (setq macros () IBASE 8. BASE 8.)
+)
+
+
+
+;;; Following temporary macro is nearly an open-coding of HERALD, but
+;;;  differs so that the "version" number is available when compiling
+(defmacro C-HERALD 
+	  (group-name &optional (version-number '||) (ofile 'MSGFILES))
+   (or (symbolp group-name)
+       (check-type group-name #'SYMBOLP 'HERALD))
+   (let* ((ifile (and (filep infile)
+		      (car (last (truename infile)))))
+	  (v (cond ((and ifile 
+			 (fixp (car (errset (readlist (exploden ifile)) () ))))
+		    ifile)
+		   ((symbolp version-number) version-number)
+		   ('||)))
+	  (putpropper `(DEFPROP ,group-name ,v VERSION))
+	  (text (symbolconc '|;Loading | group-name '| | v)) )
+     (setq text (copysymbol text () ))
+     (set text text)
+     (putprop text 'T '+INTERNAL-STRING-MARKER)
+     (if (status feature COMPLR) (putprop text `(SPECIAL ,text) 'SPECIAL))
+      ;; Remember, this is a maclisp-only file!
+      ;;In older lisps, or for cross-compilation, we simply forget 
+      ;;  about delaying-until-exit the putprop of version number.
+     (setq putpropper 
+	   `(COND ((ALPHALESSP (STATUS LISPV) '/2071) ,putpropper) 
+		  ('T (PUSH #'(LAMBDA (X) (OR X ,putpropper))
+			    FILE-EXIT-FUNCTIONS))))
+     (putprop group-name v 'C-VERSION)
+     `(PROGN 
+	(COND ((STATUS NOFEATURE NOLDMSG)
+	        (TERPRI ,ofile)
+		(PRINC ,text ,ofile)))
+	,putpropper
+	',v)))
+
+;; (SELECT-A-BIT? x b1 b2 ... bn) is true iff 'x' has one of the selected
+;;  bits turned on;  bit 'i', selected by 'bi' is 2^i
+(defmacro SELECT-A-BIT? (val &rest l) 
+  (let ((n (apply 'plus (mapcar '(lambda (x) (lsh 1 x)) l))))
+    `(NOT (= (BOOLE 1 ,val ,n) 0))))
+
+(defmacro CLEAR-BITS (mask val) `(BOOLE 2 ,mask ,val))
+
+
+
+
+;;; WARNING!! You loser, don't ever let the version number run over
+;;;   two digits.  The 2nd filename "JONLxx" will lose, and also the
+;;;   2nd filename of the dump file  will lose ("SHBDMP xx.yyy" where 
+;;;   "yyy" is the lisp version number over which the SHARABLE is built).
+
+(c-herald SHARABLE /47)
+
+;;; Functions for creating heirachical MACLISP dumps on ITS.
+;;; PURE-SUSPEND - suspend, but also delete pure pages that are shared with 
+;;; 		   previous dumps, re-sharing them upon loading.  No deletions
+;;; 		   are done unless PURE-SUSPEND is non-() and also unless 
+;;; 		   (status FLUSH) ==> T; but regardless of deletions, starting
+;;;		   up after a call to PURE-SUSPEND will cause sharing with the 
+;;; 		   previous dumped files.  Two arguments required - both passed
+;;; 		   to SUSPEND (q.v.) - but the second is analyzed as a file 
+;;; 		   name and will cause a proceedable break loop if PDUMPing
+;;; 		   by SUSPEND will clobber an existing file.
+;;; ANNOUNCE-&-LOAD-INIT-FILE - Handy little function for systems that want to
+;;; 		   to announce themselves upon loading,  and try to load an 
+;;; 		   "init" file.  See the file JONL;SHARAB LISP for an example.
+;;; 		   First argument is a symbol, which is the "name" to be
+;;; 		   announced (if there is a VERSION property on this symbol, it
+;;; 		   will be included in the "announcement");  optional second
+;;;		   argument is either () or a list of characters like returned
+;;;		   by (STATUS JCL) to be parsed as filename to be used instead
+;;;		   of the usual init file.  If a third argument is supplied, it
+;;;		   is a "fix" file to be loaded before loading the "name" init
+;;;		   file.
+;;; DEPURIFY-SYMBOL - depurifies, so that if pure pages have been deleted ...
+;;; 		   The value of DEPURIFY-SYMBOL is a list of symbols which
+;;; 		   must never be purified, since they are needed during the
+;;; 		   "chilly" load of the system.
+
+;;; Hacked up during February 1980, by JONL, from the NSHARE file of GSB
+;;; Comments, complaints, suggestions, etc. to BUG-LISP
+
+;;; For Optimal sharing, this file should be loaded into a nearly fresh
+;;;  lisp, with PURE bound to T;  in this case, *PURE ###must### be
+;;;  bound to () during the loading of this file.
+;;; Then a pure dump is made by loading up other functions and data 
+;;;  with *PURE set to T, and PURE set either to a small fixnum or to T.
+;;; When finished loading, you probably want to set *PURE to (), and then
+;;;  call PURE-SUSPEND (rather than SUSPEND) with 2 arguments -  the second 
+;;;  arg is the name of the file to PDUMP into, and the first is passed to 
+;;;  SUSPEND.  If the first arg is (), then SUSPEND merely does the PDUMP
+;;;  and returns;  if it is 0, SUSPEND will valret to DDT after PDUMPing.
+
+;;; Hackers note - 
+;;; This only maps in pure pages from a file, and only pages which are
+;;; not absolute.  (It does not recognize public pages though.)  
+;;; It will not clobber an impure page in the job with a pure page from
+;;; a file.  If, however, an earlier dump has had a patch put into a
+;;; pure area and the page has been repurified, then that change will
+;;; propagate to all dumps made from that one.
+;;; It also tries to distinguish a page which has been patchd and
+;;; repurified, but is not part of a dumped file.
+
+
+(declare (special *SHARING-FILE-LIST*  |+internal-page-map/|| 
+		  PURE-SUSPEND  COMMUNIZE-SINGLE-FILE COMMUNIZE-FILE-ARRAY 
+		  ANNOUNCE-&-LOAD-INIT-FILE )
+	 (*expr PURE-SUSPEND  COMMUNIZE-SINGLE-FILE)
+	 (*lexpr ANNOUNCE-&-LOAD-INIT-FILE)
+	 (special JOB-MSG-FILE)
+	 (setq USE-STRT7 'T))
+
+;;; Can only play the FLUSH game if this file is loaded with PURE = T
+;;;  Otherwise, you may try to "CALL 1 'CONS" during  COMMUNIZE, and find
+;;;  that the plist of CONS was on a pure page which is not yet back!
+(eval-when (load) 
+   (or (eq pure 'T) (error '|PURE must be "T" when loading SHARABLE|))
+)
+
+(setq-if-unbound *SHARING-FILE-LIST* () 
+		 PURE-SUSPEND 'T 
+		 |+internal-page-map/|| () )
+(setq ANNOUNCE-&-LOAD-INIT-FILE (status LISPV))
+
+;;; Information about the purity of pages is stored in a fixnum array,
+;;;  packed 8 4-bit bytes per word.  Meaning of the 4 bits is:
+;;;   0 	- non-existent page
+;;;   1 (1_0) 	- writeable page
+;;;   2 (1_1) 	- LISP system pure page
+;;;   4 (1_2) 	- other pure page
+;;;   8 (1_3) 	- temporary setting for purity, just before suspension
+;;; This array, "|+internal-page-map/||", is set up at the end of this file.
+
+(defmacro (LDB-A-BYTE defmacro-for-compiling () defmacro-displace-call () )
+	  (&optional (index 'PAGE-NUMBER) 
+		     (byte-size 4)
+		     (bytes-per-word 8)
+		     (ar '|+internal-page-map/||))
+    `(LOAD-BYTE (ARRAYCALL FIXNUM ,ar (// ,index ,bytes-per-word))
+		(* ,byte-size (\ ,index ,bytes-per-word))
+		,byte-size))
+
+(defmacro (DPB-A-BYTE defmacro-for-compiling () defmacro-displace-call () )
+	  (byte &optional (index 'PAGE-NUMBER) 
+			  (byte-size 4)
+			  (bytes-per-word 8)
+			  (ar '|+internal-page-map/||)
+		&aux wordno remwordno body)
+   (cond ((and (fixnump index) (fixnump bytes-per-word))
+	  (setq wordno (* index bytes-per-word)
+		remwordno (\ index bytes-per-word)))
+	 ('T (si:gen-local-var wordno)
+	     (si:gen-local-var remwordno)))
+   (setq body `(STORE (ARRAYCALL FIXNUM ,ar ,wordno)
+		      (DEPOSIT-BYTE (ARRAYCALL FIXNUM ,ar ,wordno)
+				    (* ,byte-size ,remwordno)
+				    ,byte-size 
+				    ,byte)))
+    ;;Foo - don't we wish we had a multiple-value-returning version of
+    ;;  division, which also returned the remainder!
+   (if (not (fixnump wordno))
+       (setq body `(LET ((,wordno (// ,index ,bytes-per-word))
+			 (,remwordno (\ ,index ,bytes-per-word)))
+		     (DECLARE (FIXNUM ,wordno ,remwordno))
+		     ,body)))
+   body)
+
+
+(comment PURE-SUSPEND)
+
+(putprop 'PURE-SUSPEND  (lsh bporg -10.) 'BPORG)
+
+
+(defun PURE-SUSPEND (argument-to-suspend file-namelist)
+  (prog (*PURE NORET flushp oni b-low b-hi npurep purepage? tpno tmp 
+	 file-object file-to-dump-to open-files flstbl flstbl-addr )
+	(declare (fixnum b-low b-hi npurep purepage? tpno flstbl flstbl-addr))
+	(setq npurep -1 purepage? 0 tpno 0)
+	(setq b-low (1- (or (get 'PURE-SUSPEND 'BPORG) 1000.))
+	      b-hi (1+ (or (get 'PURE-SUSPEND 'BPEND) -1000.)))
+	(setq flushp (and PURE-SUSPEND (status FLUSH)))
+    FIND-FILE 
+	(cond ((probef file-namelist)
+	       (terpri)
+	       (prin1 file-namelist)
+	       (princ '| will :PDUMP over existing file ?/
+ P to go ahead, or RETURN another file name/î|)
+	       (cond ((setq tmp (+internal-fac-break file-namelist))
+		      (setq file-namelist tmp)
+		      (go FIND-FILE)))))
+	(setq file-object (open file-namelist '(OUT FIXNUM SINGLE))
+	      file-to-dump-to (truename file-object))
+    FIND-FLSTBL 	
+	(cond ((null flushp) () )
+	      ((null (setq tmp (cond ((getddtsym 'FLSTBL))
+				     ((eq (status hactrn) 'DDT) 
+				      (valret '|:SYMLOD/î:VP |)
+				      (getddtsym 'FLSTBL)))))
+	       (princ '|/îDDT symbols?|)
+	       (+internal-fac-break () )
+	       (go FIND-FLSTBL))
+	      ('T (setq FLSTBL tmp)
+		   ;Unpurify symbols of the file's namelist - so can call OPEN 
+		   ; after dumping, but before pure data pages are loaded in.
+		  (mapc 'DEPURIFY-SYMBOL (append (car file-to-dump-to)
+						 (cdr file-to-dump-to)))))
+	(cond ((null argument-to-suspend))
+	      ((not (eq (status hactrn) 'DDT))
+	       (setq argument-to-suspend () ))
+	      ((symbolp argument-to-suspend)
+	       (depurify-symbol argument-to-suspend)))
+	(close file-object)
+	(setq file-object () )
+	(and (boundp 'JOB-MSG-FILE)	;just in case LDDT is here
+	     (filep JOB-MSG-FILE)
+	     (setq tmp (status filemo JOB-MSG-FILE))
+	     (push (cons JOB-MSG-FILE tmp) open-files))
+	;; First, set up some data passed in thru special variable 
+	;; Since this can do a GC, we must do it before we flush any pages.
+	(setq COMMUNIZE-SINGLE-FILE (*array () 'FIXNUM 256.))
+	(gctwa)
+	 ; Since NORET is bound to NIL, this should minimize BPS pages
+	(gc)
+	 ; This GC may close a few "lost" files
+	(do ((l (munkam (examine (getddtsym 'GCMKL))) (cddr l))
+	     (dedsar (getddtsym 'DEDSAR))
+	     (losing-files) )
+	    ((null l) 
+	     (cond (losing-files 
+		    (terpri)
+		    (prin1 losing-files)
+		    (princ '|/îFiles open during PURE-SUSPEND -- P to close them/î|) 
+		    (+internal-fac-break losing-files)
+		    (mapc 'CLOSE losing-files ))))
+	  (cond ((or (eq (car l) dedsar) 
+		     (not (filep (car l)))
+		     (null (setq tmp (status filemode (car l)))) )
+		 () )
+		((not (memq 'TTY (car tmp))) (push (car l) losing-files))
+		((and (not (eq (car l) TYI)) (not (eq (car l) TYO)))
+		 (push (cons (car l) (car tmp)) open-files))))
+
+	  ;; Round up binary program space to a page boundary. (This should 
+	  ;;   not be necessary but user's program may fail to do it.)
+	(pagebporg)
+	  ;; Now, do the purification.  This purifies all binary program space,
+	  ;;  a and also list structure etc. which  was 'purcopied'.
+	(purify 0 0 'BPORG)
+	  ;; Save away the name of the file we are dumping to, in effect by
+	  ;;   (push tmp (cdr *sharing-file-list*))
+	(setq tmp (list file-to-dump-to))
+	(cond ((null *SHARING-FILE-LIST*) (setq *SHARING-FILE-LIST* tmp))
+	      ('T (rplacd tmp (cdr *SHARING-FILE-LIST*))
+		  (rplacd *SHARING-FILE-LIST* tmp)))
+	(do ((l open-files (cdr l)))
+	    ((null l))
+	  (close (caar l)))
+
+	  ;; The next phase must be indivisible - hence NOINTERRUPT
+	(setq oni (nointerrupt 'T))
+	(let ((BASE 10.)
+	      (*NOPOINT 'T) 
+	      f date time PRINLEVEL PRINLENGTH)
+	  (do ((i 3 (1- i))) 
+	      ((or (< i 0)
+		   (errset (setq f (open '|DSK:LISP;LOCK MAIL| '(APPEND))) ()))
+	       (cond ((< i 0) 
+		      (errset (renamef '|DSK:LISP;LOCK MAIL| 
+				       '|DSK:LISP;LCKMAI >|) 
+			      () )
+		      (setq f (open '|DSK:LISP;LOCK MAIL| '(OUT))))))
+	    (terpri tyo)
+	    (princ '|LOCK MAIL file not available -- waiting 10 seconds.| tyo)
+	    (sleep 10.))
+	  (setq date (status date)
+		time (status daytime))
+	  (terpri f)
+	  (princ (status USERID) f)
+	  (princ '|  | f)
+	  (princ (cadr date) f)
+	  (princ '// f)
+	  (princ (caddr date) f)
+	  (princ '// f)
+	  (princ (car date) f)
+	  (princ '|  | f)
+	  (princ (car time) f)
+	  (princ '/: f)
+	  (princ (cadr date) f)
+	  (princ '/: f)
+	  (princ (caddr date) f)
+	  (terpri f)
+	  (prin1 (cons ANNOUNCE-&-LOAD-INIT-FILE *SHARING-FILE-LIST*) f)
+	  (terpri f)
+	  (princ '|| f)
+	  (close f))
+	(|+internal-call/|| () 'INIT)
+	  ;; Remember any newly shared pages, and disconnect others if flushing
+	(do ((page-number 0 (1+ page-number)))
+	    ((not (< page-number 256.)))
+	  (declare (fixnum page-number))
+	  (setq npurep (cond ((lessp b-low page-number b-hi)
+			      ;; This page needed for restart after SUSPEND, so
+			      ;;  mark as "other pure", but not cuttable.
+			      1_2)				  
+			     ((zerop (setq tpno (|+internal-call/|| page-number 'CORTYP))) 
+			      ;; 0 ==> page doesn't exist, negative ==> impure 
+			      0)
+			     ((< tpno  0) 
+			       ;; add 1_0 bit, and clear others except 1_1
+			      (logior 1_0 (clear-bits #o15 (ldb-a-byte))) )
+			     ('T -1)))
+	  (cond ((not (< npurep 0)) (dpb-a-byte npurep))
+		  ;; If npurep = -1, then page is pure, and is a candidate for
+		  ;;  for cutting out from pdump.
+		((select-a-bit? (setq tpno (ldb-a-byte)) 1)
+		  ;; 1_1-bit of internal-page-map says, "LISP" system pure page
+		 (setq flstbl-addr (+ flstbl (// page-number 36.)))
+		 (and (cond ((null (|+internal-call/|| page-number 'DSK)) 
+			      ;; But what if it was just patched?  Then diddle
+			      ;;  table SUSPEND uses, so that it isn't flushed
+			     (setq purepage? 0)
+			      ;; Also mark it as a "newly-shared"  page
+			     (setq tpno #.(+ 1_3 1_1) )
+			     'T)
+			    ((select-a-bit? tpno 2)  
+			      ;; If dumped in previous round, then permit
+			      ;;  SUSPEND to flush it in this round
+			     (setq purepage? 1)
+			      ;; Call it a "system" page, since SUSPEND will
+			      ;;  flush it in the future
+			     (setq tpno 1_1)
+			     'T))
+		      (deposit flstbl-addr  
+			       (deposit-byte (examine flstbl-addr) 
+					     (- 35. (\ page-number 36.)) 
+					     1  
+					     purepage?))
+		      (dpb-a-byte tpno))) 
+		((select-a-bit? tpno 2 3)
+		  ;Try to flush page from this job, if random shared page
+		 (and flushp (|+internal-call/|| page-number 'FLUSH)))	      
+		('T  ;; Otherwise Mark as "newly-purified" page 
+		     ;;  (maybe flush next in next cascade pdump?)
+		    (dpb-a-byte 1_3) )))
+	 ;; And finally, suspend.
+	(suspend argument-to-suspend file-to-dump-to)
+	(if flushp 
+	    (do ((page-number 0 (1+ page-number)))
+		((not (< page-number 256.)))
+	      (declare (fixnum page-number))
+	       ;;Any page that was "newly purified" just before SUSPENDing 
+	       ;; is now a random sharable pure page, and may be cut out on 
+	       ;; subsequent dumps.  So mark it in the internal-page-map.
+	      (and (select-a-bit? (setq tpno (ldb-a-byte)) 3) 
+		   (dpb-a-byte (logior 1_2 (clear-bits 1_3 tpno))))))
+	(nointerrupt oni)
+          ;; Now, since we are suspended, map in the pages from other files
+          ;;  found on *SHARING-FILE-LIST*, which restores the "1_2" pages
+	(mapc 'COMMUNIZE-SINGLE-FILE *SHARING-FILE-LIST*)
+	(*rearray COMMUNIZE-SINGLE-FILE)
+	(do ((l open-files (cdr l)))
+	    ((null l))
+	  (open (caar l) (cadar l)))
+	(return 'T)))
+
+
+(defun COMMUNIZE-SINGLE-FILE (file-namelist)
+   (prog (file-page-number entry purepage? tmp)
+	 (declare (fixnum entry purepage? file-page-number))
+	 (setq entry 0 
+	       file-page-number 1)
+	 ;; Unit mode:  keeps the file array smaller (no buffer)
+	 (cnamef COMMUNIZE-FILE-ARRAY file-namelist)
+	 (setq tmp (errset (open COMMUNIZE-FILE-ARRAY '(IN FIXNUM SINGLE))))
+	 (cond ((or (atom tmp) (not (= (in COMMUNIZE-FILE-ARRAY) 0)))
+		(princ '|;File not shared since it | msgfiles)
+		(prin1 file-namelist msgfiles)
+		(cond ((atom tmp)
+		       (princ '| could not be opened| msgfiles))
+		      ((princ '| is not in PDUMP format| msgfiles)))
+;		(princ tmp msgfiles)
+		(return (close COMMUNIZE-FILE-ARRAY))))
+	  ;; Try to COMMUNIZE-SINGLE-FILE here!
+	  ;; Get page map from first block of file - 256. words
+	 (fillarray COMMUNIZE-SINGLE-FILE COMMUNIZE-FILE-ARRAY)
+	 (do ((page-number 0 (1+ page-number)))
+	     ((not (< page-number 256.)))
+	    (declare (fixnum page-number))
+	    (setq entry (arraycall fixnum COMMUNIZE-SINGLE-FILE page-number))
+	    (cond ((plusp entry) 
+		    ;; < 0 ==> absolute page; = 0 ==> non-existent page
+		   (setq purepage? (load-byte entry 16. 2))
+		    ;; File contains a page corresponding to PAGE-NUMBER?
+		   (or (plusp purepage?)
+		       (error 'COMMUNIZE-SINGLE-FILE))
+		   (and 
+		     ;; Read-only iff bits <2.9,2.8> is 01
+		    (= purepage? 1.)
+		     ;; Tbl entry is 1 if page is writeable in most recent dump
+		    (not (select-a-bit? (ldb-a-byte) 0)) 
+		     ;; If not in us, or unpatched-pure in us
+		    (not (minusp (|+internal-call/|| page-number 'CORTYP)))
+		     ;; then map it in!
+		    (setq tmp (fetch-file-page/|  page-number 
+						  COMMUNIZE-FILE-ARRAY
+						  file-page-number))
+		     ;;  Non-null indicates an error.
+		    (error 'CORBLK))
+		   (setq file-page-number (1+ file-page-number)))))
+	 (close COMMUNIZE-FILE-ARRAY)))
+
+
+
+(lap-a-list '(
+   (lap |+internal-call/|| subr)
+	(args |+internal-call/|| (() . 2))	;a kind of "SYSCALL"
+	(defsym *ruind 23 			; 2nd arg is "message"
+		**rlfi 2 
+		f*chan 11)
+	(defsym immed-info     1000_22 	 	;arg ptrs for "CALL" uuo
+		get-info       2000_22 
+		get-error      3000_22 
+		immed-control  5000_22 )
+	(cain 2 'CORTYP)			;"CORTYP" to do a "CORTYP" call
+	 (jrst 0 do-cortyp)
+	(cain 2 'FLUSH)				;"FLUSH" to do a "CORBLK" call 
+	 (jrst 0 do-flush)			; to delete a page from our map
+	(cain 2 'DSK)				;"DSK" to find out if argument 
+	 (jrst 0 dsk-sharedp)			; page is shared with dsk file
+	(cain 2 'INIT)				;"INIT" to initialize above
+	 (jrst 0 dsk-sharedp-init)
+	(cain 2 'FILE)				;"FILE" for finding file which
+	 (jrst 0 who-bore-me?)			; was loaded to make this job
+	(lerr 0 (% sixbit |BAD MSG TO +internal-call!|))
+
+     do-flush 
+	(jsp t fxnv1)
+        (*call 0 flush-request)
+	 (*lose)
+	(jrst 0 fix1)
+      flush-request 
+	(setz)
+	(sixbit |CORBLK|)
+	 (immed-info 0 0)			;delete page
+	 (immed-info 0 -1)			;from myself
+	 (setz 0 tt)				;just 1 page, found in tt
+
+     do-cortyp 
+        (*call 0 cortyp-request)
+	 (*lose)
+	(jrst 0 fix1)
+      cortyp-request 
+	(setz)
+	(sixbit |CORTYP|)
+	 (0 0 @ a)
+	 ((setz get-info) 0 tt)
+
+     dsk-sharedp-init 
+	(move tt (% SQUOZE 0 L))
+	(*eval tt)
+	 (*lose)
+	(*suset 0 (% 0 0 t *ruind))	;Get our user index
+	(imuli tt 0 t)
+	(move t (% squoze 0 UPGCP))
+	(*eval t)			;get address of first page map
+	 (*lose)
+	(addi tt 0 t)			;get address of our page map 
+	(jsp t fxcons)			; circular links
+	(movem A (special *OUR-PAGE-MAP-ADDRESS))
+	(move tt (% squoze 0 MMPEAD))
+	(*eval tt)
+	 (*lose)
+	(movss 0 tt)
+	(hrri tt tt)
+	(*getloc tt)			;get contents of mmpead
+	(jsp t fxcons)
+	(movem a (special *ITS-VAL-MMPEAD))
+	(movei a 'T)
+	(popj p)
+
+      dsk-sharedp  
+	(move tt @ (special *OUR-PAGE-MAP-ADDRESS))
+	(move t 0 a)		   ;get page number
+	(rot t -1)		   ;get offset into page table
+	(addi tt 0 t)		   ;get location of page circular links table
+	(movss 0 tt)		   ;address from which to fetch in left half
+	(hrri tt tt)		   ;get result in TT
+	(*getloc tt)		   ;get word
+	(skipl 0 t)		   ;is our index even?
+	 (movss 0 tt)		   ;we want the other (left) half
+	(trzn tt 400000)	   ;is it an MMP/MEMPNT entry?
+	 (jrst 0 yes-on-dsk)	   ;  nope, probably not on disk
+	(trze tt 200000)	   ;Is it a MEMPNT entry?
+	 (jrst 0 yes-on-dsk)	   ;  Yes, I don't know what to do with these..
+	(add tt @ (special *ITS-VAL-MMPEAD))  ;index into mmp table
+	(aos 0 tt)		   ;we want the second word
+	(movss 0 tt)		   ;getloc wants absolute address in LH
+	(hrri tt tt)		   ;we want the result in TT
+	(*getloc tt)		   ;get the MMP second word
+	(hrrzs 0 tt)		   ;we just look at the right half
+	(jumpn tt yes-on-dsk)	   ;not on disk, not in shared-page hash table
+     ret-nil 
+	(tdza a a)		   ;Ha, it's shareable
+     yes-on-dsk	
+	(movei a 'T)
+	(popj p)
+
+     who-bore-me? 
+	(movei tt 1 flp)
+	(hrli tt **rlfi)
+	(jsp t (/0*0PUSH -4))
+	(*break 10. tt)
+	(pushj p take2)
+	(push p 1)
+	(pushj p take2)
+	(pop p 2)
+	(jcall 2 'CONS)
+     take2
+	(pop flp tt)
+	(pushj p sixatm)
+	(call 1 'NCONS)
+	(push p 1)
+	(pop flp tt)
+	(pushj p sixatm)
+	(pop p 2)
+	(jcall 2 'CONS)
+
+  (entry fetch-file-page/| subr)
+	(move d ttsar b)
+	(hrrz d f*chan d)	
+	(*call 0 fetch-request)
+	 (jrst 0 fix1)
+	(jrst 0 ret-nil)
+      fetch-request 
+	(setz)
+	(sixbit |CORBLK|)
+	 (immed-info 0 1_12.)		;Control - Fail if can't find page
+	 (immed-info 0 -1)		;from myself
+	 (0 0 @ a)			;just 1 page into core
+	 (0 0 d)			;dsk channl number
+	 (0 0 @ c)			;just 1 page from file
+	 ((setz get-error) 0 tt)
+
+	() 
+
+))
+
+
+(or (get 'BLTARRAY 'VERSION) (load '((LISP) BLTARRAY FASL)))
+(putprop 'PURE-SUSPEND (lsh bporg -10.) 'BPEND)
+
+
+
+(lap-a-list '((lap DEPURIFY-SYMBOL subr)
+		(args DEPURIFY-SYMBOL (() . 1))
+		(hlrz t 0 A)
+		(jsp r skipit?)		;Is the SY2 block marked pure?
+		(hrrz t 1 t)
+		(jsp r skipit?)		; or is the pname-list pure?
+		(hlrz t 0 t)
+		(jsp r skipit?)		; or even a pname-word pure?
+		(movei A '() )
+		(popj p)
+	    skipit? 
+		(move tt t)		;If item is pure, then copy it
+		(lsh tt -11)
+		(move tt ST tt)
+		(tlnn tt 40)		; unlesss it is alread pure
+		 (jrst 0 0 R)
+	    copyit 
+		(push p a)		;save original symbol
+		(hlrz t 0 A)
+		(hrrz t 1 t)
+	        (push p t)		;ptr to pname list
+		(setz a)
+	    loop 
+		(skipn t @ 0 P)		;depurify the pname list
+		 (jrst 0 goon)
+		(move b a)
+		(hlrz a t)
+		(hrrzm t 0 P)
+		(jsp t fxnv1)
+		(jsp t fwcons)
+		(call 2 'CONS)
+		(jrst 0 loop)
+	   goon 
+		(call 1 'NREVERSE)
+		(sub p (% 0 0 1 1))
+		(movei b '() )
+		(call 2 'PNPUT)		;really only interested in sy2 block
+		(move b a)
+		(pop p a)		;original symbol
+		(hlrz r 0 b)		;addr of new sy2 block
+		(hlrz d 0 a)		;addr of old sy2 block
+		(move t 0 d)
+		(tlo t 300)		;CCN bits etc.
+		(movem t 0 r)		;transfer first word of sy2-block
+		(move t 1 d)
+		(hllm t 1 r)		;transfer args property
+		(hrlm r 0 a)		;clobber in new sy2 block
+		(popj p)
+	      () ))
+
+
+;;;; ANNOUNCE-&-LOAD-INIT-FILE
+
+;; Note that as a global variable, ANNOUNCE-&-LOAD-INIT-FILE holds
+;;  the lisp version number as returned by (STATUS LISPV)
+; (program-name &optional jcl-line fix-file)
+;  "program-name" is the name of the program to be announced.
+;    It should have a VERSION property.  It will also be used
+;    as the FN2 of the (default) init file to be loaded.
+;  JCL-LINE should be () or a line of JCL to be parsed as a file
+;    to use instead of the normal init file.
+;  FIX-FILE is a file of fixes to be loaded at startup time, just 
+;    before loading the init file.
+; This function is grossly hacked to fit in the small amount of
+;    core we have on this page.
+
+(defun ANNOUNCE-&-LOAD-INIT-FILE n 
+ (and 
+   (not (= n 0))
+   (let ((INFILE 'T)
+	 (ERRSET)
+	 (opsys (status OPSYS))
+	 (name (arg 1) )
+	 jclp usn uid ofile file fix-file )
+	(setq DEFAULTF `((,(cond ((eq opsys 'TOPS-20) 'PS) ('DSK))
+			  ,(status UDIR))
+			 *
+			 ,(cond ((eq opsys 'ITS)	 '>) 
+				('T 			 'LSP))))
+	(terpri)
+	(princ name)
+	(cond ((setq uid (get name 'VERSION)) 
+	       (princ '| |)
+	       (princ uid)))
+	(princ '#.(maknam (nconc (exploden '| (in SHARABLE | )
+				 (exploden (get 'SHARABLE 'C-VERSION))
+				 (exploden '|, LISP |))))
+	(princ ANNOUNCE-&-LOAD-INIT-FILE)
+	(tyo #/) )
+	(terpri)
+	(and (> n 2) (setq fix-file (arg 3)))
+	(cond ((and fix-file (setq fix-file (probef fix-file)))
+	       (terpri)
+	       (princ '|;Loading FIX file |)
+	       (prin1 (namestring fix-file))
+	       (let (FASLOAD) (load fix-file))
+	       (terpri) ))
+	(setq jclp (and (> n 1) (arg 2))
+	      usn (cond ((status status HOMED) (status HOMED)) 
+			((status UDIR)))
+	      uid (cond (jclp (maknam (nreverse (cdr (reverse jclp)))))
+			((status USERID)))
+	      ofile (mergef uid `((DSK ,usn) * ,name))
+	      file (probef ofile)) 
+	(cond ((cond (file (setq uid (cadr ofile)) 'T)
+		     ((eq opsys 'ITS)
+		      (rplaca (cdr ofile) '*)
+		      (setq uid usn)
+		      (progn 
+		        (setq jclp () )
+			(errset  
+			  (let ((tfile (open ofile '(NODEFAULT))))
+			    (setq file (truename tfile))
+			    (and (not (eq (cadr file) '*))
+				 (setq uid (cadr file)))
+			    (close tfile)
+			    (setq jclp 'T))
+			  () )
+			jclp)))
+	       (princ '|/îLoading |) 
+	       (princ name)
+	       (princ '| INIT file for |)
+	       (princ uid)
+	       (terpri)
+	       (and (atom (errset (load file)))
+		    (princ '| **** Errors while loading|)))
+	      ('T (setq file () )))
+	'*)))
+	  
+
+
+
+(eval-when (load) 
+  (prog (*rset file-page-table file-namelist x y)
+	 ; set up shared pages table
+	(declare (fixnum page-number n i x))
+	(setq file-page-table (array () FIXNUM 256.)
+	      COMMUNIZE-FILE-ARRAY (open (|+internal-call/|| () 'FILE)
+					 '(IN FIXNUM SINGLE))
+	      file-namelist (truename COMMUNIZE-FILE-ARRAY))
+	(cond ((cond ((not (= (in COMMUNIZE-FILE-ARRAY) 0)) (setq y () ) 'T)
+		     ((or (not (memq (cadr file-namelist) '(PURQIO PURQIX)))
+			  (not (eq (caddr file-namelist) ANNOUNCE-&-LOAD-INIT-FILE))) 
+		      (setq y 'T)
+		      'T)) 
+	       (princ '|/îFile | msgfiles)
+	       (prin1 (namestring file-namelist) msgfiles)
+	       (princ '| is not this pdump'd LISP file| msgfiles) 
+	       (cond ((null y)  (error '|LISP| COMMUNIZE-FILE-ARRAY))
+		     ('t (princ '|/îThis has been only a courtesy warning message/î|
+				msgfiles)))))
+	(fillarray file-page-table COMMUNIZE-FILE-ARRAY)
+	(close COMMUNIZE-FILE-ARRAY)
+	(setq y (array () FIXNUM 32.))
+	(unwind-protect 
+	 (do ((page-number 0 (1+ page-number)) 
+	      (i 0 (+ i 4)) 
+	      (x 0) (n 0)  )
+	     ((= page-number 256.) 
+	      (mapc 'DEPURIFY-SYMBOL 
+		    (setq DEPURIFY-SYMBOL 
+			  (append (car file-namelist)
+				  (cdr file-namelist)
+				  '(COMMUNIZE-SINGLE-FILE COMMMUNIZE-FILE-ARRAY
+				    CORBLK DSK |:PDUMPED/î| ))))
+	        ; Success!
+	      (setq |+internal-page-map/|| y))
+	   (setq x (arraycall FIXNUM file-page-table page-number))
+	   (cond ((and (plusp x) (= (logand 3 (lsh x -16.)) 01))
+		   ; LISP system pure pages, which LISP itself 
+		   ; will cut out during a suspend
+		  (setq n (+ n (lsh 1_1 i)))))
+	 (cond ((= i 28.) 
+		(store (arraycall FIXNUM y (// page-number 8.)) n)
+		(setq i -4 n 0))) )))
+)
+
diff --git a/src/liblsp/dprint.fasl b/src/liblsp/dprint.fasl
new file mode 100755
index 00000000..04f759e4
Binary files /dev/null and b/src/liblsp/dprint.fasl differ
diff --git a/src/liblsp/gprint.fasl b/src/liblsp/gprint.fasl
new file mode 100755
index 00000000..fe6ddbbc
Binary files /dev/null and b/src/liblsp/gprint.fasl differ
diff --git a/src/liblsp/struct.fasl b/src/liblsp/struct.fasl
new file mode 100755
index 00000000..5b4f2f89
Binary files /dev/null and b/src/liblsp/struct.fasl differ
diff --git a/src/lspsrc/bits.46 b/src/lspsrc/bits.46
new file mode 100755
index 00000000..4e4f7157
--- /dev/null
+++ b/src/lspsrc/bits.46
@@ -0,0 +1,379 @@
+;;;  BITS    				-*-Mode:Lisp;Package:SI;Lowercase:T-*-
+;;;  **************************************************************************
+;;;  *** MACLISP ******** BITString Support ***********************************
+;;;  **************************************************************************
+;;;  ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
+;;;  **************************************************************************
+
+(herald BITS /46)
+
+(eval-when (eval compile)
+  (or (get 'SUBLOAD 'VERSION)
+      (load '((lisp) subload)))
+  (subload UMLMAC)
+   ;; Remember, EXTMAC down-loads CERROR
+  (subload EXTMAC)
+  (subload DEFSETF)
+  (subload LOOP)
+  (setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED)
+  (setq *:bits-per-word 36. *:bits-per-byte 7.)
+  (defun SI:BITS-ARRAY macro (x)
+      ;; XREF 0 of a BITS is a Maclisp fixnum array
+     `(SI:XREF ,(cadr x) 0))
+  (defun SI:BITS-SIZE macro (x)
+      ;; XREF 1 of a BITS is the BITS-LENGTH of the BITS.
+     `(SI:XREF ,(cadr x) 1))
+
+ )
+
+
+(eval-when (eval load compile)
+    (subload EXTEND)
+    (cond ((status FEATURE COMPLR)
+	   (*lexpr BITS-FILL BITS-REPLACE)
+	   (fixnum (NIBBLE NOTYPE FIXNUM FIXNUM))
+	   (fixnum (NIBBLE-2C NOTYPE FIXNUM FIXNUM))))
+)
+
+
+(define-loop-path (bits bit)
+		  si:loop-sequence-elements-path
+		  (of from to below above downto in by)
+		  bit bits-length bits fixnum)
+
+
+(defclass* BITS BITS-CLASS SEQUENCE-CLASS)
+(defvar PROTECTED-BITSTRING-ARRAYS () )
+
+(def-or-autoloadable FLUSH-MACROMEMOS DEFMAX)
+(def-or-autoloadable TO-BIT SUBSEQ)
+
+
+
+;;;; Basic BITS stuff
+
+(defbothmacro BITSP (x) `(EQ (PTR-TYPEP ,x) 'BITS))
+
+(defun BITP (x)
+  (if (and (fixnump x) (or (= x 0) (= x 1))) *:TRUTH))
+
+(defbothmacro BIT1P (x i) `(= (BIT ,x ,i) 1))
+
+(defun BIT (seq index)
+  (when *RSET 
+	(let ((cnt 1))
+	  (check-subsequence (seq index cnt) 'BITS 'BIT)))
+  (load-byte (arraycall FIXNUM 
+			(si:bits-array seq)
+			(// index #.*:bits-per-word))
+	     (\ index #.*:bits-per-word)
+	     1))
+
+(defsetf BIT ((() seq index) bitval) ()
+  `(RPLACBIT ,seq ,index ,bitval))
+
+
+(defun RPLACBIT (seq index bitval)
+  (when *RSET 
+	(let ((cnt 1))
+	     (check-subsequence (seq index cnt) 'BITS 'RPLACBIT)
+	     (check-type bitval #'FIXNUMP 'RPLACBIT)))
+  (let ((b-arr (si:bits-array seq))
+	(arr-i (// index #.*:bits-per-word)))
+    (store (arraycall FIXNUM b-arr arr-i)
+	   (deposit-byte (arraycall FIXNUM b-arr arr-i)
+			 (\ index #.*:bits-per-word)
+			 1 
+			 bitval))
+  seq))
+
+(defun MAKE-BITS (n)
+   (let ((nwords 0))
+     (declare (fixnum nwords))
+     (if *RSET (check-type n #'SI:NON-NEG-FIXNUMP 'MAKE-BITS)) 
+     (setq nwords (// (+ n #.(1- *:bits-per-word)) #.*:bits-per-word))
+     (if (< nwords 1) (setq nwords 1))	;well, let a 0-length bits go thru
+     (si:extend BITS-CLASS (array () FIXNUM nwords) n)))
+
+
+
+(defcomplrmac BITS-LENGTH (seq) 
+    ;; Well, the problem is that si:bits-size isn't around at load time
+   (subst seq 'SEQ '#%(SI:BITS-SIZE seq)))
+
+(defun BITS-LENGTH (seq)
+  (when *RSET (check-type seq #'BITSP 'BITS-LENGTH))
+  #%(si:bits-size seq))
+
+(defsetf BITS-LENGTH ((() bits) length) ()
+  `(SET-BITS-LENGTH ,bits ,length))
+
+
+(defun SET-BITS-LENGTH (seq count)
+  (when *RSET 
+	(let ((start 0))
+	  (check-subsequence (seq start count) 'BITS 'SET-BITS-LENGTH)))
+  (setf #%(si:bits-size seq) count)
+  seq)
+
+
+
+;;;; NIBBLE and SET-NIBBLE
+
+(defun SI:NIBBLE-COUNTP (count) 
+  (and (fixnump count) (<= 0 count #.*:bits-per-word)))
+
+(defun NIBBLE (bits index count)
+   (declare (fixnum n split hicount))
+   (when *RSET 
+	 (check-subsequence (bits index count) 'BITS 'NIBBLE)
+	 (check-type count #'SI:NIBBLE-COUNTP 'NIBBLE))
+   (let ((split count)
+	 (wordno (// index #.*:bits-per-word)) 
+	 (bitno (\ index #.*:bits-per-word))
+	 (hicount 0)
+	 (n 0)
+	 (b-arr (si:bits-array bits))
+	 fl )
+     (and (> (+ bitno count) #.*:bits-per-word)
+	  (setq fl 'T 
+		split (- #.*:bits-per-word bitno)	;bits this wd
+		hicount (- count split)))		;bits next wd
+     (setq n (load-byte (arraycall FIXNUM b-arr wordno) bitno split))
+     (if fl (setq n (logior (lsh (load-byte 
+				   (arraycall FIXNUM b-arr (1+ wordno))
+				   0 
+				   hicount)
+				 split)	     ;shift past last wd's bits
+			    n)))
+     n))
+
+(defun NIBBLE-2C (bits index count)
+  (let ((n (- #.*:bits-per-word count)))
+    (declare (fixnum n))
+    ;;Extract the nibble, lsh it so its sign bit is in PDP10 sign bit,
+    ;;and ash (with sign extension) to propagate that sign.
+    (ash (lsh (nibble bits index count)		;let NIBBLE do error checking
+	      n)
+	 (- n))))
+
+(defsetf NIBBLE ((() bits index count) byte) ()
+  `(SET-NIBBLE ,bits ,index ,count ,byte))
+
+;set-nibble-2c is identical to set-nibble, unless we really wanted to put
+;in some error checking that the truncated bits are merely sign extension
+;of the kept bits, in other words, that we're not truncating significant bits.
+
+(defsetf NIBBLE-2C ((() bits index count) byte) ()
+  `(SET-NIBBLE ,bits ,index ,count ,byte))
+
+
+(defun SET-NIBBLE (bits index count n)
+   (declare (fixnum wordno bitno split lsh-n hicount))
+   (when *RSET
+	 (check-subsequence (bits index count) 'BITS 'SET-NIBBLE)
+	 (check-type n #'FIXNUMP 'SET-NIBBLE))
+   (let ((split count)
+	 (lsh-n n)
+	 (wordno (// index #.*:bits-per-word)) 
+	 (bitno (\ index #.*:bits-per-word))
+	 (hicount 0)
+	 (b-arr (si:bits-array bits))
+	 fl )
+     (and (> (+ bitno count) #.*:bits-per-word)
+	   ;; If the field extends past the end of this word
+	  (setq fl 'T 
+		split (- #.*:bits-per-word bitno)	;number of bits this wd
+		hicount (- count split)			;number of bits next wd
+		lsh-n (lsh n (- split))))		;adjust N for next word
+     (store (arraycall FIXNUM b-arr wordno)
+	    (deposit-byte (arraycall FIXNUM b-arr wordno)
+			  bitno 
+			  split 
+			  n))
+     (if fl (store (arraycall FIXNUM b-arr (1+ wordno))
+		   (deposit-byte (arraycall FIXNUM b-arr (1+ wordno))
+				 0 
+				 hicount 
+				 lsh-n)))
+     bits))
+
+
+;;;; BITS-REPLACE and BITS-FILL
+
+
+(defun BITS-REPLACE (bs1 bs2 &optional (i1 0) (i2 0) (cnt () cntp))
+   (declare (fixnum ix1 ix2 n l1 l2 n1 n2))
+   (when *RSET 
+	 (let ((cnt1 cnt) (cnt2 cnt))
+	   (check-subsequence (bs1 i1 cnt1) 'BITS 'BITS-REPLACE 'T cntp)
+	   (check-subsequence (bs2 i2 cnt2) 'BITS 'BITS-REPLACE 'T cntp)
+	   (cond (cntp (if (or (not (= cnt cnt1)) (not (= cnt cnt2)))
+			   (setq cnt (if (< cnt1 cnt2) cnt1 cnt2))))
+		 ('T (setq cnt (if (< cnt1 cnt2) cnt1 cnt2)
+			   cntp 'T)))))
+   (prog (l1 l2 n1 n2)
+     START-OUT
+	 (setq n1 (- (setq l1 (bits-length bs1)) i1)
+	       n2 (- (setq l2 (bits-length bs2)) i2))
+	 (cond ((null cntp) (setq cnt (cond ((< n1 n2) n1) (n2))))
+	       ((or (not (fixnump cnt)) (< cnt 0) (> cnt n1) (> cnt n2))
+		(setq cnt (error '|Bad repetition-count argument|
+				 cnt 
+				 'WRNG-TYPE-ARG)
+		      cntp 'T)
+		(go START-OUT)))
+     LOOP
+	 (cond ((not (> cnt #.*:bits-per-word))
+		(set-nibble bs1 i1 cnt (nibble bs2 i2 cnt))
+		(return bs1)))
+	 (set-nibble bs1 i1 #.*:bits-per-word 
+			    (nibble bs2 i2 #.*:bits-per-word))
+	 (setq cnt (- cnt #.*:bits-per-word) 
+	       i1 (+ i1 #.*:bits-per-word) 
+	       i2 (+ i2 #.*:bits-per-word))
+	 (go LOOP)))
+
+(defun BITS-FILL (bs item &optional (i 0) (cnt () cntp))
+   (declare (fixnum worditem w r j))
+   (when *RSET 
+	 (check-subsequence (bs i cnt) 'BITS 'BITS-FILL () cntp)
+	 (setq cntp 'T)
+	 (check-type item #'BITP 'BITS-FILL)) 
+   (let ((worditem (cond ((= item 0) 0) 
+			 (-1)))
+	 (r (- (* (// (+ i #.(1- *:bits-per-word)) 	;Rounding up
+		      #.*:bits-per-word) 		; to a multiple
+		  #.*:bits-per-word) 			; of #.*:bits-per-word
+	       i))
+	 (*RSET))
+     (if (> r cnt) (setq r cnt))
+     (unless (= r 0)				;Fills out the remainder
+	     (set-nibble bs i r worditem)	; of the first word
+	     (setq cnt (- cnt r) i (+ i r)))
+     (do ((w (// cnt #.*:bits-per-word) (1- w))	;Then fill word-by-word
+	  (j i (+ j #.*:bits-per-word)))
+	 ((zerop w)
+	  (when (not (zerop (setq r (\ cnt #.*:bits-per-word))))
+		(set-nibble bs j r worditem)))	;Remainder of last word
+	(set-nibble bs j #.*:bits-per-word worditem))
+     bs))
+
+
+;;;; Defsharps,
+
+(declare (setq USE-STRT7 'T))
+
+(defvar /#-MACRO-DATALIST () )
+
+(defun |#-MACRO-/"| (c)	 		;#"..." For BITS's in hexadecimal form
+   (/#-bs-reader c 4 '/"))
+
+;; 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)))))
+
+
+;; This fun is called only by the defsharp function for #B"..."
+(defun /#-/#B-reader (lbb)
+   (prog (str c char bb)
+	 (declare (fixnum c bb))
+	 (setq c 0 bb (^ 2 lbb))
+	 (tyi)			 	;toss out first /"
+      A	(setq c (setq char (tyi)))
+         ;; Here's an open-coding of DIGIT-WEIGHT
+	(cond ((and (<= #/0 c) (<= c #/9))
+	       (setq c (- c #/0)))
+	      ((and (<= #/A c) (<= c #/z))
+	       (setq c (- c (- #/A 10.))))
+	      ((and (<= #/a c) (<= c #/z))
+	       (setq c (- c (- #/a 10.))))
+	      ('T (and (not (= c #/")) 
+		       (error "#/" string does not end with /" "))
+		  (return (replace (make-bits (length str)) (nreverse str)))))
+	(or (< c bb) 
+	    (error "Digit too big for #/" " (ascii char))) 
+	(do ((i4 lbb (1- i4)))
+	    ((= i4 0) )
+	  (push (boole 1 c 1) str)
+	  (setq c (lsh c -1)))
+	(go A)))
+
+
+(def-or-autoloadable /#-bs-reader SHARPM)
+
+
+;;;; Some Methods for BITS's
+
+;Print at most PRINLENGTH bytes, if PRINLENGTH is nonnull.
+;; This could stand much improvement!!
+
+(DEFMETHOD* (:PRINT-SELF BITS-CLASS) (OB STREAM () ()
+				   &AUX ABBREV (NBITS (BITS-LENGTH OB)))
+    (COND ((AND PRINLENGTH (> NBITS (* PRINLENGTH #.*:BITS-PER-BYTE)))
+	   (SETQ NBITS (* PRINLENGTH #.*:BITS-PER-BYTE) ABBREV 'T)))
+    (SETQ STREAM (SI:NORMALIZE-STREAM STREAM))
+    (PRINC '|#B/"| STREAM)
+    (DO ((I 0 (1+ I)))
+	((NOT (< I NBITS)))
+	(DECLARE (FIXNUM MX I))
+	(IF (= (BIT OB I) 0) 
+	    (PRINC '|0| STREAM)
+	    (PRINC '|1| STREAM)))
+    (AND ABBREV (PRINC  '|...| STREAM))
+    (PRINC '|/"| STREAM))
+
+
+(DEFMETHOD* (EQUAL BITS-CLASS) (OBJ OTHER-OBJ)
+    (COND ((NOT (BITSP OBJ)) 
+	   (ERROR '|First OBJ not a BITS? - EQUAL->BITS-CLASS| OBJ))
+	  ((NOT (BITSP OTHER-OBJ)) () )
+	  ((LET ((LN1 (BITS-LENGTH OBJ)) (LN2 (BITS-LENGTH OTHER-OBJ)))
+		(DECLARE (FIXNUM LN1 LN2 I))
+		(COND ((NOT (= LN1 LN2)) () )
+		      ('T (SETQ LN2 #.*:bits-per-word)
+			  (DO ((I 0 (+ I #.*:bits-per-word))) 
+			      ((NOT (< I LN1)) 'T)
+			    (AND (> (+ I #.*:bits-per-word) LN1)
+				 (SETQ LN2 (- LN1 I)))
+			    (OR (= (NIBBLE OBJ I LN2) (NIBBLE OTHER-OBJ I LN2))
+				(RETURN () )))))))))
+
+(DEFMETHOD* (SXHASH BITS-CLASS) (OBJ)
+   (DO ((LN1 (BITS-LENGTH OBJ))
+	(I 0 (+ I #.*:bits-per-word))
+	(LN2 #.*:bits-per-word)
+	(HN #.(SXHASH 'BITS)))
+       ((NOT (< I LN1)) HN)
+     (AND (> (+ I #.*:bits-per-word) LN1) (SETQ LN2 (- LN1 I)))
+     (SETQ HN (LOGXOR (NIBBLE OBJ I LN2) (ROT HN 1)))))
+
+(DEFMETHOD* (PURCOPY BITS-CLASS) (OBJ)
+    (PUSH (SI:BITS-ARRAY OBJ) PROTECTED-BITSTRING-ARRAYS)
+    (PURCOPY->OBJECT-CLASS OBJ 'PURCOPY))
+
+(defmethod* (DESCRIBE BITS-CLASS) (ob stream level)
+  (declare (special SI:DESCRIBE-MAX-LEVEL))
+  (if (and (not (> level SI:DESCRIBE-MAX-LEVEL)) 
+	   (bitsp ob))
+      (format stream 
+	      "~%~vTThe BITString ~S has ~D elements."
+	      level ob (bits-length ob))))
+
+
+(defmethod* (USERATOMS-HOOK BITS-CLASS) (frob)
+  (ncons (macroexpand
+	   `(SI:EXTEND BITS-CLASS
+		      ,(if (plusp (bits-length frob))
+			   (let (((atyp adim) (arraydims (si:bits-array frob)))
+				 (listed (listarray (si:bits-array frob))))
+				`(FILLARRAY (ARRAY () ,atyp ,adim) ',listed)))
+		      ,(bits-length frob)))))
+
+
+
diff --git a/src/lspsrc/funcel.3 b/src/lspsrc/funcel.3
new file mode 100755
index 00000000..63bf9421
--- /dev/null
+++ b/src/lspsrc/funcel.3
@@ -0,0 +1,65 @@
+;;;   FUNCEL			-*-Mode:Lisp;Package:SI;Lowercase:T-*-
+;;;   ****************************************************************
+;;;   *** MacLISP ******** Function-Cell Hacking *********************
+;;;   ****************************************************************
+;;;   ** (c) Copyright 1981 Massachusetts Institute of Technology ****
+;;;   ****************************************************************
+
+(herald FUNCEL /2)
+
+(eval-when (eval compile) 
+   (load '((lisp) subload)))
+
+(eval-when (eval load compile)
+    (subload EXTEND))
+
+;;;; FMAKUNBOUND, FSYMEVAL, and FSET, for maclisp
+	       
+
+(defclass* SUBR SUBR-CLASS MACLISP-PRIMITIVE-CLASS)
+(defclass* LSUBR LSUBR-CLASS MACLISP-PRIMITIVE-CLASS)
+
+(defmethod* (:PRINT-SELF SUBR-CLASS) (obj stream () () )
+  (si:print-extend obj (si:xref obj 0) stream))
+
+(defmethod* (:PRINT-SELF LSUBR-CLASS) (obj stream () () )
+  (si:print-extend obj (si:xref obj 0) stream))
+
+(defun FMAKUNBOUND (sym)
+  (if *RSET (or (and sym (symbolp sym))
+		(check-type sym #'SYMBOLP 'FMAKUNBOUND)))
+  (prog (prop)
+     A  (if (null (setq prop (getl sym '(SUBR LSUBR EXPR MACRO))))
+	    (return () ))
+	(remprop sym (car prop))
+	(go A))   ;Avoid lossage when symbol has both MACRO and SUBR
+  sym)
+
+(defun FSYMEVAL (a &aux pl fun) 
+   (do () 
+       ((and (symbolp a)
+	     (setq pl (getl a '(SUBR LSUBR MACRO EXPR))))
+	() ) 
+     (setq a (error "Not a function name -- FSYMEVAL" a 'WRNG-TYPE-ARG)))
+   (setq fun (cadr pl))
+   (caseq (car pl)
+	  ((SUBR LSUBR) 
+	    (si:extend (if (eq (car pl) 'SUBR) SUBR-CLASS LSUBR-CLASS) 
+		       fun 
+		       (args a)))
+	  (EXPR fun)
+	  (MACRO `(MACRO . ,fun))))
+
+
+(defun FSET (sym val &aux (type (typep val)))
+  (fmakunbound sym)
+  (cond ((and (eq type 'LIST) (memq (car val) '(MACRO LAMBDA)))
+	 (cond ((eq (car val) 'MACRO) (putprop sym (cdr val) 'MACRO))
+	       ((eq (car val) 'LAMBDA) (putprop sym val 'EXPR))))
+	((eq type 'SYMBOL) (putprop sym val 'EXPR))
+	((memq (setq type (type-of val)) '(SUBR LSUBR))
+	  (putprop sym (si:xref val 0) type)
+	  (args sym (si:xref val 1)))
+	('T (error "Not a function? - FSET" val)))
+  val)
+
diff --git a/src/lspsrc/ldbhlp.1 b/src/lspsrc/ldbhlp.1
new file mode 100755
index 00000000..ad4b0627
--- /dev/null
+++ b/src/lspsrc/ldbhlp.1
@@ -0,0 +1,61 @@
+;;;   LDBHLP 						  -*-LISP-*-
+;;;   **************************************************************
+;;;   ***** MACLISP ******* BYTE-manipulation Helpers **************
+;;;   **************************************************************
+;;;   ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
+;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
+;;;   **************************************************************
+
+
+(herald LDBHLP /1)
+
+(lap-a-list 
+    '((lap *LOAD-BYTE subr)	
+	 (args *LOAD-BYTE (() . 3))	;Args = (word position size)
+	 (push p (% 0 0 fix1))
+	 (move d 0 c)
+	 (rot d -6)
+	 (hrr d 0 b)
+	 (rot d -6)
+	 (move tt 0 a)
+	 (jrst 0 LD)
+      (entry *LDB subr)	
+	 (args *LDB (() . 2))	;Args = ( position_30.+size_24.  word )
+	 (push p (% 0 0 fix1))
+	 (move d 0 a)
+	 (move tt 0 b)
+      LD (hrri d tt)
+	 (ldb tt d)
+	 (popj p)
+      (entry *DEPOSIT-BYTE subr)
+	 (args *DEPOSIT-BYTE (() . 4))  ;Args = (word position size byte)
+	 (push p (% 0 0 fix1))
+	 (move r 0 4)
+	 (move d 0 c)
+	 (rot d -6)
+	 (hrr d 0 b)
+	 (rot d -6)
+	 (move tt 0 a)
+	 (jrst 0 DP)
+      (entry *DPB subr)
+	 (args *DPB (() . 3))	;Args = ( newbyte position_30.+size_24.  word )
+	 (push p (% 0 0 fix1))
+	 (move r 0 a)
+	 (move d 0 b)
+	 (move tt 0 c)
+      DP (hrri d tt)
+	 (dpb r d)		;puts result in TT
+	 (popj p)
+      (entry ASH subr)
+	 (args ASH (() . 2))
+	 (push p cfix1)
+	 (jsp t fxnv1)
+	 (jsp t fxnv2)
+	 (ash tt 0 d)
+	 (popj p)
+	 () ))
+
+(or (get 'ASH 'macro)			;foofoofoo!
+    (macro ASH (x) `(LSH ,.(cdr x))))
+
+
diff --git a/src/lspsrc/lexprf.1 b/src/lspsrc/lexprf.1
new file mode 100755
index 00000000..232fd7c7
--- /dev/null
+++ b/src/lspsrc/lexprf.1
@@ -0,0 +1,13 @@
+;;;  LEXPR-FUNCALL, for old lisps which don't have it.   -*-lisp-*-
+
+
+(defun LEXPR-FUNCALL n 
+  (and (< n 1) (error '|0 args? - LEXPR-FUNCALL|))
+  (let ((fun (arg 1)))
+    (if (<= n 1)
+	(funcall fun)
+	(do ((i 2 (1+ i))
+	     (l () (cons (arg i) l)))
+	    ((= i n) 
+	      (apply fun (nreconc l (arg n))))))))
+	  
\ No newline at end of file
diff --git a/src/lspsrc/nilaid.173 b/src/lspsrc/nilaid.173
new file mode 100755
index 00000000..da0b934c
--- /dev/null
+++ b/src/lspsrc/nilaid.173
@@ -0,0 +1,813 @@
+;;;   NILAID	-*-MODE:LISP;PACKAGE:SI-*- 		  -*-LISP-*-
+;;;   **************************************************************
+;;;   ***** MACLISP ******* Aid to MACLISP for NIL-like Code *******
+;;;   **************************************************************
+;;;   ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
+;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
+;;;   **************************************************************
+
+;;; Support routines which help MACLISP/LISPM to run NIL-like code.
+;;; To read this file in on LISPM, do (PACKAGE-DECLARE * SYSTEM 100)
+;;; Current features translated, and limitations:
+;;;   A sequence of length "n" is translated into a hunk of size "n+2"
+;;; 	  where the 1st element is the symbolic data type. (0th for CLASSes).
+;;;	  On LISPM, they translate into ART-Qs of 1 dimension.
+
+
+(herald NILAID /173)
+
+(eval-when (eval compile)
+  (or (get 'SUBLOAD 'VERSION)
+      (load '((lisp) subload)))
+  )
+
+ ;; By loading all this stuff into the "SOBARRAY", and then re-INITIALIZEing 
+ ;;  at the end of this file, we can insure that all new names will appear on 
+ ;;  both obarrays in the compiler.
+(eval-when (eval load)
+   (cond ((status FEATURE COMPLR)
+	   (setq OBARRAY SOBARRAY READTABLE SREADTABLE))
+	 ((not (memq (fboundp 'SPECIAL) '(MACRO FSUBR))) 
+	   (macro SPECIAL (x) ''SPECIAL)))
+     ;;This doesn't exist in maclisp - just ignore it for now.  2-Feb-80 JonL
+   (defun (GLOBALIZE macro) (x) x ''GLOBALIZE)
+   (subload NALET)
+   (sstatus uuoli)	 	;Foo. Foo.	
+   )
+
+
+
+
+
+(eval-when (compile) 
+	   (setq DEFMACRO-CHECK-ARGS () 
+		 DEFMACRO-DISPLACE-CALL ()  
+		 DEFMACRO-FOR-COMPILING () ))
+
+(defmacro FMOVEQQ (a b &optional (fl 'SUBR)) 
+   #Q `(FSET ',a (FSYMEVAL ',b))
+   #M `(PUTPROP ',a (GET ',b ',fl) ',fl)
+ )
+
+(defmacro FFGET (a &optional (fl 'SUBR))
+   #Q `(FSYMEVAL ',a)
+   #M `(GET ',a ',fl)
+   )
+
+(fmoveqq LIST-LENGTH LENGTH)
+(fmoveqq MACLISP-INTERN INTERN)
+
+#M 
+(eval-when (eval compile load)
+     ;; Have to "hide" some symbols so that the COMPLR wont think that it
+     ;;  "knows" all about them.
+    (cond ((status feature COMPLR)
+	   (setq |old-losing-symbols| () )
+	   ((lambda (obarray y)
+		(mapc '(lambda (x)
+			 (push x |old-losing-symbols|)	;gc protection ???
+			 (setq obarray sobarray)
+			 (remob x)
+			 (setq obarray cobarray)
+			 (remob x)
+			 (setq y (copysymbol x () ))
+			 (and (get x 'SUBR) (putprop y (get x 'SUBR) 'SUBR))
+			 (and (get x 'LSUBR) (putprop y (get x 'SUBR) 'LSUBR))
+			 (intern y)
+			 (setq obarray sobarray)
+			 (intern y))
+		      '(INTERN LENGTH)))
+	    sobarray () )))
+)
+
+
+;;;; DECLAREs and LOADs 
+
+(declare (special  NILAID:INCHBACK  |general-POSQer|  |general-FILLer| 
+		   /#-MACRO-DATALIST )
+	 (*lexpr STRING-SUBSEQ))
+
+
+(eval-when (eval compile load)
+    (cond ((status feature COMPLR)
+	   (*lexpr |general-POSQer| |general-FILLer| BPOSQ BSKIPQ SKIPQ  
+		   LIST-POSQ VECTOR-POSQ BITS-POSQ POSQ 
+		   LIST-FILL VECTOR-FILL STRING-FILL STRING-FILL-N BITS-FILL 
+		   INCH INCHPEEK OUCH OUSTR 
+		   NIL-INTERN INTERN SYMBOLCONC REPLACE)
+	   (*expr LENGTH LIST-LENGTH NIL-LENGTH MACLISP-INTERN 
+		  MAKE-VECTOR MAKE-STRING STRING-PNGET STRING-GET-PNAME 
+		  |no-funp/||  |side-effectsp/|| )
+	   (fixnum (LENGTH) (NIL-LENGTH) (LIST-LENGTH))
+	   (fixnum PRINLEVEL PRINLENGTH)
+	   (fixnum (SI:FULLADD fixnum fixnum fixnum) 
+		   (SI:FULLSUB fixnum fixnum fixnum)
+		   (SI:FULLMUL fixnum fixnum fixnum)
+		   (SI:FULLDIV fixnum fixnum fixnum))
+	   (special *:TRUTH 
+		    +INTERNAL-INTERRUPT-BOUND-VARIABLES 
+		    SI:CONSTANTS-TABLE)))
+)
+
+
+(eval-when (eval compile load)
+   (let  (#-LISPM (DEFAULTF '((LISP) * FASL)) 
+	  #-LISPM (STANDARD-OUTPUT TYO)
+	  *RSET FASLOAD)
+	(mapc '(lambda (x) 
+		 (COND ((get x 'VERSION))
+		       ((probef x) (load x))
+		       ('T  ;compiler turns off MSGFILES!
+			  (terpri STANDARD-OUTPUT)
+			  (princ '|WARNING!  File | STANDARD-OUTPUT)
+			  (prin1 x STANDARD-OUTPUT)
+			  (princ '| is missing.  Features will lose!| STANDARD-OUTPUT))))
+	      (append 
+	        '(DEFMAX MACAID DEFMACRO MLMAC UMLMAC BACKQ 
+		   SHARPM SHARPConditionals)
+	       #-LISPM 
+		'(MLSUB FORMAT CERROR FUNCEL) 
+		'(EXTEND EXTMAC SUBSEQ VECTOR BITS STRING SETF  
+		  LSETS DRAMMP) 
+	       #-LISPM 
+	        '(YESNOP)
+		(cond ((null COMPILER-state)
+		       '(NADEFVST))
+		      ((eq COMPILER-state 'TOPLEVEL)
+		         ;; DEFVST must come before DEFSETF, since latter has
+		         ;;  some compiled STRUCTS in it.
+		       '(EXTHUK NADEFVST DEFSETF))
+		      ('(DEFVST DEFSETF))) 
+	       #+LISPM 
+	        '(NALOOP DEFSETF) 
+	       ))
+	#-LISPM (progn (remprop 'LOOP 'AUTOLOAD)
+		       (def-or-autoloadable LOOP NALOOP)
+		       (def-or-autoloadable DEFSETF DEFSETF)
+		       (def-or-autoloadable DEBUG DEBUG)
+		       (def-or-autoloadable SFA-UNCLAIMED-MESSAGE EXTSFA))
+	)
+   #M (setsyntax '/. (boole 4 (status syntax /.) 1_17.) () )
+   (setq  SI:CONSTANTS-TABLE () )
+   )
+
+
+
+;;;; MACROs for temporary use
+
+
+(defmacro si:output-fixnum (&REST x) `(OUT ,. x))
+
+(defmacro si:output-byte (&REST x) `(TYO ,. x))
+
+
+#M 
+  (progn 'compile 
+     (defmacro DEFLEXPRMACRO (name fun first-arg args-prop &aux g)
+	(si:gen-local-var g "DEFLEXPRMACRO")
+	`(PROGN 'COMPILE 
+		(AND (STATUS FEATURE COMPLR) 
+		     (EVAL '(DEFMACRO ,name (&REST W)
+				`(,',fun ,',first-arg ,. W)))) 
+		(DEFUN ,name ,g 
+		   ,g 
+		   (|*lexpr-funcall-2| ',name ,fun ,first-arg ,args-prop))))
+
+     (defmacro lexpr-fcl-helper (n) 
+	       (do ((i 1 (1+ i)) (w () ))
+		   ((> i n) `(LSUBRCALL T FUN FIRST-ARG ,. (nreverse w)))
+		 (push `(ARG ,i) w)))
+     (defun |*lexpr-funcall-2| (name fun first-arg args-prop) 
+	 ;Function for passing the buck
+	(let ((n (arg () )))
+	     (and (or (< n (car args-prop)) (> n (cdr args-prop)))
+		  (error '|Wrong number args to function| name))
+	     (caseq n 
+		    (1  (lexpr-fcl-helper 1))
+		    (2  (lexpr-fcl-helper 2))
+		    (3  (lexpr-fcl-helper 3))
+		    (4  (lexpr-fcl-helper 4))
+		    (5  (lexpr-fcl-helper 5))
+		    (6  (lexpr-fcl-helper 6)))))
+
+     )	;end of #M 
+
+#Q 
+ (defmacro DEFLEXPRMACRO (name fun first-arg args-prop &aux g)
+	(si:gen-local-var g "DEFLEXPRMACRO")
+	`(DEFUN ,name (&REST ,g)
+		(LEXPR-FUNCALL ,fun ,first-arg ,g)))
+
+(eval-when (compile) 
+	   (setq DEFMACRO-CHECK-ARGS 'T 
+		 DEFMACRO-DISPLACE-CALL 'T  
+		 DEFMACRO-FOR-COMPILING 'T))
+
+
+;;;; Set up of value for *:TRUTH
+
+(defclass* TRUTH TRUTH-CLASS CONSTANT-CLASS TYPEP CONSTANT)
+
+(defmethod* (:PRINT-SELF TRUTH-CLASS) (() stream () ())
+   (princ '|#T| stream))
+(defmethod* (FLATSIZE TRUTH-CLASS) (() () () ()) 2)
+(defmethod* (DESCRIBE TRUTH-CLASS) (() &optional (stream standard-output) () )
+   (terpri stream)
+   (princ '|#T is the 'truth' constant| stream))
+(defmethod* (USERATOMS-HOOK TRUTH-CLASS) (() ) (list '*:TRUTH))
+(setq *:TRUTH (purcopy (si:make-extend 1 TRUTH-CLASS)))
+
+
+#M (fmoveqq FSET-CAREFULLY FSET)
+
+;;;; NIL-type defsharps for MacLISP
+
+
+(defsharp /! SPLICING (() ) 		;#!...!, for symbolic CONSTANTs
+   (/#-flush-chars-not-set #/! 'T))
+
+(defsharp /= (c)
+    ;#=~A converts character object "~A" into its "ascii" value
+    ;#=n  converts number n into character with that value
+   c
+   (error '|# syntax not yet implemented| '=))
+
+(defsharp /I SPLICING (()) 
+   (error '|# syntax is not yet defined| 'I))
+
+(defsharp /L SPLICING  (())			;#Lfoo= assigns "foo" as label
+   (/#-flush-chars-not-set '(#/= #/#) 'T))	;#Lfoo# references prior "foo"
+
+(defsharp /[  SPLICING (())			;#[...] for ARRAYs
+   (/#-flush-chars-not-set #/] 'T))
+(defsharp /{  SPLICING (())			;#{...} for random CLASSes
+   (/#-flush-chars-not-set #/} 'T))
+	  
+;;;; =$, <$ etc
+
+(defbothmacro =$ (a b) `(= ,a ,b))
+
+(defmacro (gen-$ defmacro-for-compiling () defmacro-displace-call () )
+	  (&rest l &aux x$)
+   `(PROGN 'COMPILE 
+	   ,.(mapcar 
+	       #'(lambda (x) 
+		    (setq x$ (symbolconc x '$))
+		     ;; puts on the "$" at the end
+		    `(DEFUN ,x$ NARGS (SI:<=>-AUX NARGS ',x)))
+	       l)))
+
+(gen-$ < > <= >=)
+
+(setq SI:<=>-AUX *:TRUTH)
+
+
+(defun SI:CIRCULARITY-ERROR (fun arglist)
+   (cerror #T () ':INCONSISTENT-ARGUMENTS 
+	   "~1G~S called with an argument that may be circular~ 
+             (argument addresses are ~S).~@
+	     Supply an integer as an increased depth limit, if you want." 
+	   arglist fun (mapcar #'MAKNUM arglist)))
+
+
+;;;; SI:SYMBOL-CONS, MAKE-SYMBOL, GET-PNAME, SI:SYMBOL-PACKAGE-PREFIX, 
+;; 	and FILL-DIGITS-INTO-STRING
+
+
+(defun SI:SYMBOL-CONS (str)
+   (if *RSET (check-type str #'STRINGP 'SI:SYMBOL-CONS))
+   (pnput (string-pnget str 7) () ))
+
+;;This is essentially the same definitions as in NILSRC;ZRF >, except for
+;; the "package" argument.
+(defun MAKE-SYMBOL (x &optional (ini-value () valuep) 
+				(ini-function () functionp) 
+				(plist () ) 
+				(package () packagep))
+  (setq x (si:symbol-cons (to-string x)))
+  (when *RSET 
+	(if plist (check-type plist #'PAIRP 'MAKE-SYMBOL)))
+  (setplist x plist)
+  (if packagep (setq x (maclisp-intern x)))
+  (if valuep (set x ini-value))
+  (if functionp (fset x ini-function)) 
+  x)
+
+
+(defun NILAID-GET-PNAME (x &aux pkg) 
+   (multiple-value (pkg x) (nilaid-pkg-pname x 'T () ))
+   x)
+
+(defun SI:SYMBOL-PACKAGE-PREFIX (x &optional shortp &aux pkg)
+   (multiple-value (pkg x) (nilaid-pkg-pname x () shortp))
+   pkg)
+
+(defun NILAID-PKG-PNAME (x pnamep shortp)
+   (let* ((str (string-get-pname x))
+	  (*RSET)
+	  (i (string-posq-n #/: str)))
+     (cond ((null i) (values () str)) 
+	   ((let ((key (string-upcase (string-subseq str 0 i))))
+	      (setq key (caseq (string-length key)
+			   (0 "")
+			   (1 (if (not (string-mismatchq key "*")) key))
+			   (2 (cond ((string-mismatchq key "SI") () )
+				    (shortp key)
+				    ("SYSTEM-INTERNALS"))) 
+			   (4 (if (not (string-mismatchq key "USER")) key)) 
+			   (6 (if (not (string-mismatchq key "GLOBAL")) key))
+			   (16. (cond ((string-mismatchq key "SYSTEM-INTERNALS") () )
+				      (shortp "SI")
+				      (key)))))
+	      (if (and key pnamep) (setq str (string-subseq str (1+ i))))
+	      (values key str))))))
+
+
+;;Code just 'lifted' out of NILSRC;EARLY >
+(defun FILL-DIGITS-INTO-STRING 
+       (str q &optional (i 0) (cnt () cntp) (radix 10.))
+    ;;Converts the number 'q' into digits base 10. fills them into the
+    ;;  indicated subsequence of 'str'
+   (when *RSET 
+	 (check-type q #'FIXNUMP 'FILL-DIGITS-INTO-STRING)
+	 (check-subsequence (str i cnt) 
+			    'STRING 'FILL-DIGITS-INTO-STRING 'T cntp)
+	 (setq cntp 'T))
+   (if (not cntp) (setq cnt (- (string-length str) i)))
+   (do ((k (+ cnt i -1) (1- k))
+	(r 0))
+       ((< k i) 
+	 (if (not (= q 0)) (ferror () "Huh? - FILL-DIGITS-INTO-STRING"))
+	 str)
+     (declare (fixnum k))
+     (setq r (\ q radix) q (// q radix))
+     (rplachar-n str k (+ r (if (< r 10.) #/0 (- #/A 10.))))))
+
+
+;;;; SI:FULLADD etc
+
+#+PDP10 
+(eval-when (eval compile load)
+    ;; 30. bits per fixnum is right for the VAX!
+   (setq *:BITS-PER-FIXNUM 36.)
+)
+
+
+#+PDP10 
+(lap-a-list '((lap SI:FULLADD SUBR)
+		(args SI:FULLADD (() . 3))
+		      (push p (% 0 0 fix1))
+		      (movei ar1 '0)	;assume no overflow
+		      (jfcl 8 (* 1))
+		      (move tt 0 a)
+		      (add tt 0 b)
+		  CARRY-AND-SNIFF-OVERFLOW 
+		      (add tt 0 c)	;should only be -1, 0 or +1
+		      (jfcl 8 TGXA)
+		  TG1 (movem ar1 (special *:ar2))
+		      (movei ar1 '1)
+		      (movem ar1 (special *:arn))  ;1 extra return value
+		      (popj p)
+		  TGXA (tlce tt #o400000)	   ;overflow -- reset sign bit
+			(skipa ar1 (% 0 0 '1))	   ; and produce 'carry'
+			 (movei ar1 '-1)
+		      (jrst 0 TG1)
+
+	      (entry SI:FULLSUB SUBR)
+		(args SI:FULLSUB (() . 3))
+		      (push p (% 0 0 fix1))
+		      (movei ar1 '0)	  ;assume no borrow
+		      (move tt 0 a)
+		      (jfcl 8 (* 1))
+		      (sub tt 0 b)
+		      (jrst 0 CARRY-AND-SNIFF-OVERFLOW)
+
+	      (entry SI:FULLMUL SUBR)
+		(args SI:FULLMUL (() . 3))
+		      (push p (% 0 0 fix1))
+		      (move tt 0 a)
+		      (mul tt 0 b)
+		      (jfcl 8 (* 1))
+		      (add (tt 1) 0 c)
+		      (jfcl 8 TGOM)
+		      (jumpge (tt 1) (* 3))
+		       (camn tt (% -1))	;If hi word merely is extending the
+			(setz tt)	; sign bit of the low word, then 0 it.
+		  TG2 (jsp t fix1a)	  ;high word
+		      (movem a (special *:ar2))
+		      (movei a '1)
+		      (movem a (special *:arn))
+		      (move tt (tt 1))
+		      (popj p)
+		  TGOM (jumpl (tt 1) (* 3))
+		        (camn tt (% -1));If hi word merely is extending the
+			 (setz tt)	; sign bit of the low word, then 0 it.
+		       (tlce (tt 1) #o400000)
+		        (aosa 0 tt)
+			 (sos 0 tt)
+		       (jrst 0 TG2)
+
+	      (entry SI:FULLDIV SUBR)
+		(args SI:FULLdiv (() . 3))
+		      (push p (% 0 0 fix1))
+		      (move (tt 2) 0 a)
+		      (move (tt 1) 0 b)
+		      (div (tt 1) 0 c)
+		      (move tt (tt 2))
+		      (jrst 0 TG2)
+		      () ))
+
+
+
+#-PDP10 
+(eval-when (eval compile load)
+    ;; 30. bits per fixnum is right for the VAX!
+   (setq *:BITS-PER-FIXNUM 30.)
+    ;; A value to use as a 'base' for bignum digits in the emulated NIL
+   (setq SI:FULL-NON-NEG-FIXNUMP (expt 2 (1- *:bits-per-fixnum))) 
+    ;; Negative of 'base' for bignum digits
+   (setq SI:FULL-FIXNUMP (minus SI:FULL-NON-NEG-FIXNUMP))
+)
+
+#+PDP10 
+(eval-when (eval compile)
+    ;; Just in order to be able to read this stuff!
+   (setq SI:FULL-NON-NEG-FIXNUMP 1 SI:FULL-FIXNUMP -1)
+)
+
+#-PDP10 
+(progn 'COMPILE 
+
+
+(declare (special *:BITS-PER-FIXNUM SI:FULL-NON-NEG-FIXNUMP SI:FULL-FIXNUMP))
+
+;;Tentatively, these values should be such that three "full-fixnums" added
+;; can't overflow a regular fixnum.
+
+(defun SI:FULLADD (x y cry)
+   (si:fulladd-sub x y cry 'SI:FULLADD))
+(defun SI:FULLSUB (x y cry)
+   (si:fulladd-sub x y cry 'SI:FULLSUB))
+(defun SI:FULLADD-SUB (x y cry opname)
+   (when *RSET 
+	 (multiple-value (x y cry) (SI:FULLCHECK x y cry opname))
+	 (check-type CRY #'SI:CRY-BITP opname))
+   (setq x (cond ((eq opname 'SI:FULLADD) (plus x y cry))
+		 ('T (difference x y cry))))
+   (psetq x (remainder x #.SI:FULL-NON-NEG-FIXNUMP) 
+	  y (quotient x #.SI:FULL-NON-NEG-FIXNUMP))
+   (if (< x 0) (setq x (+ x #.SI:FULL-NON-NEG-FIXNUMP)))
+   (values x y))
+
+(defun SI:FULLMUL (x y cry)
+   (when *RSET (multiple-value (x y cry) (si:fullcheck x y cry 'SI:FULLMUL)))  
+   (setq x (times x y))
+   (if (not (= cry 0)) (setq x (plus x cry)))
+   (setq y (quotient x SI:FULL-NON-NEG-FIXNUMP) 
+	 x (remainder x SI:FULL-NON-NEG-FIXNUMP))
+    ;; "y" here holds the "high-order" digit.
+   (values x y))
+(defun SI:FULLDIV (lo hi divsr)
+   (when *RSET (multiple-value (lo hi divsr) 
+			       (si:fullcheck lo hi divsr 'SI:FULLDIV)))  
+   (unless (= hi 0)
+	   (setq lo (plus (times hi SI:FULL-NON-NEG-FIXNUMP) lo)))
+   (setq hi (remainder lo divsr) lo (quotient lo divsr))
+    ;; "lo" here holds the quotient value, and "hi" the remainder
+   (values lo hi))
+
+(defun SI:FULLCHECK (x y z opname)
+   (check-type x #'SI:FULL-FIXNUMP opname)
+   (check-type y #'SI:FULL-FIXNUMP opname)
+   (check-type z #'SI:FULL-FIXNUMP opname)
+   (values x y z))
+
+
+(defun SI:FULL-FIXNUMP (x) 
+   (and (fixnump x)
+	(< x #.SI:FULL-NON-NEG-FIXNUMP)
+	(>= x #.SI:FULL-FIXNUMP)))
+
+(defun SI:CRY-BITP (x) 
+    ;; a "carry" bit can only be 0, 1, or -1
+   (and (fixnump x)
+	(or (= x 0) (= x 1) (= x -1))))
+
+
+)
+
+;;;; SEQUENCEP, and NIL versions of LENGTH and SET-LENGTH 
+
+(defun SEQUENCEP (x)
+   (cond ((or (null x) 		;Well, why not?  maybe its the NULL sequence?
+	      (memq (type-of x) '(PAIR VECTOR STRING BITS)))
+	  *:TRUTH)
+	  ;; Could be extended someday?
+	 ('T () )))
+
+(defun NIL-LENGTH (x)
+   (cond ((null x) 0)
+	 ('T (typecaseq X
+		(PAIR 	(list-length X))
+		(STRING (string-length X))
+		(VECTOR (vector-length X))
+		(BITS 	(bits-length X))
+		(EXTEND (send x 'LENGTH))
+		(T 	(check-type x #'SEQUENCEP 'NIL-LENGTH)
+			(nil-length x))))))
+
+(defun SET-LENGTH (v newln)
+   (DECLARE (FIXNUM LN))
+   (LET (LOSEP)
+	(TYPECASEQ (AND (EQ (TYPEP NEWLN) 'FIXNUM)
+			(>= NEWLN 0)
+			V )
+	  (PAIR (COND ((NOT (> NEWLN 0)) (SETQ LOSEP T))
+		      ((LET ((LN (LIST-LENGTH V)))
+			    (COND ((= LN NEWLN))
+				  ((< LN NEWLN) 
+				   (NCONC V (MAKE-LIST (- NEWLN LN))))
+				  ('T (RPLACD (NTHCDR (1- NEWLN) V) () )))))))
+	  (VECTOR 
+	   (COND ((> NEWLN (VECTOR-LENGTH V)) (SETQ LOSEP T))
+		 ('T 
+		   #M (DO I (1- (HUNKSIZE V)) (1- I) (< I (+ NEWLN 2))
+			 ;########## KLUDGE!  
+			 (RPLACX I V (MUNKAM 262143.) ))
+		   #Q (ADJUST-ARRAY-SIZE V (1+ NEWLN))
+		   )))
+	  (STRING 
+	   (COND ((> NEWLN (STRING-LENGTH V)) (SETQ LOSEP T))
+		 ('T (SET-STRING-LENGTH V NEWLN))))
+	  (BITS (COND ((> NEWLN (BITS-LENGTH V)) (SETQ LOSEP T))
+		      ('T (SET-BITS-LENGTH V NEWLN))))
+	  (T (SETQ LOSEP 'T)))
+	(COND ((NOT LOSEP) V)
+	      ((ERROR (LIST V NEWLN) '|You Lose - SET-LENGTH|)))))
+
+
+
+
+;;;; Replacers and POSQers
+
+(defmacro LIST-REPLACE (&rest w) `(REPLACE ,.w))
+(defmacro VECTOR-REPLACE (&rest w) `(REPLACE ,.w))
+
+(defun |general-POSQer| (foo x str &optional (i 0 ip) (cnt () cntp))
+     (declare (fixnum ii len))
+     (let (((fwp skp chkp) foo)
+	   (ors *RSET) 
+	   (*RSET *RSET)
+	   typ (len 0))
+       (when ors 
+	     (check-subsequence (str i cnt) () 'POSQ ip cntp fwp)
+	     (setq cntp 'T))
+       (typecaseq str
+		  (STRING  (setq len (string-length str) typ 'STRING))
+		  (PAIR    (setq len (list-length str) typ 'LIST))
+		  (VECTOR  (setq len (vector-length str) typ 'VECTOR))
+		  (BITS    (setq len (bits-length str) typ 'BITS)
+			   (setq x (= (to-bit x) 1)))
+		  (T 	    (cond ((null str) (setq len 0 typ 'LIST))
+				  ((setq typ () )))))
+       (or ors 
+	   (cond ((not fwp) 
+		  (or ip (setq i (1- len)))
+		  (or cntp (setq cnt i))) 
+		 ((not cntp) (setq cnt (- len i)))))
+       (cond 
+	 ((= len 0) () )
+	 ((eq typ 'STRING) 
+	   (cond (skp (cond (fwp (string-skipq x str i cnt))
+			    ((string-bskipq x str i cnt))))
+		 (fwp (string-posq x str i cnt))
+		 ('T  (string-bposq x str i cnt))))
+	 ('T (if (eq typ 'LIST) 
+		 (setq str (cond ((not fwp) 
+				  (nreverse (replace (make-list cnt) 
+						     str 
+						     0 
+						     (- i cnt -1) 
+						     cnt)))
+				 ('T (nthcdr i str)))))
+	     (do ((ii i (1+ ii)) item)
+		 ((cond ((< cnt 0))
+			(fwp (>= ii len))
+			('T (< ii 0)))
+		  () )
+	       (caseq typ 
+		      (LIST   (pop str item))
+		      (VECTOR (setq item (vref str ii)))
+		      (BITS   (setq item (bit1p str ii))))
+	       (if (cond ((eq x item) (not skp))
+			 ('T          skp))
+		   (return ii))
+	       (setq cnt (1- cnt)))))))
+
+(defvar |general-POSQer| (ffget |general-POSQer| LSUBR))
+
+(deflexprmacro LIST-POSQ  |general-POSQer| '(T () LIST) '(2 . 4))
+(deflexprmacro VECTOR-POSQ  |general-POSQer| '(T () VECTOR) '(2 . 4))
+(deflexprmacro BITS-POSQ  |general-POSQer| '(T () BITS) '(2 . 4))
+
+(deflexprmacro POSQ  |general-POSQer| '(T () ()) '(2 . 4))
+(deflexprmacro BPOSQ  |general-POSQer| '(() () ()) '(2 . 4))
+(deflexprmacro SKIPQ  |general-POSQer| '(T T ()) '(2 . 4))
+(deflexprmacro BSKIPQ  |general-POSQer| '(() T ()) '(2 . 4))
+
+
+
+;;;; FILL
+
+(defun |general-FILLer| (type s item &OPTIONAL (i 0) (cnt () cntp) )
+   (when *RSET 
+	 (check-subsequence (s i cnt) type 'FILL 'T cntp)
+	 (setq cntp 'T))
+   (typecaseq s 
+	(PAIR (or cntp (setq cnt (- (list-length s) i)))
+	      (do ((l (nthcdr i s) (cdr l))) 
+		  ((< cnt 1)) 
+		(rplaca l item)
+		(setq cnt (1- cnt))))
+	(VECTOR (or cntp (setq cnt (- (vector-length s) i)))
+		(do () ((< cnt 1)) 
+		   (vset s i item)
+		   (setq cnt (1- cnt) i (1+ i))))
+	(STRING (or cntp (setq cnt (- (string-length s) i)))
+		(string-fill-n s (to-character-n item) i cnt))
+	(BITS   (or cntp (setq cnt (- (bits-length s) i)))
+		(bits-fill s (to-bit item) i cnt))
+	(T (or cntp (setq cnt (- (nil-length s) i)))
+	   (do () ((< cnt 1)) 
+	     (setelt s i item)
+	     (setq cnt (1- cnt)))))
+   s )
+
+(defvar |general-FILLer| (ffget |general-FILLer| LSUBR))
+
+(deflexprmacro LIST-FILL  |general-FILLer| 'LIST '(2 . 4))
+(deflexprmacro VECTOR-FILL  |general-FILLer| 'VECTOR '(2 . 4))
+;;BITS-FILL should be in the BITS file now
+(deflexprmacro FILL  |general-FILLer| '() '(2 . 4))
+
+
+;;;; ELT and SETELT
+
+
+(defun ELT (v i)
+   (if *RSET (check-subsequence (v i () ) () 'ELT))
+   (typecaseq v
+	(PAIR (nth i v))
+	(VECTOR (vref v i))
+	(STRING (char v i))
+	(BITS (bit v i))
+	(EXTEND (send v 'ELT i))))
+
+(defsetf ELT ((() frob index) value) () 
+   `(SETELT ,frob ,index ,value))
+
+
+(defun SETELT (v i x)
+   (if *RSET (check-subsequence (v i () ) () 'ELT))
+   (typecaseq v
+	(PAIR (rplaca (nthcdr i v) x))
+	(VECTOR (vset v i x))
+	(STRING (rplachar v i x))
+	(BITS (rplacbit v i x))
+	(EXTEND (si:xset v i x))))
+
+
+(defun *:NPTR-TYPEP (z) (get (ptr-typep z) 'PTRTYPEN))
+
+
+;;;; I/O Functions
+
+(and (not (boundp 'NILAID:INCHBACK)) (setq NILAID:INCHBACK () ))
+
+(defun INCH  (&optional (strm () strmp))
+   (cond (NILAID:INCHBACK (pop NILAID:INCHBACK))
+	 ((*:fixnum-to-character (cond (strmp (tyi strm)) ((tyi)))))))
+
+(defun INCHPEEK (&optional (strm () strmp))
+   (cond (NILAID:INCHBACK (car NILAID:INCHBACK))
+	 ((or (null strmp) (eq strm 'T))
+	  (setq strm (*:fixnum-to-character (tyi)))
+	  (push strm NILAID:INCHBACK)
+	  strm)
+	 ('T (*:fixnum-to-character (tyipeek -1 strm)))))
+
+(defun PUTBACK (type buf-or-item stream) 
+  (and (or (not (eq type 'SINGLE)) 
+	   (and (not (eq stream 'T)) (not (eq stream TYI))))
+       (error '|bad args - PUTBACK|))
+  (push buf-or-item NILAID:INCHBACK))
+
+
+(defun OUCH (char &OPTIONAL (stream OUTFILES))
+     (si:output-byte (*:character-to-fixnum char) stream)
+      ;Someday, try writing the STREAM-OUTBUFFER-OP, keyed on the predicate
+      ; (or (memq stream '(() T)) (eq stream TYO))
+     )
+
+(defun OUSTR (str &optional (stream OUTFILES) (start 0) (cnt () cntp)
+		  &aux      (endi (string-length str)))
+   (declare (fixnum i n))
+   (if (and cntp (< (+ start cnt) endi))
+       (setq endi (+ start cnt)))
+   (do ((i start (1+ i)))
+       ((>= i endi) () )
+      (si:output-byte (*:character-to-fixnum (char str i)) stream)))
+
+
+;;;; NIL-INTERN, NILAID:EDIT-INTERRUPT etc.
+
+
+(defun NIL-INTERN (x &optional (y OBARRAY))
+   (cond ((symbolp x))
+	 ((stringp x) #M (setq x (pnput (string-pnget x 7) () )) )
+	 ((error '|Bad arg to NIL's INTERN| x)))
+   (cond ((eq y OBARRAY) (maclisp-intern x))
+	 (((lambda (OBARRAY) (maclisp-intern x)) y))))
+
+(defun NILAID:EDIT-INTERRUPT (chnl char)
+	  (setq TTY-RETURN 'NILAID:TTY-RETURN-FROM-EDIT)
+	  (LISPT-EDIT-INTERRUPT chnl char))
+(defun NILAID:TTY-RETURN-FROM-EDIT (chnl)
+	  (setq TTY-RETURN () )
+	  (TTY-RETURN-HANDLER chnl))
+
+
+
+;;;;  Setup Actions
+
+(eval-when (load)
+	  (fmoveqq STRING-GET-PNAME  GET-PNAME)
+	  (fmoveqq GET-PNAME  NILAID-GET-PNAME)
+    #M 	  (nointerrupt 'T)
+	  (fmoveqq LENGTH NIL-LENGTH)
+    #M 	  (remprop 'INTERN 'SUBR)
+	  (fmoveqq INTERN NIL-INTERN LSUBR)
+    #M 	  (args 'INTERN '(1 . 2))
+    #M 	  (nointerrupt () ) 
+    )
+
+;; Copied more-or-less out of VM;TYPES >
+(setq *:PTR-TYPEP-TABLE 
+      (to-vector '(FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM FIXNUM 
+		   PAIR SYMBOL SUBR VECTOR-S VECTOR () MODULE GC-FORWARDING 
+		   CONSTANT CHARACTER () () () SMALL-FLONUM () MSUBR FLONUM 
+		   STRING BITS FLONUM-S EXTEND () () () ) ))
+(defprop FIXNUM 0 PTRTYPEN)
+(do ((i (1- (vector-length *:PTR-TYPEP-TABLE)) (1- i))
+     (x))
+    ((< i 8) () )
+  (and (setq x (vref *:PTR-TYPEP-TABLE i))
+       (putprop x i 'PTRTYPEN)))
+
+
+(mapc '(lambda (x) (putprop x 't '|side-effectsp/||))
+      '(BITSP FIXNUMP FLONUMP <$ <=$ =$ >=$ >$ ))
+
+
+(cond ((status feature COMPLR)
+	  (setq IOBARRAY SOBARRAY IREADTABLE (ARRAY () READTABLE SREADTABLE))
+	  (let ((READTABLE IREADTABLE)) (sstatus macro /& () )) 
+	  (let ((x USERATOMS-HOOKS))
+	       (INITIALIZE MACRO SPECIAL *EXPR *FEXPR *LEXPR 
+			   NUMVAR NUMFUN *ARRAY)
+	       (setq USERATOMS-HOOKS x))
+	  (cond ((status feature SHARABLE)
+		 (defun nac:dump () 
+		   (pure-suspend () `((|()|) NACDMP ,(get 'NILAID 'VERSION)))
+		   (sstatus GCTIM 0)
+		   (ANNOUNCE-&-LOAD-INIT-FILE 
+		      'COMPLR 
+		      () 
+		      `((|()|) NACFIX ,(get 'nilaid 'version)))
+		   (MAKLAP)))))
+	 ('T (setq /@define (get 'COMMENT 'FSUBR))
+	     (mapc '(lambda (x) (putprop x /@define 'FSUBR))
+		   '(/@DEFINE SPECIAL UNSPECIAL FIXNUM FLONUM NOTYPE))))
+
+(defmacro LAMBDA (&rest bvl-body) `(FUNCTION (LAMBDA ,. bvl-body)))
+
+#M (declare (own-symbol DESETQ LET* LET))
+;;; FOO, these three macros are under a losing conditional in LET file	
+;;;  because they will be special forms in the real NIL system
+      (DEFMACRO DESETQ (&REST L) (DESETQ-expander-1 L))
+      (DEFMACRO LET* (&REST L) (LET*-expander-1 L))
+      (DEFMACRO LET (&REST L) (LET-expander-1 L))
+
+
+;;;;  Redefinitions for < and >
+
+(defun < nargs (si:<=>-aux nargs '<))
+(args '< '(2 . 510.))
+(defun > nargs (si:<=>-aux nargs '>))
+(args '> '(2 . 510.))
+
+
+
+(sstatus FEATURE NIL)
+(sstatus FEATURE NILAID)
+
diff --git a/src/lspsrc/reap.12 b/src/lspsrc/reap.12
new file mode 100755
index 00000000..d3ee8554
--- /dev/null
+++ b/src/lspsrc/reap.12
@@ -0,0 +1,86 @@
+;;; -*-LISP-*-
+;;; Program to detect reapable LISP's.
+
+(declare (special reapable-stuff))
+
+
+(defun FIND-REAPABLE-LISPS ()
+   (setq reapable-stuff nil)
+   (let ((lock-file (open '|DSK:LISP;LOCK >|))
+	 (state 'SKIPPING-TO-NEXT-LISP-BLOCK)
+	 lisp-file input-line line )
+	(eoffn lock-file 'DISPLAY-RESULTS)
+	(*catch						;CATCH end-of-file
+	  'FIND-REAPABLE-LISPS
+	  (do ()					;DO forever, or until
+	      (())					; E-O-F throws out
+	    (setq input-line (readline lock-file))
+	    (cond 
+	     ((or (null input-line)
+		  (= (flatc input-line) 0)
+		  (= (getcharn input-line 1) #/;) 
+		  (only-white-spaces? (setq line (exploden input-line))))
+	      () )
+	     ((cond ((sublist-match line '(L I S P / ))
+		     (setq lisp-file (lread-version 5 line)
+			   lisp-file `((DSK SYS) PURQIO ,lisp-file))
+		     'T)
+		    ((sublist-match line '(X L I S P / ))
+		     (setq lisp-file (lread-version 6 line)
+			   lisp-file `((DSK LISP) PURQIX ,lisp-file))
+		     'T))
+	      (cond ((not (probef (setq lisp-file (namestring lisp-file))))
+		     (terpri)
+		     (prin1 lisp-file)
+		     (princ '| -- System LISP file is missing|)))
+	      (push lisp-file reapable-stuff)
+	      (setq state 'LOOKING-FOR-FILES-USING-THIS-LISP))
+	     ((eq state 'SKIPPING-TO-NEXT-LISP-BLOCK) () )
+	     ((eq state 'LOOKING-FOR-FILES-USING-THIS-LISP)
+	      (cond ((not (eq (car reapable-stuff) lisp-file)) () )
+		    ((probef input-line)
+		      ;; If listed file is not in file sysetm, then . ..
+		     (rplaca reapable-stuff () )
+		     (setq state 'SKIPPING-TO-NEXT-LISP-BLOCK))))
+	     ('T (error '|Bad /"state/" - FIND-REAPABLE-LISPS|)))))
+	() ))
+
+
+(defun ONLY-WHITE-SPACES? (line)
+   (do ((c 0))
+       ((null line) 'T)
+     (setq c (car line))
+     (cond ((or (= c #\SPACE)		;Ignore a bunch of chars
+		(= c #\TAB) 
+		(= c #\FORMFEED) 
+		(= c #\LINEFEED)))
+	   ((= c #/;) (return 'T))	;Initial ";" means worthless line
+	   ('T (return () )))		;Ahh, something worthy found
+     (pop line)))
+
+(defun SUBLIST-MATCH (line pat)
+   (do ((s1 line (cdr s1))
+	(s2 pat (cdr s2))
+	(a 0 ) (b 0))
+       ((or (null s1) (null s2))
+	'T)
+     (setq a (car s1) b (car s2))
+     (or (eq (typep a) 'FIXNUM) (setq a (getcharn a 1)))
+     (or (eq (typep b) 'FIXNUM) (setq b (getcharn b 1)))
+     (or (= a b) (return () ))))
+
+(defun LREAD-VERSION (n line)
+   (do ((l (nthcdr n line) (cdr l))
+	(z () (cons (car l) z)))
+       ((or (null l) (not (> (car l) #\SPACE)))
+	(implode (nreverse z)))))
+
+(defun DISPLAY-RESULTS (file flag)
+   (terpri)
+   (cond ((setq reapable-stuff (delq () reapable-stuff))
+	  (princ '|These LISP's have been found to be reapable:|)
+	  (mapc '(lambda (f) (princ f) (terpri)) reapable-stuff))
+	 ('T (princ '|<none>|)))
+   (terpri)
+   (*throw 'FIND-REAPABLE-LISPS () ))
+
diff --git a/src/nilcom/drammp.19 b/src/nilcom/drammp.19
new file mode 100755
index 00000000..5abfd4e0
--- /dev/null
+++ b/src/nilcom/drammp.19
@@ -0,0 +1,243 @@
+;;;   DRAMMP 						  -*-LISP-*-
+;;;   **************************************************************
+;;;   *** NIL *** Del, Rem, Ass, Mem, and Pos type functions *******
+;;;   **************************************************************
+;;;   ** (C) Copyright 1981 Massachusetts Institute of Technology **
+;;;   ****** This is a Read-Only file! (All writes reserved) *******
+;;;   **************************************************************
+
+(herald DRAMMP /19)
+
+#-NIL (include ((lisp) subload lsp))
+#-NIL (eval-when (eval compile)
+	(subload SHARPCONDITIONALS))
+
+#+(local MacLISP)
+  (eval-when (eval compile)
+     (subload MACAID)
+      ;; Remember, EXTMAC down-loads CERROR
+     (subload EXTMAC)
+     (subload EXTEND)
+     (subload VECTOR)
+     (subload SUBSEQ)
+     (if (fboundp 'OWN-SYMBOL) (own-symbol LENGTH NREVERSE))
+     )
+
+
+(defun si:GET-PRIMITIVE-SEQUENCE (z fun &optional Q-seq-p &aux type)
+   "Ascertain whether the 1st arg is a primitive sequence, [or Q-sequence,
+    if 'Q-seq-p' is non-()], and signal a correctable error if not.  Returns
+    the possibly-corrected value, and the general type."
+  (do () 
+      ((setq type (typecaseq z 
+			(PAIR   'LIST)
+			(VECTOR 'VECTOR)
+			(STRING (if (null Q-seq-p) 'STRING))
+			(BITS   (if (null Q-seq-p) 'BITS))
+			(T (if (null z) 'LIST)))))
+    (setq z (cerror #T () ':WRONG-TYPE-ARGUMENT 
+		    "~1G~S is not a ~:[~;Q-~]sequence -- ~S"
+		    () z Q-seq-p fun)))
+  (values z type))
+
+(defvar SI:NON-CIRCULAR-DEPTH-LIMIT 100000.)
+
+
+;;;; SI:DRAMMP
+
+
+(defun SI:DRAMMP (x oseq funname vecp pred access ret-type 
+		 &optional (starti 0) (cntr SI:NON-CIRCULAR-DEPTH-LIMIT cntrp))
+  (if (null oseq) 
+      () 
+      (let ((seq oseq)
+	    (typx (ptr-typep x))
+	    (typs (typecaseq oseq
+			(PAIR 'PAIR)
+			((VECTOR VECTOR-S) (and vecp 'VECTOR)))))
+	(if (null typs)
+	    (multiple-value 
+	       (seq typs) 
+	      (si:get-primitive-sequence seq (car funname) #T)))
+	(cond 
+	  ((and (null cntrp) 
+		(eq pred 'EQUAL) 
+	  #-NIL (eq typs 'PAIR)
+		(eq-for-equal? x))
+	        (caseq (cdr funname) 
+		   (MEM    (memq x seq))
+		   (ASS    (assq x seq))
+		   (DEL    (delq x seq))
+		   (RASS   (rassq x seq))
+		   (DELASS (delassq x seq))
+		   (MEMASS (memassq x seq))
+		   (POSASS (posassq x seq))
+		   (POSMEM (posq x seq))))
+	  (    (prog (item i n lvec slot delp back-slot del-scanner posp pairp)
+		 (declare (fixnum i n))
+		 (setq i (1- starti)  n (1+ cntr))
+		 (caseq ret-type 
+		   (DEL (setq delp #T del-scanner seq))
+		   (POS (setq posp #T)))
+		 (cond ((eq typs 'PAIR) (setq pairp #T))
+		       (#T (setq lvec (vector-length seq))))
+	       A (cond 
+		   ((not (< (setq n (1- n)) 0)))
+		   ((null cntrp) 
+		    (setq n (si:circularity-error (car funname) (list seq))))
+		   (#T (setq seq () lvec (- SI:NON-CIRCULAR-DEPTH-LIMIT))))
+		 (cond ((eq typs 'PAIR)
+			 (cond (delp 
+				 (if (null seq)
+				     (return del-scanner)))
+			       (#T (or seq (return () ))
+				   (and posp (setq i (1+ i)))))
+			 (setq slot (car seq)))
+		       (#T (setq i (1+ i))
+			   (or (< i lvec) (return () ))
+			   (setq slot (vref seq i))))
+		   ;Access the relevant item from the sequence
+		 (cond ((eq access 'CAR) (setq item slot))
+		       ((atom slot) (go b))
+		       ((setq item (if (eq access 'CDAR) 
+				       (cdr slot)
+				       (car slot)))))
+		   ;Calculate the "equivalence"
+		 (cond ((cond ((eq x item))
+			      ((not (eq pred 'EQUAL)) 
+			       (if (eq pred 'EQ) 
+				   () 
+				   (funcall pred x item)))
+			      ((not (eq (ptr-typep item) typx)) () )
+			      ((caseq typx 
+				  (STRING (null (string-mismatchq x item)))
+				  (FIXNUM (= x item))	
+				  (FLONUM (=$ x item))
+				  (T      (EQUAL x item)))))
+			(cond (delp 
+			        (if (null back-slot)
+				    (setq del-scanner (cdr del-scanner))
+				     ;;'seq' should be eq to (cdr back-slot)
+				    (rplacd back-slot (cdr seq)))
+				(setq seq (cdr seq))
+				(go A))
+			      (#T (return (caseq ret-type 
+					    (ASS slot)
+					    (MEM seq)
+					    (POS i)))))))
+	       B (if delp (setq back-slot seq))
+		 (if pairp (setq seq (cdr seq)))
+		 (go A)))))))
+
+
+
+(eval-when (eval compile)
+     (setq defmacro-for-compiling () )
+)
+
+(defmacro GEN-DRAMMP/| (&rest form &aux name vecp access ret-type ans stnnm)
+   `(PROGN 
+      'COMPILE 
+      ,.(mapcan 
+	 #'(lambda (x)
+	    (desetq (funname vecp access ret-type) x)
+	     ;; First comes the generalized function, like ASS and MEM.
+	    (setq 
+	     ans
+	     `((DEFUN ,(cdr funname) 
+		   (PRED ITEM SEQ &OPTIONAL (START 0) 
+					    (CNT SI:NON-CIRCULAR-DEPTH-LIMIT))
+		 (SI:DRAMMP ITEM 
+			    SEQ 
+			    '(,(cdr funname) . ,(cdr funname))
+			    ',vecp 
+			    PRED 
+			    ',access 
+			    ',ret-type 
+			    START 
+			    CNT))))
+	     ;;Then if permitted comes the one with EQUAL testing
+	    (cond 
+	     ((car funname)
+	       (setq stnnm (gentemp))
+	       (setq ans 
+		     (nconc 
+		       `((DEFUN ,(car funname) 
+			      (ITEM SEQ &OPTIONAL (START 0) 
+					(CNT SI:NON-CIRCULAR-DEPTH-LIMIT))
+			    (SI:DRAMMP ITEM 
+				       SEQ 
+				       ',funname 
+				       ',vecp 
+				       'EQUAL 
+				       ',access 
+				       ',ret-type 
+				       START 
+				       CNT))
+			 (DEFUN ,stnnm (X)
+			    (LET (((() ITEM SEQ . MORE) X))
+			      (VALUES 
+			        `(SI:DRAMMP ,ITEM 	;"item"
+					    ,SEQ 	;"sequence" 
+					    ',',funname 
+					    ',',vecp 
+					    'EQUAL 
+					    ',',access 
+					    ',',ret-type 
+					    ,.MORE	;possibly &optinals
+					    )
+				#T)))
+			 (PUSH ',stnnm (GET ',(car funname) 'SOURCE-TRANS)))
+		       ans)))))
+	 form)))
+
+(eval-when (eval compile)
+     (setq defmacro-for-compiling #T defmacro-displace-call MACROEXPANDED)
+)
+
+(gen-drammp/| ((          RASSOC        .   RASS)  T  CDAR ASS) 
+	      ((#-MacLISP  ASSOC  #M () .    ASS)  T  CAAR ASS)
+	      ((#-MacLISP DELETE  #M () .    DEL) ()   CAR DEL)
+	      ((#-MacLISP MEMBER  #M () .    MEM) ()   CAR MEM)
+	      ((        DELASSOC        . DELASS) ()  CAAR DEL)
+	      ((        MEMASSOC        . MEMASS) ()  CAAR MEM)
+	      ((        POSASSOC        . POSASS)  T  CAAR POS) 
+	      ((       POSMEMBER        . POSMEM)  T   CAR POS) )
+
+
+
+
+#M (progn 'compile 
+
+(defun RASSQ (x ll) 
+  (if *RSET (check-type ll #'LISTP 'RASSQ))
+  (do ((l ll (cdr l)) (e))
+      ((null l) () )
+    (and (pairp (setq e (car l)))
+	 (eq x (cdr e)) 
+	 (return e))))
+
+(defun POSASSQ (x seq)
+  (if (null seq)
+      () 
+      (typecaseq seq 
+	(PAIR  (do ((l seq (cdr l)) (e) (i 0 (1+ i)))
+		   ((null l) () )
+		 (declare (fixnum i))
+		 (and (pairp (setq e (car l)))
+		      (eq x (car e)) 
+		      (return i))))
+	 ;; VECTOR-POSASSQ comes in the VECTOR file for MacLISP
+	((VECTOR VECTOR-S) (VECTOR-POSASSQ x seq))
+	(T (multiple-value (seq) (si:get-primitive-sequence seq 'POSASSQ #T))
+	   (posassq x seq)))))
+
+(defun MEMASSQ (x ll)
+  (if *RSET (check-type ll #'LISTP 'MEMASSQ))
+  (cond ((null ll) () )
+	((null (setq x (assq x ll))) () )
+	((memq x ll))))
+
+)
+
+
diff --git a/src/nilcom/lsets.7 b/src/nilcom/lsets.7
new file mode 100755
index 00000000..6077fc90
--- /dev/null
+++ b/src/nilcom/lsets.7
@@ -0,0 +1,77 @@
+;;;  LSETS    				-*-Mode:Lisp;Package:SI;Lowercase:T-*-
+;;;  *************************************************************************
+;;;  ***** NIL/MACLISP ****** SET Operations on Lists ************************
+;;;  *************************************************************************
+;;;  ** (c) Copyright 1981 Massachusetts Institute of Technology *************
+;;;  *************************************************************************
+
+
+(herald LSETS /7)
+
+;;; Utility operations on sets: 
+;;;    ADJOIN, UNION, INTERSECTION, SETDIFF, SETREMQ
+;;; Where possible, preserve the ordering of elements.
+
+
+#-NIL (include ((lisp) subload lsp))
+
+#-NIL 
+(eval-when (eval compile)
+  (subload SHARPCONDITIONALS)
+  (subload LOOP)
+  (subload UMLMAC)
+  )
+
+#+(or LISPM (and NIL (not MacLISP)))
+(progn (globalize "ADJOIN")
+       (globalize "SETDIFF")
+       (globalize "UNION")
+       (globalize "INTERSECTION")
+       (globalize "SETREMQ")
+       )
+
+
+
+(defun ADJOIN (x s) 
+   "Add an element X to a set S."
+   (if (memq x s)
+       s
+       (cons x s)))
+
+(defun SI:Y-X+Z (y x z &aux y-x)
+    "Append the set-difference Y-X to Z"
+   (mapc #'(lambda (xx) (or (memq xx x) (push xx y-x))) y)
+   (nreconc y-x z))
+
+(defun SETDIFF (x y)  
+    "Set difference: all in X but not in Y."
+   (if (LOOP FOR xx IN y THEREIS (memq xx x))
+       (SI:Y-X+Z x y () )
+       x))
+
+(defun UNION (x y)
+    "Union of two sets."
+   (if (< (length x) (length y))	  ;Interchange X and Y if that will
+       (psetq x y y x))			  ;  lead to less CONSing
+   (si:y-x+z y x x))
+
+
+(defun INTERSECTION (x y)  
+    "Intersection of two sets."
+  (LOOP FOR xx IN x 
+	WHEN (memq xx y) COLLECT xx))
+ 
+(defun SETREMQ (x s)
+    "Remove an element X from a set S, non-destructively."
+   (when (LOOP UNTIL (null s) 
+	       WHEN (eq x (car s)) DO (return 'T)
+	       DO (pop s))
+	   ;;Strip off any leading losers;  Fall thru to return () if  
+	   ;;  whole list is "leading losers"
+	 (if (not (memq x s))
+	     s 
+	      ;; If there are 'interior' losers, the copy remainder of list
+	      ;;  but omitting elements EQ to the element X.
+	     (LOOP FOR y IN s 
+		   UNLESS (eq y x) COLLECT y))))
+
diff --git a/src/nilcom/sharpa.40 b/src/nilcom/sharpa.40
new file mode 100755
index 00000000..3ecfc801
--- /dev/null
+++ b/src/nilcom/sharpa.40
@@ -0,0 +1,117 @@
+;;;  SHARPA    				 -*-Mode:Lisp;Package:SI;Lowercase:T-*-
+;;;  **************************************************************************
+;;;  **** NIL ** NIL/MACLISP/LISPM Compatible # Macro Auxiliary  **************
+;;;  **************************************************************************
+;;;  ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
+;;;  ************ this is a read-only file! (all writes reserved) *************
+;;;  **************************************************************************
+
+#-LISPM
+(herald SHARPAUX /40)
+
+;; temporary, this MUST be usuable in the LISPM for MACSYMA! -gjc
+#Q (defprop SHARPAUX (macro) mc:macsyma-module)
+
+
+(eval-when (eval compile)
+  (if (and (fboundp 'DEFSTRUCT)
+	   (not (get 'DEFVST 'VERSION)))
+      () 
+      (defmacro DEFSTRUCT (&rest w) `(DEFVST ,.w)))
+)
+
+(defstruct (FEATURE-SET :conc-name (:constructor cons-a-feature-set) :named)
+	    target features nofeatures query-mode superiors)
+
+(defprop FEATURE-SET 
+	 (FEATURES NOFEATURES QUERY-MODE)
+	 SUPPRESSED-COMPONENT-NAMES)
+
+(defmacro DEF-FEATURE-SET (target &rest options)
+  (do ((l options (cddr l)))
+      ((null l))
+    (or (memq (car l) '(:QUERY-MODE :FEATURES :NOFEATURES :SUPERIORS))
+	(error "Bad option in options list - DEF-FEATURE-SET" (car l))))
+  (setq options (cons 'DEF-FEATURE-SET options))
+  (let ((query-mode (if (getl options '(:QUERY-MODE))
+			(get options ':QUERY-MODE)
+			':QUERY))
+	(features (get options ':FEATURES))
+	(nofeatures (get options ':NOFEATURES))
+	(superiors (get options ':SUPERIORS)))
+    (check-type query-mode 
+		#'si:query-mode-keyword 
+		'DEF-FEATURE-SET)
+    (check-type target     #'SYMBOLP 'DEF-FEATURE-SET)
+    (check-type features   #'LISTP   'DEF-FEATURE-SET)
+    (check-type nofeatures #'LISTP   'DEF-FEATURE-SET)
+    (check-type superiors  #'LISTP   'DEF-FEATURE-SET)
+    `(PROGN 'COMPILE
+	    (PUTPROP ',target 
+		     (cons-a-FEATURE-SET TARGET     ',target 
+					 FEATURES   ',features
+					 NOFEATURES ',nofeatures
+					 QUERY-MODE ',query-mode 
+					 SUPERIORS  ',superiors )
+		     'FEATURE-SET)
+	    (SETQ FEATURE-NAMES (CONS ',target (DELQ ',target FEATURE-NAMES)))
+	    ',target)))
+
+(defun SI:QUERY-MODE-KEYWORD (query-mode) 
+  (memq query-mode '(:QUERY :ERROR T () )))
+
+
+(defmacro DEF-EQUIVALENCE-FEATURE-SET (name to)
+  "Define a feature set name to be equivalent to an existing name"
+  (check-type name #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
+  (check-type to #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
+  (let ((equiv-var (symbolconc 'FEATURE-SET '- name '= to)))
+    `(PROGN 
+       (SETQ ,equiv-var ',to)
+       (DEF-INDIRECT-FEATURE-SET ,name ,equiv-var))))
+
+(defmacro DEF-INDIRECT-FEATURE-SET (name to)
+  "Define a feature set name to indirect through the value of a variable"
+  (check-type name #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
+  (check-type to #'SYMBOLP 'DEF-INDIRECT-FEATURE-SET)
+  `(PROGN (PUTPROP ',name
+		   ',to 
+		   'FEATURE-SET)
+	  (SETQ FEATURE-NAMES (CONS ',name (DELQ ',name FEATURE-NAMES)))
+	  ',name))
+
+
+
+;;; (WHEN-FEATURE                       ;; (WHEN-FEATURES
+;;;   (featurespec1 . clause1)          ;;   (featurespec1 . clause1)
+;;;   (featurespec2 . clause2)          ;;   (featurespec2 . clause2)
+;;;   (featurespec3 . clause3) ...)     ;;   (featurespec3 . clause3) ...)
+;;;					;;
+;;;   Executes the first clause which	;;   Executes all clauses which
+;;;   corresponds to a feature match.	;;   corresponds to a feature match.
+;;;
+;;; Feature match specs are designated by the following types of forms:
+;;;
+;;;  T			    - always
+;;;  symbol		    - feature name
+;;;  (OR spec1 spec2 ...)   - spec disjunction
+;;;  (AND spec1 spec2 ...)  - spec conjunction
+;;;  (NOT spec)		    - spec negation
+
+
+(defmacro WHEN-FEATURE (&rest clauses)
+  `(COND ,@(mapcar #'(lambda (x)
+		       `(,(if (eq (car x) 'T) 
+			      'T
+			      `(FEATUREP ',(car x)))
+			 ,@(cdr x)))
+		   clauses)))
+
+(defmacro WHEN-FEATURES (&rest clauses)
+  `(PROGN ,@(mapcar #'(lambda (x)
+			`(COND (,(if (eq (car x) 'T) 
+				     'T
+				     `(FEATUREP ',(car x)))
+				,@(cdr x))))
+		    clauses)))
+
diff --git a/src/nilcom/sharpc.74 b/src/nilcom/sharpc.74
new file mode 100755
index 00000000..8d05dcd2
--- /dev/null
+++ b/src/nilcom/sharpc.74
@@ -0,0 +1,338 @@
+;;;  SHARPC 	   -*-mode:lisp;package:si;lowercase:T-*-	     -*-LISP-*-
+;;;  **************************************************************************
+;;;  ***** NIL ****** NIL/MACLISP/LISPM  # Conditionalizations ****************
+;;;  **************************************************************************
+;;;  ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
+;;;  ************ this is a read-only file! (all writes reserved) *************
+;;;  **************************************************************************
+
+;;;; FEATUREP and Sharpsign conditionalization.
+
+#M (include ((lisp) subload lsp))
+
+(herald SHARPCONDITIONALS /74)
+
+
+(defvar FEATURE-NAMES () 
+  "A list of all names representing feature sets currently defined.")
+
+(defvar TARGET-FEATURES 'LOCAL
+  "Features to assume objects read are for.")
+
+(defvar MACROEXPAND-FEATURES 'TARGET
+  "Features to assume when macroexpanding.")
+
+(defvar SI:FEATUREP? () 
+  "Used to communicate caller's function name to function SI:FEATUREP?")
+
+
+#M (progn 'compile
+
+(eval-when (eval compile load)
+     (if (fboundp '*LEXPR) (*lexpr FEATUREP SET-FEATURE))
+     (if (fboundp '*EXPR) (*expr SI:FEATUREP?))
+     )
+
+(eval-when (eval compile)
+  (subload ERRCK)
+  (subload LOOP)
+  (subload UMLMAC)
+  (subload DEFVST)
+  (subload SHARPAUX))
+
+(def-or-autoloadable DEF-FEATURE-SET SHARPA)
+(def-or-autoloadable DEF-EQUIVALENCE-FEATURE-SET SHARPA)
+(def-or-autoloadable DEF-INDIRECT-FEATURE-SET  SHARPA)
+(def-or-autoloadable WHEN-FEATURE SHARPA)
+(def-or-autoloadable WHEN-FEATURES SHARPA)
+
+(let ((x (get 'SHARPM 'VERSION))
+	(FASLOAD))
+    (cond ((or (null x) 			;Not yet loaded, or
+	       (alphalessp x '/75))		;Obsolete version alread loaded
+	    (LOAD (autoload-filename SHARPM)))))
+
+#+(and PDP10 (not NIL))
+  (SSTATUS UUOLI)
+
+(defvar QUERY-IO 'T 
+  "Make sure this isn't unbound in MacLISP.")
+
+) 	;end of #M
+
+
+
+
+(defun SI:FEATURE-SET-NAME-P (arg)
+    "Return the (non-null) feature set if arg is a feature set name."
+  (and (symbolp arg)
+       (get arg 'FEATURE-SET)))
+
+(defun SI:GET-FEATURE-SET (feature-set-name using-fun)
+  "Returns the FEATURE-SET struct that this name refers to, following
+   indirections."
+  (do ((set (SI:feature-set-name-p feature-set-name) 
+	    (SI:feature-set-name-p feature-set-name)))
+      ((not (null set))
+       (if (symbolp set) 
+	   (si:get-feature-set (symeval set) using-fun)	;Indirect set
+	   set))
+    (setq feature-set-name
+	  (cerror t () ':WRONG-TYPE-ARGUMENT
+		  "~*~S, an arg to ~S, is not the name of a feature set."
+		  'FEATURE-SET feature-set-name using-fun))))
+
+
+(defun FEATUREP (feature &optional (feature-set-name TARGET-FEATURES) 
+			 &aux      (SI:FEATUREP? 'FEATUREP))
+  "Returns non-() if the feature is known to be a feature in the 
+   feature-set.  Otherwise returns ()."
+  (SI:FEATUREP? feature
+		(si:get-feature-set feature-set-name 'FEATUREP)
+		'T))
+
+(defun NOFEATUREP (feature &optional (feature-set-name TARGET-FEATURES) 
+			   &aux      (SI:FEATUREP? 'NOFEATUREP))
+  "Returns non-() if the feature is known NOT to be a feature in the 
+   feature-set.  Otherwise returns ()."
+  (SI:FEATUREP? feature
+		(si:get-feature-set feature-set-name 'NOFEATUREP)
+		() ))
+
+
+(defun SI:FEATUREP? (feature feature-set featurep)
+   "Return non-() if the feature is known to be a feature in the feature set. 
+    Return () if it is known NOT to be a feature.  Otherwise query, error, or 
+    assume, depending on the query-mode of the feature-set.  The 'featurep'
+    argument being () inverts the sense of the return value."
+   (cond ((atom feature) (si:featurep-symbol feature feature-set featurep))
+	 ((eq (car feature) 'NOT)
+	  (si:featurep? (cadr feature) feature-set (not featurep)))
+	 ((eq (car feature) 'AND)
+	  (si:feature-and (cdr feature) feature-set featurep))
+	 ((eq (car feature) 'OR)
+	  (si:feature-or (cdr feature) feature-set featurep))
+	 ((SI:feature-set-name-p (car feature))
+	    ;; Programmable case -- a "feature" like (MUMBLE HOT) means
+	    ;;  that "MUMBLE" should be the name of a feature set, and the
+	    ;;  "HOT" feature should be in it.    (MUMBLE HOT COLD) means that
+	    ;;  both "HOT" and "COLD" should be in it, namely it is synonymous
+	    ;;  with (MUMBLE (AND HOT COLD))
+	  (si:feature-and (cdr feature)
+			  (si:get-feature-set (car feature) 'SI:FEATUPREP?)
+			  featurep))
+	 ('T (setq feature (cerror 'T () ':INCONSISTENT-ARGS 
+			       "~S is not a legal feature specification -- ~S"
+			       (list feature)
+			       SI:FEATUREP?))
+	     (si:featurep? feature feature-set featurep))))
+
+
+
+
+(defun SI:FEATURE-AND (feature-list feature-set featurep)
+  "FEATUREP for the (AND f1 f2 f3 ... fn) case of a feature-spec"
+  (if (loop for feature in feature-list 
+	    always (si:featurep? feature feature-set 'T))
+      featurep 
+      (not featurep)))
+
+(defun SI:FEATURE-OR (feature-list feature-set featurep)
+  "FEATUREP for the (OR f1 f2 ... fn) case of a feature-spec"
+  (if (loop for feature in feature-list 
+	    thereis (si:featurep? feature feature-set 'T))
+      featurep 
+      (not featurep)))
+
+
+(defun SI:FEATUREP-SYMBOL (feature feature-set featurep)
+   "FEATUREP for the symbol case of a feature-spec"
+  (struct-let (FEATURE-SET feature-set) (features nofeatures)
+     (or (and featurep
+	      (memq feature features)
+	      'T)
+	 (and (not featurep)
+	      (memq feature nofeatures)
+	      'T)
+;; A MACLISP compatibility crock
+#M	 (when (and (eq (feature-set-target feature-set) 'LOCAL)
+		    (memq feature (status FEATURES))
+		    featurep)
+	       (set-feature feature 'LOCAL)	;Uncrockify
+	       'T)
+	 (if (and (not (memq feature nofeatures))
+		  (not (and (not featurep)
+			    (memq feature features))))
+	     (caseq (FEATURE-SET-query-mode feature-set)
+	       (:QUERY
+		(if (y-or-n-p query-io 
+			      "~&Is ~A a feature in ~A"
+			      feature 
+			      (FEATURE-SET-target feature-set))
+		    (push feature (FEATURE-SET-features feature-set))
+		    (push feature
+			  (FEATURE-SET-nofeatures feature-set)))
+		(si:featurep? feature feature-set featurep))
+	       (:ERROR
+		(FERROR ()
+			"~S is not a known feature in ~S"
+			feature 
+			(FEATURE-SET-target feature-set)))
+	       ((T) featurep)
+	       (T (not featurep) )))	;Else assume nofeature
+	 )))
+
+
+
+(defun SET-FEATURE (feature &optional (feature-set-name TARGET-FEATURES))
+  "Say that a feature is a feature in the feature-set.  FEATUREP will then
+   return non-() when called with that feature on that feature-set."
+  (si:feature-set-update feature feature-set-name 'T () 'SET-FEATURE))
+
+(defun SET-NOFEATURE (feature &optional (feature-set-name TARGET-FEATURES))
+  "Say that a feature is NOT a feature in the feature set.  FEATUREP will
+   return ()."
+  (si:feature-set-update feature feature-set-name () 'T 'SET-NOFEATURE))
+
+
+(defun SET-FEATURE-UNKNOWN 
+	(feature &optional (feature-set-name TARGET-FEATURES))
+  "Make a feature-name be unknown in a feature set."
+  (si:feature-set-update feature feature-set-name () () 'SET-FEATURE-UNKNOWN))
+
+
+(defun SI:FEATURE-SET-UPDATE (feature feature-set-name featurep nofeaturep fun)
+   "Update the lists of known features and known non-features in a 
+    'feature-set'."
+   (let ((feature-set (si:get-feature-set feature-set-name fun))
+	 (noclobberp 'T))
+     (or (symbolp feature) (check-type feature #'SYMBOLP fun))
+     (struct-let (FEATURE-SET feature-set) (features nofeatures)
+;; A MACLISP compatibility crock
+#M     (when (eq feature-set-name 'LOCAL)
+	 (if featurep
+	     (apply 'SSTATUS `(FEATURE ,feature))
+	     (apply 'SSTATUS `(NOFEATURE ,feature))))
+       (when (not featurep)
+	     (setq features (delq feature features) noclobberp () ))
+       (when (not nofeaturep)
+	     (setq nofeatures (delq feature nofeatures) noclobberp () ))
+       (when (and featurep (not (memq feature features)))
+	     (push feature features)
+	     (setq noclobberp () ))
+       (when (and nofeaturep (not (memq feature nofeatures)))
+	     (push feature nofeatures)
+	     (setq noclobberp () ))
+       (when (not noclobberp) 
+	     (struct-setf (FEATURE-SET feature-set)
+			  (features features)
+			  (nofeatures nofeatures)))))
+     feature)
+
+
+
+(defun SET-FEATURE-QUERY-MODE (feature-set-name mode)
+   "Set the feature-set's query-mode.  :QUERY (the mode they're created in by 
+    DEF-FEATURE-SET) means to ask about unknown features, :ERROR means signal
+    an error, T means assume it's a feature, () means to assume it's not."
+   (let ((feature-set (si:get-feature-set feature-set-name 'SET-FEATURE-QUERY-MODE)))
+     (or (si:feature-modep mode)
+	 (check-type mode #'SI:FEATURE-MODEP 'SET-FEATURE-QUERY-MODE))
+     (setf (FEATURE-SET-query-mode feature-set) mode)))
+
+(defun SI:FEATURE-MODEP (mode)
+  (memq mode '(:QUERY :ERROR T () )))
+
+
+(defun COPY-FEATURE-SET (feature-set-name new)
+   "Build a new feature-set from a previously existing one, with same 
+    features and non-features"
+  (let ((feature-set (si:get-feature-set feature-set-name 'COPY-FEATURE-SET)))
+    (or (symbolp new)
+	(check-type new #'SYMBOLP 'COPY-FEATURE-SET))
+    (putprop new 
+	     (cons-a-FEATURE-SET 
+	       TARGET     new
+	       FEATURES   (append (FEATURE-SET-features feature-set) () )
+	       NOFEATURES (append (FEATURE-SET-nofeatures feature-set) () )
+	       QUERY-MODE (FEATURE-SET-query-mode feature-set))
+	     'FEATURE-SET)
+    (setq FEATURE-NAMES (cons new (delq new FEATURE-NAMES)))
+    new))
+
+
+
+(def-feature-set MACLISP
+   :FEATURES   (MACLISP FOR-MACLISP HUNK SENDI BIGNUM FASLOAD PAGING ROMAN)
+   :NOFEATURES (NIL FOR-NIL LISPM FOR-LISPM FRANZ VAX UNIX VMS )
+   )
+
+(def-feature-set LISPM 
+   :FEATURES   (LISPM FOR-LISPM BIGNUM PAGING STRING)
+   :NOFEATURES (MACLISP FOR-MACLISP NIL FOR-NIL FRANZ SFA NOLDMSG VECTOR
+		VAX UNIX VMS MULTICS PDP10 ITS TOPS-20 TOPS-10 )
+   )
+
+(def-feature-set NIL
+   :FEATURES (NIL FOR-NIL BIGNUM PAGING SFA STRING VECTOR)
+   :NOFEATURES (MACLISP FOR-MACLISP LISPM FOR-LISPM FRANZ NOLDMSG )
+   )
+
+;; The following must be done first, because STATUS FEATURE requires FEATUREP
+;; in NIL.
+
+(copy-feature-set 
+      (cond ((or (fboundp 'LAPSETUP/|) (fboundp '|ItoC|))
+	       ;; or something MacLISP-specific
+	      'MACLISP)	
+	    ((fboundp 'SI:COMPARE-BAND) 'LISPM)	;or something LISPM-specific  
+	    ('T 	      'NIL ))
+      'LOCAL)
+
+;;Remember TARGET-FEATURES was set to 'LOCAL
+
+
+#-NIL (progn 'COMPILE 
+;;The NILAID feature set is for any MacLISP with a sufficiently large
+;;  subset of NIL features to be usable for cross-compilation.
+(copy-feature-set #-LISPM 'MACLISP #+LISPM 'LISPM 'NILAID)
+(mapc #'(lambda (x) (set-nofeature x 'NILAID))
+      '(For-MacLISP For-LISPM))
+(mapc #'(lambda (x) (set-feature x 'NILAID))
+      '(NILAID NIL FOR-NIL SFA STRING VECTOR #+PDP10 PDP10 ))
+
+)
+
+;;TARGET-FEATURES now back to 'LOCAL 
+(progn (set-feature (status OPSYSTEM))
+       (set-feature (status FILESYSTEM))
+  )
+
+
+;; A MACLISP compatibility crock
+#M (let ((y (status features)))
+      ;; Set the features that are present in our environment now, in LOCAL
+     (mapc #'SET-FEATURE y)
+      ;; The following are either present or not initially
+     (mapc #'(lambda (x) (or (memq x y) (set-nofeature x)))
+	   '(SFA STRING VECTOR COMPLR NOLDMSG 
+		 VAX UNIX VMS MULTICS PDP10 ITS TOPS-20 TOPS-10))
+     )
+
+
+;; INITIAL-LOCAL is useful for creating, by COPY-FEATURE-SET, other targets 
+;;  which are variations of the default environment, where initial environment
+;;  is whatever is present at the time LISP is started.
+
+(COPY-FEATURE-SET 'LOCAL 'INITIAL-LOCAL)
+
+
+
+
+
+(DEF-EQUIVALENCE-FEATURE-SET LOCAL-FEATURES LOCAL)
+(DEF-EQUIVALENCE-FEATURE-SET MACLISP-FEATURES MACLISP)
+(DEF-EQUIVALENCE-FEATURE-SET NIL-FEATURES NIL)
+
+(DEF-INDIRECT-FEATURE-SET TARGET TARGET-FEATURES)
+(DEF-INDIRECT-FEATURE-SET MACROEXPAND MACROEXPAND-FEATURES)
diff --git a/src/nilcom/thread.8 b/src/nilcom/thread.8
new file mode 100755
index 00000000..bee7db3f
--- /dev/null
+++ b/src/nilcom/thread.8
@@ -0,0 +1,301 @@
+;;; THREAD    				-*-Mode:Lisp;Package:SI;Lowercase:T-*-
+;;; **************************************************************************
+;;; ***** MACLISP ****** THREADed list structure functions *******************
+;;; **************************************************************************
+;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
+;;; **************************************************************************
+
+(herald THREAD /8)
+
+;;;THREADs are two-way lists;  each cell has a 'car', 'cdr', and 'uncdr'.
+;;;Accessing functions are respectively called THREAD-car, THREAD-cdr, and
+;;;  THREAD-uncdr.  THREAD-cons takes three args: the 'car', the 'cdr', and
+;;;  the 'uncdr'.
+;;;Normal case is to implement them as DEFVST structures, and use the
+;;;  pre-defined printing methods; otherwise, then each THREAD cell is a
+;;;  list like `(,car (,uncdr . ,cdr) ,. SI:THREAD-MARKER), which of course 
+;;;  could cause circularity when printed.
+
+
+(eval-when (eval compile)
+  (or (get 'SUBLOAD 'VERSION)
+      (load '((lisp) subload)))
+)
+(eval-when (eval compile)
+  (subload SHARPCONDITIONALS)
+)
+
+
+#+(local MacLISP)
+(eval-when (eval compile)
+  (subload MACAID)
+  (subload UMLMAC)
+  )
+
+#+(or LISPM (and NIL (not MacLISP)))
+(progn (globalize "THREADP")
+       (globalize "THREAD-CONS")
+       (globalize "THREAD-CAR")
+       (globalize "THREAD-CDR")
+       (globalize "THREAD-UNCDR")
+       (globalize "THREAD-RPLACA")
+       (globalize "THREAD-RPLACD")
+       (globalize "THREAD-RPLACU")
+
+       (globalize "THREAD-LAST")
+       (globalize "THREAD-FIRST")
+
+       (globalize "THREAD-LENGTH")
+       (globalize "THREAD-LENGTH-CDRING")
+       (globalize "THREAD-LENGTH-UNCDRING")
+
+       (globalize "THREAD-RECLAIM")
+       (globalize "THREAD-RECLAIM-CDRING")
+       (globalize "THREAD-RECLAIM-UNCDRING")
+       (globalize "THREAD-RECLAIM-1")
+       )
+
+
+
+
+;;;; Structures, Vars, etc.
+
+(eval-when (eval compile)
+  (set-feature-query-mode 'TARGET () )
+  (if (featurep 'Minimal) (setq defmacro-for-compiling () ))
+  (if (and (or (featurep 'Minimal) 
+	       (and (fboundp 'DEFSTRUCT) (not (get 'DEFVST 'VERSION))))
+	   (nofeaturep 'Using-DEFVST))
+      (set-nofeature 'Using-DEFVST)
+      (set-feature 'Using-DEFVST))
+)
+
+
+;; DEFVST will just ignore the ":type" option in the namelist
+
+;; THREAD is a 'Two-WAy List structure', for moving forwards and backwards 
+
+#+Using-DEFVST (progn 'compile 
+(defvst THREAD CAR LINKS)
+(defbothmacro THREADP (x) `(EQ (STRUCT-TYPEP ,x) 'THREAD))
+(defun THREAD-rplaca (x y)
+  (and *RSET (not (threadp x)) (check-type x #'THREAD 'THREAD-rplaca))
+  (setf (THREAD-car x) y)
+  x)
+)
+
+
+#-Using-DEFVST (progn 'compile 
+
+(eval-when (eval load compile)
+(defconst SI:THREAD-MARKER (list 'THREAD))
+)
+
+(defmacro cons-a-THREAD (&whole form)
+  (let ((acar (get form 'CAR))
+	(links (get form 'LINKS)))
+    `(LIST* ,acar ,links SI:THREAD-MARKER)))
+(defmacro THREAD-links (x) `(CADR ,x))
+(defbothmacro THREAD-car (x) `(CAR ,x))
+(defbothmacro THREAD-rplaca (x y) `(RPLACA ,x ,y))
+(defun THREADP (x)
+  (and (not (atom x)) 
+       (not (atom (cdr x)))
+       (eq (cddr x) SI:THREAD-MARKER)))
+)
+
+
+(defmacro THREAD-linkscdr (links)
+  `(CDR ,links))
+(defmacro THREAD-linksuncdr (links)
+  `(CAR ,links))
+
+(defmacro cons-a-THREAD-links (&whole form)
+  (let ((acdr (get form 'CDR))
+	(uncdr (get form 'UNCDR)))
+    `(CONS ,uncdr ,acdr)))
+
+
+(defbothmacro THREAD-cdr (th)
+  `(THREAD-linkscdr (THREAD-links ,th)))
+(defbothmacro THREAD-uncdr (th)
+  `(THREAD-linksuncdr (THREAD-links ,th)))
+
+
+(defun THREAD-rplacd (x y)
+  (and *RSET (not (threadp x)) (check-type x #'THREAD 'THREAD-rplacd))
+  (setf (THREAD-cdr x) y)
+  x)
+
+(defun THREAD-rplacu (x y)
+  (and *RSET (not (threadp x)) (check-type x #'THREAD 'THREAD-rplacu))
+  (setf (THREAD-uncdr x) y)
+  x)
+
+
+(defvar SI:THREAD-FREELIST () 
+  "Chained thru CAR link of free struct cells.")
+
+
+
+(defun THREAD-cons (tcar tcdr tuncdr &aux cell)
+  (without-interrupts 
+     (cond ((setq cell SI:THREAD-FREELIST)
+	     (setq SI:THREAD-FREELIST (thread-car cell))
+	     (setf (thread-car cell) tcar))))
+  (cond (cell  
+	  (let ((links (THREAD-links cell)))
+	    (setf (THREAD-linkscdr links) tcdr)
+	    (setf (THREAD-linksuncdr links) tuncdr))
+	  cell)
+	('T (cons-a-THREAD CAR tcar 
+			   LINKS (cons-a-THREAD-links CDR tcdr 
+						      UNCDR tuncdr)))))
+
+
+(defun THREAD-first (cell) 
+  (si:THREAD-move cell 1_20. '(() T () ) 'THREAD-first *RSET))
+(defun THREAD-last (cell)  
+  (si:THREAD-move cell 1_20. '(T T () )  'THREAD-last *RSET))
+(defun THREAD-LENGTH-cdring (cell) 
+  (si:THREAD-move cell 1_20. '(T () T) 'THREAD-cdring *RSET))
+(defun THREAD-LENGTH-uncdring (cell) 
+  (si:THREAD-move cell 1_20. '(() () T) 'THREAD-uncdring *RSET))
+(defun THREAD-LENGTH (cell) 
+  (if (null cell)
+      0 
+      (+ (thread-length-uncdring cell)
+	  ;; Following is basically 'thread-length-cdring', but no errors
+	 (si:THREAD-move cell 1_20. '(T () T) 'THREAD-cdring () )
+	 -1))) 
+
+
+(defun si:THREAD-move (original-cell no-moves foo fun checkp)
+   "Do either CDRing or UNCDRing until either 'no-moves' moves are made,
+    or until hitting the end of the thread.  Then return either the last
+    (or first) cell, or return the total number of moves made."
+  (let (((cdrp previousp countp) foo)
+	(circularity-limit #.(if (boundp 'SI:NON-CIRCULAR-DEPTH-LIMIT) 
+				 SI:NON-CIRCULAR-DEPTH-LIMIT 
+				 100000.)))
+    (cond (checkp (or (null original-cell)
+		      (threadp original-cell)
+		      (check-type original-cell #'THREADP fun))
+		  (check-type no-moves #'FIXNUMP fun)))
+    (do ((i 0 (1+ i))
+	 (cell original-cell (if cdrp (THREAD-cdr cell) (THREAD-uncdr cell)))
+	 (previous original-cell cell)
+	 (n no-moves))
+	((or (null cell) (>= i n))
+	 (if (and (not (threadp previous))
+		  (or previous (not (= i 0))))
+	     (+internal-lossage 'NULL 'THREAD-move (maknum original-cell)))
+	 (if countp i (if previousp previous cell)))
+      (declare (fixnum n))
+      (if (> i circularity-limit)
+	#+NIL (setq circularity-limit 
+		    (si:circularity-error fun (list original-cell))) 
+	#-NIL (error "Circular THREAD at this address" (maknum original-cell))
+	))))
+
+
+;;;; THREAD reclaimers and LENGTHers 
+
+(defsimplemac si:THREAD-reclaim-1-f (cell)
+  (let ((tmp (si:gen-local-var () )))
+    `((LAMBDA (,tmp)
+	(SETF (THREAD-linkscdr ,tmp) () )
+	(SETF (THREAD-linksuncdr ,tmp) () )
+	(SETF (THREAD-car ,cell) SI:THREAD-FREELIST)
+	(SETQ SI:THREAD-FREELIST ,cell)
+	() )
+      (THREAD-links ,cell))))
+
+(defun THREAD-reclaim-1 (cell) 
+   "User-level fun to reclaim one cell.  Probably seldom used."
+  (and *RSET 
+       (not (threadp cell)) 
+       (check-type cell #'THREADP 'THREAD-reclaim-1))
+  (without-interrupts 
+    (let ((prev (thread-uncdr cell))
+	  (next (thread-cdr cell)))
+      (si:THREAD-reclaim-1-f cell)
+      (if prev (setf (thread-cdr prev) () ))
+      (if next (setf (thread-cdr next) () ))))
+  () )
+
+
+(defun THREAD-reclaim-cdring (cell) 
+   "Reclaim all cells in the CDR-chain of this thread."
+  (si:THREAD-reclaim-moving cell 'T 'THREAD-reclaim-cdring))
+
+(defun THREAD-reclaim-uncdring (cell) 
+   "Reclaim all cells in the UNCDR-chain of this thread."
+  (si:THREAD-reclaim-moving cell () 'THREAD-reclaim-uncdring))
+
+
+(defun THREAD-reclaim (cell)
+   "Reclaim all cells of this thread."
+  (let ((more (and (threadp cell) (thread-uncdr cell))))
+    (si:THREAD-reclaim-moving cell 'T 'THREAD-reclaim)
+    (and more 
+	 (si:THREAD-reclaim-moving more () 'THREAD-reclaim))))
+
+
+(defun si:THREAD-reclaim-moving (cell cdrp fun) 
+  (and *RSET 
+       (not (threadp cell)) 
+       (check-type cell #'THREADP fun))
+  (let (tem)
+     ;First, disconnect any cell which may point to this one which
+     ; is the firstt in a chain to be reclaimed.
+    (cond (cdrp 
+	   (if (setq tem (thread-uncdr cell))
+	       (setf (thread-uncdr tem) () )))
+	  ((if (setq tem (thread-cdr cell))
+	       (setf (thread-cdr tem) () )))))
+  (do ()
+      ((null cell) )
+     ;; Interrupts locked out, but permit them 'every once in a while'.
+    (without-interrupts
+     (do ((i 256. (1- i)))
+	 ((or (null cell) (<= i 0)) )
+       (setq cell (prog1 (if cdrp (THREAD-cdr cell) (THREAD-uncdr cell))
+			 (si:THREAD-reclaim-1-f cell))))))
+  () )
+
+
+
+
+;;;; :PRINT-SELF method
+
+#+Using-DEFVST 
+(defmethod* (:PRINT-SELF THREAD-CLASS) (ob stream depth slashifyp)
+  (declare (fixnum depth))
+  (setq depth (1+ depth))
+  (if (and PRINLEVEL (not (< depth PRINLEVEL)))
+      (princ SI:PRINLEVEL-EXCESS stream)
+      (let ((printer (if slashifyp #'PRIN1 #'PRINC)))
+	(princ "#{THREAD" stream)
+	(do ((curr (THREAD-first ob) (THREAD-cdr curr))
+	     (n (or PRINLENGTH 100000.) (1- n)))
+	    ((cond ((or (eq curr ob) (null curr)))
+		   ((<= n 0) 
+		     (princ " " stream)
+		     (princ SI:PRINLENGTH-EXCESS stream)
+		     'T)) )
+	  (declare (fixnum n))
+	  (princ " " stream)
+	  (funcall printer (THREAD-car curr) stream))
+	(princ " $$" stream)
+	(do ((curr ob (THREAD-cdr curr))
+	     (n (or PRINLENGTH 100000.) (1- n)))
+	    ((cond ((null curr))
+		   ((<= n 0) 
+		     (princ " " stream)
+		     (princ SI:PRINLENGTH-EXCESS stream)
+		     'T)) )
+	  (declare (fixnum n))
+	  (princ " " stream)
+	  (funcall printer (THREAD-car curr) stream))
+	(princ "}" stream))))