X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fwith-stuff.lisp;h=1c69ac214a5cc93418b67f1b0324675745f8cfb6;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=11965fbaeaa4452dd8fc8206255b750a180a6a9c;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/src/cold/with-stuff.lisp b/src/cold/with-stuff.lisp index 11965fb..1c69ac2 100644 --- a/src/cold/with-stuff.lisp +++ b/src/cold/with-stuff.lisp @@ -15,52 +15,52 @@ ;;; a helper macro for WITH-ADDITIONAL-NICKNAME and WITHOUT-SOME-NICKNAME (defmacro with-given-nicknames ((package-designator nicknames) &body body) (let ((p (gensym "P")) - (n (gensym "N")) - (o (gensym "O"))) + (n (gensym "N")) + (o (gensym "O"))) `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once - (,n ,nicknames) ; NICKNAMES, evaluated only once - (,o (package-nicknames ,p))) ; old package nicknames + (,n ,nicknames) ; NICKNAMES, evaluated only once + (,o (package-nicknames ,p))) ; old package nicknames (rename-package-carefully ,p (package-name ,p) ,n) (unwind-protect - (progn ,@body) - (unless (nicknames= ,n (package-nicknames ,p)) - ;; This probably didn't happen on purpose, and it's not clear anyway - ;; what we should do when it did happen, so die noisily: - (error "package nicknames changed within WITH-GIVEN-NICKNAMES: ~ - expected ~S, found ~S" - ,n - (package-nicknames ,p))) - (rename-package-carefully ,p (package-name ,p) ,o))))) + (progn ,@body) + (unless (nicknames= ,n (package-nicknames ,p)) + ;; This probably didn't happen on purpose, and it's not clear anyway + ;; what we should do when it did happen, so die noisily: + (error "package nicknames changed within WITH-GIVEN-NICKNAMES: ~ + expected ~S, found ~S" + ,n + (package-nicknames ,p))) + (rename-package-carefully ,p (package-name ,p) ,o))))) ;;; Execute BODY with NICKNAME added as a nickname for PACKAGE-DESIGNATOR. (defmacro with-additional-nickname ((package-designator nickname) &body body) (let ((p (gensym "P")) - (n (gensym "N"))) + (n (gensym "N"))) `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once - (,n ,nickname)) ; NICKNAME, evaluated only once + (,n ,nickname)) ; NICKNAME, evaluated only once (if (find-package ,n) - (error "~S is already a package name." ,n) - (with-given-nicknames (,p (cons ,n (package-nicknames ,p))) - ,@body))))) + (error "~S is already a package name." ,n) + (with-given-nicknames (,p (cons ,n (package-nicknames ,p))) + ,@body))))) ;;; Execute BODY with NICKNAME removed as a nickname for PACKAGE-DESIGNATOR. (defmacro without-given-nickname ((package-designator nickname) &body body) (let ((p (gensym "P")) - (n (gensym "N")) - (o (gensym "O"))) + (n (gensym "N")) + (o (gensym "O"))) `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once - (,n ,nickname) ; NICKNAME, evaluated only once - (,o (package-nicknames ,p))) ; old package nicknames + (,n ,nickname) ; NICKNAME, evaluated only once + (,o (package-nicknames ,p))) ; old package nicknames (if (find ,n ,o :test #'string=) - (with-given-nicknames (,p (remove ,n ,o :test #'string=)) - ,@body) - (error "~S is not a nickname for ~S." ,n ,p))))) + (with-given-nicknames (,p (remove ,n ,o :test #'string=)) + ,@body) + (error "~S is not a nickname for ~S." ,n ,p))))) ;;; a helper function for WITH-NICKNAME: Are two collections of package ;;; nicknames the same? (defun nicknames= (x y) (equal (sort (mapcar #'string x) #'string<) - (sort (mapcar #'string y) #'string<))) + (sort (mapcar #'string y) #'string<))) (compile 'nicknames=) ;;; helper functions for WITH-ADDITIONAL-NICKNAMES and WITHOUT-GIVEN-NICKNAMES @@ -76,25 +76,25 @@ (declare (type function single-nn-fn)) (labels ((multi-nd (nd-list body-fn) ; multiple nickname descriptors (declare (type function body-fn)) - (if (null nd-list) - (funcall body-fn) - (single-nd (first nd-list) - (lambda () - (multi-nd (rest nd-list) body-fn))))) - (single-nd (nd body-fn) ; single nickname descriptor - (destructuring-bind (package-descriptor nickname-list) nd - (multi-nn package-descriptor nickname-list body-fn))) - (multi-nn (nn-list package-descriptor body-fn) ; multiple nicknames + (if (null nd-list) + (funcall body-fn) + (single-nd (first nd-list) + (lambda () + (multi-nd (rest nd-list) body-fn))))) + (single-nd (nd body-fn) ; single nickname descriptor + (destructuring-bind (package-descriptor nickname-list) nd + (multi-nn package-descriptor nickname-list body-fn))) + (multi-nn (nn-list package-descriptor body-fn) ; multiple nicknames (declare (type function body-fn)) - (if (null nn-list) - (funcall body-fn) - (funcall single-nn-fn - (first nn-list) - package-descriptor - (lambda () - (multi-nn package-descriptor - (rest nn-list) - body-fn)))))) + (if (null nn-list) + (funcall body-fn) + (funcall single-nn-fn + (first nn-list) + package-descriptor + (lambda () + (multi-nn package-descriptor + (rest nn-list) + body-fn)))))) (multi-nd nd-list body-fn))) (compile '%with-additional-nickname) (compile '%without-given-nickname) @@ -108,9 +108,9 @@ ;;; PACKAGE-DESIGNATOR NICKNAME* (defmacro with-additional-nicknames (nickname-descriptor-list &body body) `(%multi-nickname-magic ,nickname-descriptor-list - #'%with-additional-nickname - (lambda () ,@body))) + #'%with-additional-nickname + (lambda () ,@body))) (defmacro without-given-nicknames (nickname-descriptor-list &body body) `(%multi-nickname-magic ,nickname-descriptor-list - #'%without-additional-nickname - (lambda () ,@body))) + #'%without-additional-nickname + (lambda () ,@body)))