chiark / gitweb /
Bug fixes and enhancements to the color type
[clg] / 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