| 1 | #! /bin/sh |
| 2 | ":"; ### -*-lisp-*- |
| 3 | ":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/:; export CL_SOURCE_REGISTRY |
| 4 | ":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(sod-exports::main)" -- "$0" "$@" || exit 1 |
| 5 | |
| 6 | (cl:defpackage #:sod-exports |
| 7 | (:use #:common-lisp |
| 8 | #+cmu #:mop |
| 9 | #+sbcl #:sb-mop)) |
| 10 | |
| 11 | (cl:in-package #:sod-exports) |
| 12 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 13 | (mapc #'asdf:load-system '(:sod :sod-frontend))) |
| 14 | |
| 15 | (defun symbolicate (&rest things) |
| 16 | (intern (apply #'concatenate 'string (mapcar #'string things)))) |
| 17 | |
| 18 | (defun incomprehensible-form (head tail) |
| 19 | (format *error-output* ";; incomprehensible: ~S~%" (cons head tail))) |
| 20 | |
| 21 | (defgeneric form-list-exports (head tail) |
| 22 | (:method (head tail) |
| 23 | (declare (ignore head tail)) |
| 24 | nil)) |
| 25 | |
| 26 | (defmethod form-list-exports ((head (eql 'cl:export)) tail) |
| 27 | (let ((symbols (car tail))) |
| 28 | (if (and (consp symbols) |
| 29 | (eq (car symbols) 'quote)) |
| 30 | (let ((thing (cadr symbols))) |
| 31 | (if (atom thing) (list thing) thing)) |
| 32 | (incomprehensible-form head tail)))) |
| 33 | |
| 34 | (defmethod form-list-exports ((head (eql 'sod:definst)) tail) |
| 35 | (destructuring-bind (code (streamvar &key export) args &body body) tail |
| 36 | (declare (ignore streamvar body)) |
| 37 | (and export |
| 38 | (list* (symbolicate code '-inst) |
| 39 | (symbolicate 'make- code '-inst) |
| 40 | (mapcan (lambda (arg) |
| 41 | (let ((sym (if (listp arg) (car arg) arg))) |
| 42 | (cond ((char= (char (symbol-name sym) 0) #\&) |
| 43 | nil) |
| 44 | (t |
| 45 | (list (symbolicate 'inst- sym)))))) |
| 46 | args))))) |
| 47 | |
| 48 | (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail) |
| 49 | (destructuring-bind (kind what) tail |
| 50 | (declare (ignore what)) |
| 51 | (list kind |
| 52 | (symbolicate 'c- kind '-type) |
| 53 | (symbolicate 'make- kind '-type)))) |
| 54 | |
| 55 | (defmethod form-list-exports ((head (eql 'sod:defctype)) tail) |
| 56 | (destructuring-bind (names value &key export) tail |
| 57 | (declare (ignore value)) |
| 58 | (let ((names (if (listp names) names (list names)))) |
| 59 | (and export |
| 60 | (list* (symbolicate 'c-type- (car names)) names))))) |
| 61 | |
| 62 | (defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail) |
| 63 | (destructuring-bind (names type &key export) tail |
| 64 | (declare (ignore type)) |
| 65 | (let ((names (if (listp names) names (list names)))) |
| 66 | (and export |
| 67 | (list* (symbolicate 'c-type- (car names)) names))))) |
| 68 | |
| 69 | (defmethod form-list-exports ((head (eql 'cl:macrolet)) tail) |
| 70 | (mapcan #'form-exports (cdr tail))) |
| 71 | |
| 72 | (defmethod form-list-exports ((head (eql 'cl:eval-when)) tail) |
| 73 | (mapcan #'form-exports (cdr tail))) |
| 74 | |
| 75 | (defmethod form-list-exports ((head (eql 'cl:progn)) tail) |
| 76 | (mapcan #'form-exports tail)) |
| 77 | |
| 78 | (defgeneric form-exports (form) |
| 79 | (:method (form) nil) |
| 80 | (:method ((form cons)) (form-list-exports (car form) (cdr form)))) |
| 81 | |
| 82 | (defgeneric list-exports (thing)) |
| 83 | |
| 84 | (defmethod list-exports ((stream stream)) |
| 85 | (loop with eof = '#:eof |
| 86 | for form = (read stream nil eof) |
| 87 | until (eq form eof) |
| 88 | when (consp form) nconc (form-exports form))) |
| 89 | |
| 90 | (defmethod list-exports ((path pathname)) |
| 91 | (mapcar (lambda (each) |
| 92 | (cons each (with-open-file (stream each) (list-exports stream)))) |
| 93 | (directory (merge-pathnames path #p"*.lisp")))) |
| 94 | |
| 95 | (defmethod list-exports ((path string)) |
| 96 | (list-exports (pathname path))) |
| 97 | |
| 98 | (defun list-exported-symbols (package) |
| 99 | (sort (loop for s being the external-symbols of package collect s) |
| 100 | #'string< :key #'symbol-name)) |
| 101 | |
| 102 | (defun find-symbol-homes (paths package) |
| 103 | (let* ((symbols (list-exported-symbols package)) |
| 104 | (exports-alist (let ((*package* package)) |
| 105 | (mapcan #'list-exports paths))) |
| 106 | (homes (make-hash-table :test #'equal))) |
| 107 | (dolist (assoc exports-alist) |
| 108 | (let ((home (car assoc))) |
| 109 | (dolist (symbol (cdr assoc)) |
| 110 | (let ((name (symbol-name symbol))) |
| 111 | (unless (nth-value 1 (find-symbol name package)) |
| 112 | (format *error-output* ";; unexported: ~S~%" symbol)) |
| 113 | (setf (gethash name homes) home))))) |
| 114 | (dolist (symbol symbols) |
| 115 | (unless (gethash (symbol-name symbol) homes) |
| 116 | (format *error-output* ";; mysterious: ~S~%" symbol))) |
| 117 | exports-alist)) |
| 118 | |
| 119 | (defun boring-setf-expansion-p (symbol) |
| 120 | (multiple-value-bind (temps args stores store fetch) |
| 121 | (ignore-errors (get-setf-expansion (list symbol))) |
| 122 | (declare (ignore temps args stores fetch)) |
| 123 | (and (consp store) |
| 124 | (eq (car store) 'funcall) |
| 125 | (consp (cdr store)) (consp (cadr store)) |
| 126 | (eq (caadr store) 'function) |
| 127 | (let ((func (cadadr store))) |
| 128 | (and (consp func) (consp (cdr func)) |
| 129 | (eq (car func) 'setf)))))) |
| 130 | |
| 131 | (defun specialized-on-p (func arg what) |
| 132 | (some (lambda (method) |
| 133 | (let ((spec (nth arg (method-specializers method)))) |
| 134 | (and (typep spec 'eql-specializer) |
| 135 | (eql (eql-specializer-object spec) what)))) |
| 136 | (generic-function-methods func))) |
| 137 | |
| 138 | (defun categorize (symbol) |
| 139 | (let ((things nil)) |
| 140 | (when (boundp symbol) |
| 141 | (push (if (constantp symbol) :constant :variable) things)) |
| 142 | (when (fboundp symbol) |
| 143 | (push (cond ((macro-function symbol) :macro) |
| 144 | ((typep (fdefinition symbol) 'generic-function) |
| 145 | :generic) |
| 146 | (t :function)) |
| 147 | things) |
| 148 | (when (or ;;(not (boring-setf-expansion-p symbol)) |
| 149 | (ignore-errors (fdefinition (list 'setf symbol)))) |
| 150 | (push :setf things))) |
| 151 | (when (find-class symbol nil) |
| 152 | (push :class things)) |
| 153 | (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol) |
| 154 | (specialized-on-p #'sod:expand-c-type-form 0 symbol)) |
| 155 | (push :c-type things)) |
| 156 | (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol) |
| 157 | (specialized-on-p #'sod-parser:expand-parser-form 1 symbol)) |
| 158 | (push :parser things)) |
| 159 | (when (get symbol 'optparse::opthandler) |
| 160 | (push :opthandler things)) |
| 161 | (when (get symbol 'optparse::optmacro) |
| 162 | (push :optmacro things)) |
| 163 | (nreverse things))) |
| 164 | |
| 165 | (defun categorize-symbols (paths package) |
| 166 | (mapcar (lambda (assoc) |
| 167 | (let ((home (car assoc)) |
| 168 | (symbols (delete-duplicates |
| 169 | (sort (mapcan (lambda (sym) |
| 170 | (multiple-value-bind |
| 171 | (symbol foundp) |
| 172 | (find-symbol |
| 173 | (symbol-name sym) |
| 174 | package) |
| 175 | (and foundp (list symbol)))) |
| 176 | (cdr assoc)) |
| 177 | #'string< :key #'symbol-name)))) |
| 178 | (cons home (mapcar (lambda (symbol) |
| 179 | (cons symbol (categorize symbol))) |
| 180 | symbols)))) |
| 181 | |
| 182 | (find-symbol-homes paths package))) |
| 183 | |
| 184 | (defun best-package-name (package) |
| 185 | (car (sort (cons (package-name package) |
| 186 | (copy-list (package-nicknames package))) |
| 187 | #'< :key #'length))) |
| 188 | |
| 189 | (defvar charbuf-size 0) |
| 190 | |
| 191 | (defun exported-symbol-p (symbol &optional (package (symbol-package symbol))) |
| 192 | (and package |
| 193 | (multiple-value-bind (sym how) |
| 194 | (find-symbol (symbol-name symbol) package) |
| 195 | (and (eq sym symbol) |
| 196 | (eq how :external))))) |
| 197 | |
| 198 | (defun pretty-symbol-name (symbol package) |
| 199 | (let ((pkg (symbol-package symbol)) |
| 200 | (exportp (exported-symbol-p symbol))) |
| 201 | (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)" |
| 202 | (and exportp (eq pkg package)) |
| 203 | (cond ((keywordp symbol) "") |
| 204 | ((eq pkg nil) "#") |
| 205 | (t (best-package-name pkg))) |
| 206 | (or exportp (null pkg)) (symbol-name symbol)))) |
| 207 | |
| 208 | (deftype interesting-class () |
| 209 | '(or standard-class |
| 210 | structure-class |
| 211 | #.(class-name (class-of (find-class 'condition))))) |
| 212 | |
| 213 | (defun analyse-classes (package) |
| 214 | (setf package (find-package package)) |
| 215 | (let ((classes (mapcan (lambda (symbol) |
| 216 | (let ((class (find-class symbol nil))) |
| 217 | (and class |
| 218 | (typep class 'interesting-class) |
| 219 | (list class)))) |
| 220 | (list-exported-symbols package))) |
| 221 | (subs (make-hash-table))) |
| 222 | (let ((done (make-hash-table))) |
| 223 | (labels ((walk-up (class) |
| 224 | (unless (gethash class done) |
| 225 | (dolist (super (class-direct-superclasses class)) |
| 226 | (push class (gethash super subs)) |
| 227 | (walk-up super)) |
| 228 | (setf (gethash class done) t)))) |
| 229 | (dolist (class classes) |
| 230 | (walk-up class)))) |
| 231 | (labels ((walk-down (this super depth) |
| 232 | (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%" |
| 233 | (* 2 depth) |
| 234 | (pretty-symbol-name (class-name this) package) |
| 235 | (mapcar (lambda (class) |
| 236 | (pretty-symbol-name (class-name class) |
| 237 | package)) |
| 238 | (remove super |
| 239 | (class-direct-superclasses this)))) |
| 240 | (dolist (sub (sort (copy-list (gethash this subs)) |
| 241 | #'string< :key #'class-name)) |
| 242 | (walk-down sub this (1+ depth))))) |
| 243 | (walk-down (find-class t) nil 0)))) |
| 244 | |
| 245 | (defmacro deep-compare ((left right) &body body) |
| 246 | (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-")) |
| 247 | (l (gensym "LEFT-")) (r (gensym "RIGHT-"))) |
| 248 | `(macrolet ((focus (expr &body body) |
| 249 | `(flet ((,',func (it) ,expr)) |
| 250 | (let ((,',l (,',func ,',l)) |
| 251 | (,',r (,',func ,',r))) |
| 252 | ,@body))) |
| 253 | (update (expr) |
| 254 | `(flet ((,',func (it) ,expr)) |
| 255 | (psetf ,',l (,',func ,',l) |
| 256 | ,',r (,',func ,',r)))) |
| 257 | (compare (expr) |
| 258 | `(cond ((let ((left ,',l) (right ,',r)) ,expr) |
| 259 | (return-from ,',block t)) |
| 260 | ((let ((right ,',l) (left ,',r)) ,expr) |
| 261 | (return-from ,',block nil)))) |
| 262 | (typesw (&rest clauses) |
| 263 | (labels ((iter (clauses) |
| 264 | (if (null clauses) |
| 265 | 'nil |
| 266 | (destructuring-bind (type &rest body) |
| 267 | (car clauses) |
| 268 | (if (eq type t) |
| 269 | `(progn ,@body) |
| 270 | `(if (typep ,',l ',type) |
| 271 | (if (typep ,',r ',type) |
| 272 | (progn ,@body) |
| 273 | (return-from ,',block t)) |
| 274 | (if (typep ,',r ',type) |
| 275 | (return-from ,',block nil) |
| 276 | ,(iter (cdr clauses))))))))) |
| 277 | (iter clauses)))) |
| 278 | (let ((,l ,left) (,r ,right)) |
| 279 | (block ,block |
| 280 | ,@body))))) |
| 281 | |
| 282 | (defun order-specializers (la lb) |
| 283 | (deep-compare (la lb) |
| 284 | (loop (typesw (null (return nil))) |
| 285 | (focus (car it) |
| 286 | (typesw (eql-specializer |
| 287 | (focus (eql-specializer-object it) |
| 288 | (typesw (keyword |
| 289 | (compare (string< left right))) |
| 290 | (symbol |
| 291 | (focus (package-name (symbol-package it)) |
| 292 | (compare (string< left right))) |
| 293 | (compare (string< left right))) |
| 294 | (t |
| 295 | (focus (with-output-to-string (out) |
| 296 | (prin1 it out) |
| 297 | (write-char #\nul)) |
| 298 | (compare (string< left right))))))) |
| 299 | (class |
| 300 | (focus (class-name it) |
| 301 | (focus (package-name (symbol-package it)) |
| 302 | (compare (string< left right))) |
| 303 | (compare (string< left right)))) |
| 304 | (t |
| 305 | (error "unexpected things")))) |
| 306 | (update (cdr it))))) |
| 307 | |
| 308 | (defun analyse-generic-functions (package) |
| 309 | (setf package (find-package package)) |
| 310 | (flet ((function-name-core (name) |
| 311 | (typecase name |
| 312 | (symbol (values name t)) |
| 313 | ((cons (eql setf) t) (values (cadr name) t)) |
| 314 | (t (values nil nil))))) |
| 315 | (let ((methods (make-hash-table)) |
| 316 | (functions (make-hash-table)) |
| 317 | (externs (make-hash-table))) |
| 318 | (dolist (symbol (list-exported-symbols package)) |
| 319 | (setf (gethash symbol externs) t)) |
| 320 | (dolist (symbol (list-exported-symbols package)) |
| 321 | (flet ((dofunc (func) |
| 322 | (when (typep func 'generic-function) |
| 323 | (setf (gethash func functions) t) |
| 324 | (dolist (method (generic-function-methods func)) |
| 325 | (setf (gethash method methods) t))))) |
| 326 | (dofunc (and (fboundp symbol) (fdefinition symbol))) |
| 327 | (dofunc (ignore-errors (fdefinition (list 'setf symbol))))) |
| 328 | (when (eq (symbol-package symbol) package) |
| 329 | (let ((class (find-class symbol nil))) |
| 330 | (when class |
| 331 | (dolist |
| 332 | (func (specializer-direct-generic-functions class)) |
| 333 | (multiple-value-bind (name knownp) |
| 334 | (function-name-core (generic-function-name func)) |
| 335 | (when (and knownp |
| 336 | (or (not (eq (symbol-package name) package)) |
| 337 | (gethash name externs))) |
| 338 | (setf (gethash func functions) t) |
| 339 | (dolist (method (specializer-direct-methods class)) |
| 340 | (setf (gethash method methods) t))))))))) |
| 341 | (let ((funclist nil)) |
| 342 | (maphash (lambda (func value) |
| 343 | (declare (ignore value)) |
| 344 | (push func funclist)) |
| 345 | functions) |
| 346 | (setf funclist (sort funclist |
| 347 | (lambda (a b) |
| 348 | (let ((core-a (function-name-core a)) |
| 349 | (core-b (function-name-core b))) |
| 350 | (if (eq core-a core-b) |
| 351 | (and (atom a) (consp b)) |
| 352 | (string< core-a core-b)))) |
| 353 | :key #'generic-function-name)) |
| 354 | (dolist (function funclist) |
| 355 | (let ((name (generic-function-name function))) |
| 356 | (etypecase name |
| 357 | (symbol |
| 358 | (format t "~A~%" (pretty-symbol-name name package))) |
| 359 | ((cons (eql setf) t) |
| 360 | (format t "(setf ~A)~%" |
| 361 | (pretty-symbol-name (cadr name) package))))) |
| 362 | (dolist (method (sort (copy-list |
| 363 | (generic-function-methods function)) |
| 364 | #'order-specializers |
| 365 | :key #'method-specializers)) |
| 366 | (when (gethash method methods) |
| 367 | (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%" |
| 368 | (mapcar |
| 369 | (lambda (spec) |
| 370 | (etypecase spec |
| 371 | (class |
| 372 | (let ((name (class-name spec))) |
| 373 | (if (eq name t) "t" |
| 374 | (pretty-symbol-name name package)))) |
| 375 | (eql-specializer |
| 376 | (let ((obj (eql-specializer-object spec))) |
| 377 | (format nil "(eql ~A)" |
| 378 | (if (symbolp obj) |
| 379 | (pretty-symbol-name obj package) |
| 380 | obj)))))) |
| 381 | (method-specializers method)) |
| 382 | (method-qualifiers method))))))))) |
| 383 | |
| 384 | (defun check-slot-names (package) |
| 385 | (setf package (find-package package)) |
| 386 | (let* ((symbols (list-exported-symbols package)) |
| 387 | (classes (mapcan (lambda (symbol) |
| 388 | (when (eq (symbol-package symbol) package) |
| 389 | (let ((class (find-class symbol nil))) |
| 390 | (and class (list class))))) |
| 391 | symbols)) |
| 392 | (offenders (mapcan |
| 393 | (lambda (class) |
| 394 | (let* ((slot-names |
| 395 | (mapcar #'slot-definition-name |
| 396 | (class-direct-slots class))) |
| 397 | (exported (remove-if |
| 398 | (lambda (sym) |
| 399 | (or (not (symbol-package sym)) |
| 400 | (and (not (exported-symbol-p |
| 401 | sym)) |
| 402 | (eq (symbol-package sym) |
| 403 | package)))) |
| 404 | slot-names))) |
| 405 | (and exported |
| 406 | (list (cons (class-name class) |
| 407 | exported))))) |
| 408 | classes)) |
| 409 | (bad-words (remove-duplicates (mapcan (lambda (list) |
| 410 | (copy-list (cdr list))) |
| 411 | offenders)))) |
| 412 | (values offenders bad-words))) |
| 413 | |
| 414 | (defun report-symbols (paths package) |
| 415 | (setf package (find-package package)) |
| 416 | (format t "~A~%Package `~(~A~)'~2%" |
| 417 | (make-string 77 :initial-element #\-) |
| 418 | (package-name package)) |
| 419 | (dolist (assoc (sort (categorize-symbols paths package) #'string< |
| 420 | :key (lambda (assoc) |
| 421 | (file-namestring (car assoc))))) |
| 422 | (when (cdr assoc) |
| 423 | (format t "~A~%" (file-namestring (car assoc))) |
| 424 | (dolist (def (cdr assoc)) |
| 425 | (let ((sym (car def))) |
| 426 | (format t " ~A~@[~48T~{~(~A~)~^ ~}~]~%" |
| 427 | (pretty-symbol-name sym package) |
| 428 | (cdr def)))) |
| 429 | (terpri))) |
| 430 | (multiple-value-bind (alist names) (check-slot-names package) |
| 431 | (when names |
| 432 | (format t "Leaked slot names: ~{~A~^, ~}~%" |
| 433 | (mapcar (lambda (name) (pretty-symbol-name name package)) |
| 434 | names)) |
| 435 | (dolist (assoc alist) |
| 436 | (format t "~2T~A: ~{~A~^, ~}~%" |
| 437 | (pretty-symbol-name (car assoc) package) |
| 438 | (mapcar (lambda (name) (pretty-symbol-name name package)) |
| 439 | (cdr assoc)))) |
| 440 | (terpri))) |
| 441 | (format t "Classes:~%") |
| 442 | (analyse-classes package) |
| 443 | (terpri) |
| 444 | (format t "Methods:~%") |
| 445 | (analyse-generic-functions package) |
| 446 | (terpri)) |
| 447 | |
| 448 | (export 'report-project-symbols) |
| 449 | (defun report-project-symbols () |
| 450 | (labels ((components (comp) |
| 451 | (asdf:component-children comp)) |
| 452 | (files (comp) |
| 453 | (sort (remove-if-not (lambda (comp) |
| 454 | (typep comp 'asdf:cl-source-file)) |
| 455 | (components comp)) |
| 456 | #'string< :key #'asdf:component-name)) |
| 457 | (by-name (comp name) |
| 458 | (gethash name (asdf:component-children-by-name comp))) |
| 459 | (file-name (file) |
| 460 | (slot-value file 'asdf/component:absolute-pathname))) |
| 461 | (let* ((sod (asdf:find-system "sod")) |
| 462 | (parser-files (files (by-name sod "parser"))) |
| 463 | (utilities (by-name sod "utilities")) |
| 464 | (sod-frontend (asdf:find-system "sod-frontend")) |
| 465 | (optparse (by-name sod-frontend "optparse")) |
| 466 | (frontend (by-name sod-frontend "frontend")) |
| 467 | (sod-files (set-difference (files sod) (list utilities)))) |
| 468 | (report-symbols (mapcar #'file-name sod-files) "SOD") |
| 469 | (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND") |
| 470 | (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER") |
| 471 | (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE") |
| 472 | (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES")))) |
| 473 | |
| 474 | (defun main () |
| 475 | (with-open-file (*standard-output* #p"doc/SYMBOLS" |
| 476 | :direction :output |
| 477 | :if-exists :supersede |
| 478 | :if-does-not-exist :create) |
| 479 | (report-project-symbols))) |
| 480 | |
| 481 | #+interactive (main) |