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 |
6a4a1ef0 AW |
31 | frame-object-binding frame-object-name |
32 | frame-return-values)) | |
ac99cb0c | 33 | |
aa3f6951 | 34 | (define (frame-bindings frame) |
67b699cc AW |
35 | (let ((p (frame-procedure frame))) |
36 | (if (program? p) | |
37 | (program-bindings-for-ip p (frame-instruction-pointer frame)) | |
38 | '()))) | |
1c5e8122 AW |
39 | |
40 | (define (frame-lookup-binding frame var) | |
41 | (let lp ((bindings (frame-bindings frame))) | |
42 | (cond ((null? bindings) | |
8470b3f4 | 43 | #f) |
1c5e8122 AW |
44 | ((eq? (binding:name (car bindings)) var) |
45 | (car bindings)) | |
46 | (else | |
47 | (lp (cdr bindings)))))) | |
6c6a4439 | 48 | |
aa3f6951 | 49 | (define (frame-binding-set! frame var val) |
1c5e8122 | 50 | (frame-local-set! frame |
8470b3f4 AW |
51 | (binding:index |
52 | (or (frame-lookup-binding frame var) | |
53 | (error "variable not bound in frame" var frame))) | |
1c5e8122 | 54 | val)) |
6c6a4439 | 55 | |
aa3f6951 | 56 | (define (frame-binding-ref frame var) |
1c5e8122 | 57 | (frame-local-ref frame |
8470b3f4 AW |
58 | (binding:index |
59 | (or (frame-lookup-binding frame var) | |
60 | (error "variable not bound in frame" var frame))))) | |
1c5e8122 | 61 | |
6c6a4439 | 62 | |
8470b3f4 AW |
63 | ;; This function is always called to get some sort of representation of the |
64 | ;; frame to present to the user, so let's do the logical thing and dispatch to | |
65 | ;; frame-call-representation. | |
66 | (define (frame-arguments frame) | |
67 | (cdr (frame-call-representation frame))) | |
68 | ||
69 | ||
70 | \f | |
71 | ;;; | |
72 | ;;; Pretty printing | |
73 | ;;; | |
74 | ||
b262b74b AW |
75 | (define (frame-next-source frame) |
76 | (let ((proc (frame-procedure frame))) | |
67b699cc AW |
77 | (if (program? proc) |
78 | (program-source proc | |
79 | (frame-instruction-pointer frame) | |
80 | (program-sources-pre-retire proc)) | |
81 | '()))) | |
b262b74b | 82 | |
8470b3f4 | 83 | |
6c6a4439 AW |
84 | ;; Basically there are two cases to deal with here: |
85 | ;; | |
86 | ;; 1. We've already parsed the arguments, and bound them to local | |
87 | ;; variables. In a standard (lambda (a b c) ...) call, this doesn't | |
88 | ;; involve any argument shuffling; but with rest, optional, or | |
89 | ;; keyword arguments, the arguments as given to the procedure may | |
90 | ;; not correspond to what's on the stack. We reconstruct the | |
91 | ;; arguments using e.g. for the case above: `(,a ,b ,c). This works | |
92 | ;; for rest arguments too: (a b . c) => `(,a ,b . ,c) | |
93 | ;; | |
94 | ;; 2. We have failed to parse the arguments. Perhaps it's the wrong | |
95 | ;; number of arguments, or perhaps we're doing a typed dispatch and | |
96 | ;; the types don't match. In that case the arguments are all on the | |
97 | ;; stack, and nothing else is on the stack. | |
d0168f3d AW |
98 | |
99 | (define (frame-call-representation frame) | |
1c5e8122 | 100 | (let ((p (frame-procedure frame))) |
8470b3f4 AW |
101 | (cons |
102 | (or (procedure-name p) p) | |
103 | (cond | |
67b699cc AW |
104 | ((and (program? p) |
105 | (program-arguments-alist p (frame-instruction-pointer frame))) | |
8470b3f4 AW |
106 | ;; case 1 |
107 | => (lambda (arguments) | |
108 | (define (binding-ref sym i) | |
109 | (cond | |
110 | ((frame-lookup-binding frame sym) | |
111 | => (lambda (b) (frame-local-ref frame (binding:index b)))) | |
112 | ((< i (frame-num-locals frame)) | |
113 | (frame-local-ref frame i)) | |
114 | (else | |
115 | ;; let's not error here, as we are called during backtraces... | |
116 | '???))) | |
117 | (let lp ((req (or (assq-ref arguments 'required) '())) | |
118 | (opt (or (assq-ref arguments 'optional) '())) | |
119 | (key (or (assq-ref arguments 'keyword) '())) | |
120 | (rest (or (assq-ref arguments 'rest) #f)) | |
121 | (i 0)) | |
122 | (cond | |
123 | ((pair? req) | |
124 | (cons (binding-ref (car req) i) | |
125 | (lp (cdr req) opt key rest (1+ i)))) | |
126 | ((pair? opt) | |
127 | (cons (binding-ref (car opt) i) | |
128 | (lp req (cdr opt) key rest (1+ i)))) | |
129 | ((pair? key) | |
130 | (cons* (caar key) | |
131 | (frame-local-ref frame (cdar key)) | |
132 | (lp req opt (cdr key) rest (1+ i)))) | |
133 | (rest | |
134 | (binding-ref rest i)) | |
135 | (else | |
136 | '()))))) | |
137 | (else | |
138 | ;; case 2 | |
139 | (map (lambda (i) | |
140 | (frame-local-ref frame i)) | |
141 | (iota (frame-num-locals frame)))))))) | |
1c5e8122 | 142 | |
07e56b27 AW |
143 | |
144 | \f | |
1c5e8122 | 145 | ;;; Misc |
07e56b27 AW |
146 | ;;; |
147 | ||
1c5e8122 | 148 | (define (frame-environment frame) |
07e56b27 AW |
149 | (map (lambda (binding) |
150 | (cons (binding:name binding) (frame-binding-ref frame binding))) | |
1c5e8122 | 151 | (frame-bindings frame))) |
07e56b27 | 152 | |
1c5e8122 AW |
153 | (define (frame-object-binding frame obj) |
154 | (do ((bs (frame-bindings frame) (cdr bs))) | |
155 | ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs)))) | |
156 | (and (pair? bs) (car bs))))) | |
07e56b27 | 157 | |
1c5e8122 AW |
158 | (define (frame-object-name frame obj) |
159 | (cond ((frame-object-binding frame obj) => binding:name) | |
07e56b27 | 160 | (else #f))) |
6a4a1ef0 AW |
161 | |
162 | ;; Nota bene, only if frame is in a return context (i.e. in a | |
163 | ;; pop-continuation hook dispatch). | |
164 | (define (frame-return-values frame) | |
165 | (let* ((len (frame-num-locals frame)) | |
166 | (nvalues (frame-local-ref frame (1- len)))) | |
167 | (map (lambda (i) | |
d608db1d | 168 | (frame-local-ref frame (+ (- len nvalues 1) i))) |
6a4a1ef0 | 169 | (iota nvalues)))) |