Google
 

Trailing-Edge - PDP-10 Archives - clisp - clisp/flavors/upsala/desc.lap
There are no other files named desc.lap in the archive.
;;; CLC v1.5 compiling SS:<VICTOR.FLAVORS>DESC.CLISP.4

(in-package (quote user::lisp)) 
(export (quote (describe defdescribe))) 

#_(lap #0_concat-pnames expr
       (entry-points (2-few 2-few 1 2 2-many 2-many 2-many))
       #0_(*package*)
       (code-start)
(label 1)    (move o3 (special 0))
(label 2)    (adjsp q 6)
             (movem o1 -5 q)
             (movem o2 -4 q)
             (movem o3 -3 q)
             (skipn nil -5 q)
             (jrst 4)
             (move o1 -5 q)
             (call symbol-name 1)
             (movem o1 -2 q)
             (move o1 -4 q)
             (call symbol-name 1)
             (move o2 o1)
             (move o1 -2 q)
             (call lisp::string-concatenate 2)
             (movem o1 -2 q)
             (move o2 -3 q)
             (move o1 -2 q)
             (call intern 2)
             (jrst 5)
(label 4)    (move o1 -4 q)
             (movei n 1)
(label 5)    (adjsp q -6)
             (popj p)
)

(%put (quote concat-pnames) (quote %args-documentation) (quote (name1 name2 &optional (package *package*)))) 
(%put (quote concat-pnames) (quote %source-documentation) (quote "SS:<VICTOR.FLAVORS>DESC.CLISP.4")) 
(%put (quote describe) (quote %fun-documentation) (quote "Prints a description of the object")) 

#_(lap #0_describe expr
       (entry-points (2-few 1 2-many 2-many 2-many 2-many 2-many))
       #0_(structure array internal-describe- *lisp-package* " is a " *standard-output* 0 ".")
       (code-start)
(label 1)    (adjsp q 8)
             (movem o1 -7 q)
             (move o1 -7 q)
             (call type-of 1)
             (call symbolp 1)
             (jumpe o1 4)
             (move o1 -7 q)
             (call type-of 1)
             (movem o1 -6 q)
             (jrst 3)
(label 4)    (move o1 -7 q)
             (call structurep 1)
             (jumpe o1 5)
             (move o6 (constant 0))
             (movem o6 -6 q)
             (jrst 3)
(label 5)    (move o1 -7 q)
             (call arrayp 1)
             (jumpe o1 6)
             (move o6 (constant 1))
             (movem o6 -6 q)
             (jrst 3)
(label 6)    (move o1 -7 q)
             (call type-of 1)
             (movem o1 -6 q)
(label 3)    (move o3 (special 3))
             (move o1 (constant 2))
             (move o2 -6 q)
             (call lisp::concat-pnames 3)
             (movem o1 -5 q)
             (move o1 -5 q)
             (call fboundp 1)
             (jumpe o1 9)
             (move o2 -7 q)
             (move o1 -5 q)
             (call funcall 2)
             (jrst 10)
(label 9)    (call fresh-line 0)
             (move o1 -7 q)
             (call prin1 1)
             (move o6 (special 5))
             (movem o6 -3 q)
             (move o4 nil)
             (move o1 (constant 4))
             (move o2 -3 q)
             (move o3 (constant 6))
             (call lisp::%sp-write-string 4)
             (move o1 -7 q)
             (call type-of 1)
             (call prin1 1)
             (move o6 (special 5))
             (movem o6 -3 q)
             (move o4 nil)
             (move o1 (constant 7))
             (move o2 -3 q)
             (move o3 (constant 6))
             (call lisp::%sp-write-string 4)
(label 10)   (setzb o1 n)
             (adjsp q -8)
             (popj p)
)

(%put (quote describe) (quote %args-documentation) (quote (object))) 
(%put (quote describe) (quote %source-documentation) (quote "SS:<VICTOR.FLAVORS>DESC.CLISP.4")) 

#_(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 "SS:<VICTOR.FLAVORS>DESC.CLISP.4")) 
(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))) (if (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))) (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:")) (let ((*print-level* 3) (*print-length* 5)) (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~; ~s~; ~s and ~s~
			   ~:;~@{~#[~; 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)))))))