From: Taylor R. Campbell <net/mumble/campbell>
Date: Sat, 21 Mar 2009 07:09:09 +0000 (+0000)
Subject: New primitives for fsync and exclusive output files.
X-Git-Tag: 20090517-FFI~52
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4dc6c962c4971eaa99211084a8b9d0cad98d8d7c;p=mit-scheme.git

New primitives for fsync and exclusive output files.

The primitive procedure CHANNEL-SYNCHRONIZE attempts to guarantee
that any data associated with the channel are written to permanent
storage.  Passing channels not backed by files in permanent storage
is currently an error, but perhaps should be a no-op instead.  This
procedure does what the fsync system call ought to do, which on most
operating systems it does not necessarily do; this procedure attempts
various different methods from different operating systems to ensure
that data are written to disk and that any disk caches for them are
forced to physical media.

New procedures OPEN-EXCLUSIVE-OUTPUT-FILE and CALL-WITH-*, WITH-*
variants, and binary output file variants, create files at pathnames
that currently have no links, or signal errors if they do.  Errors on
opening files now establish restarts to replace pathnames.

These new primitives are implemented only on Unix; Windows and OS/2
implementations are missing.
---

diff --git a/v7/src/microcode/configure.ac b/v7/src/microcode/configure.ac
index a772bcfba..9a621dac6 100644
--- a/v7/src/microcode/configure.ac
+++ b/v7/src/microcode/configure.ac
@@ -1,7 +1,7 @@
 dnl Process this file with autoconf to produce a configure script.
 
 AC_INIT([MIT/GNU Scheme microcode], [15.1], [bug-mit-scheme@gnu.org], [mit-scheme])
-AC_REVISION([$Id: configure.ac,v 1.61 2008/09/27 03:59:05 cph Exp $])
+AC_REVISION([$Id: configure.ac,v 1.62 2009/03/21 07:09:08 riastradh Exp $])
 AC_CONFIG_SRCDIR([boot.c])
 AC_CONFIG_HEADERS([config.h])
 AC_PROG_MAKE_SET
@@ -621,7 +621,8 @@ AC_FUNC_VPRINTF
 AC_FUNC_WAIT3
 AC_CHECK_FUNCS([ctermid])
 AC_CHECK_FUNCS([dup2])
-AC_CHECK_FUNCS([fcntl fegetround fesetround floor fpathconf frexp ftruncate])
+AC_CHECK_FUNCS([fcntl fdatasync fegetround fesetround floor fpathconf frexp])
+AC_CHECK_FUNCS([fsync fsync_range ftruncate])
 AC_CHECK_FUNCS([getcwd gethostbyname gethostname getlogin getpagesize getpgrp])
 AC_CHECK_FUNCS([getpt gettimeofday getwd grantpt])
 AC_CHECK_FUNCS([kill])
@@ -632,7 +633,7 @@ AC_CHECK_FUNCS([poll prealloc])
 AC_CHECK_FUNCS([rename rmdir])
 AC_CHECK_FUNCS([select setitimer setpgrp setpgrp2 shmat sigaction])
 AC_CHECK_FUNCS([sighold socket statfs strchr strerror strstr strtol])
-AC_CHECK_FUNCS([strtoul symlink sysconf])
+AC_CHECK_FUNCS([strtoul symlink sync_file_range sysconf])
 AC_CHECK_FUNCS([times truncate])
 AC_CHECK_FUNCS([uname utime])
 AC_CHECK_FUNCS([waitpid])
diff --git a/v7/src/microcode/ntfile.c b/v7/src/microcode/ntfile.c
index 342791d3d..812fcab2b 100644
--- a/v7/src/microcode/ntfile.c
+++ b/v7/src/microcode/ntfile.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: ntfile.c,v 1.19 2008/01/30 20:02:14 cph Exp $
+$Id: ntfile.c,v 1.20 2009/03/21 07:09:08 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -73,6 +73,13 @@ OS_open_append_file (const char * filename)
     NT_error_api_call ((GetLastError ()), apicall_SetFilePointer);
   return (NT_open_handle (hFile));
 }
+
+Tchannel
+OS_open_exclusive_output_file (const char * filename)
+{
+  error_unimplemented_primitive ();
+  return (0);
+}
 
 static Tchannel
 make_load_channel (HANDLE handle)
diff --git a/v7/src/microcode/ntio.c b/v7/src/microcode/ntio.c
index 3e038790a..c125eacce 100644
--- a/v7/src/microcode/ntio.c
+++ b/v7/src/microcode/ntio.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: ntio.c,v 1.37 2008/03/09 20:24:24 cph Exp $
+$Id: ntio.c,v 1.38 2009/03/21 07:09:08 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -225,6 +225,11 @@ OS_channel_type (Tchannel channel)
 {
   return (CHANNEL_TYPE (channel));
 }
+
+void
+OS_channel_synchronize (Tchannel channel)
+{
+}
 
 static void
 generic_channel_close (Tchannel channel, int errorp)
diff --git a/v7/src/microcode/os2file.c b/v7/src/microcode/os2file.c
index 547301a09..277c72c04 100644
--- a/v7/src/microcode/os2file.c
+++ b/v7/src/microcode/os2file.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2file.c,v 1.8 2008/01/30 20:02:16 cph Exp $
+$Id: os2file.c,v 1.9 2009/03/21 07:09:08 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -93,6 +93,13 @@ OS_open_append_file (const char * filename)
   transaction_commit ();
   return (channel);
 }
+
+Tchannel
+OS_open_exclusive_output_file (const char * filename)
+{
+  error_unimplemented_primitive ();
+  return (0);
+}
 
 static Tchannel
 open_file_noerror (const char * filename, ULONG attr, ULONG flags,
diff --git a/v7/src/microcode/os2io.c b/v7/src/microcode/os2io.c
index 535fbfb1a..59afbbd1a 100644
--- a/v7/src/microcode/os2io.c
+++ b/v7/src/microcode/os2io.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: os2io.c,v 1.15 2008/03/09 20:24:27 cph Exp $
+$Id: os2io.c,v 1.16 2009/03/21 07:09:08 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -342,6 +342,11 @@ OS_channel_blocking (Tchannel channel)
 {
   (CHANNEL_NONBLOCKING (channel)) = 0;
 }
+
+void
+OS_channel_synchronize (Tchannel channel)
+{
+}
 
 size_t
 OS_channel_read_load_file (Tchannel channel, void * buffer, size_t nbytes)
diff --git a/v7/src/microcode/osfile.h b/v7/src/microcode/osfile.h
index 4ed316f8c..0a2f6e6a6 100644
--- a/v7/src/microcode/osfile.h
+++ b/v7/src/microcode/osfile.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: osfile.h,v 1.10 2008/01/30 20:02:17 cph Exp $
+$Id: osfile.h,v 1.11 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -32,6 +32,7 @@ USA.
 
 extern Tchannel OS_open_input_file (const char * filename);
 extern Tchannel OS_open_output_file (const char * filename);
+extern Tchannel OS_open_exclusive_output_file (const char * filename);
 extern Tchannel OS_open_io_file (const char * filename);
 extern Tchannel OS_open_append_file (const char * filename);
 extern Tchannel OS_open_load_file (const char * filename);
diff --git a/v7/src/microcode/osio.h b/v7/src/microcode/osio.h
index d323bd411..17992a98d 100644
--- a/v7/src/microcode/osio.h
+++ b/v7/src/microcode/osio.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: osio.h,v 1.25 2008/03/09 20:24:30 cph Exp $
+$Id: osio.h,v 1.26 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -58,6 +58,7 @@ extern int OS_channel_open_p (Tchannel channel);
 extern void OS_channel_close (Tchannel channel);
 extern void OS_channel_close_noerror (Tchannel channel);
 extern void OS_channel_close_on_abort (Tchannel channel);
+extern void OS_channel_synchronize (Tchannel channel);
 extern enum channel_type OS_channel_type (Tchannel channel);
 extern size_t OS_channel_read_load_file
   (Tchannel channel, void * buffer, size_t nbytes);
diff --git a/v7/src/microcode/prosfile.c b/v7/src/microcode/prosfile.c
index 0ce0ef770..c3db236c8 100644
--- a/v7/src/microcode/prosfile.c
+++ b/v7/src/microcode/prosfile.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: prosfile.c,v 1.16 2008/01/30 20:02:19 cph Exp $
+$Id: prosfile.c,v 1.17 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -62,6 +62,17 @@ The channel number is saved in the cdr of WEAK-PAIR.\n\
 If the file exists, it is rewritten.")
   NEW_OPEN_FILE_PRIMITIVE (OS_open_output_file)
 
+/* Really this should just return #F or something, I think, since the
+   possibility of the file's existence is so common a case to worry
+   about.  Doing so requires more changes to the runtime, though. */
+
+DEFINE_PRIMITIVE ("NEW-FILE-OPEN-EXCLUSIVE-OUTPUT-CHANNEL",
+                  Prim_new_file_open_exclusive_output_channel, 2, 2,
+  "Open an output file called FILENAME.\n\
+The channel number is saved in the cdr of WEAK-PAPIR.\n\
+If the file exists, an error is signalled.")
+  NEW_OPEN_FILE_PRIMITIVE (OS_open_exclusive_output_file)
+
 DEFINE_PRIMITIVE ("NEW-FILE-OPEN-IO-CHANNEL", Prim_new_file_open_io_channel,
 		  2, 2,
   "Open a file called FILENAME.\n\
@@ -98,6 +109,12 @@ DEFINE_PRIMITIVE ("FILE-OPEN-OUTPUT-CHANNEL", Prim_file_open_output_channel,
 If the file exists, it is rewritten.")
   OPEN_FILE_PRIMITIVE (OS_open_output_file)
 
+DEFINE_PRIMITIVE ("FILE-OPEN-EXCLUSIVE-OUTPUT-CHANNEL",
+                  Prim_file_open_exclusive_output_channel, 2, 2,
+  "Open an output file called FILENAME, returning a channel number.\n\
+If the file exists, an error is signalled.")
+  OPEN_FILE_PRIMITIVE (OS_open_exclusive_output_file)
+
 DEFINE_PRIMITIVE ("FILE-OPEN-IO-CHANNEL", Prim_file_open_io_channel, 1, 1,
   "Open a file called FILENAME, returning a channel number.\n\
 The file is opened for both input and output.\n\
diff --git a/v7/src/microcode/prosio.c b/v7/src/microcode/prosio.c
index 5fc8d65b0..83f9ec3a4 100644
--- a/v7/src/microcode/prosio.c
+++ b/v7/src/microcode/prosio.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: prosio.c,v 1.30 2008/01/30 20:02:19 cph Exp $
+$Id: prosio.c,v 1.31 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -67,6 +67,16 @@ DEFINE_PRIMITIVE ("CHANNEL-CLOSE", Prim_channel_close, 1, 1,
   }
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
+
+DEFINE_PRIMITIVE ("CHANNEL-SYNCHRONIZE", Prim_channel_synchronize, 1, 1,
+  "(CHANNEL)\n\
+Synchronize CHANNEL with any permanent storage associated with it,\n\
+forcing any buffered data to be written permanently.")
+{
+  PRIMITIVE_HEADER (1);
+  OS_channel_synchronize (arg_channel (1));
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
 
 DEFINE_PRIMITIVE ("CHANNEL-TABLE", Prim_channel_table, 0, 0,
   "Return a vector of all channels in the channel table.")
diff --git a/v7/src/microcode/syscall.h b/v7/src/microcode/syscall.h
index f9ebaa305..d1cedbf01 100644
--- a/v7/src/microcode/syscall.h
+++ b/v7/src/microcode/syscall.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: syscall.h,v 1.23 2008/01/30 20:02:21 cph Exp $
+$Id: syscall.h,v 1.24 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -54,9 +54,14 @@ enum syscall_names
   syscall_close,
   syscall_connect,
   syscall_fcntl_GETFL,
+  syscall_fcntl_FULLFSYNC,
   syscall_fcntl_SETFL,
+  syscall_fdatasync,
   syscall_fork,
   syscall_fstat,
+  syscall_fstatfs,
+  syscall_fsync,
+  syscall_fsync_range,
   syscall_ftruncate,
   syscall_getcwd,
   syscall_gethostname,
@@ -69,8 +74,10 @@ enum syscall_names
   syscall_listen,
   syscall_localtime,
   syscall_lseek,
+  syscall_lstat,
   syscall_malloc,
   syscall_mkdir,
+  syscall_mktime,
   syscall_open,
   syscall_opendir,
   syscall_pause,
@@ -83,13 +90,17 @@ enum syscall_names
   syscall_select,
   syscall_setitimer,
   syscall_setpgid,
+  syscall_setsockopt,
   syscall_shutdown,
   syscall_sighold,
   syscall_sigprocmask,
   syscall_sigsuspend,
   syscall_sleep,
   syscall_socket,
+  syscall_stat,
+  syscall_statfs,
   syscall_symlink,
+  syscall_sync_file_range,
   syscall_tcdrain,
   syscall_tcflush,
   syscall_tcgetpgrp,
@@ -102,13 +113,6 @@ enum syscall_names
   syscall_utime,
   syscall_vfork,
   syscall_write,
-  syscall_stat,
-  syscall_lstat,
-  syscall_mktime,
-  syscall_dld,
-  syscall_statfs,
-  syscall_fstatfs,
-  syscall_setsockopt
 };
 
 enum syserr_names
diff --git a/v7/src/microcode/ux.h b/v7/src/microcode/ux.h
index d93f46fe3..34458d935 100644
--- a/v7/src/microcode/ux.h
+++ b/v7/src/microcode/ux.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: ux.h,v 1.89 2009/03/08 00:02:09 riastradh Exp $
+$Id: ux.h,v 1.90 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -457,9 +457,12 @@ typedef RETSIGTYPE Tsignal_handler_result;
 #define UX_ctime ctime
 #define UX_dup dup
 #define UX_fcntl fcntl
+#define UX_fdatasync fdatasync
 #define UX_free free
 #define UX_fstat fstat
 #define UX_fstatfs fstatfs
+#define UX_fsync fsync
+#define UX_fsync_range fsync_range
 #define UX_ftruncate ftruncate
 #define UX_getegid getegid
 #define UX_getenv getenv
@@ -499,6 +502,7 @@ typedef RETSIGTYPE Tsignal_handler_result;
 #define UX_stat stat
 #define UX_statfs statfs
 #define UX_symlink symlink
+#define UX_sync_file_range sync_file_range
 #define UX_system system
 #define UX_time time
 #define UX_times times
diff --git a/v7/src/microcode/uxfile.c b/v7/src/microcode/uxfile.c
index 330001d96..9b8413510 100644
--- a/v7/src/microcode/uxfile.c
+++ b/v7/src/microcode/uxfile.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: uxfile.c,v 1.17 2008/01/30 20:02:22 cph Exp $
+$Id: uxfile.c,v 1.18 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -95,6 +95,7 @@ name (const char * filename)						\
 
 DEFUN_OPEN_FILE (OS_open_input_file, O_RDONLY)
 DEFUN_OPEN_FILE (OS_open_output_file, (O_WRONLY | O_CREAT | O_TRUNC))
+DEFUN_OPEN_FILE (OS_open_exclusive_output_file, (O_WRONLY | O_CREAT | O_EXCL))
 DEFUN_OPEN_FILE (OS_open_io_file, (O_RDWR | O_CREAT))
 
 #ifdef O_APPEND
diff --git a/v7/src/microcode/uxio.c b/v7/src/microcode/uxio.c
index 48006b451..46d901113 100644
--- a/v7/src/microcode/uxio.c
+++ b/v7/src/microcode/uxio.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: uxio.c,v 1.60 2008/03/09 20:24:32 cph Exp $
+$Id: uxio.c,v 1.61 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -157,6 +157,39 @@ OS_channel_close_on_abort (Tchannel channel)
   (*cp) = (channel);
   transaction_record_action (tat_abort, channel_close_on_abort_1, cp);
 }
+
+/* This pile of kludgerosity makes the best effort it can to truly
+   force everything out to disk on Linux, NetBSD, and Darwin. */
+
+void
+OS_channel_synchronize (Tchannel channel)
+{
+  int fd = (CHANNEL_DESCRIPTOR (channel));
+#ifdef HAVE_FDATASYNC
+  STD_VOID_SYSTEM_CALL (syscall_fdatasync, (UX_fdatasync (fd)));
+#endif /* HAVE_FDATASYNC */
+#ifdef HAVE_FSYNC_RANGE
+  STD_VOID_SYSTEM_CALL
+    (syscall_fsync_range,
+     (UX_fsync_range (fd, (FFILESYNC | FDISKSYNC), 0, 0)));
+#endif /* HAVE_FSYNC_RANGE */
+#ifdef HAVE_SYNC_FILE_RANGE
+  STD_VOID_SYSTEM_CALL
+    (syscall_sync_file_range,
+     (UX_sync_file_range
+      (fd, 0, 0,
+       (SYNC_FILE_RANGE_WAIT_BEFORE
+	| SYNC_FILE_RANGE_WRITE
+	| SYNC_FILE_RANGE_WAIT_AFTER))));
+#endif /* HAVE_SYNC_FILE_RANGE */
+#ifdef HAVE_FSYNC
+  STD_VOID_SYSTEM_CALL (syscall_fsync, (UX_fsync (fd)));
+#endif /* HAVE_FSYNC */
+#ifdef F_FULLFSYNC
+  STD_VOID_SYSTEM_CALL
+    (syscall_fcntl_FULLFSYNC, (UX_fcntl (fd, F_FULLFSYNC, 0)));
+#endif /* F_FULLFSYNC */
+}
 
 enum channel_type
 OS_channel_type (Tchannel channel)
diff --git a/v7/src/microcode/uxtop.c b/v7/src/microcode/uxtop.c
index 67623a372..fd60b1fce 100644
--- a/v7/src/microcode/uxtop.c
+++ b/v7/src/microcode/uxtop.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: uxtop.c,v 1.39 2008/01/30 20:02:22 cph Exp $
+$Id: uxtop.c,v 1.40 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -362,9 +362,14 @@ static const char * syscall_names_table [] =
   "close",
   "connect",
   "fcntl-getfl",
+  "fcntl-fullfsync",
   "fcntl-setfl",
+  "fdatasync",
   "fork",
   "fstat",
+  "fstatfs",
+  "fsync",
+  "fsync_range",
   "ftruncate",
   "getcwd",
   "gethostname",
@@ -377,8 +382,10 @@ static const char * syscall_names_table [] =
   "listen",
   "localtime",
   "lseek",
+  "lstat",
   "malloc",
   "mkdir",
+  "mktime",
   "open",
   "opendir",
   "pause",
@@ -391,13 +398,17 @@ static const char * syscall_names_table [] =
   "select",
   "setitimer",
   "setpgid",
+  "setsockopt",
   "shutdown",
   "sighold",
   "sigprocmask",
   "sigsuspend",
   "sleep",
   "socket",
+  "stat",
+  "statfs",
   "symlink",
+  "sync_file_range",
   "tcdrain",
   "tcflush",
   "tcgetpgrp",
@@ -410,13 +421,6 @@ static const char * syscall_names_table [] =
   "utime",
   "vfork",
   "write",
-  "stat",
-  "lstat",
-  "mktime",
-  "dynamic-load",
-  "statfs",
-  "fstatfs",
-  "setsockopt"
 };
 
 void
diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm
index b345513d3..5cb965568 100644
--- a/v7/src/runtime/fileio.scm
+++ b/v7/src/runtime/fileio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: fileio.scm,v 1.38 2008/07/11 05:26:42 cph Exp $
+$Id: fileio.scm,v 1.39 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -118,6 +118,14 @@ USA.
     (port/set-line-ending port (file-line-ending pathname))
     port))
 
+(define (open-exclusive-output-file filename)
+  (let* ((pathname (merge-pathnames filename))
+	 (channel (file-open-exclusive-output-channel (->namestring pathname)))
+	 (port (make-generic-i/o-port channel #f output-file-type pathname)))
+    (set-channel-port! channel port)
+    (port/set-line-ending port (file-line-ending pathname))
+    port))
+
 (define (open-i/o-file filename)
   (let* ((pathname (merge-pathnames filename))
 	 (channel (file-open-io-channel (->namestring pathname)))
@@ -148,6 +156,15 @@ USA.
     (port/set-line-ending port 'BINARY)
     port))
 
+(define (open-exclusive-binary-output-file filename)
+  (let* ((pathname (merge-pathnames filename))
+	 (channel (file-open-exclusive-output-channel (->namestring pathname)))
+	 (port (make-generic-i/o-port channel #f output-file-type pathname)))
+    (set-channel-port! channel port)
+    (port/set-coding port 'BINARY)
+    (port/set-line-ending port 'BINARY)
+    port))
+
 (define (open-binary-i/o-file filename)
   (let* ((pathname (merge-pathnames filename))
 	 (channel (file-open-io-channel (->namestring pathname)))
@@ -172,9 +189,15 @@ USA.
 (define call-with-output-file
   (make-call-with-file open-output-file))
 
+(define call-with-exclusive-output-file
+  (make-call-with-file open-exclusive-output-file))
+
 (define call-with-binary-output-file
   (make-call-with-file open-binary-output-file))
 
+(define call-with-exclusive-binary-output-file
+  (make-call-with-file open-exclusive-binary-output-file))
+
 (define call-with-append-file
   (make-call-with-file (lambda (filename) (open-output-file filename #t))))
 
@@ -201,5 +224,11 @@ USA.
 (define with-output-to-file
   (make-with-output-to-file call-with-output-file))
 
+(define with-output-to-exclusive-file
+  (make-with-output-to-file call-with-exclusive-output-file))
+
 (define with-output-to-binary-file
-  (make-with-output-to-file call-with-binary-output-file))
\ No newline at end of file
+  (make-with-output-to-file call-with-binary-output-file))
+
+(define with-output-to-exclusive-binary-file
+  (make-with-output-to-file call-with-exclusive-binary-output-file))
\ No newline at end of file
diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index c36959b7e..c02e8b198 100644
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: io.scm,v 14.88 2008/01/30 20:02:31 cph Exp $
+$Id: io.scm,v 14.89 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -142,6 +142,7 @@ USA.
 	(ucode-primitive channel-descriptor 1)
 	(ucode-primitive channel-nonblocking 1)
 	(ucode-primitive channel-read 4)
+	(ucode-primitive channel-synchronize 1)
 	(ucode-primitive channel-write 4)
 	(ucode-primitive file-length-new 1)
 	(ucode-primitive file-position 1)
@@ -279,29 +280,54 @@ USA.
 			  (or (descriptor->channel descriptor)
 			      (make-channel descriptor)))
 			descriptors))))))
+
+(define (channel-synchronize channel)
+  ((ucode-primitive channel-synchronize 1) (channel-descriptor channel)))
 
 ;;;; File Primitives
 
-(define (file-open primitive filename)
+(define (file-open primitive operator filename)
   (let ((channel (open-channel (lambda (p) (primitive filename p)))))
     (if (or (channel-type=directory? channel)
 	    (channel-type=unknown? channel))
 	(begin
 	  (channel-close channel)
-	  (error:bad-range-argument filename primitive)))
-    channel))
+	  (file-open primitive
+		     operator
+		     (error:file-operation filename
+					   "open"
+					   "file"
+					   (if (channel-type=directory? channel)
+					       "Is a directory"
+					       "Unknown file type")
+					   operator
+					   (list filename))))
+	channel)))
 
 (define (file-open-input-channel filename)
-  (file-open (ucode-primitive new-file-open-input-channel 2) filename))
+  (file-open (ucode-primitive new-file-open-input-channel 2)
+	     file-open-input-channel
+	     filename))
 
 (define (file-open-output-channel filename)
-  (file-open (ucode-primitive new-file-open-output-channel 2) filename))
+  (file-open (ucode-primitive new-file-open-output-channel 2)
+	     file-open-output-channel
+	     filename))
+
+(define (file-open-exclusive-output-channel filename)
+  (file-open (ucode-primitive new-file-open-exclusive-output-channel 2)
+	     file-open-exclusive-output-channel
+	     filename))
 
 (define (file-open-io-channel filename)
-  (file-open (ucode-primitive new-file-open-io-channel 2) filename))
+  (file-open (ucode-primitive new-file-open-io-channel 2)
+	     file-open-io-channel
+	     filename))
 
 (define (file-open-append-channel filename)
-  (file-open (ucode-primitive new-file-open-append-channel 2) filename))
+  (file-open (ucode-primitive new-file-open-append-channel 2)
+	     file-open-append-channel
+	     filename))
 
 (define (channel-file-length channel)
   ((ucode-primitive file-length-new 1) (channel-descriptor channel)))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 2b3f64a59..a350cd551 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.689 2009/02/18 07:57:41 riastradh Exp $
+$Id: runtime.pkg,v 14.690 2009/03/21 07:09:09 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1686,17 +1686,23 @@ USA.
 	  call-with-binary-append-file
 	  call-with-binary-input-file
 	  call-with-binary-output-file
+	  call-with-exclusive-binary-output-file
+	  call-with-exclusive-output-file
 	  call-with-input-file
 	  call-with-output-file
 	  open-binary-i/o-file
 	  open-binary-input-file
 	  open-binary-output-file
+	  open-exclusive-binary-output-file
+	  open-exclusive-output-file
 	  open-i/o-file
 	  open-input-file
 	  open-output-file
 	  with-input-from-binary-file
 	  with-input-from-file
 	  with-output-to-binary-file
+	  with-output-to-exclusive-binary-file
+	  with-output-to-exclusive-file
 	  with-output-to-file)
   (initialization (initialize-package!)))
 
@@ -2875,6 +2881,7 @@ USA.
 	  channel-port
 	  channel-read
 	  channel-read-block
+	  channel-synchronize
 	  channel-table
 	  channel-type
 	  channel-type=directory?
@@ -2903,6 +2910,7 @@ USA.
 	  error:not-directory-channel
 	  error:not-dld-handle
 	  file-open-append-channel
+	  file-open-exclusive-output-channel
 	  file-open-input-channel
 	  file-open-io-channel
 	  file-open-output-channel