mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

fixups to expand.scm

Browse source 
* module/language/scheme/expand.scm: Some changes to avoid unnecessary
  begins or empty lets, and properly handle internal defines (finally).
This commit is contained in:
Andy Wingo 2009-03-02 22:15:27 +01:00
parent 237f96e7f0
commit 07e01c4cf9
1 changed files with 16 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

31
module/language/scheme/expand.scm
View file

@ -172,6 +172,8 @@
(define-scheme-expander begin
;; (begin EXPS...)
((,single-exp)
(-> (re-expand single-exp)))
(,tail
(-> `(begin . ,(map re-expand tail)))))
@ -193,13 +195,16 @@
. ,body)))
(,name . ,(map acadr (aref bindings)))))))
((() . ,body)
(re-expand (expand-internal-defines body)))
;; (let ((SYM VAL) ...) BODY...)
((,bindings . ,body) (guard (valid-bindings? bindings))
(-> `(let ,(map (lambda (x)
;; nb, relies on -> non-hygiene
(-> `(,(acar x) ,(re-expand (acadr x)))))
(aref bindings))
. ,(map re-expand body)))))
,(expand-internal-defines (map re-expand body))))))
(define-scheme-expander let*
;; (let* ((SYM VAL) ...) BODY...)
@ -215,7 +220,7 @@
;; nb, relies on -> non-hygiene
(-> `(,(acar x) ,(re-expand (acadr x)))))
(aref bindings))
. ,(map re-expand body)))))
,(expand-internal-defines (map re-expand body))))))
(define-scheme-expander cond
;; (cond (CLAUSE BODY...) ...)
@ -260,7 +265,7 @@
(define-scheme-expander lambda
;; (lambda FORMALS BODY...)
((,formals . ,body)
(-> `(lambda ,formals . ,(map re-expand body)))))
(-> `(lambda ,formals ,(expand-internal-defines (map re-expand body))))))
(define-scheme-expander delay
;; FIXME not hygienic
@ -281,20 +286,16 @@
(-> `(,(acar x) . ,(map re-expand (acdr x)))))
clauses)))))
(define (trans-body e l body)
(define (define->binding df)
(amatch (cdr df)
((,name ,val) (guard (symbol? name)) (list name val))
(((,name . ,formals) . ,body) (guard (symbol? name))
(list name `(lambda ,formals ,@body)))
(else (syntax-error (location df) "bad define" df))))
;; main
;;; Hum, I don't think this takes imported modifications to `define'
;;; properly into account. (Lexical bindings are OK because of alpha
;;; renaming.)
(define (expand-internal-defines body)
(let loop ((ls body) (ds '()))
(amatch ls
(() (syntax-error l "bad body" body))
(((define . _) . _)
(loop (cdr ls) (cons (car ls) ds)))
(((define ,name ,val) . _)
(loop (acdr ls) (cons (list name val) ds)))
(else
(if (null? ds)
(translate-1 e l `(begin ,@ls))
(translate-1 e l `(letrec ,(map define->binding ds) ,@ls)))))))
(if (null? (cdr ls)) (car ls) `(begin ,@ls))
`(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls))))))))