;;; "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 ...)
(syncase:andmap 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))))))