Stephen Chang
parent
0304fedf92
commit
7d434d266e
|
|
@ -397,7 +397,8 @@ set, and so it preserves any contract on the given set. The
|
|||
@racket[set-copy-clear] function produces a new set without any
|
||||
contracts.
|
||||
|
||||
Has no fallback.
|
||||
The @racket[set-copy-clear] function must call concrete set constructors
|
||||
and thus has no generic fallback.
|
||||
}
|
||||
|
||||
@defproc[(set-clear [st generic-set?]) (and/c generic-set? set-empty?)]{
|
||||
|
|
|
|||
284
pkgs/racket-doc/syntax/scribblings/id-set.scrbl
Normal file
284
pkgs/racket-doc/syntax/scribblings/id-set.scrbl
Normal file
|
|
@ -0,0 +1,284 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.rkt"
|
||||
(for-label syntax/id-set
|
||||
racket/set
|
||||
(only-in racket/stream gen:stream)))
|
||||
|
||||
@title[#:tag "idset"]{Sets with Identifier Keys}
|
||||
|
||||
@defmodule[syntax/id-set]
|
||||
|
||||
This module provides @deftech{identifier sets}:
|
||||
sets with identifier keys that use identifier-specific
|
||||
comparisons instead of the usual equality operators such as
|
||||
@racket[eq?] or @racket[equal?].
|
||||
|
||||
This module implements two kinds of identifier sets: one via
|
||||
@racket[free-identifier=?] and one via @racket[bound-identifier=?].
|
||||
Each are available in both mutable and immutable variants and
|
||||
implement the @racket[gen:set],
|
||||
@racket[gen:stream],
|
||||
@racket[prop:sequence], and @racket[gen:equal+hash]
|
||||
generic interfaces.
|
||||
|
||||
Identifier sets are implemented using @tech{identifier tables},
|
||||
in the same way that
|
||||
@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{hash sets}
|
||||
are implemented with
|
||||
@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{hash tables}.
|
||||
|
||||
|
||||
@section{Sets for @racket[free-identifier=?]}
|
||||
|
||||
A free-identifier set is a set whose keys are compared using
|
||||
@racket[free-identifier=?]. Free-identifier sets implement the
|
||||
@racket[gen:set] interface, so all of the
|
||||
appropriate generic functions (e.g., @racket[set-add], @racket[set-map],
|
||||
etc) can be used on free-identifier sets.
|
||||
|
||||
@deftogether[[
|
||||
@defproc[(mutable-free-id-set
|
||||
[init-set generic-set? null]
|
||||
[#:phase phase (or/c exact-integer? #f) (syntax-local-phase-level)])
|
||||
mutable-free-id-set?]
|
||||
@defproc[(immutable-free-id-set
|
||||
[init-set generic-set? null]
|
||||
[#:phase phase (or/c exact-integer? #f) (syntax-local-phase-level)])
|
||||
immutable-free-id-set?]]]{
|
||||
|
||||
Produces a mutable free-identifier set or immutable free-identifier
|
||||
set, respectively. The set uses @racket[free-identifier=?]
|
||||
to compare keys.
|
||||
|
||||
The identifiers are compared at phase level @racket[phase]. The
|
||||
default phase, @racket[(syntax-local-phase-level)], is generally
|
||||
appropriate for identifier sets used by macros, but code that
|
||||
analyzes fully-expanded programs may need to create separate
|
||||
identifier sets for each phase of the module.
|
||||
|
||||
The optional @racket[init-set] argument provides the initial
|
||||
set elements. It must be a set of identifiers. If the @racket[init-set]
|
||||
set has multiple distinct entries whose keys are @racket[free-identifier=?],
|
||||
only one of the entries appears in the new id-set, and it is not specified
|
||||
which entry is picked.
|
||||
}
|
||||
|
||||
@defproc[(free-id-set? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] was produced by
|
||||
@racket[mutable-free-id-set] or
|
||||
@racket[immutable-free-id-set], @racket[#f] otherwise.
|
||||
}
|
||||
|
||||
@defproc[(mutable-free-id-set? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] was produced by
|
||||
@racket[mutable-free-id-set], @racket[#f] otherwise.
|
||||
}
|
||||
|
||||
@defproc[(immutable-free-id-set? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if @racket[v] was produced by
|
||||
@racket[immutable-free-id-set], @racket[#f] otherwise.
|
||||
}
|
||||
|
||||
@defproc[(free-id-set-empty? [s free-id-set?]) boolean?]{
|
||||
Like @racket[set-empty?].}
|
||||
|
||||
@defproc[(free-id-set-count [s free-id-set?]) exact-nonnegative-integer?]{
|
||||
Like @racket[set-count].}
|
||||
|
||||
@defproc[(free-id-set-member? [s free-id-set?] [v identifier?]) boolean?]{
|
||||
Like @racket[set-member?].}
|
||||
|
||||
@defproc[(free-id-set=? [s1 free-id-set?] [s2 free-id-set?]) boolean?]{
|
||||
Like @racket[set=?].}
|
||||
|
||||
@defproc[(free-id-set-add [s immutable-free-id-set?] [v identifier?])
|
||||
immutable-free-id-set?]{
|
||||
Like @racket[set-add].}
|
||||
|
||||
@defproc[(free-id-set-add! [s mutable-free-id-set?] [v identifier?]) void?]{
|
||||
Like @racket[set-add!].}
|
||||
|
||||
@defproc[(free-id-set-remove [s immutable-free-id-set?] [v identifier?])
|
||||
immutable-free-id-set?]{
|
||||
Like @racket[set-remove].}
|
||||
|
||||
@defproc[(free-id-set-remove! [s mutable-free-id-set?] [v identifier?]) void?]{
|
||||
Like @racket[set-remove!].}
|
||||
|
||||
@defproc[(free-id-set-first [s free-id-set?]) identifier?]{
|
||||
Like @racket[set-first].}
|
||||
|
||||
@defproc[(free-id-set-rest [s immutable-free-id-set?]) immutable-free-id-set?]{
|
||||
Like @racket[set-rest].}
|
||||
|
||||
@defproc[(in-free-id-set [s free-id-set?]) sequence?]{
|
||||
Like @racket[in-set].}
|
||||
|
||||
@defproc[(free-id-set->stream [s free-id-set?]) stream?]{
|
||||
Like @racket[set->stream].}
|
||||
|
||||
@defproc[(free-id-set->list [s free-id-set?]) list?]{
|
||||
Like @racket[set->list].}
|
||||
|
||||
@defproc[(free-id-set-copy [s free-id-set?]) free-id-set?]{
|
||||
Like @racket[set-copy].}
|
||||
|
||||
@defproc[(free-id-set-copy-clear [s free-id-set?]) free-id-set?]{
|
||||
Like @racket[set-copy-clear].}
|
||||
|
||||
@defproc[(free-id-set-clear [s immutable-free-id-set?]) immutable-free-id-set?]{
|
||||
Like @racket[set-clear].}
|
||||
|
||||
@defproc[(free-id-set-clear! [s mutable-free-id-set?]) void?]{
|
||||
Like @racket[set-clear!].}
|
||||
|
||||
@defproc[(free-id-set-union [s0 immutable-free-id-set?] [s free-id-set?] ...)
|
||||
immutable-free-id-set?]{
|
||||
Like @racket[set-union].}
|
||||
|
||||
@defproc[(free-id-set-union! [s0 mutable-free-id-set?] [s free-id-set?] ...)
|
||||
void?]{
|
||||
Like @racket[set-union!].}
|
||||
|
||||
@defproc[(free-id-set-intersect
|
||||
[s0 immutable-free-id-set?] [s free-id-set?] ...)
|
||||
immutable-free-id-set?]{
|
||||
Like @racket[set-intersect].}
|
||||
|
||||
@defproc[(free-id-set-intersect! [s0 mutable-free-id-set?] [s free-id-set?] ...)
|
||||
void?]{
|
||||
Like @racket[set-intersect!].}
|
||||
|
||||
@defproc[(free-id-set-subtract [s0 immutable-free-id-set?] [s free-id-set?] ...)
|
||||
immutable-free-id-set?]{
|
||||
Like @racket[set-subtract].}
|
||||
|
||||
@defproc[(free-id-set-subtract! [s0 mutable-free-id-set?] [s free-id-set?] ...)
|
||||
void?]{
|
||||
Like @racket[set-subtract!].}
|
||||
|
||||
@defproc[(free-id-set-symmetric-difference
|
||||
[s0 immutable-free-id-set?] [s free-id-set?] ...)
|
||||
immutable-free-id-set?]{
|
||||
Like @racket[set-symmetric-difference].}
|
||||
|
||||
@defproc[(free-id-set-symmetric-difference!
|
||||
[s0 mutable-free-id-set?] [s free-id-set?] ...) void?]{
|
||||
Like @racket[set-symmetric-difference!].}
|
||||
|
||||
@defproc[(free-id-subset? [s1 free-id-set?] [s2 free-id-set?]) boolean?]{
|
||||
Like @racket[subset?].}
|
||||
|
||||
@defproc[(free-id-proper-subset? [s1 free-id-set?] [s2 free-id-set?]) boolean?]{
|
||||
Like @racket[proper-subset?].}
|
||||
|
||||
@defproc[(free-id-set-map [s free-id-set?] [f (-> identifier? any/c)]) list?]{
|
||||
Like @racket[set-map].}
|
||||
|
||||
@defproc[(free-id-set-for-each [s free-id-set?] [f (-> identifier? any/c)]) void?]{
|
||||
Like @racket[set-for-each].}
|
||||
|
||||
|
||||
|
||||
@defproc[(id-set/c
|
||||
[elem-ctc flat-contract?]
|
||||
[#:setidtype idsettype
|
||||
(or/c 'dont-care 'free 'bound) 'dont-care]
|
||||
[#:mutability mutability
|
||||
(or/c 'dont-care 'mutable 'immutable) 'immutable])
|
||||
contract?]{
|
||||
Creates a contract for identifier sets. If
|
||||
@racket[mutability] is @racket['immutable], the contract accepts only
|
||||
immutable identifier sets; if @racket[mutability] is @racket['mutable],
|
||||
the contract accepts only mutable identifier sets.
|
||||
}
|
||||
|
||||
@defproc[(free-id-set/c
|
||||
[elem-ctc flat-contract?]
|
||||
[#:mutability mutability
|
||||
(or/c 'dont-care 'mutable 'immutable) 'immutable])
|
||||
contract?]{
|
||||
Creates a contract for free-identifier sets. If
|
||||
@racket[mutability] is @racket['immutable], the contract accepts only
|
||||
immutable identifier sets; if @racket[mutability] is @racket['mutable],
|
||||
the contract accepts only mutable identifier sets.
|
||||
}
|
||||
|
||||
@;{----------}
|
||||
@section{Sets for @racket[bound-identifier=?]}
|
||||
|
||||
A bound-identifier set is a set whose keys are compared using
|
||||
@racket[bound-identifier=?]. Bound-identifier sets implement the
|
||||
@racket[gen:set] interface, so all of the
|
||||
appropriate generic functions (e.g., @racket[set-add], @racket[set-map],
|
||||
etc.) can be used on bound-identifier sets.
|
||||
|
||||
@deftogether[[
|
||||
@defproc[(mutable-bound-id-set
|
||||
[init-set set? null]
|
||||
[#:phase phase (or/c exact-integer? #f) (syntax-local-phase-level)])
|
||||
mutable-bound-id-set?]
|
||||
@defproc[(immutable-bound-id-set
|
||||
[init-set set? null]
|
||||
[#:phase phase (or/c exact-integer? #f) (syntax-local-phase-level)])
|
||||
immutable-bound-id-set?]
|
||||
@defproc[(bound-id-set? [v any/c]) boolean?]
|
||||
@defproc[(mutable-bound-id-set? [v any/c]) boolean?]
|
||||
@defproc[(immutable-bound-id-set? [v any/c]) boolean?]
|
||||
@defproc[(bound-id-set-empty? [s bound-id-set?]) boolean?]
|
||||
@defproc[(bound-id-set-count [s bound-id-set?]) exact-nonnegative-integer?]
|
||||
@defproc[(bound-id-set-member? [s bound-id-set?] [v identifier?]) boolean?]
|
||||
@defproc[(bound-id-set=? [s1 bound-id-set?] [s2 bound-id-set?]) boolean?]
|
||||
@defproc[(bound-id-set-add [s immutable-bound-id-set?] [v identifier?])
|
||||
immutable-bound-id-set?]
|
||||
@defproc[(bound-id-set-add! [s mutable-bound-id-set?] [v identifier?]) void?]
|
||||
@defproc[(bound-id-set-remove [s immutable-bound-id-set?] [v identifier?])
|
||||
immutable-bound-id-set?]
|
||||
@defproc[(bound-id-set-remove! [s mutable-bound-id-set?] [v identifier?]) void?]
|
||||
@defproc[(bound-id-set-first [s bound-id-set?]) identifier?]
|
||||
@defproc[(bound-id-set-rest [s immutable-bound-id-set?]) immutable-bound-id-set?]
|
||||
@defproc[(in-bound-id-set [s bound-id-set?]) sequence?]
|
||||
@defproc[(bound-id-set->stream [s bound-id-set?]) stream?]
|
||||
@defproc[(bound-id-set->list [s bound-id-set?]) list?]
|
||||
@defproc[(bound-id-set-copy [s bound-id-set?]) bound-id-set?]
|
||||
@defproc[(bound-id-set-copy-clear [s bound-id-set?]) bound-id-set?]
|
||||
@defproc[(bound-id-set-clear [s immutable-bound-id-set?])
|
||||
immutable-bound-id-set?]
|
||||
@defproc[(bound-id-set-clear! [s mutable-bound-id-set?]) void?]
|
||||
@defproc[(bound-id-set-union [s0 immutable-bound-id-set?] [s bound-id-set?] ...)
|
||||
immutable-bound-id-set?]
|
||||
@defproc[(bound-id-set-union! [s0 mutable-bound-id-set?] [s bound-id-set?] ...)
|
||||
void?]
|
||||
@defproc[(bound-id-set-intersect
|
||||
[s0 immutable-bound-id-set?] [s bound-id-set?] ...)
|
||||
immutable-bound-id-set?]
|
||||
@defproc[(bound-id-set-intersect!
|
||||
[s0 mutable-bound-id-set?] [s bound-id-set?] ...) void?]
|
||||
@defproc[(bound-id-set-subtract
|
||||
[s0 immutable-bound-id-set?] [s bound-id-set?] ...)
|
||||
immutable-bound-id-set?]
|
||||
@defproc[(bound-id-set-subtract!
|
||||
[s0 mutable-bound-id-set?] [s bound-id-set?] ...) void?]
|
||||
@defproc[(bound-id-set-symmetric-difference
|
||||
[s0 immutable-bound-id-set?] [s bound-id-set?] ...)
|
||||
immutable-bound-id-set?]
|
||||
@defproc[(bound-id-set-symmetric-difference!
|
||||
[s0 mutable-bound-id-set?] [s bound-id-set?] ...) void?]
|
||||
@defproc[(bound-id-subset? [s1 bound-id-set?] [s2 bound-id-set?]) boolean?]
|
||||
@defproc[(bound-id-proper-subset? [s1 bound-id-set?] [s2 bound-id-set?])
|
||||
boolean?]
|
||||
@defproc[(bound-id-set-map [s bound-id-set?]) list?]
|
||||
@defproc[(bound-id-set-for-each [s bound-id-set?]) void?]
|
||||
@defproc[(bound-id-set/c
|
||||
[elem-ctc flat-contract?]
|
||||
[#:mutability mutability
|
||||
(or/c 'dont-care 'mutable 'immutable) 'immutable])
|
||||
contract?]]]{
|
||||
Like the procedures for free-identifier sets
|
||||
(e.g., @racket[immutable-free-id-set], @racket[free-id-set-add], etc.), but
|
||||
for bound-identifier sets, which use @racket[bound-identifier=?] to
|
||||
compare keys.
|
||||
}
|
||||
|
|
@ -6,6 +6,7 @@
|
|||
@include-section["stx.scrbl"]
|
||||
@include-section["kerncase.scrbl"]
|
||||
@include-section["id-table.scrbl"]
|
||||
@include-section["id-set.scrbl"]
|
||||
@include-section["boundmap.scrbl"]
|
||||
@include-section["to-string.scrbl"]
|
||||
@include-section["free-vars.scrbl"]
|
||||
|
|
|
|||
696
pkgs/racket-test-core/tests/racket/id-set-test.rktl
Normal file
696
pkgs/racket-test-core/tests/racket/id-set-test.rktl
Normal file
|
|
@ -0,0 +1,696 @@
|
|||
(load-relative "loadtest.rktl")
|
||||
|
||||
(require (for-syntax syntax/parse racket/syntax syntax/stx)
|
||||
syntax/id-set
|
||||
(prefix-in gen:set- racket/set))
|
||||
|
||||
(Section 'id-set)
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-rule (mk-set-op-ids #:prefix prefix-str #:names x ...)
|
||||
(list (format-id #'x (string-append prefix-str "~a") #'x) ...)))
|
||||
;; set ops whose names have the "set-" prefix
|
||||
(define-for-syntax PREFIXED-SET-OPS
|
||||
(mk-set-op-ids
|
||||
#:prefix "set-"
|
||||
#:names
|
||||
empty? member? count map for-each copy copy-clear >list >stream first
|
||||
rest add remove clear union intersect subtract symmetric-difference
|
||||
add! remove! clear! union! intersect! subtract! symmetric-difference!))
|
||||
;; set ops whose names don't follow the "set-" prefix
|
||||
(define-for-syntax OTHER-SET-OPS
|
||||
(mk-set-op-ids #:prefix "" #:names set=? subset? proper-subset?))
|
||||
|
||||
;; usage: (define-id-set-tests #:type type
|
||||
;; #:interface intfc)
|
||||
;; where:
|
||||
;; type: the type of id-set, eg free or bound
|
||||
;; intfc: prefix to attach to set functions (eg gen:set or free-id or bound-id)
|
||||
(define-syntax (define-id-set-tests stx)
|
||||
(syntax-parse stx
|
||||
[(_ #:type type #:interface intfc)
|
||||
#:with mk-immutable-id-set (format-id #'type "immutable-~a-id-set" #'type)
|
||||
#:with mk-mutable-id-set (format-id #'type "mutable-~a-id-set" #'type)
|
||||
#:with generic-id-set? (format-id #'type "~a-id-set?" #'type)
|
||||
#:with immutable-id-set? (format-id #'type "immutable-~a" #'generic-id-set?)
|
||||
#:with mutable-id-set? (format-id #'type "mutable-~a" #'generic-id-set?)
|
||||
#:with identifier=? (format-id #'type "~a-identifier=?" #'type)
|
||||
#:with id-set=? (format-id #'type "~a-id-set=?" #'type)
|
||||
#:with id-set-empty? (format-id #'type "~a-id-set-empty?" #'type)
|
||||
;; ops that are parameterized in the tests use upcase convention
|
||||
;; handle in-set specially
|
||||
#:with IN-SET (if (free-identifier=? #'gen:set #'intfc)
|
||||
#'gen:set-in-set
|
||||
(format-id #'intfc "in-~a-set" #'intfc))
|
||||
#:with set-ops (append PREFIXED-SET-OPS OTHER-SET-OPS)
|
||||
#:with set-op-names (stx-map
|
||||
(compose
|
||||
(λ (symb) (datum->syntax #'here symb))
|
||||
string->symbol
|
||||
string-upcase
|
||||
symbol->string
|
||||
syntax->datum)
|
||||
#'set-ops)
|
||||
#:with (set-op-fn-name ...)
|
||||
(stx-map (λ (f) (format-id f "~a-~a" #'intfc f)) #'set-ops)
|
||||
#'(let-values ([set-op-names (values set-op-fn-name ...)]) ;; define set fn names
|
||||
;; -------------------------------------------------------------------
|
||||
;; mutable/immutable combination Tests
|
||||
|
||||
;; defines tests for different combinations of compatible set types
|
||||
;; (eg mutable and immutable id sets), using #:constructor as the
|
||||
;; "base" set type (ie the first argument to the set fns)
|
||||
;; - this macro must be locally defined to capture appropriate set fn names
|
||||
(define-syntax (define-id-set-combo-tests stx)
|
||||
(syntax-parse stx
|
||||
[(_ #:constructor mk-id-set)
|
||||
#:with id-set? (format-id #'mk-id-set "~a?" #'mk-id-set)
|
||||
#'(begin
|
||||
(define EMPTY (mk-id-set))
|
||||
(define ABC (mk-id-set (list #'a #'b #'c)))
|
||||
(define ABCD (mk-id-set (list #'a #'b #'c #'d)))
|
||||
|
||||
(test #t generic-id-set? EMPTY)
|
||||
(test #t generic-id-set? ABC)
|
||||
(test #t generic-id-set? ABCD)
|
||||
(test #t id-set? EMPTY)
|
||||
(test #t id-set? ABC)
|
||||
(test #t id-set? ABCD)
|
||||
|
||||
(test #t SET-EMPTY? EMPTY)
|
||||
(test #f SET-EMPTY? ABC)
|
||||
(test #f SET-EMPTY? ABCD)
|
||||
|
||||
(test 0 SET-COUNT EMPTY)
|
||||
(test 3 SET-COUNT ABC)
|
||||
(test 4 SET-COUNT ABCD)
|
||||
|
||||
(test #t SET-MEMBER? ABC #'a)
|
||||
(test #t SET-MEMBER? ABC #'b)
|
||||
(test #t SET-MEMBER? ABC #'c)
|
||||
(test #f SET-MEMBER? ABC #'d)
|
||||
(test #t SET-MEMBER? ABCD #'a)
|
||||
(test #t SET-MEMBER? ABCD #'b)
|
||||
(test #t SET-MEMBER? ABCD #'c)
|
||||
(test #t SET-MEMBER? ABCD #'d)
|
||||
(test #t SET-MEMBER? (mk-id-set (list #'x)) #'x)
|
||||
(test #f SET-MEMBER? (let ([x 1]) (mk-id-set (list #'x))) #'x)
|
||||
(test #f SET-MEMBER? (let ([x 1]) (mk-id-set (list #'x)))
|
||||
(let ([x 1]) #'x))
|
||||
|
||||
;; explicit in-*-id-set sequence iterator
|
||||
(test #t SET=? (mk-id-set (SET->LIST ABC))
|
||||
(mk-id-set (for/list ([v (IN-SET ABC)]) v)))
|
||||
(test #t SET=? (mk-id-set (SET->LIST ABCD))
|
||||
(let ([seq (IN-SET ABCD)])
|
||||
(mk-id-set (for/list ([v seq]) v))))
|
||||
(test #t sequence? (IN-SET ABCD))
|
||||
(test #f stream? (IN-SET ABCD))
|
||||
(test #t stream? (SET->STREAM ABCD))
|
||||
(test #t sequence? (SET->STREAM ABCD))
|
||||
(test #t SET=?
|
||||
(mk-id-set (SET->LIST ABCD))
|
||||
(let ([seq (SET->STREAM ABCD)])
|
||||
(mk-id-set (for/list ([v seq]) v))))
|
||||
(test #t values
|
||||
(let ([noset #t])
|
||||
(for ([v (IN-SET (mk-id-set))]) (set! noset #f))
|
||||
noset))
|
||||
|
||||
;; id-set used as implicit sequence
|
||||
(test #t SET=?
|
||||
(mk-id-set (SET->LIST ABC))
|
||||
(mk-id-set (for/list ([v ABC]) v)))
|
||||
(test #t SET=?
|
||||
(mk-id-set (SET->LIST ABCD))
|
||||
(let ([seq ABCD]) (mk-id-set (for/list ([v seq]) v))))
|
||||
(test #t sequence? ABCD)
|
||||
(test #t values (let ([noset #t])
|
||||
(for ([v (mk-id-set)]) (set! noset #f))
|
||||
noset))
|
||||
|
||||
(test #t SET=? ABCD (SET-COPY ABCD))
|
||||
(test #t eq? ABCD ABCD)
|
||||
(test #f eq? ABCD (SET-COPY ABCD))
|
||||
(test #t id-set-empty? (SET-COPY-CLEAR ABCD))
|
||||
(test #f eq? EMPTY (SET-COPY-CLEAR ABCD))
|
||||
(test #t id-set? (SET-COPY ABCD))
|
||||
(test #t id-set? (SET-COPY-CLEAR ABCD))
|
||||
|
||||
;; test gen:equal+hash
|
||||
(test #t equal?
|
||||
(mk-id-set (SET->LIST ABC))
|
||||
(mk-id-set (for/list ([v ABC]) v)))
|
||||
(test #t equal?
|
||||
(mk-id-set (SET->LIST ABCD))
|
||||
(let ([seq ABCD]) (mk-id-set (for/list ([v seq]) v))))
|
||||
(test #t equal? ABCD (SET-COPY ABCD))
|
||||
(test #t equal? (equal-hash-code ABC) (equal-hash-code ABC))
|
||||
(test #t equal?
|
||||
(equal-secondary-hash-code ABC)
|
||||
(equal-secondary-hash-code ABC))
|
||||
(test #t equal?
|
||||
(equal-hash-code (mk-id-set (SET->LIST ABC)))
|
||||
(equal-hash-code (mk-id-set (for/list ([v ABC]) v))))
|
||||
(test #t equal?
|
||||
(equal-hash-code (mk-id-set (SET->LIST ABCD)))
|
||||
(equal-hash-code
|
||||
(let ([seq ABCD]) (mk-id-set (for/list ([v seq]) v)))))
|
||||
(test #t equal?
|
||||
(equal-hash-code ABCD)
|
||||
(equal-hash-code (SET-COPY ABCD)))
|
||||
(test #t equal?
|
||||
(equal-secondary-hash-code (mk-id-set (SET->LIST ABC)))
|
||||
(equal-secondary-hash-code
|
||||
(mk-id-set (for/list ([v ABC]) v))))
|
||||
(test #t equal?
|
||||
(equal-secondary-hash-code(mk-id-set (SET->LIST ABCD)))
|
||||
(equal-secondary-hash-code
|
||||
(let ([seq ABCD]) (mk-id-set (for/list ([v seq]) v)))))
|
||||
(test #t equal?
|
||||
(equal-secondary-hash-code ABCD)
|
||||
(equal-secondary-hash-code (SET-COPY ABCD)))
|
||||
|
||||
;; set union
|
||||
(let ()
|
||||
(define EMPTY/MUTABLE (mk-mutable-id-set null))
|
||||
(define EMPTY/IMMUTABLE (mk-immutable-id-set null))
|
||||
(define ABC-LIST (list #'a #'b #'c))
|
||||
(define ABC/MUTABLE (mk-mutable-id-set ABC-LIST))
|
||||
(define ABC/IMMUTABLE (mk-immutable-id-set ABC-LIST))
|
||||
(test 3 SET-COUNT (SET-UNION ABC/IMMUTABLE))
|
||||
(test #t SET-EMPTY? (SET-UNION EMPTY/IMMUTABLE))
|
||||
(test 4 SET-COUNT (SET-UNION EMPTY/IMMUTABLE ABCD))
|
||||
(test 4 SET-COUNT (SET-UNION ABC/IMMUTABLE ABCD))
|
||||
(test 3 SET-COUNT (SET-UNION ABC/IMMUTABLE EMPTY))
|
||||
(define IMMUTABLE/UNION/3
|
||||
(SET-UNION ABC/IMMUTABLE
|
||||
ABCD
|
||||
(mk-id-set (list #'d #'e #'f))))
|
||||
(test 6 SET-COUNT IMMUTABLE/UNION/3)
|
||||
(test #t SET-MEMBER? IMMUTABLE/UNION/3 #'d)
|
||||
(test #t SET-MEMBER? IMMUTABLE/UNION/3 #'e)
|
||||
(test #t SET-MEMBER? IMMUTABLE/UNION/3 #'f)
|
||||
|
||||
(SET-UNION! ABC/MUTABLE)
|
||||
(test 3 SET-COUNT ABC/MUTABLE)
|
||||
(SET-UNION! EMPTY/MUTABLE)
|
||||
(test #t SET-EMPTY? EMPTY/MUTABLE)
|
||||
(SET-UNION! EMPTY/MUTABLE ABCD)
|
||||
(test 4 SET-COUNT EMPTY/MUTABLE)
|
||||
(SET-UNION! ABC/MUTABLE ABCD)
|
||||
(test 4 SET-COUNT ABC/MUTABLE)
|
||||
(SET-UNION! ABC/MUTABLE EMPTY)
|
||||
(test 4 SET-COUNT ABC/MUTABLE)
|
||||
(define MUTABLE/UNION/3 (mk-mutable-id-set (list #'a #'b #'c)))
|
||||
(SET-UNION! MUTABLE/UNION/3
|
||||
ABCD
|
||||
(mk-id-set (list #'d #'e #'f)))
|
||||
(test 6 SET-COUNT MUTABLE/UNION/3)
|
||||
(test #t SET-MEMBER? MUTABLE/UNION/3 #'d)
|
||||
(test #t SET-MEMBER? MUTABLE/UNION/3 #'e)
|
||||
(test #t SET-MEMBER? MUTABLE/UNION/3 #'f)
|
||||
(void))
|
||||
|
||||
;; set intersect
|
||||
(let ()
|
||||
(define EMPTY/MUTABLE (mk-mutable-id-set null))
|
||||
(define EMPTY/IMMUTABLE (mk-immutable-id-set null))
|
||||
(define ABC-LIST (list #'a #'b #'c))
|
||||
(define ABC/MUTABLE (mk-mutable-id-set ABC-LIST))
|
||||
(define ABC/IMMUTABLE (mk-immutable-id-set ABC-LIST))
|
||||
(test 3 SET-COUNT (SET-INTERSECT ABC/IMMUTABLE))
|
||||
(test #t SET-EMPTY? (SET-INTERSECT EMPTY/IMMUTABLE))
|
||||
(test 0 SET-COUNT (SET-INTERSECT EMPTY/IMMUTABLE ABCD))
|
||||
(test 3 SET-COUNT (SET-INTERSECT ABC/IMMUTABLE ABCD))
|
||||
(test 0 SET-COUNT (SET-INTERSECT ABC/IMMUTABLE EMPTY))
|
||||
(define IMMUTABLE/INTERSECT/3
|
||||
(SET-INTERSECT ABC/IMMUTABLE
|
||||
ABCD
|
||||
(mk-id-set (list #'b #'c))))
|
||||
(test 2 SET-COUNT IMMUTABLE/INTERSECT/3)
|
||||
(test #f SET-MEMBER? IMMUTABLE/INTERSECT/3 #'a)
|
||||
(test #t SET-MEMBER? IMMUTABLE/INTERSECT/3 #'b)
|
||||
(test #t SET-MEMBER? IMMUTABLE/INTERSECT/3 #'c)
|
||||
|
||||
(SET-INTERSECT! ABC/MUTABLE)
|
||||
(test 3 SET-COUNT ABC/MUTABLE)
|
||||
(SET-INTERSECT! EMPTY/MUTABLE)
|
||||
(test #t SET-EMPTY? EMPTY/MUTABLE)
|
||||
(SET-INTERSECT! EMPTY/MUTABLE ABCD)
|
||||
(test 0 SET-COUNT EMPTY/MUTABLE)
|
||||
(SET-INTERSECT! ABC/MUTABLE ABCD)
|
||||
(test 3 SET-COUNT ABC/MUTABLE)
|
||||
(test #t SET-MEMBER? ABC/MUTABLE #'a)
|
||||
(test #t SET-MEMBER? ABC/MUTABLE #'b)
|
||||
(test #t SET-MEMBER? ABC/MUTABLE #'c)
|
||||
(test #f SET-MEMBER? ABC/MUTABLE #'d)
|
||||
(test #t mutable-id-set? ABC/MUTABLE)
|
||||
(test #t SET-EMPTY? EMPTY)
|
||||
(SET-INTERSECT! ABC/MUTABLE EMPTY)
|
||||
(test 0 SET-COUNT ABC/MUTABLE)
|
||||
(define MUTABLE/INTERSECT/3 (mk-mutable-id-set (list #'a #'b #'c)))
|
||||
(SET-INTERSECT! MUTABLE/INTERSECT/3
|
||||
ABCD
|
||||
(mk-id-set (list #'a #'b)))
|
||||
(test 2 SET-COUNT MUTABLE/INTERSECT/3)
|
||||
(test #t SET-MEMBER? MUTABLE/INTERSECT/3 #'a)
|
||||
(test #t SET-MEMBER? MUTABLE/INTERSECT/3 #'b)
|
||||
(test #f SET-MEMBER? MUTABLE/INTERSECT/3 #'c)
|
||||
|
||||
(void))
|
||||
|
||||
;; set subtract
|
||||
(let ()
|
||||
(define EMPTY/MUTABLE (mk-mutable-id-set null))
|
||||
(define EMPTY/IMMUTABLE (mk-immutable-id-set null))
|
||||
(define ABCDE-LIST (list #'a #'b #'c #'d #'e))
|
||||
(define ABCDE/MUTABLE (mk-mutable-id-set ABCDE-LIST))
|
||||
(define ABCDE/IMMUTABLE (mk-immutable-id-set ABCDE-LIST))
|
||||
(test 5 SET-COUNT (SET-SUBTRACT ABCDE/IMMUTABLE))
|
||||
(test #t SET-EMPTY? (SET-SUBTRACT EMPTY/IMMUTABLE))
|
||||
(test 0 SET-COUNT (SET-SUBTRACT EMPTY/IMMUTABLE ABCD))
|
||||
(test 1 SET-COUNT (SET-SUBTRACT ABCDE/IMMUTABLE ABCD))
|
||||
(test 5 SET-COUNT (SET-SUBTRACT ABCDE/IMMUTABLE EMPTY))
|
||||
(define IMMUTABLE/SUBTRACT/3
|
||||
(SET-SUBTRACT ABCDE/IMMUTABLE
|
||||
ABC
|
||||
(mk-id-set (list #'a #'b #'e))))
|
||||
(test 1 SET-COUNT IMMUTABLE/SUBTRACT/3)
|
||||
(test #f SET-MEMBER? IMMUTABLE/SUBTRACT/3 #'a)
|
||||
(test #f SET-MEMBER? IMMUTABLE/SUBTRACT/3 #'b)
|
||||
(test #t SET-MEMBER? IMMUTABLE/SUBTRACT/3 #'d)
|
||||
(test #f SET-MEMBER? IMMUTABLE/SUBTRACT/3 #'e)
|
||||
|
||||
(SET-SUBTRACT! ABCDE/MUTABLE)
|
||||
(test 5 SET-COUNT ABCDE/MUTABLE)
|
||||
(SET-SUBTRACT! EMPTY/MUTABLE)
|
||||
(test #t SET-EMPTY? EMPTY/MUTABLE)
|
||||
(SET-SUBTRACT! EMPTY/MUTABLE ABCD)
|
||||
(test 0 SET-COUNT EMPTY/MUTABLE)
|
||||
(SET-SUBTRACT! ABCDE/MUTABLE ABC)
|
||||
(test 2 SET-COUNT ABCDE/MUTABLE)
|
||||
(test #f SET-MEMBER? ABCDE/MUTABLE #'a)
|
||||
(test #f SET-MEMBER? ABCDE/MUTABLE #'b)
|
||||
(test #f SET-MEMBER? ABCDE/MUTABLE #'c)
|
||||
(test #t SET-MEMBER? ABCDE/MUTABLE #'d)
|
||||
(test #t SET-MEMBER? ABCDE/MUTABLE #'e)
|
||||
(test #t mutable-id-set? ABCDE/MUTABLE)
|
||||
(test #t SET-EMPTY? EMPTY)
|
||||
(set! ABCDE/MUTABLE (mk-mutable-id-set ABCDE-LIST))
|
||||
(SET-SUBTRACT! ABCDE/MUTABLE EMPTY)
|
||||
(test 5 SET-COUNT ABCDE/MUTABLE)
|
||||
(define MUTABLE/SUBTRACT/3
|
||||
(mk-mutable-id-set (list #'a #'b #'c #'d #'e)))
|
||||
(SET-SUBTRACT! MUTABLE/SUBTRACT/3
|
||||
ABC
|
||||
(mk-id-set (list #'a #'b #'e)))
|
||||
(test 1 SET-COUNT MUTABLE/SUBTRACT/3)
|
||||
(test #f SET-MEMBER? MUTABLE/SUBTRACT/3 #'a)
|
||||
(test #f SET-MEMBER? MUTABLE/SUBTRACT/3 #'b)
|
||||
(test #t SET-MEMBER? MUTABLE/SUBTRACT/3 #'d)
|
||||
(test #f SET-MEMBER? MUTABLE/SUBTRACT/3 #'e)
|
||||
|
||||
(void))
|
||||
|
||||
;; set symmetric difference
|
||||
(let ()
|
||||
(define EMPTY/MUTABLE (mk-mutable-id-set null))
|
||||
(define EMPTY/IMMUTABLE (mk-immutable-id-set null))
|
||||
(define ABCDE-LIST (list #'a #'b #'c #'d #'e))
|
||||
(define ABCDE/MUTABLE (mk-mutable-id-set ABCDE-LIST))
|
||||
(define ABCDE/IMMUTABLE (mk-immutable-id-set ABCDE-LIST))
|
||||
|
||||
(test 5 SET-COUNT (SET-SYMMETRIC-DIFFERENCE ABCDE/IMMUTABLE))
|
||||
(test #t SET-EMPTY? (SET-SYMMETRIC-DIFFERENCE EMPTY/IMMUTABLE))
|
||||
(test 4 SET-COUNT (SET-SYMMETRIC-DIFFERENCE EMPTY/IMMUTABLE ABCD))
|
||||
(test #t SET=?
|
||||
(SET-SYMMETRIC-DIFFERENCE EMPTY/IMMUTABLE ABCD) ABCD)
|
||||
(test 1 SET-COUNT (SET-SYMMETRIC-DIFFERENCE ABCDE/IMMUTABLE ABCD))
|
||||
(test 5 SET-COUNT (SET-SYMMETRIC-DIFFERENCE ABCDE/IMMUTABLE EMPTY))
|
||||
(define IMMUTABLE/DIFFERENCE/3
|
||||
(SET-SYMMETRIC-DIFFERENCE ABCDE/IMMUTABLE
|
||||
ABC
|
||||
(mk-id-set (list #'a #'b #'e))))
|
||||
(test 3 SET-COUNT IMMUTABLE/DIFFERENCE/3)
|
||||
(test #t SET-MEMBER? IMMUTABLE/DIFFERENCE/3 #'a)
|
||||
(test #t SET-MEMBER? IMMUTABLE/DIFFERENCE/3 #'b)
|
||||
(test #f SET-MEMBER? IMMUTABLE/DIFFERENCE/3 #'c)
|
||||
(test #t SET-MEMBER? IMMUTABLE/DIFFERENCE/3 #'d)
|
||||
(test #f SET-MEMBER? IMMUTABLE/DIFFERENCE/3 #'e)
|
||||
|
||||
(SET-SYMMETRIC-DIFFERENCE! ABCDE/MUTABLE)
|
||||
(test 5 SET-COUNT ABCDE/MUTABLE)
|
||||
(SET-SYMMETRIC-DIFFERENCE! EMPTY/MUTABLE)
|
||||
(test #t SET-EMPTY? EMPTY/MUTABLE)
|
||||
(SET-SYMMETRIC-DIFFERENCE! EMPTY/MUTABLE ABCD)
|
||||
(test 4 SET-COUNT EMPTY/MUTABLE)
|
||||
(test #t SET=? EMPTY/MUTABLE ABCD)
|
||||
(SET-SYMMETRIC-DIFFERENCE! ABCDE/MUTABLE ABC)
|
||||
(test 2 SET-COUNT ABCDE/MUTABLE)
|
||||
(test #f SET-MEMBER? ABCDE/MUTABLE #'a)
|
||||
(test #f SET-MEMBER? ABCDE/MUTABLE #'b)
|
||||
(test #f SET-MEMBER? ABCDE/MUTABLE #'c)
|
||||
(test #t SET-MEMBER? ABCDE/MUTABLE #'d)
|
||||
(test #t SET-MEMBER? ABCDE/MUTABLE #'e)
|
||||
(test #t mutable-id-set? ABCDE/MUTABLE)
|
||||
(test #t SET-EMPTY? EMPTY)
|
||||
(set! ABCDE/MUTABLE (mk-mutable-id-set ABCDE-LIST))
|
||||
(SET-SYMMETRIC-DIFFERENCE! ABCDE/MUTABLE EMPTY)
|
||||
(test 5 SET-COUNT ABCDE/MUTABLE)
|
||||
(define MUTABLE/DIFFERENCE/3 (mk-mutable-id-set (list #'a #'b #'c #'d #'e)))
|
||||
(SET-SYMMETRIC-DIFFERENCE! MUTABLE/DIFFERENCE/3
|
||||
ABC
|
||||
(mk-id-set (list #'a #'b #'e)))
|
||||
(test 3 SET-COUNT MUTABLE/DIFFERENCE/3)
|
||||
(test #t SET-MEMBER? MUTABLE/DIFFERENCE/3 #'a)
|
||||
(test #t SET-MEMBER? MUTABLE/DIFFERENCE/3 #'b)
|
||||
(test #f SET-MEMBER? MUTABLE/DIFFERENCE/3 #'c)
|
||||
(test #t SET-MEMBER? MUTABLE/DIFFERENCE/3 #'d)
|
||||
(test #f SET-MEMBER? MUTABLE/DIFFERENCE/3 #'e)
|
||||
|
||||
(void))
|
||||
|
||||
;; Test subset:
|
||||
(let ()
|
||||
(test #t SUBSET? EMPTY EMPTY)
|
||||
(test #t SUBSET? ABC ABC)
|
||||
(test #t SUBSET? ABCD ABCD)
|
||||
(test #f PROPER-SUBSET? EMPTY EMPTY)
|
||||
(test #f PROPER-SUBSET? ABC ABC)
|
||||
(test #f PROPER-SUBSET? ABCD ABCD)
|
||||
(test #t SUBSET? EMPTY ABC)
|
||||
(test #t SUBSET? EMPTY ABCD)
|
||||
(test #t SUBSET? ABC ABCD)
|
||||
(test #f SUBSET? ABCD ABC)
|
||||
(test #f SUBSET? ABCD EMPTY)
|
||||
(test #f SUBSET? ABC EMPTY)
|
||||
(test #t PROPER-SUBSET? EMPTY ABC)
|
||||
(test #t PROPER-SUBSET? EMPTY ABCD)
|
||||
(test #t PROPER-SUBSET? ABC ABCD)
|
||||
(test #f PROPER-SUBSET? ABCD ABC)
|
||||
(test #f PROPER-SUBSET? ABCD EMPTY)
|
||||
(test #f PROPER-SUBSET? ABC EMPTY)
|
||||
|
||||
(define EMPTY/MUTABLE (mk-mutable-id-set null))
|
||||
(define EMPTY/IMMUTABLE (mk-immutable-id-set null))
|
||||
(define AB-LIST (list #'a #'b))
|
||||
(define ABC-LIST (list #'a #'b #'c))
|
||||
(define ABCDE-LIST (list #'a #'b #'c #'d #'e))
|
||||
(define AB/MUTABLE (mk-mutable-id-set AB-LIST))
|
||||
(define AB/IMMUTABLE (mk-immutable-id-set AB-LIST))
|
||||
(define ABC/MUTABLE (mk-mutable-id-set ABC-LIST))
|
||||
(define ABC/IMMUTABLE (mk-immutable-id-set ABC-LIST))
|
||||
(define ABCDE/MUTABLE (mk-mutable-id-set ABCDE-LIST))
|
||||
(define ABCDE/IMMUTABLE (mk-immutable-id-set ABCDE-LIST))
|
||||
|
||||
(test #t SUBSET? EMPTY EMPTY/MUTABLE)
|
||||
(test #t SUBSET? EMPTY EMPTY/IMMUTABLE)
|
||||
(test #f PROPER-SUBSET? EMPTY EMPTY/MUTABLE)
|
||||
(test #f PROPER-SUBSET? EMPTY EMPTY/IMMUTABLE)
|
||||
|
||||
(test #t SUBSET? ABC ABCDE/MUTABLE)
|
||||
(test #t SUBSET? ABC ABCDE/MUTABLE)
|
||||
(test #t PROPER-SUBSET? ABC ABCDE/MUTABLE)
|
||||
(test #t PROPER-SUBSET? ABC ABCDE/MUTABLE)
|
||||
(test #t SUBSET? ABC ABCDE/IMMUTABLE)
|
||||
(test #t SUBSET? ABC ABCDE/IMMUTABLE)
|
||||
(test #t PROPER-SUBSET? ABC ABCDE/IMMUTABLE)
|
||||
(test #t PROPER-SUBSET? ABC ABCDE/IMMUTABLE)
|
||||
|
||||
(test #t SUBSET? ABC ABC/MUTABLE)
|
||||
(test #t SUBSET? ABC ABC/MUTABLE)
|
||||
(test #f PROPER-SUBSET? ABC ABC/MUTABLE)
|
||||
(test #f PROPER-SUBSET? ABC ABC/MUTABLE)
|
||||
(test #t SUBSET? ABC ABC/IMMUTABLE)
|
||||
(test #t SUBSET? ABC ABC/IMMUTABLE)
|
||||
(test #f PROPER-SUBSET? ABC ABC/IMMUTABLE)
|
||||
(test #f PROPER-SUBSET? ABC ABC/IMMUTABLE)
|
||||
|
||||
(test #f SUBSET? ABC AB/MUTABLE)
|
||||
(test #f SUBSET? ABC AB/MUTABLE)
|
||||
(test #f PROPER-SUBSET? ABC AB/MUTABLE)
|
||||
(test #f PROPER-SUBSET? ABC AB/MUTABLE)
|
||||
(test #f SUBSET? ABC AB/IMMUTABLE)
|
||||
(test #f SUBSET? ABC AB/IMMUTABLE)
|
||||
(test #f PROPER-SUBSET? ABC AB/IMMUTABLE)
|
||||
(test #f PROPER-SUBSET? ABC AB/IMMUTABLE)
|
||||
|
||||
(void))
|
||||
|
||||
;; id-set and id-set-for-each
|
||||
(test #t null? (SET-MAP EMPTY (λ (x) x)))
|
||||
(test #t SET=? ABC (mk-id-set (SET-MAP ABC (λ (x) x))))
|
||||
(test #t SET=? ABCD (mk-id-set (SET-MAP ABCD (λ (x) x))))
|
||||
(test #t SET=?
|
||||
ABC
|
||||
(mk-id-set
|
||||
;; drop #'d
|
||||
(SET-MAP ABCD (λ (id) (if (identifier=? #'d id) #'a id)))))
|
||||
(let ([new-set (mk-mutable-id-set null)])
|
||||
(SET-FOR-EACH ABC (λ (id) (SET-ADD! new-set id)))
|
||||
(test #t SET=? ABC new-set))
|
||||
(let ([new-set (mk-immutable-id-set null)])
|
||||
(SET-FOR-EACH
|
||||
ABCD
|
||||
(λ (id) (set! new-set (SET-ADD new-set id))))
|
||||
(test #t SET=? ABCD new-set)))]))
|
||||
|
||||
;; invoke macro to define immutable-mutable combo tests
|
||||
(define-id-set-combo-tests #:constructor mk-immutable-id-set)
|
||||
(define-id-set-combo-tests #:constructor mk-mutable-id-set)
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; immutable-only/mutable-only id set tests
|
||||
(define EMPTY/MUTABLE (mk-mutable-id-set))
|
||||
(define NONEMPTY/MUTABLE (mk-mutable-id-set (list #'a #'b #'c)))
|
||||
(define EMPTY/IMMUTABLE (mk-immutable-id-set))
|
||||
(define NONEMPTY/IMMUTABLE (mk-immutable-id-set (list #'a #'b #'c)))
|
||||
|
||||
(test #t mutable-id-set? EMPTY/MUTABLE)
|
||||
(test #f mutable-id-set? EMPTY/IMMUTABLE)
|
||||
(test #t mutable-id-set? NONEMPTY/MUTABLE)
|
||||
(test #f mutable-id-set? NONEMPTY/IMMUTABLE)
|
||||
(test #f immutable-id-set? EMPTY/MUTABLE)
|
||||
(test #t immutable-id-set? EMPTY/IMMUTABLE)
|
||||
(test #f immutable-id-set? NONEMPTY/MUTABLE)
|
||||
(test #t immutable-id-set? NONEMPTY/IMMUTABLE)
|
||||
|
||||
(test #t SET=? EMPTY/MUTABLE EMPTY/IMMUTABLE)
|
||||
(test #t SET=? NONEMPTY/MUTABLE NONEMPTY/IMMUTABLE)
|
||||
(test #f SET=? EMPTY/MUTABLE NONEMPTY/MUTABLE)
|
||||
(test #f SET=? EMPTY/IMMUTABLE NONEMPTY/IMMUTABLE)
|
||||
(test #f SET=? EMPTY/MUTABLE NONEMPTY/IMMUTABLE)
|
||||
|
||||
;; -------------------------------------------------------------------
|
||||
;; immutable-only id set tests
|
||||
|
||||
(let ([s (mk-immutable-id-set (list #'a #'b #'c))])
|
||||
;; fns not implemented for immutable id sets
|
||||
(err/rt-test (SET-ADD! s #'z) exn:fail?)
|
||||
(err/rt-test (SET-REMOVE! s #'z) exn:fail?)
|
||||
(err/rt-test (SET-CLEAR! s) exn:fail?)
|
||||
(err/rt-test (SET-UNION! s) exn:fail?)
|
||||
(err/rt-test (SET-INTERSECTION! s) exn:fail?)
|
||||
(err/rt-test (SET-SUBTRACT! s) exn:fail?)
|
||||
(err/rt-test (SET-SYMMETRIC-DIFFERENCE! s) exn:fail?)
|
||||
|
||||
(test #t SET=?
|
||||
s
|
||||
(SET-ADD
|
||||
(SET-ADD
|
||||
(SET-ADD (mk-immutable-id-set) #'b) #'a) #'c))
|
||||
(test #f SET=?
|
||||
s
|
||||
(let ([a 1])
|
||||
(SET-ADD
|
||||
(SET-ADD
|
||||
(SET-ADD (mk-immutable-id-set) #'b) #'a) #'c)))
|
||||
|
||||
(test #t SET-MEMBER? (SET-ADD s #'d) #'c)
|
||||
(test #t SET-MEMBER? (SET-ADD s #'d) #'d)
|
||||
(test #f SET-MEMBER? (SET-ADD s #'d) #'e)
|
||||
(test #f SET-MEMBER? (SET-ADD s (let ([d 1]) #'d)) #'d)
|
||||
(test #f SET-MEMBER? (SET-ADD s #'d) (let ([d 1]) #'d))
|
||||
|
||||
(test #t SET-MEMBER? (SET-REMOVE s #'a) #'b)
|
||||
(test #f SET-MEMBER? (SET-REMOVE s #'b) #'b)
|
||||
(test #t SET-MEMBER? (SET-REMOVE s (let ([c 1]) #'c)) #'c)
|
||||
|
||||
(test #t identifier=? (SET-FIRST s) (SET-FIRST s))
|
||||
(test #t SET=? (SET-REMOVE s (SET-FIRST s))
|
||||
(SET-REST s))
|
||||
|
||||
;; tests for gen:stream interface
|
||||
(test #t stream? s)
|
||||
(test #t free-identifier=? (stream-first s) (stream-first s))
|
||||
(test #t SET=? (SET-REMOVE s (stream-first s))
|
||||
(stream-rest s))
|
||||
(test #t stream-empty? EMPTY/IMMUTABLE)
|
||||
(test #f stream-empty? NONEMPTY/IMMUTABLE)
|
||||
|
||||
(void))
|
||||
|
||||
;; -------------------------------------------------------------------
|
||||
;; mutable-only id set tests
|
||||
|
||||
(let ([ms1 (mk-mutable-id-set (list #'a #'b #'c))]
|
||||
[ms2 (mk-mutable-id-set)])
|
||||
;; fns not implemented for mutable id sets
|
||||
(err/rt-test (SET-ADD ms1 #'z) exn:fail?)
|
||||
(err/rt-test (SET-REMOVE ms1 #'z) exn:fail?)
|
||||
(err/rt-test (SET-REST ms1) exn:fail?)
|
||||
(err/rt-test (SET-CLEAR ms1) exn:fail?)
|
||||
(err/rt-test (SET-UNION ms1) exn:fail?)
|
||||
(err/rt-test (SET-INTERSECTION ms1) exn:fail?)
|
||||
(err/rt-test (SET-SUBTRACT ms1) exn:fail?)
|
||||
(err/rt-test (SET-SYMMETRIC-DIFFERENCE ms1) exn:fail?)
|
||||
|
||||
;; mutable sets are not streams
|
||||
(test #f stream? ms1)
|
||||
(err/rt-test (stream-empty? ms1) exn:fail?)
|
||||
(err/rt-test (stream-first ms1) exn:fail?)
|
||||
(err/rt-test (stream-rest ms1) exn:fail?)
|
||||
|
||||
(SET-ADD! ms2 #'b)
|
||||
(SET-ADD! ms2 #'a)
|
||||
(SET-ADD! ms2 #'c)
|
||||
(test #t SET=? ms1 ms2)
|
||||
(define ms3 (mk-mutable-id-set))
|
||||
(let ([a 1])
|
||||
(SET-ADD! ms3 #'b)
|
||||
(SET-ADD! ms3 #'a)
|
||||
(SET-ADD! ms3 #'c))
|
||||
(test #f SET=? ms1 ms3)
|
||||
|
||||
(define ms4 (mk-mutable-id-set (list #'a #'b #'c)))
|
||||
(test #t SET-MEMBER? ms4 #'c)
|
||||
(SET-ADD! ms4 #'d)
|
||||
(test #t SET-MEMBER? ms4 #'c)
|
||||
(test #t SET-MEMBER? ms4 #'d)
|
||||
(SET-ADD! ms4 #'d)
|
||||
(test #t SET-MEMBER? ms4 #'d)
|
||||
(test #f SET-MEMBER? ms4 #'e)
|
||||
(SET-ADD! ms4 (let ([e 1]) #'e))
|
||||
(test #f SET-MEMBER? ms4 #'e)
|
||||
(test #f SET-MEMBER? ms4 (let ([d 1]) #'d))
|
||||
|
||||
(SET-REMOVE! ms4 #'a)
|
||||
(test #t SET-MEMBER? ms4 #'b)
|
||||
(SET-REMOVE! ms4 #'b)
|
||||
(test #f SET-MEMBER? ms4 #'b)
|
||||
(SET-REMOVE! ms4 (let ([c 1]) #'c))
|
||||
(test #t SET-MEMBER? ms4 #'c)
|
||||
|
||||
(test #t free-identifier=? (SET-FIRST ms1) (SET-FIRST ms1))
|
||||
(SET-REMOVE! ms1 #'a)
|
||||
(test #t SET=? ms1 (mk-mutable-id-set (list #'b #'c)))
|
||||
|
||||
(SET-CLEAR! ms1)
|
||||
(test #t SET-EMPTY? ms1)
|
||||
|
||||
(void))
|
||||
|
||||
)]))
|
||||
|
||||
;; contract tests -------------------------------------------------------------
|
||||
(test #t contract? (id-set/c identifier?))
|
||||
(test #t contract? (id-set/c identifier? #:idsettype 'free))
|
||||
(test #t contract? (id-set/c identifier? #:idsettype 'bound
|
||||
#:mutability 'mutable))
|
||||
(test #t contract? (free-id-set/c (λ (id) (free-identifier=? #'a id))))
|
||||
(test #t contract? (free-id-set/c (λ (id) (free-identifier=? #'a id))
|
||||
#:mutability 'immutable))
|
||||
(test #t contract? (bound-id-set/c (λ (id) (bound-identifier=? #'b id))))
|
||||
(test #t contract? (bound-id-set/c (λ (id) (bound-identifier=? #'b id))
|
||||
#:mutability 'mutable))
|
||||
|
||||
(test #t chaperone-contract? (id-set/c identifier?))
|
||||
(test #f impersonator-contract? (id-set/c identifier?))
|
||||
(test #t flat-contract? (id-set/c identifier?))
|
||||
(test #f flat-contract? (free-id-set/c identifier? #:mutability 'mutable))
|
||||
(test #t flat-contract? (bound-id-set/c identifier? #:mutability 'immutable))
|
||||
|
||||
(let ()
|
||||
|
||||
;; - these contract testing util fns are copied from id-table-test
|
||||
;; TODO: move them into a separate file
|
||||
(define (app-ctc ctc value)
|
||||
(contract ctc value 'positive 'negative))
|
||||
|
||||
(define (positive-error? exn)
|
||||
(and exn:fail:contract?
|
||||
(regexp-match? "blaming: positive" (exn-message exn))))
|
||||
(define (negative-error? exn)
|
||||
(and exn:fail:contract?
|
||||
(regexp-match? "blaming: negative" (exn-message exn))))
|
||||
|
||||
(define-syntax-rule (test/blame-pos e)
|
||||
(thunk-error-test (lambda () e) #'e positive-error?))
|
||||
(define-syntax-rule (test/blame-neg e)
|
||||
(thunk-error-test (lambda () e) #'e negative-error?))
|
||||
|
||||
(define EMPTY/FREE/MUTABLE (mutable-free-id-set null))
|
||||
(define EMPTY/BOUND/MUTABLE (mutable-bound-id-set null))
|
||||
(define EMPTY/BOUND/IMMUTABLE (immutable-bound-id-set null))
|
||||
(test/blame-pos
|
||||
(app-ctc (id-set/c identifier? #:idsettype 'bound #:mutability 'mutable)
|
||||
EMPTY/FREE/MUTABLE))
|
||||
(test/blame-pos (app-ctc (id-set/c identifier? #:idsettype 'free)
|
||||
EMPTY/FREE/MUTABLE)) ; default is immutable
|
||||
(test/blame-pos (app-ctc (id-set/c any/c #:mutability 'immutable)
|
||||
EMPTY/FREE/MUTABLE))
|
||||
(test/blame-pos (app-ctc (free-id-set/c any/c #:mutability 'immutable)
|
||||
EMPTY/FREE/MUTABLE))
|
||||
(test/blame-pos (app-ctc (bound-id-set/c any/c #:mutability 'mutable)
|
||||
EMPTY/FREE/MUTABLE))
|
||||
(test/blame-pos (app-ctc (bound-id-set/c any/c)
|
||||
EMPTY/BOUND/MUTABLE)) ; default is immutable
|
||||
(test/blame-pos (app-ctc (id-set/c identifier? #:idsettype 'free)
|
||||
EMPTY/BOUND/IMMUTABLE))
|
||||
(test/blame-pos (app-ctc (id-set/c any/c #:mutability 'mutable)
|
||||
EMPTY/BOUND/IMMUTABLE))
|
||||
(test/blame-pos (app-ctc (bound-id-set/c any/c #:mutability 'mutable)
|
||||
EMPTY/BOUND/IMMUTABLE))
|
||||
(test/blame-pos (app-ctc (free-id-set/c any/c) EMPTY/BOUND/IMMUTABLE))
|
||||
|
||||
(define (not-free-a? id) (not (free-identifier=? id #'a)))
|
||||
(define (not-bound-b? id) (not (bound-identifier=? id #'b)))
|
||||
(define ABC/FREE (immutable-free-id-set (list #'a #'b #'c)))
|
||||
(define ABC/BOUND (immutable-bound-id-set (list #'a #'b #'c)))
|
||||
(test/blame-pos (app-ctc (free-id-set/c not-free-a?) ABC/FREE))
|
||||
(test/blame-pos (app-ctc (bound-id-set/c not-bound-b?) ABC/BOUND))
|
||||
(define EMPTY/BOUND/CTC
|
||||
(app-ctc (bound-id-set/c not-bound-b? #:mutability 'mutable)
|
||||
(mutable-bound-id-set null)))
|
||||
(define EMPTY/FREE/CTC
|
||||
(app-ctc (free-id-set/c not-free-a? #:mutability 'mutable)
|
||||
(mutable-free-id-set null)))
|
||||
(bound-id-set-add! EMPTY/BOUND/CTC #'a)
|
||||
(free-id-set-add! EMPTY/FREE/CTC #'b)
|
||||
(test/blame-neg (bound-id-set-add! EMPTY/BOUND/CTC #'b))
|
||||
(test/blame-neg (free-id-set-add! EMPTY/FREE/CTC #'a))
|
||||
(test/blame-neg (bound-id-set-union! EMPTY/BOUND/CTC (mutable-bound-id-set (list #'b))))
|
||||
(test/blame-neg (bound-id-set-union! EMPTY/BOUND/CTC (immutable-bound-id-set (list #'b))))
|
||||
(test/blame-neg (free-id-set-union! EMPTY/FREE/CTC (mutable-free-id-set (list #'a))))
|
||||
(test/blame-neg (free-id-set-union! EMPTY/FREE/CTC (immutable-free-id-set (list #'a))))
|
||||
(test/blame-neg (bound-id-set-symmetric-difference!
|
||||
EMPTY/BOUND/CTC (mutable-bound-id-set (list #'b))))
|
||||
(test/blame-neg (bound-id-set-symmetric-difference!
|
||||
EMPTY/BOUND/CTC (immutable-bound-id-set (list #'b))))
|
||||
(test/blame-neg (free-id-set-symmetric-difference!
|
||||
EMPTY/FREE/CTC (mutable-free-id-set (list #'a))))
|
||||
(test/blame-neg (free-id-set-symmetric-difference!
|
||||
EMPTY/FREE/CTC (immutable-free-id-set (list #'a))))
|
||||
)
|
||||
|
||||
|
||||
|
||||
;; ----------------------------------------------------------------------------
|
||||
;; run test suite instances
|
||||
(define-id-set-tests #:type free #:interface gen:set)
|
||||
(define-id-set-tests #:type free #:interface free-id)
|
||||
(define-id-set-tests #:type bound #:interface gen:set)
|
||||
(define-id-set-tests #:type bound #:interface bound-id)
|
||||
|
||||
(report-errs)
|
||||
245
racket/collects/syntax/id-set.rkt
Normal file
245
racket/collects/syntax/id-set.rkt
Normal file
|
|
@ -0,0 +1,245 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base syntax/parse)
|
||||
racket/contract/base racket/contract/combinator
|
||||
racket/set racket/generic racket/stream syntax/id-table
|
||||
"private/id-set.rkt")
|
||||
|
||||
(provide id-set/c free-id-set/c bound-id-set/c)
|
||||
|
||||
(define (id-set? s)
|
||||
(or (free-id-set? s)
|
||||
(bound-id-set? s)))
|
||||
(define (mutable-id-set? s)
|
||||
(or (mutable-free-id-set? s)
|
||||
(mutable-bound-id-set? s)))
|
||||
(define (immutable-id-set? s)
|
||||
(or (immutable-free-id-set? s)
|
||||
(immutable-bound-id-set? s)))
|
||||
|
||||
;; elem/c must be flat contract
|
||||
;; use 'immutable default, to default to flat contract
|
||||
(define (free-id-set/c elem/c #:mutability [mutability 'immutable])
|
||||
(id-set/c elem/c #:idsettype 'free #:mutability mutability))
|
||||
(define (bound-id-set/c elem/c #:mutability [mutability 'immutable])
|
||||
(id-set/c elem/c #:idsettype 'bound #:mutability mutability))
|
||||
|
||||
(define (id-set/c elem/c
|
||||
#:idsettype [idsettype 'dont-care]
|
||||
#:mutability [mutability 'immutable])
|
||||
(define idsettype/c
|
||||
(case idsettype
|
||||
[(dont-care) any/c]
|
||||
[(free) free-id-set?]
|
||||
[(bound) bound-id-set?]
|
||||
[else (raise-arguments-error 'id-set/c
|
||||
"invalid #:idsettype argument"
|
||||
"#:idsettype argument" idsettype)]))
|
||||
(define mutability/c
|
||||
(case mutability
|
||||
[(dont-care) any/c]
|
||||
[(mutable) mutable-id-set?]
|
||||
[(immutable) immutable-id-set?]
|
||||
[else (raise-arguments-error 'id-set/c
|
||||
"invalid #:mutability argument"
|
||||
"#:mutability argument" mutability)]))
|
||||
(unless (flat-contract? elem/c)
|
||||
(raise-arguments-error
|
||||
'id-set/c
|
||||
"element contract must be a flat contract"
|
||||
"element contract" (contract-name elem/c)))
|
||||
(case mutability
|
||||
[(immutable) (flat-id-set-contract elem/c idsettype mutability)]
|
||||
[else (chaperone-id-set-contract elem/c idsettype mutability)]))
|
||||
|
||||
(struct id-set-contract [elem/c idsettype mutability])
|
||||
|
||||
(define (id-set-contract-name ctc)
|
||||
(define elem/c (id-set-contract-elem/c ctc))
|
||||
(define idsettype (id-set-contract-idsettype ctc))
|
||||
(define mutability (id-set-contract-mutability ctc))
|
||||
`(id-set/c ,(contract-name elem/c)
|
||||
,@(if (eq? idsettype 'dont-care)
|
||||
`[]
|
||||
`[#:idsettype (quote ,idsettype)])
|
||||
,@(if (eq? mutability 'dont-care)
|
||||
`[]
|
||||
`[#:mutability (quote ,mutability)])))
|
||||
|
||||
(define (id-set-contract-first-order ctc)
|
||||
(define idsettype (id-set-contract-idsettype ctc))
|
||||
(define mutability (id-set-contract-mutability ctc))
|
||||
(define idsettype?
|
||||
(case idsettype
|
||||
[(dont-care) (lambda (x) #t)]
|
||||
[(free) free-id-set?]
|
||||
[(bound) bound-id-set?]))
|
||||
(define mutability?
|
||||
(case mutability
|
||||
[(dont-care) (lambda (x) #t)]
|
||||
[(mutable) mutable-id-set?]
|
||||
[(immutable) immutable-id-set?]))
|
||||
(lambda (s)
|
||||
(and (id-set? s) (idsettype? s) (mutability? s))))
|
||||
|
||||
(define (id-set-contract-check idsettype mutability b s)
|
||||
(unless (id-set? s)
|
||||
(raise-blame-error b s "expected either a free or bound identifier set"))
|
||||
(case idsettype
|
||||
[(free)
|
||||
(unless (free-id-set? s)
|
||||
(raise-blame-error b s "expected a free-identifier set"))]
|
||||
[(bound)
|
||||
(unless (bound-id-set? s)
|
||||
(raise-blame-error b s "expected a bound-identifier set"))])
|
||||
(case mutability
|
||||
[(mutable)
|
||||
(unless (mutable-id-set? s)
|
||||
(raise-blame-error b s "expected a mutable id set"))]
|
||||
[(immutable)
|
||||
(unless (immutable-id-set? s)
|
||||
(raise-blame-error b s "expected an immutable id set"))]))
|
||||
|
||||
(define (flat-id-set-contract-first-order ctc)
|
||||
(define set-passes? (id-set-contract-first-order ctc))
|
||||
(define elem-passes? (contract-first-order (id-set-contract-elem/c ctc)))
|
||||
(lambda (s)
|
||||
(and (set-passes? s)
|
||||
(for/and ([e (in-set s)]) (elem-passes? e)))))
|
||||
|
||||
(define (flat-id-set-contract-projection ctc)
|
||||
(define elem/c (id-set-contract-elem/c ctc))
|
||||
(define idsettype (id-set-contract-idsettype ctc))
|
||||
(define mutability (id-set-contract-mutability ctc))
|
||||
(lambda (b)
|
||||
(define proj
|
||||
((contract-projection elem/c) (blame-add-context b "an element of")))
|
||||
(lambda (s)
|
||||
(id-set-contract-check idsettype mutability b s)
|
||||
(for ([e (in-set s)]) (proj e))
|
||||
s)))
|
||||
|
||||
(define (id-set-contract-projection ctc)
|
||||
(define elem/c (id-set-contract-elem/c ctc))
|
||||
(define idsettype (id-set-contract-idsettype ctc))
|
||||
(define mutability (id-set-contract-mutability ctc))
|
||||
(lambda (b)
|
||||
(define neg-proj
|
||||
((contract-projection elem/c) (blame-add-context b "an element of" #:swap? #t)))
|
||||
(lambda (s)
|
||||
(id-set-contract-check idsettype mutability b s)
|
||||
(cond
|
||||
[(immutable-free-id-set? s)
|
||||
(chaperone-immutable-free-id-set
|
||||
s (free-id-table/c neg-proj any/c #:immutable #t))]
|
||||
[(mutable-free-id-set? s)
|
||||
(chaperone-mutable-free-id-set
|
||||
s (free-id-table/c neg-proj any/c #:immutable #f))]
|
||||
[(immutable-bound-id-set? s)
|
||||
(chaperone-immutable-bound-id-set
|
||||
s (bound-id-table/c neg-proj any/c #:immutable #t))]
|
||||
[(mutable-bound-id-set? s)
|
||||
(chaperone-mutable-bound-id-set
|
||||
s (bound-id-table/c neg-proj any/c #:immutable #f))]))))
|
||||
|
||||
|
||||
(struct flat-id-set-contract id-set-contract []
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name id-set-contract-name
|
||||
#:first-order flat-id-set-contract-first-order
|
||||
#:projection flat-id-set-contract-projection))
|
||||
|
||||
(struct chaperone-id-set-contract id-set-contract []
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name id-set-contract-name
|
||||
#:first-order id-set-contract-first-order
|
||||
#:projection id-set-contract-projection))
|
||||
|
||||
(define-syntax (provide-contracted-id-set-fns stx)
|
||||
(syntax-parse stx
|
||||
[(_ #:type type)
|
||||
#:with id-set (fmt-id "~a-id-set" #'type)
|
||||
#:with mutable-id-set (fmt-id "mutable-~a" #'id-set)
|
||||
#:with immutable-id-set (fmt-id "immutable-~a" #'id-set)
|
||||
#:with id-set? (fmt-pred-name #'id-set)
|
||||
#:with mutable-id-set? (fmt-pred-name #'mutable-id-set)
|
||||
#:with immutable-id-set? (fmt-pred-name #'immutable-id-set)
|
||||
#:with id-set-empty? (fmt-set-id-fn-name #'type "empty?")
|
||||
#:with id-set-count (fmt-set-id-fn-name #'type "count")
|
||||
#:with id-set-member? (fmt-set-id-fn-name #'type "member?")
|
||||
#:with id-set-add (fmt-set-id-fn-name #'type "add")
|
||||
#:with id-set-add! (fmt-set-id-fn-name #'type "add!")
|
||||
#:with id-set-remove (fmt-set-id-fn-name #'type "remove")
|
||||
#:with id-set-remove! (fmt-set-id-fn-name #'type "remove!")
|
||||
#:with id-set-first (fmt-set-id-fn-name #'type "first")
|
||||
#:with id-set-rest (fmt-set-id-fn-name #'type "rest")
|
||||
#:with id-set->stream (fmt-set-id-fn-name #'type ">stream")
|
||||
#:with id-set->list (fmt-set-id-fn-name #'type ">list")
|
||||
#:with id-set-copy (fmt-set-id-fn-name #'type "copy")
|
||||
#:with id-set-copy-clear (fmt-set-id-fn-name #'type "copy-clear")
|
||||
#:with id-set-clear (fmt-set-id-fn-name #'type "clear")
|
||||
#:with id-set-clear! (fmt-set-id-fn-name #'type "clear!")
|
||||
#:with id-set-union (fmt-set-id-fn-name #'type "union")
|
||||
#:with id-set-union! (fmt-set-id-fn-name #'type "union!")
|
||||
#:with id-set-intersect (fmt-set-id-fn-name #'type "intersect")
|
||||
#:with id-set-intersect! (fmt-set-id-fn-name #'type "intersect!")
|
||||
#:with id-set-subtract (fmt-set-id-fn-name #'type "subtract")
|
||||
#:with id-set-subtract! (fmt-set-id-fn-name #'type "subtract!")
|
||||
#:with id-set-symmetric-difference (fmt-set-id-fn-name #'type "symmetric-difference")
|
||||
#:with id-set-symmetric-difference! (fmt-set-id-fn-name #'type "symmetric-difference!")
|
||||
#:with id-set-map (fmt-set-id-fn-name #'type "map")
|
||||
#:with id-set-for-each (fmt-set-id-fn-name #'type "for-each")
|
||||
;; these fns don't have the conventional (eg "free-id-set-") prefix
|
||||
#:with id-subset? (fmt-id "~a-id-subset?" #'type)
|
||||
#:with id-proper-subset? (fmt-id "~a-id-proper-subset?" #'type)
|
||||
#:with in-id-set (fmt-id "in-~a-id-set" #'type)
|
||||
#:with id-set=? (fmt-id "~a-id-set=?" #'type)
|
||||
#'(provide/contract
|
||||
[mutable-id-set
|
||||
(->* () (generic-set? #:phase (or/c #f exact-integer?)) mutable-id-set?)]
|
||||
[immutable-id-set
|
||||
(->* () (generic-set? #:phase (or/c #f exact-integer?)) immutable-id-set?)]
|
||||
[id-set? (-> any/c boolean?)]
|
||||
[mutable-id-set? (-> any/c boolean?)]
|
||||
[immutable-id-set? (-> any/c boolean?)]
|
||||
[id-set-empty? (-> id-set? boolean?)]
|
||||
[id-set-count (-> id-set? exact-nonnegative-integer?)]
|
||||
[id-set-member? (-> id-set? identifier? boolean?)]
|
||||
[id-set=? (-> id-set? id-set? boolean?)]
|
||||
[id-set-add (-> immutable-id-set? identifier? immutable-id-set?)]
|
||||
[id-set-add! (-> mutable-id-set? identifier? void?)]
|
||||
[id-set-remove (-> immutable-id-set? identifier? immutable-id-set?)]
|
||||
[id-set-remove! (-> mutable-id-set? identifier? void?)]
|
||||
[id-set-first (-> id-set? identifier?)]
|
||||
[id-set-rest (-> immutable-id-set? immutable-id-set?)]
|
||||
[in-id-set (-> id-set? sequence?)]
|
||||
[id-set->stream (-> id-set? stream?)]
|
||||
[id-set->list (-> id-set? list?)]
|
||||
[id-set-copy (-> id-set? id-set?)]
|
||||
[id-set-copy-clear (-> id-set? id-set?)]
|
||||
[id-set-clear (-> immutable-id-set? immutable-id-set?)]
|
||||
[id-set-clear! (-> mutable-id-set? mutable-id-set?)]
|
||||
[id-set-union
|
||||
(->* [immutable-id-set?] [] #:rest (listof id-set?) immutable-id-set?)]
|
||||
[id-set-union!
|
||||
(->* [mutable-id-set?] [] #:rest (listof id-set?) void?)]
|
||||
[id-set-intersect
|
||||
(->* [immutable-id-set?] [] #:rest (listof id-set?) immutable-id-set?)]
|
||||
[id-set-intersect!
|
||||
(->* [mutable-id-set?] [] #:rest (listof id-set?) void?)]
|
||||
[id-set-subtract
|
||||
(->* [immutable-id-set?] [] #:rest (listof id-set?) immutable-id-set?)]
|
||||
[id-set-subtract!
|
||||
(->* [mutable-id-set?] [] #:rest (listof id-set?) void?)]
|
||||
[id-set-symmetric-difference
|
||||
(->* [immutable-id-set?] [] #:rest (listof id-set?) immutable-id-set?)]
|
||||
[id-set-symmetric-difference!
|
||||
(->* [mutable-id-set?] [] #:rest (listof id-set?) void?)]
|
||||
[id-subset? (-> id-set? id-set? boolean?)]
|
||||
[id-proper-subset? (-> id-set? id-set? boolean?)]
|
||||
[id-set-map (-> id-set? (-> identifier? any/c) list?)]
|
||||
[id-set-for-each (-> id-set? (-> identifier? any/c) void?)])]))
|
||||
|
||||
(provide-contracted-id-set-fns #:type free)
|
||||
(provide-contracted-id-set-fns #:type bound)
|
||||
423
racket/collects/syntax/private/id-set.rkt
Normal file
423
racket/collects/syntax/private/id-set.rkt
Normal file
|
|
@ -0,0 +1,423 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base syntax/parse syntax/stx racket/syntax)
|
||||
racket/set racket/dict racket/sequence racket/stream racket/contract
|
||||
syntax/id-table)
|
||||
|
||||
;; id formatting helper fns ---------------------------------------------------
|
||||
;; mk-pred-name : identifier -> identifier
|
||||
(define-for-syntax (fmt-pred-name id) (format-id id "~a?" id))
|
||||
;; fmt-set-id-fn-name : identifier string -> identifier
|
||||
;; (fmt-set-id-fn-name #'free "empty?") => #'free-id-set-empty?
|
||||
(define-for-syntax (fmt-set-id-fn-name set-id-type set-fn-name)
|
||||
(format-id set-id-type (string-append "~a-id-set-" set-fn-name) set-id-type))
|
||||
;; fmt-table-id-fn-name : identifier string -> identifier
|
||||
;; (fmt-table-id-fn-name #'free "ref") => #'free-id-table-ref
|
||||
(define-for-syntax (fmt-tbl-id-fn-name tbl-id-type tbl-fn-name)
|
||||
(format-id tbl-id-type (string-append "~a-id-table-" tbl-fn-name) tbl-id-type))
|
||||
;; fmt-id : string identifier -> identifier
|
||||
;; format id where id is used as both the ctx and the single str escape
|
||||
(define-for-syntax (fmt-id str-pat id) (format-id id str-pat id))
|
||||
|
||||
(provide (for-syntax fmt-id fmt-set-id-fn-name fmt-pred-name))
|
||||
|
||||
;; defines and provides functions for an identifier set,
|
||||
;; where type = free or bound
|
||||
(define-syntax (define-and-provide-id-set stx)
|
||||
(syntax-parse stx
|
||||
[(_ #:type type)
|
||||
;; names for id-set fns --------------------------------------------------
|
||||
#:with id-set (fmt-id "~a-id-set" #'type)
|
||||
#:with mutable-id-set (fmt-id "mutable-~a" #'id-set)
|
||||
#:with mk-mutable-id-set (fmt-id"make-~a" #'mutable-id-set)
|
||||
#:with immutable-id-set (fmt-id "immutable-~a" #'id-set)
|
||||
#:with mk-immutable-id-set (fmt-id "make-~a" #'immutable-id-set)
|
||||
#:with id-set? (fmt-pred-name #'id-set)
|
||||
#:with mutable-id-set? (fmt-pred-name #'mutable-id-set)
|
||||
#:with immutable-id-set? (fmt-pred-name #'immutable-id-set)
|
||||
#:with chaperone-mutable-id-set (fmt-id "chaperone-~a" #'mutable-id-set)
|
||||
#:with chaperone-immutable-id-set (fmt-id "chaperone-~a" #'immutable-id-set)
|
||||
#:with id-set-get-table (fmt-set-id-fn-name #'type "table") ; internal table accessor
|
||||
#:with id-set-empty? (fmt-set-id-fn-name #'type "empty?")
|
||||
#:with id-set-count (fmt-set-id-fn-name #'type "count")
|
||||
#:with id-set-member? (fmt-set-id-fn-name #'type "member?")
|
||||
#:with id-set-add (fmt-set-id-fn-name #'type "add")
|
||||
#:with id-set-add! (fmt-set-id-fn-name #'type "add!")
|
||||
#:with id-set-remove (fmt-set-id-fn-name #'type "remove")
|
||||
#:with id-set-remove! (fmt-set-id-fn-name #'type "remove!")
|
||||
#:with id-set-first (fmt-set-id-fn-name #'type "first")
|
||||
#:with id-set-rest (fmt-set-id-fn-name #'type "rest")
|
||||
#:with id-set->stream (fmt-set-id-fn-name #'type ">stream")
|
||||
#:with id-set->list (fmt-set-id-fn-name #'type ">list")
|
||||
#:with id-set-copy (fmt-set-id-fn-name #'type "copy")
|
||||
#:with id-set-copy-clear (fmt-set-id-fn-name #'type "copy-clear")
|
||||
#:with id-set-clear (fmt-set-id-fn-name #'type "clear")
|
||||
#:with id-set-clear! (fmt-set-id-fn-name #'type "clear!")
|
||||
#:with id-set-union (fmt-set-id-fn-name #'type "union")
|
||||
#:with id-set-union! (fmt-set-id-fn-name #'type "union!")
|
||||
#:with id-set-intersect (fmt-set-id-fn-name #'type "intersect")
|
||||
#:with id-set-intersect! (fmt-set-id-fn-name #'type "intersect!")
|
||||
#:with id-set-subtract (fmt-set-id-fn-name #'type "subtract")
|
||||
#:with id-set-subtract! (fmt-set-id-fn-name #'type "subtract!")
|
||||
#:with id-set-symmetric-difference (fmt-set-id-fn-name #'type "symmetric-difference")
|
||||
#:with id-set-symmetric-difference! (fmt-set-id-fn-name #'type "symmetric-difference!")
|
||||
#:with id-set-map (fmt-set-id-fn-name #'type "map")
|
||||
#:with id-set-for-each (fmt-set-id-fn-name #'type "for-each")
|
||||
;; these fns don't have the conventional (eg "free-id-set-") prefix
|
||||
#:with id-subset? (fmt-id "~a-id-subset?" #'type)
|
||||
#:with id-proper-subset? (fmt-id "~a-id-proper-subset?" #'type)
|
||||
#:with in-id-set (fmt-id "in-~a-id-set" #'type)
|
||||
#:with id-set=? (fmt-id "~a-id-set=?" #'type)
|
||||
;; names for id-table fns ------------------------------------------------
|
||||
#:with make-mutable-id-table (fmt-id "make-~a-id-table" #'type)
|
||||
#:with make-immutable-id-table (fmt-id "make-immutable-~a-id-table" #'type)
|
||||
#:with id-table-ref (fmt-tbl-id-fn-name #'type "ref")
|
||||
#:with id-table-set (fmt-tbl-id-fn-name #'type "set")
|
||||
#:with id-table-set! (fmt-tbl-id-fn-name #'type "set!")
|
||||
#:with id-table-remove (fmt-tbl-id-fn-name #'type "remove")
|
||||
#:with id-table-remove! (fmt-tbl-id-fn-name #'type "remove!")
|
||||
#:with id-table-map (fmt-tbl-id-fn-name #'type "map")
|
||||
#:with id-table-for-each (fmt-tbl-id-fn-name #'type "for-each")
|
||||
#:with id-table-count (fmt-tbl-id-fn-name #'type "count")
|
||||
#:with id-table-first (fmt-tbl-id-fn-name #'type "first")
|
||||
#:with id-table-next (fmt-tbl-id-fn-name #'type "next")
|
||||
#:with id-table-iterate-key (fmt-tbl-id-fn-name #'type "iterate-key")
|
||||
#:with id-table-iterate-first (fmt-tbl-id-fn-name #'type "iterate-first")
|
||||
#'(begin
|
||||
(provide
|
||||
(rename-out [mk-mutable-id-set mutable-id-set]
|
||||
[mk-immutable-id-set immutable-id-set])
|
||||
chaperone-mutable-id-set
|
||||
chaperone-immutable-id-set
|
||||
id-set?
|
||||
mutable-id-set?
|
||||
immutable-id-set?
|
||||
id-set-empty?
|
||||
id-set-count
|
||||
id-set-member?
|
||||
id-set=?
|
||||
id-set-add
|
||||
id-set-add!
|
||||
id-set-remove
|
||||
id-set-remove!
|
||||
id-set-first
|
||||
id-set-rest
|
||||
in-id-set
|
||||
id-set->stream
|
||||
id-set->list
|
||||
id-set-copy
|
||||
id-set-copy-clear
|
||||
id-set-clear
|
||||
id-set-clear!
|
||||
id-set-union
|
||||
id-set-union!
|
||||
id-set-intersect
|
||||
id-set-intersect!
|
||||
id-set-subtract
|
||||
id-set-subtract!
|
||||
id-set-symmetric-difference
|
||||
id-set-symmetric-difference!
|
||||
id-subset?
|
||||
id-proper-subset?
|
||||
id-set-map
|
||||
id-set-for-each)
|
||||
|
||||
;; implementations here are copied from racket/private/set-types.rkt
|
||||
|
||||
;; set predicates
|
||||
(define (id-set-member? s x)
|
||||
(id-table-ref (id-set-get-table s) x #f))
|
||||
|
||||
(define (id-set=? s1 s2)
|
||||
(define table1 (id-set-get-table s1))
|
||||
(define table2 (id-set-get-table s2))
|
||||
(and (for/and ([id (in-dict-keys table1)]) (id-table-ref table2 id #f))
|
||||
(for/and ([id (in-dict-keys table2)]) (id-table-ref table1 id #f))))
|
||||
|
||||
(define (id-set-count s)
|
||||
(id-table-count (id-set-get-table s)))
|
||||
|
||||
(define (id-set-empty? s)
|
||||
(zero? (id-set-count s)))
|
||||
|
||||
;; add/remove/copy
|
||||
(define (id-set-add s x)
|
||||
(immutable-id-set (id-table-set (id-set-get-table s) x #t)))
|
||||
(define (id-set-add! s x)
|
||||
(id-table-set! (id-set-get-table s) x #t))
|
||||
|
||||
(define (id-set-remove s x)
|
||||
(immutable-id-set (id-table-remove (id-set-get-table s) x)))
|
||||
(define (id-set-remove! s x)
|
||||
(id-table-remove! (id-set-get-table s) x))
|
||||
|
||||
;; Can't just copy id-table because there's no copy function or dict-copy
|
||||
(define (id-set-copy s)
|
||||
(if (mutable-id-set? s)
|
||||
(mk-mutable-id-set (id-set->list s))
|
||||
(mk-immutable-id-set (id-set->list s))))
|
||||
|
||||
(define (id-set-copy-clear s)
|
||||
(if (mutable-id-set? s)
|
||||
(mk-mutable-id-set null)
|
||||
(mk-immutable-id-set null)))
|
||||
|
||||
(define (id-set-clear s)
|
||||
(immutable-id-set (dict-clear (id-set-get-table s))))
|
||||
(define (id-set-clear! s)
|
||||
(define table (id-set-get-table s))
|
||||
(dict-clear! table)
|
||||
(mutable-id-set table))
|
||||
|
||||
;; set traversals
|
||||
(define (id-set-first s)
|
||||
(define table (id-set-get-table s))
|
||||
(id-table-iterate-key table (id-table-iterate-first table)))
|
||||
|
||||
;; id-set-rest is undefined for mutable sets
|
||||
;; and thus always returns a mutable set
|
||||
(define (id-set-rest s)
|
||||
(define table (id-set-get-table s))
|
||||
(define i (id-table-iterate-first table))
|
||||
(immutable-id-set (id-table-remove table (id-table-iterate-key table i))))
|
||||
|
||||
(define (in-id-set s) (in-dict-keys (id-set-get-table s)))
|
||||
(define (id-set->stream s) (sequence->stream (in-id-set s)))
|
||||
(define (id-set->list s) (dict-keys (id-set-get-table s)))
|
||||
|
||||
;; -------------------------------------------------------------------
|
||||
;; set operations
|
||||
|
||||
(define (choose-immutable cmp set0 other-sets-lst)
|
||||
(for/fold ([largest set0]) ([s (in-list other-sets-lst)])
|
||||
(if (and (immutable-id-set? s)
|
||||
(cmp (id-set-count s)
|
||||
(id-set-count largest)))
|
||||
s
|
||||
largest)))
|
||||
(define (choose-largest-immutable set0 other-sets-lst)
|
||||
(choose-immutable > set0 other-sets-lst))
|
||||
(define (choose-smallest-immutable set0 other-sets-lst)
|
||||
(choose-immutable < set0 other-sets-lst))
|
||||
|
||||
(define (id-set-union set0 . ss)
|
||||
(unless (immutable-id-set? set0)
|
||||
(error 'id-set-union "expected immutable id set in: ~a" set0))
|
||||
(define largest-immutable (choose-largest-immutable set0 ss))
|
||||
(immutable-id-set
|
||||
(for/fold
|
||||
([table (id-set-get-table largest-immutable)])
|
||||
([s (in-list (cons set0 ss))]
|
||||
#:unless (eq? s largest-immutable))
|
||||
(for/fold ([table table])
|
||||
([id (in-dict-keys (id-set-get-table s))])
|
||||
(id-table-set table id #t)))))
|
||||
(define (id-set-union! set0 . ss)
|
||||
(unless (mutable-id-set? set0)
|
||||
(error 'id-set-union! "expected mutable id set in: ~a" set0))
|
||||
(define table (id-set-get-table set0))
|
||||
(for ([s (in-list ss)])
|
||||
(for ([id (in-dict-keys (id-set-get-table s))])
|
||||
(id-table-set! table id #t))))
|
||||
|
||||
(define (id-set-intersect set0 . ss)
|
||||
(unless (immutable-id-set? set0)
|
||||
(error 'id-set-intersect "expected immutable id set in: ~a" set0))
|
||||
(define smallest-immutable (choose-smallest-immutable set0 ss))
|
||||
(define smallest-table (id-set-get-table smallest-immutable))
|
||||
(define all-tables-seq (in-list (map id-set-get-table (cons set0 ss))))
|
||||
(define (keep? id)
|
||||
(for/and ([table all-tables-seq] #:unless (eq? table smallest-table))
|
||||
(id-table-ref table id #f)))
|
||||
(immutable-id-set
|
||||
(for/fold ([table smallest-table])
|
||||
([id (in-dict-keys smallest-table)] #:unless (keep? id))
|
||||
(id-table-remove table id))))
|
||||
(define (id-set-intersect! set0 . ss)
|
||||
(unless (mutable-id-set? set0)
|
||||
(error 'id-set-intersect! "expected mutable id set in: ~a" set0))
|
||||
(define tables-seq (in-list (map id-set-get-table ss)))
|
||||
(define (keep? id)
|
||||
(for/and ([table tables-seq]) (id-table-ref table id #f)))
|
||||
(define table0 (id-set-get-table set0))
|
||||
;; use dict-keys (instead of in-dict-keys) to grab all keys ahead of time
|
||||
;; bc we will possibly be removing some of them
|
||||
(for ([id (dict-keys table0)] #:unless (keep? id))
|
||||
(id-table-remove! table0 id)))
|
||||
|
||||
(define (id-set-subtract set0 . ss)
|
||||
(unless (immutable-id-set? set0)
|
||||
(error 'id-set-subtract "expected immutable id set in: ~a" set0))
|
||||
(define tables-seq (in-list (map id-set-get-table ss)))
|
||||
(define (remove? id)
|
||||
(for/or ([table tables-seq])
|
||||
(id-table-ref table id #f)))
|
||||
(define table0 (id-set-get-table set0))
|
||||
(immutable-id-set
|
||||
(for/fold ([table table0])
|
||||
([id (in-dict-keys table0)] #:when (remove? id))
|
||||
(id-table-remove table id))))
|
||||
(define (id-set-subtract! set0 . ss)
|
||||
(unless (mutable-id-set? set0)
|
||||
(error 'id-set-subtract! "expected mutable id set in: ~a" set0))
|
||||
(define tables-seq (in-list (map id-set-get-table ss)))
|
||||
(define (remove? id)
|
||||
(for/or ([table tables-seq])
|
||||
(id-table-ref table id #f)))
|
||||
(define table0 (id-set-get-table set0))
|
||||
;; use dict-keys (instead of in-dict-keys) to grab all keys ahead of time
|
||||
;; bc we will possibly be removing some of them
|
||||
(for ([id (dict-keys table0)] #:when (remove? id))
|
||||
(id-table-remove! table0 id)))
|
||||
|
||||
(define (id-set-symmetric-difference set0 . ss)
|
||||
(unless (immutable-id-set? set0)
|
||||
(error 'id-set-symmetric-difference
|
||||
"expected immutable id set in: ~a" set0))
|
||||
(define largest-immutable (choose-largest-immutable set0 ss))
|
||||
(immutable-id-set
|
||||
(for/fold
|
||||
([table (id-set-get-table largest-immutable)])
|
||||
([s (in-list (cons set0 ss))] #:unless (eq? s largest-immutable))
|
||||
(for/fold ([table table])
|
||||
([id (in-dict-keys (id-set-get-table s))])
|
||||
(if (id-table-ref table id #f)
|
||||
(id-table-remove table id)
|
||||
(id-table-set table id #t))))))
|
||||
(define (id-set-symmetric-difference! set0 . ss)
|
||||
(unless (mutable-id-set? set0)
|
||||
(error 'id-set-symmetric-difference!
|
||||
"expected mutable id set in: ~a" set0))
|
||||
(define table (id-set-get-table set0))
|
||||
(for ([s (in-list ss)])
|
||||
(for ([id (in-dict-keys (id-set-get-table s))])
|
||||
(if (id-table-ref table id #f)
|
||||
(id-table-remove! table id)
|
||||
(id-table-set! table id #t)))))
|
||||
|
||||
(define (id-subset? s1 s2)
|
||||
(define table1 (id-set-get-table s1))
|
||||
(define table2 (id-set-get-table s2))
|
||||
(for/and ([id (in-dict-keys table1)])
|
||||
(id-table-ref table2 id #f)))
|
||||
|
||||
(define (id-proper-subset? s1 s2)
|
||||
(define table1 (id-set-get-table s1))
|
||||
(define table2 (id-set-get-table s2))
|
||||
(and (for/and ([id (in-dict-keys table1)])
|
||||
(id-table-ref table2 id #f))
|
||||
(for/or ([id (in-dict-keys table2)])
|
||||
(not (id-table-ref table1 id #f)))))
|
||||
|
||||
(define (id-set-map s f)
|
||||
(for/fold ([ids null]) ([id (in-dict-keys (id-set-get-table s))])
|
||||
(cons (f id) ids)))
|
||||
|
||||
(define (id-set-for-each s f)
|
||||
(for ([id (in-dict-keys (id-set-get-table s))]) (f id)))
|
||||
|
||||
;; -------------------------------------------------------------------
|
||||
;; struct defs
|
||||
|
||||
(define id-set-hash-constant
|
||||
(equal-hash-code "hash code for free id sets"))
|
||||
(define id-set-hash-constant2
|
||||
(equal-hash-code "another hash code for free id sets"))
|
||||
;; table: the internal id table
|
||||
(struct id-set (table)
|
||||
#:property prop:sequence in-id-set
|
||||
#:methods gen:equal+hash
|
||||
[(define (equal-proc s1 s2 rec)
|
||||
(rec (id-set-get-table s1)
|
||||
(id-set-get-table s2)))
|
||||
(define (hash-proc s rec)
|
||||
(+ (rec (id-set-get-table s))
|
||||
id-set-hash-constant))
|
||||
(define (hash2-proc s rec)
|
||||
(+ (rec (id-set-get-table s))
|
||||
id-set-hash-constant2))])
|
||||
(struct mutable-id-set id-set ()
|
||||
#:methods gen:set
|
||||
[(define set-empty? id-set-empty?)
|
||||
(define set-member? id-set-member?)
|
||||
(define set-count id-set-count)
|
||||
(define set=? id-set=?)
|
||||
(define subset? id-subset?)
|
||||
(define proper-subset? id-proper-subset?)
|
||||
(define set-map id-set-map)
|
||||
(define set-for-each id-set-for-each)
|
||||
(define set-copy id-set-copy)
|
||||
(define set-copy-clear id-set-copy-clear)
|
||||
(define set->list id-set->list)
|
||||
(define set->stream id-set->stream)
|
||||
(define in-set in-id-set)
|
||||
(define set-first id-set-first)
|
||||
(define set-add! id-set-add!)
|
||||
(define set-remove! id-set-remove!)
|
||||
(define set-clear! id-set-clear!)
|
||||
(define set-union! id-set-union!)
|
||||
(define set-intersect! id-set-intersect!)
|
||||
(define set-subtract! id-set-subtract!)
|
||||
(define set-symmetric-difference! id-set-symmetric-difference!)])
|
||||
(struct immutable-id-set id-set ()
|
||||
#:methods gen:stream
|
||||
[(define stream-empty? id-set-empty?)
|
||||
(define stream-first id-set-first)
|
||||
(define stream-rest id-set-rest)]
|
||||
#:methods gen:set
|
||||
[(define set-empty? id-set-empty?)
|
||||
(define set-member? id-set-member?)
|
||||
(define set-count id-set-count)
|
||||
(define set=? id-set=?)
|
||||
(define subset? id-subset?)
|
||||
(define proper-subset? id-proper-subset?)
|
||||
(define set-map id-set-map)
|
||||
(define set-for-each id-set-for-each)
|
||||
(define set-copy id-set-copy)
|
||||
(define set-copy-clear id-set-copy-clear)
|
||||
(define set->list id-set->list)
|
||||
(define set->stream id-set->stream)
|
||||
(define in-set in-id-set)
|
||||
(define set-first id-set-first)
|
||||
(define set-rest id-set-rest)
|
||||
(define set-add id-set-add)
|
||||
(define set-remove id-set-remove)
|
||||
(define set-clear id-set-clear)
|
||||
(define set-union id-set-union)
|
||||
(define set-intersect id-set-intersect)
|
||||
(define set-subtract id-set-subtract)
|
||||
(define set-symmetric-difference id-set-symmetric-difference)])
|
||||
|
||||
;; consumes a contract for the internal table
|
||||
(define (chaperone-immutable-id-set s table/c)
|
||||
(define/contract table/ctc table/c (id-set-get-table s))
|
||||
(immutable-id-set table/ctc))
|
||||
(define (chaperone-mutable-id-set s table/c)
|
||||
(define/contract table/ctc table/c (id-set-get-table s))
|
||||
(mutable-id-set table/ctc))
|
||||
|
||||
(define (mk-mutable-id-set
|
||||
[init-set null]
|
||||
#:phase [phase (syntax-local-phase-level)])
|
||||
(mutable-id-set
|
||||
(make-mutable-id-table
|
||||
(for/hash ([x (in-set init-set)])
|
||||
(unless (identifier? x)
|
||||
(raise-type-error (object-name mutable-id-set)
|
||||
"set with identifier keys" init-set))
|
||||
(values x #t))
|
||||
#:phase phase)))
|
||||
|
||||
(define (mk-immutable-id-set
|
||||
[init-set null]
|
||||
#:phase [phase (syntax-local-phase-level)])
|
||||
(immutable-id-set
|
||||
(make-immutable-id-table
|
||||
(for/hash ([x (in-set init-set)])
|
||||
(unless (identifier? x)
|
||||
(raise-type-error (object-name immutable-id-set)
|
||||
"set with identifier keys" init-set))
|
||||
(values x #t))
|
||||
#:phase phase))))]))
|
||||
|
||||
(define-and-provide-id-set #:type free)
|
||||
(define-and-provide-id-set #:type bound)
|
||||
Loading…
Reference in New Issue
Block a user