1.0.29.13: relax CAST-EXTERNALLY-CHECKABLE-P a bit
[sbcl.git] / 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))