Implement PATHNAME->URI.

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index 0239d1ac6fd6396b45f3152956d70a2ab6332859..f57e25d68012796d863fb95f818698a7739807f0 100644 (file)
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: pathnm.scm,v 14.42 2004/11/26 05:04:27 cph Exp $
+$Id: pathnm.scm,v 14.43 2006/01/31 18:50:02 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology
-Copyright 2004 Massachusetts Institute of Technology
+Copyright 2004,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -298,6 +298,41 @@ these rules:
                    (or (%pathname-name pathname) name)
                    (or (%pathname-type pathname) type)
                    (or (%pathname-version pathname) version))))
+
+(define (pathname->uri pathname)
+  (let ((pathname (->pathname pathname)))
+    (receive (scheme authority)
+       (if (pathname-absolute? pathname)
+           (values 'file (make-uri-authority #f "" #f))
+           (values #f #f))
+      (make-uri scheme
+               authority
+               (map (lambda (x)
+                      (if (eq? x 'WILD)
+                          "*"
+                          (string->utf8-string x)))
+                    (let ((missing?
+                           (lambda (x)
+                             (or (not x)
+                                 (eq? x 'UNSPECIFIC)))))
+                      (append (if (pathname-absolute? pathname)
+                                  (list "")
+                                  '())
+                              (let ((device (pathname-device pathname))
+                                    (directory (pathname-directory pathname)))
+                                (if (missing? device)
+                                    (if (missing? directory)
+                                        '()
+                                        (cdr directory))
+                                    (cons device (cdr directory))))
+                              (let ((name (file-namestring pathname)))
+                                (if (missing? name)
+                                    (if (pathname-absolute? pathname)
+                                        (list "")
+                                        '())
+                                    (list name))))))
+               #f
+               #f))))
 \f
 ;;;; Pathname Syntax
 

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5874bf535976c59be2ae06d141971fbba4314c22..26a3123eba4787763c64847d095ec062f140cd69 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,10 +1,11 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.571 2005/12/25 17:04:39 riastradh Exp $
+$Id: runtime.pkg,v 14.572 2006/01/31 18:50:03 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
 Copyright 2000,2001,2002,2003,2004,2005 Massachusetts Institute of Technology
+Copyright 2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -2570,6 +2571,7 @@ USA.
          make-pathname
          merge-pathnames
          parse-namestring
+         pathname->uri
          pathname-absolute?
          pathname-as-directory
          pathname-default