suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

define-values-for-syntax and (now-running b) and broken #%top

Browse Source 
svn: r542
This commit is contained in:
Guillaume Marceau 2005-08-03 19:45:21 +00:00
parent a4be78133a
commit cb30a90f04
4 changed files with 24 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mztake/annotator.ss
View File

@ -112,6 +112,9 @@
#,(annotate #`expr (syntax->list #`(var ...)) #t))] #,(annotate #`expr (syntax->list #`(var ...)) #t))]
[(define-syntaxes (var ...) expr) [(define-syntaxes (var ...) expr)
stx] stx]
[(define-values-for-syntax (var ...) expr)
#`(define-values-for-syntax (var ...)
#,(annotate #`expr #`(syntax->list #'(var ...)) #t))]
[(begin . top-level-exprs) [(begin . top-level-exprs)
(quasisyntax/loc stx (begin #,@(map (lambda (expr) (quasisyntax/loc stx (begin #,@(map (lambda (expr)
(module-level-expr-iterator expr)) (module-level-expr-iterator expr))
@ -120,6 +123,7 @@
stx] stx]
[(require-for-syntax . require-specs) [(require-for-syntax . require-specs)
stx] stx]
[(require-for-template dot require-specs) stx]
[else [else
(annotate stx '() #f)])) (annotate stx '() #f)]))

2
collects/mztake/demos/highway/highway-mztake.ss
View File

@ -2,7 +2,7 @@
(lib "animation.ss" "frtime") (lib "animation.ss" "frtime")
(lib "useful-code.ss" "mztake" "private")) (lib "useful-code.ss" "mztake" "private"))
(define/bind (loc "highway.ss" 3 4) speed) (define/bind (loc "highway.ss" 3 ) speed)
(printf-b "current speed: ~a" speed) (printf-b "current speed: ~a" speed)

2
collects/mztake/demos/sine/sine-mztake.ss
View File

@ -2,7 +2,7 @@
(lib "useful-code.ss" "mztake" "private")) (lib "useful-code.ss" "mztake" "private"))
(require (lib "mztake.ss" "mztake")) (require (lib "mztake.ss" "mztake"))
(define/bind (loc "sine.ss" 5 8) x sin-x) (define/bind (loc "sine.ss" 5 ) x sin-x)
(define (pick-cute-color x y) (define (pick-cute-color x y)
(if (< 200 y) (if (< 200 y)

18
collects/mztake/mztake.ss
View File

@ -10,7 +10,9 @@
"engine.ss") "engine.ss")
(provide loc$ loc-reqspec loc-line loc-col (provide loc$ loc-reqspec loc-line loc-col
trace trace* bind define/bind define/bind-e where set-main!) trace
trace* bind define/bind define/bind-e where set-main!
[rename #%top mztake-top])
(provide/contract [kill (() (debug-process?) . opt-> . void?)] (provide/contract [kill (() (debug-process?) . opt-> . void?)]
[kill-all (-> void?)] [kill-all (-> void?)]
[set-running-e! (frp:event? . -> . void?)] [set-running-e! (frp:event? . -> . void?)]
@ -50,7 +52,8 @@
(define set-running! (define set-running!
(opt-lambda (b [process (current-process)]) (opt-lambda (b [process (current-process)])
(if (frp:value-now b) (resume process) (pause process)) (if (frp:value-now b) (resume process) (pause process))
(frp:set-cell! (debug-process-running-e process) (frp:changes b)))) (frp:set-cell! (debug-process-running-e process) (frp:changes b))
(list 'now-running (debug-process-running-e process))))
(define where (define where
(opt-lambda ([p (current-process)]) (opt-lambda ([p (current-process)])
@ -74,6 +77,17 @@
[(_ loc body ...) [(_ loc body ...)
(trace* (current-process) loc (lambda () body ...))])) (trace* (current-process) loc (lambda () body ...))]))
;; TODO this does not actually work
(define-syntax (mztake-top stx)
(syntax-case stx ()
[(_ . name)
(begin
(printf "~a~n" 'name)
#'(with-handlers ([exn:fail?
(lambda (exn) (bind* (current-process) 'name))])
(printf "~a~n" 'name)
(#%top . name)))]))
(define (bind* p name) (define (bind* p name)
(mark-binding-value (mark-binding-value
(first (lookup-all-bindings (first (lookup-all-bindings