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

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

Rmvd use of sys ns. Simplification.

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