Commit | Line | Data |
---|---|---|
b275fb26 AW |
1 | ;;; Tree-il canonicalizer |
2 | ||
19113f1c | 3 | ;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. |
b275fb26 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 | ;;; Code: | |
20 | ||
21 | (define-module (language tree-il canonicalize) | |
22 | #:use-module (language tree-il) | |
23 | #:use-module (ice-9 match) | |
24 | #:use-module (srfi srfi-1) | |
403d78f9 | 25 | #:export (canonicalize)) |
b275fb26 AW |
26 | |
27 | (define (tree-il-any proc exp) | |
28 | (tree-il-fold (lambda (exp res) | |
29 | (or res (proc exp))) | |
b275fb26 AW |
30 | (lambda (exp res) res) |
31 | #f exp)) | |
32 | ||
403d78f9 AW |
33 | (define (canonicalize x) |
34 | (post-order | |
b275fb26 AW |
35 | (lambda (x) |
36 | (match x | |
b275fb26 AW |
37 | (($ <let> src () () () body) |
38 | body) | |
39 | (($ <letrec> src _ () () () body) | |
40 | body) | |
41 | (($ <fix> src () () () body) | |
42 | body) | |
19113f1c AW |
43 | (($ <lambda> src meta #f) |
44 | ;; Give a body to case-lambda with no clauses. | |
45 | (make-lambda | |
46 | src meta | |
47 | (make-lambda-case | |
48 | #f '() #f #f #f '() '() | |
26d14806 | 49 | (make-primcall |
19113f1c | 50 | #f |
26d14806 | 51 | 'throw |
19113f1c AW |
52 | (list (make-const #f 'wrong-number-of-args) |
53 | (make-const #f #f) | |
54 | (make-const #f "Wrong number of arguments") | |
55 | (make-const #f '()) | |
56 | (make-const #f #f))) | |
57 | #f))) | |
99983d54 AW |
58 | (($ <prompt> src escape-only? tag body handler) |
59 | ;; The prompt handler should be a simple lambda, so that we | |
60 | ;; can inline it. | |
61 | (match handler | |
62 | (($ <lambda> _ _ | |
63 | ($ <lambda-case> _ req #f rest #f () syms body #f)) | |
64 | x) | |
65 | (else | |
66 | (let ((handler-sym (gensym)) | |
67 | (args-sym (gensym))) | |
68 | (make-let | |
69 | #f (list 'handler) (list handler-sym) (list handler) | |
70 | (make-prompt | |
71 | src escape-only? tag body | |
72 | (make-lambda | |
73 | #f '() | |
74 | (make-lambda-case | |
75 | #f '() #f 'args #f '() (list args-sym) | |
76 | (make-primcall | |
77 | #f 'apply | |
78 | (list (make-lexical-ref #f 'handler handler-sym) | |
79 | (make-lexical-ref #f 'args args-sym))) | |
80 | #f)))))))) | |
403d78f9 | 81 | (_ x))) |
b275fb26 | 82 | x)) |