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

20
library/image.factor
View File

@ -85,14 +85,13 @@ USE: words
: f-type 6 ; : f-type 6 ;
: t-type 7 ; : t-type 7 ;
: empty-type 8 ; : array-type 8 ;
: array-type 9 ; : vector-type 9 ;
: vector-type 10 ; : string-type 10 ;
: string-type 11 ; : sbuf-type 11 ;
: sbuf-type 12 ; : handle-type 12 ;
: handle-type 13 ; : bignum-type 13 ;
: bignum-type 14 ; : float-type 14 ;
: float-type 15 ;
: immediate ( x tag -- tagged ) swap tag-bits shift< bitor ; : immediate ( x tag -- tagged ) swap tag-bits shift< bitor ;
: >header ( id -- tagged ) header-tag immediate ; : >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 ; : 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 ; : 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 ) ( 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 ) ( Words )

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

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

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

@ -79,4 +79,6 @@ USE: unparser
run-user-init 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) void primitive_numberp(void)
{ {
check_non_empty(env.dt); drepl(tag_boolean(numberp(dpeek())));
env.dt = tag_boolean(numberp(env.dt));
} }
bool zerop(CELL tagged) bool zerop(CELL tagged)
@ -101,7 +100,7 @@ CELL to_integer(CELL tagged)
void primitive_to_integer(void) void primitive_to_integer(void)
{ {
env.dt = to_integer(env.dt); drepl(to_integer(dpeek()));
} }
/* EQUALITY */ /* EQUALITY */

6
native/arithmetic.h
View File

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

5
native/bignum.c
View File

@ -2,8 +2,7 @@
void primitive_bignump(void) void primitive_bignump(void)
{ {
check_non_empty(env.dt); drepl(tag_boolean(typep(BIGNUM_TYPE,dpeek())));
env.dt = tag_boolean(typep(BIGNUM_TYPE,env.dt));
} }
BIGNUM* to_bignum(CELL tagged) BIGNUM* to_bignum(CELL tagged)
@ -31,7 +30,7 @@ BIGNUM* to_bignum(CELL tagged)
void primitive_to_bignum(void) 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) 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) void primitive_complexp(void)
{ {
check_non_empty(env.dt); drepl(tag_boolean(typep(COMPLEX_TYPE,dpeek())));
env.dt = tag_boolean(typep(COMPLEX_TYPE,env.dt));
} }
void primitive_real(void) void primitive_real(void)
{ {
switch(type_of(env.dt)) switch(type_of(dpeek()))
{ {
case FIXNUM_TYPE: case FIXNUM_TYPE:
case BIGNUM_TYPE: case BIGNUM_TYPE:
@ -33,29 +32,29 @@ void primitive_real(void)
/* No op */ /* No op */
break; break;
case COMPLEX_TYPE: case COMPLEX_TYPE:
env.dt = untag_complex(env.dt)->real; drepl(untag_complex(dpeek())->real);
break; break;
default: default:
type_error(COMPLEX_TYPE,env.dt); type_error(COMPLEX_TYPE,dpeek());
break; break;
} }
} }
void primitive_imaginary(void) void primitive_imaginary(void)
{ {
switch(type_of(env.dt)) switch(type_of(dpeek()))
{ {
case FIXNUM_TYPE: case FIXNUM_TYPE:
case BIGNUM_TYPE: case BIGNUM_TYPE:
case FLOAT_TYPE: case FLOAT_TYPE:
case RATIO_TYPE: case RATIO_TYPE:
env.dt = tag_fixnum(0); drepl(tag_fixnum(0));
break; break;
case COMPLEX_TYPE: case COMPLEX_TYPE:
env.dt = untag_complex(env.dt)->imaginary; drepl(untag_complex(dpeek())->imaginary);
break; break;
default: default:
type_error(COMPLEX_TYPE,env.dt); type_error(COMPLEX_TYPE,dpeek());
break; break;
} }
} }
@ -63,32 +62,29 @@ void primitive_imaginary(void)
void primitive_to_rect(void) void primitive_to_rect(void)
{ {
COMPLEX* c; COMPLEX* c;
switch(type_of(env.dt)) switch(type_of(dpeek()))
{ {
case FIXNUM_TYPE: case FIXNUM_TYPE:
case BIGNUM_TYPE: case BIGNUM_TYPE:
case FLOAT_TYPE: case FLOAT_TYPE:
case RATIO_TYPE: case RATIO_TYPE:
dpush(env.dt); dpush(tag_fixnum(0));
env.dt = tag_fixnum(0);
break; break;
case COMPLEX_TYPE: case COMPLEX_TYPE:
c = untag_complex(env.dt); c = untag_complex(dpeek());
env.dt = c->imaginary;
dpush(c->real); dpush(c->real);
dpush(c->imaginary);
break; break;
default: default:
type_error(COMPLEX_TYPE,env.dt); type_error(NUMBER_TYPE,dpeek());
break; break;
} }
} }
void primitive_from_rect(void) void primitive_from_rect(void)
{ {
CELL imaginary = env.dt; CELL imaginary = dpop();
CELL real = dpop(); CELL real = dpop();
check_non_empty(imaginary);
check_non_empty(real);
if(!realp(imaginary)) if(!realp(imaginary))
type_error(REAL_TYPE,imaginary); type_error(REAL_TYPE,imaginary);
@ -96,7 +92,7 @@ void primitive_from_rect(void)
if(!realp(real)) if(!realp(real))
type_error(REAL_TYPE,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) 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) void primitive_consp(void)
{ {
check_non_empty(env.dt); drepl(tag_boolean(typep(CONS_TYPE,dpeek())));
env.dt = tag_boolean(typep(CONS_TYPE,env.dt));
} }
void primitive_cons(void) void primitive_cons(void)
{ {
check_non_empty(env.dt); CELL cdr = dpop();
check_non_empty(dpeek()); CELL car = dpop();
env.dt = tag_cons(cons(dpop(),env.dt)); dpush(tag_cons(cons(car,cdr)));
} }
void primitive_car(void) void primitive_car(void)
{ {
env.dt = car(env.dt); drepl(car(dpeek()));
} }
void primitive_cdr(void) void primitive_cdr(void)
{ {
env.dt = cdr(env.dt); drepl(cdr(dpeek()));
} }
void primitive_set_car(void) void primitive_set_car(void)
{ {
check_non_empty(dpeek()); CELL cons = dpop();
untag_cons(env.dt)->car = dpop(); CELL car = dpop();
env.dt = dpop(); untag_cons(cons)->car = car;
} }
void primitive_set_cdr(void) void primitive_set_cdr(void)
{ {
check_non_empty(dpeek()); CELL cons = dpop();
untag_cons(env.dt)->cdr = dpop(); CELL cdr = dpop();
env.dt = dpop(); untag_cons(cons)->cdr = cdr;
} }

9
native/error.c
View File

@ -27,11 +27,16 @@ void throw_error(CELL error)
{ {
fix_stacks(); fix_stacks();
dpush(env.dt); dpush(error);
env.dt = error;
/* Execute the 'throw' word */ /* Execute the 'throw' word */
cpush(env.cf); cpush(env.cf);
env.cf = env.user[BREAK_ENV]; 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 */ /* Return to run() method */
longjmp(toplevel,1); 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_UNDEFINED_WORD (1<<3)
#define ERROR_TYPE (2<<3) #define ERROR_TYPE (2<<3)
#define ERROR_RANGE (3<<3) #define ERROR_RANGE (3<<3)
#define ERROR_UNDERFLOW (4<<3) #define ERROR_UNDERFLOW (4<<3)
#define ERROR_HANDLE_INCOMPAT (5<<3) #define ERROR_IO (5<<3)
#define ERROR_IO (6<<3) #define ERROR_OVERFLOW (6<<3)
#define ERROR_OVERFLOW (7<<3) #define ERROR_INCOMPARABLE (7<<3)
#define ERROR_INCOMPARABLE (8<<3) #define ERROR_FLOAT_FORMAT (8<<3)
#define ERROR_FLOAT_FORMAT (9<<3)
void fatal_error(char* msg, CELL tagged); void fatal_error(char* msg, CELL tagged);
void critical_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 "gc.h"
#include "types.h" #include "types.h"
#include "array.h" #include "array.h"
#include "handle.h"
#include "word.h" #include "word.h"
#include "run.h" #include "run.h"
#include "fixnum.h" #include "fixnum.h"
@ -52,14 +51,15 @@ typedef unsigned short CHAR;
#include "arithmetic.h" #include "arithmetic.h"
#include "misc.h" #include "misc.h"
#include "string.h" #include "string.h"
#include "port.h"
#include "fd.h" #include "fd.h"
#include "iomux.h"
#include "file.h" #include "file.h"
#include "socket.h"
#include "iomux.h"
#include "cons.h" #include "cons.h"
#include "image.h" #include "image.h"
#include "primitives.h" #include "primitives.h"
#include "vector.h" #include "vector.h"
#include "socket.h"
#include "stack.h" #include "stack.h"
#include "sbuf.h" #include "sbuf.h"
#include "relocate.h" #include "relocate.h"

130
native/fd.c
View File

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

10
native/fd.h
View File

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

4
native/file.c
View File

@ -2,7 +2,7 @@
void primitive_open_file(void) void primitive_open_file(void)
{ {
bool write = untag_boolean(env.dt); bool write = untag_boolean(dpop());
bool read = untag_boolean(dpop()); bool read = untag_boolean(dpop());
char* path = to_c_string(untag_string(dpop())); char* path = to_c_string(untag_string(dpop()));
int mode; int mode;
@ -21,5 +21,5 @@ void primitive_open_file(void)
if(fd < 0) if(fd < 0)
io_error(__FUNCTION__); 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) void primitive_fixnump(void)
{ {
check_non_empty(env.dt); drepl(tag_boolean(TAG(dpeek()) == FIXNUM_TYPE));
env.dt = tag_boolean(TAG(env.dt) == FIXNUM_TYPE);
} }
void primitive_not(void) void primitive_not(void)
{ {
type_check(FIXNUM_TYPE,env.dt); type_check(FIXNUM_TYPE,dpeek());
env.dt = RETAG(UNTAG(~env.dt),FIXNUM_TYPE); drepl(RETAG(UNTAG(~dpeek()),FIXNUM_TYPE));
} }
FIXNUM to_fixnum(CELL tagged) FIXNUM to_fixnum(CELL tagged)
@ -37,7 +36,7 @@ FIXNUM to_fixnum(CELL tagged)
void primitive_to_fixnum(void) 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) CELL number_eq_fixnum(CELL x, CELL y)

45
native/float.c
View File

@ -2,8 +2,7 @@
void primitive_floatp(void) void primitive_floatp(void)
{ {
check_non_empty(env.dt); drepl(tag_boolean(typep(FLOAT_TYPE,dpeek())));
env.dt = tag_boolean(typep(FLOAT_TYPE,env.dt));
} }
FLOAT* to_float(CELL tagged) FLOAT* to_float(CELL tagged)
@ -26,33 +25,33 @@ FLOAT* to_float(CELL tagged)
void primitive_to_float(void) 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) 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* c_str = to_c_string(str);
char* end = c_str; char* end = c_str;
double f = strtod(c_str,&end); double f = strtod(c_str,&end);
if(end != c_str + str->capacity) if(end != c_str + str->capacity)
general_error(ERROR_FLOAT_FORMAT,tag_object(str)); 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) void primitive_float_to_str(void)
{ {
char tmp[33]; char tmp[33];
snprintf(&tmp,32,"%.16g",to_float(env.dt)->n); snprintf(&tmp,32,"%.16g",to_float(dpeek())->n);
tmp[32] = '\0'; tmp[32] = '\0';
env.dt = tag_object(from_c_string(tmp)); drepl(tag_object(from_c_string(tmp)));
} }
void primitive_float_to_bits(void) void primitive_float_to_bits(void)
{ {
double f = untag_float(env.dt); double f = untag_float(dpeek());
BIGNUM_2 f_raw = *(BIGNUM_2*)&f; 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) CELL number_eq_float(CELL x, CELL y)
@ -117,64 +116,64 @@ CELL greatereq_float(CELL x, CELL y)
void primitive_facos(void) 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) 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) 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) void primitive_fatan2(void)
{ {
double x = to_float(env.dt)->n; double x = to_float(dpop())->n;
double y = 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) 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) 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) 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) 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) void primitive_fpow(void)
{ {
double x = to_float(env.dt)->n; double x = to_float(dpop())->n;
double y = 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) 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) 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) 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: case SBUF_TYPE:
collect_sbuf((SBUF*)scan); collect_sbuf((SBUF*)scan);
break; break;
case HANDLE_TYPE: case PORT_TYPE:
collect_handle((HANDLE*)scan); collect_port((PORT*)scan);
break; break;
} }
@ -118,14 +118,11 @@ void copy_roots(void)
CELL ptr; CELL ptr;
gc_debug("collect_roots",scan); gc_debug("collect_roots",scan);
/* these three must be the first in the heap */ /* these two must be the first in the heap */
copy_object(&empty);
gc_debug("empty",empty);
copy_object(&F); copy_object(&F);
gc_debug("f",F); gc_debug("f",F);
copy_object(&T); copy_object(&T);
gc_debug("t",T); gc_debug("t",T);
copy_object(&env.dt);
copy_object(&env.cf); copy_object(&env.cf);
copy_object(&env.boot); 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) void primitive_save_image(void)
{ {
STRING* filename = untag_string(env.dt); STRING* filename = untag_string(dpop());
env.dt = dpop();
save_image(to_c_string(filename)); 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) void primitive_room(void)
{ {
/* push: free total */ /* 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->here));
dpush(tag_fixnum(active->limit - active->base));
} }

18
native/misc.c
View File

@ -2,32 +2,29 @@
void primitive_exit(void) void primitive_exit(void)
{ {
exit(to_fixnum(env.dt)); exit(to_fixnum(dpop()));
} }
void primitive_os_env(void) 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); char* value = getenv(name);
if(value == NULL) if(value == NULL)
env.dt = F; drepl(F);
else else
env.dt = tag_object(from_c_string(getenv(name))); drepl(tag_object(from_c_string(getenv(name))));
} }
void primitive_eq(void) void primitive_eq(void)
{ {
check_non_empty(env.dt); dpush(tag_boolean(dpop() == dpop()));
check_non_empty(dpeek());
env.dt = tag_boolean(dpop() == env.dt);
} }
void primitive_millis(void) void primitive_millis(void)
{ {
struct timeval t; struct timeval t;
gettimeofday(&t,NULL); gettimeofday(&t,NULL);
dpush(env.dt); dpush(tag_object(bignum(t.tv_sec * 1000 + t.tv_usec/1000)));
env.dt = tag_object(bignum(t.tv_sec * 1000 + t.tv_usec/1000));
} }
void primitive_init_random(void) void primitive_init_random(void)
@ -43,6 +40,5 @@ void primitive_init_random(void)
void primitive_random_int(void) void primitive_random_int(void)
{ {
dpush(env.dt); dpush(tag_object(bignum(random())));
env.dt = 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_callstack,
primitive_set_datastack, primitive_set_datastack,
primitive_set_callstack, primitive_set_callstack,
primitive_handlep, primitive_portp,
primitive_exit, primitive_exit,
primitive_server_socket, primitive_server_socket,
primitive_close_fd, primitive_close_fd,

17
native/ratio.c
View File

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

12
native/relocate.c
View File

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

27
native/run.c
View File

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

8
native/run.h
View File

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

36
native/sbuf.c
View File

@ -10,40 +10,38 @@ SBUF* sbuf(FIXNUM capacity)
void primitive_sbufp(void) void primitive_sbufp(void)
{ {
check_non_empty(env.dt); drepl(tag_boolean(typep(SBUF_TYPE,dpeek())));
env.dt = tag_boolean(typep(SBUF_TYPE,env.dt));
} }
void primitive_sbuf(void) 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) 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) void primitive_set_sbuf_length(void)
{ {
SBUF* sbuf = untag_sbuf(env.dt); SBUF* sbuf = untag_sbuf(dpop());
FIXNUM length = to_fixnum(dpop()); FIXNUM length = to_fixnum(dpop());
sbuf->top = length; sbuf->top = length;
if(length < 0) if(length < 0)
range_error(env.dt,length,sbuf->top); range_error(tag_object(sbuf),length,sbuf->top);
else if(length > sbuf->string->capacity) else if(length > sbuf->string->capacity)
sbuf->string = grow_string(sbuf->string,length,F); sbuf->string = grow_string(sbuf->string,length,F);
env.dt = dpop(); /* don't forget this! */
} }
void primitive_sbuf_nth(void) void primitive_sbuf_nth(void)
{ {
SBUF* sbuf = untag_sbuf(env.dt); SBUF* sbuf = untag_sbuf(dpop());
CELL index = to_fixnum(dpop()); CELL index = to_fixnum(dpop());
if(index < 0 || index >= sbuf->top) if(index < 0 || index >= sbuf->top)
range_error(env.dt,index,sbuf->top); range_error(tag_object(sbuf),index,sbuf->top);
env.dt = string_nth(sbuf->string,index); dpush(string_nth(sbuf->string,index));
} }
void sbuf_ensure_capacity(SBUF* sbuf, int top) 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) void primitive_set_sbuf_nth(void)
{ {
SBUF* sbuf = untag_sbuf(env.dt); SBUF* sbuf = untag_sbuf(dpop());
FIXNUM index = to_fixnum(dpop()); FIXNUM index = to_fixnum(dpop());
CELL value = dpop(); CELL value = dpop();
check_non_empty(value);
set_sbuf_nth(sbuf,index,value); set_sbuf_nth(sbuf,index,value);
env.dt = dpop(); /* don't forget this! */
} }
void sbuf_append_string(SBUF* sbuf, STRING* string) 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) void primitive_sbuf_append(void)
{ {
SBUF* sbuf = untag_sbuf(env.dt); SBUF* sbuf = untag_sbuf(dpop());
CELL object = dpop(); CELL object = dpop();
check_non_empty(object);
env.dt = dpop();
switch(type_of(object)) switch(type_of(object))
{ {
case FIXNUM_TYPE: case FIXNUM_TYPE:
@ -118,7 +111,7 @@ STRING* sbuf_to_string(SBUF* sbuf)
void primitive_sbuf_to_string(void) 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) bool sbuf_eq(SBUF* s1, SBUF* s2)
@ -131,13 +124,12 @@ bool sbuf_eq(SBUF* s1, SBUF* s2)
void primitive_sbuf_eq(void) void primitive_sbuf_eq(void)
{ {
SBUF* s1 = untag_sbuf(env.dt); SBUF* s1 = untag_sbuf(dpop());
CELL with = dpop(); CELL with = dpop();
check_non_empty(with);
if(typep(SBUF_TYPE,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 else
env.dt = F; dpush(F);
} }
void fixup_sbuf(SBUF* sbuf) 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) void primitive_server_socket(void)
{ {
CHAR port = (CHAR)to_fixnum(env.dt); CHAR p = (CHAR)to_fixnum(dpop());
env.dt = handle(HANDLE_FD,make_server_socket(port)); dpush(port(make_server_socket(p)));
} }
int accept_connection(int sock) int accept_connection(int sock)
@ -61,6 +61,6 @@ int accept_connection(int sock)
void primitive_accept_fd(void) void primitive_accept_fd(void)
{ {
HANDLE* h = untag_handle(HANDLE_FD,env.dt); PORT* p = untag_port(dpop());
env.dt = handle(HANDLE_FD,accept_connection(h->object)); dpush(port(accept_connection(p->fd)));
} }

90
native/stack.c
View File

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

31
native/string.c
View File

@ -86,23 +86,22 @@ char* to_c_string(STRING* s)
void primitive_stringp(void) void primitive_stringp(void)
{ {
check_non_empty(env.dt); drepl(tag_boolean(typep(STRING_TYPE,dpeek())));
env.dt = tag_boolean(typep(STRING_TYPE,env.dt));
} }
void primitive_string_length(void) 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) void primitive_string_nth(void)
{ {
STRING* string = untag_string(env.dt); STRING* string = untag_string(dpop());
CELL index = to_fixnum(dpop()); CELL index = to_fixnum(dpop());
if(index < 0 || index >= string->capacity) if(index < 0 || index >= string->capacity)
range_error(tag_object(string),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) 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) void primitive_string_compare(void)
{ {
STRING* s2 = untag_string(env.dt); STRING* s2 = untag_string(dpop());
STRING* s1 = 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) bool string_eq(STRING* s1, STRING* s2)
@ -152,18 +151,17 @@ bool string_eq(STRING* s1, STRING* s2)
void primitive_string_eq(void) void primitive_string_eq(void)
{ {
STRING* s1 = untag_string(env.dt); STRING* s1 = untag_string(dpop());
CELL with = dpop(); CELL with = dpop();
check_non_empty(with);
if(typep(STRING_TYPE,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 else
env.dt = F; dpush(F);
} }
void primitive_string_hashcode(void) 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) CELL index_of_ch(CELL index, STRING* string, CELL ch)
@ -216,11 +214,10 @@ outer: if(i <= limit)
/* index string substring -- index */ /* index string substring -- index */
void primitive_index_of(void) void primitive_index_of(void)
{ {
CELL ch = env.dt; CELL ch = dpop();
STRING* string; STRING* string;
FIXNUM index; FIXNUM index;
CELL result; CELL result;
check_non_empty(ch);
string = untag_string(dpop()); string = untag_string(dpop());
index = to_fixnum(dpop()); index = to_fixnum(dpop());
if(index < 0 || index > string->capacity) if(index < 0 || index > string->capacity)
@ -232,7 +229,7 @@ void primitive_index_of(void)
result = index_of_ch(index,string,to_fixnum(ch)); result = index_of_ch(index,string,to_fixnum(ch));
else else
result = index_of_str(index,string,untag_string(ch)); 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) 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 */ /* start end string -- string */
void primitive_substring(void) void primitive_substring(void)
{ {
STRING* string = untag_string(env.dt); STRING* string = untag_string(dpop());
CELL end = to_fixnum(dpop()); CELL end = to_fixnum(dpop());
CELL start = 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)); return align8(sizeof(WORD));
case F_TYPE: case F_TYPE:
case T_TYPE: case T_TYPE:
case EMPTY_TYPE:
size = CELLS * 2; size = CELLS * 2;
break; break;
case ARRAY_TYPE: case ARRAY_TYPE:
@ -122,8 +121,8 @@ CELL untagged_object_size(CELL pointer)
case FLOAT_TYPE: case FLOAT_TYPE:
size = sizeof(FLOAT); size = sizeof(FLOAT);
break; break;
case HANDLE_TYPE: case PORT_TYPE:
size = sizeof(HANDLE); size = sizeof(PORT);
break; break;
default: default:
critical_error("Cannot determine size",relocating); critical_error("Cannot determine size",relocating);
@ -136,12 +135,10 @@ CELL untagged_object_size(CELL pointer)
void primitive_type_of(void) void primitive_type_of(void)
{ {
check_non_empty(env.dt); drepl(tag_fixnum(type_of(dpeek())));
env.dt = tag_fixnum(type_of(env.dt));
} }
void primitive_size_of(void) void primitive_size_of(void)
{ {
check_non_empty(env.dt); drepl(tag_fixnum(object_size(dpeek())));
env.dt = tag_fixnum(object_size(env.dt));
} }

25
native/types.h
View File

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

19
native/vector.c
View File

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

28
native/word.c
View File

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