Added lots of lisp libraries, most of them built from source.

This partially completes #251.

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)

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

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

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)

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)

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

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

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)

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

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)

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

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

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

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

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

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

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

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

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

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

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

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

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

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)

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