;;; crunch-syntax.scm - extended macro definitions
;
; Copyright (c) 2007-2009, Felix L. Winkelmann
; 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.
;
; Send bugs, suggestions and ideas to: 
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Unter den Gleichen 1
; 37130 Gleichen
; Germany


;; Taken from Olegs prelude, IIRC:

(define-syntax crunch:cond-expand-feature
  (syntax-rules ()
    ((_ x kt kf) kf)))

(define-syntax cond-expand
  (letrec-syntax ((cond-expand-2
		   (syntax-rules (crunch srfi-0 highlevel-macros syntax-rules)
		     ((_ crunch kt kf) kt)
		     ((_ srfi-0 kt kf) kt)
		     ((_ highlevel-macros kt kf) kt)
		     ((_ syntax-rules kt kf) kt)
		     ((_ x kt kf) (crunch:cond-expand-feature x kt kf)))) )
    (syntax-rules (else and or not)
      ((cond-expand)
       (let ()))
      ((cond-expand (else . cmd-or-defs*))
       (begin . cmd-or-defs*))
      ((cond-expand "satisfies?" (and) kt kf) kt)
      ((cond-expand "satisfies?" (and clause) kt kf)
       (cond-expand "satisfies?" clause kt kf))
      ((cond-expand "satisfies?" (and clause . rest) kt kf)
       (cond-expand "satisfies?" clause
		    (cond-expand "satisfies?" (and . rest) kt kf) kf))
      ((cond-expand "satisfies?" (or) kt kf) kf)
      ((cond-expand "satisfies?" (or clause) kt kf)
       (cond-expand "satisfies?" clause kt kf))
      ((cond-expand "satisfies?" (or clause . rest) kt kf)
       (cond-expand "satisfies?" clause kt
		    (cond-expand "satisfies?" (or . rest) kt kf)))
      ((cond-expand "satisfies?" (not clause) kt kf)
       (cond-expand "satisfies?" clause kf kt))
      ((cond-expand "satisfies?" x kt kf)
       (cond-expand-2 x kt kf))
      ((cond-expand (feature-req . cmd-or-defs*) . rest-clauses)
       (cond-expand "satisfies?" feature-req
		    (begin . cmd-or-defs*)
		    (cond-expand . rest-clauses))))))

(define-syntax when
  (syntax-rules ()
    [(_ x y z ...) (if x (begin y z ...))] ) )

(define-syntax unless
  (syntax-rules ()
    [(_ x y z ...) (if x (##core#undefined) (begin y z ...))] ) )

(define-syntax switch
  (syntax-rules (else)
    ((_ v (else e1 e2 ...))
     (begin e1 e2 ...))
    ((_ v (k e1 e2 ...))
     (let ((x v))
       (if (eqv? x k) (begin e1 e2 ...)) ) )
    ((_ v (k e1 e2 ...) c1 c2 ...)
     (let ((x v))
       (if (eqv? x k)
	   (begin e1 e2 ...)
	   (switch x c1 c2 ...))))))

(define-syntax rec
  (syntax-rules ()
    ((rec (NAME . VARIABLES) . BODY)
     (letrec ( (NAME (lambda VARIABLES . BODY)) ) NAME))
    ((rec NAME EXPRESSION)
     (letrec ( (NAME EXPRESSION) ) NAME))))