vm/io.cpp

   1 #include "master.hpp"
   2
   3 namespace factor
   4 {
   5
   6 /* Simple wrappers for ANSI C I/O functions, used for bootstrapping.
   7
   8 Note the ugly loop logic in almost every function; we have to handle EINTR
   9 and restart the operation if the system call was interrupted. Naive
  10 applications don't do this, but then they quickly fail if one enables
  11 itimer()s or other signals.
  12
  13 The Factor library provides platform-specific code for Unix and Windows
  14 with many more capabilities so these words are not usually used in
  15 normal operation. */
  16
  17 void factorvm::init_c_io()
  18 {
  19         userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
  20         userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
  21         userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
  22 }
  23
  24 void factorvm::io_error()
  25 {
  26 #ifndef WINCE
  27         if(errno == EINTR)
  28                 return;
  29 #endif
  30
  31         general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
  32 }
  33
  34 inline void factorvm::primitive_fopen()
  35 {
  36         gc_root<byte_array> mode(dpop(),this);
  37         gc_root<byte_array> path(dpop(),this);
  38         mode.untag_check(this);
  39         path.untag_check(this);
  40
  41         for(;;)
  42         {
  43                 FILE *file = fopen((char *)(path.untagged() + 1),
  44                                    (char *)(mode.untagged() + 1));
  45                 if(file == NULL)
  46                         io_error();
  47                 else
  48                 {
  49                         box_alien(file);
  50                         break;
  51                 }
  52         }
  53 }
  54
  55 PRIMITIVE(fopen)
  56 {
  57         PRIMITIVE_GETVM()->primitive_fopen();
  58 }
  59
  60 inline void factorvm::primitive_fgetc()
  61 {
  62         FILE *file = (FILE *)unbox_alien();
  63
  64         for(;;)
  65         {
  66                 int c = fgetc(file);
  67                 if(c == EOF)
  68                 {
  69                         if(feof(file))
  70                         {
  71                                 dpush(F);
  72                                 break;
  73                         }
  74                         else
  75                                 io_error();
  76                 }
  77                 else
  78                 {
  79                         dpush(tag_fixnum(c));
  80                         break;
  81                 }
  82         }
  83 }
  84
  85 PRIMITIVE(fgetc)
  86 {
  87         PRIMITIVE_GETVM()->primitive_fgetc();
  88 }
  89
  90 inline void factorvm::primitive_fread()
  91 {
  92         FILE *file = (FILE *)unbox_alien();
  93         fixnum size = unbox_array_size();
  94
  95         if(size == 0)
  96         {
  97                 dpush(tag<string>(allot_string(0,0)));
  98                 return;
  99         }
 100
 101         gc_root<byte_array> buf(allot_array_internal<byte_array>(size),this);
 102
 103         for(;;)
 104         {
 105                 int c = fread(buf.untagged() + 1,1,size,file);
 106                 if(c <= 0)
 107                 {
 108                         if(feof(file))
 109                         {
 110                                 dpush(F);
 111                                 break;
 112                         }
 113                         else
 114                                 io_error();
 115                 }
 116                 else
 117                 {
 118                         if(c != size)
 119                         {
 120                                 byte_array *new_buf = allot_byte_array(c);
 121                                 memcpy(new_buf + 1, buf.untagged() + 1,c);
 122                                 buf = new_buf;
 123                         }
 124                         dpush(buf.value());
 125                         break;
 126                 }
 127         }
 128 }
 129
 130 PRIMITIVE(fread)
 131 {
 132         PRIMITIVE_GETVM()->primitive_fread();
 133 }
 134
 135 inline void factorvm::primitive_fputc()
 136 {
 137         FILE *file = (FILE *)unbox_alien();
 138         fixnum ch = to_fixnum(dpop());
 139
 140         for(;;)
 141         {
 142                 if(fputc(ch,file) == EOF)
 143                 {
 144                         io_error();
 145
 146                         /* Still here? EINTR */
 147                 }
 148                 else
 149                         break;
 150         }
 151 }
 152
 153 PRIMITIVE(fputc)
 154 {
 155         PRIMITIVE_GETVM()->primitive_fputc();
 156 }
 157
 158 inline void factorvm::primitive_fwrite()
 159 {
 160         FILE *file = (FILE *)unbox_alien();
 161         byte_array *text = untag_check<byte_array>(dpop());
 162         cell length = array_capacity(text);
 163         char *string = (char *)(text + 1);
 164
 165         if(length == 0)
 166                 return;
 167
 168         for(;;)
 169         {
 170                 size_t written = fwrite(string,1,length,file);
 171                 if(written == length)
 172                         break;
 173                 else
 174                 {
 175                         if(feof(file))
 176                                 break;
 177                         else
 178                                 io_error();
 179
 180                         /* Still here? EINTR */
 181                         length -= written;
 182                         string += written;
 183                 }
 184         }
 185 }
 186
 187 PRIMITIVE(fwrite)
 188 {
 189         PRIMITIVE_GETVM()->primitive_fwrite();
 190 }
 191
 192 inline void factorvm::primitive_fseek()
 193 {
 194         int whence = to_fixnum(dpop());
 195         FILE *file = (FILE *)unbox_alien();
 196         off_t offset = to_signed_8(dpop());
 197
 198         switch(whence)
 199         {
 200         case 0: whence = SEEK_SET; break;
 201         case 1: whence = SEEK_CUR; break;
 202         case 2: whence = SEEK_END; break;
 203         default:
 204                 critical_error("Bad value for whence",whence);
 205                 break;
 206         }
 207
 208         if(FSEEK(file,offset,whence) == -1)
 209         {
 210                 io_error();
 211
 212                 /* Still here? EINTR */
 213                 critical_error("Don't know what to do; EINTR from fseek()?",0);
 214         }
 215 }
 216
 217 PRIMITIVE(fseek)
 218 {
 219         PRIMITIVE_GETVM()->primitive_fseek();
 220 }
 221
 222 inline void factorvm::primitive_fflush()
 223 {
 224         FILE *file = (FILE *)unbox_alien();
 225         for(;;)
 226         {
 227                 if(fflush(file) == EOF)
 228                         io_error();
 229                 else
 230                         break;
 231         }
 232 }
 233
 234 PRIMITIVE(fflush)
 235 {
 236         PRIMITIVE_GETVM()->primitive_fflush();
 237 }
 238
 239 inline void factorvm::primitive_fclose()
 240 {
 241         FILE *file = (FILE *)unbox_alien();
 242         for(;;)
 243         {
 244                 if(fclose(file) == EOF)
 245                         io_error();
 246                 else
 247                         break;
 248         }
 249 }
 250
 251 PRIMITIVE(fclose)
 252 {
 253         PRIMITIVE_GETVM()->primitive_fclose();
 254 }
 255
 256 /* This function is used by FFI I/O. Accessing the errno global directly is
 257 not portable, since on some libc's errno is not a global but a funky macro that
 258 reads thread-local storage. */
 259 VM_C_API int err_no()
 260 {
 261         return errno;
 262 }
 263
 264 VM_C_API void clear_err_no()
 265 {
 266         errno = 0;
 267 }
 268 }