Import Upstream version 2a6upstream/2a6

1 files changed, 181 insertions, 0 deletions

diff --git a/scamacr.scm b/scamacr.scm
new file mode 100644
index 0000000..016d7fb
--- /dev/null
+++ b/scamacr.scm
@@ -0,0 +1,181 @@
+;;; "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))))))
+