mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 12:20:20 +02:00
let-values in terms of syntax-case, add make-tree-il-folder
* module/language/tree-il.scm (tree-il-fold): Fix for let-values case. (make-tree-il-folder): New public macro, makes a multi-valued folder specific to the number of seeds that the user wants. * module/language/tree-il/optimize.scm (optimize!): Reverse the order of inline! and fix-letrec!, as the latter might expose opportunities for the former. * module/srfi/srfi-11.scm (let-values): Reimplement in terms of syntax-case, so that its expressions may reference hygienically bound variables. See the NEWS for the rationale. (let*-values): An empty let*-values still introduces a local `let' binding contour. * module/system/base/syntax.scm (record-case): Yukkkk. Reimplement in terms of syntax-case. Ug-ly, but see the NEWS again: "Lexical bindings introduced by hygienic macros may not be referenced by nonhygienic macros."
This commit is contained in:
Andy Wingo
parent
c21c89b138
commit
4dcd84998f
4 changed files with 194 additions and 189 deletions
|
|
@ -1,6 +1,6 @@
|
|||
;;; srfi-11.scm --- let-values and let*-values
|
||||
|
||||
;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
|
||||
;;
|
||||
;; This library is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -63,148 +63,55 @@
|
|||
;; (q <tmp-q>))
|
||||
;; (baz x y z p q))))))
|
||||
|
||||
;; I originally wrote this as a define-macro, but then I found out
|
||||
;; that guile's gensym/gentemp was broken, so I tried rewriting it as
|
||||
;; a syntax-rules statement.
|
||||
;; [make-symbol now fixes gensym/gentemp problems.]
|
||||
;;
|
||||
;; Since syntax-rules didn't seem powerful enough to implement
|
||||
;; let-values in one definition without exposing illegal syntax (or
|
||||
;; perhaps my brain's just not powerful enough :>). I tried writing
|
||||
;; it using a private helper, but that didn't work because the
|
||||
;; let-values expands outside the scope of this module. I wonder why
|
||||
;; syntax-rules wasn't designed to allow "private" patterns or
|
||||
;; similar...
|
||||
;;
|
||||
;; So in the end, I dumped the syntax-rules implementation, reproduced
|
||||
;; here for posterity, and went with the define-macro one below --
|
||||
;; gensym/gentemp's got to be fixed anyhow...
|
||||
;
|
||||
; (define-syntax let-values-helper
|
||||
; (syntax-rules ()
|
||||
; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
|
||||
; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
|
||||
; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
|
||||
; ;; temps you create so you can use them later...
|
||||
; ;;
|
||||
; ;; I really don't fully understand why the (var-1 var-1) trick
|
||||
; ;; works below, but basically, when all those (x x) bindings show
|
||||
; ;; up in the final "let", syntax-rules forces a renaming.
|
||||
|
||||
; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
|
||||
; body ...)
|
||||
; (lambda lambda-tmps
|
||||
; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
|
||||
|
||||
; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
|
||||
; body ...)
|
||||
; (let-values-helper "consumer"
|
||||
; (var-2 ...)
|
||||
; (lambda-tmp ... var-1)
|
||||
; ((var-1 var-1) . final-let-bindings)
|
||||
; lv-bindings
|
||||
; body ...))
|
||||
|
||||
; ((_ "cwv" () final-let-bindings body ...)
|
||||
; (let final-let-bindings
|
||||
; body ...))
|
||||
|
||||
; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
|
||||
; body ...)
|
||||
; (call-with-values (lambda () binding-1)
|
||||
; (let-values-helper "consumer"
|
||||
; vars-1
|
||||
; ()
|
||||
; final-let-bindings
|
||||
; (other-bindings ...)
|
||||
; body ...)))))
|
||||
;
|
||||
; (define-syntax let-values
|
||||
; (syntax-rules ()
|
||||
; ((let-values () body ...)
|
||||
; (begin body ...))
|
||||
; ((let-values (binding ...) body ...)
|
||||
; (let-values-helper "cwv" (binding ...) () body ...))))
|
||||
;
|
||||
;
|
||||
; (define-syntax let-values
|
||||
; (letrec-syntax ((build-consumer
|
||||
; ;; Take the vars from one let binding (i.e. the (x
|
||||
; ;; y z) from ((x y z) (values 1 2 3)) and turn it
|
||||
; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
|
||||
; ;; <tmp-z>) ...) from above.
|
||||
; (syntax-rules ()
|
||||
; ((_ () new-tmps tmp-vars () body ...)
|
||||
; (lambda new-tmps
|
||||
; body ...))
|
||||
; ((_ () new-tmps tmp-vars vars body ...)
|
||||
; (lambda new-tmps
|
||||
; (lv-builder vars tmp-vars body ...)))
|
||||
; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
|
||||
; (build-consumer (var-2 ...)
|
||||
; (tmp-1 . new-tmps)
|
||||
; ((var-1 tmp-1) . tmp-vars)
|
||||
; bindings
|
||||
; body ...))))
|
||||
; (lv-builder
|
||||
; (syntax-rules ()
|
||||
; ((_ () tmp-vars body ...)
|
||||
; (let tmp-vars
|
||||
; body ...))
|
||||
; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
|
||||
; tmp-vars
|
||||
; body ...)
|
||||
; (call-with-values (lambda () binding-1)
|
||||
; (build-consumer vars-1
|
||||
; ()
|
||||
; tmp-vars
|
||||
; ((vars-2 binding-2) ...)
|
||||
; body ...))))))
|
||||
;
|
||||
; (syntax-rules ()
|
||||
; ((_ () body ...)
|
||||
; (begin body ...))
|
||||
; ((_ ((vars binding) ...) body ...)
|
||||
; (lv-builder ((vars binding) ...) () body ...)))))
|
||||
|
||||
(define-macro (let-values vars . body)
|
||||
|
||||
(define (map-1-dot proc elts)
|
||||
;; map over one optionally dotted (a b c . d) list, producing an
|
||||
;; optionally dotted result.
|
||||
(cond
|
||||
((null? elts) '())
|
||||
((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
|
||||
(else (proc elts))))
|
||||
|
||||
(define (undot-list lst)
|
||||
;; produce a non-dotted list from a possibly dotted list.
|
||||
(cond
|
||||
((null? lst) '())
|
||||
((pair? lst) (cons (car lst) (undot-list (cdr lst))))
|
||||
(else (list lst))))
|
||||
|
||||
(define (let-values-helper vars body prev-let-vars)
|
||||
(let* ((var-binding (car vars))
|
||||
(new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
|
||||
(car var-binding)))
|
||||
(let-vars (map (lambda (sym tmp) (list sym tmp))
|
||||
(undot-list (car var-binding))
|
||||
(undot-list new-tmps))))
|
||||
|
||||
(if (null? (cdr vars))
|
||||
`(call-with-values (lambda () ,(cadr var-binding))
|
||||
(lambda ,new-tmps
|
||||
(let ,(apply append let-vars prev-let-vars)
|
||||
,@body)))
|
||||
`(call-with-values (lambda () ,(cadr var-binding))
|
||||
(lambda ,new-tmps
|
||||
,(let-values-helper (cdr vars) body
|
||||
(cons let-vars prev-let-vars)))))))
|
||||
|
||||
(if (null? vars)
|
||||
`(begin ,@body)
|
||||
(let-values-helper vars body '())))
|
||||
;; We could really use quasisyntax here...
|
||||
(define-syntax let-values
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ (clause ...) b0 b1 ...)
|
||||
(let lp ((clauses (syntax (clause ...)))
|
||||
(ids '())
|
||||
(tmps '()))
|
||||
(if (null? clauses)
|
||||
(with-syntax (((id ...) ids)
|
||||
((tmp ...) tmps))
|
||||
(syntax (let ((id tmp) ...)
|
||||
b0 b1 ...)))
|
||||
(syntax-case (car clauses) ()
|
||||
(((var ...) exp)
|
||||
(with-syntax (((new-tmp ...) (generate-temporaries
|
||||
(syntax (var ...))))
|
||||
((id ...) ids)
|
||||
((tmp ...) tmps))
|
||||
(with-syntax ((inner (lp (cdr clauses)
|
||||
(syntax (var ... id ...))
|
||||
(syntax (new-tmp ... tmp ...)))))
|
||||
(syntax (call-with-values (lambda () exp)
|
||||
(lambda (new-tmp ...) inner))))))
|
||||
((vars exp)
|
||||
(with-syntax ((((new-tmp . new-var) ...)
|
||||
(let lp ((vars (syntax vars)))
|
||||
(syntax-case vars ()
|
||||
((id . rest)
|
||||
(acons (syntax id)
|
||||
(car
|
||||
(generate-temporaries (syntax (id))))
|
||||
(lp (syntax rest))))
|
||||
(id (acons (syntax id)
|
||||
(car
|
||||
(generate-temporaries (syntax (id))))
|
||||
'())))))
|
||||
((id ...) ids)
|
||||
((tmp ...) tmps))
|
||||
(with-syntax ((inner (lp (cdr clauses)
|
||||
(syntax (new-var ... id ...))
|
||||
(syntax (new-tmp ... tmp ...))))
|
||||
(args (let lp ((tmps (syntax (new-tmp ...))))
|
||||
(syntax-case tmps ()
|
||||
((id) (syntax id))
|
||||
((id . rest) (cons (syntax id)
|
||||
(lp (syntax rest))))))))
|
||||
(syntax (call-with-values (lambda () exp)
|
||||
(lambda args inner)))))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;
|
||||
;; let*-values
|
||||
|
|
@ -226,28 +133,11 @@
|
|||
(define-syntax let*-values
|
||||
(syntax-rules ()
|
||||
((let*-values () body ...)
|
||||
(begin body ...))
|
||||
(let () body ...))
|
||||
((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
|
||||
(call-with-values (lambda () binding-1)
|
||||
(lambda vars-1
|
||||
(let*-values ((vars-2 binding-2) ...)
|
||||
body ...))))))
|
||||
|
||||
; Alternate define-macro implementation...
|
||||
;
|
||||
; (define-macro (let*-values vars . body)
|
||||
; (define (let-values-helper vars body)
|
||||
; (let ((var-binding (car vars)))
|
||||
; (if (null? (cdr vars))
|
||||
; `(call-with-values (lambda () ,(cadr var-binding))
|
||||
; (lambda ,(car var-binding)
|
||||
; ,@body))
|
||||
; `(call-with-values (lambda () ,(cadr var-binding))
|
||||
; (lambda ,(car var-binding)
|
||||
; ,(let-values-helper (cdr vars) body))))))
|
||||
|
||||
; (if (null? vars)
|
||||
; `(begin ,@body)
|
||||
; (let-values-helper vars body)))
|
||||
|
||||
;;; srfi-11.scm ends here
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue