X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/649798abde0fd23d517b09f0c030b266ce117c67..82567ea97e4f9374e8a3d586ea49ad9bf3dff3dc:/doc/list-exports.lisp

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
old mode 100644
new mode 100755
index f4cdfab..c86156b
--- a/doc/list-exports.lisp
+++ b/doc/list-exports.lisp
@@ -1,3 +1,17 @@
+#! /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))))
 
@@ -9,7 +23,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,24 +31,65 @@
 	  (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 args body))
+    (declare (ignore streamvar body))
     (and export
-	 (list (symbolicate code '-inst)
-	       (symbolicate 'make- code '-inst)))))
+	 (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 '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 '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 'progn)) 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)
@@ -63,13 +118,14 @@
 
 (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)))
 	(dolist (symbol (cdr assoc))
 	  (let ((name (symbol-name symbol)))
-	    (unless (find-symbol name package)
+	    (unless (nth-value 1 (find-symbol name package))
 	      (format *error-output* ";; unexported: ~S~%" symbol))
 	    (setf (gethash name homes) home)))))
     (dolist (symbol symbols)
@@ -91,10 +147,10 @@
 
 (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)))
+	  (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))
@@ -117,19 +173,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))))
@@ -143,27 +205,41 @@
 
 (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))))
+
+(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 '(or standard-class
-						 structure-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 (sb-mop:class-direct-superclasses class))
+		   (dolist (super (class-direct-superclasses class))
 		     (push class (gethash super subs))
 		     (walk-up super))
 		   (setf (gethash class done) t))))
@@ -177,17 +253,189 @@
 				 (pretty-symbol-name (class-name class)
 						     package))
 			       (remove super
-				       (sb-mop:class-direct-superclasses this))))
-	       (dolist (sub (reverse (gethash this subs)))
+				       (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 (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))
@@ -196,25 +444,55 @@
 		  (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))
+	     (asdf:component-children comp))
 	   (files (comp)
-	     (remove-if-not (lambda (comp)
-			      (typep comp 'asdf:cl-source-file))
-			    (components comp)))
+	     (sort (remove-if-not (lambda (comp)
+				    (typep comp 'asdf:cl-source-file))
+				  (components comp))
+		   #'string< :key #'asdf:component-name))
 	   (by-name (comp name)
-	     (find name (components comp)
-		   :test #'string= :key #'asdf:component-name))
+	     (gethash name (asdf:component-children-by-name comp)))
 	   (file-name (file)
-	     (slot-value file 'asdf::absolute-pathname)))
+	     (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-files (remove utilities (files sod))))
+	 (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)