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 #+sb-xc-host
  21 (sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
  22   #!+sb-doc
  23   "Def-Boolean-Attribute Name Attribute-Name*
  24   Define a new class of boolean attributes, with the attributes having the
  25   specified Attribute-Names. Name is the name of the class, which is used to
  26   generate some macros to manipulate sets of the attributes:
  27
  28     NAME-attributep attributes attribute-name*
  29       Return true if one of the named attributes is present, false otherwise.
  30       When set with SETF, updates the place Attributes setting or clearing the
  31       specified attributes.
  32
  33     NAME-attributes attribute-name*
  34       Return a set of the named attributes."
  35
  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 #+sb-xc-host
 135 (sb!xc:defmacro push-in (next item place &environment env)
 136   #!+sb-doc
 137   "Push Item onto a list linked by the accessor function Next that is stored in
 138   Place."
 139   (multiple-value-bind (temps vals stores store access)
 140       (sb!xc:get-setf-expansion place env)
 141     (when (cdr stores)
 142       (error "multiple store variables for ~S" place))
 143     `(let (,@(mapcar #'list temps vals)
 144            (,(first stores) ,item))
 145        (setf (,next ,(first stores)) ,access)
 146        ,store
 147        (values))))