3 ;; Copyright (C) 2011 Free Software Foundation, Inc.
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.
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.
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
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))
26 (define (verify-tree-il exp)
27 (define seen-gensyms (make-hash-table))
29 (if (hashq-ref seen-gensyms sym)
30 (error "duplicate gensym" sym)
32 (hashq-set! seen-gensyms sym #t)
34 (define (add-env new env)
37 (add-env (cdr new) (add (car new) env))))
42 (($ <lambda-case> src req opt rest kw inits gensyms body alt)
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
56 (((? keyword?) (? symbol?) (? symbol? sym))
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)
68 (if opt (length opt) 0)
69 ;; FIXME: technically possible for kw gensyms to
70 ;; alias other gensyms
72 (if kw (1- (length kw)) 0))))
73 (error "unexpected gensyms length" exp))
75 (let lp ((env (add-env (take gensyms (length req)) env))
76 (nopt (if opt (length opt) 0))
78 (tail (drop gensyms (length req))))
80 (let lp ((env (if rest (add (car tail) env) env))
82 (tail (if rest (cdr tail) tail)))
85 (visit (car inits) env)
86 (lp (add (car tail) env) (cdr inits)
90 (visit (car inits) env)
91 (lp (add (car tail) env)
95 (if alt (visit alt env)))))
96 (($ <lexical-ref> src name gensym)
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)
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))
114 (($ <lambda> src meta body)
116 ((and meta (not (and (list? meta) (and-map pair? meta))))
117 (error "meta should be alist" meta))
118 ((not (lambda-case? body))
119 (error "lambda body should be lambda-case" exp))
122 (($ <let> src names gensyms vals body)
124 ((not (and (list? names) (and-map symbol? names)))
125 (error "names should be list of syms" exp))
126 ((not (and (list? gensyms) (and-map symbol? gensyms)))
127 (error "gensyms should be list of syms" exp))
129 (error "vals should be list" exp))
130 ((not (= (length names) (length gensyms) (length vals)))
131 (error "names, syms, vals should be same length" exp))
133 (for-each (cut visit <> env) vals)
134 (visit body (add-env gensyms env)))))
135 (($ <letrec> src in-order? names gensyms vals body)
137 ((not (and (list? names) (and-map symbol? names)))
138 (error "names should be list of syms" exp))
139 ((not (and (list? gensyms) (and-map symbol? gensyms)))
140 (error "gensyms should be list of syms" exp))
142 (error "vals should be list" exp))
143 ((not (= (length names) (length gensyms) (length vals)))
144 (error "names, syms, vals should be same length" exp))
146 (let ((env (add-env gensyms env)))
147 (for-each (cut visit <> env) vals)
149 (($ <fix> src names gensyms vals body)
151 ((not (and (list? names) (and-map symbol? names)))
152 (error "names should be list of syms" exp))
153 ((not (and (list? gensyms) (and-map symbol? gensyms)))
154 (error "gensyms should be list of syms" exp))
156 (error "vals should be list" exp))
157 ((not (= (length names) (length gensyms) (length vals)))
158 (error "names, syms, vals should be same length" exp))
160 (let ((env (add-env gensyms env)))
161 (for-each (cut visit <> env) vals)
163 (($ <let-values> src exp body)
165 ((not (lambda-case? body))
166 (error "let-values body should be lambda-case" exp))
170 (($ <const> src val) #t)
172 (($ <toplevel-ref> src name)
174 ((not (symbol? name))
175 (error "name should be a symbol" name))))
176 (($ <module-ref> src mod name public?)
178 ((not (and (list? mod) (and-map symbol? mod)))
179 (error "module name should be list of symbols" exp))
180 ((not (symbol? name))
181 (error "name should be symbol" exp))))
182 (($ <primitive-ref> src name)
184 ((not (symbol? name))
185 (error "name should be symbol" exp))))
186 (($ <toplevel-set> src name exp)
188 ((not (symbol? name))
189 (error "name should be a symbol" name))
192 (($ <toplevel-define> src name exp)
194 ((not (symbol? name))
195 (error "name should be a symbol" name))
198 (($ <module-set> src mod name public? exp)
200 ((not (and (list? mod) (and-map symbol? mod)))
201 (error "module name should be list of symbols" exp))
202 ((not (symbol? name))
203 (error "name should be symbol" exp))
206 (($ <dynlet> src fluids vals body)
208 ((not (list? fluids))
209 (error "fluids should be list" exp))
211 (error "vals should be list" exp))
212 ((not (= (length fluids) (length vals)))
213 (error "mismatch in fluids/vals" exp))
215 (for-each (cut visit <> env) fluids)
216 (for-each (cut visit <> env) vals)
218 (($ <dynwind> src winder pre body post unwinder)
223 (visit unwinder env))
224 (($ <dynref> src fluid)
226 (($ <dynset> src fluid exp)
229 (($ <conditional> src condition subsequent alternate)
230 (visit condition env)
231 (visit subsequent env)
232 (visit alternate env))
233 (($ <primcall> src name args)
235 ((not (symbol? name))
236 (error "expected symbolic operator" exp))
238 (error "expected list of args" args))
240 (for-each (cut visit <> env) args))))
241 (($ <call> src proc args)
244 (error "expected list of args" args))
247 (for-each (cut visit <> env) args))))
248 (($ <seq> src head tail)
251 (($ <prompt> src tag body handler)
255 (($ <abort> src tag args tail)
257 (for-each (cut visit <> env) args)
260 (error "unexpected tree-il" exp)))
261 (let ((src (tree-il-src exp)))
262 (if (and src (not (and (list? src) (and-map pair? src)
263 (and-map symbol? (map car src)))))
265 ;; Return it, why not.