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 a772bcfba8c5134b2fee460f0294339ecbdfe2f9..9a621dac6e1fcd6b73bdd3cb0ee72b19fa44959c 100644 (file)
--- 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 342791d3d77b4c7872cb7af845df2fc0986b5a8c..812fcab2bc084a06781b57d8c7e7957cfc7d18c4 100644 (file)
--- 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);
+}
 \f
 static Tchannel
 make_load_channel (HANDLE handle)

diff --git a/v7/src/microcode/ntio.c b/v7/src/microcode/ntio.c
index 3e038790a0649e808f57b0d23c5acbd0ee39aa61..c125eacce19b64cdf4caa5124e0c16a354c19aab 100644 (file)
--- 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)
+{
+}
 \f
 static void
 generic_channel_close (Tchannel channel, int errorp)

diff --git a/v7/src/microcode/os2file.c b/v7/src/microcode/os2file.c
index 547301a0913663f2fc3756302c0c2dcb8a452064..277c72c04037424e00f3349b4331a301939a3e49 100644 (file)
--- 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);
+}
 \f
 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 535fbfb1ab5391cd33e32a0721f4b97d0fdedbaa..59afbbd1abb818eb93f034791257cfdcd891c793 100644 (file)
--- 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)
+{
+}
 \f
 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 4ed316f8c6032a8a33cf07a92c6f17b2cb6406ef..0a2f6e6a6b546792429ae244bdfb9fcfbafb6703 100644 (file)
--- 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 d323bd41157d6cb967f319713d1ba300d142b708..17992a98d359f9567d03b07c5196940d34247e9e 100644 (file)
--- 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 0ce0ef770e75f68cba0ddbb102955fef8e0fa1d1..c3db236c85e704c5ad9930b184da227e6128a62f 100644 (file)
--- 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 5fc8d65b0fd650f53f19526d467dfaedcfd85ea4..83f9ec3a4a16a136edbd54050cac499887177557 100644 (file)
--- 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);
+}
 \f
 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 f9ebaa305dc8141c2796774d0eb534f2518884bf..d1cedbf01593e6dc1b7e1b6dc2795c69794e6393 100644 (file)
--- 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
 };
 \f
 enum syserr_names

diff --git a/v7/src/microcode/ux.h b/v7/src/microcode/ux.h
index d93f46fe3b220ec4a29310713b9f16ed71fcf485..34458d935a39a54436daff4373925dc9e3803bc3 100644 (file)
--- 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 330001d96a13b6d7854176e27463e3ae866cf41b..9b84135109b6bc18a7429c391ea09aef7d89ce4d 100644 (file)
--- 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 48006b451f72926242952b31d4ab0106d0035401..46d90111351a8acdafc0ccf088ca53c601acfd0a 100644 (file)
--- 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 */
+}
 \f
 enum channel_type
 OS_channel_type (Tchannel channel)

diff --git a/v7/src/microcode/uxtop.c b/v7/src/microcode/uxtop.c
index 67623a372cee4f74b87725fd1b966c204015b332..fd60b1fcefd0cf1092a12cd1f7ad4221d6d5c105 100644 (file)
--- 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 b345513d36810990d848bd157c52e2e6fed1ef97..5cb965568606d3c6e65475a6f3ff7c46150c777e 100644 (file)
--- 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 c36959b7e5d056b8db2d9a45b0e1a4e92af75b22..c02e8b198a44afe8e785ec039329de4e0ad379c1 100644 (file)
--- 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)))
 \f
 ;;;; 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 2b3f64a59a88a16db9d2346ca3639e1182f56e7e..a350cd551f4a4b4fda0a088e7b63aba934eb56e2 100644 (file)
--- 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