source: project/release/5/coops-utils/trunk/coops-introspection.scm @ 37388

Last change on this file since 37388 was 37388, checked in by Kon Lovett, 21 months ago

rm dup issue, update test

File size: 6.9 KB
Line 
1;;;; coops-introspection.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Jul '17
4;;;; Kon Lovett, Aug '10
5
6;; Issues
7;;
8;; - all slot options are "lost" after definition.
9;;
10;; - generic-procedure introspection is dicey since the generic
11;; has no "entity" representation & methods are not 1st-class.
12;;
13;; - should use more "schemey" names for operations?
14
15(module coops-introspection
16
17(;export
18  ;
19  instance-of?
20  class? check-class error-class
21  instance? check-instance error-instance
22  generic? check-generic error-generic
23  method? check-method error-method
24  primitive-instance?
25  ;
26  class-precedence-list class-direct-supers
27  class-slots class-direct-slots
28  ;
29  generic-anonymous?
30  generic-name
31  generic-specialized-arguments
32  generic-primary-methods
33  generic-before-methods
34  generic-after-methods
35  generic-around-methods
36  ;
37  method-specializers
38  method-procedure )
39
40(import scheme
41  (chicken base)
42  (chicken fixnum)
43  (chicken type)
44  (only (srfi 1) every lset-difference lset-union)
45  (only type-checks define-check+error-type)
46  coops)
47
48;;;
49
50(define-type coops-class *)
51(define-type coops-instance *)
52(define-type coops-generic *)
53(define-type coops-method *)
54
55;;; Helpers
56
57(: union-class-property-values (procedure (list-of coops-class) --> list))
58;
59(define (union-class-property-values getter classes)
60  (foldr
61    (lambda (class ls) (lset-union eq? ls (getter class)))
62    '()
63    classes) )
64
65(: *class-slots (coops-class --> list))
66;
67(define (*class-slots class)
68  (slot-value class 'slots) )
69
70(: *class-supers (coops-class --> list))
71;
72(define (*class-supers class)
73  (slot-value class 'class-precedence-list) )
74
75(: union-class-slots ((list-of coops-class) --> list))
76;
77(define (union-class-slots classes)
78  (union-class-property-values *class-slots classes) )
79
80(: union-class-supers ((list-of coops-class) --> list))
81;
82(define (union-class-supers classes)
83  (union-class-property-values *class-supers classes) )
84
85(: class-supers-slots (coops-class --> list))
86;
87(define (class-supers-slots class)
88  (union-class-slots (*class-supers class)) )
89
90(: class-supers-supers (coops-class --> list))
91;
92(define (class-supers-supers class)
93  (union-class-supers (*class-supers class)) )
94
95(: strict-subclass? (coops-class coops-class --> boolean))
96;
97;c1 < c2
98(define (strict-subclass? c1 c2)
99  (subclass? c1 c2) )
100
101(: loose-subclass? (coops-class coops-class --> boolean))
102;
103;c1 <= c2
104(define (loose-subclass? c1 c2)
105  (or
106    (eq? c1 c2)
107    (strict-subclass? c1 c2)) )
108
109(: *method-specializers (pair --> *))
110;
111(define *method-specializers car)
112
113(: *method-procedure (pair --> *))
114;
115(define *method-procedure cdr)
116
117(: error-generic-form (symbol * fixnum -> void))
118;
119(define (error-generic-form loc obj idx)
120  (error loc "generic closure form violation" obj idx) )
121
122(: check-generic-form (symbol * fixnum procedure --> *))
123;
124(define (check-generic-form loc obj0 idx type-pred?)
125  (let ((obj (##sys#slot (check-generic loc obj0) idx)))
126    (unless (type-pred? obj)
127      (error-generic-form loc obj0 idx) )
128    obj ) )
129
130(: check-generic-methods (symbol * fixnum --> *))
131;
132(define (check-generic-methods loc obj idx)
133  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )
134
135(: top-instance-of? (* coops-class --> *))
136;
137(define (top-instance-of? x class)
138  (let ((class-x (class-of x)))
139    (or
140      (eq? #t class-x) ;primitive
141      (loose-subclass? class class-x) ) ) )
142
143;; call-by-ref
144
145(: generic-name? (* --> *))
146;
147(define (generic-name? obj)
148  (or
149    (not obj)
150    (symbol? obj)) )
151
152(: vector-boxed-list? (* --> *))
153;
154(define (vector-boxed-list? obj)
155  (and
156    (vector? obj)
157    (fx= 1 (vector-length obj))
158    (list? (vector-ref obj 0))) )
159
160;;; Predicates
161
162(: instance-of? (* coops-class --> boolean))
163;
164(define (instance-of? x class)
165  (loose-subclass? (class-of x) class) )
166
167(: class? (* -> boolean : coops-class))
168;
169(define (class? x)
170  (instance-of? x <standard-class>) )
171
172(: instance? (* -> boolean : coops-instance))
173;
174(define (instance? x)
175  (not (top-instance-of? x <standard-class>)) )
176
177(: primitive-instance? (* -> boolean : coops-instance))
178;
179(define (primitive-instance? x)
180  (top-instance-of? x <primitive-object>) )
181
182(: method? (* -> boolean : coops-method))
183;
184(define (method? obj)
185  (and
186    (pair? obj)
187    (procedure? (*method-procedure obj))
188    (and-let* (
189      (specializers (*method-specializers obj))
190      ((list? specializers)) )
191      (every class? specializers) ) ) )
192
193;;; Errors & Checks
194
195(define generic? generic-procedure?)
196
197(define-check+error-type class class? "coops-class")
198(define-check+error-type instance instance? "coops-instance")
199(define-check+error-type generic generic? "coops-generic")
200(define-check+error-type method method? "coops-method")
201
202;;; Introspection
203
204;; Class Properties
205
206(: class-precedence-list (coops-class --> list))
207;
208(define (class-precedence-list class)
209  (*class-supers (check-class 'class-precedence-list class)) )
210
211(: class-slots (coops-class --> list))
212;
213(define (class-slots class)
214  (*class-slots (check-class 'class-slots class)) )
215
216;; Class Direct Properties
217
218;those supers declared in the direct class & not inherited
219(: class-direct-supers (coops-class --> list))
220;
221(define (class-direct-supers class)
222  (check-class 'class-direct-supers class)
223  (lset-difference eq? (*class-supers class) (class-supers-supers class)))
224
225;those slots declared in the direct class & not inherited
226(: class-direct-slots (coops-class --> list))
227;
228(define (class-direct-slots class)
229  (check-class 'class-direct-slots class)
230  (lset-difference eq? (*class-slots class) (class-supers-slots class)) )
231
232;; Generic Properties
233
234(: generic-anonymous? (* -> boolean : coops-generic))
235;
236(define (generic-anonymous? generic)
237  (and
238    (generic? generic)
239    (not (##sys#slot generic 1)) ) )
240
241(: generic-name (coops-generic --> symbol))
242;
243(define (generic-name generic)
244  (check-generic-form 'generic-name generic 1 generic-name?) )
245
246(: generic-specialized-arguments (coops-generic --> list))
247;
248(define (generic-specialized-arguments generic)
249  (check-generic-form 'generic-specialized-args generic 7 pair?) )
250
251(: generic-primary-methods (coops-generic --> list))
252;
253(define (generic-primary-methods generic)
254  (check-generic-methods 'generic-primary-methods generic 2) )
255
256(: generic-before-methods (coops-generic --> list))
257;
258(define (generic-before-methods generic)
259  (check-generic-methods 'generic-before-methods generic 3) )
260
261(: generic-after-methods (coops-generic --> list))
262;
263(define (generic-after-methods generic)
264  (check-generic-methods 'generic-after-methods generic 4) )
265
266(: generic-around-methods (coops-generic --> list))
267;
268(define (generic-around-methods generic)
269  (check-generic-methods 'generic-around-methods generic 5) )
270
271;; Method Properties
272
273(: method-specializers (coops-method --> list))
274;
275(define (method-specializers method)
276  (*method-specializers (check-method 'method-specializers method)) )
277
278(: method-procedure (coops-method --> list))
279;
280(define (method-procedure method)
281  (*method-procedure (check-method 'method-procedure method)) )
282
283) ;coops-introspection
Note: See TracBrowser for help on using the repository browser.