From 163a9984508ea635a61da1b775d600db264e2d36 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 20 Dec 2004 04:37:17 +0000
Subject: [PATCH] Add new primitive file-truncate.
---
v7/src/microcode/ntapi.h | 6 ++++--
v7/src/microcode/ntfile.c | 11 +++++++++--
v7/src/microcode/osfile.h | 5 +++--
v7/src/microcode/prosfile.c | 14 ++++++++++++--
v7/src/microcode/uxfile.c | 14 ++++++++++++--
5 files changed, 40 insertions(+), 10 deletions(-)
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)));
+}
--
2.25.1