(in-package "LISP")

(defun describe (x &optional stream)
  "Prints a description of the object X."
  (declare (type (or stream (member t nil)) stream))
  (cond (*in-describe*
	 (unless (or (eq x nil) (eq x t))
	   (let ((*current-describe-level* (1+ *current-describe-level*))
		 (*current-describe-object* x))
	     (progn ;;indenting-further *describe-output* *describe-indentation*
	       (describe-aux x)))))
	(t
         (let ((describe-output
                (case stream
                  ((t) *terminal-io*)
                  ((nil) *standard-output*)
                  (t stream))))
           (let ((*standard-output* describe-output)
                 (*print-level* (or *describe-print-level* *print-level*))
                 (*print-length* (or *describe-print-length* *print-length*))
                 (*described-objects* ())
                 (*in-describe* t)
                 (*current-describe-object* x))
             (describe-aux x))
           (values)))))

(defun describe-function-interpreted (x kind name)
  (multiple-value-bind (exp closure-p dname)
		       (eval:interpreted-function-lambda-expression x)
    (let ((args (eval:interpreted-function-arglist x)))
      (format t "~&~@(~@[~A ~]arguments:~%~)" kind)
      (cond ((not args)
	     (write-string "  There are no arguments."))
	    (t
	     (write-string "  ")
	     (progn ;;indenting-further *standard-output* 2
	       (prin1 args)))))
    
    (let ((name (or name dname)))
      (desc-doc name 'function kind)
      (unless (eq kind :macro)
	(describe-function-name
	 name
	 (type-specifier (eval:interpreted-function-type x)))))
    
    (when closure-p
      (format t "~&Its closure environment is:")
      (progn ;;indenting-further *standard-output* 2
	(let ((clos (eval:interpreted-function-closure x)))
	  (dotimes (i (length clos))
	    (format t "~&~D: ~S" i (svref clos i))))))
    
    (format t "~&Its definition is:~%  ~S" exp)))

(defun describe-function-compiled (x kind name)
  (let ((args (%function-arglist x)))
    (format t "~&~@(~@[~A ~]arguments:~%~)" kind)
    (cond ((not args)
	   (format t "  There is no argument information available."))
	  ((string= args "()")
	   (write-string "  There are no arguments."))
	  (t
	   (write-string "  ")
	   (progn ;;indenting-further *standard-output* 2
	     (write-string args)))))

  (let ((name (or name (%function-name x))))
    (desc-doc name 'function kind)
    (unless (eq kind :macro)
      (describe-function-name name (%function-type x))))

  (print-compiled-from (kernel:function-code-header x)))

(defun describe-function (x &optional (kind nil) name)
  (declare (type function x) (type (member :macro :function nil) kind))
  (fresh-line)
  (ecase kind
    (:macro (format t "Macro-function: ~S" x))
    (:function (format t "Function: ~S" x))
    ((nil)
     (format t "~S is function." x)))
  (case (get-type x)
    (#.vm:closure-header-type
     (describe-function-compiled (%closure-function x) kind name)
     (format t "~&Its closure environment is:")
     ;;(indenting-further *standard-output* 8)
     (dotimes (i (- (get-closure-length x) (1- vm:closure-info-offset)))
	      (format t "~&~D: ~S" i (%closure-index-ref x i))))
    ((#.vm:function-header-type #.vm:closure-function-header-type)
     (describe-function-compiled x kind name))
    (#.vm:funcallable-instance-header-type
     (typecase x
       (kernel:byte-function
	(describe-function-byte-compiled x kind name))
       (kernel:byte-closure
	(describe-function-byte-compiled (byte-closure-function x)
					 kind name)
	(format t "~&Its closure environment is:")
	;;(indenting-further *standard-output* 8)
	(let ((data (byte-closure-data x)))
	  (dotimes (i (length data))
	    (format t "~&~D: ~S" i (svref data i)))))
       (eval:interpreted-function
	(describe-function-interpreted x kind name))
       (t
	 (describe-instance x :funcallable-instance))))
    (t
     (format t "~&It is an unknown type of function."))))