;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa ;; This file is part of GNU Common Lisp, herein referred to as GCL ;; ;; GCL is free software; you can redistribute it and/or modify it under ;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; GCL is distributed in the hope that it will be useful, but WITHOUT ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public ;; License for more details. ;; ;; You should have received a copy of the GNU Library General Public License ;; along with GCL; see the file COPYING. If not, write to the Free Software ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;; describe.lsp ;;;; ;;;; DESCRIBE and INSPECT (in-package 'lisp) (export '(describe inspect)) (in-package 'system) (proclaim '(optimize (safety 2) (space 3))) (defvar *inspect-level* 0) (defvar *inspect-history* nil) (defvar *inspect-mode* nil) (defvar *old-print-level* nil) (defvar *old-print-length* nil) (defun inspect-read-line () (do ((char (read-char *query-io*) (read-char *query-io*))) ((or (char= char #\Newline) (char= char #\Return))))) (defun read-inspect-command (label object allow-recursive) (unless *inspect-mode* (inspect-indent-1) (if allow-recursive (progn (princ label) (inspect-object object)) (format t label object)) (return-from read-inspect-command nil)) (loop (inspect-indent-1) (if allow-recursive (progn (princ label) (inspect-indent) (prin1 object)) (format t label object)) (write-char #\Space) (force-output) (case (do ((char (read-char *query-io*) (read-char *query-io*))) ((and (char/= char #\Space) (char/= #\Tab)) char)) ((#\Newline #\Return) (when allow-recursive (inspect-object object)) (return nil)) ((#\n #\N) (inspect-read-line) (when allow-recursive (inspect-object object)) (return nil)) ((#\s #\S) (inspect-read-line) (return nil)) ((#\p #\P) (inspect-read-line) (let ((*print-pretty* t) (*print-level* nil) (*print-length* nil)) (prin1 object) (terpri))) ((#\a #\A) (inspect-read-line) (throw 'abort-inspect nil)) ((#\u #\U) (return (values t (prog1 (eval (read-preserving-whitespace *query-io*)) (inspect-read-line))))) ((#\e #\E) (dolist (x (multiple-value-list (multiple-value-prog1 (eval (read-preserving-whitespace *query-io*)) (inspect-read-line)))) (write x :level *old-print-level* :length *old-print-length*) (terpri))) ((#\q #\Q) (inspect-read-line) (throw 'quit-inspect nil)) (t (inspect-read-line) (terpri) (format t "Inspect commands:~%~ n (or N or Newline): inspects the field (recursively).~%~ s (or S): skips the field.~%~ p (or P): pretty-prints the field.~%~ a (or A): aborts the inspection ~ of the rest of the fields.~%~ u (or U) form: updates the field ~ with the value of the form.~%~ e (or E) form: evaluates and prints the form.~%~ q (or Q): quits the inspection.~%~ ?: prints this.~%~%"))))) (defmacro inspect-recursively (label object &optional place) (if place `(multiple-value-bind (update-flag new-value) (read-inspect-command ,label ,object t) (when update-flag (setf ,place new-value))) `(when (read-inspect-command ,label ,object t) (princ "Not updated.") (terpri)))) (defmacro inspect-print (label object &optional place) (if place `(multiple-value-bind (update-flag new-value) (read-inspect-command ,label ,object nil) (when update-flag (setf ,place new-value))) `(when (read-inspect-command ,label ,object nil) (princ "Not updated.") (terpri)))) (defun inspect-indent () (fresh-line) (format t "~V@T" (* 4 (if (< *inspect-level* 8) *inspect-level* 8)))) (defun inspect-indent-1 () (fresh-line) (format t "~V@T" (- (* 4 (if (< *inspect-level* 8) *inspect-level* 8)) 3))) (defun inspect-symbol (symbol) (let ((p (symbol-package symbol))) (cond ((null p) (format t "~:@(~S~) - uninterned symbol" symbol)) ((eq p (find-package "KEYWORD")) (format t "~:@(~S~) - keyword" symbol)) (t (format t "~:@(~S~) - ~:[internal~;external~] symbol in ~A package" symbol (multiple-value-bind (b f) (find-symbol (symbol-name symbol) p) (declare (ignore b)) (eq f :external)) (package-name p))))) (when (boundp symbol) (if *inspect-mode* (inspect-recursively "value:" (symbol-value symbol) (symbol-value symbol)) (inspect-print "value:~% ~S" (symbol-value symbol) (symbol-value symbol)))) (do ((pl (symbol-plist symbol) (cddr pl))) ((endp pl)) (unless (and (symbolp (car pl)) (or (eq (symbol-package (car pl)) (find-package 'system)) (eq (symbol-package (car pl)) (find-package 'compiler)))) (if *inspect-mode* (inspect-recursively (format nil "property ~S:" (car pl)) (cadr pl) (get symbol (car pl))) (inspect-print (format nil "property ~:@(~S~):~% ~~S" (car pl)) (cadr pl) (get symbol (car pl)))))) (when (print-doc symbol t) (format t "~&-----------------------------------------------------------------------------~%")) ) (defun inspect-package (package) (format t "~S - package" package) (when (package-nicknames package) (inspect-print "nicknames: ~S" (package-nicknames package))) (when (package-use-list package) (inspect-print "use list: ~S" (package-use-list package))) (when (package-used-by-list package) (inspect-print "used-by list: ~S" (package-used-by-list package))) (when (package-shadowing-symbols package) (inspect-print "shadowing symbols: ~S" (package-shadowing-symbols package)))) (defun inspect-character (character) (format t (cond ((standard-char-p character) "~S - standard character") ((string-char-p character) "~S - string character") (t "~S - character")) character) (inspect-print "code: #x~X" (char-code character)) (inspect-print "bits: ~D" (char-bits character)) (inspect-print "font: ~D" (char-font character))) (defun inspect-number (number) (case (type-of number) (fixnum (format t "~S - fixnum (32 bits)" number)) (bignum (format t "~S - bignum" number)) (ratio (format t "~S - ratio" number) (inspect-recursively "numerator:" (numerator number)) (inspect-recursively "denominator:" (denominator number))) (complex (format t "~S - complex" number) (inspect-recursively "real part:" (realpart number)) (inspect-recursively "imaginary part:" (imagpart number))) ((short-float single-float) (format t "~S - short-float" number) (multiple-value-bind (signif expon sign) (integer-decode-float number) (declare (ignore sign)) (inspect-print "exponent: ~D" expon) (inspect-print "mantissa: ~D" signif))) ((long-float double-float) (format t "~S - long-float" number) (multiple-value-bind (signif expon sign) (integer-decode-float number) (declare (ignore sign)) (inspect-print "exponent: ~D" expon) (inspect-print "mantissa: ~D" signif))))) (defun inspect-cons (cons) (format t (case (car cons) ((lambda lambda-block lambda-closure lambda-block-closure) "~S - function") (quote "~S - constant") (t "~S - cons")) cons) (when *inspect-mode* (do ((i 0 (1+ i)) (l cons (cdr l))) ((atom l) (inspect-recursively (format nil "nthcdr ~D:" i) l (cdr (nthcdr (1- i) cons)))) (inspect-recursively (format nil "nth ~D:" i) (car l) (nth i cons))))) (defun inspect-string (string) (format t (if (simple-string-p string) "~S - simple string" "~S - string") string) (inspect-print "dimension: ~D"(array-dimension string 0)) (when (array-has-fill-pointer-p string) (inspect-print "fill pointer: ~D" (fill-pointer string) (fill-pointer string))) (when *inspect-mode* (dotimes (i (array-dimension string 0)) (inspect-recursively (format nil "aref ~D:" i) (char string i) (char string i))))) (defun inspect-vector (vector) (format t (if (simple-vector-p vector) "~S - simple vector" "~S - vector") vector) (inspect-print "dimension: ~D" (array-dimension vector 0)) (when (array-has-fill-pointer-p vector) (inspect-print "fill pointer: ~D" (fill-pointer vector) (fill-pointer vector))) (when *inspect-mode* (dotimes (i (array-dimension vector 0)) (inspect-recursively (format nil "aref ~D:" i) (aref vector i) (aref vector i))))) (defun inspect-array (array) (format t (if (adjustable-array-p array) "~S - adjustable aray" "~S - array") array) (inspect-print "rank: ~D" (array-rank array)) (inspect-print "dimensions: ~D" (array-dimensions array)) (inspect-print "total size: ~D" (array-total-size array))) (defun inspect-structure (x &aux name) (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" (setq name (type-of x))) (let* ((sd (get name 'si::s-data)) (spos (s-data-slot-position sd))) (dolist (v (s-data-slot-descriptions sd)) (format t "~%~4d:~@[[~s] ~]~20a:~s" (aref spos (nth 4 v)) (let ((type (nth 2 v))) (if (eq t type) nil type)) (car v) (structure-ref1 x (nth 4 v)))))) (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) (inspect-indent) (when (and (not *inspect-mode*) (or (> *inspect-level* 5) (member object *inspect-history*))) (prin1 object) (return-from inspect-object)) (incf *inspect-level*) (push object *inspect-history*) (catch 'abort-inspect (cond ((symbolp object) (inspect-symbol object)) ((packagep object) (inspect-package object)) ((characterp object) (inspect-character object)) ((numberp object) (inspect-number object)) ((consp object) (inspect-cons object)) ((stringp object) (inspect-string object)) ((vectorp object) (inspect-vector object)) ((arrayp object) (inspect-array object)) ((structurep object)(inspect-structure object)) (t (format t "~S - ~S" object (type-of object)))))) (defun describe (object &aux (*inspect-mode* nil) (*inspect-level* 0) (*inspect-history* nil) (*print-level* nil) (*print-length* nil)) ; "The lisp function DESCRIBE." (terpri) (catch 'quit-inspect (inspect-object object)) (terpri) (values)) (defun inspect (object &aux (*inspect-mode* t) (*inspect-level* 0) (*inspect-history* nil) (*old-print-level* *print-level*) (*old-print-length* *print-length*) (*print-level* 3) (*print-length* 3)) ; "The lisp function INSPECT." (read-line) (princ "Type ? and a newline for help.") (terpri) (catch 'quit-inspect (inspect-object object)) (terpri) (values)) (defun print-doc (symbol &optional (called-from-apropos-doc-p nil) &aux (f nil) x) (flet ((doc1 (doc ind) (setq f t) (format t "~&-----------------------------------------------------------------------------~%~53S~24@A~%~A" symbol ind doc)) (good-package () (if (eq (symbol-package symbol) (find-package "LISP")) (find-package "SYSTEM") *package*))) (cond ((special-form-p symbol) (doc1 (or (documentation symbol 'function) "") (if (macro-function symbol) "[Special form and Macro]" "[Special form]"))) ((macro-function symbol) (doc1 (or (documentation symbol 'function) "") "[Macro]")) ((fboundp symbol) (doc1 (or (documentation symbol 'function) (if (consp (setq x (symbol-function symbol))) (case (car x) (lambda (format nil "~%Args: ~S" (cadr x))) (lambda-block (format nil "~%Args: ~S" (caddr x))) (lambda-closure (format nil "~%Args: ~S" (car (cddddr x)))) (lambda-block-closure (format nil "~%Args: ~S" (cadr (cddddr x)))) (t "")) "")) "[Function]")) ((setq x (documentation symbol 'function)) (doc1 x "[Macro or Function]"))) (cond ((constantp symbol) (unless (and (eq (symbol-package symbol) (find-package "KEYWORD")) (null (documentation symbol 'variable))) (doc1 (or (documentation symbol 'variable) "") "[Constant]"))) ((si:specialp symbol) (doc1 (or (documentation symbol 'variable) "") "[Special variable]")) ((or (setq x (documentation symbol 'variable)) (boundp symbol)) (doc1 (or x "") "[Variable]"))) (cond ((setq x (documentation symbol 'type)) (doc1 x "[Type]")) ((setq x (get symbol 'deftype-form)) (let ((*package* (good-package))) (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFTYPE." x) "[Type]")))) (cond ((setq x (documentation symbol 'structure)) (doc1 x "[Structure]")) ((setq x (get symbol 'defstruct-form)) (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSTRUCT." x) "[Structure]"))) (cond ((setq x (documentation symbol 'setf)) (doc1 x "[Setf]")) ((setq x (get symbol 'setf-update-fn)) (let ((*package* (good-package))) (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF." `(defsetf ,symbol ,(get symbol 'setf-update-fn))) "[Setf]"))) ((setq x (get symbol 'setf-lambda)) (let ((*package* (good-package))) (doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF." `(defsetf ,symbol ,@(get symbol 'setf-lambda))) "[Setf]"))) ((setq x (get symbol 'setf-method)) (let ((*package* (good-package))) (doc1 (format nil "~@[~%Defined as: ~S~%See the doc of DEFINE-SETF-METHOD.~]" (if (consp x) (case (car x) (lambda `(define-setf-method ,@(cdr x))) (lambda-block `(define-setf-method ,@(cddr x))) (lambda-closure `(define-setf-method ,@(cddddr x))) (lambda-block-closure `(define-setf-method ,@(cdr (cddddr x)))) (t nil)) nil)) "[Setf]")))) ) (idescribe (symbol-name symbol)) (if called-from-apropos-doc-p f (progn (if f (format t "~&-----------------------------------------------------------------------------") (format t "~&No documentation for ~:@(~S~)." symbol)) (values)))) (defun apropos-doc (string &optional (package 'lisp) &aux (f nil)) (setq string (string string)) (if package (do-symbols (symbol package) (when (substringp string (string symbol)) (setq f (or (print-doc symbol t) f)))) (do-all-symbols (symbol) (when (substringp string (string symbol)) (setq f (or (print-doc symbol t) f))))) (if f (format t "~&-----------------------------------------------------------------------------") (format t "~&No documentation for ~S in ~:[any~;~A~] package." string package (and package (package-name (coerce-to-package package))))) (values))