]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ex2_81.rkt
rewrite `quote->cons' using `match'.
[sicp.git] / 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)))))))