1.0.11.1: Handle set-but-empty environment variables
[sbcl.git] / src / code / cross-byte.lisp
1 ;;;; cross-compile-time-only replacements for byte-specifier
2 ;;;; machinery.
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!INT")
14
15 (defun sb!xc:byte (size position)
16   (cons size position))
17
18 (defun sb!xc:byte-size (cross-byte)
19   (car cross-byte))
20
21 (defun sb!xc:byte-position (cross-byte)
22   (cdr cross-byte))
23
24 (defun uncross-byte (cross-byte)
25   (cl:byte (sb!xc:byte-size cross-byte) (sb!xc:byte-position cross-byte)))
26
27 (defun sb!xc:ldb (cross-byte int)
28   (cl:ldb (uncross-byte cross-byte) int))
29
30 (defun sb!xc:ldb-test (cross-byte int)
31   (cl:ldb-test (uncross-byte cross-byte) int))
32
33 (defun sb!xc:dpb (new cross-byte int)
34   (cl:dpb new (uncross-byte cross-byte) int))
35
36 (defun sb!xc:mask-field (cross-byte int)
37   (cl:mask-field (uncross-byte cross-byte) int))
38
39 (defun sb!xc:deposit-field (new cross-byte int)
40   (cl:deposit-field new (uncross-byte cross-byte) int))
41
42 (defun sb!c::mask-signed-field (size integer)
43   (if (logbitp (1- size) integer)
44       (dpb integer (byte size 0) -1)
45       (ldb (byte size 0) integer)))
46
47 (define-setf-expander sb!xc:ldb (cross-byte int &environment env)
48   (multiple-value-bind (temps vals stores store-form access-form)
49       (get-setf-expansion int env)
50     (when (cdr stores)
51       (bug "SETF SB!XC:LDB too hairy!"))
52     (let ((btemp (gensym))
53           (store (gensym)))
54       (values (cons btemp temps)
55               (cons cross-byte vals)
56               (list store)
57               `(let ((,(car stores) (cl:dpb ,store (uncross-byte ,btemp) ,access-form)))
58                 ,store-form
59                 ,store)
60               `(cl:ldb (uncross-byte ,btemp) ,access-form)))))
61
62 (define-setf-expander sb!xc:mask-field (cross-byte int &environment env)
63     (multiple-value-bind (temps vals stores store-form access-form)
64       (get-setf-expansion int env)
65     (when (cdr stores)
66       (bug "SETF SB!XC:MASK-FIELD too hairy!"))
67     (let ((btemp (gensym))
68           (store (gensym)))
69       (values (cons btemp temps)
70               (cons cross-byte vals)
71               (list store)
72               `(let ((,(car stores) (cl:deposit-field ,store (uncross-byte ,btemp) ,access-form)))
73                 ,store-form
74                 ,store)
75               `(cl:mask-field (uncross-byte ,btemp) ,access-form)))))