dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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
commit 4dcd84998f
4 changed files with 194 additions and 189 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; 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
;;; modify it under the terms of the GNU Lesser General Public
@ -174,29 +174,70 @@
;; 5.88 0.01 0.01 list-index
(define-macro (record-case record . clauses)
(let ((r (gensym))
(rtd (gensym)))
(define (process-clause clause)
(if (eq? (car clause) 'else)
clause
(let ((record-type (caar clause))
(slots (cdar clause))
(body (cdr clause)))
(let ((stem (trim-brackets record-type)))
`((eq? ,rtd ,record-type)
(let ,(map (lambda (slot)
(if (pair? slot)
`(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
`(,slot (,(symbol-append stem '- slot) ,r))))
slots)
,@(if (pair? body) body '((if #f #f)))))))))
`(let* ((,r ,record)
(,rtd (struct-vtable ,r)))
(cond ,@(let ((clauses (map process-clause clauses)))
(if (assq 'else clauses)
clauses
(append clauses `((else (error "unhandled record" ,r))))))))))
;;; So ugly... but I am too ignorant to know how to make it better.
(define-syntax record-case
(lambda (x)
(syntax-case x ()
((_ record clause ...)
(let ((r (syntax r))
(rtd (syntax rtd)))
(define (process-clause tag fields exprs)
(let ((infix (trim-brackets (syntax->datum tag))))
(with-syntax ((tag tag)
(((f . accessor) ...)
(let lp ((fields fields))
(syntax-case fields ()
(() (syntax ()))
(((v0 f0) f1 ...)
(acons (syntax v0)
(datum->syntax x
(symbol-append infix '- (syntax->datum
(syntax f0))))
(lp (syntax (f1 ...)))))
((f0 f1 ...)
(acons (syntax f0)
(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
;; code looks good.