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 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -139,12 +139,12 @@
(defun default-describe (x) (defun default-describe (x)
(format t "~&~S is a ~S." x (type-of 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) (cond ((and (fboundp 'pcl::std-instance-p)
(pcl::std-instance-p x)) (pcl::std-instance-p x))
(pcl::describe-object x *standard-output*)) (pcl::describe-object x *standard-output*))
(t (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))) (dolist (slot (cddr (inspect::describe-parts x)))
(format t "~%~A: ~S." (car slot) (cdr slot)))))) (format t "~%~A: ~S." (car slot) (cdr slot))))))
...@@ -317,6 +317,10 @@ ...@@ -317,6 +317,10 @@
(print-compiled-from x)) (print-compiled-from x))
(defun describe-funcallabe-instance (fin)
(describe-instance fin :funcallable-instance))
;;; DESCRIBE-FUNCTION -- Internal ;;; DESCRIBE-FUNCTION -- Internal
;;; ;;;
;;; Describe a function with the specified kind and name. The latter ;;; Describe a function with the specified kind and name. The latter
...@@ -344,7 +348,7 @@ ...@@ -344,7 +348,7 @@
((#.vm:function-header-type #.vm:closure-function-header-type) ((#.vm:function-header-type #.vm:closure-function-header-type)
(describe-function-compiled x kind name)) (describe-function-compiled x kind name))
(#.vm:funcallable-instance-header-type (#.vm:funcallable-instance-header-type
(pcl::describe-object x *standard-output*)) (describe-funcallabe-instance x))
(t (t
(format t "~&It is an unknown type of function.")))) (format t "~&It is an unknown type of function."))))
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -149,8 +149,11 @@
(defun describe-parts (object) (defun describe-parts (object)
(typecase object (typecase object
(symbol (describe-symbol-parts object)) (symbol (describe-symbol-parts object))
(instance (describe-instance-parts object)) (instance (describe-instance-parts object :structure))
(function (describe-function-parts object)) (function
(if (kernel:funcallable-instance-p object)
(describe-instance-parts object :funcallabe-instance)
(describe-function-parts object)))
(vector (describe-vector-parts object)) (vector (describe-vector-parts object))
(array (describe-array-parts object)) (array (describe-array-parts object))
(cons (describe-cons-parts object)) (cons (describe-cons-parts object))
...@@ -167,11 +170,10 @@ ...@@ -167,11 +170,10 @@
(cons "Plist" (symbol-plist object)) (cons "Plist" (symbol-plist object))
(cons "Package" (symbol-package object)))) (cons "Package" (symbol-package object))))
(defun describe-instance-parts (object) (defun describe-instance-parts (object kind)
(let ((dd-slots (let ((dd-slots (dd-slots (layout-info (kernel:layout-of object))))
(dd-slots (layout-info (%instance-layout object))))
(parts-list ())) (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) (push t parts-list)
(dolist (dd-slot dd-slots (nreverse parts-list)) (dolist (dd-slot dd-slots (nreverse parts-list))
(push (cons (dsd-%name dd-slot) (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