diff --git a/collects/mzlib/class-traced.ss b/collects/mzlib/class-traced.ss index 7cb78b6a4a..1df7866662 100644 --- a/collects/mzlib/class-traced.ss +++ b/collects/mzlib/class-traced.ss @@ -2,7 +2,7 @@ ;; All of the implementation is actually in private/class-internal.ss, ;; which provides extra (private) functionality to contract.ss. - (require "private/class-internal.ss") + (require (lib "private/class-internal.ss" "scheme")) (provide (rename class-traced class) (rename class*-traced class*) diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index 536df91025..c2768f4c64 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -1,44 +1,3 @@ (module class mzscheme - - ;; All of the implementation is actually in private/class-internal.ss, - ;; which provides extra (private) functionality to contract.ss. - (require "private/class-internal.ss") - - (provide class class* class/derived - define-serializable-class define-serializable-class* - class? - mixin - interface interface? - object% object? externalizable<%> - object=? - new make-object instantiate - send send/apply send* class-field-accessor class-field-mutator with-method - get-field field-bound? field-names - private* public* pubment* - override* overment* - augride* augment* - public-final* override-final* augment-final* - define/private define/public define/pubment - define/override define/overment - define/augride define/augment - define/public-final define/override-final define/augment-final - define-local-member-name define-member-name - member-name-key generate-member-key - member-name-key? member-name-key=? member-name-key-hash-code - generic make-generic send-generic - is-a? subclass? implementation? interface-extension? - object-interface object-info object->vector - object-method-arity-includes? - method-in-interface? interface->method-names class->interface class-info - (struct exn:fail:object ()) - make-primitive-class - - ;; "keywords": - private public override augment - pubment overment augride - public-final override-final augment-final - field init init-field init-rest - rename-super rename-inner inherit inherit/super inherit/inner inherit-field - this super inner - super-make-object super-instantiate super-new - inspect)) + (require scheme/private/class-internal) + (provide-public-names)) \ No newline at end of file diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index d92bc622ee..d43e465112 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -1,180 +1,10 @@ +#lang scheme/base +(require scheme/contract) +(provide (all-from-out scheme/contract)) -(module contract mzscheme +;; provide contracts for objects +(require scheme/private/contract-object) +(provide (all-from-out scheme/private/contract-object)) + - ;; povide contracts for objects - (require "private/contract-object.ss") - (provide (all-from "private/contract-object.ss")) - - (require "private/contract.ss" - "private/contract-arrow.ss" - "private/contract-guts.ss" - "private/contract-ds.ss" - "private/contract-opt-guts.ss" - "private/contract-opt.ss" - "private/contract-basic-opters.ss") - - (provide - opt/c define-opt/c ;(all-from "private/contract-opt.ss") - (all-from-except "private/contract-ds.ss" - lazy-depth-to-look) - (all-from-except "private/contract-arrow.ss" - check-procedure) - (all-from-except "private/contract.ss" - check-between/c - check-unary-between/c)) - - ;; from contract-guts.ss - - (provide any - and/c - any/c - none/c - make-none/c - - guilty-party - contract-violation->string - - contract? - contract-name - contract-proc - - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - - contract-first-order-passes? - - ;; below need docs - - make-proj-contract - - contract-stronger? - - coerce-contract - flat-contract/predicate? - - build-compound-type-name - raise-contract-error - - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - first-order-prop first-order-get)) - - -;; ====================================================================== -;; The alternate implementation disables contracts. Its useful mainly to -;; measure the cost of contracts. It's not necessarily complete, but it -;; works well enough for starting DrScheme. - -#; -(module contract mzscheme - - (define-syntax provide/contract - (syntax-rules () - [(_ elem ...) - (begin (provide-one elem) ...)])) - - (define-syntax provide-one - (syntax-rules (struct rename) - [(_ (struct (id par-id) ([field . rest] ...))) - (provide-struct id par-id (field ...))] - [(_ (struct id ([field . rest] ...))) - (provide (struct id (field ...)))] - [(_ (rename id1 id2 c)) - (provide (rename id1 id2))] - [(_ (id c)) - (provide id)])) - - (define-syntax (provide-struct stx) - (syntax-case stx () - [(_ id par-id . rest) - (let ([info (syntax-local-value #'id (lambda () #f))] - [p-info (syntax-local-value #'par-id (lambda () #f))] - [prefix (lambda (l n) - (let loop ([l l][len (length l)]) - (if (= n len) - null - (cons (car l) (loop (cdr l) - (- len 1))))))] - [ids (lambda (l) (let loop ([l l]) - (cond - [(null? l) null] - [(car l) (cons (car l) (loop (cdr l)))] - [else (loop (cdr l))])))]) - (if (and info - p-info - (list? info) - (list? p-info) - (= (length info) 6) - (= (length p-info) 6)) - #`(provide #,@(append - (list #'id - (list-ref info 0) - (list-ref info 1) - (list-ref info 2)) - (ids (prefix (list-ref info 3) (length (list-ref p-info 3)))) - (ids (prefix (list-ref info 4) (length (list-ref p-info 4)))))) - (raise-syntax-error - #f - (cond - [(not info) "cannot find struct info"] - [(not p-info) "cannot find parent-struct info"] - [else (format "struct or parent-struct info has unexpected shape: ~e and ~e" - info p-info)]) - #'id)))])) - - (define-syntax define-contract-struct - (syntax-rules () - [(_ . rest) (define-struct . rest)])) - - (define-syntax define/contract - (syntax-rules () - [(_ id c expr) (define id expr)])) - - (define-syntax contract - (syntax-rules () - [(_ c expr . rest) expr])) - - (provide provide/contract - define-contract-struct - define/contract - contract) - - (define mk* - (lambda args (lambda (x) x))) - - (define-syntax mk - (syntax-rules () - [(_ id) (begin - (define-syntax (id stx) (quote-syntax mk*)) - (provide id))] - [(_ id ...) - (begin (mk id) ...)])) - - (mk -> - ->* - opt-> - case-> - ->r - or/c - and/c - any/c - flat-named-contract - flat-contract - flat-contract-predicate - object-contract - union - listof - is-a?/c) - - (define-syntax symbols - (syntax-rules () - [(_ sym ...) - (lambda (v) (memq v '(sym ...)))])) - (provide symbols) - - ) diff --git a/collects/mzlib/serialize.ss b/collects/mzlib/serialize.ss index 8da9809503..545e6deea0 100644 --- a/collects/mzlib/serialize.ss +++ b/collects/mzlib/serialize.ss @@ -4,13 +4,13 @@ (lib "etc.ss") (lib "list.ss") ;; core [de]serializer: - "private/serialize.ss") + (lib "private/serialize.ss" "scheme")) (provide define-serializable-struct define-serializable-struct/versions ;; core [de]serializer: - (all-from "private/serialize.ss")) + (all-from (lib "private/serialize.ss" "scheme"))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; define-serializable-struct diff --git a/collects/mzlib/trait.ss b/collects/mzlib/trait.ss index b3902ffc17..00881507ca 100644 --- a/collects/mzlib/trait.ss +++ b/collects/mzlib/trait.ss @@ -1,729 +1,3 @@ -(module trait mzscheme - (require (lib "class.ss") - (lib "list.ss") - (lib "struct.ss")) - (require-for-syntax (lib "list.ss") - (lib "stx.ss" "syntax") - (lib "boundmap.ss" "syntax") - (lib "kerncase.ss" "syntax") - ;; This should be part of a public expand-time API - ;; exported by the class system: - (only (lib "classidmap.ss" "mzlib" "private") - generate-class-expand-context)) - - (provide (rename :trait trait) - trait? - trait->mixin - trait-sum - trait-exclude trait-exclude-field - trait-alias - trait-rename trait-rename-field) - - ;; A trait is a list of supplied methods. - ;; Each supplied method is: - ;; * an external name - ;; * supplies inherit? - ;; * supplies super? - ;; * supplies inner? - ;; * overrides? - ;; * augments? - ;; * list of required methods (external names) for inherit - ;; * list of required methods (external names) for super - ;; * list of required methods (external names) for inner - ;; * list of required methods (external names) for inherit-fields - ;; * a mixin patameterized by all external names - ;; * an indrection mixin for supers - - (define-struct trait (methods fields)) - - (define-struct method (name inherit? super? inner? - override? augment? - need-inherit need-super need-inner need-field - make-mixin - make-super-indirection-mixin)) - - (define-struct feeld (name make-mixin)) - - (define-syntax (:trait stx) - ;; The main compiler (helpers are below): - (define (main stx) - (syntax-case stx () - [(_ clause ...) - (let* ([clauses (syntax->list #'(clause ...))] - [expanded-clauses (expand-body clauses)]) - ;; Pull out declared names: - (let-values ([(publics pubments - overrides augments augrides overments - inherits inherits/super inherits/inner - inherit-fields) - (extract expanded-clauses - (map syntax->list - (syntax->list - #'((public public-final) - (pubment) - (override override-final) - (augment augment-final) - (augride) - (overment) - (inherit) (inherit/super) (inherit/inner) - (inherit-field)))))] - [(fields) - (extract-fields expanded-clauses)]) - ;; Every declaration implies direct use for other declarations: - (let* ([to-inherit - (append publics pubments - overrides augments augrides overments - inherits inherits/super inherits/inner)] - [to-inherit-fields - (append fields inherit-fields)] - [decls - (append to-inherit-fields to-inherit)]) - ;; Check distinct delcarations: - (check-distinct-external-names to-inherit) - (check-distinct-external-names to-inherit-fields) - (check-distinct-internal-names decls) - - ;; Some declarations imply use via `super' or `inner': - (let ([to-super (append overrides inherits/super)] - [to-inner (append augments pubments inherits/inner)]) - - (let ([to-inherit-only - (filter (lambda (n) - (not (or (ormap (lambda (n2) (internal-identifier=? n n2)) - to-super) - (ormap (lambda (n2) (internal-identifier=? n n2)) - to-inner)))) - to-inherit)]) - - ;; Current method-making function with respect to the - ;; common part: - (let* ([bindings (make-bindings expanded-clauses)] - [compose-method (compose-method-with-requirements - bindings - to-inherit-only to-super to-inner - to-inherit-fields)]) - - ;; Build a mixin and `method' record for each declaration: - (with-syntax ([(method ...) - (append - (map (compose-method #'override #t #f #f #f #f #f) publics) - (map (compose-method #'overment #t #t #f #f #f #f) pubments) - (map (compose-method #'override #t #t #f #t #f #f) overrides) - (map (compose-method #'overment #t #f #f #t #f #t) overments) - (map (compose-method #'augment #t #f #t #f #t #f) augments) - (map (compose-method #'augride #t #f #f #f #t #f) augrides))] - [(field ...) - (map (compose-field bindings) fields)]) - - (bound-identifier-mapping-for-each - bindings - (lambda (key val) - (when val - (raise-syntax-error - #f - "definition has no corresponding declaration (e.g., public)" - stx - key)))) - - ;; Combine the result into a trait: - #'(make-trait (list method ...) - (list field ...)))))))))])) - - (define (expand-body clauses) - ;; For now, we expand naively: no support for internal define-syntax, - ;; and no shadowing of syntax with method definitions. - (let ([stop-forms - (append - (syntax->list - #'(private - public public-final pubment - override override-final augment augment-final augride overment - inherit inherit/super inherit/inner - this super inner - field inherit-field)) - (kernel-form-identifier-list))] - [expand-context (generate-class-expand-context)]) - (let loop ([l clauses]) - (cond - [(null? l) null] - [else (let ([e (local-expand (car l) - expand-context - stop-forms)]) - (syntax-case e (begin define-values) - [(begin expr ...) - (loop (append - (syntax->list (syntax (expr ...))) - (cdr l)))] - [(define-values (id) rhs) - (cons e (loop (cdr l)))] - [(field (id expr) ...) - (if (andmap (lambda (id) - (or (identifier? id) - (syntax-case id () - [(a b) - (and (identifier? #'a) - (identifier? #'b))] - [_else #f]))) - (syntax->list #'(id ...))) - (cons e (loop (cdr l))) - (raise-syntax-error - #f - "bad syntax" - e))] - [(id . rest) - (ormap (lambda (x) (module-identifier=? x #'id)) - (syntax->list - #'(public public-final pubment - override override-final augment augment-final augride overment - inherit inherit/super inherit/inner - inherit-field))) - (let ([l2 (syntax->list #'rest)]) - (if (and l2 - (andmap (lambda (i) - (or (identifier? i) - (syntax-case i () - [(a b) - (and (identifier? #'a) - (identifier? #'b))] - [_else #f]))) - l2)) - (cons e (loop (cdr l))) - (raise-syntax-error - #f - "bad syntax (inside trait)" - e)))] - [(define-values . _) - (raise-syntax-error - #f - "bad syntax" - e)] - [(field . _) - (raise-syntax-error - #f - "bad syntax" - e)] - [else - (raise-syntax-error - #f - "not allowed in a trait" - e)]))])))) - - (define (extract expanded-clauses keyword-mapping) - (let loop ([l expanded-clauses] - [results (map (lambda (x) null) keyword-mapping)]) - (cond - [(null? l) (apply values results)] - [else - (let ([kw (stx-car (car l))]) - (if (or (module-identifier=? kw #'define-values) - (module-identifier=? kw #'field)) - (loop (cdr l) results) - (loop (cdr l) - (let iloop ([mapping keyword-mapping] - [results results]) - (if (ormap (lambda (x) (module-identifier=? kw x)) - (car mapping)) - (cons (append (stx->list (stx-cdr (car l))) - (car results)) - (cdr results)) - (cons (car results) - (iloop (cdr mapping) - (cdr results))))))))]))) - - (define (extract-fields expanded-clauses) - (apply - append - (map (lambda (clause) - (syntax-case clause (field) - [(field [id expr] ...) - (syntax->list #'(id ...))] - [_else null])) - expanded-clauses))) - - (define (make-bindings expanded-clauses) - (let ([boundmap (make-bound-identifier-mapping)]) - (for-each (lambda (clause) - (syntax-case clause (define-values field) - [(define-values (id) rhs) - (bound-identifier-mapping-put! boundmap #'id #'rhs)] - [(field [id expr] ...) - (for-each (lambda (id expr) - (bound-identifier-mapping-put! boundmap (internal-name id) expr)) - (syntax->list #'(id ...)) - (syntax->list #'(expr ...)))] - [_else (void)])) - expanded-clauses) - boundmap)) - - (define (internal-identifier=? a b) - (bound-identifier=? (internal-name a) (internal-name b))) - - (define (internal-name decl) - (if (identifier? decl) - decl - (stx-car decl))) - - (define (external-name decl) - (if (identifier? decl) - decl - (stx-car (stx-cdr decl)))) - - (define (check-distinct-names method-decls - what which - make-identifier-mapping - identifier-mapping-get - identifier-mapping-set!) - (let ([idmap (make-identifier-mapping)]) - (for-each (lambda (decl) - (let ([ext-id (which decl)]) - (when (identifier-mapping-get - idmap ext-id - (lambda () - (identifier-mapping-set! - idmap ext-id - #t) - #f)) - (raise-syntax-error - #f - (format "duplicate definition of ~a name in trait" - what) - ext-id)))) - method-decls))) - - (define (check-distinct-external-names method-decls) - (check-distinct-names method-decls - "external" external-name - make-module-identifier-mapping - module-identifier-mapping-get - module-identifier-mapping-put!)) - - (define (check-distinct-internal-names method-decls) - (check-distinct-names method-decls - "internal" internal-name - make-bound-identifier-mapping - bound-identifier-mapping-get - bound-identifier-mapping-put!)) - - (define (((compose-method-with-requirements binding-map - to-inherit to-super to-inner - to-inherit-field) - keyword inherit? super? inner? override? augment? always-deep?) - name) - (let ([impl (bound-identifier-mapping-get binding-map (internal-name name))] - [to-inherit (if always-deep? - (filter (lambda (n) (not (internal-identifier=? n name))) - to-inherit) - to-inherit)]) - (with-syntax ([(to-inherit ...) to-inherit] - [(to-super ...) to-super] - [(to-inner ...) to-inner] - [(to-inherit-field ...) to-inherit-field] - [(to-inherit-ext ...) (map external-name to-inherit)] - [(to-super-ext ...) (map external-name to-super)] - [(to-inner-ext ...) (map external-name to-inner)] - [(to-inherit-field-ext ...) (map external-name to-inherit-field)] - [(to-inherit-arg ...) (generate-temporaries to-inherit)] - [(to-super-arg ...) (generate-temporaries to-super)] - [(to-inner-arg ...) (generate-temporaries to-inner)] - [(to-inherit-field-arg ...) (generate-temporaries to-inherit-field)] - [impl impl] - [declare keyword] - [this-method (if always-deep? - name - #'this-method)] - [wrap-super-indirect (if override? - #'values - #'omit)] - [wrap-inner-indirect (if augment? - #'values - #'omit)]) - ;; for tracking unused bindings at the end: - (bound-identifier-mapping-put! binding-map (internal-name name) #f) - ;; generate method: - #`(make-method - (member-name-key #,(external-name name)) - #,inherit? #,super? #,inner? #,override? #,augment? - (list (member-name-key to-inherit-ext) ...) - (list (member-name-key to-super-ext) ...) - (list (member-name-key to-inner-ext) ...) - (list (member-name-key to-inherit-field-ext) ...) - (lambda (this-method-arg to-inherit-arg ... - to-super-arg ... - to-inner-arg ... - to-inherit-field-arg ...) - (define-member-name this-method this-method-arg) - (define-member-name to-inherit-ext to-inherit-arg) ... - (define-member-name to-super-ext to-super-arg) ... - (define-member-name to-inner-ext to-inner-arg) ... - (define-member-name to-inherit-field-ext to-inherit-field-arg) ... - (lambda (%) - (class % - (inherit to-inherit ...) - (inherit/super to-super ...) - (inherit/inner to-inner ...) - (inherit-field to-inherit-field ...) - (declare this-method) - (define this-method (let ([#,(internal-name name) impl]) - #,(internal-name name))) - (super-new)))) - ;; For `super' call indirections: - (wrap-super-indirect - (lambda (name-arg super-name-arg) - (define-member-name name name-arg) - (define-member-name super-name super-name-arg) - (lambda (%) - (class % - (override name) - (inherit/super super-name) - (define name (similar-lambda impl (super super-name))) - (super-new))))))))) - - (define ((compose-field binding-map) name) - (let ([impl (bound-identifier-mapping-get binding-map (internal-name name))]) - ;; for tracking unused bindings at the end: - (bound-identifier-mapping-put! binding-map (internal-name name) #f) - ;; generate method: - #`(make-feeld - (member-name-key #,(external-name name)) - (lambda (name-arg) - (define-member-name #,(external-name name) name-arg) - (lambda (%) - (class % - (field [#,name #,impl]) - (super-new))))))) - - (main stx)) - - (define-syntax (similar-lambda stx) - ;; Try to get arity the same: - (syntax-case stx (lambda) - [(_ (lambda (id ...) . __) (new-body ...)) - #'(lambda (id ...) (new-body ... id ...))] - ;; Generic case: - [(_ method-lambda (new-body ...)) - #'(lambda args (new-body ... . args))])) - - (define-syntax (omit stx) #'#f) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; trait->mixin - - (define (trait->mixin t) - (let ([methods (trait-methods t)]) - - ;; If a needed inherit, super, or inner is not immediately satisified, - ;; we can just leave it to the superclass. - ;; But we can't expect a super and have it introduced as non-overriding. - ;; We need to check in trait-sum, trait-alias, etc., because we'll - ;; have to use dummy introductions when stacking up the mixins, and - ;; there might be no error otherwise. - - ;; Order the mixins. If M1 super-calls M2 and we have an override - ;; for M2, then try to mix M2 later. Similarly, if M1 inner-calls M2 - ;; and we have an augment for M2, try to mix M2 earlier. - ;; We'll have to break cycles by inserting indirections, but we can't - ;; do that for `inner'; consequently, an `inner' from M1 to M2 - ;; might land at an implementation in the same trait! - ;; For simplicty, we sort right now by just all augments first - ;; and all overrides last. In the common case where methods - ;; only self-call supers and inners, that will work fine. - (let loop ([methods (sort methods - (lambda (a b) - (or (method-augment? a) - (method-override? b))))] - ;; Start by adding mixins for fields. Then continue - ;; by mixing a dummy method for each public/pubment - ;; method. We'll override it, but having it here at the start - ;; means that the methods can refer to each other via - ;; `inherit'. - [mixin (let loop ([methods methods] - [mixin (let loop ([mixin (lambda (%) %)] - [fields (trait-fields t)]) - (cond - [(null? fields) mixin] - [else (let ([mix ((feeld-make-mixin (car fields)) - (feeld-name (car fields)))]) - (loop (lambda (%) (mix (mixin %))) - (cdr fields)))]))]) - (cond - [(null? methods) mixin] - [else (let ([method (car methods)]) - (loop (cdr methods) - (if (or (method-override? method) - (method-augment? method)) - mixin - (introduce-into-mixin - (method-name method) - mixin))))]))] - [super-indirections null]) - (cond - [(null? methods) - ;; No more methods to add, so just insert needed - ;; super indirections (as accumulated when adding - ;; methods before): - (let loop ([indirections super-indirections] - [mixin mixin]) - (cond - [(null? indirections) mixin] - [else (let ([method (list-ref (car indirections) 2)]) - (loop (cdr indirections) - (let ([mix ((method-make-super-indirection-mixin method) - (method-name method) - (cadar indirections))]) - (lambda (%) (mix (mixin %))))))]))] - [else - ;; Add one method: - (let*-values ([(method) (car methods)] - ;; Rename method, in case we need a super - ;; indirection: - [(name) - (if (and (method-override? method) - (ormap (lambda (m) - (ormap (lambda (n) - (same-name? n (method-name method))) - (method-need-super m))) - (cdr methods))) - (generate-member-key) - (method-name method))] - ;; Build the base mixin: - [(next-mixin) (apply - (method-make-mixin method) - name - (append - (method-need-inherit method) - (method-need-super method) - (method-need-inner method) - (method-need-field method)))]) - (loop (cdr methods) - (lambda (%) (next-mixin (mixin %))) - (if (eq? name (method-name method)) - super-indirections - (cons (list (method-name method) - name - method) - super-indirections))))])))) - - (define (introduce-into-mixin name mixin) - (define-member-name m name) - (lambda (%) - (class (mixin %) - (define/public (m) 'inroduce-stub) - (super-new)))) - - (define same-name? member-name-key=?) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; sum, exclude, alias - - (define (validate-trait who t) - ;; Methods: - (let ([ht (make-hash-table)]) - ;; Build up table and check for duplicates: - (for-each (lambda (m) - (let* ([name (method-name m)] - [key (member-name-key-hash-code name)]) - (let ([l (hash-table-get ht key null)]) - (when (ormap (lambda (n) (member-name-key=? (car n) name)) - l) - (raise-mismatch-error - who - "result would include multiple declarations of a method: " - name)) - (hash-table-put! ht key (cons (cons name m) l))))) - (trait-methods t)) - ;; Check consistency of expectations and provisions: - (let* ([find (lambda (name) - (let ([l (hash-table-get ht (member-name-key-hash-code name) null)]) - (ormap (lambda (n) - (and (member-name-key=? (car n) name) - (cdr n))) - l)))] - [check (lambda (super? inner?) - (lambda (name) - (let ([m (find name)]) - (when m - (when (and super? - (not (method-override? m))) - (raise-mismatch-error - who - (string-append - "result would include both a super requirement and" - " a non-overriding declaration for method: ") - name)) - - (when (and inner? - (not (method-inner? m))) - (raise-mismatch-error - who - (string-append - "result would include both an inner requirement and" - " a non-augmentable declaration for method: ") - name))))))]) - (for-each (lambda (m) - (for-each (check #t #f) - (method-need-super m)) - (for-each (check #f #t) - (method-need-inner m))) - (trait-methods t)))) - ;; Fields: - (let ([ht (make-hash-table)]) - ;; Build up table and check for duplicates: - (for-each (lambda (f) - (let* ([name (feeld-name f)] - [key (member-name-key-hash-code name)]) - (let ([l (hash-table-get ht key null)]) - (when (ormap (lambda (n) (member-name-key=? (car n) name)) - l) - (raise-mismatch-error - who - "result would include multiple declarations of a field: " - name)) - (hash-table-put! ht key (cons (cons name f) l))))) - (trait-fields t))) - ;; Return validated trait: - t) - - (define (trait-sum . ts) - (for-each (lambda (t) - (unless (trait? t) - (raise-type-error 'trait-sum "trait" t))) - ts) - (validate-trait - 'trait-sum - (make-trait (apply - append - (map trait-methods ts)) - (apply - append - (map trait-fields ts))))) - - (define (:trait-exclude t name) - (unless (trait? t) - (raise-type-error 'trait-exclude "trait" t)) - (let ([new-methods - (filter (lambda (m) - (not (member-name-key=? (method-name m) name))) - (trait-methods t))]) - (when (= (length new-methods) - (length (trait-methods t))) - (raise-mismatch-error - 'trait-exclude - "method not in trait: " name)) - (make-trait new-methods (trait-fields t)))) - - (define (:trait-exclude-field t name) - (unless (trait? t) - (raise-type-error 'trait-exclude-field "trait" t)) - (let ([new-fields - (filter (lambda (m) - (not (member-name-key=? (feeld-name m) name))) - (trait-fields t))]) - (when (= (length new-fields) - (length (trait-fields t))) - (raise-mismatch-error - 'trait-exclude - "field not in trait: " name)) - (make-trait (trait-methods t) new-fields))) - - (define-syntax define-trait-exclude - (syntax-rules () - [(_ trait-exclude :trait-exclude) - (define-syntax (trait-exclude stx) - (syntax-case stx () - [(_ t name) - (begin - (unless (identifier? #'name) - (raise-syntax-error - #f - "expected an identifier for a method name" - stx - #'name)) - #'(:trait-exclude t (member-name-key name)))]))])) - - (define-trait-exclude trait-exclude :trait-exclude) - (define-trait-exclude trait-exclude-field :trait-exclude-field) - - (define (:trait-alias t name new-name) - (unless (trait? t) - (raise-type-error 'trait-alias "trait" t)) - (let ([m (ormap (lambda (m) - (and (member-name-key=? (method-name m) name) - m)) - (trait-methods t))]) - (unless m - (raise-mismatch-error - 'trait-alias - "method not in trait: " name)) - (validate-trait - 'trait-alias - (make-trait - (cons (copy-struct method m - [method-name new-name]) - (trait-methods t)) - (trait-fields t))))) - - (define (:trait-rename t name new-name) - (unless (trait? t) - (raise-type-error 'trait-rename "trait" t)) - (let ([rename (lambda (n) - (if (same-name? n name) - new-name - n))]) - (validate-trait - 'trait-rename - (make-trait - (map (lambda (m) - (copy-struct method m - [method-name (rename (method-name m))] - [method-need-inherit (map rename (method-need-inherit m))] - [method-need-super (map rename (method-need-super m))] - [method-need-inner (map rename (method-need-inner m))])) - (trait-methods t)) - (trait-fields t))))) - - (define (:trait-rename-field t name new-name) - (unless (trait? t) - (raise-type-error 'trait-rename-field "trait" t)) - (let ([rename (lambda (n) - (if (same-name? n name) - new-name - n))]) - (validate-trait - 'trait-rename - (make-trait - (map (lambda (m) - (copy-struct method m - [method-need-field (map rename (method-need-field m))])) - (trait-methods t)) - (map (lambda (f) - (copy-struct feeld f - [feeld-name (rename (feeld-name f))])) - (trait-fields t)))))) - - (define-syntax define-trait-alias - (syntax-rules () - [(_ trait-alias :trait-alias) - (define-syntax (trait-alias stx) - (syntax-case stx () - [(_ t name new-name) - (begin - (unless (identifier? #'name) - (raise-syntax-error - #f - "expected an identifier for a method name" - stx - #'name)) - (unless (identifier? #'new-name) - (raise-syntax-error - #f - "expected an identifier for a method name" - stx - #'new-name)) - #'(:trait-alias t (member-name-key name) (member-name-key new-name)))]))])) - - (define-trait-alias trait-alias :trait-alias) - (define-trait-alias trait-rename :trait-rename) - (define-trait-alias trait-rename-field :trait-rename-field) - - ;; ----------------------------------------; - ) +(module trait scheme/base + (require scheme/trait) + (provide (all-from-out scheme/trait))) diff --git a/collects/scheme/class.ss b/collects/scheme/class.ss index 3cd0f7800f..81915d0195 100644 --- a/collects/scheme/class.ss +++ b/collects/scheme/class.ss @@ -1,4 +1,11 @@ +(module class mzscheme + + (require "private/contract-object.ss") + (provide (all-from "private/contract-object.ss")) + + ;; All of the implementation is actually in private/class-internal.ss, + ;; which provides extra (private) functionality to contract.ss. + (require "private/class-internal.ss") + + (provide-public-names)) -(module class scheme/base - (require mzlib/class) - (provide (all-from-out mzlib/class))) diff --git a/collects/scheme/contract.ss b/collects/scheme/contract.ss index 9be30f5dd7..5f8c88ef96 100644 --- a/collects/scheme/contract.ss +++ b/collects/scheme/contract.ss @@ -1,4 +1,176 @@ -(module contract scheme/base - (require mzlib/contract) - (provide (all-from-out mzlib/contract))) +(module contract mzscheme + + (require "private/contract.ss" + "private/contract-arrow.ss" + "private/contract-guts.ss" + "private/contract-ds.ss" + "private/contract-opt-guts.ss" + "private/contract-opt.ss" + "private/contract-basic-opters.ss") + + (provide + opt/c define-opt/c ;(all-from "private/contract-opt.ss") + (all-from-except "private/contract-ds.ss" + lazy-depth-to-look) + + (all-from-except "private/contract-arrow.ss" + check-procedure) + (all-from-except "private/contract.ss" + check-between/c + check-unary-between/c)) + + ;; from contract-guts.ss + + (provide any + and/c + any/c + none/c + make-none/c + + guilty-party + contract-violation->string + + contract? + contract-name + contract-proc + + flat-contract? + flat-contract + flat-contract-predicate + flat-named-contract + + contract-first-order-passes? + + ;; below need docs + + make-proj-contract + + contract-stronger? + + coerce-contract + flat-contract/predicate? + + build-compound-type-name + raise-contract-error + + proj-prop proj-pred? proj-get + name-prop name-pred? name-get + stronger-prop stronger-pred? stronger-get + flat-prop flat-pred? flat-get + first-order-prop first-order-get)) + +;; ====================================================================== +;; The alternate implementation disables contracts. Its useful mainly to +;; measure the cost of contracts. It's not necessarily complete, but it +;; works well enough for starting DrScheme. +;; (last used pre v4) + +#; +(module contract mzscheme + + (define-syntax provide/contract + (syntax-rules () + [(_ elem ...) + (begin (provide-one elem) ...)])) + + (define-syntax provide-one + (syntax-rules (struct rename) + [(_ (struct (id par-id) ([field . rest] ...))) + (provide-struct id par-id (field ...))] + [(_ (struct id ([field . rest] ...))) + (provide (struct id (field ...)))] + [(_ (rename id1 id2 c)) + (provide (rename id1 id2))] + [(_ (id c)) + (provide id)])) + + (define-syntax (provide-struct stx) + (syntax-case stx () + [(_ id par-id . rest) + (let ([info (syntax-local-value #'id (lambda () #f))] + [p-info (syntax-local-value #'par-id (lambda () #f))] + [prefix (lambda (l n) + (let loop ([l l][len (length l)]) + (if (= n len) + null + (cons (car l) (loop (cdr l) + (- len 1))))))] + [ids (lambda (l) (let loop ([l l]) + (cond + [(null? l) null] + [(car l) (cons (car l) (loop (cdr l)))] + [else (loop (cdr l))])))]) + (if (and info + p-info + (list? info) + (list? p-info) + (= (length info) 6) + (= (length p-info) 6)) + #`(provide #,@(append + (list #'id + (list-ref info 0) + (list-ref info 1) + (list-ref info 2)) + (ids (prefix (list-ref info 3) (length (list-ref p-info 3)))) + (ids (prefix (list-ref info 4) (length (list-ref p-info 4)))))) + (raise-syntax-error + #f + (cond + [(not info) "cannot find struct info"] + [(not p-info) "cannot find parent-struct info"] + [else (format "struct or parent-struct info has unexpected shape: ~e and ~e" + info p-info)]) + #'id)))])) + + (define-syntax define-contract-struct + (syntax-rules () + [(_ . rest) (define-struct . rest)])) + + (define-syntax define/contract + (syntax-rules () + [(_ id c expr) (define id expr)])) + + (define-syntax contract + (syntax-rules () + [(_ c expr . rest) expr])) + + (provide provide/contract + define-contract-struct + define/contract + contract) + + (define mk* + (lambda args (lambda (x) x))) + + (define-syntax mk + (syntax-rules () + [(_ id) (begin + (define-syntax (id stx) (quote-syntax mk*)) + (provide id))] + [(_ id ...) + (begin (mk id) ...)])) + + (mk -> + ->* + opt-> + case-> + ->r + or/c + and/c + any/c + flat-named-contract + flat-contract + flat-contract-predicate + object-contract + union + listof + is-a?/c) + + (define-syntax symbols + (syntax-rules () + [(_ sym ...) + (lambda (v) (memq v '(sym ...)))])) + (provide symbols) + + ) \ No newline at end of file diff --git a/collects/mzlib/private/class-events.ss b/collects/scheme/private/class-events.ss similarity index 100% rename from collects/mzlib/private/class-events.ss rename to collects/scheme/private/class-events.ss diff --git a/collects/mzlib/private/class-internal.ss b/collects/scheme/private/class-internal.ss similarity index 98% rename from collects/mzlib/private/class-internal.ss rename to collects/scheme/private/class-internal.ss index c668ed3632..048f788498 100644 --- a/collects/mzlib/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -5,7 +5,7 @@ (lib "etc.ss") (lib "stxparam.ss") "class-events.ss" - "serialize-structs.ss" + "serialize-structs.ss" (for-syntax (lib "kerncase.ss" "syntax") (lib "stx.ss" "syntax") (lib "name.ss" "syntax") @@ -17,6 +17,52 @@ (define insp (current-inspector)) ; for all opaque structures + ;;-------------------------------------------------------------------- + ;; spec for external interface + ;;-------------------------------------------------------------------- + + (provide provide-public-names) + (define-syntax (provide-public-names stx) + #'(provide class class* class/derived + define-serializable-class define-serializable-class* + class? + mixin + interface interface? + object% object? externalizable<%> + object=? + new make-object instantiate + send send/apply send* class-field-accessor class-field-mutator with-method + get-field field-bound? field-names + private* public* pubment* + override* overment* + augride* augment* + public-final* override-final* augment-final* + define/private define/public define/pubment + define/override define/overment + define/augride define/augment + define/public-final define/override-final define/augment-final + define-local-member-name define-member-name + member-name-key generate-member-key + member-name-key? member-name-key=? member-name-key-hash-code + generic make-generic send-generic + is-a? subclass? implementation? interface-extension? + object-interface object-info object->vector + object-method-arity-includes? + method-in-interface? interface->method-names class->interface class-info + (struct-out exn:fail:object) + make-primitive-class + + ;; "keywords": + private public override augment + pubment overment augride + public-final override-final augment-final + field init init-field init-rest + rename-super rename-inner inherit inherit/super inherit/inner inherit-field + this super inner + super-make-object super-instantiate super-new + inspect)) + + ;;-------------------------------------------------------------------- ;; keyword setup ;;-------------------------------------------------------------------- diff --git a/collects/mzlib/private/classidmap.ss b/collects/scheme/private/classidmap.ss similarity index 100% rename from collects/mzlib/private/classidmap.ss rename to collects/scheme/private/classidmap.ss diff --git a/collects/mzlib/private/contract-arr-checks.ss b/collects/scheme/private/contract-arr-checks.ss similarity index 100% rename from collects/mzlib/private/contract-arr-checks.ss rename to collects/scheme/private/contract-arr-checks.ss diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/scheme/private/contract-arr-obj-helpers.ss similarity index 100% rename from collects/mzlib/private/contract-arr-obj-helpers.ss rename to collects/scheme/private/contract-arr-obj-helpers.ss diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss similarity index 100% rename from collects/mzlib/private/contract-arrow.ss rename to collects/scheme/private/contract-arrow.ss diff --git a/collects/mzlib/private/contract-basic-opters.ss b/collects/scheme/private/contract-basic-opters.ss similarity index 100% rename from collects/mzlib/private/contract-basic-opters.ss rename to collects/scheme/private/contract-basic-opters.ss diff --git a/collects/mzlib/private/contract-ds-helpers.ss b/collects/scheme/private/contract-ds-helpers.ss similarity index 100% rename from collects/mzlib/private/contract-ds-helpers.ss rename to collects/scheme/private/contract-ds-helpers.ss diff --git a/collects/mzlib/private/contract-ds.ss b/collects/scheme/private/contract-ds.ss similarity index 100% rename from collects/mzlib/private/contract-ds.ss rename to collects/scheme/private/contract-ds.ss diff --git a/collects/mzlib/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss similarity index 100% rename from collects/mzlib/private/contract-guts.ss rename to collects/scheme/private/contract-guts.ss diff --git a/collects/mzlib/private/contract-helpers.ss b/collects/scheme/private/contract-helpers.ss similarity index 100% rename from collects/mzlib/private/contract-helpers.ss rename to collects/scheme/private/contract-helpers.ss diff --git a/collects/mzlib/private/contract-object.ss b/collects/scheme/private/contract-object.ss similarity index 100% rename from collects/mzlib/private/contract-object.ss rename to collects/scheme/private/contract-object.ss diff --git a/collects/mzlib/private/contract-opt-guts.ss b/collects/scheme/private/contract-opt-guts.ss similarity index 100% rename from collects/mzlib/private/contract-opt-guts.ss rename to collects/scheme/private/contract-opt-guts.ss diff --git a/collects/mzlib/private/contract-opt.ss b/collects/scheme/private/contract-opt.ss similarity index 100% rename from collects/mzlib/private/contract-opt.ss rename to collects/scheme/private/contract-opt.ss diff --git a/collects/mzlib/private/contract.ss b/collects/scheme/private/contract.ss similarity index 100% rename from collects/mzlib/private/contract.ss rename to collects/scheme/private/contract.ss diff --git a/collects/mzlib/private/serialize-structs.ss b/collects/scheme/private/serialize-structs.ss similarity index 100% rename from collects/mzlib/private/serialize-structs.ss rename to collects/scheme/private/serialize-structs.ss diff --git a/collects/mzlib/private/serialize.ss b/collects/scheme/private/serialize.ss similarity index 99% rename from collects/mzlib/private/serialize.ss rename to collects/scheme/private/serialize.ss index 403d997133..26582ea018 100644 --- a/collects/mzlib/private/serialize.ss +++ b/collects/scheme/private/serialize.ss @@ -1,6 +1,6 @@ (module serialize scheme/base (require syntax/modcollapse - "serialize-structs.ss") + "serialize-structs.ss") ;; This module implements the core serializer. The syntactic ;; `define-serializable-struct' layer is implemented separately diff --git a/collects/scheme/serialize.ss b/collects/scheme/serialize.ss index 816b1680f4..b413ddefa7 100644 --- a/collects/scheme/serialize.ss +++ b/collects/scheme/serialize.ss @@ -1,10 +1,10 @@ (module serialize scheme/base - (require mzlib/private/serialize + (require "private/serialize.ss" (for-syntax scheme/base scheme/struct-info)) - (provide (all-from-out mzlib/private/serialize) + (provide (all-from-out "private/serialize.ss") define-serializable-struct define-serializable-struct/versions) diff --git a/collects/scheme/trait.ss b/collects/scheme/trait.ss new file mode 100644 index 0000000000..c31d10f189 --- /dev/null +++ b/collects/scheme/trait.ss @@ -0,0 +1,729 @@ +(module trait mzscheme + (require (lib "class.ss") + (lib "list.ss") + (lib "struct.ss")) + (require-for-syntax (lib "list.ss") + (lib "stx.ss" "syntax") + (lib "boundmap.ss" "syntax") + (lib "kerncase.ss" "syntax") + ;; This should be part of a public expand-time API + ;; exported by the class system: + (only "private/classidmap.ss" + generate-class-expand-context)) + + (provide (rename :trait trait) + trait? + trait->mixin + trait-sum + trait-exclude trait-exclude-field + trait-alias + trait-rename trait-rename-field) + + ;; A trait is a list of supplied methods. + ;; Each supplied method is: + ;; * an external name + ;; * supplies inherit? + ;; * supplies super? + ;; * supplies inner? + ;; * overrides? + ;; * augments? + ;; * list of required methods (external names) for inherit + ;; * list of required methods (external names) for super + ;; * list of required methods (external names) for inner + ;; * list of required methods (external names) for inherit-fields + ;; * a mixin patameterized by all external names + ;; * an indrection mixin for supers + + (define-struct trait (methods fields)) + + (define-struct method (name inherit? super? inner? + override? augment? + need-inherit need-super need-inner need-field + make-mixin + make-super-indirection-mixin)) + + (define-struct feeld (name make-mixin)) + + (define-syntax (:trait stx) + ;; The main compiler (helpers are below): + (define (main stx) + (syntax-case stx () + [(_ clause ...) + (let* ([clauses (syntax->list #'(clause ...))] + [expanded-clauses (expand-body clauses)]) + ;; Pull out declared names: + (let-values ([(publics pubments + overrides augments augrides overments + inherits inherits/super inherits/inner + inherit-fields) + (extract expanded-clauses + (map syntax->list + (syntax->list + #'((public public-final) + (pubment) + (override override-final) + (augment augment-final) + (augride) + (overment) + (inherit) (inherit/super) (inherit/inner) + (inherit-field)))))] + [(fields) + (extract-fields expanded-clauses)]) + ;; Every declaration implies direct use for other declarations: + (let* ([to-inherit + (append publics pubments + overrides augments augrides overments + inherits inherits/super inherits/inner)] + [to-inherit-fields + (append fields inherit-fields)] + [decls + (append to-inherit-fields to-inherit)]) + ;; Check distinct delcarations: + (check-distinct-external-names to-inherit) + (check-distinct-external-names to-inherit-fields) + (check-distinct-internal-names decls) + + ;; Some declarations imply use via `super' or `inner': + (let ([to-super (append overrides inherits/super)] + [to-inner (append augments pubments inherits/inner)]) + + (let ([to-inherit-only + (filter (lambda (n) + (not (or (ormap (lambda (n2) (internal-identifier=? n n2)) + to-super) + (ormap (lambda (n2) (internal-identifier=? n n2)) + to-inner)))) + to-inherit)]) + + ;; Current method-making function with respect to the + ;; common part: + (let* ([bindings (make-bindings expanded-clauses)] + [compose-method (compose-method-with-requirements + bindings + to-inherit-only to-super to-inner + to-inherit-fields)]) + + ;; Build a mixin and `method' record for each declaration: + (with-syntax ([(method ...) + (append + (map (compose-method #'override #t #f #f #f #f #f) publics) + (map (compose-method #'overment #t #t #f #f #f #f) pubments) + (map (compose-method #'override #t #t #f #t #f #f) overrides) + (map (compose-method #'overment #t #f #f #t #f #t) overments) + (map (compose-method #'augment #t #f #t #f #t #f) augments) + (map (compose-method #'augride #t #f #f #f #t #f) augrides))] + [(field ...) + (map (compose-field bindings) fields)]) + + (bound-identifier-mapping-for-each + bindings + (lambda (key val) + (when val + (raise-syntax-error + #f + "definition has no corresponding declaration (e.g., public)" + stx + key)))) + + ;; Combine the result into a trait: + #'(make-trait (list method ...) + (list field ...)))))))))])) + + (define (expand-body clauses) + ;; For now, we expand naively: no support for internal define-syntax, + ;; and no shadowing of syntax with method definitions. + (let ([stop-forms + (append + (syntax->list + #'(private + public public-final pubment + override override-final augment augment-final augride overment + inherit inherit/super inherit/inner + this super inner + field inherit-field)) + (kernel-form-identifier-list))] + [expand-context (generate-class-expand-context)]) + (let loop ([l clauses]) + (cond + [(null? l) null] + [else (let ([e (local-expand (car l) + expand-context + stop-forms)]) + (syntax-case e (begin define-values) + [(begin expr ...) + (loop (append + (syntax->list (syntax (expr ...))) + (cdr l)))] + [(define-values (id) rhs) + (cons e (loop (cdr l)))] + [(field (id expr) ...) + (if (andmap (lambda (id) + (or (identifier? id) + (syntax-case id () + [(a b) + (and (identifier? #'a) + (identifier? #'b))] + [_else #f]))) + (syntax->list #'(id ...))) + (cons e (loop (cdr l))) + (raise-syntax-error + #f + "bad syntax" + e))] + [(id . rest) + (ormap (lambda (x) (module-identifier=? x #'id)) + (syntax->list + #'(public public-final pubment + override override-final augment augment-final augride overment + inherit inherit/super inherit/inner + inherit-field))) + (let ([l2 (syntax->list #'rest)]) + (if (and l2 + (andmap (lambda (i) + (or (identifier? i) + (syntax-case i () + [(a b) + (and (identifier? #'a) + (identifier? #'b))] + [_else #f]))) + l2)) + (cons e (loop (cdr l))) + (raise-syntax-error + #f + "bad syntax (inside trait)" + e)))] + [(define-values . _) + (raise-syntax-error + #f + "bad syntax" + e)] + [(field . _) + (raise-syntax-error + #f + "bad syntax" + e)] + [else + (raise-syntax-error + #f + "not allowed in a trait" + e)]))])))) + + (define (extract expanded-clauses keyword-mapping) + (let loop ([l expanded-clauses] + [results (map (lambda (x) null) keyword-mapping)]) + (cond + [(null? l) (apply values results)] + [else + (let ([kw (stx-car (car l))]) + (if (or (module-identifier=? kw #'define-values) + (module-identifier=? kw #'field)) + (loop (cdr l) results) + (loop (cdr l) + (let iloop ([mapping keyword-mapping] + [results results]) + (if (ormap (lambda (x) (module-identifier=? kw x)) + (car mapping)) + (cons (append (stx->list (stx-cdr (car l))) + (car results)) + (cdr results)) + (cons (car results) + (iloop (cdr mapping) + (cdr results))))))))]))) + + (define (extract-fields expanded-clauses) + (apply + append + (map (lambda (clause) + (syntax-case clause (field) + [(field [id expr] ...) + (syntax->list #'(id ...))] + [_else null])) + expanded-clauses))) + + (define (make-bindings expanded-clauses) + (let ([boundmap (make-bound-identifier-mapping)]) + (for-each (lambda (clause) + (syntax-case clause (define-values field) + [(define-values (id) rhs) + (bound-identifier-mapping-put! boundmap #'id #'rhs)] + [(field [id expr] ...) + (for-each (lambda (id expr) + (bound-identifier-mapping-put! boundmap (internal-name id) expr)) + (syntax->list #'(id ...)) + (syntax->list #'(expr ...)))] + [_else (void)])) + expanded-clauses) + boundmap)) + + (define (internal-identifier=? a b) + (bound-identifier=? (internal-name a) (internal-name b))) + + (define (internal-name decl) + (if (identifier? decl) + decl + (stx-car decl))) + + (define (external-name decl) + (if (identifier? decl) + decl + (stx-car (stx-cdr decl)))) + + (define (check-distinct-names method-decls + what which + make-identifier-mapping + identifier-mapping-get + identifier-mapping-set!) + (let ([idmap (make-identifier-mapping)]) + (for-each (lambda (decl) + (let ([ext-id (which decl)]) + (when (identifier-mapping-get + idmap ext-id + (lambda () + (identifier-mapping-set! + idmap ext-id + #t) + #f)) + (raise-syntax-error + #f + (format "duplicate definition of ~a name in trait" + what) + ext-id)))) + method-decls))) + + (define (check-distinct-external-names method-decls) + (check-distinct-names method-decls + "external" external-name + make-module-identifier-mapping + module-identifier-mapping-get + module-identifier-mapping-put!)) + + (define (check-distinct-internal-names method-decls) + (check-distinct-names method-decls + "internal" internal-name + make-bound-identifier-mapping + bound-identifier-mapping-get + bound-identifier-mapping-put!)) + + (define (((compose-method-with-requirements binding-map + to-inherit to-super to-inner + to-inherit-field) + keyword inherit? super? inner? override? augment? always-deep?) + name) + (let ([impl (bound-identifier-mapping-get binding-map (internal-name name))] + [to-inherit (if always-deep? + (filter (lambda (n) (not (internal-identifier=? n name))) + to-inherit) + to-inherit)]) + (with-syntax ([(to-inherit ...) to-inherit] + [(to-super ...) to-super] + [(to-inner ...) to-inner] + [(to-inherit-field ...) to-inherit-field] + [(to-inherit-ext ...) (map external-name to-inherit)] + [(to-super-ext ...) (map external-name to-super)] + [(to-inner-ext ...) (map external-name to-inner)] + [(to-inherit-field-ext ...) (map external-name to-inherit-field)] + [(to-inherit-arg ...) (generate-temporaries to-inherit)] + [(to-super-arg ...) (generate-temporaries to-super)] + [(to-inner-arg ...) (generate-temporaries to-inner)] + [(to-inherit-field-arg ...) (generate-temporaries to-inherit-field)] + [impl impl] + [declare keyword] + [this-method (if always-deep? + name + #'this-method)] + [wrap-super-indirect (if override? + #'values + #'omit)] + [wrap-inner-indirect (if augment? + #'values + #'omit)]) + ;; for tracking unused bindings at the end: + (bound-identifier-mapping-put! binding-map (internal-name name) #f) + ;; generate method: + #`(make-method + (member-name-key #,(external-name name)) + #,inherit? #,super? #,inner? #,override? #,augment? + (list (member-name-key to-inherit-ext) ...) + (list (member-name-key to-super-ext) ...) + (list (member-name-key to-inner-ext) ...) + (list (member-name-key to-inherit-field-ext) ...) + (lambda (this-method-arg to-inherit-arg ... + to-super-arg ... + to-inner-arg ... + to-inherit-field-arg ...) + (define-member-name this-method this-method-arg) + (define-member-name to-inherit-ext to-inherit-arg) ... + (define-member-name to-super-ext to-super-arg) ... + (define-member-name to-inner-ext to-inner-arg) ... + (define-member-name to-inherit-field-ext to-inherit-field-arg) ... + (lambda (%) + (class % + (inherit to-inherit ...) + (inherit/super to-super ...) + (inherit/inner to-inner ...) + (inherit-field to-inherit-field ...) + (declare this-method) + (define this-method (let ([#,(internal-name name) impl]) + #,(internal-name name))) + (super-new)))) + ;; For `super' call indirections: + (wrap-super-indirect + (lambda (name-arg super-name-arg) + (define-member-name name name-arg) + (define-member-name super-name super-name-arg) + (lambda (%) + (class % + (override name) + (inherit/super super-name) + (define name (similar-lambda impl (super super-name))) + (super-new))))))))) + + (define ((compose-field binding-map) name) + (let ([impl (bound-identifier-mapping-get binding-map (internal-name name))]) + ;; for tracking unused bindings at the end: + (bound-identifier-mapping-put! binding-map (internal-name name) #f) + ;; generate method: + #`(make-feeld + (member-name-key #,(external-name name)) + (lambda (name-arg) + (define-member-name #,(external-name name) name-arg) + (lambda (%) + (class % + (field [#,name #,impl]) + (super-new))))))) + + (main stx)) + + (define-syntax (similar-lambda stx) + ;; Try to get arity the same: + (syntax-case stx (lambda) + [(_ (lambda (id ...) . __) (new-body ...)) + #'(lambda (id ...) (new-body ... id ...))] + ;; Generic case: + [(_ method-lambda (new-body ...)) + #'(lambda args (new-body ... . args))])) + + (define-syntax (omit stx) #'#f) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; trait->mixin + + (define (trait->mixin t) + (let ([methods (trait-methods t)]) + + ;; If a needed inherit, super, or inner is not immediately satisified, + ;; we can just leave it to the superclass. + ;; But we can't expect a super and have it introduced as non-overriding. + ;; We need to check in trait-sum, trait-alias, etc., because we'll + ;; have to use dummy introductions when stacking up the mixins, and + ;; there might be no error otherwise. + + ;; Order the mixins. If M1 super-calls M2 and we have an override + ;; for M2, then try to mix M2 later. Similarly, if M1 inner-calls M2 + ;; and we have an augment for M2, try to mix M2 earlier. + ;; We'll have to break cycles by inserting indirections, but we can't + ;; do that for `inner'; consequently, an `inner' from M1 to M2 + ;; might land at an implementation in the same trait! + ;; For simplicty, we sort right now by just all augments first + ;; and all overrides last. In the common case where methods + ;; only self-call supers and inners, that will work fine. + (let loop ([methods (sort methods + (lambda (a b) + (or (method-augment? a) + (method-override? b))))] + ;; Start by adding mixins for fields. Then continue + ;; by mixing a dummy method for each public/pubment + ;; method. We'll override it, but having it here at the start + ;; means that the methods can refer to each other via + ;; `inherit'. + [mixin (let loop ([methods methods] + [mixin (let loop ([mixin (lambda (%) %)] + [fields (trait-fields t)]) + (cond + [(null? fields) mixin] + [else (let ([mix ((feeld-make-mixin (car fields)) + (feeld-name (car fields)))]) + (loop (lambda (%) (mix (mixin %))) + (cdr fields)))]))]) + (cond + [(null? methods) mixin] + [else (let ([method (car methods)]) + (loop (cdr methods) + (if (or (method-override? method) + (method-augment? method)) + mixin + (introduce-into-mixin + (method-name method) + mixin))))]))] + [super-indirections null]) + (cond + [(null? methods) + ;; No more methods to add, so just insert needed + ;; super indirections (as accumulated when adding + ;; methods before): + (let loop ([indirections super-indirections] + [mixin mixin]) + (cond + [(null? indirections) mixin] + [else (let ([method (list-ref (car indirections) 2)]) + (loop (cdr indirections) + (let ([mix ((method-make-super-indirection-mixin method) + (method-name method) + (cadar indirections))]) + (lambda (%) (mix (mixin %))))))]))] + [else + ;; Add one method: + (let*-values ([(method) (car methods)] + ;; Rename method, in case we need a super + ;; indirection: + [(name) + (if (and (method-override? method) + (ormap (lambda (m) + (ormap (lambda (n) + (same-name? n (method-name method))) + (method-need-super m))) + (cdr methods))) + (generate-member-key) + (method-name method))] + ;; Build the base mixin: + [(next-mixin) (apply + (method-make-mixin method) + name + (append + (method-need-inherit method) + (method-need-super method) + (method-need-inner method) + (method-need-field method)))]) + (loop (cdr methods) + (lambda (%) (next-mixin (mixin %))) + (if (eq? name (method-name method)) + super-indirections + (cons (list (method-name method) + name + method) + super-indirections))))])))) + + (define (introduce-into-mixin name mixin) + (define-member-name m name) + (lambda (%) + (class (mixin %) + (define/public (m) 'inroduce-stub) + (super-new)))) + + (define same-name? member-name-key=?) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; sum, exclude, alias + + (define (validate-trait who t) + ;; Methods: + (let ([ht (make-hash-table)]) + ;; Build up table and check for duplicates: + (for-each (lambda (m) + (let* ([name (method-name m)] + [key (member-name-key-hash-code name)]) + (let ([l (hash-table-get ht key null)]) + (when (ormap (lambda (n) (member-name-key=? (car n) name)) + l) + (raise-mismatch-error + who + "result would include multiple declarations of a method: " + name)) + (hash-table-put! ht key (cons (cons name m) l))))) + (trait-methods t)) + ;; Check consistency of expectations and provisions: + (let* ([find (lambda (name) + (let ([l (hash-table-get ht (member-name-key-hash-code name) null)]) + (ormap (lambda (n) + (and (member-name-key=? (car n) name) + (cdr n))) + l)))] + [check (lambda (super? inner?) + (lambda (name) + (let ([m (find name)]) + (when m + (when (and super? + (not (method-override? m))) + (raise-mismatch-error + who + (string-append + "result would include both a super requirement and" + " a non-overriding declaration for method: ") + name)) + + (when (and inner? + (not (method-inner? m))) + (raise-mismatch-error + who + (string-append + "result would include both an inner requirement and" + " a non-augmentable declaration for method: ") + name))))))]) + (for-each (lambda (m) + (for-each (check #t #f) + (method-need-super m)) + (for-each (check #f #t) + (method-need-inner m))) + (trait-methods t)))) + ;; Fields: + (let ([ht (make-hash-table)]) + ;; Build up table and check for duplicates: + (for-each (lambda (f) + (let* ([name (feeld-name f)] + [key (member-name-key-hash-code name)]) + (let ([l (hash-table-get ht key null)]) + (when (ormap (lambda (n) (member-name-key=? (car n) name)) + l) + (raise-mismatch-error + who + "result would include multiple declarations of a field: " + name)) + (hash-table-put! ht key (cons (cons name f) l))))) + (trait-fields t))) + ;; Return validated trait: + t) + + (define (trait-sum . ts) + (for-each (lambda (t) + (unless (trait? t) + (raise-type-error 'trait-sum "trait" t))) + ts) + (validate-trait + 'trait-sum + (make-trait (apply + append + (map trait-methods ts)) + (apply + append + (map trait-fields ts))))) + + (define (:trait-exclude t name) + (unless (trait? t) + (raise-type-error 'trait-exclude "trait" t)) + (let ([new-methods + (filter (lambda (m) + (not (member-name-key=? (method-name m) name))) + (trait-methods t))]) + (when (= (length new-methods) + (length (trait-methods t))) + (raise-mismatch-error + 'trait-exclude + "method not in trait: " name)) + (make-trait new-methods (trait-fields t)))) + + (define (:trait-exclude-field t name) + (unless (trait? t) + (raise-type-error 'trait-exclude-field "trait" t)) + (let ([new-fields + (filter (lambda (m) + (not (member-name-key=? (feeld-name m) name))) + (trait-fields t))]) + (when (= (length new-fields) + (length (trait-fields t))) + (raise-mismatch-error + 'trait-exclude + "field not in trait: " name)) + (make-trait (trait-methods t) new-fields))) + + (define-syntax define-trait-exclude + (syntax-rules () + [(_ trait-exclude :trait-exclude) + (define-syntax (trait-exclude stx) + (syntax-case stx () + [(_ t name) + (begin + (unless (identifier? #'name) + (raise-syntax-error + #f + "expected an identifier for a method name" + stx + #'name)) + #'(:trait-exclude t (member-name-key name)))]))])) + + (define-trait-exclude trait-exclude :trait-exclude) + (define-trait-exclude trait-exclude-field :trait-exclude-field) + + (define (:trait-alias t name new-name) + (unless (trait? t) + (raise-type-error 'trait-alias "trait" t)) + (let ([m (ormap (lambda (m) + (and (member-name-key=? (method-name m) name) + m)) + (trait-methods t))]) + (unless m + (raise-mismatch-error + 'trait-alias + "method not in trait: " name)) + (validate-trait + 'trait-alias + (make-trait + (cons (copy-struct method m + [method-name new-name]) + (trait-methods t)) + (trait-fields t))))) + + (define (:trait-rename t name new-name) + (unless (trait? t) + (raise-type-error 'trait-rename "trait" t)) + (let ([rename (lambda (n) + (if (same-name? n name) + new-name + n))]) + (validate-trait + 'trait-rename + (make-trait + (map (lambda (m) + (copy-struct method m + [method-name (rename (method-name m))] + [method-need-inherit (map rename (method-need-inherit m))] + [method-need-super (map rename (method-need-super m))] + [method-need-inner (map rename (method-need-inner m))])) + (trait-methods t)) + (trait-fields t))))) + + (define (:trait-rename-field t name new-name) + (unless (trait? t) + (raise-type-error 'trait-rename-field "trait" t)) + (let ([rename (lambda (n) + (if (same-name? n name) + new-name + n))]) + (validate-trait + 'trait-rename + (make-trait + (map (lambda (m) + (copy-struct method m + [method-need-field (map rename (method-need-field m))])) + (trait-methods t)) + (map (lambda (f) + (copy-struct feeld f + [feeld-name (rename (feeld-name f))])) + (trait-fields t)))))) + + (define-syntax define-trait-alias + (syntax-rules () + [(_ trait-alias :trait-alias) + (define-syntax (trait-alias stx) + (syntax-case stx () + [(_ t name new-name) + (begin + (unless (identifier? #'name) + (raise-syntax-error + #f + "expected an identifier for a method name" + stx + #'name)) + (unless (identifier? #'new-name) + (raise-syntax-error + #f + "expected an identifier for a method name" + stx + #'new-name)) + #'(:trait-alias t (member-name-key name) (member-name-key new-name)))]))])) + + (define-trait-alias trait-alias :trait-alias) + (define-trait-alias trait-rename :trait-rename) + (define-trait-alias trait-rename-field :trait-rename-field) + + ;; ----------------------------------------; + ) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 64aa57aa4c..747fa5cea7 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1153,6 +1153,77 @@ Evaluation of a @scheme[mixin] form checks that the @; ------------------------------------------------------------------------ +@section{Object and Class Contracts} + +@defform/subs[ +#:literals (field opt-> opt->* case-> -> ->* ->d ->d* ->r ->pp ->pp-rest) + +(object-contract member-spec ...) + +([member-spec + (method-id method-contract) + (field field-id contract-expr)] + + [method-contract + (opt-> (required-contract-expr ...) + (optional-contract-expr ...) + any) + (opt-> (required-contract-expr ...) + (optional-contract-expr ...) + result-contract-expr) + (opt->* (required-contract-expr ...) + (optional-contract-expr ...) + (result-contract-expr ...)) + (case-> arrow-contract ...) + arrow-contract] + + [arrow-contract + (-> expr ... res-expr) + (-> expr ... (values res-expr ...)) + (->* (expr ...) (res-expr ...)) + (->* (expr ...) rest-expr (res-expr ...)) + (->d expr ... res-proc-expr) + (->d* (expr ...) res-proc-expr) + (->d* (expr ...) rest-expr res-gen-expr) + (->r ((id expr) ...) expr) + (->r ((id expr) ...) id expr expr) + (->pp ((id expr) ...) pre-expr + res-expr res-id post-expr) + (->pp ((id expr) ...) pre-expr any) + (->pp ((id expr) ...) pre-expr + (values (id expr) ...) post-expr) + (->pp-rest ((id expr) ...) id expr pre-expr + res-expr res-id post-expr) + (->pp-rest ((id expr) ...) id expr pre-expr any) + (->pp-rest ((id expr) ...) id expr pre-expr + (values (id expr) ...) post-expr)])]{ + +Produces a contract for an object. + +Each of the contracts for a method has the same semantics as the +corresponding function contract, but the syntax of the method contract +must be written directly in the body of the object-contract---much +like the way that methods in class definitions use the same syntax as +regular function definitions, but cannot be arbitrary procedures. The +only exception is that the @scheme[->r], @scheme[->pp], and +@scheme[->pp-rest] contracts implicitly bind @scheme[this] to the +object itself.} + + +@defthing[mixin-contract contract?]{ + +A @tech{function contract} that recognizes mixins. It guarantees that +the input to the function is a class and the result of the function is +a subclass of the input.} + +@defproc[(make-mixin-contract [type (or/c class? interface?)] ...) contract?]{ + +Produces a @tech{function contract} that guarantees the input to the +function is a class that implements/subclasses each @scheme[type], and +that the result of the function is a subclass of the input.} + +@; ------------------------------------------------------------------------ + @section[#:tag "objectserialize"]{Object Serialization} @defform[ diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index bb52e86d74..45e602c59f 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -619,77 +619,6 @@ lazy contract.} @; ------------------------------------------------------------------------ -@section{Object and Class Contracts} - -@defform/subs[ -#:literals (field opt-> opt->* case-> -> ->* ->d ->d* ->r ->pp ->pp-rest) - -(object-contract member-spec ...) - -([member-spec - (method-id method-contract) - (field field-id contract-expr)] - - [method-contract - (opt-> (required-contract-expr ...) - (optional-contract-expr ...) - any) - (opt-> (required-contract-expr ...) - (optional-contract-expr ...) - result-contract-expr) - (opt->* (required-contract-expr ...) - (optional-contract-expr ...) - (result-contract-expr ...)) - (case-> arrow-contract ...) - arrow-contract] - - [arrow-contract - (-> expr ... res-expr) - (-> expr ... (values res-expr ...)) - (->* (expr ...) (res-expr ...)) - (->* (expr ...) rest-expr (res-expr ...)) - (->d expr ... res-proc-expr) - (->d* (expr ...) res-proc-expr) - (->d* (expr ...) rest-expr res-gen-expr) - (->r ((id expr) ...) expr) - (->r ((id expr) ...) id expr expr) - (->pp ((id expr) ...) pre-expr - res-expr res-id post-expr) - (->pp ((id expr) ...) pre-expr any) - (->pp ((id expr) ...) pre-expr - (values (id expr) ...) post-expr) - (->pp-rest ((id expr) ...) id expr pre-expr - res-expr res-id post-expr) - (->pp-rest ((id expr) ...) id expr pre-expr any) - (->pp-rest ((id expr) ...) id expr pre-expr - (values (id expr) ...) post-expr)])]{ - -Produces a contract for an object (see @secref["mzlib:class"]). - -Each of the contracts for a method has the same semantics as the -corresponding function contract, but the syntax of the method contract -must be written directly in the body of the object-contract---much -like the way that methods in class definitions use the same syntax as -regular function definitions, but cannot be arbitrary procedures. The -only exception is that the @scheme[->r], @scheme[->pp], and -@scheme[->pp-rest] contracts implicitly bind @scheme[this] to the -object itself.} - - -@defthing[mixin-contract contract?]{ - -A @tech{function contract} that recognizes mixins. It guarantees that -the input to the function is a class and the result of the function is -a subclass of the input.} - -@defproc[(make-mixin-contract [type (or/c class? interface?)] ...) contract?]{ - -Produces a @tech{function contract} that guarantees the input to the -function is a class that implements/subclasses each @scheme[type], and -that the result of the function is a subclass of the input.} - -@; ------------------------------------------------------------------------ - @section{Attaching Contracts to Values} @defform/subs[ diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 8a2ed75294..c66bfdd474 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4814,7 +4814,7 @@ so that propagation occurs. 'provide/contract12 '(begin (eval '(module pc12-m mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct (exn2 exn) ()) (provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c)))))) (eval '(require 'pc12-m)))) @@ -4823,7 +4823,7 @@ so that propagation occurs. 'provide/contract13 '(begin (eval '(module pc13-common-msg-structs mzscheme - (require (lib "contract.ss" "mzlib")) + (require scheme/contract) (define-struct register (name type) (make-inspector)) (provide/contract (struct register ([name any/c] [type any/c]))))) @@ -4838,7 +4838,7 @@ so that propagation occurs. 'provide/contract14 '(begin (eval '(module pc14-test1 mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct type (flags)) (define-struct (type:ptr type) (type)) @@ -4861,7 +4861,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pos mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [i any/c])))) exn:fail:syntax?) @@ -4871,7 +4871,7 @@ so that propagation occurs. 'provide/contract15 '(begin (eval '(module pos mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define i #f) (provide/contract [i integer?]))) (eval '(require 'pos))) @@ -4882,7 +4882,7 @@ so that propagation occurs. 'provide/contract16 '(begin (eval '(module neg mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define i #f) (provide/contract [i integer?]))) (eval '(require 'neg))) @@ -4895,7 +4895,7 @@ so that propagation occurs. 'provide/contract17 '(begin (eval '(module pos mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct s (a)) (provide/contract [struct s ((a integer?))]))) (eval '(module neg mzscheme @@ -4908,7 +4908,7 @@ so that propagation occurs. 'provide/contract18 '(begin (eval '(module pc18-pos mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct s ()) (provide/contract [struct s ()]))) (eval '(require 'pc18-pos)) @@ -4918,19 +4918,19 @@ so that propagation occurs. 'provide/contract19 '(begin (eval '(module pc19-a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct a (x)) (provide/contract [struct a ([x number?])]))) (eval '(module pc19-b mzscheme (require 'pc19-a - (lib "contract.ss")) + scheme/contract) (define-struct (b a) (y)) (provide/contract [struct (b a) ([x number?] [y number?])]))) (eval '(module pc19-c mzscheme (require 'pc19-b - (lib "contract.ss")) + scheme/contract) (define-struct (c b) (z)) (provide/contract [struct (c b) ([x number?] [y number?] [z number?])]))) @@ -4948,7 +4948,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract20 '(eval '(module tmp mzscheme - (require (lib "contract.ss") + (require scheme/contract (lib "unit.ss")) (define-struct s (a b)) @@ -4961,7 +4961,7 @@ so that propagation occurs. 'provide/contract21 '(begin (eval '(module provide/contract21a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [f integer?]) (define f 1))) (eval '(module provide/contract21b mzscheme @@ -4974,7 +4974,7 @@ so that propagation occurs. 'provide/contract22 '(begin (eval '(module provide/contract22a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [make-bound-identifier-mapping integer?]) (define make-bound-identifier-mapping 1))) (eval '(module provide/contract22b mzscheme @@ -4990,7 +4990,7 @@ so that propagation occurs. 'provide/contract23 '(begin (eval '(module provide/contract23a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [f integer?]) (define f 3))) @@ -5005,7 +5005,7 @@ so that propagation occurs. 'provide/contract24 '(begin (eval '(module provide/contract24 mzscheme - (require (prefix c: (lib "contract.ss"))) + (require (prefix c: scheme/contract)) (c:case-> (c:-> integer? integer?) (c:-> integer? integer? integer?)))))) @@ -5015,7 +5015,7 @@ so that propagation occurs. 'provide/contract25 '(begin (eval '(module provide/contract25a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [seventeen integer?]) (define seventeen 17))) (eval '(module provide/contract25b mzscheme @@ -5039,7 +5039,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce1-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define the-defined-variable1 'five) (provide/contract [the-defined-variable1 number?]))) (eval '(require 'pce1-bug))) @@ -5050,7 +5050,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce2-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define the-defined-variable2 values) (provide/contract [the-defined-variable2 (-> number? any)]))) (eval '(require 'pce2-bug)) @@ -5062,7 +5062,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce3-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define the-defined-variable3 (λ (x) #f)) (provide/contract [the-defined-variable3 (-> any/c number?)]))) (eval '(require 'pce3-bug)) @@ -5074,7 +5074,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce4-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define the-defined-variable4 (λ (x) #f)) (provide/contract [the-defined-variable4 (-> any/c number?)]))) (eval '(require 'pce4-bug)) @@ -5086,7 +5086,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce5-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct bad (a b)) @@ -5100,7 +5100,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce6-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct bad-parent (a)) (define-struct (bad bad-parent) (b)) diff --git a/doc/release-notes/mzscheme/MzScheme_4.txt b/doc/release-notes/mzscheme/MzScheme_4.txt index f3e6e6ea40..31cf841053 100644 --- a/doc/release-notes/mzscheme/MzScheme_4.txt +++ b/doc/release-notes/mzscheme/MzScheme_4.txt @@ -111,6 +111,11 @@ in several significant ways: - Windows console binary names are converted like Unix binary names: downcased with " " replaced by "-". + - The contract library (in scheme/contract) no longer + exports object or mixin contracts. Instead they are + exported from scheme/class. (The libraries in mzlib + remain the same as before.) + ====================================================================== Immutable and Mutable Pairs ======================================================================