define-member-name and member-name-key

svn: r3415

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

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
@@ -1131,7 +1138,7 @@
 				  (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

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)