;;; "scamacr.scm" syntax-case macros for Scheme constructs
;;; Copyright (C) 1992 R. Kent Dybvig
;;;
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software
;;; is granted subject to the restriction that all copies made of this
;;; software must include this copyright notice in full.  This software
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER.

;;; Written by Robert Hieb & Kent Dybvig

;;; This file was munged by a simple minded sed script since it left
;;; its original authors' hands.  See syncase.sh for the horrid details.

;;; macro-defs.ss
;;; Robert Hieb & Kent Dybvig
;;; 92/06/18

(define-syntax with-syntax
   (lambda (x)
      (syntax-case x ()
         ((_ () e1 e2 ...)
          (syntax (begin e1 e2 ...)))
         ((_ ((out in)) e1 e2 ...)
          (syntax (syntax-case in () (out (begin e1 e2 ...)))))
         ((_ ((out in) ...) e1 e2 ...)
          (syntax (syntax-case (list in ...) ()
                     ((out ...) (begin e1 e2 ...))))))))

(define-syntax syntax-rules
   (lambda (x)
      (syntax-case x ()
         ((_ (k ...) ((keyword . pattern) template) ...)
          (with-syntax (((dummy ...)
                         (generate-temporaries (syntax (keyword ...)))))
             (syntax (lambda (x)
                        (syntax-case x (k ...)
                           ((dummy . pattern) (syntax template))
                           ...))))))))

(define-syntax or
   (lambda (x)
      (syntax-case x ()
         ((_) (syntax #f))
         ((_ e) (syntax e))
         ((_ e1 e2 e3 ...)
          (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))

(define-syntax and
   (lambda (x)
      (syntax-case x ()
         ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
         ((_ e) (syntax e))
         ((_) (syntax #t)))))

(define-syntax cond
   (lambda (x)
      (syntax-case x (else =>)
         ((_ (else e1 e2 ...))
          (syntax (begin e1 e2 ...)))
         ((_ (e0))
          (syntax (let ((t e0)) (if t t))))
         ((_ (e0) c1 c2 ...)
          (syntax (let ((t e0)) (if t t (cond c1 c2 ...)))))
         ((_ (e0 => e1)) (syntax (let ((t e0)) (if t (e1 t)))))
         ((_ (e0 => e1) c1 c2 ...)
          (syntax (let ((t e0)) (if t (e1 t) (cond c1 c2 ...)))))
         ((_ (e0 e1 e2 ...)) (syntax (if e0 (begin e1 e2 ...))))
         ((_ (e0 e1 e2 ...) c1 c2 ...)
          (syntax (if e0 (begin e1 e2 ...) (cond c1 c2 ...)))))))

(define-syntax let*
   (lambda (x)
      (syntax-case x ()
         ((let* () e1 e2 ...)
          (syntax (let () e1 e2 ...)))
         ((let* ((x1 v1) (x2 v2) ...) e1 e2 ...)
          (comlist:every identifier? (syntax (x1 x2 ...)))
          (syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...)))))))

(define-syntax case
   (lambda (x)
      (syntax-case x (else)
         ((_ v (else e1 e2 ...))
          (syntax (begin v e1 e2 ...)))
         ((_ v ((k ...) e1 e2 ...))
          (syntax (if (memv v '(k ...)) (begin e1 e2 ...))))
         ((_ v ((k ...) e1 e2 ...) c1 c2 ...)
          (syntax (let ((x v))
                     (if (memv x '(k ...))
                         (begin e1 e2 ...)
                         (case x c1 c2 ...))))))))

(define-syntax do
   (lambda (orig-x)
      (syntax-case orig-x ()
         ((_ ((var init . step) ...) (e0 e1 ...) c ...)
          (with-syntax (((step ...)
                         (map (lambda (v s)
                                 (syntax-case s ()
                                    (() v)
                                    ((e) (syntax e))
                                    (_ (syntax-error orig-x))))
                              (syntax (var ...))
                              (syntax (step ...)))))
             (syntax-case (syntax (e1 ...)) ()
                (() (syntax (let doloop ((var init) ...)
                               (if (not e0)
                                   (begin c ... (doloop step ...))))))
                ((e1 e2 ...)
                 (syntax (let doloop ((var init) ...)
                            (if e0
                                (begin e1 e2 ...)
                                (begin c ... (doloop step ...))))))))))))

(define-syntax quasiquote
   (letrec
      ((gen-cons
        (lambda (x y)
           (syntax-case x (quote)
              ((quote x)
               (syntax-case y (quote list)
                  ((quote y) (syntax (quote (x . y))))
                  ((list y ...) (syntax (list (quote x) y ...)))
                  (y (syntax (cons (quote x) y)))))
              (x (syntax-case y (quote list)
                   ((quote ()) (syntax (list x)))
                   ((list y ...) (syntax (list x y ...)))
                   (y (syntax (cons x y))))))))

       (gen-append
        (lambda (x y)
           (syntax-case x (quote list cons)
              ((quote (x1 x2 ...))
               (syntax-case y (quote)
                  ((quote y) (syntax (quote (x1 x2 ... . y))))
                  (y (syntax (append (quote (x1 x2 ...) y))))))
              ((quote ()) y)
              ((list x1 x2 ...)
               (gen-cons (syntax x1) (gen-append (syntax (list x2 ...)) y)))
              (x (syntax-case y (quote list)
                   ((quote ()) (syntax x))
                   (y (syntax (append x y))))))))

       (gen-vector
        (lambda (x)
           (syntax-case x (quote list)
              ((quote (x ...)) (syntax (quote #(x ...))))
              ((list x ...) (syntax (vector x ...)))
              (x (syntax (list->vector x))))))

       (gen
        (lambda (p lev)
           (syntax-case p (unquote unquote-splicing quasiquote)
              ((unquote p)
               (if (= lev 0)
                   (syntax p)
                   (gen-cons (syntax (quote unquote))
                             (gen (syntax (p)) (- lev 1)))))
              (((unquote-splicing p) . q)
               (if (= lev 0)
                   (gen-append (syntax p) (gen (syntax q) lev))
                   (gen-cons (gen-cons (syntax (quote unquote-splicing))
                                       (gen (syntax p) (- lev 1)))
                             (gen (syntax q) lev))))
              ((quasiquote p)
               (gen-cons (syntax (quote quasiquote))
                         (gen (syntax (p)) (+ lev 1))))
              ((p . q)
               (gen-cons (gen (syntax p) lev) (gen (syntax q) lev)))
              (#(x ...) (gen-vector (gen (syntax (x ...)) lev)))
              (p (syntax (quote p)))))))

    (lambda (x)
       (syntax-case x ()
          ((- e) (gen (syntax e) 0))))))

