diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index d3dd6673b6..7ade4fc857 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -22,7 +22,7 @@ define/override define/overment define/augride define/augment define/public-final define/override-final define/augment-final - define-local-member-name + define-local-member-name define-member-name member-name-key generate-member-key generic make-generic send-generic is-a? subclass? implementation? interface-extension? object-interface object-info object->vector diff --git a/collects/mzlib/private/class-internal.ss b/collects/mzlib/private/class-internal.ss index 9a251a9de7..95962b0126 100644 --- a/collects/mzlib/private/class-internal.ss +++ b/collects/mzlib/private/class-internal.ss @@ -397,8 +397,14 @@ (let* ([def-ctx (syntax-local-make-definition-context)] [localized-map (make-bound-identifier-mapping)] + [any-localized? #f] + [localize/set-flag (lambda (id) + (let ([id2 (localize id)]) + (unless (eq? id id2) + (set! any-localized? #t)) + id2))] [bind-local-id (lambda (id) - (let ([l (localize id)]) + (let ([l (localize/set-flag id)]) (syntax-local-bind-syntaxes (list id) #f def-ctx) (bound-identifier-mapping-put! localized-map @@ -868,7 +874,7 @@ [iids (map norm-init/field-iid norms)] [exids (map norm-init/field-eid norms)]) (with-syntax ([(id ...) iids] - [(idpos ...) (map localize exids)] + [(idpos ...) (map localize/set-flag exids)] [(defval ...) (map (lambda (norm) (if (stx-null? (stx-cdr norm)) @@ -959,6 +965,7 @@ (format "set-~a!" (syntax-e id))) inherit-field-names))] + [(inherit-name ...) (definify (map car inherits))] [(inherit-field-name ...) (definify inherit-field-names)] [(inherit-field-name-localized ...) (map lookup-localize inherit-field-names)] [(local-field ...) (definify @@ -1126,12 +1133,12 @@ (stx-car (stx-cdr (car inspect-decls))) #'(current-inspector))] [deserialize-id-expr deserialize-id-expr]) - + (quasisyntax/loc stx (let ([superclass super-expression] [interfaces (list interface-expression ...)]) (compose-class - 'name superclass interfaces inspector deserialize-id-expr + 'name superclass interfaces inspector deserialize-id-expr #,any-localized? ;; Field count: num-fields ;; Field names: @@ -1483,10 +1490,53 @@ (values (generate-local-member-name 'id) ...)) stx-defs))))))])) + (define-syntax (define-member-name stx) + (syntax-case stx () + [(_ id expr) + (let ([name #'id]) + (unless (identifier? name) + (raise-syntax-error + #f + "expected an identifier for definition" + stx + name)) + (with-syntax ([stx-def + ;; Need to attach srcloc to this definition: + (syntax/loc stx + (define-syntax id + (make-private-name (quote-syntax id) + ((syntax-local-certifier) (quote-syntax member-name)))))]) + #'(begin + (define member-name (check-member-key 'id expr)) + stx-def)))])) + (define (generate-local-member-name id) (string->uninterned-symbol (symbol->string id))) + (define-struct member-key (id)) + + (define (check-member-key id v) + (unless (member-key? v) + (error 'define-local-member-name "not a member key for ~a: ~e" id v)) + (member-key-id v)) + + (define-syntax (member-name-key stx) + (syntax-case stx () + [(_ id) + (identifier? #'id) + (with-syntax ([id (localize #'id)]) + (syntax/loc stx (make-member-key `id)))] + [(_ x) + (raise-syntax-error + #f + "not an identifier" + stx + #'x)])) + + (define (generate-member-key) + (make-member-key (generate-local-member-name (gensym 'member)))) + ;;-------------------------------------------------------------------- ;; class implementation ;;-------------------------------------------------------------------- @@ -1541,6 +1591,7 @@ interfaces ; list of interfaces inspector ; inspector or #f deserialize-id ; identifier or #f + any-localized? ; #t => need to double-check distinct external names num-fields ; total fields (public & private) public-field-names ; list of symbols (shorter than num-fields) @@ -1570,6 +1621,21 @@ (obj-error 'class* "superclass expression returned a non-class: ~a~a" super (for-class name))) + + (when any-localized? + (check-still-unique name + init-args + "initialization argument names") + (check-still-unique name + (append public-field-names inherit-field-names) + "field names") + (check-still-unique name + (append pubment-names public-final-names public-normal-names + overment-names override-final-names override-normal-names + augment-names augment-final-names augride-normal-names + inherit-names) + "method names")) + ;; -- Create new class's name -- (let* ([name (or name (let ([s (class-name super)]) @@ -2016,6 +2082,18 @@ ((class-fixup c) o o2)))))))) c)))))))))))) + (define (check-still-unique name syms what) + (let ([ht (make-hash-table)]) + (for-each (lambda (s) + (when (hash-table-get ht s + (lambda () + (hash-table-put! ht s #t) + #f)) + (obj-error 'class* "external ~a mapped to overlapping keys~a" + what + (for-class name)))) + syms))) + (define-values (prop:object object? object-ref) (make-struct-type-property 'object)) ;;-------------------------------------------------------------------- @@ -2912,6 +2990,7 @@ null #f #f + #f 0 null null ; no fields @@ -3275,7 +3354,7 @@ define/override define/overment define/augride define/augment define/public-final define/override-final define/augment-final - define-local-member-name + define-local-member-name define-member-name member-name-key generate-member-key (rename generic/form generic) (rename make-generic/proc make-generic) send-generic is-a? subclass? implementation? interface-extension? object-interface object-info object->vector diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index 05db5381d0..a576de73dc 100644 --- a/collects/tests/mzscheme/object.ss +++ b/collects/tests/mzscheme/object.ss @@ -1158,6 +1158,84 @@ (check-class-cert 'init-field rename?)) '(#t #f)) + +;; ------------------------------------------------------------ +;; Check arity reporting for methods. +;; (This is really a MzScheme test, not a class.s test.) + +(map + (lambda (jit?) + (parameterize ([eval-jit-enabled jit?]) + (let ([mk-f (lambda () + (eval (syntax-property #'(lambda (a b) a) 'method-arity-error #t)))] + [check-arity-error + (lambda (f cl?) + (test (if cl? '("no clause matching 0 arguments") '("expects 1 argument") ) + regexp-match #rx"expects 1 argument|no clause matching 0 arguments" + (exn-message (with-handlers ([values values]) + ;; Use `apply' to avoid triggering + ;; compilation of f: + (apply f '(1))))))]) + (test 2 procedure-arity (mk-f)) + (check-arity-error (mk-f) #f) + (test 1 (mk-f) 1 2) + (let ([f (mk-f)]) + (test 1 (mk-f) 1 2) + (check-arity-error (mk-f) #f)) + (let ([mk-f (lambda () + (eval (syntax-property #'(case-lambda [(a b) a][(c d) c]) 'method-arity-error #t)))]) + (test '(2 2) procedure-arity (mk-f)) + (check-arity-error (mk-f) #t) + (test 1 (mk-f) 1 2) + (let ([f (mk-f)]) + (test 1 (mk-f) 1 2) + (check-arity-error (mk-f) #t)))))) + '(#t #f)) + +;; ------------------------------------------------------------ +;; Check define-member-name, etc.: + +(let ([mk + (lambda (% a-name aa-name b-name c-name d-name e-name) + (define-member-name a a-name) ; init + (define-member-name aa aa-name) ; super init + (define-member-name b b-name) ; public + (define-member-name c c-name) ; override + (define-member-name d d-name) ; augment + (define-member-name e e-name) ; inherit + (class % + (init a) + (define a-val a) + (inherit e) + (define/public (b x) + (list 'b a-val x (e x))) + (define/override (c y) + (list 'c a-val y (super c y))) + (define/augment (d y) + (list 'd a-val y (inner #f d y))) + (super-new [aa (list a)])))]) + (define x% (class object% + (init x-a) + (define/public (x-e y) + (list 'x-e y)) + (define/public (x-c y) + (list 'x-c y)) + (define/pubment (x-d y) + (list 'x-d y (inner #f x-d y))) + (super-new))) + (let* ([x+% (mk x% + (member-name-key a+) + (member-name-key x-a) + (member-name-key b+) + (member-name-key x-c) + (member-name-key x-d) + (member-name-key x-e))] + [o (new x+% [a+ 'a-val])]) + (test '(b a-val 1 (x-e 1)) 'send-b+ (send o b+ 1)) + (test '(c a-val 2 (x-c 2)) 'send-b+ (send o x-c 2)) + (test '(x-d 3 (d a-val 3 #f)) 'send-b+ (send o x-d 3)) + (void))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs)