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 @@
`(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
`(,function ,@prefix ,o ,c ,@suffix))))
`(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
,(next-method
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
......
......@@ -49,7 +49,7 @@
(:file "cache" :depends-on ("upgrade"))
(:file "find-system" :depends-on ("system" "cache"))
(: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 "lisp-action" :depends-on ("action"))
(:file "plan" :depends-on ("lisp-action"))
......
......@@ -55,11 +55,13 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(let* ((systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
(operation-name (reify-symbol (etypecase operation
(operation (type-of operation))
(symbol operation))))
(operation-initargs (operation-original-initargs operation))
(component-path (typecase component
(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 () (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))
(t component))))
;; 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:
;; If we were upgraded, restart OPERATE the hardest of ways, for
;; its function may have been redefined, its symbol uninterned, its package deleted.
(return-from operate
(apply (find-symbol* 'operate :asdf)
(apply (find-symbol* 'make-operation :asdf)
(unreify-symbol operation-name)
:original-initargs operation-initargs operation-initargs)
component-path keys))))
(apply 'operate (funcall operation-remaker) component-path keys))))
;; Setup proper bindings around any operate call.
(with-system-definitions ()
(let* ((*verbose-out* (and verbose *standard-output*))
......@@ -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.")
(defclass build-op (non-propagating-operation) ()
(:documentation "BUILD-OP is the recommended 'master' operation,
performing the default operation on a system or component.
The meaning of BUILD-OP 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.
:BUILD-OPERATION may be NIL, in which case BUILD-OP will be interpreted as
*LOAD-SYSTEM-OPERATION*. Currently *LOAD-SYSTEM-OPERATION* will load the system in
the current image, using LOAD-OP."))
(:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
to operate by default on a system or component, via the function BUILD.
Its meaning is configurable via the :BUILD-OPERATION option of a component.
which typically specifies the name of a specific operation to which to delegate the build,
as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on);
if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION*
that will load the system in the current image, and its typically LOAD-OP."))
(defmethod component-depends-on ((o build-op) (c component))
`((,(or (component-build-operation c) *load-system-operation*) ,c)))
(defun build (system &rest keys)
"The recommended way to interact with ASDF3.1 is via (ASDF:BUILD :FOO).
It will build system FOO using the operation BUILD-OP,
......
......@@ -3,7 +3,7 @@
(uiop/package:define-package :asdf/operation
(: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
#:operation
#:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
......@@ -42,8 +42,10 @@
(defparameter* *operations* (make-hash-table :test 'equal))
(defun make-operation (operation-class &rest initargs)
(ensure-gethash (cons operation-class initargs) *operations*
(list* 'make-instance operation-class initargs)))
(let ((class (coerce-class operation-class
:package :asdf/interface :super 'operation :error 'sysdef-error)))
(ensure-gethash (cons class initargs) *operations*
(list* 'make-instance class initargs))))
(defgeneric find-operation (context spec)
(:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
......@@ -52,6 +54,8 @@
(defmethod find-operation (context (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))
......
......@@ -48,22 +48,14 @@
(defvar *default-component-class* 'cl-source-file)
(defun class-for-type (parent type)
(or (loop :for symbol :in (list
type
(find-symbol* type *package* nil)
(find-symbol* type :asdf/interface nil)
(and (stringp type) (safe-read-from-string type :package :asdf/interface)))
:for class = (and symbol (symbolp symbol) (find-class* symbol nil))
:when (and class
(#-cormanlisp subtypep #+cormanlisp cl::subclassp
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))))
(or (coerce-class type :package :asdf/interface :super 'component :error nil)
(and (eq type :file)
(coerce-class
(or (loop :for p = parent :then (component-parent p) :while p
:thereis (module-default-component-class p))
*default-component-class*)
:package :asdf/interface :super 'component :error nil))
(sysdef-error "don't recognize component type ~S" type))))
;;; 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 @@
#:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
#:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS
#:coerce-class ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
#:earlier-stamp #:stamps-earliest #:earliest-stamp
#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
......@@ -333,10 +333,30 @@ the two results passed to STRCAT always reconstitute the original string"
;;; CLOS
(with-upgradability ()
(defun find-class* (x &optional (errorp t) environment)
(etypecase x
((or standard-class built-in-class) x)
(symbol (find-class x errorp environment)))))
(defun coerce-class (class &key (package :cl) (super t) (error 'error))
"Coerce CLASS to a class that is subclass of SUPER if specified,
or invoke ERROR handler as per CALL-FUNCTION.
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
......
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