chicken-more-macros.scm

Scheme跨平台编译器

;;;; chicken-more-macros.scm - More syntax extensions
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(##sys#provide 'chicken-more-macros)


;;; Non-standard macros:

(##sys#register-macro 
 'define-record
 (let ((symbol->string symbol->string)
       (string->symbol string->symbol)
       (string-append string-append) )
   (lambda (name . slots)
     (##sys#check-syntax 'define-record name 'symbol)
     (##sys#check-syntax 'define-record slots '#(symbol 0))
     (let ([prefix (symbol->string name)]
	   [setters (memq #:record-setters ##sys#features)]
	   [nsprefix (##sys#qualified-symbol-prefix name)] )
       `(begin
	  (define ,(##sys#string->qualified-symbol nsprefix (string-append "make-" prefix))
	    (lambda ,slots (##sys#make-structure ',name ,@slots)) )
	  (define ,(##sys#string->qualified-symbol nsprefix (string-append prefix "?"))
	    (lambda (x) (##sys#structure? x ',name)) )
	  ,@(let mapslots ((slots slots) (i 1))
	      (if (eq? slots '())
		  slots
		  (let* ((slotname (symbol->string (##sys#slot slots 0)))
			 (setr (##sys#string->qualified-symbol nsprefix (string-append prefix "-" slotname "-set!")))
			 (getr (##sys#string->qualified-symbol nsprefix (string-append prefix "-" slotname)) ) )
		    (cons
		     `(begin
			(define ,setr
			  (lambda (x val)
			    (##core#check (##sys#check-structure x ',name))
			    (##sys#block-set! x ,i val) ) )
			(define ,getr
			  ,(if setters
			       `(getter-with-setter
				 (lambda (x) 
				   (##core#check (##sys#check-structure x ',name))
				   (##sys#block-ref x ,i) )
				 ,setr)
			       `(lambda (x)
				  (##core#check (##sys#check-structure x ',name))
				  (##sys#block-ref x ,i) ) ) ) )
		     (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )

(##sys#register-macro
 'receive
 (lambda (vars . rest)
   (if (null? rest)
       `(##sys#call-with-values (lambda () ,vars) ##sys#list)
       (begin
	 (##sys#check-syntax 'receive vars 'lambda-list)
	 (##sys#check-syntax 'receive rest '(_ . _))
	 (if (and (pair? vars) (null? (cdr vars)))
	     `(let ((,(car vars) ,(car rest)))
		,@(cdr rest))
	     `(##sys#call-with-values 
	       (lambda () ,(car rest))
	       (lambda ,vars ,@(cdr rest)) ) ) ) ) ) )

(##sys#register-macro
 'time 
 (let ((gensym gensym))
   (lambda exps
     (let ((rvar (gensym 't)))
       `(begin
	  (##sys#start-timer)
	  (##sys#call-with-values 
	   (lambda () ,@exps)
	   (lambda ,rvar
	     (##sys#display-times (##sys#stop-timer))
	     (##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) )

(##sys#register-macro
 'declare
 (lambda specs 
   `(##core#declare ,@(##sys#map (lambda (x) `(quote ,x)) specs)) ) ); hides specifiers from macroexpand

(##sys#register-macro
 'include
 (let ([with-input-from-file with-input-from-file]
       [read read]
       [reverse reverse] )
   (lambda (filename)
     (let ((path (##sys#resolve-include-filename filename #t)))
       (when (load-verbose) (print "; including " path " ..."))
       `(begin
	  ,@(with-input-from-file path
	      (lambda ()
		(fluid-let ((##sys#current-source-filename path))
		  (do ([x (read) (read)]
		       [xs '() (cons x xs)] )
		      ((eof-object? x) 
		       (reverse xs))) ) ) ) ) ) ) ) )

(##sys#register-macro
 'assert
 (lambda (exp . msg-and-args)
   (let ((msg (if (eq? '() msg-and-args)
		  `(##core#immutable '"assertion failed")
		  (##sys#slot msg-and-args 0) ) ) )
     `(if (##core#check ,exp)
	  (##core#undefined)
	  (##sys#error ,msg ',exp ,@(if (fx> (length msg-and-args) 1)
				  (##sys#slot msg-and-args 1)
				  '() ) ) ) ) ) )

(##sys#register-macro
 'ensure
 (lambda (pred exp . args)
   (let ([tmp (gensym)])
     `(let ([,tmp ,exp])
	(if (##core#check (,pred ,tmp))
	    ,tmp
	    (##sys#signal-hook
	     #:type-error
	     ,@(if (pair? args)
		   args
		   `((##core#immutable '"argument has incorrect type") ,tmp ',pred) ) ) ) ) ) ) )

(##sys#register-macro
 'fluid-let
 (let ((gensym gensym))
   (lambda (clauses . body)
     (##sys#check-syntax 'fluid-let clauses '#((symbol _) 0))
     (let ((ids (##sys#map car clauses))
	   (new-tmps (##sys#map (lambda (x) (gensym)) clauses))
	   (old-tmps (##sys#map (lambda (x) (gensym)) clauses)))
       `(let (,@(map ##sys#list new-tmps (##sys#map cadr clauses))
	      ,@(map ##sys#list old-tmps
		     (let loop ((n (length clauses)))
		       (if (eq? n 0)
			   '()
			   (cons #f (loop (fx- n 1))) ) ) ) )
	  (##sys#dynamic-wind
	      (lambda ()
		,@(map (lambda (ot id) `(##core#set! ,ot ,id))
		       old-tmps ids)
		,@(map (lambda (id nt) `(##core#set! ,id ,nt))
		       ids new-tmps)
		(##sys#void) )
	      (lambda () ,@body)
	      (lambda ()
		,@(map (lambda (nt id) `(##core#set! ,nt ,id))
		       new-tmps ids)
		,@(map (lambda (id ot) `(##core#set! ,id ,ot))
		       ids old-tmps)
		(##sys#void) ) ) ) ) ) ) )

(##sys#register-macro
 'eval-when
 (lambda (situations . body)
   (let ([e #f]
	 [c #f]
	 [l #f] 
	 [body `(begin ,@body)] )
     (let loop ([ss situations])
       (if (pair? ss)
	   (begin
	     (case (##sys#slot ss 0)
	       [(eval) (set! e #t)]
	       [(load run-time) (set! l #t)]
	       [(compile compile-time) (set! c #t)]
	       [else (##sys#error "invalid situation specifier" (##sys#slot ss 0))] )
	     (loop (##sys#slot ss 1)) ) ) )
     (if (memq '#:compiling ##sys#features)
	 (cond [(and c l) `(##core#compiletimetoo ,body)]
	       [c `(##core#compiletimeonly ,body)]
	       [l body]
	       [else '(##core#undefined)] )
	 (if e 
	     body
	     '(##core#undefined) ) ) ) ) )

(##sys#register-macro
 'parameterize 
 (let ([car car]
       [cadr cadr] 
       [map map] )
   (lambda (bindings . body)
     (##sys#check-syntax 'parameterize bindings '#((_ _) 0))
     (let* ([swap (gensym)]
	    [params (##sys#map car bindings)]
	    [vals (##sys#map cadr bindings)]
	    [aliases (##sys#map (lambda (z) (gensym)) params)]
	    [aliases2 (##sys#map (lambda (z) (gensym)) params)] )
       `(let ,(##sys#append (map ##sys#list aliases params) (map ##sys#list aliases2 vals))
	  (let ((,swap (lambda ()
			 ,@(map (lambda (a a2) `(let ((t (,a))) (,a ,a2) (##core#set! ,a2 t)))
				aliases aliases2) ) ) )
	    (##sys#dynamic-wind 
		,swap
		(lambda () ,@body)
		,swap) ) ) ) ) ) )

(##sys#register-macro
 'when
 (lambda (test . body)
   `(if ,test (begin ,@body)) ) )

(##sys#register-macro
 'unless
 (lambda (test . body)
   `(if ,test (##core#undefined) (begin ,@body)) ) )

(let* ((map map)
       (assign
	(lambda (vars exp)
	  (##sys#check-syntax 'set!-values/define-values vars '#(symbol 0))
	  (cond ((null? vars)
		 ;; may this be simply "exp"?
		 `(##sys#call-with-values (lambda () ,exp) (lambda () (##core#undefined))) )
		((null? (cdr vars))
		 `(##core#set! ,(car vars) ,exp)) 
		(else
		 (let ([aliases (map gensym vars)])
		   `(##sys#call-with-values
		     (lambda () ,exp)
		     (lambda ,aliases
		       ,@(map (lambda (v a) `(##core#set! ,v ,a)) vars aliases) ) ) ) ) ) ) ) )
  (##sys#register-macro 'set!-values assign)
  (##sys#register-macro 'define-values assign) )

(##sys#register-macro-2
 'let-values
 (letrec ((append* (lambda (il l)
		      (if (not (pair? il))
			  (cons il l)
			  (cons (car il)
				(append* (cdr il) l)))))
	    (map* (lambda (proc l)
		    (cond ((null? l) '())
			  ((not (pair? l)) (proc l))
			  (else (cons (proc (car l)) (map* proc (cdr l))))))))
   (lambda (form)
     (##sys#check-syntax 'let-values form '(#(_ 0) . #(_ 1)))
     (let* ([vbindings (car form)]
	    [body (cdr form)]
	    [llists (map car vbindings)]
	    [vars (let loop ((llists llists) (acc '()))
		    (if (null? llists)
			acc
			(let* ((llist (car llists))
			       (new-acc
				(cond ((list? llist) (append llist acc))
				      ((pair? llist) (append* llist acc))
				      (else (cons llist acc)))))
			  (loop (cdr llists) new-acc))))]
	    [aliases (map (lambda (v) (cons v (gensym v))) vars)]
	    [lookup (lambda (v) (cdr (assq v aliases)))]
	    [llists2 (let loop ((llists llists) (acc '()))
		       (if (null? llists)
			   (reverse acc)
			   (let* ((llist (car llists))
				  (new-acc
				   (cond ((not (pair? llist)) (cons (lookup llist) acc))
					 (else (cons (map* lookup llist) acc)))))
			     (loop (cdr llists) new-acc))))])
       (let fold ([llists llists]
		  [exps (map (lambda (x) (cadr x)) vbindings)]
		  [llists2 llists2] )
	 (cond ((null? llists)
		`(let ,(map (lambda (v) (##sys#list v (lookup v))) vars) ,@body) )
	       ((and (pair? (car llists2)) (null? (cdar llists2)))
		`(let ((,(caar llists2) ,(car exps)))
		   ,(fold (cdr llists) (cdr exps) (cdr llists2)) ) )
	       (else
		`(##sys#call-with-values
		  (lambda () ,(car exps))
		  (lambda ,(car llists2) ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) ) )

(##sys#register-macro-2
 'let*-values
 (lambda (form)
   (##sys#check-syntax 'let*-values form '(#(_ 0) . #(_ 1)))
   (let ([vbindings (car form)]
	 [body (cdr form)] )
     (let fold ([vbindings vbindings])
       (if (null? vbindings)
	   `(let () ,@body)
	   `(let-values (,(car vbindings))
	      ,(fold (cdr vbindings))) ) ) ) ) )

(##sys#register-macro-2 
 'letrec-values
 (lambda (form)
   (##sys#check-syntax 'letrec-values form '(#(_ 0) . #(_ 1)))
   (let* ([vbindings (car form)]
	  [body (cdr form)] 
	  [vars (apply ##sys#append (map (lambda (x) (car x)) vbindings))] 
	  [aliases (map (lambda (v) (cons v (gensym v))) vars)] 
	  [lookup (lambda (v) (cdr (assq v aliases)))] )
     `(let ,(map (lambda (v) (##sys#list v '(##core#undefined))) vars)
	,@(map (lambda (vb)
		 `(##sys#call-with-values (lambda () ,(cadr vb))
		    (lambda ,(map lookup (car vb))
		      ,@(map (lambda (v) `(##core#set! ,v ,(lookup v))) (car vb)) ) ) )
	       vbindings)
	,@body) ) ) )

(##sys#register-macro
 'nth-value
 (lambda (i exp)
   (let ([v (gensym)])
     `(##sys#call-with-values
       (lambda () ,exp)
       (lambda ,v (list-ref ,v ,i)) ) ) ) )

(letrec ([quotify-proc 
           (lambda (xs id)
	     (##sys#check-syntax id xs '#(_ 1))
             (let* ([head (car xs)]
                    [name (if (pair? head) (car head) head)]
                    [val (if (pair? head)
                           `(lambda ,(cdr head) ,@(cdr xs))
                           (cadr xs) ) ] )
	       (when (or (not (pair? val)) (not (eq? 'lambda (car val))))
		 (syntax-error 'define-inline "invalid substitution form - must be lambda"
			       name) )
               (list (list 'quote name) val) ) ) ] )
  (##sys#register-macro-2 
   'define-inline
   (lambda (form) `(##core#define-inline ,@(quotify-proc form 'define-inline)))) )

(##sys#register-macro-2
 'define-constant
 (lambda (form)
   (##sys#check-syntax 'define-constant form '(symbol _))
   `(##core#define-constant ',(car form) ,(cadr form)) ) )

(##sys#register-macro-2
 'and-let*
   (lambda (forms)
     (##sys#check-syntax 'and-let* forms '(#(_ 0) . #(_ 1)))
     (if (or (not (list? forms)) (fx< (length forms) 2))
	 (##sys#syntax-error-hook "syntax error in 'and-let*' form" forms) 
	 (let ([bindings (##sys#slot forms 0)]
	       [body (##sys#slot forms 1)] )
	   (let fold ([bs bindings])
	     (if (null? bs)
		 `(begin ,@body)
		 (let ([b (##sys#slot bs 0)]
		       [bs2 (##sys#slot bs 1)] )
		   (cond [(not-pair? b) `(if ,b ,(fold bs2) #f)]
			 [(null? (##sys#slot b 1)) `(if ,(##sys#slot b 0) ,(fold bs2) #f)]
			 [else
			  (let ([var (##sys#slot b 0)])
			    `(let ((,var ,(cadr b)))
			       (if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) )

(##sys#register-macro-2
 'select
 (let ((gensym gensym))
   (lambda (form)
     (let ((exp (car form))
	   (body (cdr form)) )
       (let ((tmp (gensym)))
	 `(let ((,tmp ,exp))
	    ,(let expand ((clauses body))
	       (if (not (pair? clauses))
		   '(##core#undefined)
		   (let ((clause (##sys#slot clauses 0))
			 (rclauses (##sys#slot clauses 1)) )
		     (##sys#check-syntax 'select clause '#(_ 1))
		     (if (eq? 'else (car clause))
			 `(begin ,@(cdr clause))
			 `(if (or ,@(map (lambda (x) `(eqv? ,tmp ,x)) 
					 (car clause) ) )
			      (begin ,@(cdr clause)) 
			      ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )

(##sys#register-macro-2			; DEPRECATED
 'switch
 (let ((gensym gensym))
   (lambda (form)
     (let ((exp (car form))
	   (body (cdr form)) )
       (let ((tmp (gensym)))
	 `(let ((,tmp ,exp))
	    ,(let expand ((clauses body))
	       (if (not (pair? clauses))
		   '(##core#undefined)
		   (let ((clause (##sys#slot clauses 0))
			 (rclauses (##sys#slot clauses 1)) )
		     (##sys#check-syntax 'switch clause '#(_ 1))
		     (if (eq? 'else (car clause))
			 `(begin ,@(cdr clause))
			 `(if (eqv? ,tmp ,(car clause))
			      (begin ,@(cdr clause)) 
			      ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )


;;; Optional argument handling:

;;; Copyright (C) 1996 by Olin Shivers.
;;;
;;; This file defines three macros for parsing optional arguments to procs:
;;; 	(LET-OPTIONALS  arg-list ((var1 default1) ...) . body)
;;; 	(LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
;;; 	(:OPTIONAL rest-arg default-exp)
;;;
;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
;;; explicit-renaming low-level macro system. You'll have to do some work to
;;; port it to another macro system.
;;;
;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
;;; high-level macros, and should be portable to any R4RS system.
;;;
;;; These macros are all careful to evaluate their default forms *only* if
;;; their values are needed.
;;;
;;; The only non-R4RS dependencies in the macros are ERROR 
;;; and CALL-WITH-VALUES.
;;; 	-Olin