diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index 39bcc4d..7b7579f 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -246,51 +246,6 @@ (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")] [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)])) - ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc] - (define (build-methods-stx mtds) - - (define (last-pair l) - (cond - [(not (pair? (cdr l))) l] - [else (last-pair (cdr l))])) - - (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)] - [names (map mtd-name mtds)] - [i 0]) - (cond - [(null? arg-spec-stxss) null] - [else (let ([arg-spec-stxs (car arg-spec-stxss)]) - (with-syntax ([(cases ...) - (map (lambda (arg-spec-stx) - (with-syntax ([i i]) - (syntax-case arg-spec-stx () - [(this rest-ids ...) - (syntax - ((this rest-ids ...) - ((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))] - [else - (let-values ([(this rest-ids last-var) - (let ([lst (syntax->improper-list arg-spec-stx)]) - (values (car lst) - (all-but-last (cdr lst)) - (cdr (last-pair lst))))]) - (with-syntax ([this this] - [(rest-ids ...) rest-ids] - [last-var last-var]) - (syntax - ((this rest-ids ... . last-var) - (apply (field-ref this i) - (wrapper-object-wrapped this) - rest-ids ... - last-var)))))]))) - (syntax->list arg-spec-stxs))] - [name (string->symbol (format "~a method" (syntax->datum (car names))))]) - (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)]) - (cons (syntax (lambda (field-ref) (let ([name proc]) name))) - (loop (cdr arg-spec-stxss) - (cdr names) - (+ i 1))))))]))) - (define (syntax->improper-list stx) (define (se->il se) (cond @@ -317,61 +272,29 @@ (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)] [(method-name ...) (map mtd-name mtds)] [(method-ctc-var ...) (generate-temporaries mtds)] - [(method-var ...) (generate-temporaries mtds)] - [(method/app-var ...) (generate-temporaries mtds)] - [(methods ...) (build-methods-stx mtds)] [(field-ctc-stx ...) (map fld-ctc-stx flds)] [(field-name ...) (map fld-name flds)] - [(field-ctc-var ...) (generate-temporaries flds)] - [(field-var ...) (generate-temporaries flds)] - [(field/app-var ...) (generate-temporaries flds)]) + [(field-ctc-var ...) (generate-temporaries flds)]) (syntax (let ([method-ctc-var method-ctc-stx] ... [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] ...) - (let ([method-var (contract-projection method-ctc-var)] - ... - [field-var (contract-projection field-ctc-var)] - ...) - (let ([cls (make-wrapper-class 'wrapper-class - '(method-name ...) - (list methods ...) - '(field-name ...) - #t)]) - (make-contract - #:name - `(object-contract - ,(build-compound-type-name 'method-name method-ctc-var) ... - ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) - #:projection - (lambda (blame) - (let ([method/app-var (method-var blame)] - ... - [field/app-var (field-var blame)] - ...) - (let ([field-names-list '(field-name ...)]) - (lambda (val) - (check-object val blame) - (let ([val-mtd-names - (interface->method-names - (object-interface - val))]) - (void) - (check-method val 'method-name val-mtd-names blame) - ...) - - (unless (field-bound? field-name val) - (field-error val 'field-name blame)) ... - - (let ([vtable (extract-vtable val)] - [method-ht (extract-method-ht val)]) - (make-object cls - val - (method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ... - (field/app-var (get-field field-name val)) ... - )))))))))))))])))) + (make-contract + #:name + `(object-contract + ,(build-compound-type-name 'method-name method-ctc-var) ... + ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) + #:projection + (lambda (blame) + (lambda (val) + (make-wrapper-object val blame + (list 'method-name ...) (list method-ctc-var ...) + (list 'field-name ...) (list field-ctc-var ...)))) + #:first-order + (lambda (val) + (check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))])))) (define (check-object val blame) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index f42cfe3..1858afb 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -1652,10 +1652,12 @@ of the contract library does not change over time. (test/pos-blame 'object-contract/field2 - '(contract (object-contract (field x integer?)) - (new (class object% (field [x #t]) (super-new))) - 'pos - 'neg)) + '(get-field + x + (contract (object-contract (field x integer?)) + (new (class object% (field [x #t]) (super-new))) + 'pos + 'neg))) (test/spec-passed/result 'object-contract/field3 @@ -1669,17 +1671,21 @@ of the contract library does not change over time. (test/pos-blame 'object-contract/field4 - '(contract (object-contract (field x boolean?) (field y boolean?)) - (new (class object% (field [x #t] [y 'x]) (super-new))) - 'pos - 'neg)) + '(get-field + y + (contract (object-contract (field x boolean?) (field y boolean?)) + (new (class object% (field [x #t] [y 'x]) (super-new))) + 'pos + 'neg))) (test/pos-blame 'object-contract/field5 - '(contract (object-contract (field x symbol?) (field y symbol?)) - (new (class object% (field [x #t] [y 'x]) (super-new))) - 'pos - 'neg)) + '(get-field + x + (contract (object-contract (field x symbol?) (field y symbol?)) + (new (class object% (field [x #t] [y 'x]) (super-new))) + 'pos + 'neg))) (test/spec-passed/result 'object-contract/field6 @@ -2710,7 +2716,7 @@ of the contract library does not change over time. ;; ;; test error message has right format ;; - + #| (test/spec-passed/result 'wrong-method-arity-error-message '(with-handlers ([exn:fail? exn-message]) @@ -2722,7 +2728,7 @@ of the contract library does not change over time. 1 2)) "procedure m method: expects 1 argument, given 2: 1 2") - + |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; tests object utilities to be sure wrappers work right @@ -4521,10 +4527,10 @@ so that propagation occurs. (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1) - (ctest #t contract-first-order-passes? + (ctest #f contract-first-order-passes? (object-contract (m (-> integer? integer?))) (new object%)) - (ctest #t contract-first-order-passes? + (ctest #f contract-first-order-passes? (object-contract (m (-> integer? integer?))) 1)