macro-stepper: fetch mark lists directly

collects/macro-debugger/syntax-browser/partition.rkt

@@ -1,9 +1,9 @@
-
 #lang scheme/base
 (require scheme/class
          syntax/boundmap
          syntax/stx
-         "interfaces.ss")
+         "interfaces.rkt"
+         "../util/stxobj.rkt")
 (provide new-bound-partition
          partition%
          identifier=-choices)
@@ -79,27 +79,32 @@
 ;; bound-partition%
 (define bound-partition%
   (class* object% (partition<%>)
-    ;; numbers : bound-identifier-mapping[identifier => number]
-    (define numbers (make-bound-identifier-mapping))
+
+    ;; simplified : hash[(listof nat) => nat]
+    (define simplified (make-hash))
+
+    ;; unsimplified : hash[(listof nat) => nat]
+    (define unsimplified (make-hash))
+
+    ;; next-number : nat
     (define next-number 0)
-    
+
     (define/public (get-partition stx)
-      (let* ([r (representative stx)]
-             [n (bound-identifier-mapping-get numbers r (lambda _ #f))])
-        (or n
-            (begin0 next-number
-              (bound-identifier-mapping-put! numbers r next-number)
-              #;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax->datum stx))
-              (set! next-number (add1 next-number))))))
-    
+      (let ([umarks (get-marks stx)])
+        (or (hash-ref unsimplified umarks #f)
+            (let ([smarks (simplify-marks umarks)])
+              (or (hash-ref simplified smarks #f)
+                  (let ([n next-number])
+                    (hash-set! simplified smarks n)
+                    (hash-set! unsimplified umarks n)
+                    (set! next-number (add1 n))
+                    n))))))
+
     (define/public (same-partition? a b)
       (= (get-partition a) (get-partition b)))
-    
+
     (define/public (count)
       next-number)
-    
-    (define/private (representative stx)
-      (datum->syntax stx representative-symbol))
 
     (get-partition unmarked-syntax)
     (super-new)))

collects/macro-debugger/syntax-browser/properties.rkt

@@ -6,7 +6,8 @@
                     [send/i send:])
          "interfaces.ss"
          "util.ss"
-         "../util/mpi.ss")
+         "../util/mpi.ss"
+         "../util/stxobj.rkt")
 (provide properties-view%
          properties-snip%)
 
@@ -206,7 +207,8 @@
     (define/public (display-stxobj-info stx)
       (display-source-info stx)
       (display-extra-source-info stx)
-      (display-symbol-property-info stx))
+      (display-symbol-property-info stx)
+      (display-marks stx))
 
     ;; display-source-info : syntax -> void
     (define/private (display-source-info stx)
@@ -244,7 +246,13 @@
           (display "No additional properties available.\n" n/a-sd))
         (when (pair? keys)
           (for-each (lambda (k) (display-subkv/value k (syntax-property stx k)))
-                    keys))))
+                    keys))
+        (display "\n" #f)))
+
+    ;; display-marks : syntax -> void
+    (define/private (display-marks stx)
+      (display "Marks: " key-sd)
+      (display (format "~s\n" (simplify-marks (get-marks stx))) #f))
 
     ;; display-kv : any any -> void
     (define/private (display-kv key value)

collects/macro-debugger/util/stxobj.rkt

@@ -0,0 +1,30 @@
+#lang racket
+(require (rename-in racket/contract [-> c:->])
+         ffi/unsafe)
+
+(define lib (ffi-lib #f))
+
+(define get-marks
+  (get-ffi-obj "scheme_stx_extract_marks" lib
+               (_fun _scheme -> _scheme)))
+
+(define (simplify-marks marklist)
+  (simplify* (sort marklist <)))
+
+(define (simplify* marklist)
+  (cond [(null? marklist) marklist]
+        [(null? (cdr marklist)) marklist]
+        [(= (car marklist) (cadr marklist))
+         (simplify* (cddr marklist))]
+        [else
+         (let ([result (simplify* (cdr marklist))])
+           (if (eq? result (cdr marklist))
+               marklist
+               (cons (car marklist) result)))]))
+
+(provide/contract
+ [get-marks
+  ;; syntax? check needed for safety!
+  (c:-> syntax? any)])
+
+(provide simplify-marks)