~ chicken-core (chicken-5) /compiler-syntax.scm

  1;;;; compiler-syntax.scm - compiler syntax used internally
  2;
  3; Copyright (c) 2009-2022, 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  (uses expand extras support compiler))
 30
 31(module chicken.compiler.compiler-syntax
 32    (compiler-syntax-statistics)
 33
 34(import scheme
 35	chicken.base
 36	chicken.compiler.support
 37	chicken.compiler.core
 38	chicken.fixnum
 39	chicken.format
 40	chicken.syntax)
 41
 42(include "tweaks.scm")
 43(include "mini-srfi-1.scm")
 44
 45
 46;;; Compiler macros (that operate in the expansion phase)
 47
 48(define compiler-syntax-statistics '())
 49
 50(set! ##sys#compiler-syntax-hook
 51  (lambda (name result)
 52    (let ((a (alist-ref name compiler-syntax-statistics eq? 0)))
 53      (set! compiler-syntax-statistics
 54	(alist-update! name (add1 a) compiler-syntax-statistics)))))
 55
 56(define (r-c-s names transformer se)
 57  (let ((t (cons (##sys#ensure-transformer
 58		  (##sys#er-transformer transformer)
 59		  (car names))
 60		 (append se ##sys#default-macro-environment))))
 61    (for-each
 62     (lambda (name)
 63       (##sys#put! name '##compiler#compiler-syntax t) )
 64     names) ) )
 65
 66(define-syntax define-internal-compiler-syntax
 67  (syntax-rules ()
 68    ((_ (names . llist) se . body)
 69     (r-c-s 'names (lambda llist . body) se))))
 70
 71(define-internal-compiler-syntax ((scheme#for-each ##sys#for-each) x r c)
 72  '((pair? . scheme#pair?))
 73  (let ((%let (r 'let))
 74	(%if (r 'if))
 75	(%loop (r 'for-each-loop))
 76	(%proc (gensym))
 77	(%begin (r 'begin))
 78	(%quote (r 'quote))
 79	(%and (r 'and))
 80	(%pair? (r 'pair?))
 81	(%lambda (r 'lambda))
 82	(lsts (cddr x)))
 83    (if (and (memq 'scheme#for-each standard-bindings) ; we have to check this because the db (and thus 
 84	     (> (length+ x) 2))			 ; intrinsic marks) isn't set up yet
 85	(let ((vars (map (lambda _ (gensym)) lsts)))
 86	  `(,%let ((,%proc ,(cadr x))
 87		   ,@(map list vars lsts))
 88		  ,@(map (lambda (var)
 89			   `(##core#check (##sys#check-list ,var (,%quote for-each))))
 90			 vars)
 91		  (,%let ,%loop ,(map list vars vars)
 92			 (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars))
 93			       (,%begin
 94				(,%proc
 95				 ,@(map (lambda (v) `(##sys#slot ,v 0)) vars))
 96				(##core#app 
 97				 ,%loop
 98				 ,@(map (lambda (v) `(##sys#slot ,v 1)) vars) ) )))))
 99	x)))
100
101(define-internal-compiler-syntax ((scheme#map ##sys#map) x r c)
102  '((pair? . scheme#pair?) (cons . scheme#cons))
103  (let ((%let (r 'let))
104	(%if (r 'if))
105	(%loop (r 'map-loop))
106	(%res (gensym))
107	(%cons (r 'cons))
108	(%set! (r 'set!))
109	(%result (gensym))
110	(%node (gensym))
111	(%proc (gensym))
112	(%quote (r 'quote))
113	(%begin (r 'begin))
114	(%lambda (r 'lambda))
115	(%and (r 'and))
116	(%pair? (r 'pair?))
117	(lsts (cddr x)))
118    (if (and (memq 'scheme#map standard-bindings) ; s.a.
119	     (> (length+ x) 2))
120	(let ((vars (map (lambda _ (gensym)) lsts)))
121	  `(,%let ((,%node (,%cons (##core#undefined) (,%quote ()))))
122	     (,%let ((,%result ,%node)
123		     (,%proc ,(cadr x))
124		     ,@(map list vars lsts))
125		    ,@(map (lambda (var)
126			     `(##core#check (##sys#check-list ,var (,%quote map))))
127			   vars)
128	       (,%let ,%loop ,(map list vars vars)
129		 (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars))
130		       (,%let ((,%res
131				(,%cons
132				 (,%proc
133				  ,@(map (lambda (v) `(##sys#slot ,v 0)) vars))
134				 (,%quote ()))))
135			      (##sys#setslot ,%node 1 ,%res)
136			      (,%set! ,%node ,%res)
137			      (##core#app
138			       ,%loop
139			       ,@(map (lambda (v) `(##sys#slot ,v 1)) vars)))
140		       (##sys#slot ,%result 1))))))
141	x)))
142
143(define-internal-compiler-syntax ((chicken.base#o) x r c) '()
144  (if (and (fx> (length x) 1)
145	   (memq 'chicken.base#o extended-bindings)) ; s.a.
146      (let ((%tmp (r 'tmp)))
147	`(,(r 'lambda) (,%tmp) ,(foldr list %tmp (cdr x))))
148      x))
149
150(define-internal-compiler-syntax ((chicken.format#sprintf chicken.format#format) x r c)
151  `((display . scheme#display)
152    (write . scheme#write)
153    (number->string . scheme#number->string)
154    (write-char . scheme#write-char)
155    (open-output-string . chicken.base#open-output-string)
156    (get-output-string . chicken.base#get-output-string))
157  (let* ((out (gensym 'out))
158	 (code (compile-format-string
159		(if (eq? (car x) 'chicken.format#sprintf) 'sprintf 'format)
160		out x (cdr x) r c)))
161    (if code
162	`(,(r 'let) ((,out (,(r 'open-output-string))))
163	  ,code
164	  (,(r 'get-output-string) ,out))
165	x)))
166
167(define-internal-compiler-syntax ((chicken.format#fprintf) x r c)
168  '((display . scheme#display)
169    (write . scheme#write)
170    (number->string . scheme#number->string)
171    (write-char . scheme#write-char)
172    (open-output-string . chicken.base#open-output-string)
173    (get-output-string . chicken.base#get-output-string))
174  (if (>= (length x) 3)
175      (let ((code (compile-format-string 'fprintf (cadr x) x (cddr x) r c)))
176	(or code x))
177      x))
178
179(define-internal-compiler-syntax ((chicken.format#printf) x r c)
180  '((display . scheme#display)
181    (write . scheme#write)
182    (number->string . scheme#number->string)
183    (write-char . scheme#write-char)
184    (open-output-string . chicken.base#open-output-string)
185    (get-output-string . chicken.base#get-output-string))
186  (let ((code (compile-format-string 'printf '##sys#standard-output x (cdr x) r c)))
187    (or code x)))
188
189(define (compile-format-string func out x args r c)
190  (call/cc
191   (lambda (return)
192     (and (>= (length args) 1)
193	  (memq (symbol-append 'chicken.format# func) extended-bindings) ; s.a.
194	  (or (string? (car args))
195	      (and (list? (car args))
196		   (c (r 'quote) (caar args))
197		   (string? (cadar args))))
198	  (let ((fstr (if (string? (car args)) (car args) (cadar args)))
199		(args (cdr args)))
200	    (define (fail ret? msg . args)
201	      (let ((ln (get-line-number x)))
202		(warning 
203		 (sprintf "~a`~a', in format string ~s, ~?" 
204		   (if ln (sprintf "(~a) " ln) "")
205		   func fstr 
206		   msg args) ))
207	      (when ret? (return #f)))
208	    (let ((code '())
209		  (index 0)
210		  (len (string-length fstr)) 
211		  (%out (r 'out))
212		  (%let (r 'let))
213		  (%number->string (r 'number->string)))
214	      (define (fetch)
215		(let ((c (string-ref fstr index)))
216		  (set! index (fx+ index 1))
217		  c) )
218	      (define (next)
219		(if (null? args)
220		    (fail #t "too few arguments to formatted output procedure")
221		    (let ((x (car args)))
222		      (set! args (cdr args))
223		      x) ) )
224	      (define (endchunk chunk)
225		(when (pair? chunk)
226		  (push 
227		   (if (= 1 (length chunk))
228		       `(##sys#write-char-0 ,(car chunk) ,%out)
229		       `(##sys#print ,(##sys#reverse-list->string chunk) #f ,%out)))))
230	      (define (push exp)
231		(set! code (cons exp code)))
232	      (let loop ((chunk '()))
233		(cond ((>= index len)
234		       (unless (null? args)
235			 (fail #f "too many arguments to formatted output procedure"))
236		       (endchunk chunk)
237		       `(,%let ((,%out ,out))
238			       (##sys#check-output-port ,%out #t ',func)
239			       ,@(reverse code)))
240		      (else
241		       (let ((c (fetch)))
242			 (if (eq? c #\~)
243			     (let ((dchar (fetch)))
244			       (endchunk chunk)
245			       (case (char-upcase dchar)
246				 ((#\S) (push `(##sys#print ,(next) #t ,%out)))
247				 ((#\A) (push `(##sys#print ,(next) #f ,%out)))
248				 ((#\C) (push `(##sys#write-char-0 ,(next) ,%out)))
249				 ((#\B)
250				  (push
251				   `(##sys#print (,%number->string ,(next) 2) 
252						  #f ,%out)))
253				 ((#\O)
254				  (push
255				   `(##sys#print (,%number->string ,(next) 8) 
256						 #f ,%out)))
257				 ((#\X)
258				  (push
259				   `(##sys#print (,%number->string ,(next) 16) 
260						 #f ,%out)))
261				 ((#\!) (push `(##sys#flush-output ,%out)))
262				 ((#\?)
263				  (let* ([fstr (next)]
264					 [lst (next)] )
265				    (push `(##sys#apply chicken.format#fprintf ,%out ,fstr ,lst))))
266				 ((#\~) (push `(##sys#write-char-0 #\~ ,%out)))
267				 ((#\% #\N) (push `(##sys#write-char-0 #\newline ,%out)))
268				 (else
269				  (if (char-whitespace? dchar)
270				      (let skip ((c (fetch)))
271					(if (char-whitespace? c)
272					    (skip (fetch))
273					    (set! index (sub1 index))))
274				      (fail #t "illegal format-string character `~c'" dchar) ) ) )
275			       (loop '()) )
276			     (loop (cons c chunk)))))))))))))
277
278(define-internal-compiler-syntax ((chicken.base#foldr) x r c)
279  '((pair? . scheme#pair?))
280  (if (and (fx= (length x) 4)
281	   (memq 'chicken.base#foldr extended-bindings) ) ; s.a.
282      (let ((f (cadr x))
283	    (z (caddr x))
284	    (lst (cadddr x))
285	    (%let* (r 'let*))
286	    (%let (r 'let))
287	    (%pair? (r 'pair?))
288	    (%if (r 'if))
289	    (loopvar (gensym "foldr"))
290	    (lstvar (gensym)))
291	`(,%let* ((,lstvar ,lst))
292		 (##core#check (##sys#check-list ,lstvar (##core#quote foldr)))
293		 (,%let ,loopvar ((,lstvar ,lstvar))
294			(,%if (,%pair? ,lstvar)
295			      (,f (##sys#slot ,lstvar 0) 
296				     (##core#app ,loopvar (##sys#slot ,lstvar 1)))
297			      ,z))))
298      x))
299
300(define-internal-compiler-syntax ((chicken.base#foldl) x r c)
301  '((pair? . scheme#pair?))
302  (if (and (fx= (length x) 4)
303	   (memq 'chicken.base#foldl extended-bindings) ) ; s.a.
304      (let ((f (cadr x))
305	    (z (caddr x))
306	    (lst (cadddr x))
307	    (%let* (r 'let*))
308	    (%let (r 'let))
309	    (%if (r 'if))
310	    (%pair? (r 'pair?))
311	    (zvar (gensym))
312	    (loopvar (gensym "foldl"))
313	    (lstvar (gensym)))
314	`(,%let* ((,zvar ,z)
315		  (,lstvar ,lst))
316		 (##core#check (##sys#check-list ,lstvar (##core#quote foldl)))
317		 (,%let ,loopvar ((,lstvar ,lstvar) (,zvar ,zvar))
318			(,%if (,%pair? ,lstvar)
319			      (##core#app 
320			       ,loopvar
321			       (##sys#slot ,lstvar 1) 
322			       (,f ,zvar (##sys#slot ,lstvar 0)))
323			      ,zvar))))
324      x))
325)