;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

;;; Assorted miscellaneous functions for Spice Lisp.

;;; Written and maintained by Scott Fahlman.
;;; Contributions made by Dan Aronson, Skef Wholey and Rob MacLachlan.

;;; *******************************************************************

(defun documentation (symbol doc-type)
  "Returns the documentation string of Doc-Type for the Symbol, or NIL if
  none exists.  Legal doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
  and SETF."
  (or (get symbol 'documentation)	; Temporary kludge.
      (case doc-type
	(variable (get symbol '%var-documentation))
	(function (get symbol '%fun-documentation))
	(structure (get symbol '%struct-documentation))
	(type (get symbol '%type-documentation))
	(setf (get symbol '%setf-documentation)))))


(defun %set-documentation (symbol doc-type string)
  (case doc-type
    (variable (%put symbol '%var-documentation string))
    (function (%put symbol '%fun-documentation string))
    (structure (%put symbol '%struct-documentation string))
    (type (%put symbol '%type-documentation string))
    (setf (%put symbol '%setf-documentation string))))


(declare (special *features*))

(defun featurep (x)
  "If X is an atom, see if it is present in *FEATURES*.  Also
  handle arbitrary combinations of atoms using NOT, AND, OR."
  (cond ((atom x) (memq x *features*))
	((eq (car x) 'not) (not (featurep (cadr x))))
	((eq (car x) 'and)
	 (every #'featurep (cdr x)))
	((eq (car x) 'or)
	 (some #'featurep (cdr x)))
	(t nil)))

;;;; Room and GC.

(defvar alloctable-address (%primitive make-immediate-type #x10000 0)
  "A system area pointer that addresses the the alloctable.")

(declare (special *already-maybe-gcing*))

(defun alloc-ref (index)
  (logior (%primitive 16bit-system-ref alloctable-address index)
	  (ash (logand #x1FF (%primitive 16bit-system-ref alloctable-address
					 (1+ index)))
	       16)))

(defun space-usage (type)
  (let ((base (ash type 4)))
    (values (alloc-ref (+ base (ash (%sp-get-newspace-bit) 2)))
	    (alloc-ref (+ base 8))
	    (alloc-ref (+ base 12)))))

(defconstant type-space-names
  '("Misc" "Bit-Vector" "Integer-Vector" "String" "Bignum" "Long-Float"
    "Complex" "Ratio" "General-Vector" "Function" "Array" "Symbol" "List"
    "Unused-13" "Unused-14" "Unused-15"))

(defconstant first-used-type 1)
(defconstant first-unused-type 13)

(defun room-header ()
  (fresh-line)
  (princ "       Type        |  Dynamic  |   Static  | Read-Only |   Total")
  (terpri)
  (princ "-------------------|-----------|-----------|-----------|-----------")
  (terpri))

(defun room-summary (dynamic static read-only)
  (princ "-------------------|-----------|-----------|-----------|-----------")
  (format t "~% Totals:           |~10D |~10D |~10D =~10D~%" 
	  dynamic static read-only (+ static dynamic read-only)))

(defun describe-one-type (type dynamic static read-only)
  (format t "~18A |~10D |~10D |~10D |~10D~%" (elt type-space-names type)
	  dynamic static read-only (+ static dynamic read-only)))
    
(defun room (&optional (x t) (object nil argp))
  "Displays information about storage allocation.
  If X is true then information is displayed broken down by types.
  If Object is supplied then just display information for objects of
  that type."
  (when x
    (let ((type (%primitive get-type object)))
      (when (>= type 16)
	(error "Objects of type ~S have no allocated storage."
	       (type-of object)))
      (room-header)
      (cond
       (argp
	(multiple-value-bind (dyn stat ro)
			     (space-usage type)
	  (describe-one-type type dyn stat ro)))
       (t
        (let ((cum-dyn 0)
	      (cum-stat 0)
	      (cum-ro 0))
	  (do ((type first-used-type (1+ type)))
	      ((= type first-unused-type))
	    (multiple-value-bind (dyn stat ro)
				 (space-usage type)
	      (describe-one-type type dyn stat ro)
	      (incf cum-dyn dyn) (incf cum-stat stat) (incf cum-ro ro)))
	  (room-summary cum-dyn cum-stat cum-ro))))))
  (format t "~%There are approximately ~D words of swap space left."
	  (ash (available-vm) -1)))

(defvar gc-flip-ratio 2
  "When the amount of stuff in dynamic space exceeds the amount of paging space
  by this factor, a GC is done.")

(defun maybe-gc ()
  "Does a GC if we're low on paging space, otherwise does nothing.  This
  function is called by the microcode now and then."
  (let ((cum-dyn 0))
    (do ((type first-used-type (1+ type)))
	((= type first-unused-type))
      (incf cum-dyn (space-usage type)))
    (when (> (/ cum-dyn (ash (available-vm) -1)) gc-flip-ratio)
      (let ((*standard-output* *terminal-io*))
	(beep)
	(terpri)
	(write-line "[GC-Flip-Ratio exceeded.  Commencing GC.]")
	(let ((freed (gc nil)))
	  (write-string "[GC completed.  Approximately ")
	  (princ freed)
	  (write-string " words were freed.]"))
	(beep)
	(terpri)))))

(defun gc (&optional (blah-p t))
  "Initiates a garbage collection.  If Blah-P is T, the amount of storage
  reclaimed is printed, otherwise it is returned."
  (let ((free-bytes-at-start (available-vm))
	(oldspace-base (ash (%sp-get-newspace-bit) 25)))
    (%sp-collect-garbage)
    (do* ((i first-used-type (1+ i))
	  (this-space (logior oldspace-base (ash i 27))
		      (logior oldspace-base (ash i 27))))
	 ((= i first-unused-type))
      (invalidate-memory this-space #x4000000)
      (validate-memory this-space #x4000000 -1))
    (cond (blah-p
	   (princ "Approximately ")
	   (princ (ash (- (available-vm) free-bytes-at-start) -1))
	   (princ " words have been reclaimed.")
	   (values))
	  (t
	   (ash (- (available-vm) free-bytes-at-start) -1)))))

;;; Describe:

;;; Desc-Doc prints the specified kind of documentation about the given Symbol.

(defun desc-doc (symbol name string)
  (let ((doc (documentation symbol name)))
    (when doc
      (format t "~%~A~%  ~A" string doc))))

(defun primep (x)
  "Returns T if X is prime, otherwise Nil."
  (setq x (abs x))
  (or (= x 1)
      (= x 2)
      (= x 3)
      (do ((i 3 (+ i 2))
	   (terminus (sqrt x)))
	  ((> i terminus) t)
	(if (zerop (rem x i))
	    (return nil)))))

(defun desc-arglist (function)
  (cond ((compiled-function-p function)
	 (%primitive header-ref function %function-arg-names-slot))
	((and (listp function)
	      (eq (car function) 'macro))
	 '(&rest **macroarg**))
	((and (listp function)
	      (eq (car function) 'lambda))
	 (cadr function))))

(defun describe (x)
  "Prints a description of the object X."
  (format t "~%~S is a ~S." x (type-of x))
  (typecase x
   (integer
    (cond ((= x 2)
	   (format t "~%It is the only even prime number."))
	  ((oddp x)
	   (if (primep x)
	       (format t "~%It is a prime number.")
	       (format t "~%It is a composite odd number.")))
	  (t
	   (format t "~%It is a composite even number."))))
   (number
    (if (primep x)
	(format t "~%It is a prime number.")))
   (symbol
    (if (boundp X)
	(format t "~%Its value is ~S." (symbol-value x)))
    (desc-doc x 'variable "Documentation on the variable:")
    (if (fboundp x)
	(format t
		"~%It can be called as a function in the following way:~%  ~S"
		(cons x (desc-arglist (symbol-function x)))))
    (desc-doc x 'function "Documentation on the function:")
    (desc-doc x 'structure "Documentation on the structure:")
    (desc-doc x 'type "Documentation on the type:")
    (desc-doc x 'setf "Documentation on the SETF form:")
    (do ((plist (symbol-plist X) (cddr plist)))
	((null plist) ())
      (unless (member (car plist) '(%var-documentation %fun-documentation
				    %struct-documentation %type-documentation
				    %setf-documentation))
	(format t "~%Its ~S property is ~S." (car plist) (cadr plist)))))
   (function
    (format t "~%It can be called in the following way:~%  ~S."
	    (cons (%primitive header-ref x %function-name-slot)
		  (desc-arglist x)))
    (desc-doc (%primitive header-ref x %function-name-slot) 'function
	      "Documentation:"))
   (hash-table
    (format t "~%It currently has ~S entries and ~S buckets."
	    (hash-table-count x) (hash-table-size x))))
  (terpri)
  x)

;;; Other Environment Inquiries.

(defun lisp-implementation-type ()
  "Spice Lisp")

(defun lisp-implementation-version ()
  *lisp-implementation-version*)

(defun machine-type ()
  "Perq-1A or Perq-2")

(defun machine-version ()
  "16K WCS CPU")

(defun machine-instance ()
  *machine-instance*)

(defun software-type ()
  "Spice")

(defun software-version ()
  "Accent system S4")

(defun short-site-name ()
  "CMU-CSD")

(defun long-site-name ()
  "Carnegie-Mellon University Computer Science Department")

;;; DIRECTORY stuff


;;; Does a directory call on NAME.

(defun directory (name)
  "Prints out a list of files that matches NAME.  NAME may be a string,
   a pathname of a file stream."
  (if (not (or (stringp name) (file-stream-p name) (pathnamep name)))
      (error "The argument ~s is not a legal argument to this function."))
  (let ((filename (namestring (truename name))))
    (multiple-value-bind (address count)
			 (ses-scan-names (concatenate 'string filename "*"))
      (do* ((i 0 (1+ i))
	    entries
	    (list (%sp-make-immediate-type address 0))
	    (base 0 (+ 90 base))
	    (len (%primitive 8bit-system-ref list base)
		 (%primitive 8bit-system-ref list base))
	    (str (make-string len) (make-string len)))
	   ((= i count) entries)
	(%sp-byte-blt list (1+ base) str 0 len)
	(push (pathname (concatenate 'string filename str)) entries)))))



;;; A timing macro.

(defmacro time (form)
  "Evaluates the Form and outputs timing statistics on *Trace-Output*."
  (let ((old-time (gensym))
	(new-time (gensym)))
    `(let ((,old-time)
	   (,new-time))
       (prog2
	(setq ,old-time (%sp-io-get-time))
	,form
	(setq ,new-time (%sp-io-get-time))
	(format *trace-output*
		"~&Evaluation took ~S second~:P (~S jiff~:@P) of real time.~%"
		(/ (- ,new-time ,old-time) 60.0) (- ,new-time ,old-time))))))