1 (define (install-rational-package)
2   (define (rational->integer r)
3     (make-integer (quotient (numer r) (denom r))))
4   (put-coercion 'rational 'integer rational->integer)
5   'done)
6 (define (install-real-package)
7   (define (real->rational r)
8     (make-rational (inexact->exact (numerator r))
9 		   (inexact->exact (denominator r))))
10   (put-coercion 'real 'rational real->rational)
11   'done)
12 (define (install-complex-package)
13   (define (complex->real z)
14     (make-real (complex-real-part z)))
15   (put-coercion 'complex 'real complex->real)
16   'done)
17 
18 (define (apply-raise x types)
19   (cond ((null? types)
20 	 (error "Type not found in the tower-of-types"
21 		(list (type-tag x) tower-of-types)))
22 	((eq? (type-tag x) (car types))
23 	 (if (null? (cdr types))
24 	     x
25 	     (let ((raiser (get-coercion (type-tag x) (cadr types))))
26 	       (if raiser
27 		   (raiser (contents x))
28 		   (error "No coercion procedure found for types"
29 			  (list (type-tag x) (cadr types)))))))
30 	(else (apply-raise x (cdr types)))))
31 (define (raise x)
32   (apply-raise x tower-of-types))
33 (define (project x)
34   (apply-raise x (reverse tower-of-types)))
35 (define (project x)
36   (define (apply-project types)
37     (cond ((eq? (type-tag x) (car types)) x)
38 	  ((or (null? types) (null? (cdr types)))
39 	   (error "type not found in the tower-of-types"
40 		  (list (type-tag x) tower-of-types)))
41 	  ((eq? (type-tag x) (cadr types))
42 	   (let ((projector (get-coercion (type-tag x) (car types))))
43 	     (if projector
44 		 (projector (contents x))
45 		 (error "No coercion procedure found for types"
46 			(list (car types) (type-tag x))))))
47 	  (else (apply-project (cdr types)))))
48   (apply-project tower-of-types))
49 
50 
51 (define (install-rational-package)
52   (define (rational->integer r)
53     (make-integer (round (/ (numer r) (denom r)))))
54   (put-coercion 'rational 'integer rational->integer)
55   'done)
56 
57 (define (install-real-package)
58   (define (real->rational r)
59     (make-rational (inexact->exact (numerator r))
60 		   (inexact->exact (denominator r))))
61   (put-coercion 'real 'rational real->rational)
62   'done)
63 
64 (define (install-complex-package)
65   (define (complex->real z)
66     (make-real (complex-real-part z)))
67   (put-coercion 'complex 'real complex->real)
68   'done)
69 
70 (define (apply-raise x types)
71   (cond ((null? types)
72 	 (error "Type not found in the tower-of-types"
73 		(list (type-tag x) tower-of-types)))
74 	((eq? (type-tag x) (car types))
75 	 (if (null? (cdr types))
76 	     x
77 	     (let ((raiser (get-coercion (type-tag x) (cadr types))))
78 	       (if raiser
79 		   (raiser (contents x))
80 		   (error "No coercion procedures found for types"
81 			  (list (type-tag x) (cadr types)))))))
82 	(else (apply-raise x (cdr types)))))
83 
84 (define (raise x)
85   (apply-raise x tower-of-types))
86 (define (project x)
87   (apply-raise x (reverse tower-of-types)))
88 
89 (define (project x)
90   (define (apply-project types)
91     (cond ((eq? (type-tag x) (car types)) x)
92 	  ((or (null? types) (null? (cdr types)))
93 	   (error "type not found in the tower-of-types"
94 		  (list (type-tag x) tower-of-types)))