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

REMOVE support for per-system special bindings

Undo all changes that implement per-system special bindings, whereby a set of
syntax variables are set to known values around actions concerning a system.
This reversal is made in view of making a minimal change towards syntax control,
and may be reversed again in some future.

A rollback of this commit is expected at some indefinite point in the future.
parent 8b3f67f7
......@@ -4,8 +4,7 @@
(uiop/package:define-package :asdf/action
(:nicknames :asdf-action)
(:recycle :asdf/action :asdf/plan :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
:asdf/component :asdf/system :asdf/operation)
(:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation)
(:import-from :asdf/operation #:check-operation-constructor)
(:import-from :asdf/component #:%additional-input-files)
(:export
......@@ -18,7 +17,6 @@
#:action-operation #:action-component #:make-action
#:component-operation-time #:mark-operation-done #:compute-action-stamp
#:perform #:perform-with-restarts #:retry #:accept
#:with-action-context #:call-with-action-context
#:action-path #:find-action
#:operation-definition-warning #:operation-definition-error ;; condition
#:action-valid-p
......@@ -464,22 +462,12 @@ Returns two values:
;;;; Perform
(with-upgradability ()
(defgeneric call-with-action-context (operation component thunk))
(define-convenience-action-methods call-with-action-context (operation component thunk))
(defmethod call-with-action-context ((o operation) (c component) thunk)
(with-updated-system-variables ((component-system c))
(call-function thunk)))
(defmacro with-action-context ((operation component) &body body)
`(call-with-action-context ,operation ,component #'(lambda () ,@body)))
(defgeneric perform (operation component)
(:documentation "PERFORM an action, consuming its input-files and building its output-files"))
(define-convenience-action-methods perform (operation component))
(defmethod perform :around ((o operation) (c component))
(while-visiting-action (o c)
(with-action-context (o c)
(call-next-method))))
(while-visiting-action (o c) (call-next-method)))
(defmethod perform :before ((o operation) (c component))
(ensure-all-directories-exist (output-files o c)))
(defmethod perform :after ((o operation) (c component))
......
......@@ -37,9 +37,6 @@
(:documentation "Base class for operations that apply the compile-time effects of a file"))
(defclass basic-prepare-op (operation) ())
(defmethod perform ((operation basic-prepare-op) (system system))
(initialize-system-variables system)
(use-initial-system-variables system))
(defvar *cl-reading-hook* 'call-function
"Hook to call around operations that read CL code (since ASDF 3.1).
......
......@@ -9,12 +9,6 @@
#:system-source-file #:system-source-directory #:system-relative-pathname
#:system-description #:system-long-description
#:system-author #:system-maintainer #:system-licence #:system-license
#:*default-system-variables* #:*asdf-syntax-variables*
#:compute-system-variables #:configure-system-variables #:configure-system-variable
#:with-updated-system-variables
#:use-initial-system-variables #:use-current-system-variables
#:initialize-system-variables #:update-system-variables
#:system-variable-specs #:system-variable-names #:system-variable-values #:system-variable-initializers
#:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on
#:system-depends-on #:system-weakly-depends-on
#:component-build-pathname #:build-pathname
......@@ -102,103 +96,10 @@ a SYSTEM is redefined and its class is modified."))
:initform nil)
;; these two are specially set in parse-component-form, so have no :INITARGs.
(depends-on :reader system-depends-on :initform nil)
(weakly-depends-on :reader system-weakly-depends-on :initform nil)
;; System variables
(variable-specs :initform nil :initarg :variables :reader system-variable-specs)
(variable-names :accessor system-variable-names)
(variable-values :accessor system-variable-values)
(variable-initializers :accessor system-variable-initializers))
(weakly-depends-on :reader system-weakly-depends-on :initform nil))
(:documentation "SYSTEM is the base class for top-level components that users may request
ASDF to build."))
(defun ensure-system-variable (variable &key when-undefined)
(ensure-variable variable :package :asdf :when-undefined when-undefined))
(defvar *asdf-syntax-variables*
`(,@*standard-syntax-variables*
(*readtable* . ,*shared-readtable*)
(*print-pprint-dispatch* . ,*shared-print-pprint-dispatch*)
(*package* . (find-package :asdf-user))))
(defvar *default-system-variables* '()) ;; make it *asdf-syntax-variables* for safety
(defgeneric configure-system-variable (system variable &key))
(defmethod configure-system-variable ((system system) variable &key (initializer nil initp))
;; You should configure system variables only during the call to compute-system-variables.
;; During configuration, the initializer hash-table ensures each variable appears only once,
;; modulo the fact that you can designate a variable using multiple names, in which case you lose.
;; The heuristics should be simple, though: if it's a CL or ASDF variable, just use it;
;; otherwise, use a string that has : if and only if the variable is exported,
;; which it should be if you're not the author of the system.
;; Beware that initializers will be called in the order the variables were declared,
;; which, if you override a variable's initializer,
;; will be earlier than other variables you're initializing.
(let ((value (variable-value variable :package :asdf :when-undefined nil))
(previousp (nth-value 1 (gethash variable (system-variable-initializers system)))))
(unless previousp
(push variable (system-variable-names system))
(push value (system-variable-values system)))
(when (or initp (not previousp))
(setf (gethash variable (system-variable-initializers system))
(if initp initializer (constantly value)))))
nil)
(defgeneric configure-system-variables (system variable-specs))
(defmethod configure-system-variables ((system system) variable-specs)
(dolist (spec variable-specs)
(multiple-value-bind (variable keys)
(if (consp spec)
(values (first spec) (when (consp (cdr spec)) (list :initializer (second spec))))
(values spec nil))
(apply 'configure-system-variable system variable keys))))
(defgeneric update-system-variables (system))
(defmethod update-system-variables ((system system))
(setf (system-variable-values system)
(loop :for variable :in (system-variable-names system)
:collect (variable-value variable :package :asdf :when-undefined nil))))
(defgeneric system-variable-initializer-list (system))
(defmethod system-variable-initializer-list ((system system))
(loop :for var :in (system-variable-names system)
:collect (gethash var (system-variable-initializers system))))
(defun use-initial-system-variables (system)
(set-variables (system-variable-names system) (system-variable-initializer-list system)
:name #'ensure-system-variable :value #'call-function))
(defun use-current-system-variables (system)
(set-variables (system-variable-names system) (system-variable-values system)
:name #'ensure-system-variable))
(defmacro with-updated-system-variables ((component) &body body)
`(call-with-updated-system-variables ,component #'(lambda () ,@body)))
(defun call-with-updated-system-variables (component thunk)
(let ((system (component-system component)))
(with-variables ((system-variable-names system) (system-variable-values system)
:name #'ensure-system-variable)
(multiple-value-prog1 (call-function thunk)
(update-system-variables system)))))
(defgeneric compute-system-variables (system))
(defmethod compute-system-variables ((system system))
(configure-system-variables system (system-variable-specs system))
;; TODO: insert an out-of-band system configuration facility <here>, or in an :after method.
nil)
(defun initialize-system-variables (system)
(setf (system-variable-names system) nil
(system-variable-values system) nil
(system-variable-initializers system) (make-hash-table :test 'equal))
(compute-system-variables system)
(setf (system-variable-names system) (reverse (system-variable-names system))
(system-variable-values system) (reverse (system-variable-values system))))
(defmethod shared-initialize :after ((system system) slot-names &key)
(declare (ignore slot-names))
(initialize-system-variables system))
(defclass undefined-system (system) ()
(:documentation "System that was not defined yet."))
......
......@@ -10,8 +10,7 @@
#:*shared-readtable* #:*shared-print-pprint-dispatch*
#:*standard-syntax-variables*
#:call-with-shared-syntax #:with-shared-syntax
#:eval-input #:eval-thunk #:shared-eval-thunk
#:ensure-variable #:variable-value))
#:eval-input #:eval-thunk #:shared-eval-thunk))
(in-package :uiop/eval)
;;; Safe syntax
......@@ -129,24 +128,3 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(with-shared-syntax (:package package)
(eval-thunk thunk)))))
;;; Late-binding variables
(with-upgradability ()
(defun ensure-variable (name &key package (when-undefined 'error))
(etypecase name
(symbol name)
(string (or (ignore-errors
(let ((s (safe-read-from-string name :package package)))
(and (symbolp s) s)))
(call-function when-undefined
"Cannot read non-nil symbol from ~S" name)))))
(defun variable-value (name &key package (when-undefined 'error))
(let ((var (ensure-variable name :package package :when-undefined when-undefined)))
(if (boundp var)
(symbol-value var)
(call-function when-undefined "Symbol ~S unbound" name))))
(defun (setf variable-value) (value name &key package (when-undefined 'error))
(if-let (var (ensure-variable name :package package :when-undefined when-undefined))
(setf (symbol-value var) value)
value)))
......@@ -146,6 +146,7 @@ going through all the proper hooks."
(defun call-with-safe-io-syntax (function &key package)
(with-standard-io-syntax
(let ((*package* (find-package (or package :common-lisp)))
(*read-default-float-format* 'double-float)
(*print-readably* nil)
(*read-eval* nil))
(call-function function))))
......
......@@ -35,9 +35,7 @@
#:simple-style-warning #:style-warn ;; simple style warnings
#:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions
#:not-implemented-error #:parameter-error
#:call-with-variables #:with-variables #:set-variables ;; variables
#:call-with-alist-variables #:with-alist-variables #:set-alist-variables))
#:not-implemented-error #:parameter-error))
(in-package :uiop/utility)
;;;; Defining functions in a way compatible with hot-upgrade:
......@@ -647,38 +645,3 @@ message, that takes the functionality as its first argument (that can be skipped
:format-control format-control
:format-arguments format-arguments)))
;;; Variables
(with-upgradability ()
(defun call-with-variables (variables bindings thunk &key (name #'identity) (value #'identity))
(loop :for variable :in variables
:for binding :in bindings
:for var = (call-function name variable)
:when var
:collect var :into vars
:and :collect (call-function value binding) :into vals
:finally (progv vars vals (call-function thunk))))
(defmacro with-variables ((variables initializers &rest keys &key name value) &body body)
(declare (ignore name value))
`(call-with-variables ,variables ,initializers #'(lambda () ,@body) ,@keys))
(defun set-variables (variables bindings &key (name #'identity) (value #'identity))
(loop :for variable :in variables
:for binding :in bindings
:for var = (call-function name variable)
:when var
:collect var :into vars
:and :collect (call-function value binding) :into vals
:finally (map () #'set vars vals)))
(defun call-with-alist-variables (alist thunk &rest keys &key name value)
(declare (ignore name value))
(apply 'call-with-variables (mapcar #'car alist) (mapcar #'cdr alist) thunk keys))
(defmacro with-alist-variables ((alist &rest keys &key name value) &body body)
(declare (ignore name value))
`(call-with-alist-variables ,alist #'(lambda () ,@body) ,@keys))
(defun set-alist-variables (alist &rest keys &key name value)
(declare (ignore name value))
(apply 'set-variables (mapcar #'car alist) (mapcar #'cdr alist) keys)))
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