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

implemented top-level lookups, with scoping

Browse Source 
svn: r2173
This commit is contained in:
Guillaume Marceau 2006-02-08 17:48:49 +00:00
parent 3e7e50d5f8
commit debdf0e431
4 changed files with 44 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mztake/annotator.ss
View File

@ -5,6 +5,7 @@
(lib "list.ss")
(lib "marks.ss" "mztake")
(lib "mred.ss" "mred")
(lib "pretty.ss")
(lib "load-sandbox.ss" "mztake")
(prefix srfi: (lib "search.ss" "srfi" "1"))
)
@ -170,14 +171,16 @@
(kernel:kernel-syntax-case
stx #f
[(define-values (var ...) expr)
(begin (for-each (lambda (v) (record-bound-id 'bind v v))
(syntax->list #'(var ...)))
(quasisyntax/loc stx
(begin (define-values (var ...) #,(annotate #`expr empty #t module-name ))
(begin (define-values (var ...) #,(annotate #`expr empty #t module-name))
#,(if (syntax-source #'stx)
#`(begin (#,record-top-level-id '#,module-name 'var var) ...)
#'(void))
(void))))
(void)))
)
]
[(define-syntaxes (var ...) expr)
stx]
@ -361,7 +364,7 @@
(syntax->list #'exprs))])
(if is-tail?
(quasisyntax/loc expr #,subexprs)
(wcm-wrap (make-debug-info expr bound-vars bound-vars 'normal #f (previous-bindings bound-vars))
(wcm-wrap (make-debug-info module-name expr bound-vars bound-vars 'normal #f (previous-bindings bound-vars))
(quasisyntax/loc expr #,subexprs))))]
[(#%datum . _) expr]
@ -376,7 +379,7 @@
(if annotate-break?
(break-wrap
(make-debug-info expr bound-vars bound-vars 'at-break #f (previous-bindings bound-vars))
(make-debug-info module-name expr bound-vars bound-vars 'at-break #f (previous-bindings bound-vars))
annotated
expr
is-tail?)

1
collects/mztake/engine.ss
View File

@ -245,7 +245,6 @@
[bindings (hash-get modules module-name (lambda () (make-hash)))])
(unless (hash-mem? modules module-name)
(hash-put! modules module-name bindings))
(printf "record-top-level-id ~a ~a ~a ~n" module-name var-name val)
(hash-put! bindings var-name val)))
(define (launch-sandbox process)

18
collects/mztake/marks.ss
View File

@ -5,7 +5,7 @@
(lib "my-macros.ss" "stepper" "private")
(lib "shared.ss" "stepper" "private"))
(define-struct full-mark-struct (source label bindings values))
(define-struct full-mark-struct (module-name source label bindings values))
; CONTRACTS
(define mark? (-> ; no args
@ -28,6 +28,7 @@
skipto-mark
strip-skiptos
mark-list?
mark-module-name
mark-source
mark-bindings
mark-label
@ -67,15 +68,18 @@
; the 'varargs' creator is used to avoid an extra cons cell in every mark:
(define (make-make-full-mark-varargs source label bindings)
(define (make-make-full-mark-varargs module-name source label bindings)
(lambda (values)
(make-full-mark-struct source label bindings values)))
(make-full-mark-struct module-name source label bindings values)))
; see module top for type
(define (make-full-mark location label bindings assembled-info-stx)
(datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs location label bindings)
(define (make-full-mark module-name source label bindings assembled-info-stx)
(datum->syntax-object #'here `(lambda () (,(make-make-full-mark-varargs module-name source label bindings)
,assembled-info-stx))))
(define (mark-module-name mark)
(full-mark-struct-module-name (mark)))
(define (mark-source mark)
(full-mark-struct-source (mark)))
@ -166,8 +170,8 @@
;;
;;;;;;;;;;
(define (make-debug-info source tail-bound free-vars label lifting? assembled-info-stx)
(make-full-mark source label free-vars assembled-info-stx))
(define (make-debug-info module-name source tail-bound free-vars label lifting? assembled-info-stx)
(make-full-mark module-name source label free-vars assembled-info-stx))
(define (assemble-debug-info tail-bound free-vars label lifting?)
(map make-mark-binding-stx free-vars))

39
collects/mztake/mztake.ss
View File

@ -6,6 +6,7 @@
(rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?)
(rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof)
"mztake-structs.ss"
"more-useful-code.ss"
(lib "etc.ss")
(lib "list.ss")
"marks.ss"
@ -15,6 +16,7 @@
(print-struct true)
(provide (rename loc loc$)
debug-process-running-e
loc/r
trace
bind
@ -108,18 +110,30 @@
(trace* (current-process) loc proc)]
[(_ loc body ...)
(trace* (current-process) loc (lambda () body ...))]))
(define (mztake-top* name thunk )
(with-handlers
([exn:fail?
(lambda (exn)
(with-handlers
([exn:fail? (lambda (exn2) (raise exn))])
(bind* (current-process) name)))])
(thunk)))
(define-syntax (mztake-top stx)
(syntax-case stx ()
[(_ . name)
(begin
#'(with-handlers
([exn:fail?
(lambda (exn)
(with-handlers
([exn:fail? (lambda (exn2) (raise exn))])
(bind* (current-process) 'name)))])
(#%top . name)))]))
#'(mztake-top* 'name (lambda () (#%top . name)))]))
(define (lookup-in-top-level p name)
(let/ec success
(for-each
(lambda (m)
(let/ec fail
(let ([fail* (lambda () (fail false))])
(success (hash-get (hash-get (debug-process-top-level p) m fail*) name fail*)))))
(map mark-module-name (debug-process-marks p)))
(error 'bind "variable `~a' not found in target at the current location" name)))
(define (bind* p name)
(unless (debug-process-marks p)
@ -128,10 +142,9 @@
(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))))
(if (empty? bs)
(lookup-in-top-level p name)
(mark-binding-value (first bs)))))
(define-syntax bind
(syntax-rules ()