Commit dc540cd2 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Merge branch 'no-operation-initargs' into 'master' 

No operation initargs

This MR build upon !33 and wholly eliminate the non-sensical and unsupported initargs to operation.

A casualty is `make-build`, as inherited from asdf-ecl (2005 era) and apparently still used by ECL. @dkochmanski will be pissed, but he'll have to learn about using `program-op` and `program-system` instead — which are supported (and using secondary systems, if for some reason he doesn't want to use `program-system` with primary systems). While we're pissing off @dkochmanski, I'm also removing the trivial and useless function `build-system` in the same directory.

@epipping I don't think you're interested in reviewing defsystem changes, so I'm assigning directly to @rgoldman for review.

@rgoldman considering the controversy, you may want to either merge fast before next release and be done with it, or make an announcement at this release and do it for the next release, which lets the wound fester longer, but gives more time for users to adapt (assuming there's more than a single one, which is not that obvious).


See merge request !34
parents 1705ceed 01aa2ff4

action.lisp

+6 −10
Original line number Original line Diff line number Diff line
@@ -44,7 +44,7 @@ and a class-name or class designates the canonical instance of the designated cl 
  (defun action-component (action)

  (defun action-component (action)

    (cdr action)))

    (cdr action)))





;;;; Reified representation for storage or debugging. Note: it drops the operation-original-initargs

;;;; Reified representation for storage or debugging. Note: an action is identified by its class.

(with-upgradability ()

(with-upgradability ()

  (defun action-path (action)

  (defun action-path (action)

    "A readable data structure that identifies the action."

    "A readable data structure that identifies the action."
@@ -67,10 +67,8 @@ and a class-name or class designates the canonical instance of the designated cl 
  ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT.

  ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT.

  ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.

  ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.

  ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.

  ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.

  ;; If OPERATION-INITARGS is true, then for backward compatibility the function has

  ;; a &rest argument that is passed into the operation's initargs if and when it is created.

  (defmacro define-convenience-action-methods

  (defmacro define-convenience-action-methods

      (function formals &key if-no-operation if-no-component operation-initargs)

      (function formals &key if-no-operation if-no-component)

    (let* ((rest (gensym "REST"))

    (let* ((rest (gensym "REST"))

           (found (gensym "FOUND"))

           (found (gensym "FOUND"))

           (keyp (equal (last formals) '(&key)))

           (keyp (equal (last formals) '(&key)))
@@ -95,9 +93,7 @@ and a class-name or class designates the canonical instance of the designated cl 
           (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args)

           (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args)

             (if ,operation

             (if ,operation

                 ,(next-method

                 ,(next-method

                   (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.

                   `(make-operation ,operation)

                       `(apply 'make-operation ,operation :original-initargs ,rest ,rest)

                       `(make-operation ,operation))

                   `(or (find-component () ,component) ,if-no-component))

                   `(or (find-component () ,component) ,if-no-component))

                 ,if-no-operation))

                 ,if-no-operation))

           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)

           (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
@@ -117,7 +113,7 @@ on this component, e.g. \"loading /a/b/c\". 
You can put together sentences using this phrase."))

You can put together sentences using this phrase."))

  (defmethod action-description (operation component)

  (defmethod action-description (operation component)

    (format nil (compatfmt "~@<~A on ~A~@:>")

    (format nil (compatfmt "~@<~A on ~A~@:>")

            (type-of operation) component))

            operation component))





  (defun format-action (stream action &optional colon-p at-sign-p)

  (defun format-action (stream action &optional colon-p at-sign-p)

    "FORMAT helper to display an action's action-description.

    "FORMAT helper to display an action's action-description.
@@ -399,10 +395,10 @@ in some previous image, or T if it needs to be done.") 
        (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))

        (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))





  (defmethod component-operation-time ((o operation) (c component))

  (defmethod component-operation-time ((o operation) (c component))

    (gethash (type-of o) (component-operation-times c)))

    (gethash o (component-operation-times c)))





  (defmethod (setf component-operation-time) (stamp (o operation) (c component))

  (defmethod (setf component-operation-time) (stamp (o operation) (c component))

    (setf (gethash (type-of o) (component-operation-times c)) stamp))

    (setf (gethash o (component-operation-times c)) stamp))





  (defmethod mark-operation-done ((o operation) (c component))

  (defmethod mark-operation-done ((o operation) (c component))

    (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t))))

    (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t))))

bundle.lisp

+36 −94
Original line number Original line Diff line number Diff line
@@ -17,8 +17,7 @@ 
   #:deliver-asd-op #:monolithic-deliver-asd-op

   #:deliver-asd-op #:monolithic-deliver-asd-op

   #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system

   #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system

   #:user-system-p #:user-system #:trivial-system-p

   #:user-system-p #:user-system #:trivial-system-p

   #:make-build

   #:prologue-code #:epilogue-code #:static-library))

   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))

(in-package :asdf/bundle)

(in-package :asdf/bundle)





(with-upgradability ()

(with-upgradability ()
@@ -26,10 +25,7 @@ 
    ;; NB: use of instance-allocated slots for operations is DEPRECATED

    ;; NB: use of instance-allocated slots for operations is DEPRECATED

    ;; and only supported in a temporary fashion for backward compatibility.

    ;; and only supported in a temporary fashion for backward compatibility.

    ;; Supported replacement: Define slots on program-system instead.

    ;; Supported replacement: Define slots on program-system instead.

    ((build-args :initarg :args :initform nil :accessor extra-build-args)

    ((bundle-type :initform :no-output-file :reader bundle-type :allocation :class))

     (name-suffix :initarg :name-suffix :initform nil)

     (bundle-type :initform :no-output-file :reader bundle-type)

     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files))

    (:documentation "base class for operations that bundle outputs from multiple components"))

    (:documentation "base class for operations that bundle outputs from multiple components"))





  (defclass monolithic-op (operation) ()

  (defclass monolithic-op (operation) ()
@@ -39,7 +35,7 @@ concatenate together a system's components and all of its dependencies, but a 
simple concatenate operation will concatenate only the components of the system

simple concatenate operation will concatenate only the components of the system

itself."))

itself."))





  (defclass monolithic-bundle-op (monolithic-op bundle-op)

  (defclass monolithic-bundle-op (bundle-op monolithic-op)

    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.

    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.

    ;; DEPRECATED. Supported replacement: Define slots on program-system instead.

    ;; DEPRECATED. Supported replacement: Define slots on program-system instead.

    ((prologue-code :initform nil :accessor prologue-code)

    ((prologue-code :initform nil :accessor prologue-code)
@@ -60,13 +56,13 @@ itself.")) 
     (extra-build-args :initarg :extra-build-args

     (extra-build-args :initarg :extra-build-args

                       :initform nil :accessor extra-build-args)))

                       :initform nil :accessor extra-build-args)))





  (defmethod prologue-code ((x t)) nil)

  (defmethod prologue-code ((x system)) nil)

  (defmethod epilogue-code ((x t)) nil)

  (defmethod epilogue-code ((x system)) nil)

  (defmethod no-uiop ((x t)) nil)

  (defmethod no-uiop ((x system)) nil)

  (defmethod prefix-lisp-object-files ((x t)) nil)

  (defmethod prefix-lisp-object-files ((x system)) nil)

  (defmethod postfix-lisp-object-files ((x t)) nil)

  (defmethod postfix-lisp-object-files ((x system)) nil)

  (defmethod extra-object-files ((x t)) nil)

  (defmethod extra-object-files ((x system)) nil)

  (defmethod extra-build-args ((x t)) nil)

  (defmethod extra-build-args ((x system)) nil)





  (defclass link-op (bundle-op) ()

  (defclass link-op (bundle-op) ()

    (:documentation "Abstract operation for linking files together"))

    (:documentation "Abstract operation for linking files together"))
@@ -169,7 +165,7 @@ for all the linkable object files associated with the system. Compare with LIB-O 
    (:documentation "produce an asd file for delivering the system as a single fasl"))

    (:documentation "produce an asd file for delivering the system as a single fasl"))









  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)

  (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)

    ((selfward-operation

    ((selfward-operation

      ;; TODO: implement link-op on all implementations, and make that

      ;; TODO: implement link-op on all implementations, and make that

      ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)

      ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
@@ -178,7 +174,7 @@ for all the linkable object files associated with the system. Compare with LIB-O 
    (:documentation "produce fasl and asd files for combined system and dependencies."))

    (:documentation "produce fasl and asd files for combined system and dependencies."))





  (defclass monolithic-compile-bundle-op

  (defclass monolithic-compile-bundle-op

      (monolithic-bundle-op basic-compile-bundle-op

      (basic-compile-bundle-op monolithic-bundle-op

       #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)

       #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)

    ((gather-operation

    ((gather-operation

      :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op

      :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op
@@ -188,29 +184,29 @@ for all the linkable object files associated with the system. Compare with LIB-O 
      :allocation :class))

      :allocation :class))

    (:documentation "Create a single fasl for the system and its dependencies."))

    (:documentation "Create a single fasl for the system and its dependencies."))





  (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)

  (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)

    ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))

    ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))

    (:documentation "Load a single fasl for the system and its dependencies."))

    (:documentation "Load a single fasl for the system and its dependencies."))





  (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation)

  (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation)

    ((gather-type :initform :static-library :allocation :class))

    ((gather-type :initform :static-library :allocation :class))

    (:documentation "Compile the system and produce a linkable static library (.a/.lib)

    (:documentation "Compile the system and produce a linkable static library (.a/.lib)

for all the linkable object files associated with the system or its dependencies. See LIB-OP."))

for all the linkable object files associated with the system or its dependencies. See LIB-OP."))





  (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)

  (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation)

    ((gather-type :initform :static-library :allocation :class))

    ((gather-type :initform :static-library :allocation :class))

    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)

    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)

for all the linkable object files associated with the system or its dependencies. See LIB-OP"))

for all the linkable object files associated with the system or its dependencies. See LIB-OP"))





  (defclass image-op (monolithic-bundle-op selfward-operation

  (defclass image-op (monolithic-bundle-op selfward-operation

                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)

                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)

    ((bundle-type :initform :image)

    ((bundle-type :initform :image :allocation :class)

     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)

     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)

     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))

     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))

    (:documentation "create an image file from the system and its dependencies"))

    (:documentation "create an image file from the system and its dependencies"))





  (defclass program-op (image-op)

  (defclass program-op (image-op)

    ((bundle-type :initform :program))

    ((bundle-type :initform :program :allocation :class))

    (:documentation "create an executable file from the system and its dependencies"))

    (:documentation "create an executable file from the system and its dependencies"))





  ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.

  ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
@@ -246,7 +242,14 @@ for all the linkable object files associated with the system or its dependencies 
      (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.

      (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.

                  (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))

                  (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))

        (let ((name (or (component-build-pathname c)

        (let ((name (or (component-build-pathname c)

                        (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))

                        (let ((suffix

                               (unless (typep o 'program-op)

                                 ;; "." is no good separator for Logical Pathnames, so we use "--"

                                 (if (operation-monolithic-p o)

                                     "--all-systems"

                                     ;; These use a different type .fasb or .a instead of .fasl

                                     #-(or clasp ecl mkcl) "--system"))))

                          (format nil "~A~@[~A~]" (component-name c) suffix))))

              (type (bundle-pathname-type bundle-type)))

              (type (bundle-pathname-type bundle-type)))

          (values (list (subpathname (component-pathname c) name :type type))

          (values (list (subpathname (component-pathname c) name :type type))

                  (eq (class-of o) (coerce-class (component-build-operation c)

                  (eq (class-of o) (coerce-class (component-build-operation c)
@@ -288,31 +291,12 @@ or of opaque libraries shipped along the source code.")) 
;;; a FASL, a statically linked library, a shared library, etc.

;;; a FASL, a statically linked library, a shared library, etc.

;;; The different targets are defined by specialization.

;;; The different targets are defined by specialization.

;;;

;;;

(with-upgradability ()

(when-upgrading (:version "3.1.9")

  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs

  ;; Cancel any previously defined method

                                         &key (name-suffix nil name-suffix-p)

  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)

                                         &allow-other-keys)

    (declare (ignore initargs))))

    (declare (ignore initargs name-suffix))

    ;; TODO: make that class slots or methods, not instance slots

    (unless name-suffix-p

      (setf (slot-value instance 'name-suffix)

            (unless (typep instance 'program-op)

              ;; "." is no good separator for Logical Pathnames, so we use "--"

              (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))

    (when (typep instance 'monolithic-bundle-op)

      (destructuring-bind (&key lisp-files prologue-code epilogue-code

                           &allow-other-keys)

          (operation-original-initargs instance)

        (setf (prologue-code instance) prologue-code

              (epilogue-code instance) epilogue-code)

        #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))

        #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))

    (setf (extra-build-args instance)

          (remove-plist-keys

           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files

             :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments

           (operation-original-initargs instance))))





(with-upgradability ()

  (defgeneric trivial-system-p (component))

  (defgeneric trivial-system-p (component))





  (defun user-system-p (s)

  (defun user-system-p (s)
@@ -362,48 +346,7 @@ or of opaque libraries shipped along the source code.")) 
      ((:image)

      ((:image)

       'image-op)

       'image-op)

      ((:program)

      ((:program)

       'program-op)))

       'program-op))))



  ;; DEPRECATED. This is originally from asdf-ecl.lisp.

  ;; It must die, and so must any use of initargs in operation,

  ;; unless keys to the asdf-cache are substantially modified to accommodate for them.

  ;; Coordinate with the ECL maintainers to get them to stop using it.

  ;; SUPPORTED REPLACEMENT: Use program-op and program-system

  (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)))

                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)

                               (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 :image))))

          (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 (handler-case (rename-file-overwriting-target f new-f)

                      (file-error (c)

                        (declare (ignore c))

                        (copy-file f new-f)

                        (delete-file-if-exists f)))

                :collect new-f)

          files)))



  ;; DEPRECATED. Apparently, some users of ECL, MKCL and ABCL may still be using it;

  ;; but at the very least, this function should be renamed, and/or

  ;; some way of specifying the output directory should be provided.

  ;; As is, it is not such a useful interface.

  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)

    (declare (ignore force verbose version))

    (apply 'operate 'deliver-asd-op system args)))





;;;

;;;

;;; LOAD-BUNDLE-OP

;;; LOAD-BUNDLE-OP
@@ -538,8 +481,7 @@ which is probably not what you want; you probably need to tweak your output tran 
        (when non-fasl-files

        (when non-fasl-files

          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"

          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"

                 (implementation-type) non-fasl-files))

                 (implementation-type) non-fasl-files))

        (when (or (prologue-code o) (epilogue-code o)

        (when (or (prologue-code c) (epilogue-code c))

                  (prologue-code c) (epilogue-code c))

          (error "prologue-code and epilogue-code are not supported on ~A"

          (error "prologue-code and epilogue-code are not supported on ~A"

                 (implementation-type)))

                 (implementation-type)))

        (with-staging-pathname (output-file)

        (with-staging-pathname (output-file)
@@ -615,9 +557,9 @@ which is probably not what you want; you probably need to tweak your output tran 
                       object-files

                       object-files

                       (when programp (postfix-lisp-object-files c)))

                       (when programp (postfix-lisp-object-files c)))

               :kind kind

               :kind kind

               :prologue-code (or (prologue-code o) (when programp (prologue-code c)))

               :prologue-code (when programp (prologue-code c))

               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))

               :epilogue-code (when programp (epilogue-code c))

               :build-args (or (extra-build-args o) (when programp (extra-build-args c)))

               :build-args (when programp (extra-build-args c))

               :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))

               :extra-object-files (when programp (extra-object-files c))

               :no-uiop (no-uiop c)

               :no-uiop (no-uiop c)

               (when programp `(:entry-point ,(component-entry-point c))))))))
 
               (when programp `(:entry-point ,(component-entry-point c))))))))

interface.lisp

+1 −1
Original line number Original line Diff line number Diff line
@@ -35,7 +35,7 @@ 
   #:needed-in-image-p

   #:needed-in-image-p

   #:component-load-dependencies #:run-shell-command ; deprecated, do not use

   #:component-load-dependencies #:run-shell-command ; deprecated, do not use

   #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system

   #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system

   #:program-system #:make-build

   #:program-system

   #:basic-compile-bundle-op #:prepare-bundle-op

   #:basic-compile-bundle-op #:prepare-bundle-op

   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op

   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op

   #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op

   #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op

lisp-action.lisp

+4 −9
Original line number Original line Diff line number Diff line
@@ -3,18 +3,17 @@ 




(uiop/package:define-package :asdf/lisp-action

(uiop/package:define-package :asdf/lisp-action

  (:recycle :asdf/lisp-action :asdf)

  (:recycle :asdf/lisp-action :asdf)

  (:intern #:proclamations #:flags)

  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache

  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache

   :asdf/component :asdf/system :asdf/find-component :asdf/find-system

   :asdf/component :asdf/system :asdf/find-component :asdf/find-system

   :asdf/operation :asdf/action)

   :asdf/operation :asdf/action)

  (:export

  (:export

   #:try-recompiling

   #:try-recompiling

   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp

   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp

   #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations

   #:basic-load-op #:basic-compile-op

   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op

   #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op

   #:call-with-around-compile-hook

   #:call-with-around-compile-hook

   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source

   #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source

   #:lisp-compilation-output-files #:flags))

   #:lisp-compilation-output-files))

(in-package :asdf/lisp-action)

(in-package :asdf/lisp-action)
@@ -35,11 +34,7 @@ 
(with-upgradability ()

(with-upgradability ()

  (defclass basic-load-op (operation) ()

  (defclass basic-load-op (operation) ()

    (:documentation "Base class for operations that apply the load-time effects of a file"))

    (:documentation "Base class for operations that apply the load-time effects of a file"))

  (defclass basic-compile-op (operation)

  (defclass basic-compile-op (operation) ()

    ;; NB: These slots are deprecated. They are for backward compatibility only,

    ;; and will be removed at some point in the future.

    ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)

     (flags :initarg :flags :accessor compile-op-flags :initform nil))

    (:documentation "Base class for operations that apply the compile-time effects of a file")))

    (:documentation "Base class for operations that apply the compile-time effects of a file")))
@@ -125,7 +120,7 @@ Note that it will NOT be called around the performing of LOAD-OP.")) 
                          (append

                          (append

                           #+clisp (list :lib-file lib-file)

                           #+clisp (list :lib-file lib-file)

                           #+(or clasp ecl mkcl) (list :object-file object-file)

                           #+(or clasp ecl mkcl) (list :object-file object-file)

                           flags (compile-op-flags o))))))

                           flags)))))

        (check-lisp-compile-results output warnings-p failure-p

        (check-lisp-compile-results output warnings-p failure-p

                                    "~/asdf-action::format-action/" (list (cons o c))))))

                                    "~/asdf-action::format-action/" (list (cons o c))))))

  (defun report-file-p (f)

  (defun report-file-p (f)

operate.lisp

+4 −8
Original line number Original line Diff line number Diff line
@@ -44,9 +44,6 @@ when instantiating a new operation, that will in turn be inherited by new operat 
But do NOT depend on it, for this is deprecated behavior."))

But do NOT depend on it, for this is deprecated behavior."))





  (define-convenience-action-methods operate (operation component &key)

  (define-convenience-action-methods operate (operation component &key)

    ;; I'd like to at least remove-plist-keys :force :force-not :verbose,

    ;; but swank.asd relies on :force (!).

    :operation-initargs t ;; backward-compatibility with ASDF1. Deprecated.

    :if-no-component (error 'missing-component :requires component))

    :if-no-component (error 'missing-component :requires component))





  (defvar *in-operate* nil

  (defvar *in-operate* nil
@@ -65,9 +62,8 @@ But do NOT depend on it, for this is deprecated behavior.")) 
           (*in-operate* t)

           (*in-operate* t)

           (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)

           (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)

            (etypecase operation

            (etypecase operation

              (operation (let ((name (type-of operation))

              (operation (let ((name (type-of operation)))

                               (initargs (operation-original-initargs operation)))

                           #'(lambda () (make-operation name))))

                           #'(lambda () (apply 'make-operation name :original-initargs initargs initargs))))

              ((or symbol string) (constantly operation))))

              ((or symbol string) (constantly operation))))

           (component-path (typecase component ;; to remake the component after ASDF upgrade

           (component-path (typecase component ;; to remake the component after ASDF upgrade

                             (component (component-find-path component))

                             (component (component-find-path component))
@@ -78,7 +74,7 @@ But do NOT depend on it, for this is deprecated behavior.")) 
       (unless in-operate

       (unless in-operate

         (when (upgrade-asdf)

         (when (upgrade-asdf)

           ;; If we were upgraded, restart OPERATE the hardest of ways, for

           ;; If we were upgraded, restart OPERATE the hardest of ways, for

           ;; its function may have been redefined, its symbol uninterned, its package deleted.

           ;; its function may have been redefined.

           (return-from operate

           (return-from operate

             (apply 'operate (funcall operation-remaker) component-path keys)))))

             (apply 'operate (funcall operation-remaker) component-path keys)))))

      ;; Setup proper bindings around any operate call.

      ;; Setup proper bindings around any operate call.
@@ -284,5 +280,5 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) 
      ;; Mark the timestamps of the common lisp-action operations as 0.

      ;; Mark the timestamps of the common lisp-action operations as 0.

      (let ((times (component-operation-times component)))

      (let ((times (component-operation-times component)))

        (dolist (o '(load-op compile-op prepare-op))

        (dolist (o '(load-op compile-op prepare-op))

          (setf (gethash o times) 0))))))

          (setf (gethash (make-operation o) times) 0))))))