1 | ;;;; compiler-syntax.scm - compiler syntax used internally |
---|
2 | ; |
---|
3 | ; Copyright (c) 2009, The Chicken Team |
---|
4 | ; All rights reserved. |
---|
5 | ; |
---|
6 | ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following |
---|
7 | ; conditions are met: |
---|
8 | ; |
---|
9 | ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following |
---|
10 | ; disclaimer. |
---|
11 | ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following |
---|
12 | ; disclaimer in the documentation and/or other materials provided with the distribution. |
---|
13 | ; Neither the name of the author nor the names of its contributors may be used to endorse or promote |
---|
14 | ; products derived from this software without specific prior written permission. |
---|
15 | ; |
---|
16 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS |
---|
17 | ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY |
---|
18 | ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR |
---|
19 | ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR |
---|
20 | ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
---|
21 | ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
---|
22 | ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR |
---|
23 | ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE |
---|
24 | ; POSSIBILITY OF SUCH DAMAGE. |
---|
25 | |
---|
26 | |
---|
27 | (declare |
---|
28 | (unit compiler-syntax) ) |
---|
29 | |
---|
30 | |
---|
31 | (include "compiler-namespace") |
---|
32 | (include "tweaks.scm") |
---|
33 | |
---|
34 | |
---|
35 | ;;; Compiler macros (that operate in the expansion phase) |
---|
36 | |
---|
37 | (define compiler-syntax-statistics '()) |
---|
38 | |
---|
39 | (set! ##sys#compiler-syntax-hook |
---|
40 | (lambda (name result) |
---|
41 | (let ((a (alist-ref name compiler-syntax-statistics eq? 0))) |
---|
42 | (set! compiler-syntax-statistics |
---|
43 | (alist-update! name (add1 a) compiler-syntax-statistics))))) |
---|
44 | |
---|
45 | (define (r-c-s names transformer #!optional (se '())) |
---|
46 | (let ((t (cons (##sys#er-transformer transformer) se))) |
---|
47 | (for-each |
---|
48 | (lambda (name) |
---|
49 | (##sys#put! name '##compiler#compiler-syntax t) ) |
---|
50 | (if (symbol? names) (list names) names) ) ) ) |
---|
51 | |
---|
52 | (define-syntax define-internal-compiler-syntax |
---|
53 | (syntax-rules () |
---|
54 | ((_ (names . llist) (se ...) . body) |
---|
55 | (r-c-s |
---|
56 | 'names (lambda llist . body) |
---|
57 | `((se . ,(##sys#primitive-alias 'se)) ...))))) |
---|
58 | |
---|
59 | (define-internal-compiler-syntax ((for-each ##sys#for-each #%for-each) x r c) |
---|
60 | (pair?) |
---|
61 | (let ((%let (r 'let)) |
---|
62 | (%if (r 'if)) |
---|
63 | (%loop (r 'loop)) |
---|
64 | (%begin (r 'begin)) |
---|
65 | (%and (r 'and)) |
---|
66 | (%pair? (r 'pair?)) |
---|
67 | (%lambda (r 'lambda)) |
---|
68 | (lsts (cddr x))) |
---|
69 | (if (and (memq 'for-each standard-bindings) ; we have to check this because the db (and thus |
---|
70 | (> (length+ x) 2) ; intrinsic marks) isn't set up yet |
---|
71 | (or (and (pair? (cadr x)) |
---|
72 | (c %lambda (caadr x))) |
---|
73 | (symbol? (cadr x)))) |
---|
74 | (let ((vars (map (lambda _ (gensym)) lsts))) |
---|
75 | `(,%let ,%loop ,(map list vars lsts) |
---|
76 | (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars)) |
---|
77 | (,%begin |
---|
78 | ((,%begin ,(cadr x)) |
---|
79 | ,@(map (lambda (v) `(##sys#slot ,v 0)) vars)) |
---|
80 | (##core#app |
---|
81 | ,%loop |
---|
82 | ,@(map (lambda (v) `(##sys#slot ,v 1)) vars) ) )))) |
---|
83 | x))) |
---|
84 | |
---|
85 | (define-internal-compiler-syntax ((map ##sys#map #%map) x r c) |
---|
86 | (pair?) |
---|
87 | (let ((%let (r 'let)) |
---|
88 | (%if (r 'if)) |
---|
89 | (%loop (r 'loop)) |
---|
90 | (%res (r 'res)) |
---|
91 | (%cons (r 'cons)) |
---|
92 | (%set! (r 'set!)) |
---|
93 | (%result (r 'result)) |
---|
94 | (%node (r 'node)) |
---|
95 | (%quote (r 'quote)) |
---|
96 | (%begin (r 'begin)) |
---|
97 | (%lambda (r 'lambda)) |
---|
98 | (%and (r 'and)) |
---|
99 | (%pair? (r 'pair?)) |
---|
100 | (lsts (cddr x))) |
---|
101 | (if (and (memq 'map standard-bindings) ; s.a. |
---|
102 | (> (length+ x) 2) |
---|
103 | (or (and (pair? (cadr x)) |
---|
104 | (c %lambda (caadr x))) |
---|
105 | (symbol? (cadr x)))) |
---|
106 | (let ((vars (map (lambda _ (gensym)) lsts))) |
---|
107 | `(,%let ((,%result (,%quote ())) |
---|
108 | (,%node #f)) |
---|
109 | (,%let ,%loop ,(map list vars lsts) |
---|
110 | (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars)) |
---|
111 | (,%let ((,%res |
---|
112 | (,%cons |
---|
113 | ((,%begin ,(cadr x)) |
---|
114 | ,@(map (lambda (v) `(##sys#slot ,v 0)) vars)) |
---|
115 | (,%quote ())))) |
---|
116 | (,%if ,%node |
---|
117 | (##sys#setslot ,%node 1 ,%res) |
---|
118 | (,%set! ,%result ,%res)) |
---|
119 | (,%set! ,%node ,%res) |
---|
120 | (,%loop |
---|
121 | ,@(map (lambda (v) `(##sys#slot ,v 1)) vars))) |
---|
122 | ,%result)))) |
---|
123 | x))) |
---|
124 | |
---|
125 | (define-internal-compiler-syntax ((o #%o) x r c) () |
---|
126 | (if (and (fx> (length x) 1) |
---|
127 | (memq 'o extended-bindings) ) ; s.a. |
---|
128 | (let ((%tmp (r 'tmp))) |
---|
129 | `(,(r 'lambda) (,%tmp) ,(fold-right list %tmp (cdr x)))) |
---|
130 | x)) |
---|
131 | |
---|
132 | (define-internal-compiler-syntax ((sprintf #%sprintf format #%format) x r c) |
---|
133 | (display write fprintf number->string write-char open-output-string get-output-string) |
---|
134 | (let* ((out (gensym 'out)) |
---|
135 | (code (compile-format-string |
---|
136 | (if (memq (car x) '(sprintf #%sprintf)) |
---|
137 | 'sprintf |
---|
138 | 'format) |
---|
139 | out |
---|
140 | x |
---|
141 | (cdr x) |
---|
142 | r c))) |
---|
143 | (if code |
---|
144 | `(,(r 'let) ((,out (,(r 'open-output-string)))) |
---|
145 | ,code |
---|
146 | (,(r 'get-output-string) ,out)) |
---|
147 | x))) |
---|
148 | |
---|
149 | (define-internal-compiler-syntax ((fprintf #%fprintf) x r c) |
---|
150 | (display write fprintf number->string write-char open-output-string get-output-string) |
---|
151 | (if (>= (length x) 3) |
---|
152 | (let ((code (compile-format-string |
---|
153 | 'fprintf (cadr x) |
---|
154 | x (cddr x) |
---|
155 | r c))) |
---|
156 | (or code x)) |
---|
157 | x)) |
---|
158 | |
---|
159 | (define-internal-compiler-syntax ((printf #%printf) x r c) |
---|
160 | (display write fprintf number->string write-char open-output-string get-output-string) |
---|
161 | (let ((code (compile-format-string |
---|
162 | 'printf '##sys#standard-output |
---|
163 | x (cdr x) |
---|
164 | r c))) |
---|
165 | (or code x))) |
---|
166 | |
---|
167 | (define (compile-format-string func out x args r c) |
---|
168 | (call/cc |
---|
169 | (lambda (return) |
---|
170 | (and (>= (length args) 1) |
---|
171 | (memq func extended-bindings) ; s.a. |
---|
172 | (or (string? (car args)) |
---|
173 | (and (list? (car args)) |
---|
174 | (c (r 'quote) (caar args)) |
---|
175 | (string? (cadar args)))) |
---|
176 | (let ((fstr (if (string? (car args)) (car args) (cadar args))) |
---|
177 | (args (cdr args))) |
---|
178 | (define (fail ret? msg . args) |
---|
179 | (let ((ln (get-line x))) |
---|
180 | (compiler-warning |
---|
181 | 'syntax |
---|
182 | "(~a) in format string ~s~a, ~?" |
---|
183 | func fstr |
---|
184 | (if ln (sprintf " in line ~a" ln) "") |
---|
185 | msg args) ) |
---|
186 | (when ret? (return #f))) |
---|
187 | (let ((code '()) |
---|
188 | (index 0) |
---|
189 | (len (string-length fstr)) |
---|
190 | (%display (r 'display)) |
---|
191 | (%write (r 'write)) |
---|
192 | (%write-char (r 'write-char)) |
---|
193 | (%out (r 'out)) |
---|
194 | (%fprintf (r 'fprintf)) |
---|
195 | (%let (r 'let)) |
---|
196 | (%number->string (r 'number->string))) |
---|
197 | (define (fetch) |
---|
198 | (let ((c (string-ref fstr index))) |
---|
199 | (set! index (fx+ index 1)) |
---|
200 | c) ) |
---|
201 | (define (next) |
---|
202 | (if (null? args) |
---|
203 | (fail #t "too few arguments to formatted output procedure") |
---|
204 | (let ((x (car args))) |
---|
205 | (set! args (cdr args)) |
---|
206 | x) ) ) |
---|
207 | (define (endchunk chunk) |
---|
208 | (when (pair? chunk) |
---|
209 | (push |
---|
210 | (if (= 1 (length chunk)) |
---|
211 | `(,%write-char ,(car chunk) ,%out) |
---|
212 | `(,%display ,(reverse-list->string chunk) ,%out))))) |
---|
213 | (define (push exp) |
---|
214 | (set! code (cons exp code))) |
---|
215 | (let loop ((chunk '())) |
---|
216 | (cond ((>= index len) |
---|
217 | (unless (null? args) |
---|
218 | (fail #f "too many arguments to formatted output procedure")) |
---|
219 | (endchunk chunk) |
---|
220 | `(,%let ((,%out ,out)) |
---|
221 | ,@(reverse code))) |
---|
222 | (else |
---|
223 | (let ((c (fetch))) |
---|
224 | (if (eq? c #\~) |
---|
225 | (let ((dchar (fetch))) |
---|
226 | (endchunk chunk) |
---|
227 | (case (char-upcase dchar) |
---|
228 | ((#\S) (push `(,%write ,(next) ,%out))) |
---|
229 | ((#\A) (push `(,%display ,(next) ,%out))) |
---|
230 | ((#\C) (push `(,%write-char ,(next) ,%out))) |
---|
231 | ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out))) |
---|
232 | ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out))) |
---|
233 | ((#\X) (push `(,%display (,%number->string ,(next) 16) ,%out))) |
---|
234 | ((#\!) (push `(##sys#flush-output ,%out))) |
---|
235 | ((#\?) |
---|
236 | (let* ([fstr (next)] |
---|
237 | [lst (next)] ) |
---|
238 | (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst)))) |
---|
239 | ((#\~) (push `(,write-char #\~ ,%out))) |
---|
240 | ((#\% #\N) (push `(,%write-char #\newline ,%out))) |
---|
241 | (else |
---|
242 | (if (char-whitespace? dchar) |
---|
243 | (let skip ((c (fetch))) |
---|
244 | (if (char-whitespace? c) |
---|
245 | (skip (fetch)) |
---|
246 | (set! index (sub1 index)))) |
---|
247 | (fail #t "illegal format-string character `~c'" dchar) ) ) ) |
---|
248 | (loop '()) ) |
---|
249 | (loop (cons c chunk))))))))))))) |
---|