1.0.6.46: better standard-specializer-p implementation
[sbcl.git] / src / cold / with-stuff.lisp
1 ;;;; code to tweak compilation environment, used to set up
2 ;;;; for different phases of cross-compilation
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB-COLD")
14
15 ;;; a helper macro for WITH-ADDITIONAL-NICKNAME and WITHOUT-SOME-NICKNAME
16 (defmacro with-given-nicknames ((package-designator nicknames) &body body)
17   (let ((p (gensym "P"))
18         (n (gensym "N"))
19         (o (gensym "O")))
20     `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
21             (,n ,nicknames) ; NICKNAMES, evaluated only once
22             (,o (package-nicknames ,p))) ; old package nicknames
23        (rename-package-carefully ,p (package-name ,p) ,n)
24        (unwind-protect
25            (progn ,@body)
26          (unless (nicknames= ,n (package-nicknames ,p))
27            ;; This probably didn't happen on purpose, and it's not clear anyway
28            ;; what we should do when it did happen, so die noisily:
29            (error "package nicknames changed within WITH-GIVEN-NICKNAMES: ~
30                    expected ~S, found ~S"
31                   ,n
32                   (package-nicknames ,p)))
33          (rename-package-carefully ,p (package-name ,p) ,o)))))
34
35 ;;; Execute BODY with NICKNAME added as a nickname for PACKAGE-DESIGNATOR.
36 (defmacro with-additional-nickname ((package-designator nickname) &body body)
37   (let ((p (gensym "P"))
38         (n (gensym "N")))
39     `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
40             (,n ,nickname)) ; NICKNAME, evaluated only once
41        (if (find-package ,n)
42          (error "~S is already a package name." ,n)
43          (with-given-nicknames (,p (cons ,n (package-nicknames ,p)))
44            ,@body)))))
45
46 ;;; Execute BODY with NICKNAME removed as a nickname for PACKAGE-DESIGNATOR.
47 (defmacro without-given-nickname ((package-designator nickname) &body body)
48   (let ((p (gensym "P"))
49         (n (gensym "N"))
50         (o (gensym "O")))
51     `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
52             (,n ,nickname) ; NICKNAME, evaluated only once
53             (,o (package-nicknames ,p))) ; old package nicknames
54        (if (find ,n ,o :test #'string=)
55          (with-given-nicknames (,p (remove ,n ,o :test #'string=))
56            ,@body)
57          (error "~S is not a nickname for ~S." ,n ,p)))))
58
59 ;;; a helper function for WITH-NICKNAME: Are two collections of package
60 ;;; nicknames the same?
61 (defun nicknames= (x y)
62   (equal (sort (mapcar #'string x) #'string<)
63          (sort (mapcar #'string y) #'string<)))
64 (compile 'nicknames=)
65
66 ;;; helper functions for WITH-ADDITIONAL-NICKNAMES and WITHOUT-GIVEN-NICKNAMES
67 (defun %with-additional-nickname (package-designator nickname body-fn)
68   (declare (type function body-fn))
69   (with-additional-nickname (package-designator nickname)
70     (funcall body-fn)))
71 (defun %without-given-nickname (package-designator nickname body-fn)
72   (declare (type function body-fn))
73   (without-given-nickname (package-designator nickname)
74     (funcall body-fn)))
75 (defun %multi-nickname-magic (nd-list single-nn-fn body-fn)
76   (declare (type function single-nn-fn))
77   (labels ((multi-nd (nd-list body-fn) ; multiple nickname descriptors
78              (declare (type function body-fn))
79              (if (null nd-list)
80                (funcall body-fn)
81                (single-nd (first nd-list)
82                           (lambda ()
83                             (multi-nd (rest nd-list) body-fn)))))
84            (single-nd (nd body-fn) ; single nickname descriptor
85              (destructuring-bind (package-descriptor nickname-list) nd
86                (multi-nn package-descriptor nickname-list body-fn)))
87            (multi-nn (nn-list package-descriptor body-fn) ; multiple nicknames
88              (declare (type function body-fn))
89              (if (null nn-list)
90                (funcall body-fn)
91                (funcall single-nn-fn
92                         (first nn-list)
93                         package-descriptor
94                         (lambda ()
95                           (multi-nn package-descriptor
96                                     (rest nn-list)
97                                     body-fn))))))
98     (multi-nd nd-list body-fn)))
99 (compile '%with-additional-nickname)
100 (compile '%without-given-nickname)
101 (compile '%multi-nickname-magic)
102
103 ;;; This is like WITH-ADDITIONAL-NICKNAME and WITHOUT-GIVEN-NICKNAMES,
104 ;;; except working on arbitrary lists of nickname descriptors instead
105 ;;; of single nickname/package pairs.
106 ;;;
107 ;;; A nickname descriptor is a list of the form
108 ;;;   PACKAGE-DESIGNATOR NICKNAME*
109 (defmacro with-additional-nicknames (nickname-descriptor-list &body body)
110   `(%multi-nickname-magic ,nickname-descriptor-list
111                           #'%with-additional-nickname
112                           (lambda () ,@body)))
113 (defmacro without-given-nicknames (nickname-descriptor-list &body body)
114   `(%multi-nickname-magic ,nickname-descriptor-list
115                           #'%without-additional-nickname
116                           (lambda () ,@body)))