diff --git a/collects/mzlib/private/class-internal.ss b/collects/mzlib/private/class-internal.ss index 30c8382013..6163bba853 100644 --- a/collects/mzlib/private/class-internal.ss +++ b/collects/mzlib/private/class-internal.ss @@ -3089,6 +3089,43 @@ ;; ;; mixin ;; + + (define (check-mixin-super mixin-name super% from-ids) + (let ([mixin-name (or mixin-name 'mixin)]) + (unless (class? super%) + (error mixin-name "argument is not a class: ~e" super%)) + (for-each (lambda (from-id) + (unless (implementation? super% from-id) + (error mixin-name "argument does not implement ~e: ~e" from-id super%))) + from-ids))) + + (define (check-mixin-from-interfaces all-from) + (for-each (lambda (from-id) + (unless (interface? from-id) + (error 'mixin + "expected from-interface, got: ~e; others ~e" + from-id + all-from))) + all-from)) + + (define (check-mixin-to-interfaces all-to) + (for-each (lambda (to-id) + (unless (interface? to-id) + (error 'mixin + "expected to-interface, got: ~e; others ~e" + to-id + all-to))) + all-to)) + + + (define (check-interface-includes xs from-ids) + (for-each + (lambda (x) + (unless (ormap (lambda (i) (method-in-interface? x i)) from-ids) + (error 'mixin + "method `~a' was referenced in definition, but is not in any of the from-interfaces: ~e" + x from-ids))) + xs)) (define-syntax (mixin stx) (syntax-case stx () @@ -3148,43 +3185,17 @@ (with-syntax ([mixin-expr (syntax/loc stx (λ (super%) - (unless (class? super%) - (error mixin-name "argument ~a not a class" super%)) - (unless (implementation? super% from-ids) - (error mixin-name "argument ~s does not implement ~s" super% from-ids)) - ... + (check-mixin-super mixin-name super% (list from-ids ...)) class-expr))]) ;; Finally, build the complete mixin expression: (syntax/loc stx (let ([from-ids from] ...) (let ([to-ids to] ...) - - (let ([all-from (list from-ids ...)]) - (void) - (unless (interface? from-ids) - (error 'mixin - "expected interfaces for from, got: ~e, others ~e" - from-ids - all-from)) ...) - - (let ([all-to (list to-ids ...)]) - (void) - (unless (interface? to-ids) - (error 'mixin - "expected interfaces for to, got: ~e, others ~e" - to-ids - all-to)) ...) - - (let ([ensure-interface-has? - (λ (x) - (unless (or (method-in-interface? x from-ids) ...) - (error 'mixin - "method `~a' not in any of ~a, but was referenced in definition" - x (list from-ids ...))))]) - (void) - (ensure-interface-has? (quote super-vars)) ...) - + (check-mixin-from-interfaces (list from-ids ...)) + (check-mixin-to-interfaces (list to-ids ...)) + (check-interface-includes (list (quote super-vars) ...) + (list from-ids ...)) mixin-expr)))))))])) (define externalizable<%> diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index 036b73f5db..ed36b094e5 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -73,6 +73,69 @@ add struct contracts for immutable structs? ; ; ; + + (define-for-syntax (make-define/contract-transformer contract-id id) + (make-set!-transformer + (lambda (stx) + (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! _ arg) + (raise-syntax-error 'define/contract + "cannot set! a define/contract variable" + stx + (syntax _))] + [(_ arg ...) + (syntax/loc stx + ((-contract contract-id + id + (syntax-object->datum (quote-syntax _)) + (string->symbol neg-blame-str) + (quote-syntax _)) + arg + ...))] + [_ + (identifier? (syntax _)) + (syntax/loc stx + (-contract contract-id + id + (syntax-object->datum (quote-syntax _)) + (string->symbol neg-blame-str) + (quote-syntax _)))]))))) + + (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) + (make-set!-transformer + (lambda (stx) + (with-syntax ([neg-stx (datum->syntax-object stx 'here)] + [contract-id contract-id] + [id id] + [pos-module-source pos-module-source]) + (syntax-case stx (set!) + [(set! _ body) (raise-syntax-error + #f + "cannot set! provide/contract identifier" + stx + (syntax _))] + [(_ arg ...) + (syntax + ((begin-lifted + (-contract contract-id + id + pos-module-source + (module-source-as-symbol #'neg-stx) + (quote-syntax _))) + arg + ...))] + [_ + (identifier? (syntax _)) + (syntax + (begin-lifted + (-contract contract-id + id + pos-module-source + (module-source-as-symbol #'neg-stx) + (quote-syntax _))))]))))) ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding @@ -81,8 +144,7 @@ add struct contracts for immutable structs? (syntax-case define-stx () [(_ name contract-expr expr) (identifier? (syntax name)) - (with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)] - [contract-id + (with-syntax ([contract-id (a:mangle-id define-stx "define/contract-contract-id" (syntax name))] @@ -93,32 +155,8 @@ add struct contracts for immutable structs? (begin (define contract-id contract-expr) (define-syntax name - (make-set!-transformer - (lambda (stx) - (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")]) - (syntax-case stx (set!) - [(set! _ arg) - (raise-syntax-error 'define/contract - "cannot set! a define/contract variable" - stx - (syntax _))] - [(_ arg (... ...)) - (syntax/loc stx - ((-contract contract-id - id - (syntax-object->datum (quote-syntax _)) - (string->symbol neg-blame-str) - (quote-syntax _)) - arg - (... ...)))] - [_ - (identifier? (syntax _)) - (syntax/loc stx - (-contract contract-id - id - (syntax-object->datum (quote-syntax _)) - (string->symbol neg-blame-str) - (quote-syntax _)))]))))) + (make-define/contract-transformer (quote-syntax contract-id) + (quote-syntax id))) (define id (let ([name expr]) name)) ;; let for procedure naming )))] [(_ name contract-expr expr) @@ -556,34 +594,9 @@ add struct contracts for immutable structs? (define pos-module-source (module-source-as-symbol #'pos-stx)) (define contract-id (let ([id ctrct]) id)) (define-syntax id-rename - (make-set!-transformer - (lambda (stx) - (with-syntax ([neg-stx (datum->syntax-object stx 'here)]) - (syntax-case stx (set!) - [(set! _ body) (raise-syntax-error - #f - "cannot set! provide/contract identifier" - stx - (syntax _))] - [(_ arg (... ...)) - (syntax - ((begin-lifted - (-contract contract-id - id - pos-module-source - (module-source-as-symbol #'neg-stx) - (quote-syntax _))) - arg - (... ...)))] - [_ - (identifier? (syntax _)) - (syntax - (begin-lifted - (-contract contract-id - id - pos-module-source - (module-source-as-symbol #'neg-stx) - (quote-syntax _))))])))))))]) + (make-provide/contract-transformer (quote-syntax contract-id) + (quote-syntax id) + (quote-syntax pos-module-source)))))]) (syntax (code id-rename))))) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])