(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM")

(IL:FILECREATED "18-Oct-93 15:29:00" "{Pele:mv:envos}<LispCore>Sources>CLTL2>DESCRIBE.;2"
 14735  

      IL:|previous| IL:|date:| " 4-Feb-92 12:21:53" 
"{Pele:mv:envos}<LispCore>Sources>CLTL2>DESCRIBE.;1")


; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:DESCRIBECOMS)

(IL:RPAQQ IL:DESCRIBECOMS

          (
           (IL:* IL:|;;| "Common LISP describe facility")


           (IL:FUNCTIONS DESCRIBE DESCRIBE-INTERNAL DESCRIBE-NEW-LINE DESCRIBE-USING-DESCRIBERS 
                  GET-SUPER-DESCRIBERS GET-INSPECT-MACRO INSPECT-MACRO-USABLE-BY-DESCRIBE? 
                  DESCRIBE-USING-INSPECT-MACRO DESCRIBE-USING-RECORD-DECL)
           (IL:FUNCTIONS A-OR-AN VOWEL-P)
           (IL:DEFINE-TYPES LISP::DESCRIBERS)
           (IL:FUNCTIONS LISP::DEFDESCRIBER GET-DESCRIBERS)
           (IL:PROP IL:PROPTYPE DESCRIBERS)
           (LISP::DESCRIBERS SYMBOL LISP::STRUCTURE-OBJECT CHARACTER FIXNUM SINGLE-FLOAT HASH-TABLE)
           (IL:VARIABLES LISP::*DESCRIBE-DEPTH* LISP::*DESCRIBE-INDENT* LISP::*DESCRIBE-PRINT-LENGTH*
                  LISP::*DESCRIBE-PRINT-LEVEL*)
           (IL:PROPS (IL:DESCRIBE IL:MAKEFILE-ENVIRONMENT IL:FILETYPE))))



(IL:* IL:|;;| "Common LISP describe facility")



(DEFUN DESCRIBE
 (LISP::OBJECT &OPTIONAL STREAM)          (IL:* IL:\; 

                                                           "Edited  3-Feb-92 11:16 by jrb:")

   "Describe OBJECT, printing to STREAM."
   (LET ((*PRINT-LENGTH* LISP::*DESCRIBE-PRINT-LENGTH*)
         (*PRINT-LEVEL* LISP::*DESCRIBE-PRINT-LEVEL*)
         (*STANDARD-OUTPUT* (IL:\\GETSTREAM STREAM)))
        (DESCRIBE-INTERNAL
 LISP::OBJECT 0)
        (VALUES)))

(DEFUN DESCRIBE-INTERNAL
 (OBJECT DEPTH)

(IL:* IL:|;;;| "Recursive entry point for descriptions.")


   (IF (< DEPTH LISP::*DESCRIBE-DEPTH*)
       (LET* ((TYPE (TYPE-OF OBJECT))
              (TYPE-NAME (IF (CONSP TYPE)
                             (CAR TYPE)
                             TYPE))
              DESCRIBERS INSPECT-MACRO SUPER-DESCRIBERS IL:DECL)
             (DESCRIBE-NEW-LINE
 DEPTH)
             (FORMAT T "~A ~A, " (A-OR-AN
 TYPE-NAME)
                    TYPE-NAME)
             (COND
                ((SETQ DESCRIBERS (GET-DESCRIBERS
 TYPE-NAME))
                 (DESCRIBE-USING-DESCRIBERS
 OBJECT (1+ DEPTH)
                        DESCRIBERS))
                ((AND (SETQ INSPECT-MACRO (GET-INSPECT-MACRO
 OBJECT))
                      (INSPECT-MACRO-USABLE-BY-DESCRIBE?
 INSPECT-MACRO))
                 (DESCRIBE-USING-INSPECT-MACRO
 OBJECT (1+ DEPTH)
                        INSPECT-MACRO))
                ((SETQ SUPER-DESCRIBERS (GET-SUPER-DESCRIBERS
 TYPE-NAME))
                 (DESCRIBE-USING-DESCRIBERS
 OBJECT (1+ DEPTH)
                        SUPER-DESCRIBERS))
                ((SETQ IL:DECL (OR (IL:FINDRECDECL OBJECT)
                                   (IL:FINDSYSRECDECL OBJECT)))
                 (DESCRIBE-USING-RECORD-DECL
 OBJECT IL:DECL (1+ DEPTH)))
                (T 
                   (IL:* IL:|;;| "Punt to printing")


                   (PRIN1 OBJECT))))
       (PRIN1 OBJECT)))

(DEFUN DESCRIBE-NEW-LINE
 (DEPTH)
   (FRESH-LINE)
   (DOTIMES (N (* DEPTH LISP::*DESCRIBE-INDENT*))
       (WRITE-CHAR #\Space)))

(DEFUN DESCRIBE-USING-DESCRIBERS
 (OBJECT DEPTH DESCRIBERS)
   (MAPC #'(LAMBDA (DESCRIBER)
                  (IF (AND (CONSP DESCRIBER)
                           (STRINGP (FIRST DESCRIBER)))
                      (MULTIPLE-VALUE-BIND (FIELD EMPTY?)
                             (FUNCALL (SECOND DESCRIBER)
                                    OBJECT)
                             (UNLESS EMPTY?
                                 (DESCRIBE-NEW-LINE
 DEPTH)
                                 (FORMAT T "~A: " (FIRST DESCRIBER))
                                 (DESCRIBE-INTERNAL
 FIELD (1+ DEPTH))))
                      (FUNCALL DESCRIBER OBJECT DEPTH)))
         DESCRIBERS))

(DEFUN GET-SUPER-DESCRIBERS
 (TYPE)

   (IL:* IL:|;;| "Search up super-types of TYPE for describers")


   (DO* ((TYPE TYPE (IL:GETSUPERTYPE TYPE))
         (DESCRIBER NIL (GET-DESCRIBERS
 TYPE)))
        ((OR DESCRIBER (NULL TYPE))
         DESCRIBER)))

(DEFUN GET-INSPECT-MACRO
 (OBJECT)

   (IL:* IL:|;;| "Search IL:INSPECTMACROS for an inspect macro for OBJECT")


   (DECLARE
 (XCL:GLOBAL IL:INSPECTMACROS))
   (DO* ((TAIL IL:INSPECTMACROS (REST TAIL))
         (HEAD NIL (FIRST TAIL))
         (TYPE NIL (FIRST HEAD))
         (MACRO NIL (TYPECASE TYPE
                        (CONS (AND (EQ (FIRST TYPE)
                                       'IL:FUNCTION)
                                   (FUNCALL (SECOND TYPE)
                                          OBJECT)))
                        (OTHERWISE (TYPEP OBJECT TYPE)))))
        ((OR MACRO (NULL TAIL))
         HEAD)))

(DEFUN INSPECT-MACRO-USABLE-BY-DESCRIBE?
 (MACRO)
   (CONSP (REST MACRO)))

(DEFUN DESCRIBE-USING-INSPECT-MACRO
 (OBJECT DEPTH MACRO)
   (LET ((FETCHFN (THIRD MACRO))
         (FIELDS (SECOND MACRO)))
        (MAPCAR #'(LAMBDA (FIELD-NAME)
                         (DESCRIBE-NEW-LINE
 DEPTH)
                         (PRINC FIELD-NAME)
                         (PRINC ": ")
                         (DESCRIBE-INTERNAL
 (FUNCALL FETCHFN OBJECT FIELD-NAME)
                                (1+ DEPTH)))
               (IF (CONSP FIELDS)
                   FIELDS
                   (FUNCALL FIELDS OBJECT)))))

(DEFUN DESCRIBE-USING-RECORD-DECL
 (OBJECT IL:DECL DEPTH)
   (MAPC #'(LAMBDA (FIELD-NAME)
                  (DESCRIBE-NEW-LINE
 DEPTH)
                  (FORMAT T "~A: " FIELD-NAME)
                  (DESCRIBE-INTERNAL
 (IL:RECORDACCESS FIELD-NAME OBJECT IL:DECL)
                         (1+ DEPTH)))
         (IL:INSPECTABLEFIELDNAMES IL:DECL)))

(DEFUN A-OR-AN
 (WORD)
   "Return 'a' or 'an' depending upon whether the first letter in WORD is a vowel"
   (IF (VOWEL-P
 (ELT (ETYPECASE WORD
                             (SYMBOL (SYMBOL-NAME WORD))
                             (STRING WORD))
                         0))
       "an"
       "a"))

(DEFUN VOWEL-P
 (CHAR)
   "T if char is an A, E, I, O or U.  Not dependable with funky charsets."
   (CASE (CHARACTER CHAR)
       ((#\A #\a #\E #\e #\I #\i #\O #\o #\U #\u) T)
       (OTHERWISE NIL)))

(XCL:DEF-DEFINE-TYPE LISP::DESCRIBERS
 "Describers of objects")

(XCL:DEFDEFINER LISP::DEFDESCRIBER
 LISP::DESCRIBERS (TYPE &REST LISP::DESCRIBERS)
   `(SETF
     (GET ',TYPE 'DESCRIBERS)
     (LIST ,@(MAPCAR #'(LAMBDA (LISP::ITEM)

                              (IL:* IL:|;;| 

           "Throughout here symbols are quoted and lambda-expressions are hash-quoted for compiler")


                              (IF (AND (CONSP LISP::ITEM)
                                       (STRINGP (FIRST LISP::ITEM)))

                                  (IL:* IL:|;;| "It's a field name and function")


                                  `(LIST ',(FIRST LISP::ITEM)
                                         (IF (CONSP ',(SECOND LISP::ITEM))
                                             #',(SECOND LISP::ITEM)
                                             ',(SECOND LISP::ITEM)))

                                  (IL:* IL:|;;| "Else, it must be just a function")


                                  (IF (CONSP LISP::ITEM)
                                      `#',LISP::ITEM
                                      `',LISP::ITEM)))
                    LISP::DESCRIBERS))))

(DEFUN GET-DESCRIBERS
 (TYPE)
   (GET TYPE 'DESCRIBERS))

(IL:PUTPROPS DESCRIBERS
 IL:PROPTYPE
 IGNORE)

(LISP::DEFDESCRIBER SYMBOL


   (IL:* IL:|;;| "This describer uses all features")


   ("name" SYMBOL-NAME)                                      (IL:* IL:\; 

                                                           "A field name and accessor")

   (LAMBDA (SYMBOL LISP::DEPTH)                              (IL:* IL:\; "An arbitrary function")

          (LET ((LISP::FIRST-TIME? 'T)
                (LISP::HASH-TABLES))
               (MAPHASH #'(LAMBDA (TYPE HASH-TABLE)
                                 (WHEN (NOT (MEMBER HASH-TABLE LISP::HASH-TABLES :TEST #'EQ))
                                     (PUSH HASH-TABLE LISP::HASH-TABLES)
                                     (LET ((LISP::DOC (GETHASH SYMBOL HASH-TABLE)))
                                          (WHEN LISP::DOC
                                              (WHEN LISP::FIRST-TIME?
                                                  (SETQ LISP::FIRST-TIME? 'NIL)
                                                  (DESCRIBE-NEW-LINE
 LISP::DEPTH)
                                                  (PRINC "documentation:"))
                                              (DESCRIBE-NEW-LINE
 (1+ LISP::DEPTH))
                                              (FORMAT T "~A: ~A" TYPE LISP::DOC)
                                              NIL))))
                      IL:*DOCUMENTATION-HASH-TABLE*)))
   ("package cell" SYMBOL-PACKAGE)                           (IL:* IL:\; 

                                                           "another field name & accessor")

   ("value cell"                                             (IL:* IL:\; 

                                                           "use of multiple values in accessor ")

          (LAMBDA (SYMBOL)
                 (LET ((LISP::UNBOUND? (NOT (BOUNDP SYMBOL))))
                      (VALUES (UNLESS LISP::UNBOUND? (SYMBOL-VALUE SYMBOL))
                             LISP::UNBOUND?))))
   ("function cell"                                          (IL:* IL:\; "ditto")

          (LAMBDA (SYMBOL)
                 (LET ((LISP::UNDEFINED? (NOT (FBOUNDP SYMBOL))))
                      (VALUES (UNLESS LISP::UNDEFINED? (SYMBOL-FUNCTION SYMBOL))
                             LISP::UNDEFINED?))))
   (LAMBDA (SYMBOL LISP::DEPTH)                              (IL:* IL:\; 

                                                           "arbitratry function again")

          (LET ((LISP::PLIST (SYMBOL-PLIST SYMBOL)))
               (WHEN LISP::PLIST
                   (DESCRIBE-NEW-LINE
 LISP::DEPTH)
                   (PRINC "property list:")
                   (DO ((LISP::PLIST LISP::PLIST (CDDR LISP::PLIST)))
                       ((NULL LISP::PLIST))
                     (DESCRIBE-NEW-LINE
 (1+ LISP::DEPTH))
                     (PRIN1 (FIRST LISP::PLIST))
                     (PRINC " : ")

                     (IL:* IL:|;;| "Recurse on each property")


                     (DESCRIBE-INTERNAL
 (SECOND LISP::PLIST)
                            (+ LISP::DEPTH 2)))))))

(LISP::DEFDESCRIBER LISP::STRUCTURE-OBJECT


   (IL:* IL:|;;| "Describer for objects created by DEFSTRUCT")


   (LAMBDA (LISP::OBJECT LISP::DEPTH)
          (MAPC #'(LAMBDA (LISP::SLOT)
                         (DESCRIBE-NEW-LINE
 LISP::DEPTH)
                         (FORMAT T "~A: " (LISP::PSLOT-NAME LISP::SLOT))

                         (IL:* IL:|;;| "Recurse on fields")


                         (DESCRIBE-INTERNAL
 (FUNCALL (LISP::PSLOT-ACCESSOR LISP::SLOT)
                                                       LISP::OBJECT)
                                (1+ LISP::DEPTH)))
                (LISP::PS-ALL-SLOTS (LISP::PARSED-STRUCTURE (TYPE-OF LISP::OBJECT))))))

(LISP::DEFDESCRIBER CHARACTER

   (LAMBDA (CHAR LISP::DEPTH)
          (MULTIPLE-VALUE-CALL 'FORMAT T 
                 "'~:@C', code #\\~O-~3,'0O (~D decimal, ~:*~X hex, ~:*~B binary)" CHAR
                 (FLOOR (CHAR-CODE CHAR)
                        256)
                 (CHAR-CODE CHAR))))

(LISP::DEFDESCRIBER FIXNUM
 (LAMBDA (NUMBER LISP::DEPTH)
                                      (FORMAT T 
                              "~D decimal, ~:*~O octal, ~:*~X hex, ~:*~B binary~@[, '~C' character~]"
                                             NUMBER (INT-CHAR NUMBER))))

(LISP::DEFDESCRIBER SINGLE-FLOAT

   ("sign" (LAMBDA (FLOAT)
                  (ECASE (FLOAT-SIGN FLOAT)
                      (1.0 'LISP::POSITIVE)
                      (-1.0 'LISP::NEGATIVE))))
   ("radix" FLOAT-RADIX)
   ("digits" FLOAT-DIGITS)
   ("significand" (LAMBDA (FLOAT)

                         (IL:* IL:|;;| "onlyt return first value, as second confuses describe.")


                         (VALUES (DECODE-FLOAT FLOAT))))
   ("exponent" (LAMBDA (FLOAT)
                      (SECOND (MULTIPLE-VALUE-LIST (DECODE-FLOAT FLOAT))))))

(LISP::DEFDESCRIBER HASH-TABLE
 ("count" HASH-TABLE-COUNT)
                                   ("size" IL:HARRAYSIZE)
                                   ("test" (LAMBDA (LISP::TABLE)
                                                  (IL:HARRAYPROP LISP::TABLE 'IL:EQUIVFN)))
                                   (LAMBDA (LISP::TABLE LISP::DEPTH)
                                          (DESCRIBE-NEW-LINE
 LISP::DEPTH)
                                          (PRINC "contents:")
                                          (LET* ((LISP::NEW-DEPTH (1+ LISP::DEPTH))
                                                 (LISP::NEW-NEW-DEPTH (1+ LISP::NEW-DEPTH)))
                                                (MAPHASH #'(LAMBDA (LISP::KEY LISP::VALUE)
                                                                  (DESCRIBE-NEW-LINE
 
                                                                         LISP::NEW-DEPTH)
                                                                  (PRIN1 LISP::KEY)
                                                                  (PRINC " : ")
                                                                  (DESCRIBE-INTERNAL
 LISP::VALUE
                                                                         LISP::NEW-NEW-DEPTH))
                                                       LISP::TABLE))))

(DEFPARAMETER LISP::*DESCRIBE-DEPTH*
 1
   "The recursive depth to which DESCRIBE describes")

(DEFPARAMETER LISP::*DESCRIBE-INDENT*
 3
   "Number of spaces to indent recursive descriptions")

(DEFPARAMETER LISP::*DESCRIBE-PRINT-LENGTH*
 3
   "The value of *PRINT-LENGTH* in DESCRIBE")

(DEFPARAMETER LISP::*DESCRIBE-PRINT-LEVEL*
 3
   "The value of *PRINT-LEVEL* in DESCRIBE")

(IL:PUTPROPS IL:DESCRIBE
 IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "XCL" :PACKAGE "SYSTEM"))

(IL:PUTPROPS IL:DESCRIBE
 IL:FILETYPE
 :COMPILE-FILE)
(IL:PUTPROPS IL:DESCRIBE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993)
)
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL)))
IL:STOP