Add new primitive file-truncate.

diff --git a/v7/src/microcode/ntapi.h b/v7/src/microcode/ntapi.h
index a11ef46ab5b89d5257268f1274b60f0add7da1b5..c4c3862964f3c59f9db4780a4763e900a0252265 100644 (file)
--- 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 120aa8b7fa7ee77a717fccbb69eb556802bd848d..6a1c3021b3a20c8d56df09adc4ae6153b9a287d8 100644 (file)
--- 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 e45229e3888a032900112b7f50f4c528ad8a2bb0..f2c755a10b530bca54e5c3194a8eea08337d3198 100644 (file)
--- 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 363ddcb1024c975cd2ca1c99299e92c28c966165..521b390f2884c0962577124d2adfd6daaf4cff5a 100644 (file)
--- 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 bd1e933d150dc2d565f8061ba13e9180847e94dc..391c0433d1f608ef2298679477f1ef3a1188c671 100644 (file)
--- 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)));
+}