Commit | Line | Data |
---|---|---|
07e56b27 AW |
1 | ;;; Guile VM program functions |
2 | ||
20d47c39 | 3 | ;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
07e56b27 | 4 | ;;; |
e1203ea0 LC |
5 | ;;; This library is free software; you can redistribute it and/or |
6 | ;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;; License as published by the Free Software Foundation; either | |
8 | ;;; version 3 of the License, or (at your option) any later version. | |
07e56b27 | 9 | ;;; |
e1203ea0 | 10 | ;;; This library is distributed in the hope that it will be useful, |
07e56b27 | 11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
e1203ea0 LC |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;; Lesser General Public License for more details. | |
07e56b27 | 14 | ;;; |
e1203ea0 LC |
15 | ;;; You should have received a copy of the GNU Lesser General Public |
16 | ;;; License along with this library; if not, write to the Free Software | |
17 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
07e56b27 AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (system vm program) | |
6c6a4439 AW |
22 | #:use-module (system base pmatch) |
23 | #:use-module (ice-9 optargs) | |
53e28ed9 AW |
24 | #:export (make-program |
25 | ||
476e3572 | 26 | make-binding binding:name binding:boxed? binding:index |
f580ec0f AW |
27 | binding:start binding:end |
28 | ||
53e28ed9 | 29 | source:addr source:line source:column source:file |
6c6a4439 | 30 | program-sources program-source |
53e28ed9 | 31 | program-properties program-property program-documentation |
6c6a4439 AW |
32 | program-name |
33 | ||
34 | program-bindings program-bindings-by-index program-bindings-for-ip | |
f916cbc4 AW |
35 | program-arities program-arity arity:start arity:end |
36 | ||
37 | arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys? | |
38 | ||
39 | program-arguments program-lambda-list | |
40 | ||
6c6a4439 | 41 | program-meta |
53e28ed9 | 42 | program-objcode program? program-objects |
57ab0671 | 43 | program-module program-base program-free-variables)) |
07e56b27 | 44 | |
60ae5ca2 | 45 | (load-extension "libguile" "scm_init_programs") |
07e56b27 | 46 | |
476e3572 AW |
47 | (define (make-binding name boxed? index start end) |
48 | (list name boxed? index start end)) | |
f580ec0f | 49 | (define (binding:name b) (list-ref b 0)) |
476e3572 | 50 | (define (binding:boxed? b) (list-ref b 1)) |
f580ec0f AW |
51 | (define (binding:index b) (list-ref b 2)) |
52 | (define (binding:start b) (list-ref b 3)) | |
53 | (define (binding:end b) (list-ref b 4)) | |
07e56b27 | 54 | |
d0168f3d AW |
55 | (define (source:addr source) |
56 | (car source)) | |
028e3d06 AW |
57 | (define (source:file source) |
58 | (cadr source)) | |
d0168f3d | 59 | (define (source:line source) |
028e3d06 | 60 | (caddr source)) |
d0168f3d | 61 | (define (source:column source) |
028e3d06 | 62 | (cdddr source)) |
d0168f3d | 63 | |
07e56b27 | 64 | (define (program-property prog prop) |
84012ef4 | 65 | (assq-ref (program-properties prog) prop)) |
07e56b27 AW |
66 | |
67 | (define (program-documentation prog) | |
17d1b4bf | 68 | (assq-ref (program-properties prog) 'documentation)) |
07e56b27 | 69 | |
6c6a4439 AW |
70 | (define (collapse-locals locs) |
71 | (let lp ((ret '()) (locs locs)) | |
72 | (if (null? locs) | |
73 | (map cdr (sort! ret | |
74 | (lambda (x y) (< (car x) (car y))))) | |
75 | (let ((b (car locs))) | |
76 | (cond | |
77 | ((assv-ref ret (binding:index b)) | |
78 | => (lambda (bindings) | |
79 | (append! bindings (list b)) | |
80 | (lp ret (cdr locs)))) | |
81 | (else | |
82 | (lp (acons (binding:index b) (list b) ret) | |
83 | (cdr locs)))))))) | |
84 | ||
85 | ;; returns list of list of bindings | |
86 | ;; (list-ref ret N) == bindings bound to the Nth local slot | |
87 | (define (program-bindings-by-index prog) | |
88 | (cond ((program-bindings prog) => collapse-locals) | |
89 | (else '()))) | |
90 | ||
91 | (define (program-bindings-for-ip prog ip) | |
92 | (let lp ((in (program-bindings-by-index prog)) (out '())) | |
93 | (if (null? in) | |
94 | (reverse out) | |
95 | (lp (cdr in) | |
96 | (let inner ((binds (car in))) | |
97 | (cond ((null? binds) out) | |
98 | ((<= (binding:start (car binds)) | |
99 | ip | |
100 | (binding:end (car binds))) | |
101 | (cons (car binds) out)) | |
102 | (else (inner (cdr binds))))))))) | |
103 | ||
df435c83 AW |
104 | (define (arity:start a) |
105 | (pmatch a ((,start ,end . _) start) (else (error "bad arity" a)))) | |
106 | (define (arity:end a) | |
107 | (pmatch a ((,start ,end . _) end) (else (error "bad arity" a)))) | |
108 | (define (arity:nreq a) | |
109 | (pmatch a ((_ _ ,nreq . _) nreq) (else 0))) | |
110 | (define (arity:nopt a) | |
111 | (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0))) | |
112 | (define (arity:rest? a) | |
113 | (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f))) | |
114 | (define (arity:kw a) | |
115 | (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '()))) | |
116 | (define (arity:allow-other-keys? a) | |
117 | (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f))) | |
118 | ||
6c6a4439 AW |
119 | (define (program-arity prog ip) |
120 | (let ((arities (program-arities prog))) | |
121 | (and arities | |
122 | (let lp ((arities arities)) | |
123 | (cond ((null? arities) #f) | |
df435c83 AW |
124 | ((and (< (arity:start (car arities)) ip) |
125 | (<= ip (arity:end (car arities)))) | |
126 | (car arities)) | |
6c6a4439 AW |
127 | (else (lp (cdr arities)))))))) |
128 | ||
129 | (define (arglist->arguments arglist) | |
130 | (pmatch arglist | |
131 | ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents) | |
132 | `((required . ,req) | |
133 | (optional . ,opt) | |
134 | (keyword . ,keyword) | |
135 | (allow-other-keys? . ,allow-other-keys?) | |
136 | (rest . ,rest) | |
137 | (extents . ,extents))) | |
138 | (else #f))) | |
139 | ||
6c6a4439 AW |
140 | (define (arity->arguments prog arity) |
141 | (define var-by-index | |
142 | (let ((rbinds (map (lambda (x) | |
143 | (cons (binding:index x) (binding:name x))) | |
144 | (program-bindings-for-ip prog | |
145 | (arity:start arity))))) | |
146 | (lambda (i) | |
147 | (assv-ref rbinds i)))) | |
148 | ||
149 | (let lp ((nreq (arity:nreq arity)) (req '()) | |
150 | (nopt (arity:nopt arity)) (opt '()) | |
151 | (rest? (arity:rest? arity)) (rest #f) | |
152 | (n 0)) | |
153 | (cond | |
154 | ((< 0 nreq) | |
155 | (lp (1- nreq) (cons (var-by-index n) req) | |
156 | nopt opt rest? rest (1+ n))) | |
157 | ((< 0 nopt) | |
158 | (lp nreq req | |
159 | (1- nopt) (cons (var-by-index n) opt) | |
160 | rest? rest (1+ n))) | |
161 | (rest? | |
162 | (lp nreq req nopt opt | |
163 | #f (var-by-index n) | |
164 | (1+ n))) | |
165 | (else | |
166 | `((required . ,(reverse req)) | |
167 | (optional . ,(reverse opt)) | |
168 | (keyword . ,(arity:kw arity)) | |
169 | (allow-other-keys? . ,(arity:allow-other-keys? arity)) | |
170 | (rest . ,rest)))))) | |
171 | ||
172 | (define* (program-arguments prog #:optional ip) | |
173 | (let ((arity (program-arity prog ip))) | |
174 | (and arity | |
175 | (arity->arguments prog arity)))) | |
176 | ||
177 | (define* (program-lambda-list prog #:optional ip) | |
178 | (and=> (program-arguments prog ip) arguments->lambda-list)) | |
179 | ||
180 | (define (arguments->lambda-list arguments) | |
181 | (let ((req (or (assq-ref arguments 'required) '())) | |
182 | (opt (or (assq-ref arguments 'optional) '())) | |
183 | (key (or (assq-ref arguments 'keyword) '())) | |
184 | (rest (or (assq-ref arguments 'rest) '()))) | |
185 | `(,@req | |
186 | ,@(if (pair? opt) (cons #:optional opt) '()) | |
187 | ,@(if (pair? key) (cons #:key key) '()) | |
188 | . ,rest))) | |
e6fea618 AW |
189 | |
190 | (define (write-program prog port) | |
6c6a4439 | 191 | (format port "#<program ~a~a>" |
e6fea618 | 192 | (or (program-name prog) |
028e3d06 AW |
193 | (and=> (program-source prog 0) |
194 | (lambda (s) | |
195 | (format #f "~a at ~a:~a:~a" | |
196 | (number->string (object-address prog) 16) | |
197 | (or (source:file s) "<unknown port>") | |
198 | (source:line s) (source:column s)))) | |
e6fea618 | 199 | (number->string (object-address prog) 16)) |
6c6a4439 AW |
200 | (let ((arities (program-arities prog))) |
201 | (if (null? arities) | |
202 | "" | |
203 | (string-append | |
204 | " " (string-join (map (lambda (a) | |
205 | (object->string | |
206 | (arguments->lambda-list | |
207 | (arity->arguments prog a)))) | |
208 | arities) | |
209 | " | ")))))) | |
210 |