steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

guard pages for stack, started io multiplexing

cvs
Slava Pestov 2004-08-12 21:36:36 +00:00
parent 3169e03624
commit 00dc2c9464
38 changed files with 356 additions and 468 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
TODO.FACTOR.txt
View File

@ -46,13 +46,13 @@
+ native:
- SIGBUS handler
- handle division by zero
- broken pipe errors with httpd and telnetd in cfactor
- read#
- to_fixnum and friends: error on float
ERROR: I/O error: [ "primitive_read_line_fd_8" "Resource temporarily unavailable" ]
- errors: don't show .factor-rc
- handle division by zero
- decide if overflow is a fatal error
- parsing should be parsing
- describe-word
- contains ==> contains?

20
library/image.factor
View File

@ -85,14 +85,13 @@ USE: words
: f-type 6 ;
: t-type 7 ;
: empty-type 8 ;
: array-type 9 ;
: vector-type 10 ;
: string-type 11 ;
: sbuf-type 12 ;
: handle-type 13 ;
: bignum-type 14 ;
: float-type 15 ;
: array-type 8 ;
: vector-type 9 ;
: string-type 10 ;
: sbuf-type 11 ;
: handle-type 12 ;
: bignum-type 13 ;
: float-type 14 ;
: immediate ( x tag -- tagged ) swap tag-bits shift< bitor ;
: >header ( id -- tagged ) header-tag immediate ;
@ -153,12 +152,11 @@ USE: words
: f, object-tag here-as "f" set f-type >header emit 0 'fixnum emit ;
: t, object-tag here-as "t" set t-type >header emit 0 'fixnum emit ;
: empty, empty-type >header emit 0 'fixnum emit ;
( Beginning of the image )
! The image proper begins with the header, then EMPTY, F, T
! The image proper begins with the header, then F, T
: begin ( -- ) header empty, f, t, ;
: begin ( -- ) header f, t, ;
( Words )

3
library/platform/native/errors.factor
View File

@ -55,12 +55,11 @@ USE: vectors
: error# ( n -- str )
[
"Expired handle: "
"Expired port: "
"Undefined word: "
"Type check: "
"Array range check: "
"Underflow"
"Incompatible handle: "
"I/O error: "
"Overflow"
"Incomparable types: "

8
library/platform/native/init.factor
View File

@ -76,7 +76,9 @@ USE: unparser
init-styles
init-vocab-styles
default-responders
run-user-init
"interactive" get [ init-interpreter ] when ;
"interactive" get [ init-interpreter ] when
0 exit* ;

5
native/arithmetic.c
View File

@ -59,8 +59,7 @@ bool numberp(CELL tagged)
void primitive_numberp(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(numberp(env.dt));
drepl(tag_boolean(numberp(dpeek())));
}
bool zerop(CELL tagged)
@ -101,7 +100,7 @@ CELL to_integer(CELL tagged)
void primitive_to_integer(void)
{
env.dt = to_integer(env.dt);
drepl(to_integer(dpeek()));
}
/* EQUALITY */

6
native/arithmetic.h
View File

@ -125,8 +125,8 @@ CELL OP(CELL x, CELL y) \
\
void primitive_##OP(void) \
{ \
CELL x = dpop(), y = env.dt; \
env.dt = OP(x,y); \
CELL y = dpop(), x = dpop(); \
dpush(OP(x,y)); \
}
#define BINARY_OP_INTEGER_ONLY(OP) \
@ -203,7 +203,7 @@ CELL OP(CELL x) \
\
void primitive_##OP(void) \
{ \
env.dt = OP(env.dt); \
drepl(OP(dpeek())); \
}
bool realp(CELL tagged);

5
native/bignum.c
View File

@ -2,8 +2,7 @@
void primitive_bignump(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(BIGNUM_TYPE,env.dt));
drepl(tag_boolean(typep(BIGNUM_TYPE,dpeek())));
}
BIGNUM* to_bignum(CELL tagged)
@ -31,7 +30,7 @@ BIGNUM* to_bignum(CELL tagged)
void primitive_to_bignum(void)
{
env.dt = tag_object(to_bignum(env.dt));
drepl(tag_object(to_bignum(dpeek())));
}
CELL number_eq_bignum(CELL x, CELL y)

34
native/complex.c
View File

@ -18,13 +18,12 @@ CELL possibly_complex(CELL real, CELL imaginary)
void primitive_complexp(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(COMPLEX_TYPE,env.dt));
drepl(tag_boolean(typep(COMPLEX_TYPE,dpeek())));
}
void primitive_real(void)
{
switch(type_of(env.dt))
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
@ -33,29 +32,29 @@ void primitive_real(void)
/* No op */
break;
case COMPLEX_TYPE:
env.dt = untag_complex(env.dt)->real;
drepl(untag_complex(dpeek())->real);
break;
default:
type_error(COMPLEX_TYPE,env.dt);
type_error(COMPLEX_TYPE,dpeek());
break;
}
}
void primitive_imaginary(void)
{
switch(type_of(env.dt))
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case FLOAT_TYPE:
case RATIO_TYPE:
env.dt = tag_fixnum(0);
drepl(tag_fixnum(0));
break;
case COMPLEX_TYPE:
env.dt = untag_complex(env.dt)->imaginary;
drepl(untag_complex(dpeek())->imaginary);
break;
default:
type_error(COMPLEX_TYPE,env.dt);
type_error(COMPLEX_TYPE,dpeek());
break;
}
}
@ -63,32 +62,29 @@ void primitive_imaginary(void)
void primitive_to_rect(void)
{
COMPLEX* c;
switch(type_of(env.dt))
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case FLOAT_TYPE:
case RATIO_TYPE:
dpush(env.dt);
env.dt = tag_fixnum(0);
dpush(tag_fixnum(0));
break;
case COMPLEX_TYPE:
c = untag_complex(env.dt);
env.dt = c->imaginary;
c = untag_complex(dpeek());
dpush(c->real);
dpush(c->imaginary);
break;
default:
type_error(COMPLEX_TYPE,env.dt);
type_error(NUMBER_TYPE,dpeek());
break;
}
}
void primitive_from_rect(void)
{
CELL imaginary = env.dt;
CELL imaginary = dpop();
CELL real = dpop();
check_non_empty(imaginary);
check_non_empty(real);
if(!realp(imaginary))
type_error(REAL_TYPE,imaginary);
@ -96,7 +92,7 @@ void primitive_from_rect(void)
if(!realp(real))
type_error(REAL_TYPE,real);
env.dt = possibly_complex(real,imaginary);
dpush(possibly_complex(real,imaginary));
}
CELL number_eq_complex(CELL x, CELL y)

25
native/cons.c
View File

@ -10,37 +10,36 @@ CONS* cons(CELL car, CELL cdr)
void primitive_consp(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(CONS_TYPE,env.dt));
drepl(tag_boolean(typep(CONS_TYPE,dpeek())));
}
void primitive_cons(void)
{
check_non_empty(env.dt);
check_non_empty(dpeek());
env.dt = tag_cons(cons(dpop(),env.dt));
CELL cdr = dpop();
CELL car = dpop();
dpush(tag_cons(cons(car,cdr)));
}
void primitive_car(void)
{
env.dt = car(env.dt);
drepl(car(dpeek()));
}
void primitive_cdr(void)
{
env.dt = cdr(env.dt);
drepl(cdr(dpeek()));
}
void primitive_set_car(void)
{
check_non_empty(dpeek());
untag_cons(env.dt)->car = dpop();
env.dt = dpop();
CELL cons = dpop();
CELL car = dpop();
untag_cons(cons)->car = car;
}
void primitive_set_cdr(void)
{
check_non_empty(dpeek());
untag_cons(env.dt)->cdr = dpop();
env.dt = dpop();
CELL cons = dpop();
CELL cdr = dpop();
untag_cons(cons)->cdr = cdr;
}

9
native/error.c
View File

@ -27,11 +27,16 @@ void throw_error(CELL error)
{
fix_stacks();
dpush(env.dt);
env.dt = error;
dpush(error);
/* Execute the 'throw' word */
cpush(env.cf);
env.cf = env.user[BREAK_ENV];
if(env.cf == 0)
{
/* Crash at startup */
fatal_error("Error thrown before BREAK_ENV set",error);
}
/* Return to run() method */
longjmp(toplevel,1);
}

11
native/error.h
View File

@ -1,13 +1,12 @@
#define ERROR_HANDLE_EXPIRED (0<<3)
#define ERROR_PORT_EXPIRED (0<<3)
#define ERROR_UNDEFINED_WORD (1<<3)
#define ERROR_TYPE (2<<3)
#define ERROR_RANGE (3<<3)
#define ERROR_UNDERFLOW (4<<3)
#define ERROR_HANDLE_INCOMPAT (5<<3)
#define ERROR_IO (6<<3)
#define ERROR_OVERFLOW (7<<3)
#define ERROR_INCOMPARABLE (8<<3)
#define ERROR_FLOAT_FORMAT (9<<3)
#define ERROR_IO (5<<3)
#define ERROR_OVERFLOW (6<<3)
#define ERROR_INCOMPARABLE (7<<3)
#define ERROR_FLOAT_FORMAT (8<<3)
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);

6
native/factor.h
View File

@ -41,7 +41,6 @@ typedef unsigned short CHAR;
#include "gc.h"
#include "types.h"
#include "array.h"
#include "handle.h"
#include "word.h"
#include "run.h"
#include "fixnum.h"
@ -52,14 +51,15 @@ typedef unsigned short CHAR;
#include "arithmetic.h"
#include "misc.h"
#include "string.h"
#include "port.h"
#include "fd.h"
#include "iomux.h"
#include "file.h"
#include "socket.h"
#include "iomux.h"
#include "cons.h"
#include "image.h"
#include "primitives.h"
#include "vector.h"
#include "socket.h"
#include "stack.h"
#include "sbuf.h"
#include "relocate.h"

130
native/fd.c
View File

@ -2,37 +2,24 @@
void init_io(void)
{
env.user[STDIN_ENV] = handle(HANDLE_FD,0);
env.user[STDOUT_ENV] = handle(HANDLE_FD,1);
env.user[STDERR_ENV] = handle(HANDLE_FD,2);
env.user[STDIN_ENV] = port(0);
env.user[STDOUT_ENV] = port(1);
env.user[STDERR_ENV] = port(2);
}
void init_buffer(HANDLE* h, int mode)
int read_step(PORT* port, STRING* buf)
{
if(h->buf_mode == B_NONE)
h->buffer = tag_object(string(BUF_SIZE,'\0'));
if(h->buf_mode != mode)
{
h->buf_fill = h->buf_pos = 0;
h->buf_mode = mode;
}
}
int amount = read(port->fd,buf + 1,buf->capacity * 2);
int fill_buffer(HANDLE* h, int fd, STRING* buf)
{
int amount = read(fd,buf + 1,buf->capacity * 2);
/* printf("READING %d GOT %d\n",buf->capacity * 2,amount); */
h->buf_fill = (amount < 0 ? 0 : amount);
h->buf_pos = 0;
port->buf_fill = (amount < 0 ? 0 : amount);
port->buf_pos = 0;
return amount;
}
void primitive_read_line_fd_8(void)
{
HANDLE* h = untag_handle(HANDLE_FD,env.dt);
int fd = h->object;
PORT* port = untag_port(dpeek());
int amount;
int i;
@ -41,18 +28,13 @@ void primitive_read_line_fd_8(void)
/* finished line, unicode */
SBUF* line = sbuf(LINE_SIZE);
/* read ascii from fd */
STRING* buf;
init_buffer(h,B_READ);
buf = untag_string(h->buffer);
init_buffer(port,B_READ);
for(;;)
{
if(h->buf_pos >= h->buf_fill)
if(port->buf_pos >= port->buf_fill)
{
amount = fill_buffer(h,fd,buf);
amount = read_step(port,port->buffer);
if(amount < 0)
io_error(__FUNCTION__);
@ -62,21 +44,21 @@ void primitive_read_line_fd_8(void)
if(line->top == 0)
{
/* didn't read anything before EOF */
env.dt = F;
drepl(F);
}
else
env.dt = tag_object(line);
drepl(tag_object(line));
return;
}
}
for(i = h->buf_pos; i < h->buf_fill; i++)
for(i = port->buf_pos; i < port->buf_fill; i++)
{
ch = bget((CELL)buf + sizeof(STRING) + i);
ch = bget((CELL)port->buffer + sizeof(STRING) + i);
if(ch == '\n')
{
h->buf_pos = i + 1;
env.dt = tag_object(line);
port->buf_pos = i + 1;
drepl(tag_object(line));
return;
}
else
@ -84,12 +66,12 @@ void primitive_read_line_fd_8(void)
}
/* We've reached the end of the above loop */
h->buf_pos = h->buf_fill;
port->buf_pos = port->buf_fill;
}
}
/* keep writing to the stream until everything is written */
void write_fully(HANDLE* h, char* str, CELL len)
void write_fully(PORT* port, char* str, CELL len)
{
FIXNUM amount, written = 0, remains;
@ -100,7 +82,7 @@ void write_fully(HANDLE* h, char* str, CELL len)
if(remains == 0)
break;
amount = write(h->object,str + written,remains);
amount = write(port->fd,str + written,remains);
if(amount < 0)
io_error(__FUNCTION__);
@ -108,67 +90,62 @@ void write_fully(HANDLE* h, char* str, CELL len)
}
}
void flush_buffer(HANDLE* h)
void flush_buffer(PORT* port)
{
STRING* buf;
if(h->buf_mode != B_WRITE || h->buf_fill == 0)
if(port->buf_mode != B_WRITE || port->buf_fill == 0)
return;
buf = untag_string(h->buffer);
write_fully(h,(char*)buf + sizeof(STRING),h->buf_fill);
h->buf_fill = 0;
write_fully(port,(char*)port->buffer + sizeof(STRING),port->buf_fill);
port->buf_fill = 0;
}
void write_fd_char_8(HANDLE* h, FIXNUM ch)
void write_fd_char_8(PORT* port, FIXNUM ch)
{
char c = (char)ch;
STRING* buf;
init_buffer(h,B_WRITE);
buf = untag_string(h->buffer);
init_buffer(port,B_WRITE);
/* Is the buffer full? */
if(h->buf_fill == buf->capacity * CHARS)
flush_buffer(h);
if(port->buf_fill == port->buffer->capacity * CHARS)
flush_buffer(port);
bput((CELL)buf + sizeof(STRING) + h->buf_fill,c);
h->buf_fill++;
bput((CELL)port->buffer + sizeof(STRING) + port->buf_fill,c);
port->buf_fill++;
}
void write_fd_string_8(HANDLE* h, STRING* str)
void write_fd_string_8(PORT* port, STRING* str)
{
char* c_str = to_c_string(str);
STRING* buf;
init_buffer(h,B_WRITE);
buf = untag_string(h->buffer);
init_buffer(port,B_WRITE);
/* Is the string longer than the buffer? */
if(str->capacity > buf->capacity * CHARS)
if(str->capacity > port->buffer->capacity * CHARS)
{
/* Just write it immediately */
flush_buffer(h);
write_fully(h,c_str,str->capacity);
flush_buffer(port);
write_fully(port,c_str,str->capacity);
}
else
{
/* Is there enough room in the buffer? If not, flush */
if(h->buf_fill + str->capacity > buf->capacity * CHARS)
flush_buffer(h);
if(port->buf_fill + str->capacity
> port->buffer->capacity * CHARS)
{
flush_buffer(port);
}
/* Append string to buffer */
memcpy((void*)((CELL)buf + sizeof(STRING) + h->buf_fill),
c_str,str->capacity);
memcpy((void*)((CELL)port->buffer + sizeof(STRING)
+ port->buf_fill),c_str,str->capacity);
h->buf_fill += str->capacity;
port->buf_fill += str->capacity;
}
}
void primitive_write_fd_8(void)
{
HANDLE* h = untag_handle(HANDLE_FD,env.dt);
PORT* port = untag_port(dpop());
CELL text = dpop();
CELL type = type_of(text);
@ -177,31 +154,26 @@ void primitive_write_fd_8(void)
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
write_fd_char_8(h,to_fixnum(text));
write_fd_char_8(port,to_fixnum(text));
break;
case STRING_TYPE:
write_fd_string_8(h,untag_string(text));
write_fd_string_8(port,untag_string(text));
break;
default:
type_error(STRING_TYPE,text);
break;
}
env.dt = dpop();
}
void primitive_flush_fd(void)
{
HANDLE* h = untag_handle(HANDLE_FD,env.dt);
flush_buffer(h);
env.dt = dpop();
PORT* port = untag_port(dpop());
flush_buffer(port);
}
void primitive_close_fd(void)
{
HANDLE* h = untag_handle(HANDLE_FD,env.dt);
flush_buffer(h);
close(h->object);
env.dt = dpop();
PORT* port = untag_port(dpop());
flush_buffer(port);
close(port->fd);
}

10
native/fd.h
View File

@ -1,13 +1,13 @@
#define LINE_SIZE 80
#define BUF_SIZE (32 * 1024)
int fill_buffer(HANDLE* h, int fd, STRING* buf);
void flush_buffer(HANDLE* h);
void write_fully(HANDLE* h, char* str, CELL len);
int read_step(PORT* port, STRING* buf);
void flush_buffer(PORT* port);
void write_fully(PORT* port, char* str, CELL len);
void init_io(void);
void primitive_read_line_fd_8(void);
void write_fd_char_8(HANDLE* h, FIXNUM ch);
void write_fd_string_8(HANDLE* h, STRING* str);
void write_fd_char_8(PORT* port, FIXNUM ch);
void write_fd_string_8(PORT* port, STRING* str);
void primitive_write_fd_8(void);
void primitive_flush_fd(void);
void primitive_close_fd(void);

4
native/file.c
View File

@ -2,7 +2,7 @@
void primitive_open_file(void)
{
bool write = untag_boolean(env.dt);
bool write = untag_boolean(dpop());
bool read = untag_boolean(dpop());
char* path = to_c_string(untag_string(dpop()));
int mode;
@ -21,5 +21,5 @@ void primitive_open_file(void)
if(fd < 0)
io_error(__FUNCTION__);
env.dt = handle(HANDLE_FD,fd);
dpush(port(fd));
}

9
native/fixnum.c
View File

@ -2,14 +2,13 @@
void primitive_fixnump(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(TAG(env.dt) == FIXNUM_TYPE);
drepl(tag_boolean(TAG(dpeek()) == FIXNUM_TYPE));
}
void primitive_not(void)
{
type_check(FIXNUM_TYPE,env.dt);
env.dt = RETAG(UNTAG(~env.dt),FIXNUM_TYPE);
type_check(FIXNUM_TYPE,dpeek());
drepl(RETAG(UNTAG(~dpeek()),FIXNUM_TYPE));
}
FIXNUM to_fixnum(CELL tagged)
@ -37,7 +36,7 @@ FIXNUM to_fixnum(CELL tagged)
void primitive_to_fixnum(void)
{
env.dt = tag_fixnum(to_fixnum(env.dt));
drepl(tag_fixnum(to_fixnum(dpeek())));
}
CELL number_eq_fixnum(CELL x, CELL y)

45
native/float.c
View File

@ -2,8 +2,7 @@
void primitive_floatp(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(FLOAT_TYPE,env.dt));
drepl(tag_boolean(typep(FLOAT_TYPE,dpeek())));
}
FLOAT* to_float(CELL tagged)
@ -26,33 +25,33 @@ FLOAT* to_float(CELL tagged)
void primitive_to_float(void)
{
env.dt = tag_object(to_float(env.dt));
drepl(tag_object(to_float(dpeek())));
}
void primitive_str_to_float(void)
{
STRING* str = untag_string(env.dt);
STRING* str = untag_string(dpeek());
char* c_str = to_c_string(str);
char* end = c_str;
double f = strtod(c_str,&end);
if(end != c_str + str->capacity)
general_error(ERROR_FLOAT_FORMAT,tag_object(str));
env.dt = tag_object(make_float(f));
drepl(tag_object(make_float(f)));
}
void primitive_float_to_str(void)
{
char tmp[33];
snprintf(&tmp,32,"%.16g",to_float(env.dt)->n);
snprintf(&tmp,32,"%.16g",to_float(dpeek())->n);
tmp[32] = '\0';
env.dt = tag_object(from_c_string(tmp));
drepl(tag_object(from_c_string(tmp)));
}
void primitive_float_to_bits(void)
{
double f = untag_float(env.dt);
double f = untag_float(dpeek());
BIGNUM_2 f_raw = *(BIGNUM_2*)&f;
env.dt = tag_object(bignum(f_raw));
drepl(tag_object(bignum(f_raw)));
}
CELL number_eq_float(CELL x, CELL y)
@ -117,64 +116,64 @@ CELL greatereq_float(CELL x, CELL y)
void primitive_facos(void)
{
env.dt = tag_object(make_float(acos(to_float(env.dt)->n)));
drepl(tag_object(make_float(acos(to_float(dpeek())->n))));
}
void primitive_fasin(void)
{
env.dt = tag_object(make_float(asin(to_float(env.dt)->n)));
drepl(tag_object(make_float(asin(to_float(dpeek())->n))));
}
void primitive_fatan(void)
{
env.dt = tag_object(make_float(atan(to_float(env.dt)->n)));
drepl(tag_object(make_float(atan(to_float(dpeek())->n))));
}
void primitive_fatan2(void)
{
double x = to_float(env.dt)->n;
double x = to_float(dpop())->n;
double y = to_float(dpop())->n;
env.dt = tag_object(make_float(atan2(y,x)));
dpush(tag_object(make_float(atan2(y,x))));
}
void primitive_fcos(void)
{
env.dt = tag_object(make_float(cos(to_float(env.dt)->n)));
drepl(tag_object(make_float(cos(to_float(dpeek())->n))));
}
void primitive_fexp(void)
{
env.dt = tag_object(make_float(exp(to_float(env.dt)->n)));
drepl(tag_object(make_float(exp(to_float(dpeek())->n))));
}
void primitive_fcosh(void)
{
env.dt = tag_object(make_float(cosh(to_float(env.dt)->n)));
drepl(tag_object(make_float(cosh(to_float(dpeek())->n))));
}
void primitive_flog(void)
{
env.dt = tag_object(make_float(log(to_float(env.dt)->n)));
drepl(tag_object(make_float(log(to_float(dpeek())->n))));
}
void primitive_fpow(void)
{
double x = to_float(env.dt)->n;
double x = to_float(dpop())->n;
double y = to_float(dpop())->n;
env.dt = tag_object(make_float(pow(y,x)));
dpush(tag_object(make_float(pow(y,x))));
}
void primitive_fsin(void)
{
env.dt = tag_object(make_float(sin(to_float(env.dt)->n)));
drepl(tag_object(make_float(sin(to_float(dpeek())->n))));
}
void primitive_fsinh(void)
{
env.dt = tag_object(make_float(sinh(to_float(env.dt)->n)));
drepl(tag_object(make_float(sinh(to_float(dpeek())->n))));
}
void primitive_fsqrt(void)
{
env.dt = tag_object(make_float(sqrt(to_float(env.dt)->n)));
drepl(tag_object(make_float(sqrt(to_float(dpeek())->n))));
}

9
native/gc.c
View File

@ -87,8 +87,8 @@ void collect_object(void)
case SBUF_TYPE:
collect_sbuf((SBUF*)scan);
break;
case HANDLE_TYPE:
collect_handle((HANDLE*)scan);
case PORT_TYPE:
collect_port((PORT*)scan);
break;
}
@ -118,14 +118,11 @@ void copy_roots(void)
CELL ptr;
gc_debug("collect_roots",scan);
/* these three must be the first in the heap */
copy_object(&empty);
gc_debug("empty",empty);
/* these two must be the first in the heap */
copy_object(&F);
gc_debug("f",F);
copy_object(&T);
gc_debug("t",T);
copy_object(&env.dt);
copy_object(&env.cf);
copy_object(&env.boot);

43
native/handle.c
View File

@ -1,43 +0,0 @@
#include "factor.h"
HANDLE* untag_handle(CELL type, CELL tagged)
{
HANDLE* h;
type_check(HANDLE_TYPE,tagged);
h = (HANDLE*)UNTAG(tagged);
/* after image load & save, handles are no longer valid */
if(h->object == -1)
general_error(ERROR_HANDLE_EXPIRED,tagged);
if(h->type != type)
general_error(ERROR_HANDLE_INCOMPAT,tagged);
return h;
}
CELL handle(CELL type, CELL object)
{
HANDLE* handle = allot_object(HANDLE_TYPE,sizeof(HANDLE));
handle->type = type;
handle->object = object;
handle->buffer = F;
handle->buf_mode = B_NONE;
handle->buf_fill = 0;
handle->buf_pos = 0;
return tag_object(handle);
}
void primitive_handlep(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(HANDLE_TYPE,env.dt));
}
void fixup_handle(HANDLE* handle)
{
handle->object = -1;
fixup(&handle->buffer);
}
void collect_handle(HANDLE* handle)
{
copy_object(&handle->buffer);
}

20
native/handle.h
View File

@ -1,20 +0,0 @@
typedef struct {
CELL header;
CELL type;
CELL object;
CELL buffer; /* tagged */
CELL buf_mode;
CELL buf_fill;
CELL buf_pos;
} HANDLE;
#define HANDLE_FD 1
#define B_READ 0
#define B_WRITE 1
#define B_NONE 2
HANDLE* untag_handle(CELL type, CELL tagged);
CELL handle(CELL type, CELL object);
void primitive_handlep(void);
void fixup_handle(HANDLE* handle);
void collect_handle(HANDLE* handle);

4
native/image.c
View File

@ -69,8 +69,6 @@ bool save_image(char* filename)
void primitive_save_image(void)
{
STRING* filename = untag_string(env.dt);
env.dt = dpop();
STRING* filename = untag_string(dpop());
save_image(to_c_string(filename));
}

3
native/memory.c
View File

@ -84,7 +84,6 @@ bool in_zone(ZONE* z, CELL pointer)
void primitive_room(void)
{
/* push: free total */
dpush(env.dt);
env.dt = tag_fixnum(active->limit - active->base);
dpush(tag_fixnum(active->limit - active->here));
dpush(tag_fixnum(active->limit - active->base));
}

18
native/misc.c
View File

@ -2,32 +2,29 @@
void primitive_exit(void)
{
exit(to_fixnum(env.dt));
exit(to_fixnum(dpop()));
}
void primitive_os_env(void)
{
char* name = to_c_string(untag_string(env.dt));
char* name = to_c_string(untag_string(dpeek()));
char* value = getenv(name);
if(value == NULL)
env.dt = F;
drepl(F);
else
env.dt = tag_object(from_c_string(getenv(name)));
drepl(tag_object(from_c_string(getenv(name))));
}
void primitive_eq(void)
{
check_non_empty(env.dt);
check_non_empty(dpeek());
env.dt = tag_boolean(dpop() == env.dt);
dpush(tag_boolean(dpop() == dpop()));
}
void primitive_millis(void)
{
struct timeval t;
gettimeofday(&t,NULL);
dpush(env.dt);
env.dt = tag_object(bignum(t.tv_sec * 1000 + t.tv_usec/1000));
dpush(tag_object(bignum(t.tv_sec * 1000 + t.tv_usec/1000)));
}
void primitive_init_random(void)
@ -43,6 +40,5 @@ void primitive_init_random(void)
void primitive_random_int(void)
{
dpush(env.dt);
env.dt = tag_object(bignum(random()));
dpush(tag_object(bignum(random())));
}

59
native/port.c Normal file
View File

@ -0,0 +1,59 @@
#include "factor.h"
PORT* untag_port(CELL tagged)
{
PORT* p;
type_check(PORT_TYPE,tagged);
p = (PORT*)UNTAG(tagged);
/* after image load & save, ports are no longer valid */
if(p->fd == -1)
general_error(ERROR_PORT_EXPIRED,tagged);
return p;
}
CELL port(CELL fd)
{
PORT* port = allot_object(PORT_TYPE,sizeof(PORT));
port->fd = fd;
port->buffer = (STRING*)0;
port->buf_mode = B_NONE;
port->buf_fill = 0;
port->buf_pos = 0;
return tag_object(port);
}
void primitive_portp(void)
{
drepl(tag_boolean(typep(PORT_TYPE,dpeek())));
}
void init_buffer(PORT* port, int mode)
{
if(port->buf_mode == B_NONE)
port->buffer = string(BUF_SIZE,'\0');
if(port->buf_mode != mode)
{
port->buf_fill = port->buf_pos = 0;
port->buf_mode = mode;
}
}
void fixup_port(PORT* port)
{
port->fd = -1;
if(port->buffer != 0)
{
port->buffer = (STRING*)((CELL)port->buffer
+ (active->base - relocation_base));
}
}
void collect_port(PORT* port)
{
if(port->buffer != 0)
{
port->buffer = copy_untagged_object(
port->buffer,SSIZE(port->buffer));
}
}

20
native/port.h Normal file
View File

@ -0,0 +1,20 @@
typedef struct {
CELL header;
FIXNUM fd;
STRING* buffer;
CELL buf_mode;
CELL buf_fill;
CELL buf_pos;
} PORT;
/* Buffer mode */
#define B_READ 0
#define B_WRITE 1
#define B_NONE 2
PORT* untag_port(CELL tagged);
CELL port(CELL fd);
void init_buffer(PORT* port, int mode);
void primitive_portp(void);
void fixup_port(PORT* port);
void collect_port(PORT* port);

2
native/primitives.c
View File

@ -114,7 +114,7 @@ XT primitives[] = {
primitive_callstack,
primitive_set_datastack,
primitive_set_callstack,
primitive_handlep,
primitive_portp,
primitive_exit,
primitive_server_socket,
primitive_close_fd,

17
native/ratio.c
View File

@ -10,40 +10,39 @@ RATIO* ratio(CELL numerator, CELL denominator)
void primitive_ratiop(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(RATIO_TYPE,env.dt));
drepl(tag_boolean(typep(RATIO_TYPE,dpeek())));
}
void primitive_numerator(void)
{
switch(type_of(env.dt))
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
/* No op */
break;
case RATIO_TYPE:
env.dt = untag_ratio(env.dt)->numerator;
drepl(untag_ratio(dpeek())->numerator);
break;
default:
type_error(RATIONAL_TYPE,env.dt);
type_error(RATIONAL_TYPE,dpeek());
break;
}
}
void primitive_denominator(void)
{
switch(type_of(env.dt))
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
env.dt = tag_fixnum(1);
drepl(tag_fixnum(1));
break;
case RATIO_TYPE:
env.dt = untag_ratio(env.dt)->denominator;
drepl(untag_ratio(dpeek())->denominator);
break;
default:
type_error(RATIONAL_TYPE,env.dt);
type_error(RATIONAL_TYPE,dpeek());
break;
}
}

12
native/relocate.c
View File

@ -24,8 +24,8 @@ void relocate_object()
case SBUF_TYPE:
fixup_sbuf((SBUF*)relocating);
break;
case HANDLE_TYPE:
fixup_handle((HANDLE*)relocating);
case PORT_TYPE:
fixup_port((PORT*)relocating);
}
relocating += size;
@ -53,13 +53,7 @@ void relocate(CELL r)
relocating = active->base;
/* The first three objects in the image must always be
EMPTY, F, T */
if(untag_header(get(relocating)) != EMPTY_TYPE)
fatal_error("Not empty",get(relocating));
empty = tag_object((CELL*)relocating);
relocate_next();
/* The first two objects in the image must always be F, T */
if(untag_header(get(relocating)) != F_TYPE)
fatal_error("Not F",get(relocating));
F = tag_object((CELL*)relocating);

27
native/run.c
View File

@ -20,9 +20,6 @@ void run(void)
{
if(env.cf == F)
{
if(cpeek() == empty)
break;
env.cf = cpop();
continue;
}
@ -34,15 +31,10 @@ void run(void)
if(TAG(next) == WORD_TYPE)
{
env.w = (WORD*)UNTAG(next);
/* printf("EXECUTE %d\n",env.w->primitive); */
EXECUTE(env.w);
}
else
{
/* printf("DPUSH %d\n",type_of(next)); */
dpush(env.dt);
env.dt = next;
}
dpush(next);
}
}
@ -65,16 +57,14 @@ void call()
void primitive_execute(void)
{
WORD* word = untag_word(env.dt);
env.dt = dpop();
WORD* word = untag_word(dpop());
env.w = word;
EXECUTE(env.w);
}
void primitive_call(void)
{
CELL calling = env.dt;
env.dt = dpop();
CELL calling = dpop();
if(env.cf != F)
cpush(env.cf);
env.cf = calling;
@ -82,11 +72,10 @@ void primitive_call(void)
void primitive_ifte(void)
{
CELL f = env.dt;
CELL f = dpop();
CELL t = dpop();
CELL cond = dpop();
CELL calling = (untag_boolean(cond) ? t : f);
env.dt = dpop();
if(env.cf != F)
cpush(env.cf);
env.cf = calling;
@ -94,19 +83,17 @@ void primitive_ifte(void)
void primitive_getenv(void)
{
FIXNUM e = to_fixnum(env.dt);
FIXNUM e = to_fixnum(dpeek());
if(e < 0 || e >= USER_ENV)
range_error(F,e,USER_ENV);
env.dt = env.user[e];
drepl(env.user[e]);
}
void primitive_setenv(void)
{
FIXNUM e = to_fixnum(env.dt);
FIXNUM e = to_fixnum(dpop());
CELL value = dpop();
if(e < 0 || e >= USER_ENV)
range_error(F,e,USER_ENV);
check_non_empty(value);
env.user[e] = value;
env.dt = dpop();
}

8
native/run.h
View File

@ -13,8 +13,6 @@
jmp_buf toplevel;
typedef struct {
/* TAGGED top of datastack; EMPTY if datastack is empty */
CELL dt;
/* TAGGED currently executing quotation */
CELL cf;
/* raw pointer to datastack bottom */
@ -36,7 +34,6 @@ typedef struct {
ENV env;
void clear_environment(void);
void check_non_empty(CELL cell);
INLINE CELL dpop(void)
{
@ -44,6 +41,11 @@ INLINE CELL dpop(void)
return get(env.ds);
}
INLINE void drepl(CELL top)
{
put(env.ds - CELLS,top);
}
INLINE void dpush(CELL top)
{
put(env.ds,top);

36
native/sbuf.c
View File

@ -10,40 +10,38 @@ SBUF* sbuf(FIXNUM capacity)
void primitive_sbufp(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(SBUF_TYPE,env.dt));
drepl(tag_boolean(typep(SBUF_TYPE,dpeek())));
}
void primitive_sbuf(void)
{
env.dt = tag_object(sbuf(to_fixnum(env.dt)));
drepl(tag_object(sbuf(to_fixnum(dpeek()))));
}
void primitive_sbuf_length(void)
{
env.dt = tag_fixnum(untag_sbuf(env.dt)->top);
drepl(tag_fixnum(untag_sbuf(dpeek())->top));
}
void primitive_set_sbuf_length(void)
{
SBUF* sbuf = untag_sbuf(env.dt);
SBUF* sbuf = untag_sbuf(dpop());
FIXNUM length = to_fixnum(dpop());
sbuf->top = length;
if(length < 0)
range_error(env.dt,length,sbuf->top);
range_error(tag_object(sbuf),length,sbuf->top);
else if(length > sbuf->string->capacity)
sbuf->string = grow_string(sbuf->string,length,F);
env.dt = dpop(); /* don't forget this! */
}
void primitive_sbuf_nth(void)
{
SBUF* sbuf = untag_sbuf(env.dt);
SBUF* sbuf = untag_sbuf(dpop());
CELL index = to_fixnum(dpop());
if(index < 0 || index >= sbuf->top)
range_error(env.dt,index,sbuf->top);
env.dt = string_nth(sbuf->string,index);
range_error(tag_object(sbuf),index,sbuf->top);
dpush(string_nth(sbuf->string,index));
}
void sbuf_ensure_capacity(SBUF* sbuf, int top)
@ -68,14 +66,11 @@ void set_sbuf_nth(SBUF* sbuf, CELL index, CHAR value)
void primitive_set_sbuf_nth(void)
{
SBUF* sbuf = untag_sbuf(env.dt);
SBUF* sbuf = untag_sbuf(dpop());
FIXNUM index = to_fixnum(dpop());
CELL value = dpop();
check_non_empty(value);
set_sbuf_nth(sbuf,index,value);
env.dt = dpop(); /* don't forget this! */
}
void sbuf_append_string(SBUF* sbuf, STRING* string)
@ -89,10 +84,8 @@ void sbuf_append_string(SBUF* sbuf, STRING* string)
void primitive_sbuf_append(void)
{
SBUF* sbuf = untag_sbuf(env.dt);
SBUF* sbuf = untag_sbuf(dpop());
CELL object = dpop();
check_non_empty(object);
env.dt = dpop();
switch(type_of(object))
{
case FIXNUM_TYPE:
@ -118,7 +111,7 @@ STRING* sbuf_to_string(SBUF* sbuf)
void primitive_sbuf_to_string(void)
{
env.dt = tag_object(sbuf_to_string(untag_sbuf(env.dt)));
drepl(tag_object(sbuf_to_string(untag_sbuf(dpeek()))));
}
bool sbuf_eq(SBUF* s1, SBUF* s2)
@ -131,13 +124,12 @@ bool sbuf_eq(SBUF* s1, SBUF* s2)
void primitive_sbuf_eq(void)
{
SBUF* s1 = untag_sbuf(env.dt);
SBUF* s1 = untag_sbuf(dpop());
CELL with = dpop();
check_non_empty(with);
if(typep(SBUF_TYPE,with))
env.dt = tag_boolean(sbuf_eq(s1,(SBUF*)UNTAG(with)));
dpush(tag_boolean(sbuf_eq(s1,(SBUF*)UNTAG(with))));
else
env.dt = F;
dpush(F);
}
void fixup_sbuf(SBUF* sbuf)

8
native/socket.c
View File

@ -39,8 +39,8 @@ int make_server_socket(CHAR port)
void primitive_server_socket(void)
{
CHAR port = (CHAR)to_fixnum(env.dt);
env.dt = handle(HANDLE_FD,make_server_socket(port));
CHAR p = (CHAR)to_fixnum(dpop());
dpush(port(make_server_socket(p)));
}
int accept_connection(int sock)
@ -61,6 +61,6 @@ int accept_connection(int sock)
void primitive_accept_fd(void)
{
HANDLE* h = untag_handle(HANDLE_FD,env.dt);
env.dt = handle(HANDLE_FD,accept_connection(h->object));
PORT* p = untag_port(dpop());
dpush(port(accept_connection(p->fd)));
}

90
native/stack.c
View File

@ -3,13 +3,11 @@
void reset_datastack(void)
{
env.ds = env.ds_bot;
env.dt = empty;
}
void reset_callstack(void)
{
env.cs = env.cs_bot;
cpush(empty);
}
void init_stacks(void)
@ -23,117 +21,91 @@ void init_stacks(void)
void primitive_drop(void)
{
check_non_empty(env.dt);
env.dt = dpop();
dpop();
}
void primitive_dup(void)
{
check_non_empty(env.dt);
dpush(env.dt);
dpush(dpeek());
}
void primitive_swap(void)
{
CELL top, next;
check_non_empty(env.dt);
check_non_empty(dpeek());
top = env.dt;
next = dpop();
dpush(top);
env.dt = next;
CELL top = dpeek();
CELL next = get(env.ds - CELLS * 2);
put(env.ds - CELLS,next);
put(env.ds - CELLS * 2,top);
}
void primitive_over(void)
{
CELL under = dpeek();
check_non_empty(env.dt);
check_non_empty(under);
dpush(env.dt);
env.dt = under;
dpush(get(env.ds - CELLS * 2));
}
void primitive_pick(void)
{
CELL under = dpeek();
CELL under_under = get(env.ds - CELLS * 2);
check_non_empty(env.dt);
check_non_empty(under);
check_non_empty(under_under);
dpush(env.dt);
env.dt = under_under;
dpush(get(env.ds - CELLS * 3));
}
void primitive_nip(void)
{
check_non_empty(dpeek());
dpop();
CELL top = dpop();
put(env.ds - CELLS,top);
}
void primitive_tuck(void)
{
CELL under = dpeek();
check_non_empty(env.dt);
check_non_empty(under);
dpop();
dpush(env.dt);
dpush(under);
CELL top = dpeek();
CELL next = get(env.ds - CELLS * 2);
put(env.ds - CELLS * 2,top);
put(env.ds - CELLS,next);
dpush(top);
}
void primitive_rot(void)
{
CELL y, z;
/* z y env.dt --> y env.dt z <top> */
check_non_empty(env.dt);
y = dpeek();
check_non_empty(y);
z = get(env.ds - CELLS * 2);
check_non_empty(z);
put(env.ds - CELLS * 2,y);
put(env.ds - CELLS,env.dt);
env.dt = z;
CELL top = dpeek();
CELL next = get(env.ds - CELLS * 2);
CELL next_next = get(env.ds - CELLS * 3);
put(env.ds - CELLS * 3,next);
put(env.ds - CELLS * 2,top);
put(env.ds - CELLS,next_next);
}
void primitive_to_r(void)
{
check_non_empty(env.dt);
cpush(env.dt);
env.dt = dpop();
cpush(dpop());
}
void primitive_from_r(void)
{
check_non_empty(cpeek());
dpush(env.dt);
env.dt = cpop();
dpush(cpop());
}
VECTOR* stack_to_vector(CELL bottom, CELL top)
{
CELL depth = (top - bottom) / CELLS - 1;
CELL depth = (top - bottom) / CELLS;
VECTOR* v = vector(depth);
ARRAY* a = v->array;
memcpy(a + 1,(char*)bottom + CELLS,depth * CELLS);
memcpy(a + 1,(void*)bottom,depth * CELLS);
v->top = depth;
return v;
}
void primitive_datastack(void)
{
dpush(env.dt);
env.dt = tag_object(stack_to_vector(env.ds_bot,env.ds));
dpush(tag_object(stack_to_vector(env.ds_bot,env.ds)));
}
void primitive_callstack(void)
{
dpush(env.dt);
env.dt = tag_object(stack_to_vector(env.cs_bot,env.cs));
dpush(tag_object(stack_to_vector(env.cs_bot,env.cs)));
}
/* Returns top of stack */
CELL vector_to_stack(VECTOR* vector, CELL bottom)
{
CELL start = bottom + CELLS;
CELL start = bottom;
CELL len = vector->top * CELLS;
memcpy((void*)start,vector->array + 1,len);
return start + len;
@ -141,12 +113,10 @@ CELL vector_to_stack(VECTOR* vector, CELL bottom)
void primitive_set_datastack(void)
{
env.ds = vector_to_stack(untag_vector(env.dt),env.ds_bot);
env.dt = dpop();
env.ds = vector_to_stack(untag_vector(dpop()),env.ds_bot);
}
void primitive_set_callstack(void)
{
env.cs = vector_to_stack(untag_vector(env.dt),env.cs_bot);
env.dt = dpop();
env.cs = vector_to_stack(untag_vector(dpop()),env.cs_bot);
}

31
native/string.c
View File

@ -86,23 +86,22 @@ char* to_c_string(STRING* s)
void primitive_stringp(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(STRING_TYPE,env.dt));
drepl(tag_boolean(typep(STRING_TYPE,dpeek())));
}
void primitive_string_length(void)
{
env.dt = tag_fixnum(untag_string(env.dt)->capacity);
drepl(tag_fixnum(untag_string(dpeek())->capacity));
}
void primitive_string_nth(void)
{
STRING* string = untag_string(env.dt);
STRING* string = untag_string(dpop());
CELL index = to_fixnum(dpop());
if(index < 0 || index >= string->capacity)
range_error(tag_object(string),index,string->capacity);
env.dt = tag_fixnum(string_nth(string,index));
dpush(tag_fixnum(string_nth(string,index)));
}
FIXNUM string_compare_head(STRING* s1, STRING* s2, CELL len)
@ -136,10 +135,10 @@ FIXNUM string_compare(STRING* s1, STRING* s2)
void primitive_string_compare(void)
{
STRING* s2 = untag_string(env.dt);
STRING* s2 = untag_string(dpop());
STRING* s1 = untag_string(dpop());
env.dt = tag_fixnum(string_compare(s1,s2));
dpush(tag_fixnum(string_compare(s1,s2)));
}
bool string_eq(STRING* s1, STRING* s2)
@ -152,18 +151,17 @@ bool string_eq(STRING* s1, STRING* s2)
void primitive_string_eq(void)
{
STRING* s1 = untag_string(env.dt);
STRING* s1 = untag_string(dpop());
CELL with = dpop();
check_non_empty(with);
if(typep(STRING_TYPE,with))
env.dt = tag_boolean(string_eq(s1,(STRING*)UNTAG(with)));
dpush(tag_boolean(string_eq(s1,(STRING*)UNTAG(with))));
else
env.dt = F;
dpush(F);
}
void primitive_string_hashcode(void)
{
env.dt = tag_object(bignum(untag_string(env.dt)->hashcode));
drepl(tag_object(bignum(untag_string(dpeek())->hashcode)));
}
CELL index_of_ch(CELL index, STRING* string, CELL ch)
@ -216,11 +214,10 @@ outer: if(i <= limit)
/* index string substring -- index */
void primitive_index_of(void)
{
CELL ch = env.dt;
CELL ch = dpop();
STRING* string;
FIXNUM index;
CELL result;
check_non_empty(ch);
string = untag_string(dpop());
index = to_fixnum(dpop());
if(index < 0 || index > string->capacity)
@ -232,7 +229,7 @@ void primitive_index_of(void)
result = index_of_ch(index,string,to_fixnum(ch));
else
result = index_of_str(index,string,untag_string(ch));
env.dt = tag_fixnum(result);
dpush(tag_fixnum(result));
}
INLINE STRING* substring(CELL start, CELL end, STRING* string)
@ -257,8 +254,8 @@ INLINE STRING* substring(CELL start, CELL end, STRING* string)
/* start end string -- string */
void primitive_substring(void)
{
STRING* string = untag_string(env.dt);
STRING* string = untag_string(dpop());
CELL end = to_fixnum(dpop());
CELL start = to_fixnum(dpop());
env.dt = tag_object(substring(start,end,string));
dpush(tag_object(substring(start,end,string)));
}

11
native/types.c
View File

@ -101,7 +101,6 @@ CELL untagged_object_size(CELL pointer)
return align8(sizeof(WORD));
case F_TYPE:
case T_TYPE:
case EMPTY_TYPE:
size = CELLS * 2;
break;
case ARRAY_TYPE:
@ -122,8 +121,8 @@ CELL untagged_object_size(CELL pointer)
case FLOAT_TYPE:
size = sizeof(FLOAT);
break;
case HANDLE_TYPE:
size = sizeof(HANDLE);
case PORT_TYPE:
size = sizeof(PORT);
break;
default:
critical_error("Cannot determine size",relocating);
@ -136,12 +135,10 @@ CELL untagged_object_size(CELL pointer)
void primitive_type_of(void)
{
check_non_empty(env.dt);
env.dt = tag_fixnum(type_of(env.dt));
drepl(tag_fixnum(type_of(dpeek())));
}
void primitive_size_of(void)
{
check_non_empty(env.dt);
env.dt = tag_fixnum(object_size(env.dt));
drepl(tag_fixnum(object_size(dpeek())));
}

25
native/types.h
View File

@ -24,17 +24,13 @@ CELL F;
#define T_TYPE 7
CELL T;
/* Empty stack marker */
#define EMPTY_TYPE 8
CELL empty;
#define ARRAY_TYPE 9
#define VECTOR_TYPE 10
#define STRING_TYPE 11
#define SBUF_TYPE 12
#define HANDLE_TYPE 13
#define BIGNUM_TYPE 14
#define FLOAT_TYPE 15
#define ARRAY_TYPE 8
#define VECTOR_TYPE 9
#define STRING_TYPE 10
#define SBUF_TYPE 11
#define PORT_TYPE 12
#define BIGNUM_TYPE 13
#define FLOAT_TYPE 14
/* Pseudo-types. For error reporting only. */
#define INTEGER_TYPE 100 /* FIXNUM or BIGNUM */
@ -46,12 +42,6 @@ bool typep(CELL type, CELL tagged);
CELL type_of(CELL tagged);
void type_check(CELL type, CELL tagged);
INLINE void check_non_empty(CELL cell)
{
if(cell == empty)
general_error(ERROR_UNDERFLOW,F);
}
INLINE CELL tag_boolean(CELL untagged)
{
return (untagged == false ? F : T);
@ -59,7 +49,6 @@ INLINE CELL tag_boolean(CELL untagged)
INLINE bool untag_boolean(CELL tagged)
{
check_non_empty(tagged);
return (tagged == F ? false : true);
}

19
native/vector.c
View File

@ -10,40 +10,38 @@ VECTOR* vector(FIXNUM capacity)
void primitive_vectorp(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(typep(VECTOR_TYPE,env.dt));
drepl(tag_boolean(typep(VECTOR_TYPE,dpeek())));
}
void primitive_vector(void)
{
env.dt = tag_object(vector(to_fixnum(env.dt)));
drepl(tag_object(vector(to_fixnum(dpeek()))));
}
void primitive_vector_length(void)
{
env.dt = tag_fixnum(untag_vector(env.dt)->top);
drepl(tag_fixnum(untag_vector(dpeek())->top));
}
void primitive_set_vector_length(void)
{
VECTOR* vector = untag_vector(env.dt);
VECTOR* vector = untag_vector(dpop());
FIXNUM length = to_fixnum(dpop());
vector->top = length;
if(length < 0)
range_error(tag_object(vector),length,vector->top);
else if(length > vector->array->capacity)
vector->array = grow_array(vector->array,length,F);
env.dt = dpop(); /* don't forget this! */
}
void primitive_vector_nth(void)
{
VECTOR* vector = untag_vector(env.dt);
VECTOR* vector = untag_vector(dpop());
CELL index = to_fixnum(dpop());
if(index < 0 || index >= vector->top)
range_error(tag_object(vector),index,vector->top);
env.dt = array_nth(vector->array,index);
dpush(array_nth(vector->array,index));
}
void vector_ensure_capacity(VECTOR* vector, CELL index)
@ -58,10 +56,9 @@ void vector_ensure_capacity(VECTOR* vector, CELL index)
void primitive_set_vector_nth(void)
{
VECTOR* vector = untag_vector(env.dt);
VECTOR* vector = untag_vector(dpop());
FIXNUM index = to_fixnum(dpop());
CELL value = dpop();
check_non_empty(value);
if(index < 0)
range_error(tag_object(vector),index,vector->top);
@ -70,8 +67,6 @@ void primitive_set_vector_nth(void)
/* the following does not check bounds! */
set_array_nth(vector->array,index,value);
env.dt = dpop(); /* don't forget this! */
}
void fixup_vector(VECTOR* vector)

28
native/word.c
View File

@ -21,57 +21,51 @@ void update_xt(WORD* word)
void primitive_wordp(void)
{
check_non_empty(env.dt);
env.dt = tag_boolean(TAG(env.dt) == WORD_TYPE);
drepl(tag_boolean(typep(WORD_TYPE,dpeek())));
}
/* <word> ( primitive parameter plist -- word ) */
void primitive_word(void)
{
CELL plist = env.dt;
CELL plist = dpop();
FIXNUM primitive;
CELL parameter = dpop();
check_non_empty(plist);
check_non_empty(parameter);
primitive = to_fixnum(dpop());
env.dt = tag_word(word(primitive,parameter,plist));
dpush(tag_word(word(primitive,parameter,plist)));
}
void primitive_word_primitive(void)
{
env.dt = tag_fixnum(untag_word(env.dt)->primitive);
drepl(tag_fixnum(untag_word(dpeek())->primitive));
}
void primitive_set_word_primitive(void)
{
WORD* word = untag_word(env.dt);
WORD* word = untag_word(dpop());
word->primitive = to_fixnum(dpop());
update_xt(word);
env.dt = dpop();
}
void primitive_word_parameter(void)
{
env.dt = untag_word(env.dt)->parameter;
drepl(untag_word(dpeek())->parameter);
}
void primitive_set_word_parameter(void)
{
check_non_empty(dpeek());
untag_word(env.dt)->parameter = dpop();
env.dt = dpop();
WORD* word = untag_word(dpop());
word->parameter = dpop();
}
void primitive_word_plist(void)
{
env.dt = untag_word(env.dt)->plist;
drepl(untag_word(dpeek())->plist);
}
void primitive_set_word_plist(void)
{
check_non_empty(dpeek());
untag_word(env.dt)->plist = dpop();
env.dt = dpop();
WORD* word = untag_word(dpop());
word->plist = dpop();
}
void fixup_word(WORD* word)