From 4dc6c962c4971eaa99211084a8b9d0cad98d8d7c Mon Sep 17 00:00:00 2001 From: "Taylor R. Campbell" Date: Sat, 21 Mar 2009 07:09:09 +0000 Subject: [PATCH] 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. --- v7/src/microcode/configure.ac | 7 +++--- v7/src/microcode/ntfile.c | 9 +++++++- v7/src/microcode/ntio.c | 7 +++++- v7/src/microcode/os2file.c | 9 +++++++- v7/src/microcode/os2io.c | 7 +++++- v7/src/microcode/osfile.h | 3 ++- v7/src/microcode/osio.h | 3 ++- v7/src/microcode/prosfile.c | 19 +++++++++++++++- v7/src/microcode/prosio.c | 12 +++++++++- v7/src/microcode/syscall.h | 20 ++++++++++------- v7/src/microcode/ux.h | 6 ++++- v7/src/microcode/uxfile.c | 3 ++- v7/src/microcode/uxio.c | 35 ++++++++++++++++++++++++++++- v7/src/microcode/uxtop.c | 20 ++++++++++------- v7/src/runtime/fileio.scm | 33 +++++++++++++++++++++++++-- v7/src/runtime/io.scm | 42 ++++++++++++++++++++++++++++------- v7/src/runtime/runtime.pkg | 10 ++++++++- 17 files changed, 204 insertions(+), 41 deletions(-) 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 -- 2.25.1