Coverage report: /home/ellis/comp/core/lib/doc/symbol.lisp

KindCoveredAll%
expression97200 48.5
branch2750 54.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; lib/doc/symbol.lisp --- Symbol Documentation
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :doc)
7
 
8
 (defmacro do-symbols* ((var &optional (package '*package*) result-form)
9
                        &body body)
10
   "Just like do-symbols, but makes sure a symbol is visited only once."
11
   (let ((seen-ht (gensym "SEEN-HT")))
12
     `(let ((,seen-ht (make-hash-table :test #'eq)))
13
        (do-symbols (,var ,package ,result-form)
14
          (unless (gethash ,var ,seen-ht)
15
            (setf (gethash ,var ,seen-ht) t)
16
            (tagbody ,@body))))))
17
 
18
 #|
19
 (Public)
20
 :CLASS
21
 :COMPILER-MACRO
22
 :CONDITION
23
 :CONSTANT
24
 :FUNCTION
25
 :GENERIC-FUNCTION
26
 :MACRO
27
 :METHOD
28
 :METHOD-COMBINATION
29
 :PACKAGE
30
 :SETF-EXPANDER
31
 :STRUCTURE
32
 :SYMBOL-MACRO
33
 :TYPE
34
 :ALIEN-TYPE
35
 :VARIABLE
36
 :DECLARATION
37
 
38
 (Internal)
39
 :OPTIMIZER
40
 :SOURCE-TRANSFORM
41
 :TRANSFORM
42
 :VOP
43
 :IR1-CONVERT
44
 |#
45
 (defun classify-symbol (symbol)
46
   "Returns a list of classifiers that classify SYMBOL according to its
47
 underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
48
 variable.) The list may contain the following classification
49
 keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
50
 :TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
51
   (check-type symbol symbol)
52
   (flet ((type-specifier-p (s)
53
            (or (documentation s 'type)
54
                (not (eq (deftype-lambda-list s) :not-available)))))
55
     (let (result)
56
       (when (boundp symbol)             (push (if (constantp symbol)
57
                                                   :constant :boundp) result))
58
       (when (fboundp symbol)            (push :function result))
59
       (when (type-specifier-p symbol)   (push :type result))
60
       (when (find-class symbol nil)     (push :class result))
61
       (when (typep symbol 'condition) (push :condition result))
62
       (when (typep symbol 'structure-class) (push :structure result))
63
       (when (alien-type-p symbol) (push :alien-type result))
64
       (when (vop-p symbol) (push :vop result))
65
       (when (macro-function symbol)     (push :macro result))
66
       (when (special-operator-p symbol) (push :special-operator result))
67
       (when (find-package symbol)       (push :package result))
68
       (when (compiler-macro-function symbol) (push :compiler-macro result))
69
       (when (compiled-function-p symbol) (push :compiled result))
70
       (when (and (fboundp symbol)
71
                  (typep (ignore-errors (fdefinition symbol))
72
                         'generic-function))
73
         (push :generic-function result))
74
       result)))
75
 
76
 (defun symbol-classification-string (symbol)
77
   "Return a string in the form -f-c---- where each letter stands for
78
 boundp fboundp generic-function class macro special-operator package"
79
   (let ((letters "bfgctmsp")
80
         (result (copy-seq "--------")))
81
     (flet ((flip (letter)
82
              (setf (char result (position letter letters))
83
                    letter)))
84
       (when (boundp symbol) (flip #\b))
85
       (when (fboundp symbol)
86
         (flip #\f)
87
         (when (typep (ignore-errors (fdefinition symbol))
88
                      'generic-function)
89
           (flip #\g)))
90
       (when (deftype-lambda-list symbol) (flip #\t))
91
       (when (find-class symbol nil)   (flip #\c) )
92
       (when (macro-function symbol)   (flip #\m))
93
       (when (special-operator-p symbol) (flip #\s))
94
       (when (find-package symbol)       (flip #\p))
95
       result)))
96
 
97
 (defclass symbol-documentation (id) ;; package-id? (sb-c::symbol-package-id s)
98
   ((symbol :initarg :symbol :type symbol :accessor doc-symbol)
99
    (class :initarg :class :type list :accessor doc-class)
100
    (definitions :initform nil :initarg :definitions :type list :accessor doc-definitions)
101
    (specs :initform nil :initarg :specs :type list :accessor doc-specs)
102
    (info :initarg :info :type (or null packed-info) :accessor doc-info)
103
    (alloc :initarg :alloc :type list :accessor doc-alloc)))
104
 
105
 (defmethod name ((self symbol-documentation))
106
   (symbol-name (doc-symbol self)))
107
 
108
 #|
109
 (setq *defs* 
110
  (loop for x across (doc-symbols (package-documentation)) collect (doc-definitions x)))
111
 
112
 |#
113
 
114
 (defun symbol-documentation (s)
115
   "Return the SYMBOL-DOCUMENTATION object of S, a symbol."
116
   (let ((class (classify-symbol s)))
117
     (multiple-value-bind (defs specs) (find-definitions s)
118
       (make-instance 'symbol-documentation
119
         :id (symbol-hash s)
120
         :symbol s
121
         :class class
122
         :definitions defs
123
         :specs specs
124
         :info (symbol-dbinfo s)
125
         :alloc (multiple-value-list (allocation-information s))))))
126
 
127
 (defmethod print-object ((self symbol-documentation) stream)
128
   (with-slots (symbol class) self
129
     (print-unreadable-object (self stream :type t)
130
       (format stream "~S ~A"  symbol class))))
131
 
132
 (defmethod doc-files ((self symbol-documentation))
133
    (remove-duplicates
134
     (remove-if
135
      #'null ;; definition-source-pathname is allowed to be nil,
136
             ;; indicating no path to definition.
137
     (mapcar #'definition-source-pathname (doc-definitions self)))))
138
 
139
 (defmethod describe-object ((self symbol-documentation) stream)
140
   (with-slots (symbol id definitions specs alloc) self
141
     (print-standard-describe-header self stream)
142
     (describe symbol stream)
143
     (format stream "~%Alloc Info: ~S" alloc)
144
     (format stream "~%Definitions: ~%")
145
     (loop for s in specs
146
           do (format stream "  ~S ~S~%" s (definition-source-pathname (pop definitions))))))