Trailing-Edge
-
PDP-10 Archives
-
clisp
-
clisp/upsala/describe.lap
There are no other files named describe.lap in the archive.
;;; CLC v1.5 compiling AIDA::SS:<CLISP.UPSALA>DESCRIBE.CLISP.1
(IN-PACKAGE (QUOTE LISP))
(EXPORT (QUOTE (DESCRIBE DEFDESCRIBE)))
(DEFUN CONCAT-PNAMES (NAME1 NAME2 &OPTIONAL (PACKAGE *PACKAGE*)) (IF NAME1 (INTERN (STRING-CONCATENATE (SYMBOL-NAME NAME1) (SYMBOL-NAME NAME2)) PACKAGE) NAME2))
(DEFUN DESCRIBE (OBJECT) "Prints a description of the object" (LET* ((TYPE (COND ((SYMBOLP (TYPE-OF OBJECT)) (TYPE-OF OBJECT)) ((STRUCTUREP OBJECT) (QUOTE STRUCTURE)) ((ARRAYP OBJECT) (QUOTE ARRAY)) (T (TYPE-OF OBJECT)))) (FUN (CONCAT-PNAMES (QUOTE INTERNAL-DESCRIBE-) TYPE *LISP-PACKAGE*))) (IF (FBOUNDP FUN) (FUNCALL FUN OBJECT) (FORMAT T "~&~S is a ~s." OBJECT (TYPE-OF OBJECT)))) (VALUES))
#_(LAP #0_DEFDESCRIBE MACRO
(ENTRY-POINTS (2-FEW 1 2-MANY 2-MANY 2-MANY 2-MANY 2-MANY))
#0_(4 "Macro ~S cannot be called with ~S args." DEFDESCRIBE SETF SYMBOL-FUNCTION CONCAT-PNAMES (QUOTE INTERNAL-DESCRIBE-) QUOTE (*LISP-PACKAGE*) FUNCTION LAMBDA)
(CODE-START)
(LABEL 1) (ADJSP Q 12)
(MOVEM O1 -11 Q)
(MOVE O1 -11 Q)
(CALL LENGTH 1)
(MOVEM O1 -10 Q)
(MOVE O2 (CONSTANT 0))
(MOVE O1 -10 Q)
(CALL < 2)
(JUMPE O1 4)
(MOVE O1 -11 Q)
(CALL LENGTH 1)
(CALL 1- 1)
(MOVE O3 O1)
(MOVE O1 (CONSTANT 1))
(MOVE O2 (CONSTANT 2))
(CALL ERROR 3)
(JRST 3)
(LABEL 4) (MOVE O1 -11 Q)
(MOVE O1 1 O1)
(MOVE O1 0 O1)
(MOVEM O1 -10 Q)
(MOVE O1 -11 Q)
(MOVE O1 1 O1)
(MOVE O1 1 O1)
(MOVE O1 0 O1)
(MOVEM O1 -9 Q)
(MOVE O1 -11 Q)
(MOVE O1 1 O1)
(MOVE O1 1 O1)
(MOVE O1 1 O1)
(MOVE O1 0 O1)
(MOVEM O1 -8 Q)
(MOVE O1 -11 Q)
(MOVE O1 1 O1)
(MOVE O1 1 O1)
(MOVE O1 1 O1)
(MOVE O1 1 O1)
(MOVEM O1 -7 Q)
(MOVE O2 -9 Q)
(MOVE O1 (CONSTANT 7))
(CALL LIST 2)
(MOVEM O1 -2 Q)
(MOVE O4 (CONSTANT 8))
(MOVE O1 (CONSTANT 5))
(MOVE O2 (CONSTANT 6))
(MOVE O3 -2 Q)
(CALL LIST* 4)
(MOVE O2 O1)
(MOVE O1 (CONSTANT 4))
(CALL LIST 2)
(MOVEM O1 -5 Q)
(MOVE O3 -7 Q)
(MOVE O1 (CONSTANT 10))
(MOVE O2 -8 Q)
(CALL LIST* 3)
(MOVE O2 O1)
(MOVE O1 (CONSTANT 9))
(CALL LIST 2)
(MOVE O3 O1)
(MOVE O1 (CONSTANT 3))
(MOVE O2 -5 Q)
(CALL LIST 3)
(LABEL 3) (ADJSP Q -12)
(POPJ P)
)
(%PUT (QUOTE DEFDESCRIBE) (QUOTE %ARGS-DOCUMENTATION) (QUOTE (**MACROARG**)))
(%PUT (QUOTE DEFDESCRIBE) (QUOTE %SOURCE-DOCUMENTATION) (QUOTE "AIDA::SS:<CLISP.UPSALA>DESCRIBE.CLISP.1"))
(DEFDESCRIBE X SYMBOL (X) (LET ((PACK (SYMBOL-PACKAGE X)) (NAME (SYMBOL-NAME X))) (FORMAT T "~&~@(~S~) is an ~@(~a~) Symbol in the ~a package." X (SYMBOL-NAME (MULTIPLE-VALUE-BIND (FOO BAR) (FIND-SYMBOL NAME PACK) BAR)) (PACKAGE-NAME PACK))) (IF (BOUNDP X) (LET ((*PRINT-LEVEL* 3) (*PRINT-LENGTH* 5)) (FORMAT T "~%Its value is ~S." (SYMBOL-VALUE X)))) (DESC-DOC X (QUOTE VARIABLE) "Documentation on the variable:") (IF (FBOUNDP X) (LET ((FUNCTION (SYMBOL-FUNCTION X)) (*PACKAGE* (SYMBOL-PACKAGE X))) (COND ((AND (LISTP FUNCTION) (EQ (CAR FUNCTION) (QUOTE MACRO))) (FORMAT T "~%It can be called as a macro ~
in the following way:~% ~S" (CONS X (DESC-ARGLIST X)))) ((SPECIAL-FORM-P X) (FORMAT T "~%It can be called as a special form ~
in the following way:~% ~S" (CONS X (DESC-ARGLIST X)))) (T (FORMAT T "~%It can be called as a function ~
in the following way:~% ~S" (CONS X (DESC-ARGLIST X))))))) (DESC-DOC X (QUOTE FUNCTION) "Documentation on the function:") (DESC-DOC X (QUOTE STRUCTURE) "Documentation on the structure:") (DESC-DOC X (QUOTE TYPE) "Documentation on the type:") (DESC-DOC X (QUOTE SETF) "Documentation on the SETF form:") (IF (COMPILEDP X) (DESC-DOC X (QUOTE SOURCE) "It was defined in the file:")) (DO ((PLIST (SYMBOL-PLIST X) (CDDR PLIST))) ((NULL PLIST) NIL) (UNLESS (MEMBER (CAR PLIST) *IMPLEMENTATION-PROPERTIES*) (FORMAT T "~%Its ~S property is ~S." (CAR PLIST) (CADR PLIST)))))
(DEFDESCRIBE X HASH-TABLE (X) (FORMAT T "~&~S is a Hash-table." X) (FORMAT T "~%It currently has ~S entries and ~S buckets." (HASH-TABLE-COUNT X) (HASH-TABLE-SIZE X)))
(DEFDESCRIBE X ARRAY (X) (FORMAT T "~&~S is an Array (~(~s~))." X (CAR (TYPE-OF X))) (LET ((TYPE (ARRAY-ELEMENT-TYPE X)) (RANK (ARRAY-RANK X)) (DIMS (ARRAY-DIMENSIONS X)) (TSIZE (ARRAY-TOTAL-SIZE X)) (ADJP (ADJUSTABLE-ARRAY-P X))) (FORMAT T "~%It has type ~a, and is ~@[not ~]adjustable." TYPE (NOT ADJP)) (FORMAT T "~%Is has rank ~d, and dimensions ~s." RANK DIMS)))
(DEFDESCRIBE X PACKAGE (X) (FORMAT T "~&~S is a Package." X) (FORMAT T "~%The name of this package is ~a." (PACKAGE-NAME X)) (LET ((NICKNAMES (PACKAGE-NICKNAMES X)) (USELIST (PACKAGE-USE-LIST X)) (USEDLIST (PACKAGE-USED-BY-LIST X)) (SHADOWING (PACKAGE-SHADOWING-SYMBOLS X))) (IF NICKNAMES (APPLY (FUNCTION FORMAT) T "~%It has nickname~p~#[ none~; ~a~; ~a and ~a~:;~
~@{~#[~; and~] ~a~^,~}~]." (LENGTH NICKNAMES) NICKNAMES)) (IF USELIST (APPLY (FUNCTION FORMAT) T "~%It uses package~p~#[ none~; ~a~; ~a and ~a~:;~
~@{~#[~; and~] ~a~^,~}~]." (LENGTH USELIST) (MAPCAR (FUNCTION PACKAGE-NAME) USELIST))) (IF USEDLIST (APPLY (FUNCTION FORMAT) T "~%Is is used by package~p~#[ none~; ~a~; ~a and ~a~
~:;~@{~#[~; and~] ~a~^,~}~]." (LENGTH USEDLIST) (MAPCAR (FUNCTION PACKAGE-NAME) USEDLIST))) (IF SHADOWING (FORMAT T "~%It has ~d shadowing symbol~:p." (LENGTH SHADOWING)))))
(DEFDESCRIBE X STREAM (X) (FORMAT T "~&~S is a Stream." X) (LET ((OUTP (OUTPUT-STREAM-P X)) (INP (INPUT-STREAM-P X))) (COND ((OR INP OUTP) (LET ((TYPE (STREAM-ELEMENT-TYPE X))) (IF (AND INP OUTP) (FORMAT T "~%It can be used for both input and output.") (IF INP (FORMAT T "~%It can be used for input only.")) (IF OUTP (FORMAT T "~%It can be used for output only."))) (FORMAT T "~%It is of type ~a." TYPE))) (T (FORMAT T "~%It can not be used for in- or output.")))))
(DEFDESCRIBE X STRUCTURE (X) (LET ((TYPE-OF (TYPE-OF X)) (PRINTER (GET (TYPE-OF X) (QUOTE STRUCTURE-PRINT)))) (FORMAT T "~S~%~2,tis a structure of type ~a." X TYPE-OF) (WHEN PRINTER (FORMAT T "~%It prints like:~%") (FUNCALL PRINTER X *STANDARD-OUTPUT* 0)) (DESC-DOC TYPE-OF (QUOTE STRUCTURE) "Documentation on the structure:") (LET ((INFO (GET TYPE-OF (QUOTE DEFSTRUCT-DESCRIPTION)))) (IF INFO (LET ((NAME (DEFSTRUCT-DESCRIPTION-NAME INFO)) (TYPE (DEFSTRUCT-DESCRIPTION-TYPE INFO)) (OPTIONS (DEFSTRUCT-DESCRIPTION-OPTIONS INFO)) (SIZE (DEFSTRUCT-DESCRIPTION-SIZE INFO)) (CONC-NAME (DEFSTRUCT-DESCRIPTION-CONC-NAME INFO)) (CONSTRUCTOR (DEFSTRUCT-DESCRIPTION-CONSTRUCTOR INFO)) (SLOT-NAMES (DEFSTRUCT-DESCRIPTION-SLOT-NAMES INFO)) (SLOT-PURE-NAMES (DEFSTRUCT-DESCRIPTION-SLOT-PURE-NAMES INFO)) (SLOT-DEFAULTS (DEFSTRUCT-DESCRIPTION-SLOT-DEFAULTS INFO)) (SLOT-NUMBERS (DEFSTRUCT-DESCRIPTION-SLOT-NUMBERS INFO)) (SLOT-TYPES (DEFSTRUCT-DESCRIPTION-SLOT-TYPES INFO)) (SLOT-KEYWORDS (DEFSTRUCT-DESCRIPTION-SLOT-KEYWORDS INFO)) (SLOT-OPTIONS (DEFSTRUCT-DESCRIPTION-SLOT-OPTIONS INFO))) (IF NAME (FORMAT T "~%~@TIts name is ~a." NAME)) (IF TYPE (FORMAT T "~%~@tIts type is ~a." TYPE)) (IF OPTIONS (FORMAT T "~%~@tIts options are ~s." OPTIONS)) (FORMAT T "~%~@tIts size is ~d." SIZE) (FORMAT T "~%~@tIts conc-name is ~a." CONC-NAME) (FORMAT T "~%~@tIts conctructor is ~a." CONSTRUCTOR) (FORMAT T "~%~@tIts slot-names are~{ ~a~}." SLOT-NAMES) (IF (DELETE NIL SLOT-DEFAULTS) (FORMAT T "~%~@tIts slot-defaults are~{ ~a~}." SLOT-DEFAULTS)) (IF SLOT-TYPES (FORMAT T "~%~@tIts slot-types are~{ ~a~}." SLOT-TYPES)) (FORMAT T "~%~@tIts slot-keywords are~{ ~a~}." SLOT-KEYWORDS) (IF (DELETE NIL SLOT-OPTIONS) (FORMAT T "~%~@tIts slot-options are~{ ~a~}." SLOT-OPTIONS)))))))