From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 20 Dec 2004 04:37:17 +0000 (+0000)
Subject: Add new primitive file-truncate.
X-Git-Tag: 20090517-FFI~1409
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=163a9984508ea635a61da1b775d600db264e2d36;p=mit-scheme.git

Add new primitive file-truncate.
---

diff --git a/v7/src/microcode/ntapi.h b/v7/src/microcode/ntapi.h
index a11ef46ab..c4c386296 100644
--- a/v7/src/microcode/ntapi.h
+++ b/v7/src/microcode/ntapi.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: ntapi.h,v 1.16 2003/07/12 03:22:08 cph Exp $
+$Id: ntapi.h,v 1.17 2004/12/20 04:36:44 cph Exp $
 
-Copyright 1997,1999,2000,2002,2003 Massachusetts Institute of Technology
+Copyright 1997,1999,2000,2002,2003,2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -65,6 +65,7 @@ enum syscall_names
   apicall_RegSetValueEx,
   apicall_RemoveDirectory,
   apicall_SetCurrentDirectory,
+  apicall_SetEndOfFile,
   apicall_SetFileAttributes,
   apicall_SetFilePointer,
   apicall_SetFileTime,
@@ -926,6 +927,7 @@ static char * syscall_names_table [] =
   "reg-set-value-ex",
   "remove-directory",
   "set-current-directory",
+  "set-end-of-file",
   "set-file-attributes",
   "set-file-pointer",
   "set-file-time",
diff --git a/v7/src/microcode/ntfile.c b/v7/src/microcode/ntfile.c
index 120aa8b7f..6a1c3021b 100644
--- a/v7/src/microcode/ntfile.c
+++ b/v7/src/microcode/ntfile.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: ntfile.c,v 1.15 2003/02/14 18:28:20 cph Exp $
+$Id: ntfile.c,v 1.16 2004/12/20 04:36:53 cph Exp $
 
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright 1993,1996,1997,1998,2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -136,3 +136,10 @@ OS_file_set_position (Tchannel channel, off_t position)
   if (old_position != ((DWORD) position))
     error_external_return ();
 }
+
+void
+OS_file_truncate (Tchannel channel, off_t length)
+{
+  OS_file_set_position (channel, length);
+  STD_BOOL_API_CALL (SetEndOfFile, (CHANNEL_HANDLE (channel)));
+}
diff --git a/v7/src/microcode/osfile.h b/v7/src/microcode/osfile.h
index e45229e38..f2c755a10 100644
--- a/v7/src/microcode/osfile.h
+++ b/v7/src/microcode/osfile.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: osfile.h,v 1.5 2003/02/14 18:28:22 cph Exp $
+$Id: osfile.h,v 1.6 2004/12/20 04:37:01 cph Exp $
 
-Copyright (c) 1990, 1999 Massachusetts Institute of Technology
+Copyright 1990,1993,2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -37,5 +37,6 @@ extern Tchannel EXFUN (OS_open_dump_file, (CONST char * filename));
 extern off_t EXFUN (OS_file_length, (Tchannel channel));
 extern off_t EXFUN (OS_file_position, (Tchannel channel));
 extern void EXFUN (OS_file_set_position, (Tchannel channel, off_t position));
+extern void EXFUN (OS_file_truncate, (Tchannel channel, off_t length));
 
 #endif /* SCM_OSFILE_H */
diff --git a/v7/src/microcode/prosfile.c b/v7/src/microcode/prosfile.c
index 363ddcb10..521b390f2 100644
--- a/v7/src/microcode/prosfile.c
+++ b/v7/src/microcode/prosfile.c
@@ -1,8 +1,9 @@
 /* -*-C-*-
 
-$Id: prosfile.c,v 1.11 2003/02/14 18:28:23 cph Exp $
+$Id: prosfile.c,v 1.12 2004/12/20 04:37:09 cph Exp $
 
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright 1990,1991,1992,1993,1994,1996 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -124,3 +125,12 @@ POSITION must be a non-negative number strictly less than the file's length.")
   OS_file_set_position ((arg_channel (1)), (arg_nonnegative_integer (2)));
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
+
+DEFINE_PRIMITIVE ("FILE-TRUNCATE", Prim_file_truncate, 2, 2,
+  "Set the length of CHANNEL to LENGTH.\n\
+LENGTH must be a non-negative number.")
+{
+  PRIMITIVE_HEADER (1);
+  OS_file_truncate ((arg_channel (1)), (arg_nonnegative_integer (2)));
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
diff --git a/v7/src/microcode/uxfile.c b/v7/src/microcode/uxfile.c
index bd1e933d1..391c0433d 100644
--- a/v7/src/microcode/uxfile.c
+++ b/v7/src/microcode/uxfile.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: uxfile.c,v 1.12 2003/02/14 18:28:24 cph Exp $
+$Id: uxfile.c,v 1.13 2004/12/20 04:37:17 cph Exp $
 
-Copyright (c) 1990-2000 Massachusetts Institute of Technology
+Copyright 1990,1991,1993,1997,2000,2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -178,3 +178,13 @@ DEFUN (OS_file_set_position, (channel, position),
   if (result != position)
     error_external_return ();
 }
+
+void
+DEFUN (OS_file_truncate, (channel, length),
+       Tchannel channel AND
+       off_t length)
+{
+  STD_VOID_SYSTEM_CALL
+    (syscall_ftruncate,
+     (UX_ftruncate ((CHANNEL_DESCRIPTOR (channel)), length)));
+}