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 ;;; Def-Boolean-Attribute Name Attribute-Name*
  21 ;;;
  22 ;;; Define a new class of Boolean attributes, with the attributes
  23 ;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
  24 ;;; class, which is used to generate some macros to manipulate sets of
  25 ;;; the attributes:
  26 ;;;
  27 ;;;   NAME-attributep attributes attribute-name*
  28 ;;;     Return true if any of the named attributes are present, false
  29 ;;;     otherwise. When set with SETF, updates the place Attributes
  30 ;;;     setting or clearing the specified attributes.
  31 ;;;
  32 ;;;   NAME-attributes attribute-name*
  33 ;;;     Return a set of the named attributes.
  34 #+sb-xc-host
  35 (sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
  36   (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
  37         (test-name (symbolicate name "-ATTRIBUTEP")))
  38     (collect ((alist))
  39       (do ((mask 1 (ash mask 1))
  40            (names attribute-names (cdr names)))
  41           ((null names))
  42         (alist (cons (car names) mask)))
  43
  44       `(progn
  45
  46          (eval-when (:compile-toplevel :load-toplevel :execute)
  47            (defparameter ,translations-name ',(alist)))
  48
  49          (defmacro ,test-name (attributes &rest attribute-names)
  50            "Automagically generated Boolean attribute test function. See
  51             DEF-BOOLEAN-ATTRIBUTE."
  52            `(logtest ,(compute-attribute-mask attribute-names
  53                                               ,translations-name)
  54                      (the attributes ,attributes)))
  55
  56          (define-setf-expander ,test-name (place &rest attributes
  57                                                  &environment env)
  58            "Automagically generated Boolean attribute setter. See
  59             DEF-BOOLEAN-ATTRIBUTE."
  60            (boolean-attribute-setter--target place
  61                                              attributes
  62                                              env
  63                                              (compute-attribute-mask
  64                                               attributes
  65                                               ,translations-name
  66                                               )
  67                                              ',test-name))
  68
  69          (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
  70            "Automagically generated Boolean attribute creation function. See
  71             DEF-BOOLEAN-ATTRIBUTE."
  72            (compute-attribute-mask attribute-names ,translations-name))))))
  73
  74 ;;; a helper function for the cross-compilation target Lisp code which
  75 ;;; DEF-BOOLEAN-ATTRIBUTE expands into
  76 ;;;
  77 ;;; KLUDGE: Eventually I'd like to rewrite the mainstream DEF-BOOLEAN-ATTRIBUTE
  78 ;;; to use code like this, to factor out some shared functionality for clarity
  79 ;;; and for economy. But the motivation for splitting out this code here is
  80 ;;; much weirder. In the current version of the code, the cross-compiler calls
  81 ;;; UNCROSS on each top level form before processing it. Ordinarily, UNCROSS
  82 ;;; isn't called on macro expansions, but since DEF-BOOLEAN-ATTRIBUTE expands
  83 ;;; into a PROGN, the cross-compiler does end up calling UNCROSS on (the
  84 ;;; components of) its macroexpansion, since they're separate top level forms.
  85 ;;; In the classic CMU CL macroexpansion, the call to GET-SETF-EXPANSION is in
  86 ;;; the macroexpansion, and even when I translate it to
  87 ;;; SB!XC:GET-SETF-MACROEXPANSION so that it will work on target code, my
  88 ;;; damned, damned UNCROSS kludge unconverts it before processing it. Moving
  89 ;;; this shared logic (which includes the troublesome
  90 ;;; SB!XC:GET-SETF-EXPANSION code) out of the macroexpansion and into this
  91 ;;; helper function works around this problem. -- WHN 19990812
  92 (defun boolean-attribute-setter--target (place attributes env mask test-name)
  93   (multiple-value-bind (temps values stores set get)
  94       (sb!xc:get-setf-expansion place env)
  95     (when (cdr stores)
  96       (error "multiple store variables for ~S" place))
  97     (let ((newval (gensym))
  98           (n-place (gensym)))
  99       (values `(,@temps ,n-place)
 100               `(,@values ,get)
 101               `(,newval)
 102               `(let ((,(first stores)
 103                       (if ,newval
 104                         (logior ,n-place ,mask)
 105                         (logand ,n-place ,(lognot mask)))))
 106                  ,set
 107                  ,newval)
 108               `(,test-name ,n-place ,@attributes)))))
 109
 110 #+sb-xc-host
 111 (sb!xc:defmacro deletef-in (next place item &environment env)
 112   (multiple-value-bind (temps vals stores store access)
 113       (sb!xc:get-setf-expansion place env)
 114     (when (cdr stores)
 115       (error "multiple store variables for ~S" place))
 116     (let ((n-item (gensym))
 117           (n-place (gensym))
 118           (n-current (gensym))
 119           (n-prev (gensym)))
 120       `(let* (,@(mapcar #'list temps vals)
 121               (,n-place ,access)
 122               (,n-item ,item))
 123          (if (eq ,n-place ,n-item)
 124              (let ((,(first stores) (,next ,n-place)))
 125                ,store)
 126              (do ((,n-prev ,n-place ,n-current)
 127                   (,n-current (,next ,n-place)
 128                               (,next ,n-current)))
 129                  ((eq ,n-current ,n-item)
 130                   (setf (,next ,n-prev)
 131                         (,next ,n-current)))))
 132          (values)))))
 133
 134 ;;; Push ITEM onto a list linked by the accessor function NEXT that is
 135 ;;; stored in PLACE.
 136 #+sb-xc-host
 137 (sb!xc:defmacro push-in (next item place &environment env)
 138   (multiple-value-bind (temps vals stores store access)
 139       (sb!xc:get-setf-expansion place env)
 140     (when (cdr stores)
 141       (error "multiple store variables for ~S" place))
 142     `(let (,@(mapcar #'list temps vals)
 143            (,(first stores) ,item))
 144        (setf (,next ,(first stores)) ,access)
 145        ,store
 146        (values))))