1 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
2 665c255d 2023-08-04 jrmu (if (or (eq? type-tag 'integer)
3 665c255d 2023-08-04 jrmu (eq? type-tag 'real))
5 665c255d 2023-08-04 jrmu (cons type-tag contents)))
6 665c255d 2023-08-04 jrmu (define (type-tag datum)
7 665c255d 2023-08-04 jrmu (cond ((pair? datum) (car datum))
8 665c255d 2023-08-04 jrmu ((exact? datum) 'integer)
9 665c255d 2023-08-04 jrmu ((number? datum) 'real)
10 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
11 665c255d 2023-08-04 jrmu (define (contents datum)
12 665c255d 2023-08-04 jrmu (cond ((pair? datum) (cdr datum))
13 665c255d 2023-08-04 jrmu ((exact? datum) datum)
14 665c255d 2023-08-04 jrmu ((number? datum) (exact->inexact datum))
15 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
17 665c255d 2023-08-04 jrmu (define (make-table)
18 665c255d 2023-08-04 jrmu (define (assoc key records)
19 665c255d 2023-08-04 jrmu (cond ((null? records) false)
20 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
21 665c255d 2023-08-04 jrmu (else (assoc key (cdr records)))))
22 665c255d 2023-08-04 jrmu (let ((local-table (list '*table*)))
23 665c255d 2023-08-04 jrmu (define (lookup key-1 key-2)
24 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
25 665c255d 2023-08-04 jrmu (if subtable
26 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
28 665c255d 2023-08-04 jrmu (cdr record)
31 665c255d 2023-08-04 jrmu (define (insert! key-1 key-2 value)
32 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
33 665c255d 2023-08-04 jrmu (if subtable
34 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
36 665c255d 2023-08-04 jrmu (set-cdr! record value)
37 665c255d 2023-08-04 jrmu (set-cdr! subtable
38 665c255d 2023-08-04 jrmu (cons (cons key-2 value)
39 665c255d 2023-08-04 jrmu (cdr subtable)))))
40 665c255d 2023-08-04 jrmu (set-cdr! local-table
41 665c255d 2023-08-04 jrmu (cons (list key-1
42 665c255d 2023-08-04 jrmu (cons key-2 value))
43 665c255d 2023-08-04 jrmu (cdr local-table)))))
45 665c255d 2023-08-04 jrmu (define (dispatch m)
46 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup-proc) lookup)
47 665c255d 2023-08-04 jrmu ((eq? m 'insert-proc!) insert!)
48 665c255d 2023-08-04 jrmu (else (error "Unknown operation -- TABLE" m))))
51 665c255d 2023-08-04 jrmu (define operation-table (make-table))
52 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
53 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
55 665c255d 2023-08-04 jrmu (define (add x y) (apply-generic 'add x y))
56 665c255d 2023-08-04 jrmu (define (sub x y) (apply-generic 'sub x y))
57 665c255d 2023-08-04 jrmu (define (mul x y) (apply-generic 'mul x y))
58 665c255d 2023-08-04 jrmu (define (div x y) (apply-generic 'div x y))
59 665c255d 2023-08-04 jrmu (define (equ? x y) (apply-generic 'equ? x y))
60 665c255d 2023-08-04 jrmu (define (=zero? x) (apply-generic '=zero? x))
61 665c255d 2023-08-04 jrmu (define (raise x) (apply-generic 'raise x))
62 665c255d 2023-08-04 jrmu (define (project x) (apply-generic 'project x))
65 665c255d 2023-08-04 jrmu (define (install-integer-package)
66 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'integer x))
67 665c255d 2023-08-04 jrmu (put 'add '(integer integer)
68 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
69 665c255d 2023-08-04 jrmu (put 'sub '(integer integer)
70 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
71 665c255d 2023-08-04 jrmu (put 'mul '(integer integer)
72 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
73 665c255d 2023-08-04 jrmu (put 'div '(integer integer)
74 665c255d 2023-08-04 jrmu (lambda (x y) (tag (quotient x y))))
75 665c255d 2023-08-04 jrmu ;; (if (integer? (/ x y))
76 665c255d 2023-08-04 jrmu ;; (tag (/ x y))
77 665c255d 2023-08-04 jrmu ;; (div (raise (tag x))
78 665c255d 2023-08-04 jrmu ;; (raise (tag y))))))
79 665c255d 2023-08-04 jrmu ;; ;; we avoided calling make-rational to avoid dependencies
80 665c255d 2023-08-04 jrmu (put 'equ? '(integer integer) =)
81 665c255d 2023-08-04 jrmu (put '=zero? '(integer) zero?)
82 665c255d 2023-08-04 jrmu (put 'make 'integer
84 665c255d 2023-08-04 jrmu (if (exact? n)
86 665c255d 2023-08-04 jrmu (error "Not an exact integer" n))))
87 665c255d 2023-08-04 jrmu (put 'raise '(integer)
88 665c255d 2023-08-04 jrmu (lambda (x) (make-rational x 1)))
89 665c255d 2023-08-04 jrmu (put 'project '(integer)
90 665c255d 2023-08-04 jrmu (lambda (x) #f))
93 665c255d 2023-08-04 jrmu (define (install-rational-package)
94 665c255d 2023-08-04 jrmu (define (gcd a b)
97 665c255d 2023-08-04 jrmu (gcd b (remainder a b))))
98 665c255d 2023-08-04 jrmu (define (numer x) (car x))
99 665c255d 2023-08-04 jrmu (define (denom x) (cdr x))
100 665c255d 2023-08-04 jrmu (define (make-rat n d)
101 665c255d 2023-08-04 jrmu (if (not (and (integer? n) (integer? d)))
102 665c255d 2023-08-04 jrmu (error "Both numerator and denominator must be integers"
103 665c255d 2023-08-04 jrmu (list n d))
104 665c255d 2023-08-04 jrmu (let ((g (gcd n d)))
105 665c255d 2023-08-04 jrmu (cons (/ n g) (/ d g)))))
106 665c255d 2023-08-04 jrmu (define (add-rat x y)
107 665c255d 2023-08-04 jrmu (make-rat (+ (* (numer x) (denom y))
108 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
109 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
110 665c255d 2023-08-04 jrmu (define (sub-rat x y)
111 665c255d 2023-08-04 jrmu (make-rat (- (* (numer x) (denom y))
112 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
113 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
114 665c255d 2023-08-04 jrmu (define (mul-rat x y)
115 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (numer y))
116 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
117 665c255d 2023-08-04 jrmu (define (div-rat x y)
118 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (denom y))
119 665c255d 2023-08-04 jrmu (* (denom x) (numer y))))
120 665c255d 2023-08-04 jrmu (define (equ-rat? x y)
121 665c255d 2023-08-04 jrmu (and (= (numer x) (numer y))
122 665c255d 2023-08-04 jrmu (= (denom x) (denom y))))
123 665c255d 2023-08-04 jrmu (define (=zero-rat? x) (= (numer x) 0))
124 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rational x))
125 665c255d 2023-08-04 jrmu (put 'add '(rational rational)
126 665c255d 2023-08-04 jrmu (lambda (x y) (tag (add-rat x y))))
127 665c255d 2023-08-04 jrmu (put 'sub '(rational rational)
128 665c255d 2023-08-04 jrmu (lambda (x y) (tag (sub-rat x y))))
129 665c255d 2023-08-04 jrmu (put 'mul '(rational rational)
130 665c255d 2023-08-04 jrmu (lambda (x y) (tag (mul-rat x y))))
131 665c255d 2023-08-04 jrmu (put 'div '(rational rational)
132 665c255d 2023-08-04 jrmu (lambda (x y) (tag (div-rat x y))))
133 665c255d 2023-08-04 jrmu (put 'equ? '(rational rational) equ-rat?)
134 665c255d 2023-08-04 jrmu (put '=zero? '(rational) =zero-rat?)
135 665c255d 2023-08-04 jrmu (put 'make 'rational
136 665c255d 2023-08-04 jrmu (lambda (n d) (tag (make-rat n d))))
137 665c255d 2023-08-04 jrmu (put 'raise '(rational)
138 665c255d 2023-08-04 jrmu (lambda (x) (make-real (/ (numer x) (denom x)))))
139 665c255d 2023-08-04 jrmu (put 'project '(rational)
140 665c255d 2023-08-04 jrmu (lambda (x) (make-integer (quotient (numer x) (denom x)))))
143 665c255d 2023-08-04 jrmu (define (install-real-package)
144 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'real x))
145 665c255d 2023-08-04 jrmu (put 'add '(real real)
146 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
147 665c255d 2023-08-04 jrmu (put 'sub '(real real)
148 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
149 665c255d 2023-08-04 jrmu (put 'mul '(real real)
150 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
151 665c255d 2023-08-04 jrmu (put 'div '(real real)
152 665c255d 2023-08-04 jrmu (lambda (x y) (tag (/ x y))))
153 665c255d 2023-08-04 jrmu (put 'equ? '(real real) =)
154 665c255d 2023-08-04 jrmu (put '=zero? '(real) zero?)
155 665c255d 2023-08-04 jrmu (put 'make 'real
156 665c255d 2023-08-04 jrmu (lambda (n)
157 665c255d 2023-08-04 jrmu (if (rational? n)
158 665c255d 2023-08-04 jrmu (tag (exact->inexact n))
160 665c255d 2023-08-04 jrmu (put 'raise '(real)
161 665c255d 2023-08-04 jrmu (lambda (x) (make-complex-from-real-imag x 0)))
162 665c255d 2023-08-04 jrmu (put 'project '(real)
163 665c255d 2023-08-04 jrmu (lambda (x) (make-rational (inexact->exact (numerator x))
164 665c255d 2023-08-04 jrmu (inexact->exact (denominator x)))))
168 665c255d 2023-08-04 jrmu (define (install-complex-package)
169 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
170 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'rectangular) x y))
171 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
172 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'polar) r a))
174 665c255d 2023-08-04 jrmu (define (real-part z) (apply-generic 'real-part z))
175 665c255d 2023-08-04 jrmu (define (imag-part z) (apply-generic 'imag-part z))
176 665c255d 2023-08-04 jrmu (define (magnitude z) (apply-generic 'magnitude z))
177 665c255d 2023-08-04 jrmu (define (angle z) (apply-generic 'angle z))
179 665c255d 2023-08-04 jrmu ;; rectangular and polar representations...
181 665c255d 2023-08-04 jrmu (define (install-complex-rectangular)
182 665c255d 2023-08-04 jrmu (define (make-from-real-imag-rectangular x y)
183 665c255d 2023-08-04 jrmu (cons x y))
184 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-rectangular r a)
185 665c255d 2023-08-04 jrmu (cons (* r (cos a)) (* r (sin a))))
186 665c255d 2023-08-04 jrmu (define (real-part z) (car z))
187 665c255d 2023-08-04 jrmu (define (imag-part z) (cdr z))
188 665c255d 2023-08-04 jrmu (define (magnitude z)
189 665c255d 2023-08-04 jrmu (sqrt (+ (square (real-part z))
190 665c255d 2023-08-04 jrmu (square (imag-part z)))))
191 665c255d 2023-08-04 jrmu (define (angle z) (atan (imag-part z) (real-part z)))
192 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rectangular x))
193 665c255d 2023-08-04 jrmu (put 'real-part '(rectangular) real-part)
194 665c255d 2023-08-04 jrmu (put 'imag-part '(rectangular) imag-part)
195 665c255d 2023-08-04 jrmu (put 'magnitude '(rectangular) magnitude)
196 665c255d 2023-08-04 jrmu (put 'angle '(rectangular) angle)
197 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'rectangular
198 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
199 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'rectangular
200 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
202 665c255d 2023-08-04 jrmu (define (install-complex-polar)
203 665c255d 2023-08-04 jrmu (define (make-from-real-imag-polar x y)
204 665c255d 2023-08-04 jrmu (cons (sqrt (+ (square x) (square y)))
205 665c255d 2023-08-04 jrmu (atan y x)))
206 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-polar r a)
207 665c255d 2023-08-04 jrmu (cons r a))
208 665c255d 2023-08-04 jrmu (define (real-part z) (* (magnitude z) (cos (angle z))))
209 665c255d 2023-08-04 jrmu (define (imag-part z) (* (magnitude z) (sin (angle z))))
210 665c255d 2023-08-04 jrmu (define (magnitude z) (car z))
211 665c255d 2023-08-04 jrmu (define (angle z) (cdr z))
212 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'polar x))
213 665c255d 2023-08-04 jrmu (put 'real-part '(polar) real-part)
214 665c255d 2023-08-04 jrmu (put 'imag-part '(polar) imag-part)
215 665c255d 2023-08-04 jrmu (put 'magnitude '(polar) magnitude)
216 665c255d 2023-08-04 jrmu (put 'angle '(polar) angle)
217 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'polar
218 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-polar x y))))
219 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'polar
220 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-polar r a))))
222 665c255d 2023-08-04 jrmu (install-complex-rectangular)
223 665c255d 2023-08-04 jrmu (install-complex-polar)
224 665c255d 2023-08-04 jrmu ;; end rectangular and polar representations
226 665c255d 2023-08-04 jrmu (define (add-complex z1 z2)
227 665c255d 2023-08-04 jrmu (make-from-real-imag (+ (real-part z1) (real-part z2))
228 665c255d 2023-08-04 jrmu (+ (imag-part z1) (imag-part z2))))
229 665c255d 2023-08-04 jrmu (define (sub-complex z1 z2)
230 665c255d 2023-08-04 jrmu (make-from-real-imag (- (real-part z1) (real-part z2))
231 665c255d 2023-08-04 jrmu (- (imag-part z1) (imag-part z2))))
232 665c255d 2023-08-04 jrmu (define (mul-complex z1 z2)
233 665c255d 2023-08-04 jrmu (make-from-mag-ang (* (magnitude z1) (magnitude z2))
234 665c255d 2023-08-04 jrmu (+ (angle z1) (angle z2))))
235 665c255d 2023-08-04 jrmu (define (div-complex z1 z2)
236 665c255d 2023-08-04 jrmu (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
237 665c255d 2023-08-04 jrmu (- (angle z1) (angle z2))))
238 665c255d 2023-08-04 jrmu (define (equ-complex? z1 z2)
239 665c255d 2023-08-04 jrmu (or (and (= (real-part z1) (real-part z2))
240 665c255d 2023-08-04 jrmu (= (imag-part z1) (imag-part z2))) ;; in case of rounding error
241 665c255d 2023-08-04 jrmu (and (= (magnitude z1) (magnitude z2))
242 665c255d 2023-08-04 jrmu (= (angle z1) (angle z2)))))
243 665c255d 2023-08-04 jrmu (define (=zero-complex? z)
244 665c255d 2023-08-04 jrmu (and (= (real-part z) 0)
245 665c255d 2023-08-04 jrmu (= (imag-part z) 0)))
247 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'complex x))
248 665c255d 2023-08-04 jrmu (put 'add '(complex complex)
249 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (add-complex z1 z2))))
250 665c255d 2023-08-04 jrmu (put 'sub '(complex complex)
251 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (sub-complex z1 z2))))
252 665c255d 2023-08-04 jrmu (put 'mul '(complex complex)
253 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (mul-complex z1 z2))))
254 665c255d 2023-08-04 jrmu (put 'div '(complex complex)
255 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (div-complex z1 z2))))
256 665c255d 2023-08-04 jrmu (put 'equ? '(complex complex) equ-complex?)
257 665c255d 2023-08-04 jrmu (put '=zero? '(complex) =zero-complex?)
258 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'complex
259 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag x y))))
260 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'complex
261 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang r a))))
262 665c255d 2023-08-04 jrmu (put 'project '(complex)
263 665c255d 2023-08-04 jrmu (lambda (z) (make-real (real-part z))))
266 665c255d 2023-08-04 jrmu (define (make-integer n)
267 665c255d 2023-08-04 jrmu ((get 'make 'integer) n))
268 665c255d 2023-08-04 jrmu (define (make-rational n d)
269 665c255d 2023-08-04 jrmu ((get 'make 'rational) n d))
270 665c255d 2023-08-04 jrmu (define (make-real n)
271 665c255d 2023-08-04 jrmu ((get 'make 'real) n))
272 665c255d 2023-08-04 jrmu (define (make-complex-from-real-imag x y)
273 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'complex) x y))
274 665c255d 2023-08-04 jrmu (define (make-complex-from-mag-ang r a)
275 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'complex) r a))
277 665c255d 2023-08-04 jrmu ;; install number packages
279 665c255d 2023-08-04 jrmu (install-integer-package)
280 665c255d 2023-08-04 jrmu (install-rational-package)
281 665c255d 2023-08-04 jrmu (install-real-package)
282 665c255d 2023-08-04 jrmu (install-complex-package)
284 665c255d 2023-08-04 jrmu (define (test-case actual expected)
286 665c255d 2023-08-04 jrmu (display "Actual: ")
287 665c255d 2023-08-04 jrmu (display actual)
289 665c255d 2023-08-04 jrmu (display "Expected: ")
290 665c255d 2023-08-04 jrmu (display expected)
293 665c255d 2023-08-04 jrmu ;; Exercise 2.85. This section mentioned a method for ``simplifying'' a data object by lowering it in the tower of types as far as possible.
295 665c255d 2023-08-04 jrmu ;; Design a procedure drop that accomplishes this for the tower described in exercise 2.83. The key is to decide, in some general way, whether an object can be lowered. For example, the complex number 1.5 + 0i can be lowered as far as real, the complex number 1 + 0i can be lowered as far as integer, and the complex number 2 + 3i cannot be lowered at all. Here is a plan for determining whether an object can be lowered:
297 665c255d 2023-08-04 jrmu ;; Begin by defining a generic operation project that ``pushes'' an object down in the tower. For example, projecting a complex number would involve throwing away the imaginary part. Then a number can be dropped if, when we project it and raise the result back to the type we started with, we end up with something equal to what we started with. Show how to implement this idea in detail, by writing a drop procedure that drops an object as far as possible. You will need to design the various projection operations and install project as a generic operation in the system. You will also need to make use of a generic equality predicate, such as described in exercise 2.79. Finally, use drop to rewrite apply-generic from exercise 2.84 so that it ``simplifies'' its answers.
299 665c255d 2023-08-04 jrmu (define (drop x)
300 665c255d 2023-08-04 jrmu (let ((projected-x (project x)))
301 665c255d 2023-08-04 jrmu (if (and projected-x
302 665c255d 2023-08-04 jrmu (equ? x (raise projected-x)))
303 665c255d 2023-08-04 jrmu (drop projected-x)
306 665c255d 2023-08-04 jrmu (test-case (drop (make-complex-from-mag-ang 5 0))
308 665c255d 2023-08-04 jrmu (test-case (drop (make-rational 3 5))
309 665c255d 2023-08-04 jrmu '(rational 3 . 5))
310 665c255d 2023-08-04 jrmu (test-case (drop (make-complex-from-real-imag 5/3 0))
311 665c255d 2023-08-04 jrmu '(rational 5 . 3))
312 665c255d 2023-08-04 jrmu (test-case (drop (make-complex-from-mag-ang (sqrt 5) 0))
313 665c255d 2023-08-04 jrmu 2.23606797749979)
315 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
316 665c255d 2023-08-04 jrmu ;; return arg1 raised to same type as arg2, #f if not possible
317 665c255d 2023-08-04 jrmu (define (raise-to-second-type arg1 arg2)
318 665c255d 2023-08-04 jrmu (if (eq? (type-tag arg1) (type-tag arg2))
320 665c255d 2023-08-04 jrmu (let ((raise-proc (get 'raise (list (type-tag arg1)))))
321 665c255d 2023-08-04 jrmu (if raise-proc
322 665c255d 2023-08-04 jrmu (raise-to-second-type (raise-proc (contents arg1)) arg2)
324 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
325 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
327 665c255d 2023-08-04 jrmu (drop (apply proc (map contents args)))
328 665c255d 2023-08-04 jrmu (if (= (length args) 2)
329 665c255d 2023-08-04 jrmu (let ((a1 (car args))
330 665c255d 2023-08-04 jrmu (a2 (cadr args)))
331 665c255d 2023-08-04 jrmu (if (eq? (type-tag a1) (type-tag a2))
332 665c255d 2023-08-04 jrmu (list "No method for these (raised) types" (list op type-tags))
333 665c255d 2023-08-04 jrmu (let ((raised1 (raise-to-second-type a1 a2))
334 665c255d 2023-08-04 jrmu (raised2 (raise-to-second-type a2 a1)))
335 665c255d 2023-08-04 jrmu (cond (raised1 (apply-generic op raised1 a2))
336 665c255d 2023-08-04 jrmu (raised2 (apply-generic op a1 raised2))
337 665c255d 2023-08-04 jrmu (else (list "No common supertype" (list op type-tags)))))))))))
341 665c255d 2023-08-04 jrmu (test-case (add (make-integer 4) '(nonsense-type . 3))
342 665c255d 2023-08-04 jrmu '("No common supertype" (add (integer nonsense-type))))
343 665c255d 2023-08-04 jrmu (test-case (apply-generic 'dummy (make-integer 3) (make-real 4.))
344 665c255d 2023-08-04 jrmu '("No method for these (raised) types" (dummy (real real))))
345 665c255d 2023-08-04 jrmu (test-case (apply-generic 'dummy (make-real 4.) (make-integer 3))
346 665c255d 2023-08-04 jrmu '("No method for these (raised) types" (dummy (real real))))
349 665c255d 2023-08-04 jrmu (test-case (add (make-integer 5) (make-rational 3 1))
350 665c255d 2023-08-04 jrmu (make-integer 8))
351 665c255d 2023-08-04 jrmu (test-case (div (make-integer 2) (make-real 5))
352 665c255d 2023-08-04 jrmu (make-rational 2 5))
353 665c255d 2023-08-04 jrmu (test-case (div (make-real 5) (make-integer 2))
354 665c255d 2023-08-04 jrmu (make-rationa 1 2))
355 665c255d 2023-08-04 jrmu (test-case (mul (div (make-complex-from-mag-ang 3 2)
356 665c255d 2023-08-04 jrmu (make-integer 3))
357 665c255d 2023-08-04 jrmu (add (make-real 2.4)
358 665c255d 2023-08-04 jrmu (make-rational 4 3)))
359 665c255d 2023-08-04 jrmu '(complex polar 3.733333333334 . 2.))
