utils.lisp

   1
   2 (in-package :st-linker)
   3
   4 ;;;; UTILITIES
   5
   6 ;;; XXX should look at norvig's dovector
   7 (defmacro dovector ((var vector) &body body)
   8   "Iterate VAR across VECTOR."
   9   `(loop for ,var across ,vector
  10          do (progn ,@body)))
  11
  12 ;;; XXX should extend this to reuse buffer when possible?
  13 (defun copy-from-stream (source destination length
  14                          &key (element-type 'unsigned-byte))
  15   "Copy LENGTH bytes of data from open stream SOURCE to open stream
  16 DESTINATION."
  17   (let ((buffer (make-array '(4096) :element-type element-type)))
  18     (do ((bytes #1=(read-sequence buffer source) #1#)
  19          (length length (- length bytes)))
  20         ((or (= bytes 0) (<= length 0)))
  21       (write-sequence buffer destination :end (if (> bytes length)
  22                                                   length
  23                                                   bytes)))))
  24
  25 (defun read-big-endian-data (stream length)
  26   "Read LENGTH bits of data encoded big-endian from STREAM, returning
  27 an integer.  LENGTH must be a multiple of 8."
  28   (assert (zerop (logand length 7)))
  29   (do ((pos (- length 8) (- pos 8))
  30        (value (read-byte stream) (logior (read-byte stream)
  31                                          (ash value 8))))
  32       ((<= pos 0) value)))
  33
  34 (defun write-big-endian-data (stream data length)
  35   "Write LENGTH bits of the integer DATA to STREAM, in big-endian
  36 order.  LENGTH must be a multiple of 8."
  37   (assert (zerop (logand length 7)))
  38   (do ((pos (- length 8) (- pos 8)))
  39       ((< pos 0))
  40     (write-byte (ldb (byte 8 pos) data) stream)))
  41
  42
  43 (defun read-nul-terminated-string (stream)
  44   (do ((char (read-byte stream) (read-byte stream))
  45        (string (make-array '(0) :element-type 'character :adjustable t
  46                            :fill-pointer 0)))
  47       ((eql char 0) string)
  48     (vector-push-extend (code-char char) string)))