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