diff --git a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt index df2d49c862..62dd570bb9 100644 --- a/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/generic/pr13737.rkt @@ -22,7 +22,7 @@ (define-primitive-generics (foo gen:foo prop:foo foo-methods foo? foo-supports?) - #:fast-defaults ([number? (define (meth foo #:kw kw) kw)]) + #:fast-defaults ([number? number? (define (meth foo #:kw kw) kw)]) #:defaults () #:fallbacks () #:derive-properties () diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index 6647d105a7..7bfd1e996b 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -33,20 +33,54 @@ (parse #'args (hash-set options 'table #'name)))] [(#:defined-table . other) (wrong-syntax (stx-car stx) "invalid #:defined-table specification")] - [(#:defaults ([pred defn ...] ...) . args) + [(#:defaults (clause ...) . args) (if (hash-ref options 'defaults #f) (wrong-syntax (stx-car stx) "duplicate #:defaults specification") - (parse #'args (hash-set options 'defaults #'([pred defn ...] ...))))] + (let loop ([defaults '()] + [defns (hash-ref options 'defns '())] + [clauses (reverse (syntax->list #'(clause ...)))]) + (if (pair? clauses) + (syntax-case (car clauses) () + [(pred #:dispatch disp defn ...) + (loop (cons #'[pred disp defn ...] defaults) + defns + (cdr clauses))] + [(pred defn ...) + (with-syntax ([name (generate-temporary #'pred)]) + (loop (cons #'[name name defn ...] defaults) + (cons #'(define name pred) defns) + (cdr clauses)))] + [clause + (wrong-syntax #'clause "invalid #:defaults specification")]) + (parse #'args + (hash-set* options 'defaults defaults 'defns defns)))))] [(#:defaults . other) (wrong-syntax (stx-car stx) "invalid #:defaults specification")] - [(#:fast-defaults ([pred defn ...] ...) . args) + [(#:fast-defaults (clause ...) . args) (if (hash-ref options 'fast-defaults #f) (wrong-syntax (stx-car stx) "duplicate #:fast-defaults specification") - (parse #'args - (hash-set options - 'fast-defaults - #'([pred defn ...] ...))))] + (let loop ([fast-defaults '()] + [defns (hash-ref options 'defns '())] + [clauses (reverse (syntax->list #'(clause ...)))]) + (if (pair? clauses) + (syntax-case (car clauses) () + [(pred #:dispatch disp defn ...) + (loop (cons #'[pred disp defn ...] fast-defaults) + defns + (cdr clauses))] + [(pred defn ...) + (with-syntax ([name (generate-temporary #'pred)]) + (loop (cons #'[name name defn ...] fast-defaults) + (cons #'(define name pred) defns) + (cdr clauses)))] + [clause + (wrong-syntax #'clause + "invalid #:fast-defaults specification")]) + (parse #'args + (hash-set* options + 'fast-defaults fast-defaults + 'defns defns)))))] [(#:fast-defaults . other) (wrong-syntax (stx-car stx) "invalid #:fast-defaults specification")] [(#:fallbacks [fallback ...] . args) @@ -77,6 +111,7 @@ (wrong-syntax #'other "expected a method identifier with formal arguments")] [() (values (hash-ref options 'methods '()) + (hash-ref options 'defns '()) (hash-ref options 'support generate-temporary) (hash-ref options 'table #f) (hash-ref options 'fast-defaults '()) @@ -93,8 +128,10 @@ (parameterize ([current-syntax-context stx]) (unless (identifier? #'name) (wrong-syntax #'name "expected an identifier")) - (define-values (methods support table fasts defaults fallbacks derived) + (define-values + (methods defns support table fasts defaults fallbacks derived) (parse #'rest)) + (define/with-syntax [defn ...] defns) (define/with-syntax [fast-default ...] fasts) (define/with-syntax [default ...] defaults) (define/with-syntax [fallback ...] fallbacks) @@ -119,6 +156,7 @@ (values sym (support-name name sym))))) #'(begin))) #'(begin + defn ... (define-primitive-generics/derived original (name gen-name prop-name get-name pred-name support-name) diff --git a/racket/collects/racket/private/dict.rkt b/racket/collects/racket/private/dict.rkt index a8e675977f..678c8abdb4 100644 --- a/racket/collects/racket/private/dict.rkt +++ b/racket/collects/racket/private/dict.rkt @@ -52,6 +52,8 @@ (define no-arg (gensym)) (define (assoc-ref d key [default no-arg]) + (unless (assoc? d) + (raise-argument-error 'dict-ref "dict?" d)) (cond [(assoc key d) => cdr] [(eq? default no-arg) @@ -79,6 +81,8 @@ (loop (cddr pairs))))) (define (assoc-set d key val) + (unless (assoc? d) + (raise-argument-error 'dict-set "dict?" d)) (let loop ([xd d]) (cond [(null? xd) (list (cons key val))] @@ -113,6 +117,8 @@ (dict-set d key (xform (dict-ref d key default)))])) (define (assoc-remove d key) + (unless (assoc? d) + (raise-argument-error 'dict-remove "dict?" d)) (let loop ([xd d]) (cond [(null? xd) null] @@ -144,43 +150,59 @@ (define vector-iterate-value vector-ref) +(define (assoc-count d) + (unless (assoc? d) + (raise-argument-error 'dict-count "dict?" d)) + (length d)) + (struct assoc-iter (head pos)) (define (assoc-iterate-first d) + (unless (assoc? d) + (raise-argument-error 'dict-iterate-first "dict?" d)) (if (null? d) #f (assoc-iter d d))) (define (assoc-iterate-next d i) - (if (and (assoc-iter? i) - (eq? d (assoc-iter-head i))) - (let ([pos (cdr (assoc-iter-pos i))]) - (if (null? pos) - #f - (assoc-iter d pos))) - (raise-mismatch-error - 'dict-iterate-next - "invalid iteration position for association list: " - i))) + (cond + [(and (assoc-iter? i) + (eq? d (assoc-iter-head i))) + (let ([pos (cdr (assoc-iter-pos i))]) + (if (null? pos) + #f + (assoc-iter d pos)))] + [(assoc? d) + (raise-mismatch-error + 'dict-iterate-next + "invalid iteration position for association list: " + i)] + [else (raise-argument-error 'dict-iterate-next "dict?" d)])) (define (assoc-iterate-key d i) - (if (and (assoc-iter? i) (eq? d (assoc-iter-head i))) - (caar (assoc-iter-pos i)) - (raise-mismatch-error - 'dict-iterate-key - "invalid iteration position for association list: " - i))) + (cond + [(and (assoc-iter? i) (eq? d (assoc-iter-head i))) + (caar (assoc-iter-pos i))] + [(assoc? d) + (raise-mismatch-error + 'dict-iterate-key + "invalid iteration position for association list: " + i)] + [else (raise-argument-error 'dict-iterate-key "dict?" d)])) (define (assoc-iterate-value d i) - (if (and (assoc-iter? i) (eq? d (assoc-iter-head i))) - (cdar (assoc-iter-pos i)) - (raise-mismatch-error - 'dict-iterate-value - "invalid iteration position for association list: " - i))) + (cond + [(and (assoc-iter? i) (eq? d (assoc-iter-head i))) + (cdar (assoc-iter-pos i))] + [(assoc? d) + (raise-mismatch-error + 'dict-iterate-value + "invalid iteration position for association list: " + i)] + [else (raise-argument-error 'dict-iterate-value "dict?" d)])) (define-primitive-generics (dict gen:dict prop:gen:dict prop:gen:dict-methods dict? dict-supports?) #:fast-defaults - ([mutable-hash? + ([mutable-hash? mutable-hash? (define dict-ref hash-ref) (define dict-set! hash-set!) (define dict-remove! hash-remove!) @@ -189,7 +211,7 @@ (define dict-iterate-next hash-iterate-next) (define dict-iterate-key hash-iterate-key) (define dict-iterate-value hash-iterate-value)] - [immutable-hash? + [immutable-hash? immutable-hash? (define dict-ref hash-ref) (define dict-set hash-set) (define dict-remove hash-remove) @@ -198,7 +220,7 @@ (define dict-iterate-next hash-iterate-next) (define dict-iterate-key hash-iterate-key) (define dict-iterate-value hash-iterate-value)] - [mutable-vector? + [mutable-vector? mutable-vector? (define dict-ref vector-ref-as-dict) (define dict-set! vector-set!) (define dict-count vector-length) @@ -206,18 +228,18 @@ (define dict-iterate-next vector-iterate-next) (define dict-iterate-key vector-iterate-key) (define dict-iterate-value vector-iterate-value)] - [immutable-vector? + [immutable-vector? immutable-vector? (define dict-ref vector-ref-as-dict) (define dict-count vector-length) (define dict-iterate-first vector-iterate-first) (define dict-iterate-next vector-iterate-next) (define dict-iterate-key vector-iterate-key) (define dict-iterate-value vector-iterate-value)] - [assoc? + [assoc? list? (define dict-ref assoc-ref) (define dict-set assoc-set) (define dict-remove assoc-remove) - (define dict-count length) + (define dict-count assoc-count) (define dict-iterate-first assoc-iterate-first) (define dict-iterate-next assoc-iterate-next) (define dict-iterate-key assoc-iterate-key) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index 0cf6de3f3a..17d47ddfca 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -34,8 +34,8 @@ accessor-name predicate-name supported-name) - #:fast-defaults ([fast-pred fast-defn ...] ...) - #:defaults ([default-pred default-defn ...] ...) + #:fast-defaults ([fast-pred fast-disp fast-defn ...] ...) + #:defaults ([default-pred default-disp default-defn ...] ...) #:fallbacks [fallback-defn ...] #:derive-properties ([derived-prop derived-impl] ...) [method-name . method-signature] @@ -67,10 +67,14 @@ (define/with-syntax [method-index ...] method-indices) (define/with-syntax contract-str (format "~s" (syntax-e #'predicate-name))) - (define/with-syntax (default-pred-name ...) - (generate-temporaries default-preds)) (define/with-syntax (fast-pred-name ...) (generate-temporaries fast-preds)) + (define/with-syntax (fast-disp-name ...) + (generate-temporaries #'(fast-disp ...))) + (define/with-syntax (default-pred-name ...) + (generate-temporaries default-preds)) + (define/with-syntax (default-disp-name ...) + (generate-temporaries #'(default-disp ...))) (define/with-syntax ([fast-by-method ...] ...) fasts-by-method) (define/with-syntax ([fast-by-type ...] ...) fasts-by-type) (define/with-syntax ([default-by-method ...] ...) defaults-by-method) @@ -79,7 +83,9 @@ (define/with-syntax forward-declaration (if (eq? (syntax-local-context) 'top-level) #'(define-syntaxes (fast-pred-name ... + fast-disp-name ... default-pred-name ... + default-disp-name ... fast-by-method ... ... default-by-method ... ... fallback ...) @@ -115,10 +121,10 @@ ...) #t)) forward-declaration - (define fast-pred-name fast-pred) - ... - (define default-pred-name default-pred) - ... + (define fast-pred-name fast-pred) ... + (define fast-disp-name fast-disp) ... + (define default-pred-name default-pred) ... + (define default-disp-name default-disp) ... (define (predicate-name self-name) (or (fast-pred-name self-name) ... @@ -161,11 +167,11 @@ method-signature self-name (or (cond - [(fast-pred-name self-name) fast-by-method] + [(fast-disp-name self-name) fast-by-method] ... [(prop:pred self-name) (vector-ref (accessor-name self-name) 'method-index)] - [(default-pred-name self-name) default-by-method] + [(default-disp-name self-name) default-by-method] ... [else (raise-argument-error 'method-name 'contract-str