Skip to content
asdf-classes.lisp 2.16 KiB
Newer Older
#+xcvb (module (:depends-on ("variables")))

(cl:in-package #:asdf-dependency-grovel)

(defclass instrumented-component ()
  ((translated-name :initarg :translated-name
                    :reader translated-name)
   (translated-pathname :initarg :translated-pathname-form
                        :reader translated-pathname)
   (output-file-type :initarg :output-file-type
                     :reader output-file-type)
   (additional-dependencies :initarg :additional-dependencies
                            :initform nil
                            :reader additional-dependencies)
   (overridden-dependencies :initarg :override-dependencies
                            :reader overridden-dependencies)
   (additional-initargs :initarg :additional-initargs
                        :initform nil
                        :reader additional-initargs)))

(defclass instrumented-cl-source-file (asdf:cl-source-file
                                       instrumented-component)
  ())

(defclass instrumented-module (asdf:module instrumented-component)
  ()
  (:default-initargs :default-component-class 'instrumented-cl-source-file))
(defun escaped-around-compile-hook (component)
  (let ((around-compile (asdf::around-compile-hook component)))
    (etypecase around-compile
      ((or null string) around-compile)
      (function (error "Can't convert around-compile hook ~S because it's a function object.~%Maybe you should use a lambda-expression instead?"
                       around-compile))
      ((or symbol cons)
       (with-standard-io-syntax
         (let ((*package* (find-package :cl)))
           (write-to-string around-compile :readably t)))))))

(defmethod additional-initargs :around ((comp instrumented-component))
  (flet ((slot-when-bound (slot-name initarg)
           (when (slot-boundp comp slot-name)
             `(,initarg ,(slot-value comp slot-name)))))
    `(,@(call-next-method)
        ,@(when (asdf::around-compile-hook comp)
            `(:around-compile ,(escaped-around-compile-hook comp)))
	`(:encoding ,(component-encoding comp))
        ,@(slot-when-bound 'translated-name :translated-name)
        ,@(slot-when-bound 'translated-pathname :translated-pathname-form))))