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 ;; Inlining these allows type inference to work.
  16 (declaim (inline sb-xc:dpb sb-xc:ldb sb-xc:mask-field))
  17
  18 (defun sb-xc:byte (size position)
  19   (cons size position))
  20
  21 (defun sb-xc:byte-size (cross-byte)
  22   (car cross-byte))
  23
  24 (defun sb-xc:byte-position (cross-byte)
  25   (cdr cross-byte))
  26
  27 (defun uncross-byte (cross-byte)
  28   (cl:byte (sb-xc:byte-size cross-byte) (sb-xc:byte-position cross-byte)))
  29
  30 (defun sb-xc:ldb (cross-byte int)
  31   (cl:ldb (uncross-byte cross-byte) int))
  32
  33 (define-compiler-macro sb-xc:ldb (&whole whole byte int)
  34   (if (typep byte '(cons (eql sb-xc:byte) (cons t (cons t null))))
  35       `(cl:ldb (cl:byte ,(second byte) ,(third byte)) ,int)
  36       whole))
  37
  38 (define-compiler-macro sb-xc:dpb (&whole whole new byte int)
  39   (if (typep byte '(cons (eql sb-xc:byte) (cons t (cons t null))))
  40       `(cl:dpb ,new (cl:byte ,(second byte) ,(third byte)) ,int)
  41       whole))
  42
  43 (defun sb-xc:ldb-test (cross-byte int)
  44   (cl:ldb-test (uncross-byte cross-byte) int))
  45
  46 (defun sb-xc:dpb (new cross-byte int)
  47   (cl:dpb new (uncross-byte cross-byte) int))
  48
  49 (defun sb-xc:mask-field (cross-byte int)
  50   (cl:mask-field (uncross-byte cross-byte) int))
  51
  52 (defun sb-xc:deposit-field (new cross-byte int)
  53   (cl:deposit-field new (uncross-byte cross-byte) int))
  54
  55 (declaim (ftype function bug))
  56 (define-setf-expander sb-xc:ldb (cross-byte int &environment env)
  57   (multiple-value-bind (temps vals stores store-form access-form)
  58       (cl:get-setf-expansion int env)
  59     (when (cdr stores)
  60       (bug "SETF SB-XC:LDB too hairy!"))
  61     (let ((btemp (gensym))
  62           (store (gensym)))
  63       (values (cons btemp temps)
  64               (cons cross-byte vals)
  65               (list store)
  66               `(let ((,(car stores) (cl:dpb ,store (uncross-byte ,btemp) ,access-form)))
  67                 ,store-form
  68                 ,store)
  69               `(cl:ldb (uncross-byte ,btemp) ,access-form)))))
  70
  71 (define-setf-expander sb-xc:mask-field (cross-byte int &environment env)
  72   (multiple-value-bind (temps vals stores store-form access-form)
  73       (cl:get-setf-expansion int env)
  74     (when (cdr stores)
  75       (bug "SETF SB-XC:MASK-FIELD too hairy!"))
  76     (let ((btemp (gensym))
  77           (store (gensym)))
  78       (values (cons btemp temps)
  79               (cons cross-byte vals)
  80               (list store)
  81               `(let ((,(car stores) (cl:deposit-field ,store (uncross-byte ,btemp) ,access-form)))
  82                 ,store-form
  83                 ,store)
  84               `(cl:mask-field (uncross-byte ,btemp) ,access-form)))))