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 or
   4 ;;;; DEFMACRO-MUNDANELY and so this code can't appear in the build
   5 ;;;; sequence until after xc DEFMACRO machinery has been set up, and
   6 ;;;; so this stuff is separated out of the main compiler/macros.lisp
   7 ;;;; file (which has to appear 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 deletef-in (next place item &environment env)
  22   (multiple-value-bind (temps vals stores store access)
  23       (sb!xc:get-setf-expansion place env)
  24     (when (cdr stores)
  25       (error "multiple store variables for ~S" place))
  26     (let ((n-item (gensym))
  27           (n-place (gensym))
  28           (n-current (gensym))
  29           (n-prev (gensym)))
  30       `(let* (,@(mapcar #'list temps vals)
  31               (,n-place ,access)
  32               (,n-item ,item))
  33          (if (eq ,n-place ,n-item)
  34              (let ((,(first stores) (,next ,n-place)))
  35                ,store)
  36              (do ((,n-prev ,n-place ,n-current)
  37                   (,n-current (,next ,n-place)
  38                               (,next ,n-current)))
  39                  ((eq ,n-current ,n-item)
  40                   (setf (,next ,n-prev)
  41                         (,next ,n-current)))))
  42          (values)))))
  43
  44 ;;; Push ITEM onto a list linked by the accessor function NEXT that is
  45 ;;; stored in PLACE.
  46 #+sb-xc-host
  47 (sb!xc:defmacro push-in (next item place &environment env)
  48   (multiple-value-bind (temps vals stores store access)
  49       (sb!xc:get-setf-expansion place env)
  50     (when (cdr stores)
  51       (error "multiple store variables for ~S" place))
  52     `(let (,@(mapcar #'list temps vals)
  53            (,(first stores) ,item))
  54        (setf (,next ,(first stores)) ,access)
  55        ,store
  56        (values))))
  57
  58 ;;; the target-code case of setting boolean attributes
  59 #+sb-xc-host
  60 (defmacro-mundanely !def-boolean-attribute-setter (test-name
  61                                                    translations-name
  62                                                    &rest attribute-names)
  63   (guts-of-!def-boolean-attribute-setter test-name
  64                                          translations-name
  65                                          attribute-names
  66                                          'sb!xc:get-setf-expansion))