chiark / gitweb /
Add a boundp-function slot, which is required by virtual slot getter.
[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" "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