Commit 50f2420f authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Accept strings as OPERATION class designators, read in package ASDF.

Refactor COMPONENT class designators to use the same general method.
As a substrate, goodbye uiop/utility:find-class*, hello uiop/utility:coerce-class.

In the operate upgrade handler, assume there is
no uninterning and renaming packages away anymore going forward.

Add tests for strings as class designators using defsystem-depends-on.
parent 4544d8db
...@@ -66,7 +66,10 @@ ...@@ -66,7 +66,10 @@
`(apply ',function ,@prefix ,o ,c ,@suffix ,rest) `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
`(,function ,@prefix ,o ,c ,@suffix)))) `(,function ,@prefix ,o ,c ,@suffix))))
`(progn `(progn
(defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args) (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args)
(let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on
,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component)))
(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. (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
......
...@@ -49,7 +49,7 @@ ...@@ -49,7 +49,7 @@
(:file "cache" :depends-on ("upgrade")) (:file "cache" :depends-on ("upgrade"))
(:file "find-system" :depends-on ("system" "cache")) (:file "find-system" :depends-on ("system" "cache"))
(:file "find-component" :depends-on ("find-system")) (:file "find-component" :depends-on ("find-system"))
(:file "operation" :depends-on ("upgrade")) (:file "operation" :depends-on ("find-system"))
(:file "action" :depends-on ("find-component" "operation")) (:file "action" :depends-on ("find-component" "operation"))
(:file "lisp-action" :depends-on ("action")) (:file "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action")) (:file "plan" :depends-on ("lisp-action"))
......
...@@ -55,11 +55,13 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ...@@ -55,11 +55,13 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(on-failure *compile-file-failure-behaviour*) &allow-other-keys) (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(let* ((systems-being-operated *systems-being-operated*) (let* ((systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
(operation-name (reify-symbol (etypecase operation (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
(operation (type-of operation)) (etypecase operation
(symbol operation)))) (operation (let ((name (type-of operation))
(operation-initargs (operation-original-initargs operation)) (initargs (operation-original-initargs operation)))
(component-path (typecase component #'(lambda () (make-operation name :original-initargs initargs initargs))))
((or symbol string) (constantly operation))))
(component-path (typecase component ;; to remake the component after ASDF upgrade
(component (component-find-path component)) (component (component-find-path component))
(t component)))) (t component))))
;; Before we operate on any system, make sure ASDF is up-to-date, ;; Before we operate on any system, make sure ASDF is up-to-date,
...@@ -69,11 +71,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ...@@ -69,11 +71,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
;; 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, its symbol uninterned, its package deleted.
(return-from operate (return-from operate
(apply (find-symbol* 'operate :asdf) (apply 'operate (funcall operation-remaker) component-path keys))))
(apply (find-symbol* 'make-operation :asdf)
(unreify-symbol operation-name)
:original-initargs operation-initargs operation-initargs)
component-path keys))))
;; Setup proper bindings around any operate call. ;; Setup proper bindings around any operate call.
(with-system-definitions () (with-system-definitions ()
(let* ((*verbose-out* (and verbose *standard-output*)) (let* ((*verbose-out* (and verbose *standard-output*))
...@@ -113,17 +111,16 @@ The default operation may change in the future if we implement a ...@@ -113,17 +111,16 @@ The default operation may change in the future if we implement a
component-directed strategy for how to load or compile systems.") component-directed strategy for how to load or compile systems.")
(defclass build-op (non-propagating-operation) () (defclass build-op (non-propagating-operation) ()
(:documentation "BUILD-OP is the recommended 'master' operation, (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
performing the default operation on a system or component. to operate by default on a system or component, via the function BUILD.
The meaning of BUILD-OP is configurable via the :BUILD-OPERATION option of a component, Its meaning is configurable via the :BUILD-OPERATION option of a component.
which is typically the name of a specific operation to which to delegate the build. which typically specifies the name of a specific operation to which to delegate the build,
:BUILD-OPERATION may be NIL, in which case BUILD-OP will be interpreted as as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on);
*LOAD-SYSTEM-OPERATION*. Currently *LOAD-SYSTEM-OPERATION* will load the system in if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION*
the current image, using LOAD-OP.")) that will load the system in the current image, and its typically LOAD-OP."))
(defmethod component-depends-on ((o build-op) (c component)) (defmethod component-depends-on ((o build-op) (c component))
`((,(or (component-build-operation c) *load-system-operation*) ,c))) `((,(or (component-build-operation c) *load-system-operation*) ,c)))
(defun build (system &rest keys) (defun build (system &rest keys)
"The recommended way to interact with ASDF3.1 is via (ASDF:BUILD :FOO). "The recommended way to interact with ASDF3.1 is via (ASDF:BUILD :FOO).
It will build system FOO using the operation BUILD-OP, It will build system FOO using the operation BUILD-OP,
......
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(uiop/package:define-package :asdf/operation (uiop/package:define-package :asdf/operation
(:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
(:use :uiop/common-lisp :uiop :asdf/upgrade) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
(:export (:export
#:operation #:operation
#:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
...@@ -42,8 +42,10 @@ ...@@ -42,8 +42,10 @@
(defparameter* *operations* (make-hash-table :test 'equal)) (defparameter* *operations* (make-hash-table :test 'equal))
(defun make-operation (operation-class &rest initargs) (defun make-operation (operation-class &rest initargs)
(ensure-gethash (cons operation-class initargs) *operations* (let ((class (coerce-class operation-class
(list* 'make-instance operation-class initargs))) :package :asdf/interface :super 'operation :error 'sysdef-error)))
(ensure-gethash (cons class initargs) *operations*
(list* 'make-instance class initargs))))
(defgeneric find-operation (context spec) (defgeneric find-operation (context spec)
(:documentation "Find an operation by resolving the SPEC in the CONTEXT")) (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
...@@ -52,6 +54,8 @@ ...@@ -52,6 +54,8 @@
(defmethod find-operation (context (spec symbol)) (defmethod find-operation (context (spec symbol))
(when spec ;; NIL designates itself, i.e. absence of operation (when spec ;; NIL designates itself, i.e. absence of operation
(apply 'make-operation spec (operation-original-initargs context)))) (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)) (defmethod operation-original-initargs ((context symbol))
(declare (ignorable context)) (declare (ignorable context))
nil)) nil))
......
...@@ -48,22 +48,14 @@ ...@@ -48,22 +48,14 @@
(defvar *default-component-class* 'cl-source-file) (defvar *default-component-class* 'cl-source-file)
(defun class-for-type (parent type) (defun class-for-type (parent type)
(or (loop :for symbol :in (list (or (coerce-class type :package :asdf/interface :super 'component :error nil)
type (and (eq type :file)
(find-symbol* type *package* nil) (coerce-class
(find-symbol* type :asdf/interface nil) (or (loop :for p = parent :then (component-parent p) :while p
(and (stringp type) (safe-read-from-string type :package :asdf/interface))) :thereis (module-default-component-class p))
:for class = (and symbol (symbolp symbol) (find-class* symbol nil)) *default-component-class*)
:when (and class :package :asdf/interface :super 'component :error nil))
(#-cormanlisp subtypep #+cormanlisp cl::subclassp (sysdef-error "don't recognize component type ~S" type))))
class (find-class* 'component)))
:return class)
(and (eq type :file)
(find-class*
(or (loop :for p = parent :then (component-parent p) :while p
:thereis (module-default-component-class p))
*default-component-class*) nil))
(sysdef-error "don't recognize component type ~A" type))))
;;; Check inputs ;;; Check inputs
......
(defpackage :l-file
(:use :asdf :uiop :cl) ;; asdf/package-system dependencies
(:export #:cl-source-file.l))
(in-package :l-file)
(defclass cl-source-file.l (cl-source-file)
((type :initform "l")))
(defclass asdf::cl-source-file.l (cl-source-file.cl) ())
(cl:defpackage :l-operation
(:use :asdf :uiop :cl) ;; asdf/package-system dependencies
(:export #:op #:*x*))
(cl:in-package :l-operation)
(defparameter *x* 0)
(defclass op (load-op) ())
(defmethod perform :after ((o op) (c t))
(incf *x*))
;;-*- Lisp -*-
(def-test-system test-defsystem-depends-on-1
:defsystem-depends-on (test-asdf/l-file)
:default-component-class "l-file:cl-source-file.l"
:components
((:cl-source-file.l "file1" :type "lisp")
(:cl-source-file "file2" :depends-on ("file1"))
(:file "test-extension")))
(load-system :test-defsystem-depends-on-1)
(def-test-system test-defsystem-depends-on-2
:defsystem-depends-on (test-asdf/l-operation)
:build-operation "l-operation:op"
:components
((:file "file3")))
(assert-equal 0 l-operation:*x*)
(build :test-defsystem-depends-on-2)
(assert-equal 2 l-operation:*x*) ;; perform called twice, on file and on system.
(def-test-system test-defsystem-depends-on-3
:defsystem-depends-on (test-asdf/l-operation)
:build-operation "does-not-exist"
:components ((:file "file3")))
(signals asdf::formatted-system-definition-error (build :test-defsystem-depends-on-3))
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,7 @@
#:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
#:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
#:string-prefix-p #:string-enclosed-p #:string-suffix-p #:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS #:coerce-class ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
#:earlier-stamp #:stamps-earliest #:earliest-stamp #:earlier-stamp #:stamps-earliest #:earliest-stamp
#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
...@@ -333,10 +333,30 @@ the two results passed to STRCAT always reconstitute the original string" ...@@ -333,10 +333,30 @@ the two results passed to STRCAT always reconstitute the original string"
;;; CLOS ;;; CLOS
(with-upgradability () (with-upgradability ()
(defun find-class* (x &optional (errorp t) environment) (defun coerce-class (class &key (package :cl) (super t) (error 'error))
(etypecase x "Coerce CLASS to a class that is subclass of SUPER if specified,
((or standard-class built-in-class) x) or invoke ERROR handler as per CALL-FUNCTION.
(symbol (find-class x errorp environment)))))
A keyword designates the name a symbol, which when found in PACKAGE, designates a class.
A string is read as a symbol while in PACKAGE, the symbol designates a class.
A class object designates itself.
NIL designates itself (no class).
A symbol otherwise designates a class by name."
(let* ((normalized
(typecase class
(keyword (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)))))
(or (and found
(or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super))
found)
(call-function error "Can't coerce ~S to a ~@[class~;subclass of ~:*~S]" class super)))))
;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity ;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
......
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