fix mistakes in augment corrections; fix runtime-path handling of lib paths

svn: r11577

collects/mzlib/runtime-path.ss

@@ -1,22 +1,25 @@
 
-(module runtime-path mzscheme
+(module runtime-path scheme/base
   (require mzlib/etc
            syntax/modcollapse
 	   setup/dirs
-           (only "private/runtime-path-table.ss" table))
+           scheme/list
+           scheme/string
+           (only-in "private/runtime-path-table.ss" table)
+           (for-syntax scheme/base))
 
   (provide define-runtime-path
            define-runtime-paths
            define-runtime-path-list
            runtime-paths)
   
-  (define-for-syntax ext-file-table (make-hash-table))
+  (define-for-syntax ext-file-table (make-hasheq))
 
   (define (lookup-in-table tag-stx p)
     ;; This function is designed to cooperate with a table embedded
     ;; in an executable by create-embedding-executable.
     (let ([mpi (syntax-source-module tag-stx)])
-      (let ([p (hash-table-get
+      (let ([p (hash-ref
                 table
                 (cons (cond
                         [(module-path-index? mpi)
@@ -71,10 +74,16 @@
 		      ((length p) . > . 1)
 		      (eq? 'lib (car p))
 		      (andmap string? (cdr p)))
-		 (let ([dir (if (null? (cddr p))
+		 (let* ([strs (regexp-split #rx"/" 
-                                (collection-path "mzlib")
+                                            (let ([s (cadr p)])
-                                (apply collection-path (cddr p)))])
+                                              (if (regexp-match? #rx"[./]" s)
-                   (build-path dir (cadr p)))]
+                                                  s
+                                                  (string-append s "/main.ss"))))]
+                        [dir (if (and (null? (cddr p))
+                                      (null? (cdr strs)))
+                                 (collection-path "mzlib")
+                                 (apply collection-path (append (cddr p) (drop-right strs 1))))])
+                   (build-path dir (last strs)))]
                 [else (error 'runtime-path "unknown form: ~e" p)])))
            paths)))
   
@@ -85,8 +94,8 @@
                        [(symbol? mpi) mpi]
                        [else (error 'register-ext-files
                                     "cannot determine source")])])
-        (let ([files (hash-table-get ext-file-table modname null)])
+        (let ([files (hash-ref ext-file-table modname null)])
-          (hash-table-put! ext-file-table modname (append paths files))))))
+          (hash-set! ext-file-table modname (append paths files))))))
     
   (define-syntax (-define-runtime-path stx)
     (syntax-case stx ()
@@ -101,12 +110,12 @@
                         #'orig-stx
                         id)))
                    ids)
-         (let ([tag (datum->syntax-object #'orig-stx 'tag #'orig-stx)])
+         (let ([tag (datum->syntax #'orig-stx 'tag #'orig-stx)])
            #`(begin
                (define-values (id ...)
                  (let-values ([(id ...) expr])
                    (let ([get-dir (lambda ()
-                                    #,(datum->syntax-object
+                                    #,(datum->syntax
                                        tag
                                        `(,#'this-expression-source-directory)
                                        tag))])
@@ -135,10 +144,10 @@
     (syntax-case stx ()
       [(_ mp)
        #`(quote
-          #,(hash-table-get
+          #,(hash-ref
              ext-file-table
              (module-path-index-resolve (module-path-index-join
-                                         (syntax-object->datum #'mp)
+                                         (syntax->datum #'mp)
                                          (syntax-source-module stx)))
              null))]))
 

collects/scheme/private/class-internal.ss

@@ -1837,7 +1837,7 @@
 	   [no-method-changes? (and (null? public-names)
 				    (null? override-names)
 				    (null? augride-names)
-                                    (null? overment-names))]
+                                    (null? final-names))]
 	   [no-new-fields? (null? public-field-names)]
 	   [xappend (lambda (a b) (if (null? b) a (append a b)))])
 
@@ -2193,7 +2193,8 @@
 					  (let ([v (list->vector (vector->list v))])
 					    (vector-set! v (sub1 (vector-length v)) method)
 					    (vector-set! beta-methods index v))))
-				    (vector-set! meth-flags index (not make-struct:prim)))
+                                    (when (not (vector-ref meth-flags index))
+                                      (vector-set! meth-flags index (not make-struct:prim))))
 				  (append replace-augonly-indices replace-final-indices replace-normal-indices
 					  refine-augonly-indices refine-final-indices refine-normal-indices)
 				  (append override-methods augride-methods)
@@ -2205,7 +2206,7 @@
                                     (append overment-names pubment-names))
                           (for-each (lambda (id)
                                       (vector-set! meth-flags (hash-ref method-ht id) #t))
-                                    augride-names))
+                                    augride-normal-names))
                         ;; Expand `rename-inner' vector, adding a #f to indicate that
 			;;  no rename-inner function is available, so far
 			(for-each (lambda (id)

collects/tests/mzscheme/object.ss

@@ -111,6 +111,17 @@
     (define (x) 1)
     (define (y) 1)))
 
+(define to-override3-class%
+  (class to-override2-class%
+    (oevrride x y)
+    (define (x) 1)
+    (define (y) 1)))
+(define to-augment3-class%
+  (class to-augment2-class%
+    (augment x y)
+    (define (x) 1)
+    (define (y) 1)))
+
 (define (test-method basic? public object% over? aug? super-ok? inner-ok? over-ok? aug-ok?)
   (when basic?
     (teval #`(test #t class? (class #,object% (#,public))))
@@ -139,7 +150,6 @@
 	(begin
 	  (teval #`(err/rt-test (class #,object% (#,public (x x)) (define (x) 1)) exn:fail:object?))
 	  (teval #`(err/rt-test (class #,object% (#,public (x y) (y x)) (define (x) 1) (define (y) 2)) exn:fail:object?)))))
-	
 
   ;; Use of external name for super/inner is always wrong (but
   ;; maybe because super/inner isn't allowed):
@@ -196,6 +206,7 @@
 
 (test-over/aug #'to-override-class% #'to-augment-class%)
 (test-over/aug #'to-override2-class% #'to-augment2-class%)
+(test-over/aug #'to-override3-class% #'to-augment3-class%)
 
 (define (test-rename rename object%)
   (teval #`(test #t class? (class #,object% (#,rename))))