From dbdf00c5f713ab5eaed70b8e6d35f32b2349aa5c Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 2 Jul 2010 11:02:47 -0600 Subject: [PATCH] macro-stepper: track syntax-local-value and syntax-track-origin (not done) --- collects/macro-debugger/model/deriv-c.rkt | 2 ++ collects/macro-debugger/model/deriv-parser.rkt | 5 +++++ collects/macro-debugger/model/deriv-tokens.rkt | 10 ++++++++-- collects/macro-debugger/model/reductions.rkt | 9 +++++++++ collects/macro-debugger/model/steps.rkt | 1 + src/racket/src/env.c | 16 +++++++++++++--- src/racket/src/schexpobs.h | 11 ++++++++++- src/racket/src/stxobj.c | 8 +++++++- 8 files changed, 55 insertions(+), 7 deletions(-) diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt index c155e64dfb..89308a538b 100644 --- a/collects/macro-debugger/model/deriv-c.rkt +++ b/collects/macro-debugger/model/deriv-c.rkt @@ -39,6 +39,8 @@ (define-struct local-lift-require (req expr mexpr) #:transparent) (define-struct local-lift-provide (prov) #:transparent) (define-struct local-bind (names ?1 renames bindrhs) #:transparent) +(define-struct local-value (name ?1 resolves bound?) #:transparent) +(define-struct track-origin (before after) #:transparent) (define-struct local-remark (contents) #:transparent) ;; contents : (listof (U string syntax)) diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt index a14043570e..ec95d05dbc 100644 --- a/collects/macro-debugger/model/deriv-parser.rkt +++ b/collects/macro-debugger/model/deriv-parser.rkt @@ -43,6 +43,7 @@ enter-check exit-check local-post exit-local exit-local/expr local-bind enter-bind exit-bind + local-value-result phase-up module-body renames-lambda renames-case-lambda @@ -201,6 +202,10 @@ (make local-bind $1 $2 $3 #f)] [(local-bind rename-list (? BindSyntaxes)) (make local-bind $1 #f $2 $3)] + [(track-origin) + (make track-origin (car $1) (cdr $1))] + [(local-value ! Resolves local-value-result) + (make local-value $1 $2 $3 $4)] [(local-remark) (make local-remark $1)] [(local-artificial-step) diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt index 3c5cb9d006..7e717e79a8 100644 --- a/collects/macro-debugger/model/deriv-tokens.rkt +++ b/collects/macro-debugger/model/deriv-tokens.rkt @@ -61,6 +61,10 @@ local-remark ; (listof (U string syntax)) local-artificial-step ; (list syntax syntax syntax syntax) + + track-origin ; (cons stx stx) + local-value ; identifier + local-value-result ; boolean )) (define-tokens renames-tokens @@ -175,8 +179,10 @@ (149 prim-varref) (150 lift-require ,token-lift-require) (151 lift-provide ,token-lift-provide) - (155 prim-#%stratified-body) - )) + (152 track-origin ,token-track-origin) + (153 local-value ,token-local-value) + (154 local-value-result ,token-local-value-result) + (155 prim-#%stratified-body))) (define (signal->symbol sig) (if (symbol? sig) diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index 3f04bf1f70..d58692339a 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -454,6 +454,15 @@ ;; FIXME: use renames [#:binders names] [#:when bindrhs => (BindSyntaxes bindrhs)]]] + [(struct track-origin (before after)) + [R [#:set-syntax before] + [#:pattern ?form] + [#:rename ?form after 'track-origin]]] + [(struct local-value (name ?1 resolves bound?)) + [R [! ?1] + ;; [#:learn (list name)] + ;; Add remark step? + ]] [(struct local-remark (contents)) (R [#:reductions (list (walk/talk 'remark contents))])])) diff --git a/collects/macro-debugger/model/steps.rkt b/collects/macro-debugger/model/steps.rkt index bb4feedd3e..e7e8184165 100644 --- a/collects/macro-debugger/model/steps.rkt +++ b/collects/macro-debugger/model/steps.rkt @@ -92,6 +92,7 @@ (splice-module-lifts . "Splice lifted module declarations") (remark . "Macro made a remark") + (track-origin . "Macro called syntax-track-origin") (error . "Error"))) diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 0e3a31e43d..a46811def1 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -4661,7 +4661,7 @@ now_transforming(int argc, Scheme_Object *argv[]) static Scheme_Object * do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur) { - Scheme_Object *v, *sym, *a[2]; + Scheme_Object *v, *sym, *a[2], *observer; Scheme_Env *menv; Scheme_Comp_Env *env; int renamed = 0; @@ -4674,6 +4674,9 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r sym = argv[0]; + observer = scheme_get_expand_observe(); + SCHEME_EXPAND_OBSERVE_LOCAL_VALUE(observer, sym); + if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym)))) scheme_wrong_type(name, "syntax identifier", 0, argc, argv); @@ -4710,12 +4713,15 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r scheme_current_thread->current_local_certs, scheme_current_thread->current_local_modidx, &menv, NULL, NULL); - + + SCHEME_EXPAND_OBSERVE_RESOLVE(observer, sym); + /* Deref globals */ if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) { + SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_false); if ((argc > 1) && SCHEME_TRUEP(argv[1])) return _scheme_tail_apply(argv[1], 0, NULL); else @@ -4735,16 +4741,20 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r menv = NULL; SCHEME_USE_FUEL(1); if (!recur) { + SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); a[0] = v; a[1] = sym; return scheme_values(2, a); } } else if (!recur) { + SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); a[0] = v; a[1] = scheme_false; return scheme_values(2, a); - } else + } else { + SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(observer, scheme_true); return v; + } } } diff --git a/src/racket/src/schexpobs.h b/src/racket/src/schexpobs.h index ba13079075..85e89e43b7 100644 --- a/src/racket/src/schexpobs.h +++ b/src/racket/src/schexpobs.h @@ -176,6 +176,15 @@ extern Scheme_Object *scheme_get_expand_observe(); #define SCHEME_EXPAND_OBSERVE_RENAME_ONE(obs,val) \ _SCHEME_EXPOBS(obs,148,val) -/* next: 156 (skipped some) */ +#define SCHEME_EXPAND_OBSERVE_TRACK_ORIGIN(obs,pre,post) \ + _SCHEME_EXPOBS(obs,152,scheme_make_pair(pre,post)) + +#define SCHEME_EXPAND_OBSERVE_LOCAL_VALUE(obs,id) \ + _SCHEME_EXPOBS(obs,153,id) + +#define SCHEME_EXPAND_OBSERVE_LOCAL_VALUE_RESULT(obs,bound) \ + _SCHEME_EXPOBS(obs,154,bound) + +/* next: 156 */ #endif diff --git a/src/racket/src/stxobj.c b/src/racket/src/stxobj.c index c9d682bd9a..eb1316f8b4 100644 --- a/src/racket/src/stxobj.c +++ b/src/racket/src/stxobj.c @@ -21,6 +21,7 @@ #include "schpriv.h" #include "schmach.h" +#include "schexpobs.h" /* The implementation of syntax objects is extremely complex due to two levels of optimization: @@ -8845,6 +8846,8 @@ static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv) static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv) { + Scheme_Object *result, *observer; + if (!SCHEME_STXP(argv[0])) scheme_wrong_type("syntax-track-origin", "syntax", 0, argc, argv); if (!SCHEME_STXP(argv[1])) @@ -8852,7 +8855,10 @@ static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv) if (!SCHEME_STX_IDP(argv[2])) scheme_wrong_type("syntax-track-origin", "identifier syntax", 2, argc, argv); - return scheme_stx_track(argv[0], argv[1], argv[2]); + result = scheme_stx_track(argv[0], argv[1], argv[2]); + observer = scheme_get_expand_observe(); + SCHEME_EXPAND_OBSERVE_TRACK_ORIGIN(observer, argv[0], result); + return result; } Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from)