source: project/release/4/srfi-102/trunk/procedure-introspection.scm @ 16110

Last change on this file since 16110 was 16110, checked in by Kon Lovett, 10 years ago

Fixed arity cache

File size: 9.4 KB
Line 
1;;;; srfi-102.scm  -*- Hen -*-
2
3(module procedure-introspection
4
5  (;export
6    ;;
7    procedure-lambda-info
8    procedure-name
9    procedure-arity
10    procedure-documentation-string
11    procedure-source-file
12    procedure-source-position
13    procedure-expression
14    procedure-environment
15    procedure-signature
16    procedure-metadata
17    ;;
18    procedure-arity-available?
19    procedure-fixed-arity?
20    procedure-minimum-arity
21    arity-at-least?
22    arity-at-least-value
23    procedure-arity-includes?)
24
25  (import scheme
26          chicken
27          (only data-structures identity)
28          (only posix set-file-position!)
29          (only srfi-1 any every))
30
31  (require-library srfi-1 data-structures posix)
32
33;;;
34
35;;
36
37(define (->boolean obj) (and obj #t))
38
39;; count of top-level pairs
40;;
41;; > 0 : proper-list length
42;; < 0 : circular-list length
43;; #.0 : dotted-list length
44
45(define (length.+ ls)
46  (if (null? ls) 0
47      (let loop ((ls (cdr ls)) (seen ls) (len 1))
48        (cond ((null? ls)       len )
49              ((not (pair? ls)) (exact->inexact len) )
50              ((eq? ls seen)    (- len) )
51              (else
52                (loop (cdr ls) (cdr seen) (fx+ len 1)) ) ) ) ) )
53
54;; Lambda Info Coding
55
56(define (decode-lambda-info lambdainfo)
57  (read (open-input-string (##sys#lambda-info->string lambdainfo))) )
58
59(define (encode-lambda-info info)
60  (##sys#make-lambda-info
61    (let ((o (open-output-string)))
62      (write info o)
63      (get-output-string o))) )
64
65;; Tagged Lambda Decoration
66
67(define (update-lambda-decoration proc pred decr)
68  (define (setter proc i) (##sys#setslot proc i (decr (##sys#slot proc i))) proc)
69  (##sys#decorate-lambda proc pred setter) )
70
71(define ((tagged-lambda-decoration-predicate tag) obj)
72  (and (pair? obj)
73       (eq? tag (car obj))) )
74
75(define ((tagged-lambda-decoration-setter tag pred) proc obj)
76  (update-lambda-decoration proc pred (lambda (old) (cons tag obj))) )
77
78(define ((lambda-decoration-getter pred) proc) (##sys#lambda-decoration proc pred))
79
80;; Arity from lambda-info
81
82(define (lambda-info-arity-object lambdainfo)
83  (define (lambda-info-arity-object info)
84    ; info should never be a circular list
85    (if (pair? info) (length.+ (cdr info))
86         ; nothing but a name - assume 0
87         0 ) )
88  (and lambdainfo
89       (lambda-info-arity-object (decode-lambda-info lambdainfo))) )
90
91(define (lambda-info-arity proc)
92  (lambda-info-arity-object (##sys#lambda-info proc)) )
93
94(define lambda-infos)
95(define lambda-infos-set!)
96(let ((+lambda-infos-tag+ '#(lambda-infos)))
97  (define lambda-infos? (tagged-lambda-decoration-predicate +lambda-infos-tag+))
98  (set! lambda-infos-set! (tagged-lambda-decoration-setter +lambda-infos-tag+ lambda-infos?))
99  (set! lambda-infos (lambda-decoration-getter lambda-infos?)) )
100
101(define (make-lambda-infos ls) (map encode-lambda-info ls))
102
103(define (lambda-infos-list proc)
104  (and-let* ((info (lambda-infos proc)))
105    (cdr info) ) )
106
107(define (lambda-infos-arities proc)
108  (and-let* ((infos (lambda-infos-list proc)))
109    (map lambda-info-arity-object infos) ) )
110
111;; Arity Cache
112
113(define lambda-arity)
114(define lambda-arity-set!)
115(let ((+lambda-arity-tag+ '#(lambda-arity)))
116  (define lambda-arity? (tagged-lambda-decoration-predicate +lambda-arity-tag+))
117  (set! lambda-arity-set! (tagged-lambda-decoration-setter +lambda-arity-tag+ lambda-arity?))
118  (set! lambda-arity (lambda-decoration-getter lambda-arity?)) )
119
120(define (##sys#procedure-arity proc)
121  (let ((arity (lambda-arity proc)))
122    (or (and arity (cdr arity))
123        (let ((arities (lambda-infos-arities proc)))
124          (if arities
125              (begin
126                (lambda-arity-set! proc arities)
127                arities )
128              (and-let* ((arity (lambda-info-arity proc)))
129                (lambda-arity-set! proc arity)
130                arity ) ) ) ) ) )
131
132
133;; Docstring
134
135(define docstring-info)
136(define docstring-info-set!)
137(let ((+docstring-info-tag+ '#(docstring)))
138  (define docstring-info? (tagged-lambda-decoration-predicate +docstring-info-tag+))
139  (set! docstring-info-set! (tagged-lambda-decoration-setter +docstring-info-tag+ docstring-info?))
140  (set! docstring-info (lambda-decoration-getter docstring-info?)) )
141
142(define make-docstring-info identity)
143(define docstring-info-string cdr)
144
145;; Source Info
146
147(define source-info)
148(define source-info-set!)
149(let ((+source-info-tag+ '#(source-info)))
150  (define source-info? (tagged-lambda-decoration-predicate +source-info-tag+))
151  (set! source-info-set! (tagged-lambda-decoration-setter +source-info-tag+ source-info?))
152  (set! source-info (lambda-decoration-getter source-info?)) )
153
154(define make-source-info cons)
155(define source-info-file cadr)
156(define source-info-position cddr)
157
158;;
159
160(define (##sys#procedure-name proc)
161  (and-let* ((info (decode-lambda-info (##sys#lambda-info proc))))
162    (if (pair? info) (car info)
163        info ) ) )
164
165(define (##sys#procedure-docstring proc)
166  (and-let* ((info (docstring-info proc)))
167    (docstring-info-string info) ) )
168
169(define (##sys#procedure-source-file proc)
170  (and-let* ((info (source-info proc)))
171    (source-info-file info) ) )
172
173(define (##sys#procedure-source-position proc)
174  (and-let* ((info (source-info proc)))
175    (source-info-position info) ) )
176   
177;sort-of
178(define (##sys#procedure-expression proc)
179  (and-let* ((info (source-info proc)))
180    (let ((inp (open-input-file (source-info-file info) #:text)))
181      (set-file-position! inp (source-info-position info))
182      (let ((exp (read inp)))
183        (close-input-port inp) 
184        exp ) ) ) )
185
186(define (##sys#procedure-environment proc)
187  #f )
188
189(define (##sys#procedure-signature proc)
190  #f )
191
192(define (##sys#procedure-metadata proc key)
193  (let* ((pred (tagged-lambda-decoration-predicate key))
194         (getter (lambda-decoration-getter pred)) )
195    (and-let* ((pare (lambda-decoration-getter pred)))
196      (cdr pare) ) ) )
197
198(define (##sys#procedure-metadata-set! proc key value)
199  (let* ((pred (tagged-lambda-decoration-predicate key))
200         (setter (tagged-lambda-decoration-setter key pred)) )
201    (setter (cons key value)) ) )
202
203;;
204
205(define (##sys#arity-at-least? obj) (and (inexact? obj) (<= 0 obj)))
206
207(define-constant ARGUMENT-COUNT-LIMIT 100000)
208
209(define (##sys#check-arity k loc)
210  (##sys#check-range k 0 ARGUMENT-COUNT-LIMIT loc) )
211
212(define (##sys#check-arity-at-least obj loc)
213  (unless (##sys#arity-at-least? obj)
214    (##sys#signal-hook #:type-error loc "bad argument type - not an arity-at-least" obj)) )
215
216;;;
217
218(define (procedure-lambda-info proc)
219  (##sys#check-closure proc 'procedure-lambda-info)
220  (let ((infos (lambda-infos-list proc)))
221    (if infos (map decode-lambda-info infos)
222        (and-let* ((info (##sys#lambda-info proc)))
223          (decode-lambda-info info) ) ) ) )
224
225(define (procedure-name proc)
226  (##sys#check-closure proc 'procedure-name)
227  (##sys#procedure-name proc) )
228
229(define (procedure-arity-available? proc)
230  (->boolean (##sys#procedure-arity proc)) )
231
232(define (procedure-arity proc)
233  (##sys#check-closure proc 'procedure-arity)
234  (##sys#procedure-arity proc) )
235
236(define (procedure-fixed-arity? proc)
237  (and-let* ((arities (##sys#procedure-arity proc)))
238    (if (not (pair? arities)) (##sys#exact? arities)
239        (every ##sys#exact? arities) ) ) )
240
241(define (procedure-minimum-arity proc)
242  (and-let* ((arities (##sys#procedure-arity proc)))
243    (if (not (pair? arities)) (##sys#inexact->exact arities)
244        (apply min (map ##sys#inexact->exact arities)) ) ) )
245
246(define arity-at-least? ##sys#arity-at-least?)
247
248(define (arity-at-least-value k)
249  (##sys#check-arity-at-least 'arity-at-least-value k)
250  (##sys#inexact->exact k) )
251
252(define (procedure-arity-includes? proc k)
253  (define (at-least-k a) (if (##sys#exact? a) (= k a) (<= a k)))
254  (##sys#check-closure proc 'procedure-arity-includes?)
255  (##sys#check-exact k 'procedure-arity-includes?)
256  (##sys#check-arity k 'procedure-arity-includes?)
257  (let ((arities (##sys#procedure-arity proc)))
258    ; no arity information? - then so assume any arity
259    (or (not arities)
260        ; > one arity?
261        (if (pair? arities) (any at-least-k arities)
262            ; one arity
263            (at-least-k arities) ) ) ) )
264
265(define (procedure-documentation-string proc)
266  (##sys#check-closure proc 'procedure-documentation-string)
267  (##sys#procedure-docstring proc) )
268
269(define (procedure-source-file proc)
270  (##sys#check-closure proc 'procedure-source-file)
271  (##sys#procedure-source-file proc) )
272
273(define (procedure-source-position proc)
274  (##sys#check-closure proc 'procedure-source-position)
275  (##sys#procedure-source-position proc) )
276
277(define (procedure-expression proc)
278  (##sys#check-closure proc 'procedure-expression)
279  (##sys#procedure-expression proc) )
280
281; the closed-over bindings as a 1st-class 'environment'
282(define (procedure-environment proc)
283  (##sys#check-closure proc 'procedure-environment)
284  (##sys#procedure-environment proc) )
285
286; the signature as defined or inferred
287(define (procedure-signature proc)
288  (##sys#check-closure proc 'procedure-signature)
289  (##sys#procedure-signature proc) )
290
291(define (procedure-metadata proc key)
292  (##sys#check-closure proc 'procedure-metadata)
293  (##sys#check-symbol key 'procedure-metadata)
294  (case key
295    ((#:name)         (##sys#procedure-name proc))
296    ((#:arity)        (##sys#procedure-arity proc))
297    ((#:file)         (##sys#procedure-source-file proc))
298    ((#:position)     (##sys#procedure-source-position proc))
299    ((#:signature)    (##sys#procedure-signature proc))
300    ((#:environment)  (##sys#procedure-environment proc))
301    ((#:expression)   (##sys#procedure-expression proc))
302    (else             (##sys#procedure-metadata proc key)) ) )
303
304) ;procedure-introspection
Note: See TracBrowser for help on using the repository browser.