diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index 7bfd1e996b..468b57e8b8 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -2,6 +2,7 @@ (require racket/contract/base racket/contract/combinator "private/generic.rkt" + "private/generic-methods.rkt" (for-syntax racket/base racket/local racket/syntax syntax/stx)) ;; Convenience layer on top of racket/private/generic. @@ -11,7 +12,12 @@ ;; Files that use racket/private/generic _must_ pass _all_ keyword ;; arguments to define-generics _in_order_. -(provide define-generics define/generic) +(provide define-generics + define/generic + chaperone-generics + impersonate-generics + redirect-generics + generic-instance/c) (begin-for-syntax @@ -144,6 +150,7 @@ index)) (define/with-syntax pred-name (format-id #'name "~a?" #'name)) (define/with-syntax gen-name (format-id #'name "gen:~a" #'name)) + (define/with-syntax ctc-name (format-id #'name "~a/c" #'name)) (define/with-syntax prop-name (generate-temporary #'name)) (define/with-syntax get-name (generate-temporary #'name)) (define/with-syntax support-name support) @@ -166,134 +173,159 @@ #:derive-properties [derive ...] method ...) table-defn - (define-generics-contract name pred-name get-name - [method-name method-index] - ...)))])) + (define-generics-contract ctc-name gen-name)))])) -;; generate a contract combinator for instances of a generic interface -(define-syntax (define-generics-contract stx) +(define-syntax (redirect-generics/derived stx) (syntax-case stx () - [(_ name name? accessor (generic generic-idx) ...) - (with-syntax ([name/c (format-id #'name "~a/c" #'name)]) - #`(define-syntax (name/c stx) - (syntax-case stx () - [(_ [method-id ctc] (... ...)) - (andmap (λ (id) (and (identifier? id) - ;; make sure the ids are all - ;; in the interface - (member (syntax-e id) (list 'generic ...)))) - (syntax->list #'(method-id (... ...)))) - #'(make-generic-instance/c - (quote #,(syntax-e #'name/c)) - name? - accessor - (list 'method-id (... ...)) - (list ctc (... ...)) - (make-immutable-hash - (list (cons 'generic generic-idx) ...)))])))])) + [(_ orig mode gen-name val-expr [method-name proc-expr] ...) + (parameterize ([current-syntax-context #'orig]) + (define gen-id #'gen-name) + (unless (identifier? gen-id) + (wrong-syntax gen-id "expected an identifier")) + (define gen-info (syntax-local-value gen-id (lambda () #f))) + (unless (generic-info? gen-info) + (wrong-syntax gen-id "expected a name for a generic interface")) + (define delta (syntax-local-make-delta-introducer gen-id)) + (define predicate (generic-info-predicate gen-info)) + (define accessor (generic-info-accessor gen-info)) + (define method-ids (syntax->list #'(method-name ...))) + (define indices + (for/list ([method-id (in-list method-ids)]) + (find-generic-method-index #'orig gen-id delta gen-info method-id))) + (define/with-syntax pred-name predicate) + (define/with-syntax ref-name accessor) + (define/with-syntax [method-index ...] indices) + #'(redirect-generics-proc 'gen-name mode pred-name ref-name val-expr + (lambda (i x) + (case i + [(method-index) (proc-expr x)] + ... + [else x]))))])) -;; make a generic instance contract -(define (make-generic-instance/c name name? accessor ids ctc-args method-map) - (define ctcs (coerce-contracts 'generic-instance/c ctc-args)) - ;; map method table indices to ids & projections - (define id+ctc-map - (for/hash ([id ids] [ctc ctcs]) - (values (hash-ref method-map id) - (cons id (contract-projection ctc))))) - (cond [(andmap chaperone-contract? ctcs) - (chaperone-generic-instance/c - name name? ids ctcs accessor id+ctc-map method-map)] - [else - (impersonator-generic-instance/c - name name? ids ctcs accessor id+ctc-map method-map)])) +(define-syntax (redirect-generics stx) + (syntax-case stx () + [(_ mode gen-name val-expr [id expr] ...) + #`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ...)])) -(define (generic-instance/c-name ctc) - (define method-names - (map (λ (id ctc) (build-compound-type-name id ctc)) - (base-generic-instance/c-ids ctc) - (base-generic-instance/c-ctcs ctc))) - (apply build-compound-type-name - (cons (base-generic-instance/c-name ctc) method-names))) +(define-syntax (chaperone-generics stx) + (syntax-case stx () + [(_ gen-name val-expr [id expr] ...) + #`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ...)])) -;; redirect for use with chaperone-vector -(define ((method-table-redirect ctc blame) vec idx val) - (define id+ctc-map (base-generic-instance/c-id+ctc-map ctc)) - (define maybe-id+ctc (hash-ref id+ctc-map idx #f)) - (cond [maybe-id+ctc - (define id (car maybe-id+ctc)) - (define proj (cdr maybe-id+ctc)) - (define blame-string (format "the ~a method of" id)) - ((proj (blame-add-context blame blame-string)) val)] - [else val])) +(define-syntax (impersonate-generics stx) + (syntax-case stx () + [(_ gen-name val-expr [id expr] ...) + #`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ...)])) -;; projection for generic methods -(define ((generic-instance/c-proj proxy-struct proxy-vector) ctc) - (λ (blame) - ;; for redirecting the method table accessor - (define (redirect struct v) - (proxy-vector - v - (method-table-redirect ctc blame) - (λ (vec i v) v))) - (λ (val) - (unless ((base-generic-instance/c-name? ctc) val) - (raise-blame-error - blame val - '(expected: "~s" given: "~e") - (contract-name ctc) - val)) - (define accessor (base-generic-instance/c-accessor ctc)) - (define method-table (accessor val)) - (define ids (base-generic-instance/c-ids ctc)) - (define ctcs (base-generic-instance/c-ctcs ctc)) - (define method-map (base-generic-instance/c-method-map ctc)) - ;; do sub-contract first-order checks - (for ([id ids] [ctc ctcs]) - (define v (vector-ref method-table (hash-ref method-map id))) - (unless (contract-first-order-passes? ctc v) - (raise-blame-error - (blame-add-context blame (format "method ~s of" id)) - v - '(expected: "~s" given: "~e") - (contract-name ctc) - v))) - (proxy-struct val accessor redirect)))) +(define (redirect-generics-proc name chaperoning? pred ref x proc) + (unless (pred x) + (raise-argument-error name (format "a structure implementing ~a" name) x)) + (define-values (redirect-struct redirect-vector) + (if chaperoning? + (values chaperone-struct chaperone-vector) + (values impersonate-struct impersonate-vector))) + (define (vec-proc vec i method) + (proc i method)) + (define (struct-proc x vec) + (redirect-vector vec vec-proc vec-proc)) + (redirect-struct x ref struct-proc)) -;; recognizes instances of this generic interface -(define ((generic-instance/c-first-order ctc) v) - (cond [((base-generic-instance/c-name? ctc) v) - (define accessor (base-generic-instance/c-accessor ctc)) - (define method-table (accessor v)) - (define ids (base-generic-instance/c-ids ctc)) - (define ctcs (base-generic-instance/c-ctcs ctc)) - (define method-map (base-generic-instance/c-method-map ctc)) - ;; do sub-contract first-order checks - (for/and ([id ids] [ctc ctcs]) - (contract-first-order-passes? - ctc - (vector-ref method-table (hash-ref method-map id))))] - [else #f])) +(define-syntax-rule (define-generics-contract ctc-name gen-name) + (define-syntax (ctc-name stx) + (syntax-case stx () + [(_ [id expr] (... ...)) + #`(generic-instance/c/derived #,stx + [ctc-name] + gen-name + [id expr] + (... ...))]))) -;; name - for building ctc name -;; name? - for first-order checks -;; ids - for method names (used to build the ctc name) -;; ctcs - for the contract name -;; accessor - for chaperoning the struct type property -;; id+ctc-map - for chaperoning the method table vector -;; method-map - for first-order checks -(struct base-generic-instance/c - (name name? ids ctcs accessor id+ctc-map method-map)) +(define-syntax (generic-instance/c stx) + (syntax-case stx () + [(_ gen-name [id expr] ...) + #`(generic-instance/c/derived #,stx + [generic-instance/c gen-name] + gen-name + [id expr] + ...)])) -(struct chaperone-generic-instance/c base-generic-instance/c () +(define-syntax (generic-instance/c/derived stx) + (syntax-case stx () + [(_ original [prefix ...] gen-name [method-id ctc-expr] ...) + (parameterize ([current-syntax-context #'original]) + (define gen-id #'gen-name) + (unless (identifier? gen-id) + (wrong-syntax gen-id "expected an identifier")) + (define gen-info (syntax-local-value gen-id (lambda () #f))) + (unless (generic-info? gen-info) + (wrong-syntax gen-id "expected a name for a generic interface")) + (define predicate (generic-info-predicate gen-info)) + (define/with-syntax pred predicate) + (define/with-syntax [ctc-id ...] + (generate-temporaries #'(ctc-expr ...))) + (define/with-syntax [proj-id ...] + (generate-temporaries #'(ctc-expr ...))) + #'(let* ([ctc-id ctc-expr] ...) + (make-generics-contract + 'gen-name + '[prefix ...] + pred + '(method-id ...) + (list ctc-id ...) + (lambda (b x mode) + (redirect-generics + mode + gen-name + x + [method-id + (lambda (m) + (define b2 + (blame-add-context b (format "method ~a" 'method-id))) + (((contract-projection ctc-id) b2) m))] + ...)))))])) + +(define (make-generics-contract ifc pfx pred mths ctcs proc) + (define chaperoning? + (for/and ([mth (in-list mths)] [ctc (in-list ctcs)]) + (unless (contract? ctc) + (raise-arguments-error + (car pfx) + "non-contract value supplied for method" + "value" ctc + "method" mth + "generic interface" ifc)) + (chaperone-contract? ctc))) + (if chaperoning? + (chaperone-generics-contract pfx pred mths ctcs proc) + (impersonator-generics-contract pfx pred mths ctcs proc))) + +(struct generics-contract [prefix predicate methods contracts redirect]) + +(define (generics-contract-name ctc) + `(,@(generics-contract-prefix ctc) + ,@(for/list ([method (in-list (generics-contract-methods ctc))] + [c (in-list (generics-contract-contracts ctc))]) + (list method (contract-name c))))) + +(define (generics-contract-first-order ctc) + (generics-contract-predicate ctc)) + +(define (generics-contract-projection mode) + (lambda (c) + (lambda (b) + (lambda (x) + ((generics-contract-redirect c) b x mode))))) + +(struct chaperone-generics-contract generics-contract [] #:property prop:chaperone-contract (build-chaperone-contract-property - #:projection (generic-instance/c-proj chaperone-struct chaperone-vector) - #:first-order generic-instance/c-first-order - #:name generic-instance/c-name)) + #:name generics-contract-name + #:first-order generics-contract-first-order + #:projection (generics-contract-projection #t))) -(struct impersonator-generic-instance/c base-generic-instance/c () +(struct impersonator-generics-contract generics-contract [] #:property prop:contract (build-contract-property - #:projection (generic-instance/c-proj impersonate-struct impersonate-vector) - #:first-order generic-instance/c-first-order - #:name generic-instance/c-name)) + #:name generics-contract-name + #:first-order generics-contract-first-order + #:projection (generics-contract-projection #f))) diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt index 918d9503ba..60b236e383 100644 --- a/racket/collects/racket/private/for.rkt +++ b/racket/collects/racket/private/for.rkt @@ -68,7 +68,7 @@ stream-first stream-rest prop:stream - stream-ref ; only provided for racket/stream + stream-ref stream-via-prop? ; only provided for racket/stream sequence->stream empty-stream make-do-stream diff --git a/racket/collects/racket/private/generic-interfaces.rkt b/racket/collects/racket/private/generic-interfaces.rkt index d7db6c13b2..2c4426dd3d 100644 --- a/racket/collects/racket/private/generic-interfaces.rkt +++ b/racket/collects/racket/private/generic-interfaces.rkt @@ -38,6 +38,8 @@ (define-syntax gen:equal+hash (make-generic-info (quote-syntax prop:gen:equal+hash) + (quote-syntax equal+hash?) + (quote-syntax gen:equal+hash-acc) (list (quote-syntax equal-proc) (quote-syntax hash-proc) (quote-syntax hash2-proc)))) @@ -67,6 +69,8 @@ (define-syntax gen:custom-write (make-generic-info (quote-syntax prop:gen:custom-write) + (quote-syntax gen:custom-write?) + (quote-syntax gen:custom-write-acc) (list (quote-syntax write-proc)))) ) diff --git a/racket/collects/racket/private/generic-methods.rkt b/racket/collects/racket/private/generic-methods.rkt index 76faaa9125..8043b0e31a 100644 --- a/racket/collects/racket/private/generic-methods.rkt +++ b/racket/collects/racket/private/generic-methods.rkt @@ -11,7 +11,10 @@ (for-syntax generic-info? make-generic-info generic-info-property - generic-info-methods)) + generic-info-predicate + generic-info-accessor + generic-info-methods + find-generic-method-index)) (begin-for-syntax @@ -20,12 +23,16 @@ generic-info? generic-info-get generic-info-set!) - (make-struct-type 'generic-info #f 2 0)) + (make-struct-type 'generic-info #f 4 0)) (define-values (generic-info-property + generic-info-predicate + generic-info-accessor generic-info-methods) (values (make-struct-field-accessor generic-info-get 0 'property) - (make-struct-field-accessor generic-info-get 1 'methods))) + (make-struct-field-accessor generic-info-get 1 'predicate) + (make-struct-field-accessor generic-info-get 2 'accessor) + (make-struct-field-accessor generic-info-get 3 'methods))) (define (check-identifier! name ctx stx) (unless (identifier? stx) @@ -56,7 +63,80 @@ unimplemented-transformer)))) (define unimplemented-method - (make-struct-field-accessor unimplemented-get 0 'method))) + (make-struct-field-accessor unimplemented-get 0 'method)) + + (define (find-generic-method who ctx gen-id delta gen-info method-id proc) + + (unless (syntax? ctx) + (raise-argument-error who "syntax?" ctx)) + (unless (identifier? gen-id) + (raise-argument-error who "identifier?" gen-id)) + (unless (and (procedure? delta) + (procedure-arity-includes? delta 1)) + (raise-argument-error who "(syntax? . -> . syntax?)" delta)) + (unless (generic-info? gen-info) + (raise-argument-error who "generic-info?" gen-info)) + (unless (identifier? method-id) + (raise-argument-error who "identifier?" method-id)) + (unless (and (procedure? proc) + (procedure-arity-includes? proc 2)) + (raise-argument-error + who + "(exact-nonnegative-integer? identifier? . -> . any)" + proc)) + + (define-values (originals indices) + (let loop ([original-ids (generic-info-methods gen-info)] + [index 0] + [rev-originals '()] + [rev-indices '()]) + (cond + [(null? original-ids) + (values (reverse rev-originals) + (reverse rev-indices))] + [else + (define original-id (car original-ids)) + (define context-id (syntax-local-get-shadower (delta original-id))) + (cond + [(free-identifier=? context-id method-id) + (loop (cdr original-ids) + (add1 index) + (cons original-id rev-originals) + (cons index rev-indices))] + [else + (loop (cdr original-ids) + (add1 index) + rev-originals + rev-indices)])]))) + + (when (null? originals) + (raise-syntax-error + #f + (format "~.s is not a method of generic interfaces ~.s" + (syntax-e method-id) + (syntax-e gen-id)) + ctx + method-id)) + (unless (null? (cdr originals)) + (raise-syntax-error + #f + (format "multiple methods match ~.s in generic interface ~.s: ~.s" + (syntax-e method-id) + (syntax-e gen-id) + (map syntax-e originals)) + ctx + method-id)) + (proc (car indices) (car originals))) + + (define (find-generic-method-index ctx gen-id delta gen-info method-id) + (find-generic-method 'find-generic-method-index + ctx gen-id delta gen-info method-id + (lambda (index original) index))) + + (define (find-generic-method-original ctx gen-id delta gen-info method-id) + (find-generic-method 'find-generic-method-index + ctx gen-id delta gen-info method-id + (lambda (index original) original)))) (define-syntax-parameter generic-method-context #f) @@ -110,28 +190,7 @@ (raise-syntax-error 'define/generic "expected an identifier" #'ref)) (define delta (syntax-local-make-delta-introducer gen-id)) (define methods (generic-info-methods gen-val)) - (define matches - (let loop ([methods methods]) - (cond - [(null? methods) '()] - [(free-identifier=? (syntax-local-get-shadower - (delta (car methods))) - #'ref) - (cons (car methods) (loop (cdr methods)))] - [else (loop (cdr methods))]))) - (unless (pair? matches) - (raise-syntax-error 'define/generic - (format "~.s is not a method of ~.s" - (syntax-e #'ref) - (syntax-e gen-id)) - stx - #'ref)) - (when (pair? (cdr matches)) - (raise-syntax-error 'define/generic - (format "multiple methods match ~.s: ~.s" - (syntax-e #'ref) - (map syntax-e matches)) - stx - #'ref)) - (with-syntax ([method (car matches)]) + (define method-id + (find-generic-method-original stx gen-id delta gen-val #'ref)) + (with-syntax ([method method-id]) #'(define bind method)))]))) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index 17d47ddfca..e14ec8b818 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -95,6 +95,8 @@ #'(begin (define-syntax generic-name (make-generic-info (quote-syntax property-name) + (quote-syntax prop:pred) + (quote-syntax accessor-name) (list (quote-syntax method-name) ...))) (define (prop:guard x info) (unless (and (vector? x) (= (vector-length x) 'size)) diff --git a/racket/collects/racket/private/pre-base.rkt b/racket/collects/racket/private/pre-base.rkt index 2dfc85c0ab..8266105f22 100644 --- a/racket/collects/racket/private/pre-base.rkt +++ b/racket/collects/racket/private/pre-base.rkt @@ -185,7 +185,8 @@ define-in-vector-like define-:vector-like-gen make-in-vector-like - stream? stream-ref stream-empty? stream-first stream-rest + stream-ref stream-via-prop? + stream? stream-empty? stream-first stream-rest prop:stream in-stream empty-stream make-do-stream split-for-body) (all-from "kernstruct.rkt") diff --git a/racket/collects/racket/private/set.rkt b/racket/collects/racket/private/set.rkt index fbaa4c7a1b..1498fe34c6 100644 --- a/racket/collects/racket/private/set.rkt +++ b/racket/collects/racket/private/set.rkt @@ -16,7 +16,6 @@ set-union! set-intersect! set-subtract! set-symmetric-difference! (rename-out [*in-set in-set]) - primitive-set/c set-implements/c) ;; Method implementations for lists: @@ -408,47 +407,6 @@ (for/and ([sym (in-list syms)]) (set-implements? x sym))))))) -(define (primitive-set/c elem/c) - (define (proc) - (set/c - [set-member? (-> set? elem/c boolean?)] - [set-empty? (or/c (-> set? boolean?) #f)] - [set-count (or/c (-> set? exact-nonnegative-integer?) #f)] - [set=? (or/c (-> set? c boolean?) #f)] - [subset? (or/c (-> set? c boolean?) #f)] - [proper-subset? (or/c (-> set? c boolean?) #f)] - [set-map (or/c (-> set? (-> elem/c any/c) list?) #f)] - [set-for-each (or/c (-> set? (-> elem/c any) void?) #f)] - [set-copy (or/c (-> set? c) #f)] - [in-set (or/c (-> set? sequence?) #f)] - [set->list (or/c (-> set? list?) #f)] - [set->stream (or/c (-> set? stream?) #f)] - [set-first (or/c (-> set? elem/c) #f)] - [set-rest (or/c (-> set? c) #f)] - [set-add (or/c (-> set? elem/c c) #f)] - [set-remove (or/c (-> set? elem/c c) #f)] - [set-clear (or/c (-> set? c) #f)] - [set-union (or/c (->* [set?] [] #:rest (listof c) c) #f)] - [set-intersect (or/c (->* [set?] [] #:rest (listof c) c) #f)] - [set-subtract (or/c (->* [set?] [] #:rest (listof c) c) #f)] - [set-symmetric-difference (or/c (->* [set?] [] #:rest (listof c) c) #f)] - [set-add! (or/c (-> set? elem/c void?) #f)] - [set-remove! (or/c (-> set? elem/c void?) #f)] - [set-clear! (or/c (-> set? void?) #f)] - [set-union! (or/c (->* [set?] [] #:rest (listof c) void?) #f)] - [set-intersect! (or/c (->* [set?] [] #:rest (listof c) void?) #f)] - [set-subtract! (or/c (->* [set?] [] #:rest (listof c) void?) #f)] - [set-symmetric-difference! - (or/c (->* [set?] [] #:rest (listof c) void?) #f)])) - (define c - (cond - [(chaperone-contract? elem/c) - (recursive-contract (proc) #:chaperone)] - [else - (recursive-contract (proc) #:impersonator)])) - (or/c (listof elem/c) - (and/c set? c))) - ;; Generics definition: (define-generics set diff --git a/racket/collects/racket/set.rkt b/racket/collects/racket/set.rkt index 6b6eae0eff..a0ee57d89a 100644 --- a/racket/collects/racket/set.rkt +++ b/racket/collects/racket/set.rkt @@ -2,10 +2,11 @@ (require racket/contract racket/private/set - racket/private/set-types) + racket/private/set-types + racket/generic + racket/private/for) -(provide (except-out (all-from-out racket/private/set) - primitive-set/c) +(provide (all-from-out racket/private/set) (all-from-out racket/private/set-types) set/c) @@ -42,30 +43,140 @@ [else (unless (contract? elem/c) (raise-argument-error 'set/c "contract?" elem/c))]) - (define c - (and/c (primitive-set/c elem/c) - cmp/c - kind/c)) - (define name - `(set/c ,(contract-name elem/c) - ,@(if (eq? cmp 'dont-care) - `[] - `[#:cmp (quote #,cmp)]) - ,@(if (eq? kind 'dont-care) - `[] - `[#:kind (quote #,kind)]))) - (rename-contract c name)) + (cond + [(chaperone-contract? elem/c) + (chaperone-set-contract elem/c cmp kind)] + [else + (impersonator-set-contract elem/c cmp kind)])) -(define (rename-contract c name) - (define make - (cond - [(flat-contract? c) make-flat-contract] - [(chaperone-contract? c) make-chaperone-contract] - [else make-contract])) - (make - #:name name - #:first-order (contract-first-order c) - #:projection +(struct set-contract [elem/c cmp kind]) + +(define (set-contract-name ctc) + (define elem/c (set-contract-elem/c ctc)) + (define cmp (set-contract-cmp ctc)) + (define kind (set-contract-kind ctc)) + `(set/c ,(contract-name elem/c) + ,@(if (eq? cmp 'dont-care) + `[] + `[#:cmp (quote #,cmp)]) + ,@(if (eq? kind 'dont-care) + `[] + `[#:kind (quote #,kind)]))) + +(define (set-contract-first-order ctc) + (define cmp (set-contract-cmp ctc)) + (define kind (set-contract-kind ctc)) + (define cmp? + (case cmp + [(dont-care) (lambda (x) #t)] + [(equal) set-equal?] + [(eqv) set-eqv?] + [(eq) set-eq?])) + (define kind? + (case kind + [(dont-care) (lambda (x) #t)] + [(mutable-or-weak) (lambda (x) (or (set-mutable? x) (set-weak? x)))] + [(mutable) set-mutable?] + [(weak) set-weak?] + [(immutable) set-immutable?])) + (lambda (x) + (and (set? x) (cmp? x) (kind? x)))) + +(define (set-contract-projection mode) + (lambda (ctc) + (define elem/c (set-contract-elem/c ctc)) + (define cmp (set-contract-cmp ctc)) + (define kind (set-contract-kind ctc)) (lambda (b) - ((contract-projection c) - (blame-add-context b #f))))) + (lambda (x) + (unless (set? x) + (raise-blame-error b x "expected a set")) + (case cmp + [(equal) + (unless (set-equal? x) + (raise-blame-error b x "expected an equal?-based set"))] + [(eqv) + (unless (set-equal? x) + (raise-blame-error b x "expected an eqv?-based set"))] + [(eq) + (unless (set-equal? x) + (raise-blame-error b x "expected an eq?-based set"))]) + (case kind + [(mutable-or-weak) + (unless (or (set-mutable? x) (set-weak? x)) + (raise-blame-error b x "expected a mutable or weak set"))] + [(mutable) + (unless (set-mutable? x) + (raise-blame-error b x "expected a mutable set"))] + [(weak) + (unless (set-mutable? x) + (raise-blame-error b x "expected a weak set"))] + [(immutable) + (unless (set-immutable? x) + (raise-blame-error b x "expected an immutable set"))]) + (cond + [(list? x) + (define proj + ((contract-projection elem/c) + (blame-add-context b "an element of"))) + (map proj x)] + [else + (define (method sym c) + (lambda (x) + (define name (contract-name c)) + (define str (format "method ~a with contract ~.s" sym name)) + (define b2 (blame-add-context b str)) + (((contract-projection c) b2) x))) + (define-syntax-rule (redirect [id expr] ...) + (redirect-generics mode gen:set x [id (method 'id expr)] ...)) + (redirect + [set-member? (-> set? elem/c boolean?)] + [set-empty? (or/c (-> set? boolean?) #f)] + [set-count (or/c (-> set? exact-nonnegative-integer?) #f)] + [set=? (or/c (-> set? ctc boolean?) #f)] + [subset? (or/c (-> set? ctc boolean?) #f)] + [proper-subset? (or/c (-> set? ctc boolean?) #f)] + [set-map (or/c (-> set? (-> elem/c any/c) list?) #f)] + [set-for-each (or/c (-> set? (-> elem/c any) void?) #f)] + [set-copy (or/c (-> set? ctc) #f)] + [in-set (or/c (-> set? sequence?) #f)] + [set->list (or/c (-> set? (listof elem/c)) #f)] + [set->stream (or/c (-> set? stream?) #f)] + [set-first (or/c (-> set? elem/c) #f)] + [set-rest (or/c (-> set? ctc) #f)] + [set-add (or/c (-> set? elem/c ctc) #f)] + [set-remove (or/c (-> set? elem/c ctc) #f)] + [set-clear (or/c (-> set? ctc) #f)] + [set-union + (or/c (->* [set?] [] #:rest (listof ctc) ctc) #f)] + [set-intersect + (or/c (->* [set?] [] #:rest (listof ctc) ctc) #f)] + [set-subtract + (or/c (->* [set?] [] #:rest (listof ctc) ctc) #f)] + [set-symmetric-difference + (or/c (->* [set?] [] #:rest (listof ctc) ctc) #f)] + [set-add! (or/c (-> set? elem/c void?) #f)] + [set-remove! (or/c (-> set? elem/c void?) #f)] + [set-clear! (or/c (-> set? void?) #f)] + [set-union! + (or/c (->* [set?] [] #:rest (listof ctc) void?) #f)] + [set-intersect! + (or/c (->* [set?] [] #:rest (listof ctc) void?) #f)] + [set-subtract! + (or/c (->* [set?] [] #:rest (listof ctc) void?) #f)] + [set-symmetric-difference! + (or/c (->* [set?] [] #:rest (listof ctc) void?) #f)])]))))) + +(struct chaperone-set-contract set-contract [] + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:name set-contract-name + #:first-order set-contract-first-order + #:projection (set-contract-projection #t))) + +(struct impersonator-set-contract set-contract [] + #:property prop:contract + (build-contract-property + #:name set-contract-name + #:first-order set-contract-first-order + #:projection (set-contract-projection #f))) diff --git a/racket/collects/racket/stream.rkt b/racket/collects/racket/stream.rkt index 993887ec54..3bf9d8d713 100644 --- a/racket/collects/racket/stream.rkt +++ b/racket/collects/racket/stream.rkt @@ -40,6 +40,8 @@ (define-syntax gen:stream (make-generic-info (quote-syntax prop:stream) + (quote-syntax stream-via-prop?) + (quote-syntax stream-get-generics) (list (quote-syntax stream-empty?) (quote-syntax stream-first) (quote-syntax stream-rest))))