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"))
   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 (defun copy-hash-table (hash-table)
  70   (let ((new-hash-table (make-hash-table
  71                          :test (hash-table-test hash-table)
  72                          :size (hash-table-size hash-table))))
  73     (maphash
  74      #'(lambda (key value)
  75          (setf (gethash key new-hash-table) value))
  76      hash-table)
  77     new-hash-table))
  78
  79 (defmacro with-export-handlers (&body body)
  80   `(let ((*export-handlers* (copy-hash-table *export-handlers*)))
  81      ,@body))
  82
  83
  84 ;;;; Exporting standard forms
  85
  86 (defexport defun (fname &rest rest)
  87   (declare (ignore rest))
  88   (export-fname fname))
  89
  90 (defexport defvar (name &rest rest)
  91   (declare (ignore rest))
  92   name)
  93
  94 (defexport defconstant (name &rest rest)
  95   (declare (ignore rest))
  96   name)
  97
  98 (defexport defparameter (name &rest rest)
  99   (declare (ignore rest))
 100   name)
 101
 102 (defexport defmacro (name &rest rest)
 103   (declare (ignore rest))
 104   name)
 105
 106 (defexport deftype (name &rest rest)
 107   (declare (ignore rest))
 108   name)
 109
 110 (defun export-defclass-form (class slotdefs &optional (export-slots-p t))
 111   (cons
 112    class
 113    (apply #'nconc
 114     (map 'list
 115      #'(lambda (slotdef)
 116          (if (symbolp slotdef)
 117              (list slotdef)
 118            (destructuring-bind
 119                (name &key reader writer accessor &allow-other-keys) slotdef
 120              (delete nil (list (when export-slots-p name) reader (export-fname writer) accessor)))))
 121      slotdefs))))
 122
 123 (defexport defclass (class superclasses &optional slotdefs &rest options)
 124   (declare (ignore superclasses options))
 125   (export-defclass-form class slotdefs))
 126
 127 (defexport define-condition (class superclasses &optional slotdefs &rest options)
 128   (declare (ignore superclasses options))
 129   (export-defclass-form class slotdefs))
 130
 131 (defexport defgeneric (fname &rest args)
 132   (declare (ignore args))
 133   (export-fname fname))
 134
 135 ;; (defexport defmethod (name &rest rest)
 136 ;;   (declare (ignore rest))
 137 ;;   name)
 138
 139 (defexport progn (&rest body)
 140   (apply #'nconc (map 'list #'list-autoexported-symbols body)))
 141
 142 (defexport eval-when (case &rest body)
 143   (declare (ignore case))
 144   (apply #'nconc (map 'list #'list-autoexported-symbols body)))
 145
 146 (defexport internal (&rest symbols)
 147   (setq *internal* (nconc *internal* symbols))
 148   nil)
 149