[plt-scheme] Best place to install custom current-module-name-resolver?

From: Derick Eddington (derick.eddington at gmail.com)
Date: Thu Apr 10 17:16:58 EDT 2008

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)




Posted on the users mailing list.