chiark / gitweb /
Initial revision
[clg] / tools / autoexport.lisp
CommitLineData
560af5c5 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 progn (&rest body)
106 (apply #'nconc (map 'list #'list-autoexported-symbols body)))
107
108(defexport eval-when (case &rest body)
109 (declare (ignore case))
110 (apply #'nconc (map 'list #'list-autoexported-symbols body)))
111
112(defexport internal (&rest symbols)
113 (setq *internal* (nconc *internal* symbols))
114 nil)
115