X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/34c51b1c9911d604386f0dc77336ad52ea81c68e..1c1a9bf16b17e504b000c30b4653e34ddc6845d1:/doc/list-exports.lisp diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp index fd02f00..eab4d54 100644 --- a/doc/list-exports.lisp +++ b/doc/list-exports.lisp @@ -1,3 +1,8 @@ +(cl:defpackage #:sod-exports + (:use #:common-lisp)) + +(cl:in-package #:sod-exports) + (defun symbolicate (&rest things) (intern (apply #'concatenate 'string (mapcar #'string things)))) @@ -9,7 +14,7 @@ (declare (ignore head tail)) nil)) -(defmethod form-list-exports ((head (eql 'export)) tail) +(defmethod form-list-exports ((head (eql 'cl:export)) tail) (let ((symbols (car tail))) (if (and (consp symbols) (eq (car symbols) 'quote)) @@ -17,7 +22,7 @@ (if (atom thing) (list thing) thing)) (incomprehensible-form head tail)))) -(defmethod form-list-exports ((head (eql 'definst)) tail) +(defmethod form-list-exports ((head (eql 'sod:definst)) tail) (destructuring-bind (code (streamvar &key export) args &body body) tail (declare (ignore streamvar body)) (and export @@ -27,20 +32,20 @@ (symbolicate 'inst- arg)) args))))) -(defmethod form-list-exports ((head (eql 'define-tagged-type)) tail) +(defmethod form-list-exports ((head (eql 'sod::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) +(defmethod form-list-exports ((head (eql 'cl:macrolet)) tail) (mapcan #'form-exports (cdr tail))) -(defmethod form-list-exports ((head (eql 'eval-when)) tail) +(defmethod form-list-exports ((head (eql 'cl:eval-when)) tail) (mapcan #'form-exports (cdr tail))) -(defmethod form-list-exports ((head (eql 'progn)) tail) +(defmethod form-list-exports ((head (eql 'cl:progn)) tail) (mapcan #'form-exports tail)) (defgeneric form-exports (form) @@ -69,7 +74,8 @@ (defun find-symbol-homes (paths package) (let* ((symbols (list-exported-symbols package)) - (exports-alist (mapcan #'list-exports paths)) + (exports-alist (let ((*package* package)) + (mapcan #'list-exports paths))) (homes (make-hash-table :test #'equal))) (dolist (assoc exports-alist) (let ((home (car assoc))) @@ -123,19 +129,25 @@ (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)) + (when (get symbol 'optparse::opthandler) + (push :opthandler things)) + (when (get symbol 'optparse::optmacro) + (push :optmacro 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))) + (symbols (delete-duplicates + (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)))) @@ -149,12 +161,22 @@ (defvar charbuf-size 0) +(defun exported-symbol-p (symbol &optional (package (symbol-package symbol))) + (and package + (multiple-value-bind (sym how) + (find-symbol (symbol-name symbol) package) + (and (eq sym symbol) + (eq how :external))))) + (defun pretty-symbol-name (symbol package) - (let* ((pkg (symbol-package symbol)) - (exportp (member symbol (list-exported-symbols pkg)))) + (let ((pkg (symbol-package symbol)) + (exportp (exported-symbol-p symbol))) (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)" - (and exportp (eq pkg package)) (best-package-name pkg) - exportp (symbol-name symbol)))) + (and exportp (eq pkg package)) + (cond ((keywordp symbol) "") + ((eq pkg nil) "#") + (t (best-package-name pkg))) + (or exportp (null pkg)) (symbol-name symbol)))) (defun analyse-classes (package) (setf package (find-package package)) @@ -189,12 +211,178 @@ (walk-down sub this (1+ depth))))) (walk-down (find-class t) nil 0)))) +(defmacro deep-compare ((left right) &body body) + (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-")) + (l (gensym "LEFT-")) (r (gensym "RIGHT-"))) + `(macrolet ((focus (expr &body body) + `(flet ((,',func (it) ,expr)) + (let ((,',l (,',func ,',l)) + (,',r (,',func ,',r))) + ,@body))) + (update (expr) + `(flet ((,',func (it) ,expr)) + (psetf ,',l (,',func ,',l) + ,',r (,',func ,',r)))) + (compare (expr) + `(cond ((let ((left ,',l) (right ,',r)) ,expr) + (return-from ,',block t)) + ((let ((right ,',l) (left ,',r)) ,expr) + (return-from ,',block nil)))) + (typesw (&rest clauses) + (labels ((iter (clauses) + (if (null clauses) + 'nil + (destructuring-bind (type &rest body) + (car clauses) + (if (eq type t) + `(progn ,@body) + `(if (typep ,',l ',type) + (if (typep ,',r ',type) + (progn ,@body) + (return-from ,',block t)) + (if (typep ,',r ',type) + (return-from ,',block nil) + ,(iter (cdr clauses))))))))) + (iter clauses)))) + (let ((,l ,left) (,r ,right)) + (block ,block + ,@body))))) + +(defun order-specializers (la lb) + (deep-compare (la lb) + (loop (typesw (null (return nil))) + (focus (car it) + (typesw (sb-mop:eql-specializer + (focus (sb-mop:eql-specializer-object it) + (typesw (keyword + (compare (string< left right))) + (symbol + (focus (package-name (symbol-package it)) + (compare (string< left right))) + (compare (string< left right))) + (t + (focus (with-output-to-string (out) + (prin1 it out) + (write-char #\nul)) + (compare (string< left right))))))) + (class + (focus (class-name it) + (focus (package-name (symbol-package it)) + (compare (string< left right))) + (compare (string< left right)))) + (t + (error "unexpected things")))) + (update (cdr it))))) + +(defun analyse-generic-functions (package) + (setf package (find-package package)) + (flet ((function-name-core (name) + (etypecase name + (symbol name) + ((cons (eql setf) t) (cadr name))))) + (let ((methods (make-hash-table)) + (functions (make-hash-table)) + (externs (make-hash-table))) + (dolist (symbol (list-exported-symbols package)) + (setf (gethash symbol externs) t)) + (dolist (symbol (list-exported-symbols package)) + (flet ((dofunc (func) + (when (typep func 'generic-function) + (setf (gethash func functions) t) + (dolist (method (sb-mop:generic-function-methods func)) + (setf (gethash method methods) t))))) + (dofunc (and (fboundp symbol) (fdefinition symbol))) + (dofunc (ignore-errors (fdefinition (list 'setf symbol))))) + (when (eq (symbol-package symbol) package) + (let ((class (find-class symbol nil))) + (when class + (dolist + (func (sb-mop:specializer-direct-generic-functions class)) + (let ((name (function-name-core + (sb-mop:generic-function-name func)))) + (when (or (not (eq (symbol-package name) package)) + (gethash name externs)) + (setf (gethash func functions) t) + (dolist (method (sb-mop:specializer-direct-methods class)) + (setf (gethash method methods) t))))))))) + (let ((funclist nil)) + (maphash (lambda (func value) + (declare (ignore value)) + (push func funclist)) + functions) + (setf funclist (sort funclist + (lambda (a b) + (let ((core-a (function-name-core a)) + (core-b (function-name-core b))) + (if (eq core-a core-b) + (and (atom a) (consp b)) + (string< core-a core-b)))) + :key #'sb-mop:generic-function-name)) + (dolist (function funclist) + (let ((name (sb-mop:generic-function-name function))) + (etypecase name + (symbol + (format t "~A~%" (pretty-symbol-name name package))) + ((cons (eql setf) t) + (format t "(setf ~A)~%" + (pretty-symbol-name (cadr name) package))))) + (dolist (method (sort (copy-list + (sb-mop:generic-function-methods function)) + #'order-specializers + :key #'sb-mop:method-specializers)) + (when (gethash method methods) + (format t "~2T~{~A~^ ~}~%" + (mapcar + (lambda (spec) + (etypecase spec + (class + (let ((name (class-name spec))) + (if (eq name t) "t" + (pretty-symbol-name name package)))) + (sb-mop:eql-specializer + (let ((obj (sb-mop:eql-specializer-object spec))) + (format nil "(eql ~A)" + (if (symbolp obj) + (pretty-symbol-name obj package) + obj)))))) + (sb-mop:method-specializers method)))))))))) + +(defun check-slot-names (package) + (setf package (find-package package)) + (let* ((symbols (list-exported-symbols package)) + (classes (mapcan (lambda (symbol) + (when (eq (symbol-package symbol) package) + (let ((class (find-class symbol nil))) + (and class (list class))))) + symbols)) + (offenders (mapcan + (lambda (class) + (let* ((slot-names + (mapcar #'sb-mop:slot-definition-name + (sb-mop:class-direct-slots class))) + (exported (remove-if + (lambda (sym) + (and (not (exported-symbol-p sym)) + (eq (symbol-package sym) + package))) + slot-names))) + (and exported + (list (cons (class-name class) + exported))))) + classes)) + (bad-words (remove-duplicates (mapcan (lambda (list) + (copy-list (cdr list))) + offenders)))) + (values offenders bad-words))) + (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)) + (dolist (assoc (sort (categorize-symbols paths package) #'string< + :key (lambda (assoc) + (file-namestring (car assoc))))) (when (cdr assoc) (format t "~A~%" (file-namestring (car assoc))) (dolist (def (cdr assoc)) @@ -203,15 +391,31 @@ (pretty-symbol-name sym package) (cdr def)))) (terpri))) + (multiple-value-bind (alist names) (check-slot-names package) + (when names + (format t "Leaked slot names: ~{~A~^, ~}~%" + (mapcar (lambda (name) (pretty-symbol-name name package)) + names)) + (dolist (assoc alist) + (format t "~2T~A: ~{~A~^, ~}~%" + (pretty-symbol-name (car assoc) package) + (mapcar (lambda (name) (pretty-symbol-name name package)) + (cdr assoc)))) + (terpri))) + (format t "Classes:~%") (analyse-classes package) + (terpri) + (format t "Methods:~%") + (analyse-generic-functions package) (terpri)) +(export 'report-project-symbols) (defun report-project-symbols () (labels ((components (comp) (slot-value comp 'asdf::components)) (files (comp) (sort (remove-if-not (lambda (comp) - (typep comp 'asdf:cl-source-file)) + (typep comp 'asdf:cl-source-file)) (components comp)) #'string< :key #'asdf:component-name)) (by-name (comp name) @@ -222,7 +426,17 @@ (let* ((sod (asdf:find-system "sod")) (parser-files (files (by-name sod "parser"))) (utilities (by-name sod "utilities")) - (sod-files (remove utilities (files sod)))) + (sod-frontend (asdf:find-system "sod-frontend")) + (optparse (by-name sod-frontend "optparse")) + (frontend (by-name sod-frontend "frontend")) + (sod-files (set-difference (files sod) (list utilities)))) (report-symbols (mapcar #'file-name sod-files) "SOD") + (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND") (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER") + (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE") (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES")))) + +#+interactive +(with-open-file (*standard-output* #p"doc/SYMBOLS" :direction :output + :if-exists :supersede :if-does-not-exist :create) + (report-project-symbols))