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

Remove cons usage from runtime

slava 2006-05-15 04:03:55 +00:00
parent be16e301d6
commit fbfad83957
24 changed files with 143 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
library/compiler/generator/xt.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: assembler errors generic hashtables kernel
kernel-internals lists math namespaces prettyprint queues
USING: arrays assembler errors generic hashtables kernel
kernel-internals math namespaces prettyprint queues
sequences strings vectors words ;
: <label> ( -- label )
@ -57,7 +57,7 @@ SYMBOL: relocation-table
compiled-offset r> rel-absolute-cell = cell 4 ? - rel, ;
: rel-dlsym ( name dll class -- )
>r cons add-literal compiled-base - cell / r>
>r 2array add-literal compiled-base - cell / r>
1 rel-type, ;
: rel-address ( class -- )

6
library/io/files.factor
View File

@ -1,5 +1,5 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io
USING: hashtables kernel lists math memory namespaces sequences
strings styles ;
@ -11,7 +11,7 @@ strings styles ;
: exists? ( file -- ? ) stat >boolean ;
: directory? ( file -- ? ) stat car ;
: directory? ( file -- ? ) stat first ;
: directory ( dir -- list )
(directory)

58
library/tools/debugger.factor
View File

@ -1,42 +1,42 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! See http://factorcode.org/license.txt for BSD license.
IN: errors
USING: generic hashtables inspector io kernel kernel-internals
lists math namespaces parser prettyprint sequences
USING: arrays generic hashtables inspector io kernel
kernel-internals math namespaces parser prettyprint sequences
sequences-internals strings vectors words ;
SYMBOL: error
SYMBOL: error-continuation
: expired-error. ( obj -- )
"Object did not survive image save/load: " write . ;
"Object did not survive image save/load: " write third . ;
: undefined-word-error. ( obj -- )
"Undefined word: " write . ;
"Undefined word: " write third . ;
: io-error. ( error -- )
"I/O error: " write print ;
"I/O error: " write third print ;
: type-check-error. ( list -- )
"Type check error" print
uncons car dup "Object: " write short.
"Object type: " write class .
"Expected type: " write type>class . ;
"Object: " write dup fourth short.
"Object type: " write dup fourth class .
"Expected type: " write third type>class . ;
: float-format-error. ( list -- )
"Invalid floating point literal format: " write . ;
"Invalid floating point literal format: " write third . ;
: signal-error. ( obj -- )
"Operating system signal " write . ;
"Operating system signal " write third . ;
: negative-array-size-error. ( obj -- )
"Cannot allocate array with negative size " write . ;
"Cannot allocate array with negative size " write third . ;
: c-string-error. ( obj -- )
"Cannot convert to C string: " write . ;
"Cannot convert to C string: " write third . ;
: ffi-error. ( obj -- )
"FFI: " write print ;
"FFI: " write third print ;
: heap-scan-error. ( obj -- )
"Cannot do next-object outside begin/end-scan" print drop ;
@ -48,27 +48,21 @@ SYMBOL: error-continuation
: user-interrupt. ( obj -- )
"User interrupt" print drop ;
: datastack-underflow. ( obj -- )
"Data stack underflow" print drop ;
: stack-underflow. ( obj name -- )
write " stack underflow" print drop ;
: datastack-overflow. ( obj -- )
"Data stack overflow" print drop ;
: callstack-underflow. ( obj -- )
"Return stack underflow" print drop ;
: callstack-overflow. ( obj -- )
"Return stack overflow" print drop ;
: stack-overflow. ( obj name -- )
write " stack overflow" print drop ;
! Hook for library/cocoa/
DEFER: objc-error. ( alien -- )
PREDICATE: cons kernel-error ( obj -- ? )
dup first kernel-error = swap second 0 16 between? and ;
PREDICATE: array kernel-error ( obj -- ? )
dup first kernel-error eq? swap second 0 18 between? and ;
M: kernel-error error. ( error -- )
#! Kernel errors are indexed by integers.
cdr uncons car swap {
dup second {
[ expired-error. ]
[ io-error. ]
[ undefined-word-error. ]
@ -81,10 +75,12 @@ M: kernel-error error. ( error -- )
[ heap-scan-error. ]
[ undefined-symbol-error. ]
[ user-interrupt. ]
[ datastack-underflow. ]
[ datastack-overflow. ]
[ callstack-underflow. ]
[ callstack-overflow. ]
[ "Data" stack-underflow. ]
[ "Data" stack-overflow. ]
[ "Retain" stack-underflow. ]
[ "Retain" stack-overflow. ]
[ "Call" stack-underflow. ]
[ "Call" stack-overflow. ]
[ objc-error. ]
} dispatch ;

2
library/tools/memory.factor
View File

@ -24,7 +24,7 @@ sequences strings vectors words ;
room
0 swap [
"Generation " write over pprint ":" write
uncons (room.) 1+
first2 (room.) 1+
] each drop
"Semi-space: " write kb. terpri
"Cards: " write kb. terpri

2
native/alien.c
View File

@ -30,7 +30,7 @@ void *alien_offset(CELL object)
case ALIEN_TYPE:
alien = untag_alien_fast(object);
if(alien->expired)
general_error(ERROR_EXPIRED,object,true);
general_error(ERROR_EXPIRED,object,F,true);
return alien_offset(alien->alien) + alien->displacement;
case F_TYPE:
return NULL;

22
native/array.c
View File

@ -7,7 +7,7 @@ F_ARRAY *allot_array(CELL type, F_FIXNUM capacity)
F_ARRAY *array;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),true);
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
array = allot_object(type,array_size(capacity));
array->capacity = tag_fixnum(capacity);
@ -15,7 +15,7 @@ F_ARRAY *allot_array(CELL type, F_FIXNUM capacity)
}
/* make a new array with an initial element */
F_ARRAY* array(CELL type, F_FIXNUM capacity, CELL fill)
F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill)
{
int i;
F_ARRAY* array = allot_array(type, capacity);
@ -42,6 +42,24 @@ void primitive_array(void)
dpush(tag_object(array(ARRAY_TYPE,size,initial)));
}
CELL make_array_2(CELL v1, CELL v2)
{
F_ARRAY *a = array(ARRAY_TYPE,2,F);
put(AREF(a,0),v1);
put(AREF(a,1),v2);
return tag_object(a);
}
CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
{
F_ARRAY *a = array(ARRAY_TYPE,4,F);
put(AREF(a,0),v1);
put(AREF(a,1),v2);
put(AREF(a,2),v3);
put(AREF(a,3),v4);
return tag_object(a);
}
/* push a new tuple on the stack */
void primitive_tuple(void)
{

5
native/array.h
View File

@ -29,11 +29,14 @@ F_ARRAY *allot_array(CELL type, F_FIXNUM capacity);
F_ARRAY *array(CELL type, F_FIXNUM capacity, CELL fill);
F_ARRAY *byte_array(F_FIXNUM size);
CELL make_array_2(CELL v1, CELL v2);
CELL make_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
void primitive_array(void);
void primitive_tuple(void);
void primitive_byte_array(void);
F_ARRAY* resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
F_ARRAY *resize_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
void primitive_resize_array(void);
void primitive_array_to_tuple(void);
void primitive_tuple_to_array(void);

2
native/debug.c
View File

@ -261,7 +261,7 @@ void factorbug(void)
fprintf(stderr,"%lx\n",(CELL)CARD_TO_ADDR(card));
}
else if(strcmp(cmd,"t") == 0)
general_error(ERROR_USER_INTERRUPT,F,true);
general_error(ERROR_USER_INTERRUPT,F,F,true);
else if(strcmp(cmd,"q") == 0)
return;
else if(strcmp(cmd,"x") == 0)

2
native/dll.c
View File

@ -32,7 +32,7 @@ void primitive_dlsym(void)
{
d = untag_dll(dll);
if(d->dll == NULL)
general_error(ERROR_EXPIRED,dll,true);
general_error(ERROR_EXPIRED,dll,F,true);
}
dpush(tag_cell((CELL)ffi_dlsym(d,sym,true)));

20
native/error.c
View File

@ -51,9 +51,9 @@ void primitive_die(void)
factorbug();
}
void general_error(CELL error, CELL tagged, bool keep_stacks)
void general_error(CELL error, CELL arg1, CELL arg2, bool keep_stacks)
{
CELL thrown = cons(userenv[ERROR_ENV],cons(error,cons(tagged,F)));
CELL thrown = make_array_4(userenv[ERROR_ENV],error,arg1,arg2);
throw_error(thrown,keep_stacks);
}
@ -61,22 +61,10 @@ void general_error(CELL error, CELL tagged, bool keep_stacks)
touch it */
void signal_error(int signal)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),false);
}
/* called from signal.c when a sigv tells us that we under/overflowed a page.
* The first bool is true if it was the return stack (otherwise it's the data
* stack) and the second bool is true if we overflowed it (otherwise we
* underflowed it) */
void signal_stack_error(bool is_return_stack, bool is_overflow)
{
CELL errors[] = { ERROR_DS_UNDERFLOW, ERROR_DS_OVERFLOW,
ERROR_CS_UNDERFLOW, ERROR_CS_OVERFLOW };
general_error(errors[is_return_stack * 2 + is_overflow],F,false);
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,false);
}
void type_error(CELL type, CELL tagged)
{
CELL c = cons(tag_fixnum(type),cons(tagged,F));
general_error(ERROR_TYPE,c,true);
general_error(ERROR_TYPE,tag_fixnum(type),tagged,true);
}

3
native/error.h
View File

@ -36,9 +36,8 @@ void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);
void throw_error(CELL error, bool keep_stacks);
void early_error(CELL error);
void general_error(CELL error, CELL tagged, bool keep_stacks);
void general_error(CELL error, CELL arg1, CELL arg2, bool keep_stacks);
void signal_error(int signal);
void signal_stack_error(bool is_return_stack, bool is_overflow);
void type_error(CELL type, CELL tagged);
void primitive_throw(void);
void primitive_die(void);

13
native/factor.c
View File

@ -64,7 +64,8 @@ int main(int argc, char** argv)
CELL aging_size = 4 * CELLS;
CELL code_size = CELLS;
CELL literal_size = 128;
CELL args;
F_ARRAY *args;
CELL arg_count;
CELL i;
bool image_given = true;
@ -107,13 +108,15 @@ int main(int argc, char** argv)
code_size * 1024 * 1024,
literal_size * 1024);
args = F;
while(--argc > (image_given ? 1 : 0))
arg_count = (image_given ? 2 : 1);
args = array(ARRAY_TYPE,argc,F);
while(arg_count < argc)
{
args = cons(tag_object(from_c_string(argv[argc])),args);
put(AREF(args,arg_count),tag_object(from_c_string(argv[arg_count])));
arg_count++;
}
userenv[ARGS_ENV] = args;
userenv[ARGS_ENV] = tag_object(args);
platform_run();

2
native/float.c
View File

@ -44,7 +44,7 @@ void primitive_str_to_float(void)
end = c_str;
f = strtod(c_str,&end);
if(end != c_str + string_capacity(str))
general_error(ERROR_FLOAT_FORMAT,tag_object(str),true);
general_error(ERROR_FLOAT_FORMAT,tag_object(str),F,true);
drepl(tag_float(f));
}

2
native/io.c
View File

@ -27,7 +27,7 @@ void init_c_io(void)
void io_error(void)
{
CELL error = tag_object(from_c_string(strerror(errno)));
general_error(ERROR_IO,error,true);
general_error(ERROR_IO,error,F,true);
}
void primitive_fopen(void)

2
native/macosx/run.m
View File

@ -23,7 +23,7 @@ NS_DURING
{
CELL e = error;
error = F;
general_error(ERROR_OBJECTIVE_C,e,true);
general_error(ERROR_OBJECTIVE_C,e,F,true);
}
run();

13
native/memory.c
View File

@ -154,20 +154,19 @@ void primitive_clone(void)
void primitive_room(void)
{
CELL list = F;
F_ARRAY *a = array(ARRAY_TYPE,gen_count,F);
int gen;
box_unsigned_cell(compiling.limit - compiling.here);
box_unsigned_cell(compiling.limit - compiling.base);
box_unsigned_cell(cards_end - cards);
box_unsigned_cell(prior.limit - prior.base);
for(gen = gen_count - 1; gen >= 0; gen--)
for(gen = 0; gen < gen_count; gen++)
{
ZONE *z = &generations[gen];
list = cons(cons(tag_cell(z->limit - z->here),
tag_cell(z->limit - z->base)),
list);
put(AREF(a,gen),make_array_2(tag_cell(z->limit - z->here),
tag_cell(z->limit - z->base)));
}
dpush(list);
dpush(tag_object(a));
}
void primitive_begin_scan(void)
@ -184,7 +183,7 @@ void primitive_next_object(void)
CELL size, type;
if(!heap_scan)
general_error(ERROR_HEAP_SCAN,F,true);
general_error(ERROR_HEAP_SCAN,F,F,true);
if(heap_scan_ptr >= tenured.here)
{

8
native/relocate.c
View File

@ -84,15 +84,15 @@ void relocate_data()
void undefined_symbol(void)
{
general_error(ERROR_UNDEFINED_SYMBOL,F,true);
general_error(ERROR_UNDEFINED_SYMBOL,F,F,true);
}
CELL get_rel_symbol(F_REL* rel)
{
CELL arg = REL_ARGUMENT(rel);
F_CONS* cons = untag_cons(get(compiling.base + arg * sizeof(CELL)));
F_STRING* symbol = untag_string(cons->car);
DLL* dll = (cons->cdr == F ? NULL : untag_dll(cons->cdr));
F_ARRAY *pair = untag_array(get(compiling.base + arg * sizeof(CELL)));
F_STRING *symbol = untag_string(AREF(pair,0));
DLL* dll = (AREF(pair,1) == F ? NULL : untag_dll(AREF(pair,1)));
CELL sym;
if(dll != NULL && !dll->dll)

2
native/run.c
View File

@ -84,7 +84,7 @@ void run_callback(CELL quot)
/* XT of deferred words */
void undefined(F_WORD* word)
{
general_error(ERROR_UNDEFINED_WORD,tag_object(word),true);
general_error(ERROR_UNDEFINED_WORD,tag_object(word),F,true);
}
/* XT of compound definitions */

2
native/sbuf.c
View File

@ -4,7 +4,7 @@ F_SBUF* sbuf(F_FIXNUM capacity)
{
F_SBUF* sbuf;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),true);
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
sbuf->top = tag_fixnum(0);
sbuf->string = tag_object(string(capacity,'\0'));

6
native/string.c
View File

@ -6,7 +6,7 @@ F_STRING* allot_string(F_FIXNUM capacity)
F_STRING* string;
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),true);
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_integer(capacity),F,true);
string = allot_object(STRING_TYPE,
sizeof(F_STRING) + (capacity + 1) * CHARS);
@ -133,7 +133,7 @@ F_ARRAY *string_to_alien(F_STRING *s, bool check)
{
u16 ch = string_nth(s,i);
if(ch == '\0' || ch > 255)
general_error(ERROR_C_STRING,tag_object(s),true);
general_error(ERROR_C_STRING,tag_object(s),F,true);
}
}
@ -200,7 +200,7 @@ u16 *unbox_utf16_string(void)
for(i = 0; i < length; i++)
{
if(unboxed[i] == 0)
general_error(ERROR_C_STRING,obj,true);
general_error(ERROR_C_STRING,obj,F,true);
}
return unboxed;

6
native/unix/ffi.c
View File

@ -16,7 +16,7 @@ void ffi_dlopen(DLL *dll, bool error)
if(error)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())),true);
from_c_string(dlerror())),F,true);
}
else
dll->dll = NULL;
@ -36,7 +36,7 @@ void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error)
if(error)
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())),true);
from_c_string(dlerror())),F,true);
}
return NULL;
@ -49,7 +49,7 @@ void ffi_dlclose(DLL *dll)
if(dlclose(dll->dll))
{
general_error(ERROR_FFI,tag_object(
from_c_string(dlerror())),true);
from_c_string(dlerror())),F,true);
}
dll->dll = NULL;
}

32
native/unix/file.c
View File

@ -16,25 +16,21 @@ void primitive_stat(void)
CELL mode = tag_fixnum(sb.st_mode & ~S_IFMT);
CELL size = tag_bignum(s48_long_long_to_bignum(sb.st_size));
CELL mtime = tag_integer(sb.st_mtime);
dpush(cons(
dirp,
cons(
mode,
cons(
size,
cons(
mtime,F)))));
dpush(make_array_4(dirp,mode,size,mtime));
}
}
void primitive_read_dir(void)
{
F_STRING* path;
F_STRING *path;
DIR* dir;
CELL result = F;
F_ARRAY *result;
CELL result_count = 0;
maybe_gc(0);
result = array(ARRAY_TYPE,100,F);
path = untag_string(dpop());
dir = opendir(to_c_string(path,true));
if(dir != NULL)
@ -43,15 +39,23 @@ void primitive_read_dir(void)
while((file = readdir(dir)) != NULL)
{
CELL name = tag_object(from_c_string(
file->d_name));
result = cons(name,result);
CELL name = tag_object(from_c_string(file->d_name));
if(result_count == array_capacity(result))
{
result = resize_array(result,
result_count * 2,F);
}
put(AREF(result,result_count),name);
result_count++;
}
closedir(dir);
}
dpush(result);
result = resize_array(result,result_count,F);
dpush(tag_object(result));
}
void primitive_cwd(void)

12
native/unix/signal.c
View File

@ -19,13 +19,17 @@ static bool in_page(void *fault, void *i_area, CELL area_size, int offset)
void signal_handler(int signal, siginfo_t* siginfo, void* uap)
{
if(in_page(siginfo->si_addr, (void *) ds_bot, 0, -1))
signal_stack_error(false, false);
general_error(ERROR_DS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) ds_bot, ds_size, 0))
signal_stack_error(false, true);
general_error(ERROR_DS_OVERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) rs_bot, 0, -1))
general_error(ERROR_RS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) cs_bot, 0, -1))
signal_stack_error(true, false);
general_error(ERROR_CS_UNDERFLOW,F,F,false);
else if(in_page(siginfo->si_addr, (void *) cs_bot, cs_size, 0))
signal_stack_error(true, true);
general_error(ERROR_CS_OVERFLOW,F,F,false);
else
signal_error(signal);
}

30
native/windows/file.c
View File

@ -19,11 +19,7 @@ void primitive_stat(void)
(s64)st.nFileSizeLow | (s64)st.nFileSizeHigh << 32));
CELL mtime = tag_integer((int)
((*(s64*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000));
dpush(
cons(dirp,
cons(tag_fixnum(0),
cons(size,
cons(mtime, F)))));
dpush(make_array_4(dirp,tag_fixnum(0),size,mtime));
}
}
@ -32,23 +28,37 @@ void primitive_read_dir(void)
F_STRING *path;
HANDLE dir;
WIN32_FIND_DATA find_data;
CELL result = F;
F_ARRAY *result;
CELL result_count = 0;
maybe_gc(0);
result = array(ARRAY_TYPE,100,F);
path = untag_string(dpop());
if (INVALID_HANDLE_VALUE != (dir = FindFirstFile(".\\*", &find_data)))
{
do
do
{
CELL name = tag_object(from_c_string(find_data.cFileName));
result = cons(name, result);
CELL name = tag_object(from_c_string(
find_data.cFileName));
if(result_count == array_capacity(result))
{
result = resize_array(result,
result_count * 2,F);
}
put(AREF(result,result_count),name);
result_count++;
}
while (FindNextFile(dir, &find_data));
CloseHandle(dir);
}
dpush(result);
result = resize_array(result,result_count,F);
dpush(tag_object(result));
}
void primitive_cwd(void)