1 (define (coerce-to target-type remaining-args result)
2   (if (null? remaining-args)
3       result
4       (let* ((arg (car remaining-args))
5 	     (original-type (type-tag arg)))
6 	(if (eq? original-type target-type)
7 	    (coerce-to target-type
8 		       (cdr remaining-args)
9 		       (append result (list arg)))
10 	    (let ((original->target (get-coercion (type-tag arg) target-type)))
11 	      (if original->target
12 		  (coerce-to target-type
13 			     (cdr remaining-args)
14 			     (append result (list (original->target arg))))
15 		  #f))))))
16 (define (put-coercion source-type target-type proc)
17   (put 'coercion (list source-type target-type) proc))
18 (define (get-coercion source-type target-type)
19   (get 'coercion (list source-type target-type)))
20 
21 (define (apply-generic-iter coercion-types)
22   (if (null? coercion-types)
23       (error "No method for these types, and could not coerce"
24 	     (list op (map type-tag args)))
25       (let ((coerced-args (coerce-to (car coercion-types) args '())))
26 	(if coerced-args
27 	    (let ((proc (get op (map type-tag coerced-args))))
28 	      (if proc
29 		  (apply proc (map contents coerced-args))
30 		  (apply-generic-iter (cdr coercion-types))))
31 	    (apply-generic-iter (cdr coercion-types))))))
32 (define (uniquify l)
33   (if (null? l)
34       '()
35       (let ((head (car l))
36 	    (tail (cdr l)))
37 	(if (memq head tail)
38 	    (uniquify tail)
39 
40 (define (apply-generic op . args)
41   (let* ((type-tags (map type-tag args))
42 	 (proc (get op type-tags)))
43     (if proc
44 	(apply proc (map contents args))
45 	(let ((unique-types (uniquify type-tags)))
46 	  (if (> (length unique-types) 1)
47 	      (apply-generic-iter unique-types)
48 	      (else (error "No method for this type"
49 			   (list op type-tags))))))))
50     
51 
52 (define (attach-tag type-tag contents)
53   (if (number? contents)
54       contents
55       (cons type-tag contents)))
56 (define (apply-generic op . args)
57   (let ((type-tags (map type-tag args)))
58     (let ((proc (get op type-tags)))
59       (if proc
60 	  (apply proc (map contents args))
61 	  (error
62 	   "No method for these types -- APPLY-GENERIC"
63 	   (list op type-tags))))))
64 (define (integer->rational n)
65   (make-rational n 1))
66 (put 'raise '(integer)
67      (lambda (i) (integer->rational i)))
68 (define (rational->real r)
69   (make-real
70    (exact->inexact (/ (numer r) (denom r)))))
71 (put 'raise '(rational)
72      (lambda (r) (rational->real r)))
73 (define (real->complex r)
74   (make-complex-from-real-imag r 0))
75 (put 'raise '(real)
76      (lambda (r) (real->complex r)))
77 (define (raise x)
78   (apply-generic 'raise x))
79 
80 (define (raise x) (apply-generic 'raise x))
81 (put 'raise '(scheme-number)
82      (lambda (x)
83        (if (exact-integer? x)
84 	   (make-rational x 1)
85 	   (make-complex-from-real-imag x 0))))
86 (put 'raise '(rational)
87      (lambda (r)
88        (make-scheme-number (exact->inexact (/ (numer r) (denom r))))))
89 
90 (define (install-integer-package)
91   (define (tag x)
92     (attach-tag 'integer x))
93   (put 'add '(integer integer)
94        (lambda (x y) (tag (+ x y))))
95   (put 'sub '(integer integer)
96        (lambda (x y) (tag (- x y))))
97   (put 'mul '(integer integer)
98        (lambda (x y) (tag (* x y))))
99   (put 'div '(integer integer)
100        (lambda (x y) (make-rational x y)))
101   (put 'equ '(integer integer) =)
102   (put '=zero? '(integer)
103        (lambda (x) (= 0 x)))
104   (put 'make 'integer
105        (lambda (x) (if (integer? x)
106 		       (tag x)
107 		       (error "non-integer value" x))))
108   'done)
109 
110 (define (make-integer n)
111   ((get 'make 'integer) n))
112 
113 (define (install-real-package)
114   (define (tag x)
115     (attach-tag 'real x))
116   (put 'add '(real real)
117        (lambda (x y) (tag (+ x y))))
118   (put 'sub '(integer integer)
119        (lambda (x y) (tag (- x y))))
120   (put 'mul '(integer integer)
121        (lambda (x y) (tag (* x y))))
122   (put 'div '(integer integer)
123        (lambda (x y) (tag (/ x y))))
124   (put 'equ? '(real real) =)
125   (put '=zero? '(real)
126        (lambda (x) (= 0 x)))
127   (put 'make 'real
128        (lambda (x) (if (real? x)
129 		       (tag x)
130 		       (error "non-real value" x))))
131   'done)
132 
133 (define (make-real n)
134   ((get 'make 'real) n))
135 
136 (define (install-rational-package)
137   (define (make-rat n d)
138     (if (and (integer? n) (integer? d))
139 	(let ((g (gcd n d)))
140 	  (cons (/ n g) (/ d g)))
141 	(error "non-integer numerator or denominator"
142 	       (list n d))))
143   'done)
144 
145 (define (install-rectangular-package)
146   (define (make-from-real-imag x y)
147     (if (and (in-tower? x) (in-tower? y))
148 	(cons x y)
149 	(error "non-real real or imaginary value" (list x y))))
150   (define (make-from-mag-ang r a)
151     (if (and (real? r) (real? a))
152 	(cons (* r (cos a)) (* r (sin a)))
153 	(error "non-real magnitude or angle" (list r a))))
154 
155   'done)
156 
157 (define (install-polar-package)
158   (define (make-from-mag-ang r a)
159     (if (and (in-tower? r) (in-tower? a))
160 	(cons r a)
161 	(error "non-real magnitude or angle" (list r a))))
162   (define (make-from-real-imag x y)
163     (if (and (in-tower? x) (in-tower? y))
164 	(cons (sqrt (+ (square x) (square y)))
165 	      (atan y x))
166 	(error "non-real real or imaginary value" (list x y))))
167   'done)
168 
169 (define (integer->rational i) (make-rational i 1))
170 (define (rational->real r) (make-real (/ (numer r) (denom r))))
171 (define (real->complex r) (make-complex-from-real-imag r 0))
172 (define (raise x) (apply-generic 'raise x))
173 
174 (define tower-of-types '(integer rational real complex))
175 (define (raise x)
176   (define (apply-raise types)
177     (cond ((null? types)
178 	   (error "Type not found in the tower-of-types"
179 		  (list x tower-of-types)))
180 	  ((eq? (type-tag x) (car types)) 
181 	   (if (null? (cdr types))
182 	       x
183 	       (let ((raiser (get-coercion (type-tag x) (cadr types))))
184 		 (if raiser
185 		     (raiser (contents x))
186 		     (error "No coercion procedure found for types"
187 			    (list (type-tag x) (cadr types)))))))
188 	  (else (apply-raise (cdr types)))))
189   (apply-raise tower-of-types))
190 
191 (define (install-integer-package)
192   (define (tag x)
193     (attach-tag 'integer x))
194   (put 'add '(integer integer)
195        (lambda (x y) (tag (+ x y))))
196   (put 'sub '(integer integer)
197        (lambda (x y) (tag (- x y))))
198   (put 'mul '(integer integer)
199        (lambda (x y) (tag (* x y))))
200   (put 'div '(integer integer)
201        (lambda (x y) (make-rational x y)))
202   (put 'equ? '(integer integer) =)
203   (put '=zero? '(integer) =zero?)
204   (put 'make 'integer
205        (lambda (x) (if (integer? x)
206 		       (tag x)
207 		       (error "non-integer value" x))))
208   'done)
209 (define (make-integer n)
210   ((get 'make 'integer) n))
211 
212 (define (install-real-package)
213   (define (tag x)
214     (attach-tag 'real x))
215   (put 'add '(real real)
216        (lambda (x y) (tag (+ x y))))
217   (put 'sub '(real real)
218        (lambda (x y) (tag (- x y))))
219   (put 'mul '(real real)
220        (lambda (x y) (tag (* x y))))
221   (put 'div '(real real)
222        (lambda (x y) (tag (/ x y))))
223   (put 'equ? '(real real) =)
224   (put '=zero? '(real)
225        (lambda (x) (= 0 x)))
226   (put 'make 'real
227        (lambda (x) (if (real? x)
228 		       (tag x)
229 		       (error "non-real value" x))))
230 
231 (define (make-real n)
232   ((get 'make 'real) n))
233 
234 (define (install-rational-package)
235   (define (make-rat n d)
236     (if (and (integer? n) (integer? d))
237 	(let ((g (gcd n d)))
238 	  (cons (/ n g) (/ d g)))
239 	(error "non-integer numerator or denominator"
240 	       (list n d))))
241   'done)
242 
243 (define (install-rectangular-package)
244   (define (make-from-real-imag x y)
245     (if (and (in-tower? x) (in-tower? y))
246 	(cons x y)
247 	(error "non-real real or imaginary value" (list x y))))
248   (define (make-from-mag-ang r a)
249     (if (and (real? r) (real? a))
250 	(cons (* r (cos a)) (* r (sin a)))
251 	(error "non-real magnitude or angle" (list r a))))
252   'done)
253 (define (install-polar-package)
254   (define (make-from-mag-ang r a)
255     (if (and (in-tower? r) (in-tower? a))
256 	(cons r a)
257 	(error "non-real magnitude or angle" (list r a))))
258   (define (make-from-real-imag x y)
259     (if (and (in-tower? x) (in-tower? y))
260 	(cons (sqrt (+ (square x) (square y)))
261 	      (atan y x))
262 	(error "non-real real or imaginary value" (list x y))))
263   'done)
264 
265 
266 (define (integer->rational i) (make-rational i 1))
267 (define (rational->real r) (make-real (/ (numer r) (denom r))))
268 (define (real->complex r) (make-complex-from-real-imag r 0))
269 (define (raise x) (apply-generic 'raise x))
270 
271 (define tower-of-types '(integer rational real complex))
272 (define (raise x)
273   (define (apply-raise types)
274     (cond ((null? types)
275 	   (error "Type not found in the tower-of-types"
276 		  (list x tower-of-types)))
277 	  ((eq? (type-tag x) (car types))
278 	   (if (null? (cdr types))
279 	       x
280 	       (let ((raiser (get-coercion (type-tag x) (cadr types))))
281 		 (if raiser
282 		     (raiser (contents x))
283 		     (error "No coercion procedure found for types"
284 			    (list (type-tag x) (cadr types)))))))
285 	  (else (apply-raise (cdr types)))))
286   (apply-raise tower-of-types))
287 
288 (define (integer->rational i) (make-rational i 1))
289 (put-coercion 'integer 'rational integer->rational)
290 'done
291 (define (rational->real r) (make-real (/ (numer r) (denom r))))
292 (put-coercion 'rational 'real rational->real)
293 'done
294 (define (real->complex r) (make-complex-from-real-imag r 0))
295 (put-coercion 'real 'complex real->complex)
296 'done
297 
298 
299 (raise (make-integer 2))
300 (raise (make-rational 3 4))
301 (raise (