diff options
Diffstat (limited to 'scamacr.scm')
| -rw-r--r-- | scamacr.scm | 181 |
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)))))) + |