src/sicp/ex2_81.rkt

   1 #lang racket
   2
   3 (define (apply-generic op . args)
   4   (let ((type-tags (map type-tag args)))
   5     (let ((proc (get op type-tags)))
   6       (if proc
   7           (apply proc (map contents args))
   8           (if (= (length args) 2)
   9               (let ((type1 (car type-tags))
  10                     (type2 (cadr type-tags))
  11                     (a1 (car args))
  12                     (a2 (cadr args)))
  13                 (let ((t1->t2 (get-coercion type1 type2))
  14                       (t2->t1 (get-coercion type2 type1)))
  15                   (cond (t1->t2
  16                          (apply-generic op (t1->t2 a1) a2))
  17                         (t2->t1
  18                          (apply-generic op a1 (t2->t1 a2)))
  19                         (else
  20                          (error "No method for these types"
  21                                 (list op type-tags))))))
  22               (error "No method for these types"
  23                      (list op type-tags)))))))
  24
  25 (define (scheme-number->scheme-number n) n)
  26 (define (complex->complex z) z)
  27 (put-coercion 'scheme-number 'scheme-number
  28               scheme-number->scheme-number)
  29 (put-coercion 'complex 'complex complex->complex)
  30
  31 (define (exp x y) (apply-generic 'exp x y))
  32
  33 ;; following added to Scheme-number package
  34 (put 'exp '(scheme-number scheme-number)
  35      (lambda (x y) (tag (expt x y)))) ; using primitive expt
  36
  37 #|
  38
  39 2.81 a. The initial (get 'exp '(complex complex)) yield a false as the procedure
  40 to handle '(complex complex) was not installed into the table. So, it gets the coercion
  41 table:
  42
  43  (get-coersion 'complex 'complex) => complex->complex
  44
  45  (apply-generic 'exp (complex->complex a1) a2) => (apply-generic 'exp a1 a2)
  46
  47 So, we keep calling ourselves until stack overflows.
  48
  49 |#
  50
  51 #|
  52
  53 b.
  54
  55 As long as we install a procedure to handle same typed data in the main table and not
  56 do a same type to same type coercion, it is fine. So, Louis is wrong.
  57
  58 |#
  59
  60 ;; c
  61 (define (apply-generic op . args)
  62   (let ((type-tags (map type-tag args)))
  63     (let ((proc (get op type-tags)))
  64       (cond
  65         (proc (apply proc (map contents args)))
  66         ((and (car type-tags) (cadr type-tags))
  67          (error "No procedure to handle the type" (car type-tags)))
  68         ((= (length args) 2)
  69          (let ((type1 (car type-tags))
  70                (type2 (cadr type-tags))
  71                (a1 (car args))
  72                (a2 (cadr args)))
  73            (let ((t1->t2 (get-coercion type1 type2))
  74                  (t2->t1 (get-coercion type2 type1)))
  75              (cond (t1->t2
  76                     (apply-generic op (t1->t2 a1) a2))
  77                    (t2->t1
  78                     (apply-generic op a1 (t2->t1 a2)))
  79                    (else
  80                     (error "No method for these types"
  81                            (list op type-tags)))))))
  82         (else (error "No method for these types"
  83                      (list op type-tags)))))))