#%top now works
svn: r593
This commit is contained in:
Guillaume Marceau
parent
d3e8815e46
commit
b9bf3b6134
|
|
@ -37,8 +37,8 @@
|
|||
"dijkstra-solver.ss"
|
||||
(lib "match.ss"))
|
||||
|
||||
(define inserts (trace (loc "heap.ss" 49 6) (bind (item) item)))
|
||||
(define removes (trace (loc "heap.ss" 67 10) (bind (result) result)))
|
||||
(define inserts (trace (loc "heap.ss" 49 6) item))
|
||||
(define removes (trace (loc "heap.ss" 67 10) result))
|
||||
|
||||
#| The following code merely observes the insertions and removals
|
||||
from the heap. We notice whether any of the removals are out
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(lib "animation.ss" "frtime")
|
||||
(lib "useful-code.ss" "mztake"))
|
||||
|
||||
(define/bind (loc "highway.ss" 3 ) speed)
|
||||
(define/bind (loc "highway.ss" 3) speed)
|
||||
|
||||
(printf-b "current speed: ~a" speed)
|
||||
|
||||
|
|
|
|||
|
|
@ -20,8 +20,6 @@ between signals and automatically recomputes them when necessary. In
|
|||
order to use MzTake, you will need to familiarize yourself with the
|
||||
FrTime language by reading its own documentation.
|
||||
|
||||
|
||||
|
||||
With signals it is possible to respond to outside events concisely,
|
||||
without using callbacks. Consider a MzTake script to monitor the
|
||||
behavior of the program "highway.ss", in the demos directory of the
|
||||
|
|
@ -91,7 +89,16 @@ where the execution is paused, then binds its values to a variable
|
|||
named "speed" in the MzTake script, then executes its body. In this
|
||||
case, it print the value with PRINTF.
|
||||
|
||||
Once satisfied, you can resume execution with "(set-running #t)", or
|
||||
Since MzTake defines a #%top syntax, you can also directly type the
|
||||
name of a variable. MzTake will first look in the scope in the MzTake
|
||||
script. If the variable is not found, it will then in the target
|
||||
process. So, the example above can be written as:
|
||||
|
||||
(printf "the speed is ~a~n" speed)
|
||||
|
||||
so long as the script itself does not declare a SPEED variable.
|
||||
|
||||
You can resume execution with "(set-running #t)", or
|
||||
some other behavior, or end the execution altogether with "(kill)".
|
||||
|
||||
Finally, FrTime provides a rich animation library. Combined
|
||||
|
|
|
|||
|
|
@ -1,142 +0,0 @@
|
|||
; ;
|
||||
; ;; ;; ;;;;;;;;; ; ;
|
||||
; ;; ;; ; ; ;
|
||||
; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ;;;;;; ; ;;;; ; ; ;;; ; ;;;; ; ;;;; ;;;;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;;
|
||||
; ; ; ;;;;;; ; ;;;; ; ; ; ;;;; ;;;;;;; ;;;; ; ; ; ;;;; ;
|
||||
; ;
|
||||
; ; ;
|
||||
; ;;;;
|
||||
|
||||
(module mztake-lang mzscheme
|
||||
(require "mztake.ss"
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "class.ss")
|
||||
(lib "unitsig.ss")
|
||||
(lib "bitmap-label.ss" "mrlib")
|
||||
(lib "contract.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(provide tool@)
|
||||
|
||||
(define tool@
|
||||
(unit/sig drscheme:tool-exports^
|
||||
(import drscheme:tool^)
|
||||
|
||||
;############################MZTAKE LANGUAGE RELATED FUNCTIONS##############################################
|
||||
(define (phase1) (void))
|
||||
(define (phase2)
|
||||
(drscheme:language-configuration:add-language
|
||||
(make-object ((drscheme:language:get-default-mixin) (make-mztake-language mztake-language%)))))
|
||||
|
||||
(define (make-mztake-language base)
|
||||
(class (drscheme:language:module-based-language->language-mixin
|
||||
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
||||
base))
|
||||
(field (watch-list empty))
|
||||
(inherit get-language-position)
|
||||
(define/override (on-execute settings run-in-user-thread)
|
||||
(let ([drs-eventspace (current-eventspace)])
|
||||
(super on-execute settings run-in-user-thread)
|
||||
(run-in-user-thread
|
||||
(lambda ()
|
||||
(let ([new-watch (namespace-variable-value 'render)]
|
||||
[set-evspc (namespace-variable-value 'set-eventspace)])
|
||||
(set-evspc drs-eventspace)
|
||||
(set! watch-list
|
||||
((if (weak-member new-watch watch-list)
|
||||
identity
|
||||
(lambda (r) (cons (make-weak-box new-watch) r)))
|
||||
(filter weak-box-value watch-list))))))))
|
||||
|
||||
(define/override (render-value/format value settings port width)
|
||||
(super render-value/format (watch watch-list value)
|
||||
settings port width))
|
||||
(define/override (render-value value settings port)
|
||||
(super render-value (watch watch-list value)
|
||||
settings port))
|
||||
(define/override (use-namespace-require/copy?) #t)
|
||||
(super-instantiate ())))
|
||||
|
||||
|
||||
(define mztake-language%
|
||||
(class* object% (drscheme:language:simple-module-based-language<%>)
|
||||
(define/public (get-language-numbers)
|
||||
'(1000 -400))
|
||||
(define/public (get-language-position)
|
||||
(list (string-constant experimental-languages) "MzTake"))
|
||||
(define/public (get-module)
|
||||
'(lib "mztake-syntax.ss" "mztake"))
|
||||
(define/public (get-one-line-summary)
|
||||
(format "MzTake Debugger"))
|
||||
(define/public (get-language-url) #f)
|
||||
(define/public (get-reader)
|
||||
(lambda (name port offsets)
|
||||
(let ([v (read-syntax name port offsets)])
|
||||
(if (eof-object? v)
|
||||
v
|
||||
(namespace-syntax-introduce v)))))
|
||||
(super-instantiate ())))
|
||||
|
||||
;;;;;;;;;;;;;FRTIME REPL STUFF;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (weak-member obj lis)
|
||||
(let ([cmp (lambda (v) (eq? v obj))])
|
||||
(let loop ([lis lis])
|
||||
(and (cons? lis)
|
||||
(or
|
||||
(cond
|
||||
[(weak-box-value (first lis)) => cmp]
|
||||
[else false])
|
||||
(loop (rest lis)))))))
|
||||
|
||||
(define (watch watch-list value)
|
||||
(foldl
|
||||
(lambda (wb acc)
|
||||
(cond
|
||||
[(weak-box-value wb)
|
||||
=> (lambda (f) (f acc))]
|
||||
[else acc]))
|
||||
value
|
||||
watch-list))
|
||||
;###########################################################################################################
|
||||
|
||||
|
||||
(define debugger-bitmap
|
||||
(bitmap-label-maker
|
||||
"Syntax Location"
|
||||
(build-path (collection-path "mztake" "icons") "stock_macro-check-brackets-16.png")))
|
||||
|
||||
(define (debugger-unit-frame-mixin super%)
|
||||
(class super%
|
||||
|
||||
(inherit get-button-panel get-interactions-text get-definitions-text get-menu-bar)
|
||||
|
||||
(super-instantiate ())
|
||||
|
||||
(define debugger-button
|
||||
(make-object button%
|
||||
(debugger-bitmap this)
|
||||
(get-button-panel)
|
||||
(lambda (button evt)
|
||||
(let* ([pos (send (get-definitions-text) get-start-position)]
|
||||
[line (send (get-definitions-text) position-paragraph pos)]
|
||||
[column (- pos (send (get-definitions-text) line-start-position
|
||||
(send (get-definitions-text) position-line pos)))])
|
||||
|
||||
(message-box "Syntax Location"
|
||||
(format "Line: ~a~nColumn: ~a" (add1 line) column))))))
|
||||
(send (get-button-panel) change-children
|
||||
(lambda (_) (cons debugger-button (remq debugger-button _))))))
|
||||
|
||||
(drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin))))
|
||||
|
|
@ -5,6 +5,9 @@
|
|||
(rename loc loc$)
|
||||
(rename make-loc loc))
|
||||
|
||||
(define (require-spec? sexp)
|
||||
(or string? list?))
|
||||
|
||||
; ;;;;; ; ;
|
||||
; ; ; ; ;
|
||||
; ; ; ;
|
||||
|
|
|
|||
|
|
@ -13,15 +13,12 @@
|
|||
;; Turn struct printing on for MzTake users.
|
||||
(print-struct true)
|
||||
|
||||
(define (require-spec? sexp)
|
||||
(or string? list?))
|
||||
|
||||
(provide loc$
|
||||
trace
|
||||
bind
|
||||
define/bind
|
||||
define/bind-e
|
||||
[rename #%top mztake-top])
|
||||
[rename mztake-top #%top])
|
||||
|
||||
(provide/contract [loc-reqspec (loc? . -> . require-spec?)]
|
||||
[loc-line (loc? . -> . number?)]
|
||||
|
|
@ -95,25 +92,29 @@
|
|||
[(_ loc body ...)
|
||||
(trace* (current-process) loc (lambda () body ...))]))
|
||||
|
||||
;; TODO this does not actually work
|
||||
(define-syntax (mztake-top stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . name)
|
||||
(begin
|
||||
(printf "top ~a~n" 'name)
|
||||
#'(with-handlers ([exn:fail?
|
||||
(lambda (exn) (bind* (current-process) 'name))])
|
||||
(printf "top ~a~n" 'name)
|
||||
#'(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exn)
|
||||
(with-handlers
|
||||
([exn:fail? (lambda (exn2) (raise exn))])
|
||||
(bind* (current-process) 'name)))])
|
||||
(#%top . name)))]))
|
||||
|
||||
(define (bind* p name)
|
||||
(unless (debug-process-marks p)
|
||||
(error "Bind called while the target process is running"))
|
||||
|
||||
(mark-binding-value
|
||||
(first (lookup-all-bindings
|
||||
(lambda (id) (eq? (syntax-e id) name))
|
||||
(debug-process-marks p)))))
|
||||
(error "Bind called but the target process is not paused."))
|
||||
|
||||
(let ([bs (lookup-all-bindings
|
||||
(lambda (id) (eq? (syntax-e id) name))
|
||||
(debug-process-marks p))])
|
||||
(when (empty? bs)
|
||||
(error 'bind "variable `~a' not found in target at the current location" name))
|
||||
|
||||
(mark-binding-value (first bs))))
|
||||
|
||||
(define-syntax bind
|
||||
(syntax-rules ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user