From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 23 Oct 1995 06:39:32 +0000 (+0000)
Subject: Implement new operation OS/FILE-END-OF-LINE-TRANSLATION, which is used
X-Git-Tag: 20090517-FFI~5880
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e00c6b7996df48849c0e958be381f614bc08ce4f;p=mit-scheme.git

Implement new operation OS/FILE-END-OF-LINE-TRANSLATION, which is used
to determine appropriate line-translation by interrogating the file
system to determine its type.  Currently this is interesting only for
OS/2, in which it is common to mount unix file systems.
---

diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm
index f327a5ec4..672dc2cad 100644
--- a/v7/src/runtime/dosprm.scm
+++ b/v7/src/runtime/dosprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dosprm.scm,v 1.30 1995/10/18 05:09:08 cph Exp $
+$Id: dosprm.scm,v 1.31 1995/10/23 06:39:32 cph Exp $
 
 Copyright (c) 1992-95 Massachusetts Institute of Technology
 
@@ -290,6 +290,10 @@ MIT in each case. |#
   ((ucode-primitive directory-delete 1)
    (->namestring (directory-pathname-as-file (merge-pathnames name)))))
 
+(define (os/file-end-of-line-translation pathname)
+  pathname
+  "\r\n")
+
 (define (os/default-end-of-line-translation)
   "\r\n")
 
diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm
index ff5093e23..13e16d0a5 100644
--- a/v7/src/runtime/dospth.scm
+++ b/v7/src/runtime/dospth.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dospth.scm,v 1.30 1995/10/18 05:00:30 cph Exp $
+$Id: dospth.scm,v 1.31 1995/10/23 06:38:26 cph Exp $
 
 Copyright (c) 1992-95 Massachusetts Institute of Technology
 
@@ -371,5 +371,4 @@ MIT in each case. |#
   (hook/dos/end-of-line-string pathname))
 
 (define (default/dos/end-of-line-string pathname)
-  pathname				; ignored
-  (os/default-end-of-line-translation))
\ No newline at end of file
+  (os/file-end-of-line-translation pathname))
\ No newline at end of file
diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index 8dca1e2ab..bbcdab741 100644
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.18 1995/07/07 06:37:24 cph Exp $
+$Id: os2prm.scm,v 1.19 1995/10/23 06:38:35 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -228,11 +228,6 @@ MIT in each case. |#
 	  (try-directory "\\")
 	  (error "Can't find temporary directory.")))))
 
-(define (os2/fs-long-filenames? pathname)
-  (not (string-ci=? "fat"
-		    ((ucode-primitive drive-type 1)
-		     (pathname-device pathname)))))
-
 (define-integrable os2/current-pid
   (ucode-primitive current-pid 0))
 
@@ -255,6 +250,32 @@ MIT in each case. |#
 		    (pathname-as-directory (merge-pathnames directory))
 		    user-name)))))
       "\\"))
+
+(define (os2/fs-drive-type pathname)
+  (let ((type ((ucode-primitive drive-type 1) (pathname-device pathname))))
+    (let ((colon (string-find-next-char type #\:)))
+      (if colon
+	  (cons (string-head type colon) (string-tail type (fix:+ colon 1)))
+	  (cons type "")))))
+
+(define (os2/fs-long-filenames? pathname)
+  (not (string-ci=? "fat" (car (os2/fs-drive-type pathname)))))
+
+(define (os/file-end-of-line-translation pathname)
+  (let ((type (os2/fs-drive-type pathname)))
+    ;; "ext2" is the Linux ext2 file-system driver.  "NFS" is the IBM
+    ;; TCP/IP NFS driver, which we further qualify by examining the
+    ;; mount info -- if the directory starts with a "/", we assume
+    ;; that it is a unix system.
+    (if (or (string=? "ext2" (car type))
+	    (and (string=? "NFS" (car type))
+		 (let* ((mount (cdr type))
+			(colon (string-find-next-char mount #\:)))
+		   (and colon
+			(fix:< (fix:+ colon 1) (string-length mount))
+			(char=? #\/ (string-ref mount (fix:+ colon 1)))))))
+	#f
+	"\r\n")))
 
 (define (os/default-end-of-line-translation)
   "\r\n")
diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm
index 93cc4d7ec..6cd60dbc7 100644
--- a/v7/src/runtime/unxprm.scm
+++ b/v7/src/runtime/unxprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxprm.scm,v 1.39 1995/10/18 05:02:57 cph Exp $
+$Id: unxprm.scm,v 1.40 1995/10/23 06:39:22 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -290,6 +290,10 @@ MIT in each case. |#
   ((ucode-primitive directory-delete 1)
    (->namestring (directory-pathname-as-file (merge-pathnames name)))))
 
+(define (os/file-end-of-line-translation pathname)
+  pathname
+  #f)
+
 (define (os/default-end-of-line-translation)
   #f)