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

Last change on this file since 38762 was 38762, checked in by Kon Lovett, 3 months ago

introspection procedures are pure, method-specializers must verify result like method-procedure

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