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

Last change on this file since 35790 was 35790, checked in by Kon Lovett, 2 years ago

canonical

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