1; *************************************************************************
2; Copyright (c) 1992 Xerox Corporation.
3; All Rights Reserved.
4;
5; Use, reproduction, and preparation of derivative works are permitted.
6; Any copy of this software or of any derivative work must include the
7; above copyright notice of Xerox Corporation, this paragraph and the
8; one after it.  Any distribution of this software or derivative works
9; must comply with all applicable United States export control laws.
10;
11; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
12; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
13; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
14; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
15; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
16; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
17; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
18; OF THE POSSIBILITY OF SUCH DAMAGES.
19; *************************************************************************
20;
21; port to R6RS -- 2007 Christian Sloma
22;
23
24(library (clos bootstrap generic-functions)
25
26  (export make
27          initialize
28          allocate-instance
29          compute-getter-and-setter
30          compute-precedence-list
31          compute-slots
32          add-method
33          compute-apply-generic
34          compute-methods
35          compute-method-more-specific?
36          compute-apply-methods
37          print-object)
38
39  (import (only (rnrs) define quote list lambda car cdr begin let cond eq? else error)
40          (only (clos bootstrap standard-classes) bootstrap-make <method> <class> <entity-class> <object>
41                <generic>)
42          (only (clos private allocation) set-instance-printer!)
43          (only (clos introspection) class-of)
44          (only (clos std-protocols make) class-make)
45          (only (clos std-protocols allocate-instance) class-allocate-instance entity-class-allocate-instance)
46          (only (clos std-protocols initialize) class-initialize generic-initialize method-initialize)
47          (only (clos std-protocols class-initialization) class-compute-precedence-list class-compute-slots class-compute-getter-and-setter)
48          (only (clos std-protocols add-method) generic-add-method)
49          (only (clos std-protocols generic-invocation) generic-compute-methods generic-compute-apply-generic generic-compute-method-more-specific?
50                generic-compute-apply-methods register-generic-invocation-generics!)
51          (only (clos std-protocols print-object) object-print-object))
52
53  (define make
54    (bootstrap-make <generic>
55      'definition-name 'make))
56
57  (define initialize
58    (bootstrap-make <generic>
59      'definition-name 'initialize))
60
61  (define allocate-instance
62    (bootstrap-make <generic>
63      'definition-name 'allocate-instance))
64
65  (define compute-getter-and-setter
66    (bootstrap-make <generic>
67      'definition-name 'compute-getter-and-setter))
68
69  (define compute-precedence-list
70    (bootstrap-make <generic>
71      'definition-name 'compute-precedence-list))
72
73  (define compute-slots
74    (bootstrap-make <generic>
75      'definition-name 'compute-slots))
76
77  (define add-method
78    (bootstrap-make <generic>
79      'definition-name 'add-method))
80
81  (define compute-apply-generic
82    (bootstrap-make <generic>
83      'definition-name 'compute-apply-generic))
84
85  (define compute-methods
86    (bootstrap-make <generic>
87      'definition-name 'compute-methods))
88
89  (define compute-method-more-specific?
90    (bootstrap-make <generic>
91      'definition-name 'compute-method-more-specific?))
92
93  (define compute-apply-methods
94    (bootstrap-make <generic>
95      'definition-name 'compute-apply-methods))
96
97  (define print-object
98    (bootstrap-make <generic>
99      'definition-name 'print-object))
100
101  (define bootstrap-add-method
102    (begin
103
104      (register-generic-invocation-generics!
105       compute-apply-generic
106       compute-apply-methods
107       compute-methods
108       compute-method-more-specific?)
109
110      (lambda (entity method)
111        (let ((class (class-of entity)))
112          (cond
113            ((eq? class <generic>)
114             (generic-add-method entity method generic-compute-apply-generic))
115            (else
116             (error 'bootstrap-add-method
117                    "cannot add method to instance of class ~a" class)))))))
118
119  (bootstrap-add-method make
120    (bootstrap-make <method>
121      'specializers (list <class>)
122      'procedure    (lambda (%generic %next-methods class . init-args)
123                      (class-make class init-args
124                                  allocate-instance initialize))))
125
126  (bootstrap-add-method allocate-instance
127    (bootstrap-make <method>
128      'specializers (list <class>)
129      'procedure    (lambda (%generic %next-methods class)
130                      (class-allocate-instance class))))
131
132  (bootstrap-add-method allocate-instance
133    (bootstrap-make <method>
134      'specializers (list <entity-class>)
135      'procedure    (lambda (%generic %next-methods entity-class)
136                      (entity-class-allocate-instance entity-class))))
137
138  (bootstrap-add-method initialize
139    (bootstrap-make <method>
140      'specializers (list <object>)
141      'procedure    (lambda (%generic %next-methods object init-args) object)))
142
143  (bootstrap-add-method initialize
144    (bootstrap-make <method>
145      'specializers (list <class>)
146      'procedure    (lambda (%generic %next-methods class-inst init-args)
147                      ;; call-next-method, the hard way ...
148                      ((car %next-methods) %generic (cdr %next-methods) class-inst init-args)
149                      (class-initialize class-inst init-args
150                                        compute-precedence-list
151                                        compute-slots
152                                        compute-getter-and-setter))))
153
154  (bootstrap-add-method initialize
155    (bootstrap-make <method>
156      'specializers (list <generic>)
157      'procedure    (lambda (%generic %next-methods generic-inst init-args)
158                      ;; call-next-method, the hard way ...
159                      ((car %next-methods) %generic (cdr %next-methods) generic-inst init-args)
160                      (generic-initialize generic-inst init-args))))
161
162  (bootstrap-add-method initialize
163    (bootstrap-make <method>
164      'specializers (list <method>)
165      'procedure    (lambda (%generic %next-methods method-inst init-args)
166                      ;; call-next-method, the hard way ...
167                      ((car %next-methods) %generic (cdr %next-methods) method-inst init-args)
168                      (method-initialize method-inst init-args))))
169
170  (bootstrap-add-method compute-precedence-list
171    (bootstrap-make <method>
172      'specializers (list <class>)
173      'procedure    (lambda (%generic %next-methods class)
174                      (class-compute-precedence-list class))))
175
176  (bootstrap-add-method compute-slots
177    (bootstrap-make <method>
178      'specializers (list <class>)
179      'procedure    (lambda (%generic %next-methods class)
180                      (class-compute-slots class))))
181
182  (bootstrap-add-method compute-getter-and-setter
183    (bootstrap-make <method>
184      'specializers (list <class>)
185      'procedure    (lambda (%generic %next-methods class slot allocator)
186                      (class-compute-getter-and-setter class slot allocator))))
187
188  (bootstrap-add-method add-method
189    (bootstrap-make <method>
190      'specializers (list <generic>)
191      'procedure    (lambda (%generic %next-methods entity method)
192                      (generic-add-method entity method compute-apply-generic))))
193
194  (bootstrap-add-method compute-apply-generic
195    (bootstrap-make <method>
196      'specializers (list <generic>)
197      'procedure    (lambda (%generic %next-methods generic)
198                      (generic-compute-apply-generic generic))))
199
200  (bootstrap-add-method compute-methods
201    (bootstrap-make <method>
202      'specializers (list <generic>)
203      'procedure    (lambda (%generic %next-methods generic args)
204                      (generic-compute-methods generic args))))
205
206  (bootstrap-add-method compute-method-more-specific?
207    (bootstrap-make <method>
208      'specializers (list <generic>)
209      'procedure    (lambda (%generic %next-methods generic args)
210                      (generic-compute-method-more-specific? generic args))))
211
212  (bootstrap-add-method compute-apply-methods
213    (bootstrap-make <method>
214      'specializers (list <generic>)
215      'procedure    (lambda (%generic %next-methods generic methods)
216                      (generic-compute-apply-methods generic methods))))
217
218  (bootstrap-add-method print-object
219    (bootstrap-make <method>
220      'specializers (list <object>)
221      'procedure    (lambda (%generic %next-methods object port)
222                      (object-print-object object port))))
223
224  (set-instance-printer! print-object)
225
226  ) ;; library (clos bootstrap generic-functions)
227