Liren Large Software Subsidy 9/09.iso/e/e070/4.ddi/LISPLIB/DESCRIBE.LSP

Text File | 1984-11-06 | 5.3 KB | 129 lines

;;; Copyright (C) 1984 by Gold Hill Computers

;;;    (DESCRIBE obj)
;;;        Prints some information about the object

(DEFUN DESCRIBE (OBJ)
  (TERPRI *STANDARD-OUTPUT*)
  ;; dispatch on type of object.
  (CASE (TYPE-OF OBJ)
    (CONS (FORMAT *STANDARD-OUTPUT* "~S is a list of length ~D."
       OBJ (LENGTH OBJ)))
    (NULL (FORMAT *STANDARD-OUTPUT* "NIL is the empty list."))
    (FIXNUM (FORMAT *STANDARD-OUTPUT*
               "~S is an ~:[even~;odd~] fixnum." OBJ (ODDP OBJ)))
    ((DOUBLE-FLOAT SINGLE-FLOAT)
     (LET (SEG OFF TEMP
           (SINGLEP (EQ (TYPE-OF OBJ) 'SINGLE-FLOAT)))
       (MULTIPLE-VALUE-SETQ (OFF SEG) (%POINTER OBJ))
       (FORMAT *STANDARD-OUTPUT*
     "~S is a ~:[double~;single~] precision floating point number."
     OBJ SINGLEP)
       (FORMAT *STANDARD-OUTPUT* "~%   Its internal representation is: #x")
       (DOTIMES (I (IF SINGLEP 4 8))
     (FORMAT *STANDARD-OUTPUT* "~:[0~X~;~X~]"
       (> (SETQ TEMP (%CONTENTS SEG (+ OFF I 1))) 15) TEMP))
       (FORMAT *STANDARD-OUTPUT* ".")))
    (SYMBOL
     (FORMAT *STANDARD-OUTPUT* "~S is a symbol." OBJ)
     (FORMAT *STANDARD-OUTPUT*
        "~%   Its ~:[global~;local~] value is~:[ unbound~;: ~S~]."
       (MULTIPLE-VALUE-BIND (OFF SEG) (%POINTER OBJ)
           (LOGBITP 7 (%CONTENTS SEG (+ OFF 16))))
       (BOUNDP OBJ)
       (AND (BOUNDP OBJ) (SYMBOL-VALUE OBJ)))
     (FORMAT *STANDARD-OUTPUT*
        "~%   Its function definition is~:[ unbound~;: ~S~]."
       (FBOUNDP OBJ) (AND (FBOUNDP OBJ)(SYMBOL-FUNCTION OBJ)))
     (FORMAT *STANDARD-OUTPUT* "~%   Its property list")
     (IF (NULL (SYMBOL-PLIST OBJ))
         (FORMAT *STANDARD-OUTPUT* " is empty.")
         (PROGN
            (FORMAT *STANDARD-OUTPUT* " contains:")
            (DO ((I (SYMBOL-PLIST OBJ) (CDDR I)))
                ((NULL I))
              (FORMAT *STANDARD-OUTPUT*
                 "~%    Property: ~S, Value: ~S"
                 (CAR I)(CADR I))))))
    (COMPILED-FUNCTION
      (FORMAT *STANDARD-OUTPUT* "~S is a compiled function." OBJ))
    (CLOSURE
      (FORMAT *STANDARD-OUTPUT* "~S is a closure." OBJ)
      (FORMAT *STANDARD-OUTPUT*
         "~%   Its function is: ~S.~%   Its environment is: ~S"
    (CAR OBJ) (CDR OBJ)))
    (STACK-GROUP
      (LET (X Y)
        (FORMAT *STANDARD-OUTPUT*"~S is a stack group." OBJ)
        (MULTIPLE-VALUE-BIND (OFF SEG)(%POINTER OBJ)
          (FORMAT *STANDARD-OUTPUT*
         "~%   Its state is: ~[ACTIVE~;RESUMABLE~;BROKEN~;EXHAUSTED~]."
         (LSH (%CONTENTS SEG (+ OFF 41)) -1))
      (MULTIPLE-VALUE-SETQ (NIL X Y) (%CONTENTS SEG (+ OFF 15)))
      (FORMAT *STANDARD-OUTPUT* "~%   Its resumer is: ~S."
         (%UNPOINTER Y X))
      (MULTIPLE-VALUE-SETQ (NIL X) (%CONTENTS SEG (+ 1 OFF)))
      (MULTIPLE-VALUE-SETQ (NIL Y) (%CONTENTS SEG (+ 3 OFF)))
      (FORMAT *STANDARD-OUTPUT* "~%   Its stack size is: ~U. bytes."
         (- X Y))
      (MULTIPLE-VALUE-SETQ (NIL X) (%CONTENTS SEG (+ 5 OFF)))
      (MULTIPLE-VALUE-SETQ (NIL Y) (%CONTENTS SEG (+ 7 OFF)))
      (FORMAT *STANDARD-OUTPUT*
         "~%   Its special stack size is: ~U. bytes." (- X Y))
      (MULTIPLE-VALUE-SETQ (NIL X) (%CONTENTS SEG (+ 42 OFF)))
      (FORMAT *STANDARD-OUTPUT*
         "~%   It contains ~D. dynamic variable bindings."
          (DO ((I 0 (1+ I))
               (X (+ OFF 44)))
              (())
            (SETF (VALUES NIL X)(%CONTENTS SEG X))
            (WHEN (ZEROP X) (RETURN I))))
      (FORMAT *STANDARD-OUTPUT*
         "~%   Its special stack pointer is: #x~X." X)
      ;; following is not valid if we are describing the current SG
      (UNLESS (EQ OBJ *CURRENT-STACK-GROUP*)
        (MULTIPLE-VALUE-SETQ (NIL X) (%CONTENTS SEG (+ 39 OFF)))
        (FORMAT *STANDARD-OUTPUT* "~%   Its stack pointer is: #x~X." X)
        (MULTIPLE-VALUE-SETQ (NIL X Y) (%CONTENTS SEG (+ OFF 31)))
        (FORMAT *STANDARD-OUTPUT* "~%   Its program counter is: ~X:~X."
           Y X)
        (MULTIPLE-VALUE-SETQ (NIL X) (%CONTENTS SEG (+ 35 OFF)))
        (FORMAT *STANDARD-OUTPUT* "~%   Its frame pointer is: #x~X." X)
      )))
     )
    (OTHERWISE
      (COND ((ARRAYP OBJ)
         (FORMAT *STANDARD-OUTPUT*
            "~S is a ~:[vector~;string~] of length ~D."
            OBJ (STRINGP OBJ) (ARRAY-LENGTH OBJ))
         (WHEN (ARRAY-HAS-LEADER-P OBJ)
           (FORMAT *STANDARD-OUTPUT*
              "~%   It has an array leader with the contents:")
           (DOTIMES (I (ARRAY-LEADER-LENGTH OBJ))
             (FORMAT *STANDARD-OUTPUT* "~%    ~D : ~S"
            I (ARRAY-LEADER OBJ I))))
         (WHEN (AND (NOT (STRINGP OBJ)) (PLUSP (LENGTH OBJ)))
           (FORMAT *STANDARD-OUTPUT* "~&   Its elements are:")
           (DOTIMES (I (LENGTH OBJ))
             (FORMAT *STANDARD-OUTPUT* "~&    ~D : ~S" I (AREF OBJ I)))))
        ((NAMED-STRUCTURE-P OBJ)
         (FORMAT *STANDARD-OUTPUT* "~S is a Named Structure of type ~S."
           OBJ (TYPE-OF OBJ))
         (FORMAT *STANDARD-OUTPUT* "~%   Its slot names and values are:")
         (LET* ((DESCR (GET (TYPE-OF OBJ) 'STRUCTURE-DESCRIPTOR))
            (CONC-NAME (ASSOC 'CONC-NAME (CADDR DESCR))))
        (SETQ CONC-NAME (COND ((NULL CONC-NAME)
                       (STRING-APPEND (TYPE-OF OBJ) #\-))
                      ((SECOND CONC-NAME))
                      (T "")))
            (DOLIST (X (CAR DESCR))
              (FORMAT *STANDARD-OUTPUT* "~&    Name: ~S, Value: ~S"
            (CAR X) (EVAL `(,(INTERN (STRING-APPEND CONC-NAME
                                (CAR X)))
                    ',OBJ)))
        ))
         )))
    )
  (TERPRI *STANDARD-OUTPUT*)
  (VALUES NIL))