bundle.lisp 22.2 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; ASDF-Bundle

4
(uiop/package:define-package :asdf/bundle
5
  (:recycle :asdf/bundle :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade
7 8 9
   :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
  (:export
10 11 12 13 14 15 16 17
   #:bundle-op #:bundle-op-build-args #:bundle-type
   #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
   #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
   #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
   #:lib-op #:monolithic-lib-op
   #:dll-op #:monolithic-dll-op
   #:binary-op #:monolithic-binary-op
   #:program-op #:compiled-file #:precompiled-system #:prebuilt-system
18
   #:user-system-p #:user-system #:trivial-system-p
19
   #+ecl #:make-build
20
   #:register-pre-built-system
21
   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
22 23
(in-package :asdf/bundle)

24 25 26 27 28 29 30 31 32
(with-upgradability ()
  (defclass bundle-op (operation)
    ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
     (name-suffix :initarg :name-suffix :initform nil)
     (bundle-type :initform :no-output-file :reader bundle-type)
     #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
     #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
     #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))

33 34 35 36
  (defclass bundle-compile-op (bundle-op basic-compile-op)
    ()
    (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))

37
  ;; create a single fasl for the entire library
38
  (defclass basic-fasl-op (bundle-compile-op)
39
    ((bundle-type :initform :fasl)))
40
  (defclass prepare-fasl-op (sideway-operation)
41
    ((sideway-operation :initform 'load-fasl-op :allocation :class)))
42
  (defclass fasl-op (basic-fasl-op selfward-operation)
43
    ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op) :allocation :class)))
44
  (defclass load-fasl-op (basic-load-op selfward-operation)
45
    ((selfward-operation :initform '(prepare-op fasl-op) :allocation :class)))
46 47 48 49 50 51

  ;; NB: since the monolithic-op's can't be sideway-operation's,
  ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's,
  ;; we'd have to have the monolithic-op not inherit from the main op,
  ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.

52 53
  (defclass no-ld-flags-op (operation) ())

54
  (defclass lib-op (bundle-compile-op no-ld-flags-op non-propagating-operation)
55 56 57
    ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
    (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
     #-(or ecl mkcl) "just compile the system"))
58

59
  (defclass dll-op (bundle-compile-op no-ld-flags-op non-propagating-operation)
60
    ((bundle-type :initform :dll))
61
    (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
62

63
  (defclass binary-op (basic-compile-op selfward-operation)
64
    ((selfward-operation :initform '(fasl-op lib-op) :allocation :class))
65
    (:documentation "produce fasl and asd files for the system"))
66

67 68 69 70 71 72
  (defclass monolithic-op (operation) ()
    (:documentation "A MONOLITHIC operation operates on a system *and all of its
dependencies*.  So, for example, a monolithic concatenate operation will
concatenate together a system's components and all of its dependencies, but a
simple concatenate operation will concatenate only the components of the system
itself.")) ;; operation on a system and its dependencies
73 74 75 76 77

  (defclass monolithic-bundle-op (monolithic-op bundle-op)
    ((prologue-code :accessor monolithic-op-prologue-code)
     (epilogue-code :accessor monolithic-op-epilogue-code)))

78 79
  (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op)
    ()
80 81
    (:documentation "Abstract operation for ways to bundle the outputs of compiling
*Lisp* files over a system, and all of its dependencies."))
82

83
  (defclass monolithic-binary-op (monolithic-op binary-op)
84
    ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op) :allocation :class))
85 86
    (:documentation "produce fasl and asd files for combined system and dependencies."))

87
  (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op non-propagating-operation) ()
88
    (:documentation "Create a single fasl for the system and its dependencies."))
89

90
  (defclass monolithic-lib-op (monolithic-bundle-compile-op non-propagating-operation no-ld-flags-op)
91
    ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
92 93
    (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
     #-(or ecl mkcl) "Compile a system and its dependencies."))
94

95
  (defclass monolithic-dll-op (monolithic-bundle-compile-op non-propagating-operation no-ld-flags-op)
96 97
    ((bundle-type :initform :dll))
    (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
98

99 100 101 102
  ;; Fare reports that the PROGRAM-OP doesn't need any propagation on MKCL or
  ;; ECL because the necessary dependency wrangling is done by other, earlier
  ;; operations. [2014/01/20:rpg]
  (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op non-propagating-operation)
103
            #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
104
    ((bundle-type :initform :program)
105
     #-(or mkcl ecl) (selfward-operation :initform 'load-op))
106
    (:documentation "create an executable file from the system and its dependencies"))
107 108 109

  (defun bundle-pathname-type (bundle-type)
    (etypecase bundle-type
110
      ((eql :no-output-file) nil) ;; should we error out instead?
111 112 113
      ((or null string) bundle-type)
      ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
      #+ecl
114
      ((member :binary :dll :lib :shared-library :static-library :program :object :program)
115 116
       (compile-file-type :type bundle-type))
      ((eql :binary) "image")
117
      ((eql :dll) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
118 119 120 121
      ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
      ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))

  (defun bundle-output-files (o c)
122 123 124 125 126 127 128 129
    (when (input-files o c)
      (let ((bundle-type (bundle-type o)))
        (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
          (let ((name (or (component-build-pathname c)
                          (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
                (type (bundle-pathname-type bundle-type)))
            (values (list (subpathname (component-pathname c) name :type type))
                    (eq (type-of o) (component-build-operation c))))))))
130 131 132 133 134

  (defmethod output-files ((o bundle-op) (c system))
    (bundle-output-files o c))

  #-(or ecl mkcl)
135 136 137 138
  (defmethod perform ((o program-op) (c system))
    (let ((output-file (output-file o c)))
      (setf *image-entry-point* (ensure-function (component-entry-point c)))
      (dump-image output-file :executable t)))
139 140 141 142 143 144 145 146 147 148 149

  (defclass compiled-file (file-component)
    ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))

  (defclass precompiled-system (system)
    ((build-pathname :initarg :fasl)))

  (defclass prebuilt-system (system)
    ((build-pathname :initarg :static-library :initarg :lib
                     :accessor prebuilt-system-static-library))))

150 151 152 153 154 155 156 157 158

;;;
;;; BUNDLE-OP
;;;
;;; This operation takes all components from one or more systems and
;;; creates a single output file, which may be
;;; a FASL, a statically linked library, a shared library, etc.
;;; The different targets are defined by specialization.
;;;
159 160 161 162 163 164 165
(with-upgradability ()
  (defun operation-monolithic-p (op)
    (typep op 'monolithic-op))

  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
                                         &key (name-suffix nil name-suffix-p)
                                         &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
166
    (declare (ignore initargs name-suffix))
167 168 169
    (unless name-suffix-p
      (setf (slot-value instance 'name-suffix)
            (unless (typep instance 'program-op)
170
              (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
    (when (typep instance 'monolithic-bundle-op)
      (destructuring-bind (&rest original-initargs
                           &key lisp-files prologue-code epilogue-code
                           &allow-other-keys)
          (operation-original-initargs instance)
        (setf (operation-original-initargs instance)
              (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
              (monolithic-op-prologue-code instance) prologue-code
              (monolithic-op-epilogue-code instance) epilogue-code)
        #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
        #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
    (setf (bundle-op-build-args instance)
          (remove-plist-keys '(:type :monolithic :name-suffix)
                             (operation-original-initargs instance))))

186
  (defmethod bundle-op-build-args :around ((o no-ld-flags-op))
187
    #+xcl (declare (ignorable o))
188 189 190 191 192 193 194
    (let ((args (call-next-method)))
      (remf args :ld-flags)
      args))

  (defun bundlable-file-p (pathname)
    (let ((type (pathname-type pathname)))
      (declare (ignorable type))
195 196 197
      (or #+ecl (or (equalp type (compile-file-type :type :object))
                    (equalp type (compile-file-type :type :static-library)))
          #+mkcl (equalp type (compile-file-type :fasl-p nil))
198
          #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
199 200 201 202 203 204

  (defgeneric* (trivial-system-p) (component))

  (defun user-system-p (s)
    (and (typep s 'system)
         (not (builtin-system-p s))
205
         (not (trivial-system-p s)))))
206

207
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
208
  (deftype user-system () '(and system (satisfies user-system-p))))
209 210 211 212 213 214 215 216 217

;;;
;;; First we handle monolithic bundles.
;;; These are standalone systems which contain everything,
;;; including other ASDF systems required by the current one.
;;; A PROGRAM is always monolithic.
;;;
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
218
(with-upgradability ()
219 220 221 222 223 224 225 226 227 228
  (defmethod component-depends-on ((o bundle-compile-op) (c system))
    `(,(if (operation-monolithic-p o)
           `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
               ,@(required-components c :other-systems t :component-type 'system
                                        :goal-operation (find-operation o 'load-op)
                                        :keep-operation 'compile-op))
           `(compile-op
             ,@(required-components c :other-systems nil :component-type '(not system)
                                      :goal-operation (find-operation o 'load-op)
                                      :keep-operation 'compile-op)))
229
      ,@(call-next-method)))
230 231 232

  (defmethod component-depends-on :around ((o bundle-op) (c component))
    (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
233 234 235
      `((,op ,c))
      (call-next-method)))

236
  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
237 238
    ;; This file selects output files from direct dependencies;
    ;; your component-depends-on method better gathered the correct dependencies in the correct order.
239 240 241 242 243 244
    (while-collecting (collect)
      (map-direct-dependencies
       o c #'(lambda (sub-o sub-c)
               (loop :for f :in (funcall key sub-o sub-c)
                     :when (funcall test f) :do (collect f))))))

245
  (defmethod input-files ((o bundle-compile-op) (c system))
246 247
    (unless (eq (bundle-type o) :no-output-file)
      (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267

  (defun select-bundle-operation (type &optional monolithic)
    (ecase type
      ((:binary)
       (if monolithic 'monolithic-binary-op 'binary-op))
      ((:dll :shared-library)
       (if monolithic 'monolithic-dll-op 'dll-op))
      ((:lib :static-library)
       (if monolithic 'monolithic-lib-op 'lib-op))
      ((:fasl)
       (if monolithic 'monolithic-fasl-op 'fasl-op))
      ((:program)
       'program-op)))

  (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
                             (move-here nil move-here-p)
                             &allow-other-keys)
    (let* ((operation-name (select-bundle-operation type monolithic))
           (move-here-path (if (and move-here
                                    (typep move-here '(or pathname string)))
268
                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284
                               (system-relative-pathname system "asdf-output/")))
           (operation (apply #'operate operation-name
                             system
                             (remove-plist-keys '(:monolithic :type :move-here) args)))
           (system (find-system system))
           (files (and system (output-files operation system))))
      (if (or move-here (and (null move-here-p)
                             (member operation-name '(:program :binary))))
          (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
                :for f :in files
                :for new-f = (make-pathname :name (pathname-name f)
                                            :type (pathname-type f)
                                            :defaults dest-path)
                :do (rename-file-overwriting-target f new-f)
                :collect new-f)
          files))))
285 286 287 288 289 290

;;;
;;; LOAD-FASL-OP
;;;
;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
;;;
291 292
(with-upgradability ()
  (defmethod component-depends-on ((o load-fasl-op) (c system))
293
    `((,o ,@(loop :for dep :in (component-sideway-dependencies c)
294 295 296
                  :collect (resolve-dependency-spec c dep)))
      (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
      ,@(call-next-method)))
297

298 299 300
  (defmethod input-files ((o load-fasl-op) (c system))
    (when (user-system-p c)
      (output-files (find-operation o 'fasl-op) c)))
301

302
  (defmethod perform ((o load-fasl-op) (c system))
303 304
    (when (input-files o c)
      (perform-lisp-load-fasl o c)))
305

306 307
  (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
    (mark-operation-done (find-operation o 'load-op) c)))
308 309 310 311 312 313 314

;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF systems in precompiled form.
;;; Only useful when the dependencies have also been precompiled.
;;;
315 316 317 318
(with-upgradability ()
  (defmethod trivial-system-p ((s system))
    (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
319
  (defmethod input-files ((o operation) (c compiled-file))
320
    (list (component-pathname c)))
321 322 323 324 325 326
  (defmethod perform ((o load-op) (c compiled-file))
    (perform-lisp-load-fasl o c))
  (defmethod perform ((o load-source-op) (c compiled-file))
    (perform (find-operation o 'load-op) c))
  (defmethod perform ((o load-fasl-op) (c compiled-file))
    (perform (find-operation o 'load-op) c))
327
  (defmethod perform ((o operation) (c compiled-file))
328
    nil))
329 330 331 332

;;;
;;; Pre-built systems
;;;
333 334 335
(with-upgradability ()
  (defmethod trivial-system-p ((s prebuilt-system))
    t)
336

337 338
  (defmethod perform ((o lib-op) (c prebuilt-system))
    nil)
339

340 341
  (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
    nil)
342

343 344
  (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
    nil))
345

346

347 348 349
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
350 351 352 353 354 355
(with-upgradability ()
  (defmethod output-files ((o binary-op) (s system))
    (list (make-pathname :name (component-name s) :type "asd"
                         :defaults (component-pathname s))))

  (defmethod perform ((o binary-op) (s system))
356 357 358
    (let* ((inputs (input-files o s))
           (fasl (first inputs))
           (library (second inputs))
359
           (asd (first (output-files o s)))
360
           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376
           (dependencies
             (if (operation-monolithic-p o)
                 (remove-if-not 'builtin-system-p
                                (required-components s :component-type 'system
                                                       :keep-operation 'load-op))
                 (while-collecting (x) ;; resolve the sideway-dependencies of s
                   (map-direct-dependencies
                    'load-op s
                    #'(lambda (o c)
                        (when (and (typep o 'load-op) (typep c 'system))
                          (x c)))))))
           (depends-on (mapcar 'coerce-name dependencies)))
      (when (pathname-equal asd (system-source-file s))
        (cerror "overwrite the asd file"
                "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
                (cons o s) asd))
377 378
      (with-open-file (s asd :direction :output :if-exists :supersede
                             :if-does-not-exist :create)
379 380 381
        (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
                (operation-monolithic-p o) name)
        (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
382 383 384 385 386
                (lisp-implementation-type)
                (lisp-implementation-version)
                (software-type)
                (machine-type)
                (software-version))
387 388
        (let ((*package* (find-package :asdf-user)))
          (pprint `(defsystem ,name
389
                     :class prebuilt-system
390
                     :depends-on ,depends-on
391
                     :components ((:compiled-file ,(pathname-name fasl)))
392 393 394
                     ,@(when library `(:lib ,(file-namestring library))))
                  s)
          (terpri s)))))
395 396

  #-(or ecl mkcl)
397
  (defmethod perform ((o bundle-compile-op) (c system))
398
    (let* ((input-files (input-files o c))
399 400
           (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
           (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
401 402
           (output-files (output-files o c))
           (output-file (first output-files)))
403
      (assert (eq (not input-files) (not output-files)))
404 405
      (when input-files
        (when non-fasl-files
406
          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
407 408 409 410 411 412 413 414 415 416 417
                 (implementation-type) non-fasl-files))
        (when (and (typep o 'monolithic-bundle-op)
                   (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
          (error "prologue-code and epilogue-code are not supported on ~A"
                 (implementation-type)))
        (with-staging-pathname (output-file)
          (combine-fasls fasl-files output-file)))))

  (defmethod input-files ((o load-op) (s precompiled-system))
    (bundle-output-files (find-operation o 'fasl-op) s))

418 419 420
  (defmethod perform ((o load-op) (s precompiled-system))
    (perform-lisp-load-fasl o s))

421
  (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
422
    #+xcl (declare (ignorable o))
423 424
    `((load-op ,s) ,@(call-next-method))))

425
#| ;; Example use:
426 427 428 429
(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
(asdf:load-system :precompiled-asdf-utils)
|#

430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452
#+(or ecl mkcl)
(with-upgradability ()
  (defun uiop-library-file ()
    (or (and (find-system :uiop nil)
             (system-source-directory :uiop)
             (progn
               (operate 'lib-op :uiop)
               (output-file 'lib-op :uiop)))
        (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib))))
  (defmethod input-files :around ((o program-op) (c system))
    (let ((files (call-next-method))
          (plan (traverse-sub-actions o c :plan-class 'sequential-plan)))
      (unless (or (and (find-system :uiop nil)
                       (system-source-directory :uiop)
                       (plan-operates-on-p plan '("uiop")))
                  (and (system-source-directory :asdf)
                       (plan-operates-on-p plan '("asdf"))))
        (pushnew (uiop-library-file) files :test 'pathname-equal))
      files))

  (defun register-pre-built-system (name)
    (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))

453
#+ecl
454
(with-upgradability ()
455
  (defmethod perform ((o bundle-compile-op) (c system))
456 457 458 459
    (let* ((object-files (input-files o c))
           (output (output-files o c))
           (bundle (first output))
           (kind (bundle-type o)))
460 461 462 463 464 465 466 467 468 469 470 471
      (when output
        (create-image
         bundle (append object-files (bundle-op-lisp-files o))
         :kind kind
         :entry-point (component-entry-point c)
         :prologue-code
         (when (typep o 'monolithic-bundle-op)
           (monolithic-op-prologue-code o))
         :epilogue-code
         (when (typep o 'monolithic-bundle-op)
           (monolithic-op-epilogue-code o))
         :build-args (bundle-op-build-args o))))))
472 473

#+mkcl
474
(with-upgradability ()
475
  (defmethod perform ((o lib-op) (s system))
476
    (apply #'compiler::build-static-library (output-file o c)
477
           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
478

479 480
  (defmethod perform ((o basic-fasl-op) (s system))
    (apply #'compiler::build-bundle (output-file o c) ;; second???
481
           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
482

483
  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
484 485
    (declare (ignore force verbose version))
    (apply #'operate 'binary-op system args)))
486 487

#+(and (not asdf-use-unsafe-mac-bundle-op)
488 489
       (or (and ecl darwin)
           (and abcl darwin (not abcl-bundle-op-supported))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
490 491
(defmethod perform :before ((o basic-fasl-op) (c component))
  (unless (featurep :asdf-use-unsafe-mac-bundle-op)
492
    (cerror "Continue after modifying *FEATURES*."
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
493 494 495
            "BASIC-FASL-OP bundle operations are not supported on Mac OS X for this lisp.~%~T~
To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~
Please report to ASDF-DEVEL if this works for you.")))