andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

mes: Nyacc support: with-fluids. 

* module/mes/fluids.mes (with-fluids): New macro.
* tests/fluids.test ("with-fluids"): Test it.
This commit is contained in:
Jan Nieuwenhuizen 2017-11-20 23:21:25 +01:00
parent 448b167c09
commit e81cb61b87
2 changed files with 21 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
module/mes/fluids.mes
View File

@ -79,12 +79,13 @@
;; (define (with-fluids* fluids values thunk)
;; (primitive-eval (with-fluids*-next fluids values thunk)))
;; (define-macro (with-fluids bindings . bodies)
;; `(let ()
;; (define (expand bindings a)
;; (if (null? bindings)
;; (cons (car bindings) (expand (cdr bindings) a))))
;; (eval (begin ,@bodies) (expand ',bindings (current-module)))))
(define-macro (with-fluids bindings . bodies)
(let ((syms (map gensym bindings)))
`(let ,(map (lambda (b s) `(,s (,b))) (map car bindings) syms)
,@(map (lambda (o) `(fluid-set! ,(car o) ,(cadr o))) bindings)
(let ((r (begin ,@bodies)))
`,@(map (lambda (b s) `(fluid-set! ,b ,s)) (map car bindings) syms)
r))))
(define (dynamic-wind in-guard thunk out-guard)
(in-guard)

29
tests/fluids.test
View File

@ -50,20 +50,19 @@ exit $?
;; 0 (with-fluids* (list a b) '(0 1)
;; (lambda () (fluid-ref a))))
;; (pass-if-equal "with-fluids"
;; 0 (with-fluids ((a 1)
;; (a 2)
;; (a 3))
;; (begin (fluid-set! a 0))
;; (begin (fluid-ref a))))
(pass-if-equal "with-fluids"
0 (with-fluids ((a 1)
(a 2)
(a 3))
(fluid-set! a 0)
(fluid-ref a)))
;; (pass-if-equal "with-fluids"
;; #f (begin
;; (with-fluids ((a 1)
;; (a 2)
;; (a 3))
;; (begin (fluid-set! a 0))
;; (begin (display "X:") (display (fluid-ref a)) (newline)))
;; (fluid-ref a)))
(pass-if-equal "with-fluids" ; FIXME: fails with Mes
#f (begin
(with-fluids ((a 1)
(b 2))
(fluid-set! a 0)
(display "X:") (display (fluid-ref a)) (newline))
(fluid-ref a)))
(result 'report)
(result 'report (if mes? 1 0))