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

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
......@@ -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))))
......
This diff is collapsed.
......@@ -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
......
......@@ -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)
......
......@@ -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))))))
......@@ -6,40 +6,25 @@
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
(:export
#:operation
#:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
#:*operations* #:make-operation #:find-operation
#:feature)) ;; TODO: stop exporting the deprecated FEATURE feature.
(in-package :asdf/operation)
;;; Operation Classes
(when-upgrading (:when (find-class 'operation nil))
(when-upgrading (:version "2.27" :when (find-class 'operation nil))
;; override any obsolete shared-initialize method when upgrading from ASDF2.
(defmethod shared-initialize :after ((o operation) (slot-names t) &key)
(values)))
(with-upgradability ()
(defclass operation ()
((original-initargs ;; for backward-compat -- used by GBBopen, and swank (via operation-forced)
:initform nil :initarg :original-initargs :accessor operation-original-initargs))
()
(:documentation "The base class for all ASDF operations.
ASDF does NOT, never did and never will distinguish between multiple operations of the same class.
Therefore, all slots of all operations must have (:allocation class) and no initargs.
Any exceptions currently maintained for backward-compatibility are deprecated,
and support for them may be discontinued at any moment.
ASDF does NOT and never did distinguish between multiple operations of the same class.
Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions.
"))
;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not already bound.
;; This is a deprecated feature temporarily maintained for backward compatibility.
;; It will be removed at some point in the future.
(defmethod initialize-instance :after ((o operation) &rest initargs
&key force force-not system verbose &allow-other-keys)
(declare (ignore force force-not system verbose))
(unless (slot-boundp o 'original-initargs)
(setf (operation-original-initargs o) initargs)))
(defvar *in-make-operation* nil)
(defun check-operation-constructor ()
......@@ -48,9 +33,13 @@ and support for them may be discontinued at any moment.
(sysdef-error "OPERATION instances must only be created through MAKE-OPERATION.")))
(defmethod print-object ((o operation) stream)
(print-unreadable-object (o stream :type t :identity nil)
(ignore-errors
(format stream "~{~S~^ ~}" (operation-original-initargs o))))))
(print-unreadable-object (o stream :type t :identity nil)))
;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking.
(defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys)
(unless (null initargs)
(parameter-error "~S does not accept initargs" 'operation))))
;;; make-operation, find-operation
......@@ -59,30 +48,27 @@ and support for them may be discontinued at any moment.
(defparameter* *operations* (make-hash-table :test 'equal))
;; A memoizing way of creating instances of operation.
(defun make-operation (operation-class &rest initargs)
(defun make-operation (operation-class)
"This function creates and memoizes an instance of OPERATION-CLASS.
All operation instances MUST be created through this function.
Use of INITARGS is for backward compatibility and may be discontinued at any time."
Use of INITARGS is not supported at this time."
(let ((class (coerce-class operation-class
:package :asdf/interface :super 'operation :error 'sysdef-error))
(*in-make-operation* t))
(ensure-gethash (cons class initargs) *operations*
(list* 'make-instance class initargs))))
(ensure-gethash class *operations* `(make-instance ,class))))
;; We preserve the operation-original-initargs of the context,
;; but only as an unsupported feature.
;; This is all done purely for the temporary sake of backwards compatibility.
;; This function is mostly for backward and forward compatibility:
;; operations used to preserve the operation-original-initargs of the context,
;; and may in the future preserve some operation-canonical-initargs.
;; Still, the treatment of NIL as a disabling context is useful in some cases.
(defgeneric find-operation (context spec)
(:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
(defmethod find-operation ((context t) (spec operation))
spec)
(defmethod find-operation (context (spec symbol))
(defmethod find-operation ((context t) (spec symbol))
(when spec ;; NIL designates itself, i.e. absence of operation
(apply 'make-operation spec (operation-original-initargs context))))
(defmethod find-operation (context (spec string))
(apply 'make-operation spec (operation-original-initargs context)))
(defmethod operation-original-initargs ((context symbol))
(declare (ignorable context))
nil))
(make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
(defmethod find-operation ((context t) (spec string))
(make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
......@@ -12,7 +12,7 @@
#:plan #:plan-traversal #:sequential-plan #:*default-plan-class*
#:planned-action-status #:plan-action-status #:action-already-done-p
#:circular-dependency #:circular-dependency-actions
#:node-for #:needed-in-image-p
#:needed-in-image-p
#:action-index #:action-planned-p #:action-valid-p
#:plan-record-dependency
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p
......@@ -83,13 +83,6 @@ the action of OPERATION on COMPONENT in the PLAN"))
(defmethod action-planned-p ((action-status t))
t) ; default method for non planned-action-status objects
;; TODO: either confirm there are no operation-original-initargs, eliminate NODE-FOR,
;; and use (CONS O C); or keep the operation initargs, and here use MAKE-OPERATION.
;; However, see also component-operation-time and mark-operation-done
(defun node-for (o c)
"Given operation O and component C, return an object to use as key in action-indexed tables."
(cons (type-of o) c))
(defun action-already-done-p (plan operation component)
"According to this plan, is this action already done and up to date?"
(action-done-p (plan-action-status plan operation component)))
......@@ -99,11 +92,10 @@ the action of OPERATION on COMPONENT in the PLAN"))
(make-instance 'action-status :stamp stamp :done-p done-p)))
(defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component))
(let ((to (type-of o))
(times (component-operation-times c)))
(let ((times (component-operation-times c)))
(if (action-done-p new-status)
(remhash to times)
(setf (gethash to times) (action-stamp new-status))))
(remhash o times)
(setf (gethash o times) (action-stamp new-status))))
new-status))
......@@ -315,11 +307,11 @@ initialized with SEED."
plan)
(defmethod (setf plan-action-status) (new-status (p plan-traversal) (o operation) (c component))
(setf (gethash (node-for o c) (plan-visited-actions p)) new-status))
(setf (gethash (cons o c) (plan-visited-actions p)) new-status))
(defmethod plan-action-status ((p plan-traversal) (o operation) (c component))
(or (and (action-forced-not-p p o c) (plan-action-status nil o c))
(values (gethash (node-for o c) (plan-visited-actions p)))))
(values (gethash (cons o c) (plan-visited-actions p)))))
(defmethod action-valid-p ((p plan-traversal) (o operation) (s system))
(and (not (action-forced-not-p p o s)) (call-next-method)))
......
;;;; a.lisp
(defpackage :sample
(:use #:cl)
(:export #:loaded))
(in-package :sample)
(defparameter loaded t)
;;;; foo.asd
(asdf:defsystem #:sample-system
:serial t
:components ((:file "a")))
;;; -*- Lisp -*-
(unless (or #+(or (and clisp os-unix) clozure cmucl
(and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t)
(DBG "Creating executables is not supported on your CL implementation")
(leave-test "Skipping test" 0))
(DBG "build sample-system. Should load from sample-system/")
(setf *central-registry* (list (subpathname *test-directory* "sample-system/")))
#+lispworks (lispworks:load-all-patches)
(make-build 'sample-system
:type :program :monolithic t
#+ecl :epilogue-code #+ecl '(println "blue sky"))
......@@ -23,11 +23,11 @@
(defun simplify-pathname-directory-component (dir)
(setf dir (normalize-pathname-directory-component dir))
(loop
:with head = (progn
(unless (and (consp dir) (cdr dir)) (return dir))
(subseq dir 0 1))
:with tail = (rest dir)
:for (next rest) :on tail :do
:with head = (progn
(unless (and (consp dir) (cdr dir)) (return dir))
(subseq dir 0 1))
:with tail = (rest dir)
:for next :in tail :do
(unless (equal next ".")
(when (member next '(".." :up) :test 'equal) (setf next :back))
(setf head (merge-pathname-directory-components (list :relative next) head)))
......@@ -213,9 +213,7 @@
asdf/action:done-p
asdf/action:stamp
asdf/bundle:prologue-code
asdf/bundle:build-args
asdf/bundle:epilogue-code
asdf/bundle:name-suffix
asdf/component:absolute-pathname
asdf/component:around-compile
asdf/component:author
......@@ -242,9 +240,7 @@
asdf/component:relative-pathname
asdf/component:sideway-dependencies
asdf/component:version
asdf/lisp-action:flags
asdf/operation:feature
asdf/operation:original-initargs
asdf/plan:index
asdf/plan:forced
asdf/plan:forced-not
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment