Add system-dependent pathname canonicalization.

diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm
index 2b9360eda959862cf58ac3c7d747e82f89daadc8..06f6bf7f30fdf682f59ca7e1a59a9f11ec361758 100644 (file)
--- a/v7/src/runtime/dospth.scm
+++ b/v7/src/runtime/dospth.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dospth.scm,v 1.7 1992/07/28 19:43:18 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dospth.scm,v 1.8 1992/08/12 08:49:46 jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -62,7 +62,8 @@ MIT in each case. |#
                  dos/user-homedir-pathname
                  dos/init-file-pathname
                  dos/pathname-simplify
-                 dos/end-of-line-string))
+                 dos/end-of-line-string
+                 dos/canonicalize))
 
 (define (initialize-package!)
   (add-pathname-host-type! 'DOS make-dos-host-type))
@@ -190,6 +191,29 @@ MIT in each case. |#
   (if (substring=? string start end "*" 0 1)
       'WILD
       (substring string start end)))
+
+(define (dos/canonicalize pathname)
+  (define (valid? field length)
+    (or (not (string? field))
+       (<= (string-length field) length)))
+
+  (define (canonicalize-field field length)
+    (if (not (string? field))
+       field
+       (substring field 0 length)))
+
+  ;; This should really canonicalize the directory as well.
+  (let ((name (%pathname-name pathname))
+       (type (%pathname-type pathname)))
+    (if (and (valid? name 8)
+            (valid? type 3)
+       pathname
+       (%make-pathname (%pathname-host pathname)
+                       (%pathname-device pathname)
+                       (%pathname-directory pathname)
+                       (canonicalize-field name 8)
+                       (canonicalize-field type 3)
+                       (%pathname-version pathname))))))
 \f
 ;;;; Pathname Unparser
 

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index 4f85519a9c58cf988509139707f4a443b20fc485..79a03fb1edb1776cafd024cb82c676e6f1d6049b 100644 (file)
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.20 1992/04/16 05:12:44 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.21 1992/08/12 08:50:05 jinx Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -218,30 +218,33 @@ these rules:
 
 (define (pathname-new-directory pathname directory)
   (let ((pathname (->pathname pathname)))
-    (%make-pathname (%pathname-host pathname)
-                   (%pathname-device pathname)
-                   directory
-                   (%pathname-name pathname)
-                   (%pathname-type pathname)
-                   (%pathname-version pathname))))
+    ((host-operation/pathname-canonicalize (%pathname-host pathname))
+     (%make-pathname (%pathname-host pathname)
+                    (%pathname-device pathname)
+                    directory
+                    (%pathname-name pathname)
+                    (%pathname-type pathname)
+                    (%pathname-version pathname)))))
 
 (define (pathname-new-name pathname name)
   (let ((pathname (->pathname pathname)))
-    (%make-pathname (%pathname-host pathname)
-                   (%pathname-device pathname)
-                   (%pathname-directory pathname)
-                   name
-                   (%pathname-type pathname)
-                   (%pathname-version pathname))))
+    ((host-operation/pathname-canonicalize (%pathname-host pathname))
+     (%make-pathname (%pathname-host pathname)
+                    (%pathname-device pathname)
+                    (%pathname-directory pathname)
+                    name
+                    (%pathname-type pathname)
+                    (%pathname-version pathname)))))
 
 (define (pathname-new-type pathname type)
   (let ((pathname (->pathname pathname)))
-    (%make-pathname (%pathname-host pathname)
-                   (%pathname-device pathname)
-                   (%pathname-directory pathname)
-                   (%pathname-name pathname)
-                   type
-                   (%pathname-version pathname))))
+    ((host-operation/pathname-canonicalize (%pathname-host pathname))
+     (%make-pathname (%pathname-host pathname)
+                    (%pathname-device pathname)
+                    (%pathname-directory pathname)
+                    (%pathname-name pathname)
+                    type
+                    (%pathname-version pathname)))))
 
 (define (pathname-new-version pathname version)
   (let ((pathname (->pathname pathname)))
@@ -443,7 +446,8 @@ these rules:
   (operation/user-homedir-pathname false read-only true)
   (operation/init-file-pathname false read-only true)
   (operation/pathname-simplify false read-only true)
-  (operation/end-of-line-string false read-only true))
+  (operation/end-of-line-string false read-only true)
+  (operation/pathname-canonicalize false read-only true))
 
 (define-structure (host
                   (named (string->symbol "#[(runtime pathname)host]"))
@@ -499,6 +503,9 @@ these rules:
 
 (define (host-operation/end-of-line-string host)
   (host-type/operation/end-of-line-string (host/type host)))
+
+(define (host-operation/pathname-canonicalize host)
+  (host-type/operation/pathname-canonicalize (host/type host)))
 \f
 ;;;; File System Stuff