From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 31 Jan 1995 22:36:55 +0000 (+0000)
Subject: Temporary filenames now use long format which includes the Scheme PID
X-Git-Tag: 20090517-FFI~6678
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fb8eb63e693846d05faee48b4dd4015b22f08500;p=mit-scheme.git

Temporary filenames now use long format which includes the Scheme PID
if the filesystem that they are stored on supports long filenames.
---

diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index 160963f1b..af28e77f9 100644
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.4 1995/01/31 19:34:44 cph Exp $
+$Id: os2prm.scm,v 1.5 1995/01/31 22:36:55 cph Exp $
 
 Copyright (c) 1994-95 Massachusetts Institute of Technology
 
@@ -160,7 +160,15 @@ MIT in each case. |#
   ((ucode-primitive get-environment-variable 1) name))
 
 (define (temporary-file-pathname)
-  (let ((root (merge-pathnames "_scm_tmp" (temporary-directory-pathname))))
+  (let ((root
+	 (let ((directory (temporary-directory-pathname)))
+	   (merge-pathnames
+	    (if (os2/fs-long-filenames? directory)
+		(string-append
+		 "sch"
+		 (string-pad-left (number->string (os2/current-pid)) 6 #\0))
+		"_scm_tmp")
+	    directory))))
     (let loop ((ext 0))
       (let ((pathname (pathname-new-type root (number->string ext))))
 	(if (allocate-temporary-file pathname)
@@ -191,6 +199,14 @@ MIT in each case. |#
 	  (try-directory "\\")
 	  (error "Can't find temporary directory.")))))
 
+(define (os2/fs-long-filenames? pathname)
+  (let ((type ((ucode-primitive drive-type 1) (pathname-device pathname))))
+    (or (string-ci=? "hpfs" type)
+	(string-ci=? "nfs" type))))
+
+(define-integrable os2/current-pid
+  (ucode-primitive current-pid 0))
+
 (define (os2/current-home-directory)
   (let ((home (get-environment-variable "HOME")))
     (if home