commit fc8ab37c3f8a2de12855bd9f184a66cef9725c4d
parent f4d14edaac382e1784b252eb3dbbd6a2cbc75e7f
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 14 Jun 2010 18:38:21 -0600
macro-stepper: fetch mark lists directly
original commit: 472b5ecdc0d6048750ec3ff12bec3af51a1a43a4
Diffstat:
3 files changed, 63 insertions(+), 20 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/partition.rkt b/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)))
diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/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)
diff --git a/collects/macro-debugger/util/stxobj.rkt b/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)
