diff --git a/collects/mzlib/runtime-path.ss b/collects/mzlib/runtime-path.ss index 795f2c3c57..4fbbc81d50 100644 --- a/collects/mzlib/runtime-path.ss +++ b/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)) - (collection-path "mzlib") - (apply collection-path (cddr p)))]) - (build-path dir (cadr p)))] + (let* ([strs (regexp-split #rx"/" + (let ([s (cadr p)]) + (if (regexp-match? #rx"[./]" s) + 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)]) - (hash-table-put! ext-file-table modname (append paths files)))))) + (let ([files (hash-ref ext-file-table modname null)]) + (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))])) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index bf4b21bf5b..6bfec81799 100644 --- a/collects/scheme/private/class-internal.ss +++ b/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) diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss index 4fe2ff01b4..62951775e2 100644 --- a/collects/tests/mzscheme/object.ss +++ b/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))))