2009-05-02 05:04:19 -04:00
|
|
|
#include "master.hpp"
|
|
|
|
|
2009-05-04 02:46:13 -04:00
|
|
|
namespace factor
|
|
|
|
{
|
|
|
|
|
2009-05-02 05:04:19 -04:00
|
|
|
/* Simple wrappers for ANSI C I/O functions, used for bootstrapping.
|
|
|
|
|
|
|
|
Note the ugly loop logic in almost every function; we have to handle EINTR
|
|
|
|
and restart the operation if the system call was interrupted. Naive
|
|
|
|
applications don't do this, but then they quickly fail if one enables
|
|
|
|
itimer()s or other signals.
|
|
|
|
|
|
|
|
The Factor library provides platform-specific code for Unix and Windows
|
|
|
|
with many more capabilities so these words are not usually used in
|
|
|
|
normal operation. */
|
|
|
|
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::init_c_io()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-10-23 01:33:53 -04:00
|
|
|
special_objects[OBJ_STDIN] = allot_alien(false_object,(cell)stdin);
|
|
|
|
special_objects[OBJ_STDOUT] = allot_alien(false_object,(cell)stdout);
|
|
|
|
special_objects[OBJ_STDERR] = allot_alien(false_object,(cell)stderr);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-09-23 14:05:46 -04:00
|
|
|
void factor_vm::io_error()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
|
|
|
#ifndef WINCE
|
|
|
|
if(errno == EINTR)
|
|
|
|
return;
|
|
|
|
#endif
|
|
|
|
|
2009-10-18 21:26:21 -04:00
|
|
|
general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2010-02-05 00:52:55 -05:00
|
|
|
FILE *factor_vm::safe_fopen(char *filename, char *mode)
|
|
|
|
{
|
|
|
|
FILE *file;
|
|
|
|
do {
|
|
|
|
file = fopen(filename,mode);
|
|
|
|
if(file == NULL)
|
|
|
|
io_error();
|
|
|
|
else
|
|
|
|
break;
|
|
|
|
} while(errno == EINTR);
|
|
|
|
return file;
|
|
|
|
}
|
|
|
|
|
|
|
|
int factor_vm::safe_fgetc(FILE *stream)
|
|
|
|
{
|
|
|
|
int c;
|
|
|
|
do {
|
|
|
|
c = fgetc(stream);
|
|
|
|
if(c == EOF)
|
|
|
|
{
|
|
|
|
if(feof(stream))
|
|
|
|
return EOF;
|
|
|
|
else
|
|
|
|
io_error();
|
|
|
|
}
|
|
|
|
else
|
|
|
|
break;
|
|
|
|
} while(errno == EINTR);
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
size_t factor_vm::safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream)
|
2010-01-19 15:01:11 -05:00
|
|
|
{
|
2010-01-23 10:07:35 -05:00
|
|
|
size_t items_read = 0;
|
2010-01-19 15:01:11 -05:00
|
|
|
|
2010-01-23 10:07:35 -05:00
|
|
|
do {
|
|
|
|
items_read += fread((void*)((int*)ptr+items_read*size),size,nitems-items_read,stream);
|
|
|
|
} while(items_read != nitems && errno == EINTR);
|
2010-01-19 15:01:11 -05:00
|
|
|
|
2010-01-23 10:07:35 -05:00
|
|
|
return items_read;
|
2010-01-19 15:01:11 -05:00
|
|
|
}
|
|
|
|
|
2010-02-05 00:52:55 -05:00
|
|
|
void factor_vm::safe_fputc(int c, FILE *stream)
|
|
|
|
{
|
|
|
|
do {
|
|
|
|
if(fputc(c,stream) == EOF)
|
|
|
|
io_error();
|
|
|
|
else
|
|
|
|
break;
|
|
|
|
} while(errno == EINTR);
|
|
|
|
}
|
|
|
|
|
|
|
|
size_t factor_vm::safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream)
|
2010-01-19 15:01:11 -05:00
|
|
|
{
|
2010-01-23 10:07:35 -05:00
|
|
|
size_t items_written = 0;
|
2010-01-19 15:01:11 -05:00
|
|
|
|
2010-01-23 10:07:35 -05:00
|
|
|
do {
|
|
|
|
items_written += fwrite((void*)((int*)ptr+items_written*size),size,nitems-items_written,stream);
|
|
|
|
} while(items_written != nitems && errno == EINTR);
|
2010-01-19 15:01:11 -05:00
|
|
|
|
2010-01-23 10:07:35 -05:00
|
|
|
return items_written;
|
2010-01-19 15:01:11 -05:00
|
|
|
}
|
|
|
|
|
2010-02-05 00:52:55 -05:00
|
|
|
int factor_vm::safe_ftell(FILE *stream)
|
2010-01-19 15:01:11 -05:00
|
|
|
{
|
2010-02-05 00:52:55 -05:00
|
|
|
off_t offset;
|
|
|
|
do {
|
|
|
|
if((offset = FTELL(stream)) == -1)
|
|
|
|
io_error();
|
|
|
|
else
|
|
|
|
break;
|
|
|
|
} while(errno == EINTR);
|
|
|
|
return offset;
|
|
|
|
}
|
|
|
|
|
|
|
|
void factor_vm::safe_fseek(FILE *stream, off_t offset, int whence)
|
|
|
|
{
|
|
|
|
switch(whence)
|
|
|
|
{
|
|
|
|
case 0: whence = SEEK_SET; break;
|
|
|
|
case 1: whence = SEEK_CUR; break;
|
|
|
|
case 2: whence = SEEK_END; break;
|
|
|
|
default:
|
|
|
|
critical_error("Bad value for whence",whence);
|
|
|
|
}
|
2010-01-19 15:01:11 -05:00
|
|
|
|
2010-01-23 10:07:35 -05:00
|
|
|
do {
|
2010-02-05 00:52:55 -05:00
|
|
|
if(FSEEK(stream,offset,whence) == -1)
|
|
|
|
io_error();
|
|
|
|
else
|
|
|
|
break;
|
|
|
|
} while(errno == EINTR);
|
|
|
|
}
|
2010-01-19 15:01:11 -05:00
|
|
|
|
2010-02-05 00:52:55 -05:00
|
|
|
void factor_vm::safe_fflush(FILE *stream)
|
|
|
|
{
|
|
|
|
do {
|
|
|
|
if(fflush(stream) == EOF)
|
|
|
|
io_error();
|
|
|
|
else
|
|
|
|
break;
|
|
|
|
} while(errno == EINTR);
|
|
|
|
}
|
|
|
|
|
|
|
|
void factor_vm::safe_fclose(FILE *stream)
|
|
|
|
{
|
|
|
|
do {
|
|
|
|
if(fclose(stream) == EOF)
|
|
|
|
io_error();
|
|
|
|
else
|
|
|
|
break;
|
|
|
|
} while(errno == EINTR);
|
2010-01-19 15:01:11 -05:00
|
|
|
}
|
|
|
|
|
2009-09-27 14:42:18 -04:00
|
|
|
void factor_vm::primitive_fopen()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
data_root<byte_array> mode(ctx->pop(),this);
|
|
|
|
data_root<byte_array> path(ctx->pop(),this);
|
2009-08-17 16:37:15 -04:00
|
|
|
mode.untag_check(this);
|
|
|
|
path.untag_check(this);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
2010-01-19 15:01:11 -05:00
|
|
|
FILE *file;
|
2010-02-05 00:52:55 -05:00
|
|
|
file = safe_fopen((char *)(path.untagged() + 1),
|
|
|
|
(char *)(mode.untagged() + 1));
|
2010-01-19 15:01:11 -05:00
|
|
|
ctx->push(allot_alien(file));
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-12-18 16:59:56 -05:00
|
|
|
FILE *factor_vm::pop_file_handle()
|
|
|
|
{
|
|
|
|
return (FILE *)alien_offset(ctx->pop());
|
|
|
|
}
|
|
|
|
|
2009-09-27 14:42:18 -04:00
|
|
|
void factor_vm::primitive_fgetc()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
FILE *file = pop_file_handle();
|
2009-05-02 05:04:19 -04:00
|
|
|
|
2010-02-05 00:52:55 -05:00
|
|
|
int c = safe_fgetc(file);
|
|
|
|
if(c == EOF && feof(file))
|
|
|
|
ctx->push(false_object);
|
|
|
|
else
|
|
|
|
ctx->push(tag_fixnum(c));
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-09-27 14:42:18 -04:00
|
|
|
void factor_vm::primitive_fread()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
FILE *file = pop_file_handle();
|
2009-05-04 05:50:24 -04:00
|
|
|
fixnum size = unbox_array_size();
|
2009-05-02 05:04:19 -04:00
|
|
|
|
|
|
|
if(size == 0)
|
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
ctx->push(tag<string>(allot_string(0,0)));
|
2009-05-02 05:04:19 -04:00
|
|
|
return;
|
|
|
|
}
|
|
|
|
|
2009-11-02 19:10:34 -05:00
|
|
|
data_root<byte_array> buf(allot_uninitialized_array<byte_array>(size),this);
|
2009-05-02 05:04:19 -04:00
|
|
|
|
|
|
|
for(;;)
|
|
|
|
{
|
2010-01-19 15:01:11 -05:00
|
|
|
int c = safe_fread(buf.untagged() + 1,1,size,file);
|
|
|
|
if(c == 0)
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
|
|
|
if(feof(file))
|
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
ctx->push(false_object);
|
2009-05-02 05:04:19 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
io_error();
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
2010-01-19 15:01:11 -05:00
|
|
|
if(feof(file))
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-05-04 05:50:24 -04:00
|
|
|
byte_array *new_buf = allot_byte_array(c);
|
2009-05-02 10:19:09 -04:00
|
|
|
memcpy(new_buf + 1, buf.untagged() + 1,c);
|
2009-05-02 05:04:19 -04:00
|
|
|
buf = new_buf;
|
|
|
|
}
|
2010-01-19 15:01:11 -05:00
|
|
|
|
2009-12-18 16:59:56 -05:00
|
|
|
ctx->push(buf.value());
|
2009-05-02 05:04:19 -04:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2009-09-27 14:42:18 -04:00
|
|
|
void factor_vm::primitive_fputc()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
FILE *file = pop_file_handle();
|
|
|
|
fixnum ch = to_fixnum(ctx->pop());
|
2010-02-05 00:52:55 -05:00
|
|
|
safe_fputc(ch, file);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-09-27 14:42:18 -04:00
|
|
|
void factor_vm::primitive_fwrite()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
FILE *file = pop_file_handle();
|
|
|
|
byte_array *text = untag_check<byte_array>(ctx->pop());
|
2009-05-04 05:50:24 -04:00
|
|
|
cell length = array_capacity(text);
|
2009-05-02 05:04:19 -04:00
|
|
|
char *string = (char *)(text + 1);
|
|
|
|
|
|
|
|
if(length == 0)
|
|
|
|
return;
|
|
|
|
|
2010-01-19 15:01:11 -05:00
|
|
|
size_t written = safe_fwrite(string,1,length,file);
|
|
|
|
if(written != length)
|
|
|
|
io_error();
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-10-03 19:20:35 -04:00
|
|
|
void factor_vm::primitive_ftell()
|
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
FILE *file = pop_file_handle();
|
2010-02-05 00:52:55 -05:00
|
|
|
ctx->push(from_signed_8(safe_ftell(file)));
|
2009-10-03 19:20:35 -04:00
|
|
|
}
|
|
|
|
|
2009-09-27 14:42:18 -04:00
|
|
|
void factor_vm::primitive_fseek()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
int whence = to_fixnum(ctx->pop());
|
|
|
|
FILE *file = pop_file_handle();
|
|
|
|
off_t offset = to_signed_8(ctx->pop());
|
2010-02-05 00:52:55 -05:00
|
|
|
safe_fseek(file,offset,whence);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-09-27 14:42:18 -04:00
|
|
|
void factor_vm::primitive_fflush()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
FILE *file = pop_file_handle();
|
2010-02-05 00:52:55 -05:00
|
|
|
safe_fflush(file);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
2009-09-27 14:42:18 -04:00
|
|
|
void factor_vm::primitive_fclose()
|
2009-05-02 05:04:19 -04:00
|
|
|
{
|
2009-12-18 16:59:56 -05:00
|
|
|
FILE *file = pop_file_handle();
|
2010-02-05 00:52:55 -05:00
|
|
|
safe_fclose(file);
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
/* This function is used by FFI I/O. Accessing the errno global directly is
|
|
|
|
not portable, since on some libc's errno is not a global but a funky macro that
|
|
|
|
reads thread-local storage. */
|
2009-08-17 16:37:07 -04:00
|
|
|
VM_C_API int err_no()
|
|
|
|
{
|
2009-08-21 15:44:06 -04:00
|
|
|
return errno;
|
2009-05-02 05:04:19 -04:00
|
|
|
}
|
2009-05-04 02:46:13 -04:00
|
|
|
|
2010-02-03 18:20:24 -05:00
|
|
|
VM_C_API void set_err_no(int err)
|
2009-08-17 16:37:07 -04:00
|
|
|
{
|
2010-02-03 18:20:24 -05:00
|
|
|
errno = err;
|
2009-08-17 16:37:07 -04:00
|
|
|
}
|
2009-05-04 02:46:13 -04:00
|
|
|
}
|