1 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
 2 665c255d 2023-08-04 jrmu   (define (can-coerce-into? types target-type)
 3 665c255d 2023-08-04 jrmu     (andmap (lambda (type)
 4 665c255d 2023-08-04 jrmu 	      (or (equal? type target-type)
 5 665c255d 2023-08-04 jrmu 		  (get-coercion type target-type)))
 6 665c255d 2023-08-04 jrmu 	    types))
 7 665c255d 2023-08-04 jrmu   (define (find-coercion-target types)
 8 665c255d 2023-08-04 jrmu     (ormap
 9 665c255d 2023-08-04 jrmu      (lambda (target-type)
10 665c255d 2023-08-04 jrmu        (if (can-coerce-into? types target-type)
11 665c255d 2023-08-04 jrmu 	   target-type
12 665c255d 2023-08-04 jrmu 	   #f))
13 665c255d 2023-08-04 jrmu      types))
14 665c255d 2023-08-04 jrmu   (define (coerce-all args target-type)
15 665c255d 2023-08-04 jrmu     (map (lambda (arg)
16 665c255d 2023-08-04 jrmu 	   (let ((arg-type (type-tag arg)))
17 665c255d 2023-08-04 jrmu 	     (if (equal? arg-type target-type)
18 665c255d 2023-08-04 jrmu 		 arg
19 665c255d 2023-08-04 jrmu 		 ((get-coercion arg-type target-type) arg))))
20 665c255d 2023-08-04 jrmu 	 args))
21 665c255d 2023-08-04 jrmu   (define (no-method type-tags)
22 665c255d 2023-08-04 jrmu     (error "No method for these types"
23 665c255d 2023-08-04 jrmu 	   (list op type-tags)))
24 665c255d 2023-08-04 jrmu   (let ((type-tags (map type-tag args)))
25 665c255d 2023-08-04 jrmu     (let ((proc (get op type-tags)))
26 665c255d 2023-08-04 jrmu       (if proc
27 665c255d 2023-08-04 jrmu 	  (apply proc (map contents args))
28 665c255d 2023-08-04 jrmu 	  (let ((target-type (find-coercion-target type-tags)))
29 665c255d 2023-08-04 jrmu 	    (if target-type
30 665c255d 2023-08-04 jrmu 		(apply
31 665c255d 2023-08-04 jrmu 		 apply-generic
32 665c255d 2023-08-04 jrmu 		 (append (list op)
33 665c255d 2023-08-04 jrmu 			 (coerce-all args target-type)))
34 665c255d 2023-08-04 jrmu 		(no-method type-tags)))))))