From 5b66ebae9a1adda4fcc60f3a2b6440d80ceb89b6 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 7 Jan 2017 22:53:16 -0800
Subject: [PATCH] Add basic tests for predicate dispatchers.  More to come.

---
 src/runtime/predicate-dispatch.scm        | 13 ++---
 tests/runtime/test-predicate-dispatch.scm | 63 +++++++++++++++++++++++
 2 files changed, 70 insertions(+), 6 deletions(-)
 create mode 100644 tests/runtime/test-predicate-dispatch.scm

diff --git a/src/runtime/predicate-dispatch.scm b/src/runtime/predicate-dispatch.scm
index b5c6c633a..4096a717e 100644
--- a/src/runtime/predicate-dispatch.scm
+++ b/src/runtime/predicate-dispatch.scm
@@ -108,7 +108,7 @@ USA.
 
 (define (predicate-dispatcher-rules dispatch)
   (map list-copy
-       ((get-handler-set dispatch 'predicate-dispatcher-rules) 'get-rules)))
+       (((get-handler-set dispatch 'predicate-dispatcher-rules) 'get-rules))))
 
 (define (get-handler-set dispatch caller)
   (metadata-handler-set (get-metadata dispatch caller)))
@@ -119,11 +119,12 @@ USA.
 		       'define-predicate-dispatch-handler)
     (guarantee-procedure-of-arity handler (metadata-arity metadata)
 				  'define-predicate-dispatch-handler)
-    ((metadata-handler-set metadata) 'set-handler! predicates handler)))
+    (((metadata-handler-set metadata) 'set-handler!) predicates handler)))
 
 (define (define-predicate-dispatch-default-handler dispatch handler)
-  ((get-handler-set dispatch 'define-predicate-dispatch-default-handler)
-   'set-default-handler! handler))
+  (((get-handler-set dispatch 'define-predicate-dispatch-default-handler)
+    'set-default-handler!)
+   handler))
 
 ;;;; Handler set implementations
 
@@ -252,7 +253,7 @@ USA.
         (else (delegate operator))))))
 
 (define (cached-most-specific-handler-set)
-  (make-cached-handler-set (most-specific-handler-set) object->tag))
+  (cached-handler-set (most-specific-handler-set) object->tag))
 
 (define (cached-chaining-handler-set)
-  (make-cached-handler-set (chaining-handler-set) object->tag))
\ No newline at end of file
+  (cached-handler-set (chaining-handler-set) object->tag))
\ No newline at end of file
diff --git a/tests/runtime/test-predicate-dispatch.scm b/tests/runtime/test-predicate-dispatch.scm
new file mode 100644
index 000000000..cfc17e29f
--- /dev/null
+++ b/tests/runtime/test-predicate-dispatch.scm
@@ -0,0 +1,63 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests for predicate dispatchers
+
+(declare (usual-integrations))
+
+(define-test 'generic-basic
+  (lambda ()
+    (assert-range-error (lambda () (simple-predicate-dispatcher 'foo 0)))
+
+    (define foo
+      (simple-predicate-dispatcher 'foo 1))
+
+    (define-predicate-dispatch-handler foo (list any-object?)
+      (lambda (arg)
+        'foobar))
+
+    (assert-equal (foo #f) 'foobar)))
+
+(define-test 'generic-example1
+  (lambda ()
+    (define foo
+      (simple-predicate-dispatcher 'foo 2))
+
+    (define-predicate-dispatch-handler foo (list number? number?)
+      (lambda (a b)
+        (+ a b)))
+
+    (let ((symbolic
+           (lambda (a b)
+             (list '+ a b))))
+      (define-predicate-dispatch-handler foo (list number? symbol?) symbolic)
+      (define-predicate-dispatch-handler foo (list symbol? number?) symbolic)
+      (define-predicate-dispatch-handler foo (list symbol? symbol?) symbolic))
+
+    (assert-equal (foo 1 2) 3)
+    (assert-equal (foo 1 'a) '(+ 1 a))
+    (assert-equal (foo 'a 2) '(+ a 2))
+    (assert-equal (foo 'a 'b) '(+ a b))))
\ No newline at end of file
-- 
2.25.1