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

...

Browse Source 
svn: r3711
This commit is contained in:
John Clements 2006-07-15 15:41:55 +00:00
parent dc28270d5d
commit 1c302a2902
3 changed files with 81 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -377,13 +377,13 @@
(let* ([free-vars-captured #f] ; this will be set!'ed
;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (syntax-property expr 'stepper-skipto))]
; WARNING! I depend on the order of evaluation in application arguments here:
[annotated (skipto-annotate
(syntax-property exp 'stepper-skipto)
exp
[annotated (skipto/auto
exp
'rebuild
(lambda (subterm)
(let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info offset-counter)])
(set! free-vars-captured free-vars)
stx)))])
(set! free-vars-captured free-vars)
stx)))])
(2vals (wcm-wrap
skipto-mark
annotated)
@ -1103,7 +1103,7 @@
#`(begin #,exp
(#,(make-define-struct-break exp)))]
[(syntax-property exp 'stepper-skipto)
(skipto-annotate (syntax-property exp 'stepper-skipto) exp annotate/module-top-level)]
(skipto/auto exp 'rebuild annotate/module-top-level)]
[else
(syntax-case exp (#%app call-with-values define-values define-syntaxes require require-for-syntax provide begin lambda)
[(define-values (new-var ...) e)

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

@ -205,12 +205,18 @@
(struct-constructor-procedure? fun-val))))]
[else #f])))))
;; find-special-value finds the value associated with the given name. Applications of functions
;; like 'list' should not be shown as steps, because the before and after steps will be the same.
;; it might be easier simply to discover and discard these at display time.
(define (find-special-value name valid-args)
(let ([expanded (kernel:kernel-syntax-case (expand (cons name valid-args)) #f
[(#%app fn . rest)
#`fn]
[else (error 'find-special-name "couldn't find expanded name for ~a" name)])])
(eval expanded)))
#f
#;(let* ([expanded-application (expand (cons name valid-args))]
[stepper-safe-expanded (skipto/auto expanded-application 'discard (lambda (x) x))]
[just-the-fn (kernel:kernel-syntax-case stepper-safe-expanded #f
[(#%app fn . rest)
#`fn]
[else (error 'find-special-name "couldn't find expanded name for ~a" name)])])
(eval just-the-fn)))
(define (second-arg-is-list? mark-list)
(let ([arg-val (lookup-binding mark-list (get-arg-var 2))])
@ -287,12 +293,10 @@
(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)
(skipto-reconstruct
(syntax-property expr 'stepper-skipto)
expr
(lambda (stx)
(recon-source-expr stx mark-list dont-lookup use-lifted-names render-settings)))
(skipto/auto
expr
'discard
(lambda (expr)
(if (syntax-property expr 'stepper-prim-name)
(syntax-property expr 'stepper-prim-name)
(let* ([recur (lambda (expr) (recon-source-expr expr mark-list dont-lookup use-lifted-names render-settings))]
@ -424,7 +428,7 @@
[else
(error 'recon-source "no matching clause for syntax: ~a" expr)])])
(attach-info recon expr))))))
(attach-info recon expr)))))))
;; reconstruct-set!-var
@ -502,28 +506,24 @@
(syntax->list #`vars-stx)
lifting-indices)])
(vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))])
(let skipto-loop ([exp exp])
(let ([exp (skipto/auto exp 'discard (lambda (exp) exp))])
(cond
[(syntax-property exp 'stepper-skipto) =>
(lambda (skipto)
(skipto-reconstruct skipto exp
skipto-loop))]
[(syntax-property exp 'stepper-define-struct-hint)
;; the hint contains the original syntax
(vector (syntax-property exp 'stepper-define-struct-hint) #t)]
[else
(vector
(kernel:kernel-syntax-case exp #f
[(define-values vars-stx body)
(reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)]
[else
(let* ([recon-vals (map (lambda (val)
(recon-value val render-settings))
(vals-getter))])
(if (= (length recon-vals) 1)
(attach-info (car recon-vals) exp)
(attach-info #`(values #,@recon-vals) exp)))])
#f)]))))
(kernel:kernel-syntax-case exp #f
[(define-values vars-stx body)
(reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)]
[else
(let* ([recon-vals (map (lambda (val)
(recon-value val render-settings))
(vals-getter))])
(if (= (length recon-vals) 1)
(attach-info (car recon-vals) exp)
(attach-info #`(values #,@recon-vals) exp)))])
#f)]))))
;; an abstraction lifted from reconstruct-completed
(define (reconstruct-completed-define exp vars vals render-settings)
@ -541,19 +541,16 @@
; : (-> syntax? syntax? syntax?)
(define (reconstruct-top-level source reconstructed)
(cond
[(syntax-property source 'stepper-skipto) =>
(lambda (skipto)
(skipto-reconstruct skipto source
(lambda (expr)
(reconstruct-top-level expr reconstructed))))]
[else
(skipto/auto
source
'discard
(lambda (source)
(kernel:kernel-syntax-case source #f
[(define-values vars-stx body)
(attach-info #`(define-values vars-stx #,reconstructed)
source)]
[else
reconstructed])]))
[(define-values vars-stx body)
(attach-info #`(define-values vars-stx #,reconstructed)
source)]
[else
reconstructed]))))

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

@ -4,7 +4,8 @@
(lib "contract.ss")
(lib "list.ss")
(lib "etc.ss")
(lib "match.ss"))
(lib "match.ss")
(lib "26.ss" "srfi"))
; CONTRACTS
@ -24,16 +25,22 @@
;[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)]
;[binding-set-union (-> (listof binding-set?) binding-set?)]
;[varref-set-union (-> (listof varref-set?) varref-set?)]
[skipto-annotate (-> (listof procedure?) syntax? (-> syntax? syntax?) syntax?)]
[skipto-reconstruct (-> (listof procedure?) syntax? (-> syntax? any/c) any/c)]
[in-closure-table (-> any/c boolean?)]
[sublist (-> number? number? list? list?)]
[attach-info (-> syntax? syntax? syntax?)]
[transfer-info (-> syntax? syntax? syntax?)]
[arglist->ilist (-> arglist? any)]
[arglist-flatten (-> arglist? (listof identifier?))])
#;[skipto/auto (syntax? (symbols 'rebuild 'discard) (syntax? . -> . syntax?) . -> . syntax?)]
#;[in-closure-table (-> any/c boolean?)]
#;[sublist (-> number? number? list? list?)]
#;[attach-info (-> syntax? syntax? syntax?)]
#;[transfer-info (-> syntax? syntax? syntax?)]
#;[arglist->ilist (-> arglist? any)]
#;[arglist-flatten (-> arglist? (listof identifier?))])
(provide
skipto/auto
in-closure-table
sublist
attach-info
transfer-info
arglist->ilist
arglist-flatten
binding-set-union
binding-set-pair-union
varref-set-union
@ -384,16 +391,29 @@
[up (cadr (assq down (cadr (assq traversal up-mappings))))])
(up val (update (cdr fn-list) (down val) fn traversal)))))
(define (skipto-annotate fn-list stx annotater)
(update fn-list stx annotater 'rebuild))
; test cases
; (equal? (syntax-object->datum (skipto-annotate (list syntax-e car syntax-e cdr cdr car) #'((a b c) (d e f) (g h i)) (lambda (dc) #'foo)))
; '((a b foo) (d e f) (g h i)))
(define (skipto-reconstruct fn-list stx reconstructer)
(update fn-list stx reconstructer 'discard))
;; skipto/auto : syntax-object? (symbols 'rebuild 'discard) (syntax-object? . -> . syntax-object?)
;; "skips over" part of a tree to find a subtree indicated by the stepper-skipto property. If the
;; traversal argument is 'rebuild, the result of transformation is embedded again in the same tree.
;; if the traversal argument is 'discard, the result of the transformation is the result of this
;; function
(define (skipto/auto stx traversal transformer)
(cond [(syntax-property stx 'stepper-skipto)
=>
(cut update <> stx (cut skipto/auto <> traversal transformer) traversal)]
[else (transformer stx)]))
; small test case:
;(equal? (syntax-object->datum
; (skipto/auto (syntax-property #`(a #,(syntax-property #`(b c)
; 'stepper-skipto
; (list syntax-e cdr car)))
; 'stepper-skipto
; (list syntax-e cdr car))
; 'discard
; (lambda (x) x)))
; 'c)
; BINDING-/VARREF-SET FUNCTIONS