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
Loading
Loading
Loading
Loading
+6 −10
Original line number 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)
    (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 ()
  (defun action-path (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.
  ;; 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 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
      (function formals &key if-no-operation if-no-component operation-initargs)
      (function formals &key if-no-operation if-no-component)
    (let* ((rest (gensym "REST"))
           (found (gensym "FOUND"))
           (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)
             (if ,operation
                 ,(next-method
                   (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
                       `(apply 'make-operation ,operation :original-initargs ,rest ,rest)
                       `(make-operation ,operation))
                   `(make-operation ,operation)
                   `(or (find-component () ,component) ,if-no-component))
                 ,if-no-operation))
           (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."))
  (defmethod action-description (operation component)
    (format nil (compatfmt "~@<~A on ~A~@:>")
            (type-of operation) component))
            operation component))

  (defun format-action (stream action &optional colon-p at-sign-p)
    "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))))

  (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))
    (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))
    (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t))))
+36 −94
Original line number Diff line number Diff line
@@ -17,8 +17,7 @@
   #:deliver-asd-op #:monolithic-deliver-asd-op
   #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
   #:user-system-p #:user-system #:trivial-system-p
   #:make-build
   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
   #:prologue-code #:epilogue-code #:static-library))
(in-package :asdf/bundle)

(with-upgradability ()
@@ -26,10 +25,7 @@
    ;; NB: use of instance-allocated slots for operations is DEPRECATED
    ;; and only supported in a temporary fashion for backward compatibility.
    ;; Supported replacement: Define slots on program-system instead.
    ((build-args :initarg :args :initform nil :accessor extra-build-args)
     (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))
    ((bundle-type :initform :no-output-file :reader bundle-type :allocation :class))
    (:documentation "base class for operations that bundle outputs from multiple components"))

  (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
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.
    ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
    ((prologue-code :initform nil :accessor prologue-code)
@@ -60,13 +56,13 @@ itself."))
     (extra-build-args :initarg :extra-build-args
                       :initform nil :accessor extra-build-args)))

  (defmethod prologue-code ((x t)) nil)
  (defmethod epilogue-code ((x t)) nil)
  (defmethod no-uiop ((x t)) nil)
  (defmethod prefix-lisp-object-files ((x t)) nil)
  (defmethod postfix-lisp-object-files ((x t)) nil)
  (defmethod extra-object-files ((x t)) nil)
  (defmethod extra-build-args ((x t)) nil)
  (defmethod prologue-code ((x system)) nil)
  (defmethod epilogue-code ((x system)) nil)
  (defmethod no-uiop ((x system)) nil)
  (defmethod prefix-lisp-object-files ((x system)) nil)
  (defmethod postfix-lisp-object-files ((x system)) nil)
  (defmethod extra-object-files ((x system)) nil)
  (defmethod extra-build-args ((x system)) nil)

  (defclass link-op (bundle-op) ()
    (: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"))


  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
  (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
    ((selfward-operation
      ;; TODO: implement link-op on all implementations, and make that
      ;; '(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."))

  (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)
    ((gather-operation
      :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))
    (: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))
    (: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))
    (: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."))

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

  (defclass image-op (monolithic-bundle-op selfward-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)
     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
    (:documentation "create an image file from the system and its dependencies"))

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

  ;; 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.
                  (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
        (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)))
          (values (list (subpathname (component-pathname c) name :type type))
                  (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.
;;; The different targets are defined by specialization.
;;;
(with-upgradability ()
  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
                                         &key (name-suffix nil name-suffix-p)
                                         &allow-other-keys)
    (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))))
(when-upgrading (:version "3.1.9")
  ;; Cancel any previously defined method
  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
    (declare (ignore initargs))))

(with-upgradability ()
  (defgeneric trivial-system-p (component))

  (defun user-system-p (s)
@@ -362,48 +346,7 @@ or of opaque libraries shipped along the source code."))
      ((:image)
       'image-op)
      ((:program)
       '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)))
       'program-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
          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
                 (implementation-type) non-fasl-files))
        (when (or (prologue-code o) (epilogue-code o)
                  (prologue-code c) (epilogue-code c))
        (when (or (prologue-code c) (epilogue-code c))
          (error "prologue-code and epilogue-code are not supported on ~A"
                 (implementation-type)))
        (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
                       (when programp (postfix-lisp-object-files c)))
               :kind kind
               :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
               :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
               :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
               :prologue-code (when programp (prologue-code c))
               :epilogue-code (when programp (epilogue-code c))
               :build-args (when programp (extra-build-args c))
               :extra-object-files (when programp (extra-object-files c))
               :no-uiop (no-uiop c)
               (when programp `(:entry-point ,(component-entry-point c))))))))
+1 −1
Original line number Diff line number Diff line
@@ -35,7 +35,7 @@
   #:needed-in-image-p
   #:component-load-dependencies #:run-shell-command ; deprecated, do not use
   #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
   #:program-system #:make-build
   #:program-system
   #:basic-compile-bundle-op #:prepare-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
+4 −9
Original line number Diff line number Diff line
@@ -3,18 +3,17 @@

(uiop/package:define-package :asdf/lisp-action
  (:recycle :asdf/lisp-action :asdf)
  (:intern #:proclamations #:flags)
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
   :asdf/component :asdf/system :asdf/find-component :asdf/find-system
   :asdf/operation :asdf/action)
  (:export
   #:try-recompiling
   #: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
   #:call-with-around-compile-hook
   #: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)


@@ -35,11 +34,7 @@
(with-upgradability ()
  (defclass basic-load-op (operation) ()
    (:documentation "Base class for operations that apply the load-time effects of a file"))
  (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))
  (defclass basic-compile-op (operation) ()
    (: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
                           #+clisp (list :lib-file lib-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
                                    "~/asdf-action::format-action/" (list (cons o c))))))
  (defun report-file-p (f)
+4 −8
Original line number 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."))

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

  (defvar *in-operate* nil
@@ -65,9 +62,8 @@ But do NOT depend on it, for this is deprecated behavior."))
           (*in-operate* t)
           (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
            (etypecase operation
              (operation (let ((name (type-of operation))
                               (initargs (operation-original-initargs operation)))
                           #'(lambda () (apply 'make-operation name :original-initargs initargs initargs))))
              (operation (let ((name (type-of operation)))
                           #'(lambda () (make-operation name))))
              ((or symbol string) (constantly operation))))
           (component-path (typecase component ;; to remake the component after ASDF upgrade
                             (component (component-find-path component))
@@ -78,7 +74,7 @@ But do NOT depend on it, for this is deprecated behavior."))
       (unless in-operate
         (when (upgrade-asdf)
           ;; 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
             (apply 'operate (funcall operation-remaker) component-path keys)))))
      ;; 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.
      (let ((times (component-operation-times component)))
        (dolist (o '(load-op compile-op prepare-op))
          (setf (gethash o times) 0))))))
          (setf (gethash (make-operation o) times) 0))))))
Loading