+#! /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))))
(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))
(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)
(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)))
(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))
(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))))
(defun analyse-classes (package)
(setf package (find-package package))
(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))))
(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)))
(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)))))
(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)
(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
(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))
(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)
(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))
(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"))
(sod-frontend (asdf:find-system "sod-frontend"))
(optparse (by-name sod-frontend "optparse"))
+ (frontend (by-name sod-frontend "frontend"))
(sod-files (set-difference (files sod) (list 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)
~mdw / sod / blobdiff