From 038c69c3ef4ee28f01415353f6f466a28d818747 Mon Sep 17 00:00:00 2001 From: Guillaume Marceau Date: Thu, 19 Jan 2006 17:43:00 +0000 Subject: [PATCH] implemented pattern matching locations svn: r1872 --- collects/mztake/demos/sine/sine-mztake.ss | 3 +- collects/mztake/engine.ss | 148 +++++++++++++++------- collects/mztake/mztake-structs.ss | 6 +- collects/mztake/mztake.ss | 14 +- collects/mztake/tests/engine-test.ss | 12 ++ 5 files changed, 129 insertions(+), 54 deletions(-) create mode 100644 collects/mztake/tests/engine-test.ss diff --git a/collects/mztake/demos/sine/sine-mztake.ss b/collects/mztake/demos/sine/sine-mztake.ss index f34366b8c3..dc94bd1a9e 100644 --- a/collects/mztake/demos/sine/sine-mztake.ss +++ b/collects/mztake/demos/sine/sine-mztake.ss @@ -2,7 +2,8 @@ (lib "useful-code.ss" "mztake")) (require (lib "mztake.ss" "mztake")) -(define/bind (loc "sine.ss" 5 ) x sin-x) +;(define/bind (loc "sine.ss" 5 ) x sin-x) +(define/bind (loc "sine.ss" '(if _ ...) ) x sin-x) (define (pick-cute-color x y) (if (< 200 y) diff --git a/collects/mztake/engine.ss b/collects/mztake/engine.ss index 47092f2734..86731360cf 100644 --- a/collects/mztake/engine.ss +++ b/collects/mztake/engine.ss @@ -7,8 +7,9 @@ "more-useful-code.ss" ; mostly for hash- bindings "mztake-structs.ss" "load-sandbox.ss" - "annotator.ss") - + "annotator.ss" + (lib "match.ss")) + (provide process:set-main! current-policy all-debug-processes @@ -20,40 +21,44 @@ process:paused->running pause resume - trace*) + trace* + + read-all-syntax + pattern->pos) ;Keeps track of all debugging processes (define all-debug-processes null) + ; produces a nested list of (line column offset) for all addressable syntax + (define (unwrap-syntax stx) + (let ([elt (list (syntax-line stx) + (syntax-column stx) + (sub1 (syntax-position stx)))]) + (syntax-case stx () + [(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))] + [x elt]))) + + (define (read-all-syntax filename) + (parameterize ([port-count-lines-enabled #t]) + (let ([port (open-input-file filename)]) + (begin0 + (let loop ([stx (read-syntax filename port)]) + (if (eof-object? stx) '() + (cons stx + (loop (read-syntax filename port))))) + (close-input-port port))))) + ;; returns a memoized function that takes (line column) -> position ;; line-col->pos : (debug-file? . -> . (number? number? . -> . (union void? number?))) - (define (line-col->pos filename) - ; produces a nested list of (line column offset) for all addressable syntax - (define (unwrap-syntax stx) - (let ([elt (list (syntax-line stx) - (syntax-column stx) - (sub1 (syntax-position stx)))]) - (syntax-case stx () - [(item ...) (cons elt (map unwrap-syntax (syntax->list stx)))] - [x elt]))) - - (let ([pos-list - (flatten (parameterize ([port-count-lines-enabled #t]) - (let ([port (open-input-file filename)]) - (begin0 - (let loop ([stx (read-syntax filename port)]) - (if (eof-object? stx) '() - (cons (unwrap-syntax stx) - (loop (read-syntax filename port))))) - (close-input-port port)))))]) - + (define (line-col->pos stx) + (let ([pos-list (flatten (map unwrap-syntax stx))]) (lambda (line maybe-col) (let loop ([lst pos-list]) (cond [(empty? lst) (error 'loc - "No syntax found for trace at line/column ~a:~a in client `~a'" - line maybe-col filename)] + "No syntax found for trace at line/column ~a:~a in `~a'" + line maybe-col (syntax-source stx))] [(and (<= line (first (first lst))) (or (not maybe-col) (<= maybe-col (second (first lst))))) @@ -61,12 +66,58 @@ [else (loop (rest lst))]))))) + (define (pattern->pos stx-lst) + (define (quote-symbols lst) + (cond + [(empty? lst) empty] + [(eq? lst '_) lst] + [(eq? lst '...) lst] + [(symbol? lst) `(quote ,lst)] + [else (cons (quote-symbols (first lst)) + (quote-symbols (rest lst)))])) + + (define (collect-locations h stx lst) + (let loop ([stx stx] [lst lst]) + (cond + [(empty? stx) (void)] + [(pair? stx) + (loop (first stx) (first lst)) + (loop (rest stx) (rest lst))] + [else + (when (syntax-line stx) + (hash-put! h lst (sub1 (syntax-position stx)))) + (when (pair? (syntax-e stx)) + (loop (first (syntax-e stx)) (first lst)) + (loop (rest (syntax-e stx)) (rest lst)))]))) + + (define stx2line-col (make-hash)) + (define lst (map syntax-object->datum stx-lst)) + + (for-each (lambda (s l) (collect-locations stx2line-col s l)) + stx-lst lst) + + (lambda (pattern) + (let ([pred (eval `(begin (require (lib "match.ss")) + (lambda (v) + (match v + [,(quote-symbols pattern) #t] + [_ #f]))))]) + (let loop ([lst lst]) + (let ([sub (if (pair? lst) + (append (loop (first lst)) + (loop (rest lst))) + empty)]) + (if (and (hash-mem? stx2line-col lst) (pred lst)) + (cons (hash-get stx2line-col lst) sub) + sub)))))) + + (define (find-client process modpath) (cond [(memf (lambda (c) (equal? (debug-client-modpath c) modpath)) (debug-process-clients process)) => first] [else false])) - + (define (find-client/create process modpath) (or (find-client process modpath) (create-debug-client process modpath))) @@ -98,12 +149,12 @@ [no-where? (not (debug-process-where process))] [no-events? (and no-traces? no-where? (not (debug-process-pause-requested? process)))]) - + (unless no-events? (let* ([marks (cons top-mark (continuation-mark-set->list rest-marks debug-key))]) (set-debug-process-marks! process marks) - + (if no-where? ;; No where event to generate (cond [has-single-trace? @@ -113,7 +164,7 @@ ((trace-struct-thunk t))))] [no-traces? void] [else (frp:send-synchronous-events (traces->events traces))]) - + ;; With a where event to generate (let ([where-event (debug-process-where process)] [w (map (compose syntax-local-infer-name mark-source) marks)]) @@ -123,7 +174,7 @@ (let* ([where-event (list where-event w)] [trace-events (traces->events traces)]) (frp:send-synchronous-events (cons where-event trace-events)))))) - + ;; Now that we processed the trace, do we want to pause or continue (when (debug-process-pause-requested? process) (let loop () @@ -134,8 +185,8 @@ (set-debug-process-resume-requested?! process false)) (set-debug-process-marks! process false))))) - - + + (define ((break-after process client) top-mark marks . vals) @@ -160,7 +211,7 @@ (define (dir-contains? dir filename) (let ([dir-lst (unbuild-path dir)]) (equal? dir-lst (head (unbuild-path filename) (length dir-lst))))) - + (define (map-policy-tag tag) (cond [(eq? tag 'fast) false] [(eq? tag 'debuggable) true] @@ -186,13 +237,13 @@ (path->string filename)));; TODO: harmonize path & string (debug-process-clients process)) true)) - + (define (launch-sandbox process) (unless (debug-process-main-client process) (error 'launch-sandbox "No main file specified. Use TRACE or SET-MAIN! to indicate where to start execution")) - + (parameterize ([current-inspector (make-inspector)]) (require/sandbox+annotations (debug-process-custodian process) @@ -201,10 +252,10 @@ (lambda (msg exn) (frp:send-event (debug-process-exceptions process) exn) (orig-err-disp msg exn))) - + ;; target file `(file ,(debug-client-modpath (debug-process-main-client process))) - + ;; annotate-module? (lambda (filename module-name) (or (process-has-file? process filename) @@ -292,7 +343,8 @@ (define (create-debug-client process modpath) ; throwaway namespace so the module-name-resolver doesn't load an unannotated module (parameterize ([current-namespace (make-namespace)]) - (let ([client (create-empty-debug-client)]) + (let ([client (create-empty-debug-client)] + [stx (read-all-syntax modpath)]) (for-each (lambda (c) (when (equal? modpath (debug-client-modpath c)) (raise-syntax-error 'mztake:script-error:create-debug-client @@ -301,7 +353,8 @@ (set-debug-client-modpath! client modpath) (set-debug-client-process! client process) - (set-debug-client-line-col->pos! client (line-col->pos modpath)) + (set-debug-client-line-col->pos! client (line-col->pos stx)) + (set-debug-client-pattern->pos! client (pattern->pos stx)) (set-debug-process-clients! process (append (list client) (debug-process-clients process))) @@ -324,16 +377,23 @@ (substring modpath 1 (string-length modpath)) modpath)))) + (define (loc->positions client loc) + (if (loc/lc? loc) + (list ((debug-client-line-col->pos client) (loc/lc-line loc) (loc/lc-col loc))) + ((debug-client-pattern->pos client) (loc/p-pattern loc)))) + (define (trace* p loc thunk) (let* ([modpath (reqspec->modpath (loc-reqspec loc))] [client (find-client/create p modpath)] [trace-hash (debug-client-tracepoints client)] [trace (make-trace-struct (frp:event-receiver) thunk)] - [pos ((debug-client-line-col->pos client) (loc-line loc) (loc-col loc))]) - ; add the trace to the list of traces for that byte-offset - (hash-put! trace-hash pos - (append (hash-get trace-hash pos (lambda () '())) - (list trace))) + [positions (loc->positions client loc)]) + ; add the trace to the list of traces for these byte-offsets + (for-each (lambda (pos) + (hash-put! trace-hash pos + (append (hash-get trace-hash pos (lambda () '())) + (list trace)))) + positions) (trace-struct-evnt-rcvr trace))) (define (syntax-local-infer-name stx) diff --git a/collects/mztake/mztake-structs.ss b/collects/mztake/mztake-structs.ss index 3bdb8fae2b..9c7e4ea0ae 100644 --- a/collects/mztake/mztake-structs.ss +++ b/collects/mztake/mztake-structs.ss @@ -26,6 +26,7 @@ (define-struct debug-client (modpath ; complete-path of the module tracepoints ; hash-table of traces line-col->pos ; memoized O(n) function to map line/col -> byte offset + pattern->pos process)) ; parent debug-process (define-struct debug-process (custodian ; If you shutdown-all it will kill the debugger process @@ -44,7 +45,9 @@ where ; a behavior signaling each position where we pause marks)) ; while paused, the marks at the point of the pause (else false) - (define-struct loc (reqspec line col)) + (define-struct loc (reqspec)) + (define-struct (loc/lc loc) (line col)) + (define-struct (loc/p loc) (pattern)) ;########################################################################################################### @@ -68,6 +71,7 @@ (make-debug-client null ; modpath (make-hash) ; tracepoints null ; line-col->pos function + null null)) ; process ;########################################################################################################### diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index da40c05497..c2ab21a9d2 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -18,14 +18,10 @@ bind define/bind define/bind-e + [rename loc/opt-col loc] [rename mztake-top #%top]) - (provide/contract [loc-reqspec (loc? . -> . require-spec?)] - [loc-line (loc? . -> . number?)] - [loc-col (loc? . -> . number?)] - [rename loc/opt-col loc - ((any/c number?) (number?) . opt-> . loc?)] - [exceptions (() (debug-process?) . opt-> . frp:event?)] + (provide/contract [exceptions (() (debug-process?) . opt-> . frp:event?)] [exited? (() (debug-process?) . opt-> . frp:behavior?)] [kill (() (debug-process?) . opt-> . void?)] [kill-all (-> void?)] @@ -42,8 +38,10 @@ [bind* (debug-process? symbol? . -> . any)]) (define loc/opt-col - (opt-lambda (reqspec line [col #f]) - (loc reqspec line col))) + (opt-lambda (reqspec line/pattern [col #f]) + (if (number? line/pattern) + (make-loc/lc reqspec line/pattern col) + (make-loc/p reqspec line/pattern)))) (define exceptions (opt-lambda ([p (current-process)]) diff --git a/collects/mztake/tests/engine-test.ss b/collects/mztake/tests/engine-test.ss new file mode 100644 index 0000000000..4789d6ad78 --- /dev/null +++ b/collects/mztake/tests/engine-test.ss @@ -0,0 +1,12 @@ +(module engine-test mzscheme + + (require "../engine.ss") + + (define stx (read-all-syntax "../demos/dijkstra/dijkstra.ss")) + + (define fn (pattern->pos stx)) + (define result (fn '(define (_ ...) _ ...))) + + (define expected '((7 2 147) (18 2 463))) + (printf "~a~n" (list (equal? result expected) result expected)) + ) \ No newline at end of file