From 96d857dcd08691230bf366eed81be7df0a103660 Mon Sep 17 00:00:00 2001 From: John Clements Date: Fri, 3 Nov 2006 18:15:16 +0000 Subject: [PATCH] changed syntax-property to stepper-syntax-property svn: r4762 --- collects/stepper/private/annotate.ss | 48 +++++------ collects/stepper/private/lifting.ss | 8 +- collects/stepper/private/macro-unwind.ss | 52 ++++++------ collects/stepper/private/marks.ss | 6 +- collects/stepper/private/model.ss | 16 ++-- collects/stepper/private/mred-extensions.ss | 5 +- collects/stepper/private/reconstruct.ss | 52 ++++++------ collects/stepper/private/shared.ss | 89 ++++++++++---------- collects/stepper/private/testing-shared.ss | 10 +-- collects/stepper/private/xml-box.ss | 6 +- collects/stepper/private/xml-snip-helpers.ss | 9 +- 11 files changed, 152 insertions(+), 149 deletions(-) diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 382ebb0d11..bb7700fbb2 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -115,14 +115,14 @@ ; it flags if's which could come from cond's, it labels the begins in conds with 'stepper-skip annotations ; label-var-types returns a syntax object which is identical to the original except that the variable references are labeled - ; with the syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical. + ; with the stepper-syntax-property 'stepper-binding-type, which is set to either let-bound, lambda-bound, or non-lexical. (define (top-level-rewrite stx) (let loop ([stx stx] [let-bound-bindings null] [cond-test (lx #f)]) - (if (or (syntax-property stx 'stepper-skip-completely) - (syntax-property stx 'stepper-define-struct-hint)) + (if (or (stepper-syntax-property stx 'stepper-skip-completely) + (stepper-syntax-property stx 'stepper-define-struct-hint)) stx (let* ([recur-regular (lambda (stx) @@ -162,7 +162,7 @@ [rebuild-if (lambda (new-cond-test) (let* ([new-then (recur-regular (syntax then))] - [rebuilt (syntax-property + [rebuilt (stepper-syntax-property (rebuild-stx `(if ,(recur-regular (syntax test)) ,new-then ,(recur-in-cond (syntax else-stx) new-cond-test)) @@ -170,8 +170,8 @@ 'stepper-hint 'comes-from-cond)]) ; move the stepper-else mark to the if, if it's present: - (if (syntax-property (syntax test) 'stepper-else) - (syntax-property rebuilt 'stepper-else #t) + (if (stepper-syntax-property (syntax test) 'stepper-else) + (stepper-syntax-property rebuilt 'stepper-else #t) rebuilt)))]) (cond [(cond-test stx) ; continuing an existing 'cond' (rebuild-if cond-test)] @@ -183,17 +183,17 @@ (rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))] [(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL (cond-test stx) - (syntax-property stx 'stepper-skip-completely #t)] + (stepper-syntax-property stx 'stepper-skip-completely #t)] ; wrapper on a local. This is necessary because teach.ss expands local into a trivial let wrapping a bunch of ; internal defines, and therefore the letrec-values on which I want to hang the 'stepper-hint doesn't yet ; exist. So we patch it up after expansion. And we discard the outer 'let' at the same time. [(let-values () expansion-of-local) - (eq? (syntax-property stx 'stepper-hint) 'comes-from-local) + (eq? (stepper-syntax-property stx 'stepper-hint) 'comes-from-local) (syntax-case #`expansion-of-local (letrec-values) [(letrec-values (bogus-clause clause ...) . bodies) (recur-regular - (syntax-property #`(letrec-values (clause ...) . bodies) 'stepper-hint 'comes-from-local))] + (stepper-syntax-property #`(letrec-values (clause ...) . bodies) 'stepper-hint 'comes-from-local))] [else (error 'top-level-rewrite "expected a letrec-values inside a local, given: ~e" (syntax-object->datum #`expansion-of-local))])] @@ -204,7 +204,7 @@ ; varref : [var (identifier? (syntax var)) - (syntax-property + (stepper-syntax-property (syntax var) 'stepper-binding-type (if (eq? (identifier-binding (syntax var)) 'lexical) @@ -220,8 +220,8 @@ (rebuild-stx (syntax-pair-map content recur-regular) stx) stx))])]) - (if (eq? (syntax-property stx 'stepper-xml-hint) 'from-xml-box) - (syntax-property #`(#,put-into-xml-table #,rewritten) + (if (eq? (stepper-syntax-property stx 'stepper-xml-hint) 'from-xml-box) + (stepper-syntax-property #`(#,put-into-xml-table #,rewritten) 'stepper-skipto (list syntax-e cdr car)) (syntax-recertify rewritten stx (current-code-inspector) #f)))))) @@ -383,9 +383,9 @@ . -> . (vector/p syntax? binding-set?)) (lambda (exp tail-bound pre-break? procedure-name-info) - (cond [(syntax-property exp 'stepper-skipto) + (cond [(stepper-syntax-property exp 'stepper-skipto) (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 (stepper-syntax-property expr 'stepper-skipto))] ; WARNING! I depend on the order of evaluation in application arguments here: [annotated (skipto/auto exp @@ -399,7 +399,7 @@ annotated) free-vars-captured))] - [(syntax-property exp 'stepper-skip-completely) + [(stepper-syntax-property exp 'stepper-skip-completely) (2vals (wcm-wrap 13 exp) null)] [else @@ -443,7 +443,7 @@ 'let-body #t))] [make-debug-info-fake-exp (lambda (exp free-bindings) - (make-debug-info (syntax-property exp 'stepper-fake-exp #t) + (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) tail-bound free-bindings 'none #t))] [outer-wcm-wrap (if pre-break? @@ -476,7 +476,7 @@ ; wrap bodies in explicit begin if more than 1 user-introduced (non-skipped) bodies ; NB: CAN'T HAPPEN in beginner up through int/lambda (if (> (length (filter (lambda (clause) - (not (syntax-property clause 'stepper-skip-completely))) + (not (stepper-syntax-property clause 'stepper-skip-completely))) (syntax->list (syntax bodies)))) 1) (lambda-body-recur (syntax (begin . bodies))) (let*-2vals ([(annotated-bodies free-var-sets) @@ -728,7 +728,7 @@ (varref-break-wrap) (varref-no-break-wrap)))]) (2vals - (case (syntax-property var 'stepper-binding-type) + (case (stepper-syntax-property var 'stepper-binding-type) ((lambda-bound macro-bound) (varref-no-break-wrap)) ((let-bound) (varref-break-wrap)) ((non-lexical) ;; is it from this module or not? @@ -836,7 +836,7 @@ ;; more efficient, but disabled because of difficulties in threading it through the ;; reconstruction. Easier to undo in the macro-unwind phase. #;[(let-values () . bodies-stx) - (eq? (syntax-property exp 'stepper-hint) 'comes-from-begin) + (eq? (stepper-syntax-property exp 'stepper-hint) 'comes-from-begin) (begin-abstraction (syntax->list #`bodies-stx))] [(let-values . _) @@ -976,7 +976,7 @@ [free-varrefs (varref-set-union free-varrefs-terms)]) (2vals (let* ([arg-temps (build-list (length annotated-terms) get-arg-var)] - [tagged-arg-temps (map (lambda (var) (syntax-property var 'stepper-binding-type 'stepper-temp)) + [tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp)) arg-temps)] [let-clauses #`((#,tagged-arg-temps (values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))] @@ -1090,11 +1090,11 @@ (define/contract annotate/module-top-level (syntax? . -> . syntax?) (lambda (exp) - (cond [(syntax-property exp 'stepper-skip-completely) exp] - [(syntax-property exp 'stepper-define-struct-hint) + (cond [(stepper-syntax-property exp 'stepper-skip-completely) exp] + [(stepper-syntax-property exp 'stepper-define-struct-hint) #`(begin #,exp (#,(make-define-struct-break exp)))] - [(syntax-property exp 'stepper-skipto) + [(stepper-syntax-property exp 'stepper-skipto) (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) @@ -1127,7 +1127,7 @@ (call-with-values (lambda () vals) print-values))))] [any - (syntax-property exp 'stepper-test-suite-hint) + (stepper-syntax-property exp 'stepper-test-suite-hint) (top-level-annotate/inner (top-level-rewrite exp) exp #f)] [else (top-level-annotate/inner (top-level-rewrite exp) exp #f) diff --git a/collects/stepper/private/lifting.ss b/collects/stepper/private/lifting.ss index 970c4d2128..7147c14aec 100644 --- a/collects/stepper/private/lifting.ss +++ b/collects/stepper/private/lifting.ss @@ -91,7 +91,7 @@ (expr-iterator stx context-so-far)]))) (define (expr-iterator stx context-so-far) - (when (syntax-property stx 'stepper-highlight) + (when (stepper-syntax-property stx 'stepper-highlight) (success-escape (2vals context-so-far stx))) (let* ([try (make-try-all-subexprs stx 'expr context-so-far)] [try-exprs (lambda (index-mangler exprs) (try index-mangler (map (lambda (expr) (list expr-iterator expr)) @@ -243,9 +243,9 @@ (lift-helper highlighted #f null) (values null highlighted))]) (let loop ([ctx-list ctx-list] - [so-far-defs (map (lambda (x) (syntax-property x 'stepper-highlight #t)) + [so-far-defs (map (lambda (x) (stepper-syntax-property x 'stepper-highlight #t)) highlighted-defs)] - [body (syntax-property highlighted-body 'stepper-highlight #t)]) + [body (stepper-syntax-property highlighted-body 'stepper-highlight #t)]) (if (null? ctx-list) (append so-far-defs (list body)) (let*-values ([(ctx) (car ctx-list)] @@ -280,7 +280,7 @@ [else (error 'lift-helper "let or letrec does not have expected shape: ~v\n" (syntax-object->datum stx))]))]) (kernel:kernel-syntax-case stx #f [(let-values . dc) - (not (eq? (syntax-property stx 'user-stepper-hint) 'comes-from-or)) + (not (eq? (stepper-syntax-property stx 'stepper-hint) 'comes-from-or)) (lift)] [(letrec-values . dc) (lift)] diff --git a/collects/stepper/private/macro-unwind.ss b/collects/stepper/private/macro-unwind.ss index 8c535871a0..fa310cb601 100644 --- a/collects/stepper/private/macro-unwind.ss +++ b/collects/stepper/private/macro-unwind.ss @@ -52,7 +52,7 @@ (kernel:kernel-syntax-case stx #f [id (identifier? stx) - (or (syntax-property stx 'stepper-lifted-name) + (or (stepper-syntax-property stx 'stepper-lifted-name) stx)] [(define-values dc ...) (unwind-define stx settings)] @@ -65,7 +65,7 @@ [(letrec-values . rest) (unwind-mz-let stx settings)] [(set! var rhs) - (with-syntax ([unwound-var (or (syntax-property + (with-syntax ([unwound-var (or (stepper-syntax-property #`var 'stepper-lifted-name) #`var)] [unwound-body (unwind #`rhs settings)]) @@ -74,7 +74,7 @@ (define (unwind stx settings) (transfer-info - (let ([hint (syntax-property stx 'user-stepper-hint)]) + (let ([hint (stepper-syntax-property stx 'stepper-hint)]) (if (procedure? hint) (hint stx (lambda (stx) (recur-on-pieces stx settings))) (let ([process (case hint @@ -89,8 +89,8 @@ stx)) (define (transfer-highlight from to) - (if (syntax-property from 'stepper-highlight) - (syntax-property to 'stepper-highlight #t) + (if (stepper-syntax-property from 'stepper-highlight) + (stepper-syntax-property to 'stepper-highlight #t) to)) (define (unwind-recur stx settings) @@ -118,29 +118,29 @@ "reconstruct fails on multiple-values define: ~v\n" (syntax-object->datum stx))) (let* ([printed-name - (or (syntax-property #`name 'stepper-lifted-name) - (syntax-property #'name 'stepper-orig-name) + (or (stepper-syntax-property #`name 'stepper-lifted-name) + (stepper-syntax-property #'name 'stepper-orig-name) #'name)] [unwound-body (unwind #'body settings)] ;; see notes in internal-docs.txt - [define-type (syntax-property - unwound-body 'user-stepper-define-type)]) + [define-type (stepper-syntax-property + unwound-body 'stepper-define-type)]) (if define-type (kernel:kernel-syntax-case unwound-body #f [(lambda arglist lam-body ...) (case define-type [(shortened-proc-define) (let ([proc-define-name - (syntax-property + (stepper-syntax-property unwound-body - 'user-stepper-proc-define-name)]) + 'stepper-proc-define-name)]) (if (or (module-identifier=? proc-define-name #'name) - (and (syntax-property #'name + (and (stepper-syntax-property #'name 'stepper-orig-name) (module-identifier=? proc-define-name - (syntax-property + (stepper-syntax-property #'name 'stepper-orig-name)))) #`(define (#,printed-name . arglist) lam-body ...) @@ -149,7 +149,7 @@ [(lambda-define) #`(define #,printed-name #,unwound-body)] [else (error 'unwind-define - "unknown value for syntax property 'user-stepper-define-type: ~e" + "unknown value for syntax property 'stepper-define-type: ~e" define-type)])] [else (error 'unwind-define "expr with stepper-define-type is not a lambda: ~e" @@ -164,8 +164,8 @@ (with-syntax ([(rhs2 ...) (map (lambda (rhs) (unwind rhs settings)) (syntax->list #'(rhs ...)))] [new-label (if (improper-member 'comes-from-let* - (syntax-property - stx 'user-stepper-hint)) + (stepper-syntax-property + stx 'stepper-hint)) #`let* (case (syntax-e #'label) [(let-values) #'let] @@ -176,13 +176,13 @@ [((let* bindings inner-body ...)) (and (improper-member 'comes-from-let* - (syntax-property stx 'user-stepper-hint)) - (eq? (syntax-property stx 'user-stepper-source) - (syntax-property (car (syntax->list #`new-bodies)) - 'user-stepper-source)) - (eq? (syntax-property stx 'user-stepper-position) - (syntax-property (car (syntax->list #`new-bodies)) - 'user-stepper-position))) + (stepper-syntax-property stx 'stepper-hint)) + (eq? (stepper-syntax-property stx 'stepper-source) + (stepper-syntax-property (car (syntax->list #`new-bodies)) + 'stepper-source)) + (eq? (stepper-syntax-property stx 'stepper-position) + (stepper-syntax-property (car (syntax->list #`new-bodies)) + 'stepper-position))) #`(let* #,(append (syntax->list #`([var rhs2] ...)) (syntax->list #`bindings)) inner-body ...)] @@ -212,7 +212,7 @@ ; "unexpected result for unwinding the-cons application")])) (define (unwind-cond-clause stx test-stx result-stx settings) - (with-syntax ([new-test (if (syntax-property stx 'user-stepper-else) + (with-syntax ([new-test (if (stepper-syntax-property stx 'stepper-else) #`else (unwind test-stx settings))] [result (unwind result-stx settings)]) @@ -266,8 +266,8 @@ (with-syntax ([clauses (append - (build-list (syntax-property - stx 'user-stepper-and/or-clauses-consumed) + (build-list (stepper-syntax-property + stx 'stepper-and/or-clauses-consumed) (lambda (dc) clause-padder)) (let loop ([stx stx]) (if (and (eq? user-source diff --git a/collects/stepper/private/marks.ss b/collects/stepper/private/marks.ss index 20bb4a60ec..5217bb2103 100644 --- a/collects/stepper/private/marks.ss +++ b/collects/stepper/private/marks.ss @@ -79,7 +79,7 @@ ; : identifier -> identifier (define (make-mark-binding-stx id) - #`(lambda () #,(syntax-property id 'stepper-dont-check-for-function #t))) + #`(lambda () #,(stepper-syntax-property id 'stepper-dont-check-for-function #t))) (define (mark-bindings mark) (map list @@ -163,13 +163,13 @@ (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)]) (if lifting? (let*-2vals ([let-bindings (filter (lambda (var) - (case (syntax-property var 'stepper-binding-type) + (case (stepper-syntax-property var 'stepper-binding-type) ((let-bound macro-bound) #t) ((lambda-bound stepper-temp non-lexical) #f) (else (error 'make-debug-info "varref ~a's binding-type info was not recognized: ~a" (syntax-e var) - (syntax-property var 'stepper-binding-type))))) + (stepper-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))) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index ddbd6fc57d..0e656992d8 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -49,7 +49,8 @@ "macro-unwind.ss" "lifting.ss" ;; for breakpoint display - "display-break-stuff.ss") + "display-break-stuff.ss" + (file "/Users/clements/clements/scheme-scraps/eli-debug.ss")) (define program-expander-contract ((-> void?) ; init @@ -134,8 +135,8 @@ (define (highlight-mutated-expression left right) (cond ;; if either one is already highlighted, leave them alone. - [(or (syntax-property left 'stepper-highlight) - (syntax-property right 'stepper-highlight)) + [(or (stepper-syntax-property left 'stepper-highlight) + (stepper-syntax-property right 'stepper-highlight)) (list left right)] ;; first pass: highlight if not eq?. Should be broken for local-bound @@ -143,8 +144,8 @@ [(eq? left right) (list left right)] - [else (list (syntax-property left 'stepper-highlight) - (syntax-property right 'stepper-highlight))])) + [else (list (stepper-syntax-property left 'stepper-highlight) + (stepper-syntax-property right 'stepper-highlight))])) ;; mutated on receipt of a break, used in displaying breakpoint stuff. (define steps-received 0) @@ -311,6 +312,7 @@ (define (step-through-expression expanded expand-next-expression) (let* ([annotated (a:annotate expanded break track-inferred-names? language-level)]) + (>>> "annotation complete") (eval-syntax annotated) (expand-next-expression))) @@ -326,8 +328,8 @@ (program-expander (lambda () ;; swap these to allow errors to escape (e.g., when debugging) - (error-display-handler err-display-handler) - ;;(void) + ;;(error-display-handler err-display-handler) + (void) ) (lambda (expanded continue-thunk) ; iter (r:reset-special-values) diff --git a/collects/stepper/private/mred-extensions.ss b/collects/stepper/private/mred-extensions.ss index 2026f69d83..ab4b2212d7 100644 --- a/collects/stepper/private/mred-extensions.ss +++ b/collects/stepper/private/mred-extensions.ss @@ -4,6 +4,7 @@ (prefix f: (lib "framework.ss" "framework")) (lib "pretty.ss") "testing-shared.ss" + "shared.ss" (lib "string-constant.ss" "string-constants") (lib "bitmap-label.ss" "mrlib")) @@ -487,7 +488,7 @@ (define (strip-to-sexp stx highlight-table) (define (strip-regular stx) (let* ([it (if (and (syntax? stx) - (eq? (syntax-property stx 'stepper-hint) 'from-xml)) + (eq? (stepper-syntax-property stx 'stepper-hint) 'from-xml)) (strip-xml stx) stx)] [it @@ -499,7 +500,7 @@ [else it])] [it (if (and (syntax? stx) - (syntax-property stx 'stepper-highlight)) + (stepper-syntax-property stx 'stepper-highlight)) (if (pair? it) (begin (hash-table-put! highlight-table it 'non-confusable) diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index 231ec93ed3..28e427bf7e 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -87,7 +87,7 @@ (define (mark-as-highlight stx) - (syntax-property stx 'stepper-highlight #t)) + (stepper-syntax-property stx 'stepper-highlight #t)) ; ; ; ;; ;;; ;;; ;;; ; ;; ; ; ;;; ; ; ; ;;; @@ -106,7 +106,7 @@ (define recon-value (opt-lambda (val render-settings [assigned-name #f]) (if (hash-table-get finished-xml-box-table val (lambda () #f)) - (syntax-property #`(#%datum . #,val) 'stepper-xml-value-hint 'from-xml-box) + (stepper-syntax-property #`(#%datum . #,val) 'stepper-xml-value-hint 'from-xml-box) (let ([closure-record (closure-table-lookup val (lambda () #f))]) (if closure-record (let* ([mark (closure-record-mark closure-record)] @@ -147,7 +147,7 @@ #f] [(result-exp-break) ;; skip if clauses that are the result of and/or reductions - (let ([and/or-clauses-consumed (syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)]) + (let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)]) (and and/or-clauses-consumed (> and/or-clauses-consumed 0)))] [(normal-break normal-break/values) @@ -156,8 +156,8 @@ (or ;; don't stop for a double-break on a let that is the expansion of a 'begin' (let ([expr (mark-source (car mark-list))]) - (or (eq? (syntax-property expr 'stepper-hint) 'comes-from-begin) - (syntax-property expr 'stepper-skip-double-break))) + (or (eq? (stepper-syntax-property expr 'stepper-hint) 'comes-from-begin) + (stepper-syntax-property expr 'stepper-skip-double-break))) (not (render-settings-lifting? render-settings)))] [(expr-finished-break define-struct-break late-let-break) #f])) @@ -167,14 +167,14 @@ (with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)]) (let ([val (lookup-binding mark-list varref)]) (equal? (syntax-object->interned-datum (recon-value val render-settings)) - (syntax-object->interned-datum (case (syntax-property varref 'stepper-binding-type) + (syntax-object->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type) ([let-bound] (binding-lifted-name mark-list varref)) ([non-lexical] varref) (else (error 'varref-skip-step? "unexpected value for stepper-binding-type: ~e for variable: ~e\n" - (syntax-property varref 'stepper-binding-type) + (stepper-syntax-property varref 'stepper-binding-type) varref)))))))) (and (pair? mark-list) @@ -182,7 +182,7 @@ (or (kernel:kernel-syntax-case expr #f [id (identifier? expr) - (case (syntax-property expr 'stepper-binding-type) + (case (stepper-syntax-property expr 'stepper-binding-type) [(lambda-bound) #t] ; don't halt for lambda-bound vars [(let-bound) (varref-skip-step? expr)] @@ -308,8 +308,8 @@ expr 'discard (lambda (expr) - (if (syntax-property expr 'stepper-prim-name) - (syntax-property expr 'stepper-prim-name) + (if (stepper-syntax-property expr 'stepper-prim-name) + (stepper-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 bindings) (recon-source-expr expr mark-list (append bindings dont-lookup) use-lifted-names render-settings))] @@ -335,7 +335,7 @@ [(new-vars ...) (map (lx (map (lx (if (ormap (lambda (binding) (bound-identifier=? binding _)) use-lifted-names) - (syntax-property _ + (stepper-syntax-property _ 'stepper-lifted-name (binding-lifted-name mark-list _)) _)) @@ -414,14 +414,14 @@ use-lifted-names))) var - (case (syntax-property var 'stepper-binding-type) + (case (stepper-syntax-property var 'stepper-binding-type) ((lambda-bound) (recon-value (lookup-binding mark-list var) render-settings)) ((macro-bound) ; for the moment, let-bound vars occur only in and/or : (recon-value (lookup-binding mark-list var) render-settings)) ((let-bound) - (syntax-property var + (stepper-syntax-property var 'stepper-lifted-name (binding-lifted-name mark-list var))) ((stepper-temp) @@ -430,7 +430,7 @@ (error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical")) (else (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a" - (syntax-property var 'stepper-binding-type)))))] + (stepper-syntax-property var 'stepper-binding-type)))))] [else ; top-level-varref (fixup-name var)]))] @@ -444,7 +444,7 @@ ;; reconstruct-set!-var (define (reconstruct-set!-var mark-list var) - (case (syntax-property var 'stepper-binding-type) + (case (stepper-syntax-property var 'stepper-binding-type) ((lambda-bound) (error 'reconstruct-inner "lambda-bound variables can't be mutated")) ((macro-bound) @@ -452,21 +452,21 @@ (error 'reconstruct-inner "macro-bound variables can't occur in a set!")) ((non-lexical) var) ((let-bound) - (syntax-property var + (stepper-syntax-property var 'stepper-lifted-name (binding-lifted-name mark-list var))) ((stepper-temp) (error 'recon-source-expr "stepper-temp showed up in source?!?")) (else (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a" - (syntax-property var 'stepper-binding-type))))) + (stepper-syntax-property var 'stepper-binding-type))))) ;; filter-skipped : (listof syntax?) -> (listof syntax?) ;; filter out any elements of the list with 'stepper-skip-completely set, except those with stepper-prim-name set. (HACK). (define (filter-skipped los) (filter (lambda (stx) - (or (syntax-property stx 'stepper-prim-name) - (not (syntax-property stx 'stepper-skip-completely)))) + (or (stepper-syntax-property stx 'stepper-prim-name) + (not (stepper-syntax-property stx 'stepper-skip-completely)))) los)) @@ -513,15 +513,15 @@ (if lifting-indices (syntax-case exp () [(vars-stx rhs ...) - (let* ([vars (map (lambda (var index) (syntax-property var 'stepper-lifted-name (construct-lifted-name var index))) + (let* ([vars (map (lambda (var index) (stepper-syntax-property var 'stepper-lifted-name (construct-lifted-name var index))) (syntax->list #`vars-stx) lifting-indices)]) (vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))]) (let ([exp (skipto/auto exp 'discard (lambda (exp) exp))]) (cond - [(syntax-property exp 'stepper-define-struct-hint) + [(stepper-syntax-property exp 'stepper-define-struct-hint) ;; the hint contains the original syntax - (vector (syntax-property exp 'stepper-define-struct-hint) #t)] + (vector (stepper-syntax-property exp 'stepper-define-struct-hint) #t)] [else (vector (kernel:kernel-syntax-case exp #f @@ -625,7 +625,7 @@ (map (lambda (binding-set rhs) (make-let-glump (map (lambda (binding) - (syntax-property binding + (stepper-syntax-property binding 'stepper-lifted-name (binding-lifted-name mark-list binding))) binding-set) @@ -669,10 +669,10 @@ null)] [recon-bindings (append before-bindings after-bindings)] ;; 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 + ;; num-defns-done = (length binding-sets) IFF the so-far has a '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))] + (stepper-syntax-property so-far 'stepper-offset-index))] [bodies (syntax->list (syntax bodies))] [rectified-bodies (map (lambda (body offset-index) @@ -682,7 +682,7 @@ bodies (iota (length bodies)))]) (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) - (if (syntax-property exp 'stepper-fake-exp) + (if (stepper-syntax-property exp 'stepper-fake-exp) (syntax-case exp () [(begin . bodies) diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index dd393b6a60..b3d8f257c5 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -88,8 +88,26 @@ get-set-pair-union-stats ; profiling info re-intern-identifier finished-xml-box-table - language-level->name) + language-level->name + + stepper-syntax-property) + + ;; stepper-syntax-property : like syntax property, but adds properties to an association + ;; list associated with the syntax property 'stepper-properties + (define stepper-syntax-property + (case-lambda + [(stx tag) (let ([stepper-props (syntax-property stx 'stepper-properties)]) + (if stepper-props + (let ([table-lookup (assq tag stepper-props)]) + (if table-lookup + (cadr table-lookup) + #f)) + #f))] + [(stx tag new-val) (syntax-property stx 'stepper-properties + (cons (list tag new-val) + (or (syntax-property stx 'stepper-properties) + null)))])) ; A step-result is either: ; (make-before-after-result finished-exps exp redex reduct) @@ -325,7 +343,7 @@ (apply map list args))) (define let-counter - (syntax-property #'let-counter 'stepper-binding-type 'stepper-temp)) + (stepper-syntax-property #'let-counter 'stepper-binding-type 'stepper-temp)) ; syntax-pair-map (using the def'ns of the MzScheme docs): @@ -432,14 +450,14 @@ ;; 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) + (cond [(stepper-syntax-property stx 'stepper-skipto) => (cut update <> stx (cut skipto/auto <> traversal transformer) traversal)] [else (transformer stx)])) ; small test case: #;(display (equal? (syntax-object->datum - (skipto/auto (syntax-property #`(a #,(syntax-property #`(b c) + (skipto/auto (stepper-syntax-property #`(a #,(stepper-syntax-property #`(b c) 'stepper-skipto '(syntax-e cdr car))) 'stepper-skipto @@ -531,54 +549,25 @@ (sublist 0 (- end 1) (cdr lst))) (sublist (- begin 1) (- end 1) (cdr lst))))) - ; attach-info : SYNTAX-OBJECT SYNTAX-OBJECT -> SYNTAX-OBJECT - ; attach-info attaches to a generated piece of syntax the origin & source - ; information of another. we do this so that macro unwinding can tell what - ; reconstructed syntax came from what original syntax - - (define labels-to-attach - `((user-origin origin) - (user-stepper-hint stepper-hint) - (user-stepper-else stepper-else) - (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) - ;; I find it mildly worrisome that this breaks the pattern - ;; by failing to preface the identifier with 'user-'. JBC, 2005-08 - (stepper-xml-hint stepper-xml-hint))) - ;; take info from source expressions to reconstructed expressions - ;; (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) - (syntax-property stx new-label (syntax-property from-exp old-label))])) - to-exp - labels-to-attach)] + ;; (if (stepper-syntax-property from-exp 'stepper-offset-index) + ;; (>>> (stepper-syntax-property from-exp 'stepper-offset-index))) + (let* ([attached (syntax-property to-exp 'stepper-properties (syntax-property from-exp 'stepper-properties))] [attached (syntax-property attached 'user-source (syntax-source from-exp))] [attached (syntax-property attached 'user-position (syntax-position from-exp))]) attached)) ;; transfer info from reconstructed expressions to other reconstructed ;; expressions - ;; (from 'user-' style names to 'user-' style names) - (define (transfer-info to-stx from-exp) - (let* ([attached (foldl (lambda (labels stx) - (match labels - [`(,new-label ,old-label) - (syntax-property stx new-label (syntax-property from-exp new-label))])) - to-stx - labels-to-attach)] + (define (transfer-info to-exp from-exp) + (let* ([attached (syntax-property to-exp 'stepper-properties (append (syntax-property from-exp 'stepper-properties) + (or (syntax-property to-exp 'stepper-properties) + null)))] [attached (syntax-property attached 'user-source (syntax-property from-exp 'user-source))] - [attached (syntax-property attached 'user-position (syntax-property from-exp 'user-position))] - [attached (syntax-property attached 'stepper-highlight (or (syntax-property from-exp 'stepper-highlight) - (syntax-property attached 'stepper-highlight)))]) + [attached (syntax-property attached 'user-position (syntax-property from-exp 'user-position))]) attached)) (define (values-map fn . lsts) @@ -624,16 +613,16 @@ [else (if (syntax? stx) (syntax-object->datum stx) stx)])]) - (let* ([it (case (syntax-property stx 'stepper-xml-hint) + (let* ([it (case (stepper-syntax-property stx 'stepper-xml-hint) [(from-xml-box) `(xml-box ,datum)] [(from-scheme-box) `(scheme-box ,datum)] [(from-splice-box) `(splice-box ,datum)] [else datum])] - [it (case (syntax-property stx 'stepper-xml-value-hint) + [it (case (stepper-syntax-property stx 'stepper-xml-value-hint) [(from-xml-box) `(xml-box-value ,it)] [else it])] [it (if (and (not ignore-highlight?) - (syntax-property stx 'stepper-highlight)) + (stepper-syntax-property stx 'stepper-highlight)) `(hilite ,it) it)]) it)))) @@ -703,11 +692,14 @@ (define (language-level->name language) (car (last-pair (send language get-language-position)))) + ) + ; test cases ;(require shared) -;(load "/Users/clements/plt/tests/mzscheme/testing.ss") +;(write (collection-path "tests" "mzscheme")) +;(load (build-path (collection-path "tests" "mzscheme") "testing.ss")) ; ;(define (a sym) ; (syntax-object->datum (get-lifted-var sym))) @@ -755,3 +747,10 @@ ; (list sums diffs))) ; `((10 10 10 10 10) ; (-8 -6 -4 -2 0))) + +;(test #f stepper-syntax-property #`13 'abc) +;(test 'yes stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'abc) +;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'no) 'abc 'yes) 'abc) +;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg) 'abc) +;(test 13 syntax-object->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg)) + diff --git a/collects/stepper/private/testing-shared.ss b/collects/stepper/private/testing-shared.ss index c71d5cba5d..1709704de7 100644 --- a/collects/stepper/private/testing-shared.ss +++ b/collects/stepper/private/testing-shared.ss @@ -25,7 +25,7 @@ (let stx-loop ([stx stx]) (syntax-case stx (hilite) [(hilite x) - (syntax-property (stx-loop #`x) 'stepper-highlight #t)] + (stepper-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)))))) @@ -43,13 +43,13 @@ ; (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 () +; (test #f stepper-syntax-property test-stx 'stepper-highlight) +; (test #t stepper-syntax-property (car (syntax-e (cdr (syntax-e test-stx)))) 'stepper-highlight) +; (test #t stepper-syntax-property (syntax-case test-stx () ; [(+ x target) ; #`target]) ; 'stepper-highlight) -; (test #t syntax-property (syntax-case test-stx (#%app) +; (test #t stepper-syntax-property (syntax-case test-stx (#%app) ; [(+ x (a target d)) ; #`target]) ; 'stepper-highlight))) diff --git a/collects/stepper/private/xml-box.ss b/collects/stepper/private/xml-box.ss index 04a63384ad..a059d3aae4 100644 --- a/collects/stepper/private/xml-box.ss +++ b/collects/stepper/private/xml-box.ss @@ -17,10 +17,10 @@ (define (rewrite-xml-error) (error 'rewrite-xml-box "unexpected syntax in expansion of xml box: ~e" stx)) - (case (syntax-property stx 'stepper-hint) + (case (stepper-syntax-property stx 'stepper-hint) [(from-scheme-box from-splice-box) (rewrite-other stx)] [(from-xml-box #f) - (syntax-property + (stepper-syntax-property (kernel:kernel-syntax-case stx #f [var-stx (identifier? (syntax var-stx)) (rewrite-xml-error)] @@ -61,7 +61,7 @@ [else (error 'rewrite-xml-box "unexpected stepper-hint \"~v\" on syntax from xml box: ~e" - (syntax-property stx 'stepper-hint) + (stepper-syntax-property stx 'stepper-hint) stx)]))) diff --git a/collects/stepper/private/xml-snip-helpers.ss b/collects/stepper/private/xml-snip-helpers.ss index 2eba732123..432b33f22a 100644 --- a/collects/stepper/private/xml-snip-helpers.ss +++ b/collects/stepper/private/xml-snip-helpers.ss @@ -4,7 +4,8 @@ (lib "readerr.ss" "syntax") (lib "mred.ss" "mred") (lib "class.ss") - (lib "list.ss")) + (lib "list.ss") + "shared.ss") (provide xml-read-special xml-snip<%> @@ -53,7 +54,7 @@ [expd-xexpr (expand-embedded clean-xexpr)] [qq-body (datum->syntax-object #'here expd-xexpr (list editor #f #f #f #f))]) (with-syntax ([qq-body qq-body]) - (syntax-property (syntax (quasiquote qq-body)) + (stepper-syntax-property (syntax (quasiquote qq-body)) 'stepper-xml-hint 'from-xml-box)))) (lambda () (send editor lock old-locked))))) @@ -111,13 +112,13 @@ (with-syntax ([err (syntax/loc (car (last-pair raw-stxs)) (error 'scheme-splice-box "expected a list, found: ~e" lst))]) - #`,@#,(syntax-property #`(let ([lst (begin stxs ...)]) + #`,@#,(stepper-syntax-property #`(let ([lst (begin stxs ...)]) (if (list? lst) lst err)) 'stepper-xml-hint 'from-splice-box)) - #`,#,(syntax-property #`(begin stxs ...) + #`,#,(stepper-syntax-property #`(begin stxs ...) 'stepper-xml-hint 'from-scheme-box))))] [else xexpr])))