From 19e5398b9270801c829cf5140fee1f8304874f53 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Mon, 29 Jul 2013 21:16:18 +0900
Subject: [PATCH] Allowing a default predicate for methods. Fixes issue #191.

---
 lib/chibi/generic.scm   | 22 +++++++++++++++++-----
 tests/generic-tests.scm | 35 +++++++++++++++++++++++++++++++++++
 2 files changed, 52 insertions(+), 5 deletions(-)
 create mode 100644 tests/generic-tests.scm

diff --git a/lib/chibi/generic.scm b/lib/chibi/generic.scm
index f32ebe8a..671ccf13 100644
--- a/lib/chibi/generic.scm
+++ b/lib/chibi/generic.scm
@@ -17,22 +17,34 @@
                        . body))))))
 
 ;;> \subsubsubsection{(define-method (name (param type) ...) body ...)}
+;;> \subsubsubsection{\scheme{(define-method (name params ...) body ...)}}
+ 
+;;> Each parameter should be either a single identifier or a list of the form
+;;> \scheme{(param type)} where \var{param} is the parameter name and
+;;> \var{type} is a predicate which returns true if it's argument is of the
+;;> correct type.
+;;> Parameters without a predicate will always match.
 
-;;> Extends the generic function \var{name} with a new method that
-;;> applies when the given param types all match.
+;;> If multiple methods satisfy the arguments, the most recent method
+;;> will be used.  The special form \scheme{(call-next-method)} can be
+;;> invoked to call the next most recent method with the same arguments.
 
 (define-syntax define-method
   (er-macro-transformer
    (lambda (e r c)
      (let ((name (car (cadr e)))
-           (params (cdr (cadr e)))
+           (params (map (lambda (param)
+                          (if (identifier? param)
+                              `(,param (lambda _ #t))
+                              param))
+                        (cdr (cadr e))))
            (body (cddr e)))
        `(,(r 'generic-add!) ,name
          (,(r 'list) ,@(map cadr params))
-         (,(r 'lambda) (next ,@(map car params))
+         (,(r 'lambda) (,(r 'next) ,@(map car params))
           (,(r 'let-syntax) ((call-next-method
                               (,(r 'syntax-rules) ()
-                               ((_) (next)))))
+                               ((_) (,(r 'next))))))
            ,@body)))))))
 
 (define (no-applicable-method-error name args)
diff --git a/tests/generic-tests.scm b/tests/generic-tests.scm
new file mode 100644
index 00000000..8c6fc72d
--- /dev/null
+++ b/tests/generic-tests.scm
@@ -0,0 +1,35 @@
+
+(import (chibi) (chibi generic) (chibi test))
+
+(test-begin "generics")
+
+(let ()
+  (define-generic add)
+  (define-method (add (x number?) (y number?))
+    (+ x y))
+  (define-method (add (x string?) (y string?))
+    (string-append x y))
+  (define-method (add x (y list?))
+    (append x y))
+  (test 4 (add 2 2))
+  (test "22" (add "2" "2"))
+  (test '(2 2) (add '() '(2 2)))
+  (test '(2 2) (add '(2) '(2)))
+  (test '(2 2) (add '(2 2) '()))
+  (test '(2) (add #f '(2)))
+  (test-error (add #(2) #(2))))
+
+(let ()
+  (define-generic mul)
+  (define-method (mul (x number?) (y number?))
+    (* x y))
+  (define-method (mul (x inexact?) (y inexact?))
+    (+ (* x y) 0.1))
+  (define-method (mul (x exact?) (y exact?))
+    (inexact->exact (call-next-method)))
+  (test 21 (mul 3 7))
+  (test 21.0 (mul 3.0 7))
+  (test 21.0 (mul 3 7.0))
+  (test 21.1 (mul 3.0 7.0)))
+
+(test-end)