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

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

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

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

@ -4,7 +4,8 @@
(lib "contract.ss") (lib "contract.ss")
(lib "list.ss") (lib "list.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "match.ss")) (lib "match.ss")
(lib "26.ss" "srfi"))
; CONTRACTS ; CONTRACTS
@ -24,16 +25,22 @@
;[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)] ;[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)]
;[binding-set-union (-> (listof binding-set?) binding-set?)] ;[binding-set-union (-> (listof binding-set?) binding-set?)]
;[varref-set-union (-> (listof varref-set?) varref-set?)] ;[varref-set-union (-> (listof varref-set?) varref-set?)]
[skipto-annotate (-> (listof procedure?) syntax? (-> syntax? syntax?) syntax?)] #;[skipto/auto (syntax? (symbols 'rebuild 'discard) (syntax? . -> . syntax?) . -> . syntax?)]
[skipto-reconstruct (-> (listof procedure?) syntax? (-> syntax? any/c) any/c)] #;[in-closure-table (-> any/c boolean?)]
[in-closure-table (-> any/c boolean?)] #;[sublist (-> number? number? list? list?)]
[sublist (-> number? number? list? list?)] #;[attach-info (-> syntax? syntax? syntax?)]
[attach-info (-> syntax? syntax? syntax?)] #;[transfer-info (-> syntax? syntax? syntax?)]
[transfer-info (-> syntax? syntax? syntax?)] #;[arglist->ilist (-> arglist? any)]
[arglist->ilist (-> arglist? any)] #;[arglist-flatten (-> arglist? (listof identifier?))])
[arglist-flatten (-> arglist? (listof identifier?))])
(provide (provide
skipto/auto
in-closure-table
sublist
attach-info
transfer-info
arglist->ilist
arglist-flatten
binding-set-union binding-set-union
binding-set-pair-union binding-set-pair-union
varref-set-union varref-set-union
@ -384,16 +391,29 @@
[up (cadr (assq down (cadr (assq traversal up-mappings))))]) [up (cadr (assq down (cadr (assq traversal up-mappings))))])
(up val (update (cdr fn-list) (down val) fn traversal))))) (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) ;; skipto/auto : syntax-object? (symbols 'rebuild 'discard) (syntax-object? . -> . syntax-object?)
(update fn-list stx reconstructer 'discard)) ;; "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 ; BINDING-/VARREF-SET FUNCTIONS