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

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
......@@ -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)))
......
......@@ -4,5 +4,4 @@
(ffi::def-foreign-var ("hello_string" +hello-string+) (* :char) nil)
(print (ffi:convert-from-foreign-string +hello-string+))
(princ (ffi:convert-from-foreign-string +hello-string+))
(defsystem #:hellow
:serial t
:components ((:file "hello")))
(defsystem "hellow"
:components ((:file "hello"))
:class program-system
:build-operation program-op
:build-pathname "hellow"
:prologue-code "printf(\"Good morning sunshine!\\n\");fflush(stdout);"
:epilogue-code (progn
(format t "~%Good bye sunshine.~%")
(ext:quit 0))
:no-uiop t
:extra-build-args (:ld-flags #.(list (namestring (compile-file-pathname "hello_aux.c" :type :object)))))
......@@ -49,20 +49,7 @@
:defaults *load-truename*)
asdf:*central-registry*)
(asdf:make-build :hellow
:type :program
:move-here "./"
:prologue-code "printf(\"Good morning sunshine!\");"
:epilogue-code '(progn
(format t "~%Good bye sunshine.~%")
(ext:quit 0))
:ld-flags
(list (namestring (compile-file-pathname "hello_aux.c" :type :object))))
;; This doesn't seem to work
;; (asdf:operate 'asdf:program-op :hellow
;; :ld-flags
;; (list (namestring (compile-file-pathname "hello_aux.c" :type :object))))
(asdf:make "hellow")
;;
;; * Test the program
......
(asdf:defsystem #:hellow
:serial t
:depends-on (#:asdf)
:components ((:file "hello")))
(defsystem "hellow"
:depends-on ("asdf")
:components ((:file "hello"))
:class program-system
:build-operation program-op
:build-pathname "hellow"
:prologue-code "printf(\"Good morning sunshine!\");fflush(stdout);"
:epilogue-code (progn (format t "~%Good bye sunshine.~%") (ext:quit 0)))
......@@ -31,13 +31,7 @@
:defaults *load-truename*)
asdf:*central-registry*)
(asdf:make-build :hellow
:type :program
:move-here "./"
:prologue-code "printf(\"Good morning sunshine!\");"
:epilogue-code '(progn
(format t "~%Good bye sunshine.~%")
(ext:quit 0)))
(asdf:make "hellow")
;;
;; * Test the program
......
;;;; 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
......
......@@ -461,18 +461,24 @@ A class object designates itself.
NIL designates itself (no class).
A symbol otherwise designates a class by name."
(let* ((normalized
(typecase class
(typecase class
(keyword (or (find-symbol* class package nil)
(find-symbol* class *package* nil)))
(string (symbol-call :uiop :safe-read-from-string class :package package))
(t class)))
(found
(etypecase normalized
((or standard-class built-in-class) normalized)
((or null keyword) nil)
(symbol (find-class normalized nil nil)))))
(etypecase normalized
((or standard-class built-in-class) normalized)
((or null keyword) nil)
(symbol (find-class normalized nil nil))))
(super-class
(etypecase super
((or standard-class built-in-class) super)
((or null keyword) nil)
(symbol (find-class super nil nil)))))
#+allegro (when found (mop:finalize-inheritance found))
(or (and found
(or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super))
(or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class))
found)
(call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
......
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