conditions.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 ;;; Conditions
  28 ;;;
  29 ;;; $Id: conditions.lisp,v 1.3 2006/02/18 23:13:43 xach Exp $
  30
  31 (in-package #:zpb-ttf)
  32
  33 (define-condition regrettable-value ()
  34   ((actual-value
  35     :initarg :actual-value
  36     :accessor actual-value)
  37    (expected-values
  38     :initarg :expected-values
  39     :accessor expected-values)
  40    (description
  41     :initarg :description
  42     :initform nil
  43     :accessor description)
  44    (location
  45     :initarg :location
  46     :initform nil
  47     :accessor location))
  48   (:report
  49    (lambda (c s)
  50      (format s "~:[Regrettable~;~:*~A~] value~:[~;~:* in ~A~]: ~
  51                 ~A (expected ~{~A~^ or ~})"
  52              (description c)
  53              (location c)
  54              (actual-value c)
  55              (expected-values c)))))
  56
  57 (define-condition regrettable-hex-value (regrettable-value)
  58   ((size
  59     :initarg :size
  60     :initform 8
  61     :accessor size)
  62    (actual-value
  63     :reader %actual-value)
  64    (expected-values
  65     :reader %expected-values)))
  66
  67 (defmethod actual-value ((c regrettable-hex-value))
  68   (format nil "#x~v,'0X" (size c) (%actual-value c)))
  69
  70 (defmethod expected-values ((c regrettable-hex-value))
  71   (mapcar (lambda (v)
  72             (format nil "#x~v,'0X" (size c) v))
  73           (%expected-values c)))
  74
  75 (define-condition bad-magic (regrettable-hex-value)
  76   ((description :initform "Bad magic")))
  77
  78 (define-condition unsupported-version (regrettable-hex-value)
  79   ((description :initform "Unsupported version")))
  80
  81 (define-condition unsupported-format (regrettable-hex-value)
  82   ((description :initform "Unsupported format")))
  83
  84 (define-condition unsupported-value (regrettable-value)
  85   ((description :initform "Unsupported")))
  86
  87 (defun check-version (location actual &rest expected)
  88   (or (member actual expected :test #'=)
  89       (error 'unsupported-version
  90              :location location
  91              :actual-value actual
  92              :expected-values expected)))