;;;---	HENUTL >	-*- Mode:LISP; Package:USER; Base:10 -*-

; This file contains miscellaneous functions of general utility.

; GENERAL "OPERATING SYSTEM" UTILITIES:

(defun e ( )
  (setq DEFAULT-CONS-AREA WORKING-STORAGE-AREA
	PRIN1 nil TV:MOUSE-X 761. TV:MOUSE-Y 883.)
  (tv:with-mouse-usurped
    (ed) (beep-tune) (tyo #\SPACE) (tyo #\BACKSPACE))
  (beep-tune 2000.)
  (reset)
  (sa nil))


(defun c ( )
  (cond ((fboundp 'G1DO-CONTINUE)
	 (let ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA))
	   (g1do-continue)))
	(t "AI: DICK; LSPMP QFASL  not loaded.")))


(defun up (&optional n)
  (cond ((fixp n) (cursorset (min 62. (max 0. (- (linenum) n))) 0.))
	(t (cursorset 0. 0.))))


(defun sa (&optional output? &aux temp file-list (line 0.))
  (setq DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
  (terpri1)
  (dolist (buffer ZWEI:*ZMACS-BUFFER-LIST*)
    (let* ((file-id (ZWEI:BUFFER-FILE-ID buffer))
	   (file-name (ZWEI:BUFFER-NAME buffer))
	   (file-symbol (read-from-string file-name)))
      (cond ((not (null file-id))
	     (putprop file-symbol file-name 'BUFFER-NAME)
	     (cond ((or (symbolp file-id) (ZWEI:BUFFER-MUNGED-P buffer))
		    (push file-symbol file-list)
		    (and (memq file-symbol COMPILE-FILE-LIST)
			 (putprop file-symbol 'NEEDS-COMPILING 'COMPILE-STATUS))
		    (putprop file-symbol '****CHANGED**** 'EDITOR-STATUS))
		   ((eq (get file-symbol 'EDITOR-STATUS) 'WRITTEN))
		   ((eq (get file-symbol 'EDITOR-STATUS) '****CHANGED****)
		    (putprop file-symbol 'WRITTEN 'EDITOR-STATUS))
		   (t (putprop file-symbol 'IN-BUFFER 'EDITOR-STATUS)))
	     (cond (output? (terpri)
			    (col-print 0. (increment line)
				       6. (get file-symbol 'BUFFER-NAME)
				       32. "Edit:"
				       39. (get file-symbol 'EDITOR-STATUS)
				       60. "Comp:"
				       67. (cond ((get file-symbol 'COMPILE-STATUS))
						 (t "OK")))))))))
  (and output? (terpri2))
  (cond ((null file-list) (princ "All Editor buffers written out.") (terpri) (beep-tune))
	((= (length file-list) 1.)
	 (cond ((ask-yn "***  " file-list " needs writing out.  Save? ")
		(save-files t))))
	(t (setq temp (ask-yn-else "***  " (reverse file-list)
				   " need writing out.  Save all? "))
	   (cond ((null temp))
		 ((eq temp 't) (save-files t))
		 (t (save-files nil)))))
  DONE)


(defun save-files (all?)
  (setq DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
  (terpri2)
  (princ (cond (all? "Saving Editor buffers ... ")
	       (t "Checking Editor buffers ... ")))
  (terpri)
  zwei:(LET ((*WINDOW* NIL)
	     (*TYPEOUT-WINDOW* STANDARD-OUTPUT)
	     (*TYPEIN-WINDOW* STANDARD-OUTPUT)
	     (*NUMERIC-ARG-P* user:all?))
	 (COM-SAVE-ALL-FILES))
  (beep-tune))


; COMPILATION FUNCTIONS:

(defun cll (&quote &rest files)				; "CompiLe and Load"
  (sa nil) (cl-internal files t))

(defun cl (&quote &rest files)				; "CompiLe"
  (sa nil) (cl-internal files nil))


(local-declare ((special TO-COMPILE-LIST TO-LOAD-LIST))
  
  (defun cl-internal (files load? &aux TO-COMPILE-LIST TO-LOAD-LIST)
    (cond ((null files)
	   (mapatoms #'(lambda (x &aux status)
			 (setq status (get x 'COMPILE-STATUS))
			 (and (eq status 'NEEDS-COMPILING) (push x TO-COMPILE-LIST))
			 (and (memq status '(NEEDS-COMPILING COMPILED))
			      (push x TO-LOAD-LIST)))
		     PACKAGE nil))
	  ((equal files '(t))
	   (setq TO-COMPILE-LIST COMPILE-FILE-LIST
		 TO-LOAD-LIST COMPILE-FILE-LIST))
	  (t (setq TO-COMPILE-LIST files TO-LOAD-LIST files)))
    (do ((x TO-COMPILE-LIST (cdr x)))
	((null x))
      (putprop (car x) 'NEEDS-COMPILING 'COMPILE-STATUS))
    (cond ((null TO-COMPILE-LIST) (^g "No files need compiling."))
	  (t (terpri)
	     (let ((PRINLENGTH nil))
	       (princ-rest "Will Compile:  " TO-COMPILE-LIST)
	       (cond (load? (terpri)
			    (princ-rest "    and load:  " TO-LOAD-LIST))))
	     (cond ((ask-yn " OK? ->"))
		   (t (^g "List files specifically.")))))
    (do ((x TO-COMPILE-LIST (cdr x))
	 (y))
	((null x))
      (setq y (fnp (car x)))
      (print `(compiling ,y))
      (qc-file y)
      (putprop (car x) 'COMPILED 'COMPILE-STATUS))
    (terpri1)
    (cond (load? (terpri)
		 (do ((x TO-LOAD-LIST (cdr x))
		      (y))
		     ((null x))
		   (setq y (fnp `(,(car x) qfasl)))
		   (load y)
		   (putprop (car x) 'COMPILED-AND-LOADED 'COMPILE-STATUS))))
    (beep-tune)
    (cond (load? "Compilation Done and Loaded.")
	  (t "Compilation Done."))))


(defun reset (&optional (num 10.))
  (setq TV:MOUSE-X 761. TV:MOUSE-Y 883. ZUNDERFLOW t
	DEFAULT-CONS-AREA WORKING-STORAGE-AREA
	BASE 10. IBASE 10. *NOPOINT nil)
  (and (boundp 'SKIP-FLAG) (makunbound 'SKIP-FLAG))
  (and (fboundp 'G1DO-CONTINUE)
       (setq PRIN1 #'GPRIN1 G-PRINLENGTH nil G-PRINLEVEL nil G-PRINENDLINE num))
  (tv:kbd-esc-w nil)
  DONE)


; Edit-Run-Loop.

(defun erl (&optional (function 'RUN) &rest arglist)
  (do ((DEFAULT-CONS-AREA WORKING-STORAGE-AREA))
      (())
    (ed) (terpri)
    (cond ((ask-yn "Function " function " applied to args " arglist " -- OK? ->")
	   (apply function arglist))
	  (t (^g "Quit.")))))


; Load a file -- (LD FILE > RSG AI) -- only need give args different from last time.

(defun ld (&quote &rest file-list)			; "LoaD"
  (cond (file-list
	 (cond ((cdr file-list)
		(cond ((cddr file-list)
		       (cond ((cdddr file-list)
			      (setq LD31417 (fourth file-list))))
		       (setq LD31418 (third file-list))))
		(setq LD31416 (second file-list))))
	 (setq LD31415 (first file-list))))
  (load (string-append (string LD31417) ": " (string LD31418) "; "
		       (string LD31415) " "  (string LD31416))))


(defun change (&optional machine (directory "RSG"))
  (cond ((null machine))
	((eq machine 'MC) (setq ITS "MC" DIR "EF"))
	((eq machine 'ML) (setq ITS "ML" DIR "EFSTU"))
	((eq machine 'AI) (setq ITS "AI" DIR (string directory)))
	(t (^g "Wrong machine -- use 'AI, 'MC, or 'ML")))
  (setq PF31415 "NONE" LD31415 "NONE"
	PF31416 ">" LD31416 "QFASL"
	PF31417 ITS LD31417 ITS
	PF31418 DIR LD31418 DIR)
  (terpri1) (princ "Defaults:")
  (terpri) (princ-rest " LD:   " (fnp '(NONE QFASL)))
  (terpri) (princ-rest " PF:   " (fnp '(NONE >)))
  (setq FS:FILE-DEFAULT-HOST ITS))


; Print a Directory  --  (DIR) for default, or (DIR XGP), etc.

(defun dir (&quote &rest file)
  (let ((PF31415 ".FILE.")
	(PF31416 "(DIR)")
	(PF31418 (cond ((first file))
		       (t dir)))
	(PF31417 (cond ((second file))
		       ((string-equal (first file) "XGP") "XGP")
		       ((string-equal (first file) "TPL") "TPL")
		       ((first file) "DIR")
		       (t "AI"))))
    (pf)))


; Print a File  --  args same as LD.

(defun pf (&quote &rest file-list)			; "Print File"
  (setq BASE 10. IBASE 10. *NOPOINT nil)
  (let ((file-string) (file-object))
    (cond (file-list
	    (cond ((cdr file-list)
		   (cond ((cddr file-list)
			  (cond ((cdddr file-list)
				 (setq PF31417 (fourth file-list))))
			  (setq PF31418 (third file-list))))
		   (setq PF31416 (second file-list))))
	    (setq PF31415 (first file-list))))
    (setq file-string (string-append (string PF31417) ": " (string PF31418) "; "
				     (string PF31415) " "  (string PF31416)))
    (setq file-object (open file-string '(:READ :ASCII)))
    (clear)
    (skip-this
      (funcall file-object ':CLOSE)
      (princ-rest "File:  " file-string)
      (terpri2)
      (do ((list (funcall file-object ':LINE-IN nil)
		 (funcall file-object ':LINE-IN nil)))
	  ((null list))
	(princ list)
	(terpri) (more)))
    (beep-tune)
    file-string))


; Purge a Directory (the default one -- value of DIR on ITS).

(defun purge (&aux batch directory string1 string2 file-list)
  (let ((DEFAULT-CONS-AREA TEMPORARY-AREA))
    (skip-this
      (close directory)
      (setq directory (open (fnp `(".FILE." "(DIR)" ,DIR  ,ITS))
			    '(:READ :ASCII))
	    string1 (readline directory)
	    string2 (readline directory))
      (do ((line (readline directory) (readline directory)))
	  ((null line))
	(cond ((fixp (read-from-string (substring line 13. 19.)))
	       (cond ((null batch) (push line batch))
		     ((string-equal (first batch) line 6. 6. 12. 12.)
		      (push line batch))
		     (t (and (> (length batch) 1.) (push batch file-list))
			(setq batch (list line)))))))
      (and (> (length batch) 1.) (push batch file-list)))
    (clear) (princ string1) (terpri) (princ string2)
    (mapc #'CHECK-DELETE (reverse file-list)))
  (si:reset-temporary-area TEMPORARY-AREA)
  (terpri1) (beep-tune) "PURGE done.")


(defun check-delete (batch)
  (let ((copy (copylist batch TEMPORARY-AREA)))
    (sort copy #'(lambda (x y)
		   (> (read-from-string (substring x 13. 19.))
		      (read-from-string (substring y 13. 19.)))))
    (terpri2) (princ "Saving:")
    (terpri) (princ-rest "    " (first copy))
    (terpri) (princ-rest "    " (second copy))
    (cond ((cddr copy)
	   (terpri2) (princ "Delete:") (terpri)
	   (mapc #'(lambda (x)
		     (princ-rest "    " x) (terpri))
		 (cddr copy))
	   (terpri2)
	   (cond ((ask-yn "Delete above files? ->")
		  (mapc #'(lambda (x)
			    (let ((filename (string-append ITS ": " DIR "; "
							   (substring x 6. 19.))))
			      (deletef filename)))
			(cddr copy))
		  (terpri) (princ "Gone!"))
		 (t (terpri)
		    (mapc #'(lambda (x)
			      (let ((filename (string-append ITS ": " DIR "; "
							     (substring x 6. 19.))))
				(cond ((ask-yn "Delete: " filename " ->")
				       (deletef filename)))))
			  (cddr copy))))))))


; FILE AND EDITOR-BUFFER SEARCHING UTILITIES:

(defun editor-stream (file-string read-from-buffer? &aux buffer)
  (setq DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
  (setq buffer (zwei:find-buffer-named file-string t))
  (cond (read-from-buffer? (zwei:interval-stream buffer))
	(t (zwei:interval-stream (zwei:interval-last-bp buffer)
				 (zwei:interval-last-bp buffer)))))


(defun findf (&quote &rest arglist)
  (cond ((or (null arglist)
	     (not (listp (first arglist))))
	 "Args:  [ ( <filename> ... )  <string> ... ] -- no quotes.
              Each <filename> a spec suitable for FNP.")
	(t (find-internal (first arglist) (cdr arglist) nil))))


(defun find (&quote &rest strings)
  (find-internal nil strings t))


(defun find-internal (files strings editor? &aux FOUND-FILES-LIST)
  (setq BASE 10. IBASE 10. *NOPOINT nil)
  (set-latest)
  (and files (sa nil))
  (do ((string strings (cdr string)))
      ((null string))
    (find1 (string (car string)) files editor?))
  (cond (FOUND-FILES-LIST
	 (terpri2)
	 (princ "Strings found in:  ")
	 (funcall PRIN1 (reverse FOUND-FILES-LIST))))
  (beep-tune 1667.) (message "")
  (terpri1) "FIND done.")


(defun find1 (string files editor? &aux filename stream)
  (terpri2)
  (princ-rest "************  /"" string "/"  ************")
  (cond ((null files)
	 (do ((buffer-list ZWEI:*ZMACS-BUFFER-LIST* (cdr buffer-list)))
	     ((null buffer-list))
	   (setq filename (ZWEI:BUFFER-NAME (car buffer-list))
		 stream (editor-stream filename t))			  
	   (find2 string filename stream editor? t)))
	(t (do ((file files (cdr file)))
	       ((null file))
	     (setq filename (fnp (car file))
		   stream (open filename '(:ASCII :READ)))
	     (find2 string filename stream editor? nil)))))


(defun find2 (string filename stream editor? check? &aux found? (*NOPOINT t))
  (message filename)
  (skip-this
    (funcall stream ':CLOSE)
    (do ((line (funcall stream ':LINE-IN nil) (funcall stream ':LINE-IN nil))
	 (line-number 0. (1+ line-number)))
	((null line))
      (cond ((string-search string line)
	     (cond ((not found?) (beep-tune* 50000. 2500.)
		    (terpri2)
		    (princ-rest (cond (editor? "Buffer:   ") (t "File:   "))
				filename "      String:   /"" string "/"")
		    (terpri2)
		    (setq found? t)))
	     (beep-tune* 30000. 1667.) (princ-rest line-number ": " line) (terpri)))
      (and check? (null (symeval-in-closure stream 'ZWEI:*INDEX*))
	   (return nil))
      (more))
    (and found?
	 (not (memq filename FOUND-FILES-LIST))
	 (push filename FOUND-FILES-LIST))))


; DOCUMENTATION UTILITIES:

; Like APROPOS  --  args are strings on which to match symbol printnames.

(local-declare ((special *FOUND* *ARG* ALL?))
  
  (defun aphelp (&quote &rest arglist)
    (let ((ALL? t))
      (apply #'HELP arglist)))
  
  (defun phelp (&quote pkg &rest arglist)
    (let ((PACKAGE (pkg-find-package pkg)))
      (apply #'HELP arglist)))
  
  
  (defun help (&quote &rest arglist)
    (and (eq (car -) 'HELP) (set-latest))
    (setq BASE 10. IBASE 10. *NOPOINT nil)
    (terpri)
    (cond ((null arglist) (help1 nil))
	  ((null (cdr arglist)) (help1 (car arglist)))
	  (t (mapc #'HELP1 arglist)))
    (terpri) (beep-tune)
    "HELP done.")
  
  
  (defun help1 (argument)
    (terpri2)
    (skip-this nil
	       (let ((*FOUND* nil)
		     (*ARG* (cond ((null argument) nil)
				  ((stringp argument) argument)
				  ((atom argument) (string argument))
				  (t nil))))
		 (cond ((null *ARG*) (princ "**   Everything shown:"))
		       (t (princ-rest "**   /"" *ARG* "/" substring:")))
		 (terpri)
		 (cond ((boundp 'ALL?) (mapatoms-all #'HELP-INTERNAL))
		       (t (mapatoms #'HELP-INTERNAL PACKAGE nil)))
		 (cond ((not *FOUND*)
			(princ "None found."))))))
  
  
  (defun help-internal (x)
    (cond ((and (or (boundp x)
		    (plist x)
		    (fboundp x))
		(cond ((and (boundp 'SYMBOL-SELECT)
			    (not (null SYMBOL-SELECT)))
		       (funcall SYMBOL-SELECT x))
		      (t t))
		(or (null *ARG*)
		    (string-search *ARG* (get-pname x))))
	   (setq *FOUND* t)
	   (cond ((and (boundp 'SYMBOL-ACTION)
		       (not (null SYMBOL-ACTION)))
		  (funcall SYMBOL-ACTION x))
		 (t (print-out-symbol x)))))))


; Show symbols whose values are of a certain datatype  --  args as for HELP.

(defun vals (&quote &rest arglist &aux AREA-NUMBER)
  (set-latest) (terpri1)
  (let ((SYMBOL-SELECT nil) (SYMBOL-ACTION nil)
	(s-flonums (ask-yn "**  Small Flonums? ->"))
	(b-flonums (ask-yn "**  Large Flonums? ->"))
	(fixnums (ask-yn   "**        Fixnums? ->"))
	(functions (ask-yn "**      Functions? ->"))
	(macros (ask-yn    "**         Macros? ->"))
	(commands (ask-yn  "**       Commands? ->"))
	(specials (ask-yn  "**       Specials? ->"))
	(others (ask-yn    "**         Others? ->"))
	(in-area (cond ((ask-yn   "**     In an Area? ->")
			(setq AREA-NUMBER (eval (ask "             Area:  "))) t)
		       (t nil))))
    (terpri1)
    (and s-flonums
	 (let ((SYMBOL-SELECT #'(lambda (x)
				  (and (boundp x) (small-floatp (symeval x))))))
	   (terpri2) (princ "***  Small Flonums:")
	   (cond ((null arglist) (help1 nil))
		 (t (mapc #'HELP1 arglist)))))
    (and b-flonums
	 (let ((SYMBOL-SELECT #'(lambda (x)
				  (and (boundp x) (floatp (symeval x))
				       (not (small-floatp (symeval x)))))))
	   (terpri2) (princ "***  Large Flonums:")
	   (cond ((null arglist) (help1 nil))
		 (t (mapc #'HELP1 arglist)))))
    (and fixnums
	 (let ((SYMBOL-SELECT #'(lambda (x)
				  (and (boundp x) (fixp (symeval x))))))
	   (terpri2) (princ "***  Fixnums:")
	   (cond ((null arglist) (help1 nil))
		 (t (mapc #'HELP1 arglist)))))
    (and functions
	 (let ((SYMBOL-SELECT #'FBOUNDP))
	   (terpri2) (princ "***  Functions:")
	   (cond ((null arglist) (help1 nil))
		 (t (mapc #'HELP1 arglist)))))
    (and macros
	 (let ((SYMBOL-SELECT #'(lambda (x)
				  (and (fboundp x)
				       (listp (setq x (fsymeval x)))
				       (eq (car x) 'MACRO)))))
	   (terpri2) (princ "***  Macros:")
	   (cond ((null arglist) (help1 nil))
		 (t (mapc #'HELP1 arglist)))))
    (and commands (apply #'COMS arglist))
    (and specials
	 (let ((SYMBOL-SELECT #'(lambda (x) (get x ':SPECIAL))))
	   (terpri2) (princ "***  Specials:")
	   (cond ((null arglist) (help1 nil))
		 (t (mapc #'HELP1 arglist)))))
    (and in-area
	 (let ((SYMBOL-SELECT #'(lambda (x &aux num)
				  (and (boundp x)
				       (fixp (setq num (%area-number (symeval x))))
				       (= num AREA-NUMBER)))))
	   (terpri2) (princ-rest "***  Value in Area " AREA-NUMBER ":")
	   (cond ((null arglist) (help1 nil))
		 (t (mapc #'HELP1 arglist)))))
    (and others
	 (let ((SYMBOL-SELECT #'(lambda (x)
				  (and (boundp x) (not (numberp (symeval x)))))))
	   (terpri2) (princ "***  Others:")
	   (cond ((null arglist) (help1 nil))
		 (t (mapc #'HELP1 arglist))))))
  (terpri) (beep-tune)
  "VALS done.")


; Show all symbols bound to saved commands (remembered function calls with args).

(defun coms (&quote &rest arglist)
  (and (eq (car -) 'COMS) (set-latest))
  (let ((SYMBOL-ACTION nil)
	(SYMBOL-SELECT #'(lambda (x)
			   (and (boundp x)
				(listp (symeval x))
				(symbolp (car (symeval x)))
				(not (null (car (symeval x))))))))
    (terpri2) (princ "***  Commands:")
    (cond ((null arglist) (help1 nil))
	  (t (mapc #'HELP1 arglist))))
  (cond ((eq (car -) 'COMS)
	 (terpri) (beep-tune) "COMS done.")))


; Display all symbols whose values match something in function's arglist.

(defun find-vals (&rest search-val-list)
  (set-latest) (terpri)
  (princ-rest "Values sought:  " search-val-list)
  (let ((SYMBOL-SELECT #'(lambda (x)
			   (and (boundp x)
				(not (listp (symeval x)))
				(member (symeval x) search-val-list)))))
    (help1 nil))
  (terpri) (beep-tune) "FIND-VALS done.")


(local-declare ((special SEARCH-VAL TIME-LIMIT))
  
  (defun subvalue (SEARCH-VAL &optional (TIME-LIMIT 20.))
    (set-latest) (terpri)
    (princ-rest "Value sought:  " SEARCH-VAL)
    (let ((SYMBOL-SELECT #'SUBVALUE-INTERNAL))
      (help1 nil))
    (terpri) (beep-tune) "SUBVALUE done.")
  
  
  (defun subvalue-internal (x)
    (*catch ':FLUSH
      (cond ((not (boundp x)) nil)
	    (t (subvalue-internal2 (symeval x) SEARCH-VAL TIME-LIMIT (time))))))
  
  
  (defun subvalue-internal2 (val val-check tlim start-time)
    (cond ((equal val val-check) t)
	  ((> (abs (- (time) start-time)) tlim) (*throw ':FLUSH nil))
	  ((null val) nil)
	  ((arrayp val)
	   (cond ((= (array-/#-dims val) 1.)
		  (do ((index 0. (1+ index)))
		      ((>= index (array-length val)))
		    (and (subvalue-internal2 (aref val index) val-check tlim start-time)
			 (return t))))))
	  ((listp val)
	   (do ((itemlist val (cdr itemlist)))
	       ((or (null itemlist)
		    (atom itemlist)))
	     (and (subvalue-internal2 (car itemlist) val-check tlim start-time)
		  (return t))))
	  (t nil))))


(defun print-out-symbol (x &aux y (PACKAGE (pkg-find-package "USER")))
  (terpri1) (prin1 x) (princ "  ")
  (cond ((boundp x)
	 (line-print 24. "Va: ")
	 (let ((G-PRINENDLINE 3.))
	   (funcall PRIN1 (symeval x)))
	 (princ-rest-indented 16. "  " (data-type (symeval x))
			      "  Ar: " (%area-number (symeval x)) "  "))
	(t (line-print 24. "Unbound.  ")))
  (cond ((fboundp x)
	 (princ-rest-indented 16. (cond ((= (charpos) 16.) "") (t "	"))
			      "Ag: " (arglist x) "  ")
	 (and (>= (charpos) 64.) (skip-to 16.))
	 (princ-rest-indented 16. (cond ((= (charpos) 16.) "") (t "	"))
			      "File:  " (get x 'SOURCE-FILE-NAME))))
  (cond ((not (null (setq y (get x 'DOCUMENTATION))))
	 (line-print 8. "Documentation:")
	 (terpri) (princ y)))
  (more))


; Change all Large-float values back to Small-float.

(defun reset-floats ( )
  (terpri)
  (mapatoms #'(lambda (x &aux value)
		(cond ((and (boundp x)
			    (floatp (setq value (symeval x)))
			    (not (small-floatp value)))
		       (cond ((ask-yn "Symbol:  " x "  has value:  " value
				      "  Set to small-float? ")
			      (set x (small-float value)))))))
	    PACKAGE nil)
  DONE)


; Display various statistics on memory usage.

(defun memch (&optional area)
  (terpri2)
  (princ-rest "Free-space:  "
	      (// (small-float (si:room-get-area-length-used SI:FREE-AREA))
		  (small-float INITIAL-MEMORY-SIZE) 0.01s0)
	      " percent remaining.")
  (cond ((fixp area)
	 (terpri2) (princ-rest "Area:  " area)
	 (terpri) (si:room-print-area area))
	(t (terpri) (room) (terpri)
	   (princ-rest "Data-area (" DATA-AREA "):")
	   (terpri) (si:room-print-area DATA-AREA) (terpri)
	   (princ-rest "Signal-area (" SIGNAL-AREA "):")
	   (terpri) (si:room-print-area SIGNAL-AREA) (terpri)
	   (princ-rest "Temporary-area (" TEMPORARY-AREA "):")
	   (terpri) (si:room-print-area TEMPORARY-AREA)))
  DONE)


(defun area-test (object)
  (terpri) (princ "Obj:") (area-test2 object 5.)
  "AREA-TEST done.")


(defun area-test2 (object col)
  (skip-to (setq col (max 3. (\ col 50.))))
  (funcall PRIN1 object)
  (princ-rest "  Type: " (typep object) "  Area: " (%area-number object))
  (cond ((atom object))
	(t (terpri)
	   (line-print (- col 3.) "Car:")
	   (area-test2 (car object) (+ col 2.))
	   (terpri)
	   (area-test3 (cdr object) (- col 3.)))))


(defun area-test3 (object col)
  (setq col (max 0. (\ col 50.)))
  (cond ((atom object)
	 (line-print col "Cdr:")
	 (area-test2 object (+ col 5.)))
	(t (line-print col "Nxt:")
	   (area-test2 (car object) (+ col 5.))
	   (terpri)
	   (area-test3 (cdr object) col))))


(defun sym-area-test (object)
  (terpri) (princ "Obj:") (sym-area-test2 object 5.)
  "SYM-AREA-TEST done.")


(defun sym-area-test2 (object col)
  (skip-to (setq col (max 3. (\ col 50.))))
  (funcall PRIN1 object)
  (princ-rest "  Type: " (typep object) "  Area: " (%area-number object))
  (cond ((atom object))
	(t (terpri)
	   (line-print (- col 3.) "Car:")
	   (sym-area-test2 (car object) (+ col 2.))
	   (terpri)
	   (line-print (- col 3.) "Cdr:")
	   (sym-area-test2 (cdr object) (+ col 2.)))))


; MISCELLANEOUS USEFUL FUNCTIONS:

(defun fonts-test ( )
  (princ "
 Type space to see successive pages of same font.
 Type n to see next font.
 Type space to start.")
  (tyi)
  (mapatoms #'(lambda (font)
		(cond ((boundp font)
		       (do ((page 0. (+ page 128.)))
			   (( ))
			 (clear)
			 (princ-rest font ", Page " (// page 128.) " (no "
				     page " through " (+ page 127.) ") ")
			 (and (eq 'NEXT (do ((i 0. (1+ i)) (x) (y))
					    ((>= i 128.)
					     (and (= (tyi) #/n) (return 'NEXT)))
					  (setq y (// i 9.)
						x (\ i 9.))
					  (tv:%draw-char (symeval font) (+ i page)
							 (+ 100. (* x 50.))
							 (+ 100. (* y 50.))
							 TV:ALU-IOR TV:SELECTED-WINDOW)))
			      (return nil))))
		      (t (print-line 0. 50. "Unbound."))))
	    "FONTS" nil)
  (beep-tune) "FONTS-TEST done.")


; GENERAL-PURPOSE UTILITY FUNCTIONS:

(defun dof (&quote &rest forms)
  (do ( )
      (( ))
    (and (more) (return DONE))
    (mapc #'EVAL forms)))


(defun ma (fcn list)				; Avoids garbage printout of
  (mapc fcn list)				; MAPC's return value.
  DONE)


(defun ch (index new-value ch-list)
  (and (fixp index)
       (setf (nth index ch-list)
	     (cond ((floatp new-value) (small-float new-value))
		   (t new-value))))
  ch-list)


(defun mult (list num)
  (map #'(lambda (x) (rplaca x (* (car x) (small-float num))))
       list)
  list)


; Declare a set of variables SPECIAL and others UNSPECIAL.

(defun spec (&quote &rest vars)
  (cond ((neq (first vars) 't) (terpri) (princ "Special:   ")))
  (do ((varlist vars (cdr varlist))
       (flag t))
      ((null varlist) DONE)
    (cond ((eq (car varlist) 't)
	   (setq flag nil) (terpri) (princ "Unspecial: "))
	  (flag ((lambda (&rest var) (apply #'SPECIAL var)) (car varlist))
		(and (boundp (car varlist)) (makunbound (car varlist)))
		(princ-rest " " (car varlist)))
	  (t ((lambda (&rest var) (apply #'UNSPECIAL var)) (car varlist))
	     (princ-rest " " (car varlist))))))


; POP first arg <2nd arg> times.

(defun popn (&quote thing n)
  (or (numberp n) (psetq thing n n thing))
  (do ((i 0. (1+ i)))
      ((>= i n) (symeval thing))
    (terpri1)
    (princ "Popped:  ") (funcall PRIN1 (car (symeval thing)))
    (set thing (cdr (symeval thing)))))


; Changes all floats in a tree (or list) to small-float.

(defun make-small-float (tree &optional area)
  (and (fixp area)
       (let ((DEFAULT-CONS-AREA area))
	 (setq tree (subst nil nil tree))))
  (and (numberp (car tree)) (rplaca tree (small-float (car tree))))
  (and (numberp (cdr tree)) (rplacd tree (small-float (cdr tree))))
  (or (atom (car tree)) (make-small-float (car tree)))
  (or (atom (cdr tree)) (make-small-float (cdr tree)))
  tree)


; Just like SETQ except converts numbers to SMALL-FLOAT.  Also returns a LIST of
; what it did (USE ONLY FOR SIDE EFFECT).

(defun sett (&quote &rest list &aux a b c d)
  (do ((arglist list (cddr arglist)))
      ((null arglist) (reverse c))
    (setq d (eval (second arglist)))
    (setq a (first arglist) b (cond ((numberp d) (small-float d))
				    (t d)))
    (set a b)
    (push (list a b) c)))


; Like SETQ except remembers previous values.

(defun setw (&quote &rest a)
  (prog (temp)
	(and (or (= (length a) 1.) (= (length a) 2.))
	     (not (symbolp (first a)))
	     (return (first a) '(MUST BE A SYMBOL.)))
	(and (null (get (first a) 'OLD-VALUE))
	     (putprop (first a) '(*UNBOUND*) 'OLD-VALUE))
	(cond ((= (length a) 1.)
	       (setq temp (get (first a) 'OLD-VALUE))
	       (cond ((equal temp '(*UNBOUND*))
		      (return (makunbound (first a)) '(*UNBOUND*)))
		     (t (putprop (first a) (cdr temp) 'OLD-VALUE)
			(return (set (first a) (car temp))
				`(saved -> ,@(cdr temp))))))
	      ((= (length a) 2.)
	       (cond ((not (boundp (first a)))
		      (putprop (first a) '(*UNBOUND*) 'OLD-VALUE)
		      (return (set (first a) (eval (second a)))
			      '(0. OLD VALUES SAVED.)))
		     (t (putprop (first a)
				 (setq temp (cons (symeval (first a))
						  (get (first a) 'OLD-VALUE)))
				 'OLD-VALUE)
			(return (set (first a) (eval (second a)))
				`(saved -> ,@temp)))))
	      (t (return (first a) '(ONE OR TWO ARGUMENTS PLEASE.))))))


; Factoring and Prime-Number-finding Functions:

(defun factor (x &optional (num 1.) &aux limit)
  (setq BASE 10. IBASE 10. *NOPOINT nil)
  (setq limit (fix (square-root (* 1.001s0 (small-float x)))))
  (do ((i 2. (plus i bump))
       (DEFAULT-CONS-AREA TEMPORARY-AREA)
       (bump 1. 2.)
       (val 0. (or (listen2) 0.)))
      ((greaterp i limit) (list-in-area TEMPORARY-AREA x))
    (cond ((= val #\RUBOUT)
	   (princ-rest " * running: " (cons num i)))
	  ((= val #\TAB) (return '(QUIT)))
	  ((zerop (remainder x i))
	   (return (cons i (factor (// x i) (1+ num))))))))


(defun *factor (x &aux limit)
  (setq limit (fix (square-root (* 1.001s0 (small-float x)))))
  (do ((i 2. (plus i bump))
       (DEFAULT-CONS-AREA TEMPORARY-AREA)
       (bump 1. 2.))
      ((greaterp i limit) (list-in-area TEMPORARY-AREA x))
    (cond ((zerop (remainder x i))
	   (return (cons i (*factor (// x i))))))))


(defun listem (&optional (start 1.) &aux y)
  (setq BASE 10. IBASE 10. *NOPOINT nil)
  (terpri1)
  (skip-this nil
     (do ((i start (add1 i)))
	 (())
       (princ-rest i "  	"
		   (cond ((= (length (setq y (*factor i))) 1.) "** Prime **")
			 (t y)))
       (terpri1) (more)))
  (beep-tune) "LISTEM done.")


; TIMING UTILITIES:

(defun time-it (&quote form &eval &optional (number 1.))	; use: (time-it <form> n)
  (set-latest)
  (time1 form number)
  (beep-tune)
  "TIME-IT done.")


(defun time1 (form number &aux t-time val)
  (setq BASE 10. IBASE 10. *NOPOINT nil)
  (terpri1) (princ "Form:  ") (funcall PRIN1 form) (terpri)
  (setq t-time
	(* 16. (- (- (time)
		     (prog2 (do ((count 0. (1+ count)))
				((>= count number))
			      (setq val (eval form)))
			    (time))))))
  (terpri1) (princ-rest "Took:  " t-time " milliseconds.") (terpri)
  (princ "Returned value:  ") (funcall PRIN1 val) (terpri)
  (princ-rest "Repetitions:     " number) (terpri))


(defun calculate (&optional (print? t) (n 10.))
  (and print? (cursorset (linenum) 0.))
  (do ((i 0. (\ (1+ i) 1000.)))
      (( ))
    (do ((j 0. (1+ j)))
	((>= j (* n 1200.)))
      (cosine 0.35s0) (sine 0.35s0))
    (cond (print? (terpri)
		  (and (>= (linenum) 55.) (cursorset 0. 0.))
		  (princ-rest "Data point:  " i "    Value:  " (random-number))
		  (line-print 45. "Cosine:  " (cosine (random-number)))
		  (line-print 72. "Sine:  " (sine (random-number)) " ")))
    (setq tv:kbd-last-activity-time (time))
    (process-allow-schedule)))


;;; FILE I/0:
;;; functions for saving arbitrary lisp data in pdp10 files

;;; for example if arr1 is bound to an art-q array and arr2 is bound to some other array
;;; and list1 is bound to a list, 
;;; (savesymbols "nis;foo" arr1 arr2 list1) will cause these to be saved in nis;foo qfasl
;;; (readsymbols "nis;foo") will cause them to be read back into the lispmachine and 
;;; arr1 arr2 and list1 will again be bound to their previous values

(declare (special SAVESYMBOLSLIST))

(defun savesymbols (file &quote &rest SAVESYMBOLSLIST)
  (setq SAVESYMBOLSLIST (cons 'SAVESYMBOLSLIST SAVESYMBOLSLIST))
  (compiler:fasd-file-symbols-properties file SAVESYMBOLSLIST nil t nil
    (function (lambda (symbol) (or (memq symbol compiler:FASD-ALREADY-DUMPED-SYMBOL-LIST)
				   (memq symbol compiler:FASD-SYMBOL-LIST)
				   (push symbol compiler:FASD-SYMBOL-LIST)))))
  SAVESYMBOLSLIST)

(defun readsymbols (file &aux SAVESYMBOLSLIST)
  (fasload file)
  SAVESYMBOLSLIST)


; DEBUGGING UTILITIES:

(defun test-print (&quote &rest arguments)
  (terpri2)
  (do ((values arguments (cdr values))
       (value))      
      ((null values))
    (setq value (car values))
    (and (> (charpos) 48.) (terpri))
    (and (> (charpos) 0.) (skip-to 48.))
    (cond ((stringp value) (princ-rest "****  " value "  ****"))
	  (t (princ-rest value "  " (eval value))))))


(local-declare ((special TRACELIST FILE))
  
  (defun debug (&quote &optional (arg1 '?) &rest TRACELIST)
    (setq BASE 10. IBASE 10. *NOPOINT nil DEBUGGING? nil)
    (set-latest) (untrace)
    (and (eq arg1 'ALL) (setq arg1 DEBUG-FILE-LIST))
    (cond ((null arg1) (setq TRACE-COMPILE-FLAG nil))
	  ((eq arg1 't) (setq DEBUGGING? t))
	  ((eq arg1 'JUST)
	   (mapc #'PRINT-OUT-SYMBOL TRACELIST)
	   (setq DEBUGGING? t))
	  ((listp arg1)
	   (mapc #'(lambda (FILE)
		     (setq FILE (string FILE))
		     (mapatoms #'(lambda (x)
				   (cond ((and (fboundp x)
					       (not (eq x 'CC))
					       (string-search
						 FILE (string (get x 'SOURCE-FILE-NAME))))
					  (push x TRACELIST)
					  (print-out-symbol x))))
			       PACKAGE nil))
		 arg1)
	   (setq DEBUGGING? t))
	  (t (setq DEBUGGING? nil TRACE-COMPILE-FLAG nil)
	     (print "Args:  (1) List of file first names or keyword T, NIL, ALL, or JUST.
	(rest) Names of functions to trace (if JUST is used, or names additional
	to those in files).  Arguments not evaluated.")))
    (terpri)
    (cond ((and DEBUGGING? TRACELIST)
	   (apply #'TRACE TRACELIST) "Above Functions Traced.")
	  (DEBUGGING? "Debugging on but TRACE disabled.")
	  (t "TRACE disabled."))))


; DRIBBLE-FILE FUNCTIONS:

(defun to-ed (&quote &rest forms)
  (let ((DRIBBLE-FILE (editor-stream "Dribble" nil))
	(DRIBBLE-IO-UNRCHF nil)
	(STANDARD-OUTPUT #'RSG-DRIBBLE-IO)
	(STANDARD-INPUT #'RSG-DRIBBLE-IO)
	(PRIN1 #'PRIN1))
    (do ((form forms (cdr form)))
	((null form))
      (terpri) (print (car form))
      (print (eval (car form))))
    (terpri))
  "TO-ED done.")


(defun dribble (&optional (action '?))
  (setq BASE 10. IBASE 10. *NOPOINT nil)
  (cond ((null action)
	 (cond ((boundp 'DRIBBLE-FILE)
		(princ "  Dribble turned off.")
		(terpri DRIBBLE-FILE)
		(close DRIBBLE-FILE)
		(makunbound 'DRIBBLE-FILE)
		(setq STANDARD-OUTPUT 'SI:TERMINAL-IO-SYN-STREAM
		      STANDARD-INPUT 'SI:TERMINAL-IO-SYN-STREAM
		      DRIBBLE-IO-UNRCHF nil
		      TRACE-OUTPUT 'QUERY-IO-SYN-STREAM
		      ERROR-OUTPUT 'QUERY-IO-SYN-STREAM
		      EH:ERROR-HANDLER-IO nil))
	       (t (princ "  Dribble not on."))))
	((eq action 't)
	 (cond ((not (boundp 'DRIBBLE-FILE))
		(setq DRIBBLE-FILE (editor-stream "Dribble" nil)
		      DRIBBLE-IO-UNRCHF nil
		      STANDARD-OUTPUT #'RSG-DRIBBLE-IO
		      STANDARD-INPUT #'RSG-DRIBBLE-IO
		      ERROR-OUTPUT #'RSG-DRIBBLE-IO
		      TRACE-OUTPUT #'RSG-DRIBBLE-IO)
		(terpri DRIBBLE-FILE)
		(princ "  Dribble started on LISP Machine."))
	       (t (princ "  Dribble already on."))))
	(t (cond ((boundp 'DRIBBLE-FILE)
		  (princ "  Dribble on."))
		 (t (princ "  Dribble off.")))))
  (beep-tune) "DRIBBLE done.")


(defun RSG-DRIBBLE-IO (&rest arglist &aux op arg rest)
  (setq op (first arglist) arg (second arglist) rest (cddr arglist))
  (selectq op
    (:TYI (COND (DRIBBLE-IO-UNRCHF
		 (prog1 DRIBBLE-IO-UNRCHF (setq DRIBBLE-IO-UNRCHF nil)))
		(t (and (setq arg (funcall TERMINAL-IO ':TYI))
			(funcall DRIBBLE-FILE ':TYO arg))
		   arg)))
    (:UNTYI (setq DRIBBLE-IO-UNRCHF arg))
    (:OTHERWISE
     (selectq op
       (:TYO (funcall DRIBBLE-FILE ':TYO arg))
       (:STRING-OUT (funcall DRIBBLE-FILE ':STRING-OUT arg))
       (:LINE-OUT (funcall DRIBBLE-FILE ':LINE-OUT arg))
       (:FRESH-LINE (terpri DRIBBLE-FILE))
       (:CLEAR-SCREEN
	(terpri DRIBBLE-FILE) (terpri DRIBBLE-FILE)
	(princ "** :CLEAR-SCREEN **" DRIBBLE-FILE)
	(terpri DRIBBLE-FILE) (terpri DRIBBLE-FILE)))
     (apply TERMINAL-IO arglist))))

(defprop RSG-DRIBBLE-IO t IO-STREAM-P)


;;; End.