[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)
		(labels ((dig (tree path)
			   (if (or (atom tree) (null path)) tree
			       (dig (nth (car path) tree) (cdr path))))
			 (cook (arg)
			   (if (consp arg) (car arg)
			       (let ((name (symbol-name arg)))
				 (if (char= (char name 0) #\%)
				     (intern (subseq name 1))
				     arg))))
			 (instify (arg)
			   (symbolicate 'inst- (cook arg))))
		  (loop with state = :mandatory
			for arg in args
			if (and (symbolp arg)
				(char= (char (symbol-name arg) 0) #\&))
			  do (setf state arg)
			else if (member state '(:mandatory &rest))
			  collect (instify arg)
			else if (member state '(&optional &aux))
			  collect (instify (dig arg '(0)))
			else if (eq state '&key)
			  collect (instify (dig arg '(0 1)))
			else
			  do (error "Confused by ~S." arg)))))))

(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))))

(deftype interesting-class ()
  '(or standard-class
       structure-class
       #.(class-name (class-of (find-class 'condition)))))

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