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