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 (defexport defclass (class superclasses &optional slotdefs &rest options)
  86   (declare (ignore superclasses options))
  87   (cons
  88    class
  89    (apply
  90     #'nconc
  91     (map
  92      'list
  93      #'(lambda (slotdef)
  94          (if (symbolp slotdef)
  95              (list slotdef)
  96            (destructuring-bind
  97                (name &key reader writer accessor &allow-other-keys) slotdef
  98              (delete nil (list name reader (export-fname writer) accessor)))))
  99      slotdefs))))
 100
 101 (defexport defgeneric (fname &rest args)
 102   (declare (ignore args))
 103   (export-fname fname))
 104
 105 (defexport defmethod (name &rest rest)
 106   (declare (ignore rest))
 107   name)
 108
 109 (defexport progn (&rest body)
 110   (apply #'nconc (map 'list #'list-autoexported-symbols body)))
 111
 112 (defexport eval-when (case &rest body)
 113   (declare (ignore case))
 114   (apply #'nconc (map 'list #'list-autoexported-symbols body)))
 115
 116 (defexport internal (&rest symbols)
 117   (setq *internal* (nconc *internal* symbols))
 118   nil)
 119