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

Get fully rid of operation initargs

ASDF never supported operation initargs, and its component-operation-times
always assumed that two operations of the same class were equivalent.
Make it explicitly so and enforce it.

Do NOT pass keys from operate to make-instance operation.
Catch any attempt to create an operation with initargs and raise an error.
Make sure no operation class has any slot that isn't :allocation :class
(with some MOP magic we could do it in at class definition time,
but that's not portable enough and we don't want to reimplement closer-mop
or depend on it.)

This is a preliminary to allowing CONS instead of NODE-FOR to identify actions,
whether or not we want to allow some form of initargs in the future.

Remove unused COMPILE-OP-FLAGS and COMPILE-OP-PROCLAMATIONS.
Remove MAKE-BUILD that depended on the unsupported operation initargs.
Use PROGRAM-OP on a PROGRAM-SYSTEM instead.
Remove the confusingly misnamed and not-so-useful BUILD-SYSTEM function;
it can be done better in userland.
parent 1705ceed
Loading
Loading
Loading
Loading
+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))))
+30 −88
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) ()
@@ -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"))
@@ -204,13 +200,13 @@ for all the linkable object files associated with the system or its dependencies


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