[sod] / doc / list-exports.lisp

#! /bin/sh
":"; ### -*-lisp-*-
":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/:; export CL_SOURCE_REGISTRY
":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(sod-exports::main)" -- "$0" "$@" || exit 1

(cl:defpackage #:sod-exports
  (:use #:common-lisp
	#+cmu #:mop
	#+sbcl #:sb-mop))

(cl:in-package #:sod-exports)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (mapc #'asdf:load-system '(:sod :sod-frontend)))

(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 'cl: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 'sod:definst)) tail)
  (destructuring-bind (code (streamvar &key export) args &body body) tail
    (declare (ignore streamvar body))
    (and export
	 (list* (symbolicate code '-inst)
		(symbolicate 'make- code '-inst)
		(mapcan (lambda (arg)
			  (let ((sym (if (listp arg) (car arg) arg)))
			    (cond ((char= (char (symbol-name sym) 0) #\&)
				   nil)
				  (t
				   (list (symbolicate 'inst- sym))))))
			args)))))

(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 'sod:defctype)) tail)
  (destructuring-bind (names value &key export) tail
    (declare (ignore value))
    (let ((names (if (listp names) names (list names))))
      (and export
	   (list* (symbolicate 'c-type- (car names)) names)))))

(defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)
  (destructuring-bind (names type &key export) tail
    (declare (ignore type))
    (let ((names (if (listp names) names (list names))))
      (and export
	   (list* (symbolicate 'c-type- (car names)) names)))))

(defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)
  (mapcan #'form-exports (cdr tail)))

(defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
  (mapcan #'form-exports (cdr tail)))

(defmethod form-list-exports ((head (eql 'cl: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 (let ((*package* package))
			  (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 (nth-value 1 (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 (method-specializers method))))
	    (and (typep spec 'eql-specializer)
		 (eql (eql-specializer-object spec) what))))
	(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))
    (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 (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))))

	  (find-symbol-homes paths package)))

(defun best-package-name (package)
  (car (sort (cons (package-name package)
		   (copy-list (package-nicknames package)))
	     #'< :key #'length)))

(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 (exported-symbol-p symbol)))
    (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)"
	    (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))
  (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 (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
				       (class-direct-superclasses this))))
	       (dolist (sub (sort (copy-list (gethash this subs))
				  #'string< :key #'class-name))
		 (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 (eql-specializer
		     (focus (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)
	   (typecase name
	     (symbol (values name t))
	     ((cons (eql setf) t) (values (cadr name) t))
	     (t (values nil nil)))))
    (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 (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 (specializer-direct-generic-functions class))
		(multiple-value-bind (name knownp)
		    (function-name-core (generic-function-name func))
		  (when (and knownp
			     (or (not (eq (symbol-package name) package))
				 (gethash name externs)))
		    (setf (gethash func functions) t)
		    (dolist (method (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 #'generic-function-name))
	(dolist (function funclist)
	  (let ((name (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
				 (generic-function-methods function))
				#'order-specializers
				:key #'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))))
			   (eql-specializer
			    (let ((obj (eql-specializer-object spec)))
			      (format nil "(eql ~A)"
				      (if (symbolp obj)
					  (pretty-symbol-name obj package)
					  obj))))))
		       (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 #'slot-definition-name
				       (class-direct-slots class)))
			      (exported (remove-if
					 (lambda (sym)
					   (or (not (symbol-package 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 (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))
	(let ((sym (car def)))
	  (format t "  ~A~@[~48T~{~(~A~)~^ ~}~]~%"
		  (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)
	     (asdf:component-children comp))
	   (files (comp)
	     (sort (remove-if-not (lambda (comp)
				    (typep comp 'asdf:cl-source-file))
				  (components comp))
		   #'string< :key #'asdf:component-name))
	   (by-name (comp name)
	     (gethash name (asdf:component-children-by-name comp)))
	   (file-name (file)
	     (slot-value file 'asdf/component:absolute-pathname)))
  (let* ((sod (asdf:find-system "sod"))
	 (parser-files (files (by-name sod "parser")))
	 (utilities (by-name sod "utilities"))
	 (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"))))

(defun main ()
  (with-open-file (*standard-output* #p"doc/SYMBOLS"
		   :direction :output
		   :if-exists :supersede
		   :if-does-not-exist :create)
    (report-project-symbols)))

#+interactive (main)
Commit	Line	Data
fae90f24	1	#! /bin/sh
d610d8be	2	":"; ### --lisp--
fae90f24 MW	3	":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/:; export CL_SOURCE_REGISTRY
	4	":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(sod-exports::main)" -- "$0" "$@" \|\| exit 1
	5
cf268da2	6	(cl:defpackage #:sod-exports
91d9ba3c MW	7	(:use #:common-lisp
	8	#+cmu #:mop
	9	#+sbcl #:sb-mop))
cf268da2 MW	10
cf268da2 MW	11	(cl:in-package #:sod-exports)
91d9ba3c MW	12	(eval-when (:compile-toplevel :load-toplevel :execute)
91d9ba3c MW	13	(mapc #'asdf:load-system '(:sod :sod-frontend)))
cf268da2	14
097d5a3e MW	15	(defun symbolicate (&rest things)
	16	(intern (apply #'concatenate 'string (mapcar #'string things))))
	17
	18	(defun incomprehensible-form (head tail)
	19	(format error-output ";; incomprehensible: ~S~%" (cons head tail)))
	20
	21	(defgeneric form-list-exports (head tail)
	22	(:method (head tail)
	23	(declare (ignore head tail))
	24	nil))
	25
ea28678b	26	(defmethod form-list-exports ((head (eql 'cl:export)) tail)
097d5a3e MW	27	(let ((symbols (car tail)))
	28	(if (and (consp symbols)
	29	(eq (car symbols) 'quote))
	30	(let ((thing (cadr symbols)))
	31	(if (atom thing) (list thing) thing))
	32	(incomprehensible-form head tail))))
	33
ea28678b	34	(defmethod form-list-exports ((head (eql 'sod:definst)) tail)
097d5a3e	35	(destructuring-bind (code (streamvar &key export) args &body body) tail
34c51b1c	36	(declare (ignore streamvar body))
097d5a3e	37	(and export
34c51b1c MW	38	(list* (symbolicate code '-inst)
34c51b1c MW	39	(symbolicate 'make- code '-inst)
167524b5 MW	40	(mapcan (lambda (arg)
	41	(let ((sym (if (listp arg) (car arg) arg)))
	42	(cond ((char= (char (symbol-name sym) 0) #\&)
	43	nil)
	44	(t
	45	(list (symbolicate 'inst- sym))))))
34c51b1c	46	args)))))
097d5a3e	47
ea28678b	48	(defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)
097d5a3e MW	49	(destructuring-bind (kind what) tail
	50	(declare (ignore what))
	51	(list kind
	52	(symbolicate 'c- kind '-type)
	53	(symbolicate 'make- kind '-type))))
	54
e43d3532 MW	55	(defmethod form-list-exports ((head (eql 'sod:defctype)) tail)
	56	(destructuring-bind (names value &key export) tail
	57	(declare (ignore value))
	58	(let ((names (if (listp names) names (list names))))
	59	(and export
	60	(list* (symbolicate 'c-type- (car names)) names)))))
	61
	62	(defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)
	63	(destructuring-bind (names type &key export) tail
	64	(declare (ignore type))
	65	(let ((names (if (listp names) names (list names))))
	66	(and export
	67	(list* (symbolicate 'c-type- (car names)) names)))))
	68
ea28678b	69	(defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)
097d5a3e MW	70	(mapcan #'form-exports (cdr tail)))
097d5a3e MW	71
ea28678b	72	(defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
fdc3e506 MW	73	(mapcan #'form-exports (cdr tail)))
fdc3e506 MW	74
ea28678b	75	(defmethod form-list-exports ((head (eql 'cl:progn)) tail)
097d5a3e MW	76	(mapcan #'form-exports tail))
	77
	78	(defgeneric form-exports (form)
	79	(:method (form) nil)
	80	(:method ((form cons)) (form-list-exports (car form) (cdr form))))
	81
	82	(defgeneric list-exports (thing))
	83
	84	(defmethod list-exports ((stream stream))
	85	(loop with eof = '#:eof
	86	for form = (read stream nil eof)
	87	until (eq form eof)
	88	when (consp form) nconc (form-exports form)))
	89
	90	(defmethod list-exports ((path pathname))
	91	(mapcar (lambda (each)
	92	(cons each (with-open-file (stream each) (list-exports stream))))
	93	(directory (merge-pathnames path #p"*.lisp"))))
	94
	95	(defmethod list-exports ((path string))
	96	(list-exports (pathname path)))
	97
	98	(defun list-exported-symbols (package)
	99	(sort (loop for s being the external-symbols of package collect s)
	100	#'string< :key #'symbol-name))
	101
	102	(defun find-symbol-homes (paths package)
	103	(let* ((symbols (list-exported-symbols package))
ea28678b MW	104	(exports-alist (let ((package package))
ea28678b MW	105	(mapcan #'list-exports paths)))
097d5a3e MW	106	(homes (make-hash-table :test #'equal)))
	107	(dolist (assoc exports-alist)
	108	(let ((home (car assoc)))
	109	(dolist (symbol (cdr assoc))
	110	(let ((name (symbol-name symbol)))
de8f0794	111	(unless (nth-value 1 (find-symbol name package))
097d5a3e MW	112	(format error-output ";; unexported: ~S~%" symbol))
	113	(setf (gethash name homes) home)))))
	114	(dolist (symbol symbols)
	115	(unless (gethash (symbol-name symbol) homes)
	116	(format error-output ";; mysterious: ~S~%" symbol)))
	117	exports-alist))
	118
	119	(defun boring-setf-expansion-p (symbol)
	120	(multiple-value-bind (temps args stores store fetch)
	121	(ignore-errors (get-setf-expansion (list symbol)))
	122	(declare (ignore temps args stores fetch))
	123	(and (consp store)
	124	(eq (car store) 'funcall)
	125	(consp (cdr store)) (consp (cadr store))
	126	(eq (caadr store) 'function)
	127	(let ((func (cadadr store)))
	128	(and (consp func) (consp (cdr func))
	129	(eq (car func) 'setf))))))
	130
	131	(defun specialized-on-p (func arg what)
	132	(some (lambda (method)
91d9ba3c MW	133	(let ((spec (nth arg (method-specializers method))))
	134	(and (typep spec 'eql-specializer)
	135	(eql (eql-specializer-object spec) what))))
	136	(generic-function-methods func)))
097d5a3e MW	137
	138	(defun categorize (symbol)
	139	(let ((things nil))
	140	(when (boundp symbol)
	141	(push (if (constantp symbol) :constant :variable) things))
	142	(when (fboundp symbol)
	143	(push (cond ((macro-function symbol) :macro)
	144	((typep (fdefinition symbol) 'generic-function)
	145	:generic)
	146	(t :function))
	147	things)
	148	(when (or ;;(not (boring-setf-expansion-p symbol))
	149	(ignore-errors (fdefinition (list 'setf symbol))))
	150	(push :setf things)))
	151	(when (find-class symbol nil)
	152	(push :class things))
	153	(when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
	154	(specialized-on-p #'sod:expand-c-type-form 0 symbol))
	155	(push :c-type things))
	156	(when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
	157	(specialized-on-p #'sod-parser:expand-parser-form 1 symbol))
	158	(push :parser things))
61982981 MW	159	(when (get symbol 'optparse::opthandler)
	160	(push :opthandler things))
	161	(when (get symbol 'optparse::optmacro)
	162	(push :optmacro things))
097d5a3e MW	163	(nreverse things)))
	164
	165	(defun categorize-symbols (paths package)
	166	(mapcar (lambda (assoc)
	167	(let ((home (car assoc))
8922d110 MW	168	(symbols (delete-duplicates
	169	(sort (mapcan (lambda (sym)
	170	(multiple-value-bind
	171	(symbol foundp)
	172	(find-symbol
	173	(symbol-name sym)
	174	package)
	175	(and foundp (list symbol))))
	176	(cdr assoc))
	177	#'string< :key #'symbol-name))))
097d5a3e MW	178	(cons home (mapcar (lambda (symbol)
	179	(cons symbol (categorize symbol)))
	180	symbols))))
	181
649798ab	182	(find-symbol-homes paths package)))
097d5a3e MW	183
	184	(defun best-package-name (package)
	185	(car (sort (cons (package-name package)
	186	(copy-list (package-nicknames package)))
	187	#'< :key #'length)))
	188
	189	(defvar charbuf-size 0)
	190
b9d603a0 MW	191	(defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
	192	(and package
	193	(multiple-value-bind (sym how)
	194	(find-symbol (symbol-name symbol) package)
	195	(and (eq sym symbol)
	196	(eq how :external)))))
	197
097d5a3e	198	(defun pretty-symbol-name (symbol package)
b9d603a0 MW	199	(let ((pkg (symbol-package symbol))
b9d603a0 MW	200	(exportp (exported-symbol-p symbol)))
097d5a3e	201	(format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)"
ed006915	202	(and exportp (eq pkg package))
b9d603a0 MW	203	(cond ((keywordp symbol) "")
	204	((eq pkg nil) "#")
	205	(t (best-package-name pkg)))
	206	(or exportp (null pkg)) (symbol-name symbol))))
097d5a3e MW	207
	208	(defun analyse-classes (package)
	209	(setf package (find-package package))
	210	(let ((classes (mapcan (lambda (symbol)
	211	(let ((class (find-class symbol nil)))
	212	(and class
	213	(typep class '(or standard-class
	214	structure-class))
	215	(list class))))
	216	(list-exported-symbols package)))
	217	(subs (make-hash-table)))
	218	(let ((done (make-hash-table)))
	219	(labels ((walk-up (class)
	220	(unless (gethash class done)
91d9ba3c	221	(dolist (super (class-direct-superclasses class))
097d5a3e MW	222	(push class (gethash super subs))
	223	(walk-up super))
	224	(setf (gethash class done) t))))
	225	(dolist (class classes)
	226	(walk-up class))))
	227	(labels ((walk-down (this super depth)
	228	(format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
	229	(* 2 depth)
	230	(pretty-symbol-name (class-name this) package)
	231	(mapcar (lambda (class)
	232	(pretty-symbol-name (class-name class)
	233	package))
	234	(remove super
91d9ba3c	235	(class-direct-superclasses this))))
7a35400d MW	236	(dolist (sub (sort (copy-list (gethash this subs))
7a35400d MW	237	#'string< :key #'class-name))
097d5a3e MW	238	(walk-down sub this (1+ depth)))))
	239	(walk-down (find-class t) nil 0))))
	240
b9d603a0 MW	241	(defmacro deep-compare ((left right) &body body)
	242	(let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
	243	(l (gensym "LEFT-")) (r (gensym "RIGHT-")))
	244	`(macrolet ((focus (expr &body body)
	245	`(flet ((,',func (it) ,expr))
	246	(let ((,',l (,',func ,',l))
	247	(,',r (,',func ,',r)))
	248	,@body)))
	249	(update (expr)
	250	`(flet ((,',func (it) ,expr))
	251	(psetf ,',l (,',func ,',l)
	252	,',r (,',func ,',r))))
	253	(compare (expr)
	254	`(cond ((let ((left ,',l) (right ,',r)) ,expr)
	255	(return-from ,',block t))
	256	((let ((right ,',l) (left ,',r)) ,expr)
	257	(return-from ,',block nil))))
	258	(typesw (&rest clauses)
	259	(labels ((iter (clauses)
	260	(if (null clauses)
	261	'nil
	262	(destructuring-bind (type &rest body)
	263	(car clauses)
	264	(if (eq type t)
	265	`(progn ,@body)
	266	`(if (typep ,',l ',type)
	267	(if (typep ,',r ',type)
	268	(progn ,@body)
	269	(return-from ,',block t))
	270	(if (typep ,',r ',type)
	271	(return-from ,',block nil)
	272	,(iter (cdr clauses)))))))))
	273	(iter clauses))))
	274	(let ((,l ,left) (,r ,right))
	275	(block ,block
	276	,@body)))))
	277
	278	(defun order-specializers (la lb)
	279	(deep-compare (la lb)
	280	(loop (typesw (null (return nil)))
	281	(focus (car it)
91d9ba3c MW	282	(typesw (eql-specializer
91d9ba3c MW	283	(focus (eql-specializer-object it)
b9d603a0 MW	284	(typesw (keyword
	285	(compare (string< left right)))
	286	(symbol
	287	(focus (package-name (symbol-package it))
	288	(compare (string< left right)))
	289	(compare (string< left right)))
	290	(t
	291	(focus (with-output-to-string (out)
	292	(prin1 it out)
	293	(write-char #\nul))
	294	(compare (string< left right)))))))
	295	(class
	296	(focus (class-name it)
	297	(focus (package-name (symbol-package it))
	298	(compare (string< left right)))
	299	(compare (string< left right))))
	300	(t
	301	(error "unexpected things"))))
	302	(update (cdr it)))))
	303
a535feed MW	304	(defun analyse-generic-functions (package)
	305	(setf package (find-package package))
	306	(flet ((function-name-core (name)
e36ab294 MW	307	(typecase name
	308	(symbol (values name t))
	309	((cons (eql setf) t) (values (cadr name) t))
	310	(t (values nil nil)))))
a535feed MW	311	(let ((methods (make-hash-table))
	312	(functions (make-hash-table))
	313	(externs (make-hash-table)))
	314	(dolist (symbol (list-exported-symbols package))
	315	(setf (gethash symbol externs) t))
	316	(dolist (symbol (list-exported-symbols package))
	317	(flet ((dofunc (func)
	318	(when (typep func 'generic-function)
	319	(setf (gethash func functions) t)
91d9ba3c	320	(dolist (method (generic-function-methods func))
a535feed MW	321	(setf (gethash method methods) t)))))
	322	(dofunc (and (fboundp symbol) (fdefinition symbol)))
	323	(dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
	324	(when (eq (symbol-package symbol) package)
	325	(let ((class (find-class symbol nil)))
	326	(when class
	327	(dolist
91d9ba3c	328	(func (specializer-direct-generic-functions class))
e36ab294 MW	329	(multiple-value-bind (name knownp)
	330	(function-name-core (generic-function-name func))
	331	(when (and knownp
	332	(or (not (eq (symbol-package name) package))
	333	(gethash name externs)))
a535feed	334	(setf (gethash func functions) t)
91d9ba3c	335	(dolist (method (specializer-direct-methods class))
a535feed MW	336	(setf (gethash method methods) t)))))))))
	337	(let ((funclist nil))
	338	(maphash (lambda (func value)
	339	(declare (ignore value))
	340	(push func funclist))
	341	functions)
	342	(setf funclist (sort funclist
	343	(lambda (a b)
	344	(let ((core-a (function-name-core a))
	345	(core-b (function-name-core b)))
	346	(if (eq core-a core-b)
	347	(and (atom a) (consp b))
	348	(string< core-a core-b))))
91d9ba3c	349	:key #'generic-function-name))
a535feed	350	(dolist (function funclist)
91d9ba3c	351	(let ((name (generic-function-name function)))
a535feed MW	352	(etypecase name
	353	(symbol
	354	(format t "~A~%" (pretty-symbol-name name package)))
	355	((cons (eql setf) t)
	356	(format t "(setf ~A)~%"
	357	(pretty-symbol-name (cadr name) package)))))
b9d603a0	358	(dolist (method (sort (copy-list
91d9ba3c	359	(generic-function-methods function))
b9d603a0	360	#'order-specializers
91d9ba3c	361	:key #'method-specializers))
a535feed MW	362	(when (gethash method methods)
	363	(format t "~2T~{~A~^ ~}~%"
	364	(mapcar
	365	(lambda (spec)
	366	(etypecase spec
	367	(class
	368	(let ((name (class-name spec)))
	369	(if (eq name t) "t"
	370	(pretty-symbol-name name package))))
91d9ba3c MW	371	(eql-specializer
91d9ba3c MW	372	(let ((obj (eql-specializer-object spec)))
a535feed MW	373	(format nil "(eql ~A)"
	374	(if (symbolp obj)
	375	(pretty-symbol-name obj package)
	376	obj))))))
91d9ba3c	377	(method-specializers method))))))))))
a535feed	378
4b8e5c03 MW	379	(defun check-slot-names (package)
	380	(setf package (find-package package))
	381	(let* ((symbols (list-exported-symbols package))
	382	(classes (mapcan (lambda (symbol)
	383	(when (eq (symbol-package symbol) package)
	384	(let ((class (find-class symbol nil)))
	385	(and class (list class)))))
	386	symbols))
	387	(offenders (mapcan
	388	(lambda (class)
	389	(let* ((slot-names
91d9ba3c MW	390	(mapcar #'slot-definition-name
91d9ba3c MW	391	(class-direct-slots class)))
b9d603a0	392	(exported (remove-if
4b8e5c03	393	(lambda (sym)
211bfc14 MW	394	(or (not (symbol-package sym))
	395	(and (not (exported-symbol-p
	396	sym))
	397	(eq (symbol-package sym)
	398	package))))
4b8e5c03 MW	399	slot-names)))
	400	(and exported
	401	(list (cons (class-name class)
	402	exported)))))
	403	classes))
	404	(bad-words (remove-duplicates (mapcan (lambda (list)
	405	(copy-list (cdr list)))
	406	offenders))))
	407	(values offenders bad-words)))
	408
097d5a3e MW	409	(defun report-symbols (paths package)
	410	(setf package (find-package package))
	411	(format t "~A~%Package `~(~A~)'~2%"
	412	(make-string 77 :initial-element #\-)
	413	(package-name package))
b9d603a0 MW	414	(dolist (assoc (sort (categorize-symbols paths package) #'string<
	415	:key (lambda (assoc)
	416	(file-namestring (car assoc)))))
097d5a3e MW	417	(when (cdr assoc)
	418	(format t "~A~%" (file-namestring (car assoc)))
	419	(dolist (def (cdr assoc))
	420	(let ((sym (car def)))
	421	(format t " ~A~@[~48T~{~(~A~)~^ ~}~]~%"
	422	(pretty-symbol-name sym package)
	423	(cdr def))))
	424	(terpri)))
4b8e5c03 MW	425	(multiple-value-bind (alist names) (check-slot-names package)
	426	(when names
	427	(format t "Leaked slot names: ~{~A~^, ~}~%"
	428	(mapcar (lambda (name) (pretty-symbol-name name package))
	429	names))
	430	(dolist (assoc alist)
	431	(format t "~2T~A: ~{~A~^, ~}~%"
	432	(pretty-symbol-name (car assoc) package)
	433	(mapcar (lambda (name) (pretty-symbol-name name package))
	434	(cdr assoc))))
	435	(terpri)))
388caffa	436	(format t "Classes:~%")
097d5a3e	437	(analyse-classes package)
a535feed MW	438	(terpri)
	439	(format t "Methods:~%")
	440	(analyse-generic-functions package)
097d5a3e MW	441	(terpri))
097d5a3e MW	442
cf268da2	443	(export 'report-project-symbols)
097d5a3e MW	444	(defun report-project-symbols ()
097d5a3e MW	445	(labels ((components (comp)
e390f747	446	(asdf:component-children comp))
097d5a3e	447	(files (comp)
7a35400d	448	(sort (remove-if-not (lambda (comp)
b9d603a0	449	(typep comp 'asdf:cl-source-file))
7a35400d MW	450	(components comp))
7a35400d MW	451	#'string< :key #'asdf:component-name))
097d5a3e	452	(by-name (comp name)
e390f747	453	(gethash name (asdf:component-children-by-name comp)))
097d5a3e	454	(file-name (file)
e390f747	455	(slot-value file 'asdf/component:absolute-pathname)))
097d5a3e MW	456	(let* ((sod (asdf:find-system "sod"))
	457	(parser-files (files (by-name sod "parser")))
	458	(utilities (by-name sod "utilities"))
61982981 MW	459	(sod-frontend (asdf:find-system "sod-frontend"))
61982981 MW	460	(optparse (by-name sod-frontend "optparse"))
6ac5b807	461	(frontend (by-name sod-frontend "frontend"))
61982981	462	(sod-files (set-difference (files sod) (list utilities))))
097d5a3e	463	(report-symbols (mapcar #'file-name sod-files) "SOD")
6ac5b807	464	(report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND")
097d5a3e	465	(report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
61982981	466	(report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE")
097d5a3e	467	(report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))
1c1a9bf1	468
fae90f24 MW	469	(defun main ()
	470	(with-open-file (standard-output #p"doc/SYMBOLS"
	471	:direction :output
	472	:if-exists :supersede
	473	:if-does-not-exist :create)
	474	(report-project-symbols)))
	475
	476	#+interactive (main)