src/compiler/late-macros.lisp

   1 ;;;; macros which use GET-SETF-EXPANSION in their macroexpander code,
   2 ;;;; and hence need special treatment. Currently (19990806) this
   3 ;;;; special treatment involves bare calls to SB!XC:DEFMACRO, and so
   4 ;;;; this code can't appear in the build sequence until after
   5 ;;;; SB!XC:DEFMACRO has been defined, and so this stuff is separated
   6 ;;;; out of the main compiler/macros.lisp file (which has to appear
   7 ;;;; earlier)
   8
   9 ;;;; This software is part of the SBCL system. See the README file for
  10 ;;;; more information.
  11 ;;;;
  12 ;;;; This software is derived from the CMU CL system, which was
  13 ;;;; written at Carnegie Mellon University and released into the
  14 ;;;; public domain. The software is in the public domain and is
  15 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  16 ;;;; files for more information.
  17
  18 (in-package "SB!C")
  19
  20 (file-comment
  21   "$Header$")
  22
  23 #+sb-xc-host
  24 (sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
  25   #!+sb-doc
  26   "Def-Boolean-Attribute Name Attribute-Name*
  27   Define a new class of boolean attributes, with the attributes having the
  28   specified Attribute-Names. Name is the name of the class, which is used to
  29   generate some macros to manipulate sets of the attributes:
  30
  31     NAME-attributep attributes attribute-name*
  32       Return true if one of the named attributes is present, false otherwise.
  33       When set with SETF, updates the place Attributes setting or clearing the
  34       specified attributes.
  35
  36     NAME-attributes attribute-name*
  37       Return a set of the named attributes."
  38
  39   (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
  40         (test-name (symbolicate name "-ATTRIBUTEP")))
  41     (collect ((alist))
  42       (do ((mask 1 (ash mask 1))
  43            (names attribute-names (cdr names)))
  44           ((null names))
  45         (alist (cons (car names) mask)))
  46
  47       `(progn
  48          (eval-when (:compile-toplevel :load-toplevel :execute)
  49            (defconstant ,const-name ',(alist)))
  50
  51          (defmacro ,test-name (attributes &rest attribute-names)
  52            "Automagically generated boolean attribute test function. See
  53             Def-Boolean-Attribute."
  54            `(logtest ,(compute-attribute-mask attribute-names ,const-name)
  55                      (the attributes ,attributes)))
  56
  57          (define-setf-expander ,test-name (place &rest attributes
  58                                                  &environment env)
  59            "Automagically generated boolean attribute setter. See
  60             Def-Boolean-Attribute."
  61            (boolean-attribute-setter--target place
  62                                              attributes
  63                                              env
  64                                              (compute-attribute-mask
  65                                               attributes
  66                                               ,const-name
  67                                               )
  68                                              ',test-name))
  69
  70          (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
  71            "Automagically generated boolean attribute creation function. See
  72             Def-Boolean-Attribute."
  73            (compute-attribute-mask attribute-names ,const-name))))))
  74
  75 ;;; a helper function for the cross-compilation target Lisp code which
  76 ;;; DEF-BOOLEAN-ATTRIBUTE expands into
  77 ;;;
  78 ;;; KLUDGE: Eventually I'd like to rewrite the mainstream DEF-BOOLEAN-ATTRIBUTE
  79 ;;; to use code like this, to factor out some shared functionality for clarity
  80 ;;; and for economy. But the motivation for splitting out this code here is
  81 ;;; much weirder. In the current version of the code, the cross-compiler calls
  82 ;;; UNCROSS on each top-level form before processing it. Ordinarily, UNCROSS
  83 ;;; isn't called on macro expansions, but since DEF-BOOLEAN-ATTRIBUTE expands
  84 ;;; into a PROGN, the cross-compiler does end up calling UNCROSS on (the
  85 ;;; components of) its macroexpansion, since they're separate top-level forms.
  86 ;;; In the classic CMU CL macroexpansion, the call to GET-SETF-EXPANSION is in
  87 ;;; the macroexpansion, and even when I translate it to
  88 ;;; SB!XC:GET-SETF-MACROEXPANSION so that it will work on target code, my
  89 ;;; damned, damned UNCROSS kludge unconverts it before processing it. Moving
  90 ;;; this shared logic (which includes the troublesome
  91 ;;; SB!XC:GET-SETF-EXPANSION code) out of the macroexpansion and into this
  92 ;;; helper function works around this problem. -- WHN 19990812
  93 (defun boolean-attribute-setter--target (place attributes env mask test-name)
  94   (multiple-value-bind (temps values stores set get)
  95       (sb!xc:get-setf-expansion place env)
  96     (when (cdr stores)
  97       (error "multiple store variables for ~S" place))
  98     (let ((newval (gensym))
  99           (n-place (gensym)))
 100       (values `(,@temps ,n-place)
 101               `(,@values ,get)
 102               `(,newval)
 103               `(let ((,(first stores)
 104                       (if ,newval
 105                         (logior ,n-place ,mask)
 106                         (logand ,n-place ,(lognot mask)))))
 107                  ,set
 108                  ,newval)
 109               `(,test-name ,n-place ,@attributes)))))
 110
 111 #+sb-xc-host
 112 (sb!xc:defmacro deletef-in (next place item &environment env)
 113   (multiple-value-bind (temps vals stores store access)
 114       (sb!xc:get-setf-expansion place env)
 115     (when (cdr stores)
 116       (error "multiple store variables for ~S" place))
 117     (let ((n-item (gensym))
 118           (n-place (gensym))
 119           (n-current (gensym))
 120           (n-prev (gensym)))
 121       `(let* (,@(mapcar #'list temps vals)
 122               (,n-place ,access)
 123               (,n-item ,item))
 124          (if (eq ,n-place ,n-item)
 125              (let ((,(first stores) (,next ,n-place)))
 126                ,store)
 127              (do ((,n-prev ,n-place ,n-current)
 128                   (,n-current (,next ,n-place)
 129                               (,next ,n-current)))
 130                  ((eq ,n-current ,n-item)
 131                   (setf (,next ,n-prev)
 132                         (,next ,n-current)))))
 133          (values)))))
 134
 135 #+sb-xc-host
 136 (sb!xc:defmacro push-in (next item place &environment env)
 137   #!+sb-doc
 138   "Push Item onto a list linked by the accessor function Next that is stored in
 139   Place."
 140   (multiple-value-bind (temps vals stores store access)
 141       (sb!xc:get-setf-expansion place env)
 142     (when (cdr stores)
 143       (error "multiple store variables for ~S" place))
 144     `(let (,@(mapcar #'list temps vals)
 145            (,(first stores) ,item))
 146        (setf (,next ,(first stores)) ,access)
 147        ,store
 148        (values))))