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