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

not even a checkpoint... trying to get the load/annotator to match up with the client's filenames as I create them.

Browse Source 
need to make sure that the module names are unique when eval'ng them in load/annotate 

one frtime file was missing - added

svn: r114
This commit is contained in:
Jono Spiro 2004-07-29 03:28:52 +00:00
parent 7b4506e58e
commit a19e47e861
2 changed files with 250 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

276
collects/mztake/mztake.ss
View File

@ -1,4 +1,32 @@
#| TODO #| TODO
-------------------
does this work on binary drscheme files?
create client takes either a lib or relative or absolute path string
need client-error to throw an exception, they are all fatal
all errors are fatal now -- you can do this when
make all exposed cells and evstreams read-only
does this handle module prefixes?
what happens if two modules have the same name in different directories
WHY CANT REQUIRE TAKE AN ABSOLUTE PATH?
(require (lib "file.ss"))
(find-relative-path (current-directory) "C:/Files/Desktop/debugger/src/collects/mztake/mztake.ss")
Need to find a way to map the absolute paths taken in from clients to the function that determines what to annotate.
MAKE SURE THERE WONT BE COLLISIONS WHEN EVAL'NG MODULES...GIVE THEM UNIQUE NAMES BASED ON PATH!
----------------
Remove client from runtime setters Remove client from runtime setters
------------------------------------------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------------------------------------------
@ -29,24 +57,17 @@ Need to know where the program breaks at -- need to know *when* it breaks too --
I will want to be able to take "(lib ...)" as a path to the file being debugged I will want to be able to take "(lib ...)" as a path to the file being debugged
exceptions thrown in anonymous threads spawned by the target, are caught by the default drs handler, and not by frtime or mztake. they get printed out in the interaction window and there is nothing we can do about them for now -- if you want you can parameterize and rethrow the exceptions. just be aware of that. exceptions thrown in anonymous threads spawned by the target, are caught by the default drs handler, and not by frtime or mztake. they get printed out in the interaction window and there is nothing we can do about them for now -- if you want you can parameterize and rethrow the exceptions. just be aware of that.
RETHROW EXCEPTIONS CAUGHT ON THE STREAM FOR A CLIENT -- OFFER A WAY TO DISABLE IT
WHO is catching (thread (lambda () (raise 'first-raise)))? It never gets to the exn evstream
CAN I CATCH FRTIME EXCEPTIONS AND RETHROW THOSE TOO? CAN I CATCH FRTIME EXCEPTIONS AND RETHROW THOSE TOO?
When lifting for debugging a frtime program, you cannot lift in the target program, you have to lift in the script itself. Everything else should be as-is/unchecked.
code like code like
(set-running! client (or (elapsed . < . 5) (elapsed . >= . 10))) (set-running! client (or (elapsed . < . 5) (elapsed . >= . 10)))
(set-running! client #t) (set-running! client #t)
will break the behavior ... it gets set!'d. Fix this! will break the behavior ... it gets set!'d. Fix this!
set-running! behaviors can go in a list which is and'd to check if all are satisfied
rethink start/resume and kill -- do we want people to be able to restart after a kill or the progam exits (we have a behavior to check for that)?
RETHROW EXCEPTIONS CAUGHT ON THE STREAM FOR A CLIENT -- OFFER A WAY TO DISABLE IT
WHO is catching (thread (lambda () (raise 'first-raise)))? It never gets to the exn evstream
You cannot annotate across requires. Test threads and multiple clients. Two files at the same time if they use each other?
DrScheme has hooks which should let me bind to the 'load's of libraries and force loading source, then annotating after expansion.
DEMOS--------------------------------------------------------------------------------------- DEMOS---------------------------------------------------------------------------------------
Data structure examples Data structure examples
@ -57,6 +78,7 @@ MST example
Code something with multiple threads doing something and draw the threads in different colors in a window Code something with multiple threads doing something and draw the threads in different colors in a window
code the heap example and copy the set-running! coolness to it from sine-test.ss
SCRIPT-------------------------------------------------------------------------------------- SCRIPT--------------------------------------------------------------------------------------
provide a running? behavior for the scripts, which actually works. provide a running? behavior for the scripts, which actually works.
@ -65,8 +87,6 @@ make (script-error) map to some exception stream for script errors only.
For now it is a synonym for (display) For now it is a synonym for (display)
Find a way to signal the error outside of FrTime's eventspace so that it doesnt loop the error endlessly Find a way to signal the error outside of FrTime's eventspace so that it doesnt loop the error endlessly
add a trace/break function.
make script errors highlight the location of the error make script errors highlight the location of the error
let traces take a line number without offset and find the first bindable location. let traces take a line number without offset and find the first bindable location.
@ -74,10 +94,10 @@ let traces take a line number without offset and find the first bindable locatio
OPTIMIZATIONS------------------------------------------------------------------------------- OPTIMIZATIONS-------------------------------------------------------------------------------
get rid of references to stepper and move files like marks.ss over to debugger
improve speed of lookup for line-col->pos; load them into a hashtable? not important since this is just startup time for the script. improve speed of lookup for line-col->pos; load them into a hashtable? not important since this is just startup time for the script.
improve speed of load/annotate
ERROR-CHECKING------------------------------------------------------------------------------ ERROR-CHECKING------------------------------------------------------------------------------
@ -94,10 +114,6 @@ The script does not tell you something went wrong though, and the solution (as-i
TESTING/CAPABILITIES------------------------------------------------------------------------ TESTING/CAPABILITIES------------------------------------------------------------------------
Does user interaction work? Can we step through loops one line at a time waiting for input? GUIs? Does user interaction work? Can we step through loops one line at a time waiting for input? GUIs?
Verify that when killing the debugger, all the memory and bindings that need to be released are released.
code the heap example and copy the set-running! coolness to it from sine-test.ss
We want a way to interactively step through code one line at a time when we hit a breakpoint. Provide way to check bindings at the same time -- EVEN IF NOT BOUND USING TRACE/BIND We want a way to interactively step through code one line at a time when we hit a breakpoint. Provide way to check bindings at the same time -- EVEN IF NOT BOUND USING TRACE/BIND
trace/bind what kind of interface do we want to dig into frames trace/bind what kind of interface do we want to dig into frames
@ -135,7 +151,20 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
;(rename script-running? client-running?)) ; disabled until it works ;(rename script-running? client-running?)) ; disabled until it works
;######################## STRUCTS ########################
; ;;;;; ; ;
; ; ; ; ;
; ; ; ;
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ;;;;
; ; ; ;; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;
(define-struct trace (evnt-rcvr)) ; frp:event-receiver (define-struct trace (evnt-rcvr)) ; frp:event-receiver
@ -147,7 +176,23 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
tracepoints ; hash-table of traces tracepoints ; hash-table of traces
line-col->pos)); memoized O(n) function to map line/col -> byte offset line-col->pos)); memoized O(n) function to map line/col -> byte offset
;#################### STRUCT-BUILDERS ##################### ;###########################################################################################################
; ;;;;; ; ; ;;;;; ;
; ; ; ; ; ;; ; ;
; ; ; ; ; ;
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ; ; ;;; ;;; ;;;; ;;;;; ;;;; ; ;;; ;;;;
; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;
; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;;
; Creates a trace that binds to the value of a variable in scope ; Creates a trace that binds to the value of a variable in scope
(define (create-bind-trace sym-to-bind) ; ((union (listof symbol?) symbol?) . -> . trace?) (define (create-bind-trace sym-to-bind) ; ((union (listof symbol?) symbol?) . -> . trace?)
@ -157,8 +202,23 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(define (create-break-trace) ; (void? . -> . trace?) (define (create-break-trace) ; (void? . -> . trace?)
(make-break-trace (frp:event-receiver))) (make-break-trace (frp:event-receiver)))
;###########################################################################################################
;################### GLOBAL VARIABLES ####################
; ; ; ;
; ;;;;;; ; ; ; ; ;
; ;; ; ; ; ; ; ;
; ; ; ; ; ; ;
; ; ; ;;;; ; ;;;; ;;;; ; ; ; ;;;; ; ;;; ;;;;
; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ;;;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ;
; ;;;;;; ; ;;;; ;;;;;; ;;;; ; ; ; ;;;; ; ; ;;;;
; Keeps track of all defined clients ; Keeps track of all defined clients
(define all-clients null) (define all-clients null)
@ -195,8 +255,24 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
second) second)
0)) 0))
;###########################################################################################################
;####################### CALLBACKS #######################
; ; ; ; ;
; ;;;;; ; ; ; ;
; ;; ; ; ; ; ;
; ; ; ; ; ;
; ; ;;;; ; ; ; ;;;; ;;;; ;;; ; ; ;;;;
; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ;;;;; ; ; ; ; ;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ; ; ; ;;;;;; ;;;; ; ;;; ; ; ;;;;
;
; Callback for when a breakpoint (tracepoint) is hit by the model ; Callback for when a breakpoint (tracepoint) is hit by the model
; ((client) breakpoint-struct) -> () ; ((client) breakpoint-struct) -> ()
@ -210,7 +286,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
[traces (hash-get trace-hash byte-offset)]) [traces (hash-get trace-hash byte-offset)])
(assert (not (empty? traces)) (assert (not (empty? traces))
(format "There are no traces at offset ~a, but a breakpoint is defined!" (format "There are no traces at offset ~a, but a breakpoint is defined!~n"
(number->string byte-offset))) (number->string byte-offset)))
; Run all traces at this breakpoint ; Run all traces at this breakpoint
@ -229,16 +305,48 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(semaphore-post run-semaphore))] (semaphore-post run-semaphore))]
;when a top level expression finishes ;when a top level expression finishes
[($ expression-finished return-val-list) (void)] [($ expression-finished return-val-list) (void)]))
[else-struct ;###########################################################################################################
(assert false)(printf "something else hit: ~a~n" else-struct)]))
;################### DEBUGGER BACKEND ####################
;(define (annotate-all-clients)
; ( ; ; ; ;
; ;;;;;; ; ;;;;;; ; ;
; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ;
; ; ; ; ;;;; ;;;;;; ; ;;; ; ; ;;;; ;;; ; ; ;;; ; ;;;; ;;;;;;
; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ;; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;;
; ;;;;;; ;;;;;; ;;;; ; ; ;;;;;; ;;;; ; ;;; ; ; ;;;; ; ; ;;;; ;
; ;
; ; ;
; ;;;;
#|(define (annotate-and-load-all-clients break namespace)
(let ([main-client-fn (client-filename (first all-clients))]
[annotate-module?
(lambda (m)
(filter (lambda (c)
(client-
]
[annotator
(lambda (fn m stx)
[fn (client-filename client)]
[breakpoints (hash-keys (client-tracepoints client))]
[receive-result (receive-result client)]
[annotator (lambda (stx)
(annotate stx breakpoints fn break))])
(parameterize ([current-namespace namespace])
(load/annotate main-client
(printf "expanding: ~a~n~n" (syntax-object->datum (expand stx)))))))|#
; retreives the binding of a variable from a breakpoint event ; retreives the binding of a variable from a breakpoint event
(define (binding event sym) (define (binding event sym)
@ -257,12 +365,15 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(define (script-error err) (define (script-error err)
; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up ; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up
; it could easily be an (error) ; it could easily be an (error)
(display (format "mztake:script-error: ~a~n" err))) (display (format "mztake:script-error: ~a~n---~n" err)))
(define (client-error err) (define (client-error err)
; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up ; TODO I made this a syntax error so that the little 'goto' clickable box wouldnt show up
; it could easily be an (error) ; it could easily be an (error)
(display (format "mztake:client-error: ~a~n" err))) (display (format "mztake:client-error: ~a~n---~n" err)))
(define (print-debug str)
(display (format "mztake:debug: ~a~n---~n" str)))
(define (fatal-script-error err client) (define (fatal-script-error err client)
(script-error err) (script-error err)
@ -297,15 +408,17 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(begin0 (begin0
(let loop ([stx (read-syntax filename port)]) (let loop ([stx (read-syntax filename port)])
(unless (eof-object? stx) (unless (eof-object? stx)
(printf "expanding: ~a~n~n" (syntax-object->datum (expand stx))) (print-debug (format "expanding: ~a" (syntax-object->datum (expand stx))))
(callback (callback
(expand stx) (expand stx)
(lambda () (loop (read-syntax filename port)))))) (lambda () (loop (read-syntax filename port))))))
(close-input-port port))))) (close-input-port port)))))
(define (start-debugger client) (define (start-debugger)
(let* ([breakpoint-origin (client-filename client)] (let* ([client (first all-clients)]
[_ (print-debug "change '[client (first all-clients)]' in (start-debugger)")]
[breakpoint-origin (client-filename client)]
[breakpoints (hash-keys (client-tracepoints client))] [breakpoints (hash-keys (client-tracepoints client))]
[program-expander (program-expander breakpoint-origin)] [program-expander (program-expander breakpoint-origin)]
[receive-result (receive-result client)]) [receive-result (receive-result client)])
@ -325,6 +438,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(set! run-semaphore go-semaphore) (set! run-semaphore go-semaphore)
(set! debugger-custodian user-custodian) (set! debugger-custodian user-custodian)
(print-debug (format "~a" debugger-custodian))
; we run the program under its own custodian so we can easily kill it...that's IT ; we run the program under its own custodian so we can easily kill it...that's IT
@ -335,7 +449,8 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(lambda () (lambda ()
; all errors and raises from the TARGET program will be caught here ; all errors and raises from the TARGET program will be caught here
; FrTime errors from the script have their own eventstream ; FrTime errors from the script have their own eventstream
(with-handlers ([(lambda (exn) #t) (with-handlers
([(lambda (exn) #t)
(lambda (exn) (lambda (exn)
(frp:send-event debugger:exceptions exn) (frp:send-event debugger:exceptions exn)
(client-error (if (exn? exn) (client-error (if (exn? exn)
@ -345,7 +460,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(thread (lambda () (thread (lambda ()
(thread-wait evaluation-thread) (thread-wait evaluation-thread)
; program terminates ; program terminates
(script:kill client)))))) (script:kill))))))
; returns a memoized function that takes (line column) -> position ; returns a memoized function that takes (line column) -> position
@ -392,16 +507,34 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(and (not (null? run-semaphore)) (and (not (null? run-semaphore))
(frp:value-now debugger:running?))) (frp:value-now debugger:running?)))
;###########################################################################################################
;#################### SCRIPT FUNCTIONS ###################
; ;;;;; ; ; ;;;;;;;
; ; ; ; ; ;
; ; ; ;
; ; ;;; ; ;;; ; ; ;;;; ;;;;; ; ; ; ; ;;;; ;;; ;;;;
; ; ; ; ;; ; ;; ; ; ; ; ; ;; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
; ;;;;; ;;; ; ; ;;;;;; ;;; ; ;;;; ; ; ; ;;; ;;;;
; ;
; ;
; ;
; Switches the running state on or off ; Switches the running state on or off
; (client [boolean]) -> () ; ([boolean]) -> ()
(define/contract script:set-running! (client? (union frp:behavior? boolean?) . -> . void?) (define/contract script:set-running! ((union frp:behavior? boolean?) . -> . void?)
(lambda (client run?) (lambda (run?)
(define (update) (define (update)
; (re)start the debugger if needed ; start the debugger if needed
(when (null? run-semaphore) (start-debugger client)) (when (null? run-semaphore) (start-debugger))
(when run? (semaphore-post run-semaphore)) (when run? (semaphore-post run-semaphore))
(frp:value-now run?)) (frp:value-now run?))
@ -414,46 +547,74 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
;TODO dont forget to contract this ;TODO dont forget to contract this
(define (script:running?) (define (script:running?)
(print "client-running? is broken") (script-error "client-running? is broken")
(and (running-now?) (and (running-now?)
(not debugger:exited?))) (not debugger:exited?)))
(define script:runtime/milliseconds debugger:runtime) (define script:runtime/milliseconds debugger:runtime)
(define script:runtime/seconds (define script:runtime/seconds
(frp:hold ((frp:changes debugger:runtime) (frp:hold ((frp:changes debugger:runtime)
. frp:==> . . frp:==> .
(lambda (t) (truncate (/ t 1000)))) (lambda (t) (truncate (/ t 1000))))
0)) 0))
; Creates a debugger client ; Creates a debugger client
; (string) -> (client) ; (string) -> (client)
(define/contract script:create (string? . -> . client?) (define/contract script:create ((union (listof (union string? symbol?)) string?) . -> . client?)
(lambda (filename) (lambda (filename)
(let ([c (make-client filename (make-hash) null)]) ; throwaway namespace so the module-name-resolver doesn't load an unannotated module
(parameterize ([current-namespace (make-namespace)])
(with-handlers ([exn:module?
(lambda (exn)
(client-error (format "Expected a module in client: ~a" filename)))])
(let* ([build-module-filename ; taken from module-overview.ss
(lambda (str)
(let ([try (lambda (ext)
(let ([tst (string-append str ext)])
(and (file-exists? tst) tst)))])
(or (try ".ss") (try ".scm") (try "") str)))]
[modpath (symbol->string ((current-module-name-resolver) filename #f #f))]
[modpath (build-module-filename
(if (regexp-match #rx"^," modpath)
(substring modpath 1 (string-length modpath))
modpath))]
[c (make-client modpath (make-hash) null)])
;TODO remove me
(print-debug (format "'~a' -> '~a'" filename modpath))
; set curried line-col->pos function for client ; set curried line-col->pos function for client
(set-client-line-col->pos! c (line-col->pos c)) (set-client-line-col->pos! c (line-col->pos c))
(set! all-clients (cons c all-clients)) (set! all-clients (cons c all-clients))
c))) c)))))
(define (script:pause) (script:set-running! #f))
(define (script:start/resume)
; only start the debugger once
(if (frp:value-now debugger:exited?)
(script-error "Cannot restart program once it has exited. Try restarting the script.")
(script:set-running! #t)))
(define (script:pause c) (script:set-running! c #f))
(define (script:start/resume c) (script:set-running! c #t))
; Kills the debugger immediately ; Kills the debugger immediately
; (client) -> () (define (script:kill)
(define/contract script:kill (client? . -> . void?) (script:pause)
(lambda (client)
(script:pause client)
; shutdown the custodian ; shutdown the custodian
(custodian-shutdown-all debugger-custodian) (custodian-shutdown-all debugger-custodian)
(set! debugger-custodian null)
(set! run-semaphore null)
; set the exit predicate to 'exited' ; set the exit predicate to 'exited'
(frp:set-cell! debugger:exited? #t))) (frp:set-cell! debugger:exited? #t))
; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver) ; (client (offset | line column) (symbol | listof symbols) -> (frp:event-receiver)
(define/contract script:trace/bind (client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?) (define/contract script:trace/bind (client? number? number? (union symbol? (listof symbol?)) . -> . frp:event?)
@ -467,6 +628,7 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(hash-get trace-hash pos (lambda () '())))) (hash-get trace-hash pos (lambda () '()))))
(trace-evnt-rcvr trace)))) (trace-evnt-rcvr trace))))
(define/contract script:trace/break (client? number? number? . -> . frp:event?) (define/contract script:trace/break (client? number? number? . -> . frp:event?)
(lambda (client line col) (lambda (client line col)
(let ([trace-hash (client-tracepoints client)] (let ([trace-hash (client-tracepoints client)]
@ -476,4 +638,6 @@ Find a way to bind to the result of ananonymous expression: here->(add1 2)
(cons trace (cons trace
(hash-get trace-hash pos (lambda () '())))) (hash-get trace-hash pos (lambda () '()))))
(trace-evnt-rcvr trace)))) (trace-evnt-rcvr trace))))
;###########################################################################################################
) )

16
collects/mztake/private/load-annotator.ss
View File

@ -23,7 +23,7 @@
If true, loads source file and annotates. If true, loads source file and annotates.
Else, tries to load compiled or source, no annotation. Else, tries to load compiled or source, no annotation.
>annotator : (syntax? . -> . syntax?) >annotator : (string? symbol? syntax? . -> . syntax?)
|# |#
(define (load-with-annotations initial-module annotate-module? annotator) (define (load-with-annotations initial-module annotate-module? annotator)
(parameterize (parameterize
@ -50,11 +50,11 @@
(lambda () (lambda ()
(parameterize ([read-accept-compiled #f] (parameterize ([read-accept-compiled #f]
[current-load-relative-directory base]) [current-load-relative-directory base])
(unless m (raise 'oops)) (unless m (raise 'module-name-not-passed-to-load/annotate))
(with-module-reading-parameterization (with-module-reading-parameterization
(lambda () (lambda ()
(let* ([first (read-syntax src in-port)] (let* ([first (expand (read-syntax src in-port))]
[module-ized-exp (annotator (check-module-form first m fn))] [module-ized-exp (annotator fn m (check-module-form first m fn))]
[second (read in-port)]) [second (read in-port)])
(unless (eof-object? second) (unless (eof-object? second)
(raise-syntax-error (raise-syntax-error
@ -65,12 +65,13 @@
(lambda () (close-input-port in-port))))) (lambda () (close-input-port in-port)))))
; taken directly from mred.ss -- it's not exported... ; taken directly from mred.ss -- it's not exported...
(define (build-input-port filename) (define (build-input-port filename)
(let ([p (open-input-file filename)]) (let ([p (open-input-file filename)])
(port-count-lines! p) (port-count-lines! p)
(let ([p (cond (let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p)
[(regexp-match-peek "^WXME01[0-9][0-9] ## " p)
(let ([t (make-object text%)]) (let ([t (make-object text%)])
(send t insert-file p 'standard) (send t insert-file p 'standard)
(close-input-port p) (close-input-port p)
@ -90,12 +91,13 @@
(lloop c)))))) (lloop c))))))
(values p filename)))) (values p filename))))
(define (test annotate-all?) (define (test annotate-all?)
(load-with-annotations '(lib "mztake.ss" "mztake") (load-with-annotations '(lib "mztake.ss" "mztake")
(lambda (fn m) (lambda (fn m)
(printf "~a ~a~n" fn m) (printf "~a ~a~n" fn m)
annotate-all?) annotate-all?)
(lambda (stx) stx))) (lambda (fn m stx) stx)))
;(test #t) ; slow ;(test #t) ; slow
;(test #f) ; fast ;(test #f) ; fast
) )