external/ch-asdf/src/ch-asdf.cl

   1 ;;
   2 ;; file: ch-asdf.cl
   3 ;; author: cyrus harmon
   4 ;;
   5
   6 (in-package :ch-asdf)
   7
   8 (defparameter *c-compiler* "gcc")
   9
  10 (defclass clean-op (operation) ())
  11
  12 (defmethod perform ((operation clean-op) (c component))
  13   nil)
  14
  15 (defclass ch-cl-source-file (cl-source-file) ())
  16
  17 (defparameter *fasl-directory*
  18   (make-pathname :directory '(:relative #+sbcl "sbcl-fasl"
  19                               #+openmcl "openmcl-fasl"
  20                               #-(or sbcl openmcl) "fasl")))
  21
  22 (defmethod source-file-type ((c ch-cl-source-file) (s module)) "cl")
  23
  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)))))
  26
  27 (defclass ch-lisp-source-file (cl-source-file) ())
  28
  29 (defparameter *fasl-directory*
  30   (make-pathname :directory '(:relative #+sbcl "sbcl-fasl"
  31                               #+openmcl "openmcl-fasl"
  32                               #-(or sbcl openmcl) "fasl")))
  33
  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)))))
  36
  37 ;;;; C source file compilation section
  38 ;;;; ripped from sb-posix.asd in the sbcl source code
  39
  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
  48              #+darwin "so"
  49              #-darwin "so")))
  50
  51 (defmethod input-files ((operation compile-op) (dso unix-dso))
  52   (mapcar #'component-pathname (module-components dso)))
  53
  54 (defmethod output-files ((operation compile-op) (dso unix-dso))
  55   (let ((dir (component-pathname dso)))
  56     (list
  57      (make-pathname :type (dso-type dso)
  58                     :name (if (slot-boundp dso 'dso-name)
  59                               (dso-name dso)
  60                               (car (last (pathname-directory dir))))
  61                     :directory (cond
  62                                  ((slot-boundp dso 'dso-directory)
  63                                   (let ((dso-pathname
  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)))
  70                                   nil)
  71                                  (t (butlast (pathname-directory dir))))
  72                     :defaults dir))))
  73
  74 (defmethod perform :after ((operation compile-op) (dso unix-dso))
  75   (let ((dso-name (unix-name (car (output-files operation dso)))))
  76     (unless (zerop
  77              (run-shell-command
  78               "~A ~A -o ~S ~{~S ~}"
  79               *c-compiler*
  80               (concatenate 'string
  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")
  85                            " "
  86                            (format nil " ~{-L~A~^ ~} " (link-library-directories dso))
  87                            #-darwin
  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 "
  91                            #+darwin " -bundle "
  92                            #-(or darwin sunos) " -shared ")
  93               dso-name
  94               (mapcar #'unix-name
  95                       (mapcan (lambda (c)
  96                                 (output-files operation c))
  97                               (module-components dso)))))
  98       (error 'operation-error :operation operation :component dso))))
  99
 100 ;;;; Unix executables
 101 ;;;;
 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)))
 107
 108 (defmethod input-files ((operation compile-op) (executable unix-executable))
 109   (declare (optimize (debug 3)))
 110   (let ((files
 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)))))
 116
 117 (defmethod output-files ((operation compile-op) (executable unix-executable))
 118   (list (component-pathname executable)))
 119
 120 #+nil
 121 (defmethod operation-done-p ((o compile-op) (c unix-executable))
 122   nil)
 123
 124 (defmethod perform :after ((operation compile-op) (executable unix-executable))
 125   (let ((executable-name (unix-name (car (output-files operation executable)))))
 126     (unless (zerop
 127              (run-shell-command
 128               "~A ~A ~A -o ~S ~{~S ~}"
 129               *c-compiler*
 130               *c-compiler-options*
 131               (concatenate 'string
 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")
 136                            " "
 137                            (format nil " ~{-L~A~^ ~} " (link-library-directories executable))
 138                            #-darwin
 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)))
 142               executable-name
 143               nil
 144               #+nil
 145               (mapcar #'unix-name
 146                       (mapcan (lambda (c)
 147                                 (output-files operation c))
 148                               (module-components executable)))))
 149       (error 'operation-error :operation operation :component executable))))
 150
 151 (defmethod component-depends-on ((op compile-op) (c unix-executable))
 152   (append (call-next-method)
 153           (mapcar #'(lambda (x)
 154                       `(compile-op ,x))
 155                   (source-files c))))
 156
 157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 158 ;;; C Header Files
 159 (defclass c-header-file (source-file) ())
 160
 161 (defmethod perform ((op compile-op) (c c-header-file)))
 162
 163 (defmethod perform ((op load-op) (c c-header-file)))
 164
 165 (defmethod source-file-type ((c c-header-file) (s module)) "h")
 166
 167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 168 ;;; C Source Files
 169
 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))
 173   (list
 174    (make-pathname :type "o" :defaults
 175                   (component-pathname c))))
 176
 177 (defgeneric get-include-directories (c))
 178
 179 (defmethod get-include-directories ((c c-source-file))
 180   (when (and
 181          (slot-exists-p (component-parent c) 'include-directories)
 182          (slot-boundp (component-parent c) 'include-directories))
 183     (mapcar
 184      #'unix-name
 185      (include-directories
 186       (component-parent c)))))
 187
 188 ;;;
 189 ;;; removed this bit here:
 190 ;;; #+nil "~{-isystem ~A~^ ~}"
 191 ;;; #+nil (mapcar #'unix-name (system-include-directories c))
 192
 193 (defparameter *c-compiler-options* "-Wall")
 194
 195 (defmethod perform ((op compile-op) (c c-source-file))
 196   (unless
 197       (= 0 (run-shell-command
 198             (concatenate 'string
 199                          (format nil "~A ~A ~A -o ~S -c ~S"
 200                                  *c-compiler*
 201                                  *c-compiler-options*
 202                                  (concatenate
 203                                   'string
 204                                   (format nil "~{-I~A~^ ~}" (get-include-directories c))
 205                                   " " (sb-ext:posix-getenv "EXTRA_CFLAGS")
 206                                   " -fPIC")
 207                                  (unix-name (car (output-files op c)))
 208                                  (unix-name (component-pathname c))))))
 209     (error 'operation-error :operation op :component c)))
 210
 211 (defmethod perform ((op load-op) (c c-source-file)))
 212
 213
 214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 215 ;;; ASM Source Files
 216 ;;;
 217 ;;; NASTY cut-and-paste job here!
 218
 219 (defclass asm-source-file (source-file) ())
 220
 221 (defmethod source-file-type ((c asm-source-file) (s module)) "s")
 222
 223 (defmethod output-files ((op compile-op) (c asm-source-file))
 224   (list
 225    (make-pathname :type "o" :defaults
 226                   (component-pathname c))))
 227
 228 (defgeneric get-include-directories (c))
 229
 230 (defmethod get-include-directories ((c asm-source-file))
 231   (when (and
 232          (slot-exists-p (component-parent c) 'include-directories)
 233          (slot-boundp (component-parent c) 'include-directories))
 234     (mapcar
 235      #'unix-name
 236      (include-directories
 237       (component-parent c)))))
 238
 239 (defmethod perform ((op compile-op) (c asm-source-file))
 240   (unless
 241       (= 0 (run-shell-command
 242             (concatenate 'string
 243                          (format nil "~A ~A -o ~S -c ~S"
 244                                  *c-compiler*
 245                                  (concatenate
 246                                   'string
 247                                   (format nil "~{-I~A~^ ~}" (get-include-directories c))
 248                                   " " (sb-ext:posix-getenv "EXTRA_ASMFLAGS")
 249                                   " -fPIC")
 250                                  (unix-name (car (output-files op c)))
 251                                  (unix-name (component-pathname c))))))
 252     (error 'operation-error :operation op :component c)))
 253
 254 (defmethod perform ((op load-op) (c asm-source-file)))
 255
 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))))
 261
 262 ;;;; ASDF hackery for generating components, generated source files
 263 ;;;; and other neat stuff.
 264
 265 ;;;
 266 ;;; generate-op
 267 (defclass generate-op (asdf:operation) ())
 268
 269 ;;;
 270 ;;; generated-component for components that generate files
 271 (defclass generated-component (asdf:component) ())
 272
 273
 274 (defmethod perform ((op generate-op) (c component)))
 275
 276 (defmethod perform ((op generate-op) (c generated-component)))
 277
 278 (defmethod component-depends-on ((op compile-op) (c generated-component))
 279   (append (call-next-method)
 280           `((generate-op ,(component-name c)))))
 281
 282 (defmethod component-depends-on ((op load-op) (c generated-component))
 283   (append (call-next-method)
 284           `((generate-op ,(component-name c)))))
 285
 286
 287 (defmethod perform :before ((operation generate-op) (c generated-component))
 288   (map nil #'ensure-directories-exist (output-files operation c)))
 289
 290 ;;;
 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) ())
 295
 296 (defmethod asdf::component-relative-pathname ((component generated-file))
 297   (let ((relative-pathname (slot-value component 'asdf::relative-pathname)))
 298     (if relative-pathname
 299         relative-pathname
 300         (let ((*default-pathname-defaults*
 301                (asdf::component-parent-pathname component)))
 302           (make-pathname
 303            :name (component-name component))))))
 304
 305 (defclass generated-source-file (generated-file) ())
 306
 307 (defmethod operation-done-p ((o operation) (c generated-source-file))
 308   (let ((in-files (input-files o c)))
 309     (if in-files
 310         (and (every #'probe-file in-files)
 311              (call-next-method))
 312         (call-next-method))))
 313
 314 (defmethod source-file-type ((c generated-file) (s module)) "")
 315
 316 (defmethod perform ((op compile-op) (c generated-file)))
 317
 318 (defmethod perform ((op load-op) (c generated-file)))
 319
 320 ;;; pdf files
 321
 322 (defclass pdf-file (source-file) ())
 323 (defmethod source-file-type ((c pdf-file) (s module)) "pdf")
 324
 325 (defmethod perform ((operation compile-op) (c pdf-file)))
 326
 327 (defmethod perform ((operation load-op) (c pdf-file))
 328   (ch-util::app-open (unix-name (component-pathname c))))
 329
 330 (defmethod operation-done-p ((o load-op) (c pdf-file))
 331   nil)
 332
 333
 334 ;;; css files
 335
 336 (defclass css-file (static-file) ())
 337 (defmethod source-file-type ((c css-file) (s module)) "css")
 338
 339 ;;; xhtml files
 340
 341 (defclass xhtml-file (html-file) ())
 342 (defmethod source-file-type ((c xhtml-file) (s module)) "xhtml")
 343
 344 ;;; tiff files
 345
 346 (defclass tiff-file (static-file) ())
 347 (defmethod source-file-type ((c tiff-file) (s module)) "tiff")
 348
 349 ;;; jpeg files
 350
 351 (defclass jpeg-file (static-file) ())
 352 (defmethod source-file-type ((c jpeg-file) (s module)) "jpg")
 353
 354 ;;; png files
 355
 356 (defclass png-file (static-file) ())
 357 (defmethod source-file-type ((c png-file) (s module)) "png")
 358
 359 ;;; markup files
 360
 361 (defclass markup-file (source-file) ())
 362 (defmethod source-file-type ((c markup-file) (s module)) "gmarkup")
 363
 364 (defclass markup-latex-file (generated-source-file) ())
 365 (defmethod source-file-type ((c markup-latex-file) (s module)) "tex")
 366
 367 (defclass markup-pdf-file (pdf-file generated-source-file) ())
 368 (defclass markup-xhtml-file (xhtml-file) ())
 369
 370 ;;; tinaa documentation
 371
 372 (defclass tinaa-directory (module) ())
 373
 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.
 378
 379 (defun get-sibling-component (comp sib)
 380   (asdf:find-component (asdf:component-parent comp)
 381                        (asdf::coerce-name sib)))
 382
 383 (defclass object-component (generated-component)
 384   ((symbol :accessor object-symbol :initarg :symbol)))
 385
 386 (defmethod operation-done-p ((o generate-op) (c object-component))
 387   t)
 388
 389 (defmethod source-file-type ((c object-component) (s module)) nil)
 390
 391 (defun make-symbol-from-name (name)
 392   (intern (string (read-from-string name))))
 393
 394 (defmethod shared-initialize :after ((c object-component) slot-names
 395                                      &key force
 396                                      &allow-other-keys)
 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))))))
 402
 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)))
 407
 408 (defmethod operation-done-p ((o compile-op) (c object-component))
 409   t)
 410
 411 (defmethod operation-done-p ((o load-op) (comp object-component))
 412   (every #'identity
 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)))))
 418
 419 ;;; An object-from-file is the file-based representation of an object. The
 420 ;;; load-op
 421 (defclass object-from-file (object-component source-file)
 422   ((load-date :accessor object-load-date :initarg :load-date)))
 423
 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)))
 430   (call-next-method))
 431
 432 (defmethod perform ((op generate-op) (c object-from-file))
 433   (setf (asdf::component-property c 'last-generated)
 434         (get-universal-time)))
 435
 436 ;;; this needs to check the file date!!!!
 437 (defmethod operation-done-p ((o generate-op) (c object-from-file))
 438   (let ((on-disk-time
 439          (file-write-date (component-pathname c)))
 440         (my-last-load-time (asdf::component-property c 'last-loaded)))
 441     (and on-disk-time
 442          my-last-load-time
 443          (>= my-last-load-time on-disk-time))))
 444
 445
 446 (defclass object-to-file (object-component)
 447   ((write-date :accessor object-write-date :initarg :write-date)))
 448
 449
 450 (defclass object-from-variable (object-component)
 451   ((input-object :accessor object-input-object :initarg :input-object)))
 452
 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))))))
 456
 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))))))
 460
 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)))
 466           'last-loaded))
 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))))
 471
 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
 476          my-last-compile-time
 477          (>= my-last-compile-time my-last-generate-time))))
 478
 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
 483          my-last-load-time
 484          (>= my-last-load-time my-last-compile-time))))
 485
 486 (defmethod perform ((op generate-op) (c object-from-variable))
 487   (setf (asdf:component-property c 'last-generated)
 488         (get-universal-time))
 489   (let ((sexp
 490        (symbol-value
 491         (object-symbol
 492          (find-component (component-parent c)
 493                          (asdf::coerce-name (object-input-object c)))))))
 494   (setf (symbol-value (object-symbol c)) sexp)))
 495
 496
 497 (defmethod perform ((op compile-op) (c object-from-variable))
 498   (setf (asdf:component-property c 'last-compiled)
 499         (get-universal-time)))
 500
 501 (defmethod perform ((op load-op) (c object-from-variable))
 502     (setf (asdf:component-property c 'last-loaded)
 503         (get-universal-time)))
 504
 505 (defclass load-only-file-mixin ()
 506    ())
 507
 508 (defclass load-only-cl-source-file (load-only-file-mixin cl-source-file)
 509    ())
 510
 511 (defmethod perform ((op compile-op) (component load-only-file-mixin))
 512    nil)
 513
 514 (defmethod perform ((op load-op) (component load-only-cl-source-file))
 515    (load (component-pathname component)))
 516
 517 ;;; graphviz dot-files
 518
 519 (defparameter *dot-program* "dot")
 520 (defparameter *dot-program-path*
 521   (let ((found (sb-ext:find-executable-in-search-path
 522                 *dot-program*)))
 523     (unless found
 524       (setf found
 525             #+darwin "/opt/local/bin/dot"
 526             #-darwin "/usr/local/bin/dot"))
 527     found))
 528
 529 (defclass graphviz-dot-file (generated-source-file) ())
 530
 531 (defmethod source-file-type ((c graphviz-dot-file) (s module)) "dot")
 532
 533 (defmethod output-files ((operation compile-op) (c graphviz-dot-file))
 534   (list
 535    (merge-pathnames (make-pathname :type "png")
 536                     (compile-file-pathname (component-pathname c)))))
 537
 538 (defmethod perform ((op compile-op) (c graphviz-dot-file))
 539   (run-shell-command
 540    "~A ~A -o~A ~A"
 541    *dot-program-path*
 542    "-Tpng"
 543    (ch-asdf:unix-name (car (output-files op c)))
 544    (ch-asdf:unix-name (component-pathname c))))
 545
 546
 547 ;;; benchmarking stuff
 548
 549 (defclass benchmark-op (operation) ())
 550
 551 (defmethod perform ((operation benchmark-op) (c component))
 552   (oos 'load-op c))
 553
 554
 555