syndicate-lang
/
minimart-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fix error in analyze-body* macro; adjust scope of compute-gestalt

This commit is contained in:
Tony Garnock-Jones 2014-06-23 07:27:25 -04:00
parent 38ea50e352
commit c0a92a64f5
1 changed files with 24 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
minimart/actor.rkt
View File

@ -73,17 +73,17 @@
body-forms body-forms
forms-stx) forms-stx)
(define-syntax-rule (analyze-body* body-stx struct-type o [keyword accessor fieldname] ...) (define-syntax-rule (analyze-body* self body-stx struct-type o [keyword accessor fieldname] ...)
(syntax-case body-stx () (syntax-case body-stx ()
[(keyword v rest (... ...)) [(keyword v rest (... ...))
(if (accessor o) (if (accessor o)
(raise-syntax-error #f (format "duplicate ~a clause" 'keyword) body-stx) (raise-syntax-error #f (format "duplicate ~a clause" 'keyword) body-stx)
(analyze-observer-body #'(rest (... ...)) (struct-copy struct-type o [fieldname #'v])))] (self #'(rest (... ...)) (struct-copy struct-type o [fieldname #'v])))]
... ...
[other (values o #'other)])) [other (values o #'other)]))
(define (analyze-observer-body body-stx o) (define (analyze-observer-body body-stx o)
(analyze-body* body-stx observer o (analyze-body* analyze-observer-body body-stx observer o
[#:when observer-condition condition] [#:when observer-condition condition]
[#:level observer-level level] [#:level observer-level level]
[#:meta-level observer-meta-level meta-level] [#:meta-level observer-meta-level meta-level]
@ -94,7 +94,7 @@
[#:removed observer-removed-name removed-name])) [#:removed observer-removed-name removed-name]))
(define (analyze-participator-body body-stx p) (define (analyze-participator-body body-stx p)
(analyze-body* body-stx participator p (analyze-body* analyze-participator-body body-stx participator p
[#:when participator-condition condition] [#:when participator-condition condition]
[#:meta-level participator-meta-level meta-level])) [#:meta-level participator-meta-level meta-level]))
@ -286,26 +286,29 @@
[(and id (struct #,state-struct-name (#,@stateinits))) [(and id (struct #,state-struct-name (#,@stateinits)))
(syntax-parameterize (#,@(for/list ([sv statevars] [si stateinits]) (syntax-parameterize (#,@(for/list ([sv statevars] [si stateinits])
#`(#,sv (syntax-id-rules () [_ #,si])))) #`(#,sv (syntax-id-rules () [_ #,si]))))
body (... ...))])])) body (... ...))])])))
(compute-gestalt (syntax-rules () [(_ state) (#,compute-gestalt-stx state)])))
(let ((#,compute-gestalt-stx (match-state #,state-stx (let ((#,compute-gestalt-stx (match-state #,state-stx
(gestalt-union #,@gestalt-computers))) (gestalt-union #,@gestalt-computers)))
(#,state-stx (#,state-struct-name #,@statevars))) (#,state-stx (#,state-struct-name #,@statevars)))
(spawn #:boot (begin-transition #,@(reverse action-ids)) (syntax-parameterize
(procedure-rename ((compute-gestalt (syntax-rules () [(_ state) (#,compute-gestalt-stx state)])))
(lambda (#,e-stx #,state-stx) (spawn #:boot (begin-transition #,@(reverse action-ids))
((match-state #,state-stx (procedure-rename
((match #,e-stx (lambda (#,e-stx #,state-stx)
[(routing-update #,g-stx) ((match-state #,state-stx
(begin-transition ((match #,e-stx
#,@(append-map (lambda (p) (syntax->list (p g-stx))) gestalt-observers))] [(routing-update #,g-stx)
#,@(map (lambda (p) (p e-stx)) message-handlers) (begin-transition
[_ (lambda (state) #f)]) #,@(append-map
#,state-stx)) (lambda (p) (syntax->list (p g-stx)))
#,state-stx)) gestalt-observers))]
'#,actor-name) #,@(map (lambda (p) (p e-stx)) message-handlers)
#,state-stx [_ (lambda (state) #f)])
(#,compute-gestalt-stx #,state-stx)))))) #,state-stx))
#,state-stx))
'#,actor-name)
#,state-stx
(#,compute-gestalt-stx #,state-stx)))))))
;; (pretty-print `(result ,(syntax->datum result))) ;; (pretty-print `(result ,(syntax->datum result)))
result)] result)]