1 (define (attach-tag type-tag contents)
2   (cons type-tag contents))
3 (define (type-tag datum)
4   (if (pair? datum)
5       (car datum)
6       (error "invalid datum -- TYPE-TAG" datum)))
7 (define (contents datum)
8   (if (pair? datum)
9       (cdr datum)
10       (error "invalid datum -- TYPE-TAG" datum)))
11 (define (apply-generic op . args)
12   (let* ((type-tags (map type-tag args))
13 	 (proc (get op type-tags)))
14     (if proc
15 	(apply proc (map contents args))
16 	(error "procedure not found -- APPLY-GENERIC" (list op args)))))
17 
18 (define (add x y) (apply-generic 'add x y))
19 (define (sub x y) (apply-generic 'sub x y))
20 (define (mul x y) (apply-generic 'mul x y))
21 (define (div x y) (apply-generic 'div x y))
22 
23 (define (install-scheme-number-package)
24   (define (tag x)
25     (attach-tag 'scheme-number x))
26   (put 'add '(scheme-number scheme-number)
27        (lambda (x y) (tag (+ x y))))
28   (put 'sub '(scheme-number scheme-number)
29        (lambda (x y) (tag (- x y))))
30   (put 'mul '(scheme-number scheme-number)
31        (lambda (x y) (tag (* x y))))
32   (put 'div '(scheme-number scheme-number)
33        (lambda (x y) (tag (/ x y))))
34   (put 'make 'scheme-number
35        (lambda (x) (tag x)))
36   'done)
37 
38 (define (make-scheme-number n)
39   ((get 'make 'scheme-number) n))
40 
41 (define (install-rational-package)
42   (define (numer x) (car x))
43   (define (denom x) (cdr x))
44   (define (make-rat n d)
45     (let ((g (gcd n d)))
46       (cons (/ n g) (/ d g))))
47   (define (add-rat x y)
48     (make-rat (+ (* (numer x) (denom y))
49 		 (* (numer y) (denom x)))
50 	      (* (denom x) (denom y))))
51   (define (sub-rat x y)
52     (make-rat (- (* (numer x) (denom y))
53 		 (* (numer y) (denom x)))
54 	      (* (denom x) (denom y))))
55   (define (mul-rat x y)
56     (make-rat (* (numer x) (numer y))
57 	      (* (denom x) (denom y))))
58   (define (div-rat x y)
59     (make-rat (* (numer x) (denom y))
60 	      (* (denom x) (numer y))))
61   (define (tag x) (attach-tag 'rational x))
62   (put 'add '(rational rational) (lambda (x y) (tag (add-rat x y))))
63   (put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y))))
64   (put 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y))))
65   (put 'div '(rational rational) (lambda (x y) (tag (div-rat x y))))
66   (put 'make 'rational (lambda (n d) (tag (make-rat n d))))
67   'done)
68 
69 (define (make-rational n d)
70   ((get 'make 'rational) n d))
71 
72 (define (install-complex-package)
73   (define (make-from-real-imag x y)
74     ((get 'make-from-real-imag 'rectangular) x y))
75   (define (make-from-mag-ang r a)
76     ((get 'make-from-mag-ang 'polar) r a))
77   (define (add-complex z1 z2)
78     (make-from-real-imag (+ (real-part z1) (real-part z2))
79 			 (+ (imag-part z1) (imag-part z2))))
80   (define (sub-complez x1 x2)
81     (make-from-real-imag (- (real-part z1) (real-part z2))
82 			 (- (imag-part z1) (imag-part z2))))
83   (define (mul-complex z1 z2)
84     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
85 		       (+ (angle z1) (angle z2))))
86   (define (div-complex z1 z2)
87     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
88 		       (- (angle z1) (angle z2))))
89   (define (tag z) (attach-tag 'complex z))
90   (put 'add '(complex complex) 
91        (lambda (z1 z2) (tag (add-complex z1 z2))))
92   (put 'sub '(complex complex) 
93        (lambda (z1 z2) (tag (sub-complex z1 z2))))
94   (put 'mul '(complex complex) 
95        (lambda (z1 z2) (tag (mul-complex z1 z2))))
96   (put 'div '(complex complex) 
97        (lambda (z1 z2) (tag (div-complex z1 z2))))
98   (put 'make-from-real-imag 'complex 
99        (lambda (x y) (tag (make-from-real-imag x y))))
100   (put 'make-from-mag-ang 'complex 
101        (lambda (r a) (tag (make-from-mag-ang r a))))
102   'done)
103 
104 (define (make-from-real-imag x y)
105   ((get 'make-from-real-imag 'complex) x y))
106 (define (make-from-mag-ang r a)
107   ((get 'make-from-mag-ang 'complex) r a))