From ae9cab6ee04f962656cdd590bc483aaf9fcde2d4 Mon Sep 17 00:00:00 2001 From: John Clements Date: Wed, 29 Jun 2011 00:29:00 -0700 Subject: [PATCH] Updated stepper-syntax property to only permit known & documented stepper properties, discovered quite a number of strange old errors. Also fixed an error on setting current-directory when the tab has no directory, no infrastructure for testing this automatically. Requires are now handled correctly, except that required bindings aren't treated as top-level (that is, their reductions are skipped). Should be an easy fix... --- collects/stepper/internal-docs.txt | 70 +++++++------ collects/stepper/private/model.rkt | 4 +- collects/stepper/private/reconstruct.rkt | 23 ++--- collects/stepper/private/shared.rkt | 121 +++++++++-------------- collects/stepper/stepper-tool.rkt | 2 +- 5 files changed, 97 insertions(+), 123 deletions(-) diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt index 223b42402b..0488caf8b4 100644 --- a/collects/stepper/internal-docs.txt +++ b/collects/stepper/internal-docs.txt @@ -28,12 +28,17 @@ textual locations: collects/lang/private/teach.ss, and collects/stepper/private/annotate.ss (with a few stray ones in collects/lang/private/teachhelp.ss). -Also, in order to be visible to the reconstructor, these properties -must be explicitly transferred from the annotated source code syntax -to the reconstructed syntax. This is accomplished by the 'attach-info' -procedure in reconstruct.ss. Note that in the process, these properties -are given names that have "user-" prepended to them. This now seems -like a strange decision. +In order to make it easy to move the stepper's syntax properties +as a group and also in order to check that only sane ones are +used, the stepper syntax properties are actually all grouped +together as a list stored under a single syntax property. + +In order to be visible to the reconstructor, these properties must +be explicitly transferred from the annotated source code syntax to the +reconstructed syntax. This is accomplished by the 'attach-info' +procedure in shared.rkt. Note that in the process, the source and +source-position properties are given names that have "user-" prepended +to them. This now seems like a strange decision. Finally, the astute reader may wonder why I need to add things like 'comes-from-or, since the expression that results from the expansion @@ -43,13 +48,16 @@ in the expansion, and during runtime reconstruction, this outermost expression may be gone. Here are the syntax properties added, the values they may be -associated with, their meanings, whether they're transferred -by attach-info, and where they're used: +associated with, their meanings, and where they're used. + +NB: this list of property names is specified in the code in +private/shared.rkt; if you add one or change its name, you should +do so in that code as well, or you'll get errors. stepper-skip-completely : [ #t ] : this code should not be annotated at all. In general, this - means it therefore be invisible to the reconstructor. (Not - transferred.) Actually, the code is wrapped with a dummy mark, + means it therefore be invisible to the reconstructor. + Actually, the code is wrapped with a dummy mark, just to make sure that other marks get properly obliterated. Note that skipping an expression can turn a sensible expression into @@ -71,8 +79,6 @@ stepper-hint : See notes below about 'being careful with stepper-hint'. -(Transferred.) - [ 'comes-from-cond ] : similarly, this expression came from a use of 'cond'. This tag is applied to all the if's, but not to the else clause. @@ -102,8 +108,6 @@ stepper-define-type: [ 'lambda-define ] : this lambda arose from the expansion of (define id (lambda ( - (Transferred.) - Question 1: why the right-hand side? Why not on the define itself? A: because for certain kinds of define (namely those in a local), the define itself evaporates into an internal define which is then @@ -135,8 +139,6 @@ xml-box. The protocol is as follows: [ 'from-splice-box ] : attached to the (qq-append ...) that wraps the result of expanding a splice-box - (Transferred.) - stepper-xml-value-hint : like the stepper-xml-hint, used to indicate values that are the result of evaluating xml boxes. The reason this cannot be the same as the stepper-xml-hint property is that @@ -152,14 +154,10 @@ stepper-xml-value-hint : like the stepper-xml-hint, used to indicate stepper-proc-define-name : stores the name to which a procedure defined with the (define (fn arg ...) body) was bound. - (Transferred.) - stepper-orig-name: attached to an uninterned symbol used by the expansion of define so that the stepper can compare the name attached to a lambda to the name of a definition. - (Not transferred.) - stepper-prim-name: this is attached to the expansion of primitives introduced with the 'define-primitive' form. Its value indicates what name to give to @@ -167,7 +165,7 @@ stepper-prim-name: stepper-binding-type : this is actually unrelated to macro expansion. It differentiates - between the various kinds of lexical bindings. (Not transferred.) + between the various kinds of lexical bindings. [ 'macro-bound ] : this variable's binding was inserted by a macro [ 'let-bound ] : this variable's binding was in a let/*/rec @@ -186,13 +184,12 @@ stepper-and/or-clauses-consumed : This allows the stepper to reconstruct a partially evaluated 'and' or 'or' with the right number of 'true's or 'false's in front. - (Transferred.) - + stepper-skipto : this instructs the annotator to look inside the current expression along a given path for the expression to be annotated. In particular, the value bound to stepper-skipto must be a list whose - elements are car, cdr, or syntax-e. (Not transferred) + elements are car, cdr, or syntax-e. Some uses: - applied to the 'check-undefined' check added on local-bound variables. @@ -227,14 +224,17 @@ stepper-else : Note that it cannot be applied simply to the 'true' itself, because then, when you reduce to the then, the mark on the test (that is, the (#%datum . true)) is gone. - (Transferred.) - -stepper-define-struct-hint : - this expression came from a define-struct. The value associated with - this label is the syntax-object representing the define-struct itself. - -NB: this should be renamed now that we're using it for "require" as well. - + +stepper-black-box-expr : + this expression should be treated as a "black box"; evaluated without + annotation, and "transparent" in the stepper, in the sense that the + original expression should appear in the completed expressions without + alteration. + + Examples: + - define-struct + - require + stepper-test-suite-hint : this expression was the expression being tested in a test-suite-tool test. this hint indicates to the annotator that the expression should @@ -262,6 +262,12 @@ stepper-hide-reduction : don't show any reductions where this term is stepper-use-val-as-final : use the return value of this expression as a "completed" val in the stepper. Used for test cases. +stepper-lifted-name : used by the reconstructor to tell the unwinder + what the lifted name of a variable is. + +lazy-op : ??? + + STEPPER-HINT COLLISIONS The major concern with the stepper-hint is that two of them may diff --git a/collects/stepper/private/model.rkt b/collects/stepper/private/model.rkt index c619a4b9a9..11f56d66af 100644 --- a/collects/stepper/private/model.rkt +++ b/collects/stepper/private/model.rkt @@ -488,8 +488,8 @@ (printf " source: ~a\n" (syntax->hilite-datum ((car x)))) (printf " index: ~a\n" (second x)) (printf " getter: ") - (if (stepper-syntax-property ((car x)) 'stepper-define-struct-hint) - (printf "no getter for term with stepper-define-struct-hint property\n") + (if (stepper-syntax-property ((car x)) 'stepper-black-box-expr) + (printf "no getter for term with stepper-black-box-expr property\n") (printf "~a\n" ((third x))))) returned-value-list)) (for-each (lambda (source/index/getter) diff --git a/collects/stepper/private/reconstruct.rkt b/collects/stepper/private/reconstruct.rkt index beb8469c8d..e11724b15c 100644 --- a/collects/stepper/private/reconstruct.rkt +++ b/collects/stepper/private/reconstruct.rkt @@ -285,8 +285,7 @@ (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? (stepper-syntax-property expr 'stepper-hint) 'comes-from-begin) - (stepper-syntax-property expr 'stepper-skip-double-break))) + (eq? (stepper-syntax-property expr 'stepper-hint) 'comes-from-begin)) (not (render-settings-lifting? render-settings)))] [(expr-finished-break define-struct-break late-let-break) #f])) @@ -674,9 +673,9 @@ (vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))]) (let ([exp (skipto/auto exp 'discard (lambda (exp) exp))]) (cond - [(stepper-syntax-property exp 'stepper-define-struct-hint) + [(stepper-syntax-property exp 'stepper-black-box-expr) ;; the hint contains the original syntax - (vector (stepper-syntax-property exp 'stepper-define-struct-hint) #t)] + (vector (stepper-syntax-property exp 'stepper-black-box-expr) #t)] ;; for test cases, use the result here as the final result of the expression: [(stepper-syntax-property exp 'stepper-use-val-as-final) (vector (recon-value (car (vals-getter)) render-settings) #f)] @@ -833,19 +832,11 @@ (map reconstruct-remaining-def (cdr not-done-glumps)))) 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 '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)) - (stepper-syntax-property so-far 'stepper-offset-index))] - [bodies (syntax->list (syntax bodies))] + ;; JBC: deleted a bunch of dead code here referring to a never-set "stepper-offset" index... + ;; frightening. [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)))]) + (for/list ([body (in-list (syntax->list #'bodies))]) + (recon-source-expr body mark-list binding-list binding-list render-settings))]) (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) ; STC: cache any running promises in the top mark diff --git a/collects/stepper/private/shared.rkt b/collects/stepper/private/shared.rkt index 2b33777eb2..b454457dd1 100644 --- a/collects/stepper/private/shared.rkt +++ b/collects/stepper/private/shared.rkt @@ -1,7 +1,6 @@ #lang racket -(require scheme/class) - +(require rackunit) ; CONTRACTS @@ -103,21 +102,56 @@ ;; stepper-syntax-property : like syntax property, but adds properties to an association ;; list associated with the syntax property 'stepper-properties -;; 2010-12-05: I no longer see any reason not just to use the regular -;; syntax-property for this... + (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)))])) + [(stx tag) + (unless (member tag known-stepper-syntax-property-names) + (raise-type-error 'stepper-syntax-property "known stepper property symbol" 1 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) + (unless (member tag known-stepper-syntax-property-names) + (raise-type-error 'stepper-syntax-property "known stepper property symbol" 1 + stx tag new-val)) + (syntax-property stx 'stepper-properties + (cons (list tag new-val) + (or (syntax-property stx 'stepper-properties) + null)))])) + +;; if the given property name isn't in this list, signal an error... +(define known-stepper-syntax-property-names + '(stepper-skip-completely + stepper-hint + stepper-define-type + stepper-xml-hint + stepper-xml-value-hint + stepper-proc-define-name + stepper-orig-name + stepper-prim-name + stepper-binding-type + stepper-no-lifting-info + stepper-and/or-clauses-consumed + stepper-skipto + stepper-skipto/discard + stepper-replace + stepper-else + stepper-black-box-expr + stepper-test-suite-hint + stepper-highlight + stepper-fake-exp + stepper-args-of-call + stepper-hide-completed + stepper-hide-reduction + stepper-use-val-as-final + stepper-lifted-name + lazy-op + )) ;; with-stepper-syntax-properties : like stepper-syntax-property, but in a "let"-like form (define-syntax (with-stepper-syntax-properties stx) @@ -738,62 +772,5 @@ -; test cases -;(require shared) -;(write (collection-path "tests" "mzscheme")) -;(load (build-path (collection-path "tests" "mzscheme") "testing.ss")) -; -;(define (a sym) -; (syntax->datum (get-lifted-var sym))) -;(define cd-stx -; (datum->syntax #f 'cd)) -;(test 'lifter-ab-0 a (datum->syntax #f 'ab)) -;(test 'lifter-cd-1 a cd-stx) -;(test 'lifter-ef-2 a (datum->syntax #f 'ef)) -;(test 'lifter-cd-1 a cd-stx) -; -;(test '(a b c) map syntax-e (arglist->ilist #'(a b c))) -;(test '(a b c) map syntax-e (arglist->ilist #'(a . (b c)))) -;(test 'a syntax-e (arglist->ilist #'a)) -;(let ([result (arglist->ilist #' (a b . c))]) -; (test 'a syntax-e (car result)) -; (test 'b syntax-e (cadr result)) -; (test 'c syntax-e (cddr result))) -;(test '(a b c) map syntax-e (arglist-flatten #'(a b c))) -;(test '(a b c) map syntax-e (arglist-flatten #'(a . (b c)))) -;(test '(a b c) map syntax-e (arglist-flatten #'(a b . c))) -;(test '(a) map syntax-e (arglist-flatten #'a)) -; -;(define (add1 x) (+ x 1)) -;(test '(3 4 5) ilist-map add1 '(2 3 4)) -;(test '(3 4 . 5) ilist-map add1 '(2 3 . 4)) -; -;(test '(2 3 4) ilist-flatten '(2 3 4)) -;(test '(2 3 4) ilist-flatten '(2 3 . 4)) -; -;(define new-queue (make-queue)) -;(test (void) queue-push new-queue 1) -;(test (void) queue-push new-queue 2) -;(test 1 queue-pop new-queue) -;(test (void) queue-push new-queue 3) -;(test 2 queue-pop new-queue) -;(test 3 queue-pop new-queue) -;(err/rt-test (queue-pop new-queue) exn:user?) - -;(equal? -; (call-with-values (lambda () -; (values-map (lambda (a b) (values (+ a b) (- a b))) -; `(1 2 3 4 5) -; `(9 8 7 6 5))) -; (lambda (sums diffs) -; (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->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg)) diff --git a/collects/stepper/stepper-tool.rkt b/collects/stepper/stepper-tool.rkt index 92df9bec33..cfdec48af6 100644 --- a/collects/stepper/stepper-tool.rkt +++ b/collects/stepper/stepper-tool.rkt @@ -287,7 +287,7 @@ [language-level-name (language-level->name language-level)]) (if (or (stepper-works-for? language-level) (is-a? language-level drracket:module-language:module-language<%>)) - (parameterize ([current-directory (get-directory)]) + (parameterize ([current-directory (or (get-directory) (current-directory))]) (set! stepper-frame (go this program-expander