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

implemented pattern matching locations

Browse Source 
svn: r1872
This commit is contained in:
Guillaume Marceau 2006-01-19 17:43:00 +00:00
parent 24b9e2f5c7
commit 038c69c3ef
5 changed files with 129 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)

122
collects/mztake/engine.ss
View File

@ -7,7 +7,8 @@
"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
@ -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,6 +66,52 @@
[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))
@ -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)

6
collects/mztake/mztake-structs.ss
View File

@ -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
;###########################################################################################################

14
collects/mztake/mztake.ss
View File

@ -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)])

12
collects/mztake/tests/engine-test.ss Normal file
View File

@ -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))
)