1 ;;;; code to tweak compilation environment, used to set up
2 ;;;; for different phases of cross-compilation
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB-COLD")
17 ;;; a helper macro for WITH-ADDITIONAL-NICKNAME and WITHOUT-SOME-NICKNAME
18 (defmacro with-given-nicknames ((package-designator nicknames) &body body)
19 (let ((p (gensym "P"))
22 `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
23 (,n ,nicknames) ; NICKNAMES, evaluated only once
24 (,o (package-nicknames ,p))) ; old package nicknames
25 (rename-package-carefully ,p (package-name ,p) ,n)
28 (unless (nicknames= ,n (package-nicknames ,p))
29 ;; This probably didn't happen on purpose, and it's not clear anyway
30 ;; what we should do when it did happen, so die noisily:
31 (error "package nicknames changed within WITH-GIVEN-NICKNAMES: ~
32 expected ~S, found ~S"
34 (package-nicknames ,p)))
35 (rename-package-carefully ,p (package-name ,p) ,o)))))
37 ;;; Execute BODY with NICKNAME added as a nickname for PACKAGE-DESIGNATOR.
38 (defmacro with-additional-nickname ((package-designator nickname) &body body)
39 (let ((p (gensym "P"))
41 `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
42 (,n ,nickname)) ; NICKNAME, evaluated only once
44 (error "~S is already a package name." ,n)
45 (with-given-nicknames (,p (cons ,n (package-nicknames ,p)))
48 ;;; Execute BODY with NICKNAME removed as a nickname for PACKAGE-DESIGNATOR.
49 (defmacro without-given-nickname ((package-designator nickname) &body body)
50 (let ((p (gensym "P"))
53 `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
54 (,n ,nickname) ; NICKNAME, evaluated only once
55 (,o (package-nicknames ,p))) ; old package nicknames
56 (if (find ,n ,o :test #'string=)
57 (with-given-nicknames (,p (remove ,n ,o :test #'string=))
59 (error "~S is not a nickname for ~S." ,n ,p)))))
61 ;;; a helper function for WITH-NICKNAME: Are two collections of package
62 ;;; nicknames the same?
63 (defun nicknames= (x y)
64 (equal (sort (mapcar #'string x) #'string<)
65 (sort (mapcar #'string y) #'string<)))
68 ;;; helper functions for WITH-ADDITIONAL-NICKNAMES and WITHOUT-GIVEN-NICKNAMES
69 (defun %with-additional-nickname (package-designator nickname body-fn)
70 (with-additional-nickname (package-designator nickname)
72 (defun %without-given-nickname (package-designator nickname body-fn)
73 (without-given-nickname (package-designator nickname)
75 (defun %multi-nickname-magic (nd-list single-nn-fn body-fn)
76 (labels ((multi-nd (nd-list body-fn) ; multiple nickname descriptors
79 (single-nd (first nd-list)
81 (multi-nd (rest nd-list) body-fn)))))
82 (single-nd (nd body-fn) ; single nickname descriptor
83 (destructuring-bind (package-descriptor nickname-list) nd
84 (multi-nn package-descriptor nickname-list body-fn)))
85 (multi-nn (nn-list package-descriptor body-fn) ; multiple nicknames
92 (multi-nn package-descriptor
95 (multi-nd nd-list body-fn)))
96 (compile '%with-additional-nickname)
97 (compile '%without-given-nickname)
98 (compile '%multi-nickname-magic)
100 ;;; Like WITH-ADDITIONAL-NICKNAME and WITHOUT-GIVEN-NICKNAMES, except
101 ;;; working on arbitrary lists of nickname descriptors instead of
102 ;;; single nickname/package pairs.
104 ;;; A nickname descriptor is a list of the form
105 ;;; PACKAGE-DESIGNATOR NICKNAME*
106 (defmacro with-additional-nicknames (nickname-descriptor-list &body body)
107 `(%multi-nickname-magic ,nickname-descriptor-list
108 #'%with-additional-nickname
110 (defmacro without-given-nicknames (nickname-descriptor-list &body body)
111 `(%multi-nickname-magic ,nickname-descriptor-list
112 #'%without-additional-nickname