Commit | Line | Data |
---|---|---|
6d2d6897 AW |
1 | ;;; Tree-IL verifier |
2 | ||
19113f1c | 3 | ;; Copyright (C) 2011, 2013 Free Software Foundation, Inc. |
6d2d6897 AW |
4 | |
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. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
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 | |
18 | ||
19 | (define-module (language tree-il debug) | |
20 | #:use-module (language tree-il) | |
21 | #:use-module (ice-9 match) | |
22 | #:use-module (srfi srfi-1) | |
23 | #:use-module (srfi srfi-26) | |
24 | #:export (verify-tree-il)) | |
25 | ||
26 | (define (verify-tree-il exp) | |
27 | (define seen-gensyms (make-hash-table)) | |
28 | (define (add sym env) | |
29 | (if (hashq-ref seen-gensyms sym) | |
30 | (error "duplicate gensym" sym) | |
31 | (begin | |
32 | (hashq-set! seen-gensyms sym #t) | |
33 | (cons sym env)))) | |
34 | (define (add-env new env) | |
35 | (if (null? new) | |
36 | env | |
37 | (add-env (cdr new) (add (car new) env)))) | |
38 | ||
39 | (let visit ((exp exp) | |
40 | (env '())) | |
41 | (match exp | |
42 | (($ <lambda-case> src req opt rest kw inits gensyms body alt) | |
43 | (cond | |
44 | ((not (and (list? req) (and-map symbol? req))) | |
45 | (error "bad required args (should be list of symbols)" exp)) | |
46 | ((and opt (not (and (list? opt) (and-map symbol? opt)))) | |
47 | (error "bad optionals (should be #f or list of symbols)" exp)) | |
48 | ((and rest (not (symbol? rest))) | |
49 | (error "bad required args (should be #f or symbol)" exp)) | |
50 | ((and kw (not (match kw | |
51 | ((aok . kwlist) | |
52 | (and (list? kwlist) | |
53 | (and-map | |
54 | (lambda (x) | |
55 | (match x | |
56 | (((? keyword?) (? symbol?) (? symbol? sym)) | |
57 | (memq sym gensyms)) | |
58 | (_ #f))) | |
59 | kwlist))) | |
60 | (_ #f)))) | |
61 | (error "bad keywords (should be #f or (aok (kw name sym) ...))" exp)) | |
62 | ((not (and (list? gensyms) (and-map symbol? gensyms))) | |
63 | (error "bad gensyms (should be list of symbols)" exp)) | |
64 | ((not (and (list? gensyms) (and-map symbol? gensyms))) | |
65 | (error "bad gensyms (should be list of symbols)" exp)) | |
66 | ((not (= (length gensyms) | |
67 | (+ (length req) | |
68 | (if opt (length opt) 0) | |
69 | ;; FIXME: technically possible for kw gensyms to | |
70 | ;; alias other gensyms | |
71 | (if rest 1 0) | |
72 | (if kw (1- (length kw)) 0)))) | |
73 | (error "unexpected gensyms length" exp)) | |
74 | (else | |
75 | (let lp ((env (add-env (take gensyms (length req)) env)) | |
76 | (nopt (if opt (length opt) 0)) | |
77 | (inits inits) | |
78 | (tail (drop gensyms (length req)))) | |
79 | (if (zero? nopt) | |
80 | (let lp ((env (if rest (add (car tail) env) env)) | |
81 | (inits inits) | |
82 | (tail (if rest (cdr tail) tail))) | |
83 | (if (pair? inits) | |
84 | (begin | |
85 | (visit (car inits) env) | |
86 | (lp (add (car tail) env) (cdr inits) | |
87 | (cdr tail))) | |
88 | (visit body env))) | |
89 | (begin | |
90 | (visit (car inits) env) | |
91 | (lp (add (car tail) env) | |
92 | (1- nopt) | |
93 | (cdr inits) | |
94 | (cdr tail))))) | |
95 | (if alt (visit alt env))))) | |
96 | (($ <lexical-ref> src name gensym) | |
97 | (cond | |
98 | ((not (symbol? name)) | |
99 | (error "name should be a symbol" name)) | |
100 | ((not (hashq-ref seen-gensyms gensym)) | |
101 | (error "unbound lexical" exp)) | |
102 | ((not (memq gensym env)) | |
103 | (error "displaced lexical" exp)))) | |
104 | (($ <lexical-set> src name gensym exp) | |
105 | (cond | |
106 | ((not (symbol? name)) | |
107 | (error "name should be a symbol" name)) | |
108 | ((not (hashq-ref seen-gensyms gensym)) | |
109 | (error "unbound lexical" exp)) | |
110 | ((not (memq gensym env)) | |
111 | (error "displaced lexical" exp)) | |
112 | (else | |
113 | (visit exp env)))) | |
114 | (($ <lambda> src meta body) | |
115 | (cond | |
116 | ((and meta (not (and (list? meta) (and-map pair? meta)))) | |
117 | (error "meta should be alist" meta)) | |
19113f1c | 118 | ((and body (not (lambda-case? body))) |
6d2d6897 AW |
119 | (error "lambda body should be lambda-case" exp)) |
120 | (else | |
19113f1c AW |
121 | (if body |
122 | (visit body env))))) | |
6d2d6897 AW |
123 | (($ <let> src names gensyms vals body) |
124 | (cond | |
125 | ((not (and (list? names) (and-map symbol? names))) | |
126 | (error "names should be list of syms" exp)) | |
127 | ((not (and (list? gensyms) (and-map symbol? gensyms))) | |
128 | (error "gensyms should be list of syms" exp)) | |
129 | ((not (list? vals)) | |
130 | (error "vals should be list" exp)) | |
131 | ((not (= (length names) (length gensyms) (length vals))) | |
132 | (error "names, syms, vals should be same length" exp)) | |
133 | (else | |
134 | (for-each (cut visit <> env) vals) | |
135 | (visit body (add-env gensyms env))))) | |
136 | (($ <letrec> src in-order? names gensyms vals body) | |
137 | (cond | |
138 | ((not (and (list? names) (and-map symbol? names))) | |
139 | (error "names should be list of syms" exp)) | |
140 | ((not (and (list? gensyms) (and-map symbol? gensyms))) | |
141 | (error "gensyms should be list of syms" exp)) | |
142 | ((not (list? vals)) | |
143 | (error "vals should be list" exp)) | |
144 | ((not (= (length names) (length gensyms) (length vals))) | |
145 | (error "names, syms, vals should be same length" exp)) | |
146 | (else | |
147 | (let ((env (add-env gensyms env))) | |
148 | (for-each (cut visit <> env) vals) | |
149 | (visit body env))))) | |
150 | (($ <fix> src names gensyms vals body) | |
151 | (cond | |
152 | ((not (and (list? names) (and-map symbol? names))) | |
153 | (error "names should be list of syms" exp)) | |
154 | ((not (and (list? gensyms) (and-map symbol? gensyms))) | |
155 | (error "gensyms should be list of syms" exp)) | |
156 | ((not (list? vals)) | |
157 | (error "vals should be list" exp)) | |
158 | ((not (= (length names) (length gensyms) (length vals))) | |
159 | (error "names, syms, vals should be same length" exp)) | |
160 | (else | |
161 | (let ((env (add-env gensyms env))) | |
162 | (for-each (cut visit <> env) vals) | |
163 | (visit body env))))) | |
164 | (($ <let-values> src exp body) | |
165 | (cond | |
166 | ((not (lambda-case? body)) | |
167 | (error "let-values body should be lambda-case" exp)) | |
168 | (else | |
169 | (visit exp env) | |
170 | (visit body env)))) | |
171 | (($ <const> src val) #t) | |
172 | (($ <void> src) #t) | |
173 | (($ <toplevel-ref> src name) | |
174 | (cond | |
175 | ((not (symbol? name)) | |
176 | (error "name should be a symbol" name)))) | |
177 | (($ <module-ref> src mod name public?) | |
178 | (cond | |
179 | ((not (and (list? mod) (and-map symbol? mod))) | |
180 | (error "module name should be list of symbols" exp)) | |
181 | ((not (symbol? name)) | |
182 | (error "name should be symbol" exp)))) | |
183 | (($ <primitive-ref> src name) | |
184 | (cond | |
185 | ((not (symbol? name)) | |
186 | (error "name should be symbol" exp)))) | |
187 | (($ <toplevel-set> src name exp) | |
188 | (cond | |
189 | ((not (symbol? name)) | |
190 | (error "name should be a symbol" name)) | |
191 | (else | |
192 | (visit exp env)))) | |
193 | (($ <toplevel-define> src name exp) | |
194 | (cond | |
195 | ((not (symbol? name)) | |
196 | (error "name should be a symbol" name)) | |
197 | (else | |
198 | (visit exp env)))) | |
199 | (($ <module-set> src mod name public? exp) | |
200 | (cond | |
201 | ((not (and (list? mod) (and-map symbol? mod))) | |
202 | (error "module name should be list of symbols" exp)) | |
203 | ((not (symbol? name)) | |
204 | (error "name should be symbol" exp)) | |
205 | (else | |
206 | (visit exp env)))) | |
6d2d6897 AW |
207 | (($ <conditional> src condition subsequent alternate) |
208 | (visit condition env) | |
209 | (visit subsequent env) | |
210 | (visit alternate env)) | |
a215c159 | 211 | (($ <primcall> src name args) |
6d2d6897 | 212 | (cond |
a215c159 AW |
213 | ((not (symbol? name)) |
214 | (error "expected symbolic operator" exp)) | |
6d2d6897 AW |
215 | ((not (list? args)) |
216 | (error "expected list of args" args)) | |
217 | (else | |
6d2d6897 | 218 | (for-each (cut visit <> env) args)))) |
a215c159 | 219 | (($ <call> src proc args) |
6d2d6897 | 220 | (cond |
a215c159 AW |
221 | ((not (list? args)) |
222 | (error "expected list of args" args)) | |
6d2d6897 | 223 | (else |
a215c159 AW |
224 | (visit proc env) |
225 | (for-each (cut visit <> env) args)))) | |
226 | (($ <seq> src head tail) | |
227 | (visit head env) | |
228 | (visit tail env)) | |
178a4092 AW |
229 | (($ <prompt> src escape-only? tag body handler) |
230 | (unless (boolean? escape-only?) | |
231 | (error "escape-only? should be a bool" escape-only?)) | |
6d2d6897 AW |
232 | (visit tag env) |
233 | (visit body env) | |
234 | (visit handler env)) | |
235 | (($ <abort> src tag args tail) | |
236 | (visit tag env) | |
237 | (for-each (cut visit <> env) args) | |
238 | (visit tail env)) | |
239 | (_ | |
240 | (error "unexpected tree-il" exp))) | |
241 | (let ((src (tree-il-src exp))) | |
242 | (if (and src (not (and (list? src) (and-map pair? src) | |
243 | (and-map symbol? (map car src))))) | |
244 | (error "bad src")) | |
245 | ;; Return it, why not. | |
246 | exp))) |