From e5821d622d7bfeb7f04c6080aaf0ff5b6df56c11 Mon Sep 17 00:00:00 2001
From: seckcoder <seckcoder@Gmail.com>
Date: Tue, 23 Jul 2013 21:43:58 +0800
Subject: [PATCH] c2 81-82

---
 src/c2_81.scm    |  8 ++++++++
 src/c2_82.scm    |  2 ++
 src/lib/base.scm | 25 +++++++++++++++++++++----
 3 files changed, 31 insertions(+), 4 deletions(-)
 create mode 100644 src/c2_81.scm
 create mode 100644 src/c2_82.scm

diff --git a/src/c2_81.scm b/src/c2_81.scm
new file mode 100644
index 0000000..213fcb9
--- /dev/null
+++ b/src/c2_81.scm
@@ -0,0 +1,8 @@
+; a)
+; there will be infinite loop. since apply-generic will call apply-generic
+; again(with complex number coerced to complex number)
+; when it cannot find the exp proc for (complex-number complex-number).
+; b)
+; ...
+; c)
+; in lib/base.scm
diff --git a/src/c2_82.scm b/src/c2_82.scm
new file mode 100644
index 0000000..13d1299
--- /dev/null
+++ b/src/c2_82.scm
@@ -0,0 +1,2 @@
+; This strategy apparently not works. For an defined operation intable:
+; op(numeric, rational, complex), the op will not be tried.
diff --git a/src/lib/base.scm b/src/lib/base.scm
index d03fc06..e63037a 100644
--- a/src/lib/base.scm
+++ b/src/lib/base.scm
@@ -9,6 +9,9 @@
   (define operation-table (make-table))
   (define get (operation-table 'lookup-proc))
   (define put (operation-table 'insert-proc!))
+  (define coercion-table (make-table))
+  (define get-coercion (coercion-table 'lookup-proc))
+  (define put-coercion (coercion-table 'insert-proc!))
   (define (attach-tag type-tag contents)
     (cons type-tag contents))
   (define (type-tag datum)
@@ -23,12 +26,26 @@
     (* x x))
   (define (apply-generic op . args)
     ; args corresponding to the args of op
+    (define (error-msg)
+      (error 'apply-generic "No method for these types"
+             (list op type-tags)))
+
     (let ((type-tags (map type-tag args)))
       (let ((proc (get op type-tags)))
         (if proc
           (apply proc (map contents args))
-          (error
-            'apply-generic
-            "No method for these types"
-            (list op type-tags))))))
+          (if (= (length args) 2)
+            (let ((type1 (car type-tags))
+                  (type2 (cadr type-tags)))
+              (if (eq? type1 type2)
+                (error-msg)
+                (let ((t1->t2 (get-coercion type1 type2))
+                      (t2->t1 (get-coercion type2 type1)))
+                  (cond (t1->t2
+                          (apply-generic op (t1->t2 a1) a2))
+                        (t2->t1
+                          (apply-generic op a1 (t2->t1 a2)))
+                        (else
+                          (error-msg))))))
+            (error-msg))))))
   )