src/sicp/ex2_82.rkt

   1 #lang racket
   2
   3 ;; get a list of coercions (t1->t t2->2 .... tn->t)
   4 ;; if a type coercion does not exist, the
   5 ;; particular index will have #f
   6 (define (get-coercions type types)
   7   (map (lambda (t)
   8          (if (eq? t type)
   9              (lambda (x) x)
  10              (get-coercion t type)))
  11        types))
  12
  13 (define (all-valid? coercions)
  14   (cond
  15     ((null? coercions) #t)
  16     ((car coercions) (all-valid? (cdr coercions)))
  17     (else #f)))
  18
  19 (define (get-all-type-coercions types)
  20   (map (lambda (t)
  21          (get-coercions t types))
  22        types))
  23
  24 (define (apply-generic op . args)
  25   (define (apply-generic-2 type-coercion-list)
  26     (cond
  27       ((null? type-coercion-list) (error "cannot find a suitable type coercion"))
  28       ((all-valid? (car type-coercion-list))
  29        (let ((coerced-args (map (lambda (t a) (t a)) (car type-coercion-list) args)))
  30          (apply-generic-1 coerced-args)))
  31       (else (apply-generic-2 (cdr type-coercion-list)))))
  32
  33   (define (apply-generic-1 args)
  34     (let ((type-tags (map type-tag args)))
  35       (let ((proc (get op type-tags)))
  36         (if proc
  37             (apply proc (map contents args))
  38             (let ((tn->t1 (get-all-type-coercions types)))
  39               (apply-generic-2 tn->t1))))))
  40
  41   (apply-generic-1 args))
  42
  43 #|
  44 The method will fail if say, t2, t3 and t4 can only be coreced into t1 but the call to apply-generic does not have an argument of type t1.
  45 Instead, if we have a way to figure out the relation between types and the hierarchy, then we can deal with it better.
  46 |#