mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 00:00:49 +02:00
181 lines
6.7 KiB
Scheme
181 lines
6.7 KiB
Scheme
;;; "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))))))
|
|
|