--- /dev/null
+(defun symbolicate (&rest things)
+ (intern (apply #'concatenate 'string (mapcar #'string things))))
+
+(defun incomprehensible-form (head tail)
+ (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))
+
+(defgeneric form-list-exports (head tail)
+ (:method (head tail)
+ (declare (ignore head tail))
+ nil))
+
+(defmethod form-list-exports ((head (eql 'export)) tail)
+ (let ((symbols (car tail)))
+ (if (and (consp symbols)
+ (eq (car symbols) 'quote))
+ (let ((thing (cadr symbols)))
+ (if (atom thing) (list thing) thing))
+ (incomprehensible-form head tail))))
+
+(defmethod form-list-exports ((head (eql 'definst)) tail)
+ (destructuring-bind (code (streamvar &key export) args &body body) tail
+ (declare (ignore streamvar args body))
+ (and export
+ (list (symbolicate code '-inst)
+ (symbolicate 'make- code '-inst)))))
+
+(defmethod form-list-exports ((head (eql 'define-tagged-type)) tail)
+ (destructuring-bind (kind what) tail
+ (declare (ignore what))
+ (list kind
+ (symbolicate 'c- kind '-type)
+ (symbolicate 'make- kind '-type))))
+
+(defmethod form-list-exports ((head (eql 'macrolet)) tail)
+ (mapcan #'form-exports (cdr tail)))
+
+(defmethod form-list-exports ((head (eql 'progn)) tail)
+ (mapcan #'form-exports tail))
+
+(defgeneric form-exports (form)
+ (:method (form) nil)
+ (:method ((form cons)) (form-list-exports (car form) (cdr form))))
+
+(defgeneric list-exports (thing))
+
+(defmethod list-exports ((stream stream))
+ (loop with eof = '#:eof
+ for form = (read stream nil eof)
+ until (eq form eof)
+ when (consp form) nconc (form-exports form)))
+
+(defmethod list-exports ((path pathname))
+ (mapcar (lambda (each)
+ (cons each (with-open-file (stream each) (list-exports stream))))
+ (directory (merge-pathnames path #p"*.lisp"))))
+
+(defmethod list-exports ((path string))
+ (list-exports (pathname path)))
+
+(defun list-exported-symbols (package)
+ (sort (loop for s being the external-symbols of package collect s)
+ #'string< :key #'symbol-name))
+
+(defun find-symbol-homes (paths package)
+ (let* ((symbols (list-exported-symbols package))
+ (exports-alist (mapcan #'list-exports paths))
+ (homes (make-hash-table :test #'equal)))
+ (dolist (assoc exports-alist)
+ (let ((home (car assoc)))
+ (dolist (symbol (cdr assoc))
+ (let ((name (symbol-name symbol)))
+ (unless (find-symbol name package)
+ (format *error-output* ";; unexported: ~S~%" symbol))
+ (setf (gethash name homes) home)))))
+ (dolist (symbol symbols)
+ (unless (gethash (symbol-name symbol) homes)
+ (format *error-output* ";; mysterious: ~S~%" symbol)))
+ exports-alist))
+
+(defun boring-setf-expansion-p (symbol)
+ (multiple-value-bind (temps args stores store fetch)
+ (ignore-errors (get-setf-expansion (list symbol)))
+ (declare (ignore temps args stores fetch))
+ (and (consp store)
+ (eq (car store) 'funcall)
+ (consp (cdr store)) (consp (cadr store))
+ (eq (caadr store) 'function)
+ (let ((func (cadadr store)))
+ (and (consp func) (consp (cdr func))
+ (eq (car func) 'setf))))))
+
+(defun specialized-on-p (func arg what)
+ (some (lambda (method)
+ (let ((spec (nth arg (sb-mop:method-specializers method))))
+ (and (typep spec 'sb-mop:eql-specializer)
+ (eql (sb-mop:eql-specializer-object spec) what))))
+ (sb-mop:generic-function-methods func)))
+
+(defun categorize (symbol)
+ (let ((things nil))
+ (when (boundp symbol)
+ (push (if (constantp symbol) :constant :variable) things))
+ (when (fboundp symbol)
+ (push (cond ((macro-function symbol) :macro)
+ ((typep (fdefinition symbol) 'generic-function)
+ :generic)
+ (t :function))
+ things)
+ (when (or ;;(not (boring-setf-expansion-p symbol))
+ (ignore-errors (fdefinition (list 'setf symbol))))
+ (push :setf things)))
+ (when (find-class symbol nil)
+ (push :class things))
+ (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
+ (specialized-on-p #'sod:expand-c-type-form 0 symbol))
+ (push :c-type things))
+ (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
+ (specialized-on-p #'sod-parser:expand-parser-form 1 symbol))
+ (push :parser things))
+ (nreverse things)))
+
+(defun categorize-symbols (paths package)
+ (mapcar (lambda (assoc)
+ (let ((home (car assoc))
+ (symbols (sort (mapcan (lambda (sym)
+ (multiple-value-bind
+ (symbol foundp)
+ (find-symbol (symbol-name sym)
+ package)
+ (and foundp (list symbol))))
+ (cdr assoc))
+ #'string< :key #'symbol-name)))
+ (cons home (mapcar (lambda (symbol)
+ (cons symbol (categorize symbol)))
+ symbols))))
+
+ (mapcan #'list-exports paths)))
+
+(defun best-package-name (package)
+ (car (sort (cons (package-name package)
+ (copy-list (package-nicknames package)))
+ #'< :key #'length)))
+
+(defvar charbuf-size 0)
+
+(defun pretty-symbol-name (symbol package)
+ (let* ((pkg (symbol-package symbol))
+ (exportp (member symbol (list-exported-symbols pkg))))
+ (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)"
+ (and exportp (eq pkg package)) (best-package-name pkg)
+ exportp (symbol-name symbol))))
+
+(defun analyse-classes (package)
+ (setf package (find-package package))
+ (let ((classes (mapcan (lambda (symbol)
+ (let ((class (find-class symbol nil)))
+ (and class
+ (typep class '(or standard-class
+ structure-class))
+ (list class))))
+ (list-exported-symbols package)))
+ (subs (make-hash-table)))
+ (let ((done (make-hash-table)))
+ (labels ((walk-up (class)
+ (unless (gethash class done)
+ (dolist (super (sb-mop:class-direct-superclasses class))
+ (push class (gethash super subs))
+ (walk-up super))
+ (setf (gethash class done) t))))
+ (dolist (class classes)
+ (walk-up class))))
+ (labels ((walk-down (this super depth)
+ (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
+ (* 2 depth)
+ (pretty-symbol-name (class-name this) package)
+ (mapcar (lambda (class)
+ (pretty-symbol-name (class-name class)
+ package))
+ (remove super
+ (sb-mop:class-direct-superclasses this))))
+ (dolist (sub (reverse (gethash this subs)))
+ (walk-down sub this (1+ depth)))))
+ (walk-down (find-class t) nil 0))))
+
+(defun report-symbols (paths package)
+ (setf package (find-package package))
+ (format t "~A~%Package `~(~A~)'~2%"
+ (make-string 77 :initial-element #\-)
+ (package-name package))
+ (dolist (assoc (categorize-symbols paths package))
+ (when (cdr assoc)
+ (format t "~A~%" (file-namestring (car assoc)))
+ (dolist (def (cdr assoc))
+ (let ((sym (car def)))
+ (format t " ~A~@[~48T~{~(~A~)~^ ~}~]~%"
+ (pretty-symbol-name sym package)
+ (cdr def))))
+ (terpri)))
+ (analyse-classes package)
+ (terpri))
+
+(defun report-project-symbols ()
+ (labels ((components (comp)
+ (slot-value comp 'asdf::components))
+ (files (comp)
+ (remove-if-not (lambda (comp)
+ (typep comp 'asdf:cl-source-file))
+ (components comp)))
+ (by-name (comp name)
+ (find name (components comp)
+ :test #'string= :key #'asdf:component-name))
+ (file-name (file)
+ (slot-value file 'asdf::absolute-pathname)))
+ (let* ((sod (asdf:find-system "sod"))
+ (parser-files (files (by-name sod "parser")))
+ (utilities (by-name sod "utilities"))
+ (sod-files (remove utilities (files sod))))
+ (report-symbols (mapcar #'file-name sod-files) "SOD")
+ (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
+ (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))
~mdw / sod / commitdiff