summaryrefslogtreecommitdiffstats
path: root/scamacr.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scamacr.scm')
-rw-r--r--scamacr.scm181
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))))))
+