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

let-values in terms of syntax-case, add make-tree-il-folder

Browse source 
* 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 2009-08-05 21:25:35 +02:00
parent c21c89b138
commit 4dcd84998f
4 changed files with 194 additions and 189 deletions
Download patch file Download diff file Expand all files Collapse all files

78
module/language/tree-il.scm
View file

@ -18,6 +18,7 @@
(define-module (language tree-il) (define-module (language tree-il)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (system base syntax) #:use-module (system base syntax)
#:export (tree-il-src #:export (tree-il-src
@ -46,6 +47,7 @@
tree-il->scheme tree-il->scheme
tree-il-fold tree-il-fold
make-tree-il-folder
post-order! post-order!
pre-order!)) pre-order!))
@ -316,11 +318,83 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop body (up tree (loop body
(loop vals (loop vals
(down tree result))))) (down tree result)))))
((<let-values> body) ((<let-values> exp body)
(up tree (loop body (down tree result)))) (up tree (loop body (loop exp (down tree result)))))
(else (else
(leaf tree result)))))) (leaf tree result))))))
(define-syntax make-tree-il-folder
(syntax-rules ()
((_ seed ...)
(lambda (tree down up leaf seed ...)
(define (fold-values proc exps seed ...)
(if (null? exps)
(values seed ...)
(let-values (((seed ...) (proc (car exps) seed ...)))
(fold-values proc (cdr exps) seed ...))))
(let foldts ((tree tree) (seed seed) ...)
(record-case tree
((<lexical-set> exp)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (foldts exp seed ...)))
(up tree seed ...)))
((<module-set> exp)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (foldts exp seed ...)))
(up tree seed ...)))
((<toplevel-set> exp)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (foldts exp seed ...)))
(up tree seed ...)))
((<toplevel-define> exp)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (foldts exp seed ...)))
(up tree seed ...)))
((<conditional> test then else)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (foldts test seed ...))
((seed ...) (foldts then seed ...))
((seed ...) (foldts else seed ...)))
(up tree seed ...)))
((<application> proc args)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (foldts proc seed ...))
((seed ...) (fold-values foldts args seed ...)))
(up tree seed ...)))
((<sequence> exps)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (fold-values foldts exps seed ...)))
(up tree seed ...)))
((<lambda> body)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (foldts body seed ...)))
(up tree seed ...)))
((<let> vals body)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (fold-values foldts vals seed ...))
((seed ...) (foldts body seed ...)))
(up tree seed ...)))
((<letrec> vals body)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (fold-values foldts vals seed ...))
((seed ...) (foldts body seed ...)))
(up tree seed ...)))
((<fix> vals body)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (fold-values foldts vals seed ...))
((seed ...) (foldts body seed ...)))
(up tree seed ...)))
((<let-values> exp body)
(let*-values (((seed ...) (down tree seed ...))
((seed ...) (fold-values foldts vals seed ...))
((seed ...) (foldts body seed ...)))
(up tree seed ...)))
(else
(leaf tree seed ...))))))))
(define (post-order! f x) (define (post-order! f x)
(let lp ((x x)) (let lp ((x x))
(record-case x (record-case x

4
module/language/tree-il/optimize.scm
View file

@ -29,7 +29,7 @@
(if e (car e) (current-module))) (if e (car e) (current-module)))
(define (optimize! x env opts) (define (optimize! x env opts)
(fix-letrec! (inline!
(inline! (fix-letrec!
(expand-primitives! (expand-primitives!
(resolve-primitives! x (env-module env)))))) (resolve-primitives! x (env-module env))))))

212
module/srfi/srfi-11.scm
View file

@ -1,6 +1,6 @@
;;; srfi-11.scm --- let-values and let*-values ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -63,148 +63,55 @@
;; (q <tmp-q>)) ;; (q <tmp-q>))
;; (baz x y z p q)))))) ;; (baz x y z p q))))))
;; I originally wrote this as a define-macro, but then I found out ;; We could really use quasisyntax here...
;; that guile's gensym/gentemp was broken, so I tried rewriting it as (define-syntax let-values
;; a syntax-rules statement. (lambda (x)
;; [make-symbol now fixes gensym/gentemp problems.] (syntax-case x ()
;; ((_ (clause ...) b0 b1 ...)
;; Since syntax-rules didn't seem powerful enough to implement (let lp ((clauses (syntax (clause ...)))
;; let-values in one definition without exposing illegal syntax (or (ids '())
;; perhaps my brain's just not powerful enough :>). I tried writing (tmps '()))
;; it using a private helper, but that didn't work because the (if (null? clauses)
;; let-values expands outside the scope of this module. I wonder why (with-syntax (((id ...) ids)
;; syntax-rules wasn't designed to allow "private" patterns or ((tmp ...) tmps))
;; similar... (syntax (let ((id tmp) ...)
;; b0 b1 ...)))
;; So in the end, I dumped the syntax-rules implementation, reproduced (syntax-case (car clauses) ()
;; here for posterity, and went with the define-macro one below -- (((var ...) exp)
;; gensym/gentemp's got to be fixed anyhow... (with-syntax (((new-tmp ...) (generate-temporaries
; (syntax (var ...))))
; (define-syntax let-values-helper ((id ...) ids)
; (syntax-rules () ((tmp ...) tmps))
; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y (with-syntax ((inner (lp (cdr clauses)
; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda (syntax (var ... id ...))
; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the (syntax (new-tmp ... tmp ...)))))
; ;; temps you create so you can use them later... (syntax (call-with-values (lambda () exp)
; ;; (lambda (new-tmp ...) inner))))))
; ;; I really don't fully understand why the (var-1 var-1) trick ((vars exp)
; ;; works below, but basically, when all those (x x) bindings show (with-syntax ((((new-tmp . new-var) ...)
; ;; up in the final "let", syntax-rules forces a renaming. (let lp ((vars (syntax vars)))
(syntax-case vars ()
; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings ((id . rest)
; body ...) (acons (syntax id)
; (lambda lambda-tmps (car
; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) (generate-temporaries (syntax (id))))
(lp (syntax rest))))
; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings (id (acons (syntax id)
; body ...) (car
; (let-values-helper "consumer" (generate-temporaries (syntax (id))))
; (var-2 ...) '())))))
; (lambda-tmp ... var-1) ((id ...) ids)
; ((var-1 var-1) . final-let-bindings) ((tmp ...) tmps))
; lv-bindings (with-syntax ((inner (lp (cdr clauses)
; body ...)) (syntax (new-var ... id ...))
(syntax (new-tmp ... tmp ...))))
; ((_ "cwv" () final-let-bindings body ...) (args (let lp ((tmps (syntax (new-tmp ...))))
; (let final-let-bindings (syntax-case tmps ()
; body ...)) ((id) (syntax id))
((id . rest) (cons (syntax id)
; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings (lp (syntax rest))))))))
; body ...) (syntax (call-with-values (lambda () exp)
; (call-with-values (lambda () binding-1) (lambda args inner)))))))))))))
; (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 '())))
;;;;;;;;;;;;;; ;;;;;;;;;;;;;;
;; let*-values ;; let*-values
@ -226,28 +133,11 @@
(define-syntax let*-values (define-syntax let*-values
(syntax-rules () (syntax-rules ()
((let*-values () body ...) ((let*-values () body ...)
(begin body ...)) (let () body ...))
((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
(call-with-values (lambda () binding-1) (call-with-values (lambda () binding-1)
(lambda vars-1 (lambda vars-1
(let*-values ((vars-2 binding-2) ...) (let*-values ((vars-2 binding-2) ...)
body ...)))))) 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 ;;; srfi-11.scm ends here

89
module/system/base/syntax.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM specific syntaxes and utilities ;;; Guile VM specific syntaxes and utilities
;; Copyright (C) 2001 Free Software Foundation, Inc ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc
;;; This library is free software; you can redistribute it and/or ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -174,29 +174,70 @@
;; 5.88 0.01 0.01 list-index ;; 5.88 0.01 0.01 list-index
(define-macro (record-case record . clauses) ;;; So ugly... but I am too ignorant to know how to make it better.
(let ((r (gensym)) (define-syntax record-case
(rtd (gensym))) (lambda (x)
(define (process-clause clause) (syntax-case x ()
(if (eq? (car clause) 'else) ((_ record clause ...)
clause (let ((r (syntax r))
(let ((record-type (caar clause)) (rtd (syntax rtd)))
(slots (cdar clause)) (define (process-clause tag fields exprs)
(body (cdr clause))) (let ((infix (trim-brackets (syntax->datum tag))))
(let ((stem (trim-brackets record-type))) (with-syntax ((tag tag)
`((eq? ,rtd ,record-type) (((f . accessor) ...)
(let ,(map (lambda (slot) (let lp ((fields fields))
(if (pair? slot) (syntax-case fields ()
`(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r)) (() (syntax ()))
`(,slot (,(symbol-append stem '- slot) ,r)))) (((v0 f0) f1 ...)
slots) (acons (syntax v0)
,@(if (pair? body) body '((if #f #f))))))))) (datum->syntax x
`(let* ((,r ,record) (symbol-append infix '- (syntax->datum
(,rtd (struct-vtable ,r))) (syntax f0))))
(cond ,@(let ((clauses (map process-clause clauses))) (lp (syntax (f1 ...)))))
(if (assq 'else clauses) ((f0 f1 ...)
clauses (acons (syntax f0)
(append clauses `((else (error "unhandled record" ,r)))))))))) (datum->syntax x
(symbol-append infix '- (syntax->datum
(syntax f0))))
(lp (syntax (f1 ...))))))))
((e0 e1 ...)
(syntax-case exprs ()
(() (syntax (#t)))
((e0 e1 ...) (syntax (e0 e1 ...))))))
(syntax
((eq? rtd tag)
(let ((f (accessor r))
...)
e0 e1 ...))))))
(with-syntax
((r r)
(rtd rtd)
((processed ...)
(let lp ((clauses (syntax (clause ...)))
(out '()))
(syntax-case clauses (else)
(()
(reverse! (cons (syntax
(else (error "unhandled record" r)))
out)))
(((else e0 e1 ...))
(reverse! (cons (syntax (else e0 e1 ...)) out)))
(((else e0 e1 ...) . rest)
(syntax-violation 'record-case
"bad else clause placement"
(syntax x)
(syntax (else e0 e1 ...))))
((((<foo> f0 ...) e0 ...) . rest)
(lp (syntax rest)
(cons (process-clause (syntax <foo>)
(syntax (f0 ...))
(syntax (e0 ...)))
out)))))))
(syntax
(let* ((r record)
(rtd (struct-vtable r)))
(cond processed ...)))))))))
;; Here we take the terrorism to another level. Nasty, but the client ;; Here we take the terrorism to another level. Nasty, but the client
;; code looks good. ;; code looks good.