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

Updated stepper-syntax property to only permit known & documented stepper properties,

Browse Source 
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...
This commit is contained in:
John Clements 2011-06-29 00:29:00 -07:00
parent d839b9fea6
commit ae9cab6ee0
5 changed files with 97 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/stepper/internal-docs.txt
View File

@ -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

4
collects/stepper/private/model.rkt
View File

@ -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)

23
collects/stepper/private/reconstruct.rkt
View File

@ -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

121
collects/stepper/private/shared.rkt
View File

@ -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))

2
collects/stepper/stepper-tool.rkt
View File

@ -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