From ae3b26b18ec33a570752bbfb584171781210f97c Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Mon, 24 Mar 2014 16:16:03 -0400 Subject: [PATCH] Merge some fixes back from the fare-3.1 branch: * override for prepare-op is on component-depends-on, not perform. * coerce-class must be defined after call-function, and accept *package* for now. --- action.lisp | 1 - operate.lisp | 2 +- uiop/utility.lisp | 58 ++++++++++++++++++++++++----------------------- 3 files changed, 31 insertions(+), 30 deletions(-) diff --git a/action.lisp b/action.lisp index 4600edd8..2c1b4471 100644 --- a/action.lisp +++ b/action.lisp @@ -56,7 +56,6 @@ (component 'component) (opix (position operation formals)) (coix (position component formals)) - (prefix (subseq formals 0 opix)) (suffix (subseq formals (1+ coix) len)) (more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) diff --git a/operate.lisp b/operate.lisp index 1df546ae..74aa5c53 100644 --- a/operate.lisp +++ b/operate.lisp @@ -110,7 +110,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken. The default operation may change in the future if we implement a component-directed strategy for how to load or compile systems.") - (defmethod perform ((o prepare-op) (s system)) + (defmethod component-depends-on ((o prepare-op) (s system)) `((,*load-system-operation* ,@(component-sideway-dependencies s)))) (defclass build-op (non-propagating-operation) () diff --git a/uiop/utility.lisp b/uiop/utility.lisp index 1d362da6..aac6a3a6 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -331,34 +331,6 @@ the two results passed to STRCAT always reconstitute the original string" (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) -;;; CLOS -(with-upgradability () - (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 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype stamp () '(or real boolean))) @@ -457,6 +429,36 @@ When CALL-NOW-P is true, also call the function immediately." (when call-now-p (call-function hook)))) +;;; CLOS +(with-upgradability () + (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 either PACKAGE, designates a class. +-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future. +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 (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))))) + (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))))) + + ;;; Hash-tables (with-upgradability () (defun ensure-gethash (key table default) -- GitLab