chiark - git - mdw - sod/blob - src/pset-test.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Test the property set implementation
   4 ;;;
   5 ;;; (c) 2013 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod-test)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Here we go.
  30
  31 (defclass pset-test (test-case) ())
  32 (add-test *sod-test-suite* (get-suite pset-test))
  33
  34 ;;;--------------------------------------------------------------------------
  35 ;;; Utilities.
  36
  37 (defun pset-equal-p (pset-a pset-b)
  38   (do ((i 0 (1+ i))
  39        (p (or pset-a (make-property-set)) q)
  40        (q (or pset-b (make-property-set)) p))
  41       ((>= i 2) t)
  42     (with-pset-iterator (next p)
  43       (loop (let ((prop (next)))
  44               (when (null prop) (return))
  45               (let ((other (pset-get q (p-key prop))))
  46                 (unless (and other
  47                              (equal (p-name prop) (p-name other))
  48                              (eq (p-type prop) (p-type other))
  49                              (equal (p-value prop) (p-value other)))
  50                   (return-from pset-equal-p nil))))))))
  51
  52 (defun assert-pset-equal (pset-a pset-b)
  53   (unless (pset-equal-p pset-a pset-b)
  54     (failure "Assert equal property sets: ~A ~_and ~A" pset-a pset-b)))
  55
  56 ;;;--------------------------------------------------------------------------
  57 ;;; Parser tests.
  58
  59 (defun check-pset-parse (string pset)
  60   (let* ((char-scanner (make-string-scanner string))
  61          (scanner (make-instance 'sod-token-scanner
  62                                  :char-scanner char-scanner
  63                                  :filename "<none>"))
  64          (errors nil))
  65     (with-parser-context (token-scanner-context :scanner scanner)
  66       (multiple-value-bind (result winp consumedp)
  67           (handler-bind ((error (lambda (cond)
  68                                   (setf errors t)
  69                                   (if (find-restart 'continue cond)
  70                                       (continue cond)
  71                                       :decline))))
  72             (parse-property-set scanner))
  73         (declare (ignore consumedp))
  74         (when errors (setf winp nil))
  75         (cond ((null pset)
  76                (assert-false winp))
  77               (t
  78                (assert-true winp)
  79                (unless (eq pset t)
  80                  (assert-pset-equal result pset))))))))
  81
  82 (def-test-method parse-empty ((test pset-test) :run nil)
  83   (check-pset-parse "anything" (make-property-set)))
  84
  85 (def-test-method parse-simple ((test pset-test) :run nil)
  86   (check-pset-parse "[ thing = 69 ]"
  87                     (make-property-set "thing" 69)))
  88
  89 (def-test-method parse-wrong ((test pset-test) :run nil)
  90   (check-pset-parse "[ broken = (1 + ]" nil))
  91
  92 (def-test-method parse-arith ((test pset-test) :run nil)
  93   (check-pset-parse (concatenate 'string "[ "
  94                                  "one = 13*5 - 16*4, "
  95                                  "two = \"spong\", "
  96                                  "three = 'c', "
  97                                  "four = something_different"
  98                                  "]")
  99                     (make-property-set "one" 1
 100                                        "two" "spong"
 101                                        "three" #\c
 102                                        "four" (cons :id
 103                                                     "something_different"))))
 104
 105 ;;;----- That's all, folks --------------------------------------------------