1 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
 2 665c255d 2023-08-04 jrmu   (if (number? contents)
 3 665c255d 2023-08-04 jrmu       contents
 4 665c255d 2023-08-04 jrmu       (cons type-tag contents)))
 5 665c255d 2023-08-04 jrmu 
 6 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
 7 665c255d 2023-08-04 jrmu   (let ((type-tags (map type-tag args)))
 8 665c255d 2023-08-04 jrmu     (let ((proc (get op type-tags)))
 9 665c255d 2023-08-04 jrmu       (if proc
10 665c255d 2023-08-04 jrmu 	  (apply proc (map contents args))
11 665c255d 2023-08-04 jrmu 	  (error "No method for these types -- APPLY-GENERIC"
12 665c255d 2023-08-04 jrmu 		 (list op type-tags))))))
13 665c255d 2023-08-04 jrmu 
14 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
15 665c255d 2023-08-04 jrmu   (let ((type-tags (map type-tag args)))
16 665c255d 2023-08-04 jrmu     (let ((proc (get op type-tags)))
17 665c255d 2023-08-04 jrmu       (if proc
18 665c255d 2023-08-04 jrmu 	  (apply proc (map contents args))
19 665c255d 2023-08-04 jrmu 	  (if (= (length args) 2)
20 665c255d 2023-08-04 jrmu 	      (let ((type1 (car type-tags))
21 665c255d 2023-08-04 jrmu 		    (type2 (cadr type-tags))
22 665c255d 2023-08-04 jrmu 		    (a1 (car args))
23 665c255d 2023-08-04 jrmu 		    (a2 (cadr args)))
24 665c255d 2023-08-04 jrmu 		(let ((t1->t2 (get-coercion type1 type2))
25 665c255d 2023-08-04 jrmu 		      (t2->t1 (get-coercion type2 type1)))
26 665c255d 2023-08-04 jrmu 		  (cond (t1->t2
27 665c255d 2023-08-04 jrmu 			 (apply-generic op (t1->t2 a1) a2))
28 665c255d 2023-08-04 jrmu 			(t2->t1
29 665c255d 2023-08-04 jrmu 			 (apply-generic op a1 (t2->t1 a2)))
30 665c255d 2023-08-04 jrmu 			(else
31 665c255d 2023-08-04 jrmu 			 (error "No method for these types"
32 665c255d 2023-08-04 jrmu 				(list op type-tags))))))
33 665c255d 2023-08-04 jrmu 	      (error "No method for these types"
34 665c255d 2023-08-04 jrmu 		     (list op type-tags)))))))
35 665c255d 2023-08-04 jrmu