chiark / gitweb /
Force asdf to call the C source file blah.c, rather than just blah. I'm
[clg] / tools / asdf-extensions.lisp
CommitLineData
77dd2192 1(in-package :asdf)
2
b33bdd39 3(eval-when (:load-toplevel :compile-toplevel :execute)
4 (use-package :pkg-config))
34abe734 5
b33bdd39 6(export '(*search-library-path-on-reload* *dso-extension*
7 *operation* *system* *component* library shared-object
8 install-init-hook))
9
10(defvar *dso-extension*
e6ab30c2 11 #-(or darwin win32)"so" #+darwin"dylib" #+win32"dll")
34abe734 12
b33bdd39 13(defvar *search-library-path-on-reload* t)
14
15
16;;; Since Common Lisp implementations doesn't seem to agree on how to
17;;; run init hooks, we have to add our own compatibility layer.
18
19(defvar *init-hooks* ())
20
21(defun install-init-hook (func &optional (only-once t))
22 (if only-once
23 (pushnew func *init-hooks*)
24 (push func *init-hooks*)))
25
26(defun run-init-hooks ()
27 (mapcar #'funcall (reverse *init-hooks*)))
28
29(pushnew 'run-init-hooks
30 #+cmu ext:*after-save-initializations*
31 #+sbcl sb-ext:*init-hooks*
32 #+clisp custom:*init-hooks*)
33
34(defvar *reload-shared-objects* ()
35 "List of shared objects which should be reloaded from library search
36 path in saved images.")
37
38#?-(sbcl>= 1 0 22)
39(defvar *dont-save-shared-objects* ()
40 "List of shared objects which should not be saved in images.")
41
42(defun namestring-name (namestring)
43 (let ((pos (position #\/ namestring :from-end t)))
44 (if pos
45 (subseq namestring (1+ pos))
46 namestring)))
47
48(defun load-shared-object (pathname &optional dont-save-p (reload-p dont-save-p))
49 (let* ((namestring (ensure-namestring pathname)))
50 #?(sbcl< 1 0 22)(sb-alien:load-shared-object namestring)
51 #?(sbcl>= 1 0 22)
52 (sb-alien:load-shared-object namestring :dont-save dont-save-p)
53 #+cmu(ext:load-foreign namestring)
54 #?(clisp< 2 45)(ffi::foreign-library namestring)
55 #?(clisp>= 2 45)(ffi:open-foreign-library namestring)
56 (when dont-save-p
57 #?-(sbcl>= 1 0 22)
58 (pushnew namestring *dont-save-shared-objects* :test #'string=)
59 (when reload-p
60 (pushnew (namestring-name namestring)
61 *reload-shared-objects* :test #'string=)))))
62
63#?(or (sbcl< 1 0 22) (featurep :cmu))
64(progn
65 (defun remove-shared-objects ()
66 (dolist (namestring *dont-save-shared-objects*)
67 #+sbcl
68 (setf sb-alien::*shared-objects*
69 (remove namestring sb-alien::*shared-objects*
70 :key #'sb-alien::shared-object-file
71 :test #'string=))
72 #+cmu
73 (setf system::*global-table*
74 (remove namestring system::*global-table*
75 :key #'cdr :test #'string=))))
76 (pushnew 'remove-shared-objects
77 #+sbcl sb-ext:*save-hooks*
78 #+cmu ext:*before-save-initializations*))
79
80(defun reload-shared-objects ()
81 (handler-bind (#+sbcl (style-warning #'muffle-warning))
82 (dolist (namestring (reverse *reload-shared-objects*))
83 (load-shared-object namestring))))
84
85(install-init-hook 'reload-shared-objects)
86
87
1a9c1e08 88
57f6526c 89;;; The following code is more or less copied from sb-bsd-sockets.asd,
90;;; but extended to allow flags to be set in a general way. The class
b133c3a7 91;;; has been renamed from unix-dso to shared-object as this code is no
92;;; longer specific to unix
77dd2192 93
57f6526c 94(defclass shared-object (module)
b133c3a7 95 ((ldflags :initform nil :initarg :ldflags)
b33bdd39 96 (search :initform *search-library-path-on-reload* :initarg :search
97 :reader search-library-path-on-reload)))
57f6526c 98
99(defun ensure-namestring (pathname)
77dd2192 100 (namestring
101 (typecase pathname
102 (logical-pathname (translate-logical-pathname pathname))
103 (t pathname))))
104
57f6526c 105(defmethod input-files ((operation compile-op) (dso shared-object))
77dd2192 106 (mapcar #'component-pathname (module-components dso)))
107
57f6526c 108(defmethod output-files ((operation compile-op) (dso shared-object))
77dd2192 109 (let ((dir (component-pathname dso)))
110 (list
34abe734 111 (make-pathname :type *dso-extension*
b6f51030 112 :name (component-name dso)
77dd2192 113 :directory (butlast (pathname-directory dir))
114 :defaults dir))))
115
57f6526c 116(defmethod perform :after ((operation compile-op) (dso shared-object))
a4263d6d 117 (let ((output (first (output-files operation dso)))
57f6526c 118 (inputs (mapcar #'ensure-namestring
a4263d6d 119 (mapcan #'(lambda (c)
120 (output-files operation c))
121 (module-components dso)))))
77dd2192 122 (unless (zerop
e6ab30c2 123 (run-shell-command "gcc ~A -o ~S ~{~S~^ ~} ~{~A~^ ~}"
124 #-(or darwin win32)"-shared"
a4263d6d 125 #+darwin "-bundle"
126 #+win32
127 (format nil "-shared -Wl,--out-implib,~S"
57f6526c 128 (ensure-namestring
a4263d6d 129 (make-pathname
130 :type "a"
131 :name (format nil "lib~Adll" (pathname-name output))
132 :defaults output)))
57f6526c 133 (ensure-namestring output)
e6ab30c2 134 inputs
135 (slot-value dso 'ldflags)))
77dd2192 136 (error 'operation-error :operation operation :component dso))))
137
b133c3a7 138(defmethod perform ((o load-op) (dso shared-object))
77dd2192 139 (let ((co (make-instance 'compile-op)))
b133c3a7 140 (let ((pathname (car (output-files co dso))))
b33bdd39 141 (load-shared-object pathname (search-library-path-on-reload dso)))))
77dd2192 142
143
144
145(defclass c-source-file (source-file)
146 ((cflags :initform nil :initarg :cflags)
147 (optimization :initform 2 :initarg :optimization)
148 (definitions :initform nil :initarg :definitions)
149 (include-paths :initform nil :initarg :include-paths)))
150
151
152(defmethod output-files ((op compile-op) (c c-source-file))
73572c12 153 (list (make-pathname :type "o" :defaults (component-pathname c))))
77dd2192 154
1bf1bfc9
RS
155(defmethod component-pathname ((c c-source-file))
156 (make-pathname :type "c" :name (component-name c)
157 :directory (pathname-directory (call-next-method))))
77dd2192 158
159(defmethod perform ((op compile-op) (c c-source-file))
160 (unless
fb1753d9 161 (= 0 (run-shell-command "gcc -Wall ~A~{ ~A~} -o ~S -c ~S"
a4263d6d 162 #-win32 "-fPIC"
163 #+win32 "-DBUILD_DLL"
164 (nconc
165 (when (slot-value c 'optimization)
166 (list (format nil "-O~A" (slot-value c 'optimization))))
167 (loop
168 for symbol in (slot-value c 'definitions)
169 collect (format nil "-D~A" symbol))
170 (loop
171 for path in (slot-value c 'include-paths)
172 collect (format nil "-I~A" path))
173 (slot-value c 'cflags))
57f6526c 174 (ensure-namestring (first (output-files op c)))
175 (ensure-namestring (component-pathname c))))
77dd2192 176 (error 'operation-error :operation op :component c)))
177
178
179(defmethod perform ((operation load-op) (c c-source-file))
180 t)
181
182
fd9d29a4 183;;; Shared libraries
1a9c1e08 184
fd9d29a4 185(defclass library (component)
57f6526c 186 ((libdir :initarg :libdir :initform nil)
b133c3a7 187 (libname :initarg :libname :initform nil)
b33bdd39 188 (search :initform *search-library-path-on-reload* :initarg :search
189 :reader search-library-path-on-reload)))
1a9c1e08 190
191
3e9e71e7 192(defun split-path (path)
fb1753d9 193 (when path
194 (labels ((split (path)
195 (unless (zerop (length path))
196 (let ((slash (position #\/ path)))
197 (if slash
198 (cons (subseq path 0 slash) (split (subseq path (1+ slash))))
199 (list path))))))
200 (if (and (not (zerop (length path))) (char= (char path 0) #\/))
201 (cons :absolute (split (subseq path 1)))
202 (cons :relative (split path))))))
203
1a9c1e08 204
205(defmethod component-pathname ((lib library))
fb1753d9 206 (or
207 (when (slot-value lib 'libname)
208 (let ((filename (format nil "~A~A" (namestring (make-pathname :directory (split-path (slot-value lib 'libdir)))) (slot-value lib 'libname))))
209 (when (probe-file filename)
210 (pathname filename))))
211
212 (make-pathname
213 :type *dso-extension*
214 :name (or (slot-value lib 'libname) (component-name lib))
215 :directory (split-path (slot-value lib 'libdir)))))
1a9c1e08 216
b33bdd39 217
218(defvar *loaded-libraries* ())
219
b133c3a7 220(defmethod perform ((o load-op) (lib library))
b33bdd39 221 (load-shared-object (component-pathname lib)
222 (search-library-path-on-reload lib))
223 (pushnew lib *loaded-libraries*))
fd9d29a4 224
b133c3a7 225(defmethod perform ((operation operation) (lib library))
fd9d29a4 226 nil)
227
b133c3a7 228(defmethod operation-done-p ((o load-op) (lib library))
b33bdd39 229 (find lib *loaded-libraries*))
fd9d29a4 230
b133c3a7 231(defmethod operation-done-p ((o operation) (lib library))
fd9d29a4 232 t)
90309986 233
234
235;;; Binding of dynamic variables during perform
236
237(defvar *operation* nil)
238(defvar *system* nil)
239(defvar *component* nil)
240
241(defmethod perform :around ((operation operation) (c component))
242 (let ((*operation* operation)
243 (*component* c)
244 (*system* (component-system c)))
245 (call-next-method)))