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

Last change on this file since 34204 was 34204, checked in by kon, 6 months ago

fix lib rqr

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