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