Skip to content
Snippets Groups Projects
Commit 2f5f5910 authored by wlott's avatar wlott
Browse files

Added rudimentary support for funcallable-instances.

parent 3e6d724b
No related branches found
No related tags found
No related merge requests found
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.23 1993/02/26 08:25:09 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.24 1993/05/29 07:00:59 wlott Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -139,12 +139,12 @@
(defun default-describe (x)
(format t "~&~S is a ~S." x (type-of x)))
(defun describe-instance (x)
(defun describe-instance (x &optional (kind :structure))
(cond ((and (fboundp 'pcl::std-instance-p)
(pcl::std-instance-p x))
(pcl::describe-object x *standard-output*))
(t
(format t "~&~S is a structure of type ~A." x (type-of x))
(format t "~&~S is a ~(~A~) of type ~A." x kind (type-of x))
(dolist (slot (cddr (inspect::describe-parts x)))
(format t "~%~A: ~S." (car slot) (cdr slot))))))
......@@ -317,6 +317,10 @@
(print-compiled-from x))
(defun describe-funcallabe-instance (fin)
(describe-instance fin :funcallable-instance))
;;; DESCRIBE-FUNCTION -- Internal
;;;
;;; Describe a function with the specified kind and name. The latter
......@@ -344,7 +348,7 @@
((#.vm:function-header-type #.vm:closure-function-header-type)
(describe-function-compiled x kind name))
(#.vm:funcallable-instance-header-type
(pcl::describe-object x *standard-output*))
(describe-funcallabe-instance x))
(t
(format t "~&It is an unknown type of function."))))
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/tty-inspect.lisp,v 1.12 1993/02/26 08:26:20 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/tty-inspect.lisp,v 1.13 1993/05/29 07:01:10 wlott Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -149,8 +149,11 @@
(defun describe-parts (object)
(typecase object
(symbol (describe-symbol-parts object))
(instance (describe-instance-parts object))
(function (describe-function-parts object))
(instance (describe-instance-parts object :structure))
(function
(if (kernel:funcallable-instance-p object)
(describe-instance-parts object :funcallabe-instance)
(describe-function-parts object)))
(vector (describe-vector-parts object))
(array (describe-array-parts object))
(cons (describe-cons-parts object))
......@@ -167,11 +170,10 @@
(cons "Plist" (symbol-plist object))
(cons "Package" (symbol-package object))))
(defun describe-instance-parts (object)
(let ((dd-slots
(dd-slots (layout-info (%instance-layout object))))
(defun describe-instance-parts (object kind)
(let ((dd-slots (dd-slots (layout-info (kernel:layout-of object))))
(parts-list ()))
(push (format nil "~s is a structure.~%" object) parts-list)
(push (format nil "~s is a ~(~A~).~%" object kind) parts-list)
(push t parts-list)
(dolist (dd-slot dd-slots (nreverse parts-list))
(push (cons (dsd-%name dd-slot)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment