source: project/release/4/coops-utils/trunk/coops-introspection.scm @ 34193

Last change on this file since 34193 was 34193, checked in by kon, 4 months ago

fix per sandra snan to make/copy

File size: 5.8 KB
Line 
1;;;; coops-introspection.scm
2;;;; Kon Lovett, Aug '10
3
4;; Issues
5;;
6;; - all slot options are "lost" after definition.
7;;
8;; - generic-procedure introspection is dicey since the generic
9;; has no "entity" representation & methods are not 1st-class.
10
11(module coops-introspection
12
13(;export
14  ;
15  class-cpl class-supers  ;= class-precedence-list
16  primitive?              ;= primitive-instance?
17  generic-methods         ;= generic-primary-methods
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(import
42  chicken
43  (only srfi-1 every fold-right lset-difference lset-union))
44
45(import
46  (only type-checks define-check+error-type))
47(require-library type-checks)
48
49(require-extension coops)
50
51;;; Helpers
52
53(define-inline (*class-slots class)
54  (slot-value class 'slots) )
55
56(define-inline (*class-supers class)
57  (slot-value class 'class-precedence-list) )
58
59(define-inline (union-class-slots classes)
60  (fold-right
61    (lambda (class ls)
62      (lset-union eq? ls (*class-slots class)) )
63    '()
64    classes) )
65
66(define-inline (union-class-supers classes)
67  (fold-right
68    (lambda (class ls)
69      (lset-union eq? ls (*class-supers class)) )
70    '()
71    classes) )
72
73(define-inline (class-supers-slots class)
74  (union-class-slots (*class-supers class)) )
75
76(define-inline (class-supers-supers class)
77  (union-class-supers (*class-supers class)) )
78
79; c1 < c2
80(define-inline (strict-subclass? c1 c2)
81  (subclass? c1 c2) )
82
83; c1 <= c2
84(define-inline (loose-subclass? c1 c2)
85  (or
86    (eq? c1 c2)
87    (strict-subclass? c1 c2)) )
88
89(define-inline (*method-specializers method)
90  (car method) )
91
92(define-inline (*method-procedure method)
93  (cdr method) )
94
95(define-inline (error-generic-form loc obj idx)
96  (error loc "generic closure form violation" obj idx) )
97
98(define-inline (check-generic-form loc obj0 idx type-pred?)
99  (let ((obj (##sys#slot (check-generic loc obj0) idx)))
100    (unless (type-pred? obj)
101      (error-generic-form loc obj0 idx) )
102    obj ) )
103
104(define-inline (check-generic-methods loc obj idx)
105  (vector-ref (check-generic-form loc obj idx vector-boxed-list?) 0) )
106
107(define-inline (top-instance-of? x class)
108  (let ((class-x (class-of x)))
109    (or
110      (eq? #t class-x) ; primitive
111      (loose-subclass? class class-x) ) ) )
112
113;; call-by-ref
114
115(define (generic-name? obj)
116  (or
117    (not obj)
118    (symbol? obj)) )
119
120(define (vector-boxed-list? obj)
121  (and
122    (vector? obj)
123    (= 1 (vector-length obj))
124    (list? (vector-ref obj 0))) )
125
126;;; Predicates
127
128(define (instance-of? x class)
129  (loose-subclass? (class-of x) class) )
130
131(define (class? x)
132  (instance-of? x <standard-class>) )
133
134(define (instance? x)
135  (not (top-instance-of? x <standard-class>)) )
136
137(define (primitive-instance? x)
138  (top-instance-of? x <primitive-object>) )
139
140(define (method? obj)
141  (and
142    (pair? obj)
143    (procedure? (*method-procedure obj))
144    (let ((specializers (*method-specializers obj)))
145      (and
146        (list? specializers)
147        (every class? specializers) ) ) ) )
148
149;;; Errors & Checks
150
151(define-check+error-type class class? "coops-class")
152(define-check+error-type instance instance? "coops-instance")
153(define-check+error-type generic generic-procedure? "coops-generic")
154(define-check+error-type method method? "coops-method")
155
156;;; Introspection
157
158;; Class Properties
159
160(define (class-precedence-list class)
161  (*class-supers (check-class 'class-precedence-list class)) )
162
163(define (class-slots class)
164  (*class-slots (check-class 'class-slots class)) )
165
166;; Class Direct Properties
167
168; those supers declared in the direct class & not inherited
169(define (class-direct-supers class)
170  (check-class 'class-direct-supers class)
171  (lset-difference eq? (*class-supers class) (class-supers-supers class)))
172
173; those slots declared in the direct class & not inherited
174(define (class-direct-slots class)
175  (check-class 'class-direct-slots class)
176  (lset-difference eq? (*class-slots class) (class-supers-slots class)) )
177
178;; Generic Properties
179
180(define (generic-anonymous? generic)
181  (and
182    (generic-procedure? generic)
183    (not (##sys#slot generic 1)) ) )
184
185(define (generic-name generic)
186  (check-generic-form 'generic-name generic 1 generic-name?) )
187
188(define (generic-specialized-arguments generic)
189  (check-generic-form 'generic-specialized-args generic 7 pair?) )
190
191(define (generic-primary-methods generic)
192  (check-generic-methods 'generic-primary-methods generic 2) )
193
194(define (generic-before-methods generic)
195  (check-generic-methods 'generic-before-methods generic 3) )
196
197(define (generic-after-methods generic)
198  (check-generic-methods 'generic-after-methods generic 4) )
199
200(define (generic-around-methods generic)
201  (check-generic-methods 'generic-around-methods generic 5) )
202
203;; Method Properties
204
205(define (method-specializers method)
206  (check-method 'method-specializers method)
207  (*method-specializers method) )
208
209(define (method-procedure method)
210  (check-method 'method-procedure method)
211  (*method-procedure method) )
212
213;;; Synonyms
214
215(define class-cpl class-precedence-list)
216(define class-supers class-precedence-list)
217
218(define primitive? primitive-instance?)
219
220(define generic? generic-procedure?)
221
222(define generic-methods generic-primary-methods)
223
224;;
225
226#; ;Debugging Only
227(define (print-closure p)
228  (##sys#check-closure p 'print-closure)
229  (print "0\t: #x" (number->string (##sys#peek-unsigned-integer p 0) 16))
230  (let ((size (##sys#size p)))
231    (do ((i 1 (add1 i)))
232        ((= i size))
233      (print i "\t: " (##sys#slot p i)) ) ) )
234
235) ;coops-introspection
Note: See TracBrowser for help on using the repository browser.