From 37fff4a32ba8d52e7cb7d54ebfe01fa2cb9d4015 Mon Sep 17 00:00:00 2001
From: "Guillermo J. Rozas" <edu/mit/csail/zurich/gjr>
Date: Wed, 12 Aug 1992 08:50:05 +0000
Subject: [PATCH] Add system-dependent pathname canonicalization.

---
 v7/src/runtime/dospth.scm | 28 +++++++++++++++++++++--
 v7/src/runtime/pathnm.scm | 47 ++++++++++++++++++++++-----------------
 2 files changed, 53 insertions(+), 22 deletions(-)

diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm
index 2b9360eda..06f6bf7f3 100644
--- 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))))))
 
 ;;;; Pathname Unparser
 
diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index 4f85519a9..79a03fb1e 100644
--- 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)))
 
 ;;;; File System Stuff
 
-- 
2.25.1