1 (define (find-highest-type l)
2   (define (filter-type t f)
3     (cond ((null? f) '())
4 	  ((eq? (car f) t) (filter-type t (cdr f)))
5 	  (else (cons (car f) (filter-type t (cdr f))))))
6   (define (find-highest highest remaining-tower remaining-list)
7     (cond ((null? remaining-list) highest)
8 	  ((null? remaining-tower)
9 	   (error "Cannot find highest type from non-tower types -- FIND-HIGHEST-TYPE"
10 		  remaining-list))
11 	  (else (find-highest (car remaining-tower)
12 			      (cdr remaining-tower)
13 			      (filter-type (car remaining-tower) remaining-list)))))
14   (find-highest #f tower-of-types l))
15 
16 (find-highest-type '(integer real rational real))
17 (find-highest-type '(rational rational rational))
18 (find-highest-type '(complex real rational integer))
19 (find-highest-type '())
20 (find-highest-type '(integer wibble real wobble complex))
21 
22 (define (raise-to type value)
23   (cond ((eq? type (type-tag value)) value)
24 	((memq type tower-of-types) (raise-to type (raise value)))
25 	(else (error "Cannot raise to non-tower type -- RAISE-TO"
26 		     (list type tower-of-types)))))
27 (raise-to 'real (make-integer 4))
28 (raise-to 'complex (make-rational 3 4))
29 (raise-to 'real (make-real 3.14159))
30 (raise-to 'wibble (make-integer 42))
31 
32 (define (raise-all-to type values)
33   (if (null? values)
34       '()
35       (cons (raise-to-type (car values)) (raise-all-to type (cdr values)))))
36 
37 (define (apply-generic op . args)
38   (let* ((type-tags (map type-tag args))
39 	 (proc (get op type-tags)))
40     (if proc
41 	(apply proc (map contents args))
42 	(if (> (length args) 1)
43 	    (let* ((highest-type (find-highest-type type-tags))
44 		   (mapped-args (raise-all-to highest-type args))
45 		   (mapped-types (map type-tag mapped-args))
46 		   (mapped-proc (get op mapped-types)))
47 	      (if mapped-proc
48 		  (apply mapped-proc (map contents mapped-args))
49 		  (error
50 		   "No method for these types -- APPLY-GENERIC"
51 		   (list op type-tags))))))))
52 (put 'addd '(integer integer integer)
53      (lambda (x y z) (tag (+ x y z))))
54 (define (addd x y z)
55   (make-rat (+ (* (numer x) (denom y) (denom z))
56 	       (* (denom x) (numer y) (denom z))
57 	       (* (denom x) (denom y) (numer z)))
58 	    (* (denom x) (denom y) (denom z))))
59 (put 'addd '(rational rational rational)
60      (lambda (x y z) (tag (addd x y z))))
61 (put 'add '(real real real)
62      (lambda (x y z) (tag (+ x y z))))
63 (addd (make-real 3.14159) (make-rational 3 4) (make-complex-from-real-imag 1 7))
64 
65 (define (raise x) (apply-generic 'raise x))
66 (put 'raise '(scheme-number)
67      (lambda (x)
68        (if (exact-integer? x)
69 	   (make-rational x 1)
70 	   (make-complex-from-real-imag x 0))))
71 (put 'raise '(rational)
72      (lambda (r)
73        (make-scheme-number (exact->inexact (/ (numer r) (denom r))))))
74 
75 (define (tower-level x)
76   (let ((typex (type-tag x)))
77     (cond ((eq? typex 'rational) 1)
78 	  ((eq? typex 'complex) 3)
79 	  (else
80 	   (let ((y (contents x)))
81 	     (if (exact-integer? y)
82 		 0
83 		 2))))))
84 (define (raise-to level x)
85   (if (= level (tower-level x))
86       x
87       (raise-to level (raise x))))
88 
89 (define (apply-generic op . args)
90   (let ((typetags (map type-tag args)))
91     (let ((proc (get op type-tags)))
92       (if proc
93 	  (apply proc (map contents args))
94 	  (if (= (length args) 2)
95 	      (let* ((a1 (car args))
96 		     (a2 (cadr args))
97 		     (level1 (tower-level a1))
98 		     (level2 (tower-level a2)))
99 		(cond ((< level1 level2)
100 		       (apply-generic op (raise-to level2 a1) a2))
101 		      ((< level2 level1)
102 		       (apply-generic op a1 (raise-to level1 a2)))
103 		      (else
104 		       (error "No method for these types"
105 			      (list op type-tags)))))
106 	      (error "No method for these types"
107 		     (lsit op type-tags)))))))
108 
109 (define (apply-generic-r op . args)
110   (define (no-method type-tags)
111     (error "No method for these types"
112 	   (list op type-tags)))
113   (define (raise-into s t)
114     (let ((s-type (type-tag s))
115 	  (t-type (type-tag t)))
116       (cond ((equal? s-type t-type) s)
117 	    ((get 'raise (list s-type))
118 	     (raise-into ((get 'raise (list s-type)) (contents s)) t))
119 	    (t #f))))
120   (let ((type-tags (map type-tag args)))
121     (let ((proc (get op type-tags)))
122       (if proc
123 	  (apply proc (map contents args))
124 	  (if (= (length args) 2)
125 	      (let ((o1 (car args))
126 		    (o2 (cadr args)))
127 		(cond
128 		 ((raise-into o1 o2)
129 		  (apply-generic-r op (raise-into o1 o2) o2))
130 		 ((raise-into o2 o1)
131 		  (apply-generic-r op o2 (raise-into o2 o1)))
132 		 (t (no-method type-tags))))
133 	      (no-method type-tags))))))