Completed 2.81

2_78.rkt

@@ -53,22 +53,52 @@
 (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!))
+
 ;; Apply generic
 
+;;(define (apply-generic op . args)
+;;  (let ((type-tags (map type-tag args)))
+;;    (let ((proc (get op type-tags)))
+;;      (if proc
+;;          (apply proc (map contents args))
+;;          (error
+;;            "No method for these types -- APPLY-GENERIC"
+;;            (list op type-tags))))))
+
 (define (apply-generic op . args)
   (let ((type-tags (map type-tag args)))
     (let ((proc (get op type-tags)))
       (if proc
           (apply proc (map contents args))
-          (error
-            "No method for these types -- APPLY-GENERIC"
-            (list op type-tags))))))
+          (if (= (length args) 2)
+              (let ((type1 (car type-tags))
+                    (type2 (cadr type-tags))
+                    (a1 (car args))
+                    (a2 (cadr args)))
+                (if (not (eq? type1 type2))
+                    (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 "No method for these types"
+                                    (list op type-tags)))))
+                    (error "No method for these types"
+                           (list op type-tags))))
+              (error "No method for these types"
+                     (list op type-tags)))))))
 
 ;; Scheme numbers
 
 (define (install-scheme-number-package)
   (define (tag x)
     (attach-tag 'scheme-number x))
+  (define (exp x y) (apply-generic 'exp x y))
   (put 'add '(scheme-number scheme-number)
        (lambda (x y) (tag (+ x y))))
   (put 'sub '(scheme-number scheme-number)
@@ -80,6 +110,8 @@
   (put 'equ? '(scheme-number scheme-number) =)
   (put '=zero? '(scheme-number)
        (lambda (x) (= x 0)))
+  (put 'exp '(scheme-number scheme-number)
+       (lambda (x y) (tag (expt x y))))
   (put 'make 'scheme-number
        (lambda (x) (tag x)))
   'done)
@@ -264,6 +296,7 @@
 ;;(put 'equ? '(complex complex) equ?)
 
 (define (=zero? x) (apply-generic '=zero? x))
+(define (exp x y) (apply-generic 'exp x y))
 
 (install-scheme-number-package)
 (install-rational-package)
@@ -286,3 +319,23 @@
   (cond ((number? datum) datum)
         ((pair? datum) (cdr datum))
         (else (error "Bad tagged datum -- CONTENTS" datum))))
+
+;; Coercion
+
+
+(define (scheme-number->complex n)
+  (make-complex-from-real-imag (contents n) 0))
+
+(put-coercion 'scheme-number 'complex scheme-number->complex)
+
+(define (scheme-number->scheme-number n) n)
+(define (complex->complex z) z)
+(put-coercion 'scheme-number 'scheme-number
+              scheme-number->scheme-number)
+(put-coercion 'complex 'complex complex->complex)
+
+;; 2.81a: If we call exp with two complex arguments, apply-generic fails to find an
+;; operation with the correct argument list, so tries to coerce t1->t2.
+;; b: If the arguments are of the same type, and if there isn't an operation defined for
+;; that combination of arguments, then apply-generic will try to coerce a type to itself,
+;; so there is a need change it.