X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/91d9ba3cb6ed57640dc29c2b2e73bb89e2628484..e9f884f9722eb676b3a9a6f5ffeab4e61fe4d872:/doc/list-exports.lisp diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp old mode 100644 new mode 100755 index 5eab34e..f4117df --- a/doc/list-exports.lisp +++ b/doc/list-exports.lisp @@ -1,3 +1,8 @@ +#! /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 @@ -32,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 @@ -43,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))) @@ -122,9 +162,10 @@ :generic) (t :function)) things) - (when (or ;;(not (boring-setf-expansion-p symbol)) - (ignore-errors (fdefinition (list 'setf symbol)))) - (push :setf things))) + (etypecase (ignore-errors (fdefinition (list 'setf symbol))) + (generic-function (push :setf-generic things)) + (function (push :setf-function things)) + (null))) (when (find-class symbol nil) (push :class things)) (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol) @@ -182,13 +223,17 @@ (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))) @@ -281,9 +326,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))) @@ -302,10 +348,11 @@ (when class (dolist (func (specializer-direct-generic-functions class)) - (let ((name (function-name-core - (generic-function-name func)))) - (when (or (not (eq (symbol-package name) package)) - (gethash name externs)) + (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))))))))) @@ -335,7 +382,7 @@ #'order-specializers :key #'method-specializers)) (when (gethash method methods) - (format t "~2T~{~A~^ ~}~%" + (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%" (mapcar (lambda (spec) (etypecase spec @@ -349,7 +396,8 @@ (if (symbolp obj) (pretty-symbol-name obj package) obj)))))) - (method-specializers method)))))))))) + (method-specializers method)) + (method-qualifiers method))))))))) (defun check-slot-names (package) (setf package (find-package package)) @@ -366,9 +414,11 @@ (class-direct-slots class))) (exported (remove-if (lambda (sym) - (and (not (exported-symbol-p sym)) - (eq (symbol-package sym) - package))) + (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) @@ -416,31 +466,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)