1 665c255d 2023-08-04 jrmu (define (coerce-to target-type remaining-args result)
2 665c255d 2023-08-04 jrmu (if (null? remaining-args)
4 665c255d 2023-08-04 jrmu (let* ((arg (car remaining-args))
5 665c255d 2023-08-04 jrmu (original-type (type-tag arg)))
6 665c255d 2023-08-04 jrmu (if (eq? original-type target-type)
7 665c255d 2023-08-04 jrmu (coerce-to target-type
8 665c255d 2023-08-04 jrmu (cdr remaining-args)
9 665c255d 2023-08-04 jrmu (append result (list arg)))
10 665c255d 2023-08-04 jrmu (let ((original->target (get-coercion (type-tag arg) target-type)))
11 665c255d 2023-08-04 jrmu (if original->target
12 665c255d 2023-08-04 jrmu (coerce-to target-type
13 665c255d 2023-08-04 jrmu (cdr remaining-args)
14 665c255d 2023-08-04 jrmu (append result (list (original->target arg))))
16 665c255d 2023-08-04 jrmu (define (put-coercion source-type target-type proc)
17 665c255d 2023-08-04 jrmu (put 'coercion (list source-type target-type) proc))
18 665c255d 2023-08-04 jrmu (define (get-coercion source-type target-type)
19 665c255d 2023-08-04 jrmu (get 'coercion (list source-type target-type)))
21 665c255d 2023-08-04 jrmu (define (apply-generic-iter coercion-types)
22 665c255d 2023-08-04 jrmu (if (null? coercion-types)
23 665c255d 2023-08-04 jrmu (error "No method for these types, and could not coerce"
24 665c255d 2023-08-04 jrmu (list op (map type-tag args)))
25 665c255d 2023-08-04 jrmu (let ((coerced-args (coerce-to (car coercion-types) args '())))
26 665c255d 2023-08-04 jrmu (if coerced-args
27 665c255d 2023-08-04 jrmu (let ((proc (get op (map type-tag coerced-args))))
29 665c255d 2023-08-04 jrmu (apply proc (map contents coerced-args))
30 665c255d 2023-08-04 jrmu (apply-generic-iter (cdr coercion-types))))
31 665c255d 2023-08-04 jrmu (apply-generic-iter (cdr coercion-types))))))
32 665c255d 2023-08-04 jrmu (define (uniquify l)
33 665c255d 2023-08-04 jrmu (if (null? l)
35 665c255d 2023-08-04 jrmu (let ((head (car l))
36 665c255d 2023-08-04 jrmu (tail (cdr l)))
37 665c255d 2023-08-04 jrmu (if (memq head tail)
38 665c255d 2023-08-04 jrmu (uniquify tail)
40 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
41 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
42 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
44 665c255d 2023-08-04 jrmu (apply proc (map contents args))
45 665c255d 2023-08-04 jrmu (let ((unique-types (uniquify type-tags)))
46 665c255d 2023-08-04 jrmu (if (> (length unique-types) 1)
47 665c255d 2023-08-04 jrmu (apply-generic-iter unique-types)
48 665c255d 2023-08-04 jrmu (else (error "No method for this type"
49 665c255d 2023-08-04 jrmu (list op type-tags))))))))
52 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
53 665c255d 2023-08-04 jrmu (if (number? contents)
55 665c255d 2023-08-04 jrmu (cons type-tag contents)))
56 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
57 665c255d 2023-08-04 jrmu (let ((type-tags (map type-tag args)))
58 665c255d 2023-08-04 jrmu (let ((proc (get op type-tags)))
60 665c255d 2023-08-04 jrmu (apply proc (map contents args))
62 665c255d 2023-08-04 jrmu "No method for these types -- APPLY-GENERIC"
63 665c255d 2023-08-04 jrmu (list op type-tags))))))
64 665c255d 2023-08-04 jrmu (define (integer->rational n)
65 665c255d 2023-08-04 jrmu (make-rational n 1))
66 665c255d 2023-08-04 jrmu (put 'raise '(integer)
67 665c255d 2023-08-04 jrmu (lambda (i) (integer->rational i)))
68 665c255d 2023-08-04 jrmu (define (rational->real r)
70 665c255d 2023-08-04 jrmu (exact->inexact (/ (numer r) (denom r)))))
71 665c255d 2023-08-04 jrmu (put 'raise '(rational)
72 665c255d 2023-08-04 jrmu (lambda (r) (rational->real r)))
73 665c255d 2023-08-04 jrmu (define (real->complex r)
74 665c255d 2023-08-04 jrmu (make-complex-from-real-imag r 0))
75 665c255d 2023-08-04 jrmu (put 'raise '(real)
76 665c255d 2023-08-04 jrmu (lambda (r) (real->complex r)))
77 665c255d 2023-08-04 jrmu (define (raise x)
78 665c255d 2023-08-04 jrmu (apply-generic 'raise x))
80 665c255d 2023-08-04 jrmu (define (raise x) (apply-generic 'raise x))
81 665c255d 2023-08-04 jrmu (put 'raise '(scheme-number)
83 665c255d 2023-08-04 jrmu (if (exact-integer? x)
84 665c255d 2023-08-04 jrmu (make-rational x 1)
85 665c255d 2023-08-04 jrmu (make-complex-from-real-imag x 0))))
86 665c255d 2023-08-04 jrmu (put 'raise '(rational)
88 665c255d 2023-08-04 jrmu (make-scheme-number (exact->inexact (/ (numer r) (denom r))))))
90 665c255d 2023-08-04 jrmu (define (install-integer-package)
91 665c255d 2023-08-04 jrmu (define (tag x)
92 665c255d 2023-08-04 jrmu (attach-tag 'integer x))
93 665c255d 2023-08-04 jrmu (put 'add '(integer integer)
94 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
95 665c255d 2023-08-04 jrmu (put 'sub '(integer integer)
96 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
97 665c255d 2023-08-04 jrmu (put 'mul '(integer integer)
98 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
99 665c255d 2023-08-04 jrmu (put 'div '(integer integer)
100 665c255d 2023-08-04 jrmu (lambda (x y) (make-rational x y)))
101 665c255d 2023-08-04 jrmu (put 'equ '(integer integer) =)
102 665c255d 2023-08-04 jrmu (put '=zero? '(integer)
103 665c255d 2023-08-04 jrmu (lambda (x) (= 0 x)))
104 665c255d 2023-08-04 jrmu (put 'make 'integer
105 665c255d 2023-08-04 jrmu (lambda (x) (if (integer? x)
107 665c255d 2023-08-04 jrmu (error "non-integer value" x))))
110 665c255d 2023-08-04 jrmu (define (make-integer n)
111 665c255d 2023-08-04 jrmu ((get 'make 'integer) n))
113 665c255d 2023-08-04 jrmu (define (install-real-package)
114 665c255d 2023-08-04 jrmu (define (tag x)
115 665c255d 2023-08-04 jrmu (attach-tag 'real x))
116 665c255d 2023-08-04 jrmu (put 'add '(real real)
117 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
118 665c255d 2023-08-04 jrmu (put 'sub '(integer integer)
119 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
120 665c255d 2023-08-04 jrmu (put 'mul '(integer integer)
121 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
122 665c255d 2023-08-04 jrmu (put 'div '(integer integer)
123 665c255d 2023-08-04 jrmu (lambda (x y) (tag (/ x y))))
124 665c255d 2023-08-04 jrmu (put 'equ? '(real real) =)
125 665c255d 2023-08-04 jrmu (put '=zero? '(real)
126 665c255d 2023-08-04 jrmu (lambda (x) (= 0 x)))
127 665c255d 2023-08-04 jrmu (put 'make 'real
128 665c255d 2023-08-04 jrmu (lambda (x) (if (real? x)
130 665c255d 2023-08-04 jrmu (error "non-real value" x))))
133 665c255d 2023-08-04 jrmu (define (make-real n)
134 665c255d 2023-08-04 jrmu ((get 'make 'real) n))
136 665c255d 2023-08-04 jrmu (define (install-rational-package)
137 665c255d 2023-08-04 jrmu (define (make-rat n d)
138 665c255d 2023-08-04 jrmu (if (and (integer? n) (integer? d))
139 665c255d 2023-08-04 jrmu (let ((g (gcd n d)))
140 665c255d 2023-08-04 jrmu (cons (/ n g) (/ d g)))
141 665c255d 2023-08-04 jrmu (error "non-integer numerator or denominator"
142 665c255d 2023-08-04 jrmu (list n d))))
145 665c255d 2023-08-04 jrmu (define (install-rectangular-package)
146 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
147 665c255d 2023-08-04 jrmu (if (and (in-tower? x) (in-tower? y))
149 665c255d 2023-08-04 jrmu (error "non-real real or imaginary value" (list x y))))
150 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
151 665c255d 2023-08-04 jrmu (if (and (real? r) (real? a))
152 665c255d 2023-08-04 jrmu (cons (* r (cos a)) (* r (sin a)))
153 665c255d 2023-08-04 jrmu (error "non-real magnitude or angle" (list r a))))
157 665c255d 2023-08-04 jrmu (define (install-polar-package)
158 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
159 665c255d 2023-08-04 jrmu (if (and (in-tower? r) (in-tower? a))
161 665c255d 2023-08-04 jrmu (error "non-real magnitude or angle" (list r a))))
162 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
163 665c255d 2023-08-04 jrmu (if (and (in-tower? x) (in-tower? y))
164 665c255d 2023-08-04 jrmu (cons (sqrt (+ (square x) (square y)))
165 665c255d 2023-08-04 jrmu (atan y x))
166 665c255d 2023-08-04 jrmu (error "non-real real or imaginary value" (list x y))))
169 665c255d 2023-08-04 jrmu (define (integer->rational i) (make-rational i 1))
170 665c255d 2023-08-04 jrmu (define (rational->real r) (make-real (/ (numer r) (denom r))))
171 665c255d 2023-08-04 jrmu (define (real->complex r) (make-complex-from-real-imag r 0))
172 665c255d 2023-08-04 jrmu (define (raise x) (apply-generic 'raise x))
174 665c255d 2023-08-04 jrmu (define tower-of-types '(integer rational real complex))
175 665c255d 2023-08-04 jrmu (define (raise x)
176 665c255d 2023-08-04 jrmu (define (apply-raise types)
177 665c255d 2023-08-04 jrmu (cond ((null? types)
178 665c255d 2023-08-04 jrmu (error "Type not found in the tower-of-types"
179 665c255d 2023-08-04 jrmu (list x tower-of-types)))
180 665c255d 2023-08-04 jrmu ((eq? (type-tag x) (car types))
181 665c255d 2023-08-04 jrmu (if (null? (cdr types))
183 665c255d 2023-08-04 jrmu (let ((raiser (get-coercion (type-tag x) (cadr types))))
185 665c255d 2023-08-04 jrmu (raiser (contents x))
186 665c255d 2023-08-04 jrmu (error "No coercion procedure found for types"
187 665c255d 2023-08-04 jrmu (list (type-tag x) (cadr types)))))))
188 665c255d 2023-08-04 jrmu (else (apply-raise (cdr types)))))
189 665c255d 2023-08-04 jrmu (apply-raise tower-of-types))
