Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

env vars are identifiers, not symbols; fix evaluation time (issue #516)

Browse source
This commit is contained in:
Alex Shinn 2020-07-06 15:00:27 +09:00
parent 47b0a19733
commit a6e8e9d7ba
1 changed files with 13 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
lib/chibi/monad/environment.scm
View file

@ -114,7 +114,7 @@
(else (cond ((assq x (get-props st)) => cdr) (else #f))))) (else (cond ((assq x (get-props st)) => cdr) (else #f)))))
(define-syntax ask (define-syntax ask
(syntax-rules (quote field ...) (syntax-rules (quote field ...)
((ask st 'field) (get st)) ... ((ask st (syntax-quote field)) (get st)) ...
((ask st x) (%ask st x)))) ((ask st x) (%ask st x))))
(define (%tell st x val) (define (%tell st x val)
(case x (case x
@ -127,7 +127,7 @@
(set-props! st (cons (cons x val) (get-props st)))))))) (set-props! st (cons (cons x val) (get-props st))))))))
(define-syntax tell (define-syntax tell
(syntax-rules (quote field ...) (syntax-rules (quote field ...)
((tell st 'field val) (put st val)) ... ((tell st (syntax-quote field) val) (put st val)) ...
((tell st x val) (%tell st x val)))) ((tell st x val) (%tell st x val))))
;; External API ;; External API
;; ;;
@ -147,7 +147,7 @@
(f! ("step") (params ooo (param param)) rest . body)) (f! ("step") (params ooo (param param)) rest . body))
((f! ("step") ((p param) ooo) () . body) ((f! ("step") ((p param) ooo) () . body)
(lambda (st) (lambda (st)
(let ((p (ask st 'param)) ooo) (let ((p (ask st (syntax-quote param))) ooo)
((let () . body) st)))) ((let () . body) st))))
((f! params . body) ((f! params . body)
(f! ("step") () params . body)))) (f! ("step") () params . body))))
@ -161,26 +161,29 @@
(define-syntax s (define-syntax s
(syntax-rules () (syntax-rules ()
((s f) f) ((s f) f)
((s f . g) (lambda (st) ((s . g) (f st)))))) ((s f . g)
(let ((f-tmp f) (g-tmp (s . g)))
(lambda (st) (g-tmp (f-tmp st)))))))
;; update in place ;; update in place
(define-syntax u (define-syntax u
(syntax-rules ooo () (syntax-rules ooo ()
((u (prop value) ooo) ((u (prop value) ooo)
(lambda (st) (lambda (st)
(tell st 'prop value) ooo (tell st (syntax-quote prop) value) ooo
st)))) st))))
;; local binding - update temporarily ;; local binding - update temporarily
(define-syntax w (define-syntax w
(syntax-rules ooo () (syntax-rules ooo ()
((w ("step") ((p tmp v) ooo) () . b) ((w ("step") ((p tmp v tmp-v) ooo) () . b)
(lambda (st) (lambda (st)
(let ((tmp (ask st 'p)) ooo) (let ((tmp-v v) ooo
(tmp (ask st (syntax-quote p))) ooo)
(dynamic-wind (dynamic-wind
(lambda () (tell st 'p v) ooo) (lambda () (tell st (syntax-quote p) tmp-v) ooo)
(lambda () ((begin . b) st)) (lambda () ((begin . b) st))
(lambda () (tell st 'p tmp) ooo))))) (lambda () (tell st (syntax-quote p) tmp) ooo)))))
((w ("step") (props ooo) ((p v) . rest) . b) ((w ("step") (props ooo) ((p v) . rest) . b)
(w ("step") (props ooo (p tmp v)) rest . b)) (w ("step") (props ooo (p tmp v tmp-v)) rest . b))
((w ((prop value) ooo) . body) ((w ((prop value) ooo) . body)
(w ("step") () ((prop value) ooo) . body)))) (w ("step") () ((prop value) ooo) . body))))
;; run ;; run