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