From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 23 Jul 2007 04:52:48 +0000 (+0000)
Subject: Fix WITH-LOADER-BASE-URI so that it correctly recognizes system
X-Git-Tag: 20090517-FFI~486
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f83ff749f049a68708974c377f8cc4e0d6894d9b;p=mit-scheme.git

Fix WITH-LOADER-BASE-URI so that it correctly recognizes system
library URIs and generates relative references to them.
---

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index a05b87690..6c06995ae 100644
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.96 2007/06/13 13:34:47 cph Exp $
+$Id: load.scm,v 14.97 2007/07/23 04:52:48 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -375,9 +375,29 @@ USA.
   (let ((directory (directory-pathname (current-load-pathname))))
     (with-working-directory-pathname directory
       (lambda ()
-	(with-directory-rewriting-rule directory 
-	  (pathname-as-directory (last (uri-path uri)))
-	 thunk)))))
+	(let ((path
+	       (let ((lib (system-library-uri))
+		     (trim-path
+		      (lambda (uri)
+			(reverse! (let ((rp (reverse (uri-path uri))))
+				    (if (and (pair? rp)
+					     (string-null? (car rp)))
+					(cdr rp)
+					rp))))))
+		 (and (eq? (uri-scheme uri) (uri-scheme lib))
+		      (uri-authority=? (uri-authority uri) (uri-authority lib))
+		      (equal? (uri-query uri) (uri-query lib))
+		      (equal? (uri-fragment uri) (uri-fragment lib))
+		      (let loop ((pu (trim-path uri)) (pl (trim-path lib)))
+			(if (pair? pl)
+			    (and (pair? pu)
+				 (string=? (car pu) (car pl))
+				 (loop (cdr pu) (cdr pl)))
+			    (make-pathname #f #f (cons 'RELATIVE pu)
+					   #f #f #f)))))))
+	  (if path
+	      (with-directory-rewriting-rule directory path thunk)
+	      (thunk)))))))
 
 (define (pathname->standard-uri pathname)
   (let ((uri