Commit | Line | Data |
---|---|---|
ac99cb0c KN |
1 | ;;; Guile VM frame functions |
2 | ||
67b699cc | 3 | ;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. |
884d46de | 4 | ;;; |
587cd3bf 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. | |
884d46de | 9 | ;;; |
587cd3bf | 10 | ;;; This library is distributed in the hope that it will be useful, |
884d46de | 11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
587cd3bf LC |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;; Lesser General Public License for more details. | |
884d46de | 14 | ;;; |
587cd3bf 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 | |
ac99cb0c KN |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (system vm frame) | |
6c6a4439 | 22 | #:use-module (system base pmatch) |
1a1a10d3 AW |
23 | #:use-module (system vm program) |
24 | #:use-module (system vm instruction) | |
84012ef4 | 25 | #:use-module (system vm objcode) |
1c5e8122 AW |
26 | #:export (frame-bindings |
27 | frame-lookup-binding | |
28 | frame-binding-ref frame-binding-set! | |
423fca76 | 29 | frame-next-source frame-call-representation |
476e3572 | 30 | frame-environment |
c850a0ff | 31 | frame-object-binding frame-object-name)) |
ac99cb0c | 32 | |
aa3f6951 | 33 | (define (frame-bindings frame) |
67b699cc AW |
34 | (let ((p (frame-procedure frame))) |
35 | (if (program? p) | |
36 | (program-bindings-for-ip p (frame-instruction-pointer frame)) | |
37 | '()))) | |
1c5e8122 AW |
38 | |
39 | (define (frame-lookup-binding frame var) | |
40 | (let lp ((bindings (frame-bindings frame))) | |
41 | (cond ((null? bindings) | |
8470b3f4 | 42 | #f) |
1c5e8122 AW |
43 | ((eq? (binding:name (car bindings)) var) |
44 | (car bindings)) | |
45 | (else | |
46 | (lp (cdr bindings)))))) | |
6c6a4439 | 47 | |
aa3f6951 | 48 | (define (frame-binding-set! frame var val) |
1c5e8122 | 49 | (frame-local-set! frame |
8470b3f4 AW |
50 | (binding:index |
51 | (or (frame-lookup-binding frame var) | |
52 | (error "variable not bound in frame" var frame))) | |
1c5e8122 | 53 | val)) |
6c6a4439 | 54 | |
aa3f6951 | 55 | (define (frame-binding-ref frame var) |
1c5e8122 | 56 | (frame-local-ref frame |
8470b3f4 AW |
57 | (binding:index |
58 | (or (frame-lookup-binding frame var) | |
59 | (error "variable not bound in frame" var frame))))) | |
1c5e8122 | 60 | |
6c6a4439 | 61 | |
8470b3f4 AW |
62 | ;; This function is always called to get some sort of representation of the |
63 | ;; frame to present to the user, so let's do the logical thing and dispatch to | |
64 | ;; frame-call-representation. | |
65 | (define (frame-arguments frame) | |
66 | (cdr (frame-call-representation frame))) | |
67 | ||
68 | ||
69 | \f | |
70 | ;;; | |
71 | ;;; Pretty printing | |
72 | ;;; | |
73 | ||
b262b74b AW |
74 | (define (frame-next-source frame) |
75 | (let ((proc (frame-procedure frame))) | |
67b699cc AW |
76 | (if (program? proc) |
77 | (program-source proc | |
78 | (frame-instruction-pointer frame) | |
79 | (program-sources-pre-retire proc)) | |
80 | '()))) | |
b262b74b | 81 | |
8470b3f4 | 82 | |
6c6a4439 AW |
83 | ;; Basically there are two cases to deal with here: |
84 | ;; | |
85 | ;; 1. We've already parsed the arguments, and bound them to local | |
86 | ;; variables. In a standard (lambda (a b c) ...) call, this doesn't | |
87 | ;; involve any argument shuffling; but with rest, optional, or | |
88 | ;; keyword arguments, the arguments as given to the procedure may | |
89 | ;; not correspond to what's on the stack. We reconstruct the | |
90 | ;; arguments using e.g. for the case above: `(,a ,b ,c). This works | |
91 | ;; for rest arguments too: (a b . c) => `(,a ,b . ,c) | |
92 | ;; | |
93 | ;; 2. We have failed to parse the arguments. Perhaps it's the wrong | |
94 | ;; number of arguments, or perhaps we're doing a typed dispatch and | |
95 | ;; the types don't match. In that case the arguments are all on the | |
96 | ;; stack, and nothing else is on the stack. | |
d0168f3d AW |
97 | |
98 | (define (frame-call-representation frame) | |
1c5e8122 | 99 | (let ((p (frame-procedure frame))) |
8470b3f4 | 100 | (cons |
da874e54 | 101 | (or (false-if-exception (procedure-name p)) p) |
8470b3f4 | 102 | (cond |
67b699cc AW |
103 | ((and (program? p) |
104 | (program-arguments-alist p (frame-instruction-pointer frame))) | |
8470b3f4 AW |
105 | ;; case 1 |
106 | => (lambda (arguments) | |
107 | (define (binding-ref sym i) | |
108 | (cond | |
109 | ((frame-lookup-binding frame sym) | |
110 | => (lambda (b) (frame-local-ref frame (binding:index b)))) | |
111 | ((< i (frame-num-locals frame)) | |
112 | (frame-local-ref frame i)) | |
113 | (else | |
114 | ;; let's not error here, as we are called during backtraces... | |
115 | '???))) | |
116 | (let lp ((req (or (assq-ref arguments 'required) '())) | |
117 | (opt (or (assq-ref arguments 'optional) '())) | |
118 | (key (or (assq-ref arguments 'keyword) '())) | |
119 | (rest (or (assq-ref arguments 'rest) #f)) | |
120 | (i 0)) | |
121 | (cond | |
122 | ((pair? req) | |
123 | (cons (binding-ref (car req) i) | |
124 | (lp (cdr req) opt key rest (1+ i)))) | |
125 | ((pair? opt) | |
126 | (cons (binding-ref (car opt) i) | |
127 | (lp req (cdr opt) key rest (1+ i)))) | |
128 | ((pair? key) | |
129 | (cons* (caar key) | |
130 | (frame-local-ref frame (cdar key)) | |
131 | (lp req opt (cdr key) rest (1+ i)))) | |
132 | (rest | |
133 | (binding-ref rest i)) | |
134 | (else | |
135 | '()))))) | |
136 | (else | |
137 | ;; case 2 | |
138 | (map (lambda (i) | |
139 | (frame-local-ref frame i)) | |
140 | (iota (frame-num-locals frame)))))))) | |
1c5e8122 | 141 | |
07e56b27 AW |
142 | |
143 | \f | |
1c5e8122 | 144 | ;;; Misc |
07e56b27 AW |
145 | ;;; |
146 | ||
1c5e8122 | 147 | (define (frame-environment frame) |
07e56b27 AW |
148 | (map (lambda (binding) |
149 | (cons (binding:name binding) (frame-binding-ref frame binding))) | |
1c5e8122 | 150 | (frame-bindings frame))) |
07e56b27 | 151 | |
1c5e8122 AW |
152 | (define (frame-object-binding frame obj) |
153 | (do ((bs (frame-bindings frame) (cdr bs))) | |
154 | ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs)))) | |
155 | (and (pair? bs) (car bs))))) | |
07e56b27 | 156 | |
1c5e8122 AW |
157 | (define (frame-object-name frame obj) |
158 | (cond ((frame-object-binding frame obj) => binding:name) | |
07e56b27 | 159 | (else #f))) |