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