--- /dev/null
+/* -*-C-*-
+
+$Id: cmptype.h,v 1.1 1993/06/24 06:52:52 gjr Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/*
+ *
+ * Processor type definitions
+ *
+ */
+\f
+/*
+This file contains the associations between processor numbers and
+their descriptions. This file should only be modified by the Scheme
+project at MIT, to avoid conflicts.
+
+These numbers are the numbers stored in Scheme images (bands) so that
+the microcode can detect whether the compiled code in the band is
+compatible with it.
+
+These _are not_ the same numbers as the PROC_TYPE_XXX used to
+configure the microcode under Unix (cf.h)---they probably should be.
+
+Number Description
+______ ___________
+
+0 No compiled code support
+
+1 Motorola MC68020 with MC68881 floating point coprocessor,
+ or MC68030 (not MC68040).
+ Examples: HP series 9000 models 320, 350, 370, 375
+ Sun models 340, 360
+
+2 DEC Vax
+ Examples: Vax-11 750
+ MicroVax II
+ VaxStation 3100
+
+3 HP Precision architecture (version 1.0 and later).
+ Examples: HP series 9000 models 850, 835, 720, 750, 710, 877.
+
+4 MIPS R2000/R3000 with cache line <= 16 bytes.
+ Examples: DecStation 3100, 2100, 5000/200.
+ Sony News 3250
+
+5 Motorola MC68020-MC68040
+ Examples: HP series 9000 models 320-380, models 400+
+ All Next computers (up to Aug. 1992).
+
+6 Sun Sparc
+ Examples: Sun 4, SparcStation 2, IPC, ELC.
+ Solbourne ?
+
+7 IBM POWER and POWER/PC architecture.
+ Examples: IBM RS6000 model 560.
+
+8 Motorola 88000 architecture (88100 and 88110).
+ Examples: ?
+
+9 Intel i386/i486/Pentium architecture.
+ Examples: IBM PC AT clones with 386+ processors.
+
+10 DEC Alpha architecture
+ Examples: DEC AXP 500
+
+11 MIPS R200-R4000 (32 bit) with arbitrary cache line size.
+ Examples: DecStation 2100, 3100, 5000/200, 5000/240
+ Sony News 3250
+ Silicon Graphics Predator, Indigo, and Crimson
+
+12 Virtual C processor.
+ The Scheme compiler produces C to be compiled by the
+ same C compiler as the microcode.
+
+*/
+\f
+#ifndef CMPTYPE_H_INCLUDED
+#define CMPTYPE_H_INCLUDED
+
+#define COMPILER_NONE_TYPE 0
+#define COMPILER_MC68020_TYPE 1
+#define COMPILER_VAX_TYPE 2
+#define COMPILER_SPECTRUM_TYPE 3
+#define COMPILER_OLD_MIPS_TYPE 4
+#define COMPILER_MC68040_TYPE 5
+#define COMPILER_SPARC_TYPE 6
+#define COMPILER_RS6000_TYPE 7
+#define COMPILER_MC88K_TYPE 8
+#define COMPILER_I386_TYPE 9
+#define COMPILER_ALPHA_TYPE 10
+#define COMPILER_MIPS_TYPE 11
+#define COMPILER_LOSING_C_TYPE 12
+
+#endif /* CMPTYPE_H_INCLUDED */
--- /dev/null
+/* -*-C-*-
+
+$Id: outf.c,v 1.1 1993/06/24 06:54:47 gjr Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/*
+ OUTF system
+
+ outf_channel i/o is a substitute for <stdio.h>. On text based unix-like
+ systems it is implmented in terms of stdio. On windowing systems, however,
+ we have to be able to report problems withou having an obvious text output.
+
+ There are three channels for output:
+
+ console_output - for normal output to the user
+ error_output - for output of exceptional things
+ fatal_output - for details of an impending crash
+
+ Use outf where you would normally think of using fprintf and outf_flush
+ where you would normally use fflush.
+
+ outf_flush(fatal_output) is special. It causes the buffered fatal_output
+ data to be displayed. On windowing systems this may cause a window to be
+ created to display the information, or allow the window containging the
+ information to stay visible `after' the termination of Scheme.
+*/
+
+#include <stdarg.h>
+#include <stdio.h>
+#include "scheme.h"
+
+#ifdef WINNT
+#include <windows.h>
+#include "ntscreen.h"
+#endif
+\f
+#define make_outf_variants(outputter,flusher,chan) \
+void \
+DEFUN (outputter, (format), CONST char *format DOTS) \
+{ \
+ va_list args; \
+ va_start(args, format); \
+ voutf((chan), format, args); \
+} \
+void \
+DEFUN_VOID (flusher) \
+{ \
+ outf_flush (chan); \
+}
+
+make_outf_variants(outf_console, outf_flush_console, console_output)
+make_outf_variants(outf_error, outf_flush_error, error_output)
+make_outf_variants(outf_fatal, outf_flush_fatal, fatal_output)
+
+void
+DEFUN (outf, (chan, format), outf_channel chan AND CONST char *format DOTS)
+{
+ va_list ap;
+ va_start(ap, format);
+ voutf(chan, format, ap);
+}
+
+static FILE *
+DEFUN (outf_channel_to_FILE, (chan), outf_channel chan)
+{
+ if (chan==fatal_output) return stderr;
+ if (chan==error_output) return stderr;
+ if (chan==console_output) return stdout;
+ return (FILE*)chan;
+}
+\f
+#ifdef WINNT
+
+static int max_fatal_buf = 1000;
+static char fatal_buf[1000+1] = {0};
+
+void
+DEFUN (voutf_fatal, (format, args), CONST char *format AND va_list args)
+{
+ int end = strlen(fatal_buf);
+ _vsnprintf (&fatal_buf[end], max_fatal_buf - end, format, args);
+}
+
+
+void popup_outf_flush_fatal()
+{
+ fprintf(stderr,"%s", fatal_buf); fflush(stderr);
+ MessageBox(0,fatal_buf,"MIT-Scheme terminating", MB_OK|MB_TASKMODAL);
+ fatal_buf[0] = 0;
+}
+
+
+void
+DEFUN (voutf_master_tty, (chan, format, args),
+ outf_channel chan AND CONST char *format AND va_list args)
+{
+ extern HANDLE master_tty_window;
+ char buf[1000];
+
+ if (master_tty_window) {
+ _vsnprintf (buf, 1000, format, args);
+ Screen_WriteText (master_tty_window, buf);
+ } else {
+ vfprintf (outf_channel_to_FILE(chan), format, args);
+ }
+}
+
+#endif
+
+void
+DEFUN (voutf, (chan, format, args),
+ outf_channel chan AND CONST char *format AND va_list args)
+{
+#ifdef WINNT
+ if (chan==fatal_output) voutf_fatal(format, args);
+ else if (chan==console_output) voutf_master_tty(chan, format, args);
+ else if (chan==error_output) voutf_master_tty(chan, format, args);
+ else
+#endif
+ vfprintf(outf_channel_to_FILE(chan), format, args);
+
+}
+
+void
+DEFUN (outf_flush, (chan), outf_channel chan)
+{
+#ifdef WINNT
+ if (chan==fatal_output) popup_outf_flush_fatal();
+ else
+#endif
+ fflush(outf_channel_to_FILE(chan));
+}
+
--- /dev/null
+/* -*-C-*-
+
+$Id: outf.h,v 1.1 1993/06/24 06:55:44 gjr Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#ifndef SCM_OUTF_H
+#define SCM_OUTF_H
+
+#include <stdarg.h>
+#include <stdio.h>
+
+typedef struct __outf_channel_type_placeholder *outf_channel;
+
+extern void EXFUN (outf, (outf_channel chan, CONST char *format DOTS));
+extern void EXFUN (outf_console, (CONST char *format DOTS));
+extern void EXFUN (outf_error, (CONST char *format DOTS));
+extern void EXFUN (outf_fatal, (CONST char *format DOTS));
+extern void EXFUN (voutf,
+ (CONST outf_channel chan, CONST char *format, va_list ap));
+
+extern void EXFUN (outf_flush, (outf_channel chan));
+extern void EXFUN (outf_flush_console, (void));
+extern void EXFUN (outf_flush_error, (void));
+extern void EXFUN (outf_flush_fatal, (void));
+
+#define console_output ((outf_channel)-1)
+#define error_output ((outf_channel)-2)
+#define fatal_output ((outf_channel)-3)
+
+#endif /* SCM_OUTF_H */
--- /dev/null
+/* -*-C-*-
+
+$Id: prntenv.c,v 1.1 1993/06/24 06:57:57 gjr Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Unix-specific process-environment primitives. */
+/* DOS imitation */
+
+#include "scheme.h"
+#include "prims.h"
+#include "nt.h"
+#include "ntio.h"
+\f
+DEFINE_PRIMITIVE ("FILE-TIME->STRING", Prim_file_time_to_string, 1, 1,
+ "Convert a file system time stamp into a date/time string.")
+{
+ PRIMITIVE_HEADER (1);
+ CHECK_ARG (1, INTEGER_P);
+ {
+ time_t clock = (arg_integer (1));
+ char * time_string = (DOS_ctime (&clock));
+ (time_string[24]) = '\0';
+ PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) time_string));
+ }
+}
+
+DEFINE_PRIMITIVE ("GET-ENVIRONMENT-VARIABLE", Prim_get_environment_variable, 1, 1,
+ "Look up the value of a variable in the user's shell environment.\n\
+The argument, a variable name, must be a string.\n\
+The result is either a string (the variable's value),\n\
+ or #F indicating that the variable does not exist.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ CONST char * variable_value = (DOS_getenv (STRING_ARG (1)));
+ PRIMITIVE_RETURN
+ ((variable_value == 0)
+ ? SHARP_F
+ : (char_pointer_to_string ((unsigned char *) variable_value)));
+ }
+}
--- /dev/null
+/* -*-C-*-
+
+$Id: prntfs.c,v 1.1 1993/06/24 06:59:14 gjr Exp $
+
+Copyright (c) 1993 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Unix-specific file-system primitives. */
+/* DOS Immitation */
+
+#include "scheme.h"
+#include "prims.h"
+#include "nt.h"
+#include "osfs.h"
+
+#ifdef WINNT
+#include <sys/utime.h>
+#endif
+
+extern int EXFUN
+ (DOS_read_file_status, (CONST char * filename, struct stat * s));
+
+static SCHEME_OBJECT EXFUN (file_attributes_internal, (struct stat * s));
+static void EXFUN (file_mode_string, (struct stat * s, char * a));
+static char EXFUN (file_type_letter, (struct stat * s));
+static void EXFUN (rwx, (unsigned short bits, char * chars));
+static SCHEME_OBJECT EXFUN (file_touch, (CONST char * filename));
+static void EXFUN (protect_fd, (int fd));
+
+#ifndef FILE_TOUCH_OPEN_TRIES
+#define FILE_TOUCH_OPEN_TRIES 5
+#endif
+\f
+DEFINE_PRIMITIVE ("FILE-MODES", Prim_file_modes, 1, 1,
+ "Return mode bits of FILE, as an integer.")
+{
+ struct stat stat_result;
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ ((DOS_read_file_status ((STRING_ARG (1)), (&stat_result)))
+ ? (LONG_TO_UNSIGNED_FIXNUM ((stat_result . st_mode) & 07777))
+ : SHARP_F);
+}
+
+DEFINE_PRIMITIVE ("SET-FILE-MODES!", Prim_set_file_modes, 2, 2,
+ "Set the mode bits of FILE to MODE.")
+{
+ PRIMITIVE_HEADER (2);
+ if ((DOS_chmod ((STRING_ARG (1)), (arg_index_integer (2, 010000)))) < 0)
+ error_system_call (errno, syscall_chmod);
+ PRIMITIVE_RETURN (SHARP_F);
+}
+
+DEFINE_PRIMITIVE ("FILE-MOD-TIME", Prim_file_mod_time, 1, 1, 0)
+{
+ struct stat s;
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ ((DOS_read_file_status ((STRING_ARG (1)), (&s)))
+ ? (long_to_integer (s . st_mtime))
+ : SHARP_F);
+}
+\f
+/* Returns a vector of 10 items:
+
+ 0 = #T iff the file is a directory,
+ string (name linked to) for symbolic link,
+ #F for all other files.
+ 1 = number of links to the file
+ 2 = user id, as an unsigned integer
+ 3 = group id, as an unsigned integer
+ 4 = last access time of the file
+ 5 = last modification time of the file
+ 6 = last change time of the file
+ 7 = size of the file in bytes
+ 8 = mode string for the file
+ 9 = inode number of the file
+
+ The file_mode_string stuff was gobbled from GNU Emacs. */
+
+#define FILE_ATTRIBUTES_PRIMITIVE(stat_syscall) \
+{ \
+ struct stat s; \
+ PRIMITIVE_HEADER (1); \
+ PRIMITIVE_RETURN \
+ ((stat_syscall ((STRING_ARG (1)), (&s))) \
+ ? (file_attributes_internal (&s)) \
+ : SHARP_F); \
+}
+
+DEFINE_PRIMITIVE ("FILE-ATTRIBUTES", Prim_file_attributes, 1, 1,
+ "Given a file name, return attribute information about the file.\n\
+If the file exists and its status information is accessible, the result\n\
+is a vector of 10 items (see the reference manual for details). Otherwise\n\
+the result is #F.")
+ FILE_ATTRIBUTES_PRIMITIVE (DOS_read_file_status)
+
+static SCHEME_OBJECT
+DEFUN (file_attributes_internal, (s), struct stat * s)
+{
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 10, true));
+ SCHEME_OBJECT modes = (allocate_string (10));
+ switch ((s -> st_mode) & S_IFMT)
+ {
+ case S_IFDIR:
+ VECTOR_SET (result, 0, SHARP_T);
+ break;
+#ifdef S_IFLNK
+ case S_IFLNK:
+ VECTOR_SET (result, 0,
+ (char_pointer_to_string
+ ((unsigned char *)
+ (OS_file_soft_link_p
+ ((CONST char *) (STRING_LOC ((ARG_REF (1)), 0)))))));
+ break;
+#endif
+ default:
+ VECTOR_SET (result, 0, SHARP_F);
+ break;
+ }
+ VECTOR_SET (result, 1, (long_to_integer (s -> st_nlink)));
+ VECTOR_SET (result, 2, (long_to_integer (s -> st_uid)));
+ VECTOR_SET (result, 3, (long_to_integer (s -> st_gid)));
+ VECTOR_SET (result, 4, (long_to_integer (s -> st_atime)));
+ VECTOR_SET (result, 5, (long_to_integer (s -> st_mtime)));
+ VECTOR_SET (result, 6, (long_to_integer (s -> st_ctime)));
+ VECTOR_SET (result, 7, (long_to_integer (s -> st_size)));
+ file_mode_string (s, ((char *) (STRING_LOC (modes, 0))));
+ VECTOR_SET (result, 8, modes);
+ VECTOR_SET (result, 9, (long_to_integer (s -> st_ino)));
+ return (result);
+}
+\f
+/* file_mode_string - set file attribute data
+
+ File_mode_string converts the data in the st_mode field of file
+ status block `s' to a 10 character attribute string, which it
+ stores in the block that `a' points to.
+
+ This attribute string is modelled after the string produced by the
+ Berkeley ls.
+
+ As usual under Unix, the elements of the string are numbered from
+ 0. Their meanings are:
+
+ 0 File type. 'd' for directory, 'c' for character special, 'b'
+ for block special, 'm' for multiplex, 'l' for symbolic link,
+ 's' for socket, 'p' for fifo, '-' for any other file type
+ 1 'r' if the owner may read, '-' otherwise.
+ 2 'w' if the owner may write, '-' otherwise.
+ 3 'x' if the owner may execute, 's' if the file is set-user-id,
+ '-' otherwise. 'S' if the file is set-user-id, but the
+ execute bit isn't set. (sys V `feature' which helps to catch
+ screw case.)
+ 4 'r' if group members may read, '-' otherwise.
+ 5 'w' if group members may write, '-' otherwise.
+ 6 'x' if group members may execute, 's' if the file is
+ set-group-id, '-' otherwise. 'S' if it is set-group-id but
+ not executable.
+ 7 'r' if any user may read, '-' otherwise.
+ 8 'w' if any user may write, '-' otherwise.
+ 9 'x' if any user may execute, 't' if the file is "sticky" (will
+ be retained in swap space after execution), '-' otherwise. */
+
+static void
+DEFUN (file_mode_string, (s, a), struct stat * s AND char * a)
+{
+ (a[0]) = (file_type_letter (s));
+ rwx ((((s -> st_mode) & 0700) << 0), (& (a [1])));
+ rwx ((((s -> st_mode) & 0070) << 3), (& (a [4])));
+ rwx ((((s -> st_mode) & 0007) << 6), (& (a [7])));
+#ifdef S_ISUID
+ if (((s -> st_mode) & S_ISUID) != 0)
+ (a[3]) = (((a[3]) == 'x') ? 's' : 'S');
+#endif
+#ifdef S_ISGID
+ if (((s -> st_mode) & S_ISGID) != 0)
+ (a[6]) = (((a [6]) == 'x') ? 's' : 'S');
+#endif
+#ifdef S_ISVTX
+ if (((s -> st_mode) & S_ISVTX) != 0)
+ (a[9]) = (((a [9]) == 'x') ? 't' : 'T');
+#endif
+}
+\f
+static char
+DEFUN (file_type_letter, (s), struct stat * s)
+{
+ switch ((s -> st_mode) & S_IFMT)
+ {
+ case S_IFDIR:
+ return ('d');
+ case S_IFCHR:
+ return ('c');
+#ifndef NT386CL
+/* S_IFBLK seems not to exist*/
+ case S_IFBLK:
+ return ('b');
+#endif
+#ifdef S_IFLNK
+ case S_IFLNK:
+ return ('l');
+#endif
+#ifdef S_IFMPC
+/* These do not seem to exist */
+ case S_IFMPC:
+ case S_IFMPB:
+ return ('m');
+#endif
+#ifdef S_IFSOCK
+ case S_IFSOCK:
+ return ('s');
+#endif
+#ifdef S_IFIFO
+ case S_IFIFO:
+ return ('p');
+#endif
+#ifdef S_IFNWK /* hp-ux hack */
+ case S_IFNWK:
+ return ('n');
+#endif
+ default:
+ return ('-');
+ }
+}
+
+static void
+DEFUN (rwx, (bits, chars), unsigned short bits AND char * chars)
+{
+ (chars[0]) = (((bits & S_IREAD) != 0) ? 'r' : '-');
+ (chars[1]) = (((bits & S_IWRITE) != 0) ? 'w' : '-');
+ (chars[2]) = (((bits & S_IEXEC) != 0) ? 'x' : '-');
+}
+\f
+DEFINE_PRIMITIVE ("FILE-TOUCH", Prim_file_touch, 1, 1,
+ "Given a file name, change the times of the file to the current time.\n\
+If the file does not exist, create it.\n\
+Both the access time and modification time are changed.\n\
+Return #F if the file existed and its time was modified.\n\
+Otherwise the file did not exist and it was created.")
+{
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (file_touch ((CONST char *) (STRING_ARG (1))));
+}
+
+
+static SCHEME_OBJECT
+DEFUN (file_touch, (filename), CONST char * filename)
+{
+ int fd;
+ transaction_begin ();
+ {
+ unsigned int count = 0;
+ while (1)
+ {
+ count += 1;
+ /* Use O_EXCL to prevent overwriting existing file. */
+ fd = (DOS_open (filename, (O_RDWR | O_CREAT | O_EXCL), MODE_REG));
+ if (fd >= 0)
+ {
+ protect_fd (fd);
+ transaction_commit ();
+ return (SHARP_T);
+ }
+ if (errno == EEXIST)
+ {
+ fd = (DOS_open (filename, O_RDWR, MODE_REG));
+ if (fd >= 0)
+ {
+ protect_fd (fd);
+ break;
+ }
+ else if ((errno == ENOENT) || (errno == ESTALE))
+ continue;
+ }
+ if (count >= FILE_TOUCH_OPEN_TRIES)
+ error_system_call (errno, syscall_open);
+ }
+ }
+ {
+ struct stat file_status;
+ STD_VOID_SYSTEM_CALL (syscall_fstat, (DOS_fstat (fd, (&file_status))));
+ if (((file_status . st_mode) & S_IFMT) != S_IFREG)
+ error_bad_range_arg (1);
+ /* CASE 3: file length of 0 needs special treatment. */
+ if ((file_status . st_size) == 0)
+ {
+ char buf [1];
+ (buf[0]) = '\0';
+ STD_VOID_SYSTEM_CALL (syscall_write, (DOS_write (fd, buf, 1)));
+#ifdef HAVE_TRUNCATE
+ STD_VOID_SYSTEM_CALL (syscall_ftruncate, (DOS_ftruncate (fd, 0)));
+ transaction_commit ();
+#else /* not HAVE_TRUNCATE */
+ transaction_commit ();
+ fd = (DOS_open (filename, (O_WRONLY | O_TRUNC), MODE_REG));
+ if (fd >= 0)
+ STD_VOID_SYSTEM_CALL (syscall_close, (DOS_close (fd)));
+#endif /* HAVE_TRUNCATE */
+ return (SHARP_F);
+ }
+ }
+ /* CASE 4: read, then write back the first byte in the file. */
+ {
+ char buf [1];
+ int scr;
+ STD_UINT_SYSTEM_CALL (syscall_read, scr, (DOS_read (fd, buf, 1)));
+ if (scr > 0)
+ {
+ STD_VOID_SYSTEM_CALL (syscall_lseek, (DOS_lseek (fd, 0, SEEK_SET)));
+ STD_VOID_SYSTEM_CALL (syscall_write, (DOS_write (fd, buf, 1)));
+ }
+ }
+ transaction_commit ();
+ return (SHARP_F);
+}
+
+static void
+DEFUN (protect_fd_close, (ap), PTR ap)
+{
+ DOS_close (* ((int *) ap));
+}
+
+static void
+DEFUN (protect_fd, (fd), int fd)
+{
+ int * p = (dstack_alloc (sizeof (int)));
+ (*p) = fd;
+ transaction_record_action (tat_always, protect_fd_close, p);
+}
+\f
+DEFINE_PRIMITIVE ("SET-FILE-TIMES!", Prim_set_file_times, 3, 3,
+ "Change the access and modification times of FILE.\n\
+The second and third arguments are the respective times;\n\
+they are integers are the times in seconds since 00:00:00 GMT, Jan. 1, 1970\n\
+The file must exist and you must be the owner (or superuser).")
+{
+ PRIMITIVE_HEADER (3);
+ {
+ time_t times[2];
+
+ times[0] = (time_t) arg_integer (2);
+ times[1] = (time_t) arg_integer (3);
+ STD_VOID_SYSTEM_CALL(syscall_utime, (utime ((STRING_ARG (1)), ×)));
+ PRIMITIVE_RETURN (SHARP_F);
+ }
+}
+
+DEFINE_PRIMITIVE ("FILE-EQ?", Prim_file_eq_p, 2, 2,
+ "True iff the two file arguments are the same file.")
+{
+ static char buf1[128], buf2[128];
+ char *filepart;
+ PRIMITIVE_HEADER (2);
+
+ if (GetFullPathName(STRING_ARG (1), 128, buf1, &filepart) == 0 ||
+ GetFullPathName(STRING_ARG (2), 128, buf2, &filepart) == 0)
+ error_external_return ();
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((strcmp (&buf1[0], &buf2[0])) == 0));
+}
projects / mit-scheme.git / commitdiff