X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/211bfc1487ed4f34b54904b011a65ae05aefa19d..f0b1f2bfc04f53416356be951b2655ff26ce7e7f:/doc/list-exports.lisp diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp old mode 100644 new mode 100755 index 7e5ea73..c86156b --- a/doc/list-exports.lisp +++ b/doc/list-exports.lisp @@ -1,7 +1,16 @@ +#! /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)) + (: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)))) @@ -28,9 +37,30 @@ (and export (list* (symbolicate code '-inst) (symbolicate 'make- code '-inst) - (mapcar (lambda (arg) - (symbolicate 'inst- arg)) - args))))) + (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 @@ -39,6 +69,20 @@ (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))) @@ -103,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)) @@ -178,20 +222,24 @@ (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)))) @@ -205,7 +253,7 @@ (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))))) @@ -252,8 +300,8 @@ (deep-compare (la lb) (loop (typesw (null (return nil))) (focus (car it) - (typesw (sb-mop:eql-specializer - (focus (sb-mop:eql-specializer-object it) + (typesw (eql-specializer + (focus (eql-specializer-object it) (typesw (keyword (compare (string< left right))) (symbol @@ -277,9 +325,10 @@ (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))) @@ -289,7 +338,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))))) @@ -297,13 +346,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) @@ -317,9 +367,9 @@ (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))) @@ -327,11 +377,11 @@ (format t "(setf ~A)~%" (pretty-symbol-name (cadr name) package))))) (dolist (method (sort (copy-list - (sb-mop:generic-function-methods function)) + (generic-function-methods function)) #'order-specializers - :key #'sb-mop:method-specializers)) + :key #'method-specializers)) (when (gethash method methods) - (format t "~2T~{~A~^ ~}~%" + (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%" (mapcar (lambda (spec) (etypecase spec @@ -339,13 +389,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)) @@ -358,8 +409,8 @@ (offenders (mapcan (lambda (class) (let* ((slot-names - (mapcar #'sb-mop:slot-definition-name - (sb-mop:class-direct-slots class))) + (mapcar #'slot-definition-name + (class-direct-slots class))) (exported (remove-if (lambda (sym) (or (not (symbol-package sym)) @@ -414,31 +465,34 @@ (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)) (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-frontend (asdf:find-system "sod-frontend")) - (optparse (by-name sod-frontend "optparse")) + (optparse (by-name sod "optparse")) (frontend (by-name sod-frontend "frontend")) - (sod-files (set-difference (files sod) (list utilities)))) + (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")))) -#+interactive -(with-open-file (*standard-output* #p"doc/SYMBOLS" :direction :output - :if-exists :supersede :if-does-not-exist :create) - (report-project-symbols)) +(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)