Commit | Line | Data |
---|---|---|
adb8f306 LC |
1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
2 | ;;; | |
403d78f9 | 3 | ;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
adb8f306 LC |
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 | (use-modules (language tree-il) | |
72ee0ef7 | 20 | (language tree-il primitives) |
014de9e2 | 21 | (language tree-il canonicalize) |
1af6d2a7 | 22 | (srfi srfi-1) |
f9685f43 AW |
23 | (ice-9 pretty-print) |
24 | (system syntax)) | |
25 | ||
1af6d2a7 MW |
26 | ;; Minimize a syntax-object such that it can no longer be used as the |
27 | ;; first argument to 'datum->syntax', but is otherwise equivalent. | |
28 | (define (squeeze-syntax-object! syn) | |
29 | (define (ensure-list x) (if (vector? x) (vector->list x) x)) | |
30 | (let ((x (vector-ref syn 1)) | |
31 | (wrap (vector-ref syn 2)) | |
32 | (mod (vector-ref syn 3))) | |
33 | (let ((marks (car wrap)) | |
34 | (subst (cdr wrap))) | |
35 | (define (set-wrap! marks subst) | |
36 | (vector-set! syn 2 (cons marks subst))) | |
37 | (cond | |
38 | ((symbol? x) | |
39 | (let loop ((marks marks) (subst subst)) | |
40 | (cond | |
41 | ((null? subst) (set-wrap! marks subst) syn) | |
42 | ((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst))) | |
43 | ((find (lambda (entry) (and (eq? x (car entry)) | |
44 | (equal? marks (cadr entry)))) | |
45 | (apply map list (map ensure-list | |
46 | (cdr (vector->list (car subst)))))) | |
47 | => (lambda (entry) | |
48 | (set-wrap! marks | |
49 | (list (list->vector | |
50 | (cons 'ribcage | |
51 | (map vector entry))))) | |
52 | syn)) | |
53 | (else (loop marks (cdr subst)))))) | |
54 | ((or (pair? x) (vector? x)) | |
55 | syn) | |
56 | (else x))))) | |
57 | ||
58 | (define (squeeze-constant! x) | |
59 | (define (syntax-object? x) | |
60 | (and (vector? x) | |
61 | (= 4 (vector-length x)) | |
62 | (eq? 'syntax-object (vector-ref x 0)))) | |
63 | (cond ((syntax-object? x) | |
64 | (squeeze-syntax-object! x)) | |
65 | ((pair? x) | |
66 | (set-car! x (squeeze-constant! (car x))) | |
67 | (set-cdr! x (squeeze-constant! (cdr x))) | |
68 | x) | |
69 | ((vector? x) | |
70 | (for-each (lambda (i) | |
71 | (vector-set! x i (squeeze-constant! (vector-ref x i)))) | |
72 | (iota (vector-length x))) | |
73 | x) | |
74 | (else x))) | |
75 | ||
403d78f9 AW |
76 | (define (squeeze-tree-il x) |
77 | (post-order (lambda (x) | |
78 | (if (const? x) | |
79 | (make-const (const-src x) | |
80 | (squeeze-constant! (const-exp x))) | |
81 | x)) | |
82 | x)) | |
1af6d2a7 | 83 | |
f9685f43 AW |
84 | ;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels |
85 | ;; changing session identifiers. | |
86 | (set! syntax-session-id (lambda () "*")) | |
adb8f306 | 87 | |
9c35c579 AW |
88 | (let ((source (list-ref (command-line) 1)) |
89 | (target (list-ref (command-line) 2))) | |
90 | (let ((in (open-input-file source)) | |
91 | (out (open-output-file (string-append target ".tmp")))) | |
92 | (write '(eval-when (compile) (set-current-module (resolve-module '(guile)))) | |
93 | out) | |
94 | (newline out) | |
95 | (let loop ((x (read in))) | |
96 | (if (eof-object? x) | |
97 | (begin | |
98 | (close-port out) | |
99 | (close-port in)) | |
100 | (begin | |
65dd9e38 | 101 | (pretty-print (tree-il->scheme |
403d78f9 AW |
102 | (squeeze-tree-il |
103 | (canonicalize | |
104 | (resolve-primitives | |
1af6d2a7 MW |
105 | (macroexpand x 'c '(compile load eval)) |
106 | (current-module)))) | |
72ee0ef7 MW |
107 | (current-module) |
108 | (list #:avoid-lambda? #f | |
109 | #:use-case? #f | |
110 | #:strip-numeric-suffixes? #t | |
111 | #:use-derived-syntax? | |
112 | (and (pair? x) | |
113 | (eq? 'let (car x))))) | |
114 | out #:width 120 #:max-expr-width 70) | |
9c35c579 AW |
115 | (newline out) |
116 | (loop (read in)))))) | |
117 | (system (format #f "mv -f ~s.tmp ~s" target target))) |