src/**/*.lisp: Use convenience functions to invoke restarts.

[sod] / src / pset-test.lisp

;;; -*-lisp-*-
;;;
;;; Test the property set implementation
;;;
;;; (c) 2013 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod-test)

;;;--------------------------------------------------------------------------
;;; Here we go.

(defclass pset-test (test-case) ())
(add-test *sod-test-suite* (get-suite pset-test))

;;;--------------------------------------------------------------------------
;;; Utilities.

(defun pset-equal-p (pset-a pset-b)
  (do ((i 0 (1+ i))
       (p (or pset-a (make-property-set)) q)
       (q (or pset-b (make-property-set)) p))
      ((>= i 2) t)
    (with-pset-iterator (next p)
      (loop (let ((prop (next)))
	      (when (null prop) (return))
	      (let ((other (pset-get q (p-key prop))))
		(unless (and other
			     (equal (p-name prop) (p-name other))
			     (eq (p-type prop) (p-type other))
			     (equal (p-value prop) (p-value other)))
		  (return-from pset-equal-p nil))))))))

(defun assert-pset-equal (pset-a pset-b)
  (unless (pset-equal-p pset-a pset-b)
    (failure "Assert equal property sets: ~A ~_and ~A" pset-a pset-b)))

;;;--------------------------------------------------------------------------
;;; Parser tests.

(defun check-pset-parse (string pset)
  (let* ((char-scanner (make-string-scanner string))
	 (scanner (make-instance 'sod-token-scanner
				 :char-scanner char-scanner
				 :filename "<none>"))
	 (errors nil))
    (with-parser-context (token-scanner-context :scanner scanner)
      (multiple-value-bind (result winp consumedp)
	  (handler-bind ((error (lambda (cond)
				  (setf errors t)
				  (if (find-restart 'continue cond)
				      (continue cond)
				      :decline))))
	    (parse-property-set scanner))
	(declare (ignore consumedp))
	(when errors (setf winp nil))
	(cond ((null pset)
	       (assert-false winp))
	      (t
	       (assert-true winp)
	       (unless (eq pset t)
		 (assert-pset-equal result pset))))))))

(def-test-method parse-empty ((test pset-test) :run nil)
  (check-pset-parse "anything" (make-property-set)))

(def-test-method parse-simple ((test pset-test) :run nil)
  (check-pset-parse "[ thing = 69 ]"
		    (make-property-set "thing" 69)))

(def-test-method parse-wrong ((test pset-test) :run nil)
  (check-pset-parse "[ broken = (1 + ]" nil))

(def-test-method parse-arith ((test pset-test) :run nil)
  (check-pset-parse (concatenate 'string "[ "
				 "one = 13*5 - 16*4, "
				 "two = \"spong\", "
				 "three = 'c', "
				 "four = something_different"
				 "]")
		    (make-property-set "one" 1
				       "two" "spong"
				       "three" #\c
				       "four" (cons :id
						    "something_different"))))

;;;----- That's all, folks --------------------------------------------------