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" "EXPORT-FROM-FILES" "INTERNAL"
   5            "WITH-EXPORT-HANDLERS" "EXPORT-HANDLER-MAKUNBOUND"
   6            "EXPORT-DEFCLASS-FORM" "EXPORT-FROM-SYSTEM"))
   7
   8 (in-package "AUTOEXPORT")
   9
  10 (declaim (special *internal*))
  11
  12 (defvar *export-handlers* (make-hash-table))
  13 (defvar *noexport-prefix* #\%)
  14
  15 (defmacro defexport (operator lambda-list &body body)
  16   `(setf
  17     (gethash ',operator *export-handlers*)
  18     #'(lambda ,lambda-list
  19         ,@body)))
  20
  21 (defmacro internal (&rest symbols)
  22   (declare (ignore symbols))
  23   nil)
  24
  25 (defun export-handler-makunbound (handler)
  26   (remhash handler *export-handlers*))
  27
  28 (defun list-autoexported-symbols (form)
  29   (let ((handler (gethash (first form) *export-handlers*)))
  30     (when handler
  31       (let ((export (apply handler (cdr form))))
  32         (delete-if
  33          #'(lambda (symbol)
  34              (char= (char (string symbol) 0) *noexport-prefix*))
  35          (if (atom export)
  36              (list export)
  37            export))))))
  38
  39 (defun export-fname (fname)
  40   (if (atom fname)
  41       fname
  42     (second fname)))
  43
  44 (defun list-autoexported-symbols-in-file (file)
  45   (let ((*internal* nil))
  46     (declare (special *internal*))
  47     (with-open-file (in file)
  48       (labels ((read-file (in)
  49                  (let ((form (read in nil nil)))
  50                    (when form
  51                      (delete-if
  52                       #'(lambda (symbol)
  53                           (member symbol *internal*))
  54                       (delete-duplicates
  55                        (nconc
  56                         (list-autoexported-symbols form)
  57                         (read-file in))))))))
  58         (read-file in)))))
  59
  60 (defmacro export-from-file (file &optional package)
  61   (if package
  62       `(export ',(list-autoexported-symbols-in-file file) ,package)
  63     `(export ',(list-autoexported-symbols-in-file file))))
  64
  65 (defmacro export-from-files (files &optional package)
  66   `(progn
  67      ,@(loop for file in files collect `(export-from-file ,file ,package))))
  68
  69 (defmacro export-from-system (&optional package)
  70   (let ((depends-on (cdar (asdf:component-depends-on asdf:*operation* asdf:*component*))))
  71     `(progn
  72        ,@(loop
  73           for component in depends-on
  74           as pathname = (asdf:component-pathname
  75                          (asdf:find-component asdf:*system* component))
  76           collect `(export-from-file ,pathname ,package)))))
  77
  78 (defun copy-hash-table (hash-table)
  79   (let ((new-hash-table (make-hash-table
  80                          :test (hash-table-test hash-table)
  81                          :size (hash-table-size hash-table))))
  82     (maphash
  83      #'(lambda (key value)
  84          (setf (gethash key new-hash-table) value))
  85      hash-table)
  86     new-hash-table))
  87
  88 (defmacro with-export-handlers (&body body)
  89   `(let ((*export-handlers* (copy-hash-table *export-handlers*)))
  90      ,@body))
  91
  92
  93 ;;;; Exporting standard forms
  94
  95 (defexport defun (fname &rest rest)
  96   (declare (ignore rest))
  97   (export-fname fname))
  98
  99 (defexport defvar (name &rest rest)
 100   (declare (ignore rest))
 101   name)
 102
 103 (defexport defconstant (name &rest rest)
 104   (declare (ignore rest))
 105   name)
 106
 107 (defexport defparameter (name &rest rest)
 108   (declare (ignore rest))
 109   name)
 110
 111 (defexport defmacro (name &rest rest)
 112   (declare (ignore rest))
 113   name)
 114
 115 (defexport deftype (name &rest rest)
 116   (declare (ignore rest))
 117   name)
 118
 119 (defun export-defclass-form (class slotdefs &optional (export-slots-p t))
 120   (cons
 121    class
 122    (apply #'nconc
 123     (map 'list
 124      #'(lambda (slotdef)
 125          (if (symbolp slotdef)
 126              (list slotdef)
 127            (destructuring-bind
 128                (name &key reader writer accessor &allow-other-keys) slotdef
 129              (delete nil (list (when export-slots-p name) reader (export-fname writer) accessor)))))
 130      slotdefs))))
 131
 132 (defexport defclass (class superclasses &optional slotdefs &rest options)
 133   (declare (ignore superclasses options))
 134   (export-defclass-form class slotdefs))
 135
 136 (defexport define-condition (class superclasses &optional slotdefs &rest options)
 137   (declare (ignore superclasses options))
 138   (export-defclass-form class slotdefs))
 139
 140 (defexport defgeneric (fname &rest args)
 141   (declare (ignore args))
 142   (export-fname fname))
 143
 144 ;; (defexport defmethod (name &rest rest)
 145 ;;   (declare (ignore rest))
 146 ;;   name)
 147
 148 (defexport progn (&rest body)
 149   (apply #'nconc (map 'list #'list-autoexported-symbols body)))
 150
 151 (defexport eval-when (case &rest body)
 152   (declare (ignore case))
 153   (apply #'nconc (map 'list #'list-autoexported-symbols body)))
 154
 155 (defexport internal (&rest symbols)
 156   (setq *internal* (nconc *internal* symbols))
 157   nil)
 158