X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1818107e8198734df843841a51bca3713bd37596..b8eeeb378980ebf06cd5b57fe0e967c23955cf5f:/doc/list-exports.lisp

diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp
old mode 100644
new mode 100755
index 93ee8be..f58fb2b
--- 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,30 +31,48 @@
 	  (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
 	 (list* (symbolicate code '-inst)
 		(symbolicate 'make- code '-inst)
-		(mapcar (lambda (arg)
-			  (symbolicate 'inst- arg))
+		(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 '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 '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 +101,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)))
@@ -97,10 +130,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))
@@ -155,28 +188,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))
-	    (if (keywordp symbol) "" (best-package-name pkg))
-	    exportp (symbol-name symbol))))
+	    (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))))
@@ -190,18 +236,82 @@
 				 (pretty-symbol-name (class-name class)
 						     package))
 			       (remove super
-				       (sb-mop:class-direct-superclasses this))))
+				       (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)
-	   (etypecase name
-	     (symbol name)
-	     ((cons (eql setf) t) (cadr 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)))
@@ -211,7 +321,7 @@
 	(flet ((dofunc (func)
 		 (when (typep func 'generic-function)
 		   (setf (gethash func functions) t)
-		   (dolist (method (sb-mop:generic-function-methods func))
+		   (dolist (method (generic-function-methods func))
 		     (setf (gethash method methods) t)))))
 	  (dofunc (and (fboundp symbol) (fdefinition symbol)))
 	  (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
@@ -219,13 +329,14 @@
 	  (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))
+		  (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 (sb-mop:specializer-direct-methods class))
+		    (dolist (method (specializer-direct-methods class))
 		      (setf (gethash method methods) t)))))))))
       (let ((funclist nil))
 	(maphash (lambda (func value)
@@ -239,18 +350,21 @@
 				 (if (eq core-a core-b)
 				     (and (atom a) (consp b))
 				     (string< core-a core-b))))
-			     :key #'sb-mop:generic-function-name))
+			     :key #'generic-function-name))
 	(dolist (function funclist)
-	  (let ((name (sb-mop:generic-function-name function)))
+	  (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 (sb-mop:generic-function-methods function))
+	  (dolist (method (sort (copy-list
+				 (generic-function-methods function))
+				#'order-specializers
+				:key #'method-specializers))
 	    (when (gethash method methods)
-	      (format t "~2T~{~A~^ ~}~%"
+	      (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
 		      (mapcar
 		       (lambda (spec)
 			 (etypecase spec
@@ -258,13 +372,14 @@
 			    (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)))
+			   (eql-specializer
+			    (let ((obj (eql-specializer-object spec)))
 			      (format nil "(eql ~A)"
 				      (if (symbolp obj)
 					  (pretty-symbol-name obj package)
 					  obj))))))
-		       (sb-mop:method-specializers method))))))))))
+		       (method-specializers method))
+		      (method-qualifiers method)))))))))
 
 (defun check-slot-names (package)
   (setf package (find-package package))
@@ -277,15 +392,15 @@
 	 (offenders (mapcan
 		     (lambda (class)
 		       (let* ((slot-names
-			       (mapcar #'sb-mop:slot-definition-name
-				       (sb-mop:class-direct-slots class)))
-			      (exported (remove-if-not
+			       (mapcar #'slot-definition-name
+				       (class-direct-slots class)))
+			      (exported (remove-if
 					 (lambda (sym)
-					   (or (and (symbol-package sym)
-						    (not (eq (symbol-package
-							      sym)
-							     package)))
-					       (member sym symbols)))
+					   (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)
@@ -301,7 +416,9 @@
   (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))
@@ -328,19 +445,19 @@
   (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)
 	     (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)
-	     (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"))
@@ -353,3 +470,12 @@
     (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)