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)))))