100 lines
3.5 KiB
Racket
100 lines
3.5 KiB
Racket
#lang racket
|
|
|
|
(require racket/struct
|
|
;; TODO: move delay-pure/private/immutable-struct to a separate package
|
|
phc-toolkit/untyped/meta-struct) ;; for immutable-struct? below.
|
|
|
|
(provide free-id-tree=?
|
|
free-id-tree-hash-code
|
|
free-id-tree-secondary-hash-code
|
|
|
|
free-id-tree-table?
|
|
immutable-free-id-tree-table?
|
|
mutable-free-id-tree-table?
|
|
weak-free-id-tree-table?
|
|
make-immutable-free-id-tree-table
|
|
make-mutable-free-id-tree-table
|
|
make-weak-free-id-tree-table)
|
|
|
|
;; Contract:
|
|
;; TODO: move to tr-immutable
|
|
(define isyntax/c
|
|
(flat-rec-contract isyntax
|
|
(or/c boolean?
|
|
char?
|
|
number?
|
|
keyword?
|
|
null?
|
|
(and/c string? immutable?)
|
|
symbol?
|
|
(box/c isyntax #:immutable #t)
|
|
(cons/c isyntax isyntax)
|
|
(vectorof isyntax #:immutable #t)
|
|
(syntax/c isyntax)
|
|
(and/c struct-instance-is-immutable?
|
|
(λ (v)
|
|
(andmap isyntax/c (struct->list v)))))))
|
|
|
|
(define/contract (free-id-tree=? a b [r equal?])
|
|
(->* {isyntax/c isyntax/c}
|
|
{(-> isyntax/c isyntax/c boolean?)}
|
|
boolean?)
|
|
(define (rec=? a b) (free-id-tree=? a b r))
|
|
(cond
|
|
[(identifier? a) (and (identifier? b)
|
|
(free-identifier=? a b))]
|
|
[(syntax? a) (and (syntax? b)
|
|
(rec=? (syntax-e a)
|
|
(syntax-e b)))]
|
|
[(pair? a) (and (pair? b)
|
|
(rec=? (car a) (car b))
|
|
(rec=? (cdr a) (cdr b)))]
|
|
[(vector? a) (and (vector? b)
|
|
(rec=? (vector->list a)
|
|
(vector->list b)))]
|
|
[(box? a) (and (box? b)
|
|
(rec=? (unbox a)
|
|
(unbox b)))]
|
|
[(prefab-struct-key a)
|
|
=> (λ (a-key)
|
|
(let ([b-key (prefab-struct-key b)])
|
|
(and (equal? a-key b-key)
|
|
(rec=? (struct->list a)
|
|
(struct->list b)))))]
|
|
[(struct? a)
|
|
(and (struct? b)
|
|
(rec=? (vector->immutable-vector (struct->vector a))
|
|
(vector->immutable-vector (struct->vector b))))]
|
|
[(null? a) (null? b)]
|
|
[else (equal? a b)]))
|
|
|
|
(define/contract ((free-id-tree-hash default-hc) a [hc default-hc])
|
|
(-> (-> any/c fixnum?) (->* {isyntax/c} {(-> isyntax/c fixnum?)} fixnum?))
|
|
(define rec-hash (free-id-tree-hash hc))
|
|
(cond
|
|
[(identifier? a) (hc (syntax-e #'a))]
|
|
[(syntax? a) (rec-hash (syntax-e a))]
|
|
[(pair? a) (hc (cons (rec-hash (car a))
|
|
(rec-hash (cdr a))))]
|
|
[(vector? a) (hc (vector->immutable-vector
|
|
(list->vector (map rec-hash (vector->list a)))))]
|
|
[(box? a) (hc (box (rec-hash (unbox a))))]
|
|
[(prefab-struct-key a)
|
|
=> (λ (a-key)
|
|
(hc (apply make-prefab-struct a-key
|
|
(rec-hash (struct->list a)))))]
|
|
[(struct? a)
|
|
(rec-hash (vector->immutable-vector (struct->vector a)))]
|
|
[else (hc a)]))
|
|
|
|
(define free-id-tree-hash-code
|
|
(free-id-tree-hash equal-hash-code))
|
|
(define free-id-tree-secondary-hash-code
|
|
(free-id-tree-hash equal-secondary-hash-code))
|
|
|
|
(define-custom-hash-types free-id-tree-table
|
|
#:key? syntax?
|
|
free-id-tree=?
|
|
free-id-tree-hash-code
|
|
free-id-tree-secondary-hash-code)
|