free-identifier-tree-equal.rkt (3601B)
1 #lang racket 2 3 (require racket/struct 4 ;; TODO: move delay-pure/private/immutable-struct to a separate package 5 phc-toolkit/untyped/meta-struct) ;; for immutable-struct? below. 6 7 (provide free-id-tree=? 8 free-id-tree-hash-code 9 free-id-tree-secondary-hash-code 10 11 free-id-tree-table? 12 immutable-free-id-tree-table? 13 mutable-free-id-tree-table? 14 weak-free-id-tree-table? 15 make-immutable-free-id-tree-table 16 make-mutable-free-id-tree-table 17 make-weak-free-id-tree-table) 18 19 ;; Contract: 20 ;; TODO: move to tr-immutable 21 (define isyntax/c 22 (flat-rec-contract isyntax 23 (or/c boolean? 24 char? 25 number? 26 keyword? 27 null? 28 (and/c string? immutable?) 29 symbol? 30 (box/c isyntax #:immutable #t) 31 (cons/c isyntax isyntax) 32 (vectorof isyntax #:immutable #t) 33 (syntax/c isyntax) 34 (and/c struct-instance-is-immutable? 35 (λ (v) 36 (andmap isyntax/c (struct->list v))))))) 37 38 (define/contract (free-id-tree=? a b [r equal?]) 39 (->* {isyntax/c isyntax/c} 40 {(-> isyntax/c isyntax/c boolean?)} 41 boolean?) 42 (define (rec=? a b) (free-id-tree=? a b r)) 43 (cond 44 [(identifier? a) (and (identifier? b) 45 (free-identifier=? a b))] 46 [(syntax? a) (and (syntax? b) 47 (rec=? (syntax-e a) 48 (syntax-e b)))] 49 [(pair? a) (and (pair? b) 50 (rec=? (car a) (car b)) 51 (rec=? (cdr a) (cdr b)))] 52 [(vector? a) (and (vector? b) 53 (rec=? (vector->list a) 54 (vector->list b)))] 55 [(box? a) (and (box? b) 56 (rec=? (unbox a) 57 (unbox b)))] 58 [(prefab-struct-key a) 59 => (λ (a-key) 60 (let ([b-key (prefab-struct-key b)]) 61 (and (equal? a-key b-key) 62 (rec=? (struct->list a) 63 (struct->list b)))))] 64 [(struct? a) 65 (and (struct? b) 66 (rec=? (vector->immutable-vector (struct->vector a)) 67 (vector->immutable-vector (struct->vector b))))] 68 [(null? a) (null? b)] 69 [else (equal? a b)])) 70 71 (define/contract ((free-id-tree-hash default-hc) a [hc default-hc]) 72 (-> (-> any/c fixnum?) (->* {isyntax/c} {(-> isyntax/c fixnum?)} fixnum?)) 73 (define rec-hash (free-id-tree-hash hc)) 74 (cond 75 [(identifier? a) (hc (syntax-e #'a))] 76 [(syntax? a) (rec-hash (syntax-e a))] 77 [(pair? a) (hc (cons (rec-hash (car a)) 78 (rec-hash (cdr a))))] 79 [(vector? a) (hc (vector->immutable-vector 80 (list->vector (map rec-hash (vector->list a)))))] 81 [(box? a) (hc (box (rec-hash (unbox a))))] 82 [(prefab-struct-key a) 83 => (λ (a-key) 84 (hc (apply make-prefab-struct a-key 85 (rec-hash (struct->list a)))))] 86 [(struct? a) 87 (rec-hash (vector->immutable-vector (struct->vector a)))] 88 [else (hc a)])) 89 90 (define free-id-tree-hash-code 91 (free-id-tree-hash equal-hash-code)) 92 (define free-id-tree-secondary-hash-code 93 (free-id-tree-hash equal-secondary-hash-code)) 94 95 (define-custom-hash-types free-id-tree-table 96 #:key? syntax? 97 free-id-tree=? 98 free-id-tree-hash-code 99 free-id-tree-secondary-hash-code)