Commit | Line | Data |
---|---|---|
80b01fd0 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
3 | ;; Copyright (C) 2013 Free Software Foundation, Inc. | |
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 | ;;; Commentary: | |
20 | ;;; | |
21 | ;;; | |
22 | ;;; Code: | |
23 | ||
24 | (define-module (language cps verify) | |
25 | #:use-module (ice-9 match) | |
26 | #:use-module (srfi srfi-26) | |
27 | #:use-module (language cps) | |
28 | #:export (verify-cps)) | |
29 | ||
30 | (define (verify-cps fun) | |
31 | (define seen-gensyms (make-hash-table)) | |
32 | ||
33 | (define (add sym env) | |
34 | (if (hashq-ref seen-gensyms sym) | |
35 | (error "duplicate gensym" sym) | |
36 | (begin | |
37 | (hashq-set! seen-gensyms sym #t) | |
38 | (cons sym env)))) | |
39 | ||
40 | (define (add-env new env) | |
41 | (if (null? new) | |
42 | env | |
43 | (add-env (cdr new) (add (car new) env)))) | |
44 | ||
45 | (define (check-var sym env) | |
46 | (cond | |
47 | ((not (hashq-ref seen-gensyms sym)) | |
48 | (error "unbound lexical" sym)) | |
49 | ((not (memq sym env)) | |
50 | (error "displaced lexical" sym)))) | |
51 | ||
52 | (define (check-src src) | |
53 | (if (and src (not (and (list? src) (and-map pair? src) | |
54 | (and-map symbol? (map car src))))) | |
55 | (error "bad src"))) | |
56 | ||
57 | (define (visit-cont-body cont k-env v-env) | |
58 | (match cont | |
59 | (($ $kif kt kf) | |
60 | (check-var kt k-env) | |
61 | (check-var kf k-env)) | |
62 | (($ $ktrunc ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k) | |
63 | (check-var k k-env)) | |
64 | (($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body) | |
65 | (unless (= (length name) (length sym)) | |
66 | (error "name and sym lengths don't match" name sym)) | |
67 | (visit-term body k-env (add-env sym v-env))) | |
68 | (_ | |
69 | ;; $kclause, $kentry, and $ktail are only ever seen in $fun. | |
70 | (error "unexpected cont body" cont)))) | |
71 | ||
72 | (define (visit-clause clause k-env v-env) | |
73 | (match clause | |
74 | (($ $cont kclause src* | |
75 | ($ $kclause | |
76 | ($ $arity | |
77 | ((? symbol? req) ...) | |
78 | ((? symbol? opt) ...) | |
79 | (and rest (or #f (? symbol?))) | |
80 | (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...) | |
81 | (or #f #t)) | |
82 | ($ $cont kbody src (and body ($ $kargs names syms _))))) | |
83 | (check-src src*) | |
84 | (check-src src) | |
85 | (for-each (lambda (sym) | |
86 | (unless (memq sym syms) | |
87 | (error "bad keyword sym" sym))) | |
88 | kwsym) | |
89 | ;; FIXME: It is technically possible for kw syms to alias other | |
90 | ;; syms. | |
91 | (unless (equal? (append req opt (if rest (list rest) '()) kwname) | |
92 | names) | |
93 | (error "clause body names do not match arity names" exp)) | |
94 | (let ((k-env (add-env (list kclause kbody) k-env))) | |
95 | (visit-cont-body body k-env v-env))) | |
96 | (_ | |
97 | (error "unexpected clause" clause)))) | |
98 | ||
99 | (define (visit-fun fun k-env v-env) | |
100 | (match fun | |
101 | (($ $fun meta ((? symbol? free) ...) | |
102 | ($ $cont kbody src | |
103 | ($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail)) clauses))) | |
104 | (when (and meta (not (and (list? meta) (and-map pair? meta)))) | |
105 | (error "meta should be alist" meta)) | |
106 | (for-each (cut check-var <> v-env) free) | |
107 | (check-src src) | |
108 | ;; Reset the continuation environment, because Guile's | |
109 | ;; continuations are local. | |
110 | (let ((v-env (add-env (list self) v-env)) | |
111 | (k-env (add-env (list ktail) '()))) | |
112 | (for-each (cut visit-clause <> k-env v-env) clauses))) | |
113 | (_ | |
114 | (error "unexpected $fun" fun)))) | |
115 | ||
116 | (define (visit-expression exp k-env v-env) | |
117 | (match exp | |
118 | (($ $var sym) | |
119 | (check-var sym v-env)) | |
120 | (($ $void) | |
121 | #t) | |
122 | (($ $const val) | |
123 | #t) | |
124 | (($ $prim (? symbol? name)) | |
125 | #t) | |
126 | (($ $fun) | |
25833e80 | 127 | (visit-fun exp k-env v-env)) |
80b01fd0 AW |
128 | (($ $call (? symbol? proc) ((? symbol? arg) ...)) |
129 | (check-var proc v-env) | |
130 | (for-each (cut check-var <> v-env) arg)) | |
131 | (($ $primcall (? symbol? name) ((? symbol? arg) ...)) | |
132 | (for-each (cut check-var <> v-env) arg)) | |
133 | (($ $values ((? symbol? arg) ...)) | |
134 | (for-each (cut check-var <> v-env) arg)) | |
96af4a18 | 135 | (($ $prompt escape? tag handler pop) |
80b01fd0 AW |
136 | (unless (boolean? escape?) (error "escape? should be boolean" escape?)) |
137 | (check-var tag v-env) | |
96af4a18 AW |
138 | (check-var handler k-env) |
139 | (check-var pop k-env)) | |
80b01fd0 AW |
140 | (_ |
141 | (error "unexpected expression" exp)))) | |
142 | ||
143 | (define (visit-term term k-env v-env) | |
144 | (match term | |
145 | (($ $letk (($ $cont (? symbol? k) src cont) ...) body) | |
146 | (let ((k-env (add-env k k-env))) | |
147 | (for-each check-src src) | |
148 | (for-each (cut visit-cont-body <> k-env v-env) cont) | |
149 | (visit-term body k-env v-env))) | |
150 | ||
151 | (($ $letrec ((? symbol? name) ...) ((? symbol? sym) ...) (fun ...) body) | |
152 | (unless (= (length name) (length sym) (length fun)) | |
153 | (error "letrec syms, names, and funs not same length" term)) | |
154 | (let ((v-env (add-env sym v-env))) | |
155 | (for-each (cut visit-fun <> k-env v-env) fun) | |
156 | (visit-term body k-env v-env))) | |
157 | ||
158 | (($ $continue k exp) | |
159 | (check-var k k-env) | |
160 | (visit-expression exp k-env v-env)) | |
161 | ||
162 | (_ | |
163 | (error "unexpected term" term)))) | |
164 | ||
165 | (visit-fun fun '() '()) | |
166 | fun) |