util.lisp

   1 ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved
   2 ;;;
   3 ;;; Redistribution and use in source and binary forms, with or without
   4 ;;; modification, are permitted provided that the following conditions
   5 ;;; are met:
   6 ;;;
   7 ;;;   * Redistributions of source code must retain the above copyright
   8 ;;;     notice, this list of conditions and the following disclaimer.
   9 ;;;
  10 ;;;   * Redistributions in binary form must reproduce the above
  11 ;;;     copyright notice, this list of conditions and the following
  12 ;;;     disclaimer in the documentation and/or other materials
  13 ;;;     provided with the distribution.
  14 ;;;
  15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26 ;;;
  27 ;;; Utility functions, mostly for reading data out of the input-stream
  28 ;;; of a font-loader.
  29 ;;;
  30 ;;; $Id: util.lisp,v 1.9 2006/02/18 23:13:43 xach Exp $
  31
  32 (in-package #:zpb-ttf)
  33
  34 ;;; Reading compound MSB values from an '(unsigned-byte 8) stream
  35
  36 (defun read-uint32 (stream)
  37   (loop repeat 4
  38         for value = (read-byte stream)
  39         then (logior (ash value 8) (read-byte stream))
  40         finally (return value)))
  41
  42 (defun read-uint16 (stream)
  43   (loop repeat 2
  44         for value = (read-byte stream)
  45           then (logior (ash value 8) (read-byte stream))
  46         finally (return value)))
  47
  48
  49 (defun read-uint8 (stream)
  50   (read-byte stream))
  51
  52 (defun read-int8 (stream)
  53   (let ((result (read-byte stream)))
  54     (if (logbitp 7 result)
  55         (1- (- (logandc2 #xFF result)))
  56         result)))
  57
  58 (defun read-int16 (stream)
  59   (let ((result (read-uint16 stream)))
  60     (if (logbitp 15 result)
  61         (1- (- (logandc2 #xFFFF result)))
  62         result)))
  63
  64 (defun read-fixed (stream)
  65   (read-uint32 stream))
  66
  67 (defun read-fword (stream)
  68   (read-int16 stream))
  69
  70 (defun read-ufword (stream)
  71   (read-uint16 stream))
  72
  73 (defun read-fixed2.14 (stream)
  74   (let ((value (read-uint16 stream)))
  75     (let ((integer (ash value -14))
  76           (fraction (logand #x3FFF value)))
  77       (when (logbitp 1 integer)
  78         (setf integer (1- (- (logandc2 #b11 integer)))))
  79       (+ integer (float (/ fraction #x4000))))))
  80
  81 (defun read-pstring (stream)
  82   "Read a Pascal-style length-prefixed string."
  83   (let* ((length (read-uint8 stream))
  84          (buf (make-array length :element-type '(unsigned-byte 8)))
  85          (string (make-string length)))
  86     (read-sequence buf stream)
  87     ;; The following could be (map 'string #'code-char buf), but that
  88     ;; form benchmarked poorly
  89     (dotimes (i length string)
  90       (setf (schar string i) (code-char (aref buf i))))))
  91
  92 (defun advance-file-position (stream n)
  93   "Move the file position of STREAM ahead by N bytes."
  94   (let ((pos (file-position stream)))
  95     (file-position stream (+ pos n))))
  96
  97 (defun bounded-aref (vector index)
  98   "Some TrueType data vectors are truncated, and any references beyond
  99 the end of the vector should be treated as a reference to the last
 100 element in the vector."
 101   (aref vector (min (1- (length vector)) index)))
 102
 103 (defun (setf bounded-aref) (new-value vector index)
 104   (setf (aref vector (min (1- (length vector)) index)) new-value))