chiark / gitweb /
Mde autoexport dependent on asdf-extensions
[clg] / tools / autoexport.lisp
CommitLineData
560af5c5 1(defpackage "AUTOEXPORT"
2 (:use "COMMON-LISP")
3 (:export "LIST-AUTOEXPORTED-SYMBOLS" "LIST-AUTOEXPORTED-SYMBOLS-IN-FILE"
f3808390 4 "DEFEXPORT" "EXPORT-FROM-FILE" "EXPORT-FROM-FILES" "INTERNAL"
5 "WITH-EXPORT-HANDLERS" "EXPORT-HANDLER-MAKUNBOUND"
6 "EXPORT-DEFCLASS-FORM"))
560af5c5 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
f3808390 25(defun export-handler-makunbound (handler)
26 (remhash handler *export-handlers*))
27
560af5c5 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
f3808390 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
560af5c5 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
f3808390 110(defun export-defclass-form (class slotdefs &optional (export-slots-p t))
560af5c5 111 (cons
112 class
aee2ecd4 113 (apply #'nconc
114 (map 'list
560af5c5 115 #'(lambda (slotdef)
116 (if (symbolp slotdef)
117 (list slotdef)
118 (destructuring-bind
119 (name &key reader writer accessor &allow-other-keys) slotdef
f3808390 120 (delete nil (list (when export-slots-p name) reader (export-fname writer) accessor)))))
560af5c5 121 slotdefs))))
122
aee2ecd4 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
560af5c5 131(defexport defgeneric (fname &rest args)
132 (declare (ignore args))
133 (export-fname fname))
134
f3808390 135;; (defexport defmethod (name &rest rest)
136;; (declare (ignore rest))
137;; name)
573086fb 138
560af5c5 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