macro-stepper: track syntax-local-value and syntax-track-origin (not done)

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

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)

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)

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

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

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);
 
@@ -4711,11 +4714,14 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r
 			      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;
+    }
   }
 }
 

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

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)