#! /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
(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 'sod::define-tagged-type)) tail)
(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)))
(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)))
#'order-specializers
:key #'method-specializers))
(when (gethash method methods)
- (format t "~2T~{~A~^ ~}~%"
+ (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
(mapcar
(lambda (spec)
(etypecase spec
(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))
(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)
(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"))