3 ;; author: cyrus harmon
8 (defparameter *c-compiler
* "gcc")
10 (defclass clean-op
(operation) ())
12 (defmethod perform ((operation clean-op
) (c component
))
15 (defclass ch-cl-source-file
(cl-source-file) ())
17 (defparameter *fasl-directory
*
18 (make-pathname :directory
'(:relative
#+sbcl
"sbcl-fasl"
19 #+openmcl
"openmcl-fasl"
20 #-
(or sbcl openmcl
) "fasl")))
22 (defmethod source-file-type ((c ch-cl-source-file
) (s module
)) "cl")
24 (defmethod output-files :around
((operation compile-op
) (c ch-cl-source-file
))
25 (list (merge-pathnames *fasl-directory
* (compile-file-pathname (component-pathname c
)))))
27 (defclass ch-lisp-source-file
(cl-source-file) ())
29 (defparameter *fasl-directory
*
30 (make-pathname :directory
'(:relative
#+sbcl
"sbcl-fasl"
31 #+openmcl
"openmcl-fasl"
32 #-
(or sbcl openmcl
) "fasl")))
34 (defmethod output-files :around
((operation compile-op
) (c ch-lisp-source-file
))
35 (list (merge-pathnames *fasl-directory
* (compile-file-pathname (component-pathname c
)))))
37 ;;;; C source file compilation section
38 ;;;; ripped from sb-posix.asd in the sbcl source code
40 (defclass unix-dso
(module)
41 ((dso-name :accessor dso-name
:initarg
:dso-name
)
42 (dso-directory :accessor dso-directory
:initarg
:dso-directory
)
43 (include-directories :accessor include-directories
:initarg
:include-directories
:initform nil
)
44 (link-library-directories :accessor link-library-directories
:initarg
:link-library-directories
:initform nil
)
45 (link-libraries :accessor link-libraries
:initarg
:link-libraries
:initform nil
)
46 (dso-type :accessor dso-type
:initarg
:dso-type
:initform
47 ;; fill appropriate OS specific types in here
51 (defmethod input-files ((operation compile-op
) (dso unix-dso
))
52 (mapcar #'component-pathname
(module-components dso
)))
54 (defmethod output-files ((operation compile-op
) (dso unix-dso
))
55 (let ((dir (component-pathname dso
)))
57 (make-pathname :type
(dso-type dso
)
58 :name
(if (slot-boundp dso
'dso-name
)
60 (car (last (pathname-directory dir
))))
62 ((slot-boundp dso
'dso-directory
)
64 (merge-pathnames (dso-directory dso
)
65 (component-pathname dso
))))
66 (ensure-directories-exist dso-pathname
)
67 (pathname-directory dso-pathname
)))
68 ((and (slot-boundp dso
'dso-name
)
69 (absolute-path-p (dso-name dso
)))
71 (t (butlast (pathname-directory dir
))))
74 (defmethod perform :after
((operation compile-op
) (dso unix-dso
))
75 (let ((dso-name (unix-name (car (output-files operation dso
)))))
81 ;; This really should be specified as an initarg of the unix-dso
82 ;; rather than hard coded here!
83 ;; e.g. :components (... (:unix-library "R" :library-directory *r-dir*))
84 (sb-ext:posix-getenv
"EXTRA_LDFLAGS")
86 (format nil
" ~{-L~A~^ ~} " (link-library-directories dso
))
88 (format nil
" ~{-Xlinker -rpath -Xlinker ~A~^ ~} " (link-library-directories dso
))
89 (format nil
" ~{-l~A~^ ~} " (link-libraries dso
))
90 #+sunos
" -shared -lresolv -lsocket -lnsl "
92 #-
(or darwin sunos
) " -shared ")
96 (output-files operation c
))
97 (module-components dso
)))))
98 (error 'operation-error
:operation operation
:component dso
))))
100 ;;;; Unix executables
102 (defclass unix-executable
(module)
103 ((include-directories :accessor include-directories
:initarg
:include-directories
:initform nil
)
104 (link-library-directories :accessor link-library-directories
:initarg
:link-library-directories
:initform nil
)
105 (link-libraries :accessor link-libraries
:initarg
:link-libraries
:initform nil
)
106 (source-files :accessor source-files
:initarg
:source-files
:initform nil
)))
108 (defmethod input-files ((operation compile-op
) (executable unix-executable
))
109 (declare (optimize (debug 3)))
111 (mapcan #'(lambda (obj)
112 (output-files operation
(get-sibling-component executable obj
)))
113 (source-files executable
))))
114 (append (mapcar #'unix-name files
)
115 (mapcar #'component-pathname
(module-components executable
)))))
117 (defmethod output-files ((operation compile-op
) (executable unix-executable
))
118 (list (component-pathname executable
)))
121 (defmethod operation-done-p ((o compile-op
) (c unix-executable
))
124 (defmethod perform :after
((operation compile-op
) (executable unix-executable
))
125 (let ((executable-name (unix-name (car (output-files operation executable
)))))
128 "~A ~A ~A -o ~S ~{~S ~}"
132 ;; This really should be specified as an initarg of the unix-executable
133 ;; rather than hard coded here!
134 ;; e.g. :components (... (:unix-library "R" :library-directory *r-dir*))
135 (sb-ext:posix-getenv
"EXTRA_LDFLAGS")
137 (format nil
" ~{-L~A~^ ~} " (link-library-directories executable
))
139 (format nil
" ~{-Xlinker -rpath -Xlinker ~A~^ ~} " (link-library-directories executable
))
140 (format nil
" ~{-l~A~^ ~} " (link-libraries executable
))
141 (format nil
" ~{~A~^ ~} " (input-files operation executable
)))
147 (output-files operation c
))
148 (module-components executable
)))))
149 (error 'operation-error
:operation operation
:component executable
))))
151 (defmethod component-depends-on ((op compile-op
) (c unix-executable
))
152 (append (call-next-method)
153 (mapcar #'(lambda (x)
157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159 (defclass c-header-file
(source-file) ())
161 (defmethod perform ((op compile-op
) (c c-header-file
)))
163 (defmethod perform ((op load-op
) (c c-header-file
)))
165 (defmethod source-file-type ((c c-header-file
) (s module
)) "h")
167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
170 ;;; if this goes into the standard asdf, it could reasonably be extended
171 ;;; to allow cflags to be set somehow
172 (defmethod output-files ((op compile-op
) (c c-source-file
))
174 (make-pathname :type
"o" :defaults
175 (component-pathname c
))))
177 (defgeneric get-include-directories
(c))
179 (defmethod get-include-directories ((c c-source-file
))
181 (slot-exists-p (component-parent c
) 'include-directories
)
182 (slot-boundp (component-parent c
) 'include-directories
))
186 (component-parent c
)))))
189 ;;; removed this bit here:
190 ;;; #+nil "~{-isystem ~A~^ ~}"
191 ;;; #+nil (mapcar #'unix-name (system-include-directories c))
193 (defparameter *c-compiler-options
* "-Wall")
195 (defmethod perform ((op compile-op
) (c c-source-file
))
197 (= 0 (run-shell-command
199 (format nil
"~A ~A ~A -o ~S -c ~S"
204 (format nil
"~{-I~A~^ ~}" (get-include-directories c
))
205 " " (sb-ext:posix-getenv
"EXTRA_CFLAGS")
207 (unix-name (car (output-files op c
)))
208 (unix-name (component-pathname c
))))))
209 (error 'operation-error
:operation op
:component c
)))
211 (defmethod perform ((op load-op
) (c c-source-file
)))
214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
217 ;;; NASTY cut-and-paste job here!
219 (defclass asm-source-file
(source-file) ())
221 (defmethod source-file-type ((c asm-source-file
) (s module
)) "s")
223 (defmethod output-files ((op compile-op
) (c asm-source-file
))
225 (make-pathname :type
"o" :defaults
226 (component-pathname c
))))
228 (defgeneric get-include-directories
(c))
230 (defmethod get-include-directories ((c asm-source-file
))
232 (slot-exists-p (component-parent c
) 'include-directories
)
233 (slot-boundp (component-parent c
) 'include-directories
))
237 (component-parent c
)))))
239 (defmethod perform ((op compile-op
) (c asm-source-file
))
241 (= 0 (run-shell-command
243 (format nil
"~A ~A -o ~S -c ~S"
247 (format nil
"~{-I~A~^ ~}" (get-include-directories c
))
248 " " (sb-ext:posix-getenv
"EXTRA_ASMFLAGS")
250 (unix-name (car (output-files op c
)))
251 (unix-name (component-pathname c
))))))
252 (error 'operation-error
:operation op
:component c
)))
254 (defmethod perform ((op load-op
) (c asm-source-file
)))
256 (defmethod perform ((o load-op
) (c unix-dso
))
257 (let ((co (make-instance 'compile-op
)))
258 (let ((filename (car (output-files co c
))))
259 #+cmu
(ext:load-foreign filename
)
260 #+sbcl
(sb-alien:load-shared-object filename
))))
262 ;;;; ASDF hackery for generating components, generated source files
263 ;;;; and other neat stuff.
267 (defclass generate-op
(asdf:operation
) ())
270 ;;; generated-component for components that generate files
271 (defclass generated-component
(asdf:component
) ())
274 (defmethod perform ((op generate-op
) (c component
)))
276 (defmethod perform ((op generate-op
) (c generated-component
)))
278 (defmethod component-depends-on ((op compile-op
) (c generated-component
))
279 (append (call-next-method)
280 `((generate-op ,(component-name c
)))))
282 (defmethod component-depends-on ((op load-op
) (c generated-component
))
283 (append (call-next-method)
284 `((generate-op ,(component-name c
)))))
287 (defmethod perform :before
((operation generate-op
) (c generated-component
))
288 (map nil
#'ensure-directories-exist
(output-files operation c
)))
291 ;;; generated-file - not all components will have files associated
292 ;;; with them. for those that do, use this subclass of
293 ;;; generated-component.
294 (defclass generated-file
(generated-component source-file
) ())
296 (defmethod asdf::component-relative-pathname
((component generated-file
))
297 (let ((relative-pathname (slot-value component
'asdf
::relative-pathname
)))
298 (if relative-pathname
300 (let ((*default-pathname-defaults
*
301 (asdf::component-parent-pathname component
)))
303 :name
(component-name component
))))))
305 (defclass generated-source-file
(generated-file) ())
307 (defmethod operation-done-p ((o operation
) (c generated-source-file
))
308 (let ((in-files (input-files o c
)))
310 (and (every #'probe-file in-files
)
312 (call-next-method))))
314 (defmethod source-file-type ((c generated-file
) (s module
)) "")
316 (defmethod perform ((op compile-op
) (c generated-file
)))
318 (defmethod perform ((op load-op
) (c generated-file
)))
322 (defclass pdf-file
(source-file) ())
323 (defmethod source-file-type ((c pdf-file
) (s module
)) "pdf")
325 (defmethod perform ((operation compile-op
) (c pdf-file
)))
327 (defmethod perform ((operation load-op
) (c pdf-file
))
328 (ch-util::app-open
(unix-name (component-pathname c
))))
330 (defmethod operation-done-p ((o load-op
) (c pdf-file
))
336 (defclass css-file
(static-file) ())
337 (defmethod source-file-type ((c css-file
) (s module
)) "css")
341 (defclass xhtml-file
(html-file) ())
342 (defmethod source-file-type ((c xhtml-file
) (s module
)) "xhtml")
346 (defclass tiff-file
(static-file) ())
347 (defmethod source-file-type ((c tiff-file
) (s module
)) "tiff")
351 (defclass jpeg-file
(static-file) ())
352 (defmethod source-file-type ((c jpeg-file
) (s module
)) "jpg")
356 (defclass png-file
(static-file) ())
357 (defmethod source-file-type ((c png-file
) (s module
)) "png")
361 (defclass markup-file
(source-file) ())
362 (defmethod source-file-type ((c markup-file
) (s module
)) "gmarkup")
364 (defclass markup-latex-file
(generated-source-file) ())
365 (defmethod source-file-type ((c markup-latex-file
) (s module
)) "tex")
367 (defclass markup-pdf-file
(pdf-file generated-source-file
) ())
368 (defclass markup-xhtml-file
(xhtml-file) ())
370 ;;; tinaa documentation
372 (defclass tinaa-directory
(module) ())
374 ;;; Need a generic ASDF object that reads a file and associates an
375 ;;; in-memory object with the file. It should cache the creation date
376 ;;; of the object and reload the object if the modification date of
377 ;;; the file is newer than the creation date of the in-memory object.
379 (defun get-sibling-component (comp sib
)
380 (asdf:find-component
(asdf:component-parent comp
)
381 (asdf::coerce-name sib
)))
383 (defclass object-component
(generated-component)
384 ((symbol :accessor object-symbol
:initarg
:symbol
)))
386 (defmethod operation-done-p ((o generate-op
) (c object-component
))
389 (defmethod source-file-type ((c object-component
) (s module
)) nil
)
391 (defun make-symbol-from-name (name)
392 (intern (string (read-from-string name
))))
394 (defmethod shared-initialize :after
((c object-component
) slot-names
397 (declare (ignore force
))
398 (when (slot-boundp c
'asdf
::name
)
399 (unless (slot-boundp c
'symbol
)
400 (setf (object-symbol c
)
401 (make-symbol-from-name (asdf::component-name c
))))))
403 (defmethod perform ((op compile-op
) (c object-component
)))
404 (defmethod perform ((op load-op
) (c object-component
))
405 (setf (component-property c
'last-loaded
)
406 (get-universal-time)))
408 (defmethod operation-done-p ((o compile-op
) (c object-component
))
411 (defmethod operation-done-p ((o load-op
) (comp object-component
))
413 (loop for
(dep-op dep-comp
) in
414 (asdf::component-depends-on o comp
)
415 collect
(asdf::operation-done-p
416 (make-instance dep-op
)
417 (get-sibling-component comp dep-comp
)))))
419 ;;; An object-from-file is the file-based representation of an object. The
421 (defclass object-from-file
(object-component source-file
)
422 ((load-date :accessor object-load-date
:initarg
:load-date
)))
424 (defmethod perform ((op compile-op
) (c object-from-file
))
425 (setf (asdf:component-property c
'last-compiled
)
426 (get-universal-time))
427 (with-open-file (input-stream (component-pathname c
))
428 (setf (symbol-value (object-symbol c
))
429 (read input-stream
)))
432 (defmethod perform ((op generate-op
) (c object-from-file
))
433 (setf (asdf::component-property c
'last-generated
)
434 (get-universal-time)))
436 ;;; this needs to check the file date!!!!
437 (defmethod operation-done-p ((o generate-op
) (c object-from-file
))
439 (file-write-date (component-pathname c
)))
440 (my-last-load-time (asdf::component-property c
'last-loaded
)))
443 (>= my-last-load-time on-disk-time
))))
446 (defclass object-to-file
(object-component)
447 ((write-date :accessor object-write-date
:initarg
:write-date
)))
450 (defclass object-from-variable
(object-component)
451 ((input-object :accessor object-input-object
:initarg
:input-object
)))
453 (defmethod component-depends-on ((op generate-op
) (c object-from-variable
))
454 (append (call-next-method)
455 `((load-op , (asdf::coerce-name
(object-input-object c
))))))
457 (defmethod component-depends-on ((op compile-op
) (c object-from-variable
))
458 (append (call-next-method)
459 `((load-op ,(asdf::coerce-name
(object-input-object c
))))))
461 (defmethod operation-done-p ((o generate-op
) (c object-from-variable
))
462 (let ((input-object-last-load-time
463 (asdf::component-property
464 (find-component (component-parent c
)
465 (asdf::coerce-name
(object-input-object c
)))
467 (my-last-generate-time (asdf::component-property c
'last-generated
)))
468 (and input-object-last-load-time
469 my-last-generate-time
470 (>= my-last-generate-time input-object-last-load-time
))))
472 (defmethod operation-done-p ((o compile-op
) (c object-from-variable
))
473 (let ((my-last-generate-time (asdf::component-property c
'last-generated
))
474 (my-last-compile-time (asdf::component-property c
'last-compiled
)))
475 (and my-last-generate-time
477 (>= my-last-compile-time my-last-generate-time
))))
479 (defmethod operation-done-p ((o load-op
) (c object-from-variable
))
480 (let ((my-last-compile-time (asdf::component-property c
'last-compiled
))
481 (my-last-load-time (asdf::component-property c
'last-loaded
)))
482 (and my-last-compile-time
484 (>= my-last-load-time my-last-compile-time
))))
486 (defmethod perform ((op generate-op
) (c object-from-variable
))
487 (setf (asdf:component-property c
'last-generated
)
488 (get-universal-time))
492 (find-component (component-parent c
)
493 (asdf::coerce-name
(object-input-object c
)))))))
494 (setf (symbol-value (object-symbol c
)) sexp
)))
497 (defmethod perform ((op compile-op
) (c object-from-variable
))
498 (setf (asdf:component-property c
'last-compiled
)
499 (get-universal-time)))
501 (defmethod perform ((op load-op
) (c object-from-variable
))
502 (setf (asdf:component-property c
'last-loaded
)
503 (get-universal-time)))
505 (defclass load-only-file-mixin
()
508 (defclass load-only-cl-source-file
(load-only-file-mixin cl-source-file
)
511 (defmethod perform ((op compile-op
) (component load-only-file-mixin
))
514 (defmethod perform ((op load-op
) (component load-only-cl-source-file
))
515 (load (component-pathname component
)))
517 ;;; graphviz dot-files
519 (defparameter *dot-program
* "dot")
520 (defparameter *dot-program-path
*
521 (let ((found (sb-ext:find-executable-in-search-path
525 #+darwin
"/opt/local/bin/dot"
526 #-darwin
"/usr/local/bin/dot"))
529 (defclass graphviz-dot-file
(generated-source-file) ())
531 (defmethod source-file-type ((c graphviz-dot-file
) (s module
)) "dot")
533 (defmethod output-files ((operation compile-op
) (c graphviz-dot-file
))
535 (merge-pathnames (make-pathname :type
"png")
536 (compile-file-pathname (component-pathname c
)))))
538 (defmethod perform ((op compile-op
) (c graphviz-dot-file
))
543 (ch-asdf:unix-name
(car (output-files op c
)))
544 (ch-asdf:unix-name
(component-pathname c
))))
547 ;;; benchmarking stuff
549 (defclass benchmark-op
(operation) ())
551 (defmethod perform ((operation benchmark-op
) (c component
))