src/code/debug-var-io.lisp

   1 ;;;; variable-length encoding and other i/o tricks for the debugger
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13 \f
  14 ;;;; reading variable length integers
  15 ;;;;
  16 ;;;; The debug info representation makes extensive use of integers
  17 ;;;; encoded in a byte vector using a variable number of bytes:
  18 ;;;;    0..253 => the integer
  19 ;;;;    254 => read next two bytes for integer
  20 ;;;;    255 => read next four bytes for integer
  21
  22 ;;; Given a byte vector VEC and an index variable INDEX, read a
  23 ;;; variable length integer and advance index.
  24 (defun %read-var-integer (vec index)
  25   (let ((val (aref vec index)))
  26     (cond ((<= val 253)
  27            (values val (1+ index)))
  28           ((= val 254)
  29            (values
  30             (logior (aref vec (+ index 1))
  31                     (ash (aref vec (+ index 2)) 8))
  32             (+ index 3)))
  33           (t
  34            (values
  35             (logior (aref vec (+ index 1))
  36                     (ash (aref vec (+ index 2)) 8)
  37                     (ash (aref vec (+ index 3)) 16)
  38                     (ash (aref vec (+ index 4)) 24))
  39             (+ index 5))))))
  40
  41 (defmacro read-var-integer (vec index)
  42   (once-only ((vec vec))
  43     `(multiple-value-bind (value new-index)
  44          (%read-var-integer ,vec ,index)
  45        (setf ,index new-index)
  46        value)))
  47
  48 ;;; Take an adjustable vector VEC with a fill pointer and push the
  49 ;;; variable length representation of INT on the end.
  50 (defun write-var-integer (int vec)
  51   (declare (type (unsigned-byte 32) int))
  52   (cond ((<= int 253)
  53          (vector-push-extend int vec))
  54         (t
  55          (let ((32-p (> int #xFFFF)))
  56            (vector-push-extend (if 32-p 255 254) vec)
  57            (vector-push-extend (ldb (byte 8 0) int) vec)
  58            (vector-push-extend (ldb (byte 8 8) int) vec)
  59            (when 32-p
  60              (vector-push-extend (ldb (byte 8 16) int) vec)
  61              (vector-push-extend (ldb (byte 8 24) int) vec)))))
  62   (values))
  63 \f
  64 ;;;; packed strings
  65 ;;;;
  66 ;;;; A packed string is a variable length integer length followed by
  67 ;;;; the character codes.
  68
  69 ;;; Read a packed string from VEC starting at INDEX, advancing INDEX.
  70 (defmacro read-var-string (vec index)
  71   (once-only ((len `(read-var-integer ,vec ,index)))
  72     (once-only ((res `(make-string ,len)))
  73       `(progn
  74          (loop for i from 0 below ,len
  75                do (setf (aref ,res i)
  76                         (code-char (read-var-integer ,vec ,index))))
  77          ,res))))
  78
  79 ;;; Write STRING into VEC (adjustable, with fill-pointer) represented
  80 ;;; as the length (in a var-length integer) followed by the codes of
  81 ;;; the characters.
  82 (defun write-var-string (string vec)
  83   (declare (simple-string string))
  84   (let ((len (length string)))
  85     (write-var-integer len vec)
  86     (dotimes (i len)
  87       (write-var-integer (char-code (schar string i)) vec)))
  88   (values))
  89 \f
  90 ;;;; packed bit vectors
  91
  92 ;;; Read the specified number of BYTES out of VEC at INDEX and convert
  93 ;;; them to a BIT-VECTOR. INDEX is incremented.
  94 (defmacro read-packed-bit-vector (bytes vec index)
  95   (once-only ((n-bytes bytes))
  96     (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit)))
  97       `(progn
  98          (%byte-blt ,vec ,index ,n-res 0 ,n-bytes)
  99          (incf ,index ,n-bytes)
 100          ,n-res))))