[plt-scheme] Best place to install custom current-module-name-resolver?
On Thu, 2008-04-10 at 09:53 -0600, Matthew Flatt wrote:
> You'd have to modify DrScheme and/or MzScheme, such as replacing the
> handler that's in "src/mzscheme/startup.ss".
I've modified src/mzscheme/startup.ss (diff below), but then ran into a
problem: I can't catch the "file not found" exception possibly thrown
by current-load/use-compiled because neither call-with-exception-handler
nor with-handlers is available in startup.ss. Is there any way to catch
this exception where I'm trying to?
Thanks again,
--
: Derick
----------------------------------------------------------------
diff -u -b -r plt-3.99.0.23/collects/r6rs/private/parse-ref.ss plt-3.99.0.23--more-exts/collects/r6rs/private/parse-ref.ss
--- plt-3.99.0.23/collects/r6rs/private/parse-ref.ss 2008-03-06 19:18:06.000000000 -0800
+++ plt-3.99.0.23--more-exts/collects/r6rs/private/parse-ref.ss 2008-04-10 12:54:25.000000000 -0700
@@ -64,8 +64,7 @@
(append (cdr coll) (list file)))
(map (lambda (v)
(format "-~a" v))
- vers)
- (list ".ss")))
+ vers)))
(err "cannot find suitable installed library")))))]
[(id1 id2 ...)
(and (identifier? #'id1)
diff -u -b -r plt-3.99.0.23/src/mzscheme/src/startup.ss plt-3.99.0.23--more-exts/src/mzscheme/src/startup.ss
--- plt-3.99.0.23/src/mzscheme/src/startup.ss 2008-04-08 14:42:38.000000000 -0700
+++ plt-3.99.0.23--more-exts/src/mzscheme/src/startup.ss 2008-04-10 13:46:09.000000000 -0700
@@ -625,7 +625,17 @@
#f
s
stx)
- (error s)))])
+ (error s)))]
+ [try-more-exts #f]
+ [try-next-ext-k #f])
+ (let-values ([(exts last-ex)
+ (call/cc (lambda (k)
+ (set! try-next-ext-k k)
+ (values '(".ss" ".sls" ".scm" ".sch" ".mzscheme.ss"
+ ".mzscheme.sls" ".mzscheme.scm" ".mzscheme.sch")
+ #f)))])
+ (when (null? exts)
+ (raise last-ex))
(let ([s-parsed
;; Non-string result represents an error
(cond
@@ -638,9 +648,10 @@
show-collection-err
(if (null? cols) file (car cols))
(if (null? cols) null (cdr cols)))])
+ (set! try-more-exts #t)
(build-path p (if (null? cols)
"main.ss"
- (string-append file ".ss"))))))]
+ (string-append file (car exts)))))))]
[(string? s)
(let* ([dir (get-dir)])
(or (hash-ref -path-cache (cons s dir) #f)
@@ -690,7 +701,9 @@
"main.ss"
(if (regexp-match? #rx"[.]" file)
file
- (string-append file ".ss"))))))))]
+ (begin
+ (set! try-more-exts #t)
+ (string-append file (car exts))))))))))]
[(eq? (car s) 'file)
(path->complete-path (cadr s) (get-dir))])])
(unless (or (path? s-parsed)
@@ -759,11 +772,18 @@
(lambda (f) (f))
(lambda (f) (call-with-continuation-prompt f -loading-prompt-tag)))
(lambda ()
+ (call-with-exception-handler
+ (lambda (ex)
+ (if (and try-more-exts
+ (exn:fail:filesystem? ex))
+ (try-next-ext-k (cdr exts) ex)
+ (raise ex)))
+ (lambda ()
(with-continuation-mark -loading-filename (cons (current-namespace) normal-filename)
(parameterize ([current-module-declare-name modname])
((current-load/use-compiled)
filename
- (string->symbol (path->string no-sfx)))))))
+ (string->symbol (path->string no-sfx)))))))))
(hash-set! ht modname #t))))
;; If a `lib' path, cache pathname manipulations
(when (and (not (vector? s-parsed))
@@ -780,7 +800,7 @@
no-sfx
modname)))
;; Result is the module name:
- modname))))))])]))
+ modname)))))))])]))
standard-module-name-resolver))
(define-values (boot)