suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r11577
This commit is contained in:
Matthew Flatt 2008-09-08 19:44:32 +00:00
parent 74addc1b71
commit 1a8b6cb824
3 changed files with 39 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/mzlib/runtime-path.ss
View File

@ -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))]))

7
collects/scheme/private/class-internal.ss
View File

@ -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)

13
collects/tests/mzscheme/object.ss
View File

@ -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))))