chiark - git - mdw - clg/blob - tools/autoexport.lisp

   1 (defpackage "AUTOEXPORT"
   2   (:use "COMMON-LISP")
   3   (:export "LIST-AUTOEXPORTED-SYMBOLS" "LIST-AUTOEXPORTED-SYMBOLS-IN-FILE"
   4            "DEFEXPORT" "EXPORT-FROM-FILE" "INTERNAL"))
   5
   6 (in-package "AUTOEXPORT")
   7
   8 (declaim (special *internal*))
   9
  10 (defvar *export-handlers* (make-hash-table))
  11 (defvar *noexport-prefix* #\%)
  12
  13 (defmacro defexport (operator lambda-list &body body)
  14   `(setf
  15     (gethash ',operator *export-handlers*)
  16     #'(lambda ,lambda-list
  17         ,@body)))
  18
  19 (defmacro internal (&rest symbols)
  20   (declare (ignore symbols))
  21   nil)
  22
  23 (defun list-autoexported-symbols (form)
  24   (let ((handler (gethash (first form) *export-handlers*)))
  25     (when handler
  26       (let ((export (apply handler (cdr form))))
  27         (delete-if
  28          #'(lambda (symbol)
  29              (char= (char (string symbol) 0) *noexport-prefix*))
  30          (if (atom export)
  31              (list export)
  32            export))))))
  33
  34 (defun export-fname (fname)
  35   (if (atom fname)
  36       fname
  37     (second fname)))
  38
  39 (defun list-autoexported-symbols-in-file (file)
  40   (let ((*internal* nil))
  41     (declare (special *internal*))
  42     (with-open-file (in file)
  43       (labels ((read-file (in)
  44                  (let ((form (read in nil nil)))
  45                    (when form
  46                      (delete-if
  47                       #'(lambda (symbol)
  48                           (member symbol *internal*))
  49                       (delete-duplicates
  50                        (nconc
  51                         (list-autoexported-symbols form)
  52                         (read-file in))))))))
  53         (read-file in)))))
  54
  55 (defmacro export-from-file (file)
  56   `(export ',(list-autoexported-symbols-in-file file)))
  57
  58
  59 ;;;; Exporting standard forms
  60
  61 (defexport defun (fname &rest rest)
  62   (declare (ignore rest))
  63   (export-fname fname))
  64
  65 (defexport defvar (name &rest rest)
  66   (declare (ignore rest))
  67   name)
  68
  69 (defexport defconstant (name &rest rest)
  70   (declare (ignore rest))
  71   name)
  72
  73 (defexport defparameter (name &rest rest)
  74   (declare (ignore rest))
  75   name)
  76
  77 (defexport defmacro (name &rest rest)
  78   (declare (ignore rest))
  79   name)
  80
  81 (defexport deftype (name &rest rest)
  82   (declare (ignore rest))
  83   name)
  84
  85 (defun export-defclass-form (class slotdefs)
  86   (cons
  87    class
  88    (apply #'nconc
  89     (map 'list
  90      #'(lambda (slotdef)
  91          (if (symbolp slotdef)
  92              (list slotdef)
  93            (destructuring-bind
  94                (name &key reader writer accessor &allow-other-keys) slotdef
  95              (delete nil (list name reader (export-fname writer) accessor)))))
  96      slotdefs))))
  97
  98 (defexport defclass (class superclasses &optional slotdefs &rest options)
  99   (declare (ignore superclasses options))
 100   (export-defclass-form class slotdefs))
 101
 102 (defexport define-condition (class superclasses &optional slotdefs &rest options)
 103   (declare (ignore superclasses options))
 104   (export-defclass-form class slotdefs))
 105
 106 (defexport defgeneric (fname &rest args)
 107   (declare (ignore args))
 108   (export-fname fname))
 109
 110 (defexport defmethod (name &rest rest)
 111   (declare (ignore rest))
 112   name)
 113
 114 (defexport progn (&rest body)
 115   (apply #'nconc (map 'list #'list-autoexported-symbols body)))
 116
 117 (defexport eval-when (case &rest body)
 118   (declare (ignore case))
 119   (apply #'nconc (map 'list #'list-autoexported-symbols body)))
 120
 121 (defexport internal (&rest symbols)
 122   (setq *internal* (nconc *internal* symbols))
 123   nil)
 124