1.0.37.57: better DEFMETHOD pretty-printing
[sbcl/pkhuong.git] / src / code / cross-byte.lisp
blob319ad7d4308755bb34d1d6c1ac213fad3556f85c
1 ;;;; cross-compile-time-only replacements for byte-specifier
2 ;;;; machinery.
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.
13 (in-package "SB!INT")
15 (defun sb!xc:byte (size position)
16 (cons size position))
18 (defun sb!xc:byte-size (cross-byte)
19 (car cross-byte))
21 (defun sb!xc:byte-position (cross-byte)
22 (cdr cross-byte))
24 (defun uncross-byte (cross-byte)
25 (cl:byte (sb!xc:byte-size cross-byte) (sb!xc:byte-position cross-byte)))
27 (defun sb!xc:ldb (cross-byte int)
28 (cl:ldb (uncross-byte cross-byte) int))
30 (defun sb!xc:ldb-test (cross-byte int)
31 (cl:ldb-test (uncross-byte cross-byte) int))
33 (defun sb!xc:dpb (new cross-byte int)
34 (cl:dpb new (uncross-byte cross-byte) int))
36 (defun sb!xc:mask-field (cross-byte int)
37 (cl:mask-field (uncross-byte cross-byte) int))
39 (defun sb!xc:deposit-field (new cross-byte int)
40 (cl:deposit-field new (uncross-byte cross-byte) int))
42 (define-setf-expander sb!xc:ldb (cross-byte int &environment env)
43 (multiple-value-bind (temps vals stores store-form access-form)
44 (get-setf-expansion int env)
45 (when (cdr stores)
46 (bug "SETF SB!XC:LDB too hairy!"))
47 (let ((btemp (gensym))
48 (store (gensym)))
49 (values (cons btemp temps)
50 (cons cross-byte vals)
51 (list store)
52 `(let ((,(car stores) (cl:dpb ,store (uncross-byte ,btemp) ,access-form)))
53 ,store-form
54 ,store)
55 `(cl:ldb (uncross-byte ,btemp) ,access-form)))))
57 (define-setf-expander sb!xc:mask-field (cross-byte int &environment env)
58 (multiple-value-bind (temps vals stores store-form access-form)
59 (get-setf-expansion int env)
60 (when (cdr stores)
61 (bug "SETF SB!XC:MASK-FIELD too hairy!"))
62 (let ((btemp (gensym))
63 (store (gensym)))
64 (values (cons btemp temps)
65 (cons cross-byte vals)
66 (list store)
67 `(let ((,(car stores) (cl:deposit-field ,store (uncross-byte ,btemp) ,access-form)))
68 ,store-form
69 ,store)
70 `(cl:mask-field (uncross-byte ,btemp) ,access-form)))))