From: Guillermo J. Rozas Date: Thu, 24 Jun 1993 06:59:14 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~8301 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a633b6b17fe9227750e41503e06b2ef3989eb0c8;p=mit-scheme.git Initial revision --- diff --git a/v7/src/microcode/cmptype.h b/v7/src/microcode/cmptype.h new file mode 100644 index 000000000..c8f6584bc --- /dev/null +++ b/v7/src/microcode/cmptype.h @@ -0,0 +1,123 @@ +/* -*-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 + * + */ + +/* +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. + +*/ + +#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 */ diff --git a/v7/src/microcode/outf.c b/v7/src/microcode/outf.c new file mode 100644 index 000000000..7d0a09ecb --- /dev/null +++ b/v7/src/microcode/outf.c @@ -0,0 +1,162 @@ +/* -*-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 . 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 +#include +#include "scheme.h" + +#ifdef WINNT +#include +#include "ntscreen.h" +#endif + +#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; +} + +#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)); +} + diff --git a/v7/src/microcode/outf.h b/v7/src/microcode/outf.h new file mode 100644 index 000000000..a6bedc0f7 --- /dev/null +++ b/v7/src/microcode/outf.h @@ -0,0 +1,59 @@ +/* -*-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 +#include + +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 */ diff --git a/v7/src/microcode/prntenv.c b/v7/src/microcode/prntenv.c new file mode 100644 index 000000000..e990b4459 --- /dev/null +++ b/v7/src/microcode/prntenv.c @@ -0,0 +1,70 @@ +/* -*-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" + +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))); + } +} diff --git a/v7/src/microcode/prntfs.c b/v7/src/microcode/prntfs.c new file mode 100644 index 000000000..3ab49d471 --- /dev/null +++ b/v7/src/microcode/prntfs.c @@ -0,0 +1,387 @@ +/* -*-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 +#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 + +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); +} + +/* 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); +} + +/* 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 +} + +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' : '-'); +} + +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); +} + +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)); +}