mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 00:00:49 +02:00
100 lines
3 KiB
Scheme
100 lines
3 KiB
Scheme
;;;"defmacex.scm" defmacro:expand* for any Scheme dialect.
|
|
;;;Copyright 1993-1994 Dorai Sitaram and Aubrey Jaffer.
|
|
;
|
|
;Permission to copy this software, to redistribute it, and to use it
|
|
;for any purpose is granted, subject to the following restrictions and
|
|
;understandings.
|
|
;
|
|
;1. Any copy made of this software must include this copyright notice
|
|
;in full.
|
|
;
|
|
;2. I have made no warrantee or representation that the operation of
|
|
;this software will be error-free, and I am under no obligation to
|
|
;provide any services, by way of maintenance, update, or otherwise.
|
|
;
|
|
;3. In conjunction with products arising from the use of this
|
|
;material, there shall be no use of my name in any advertising,
|
|
;promotional, or sales literature without prior written consent in
|
|
;each case.
|
|
|
|
;;;expand thoroughly, not just topmost expression. While expanding
|
|
;;;subexpressions, the primitive forms quote, lambda, set!, let/*/rec,
|
|
;;;cond, case, do, quasiquote: need to be destructured properly. (if,
|
|
;;;and, or, begin: don't need special treatment.)
|
|
|
|
(define (defmacro:iqq e depth)
|
|
(letrec
|
|
((map1 (lambda (f x)
|
|
(if (pair? x) (cons (f (car x)) (map1 f (cdr x)))
|
|
x)))
|
|
(iqq (lambda (e depth)
|
|
(if (pair? e)
|
|
(case (car e)
|
|
((quasiquote) (list (car e) (iqq (cadr e) (+ 1 depth))))
|
|
((unquote unquote-splicing)
|
|
(list (car e) (if (= 1 depth)
|
|
(defmacro:expand* (cadr e))
|
|
(iqq (cadr e) (+ -1 depth)))))
|
|
(else (map1 (lambda (e) (iqq e depth)) e)))
|
|
e))))
|
|
(iqq e depth)))
|
|
|
|
(define (defmacro:expand* e)
|
|
(if (pair? e)
|
|
(let* ((c (macroexpand-1 e)))
|
|
(if (not (eq? e c))
|
|
(defmacro:expand* c)
|
|
(case (car e)
|
|
((quote) e)
|
|
((quasiquote) (defmacro:iqq e 0))
|
|
((lambda define set!)
|
|
(cons (car e) (cons (cadr e) (map defmacro:expand* (cddr e)))))
|
|
((let)
|
|
(let ((b (cadr e)))
|
|
(if (symbol? b) ;named let
|
|
`(let ,b
|
|
,(map (lambda (vv)
|
|
`(,(car vv)
|
|
,(defmacro:expand* (cadr vv))))
|
|
(caddr e))
|
|
,@(map defmacro:expand*
|
|
(cdddr e)))
|
|
`(let
|
|
,(map (lambda (vv)
|
|
`(,(car vv)
|
|
,(defmacro:expand* (cadr vv))))
|
|
b)
|
|
,@(map defmacro:expand*
|
|
(cddr e))))))
|
|
((let* letrec)
|
|
`(,(car e) ,(map (lambda (vv)
|
|
`(,(car vv)
|
|
,(defmacro:expand* (cadr vv))))
|
|
(cadr e))
|
|
,@(map defmacro:expand* (cddr e))))
|
|
((cond)
|
|
`(cond
|
|
,@(map (lambda (c)
|
|
(map defmacro:expand* c))
|
|
(cdr e))))
|
|
((case)
|
|
`(case ,(defmacro:expand* (cadr e))
|
|
,@(map (lambda (c)
|
|
`(,(car c)
|
|
,@(map defmacro:expand* (cdr c))))
|
|
(cddr e))))
|
|
((do)
|
|
`(do ,(map
|
|
(lambda (initsteps)
|
|
`(,(car initsteps)
|
|
,@(map defmacro:expand*
|
|
(cdr initsteps))))
|
|
(cadr e))
|
|
,(map defmacro:expand* (caddr e))
|
|
,@(map defmacro:expand* (cdddr e))))
|
|
((defmacro)
|
|
(cons (car e)
|
|
(cons (cadr e)
|
|
(cons (caddr e) (map defmacro:expand* (cdddr e))))))
|
|
(else (map defmacro:expand* e)))))
|
|
e))
|