Updated FrTime
Created the MzTake language and updated sine demo to reflect it. svn: r127
This commit is contained in:
Jono Spiro
parent
17d72dcfe6
commit
1fc5e1efea
|
|
@ -1,11 +1,30 @@
|
|||
; ;
|
||||
; ;; ;; ;;;;;;;;; ; ;
|
||||
; ;; ;; ; ; ;
|
||||
; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ;;;;;; ; ;;;; ; ; ;;; ; ;;;; ; ;;;; ;;;;;;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;;
|
||||
; ; ; ;;;;;; ; ;;;; ; ; ; ;;;; ;;;;;;; ;;;; ; ; ; ;;;; ;
|
||||
; ;
|
||||
; ; ;
|
||||
; ;;;;
|
||||
|
||||
(module debugger-tool mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "unitsig.ss")
|
||||
(require (lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "class.ss")
|
||||
(lib "list.ss"))
|
||||
(lib "unitsig.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "string-constant.ss" "string-constants"))
|
||||
|
||||
(provide tool@)
|
||||
|
||||
|
|
@ -13,8 +32,87 @@
|
|||
(unit/sig drscheme:tool-exports^
|
||||
(import drscheme:tool^)
|
||||
|
||||
;############################MZTAKE LANGUAGE RELATED FUNCTIONS##############################################
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (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))
|
||||
(rename [super-on-execute on-execute])
|
||||
(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))))))))
|
||||
|
||||
(rename (super:render-value/format render-value/format)
|
||||
(super:render-value render-value))
|
||||
(override render-value/format render-value)
|
||||
(define (render-value/format value settings port put-snip width)
|
||||
(super:render-value/format (watch watch-list value put-snip)
|
||||
settings port put-snip width))
|
||||
(define (render-value value settings port put-snip)
|
||||
(super:render-value (watch watch-list value put-snip)
|
||||
settings port put-snip))
|
||||
(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)
|
||||
"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 as-snip?)
|
||||
(foldl
|
||||
(lambda (wb acc)
|
||||
(cond
|
||||
[(weak-box-value wb)
|
||||
=> (lambda (f) (f acc as-snip?))]
|
||||
[else acc]))
|
||||
value
|
||||
watch-list))
|
||||
;###########################################################################################################
|
||||
|
||||
|
||||
(define debugger-bitmap
|
||||
(drscheme:unit:make-bitmap
|
||||
|
|
|
|||
|
|
@ -1,48 +1,39 @@
|
|||
#|
|
||||
(debugger
|
||||
(processes (p ("sine.ss" [sin/x 5 8 bind '(sin-x x)]
|
||||
[foo 10 20 bind '(sin-x x)])
|
||||
("sine-extra.ss")))
|
||||
|
||||
(define sin/x (hold sin/x))
|
||||
(define x (+ 200 (second sin/x)))
|
||||
(print-b "x:" x))
|
||||
|
||||
*** translates to ***
|
||||
|
||||
(define p (create-debug-process))
|
||||
(define-values (sin/x foo ...)(
|
||||
(let ([tmp (create-debug-client p "sine.ss")])
|
||||
(values (create-trace tmp 5 8 'bind '(sin-x x))))
|
||||
...
|
||||
(start/resume <temp1>)
|
||||
...
|
||||
|#
|
||||
|
||||
(module mztake-syntax (lib "frtime-big.ss" "frtime")
|
||||
|
||||
(define-syntax debugger-module-begin
|
||||
(syntax-rules (debugger)
|
||||
[(_ (debugger . clauses))
|
||||
(#%module-begin (debugger . clauses))]))
|
||||
|
||||
(define-syntax debugger
|
||||
(syntax-rules (processes)
|
||||
[(_ (processes (proc-id (client (trace line col cmd . args) ...))
|
||||
...)
|
||||
expr ...)
|
||||
(begin
|
||||
(define proc-id (create-debug-process))
|
||||
...
|
||||
(define-values (trace ...)
|
||||
(let ([tmp (create-debug-client proc-id client)])
|
||||
(values
|
||||
(create-trace line col 'cmd . args)
|
||||
...)))
|
||||
...
|
||||
expr
|
||||
...)]))
|
||||
|
||||
(provide debugger
|
||||
(rename debugger-module-begin #%module-begin)
|
||||
(all-from-except (lib "frtime-big.ss" "frtime") #%module-begin)))
|
||||
#|
|
||||
(debug-process p ("sine.ss" [sin/x 5 8 bind '(sin-x x)]
|
||||
[foo 10 20 bind '(sin-x x)])
|
||||
("sine-extra.ss"))
|
||||
|
||||
(define sin/x (hold sin/x))
|
||||
(define x (+ 200 (second sin/x)))
|
||||
(print-b "x:" x)
|
||||
|
||||
*** translates to ***
|
||||
|
||||
(define p (create-debug-process))
|
||||
(define-values (sin/x foo ...)(
|
||||
(let ([tmp (create-debug-client p "sine.ss")])
|
||||
(values (create-trace tmp 5 8 'bind '(sin-x x))))
|
||||
...
|
||||
|#
|
||||
|
||||
(module mztake-syntax (lib "frtime-big.ss" "frtime")
|
||||
|
||||
(require (lib "mztake.ss" "mztake")
|
||||
(lib "useful-code.ss" "mztake/private"))
|
||||
|
||||
(define-syntax debug-process
|
||||
(syntax-rules (debug-process)
|
||||
[(debug-process proc-id (client (trace line col cmd . args) ...) ...)
|
||||
(begin
|
||||
(define proc-id (create-debug-process))
|
||||
(begin
|
||||
(define-values (trace ...)
|
||||
(let ([tmp (create-debug-client proc-id 'client)])
|
||||
(values
|
||||
(create-trace tmp line col 'cmd . args)
|
||||
...))) ...))]))
|
||||
|
||||
(provide debug-process
|
||||
(all-from-except (lib "frtime-big.ss" "frtime") #%module-begin)
|
||||
(all-from (lib "mztake.ss" "mztake"))
|
||||
(all-from (lib "useful-code.ss" "mztake/private"))))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,7 +1,7 @@
|
|||
(module more-useful-code mzscheme
|
||||
(require (lib "list.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "etc.ss"))
|
||||
(lib "etc.ss"))
|
||||
|
||||
(provide assert
|
||||
cons-to-end
|
||||
|
|
|
|||
|
|
@ -23,9 +23,8 @@
|
|||
(define (sequence-match? seq evs)
|
||||
(equal? seq (history-b (length seq) evs)))
|
||||
|
||||
; Reaaaalllly cheap print function
|
||||
(define (print-b str b)
|
||||
(format "~a ~a" str b))
|
||||
; Cheap printf for behaviors
|
||||
(define printf-b format)
|
||||
|
||||
; Flattens a list
|
||||
(define (flatten x)
|
||||
|
|
@ -33,4 +32,4 @@
|
|||
((and (list? x)
|
||||
(list? (first x)))
|
||||
(append (flatten (car x)) (flatten (cdr x))))
|
||||
(else (list x)))))
|
||||
(else (list x)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user