chiark / gitweb /
Show Cairo version instead of Gtk+ version
[clg] / tools / asdf-extensions.lisp
1 (in-package :asdf)
2
3 (export '(*dso-extension* *operation* *system* *component*))
4
5 (defparameter *dso-extension* 
6  #-(or darwin win32)"so" #+darwin"dylib" #+win32"dll")
7
8
9 ;;; The following code is more or less copied from sb-bsd-sockets.asd,
10 ;;; but extended to allow flags to be set in a general way. The class
11 ;;; has been renamed from unix-dso to shared-object as this code is no
12 ;;; longer specific to unix
13
14 (defclass shared-object (module)
15   ((ldflags :initform nil :initarg :ldflags)
16    (absolute :initform nil :initarg :absolute :reader absolute-p)))
17
18 (defun ensure-namestring (pathname)
19   (namestring 
20    (typecase pathname
21      (logical-pathname (translate-logical-pathname pathname))
22      (t pathname))))
23
24 (defmethod input-files ((operation compile-op) (dso shared-object))
25   (mapcar #'component-pathname (module-components dso)))
26
27 (defmethod output-files ((operation compile-op) (dso shared-object))
28   (let ((dir (component-pathname dso)))
29     (list
30      (make-pathname :type *dso-extension*
31                     :name (component-name dso)
32                     :directory (butlast (pathname-directory dir))
33                     :defaults dir))))
34
35 (defmethod perform :after ((operation compile-op) (dso shared-object))
36   (let ((output (first (output-files operation dso)))
37         (inputs (mapcar #'ensure-namestring
38                  (mapcan #'(lambda (c)
39                              (output-files operation c))
40                   (module-components dso)))))
41     (unless (zerop
42              (run-shell-command "gcc ~A -o ~S ~{~S~^ ~} ~{~A~^ ~}"
43               #-(or darwin win32)"-shared"
44               #+darwin "-bundle"
45               #+win32
46               (format nil "-shared -Wl,--out-implib,~S"
47                (ensure-namestring
48                 (make-pathname 
49                  :type "a" 
50                  :name (format nil "lib~Adll" (pathname-name output))
51                  :defaults output)))
52               (ensure-namestring output)
53               inputs
54               (slot-value dso 'ldflags)))
55       (error 'operation-error :operation operation :component dso))))
56
57 #+clisp
58 (defvar *loaded-libraries* ())
59
60 (defun load-shared-object (pathname &optional (absolute-p t))
61   (let* ((namestring (ensure-namestring pathname))
62          (directory (namestring (pathname-sans-name+type namestring)))
63          (name+type (subseq namestring (length directory))))
64     #+sbcl
65     (progn
66       (sb-alien:load-shared-object namestring)
67       (unless absolute-p
68         (let ((shared-object (find namestring sb-alien::*shared-objects* 
69                               :key #'sb-alien::shared-object-file 
70                               :test #'equal)))
71           (setf (sb-alien::shared-object-file shared-object) name+type))))
72     #+cmu
73     (progn
74       (ext:load-foreign namestring)
75       (unless absolute-p
76         (let ((shared-object (rassoc namestring system::*global-table* 
77                               :test #'equal)))
78           (setf (cdr shared-object) name+type))))
79     #+clisp 
80     (progn
81       (ffi::foreign-library namestring)
82       (pushnew 
83        (if absolute-p namestring name+type)
84        *loaded-libraries* :test #'string=))))
85
86
87 (defmethod perform ((o load-op) (dso shared-object))
88   (let ((co (make-instance 'compile-op)))
89     (let ((pathname (car (output-files co dso))))
90       (load-shared-object pathname (absolute-p dso)))))
91
92
93
94 (defclass c-source-file (source-file) 
95   ((cflags :initform nil :initarg :cflags)
96    (optimization :initform 2 :initarg :optimization)
97    (definitions :initform nil :initarg :definitions)
98    (include-paths :initform nil :initarg :include-paths)))
99
100
101 (defmethod output-files ((op compile-op) (c c-source-file))
102   (list (make-pathname :type "o" :defaults (component-pathname c))))
103
104
105 (defmethod perform ((op compile-op) (c c-source-file))
106   (unless
107       (= 0 (run-shell-command "gcc ~A~{ ~A~} -o ~S -c ~S"
108             #-win32 "-fPIC"
109             #+win32 "-DBUILD_DLL"
110             (nconc
111              (when (slot-value c 'optimization)
112                (list (format nil "-O~A" (slot-value c 'optimization))))
113              (loop 
114               for symbol in (slot-value c 'definitions)
115               collect (format nil "-D~A" symbol))
116              (loop 
117               for path in (slot-value c 'include-paths)
118               collect (format nil "-I~A" path))
119              (slot-value c 'cflags))
120             (ensure-namestring (first (output-files op c)))
121             (ensure-namestring (component-pathname c))))
122     (error 'operation-error :operation op :component c)))
123
124
125 (defmethod perform ((operation load-op) (c c-source-file))
126   t)
127   
128
129 ;;; Shared libraries
130
131 (defclass library (component) 
132   ((libdir :initarg :libdir :initform nil)
133    (libname :initarg :libname :initform nil)
134    (absolute :initform nil :initarg :absolute :reader absolute-p)))
135
136
137 (defun split-path (path)
138   (labels ((split (path)
139              (unless (zerop (length path))
140                (let ((slash (position #\/ path)))
141                  (if slash
142                      (cons (subseq path 0 slash) (split (subseq path (1+ slash))))
143                    (list path))))))
144     (if (and (not (zerop (length path))) (char= (char path 0) #\/))
145         (cons :absolute (split (subseq path 1)))
146       (cons :relative (split path)))))
147
148
149 (defmethod component-pathname ((lib library))
150   (make-pathname :type *dso-extension*
151                  :name (or (slot-value lib 'libname) (component-name lib))
152                  :directory (split-path (slot-value lib 'libdir))))
153
154 (defmethod perform ((o load-op) (lib library))
155   (load-shared-object (component-pathname lib) (absolute-p lib)))
156
157 (defmethod perform ((operation operation) (lib library))
158   nil)
159
160 (defmethod operation-done-p ((o load-op) (lib library))
161   (let* ((namestring (ensure-namestring (component-pathname lib)))
162          (directory (namestring (pathname-sans-name+type namestring)))
163          (name+type (subseq namestring (length directory)))
164          (stored-name (if (absolute-p lib) namestring name+type)))
165
166     #+sbcl(find stored-name sb-alien::*shared-objects* :key #'sb-alien::shared-object-file :test #'equal)
167     #+cmu(rassoc stored-name system::*global-table* :test #'equal)
168     #+clisp(find stored-name *loaded-libraries* :test #'equal)))
169
170 (defmethod operation-done-p ((o operation) (lib library))
171   t)
172
173
174 ;;; Binding of dynamic variables during perform
175
176 (defvar *operation* nil)
177 (defvar *system* nil)
178 (defvar *component* nil)
179
180 (defmethod perform :around ((operation operation) (c component))
181   (let ((*operation* operation)
182         (*component* c)
183         (*system* (component-system c)))
184     (call-next-method)))