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 ;;;; $Header$
  16
  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"))
  20         (n (gensym "N"))
  21         (o (gensym "O")))
  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)
  26        (unwind-protect
  27            (progn ,@body)
  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"
  33                   ,n
  34                   (package-nicknames ,p)))
  35          (rename-package-carefully ,p (package-name ,p) ,o)))))
  36
  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"))
  40         (n (gensym "N")))
  41     `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
  42             (,n ,nickname)) ; NICKNAME, evaluated only once
  43        (if (find-package ,n)
  44          (error "~S is already a package name." ,n)
  45          (with-given-nicknames (,p (cons ,n (package-nicknames ,p)))
  46            ,@body)))))
  47
  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"))
  51         (n (gensym "N"))
  52         (o (gensym "O")))
  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=))
  58            ,@body)
  59          (error "~S is not a nickname for ~S." ,n ,p)))))
  60
  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<)))
  66 (compile 'nicknames=)
  67
  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)
  71     (funcall body-fn)))
  72 (defun %without-given-nickname (package-designator nickname 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   (labels ((multi-nd (nd-list body-fn) ; multiple nickname descriptors
  77              (if (null nd-list)
  78                (funcall body-fn)
  79                (single-nd (first nd-list)
  80                           (lambda ()
  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
  86              (if (null nn-list)
  87                (funcall body-fn)
  88                (funcall single-nn-fn
  89                         (first nn-list)
  90                         package-descriptor
  91                         (lambda ()
  92                           (multi-nn package-descriptor
  93                                     (rest nn-list)
  94                                     body-fn))))))
  95     (multi-nd nd-list body-fn)))
  96 (compile '%with-additional-nickname)
  97 (compile '%without-given-nickname)
  98 (compile '%multi-nickname-magic)
  99
 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.
 103 ;;;
 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
 109                           (lambda () ,@body)))
 110 (defmacro without-given-nicknames (nickname-descriptor-list &body body)
 111   `(%multi-nickname-magic ,nickname-descriptor-list
 112                           #'%without-additional-nickname
 113                           (lambda () ,@body)))