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

...

Browse Source 
svn: r2065
This commit is contained in:
John Clements 2006-02-01 00:15:59 +00:00
parent bc0f1265c5
commit 96ced692fa
7 changed files with 74 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
collects/stepper/private/annotate.ss
View File

@ -22,7 +22,7 @@
(provide/contract
[annotate
(-> syntax? ; syntax to annotate
(opt->* ((union continuation-mark-set? false/c)
(opt->* ((or/c continuation-mark-set? false/c)
break-kind?)
(list?)
(any/c)) ; procedure for runtime break
@ -328,7 +328,7 @@
(define (top-level-annotate/inner exp source-exp defined-name)
(let*-2vals ([(annotated dont-care)
(annotate/inner exp 'all #f defined-name)])
(annotate/inner exp 'all #f defined-name #f)])
#`(with-continuation-mark #,debug-key
#,(make-top-level-mark source-exp)
;; inserting eta-expansion to prevent destruction of top-level mark
@ -348,7 +348,7 @@
; a) an annotated s-expression
; b) a list of varrefs for the variables which occur free in the expression
;
;(syntax-object BINDING-SET bool bool (union #f symbol (list binding symbol)) ->
;(syntax-object BINDING-SET bool bool (or/c #f symbol (list binding symbol)) ->
; sexp (list-of z:varref))
@ -368,8 +368,9 @@
;
(define annotate/inner
;(-> syntax? binding-set? boolean? (union false/c syntax? (list/p syntax? syntax?)) (vector/p syntax? binding-set?))
(lambda (exp tail-bound pre-break? procedure-name-info)
#;(syntax? binding-set? boolean? (or/c false/c syntax? (list/p syntax? syntax?)) (or/c false/c integer?)
. -> . (vector/p syntax? binding-set?))
(lambda (exp tail-bound pre-break? procedure-name-info offset-counter)
(cond [(syntax-property exp 'stepper-skipto)
(let* ([free-vars-captured #f] ; this will be set!'ed
@ -379,7 +380,7 @@
(syntax-property exp 'stepper-skipto)
exp
(lambda (subterm)
(let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
(let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info offset-counter)])
(set! free-vars-captured free-vars)
stx)))])
(2vals (wcm-wrap
@ -393,50 +394,50 @@
[else
(let*
;; recurrence procedures, used to recur on sub-expressions:
([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info))]
[non-tail-recur (lambda (exp) (annotate/inner exp null #f #f))]
[result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info))]
[set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name))]
([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info #f))]
[non-tail-recur (lambda (exp) (annotate/inner exp null #f #f #f))]
[result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info #f))]
[set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name #f))]
[let-rhs-recur (lambda (exp binding-names dyn-index-syms)
(let* ([proc-name-info
(if (not (null? binding-names))
(list (car binding-names) (car dyn-index-syms))
#f)])
(annotate/inner exp null #f proc-name-info)))]
[lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f))]
(annotate/inner exp null #f proc-name-info #f)))]
[lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f #f))]
; let bodies have a startling number of recurrence patterns. ouch!
;; no pre-break, tail w.r.t. new bindings:
[let-body-recur/single
(lambda (exp bindings)
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info))]
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info #f))]
;; no pre-break, non-tail w.r.t. new bindings
[let-body-recur/first
(lambda (exp)
(lambda (exp-n-index)
(apply-to-first-of-2vals
normal-break/values-wrap
(non-tail-recur exp)))]
(annotate/inner (car exp-n-index) null #f #f (cadr exp-n-index))))]
;; yes pre-break, non-tail w.r.t. new bindings
[let-body-recur/middle
(lambda (exp)
(lambda (exp-n-index)
(apply-to-first-of-2vals
normal-break/values-wrap
(annotate/inner exp null #t #f)))]
(annotate/inner (car exp-n-index) null #t #f (cadr exp-n-index))))]
;; yes pre-break, tail w.r.t. new bindings:
[let-body-recur/last
(lambda (exp bindings)
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #t procedure-name-info))]
(lambda (exp-n-index bindings)
(annotate/inner (car exp-n-index) (binding-set-union (list tail-bound bindings)) #t procedure-name-info (cadr exp-n-index)))]
;; different flavors of make-debug-info allow users to provide only the needed fields:
[make-debug-info-normal (lambda (free-bindings)
(make-debug-info exp tail-bound free-bindings 'none #t))]
(make-debug-info exp tail-bound free-bindings 'none #t offset-counter))]
[make-debug-info-app (lambda (tail-bound free-bindings label)
(make-debug-info exp tail-bound free-bindings label #t))]
(make-debug-info exp tail-bound free-bindings label #t offset-counter))]
[make-debug-info-let (lambda (free-bindings binding-list let-counter)
(make-debug-info exp
(binding-set-union (list tail-bound
@ -446,7 +447,8 @@
binding-list
(list let-counter))) ; NB using bindings as varrefs
'let-body
#t))]
#t
offset-counter))]
[outer-wcm-wrap (if pre-break?
wcm-pre-break-wrap
wcm-wrap)]
@ -459,6 +461,14 @@
annotated)
free-vars))]
;; taken from SRFI 1:
[iota
(lambda (n) (build-list n (lambda (x) x)))]
[with-indices
(lambda (exps)
(map list exps (iota (length exps))))]
; @@ @@ @@
; @ @ @
@ -587,10 +597,10 @@
[lifted-vars (apply append lifted-var-sets)]
[(annotated-vals free-varref-sets-vals)
(2vals-map let-rhs-recur vals binding-sets lifted-var-sets)]
[bodies-list (syntax->list #'bodies)]
[bodies-list (with-indices (syntax->list #'bodies))]
[(annotated-body free-varrefs-body)
(if (= (length bodies-list) 1)
(let-body-recur/single (car bodies-list) binding-list)
(let-body-recur/single (caar bodies-list) binding-list)
;; like a map, but must special-case first and last exps:
(let*-2vals
([first (car bodies-list)]
@ -710,7 +720,7 @@
; @ @
; @@@@@ @@@@@
; if-abstraction: (-> syntax? syntax? (union false/c syntax?) (values syntax? varref-set?))
; if-abstraction: (-> syntax? syntax? (or/c false/c syntax?) (values syntax? varref-set?))
[if-abstraction
(lambda (test then else)
(let*-2vals

2
collects/stepper/private/debugger-model.ss
View File

@ -14,7 +14,7 @@
(define program-expander-contract
(-> (-> void?) ; init
(-> (union eof-object? syntax? (cons/c string? any/c)) (-> void?) void?) ; iter
(-> (or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) void?) ; iter
void?))
(provide debugger-model@)

10
collects/stepper/private/marks.ss
View File

@ -13,7 +13,7 @@
(define mark-list? (listof procedure?))
(provide/contract
;[make-debug-info (-> any/c binding-set? varref-set? any/c boolean? syntax?)] ; (location tail-bound free label lifting? -> mark-stx)
;[make-debug-info (-> any/c binding-set? varref-set? any/c boolean? syntax?)] ; (location tail-bound free label lifting? offset-index -> mark-stx)
[expose-mark (-> mark? (list/c any/c symbol? (listof (list/c identifier? any/c))))]
[make-top-level-mark (syntax? . -> . syntax?)]
[lookup-all-bindings ((identifier? . -> . boolean?) mark-list? . -> . (listof any/c))]
@ -155,11 +155,11 @@
;;
;; make-debug-info builds the thunk which will be the mark at runtime. It contains
;; a source expression and a set of binding/value pairs.
;; (syntax-object BINDING-SET VARREF-SET any boolean) -> debug-info)
;; (syntax-object BINDING-SET VARREF-SET any boolean (union/c false/c integer?)) -> debug-info)
;;
;;;;;;;;;;
(define (make-debug-info source tail-bound free-vars label lifting?)
(define (make-debug-info source tail-bound free-vars label lifting? offset-index)
(let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)])
(if lifting?
(let*-2vals ([let-bindings (filter (lambda (var)
@ -172,9 +172,9 @@
(syntax-property var 'stepper-binding-type)))))
kept-vars)]
[lifter-syms (map get-lifted-var let-bindings)])
(make-full-mark source label (append kept-vars lifter-syms)))
(make-full-mark (syntax-property source 'stepper-offset-index offset-index) label (append kept-vars lifter-syms)))
;; I'm not certain that non-lifting is currently tested: 2005-12, JBC
(make-full-mark source label kept-vars))))
(make-full-mark (syntax-property source 'stepper-offset-index offset-index) label kept-vars))))
(define (make-top-level-mark source-expr)

8
collects/stepper/private/model.ss
View File

@ -49,14 +49,14 @@
(define program-expander-contract
((-> void?) ; init
((union eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter
((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter
. -> .
void?))
(provide/contract [go (program-expander-contract ; program-expander
(step-result? . -> . void?) ; receive-result
(union render-settings? false/c) ; render-settings
(or/c render-settings? false/c) ; render-settings
boolean? ; track-inferred-names?
. -> .
void?)])
@ -67,11 +67,11 @@
(local
(;; finished-exps: (listof (list/c syntax-object? (union number? false?)( -> any)))
(;; finished-exps: (listof (list/c syntax-object? (or/c number? false?)( -> any)))
;; because of mutation, these cannot be fixed renderings, but must be re-rendered at each step.
(define finished-exps null)
(define/contract add-to-finished
((-> syntax?) (union (listof natural-number/c) false/c) (-> any) . -> . void?)
((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any) . -> . void?)
(lambda (exp-thunk lifting-indices getter)
(set! finished-exps (append finished-exps (list (list exp-thunk lifting-indices getter))))))

34
collects/stepper/private/reconstruct.ss
View File

@ -16,7 +16,7 @@
(provide/contract
[reconstruct-completed (syntax?
(union (listof natural-number/c) false/c)
(or/c (listof natural-number/c) false/c)
(-> (listof any/c))
render-settings?
. -> .
@ -24,12 +24,12 @@
;; front ends for reconstruct-current
[reconstruct-left-side (mark-list?
(union (listof any/c) false/c)
(or/c (listof any/c) false/c)
render-settings?
. -> .
(listof syntax?))]
[reconstruct-right-side (mark-list?
(union (listof any/c) false/c)
(or/c (listof any/c) false/c)
render-settings?
. -> .
(listof syntax?))]
@ -39,7 +39,7 @@
(list/c (listof syntax?) (listof syntax?)))]
[final-mark-list? (-> mark-list? boolean?)]
[skip-step? (-> break-kind? (union mark-list? false/c) render-settings? boolean?)]
[skip-step? (-> break-kind? (or/c mark-list? false/c) render-settings? boolean?)]
[step-was-app? (-> mark-list? boolean?)])
(define nothing-so-far (gensym "nothing-so-far-"))
@ -233,7 +233,7 @@
; new-index)]))))
; construct-lifted-name
; (-> syntax? (union num? false/c) symbol?)
; (-> syntax? (or/c num? false/c) symbol?)
(define/contract construct-lifted-name
(-> syntax? number? syntax?)
@ -522,7 +522,7 @@
; ;;;; ;;; ;;; ; ; ;;; ;;; ;; ; ; ;;; ;;;; ;;;; ; ; ; ;;; ;
;
;
7
; recon-source-expr
@ -539,7 +539,7 @@
(define/contract recon-source-expr
(-> syntax? mark-list? binding-set? binding-set? render-settings? syntax?)
(lambda (expr mark-list dont-lookup use-lifted-names render-settings)
(if (syntax-property expr 'stepper-skipto)
(if (syntax-property expr 'stepper-skipto)
(skipto-reconstruct
(syntax-property expr 'stepper-skipto)
expr
@ -857,6 +857,7 @@
(recon-source-expr expr mark-list null null render-settings))]
[top-mark (car mark-list)]
[exp (mark-source top-mark)]
[iota (lambda (x) (build-list x (lambda (x) x)))]
[recon-let
(lambda ()
@ -910,8 +911,19 @@
(map reconstruct-remaining-def (cdr not-done-glumps))))
null)]
[recon-bindings (append before-bindings after-bindings)]
[rectified-bodies (map (lambda (body) (recon-source-expr body mark-list binding-list binding-list render-settings))
(syntax->list (syntax bodies)))])
;; there's a terrible tangle of invariants here. Among them:
;; num-defns-done = (length binding-sets) IFF the so-far has a 'user-stepper-offset' index
;; that is not #f (that is, we're evaluating the body...)
[so-far-offset-index (>>> (and (not (eq? so-far nothing-so-far))
(syntax-property so-far 'user-stepper-offset-index)))]
[bodies (syntax->list (syntax bodies))]
[rectified-bodies
(map (lambda (body offset-index)
(if (eq? offset-index so-far-offset-index)
so-far
(recon-source-expr body mark-list binding-list binding-list render-settings)))
bodies
(iota (length bodies)))])
(attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))])
(kernel:kernel-syntax-case exp #f
; variable references
@ -1094,7 +1106,7 @@
#f))])]))
; uncomment to see all breaks coming in:
#;(define _ (printf "break-kind: ~a\ninnermost source: ~a\nreturned-value-list: ~a\n"
(define _ (printf "break-kind: ~a\ninnermost source: ~a\nreturned-value-list: ~a\n"
break-kind
(and (pair? mark-list)
(syntax-object->datum (mark-source (car mark-list))))
@ -1115,6 +1127,8 @@
(error 'reconstruct "context expected one value, given ~v" returned-value-list))
(recon-value (car returned-value-list) render-settings))
(recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings))])
(>>> innermost)
(>>> (syntax-property innermost 'user-stepper-offset-index))
(unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f)))
((double-break)
(let* ([source-expr (mark-source (car mark-list))]

8
collects/stepper/private/shared.ss
View File

@ -9,7 +9,7 @@
; CONTRACTS
(define varref-set? (listof identifier?))
(define binding-set? (union varref-set? (symbols 'all)))
(define binding-set? (or/c varref-set? (symbols 'all)))
(define (arglist? v)
(or (null? v)
(identifier? v)
@ -101,7 +101,7 @@
(define-struct error-result (err-msg) (make-inspector))
(define-struct finished-stepping () (make-inspector))
(define step-result? (union before-after-result? before-error-result? error-result? finished-stepping?))
(define step-result? (or/c before-after-result? before-error-result? error-result? finished-stepping?))
; the closure record is placed in the closure table
@ -284,7 +284,7 @@
;; arglist : for our puposes, an ilist is defined like this:
;; arglist : (union identifier? null? (cons identifier? arglist?) (syntax (cons identifier? arglist?))
;; arglist : (or/c identifier? null? (cons identifier? arglist?) (syntax (cons identifier? arglist?))
;; ... where an ilist val can be anything _except_ a pair or null
;; arglist->ilist : turns an (possibly improper) arglist into a (possibly improper) list of syntax objects
@ -491,6 +491,7 @@
(user-stepper-define-type stepper-define-type)
(user-stepper-proc-define-name stepper-proc-define-name)
(user-stepper-and/or-clauses-consumed stepper-and/or-clauses-consumed)
(user-stepper-offset-index stepper-offset-index)
(stepper-xml-hint stepper-xml-hint))) ; I find it mildly worrisome that this breaks the pattern
; by failing to preface the identifier with 'user-'. JBC, 2005-08
@ -498,6 +499,7 @@
; (from native property names to 'user-' style property names)
(define (attach-info to-exp from-exp)
(if (syntax-property from-exp 'stepper-offset-index) (>>> (syntax-property from-exp 'stepper-offset-index)))
(let* ([attached (foldl (lambda (labels stx)
(match labels
[`(,new-label ,old-label)

62
collects/stepper/private/testing-shared.ss
View File

@ -1,62 +0,0 @@
(module testing-shared mzscheme
(require (lib "contract.ss")
"shared.ss"
(lib "kerncase.ss" "syntax")
(lib "file.ss"))
(provide/contract [build-stx-with-highlight ((union (listof any/c) string?) ; input with one or more '(hilite ...) tags
. -> .
(listof syntax?))]) ; result
(define (build-stx-with-highlight input)
(let ([temp-file (make-temporary-file)])
(call-with-output-file temp-file
(lambda (port)
(if (string? input)
(display input port)
(map (lambda (sexp) (write sexp port) (display #\space port)) input)))
'truncate)
(begin0
(let ([file-port (open-input-file temp-file)])
(let read-loop ([stx (read-syntax temp-file file-port)])
(if (eof-object? stx)
null
(cons
(let stx-loop ([stx stx])
(syntax-case stx (hilite)
[(hilite x)
(syntax-property (stx-loop #`x) 'stepper-highlight #t)]
[(a . rest) (datum->syntax-object stx (cons (stx-loop #`a) (stx-loop #`rest)) stx stx)]
[else stx]))
(read-loop (read-syntax temp-file file-port))))))
(delete-file temp-file))))
; (require (lib "mz-testing.ss" "tests" "utils")
; (lib "sexp-diff.ss" "tests" "utils"))
; (test `((define a 13) 14 15 #f 1)
; map
; syntax-object->datum
; (build-stx-with-highlight `((define a 13) 14 15 #f 1)))
; (let ([test-run (build-stx-with-highlight `((+ (hilite x) (hilite (+ (hilite 13) (a b))))))])
; (test #t (lambda () (and (pair? test-run) (null? (cdr test-run)))))
; (let ([test-stx (car test-run)])
; (test `(+ x (+ 13 (a b)))
; syntax-object->datum test-stx)
; (test #f syntax-property test-stx 'stepper-highlight)
; (test #t syntax-property (car (syntax-e (cdr (syntax-e test-stx)))) 'stepper-highlight)
; (test #t syntax-property (syntax-case test-stx ()
; [(+ x target)
; #`target])
; 'stepper-highlight)
; (test #t syntax-property (syntax-case test-stx (#%app)
; [(+ x (a target d))
; #`target])
; 'stepper-highlight)))
;
;
;
; (let ([test-sexp `(+ (hilite x) (hilite (+ (hilite 13) (a b))))])
; (test #t equal? test-sexp (syntax-object->hilite-datum (car (build-stx-with-highlight (list test-sexp))))))
)