partition.rkt (2016B)
1 #lang racket/base 2 (require racket/class 3 "interfaces.rkt") 4 (provide new-macro-scopes-partition 5 new-all-scopes-partition 6 partition-choices 7 identifier=-choices) 8 9 (define (new-macro-scopes-partition) 10 (new macro-scopes-partition%)) 11 12 (define (new-all-scopes-partition) 13 (new scopes-partition%)) 14 15 ;; scopes-partition% 16 (define scopes-partition% 17 (class* object% (partition<%>) 18 19 ;; simplified : hash[(listof nat) => nat] 20 (define simplified (make-hash)) 21 22 ;; next-number : nat 23 (define next-number 0) 24 25 (define/public (get-partition stx) 26 (let ([marks (get-scopes stx)]) 27 (or (hash-ref simplified marks #f) 28 (let ([n next-number]) 29 (hash-set! simplified marks n) 30 (set! next-number (add1 n)) 31 n)))) 32 33 (define/public (get-scopes stx) 34 (get-all-scopes stx)) 35 36 (define/public (same-partition? a b) 37 (= (get-partition a) (get-partition b))) 38 39 (define/public (count) 40 next-number) 41 42 (get-partition (datum->syntax #f 'nowhere)) 43 (super-new))) 44 45 ;; macro-scopes-partition% 46 (define macro-scopes-partition% 47 (class scopes-partition% 48 (super-new) 49 (define/override (get-scopes stx) 50 (get-macro-scopes stx)))) 51 52 (define (get-macro-scopes stx) 53 (define ctx (hash-ref (syntax-debug-info stx) 'context null)) 54 (for/list ([scope (in-list ctx)] 55 #:when (memq (vector-ref scope 1) '(macro))) 56 (vector-ref scope 0))) 57 58 (define (get-all-scopes stx) 59 (define ctx (hash-ref (syntax-debug-info stx) 'context null)) 60 (for/list ([scope (in-list ctx)]) 61 (vector-ref scope 0))) 62 63 ;; ==== Partition choices ==== 64 65 (define partition-choices 66 (make-parameter 67 `(("By macro scopes" . ,new-macro-scopes-partition) 68 ("By all scopes" . ,new-all-scopes-partition)))) 69 70 ;; ==== Identifier relations ==== 71 72 (define identifier=-choices 73 (make-parameter 74 `(("<nothing>" . #f) 75 ("bound-identifier=?" . ,bound-identifier=?) 76 ("free-identifier=?" . ,free-identifier=?))))