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 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))))
+30 −88
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) ()
@@ -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"))
@@ -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
                      #+(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