tort_mtable* tort_mtable_create_class(const char *name, tort_v parent)
{
tort_v sym = tort_symbol_new(name);
tort_v mt = tort_send(tort__s(get), tort_(m_mtable), sym);
if ( mt == tort_nil ) {
mt = tort_mtable_new_class(parent && parent != tort_nil ? parent : tort__mt(object));
tort_send(tort__s(set), tort_(m_mtable), sym, mt);
}
return mt;
}
tort_v _tort_m_initializer__lisp(tort_tp tort_v init)
{
tort_v _mt_cons = tort_mtable_create_class("cons", tort_mt(pair)); // FIXME: tort_mtable_create_class().
tort_mtable_create_class("list", 0); // FIXME: tort_mtable_create_class().
/* Dependency. */
tort_send(tort_s(load), tort_mt(dynlib), tort_string_new_cstr("libtortext"));
/* Reused methods. */
tort_add_method(tort__mt(fixnum), "lisp_write", _tort_m_fixnum___inspect);
tort_add_method(tort__mt(string), "lisp_write", _tort_m_string___inspect);
tort_add_method(tort__mt(method), "lisp_write", _tort_m_method___inspect);
tort_add_method(tort__mt(message), "lisp_write", _tort_m_message___inspect);
tort_add_method(tort__mt(nil), "lisp_write", _tort_m_nil___inspect);
tort_add_method(_mt_cons, "value", _tort_m_cons__car);
tort_add_method(_mt_cons, "lisp_write", _tort_m_list__lisp_write);
tort_add_method(_mt_cons, "_inspect", _tort_m_list__lisp_write);
tort_add_method(tort__mt(nil), "lisp_write", _tort_m_list__lisp_write);
tort_add_method(_mt_cons, "size", _tort_m_list__size);
tort_add_method(tort__mt(nil), "size", _tort_m_list__size);
tort_add_method(_mt_cons, "list->vector", _tort_m_list__list_TO_vector);
tort_add_method(tort__mt(nil), "list->vector", _tort_m_list__list_TO_vector);
tort_send(tort_s(set), tort_(_printf_dispatch), tort_c('O'), tort_s(printf_lisp_write));
return _mt_cons;
}
int main(int argc, char **argv, char **environ)
{
tort_v io;
tort_v s, p, v;
tort_v st;
extern tort_v _tort_m_initializer__dynlib(tort_tp tort_v init);
tort_runtime_create();
st = tort_send(tort_s(get), tort_(root), tort_s(dl_maps));
st = tort_send(tort_s(get), st, tort_s(all));
assert(st);
io = tort_stdout;
s = tort_s(_tort_m_initializer__dynlib);
p = tort_ptr_new(&_tort_m_initializer__dynlib);
tort_printf(io, " (size _symtab) => %T\n", tort_send(tort__s(size), st));
v = tort_send(tort__s(get), st, s);
if ( v != tort_nil ) {
assert(tort_ptr_data(v) == tort_ptr_data(p));
v = tort_send(tort__s(get), st, p);
assert(v == s);
}
printf("\nDONE\n");
return 0;
}
tort_v _tort_m_dynlib__dlopen(tort_tp struct tort_dynlib *rcvr, tort_v name)
{
char file_buffer[1024];
const char *file;
void *dl;
const char *base_sym;
void *base_ptr;
rcvr->name = name;
file = tort_string_data(name);
if ( ! (dl = tort_dlopen(file, file_buffer)) ) {
const char *str = dlerror();
str = str ? str : "UNKNOWN ERROR";
rcvr->error = tort_string_new_cstr(str);
perror(str);
return rcvr;
}
file = file_buffer;
rcvr->path = tort_string_new_cstr(file);
rcvr->base_sym = rcvr->base_ptr = tort_nil;
tort_send(tort__s(emptyE), rcvr);
tort_send(tort__s(_load_symtab), rcvr, file, 0);
if ( ! tort_map_size(rcvr) )
return rcvr;
base_sym = tort_symbol_data(tort_map_data(rcvr)[0]->first);
rcvr->base_sym = tort_string_new_cstr(base_sym);
base_ptr = tort_ptr_data(tort_map_data(rcvr)[0]->second);
rcvr->base_ptr = tort_ptr_new(base_ptr);
if ( _tort_dl_debug ) {
fprintf(stderr, " base_sym = '%s'\n", base_sym);
fprintf(stderr, " base_ptr = %p\n", base_ptr);
}
base_ptr = dlsym(dl, base_sym);
if ( _tort_dl_debug )
fprintf(stderr, " dlsym(@%p, \"%s\") => @%p\n", dl, base_sym, base_ptr);
{
Dl_info info;
bzero(&info, sizeof(info));
dladdr((void*) base_ptr, &info);
if ( _tort_dl_debug > 1 ) {
fprintf(stderr, " dli_fname = %s\n", info.dli_fname);
fprintf(stderr, " dli_fbase = %p\n", info.dli_fbase);
fprintf(stderr, " dli_sname = %s\n", info.dli_sname);
fprintf(stderr, " dli_saddr = %p\n", info.dli_saddr);
}
base_ptr = info.dli_fbase;
}
tort_dlclose(dl);
tort_send(tort__s(emptyE), rcvr);
tort_send(tort__s(_load_symtab), rcvr, file, base_ptr);
tort_send(tort__s(set), tort_(dl_maps), tort_string_new_cstr(file), rcvr);
return rcvr;
}
tort_v _tort_m_mtable__initialize(tort_tp tort_mtable *mt, tort_v delegate)
{
_tort_m_map__initialize(tort_ta (tort_v) mt);
if ( 0 && tort_(_initialized) ) {
mt->_map.equality = tort__s(eqQ);
mt->_map.hash = tort__s(eqQ_hash);
}
mt->delegate = delegate;
mt->instance_size = 0;
mt->slots = 0;
mt->gc_data = 0;
mt->gc_mark_method = 0;
mt->gc_free_method = 0;
mt->data = 0;
return mt;
}
tort_v _tort_m_object___printfv(tort_tp tort_io *io, const char *format, const char *fe, va_list *vapp)
{
#define vap (*vapp)
const char *b = format, *e;
while ( b < fe ) {
size_t size;
e = b;
while ( e < fe && *e != '%' )
++ e;
if ( (size = e - b) )
tort_send(tort__s(__write), io, b, size);
b = e;
if ( b >= fe ) break;
if ( *b == '%' ) {
int l = 0, done = 0, c;
char fmt[16], *fp = fmt;
*(fp ++) = *(b ++);
#define FMT (*fp = 0, fmt)
do {
if ( fp >= fmt + sizeof(fmt) ) abort();
if ( ! (b < fe) ) break;
fp[1] = 0;
switch ( (c = (*(fp ++) = *(b ++))) ) {
case 0:
abort();
break;
case '-':
case '0' ... '9':
break;
case 'l':
++ l;
break;
case 'c':
case 'd':
case 'i':
case 'u':
case 'o':
case 'x':
case 'X':
switch ( l ) {
case 0:
fprintf(FP, FMT, va_arg(vap, int));
break;
case 1:
fprintf(FP, FMT, va_arg(vap, long));
break;
case 2:
fprintf(FP, FMT, va_arg(vap, long long));
break;
default:
abort();
break;
}
done = 1;
break;
case 'g':
case 'G':
case 'f':
case 'F':
case 'a':
case 'A':
switch ( l ) {
case 0:
fprintf(FP, FMT, va_arg(vap, double));
break;
case 1:
fprintf(FP, FMT, va_arg(vap, long double));
break;
default:
abort();
break;
}
done = 1;
break;
case 'p':
fprintf(FP, FMT, va_arg(vap, void*));
done = 1;
break;
case 's':
case 'b':
fprintf(FP, FMT, va_arg(vap, char*));
done = 1;
break;
case 'T':
tort_send(tort__s(_inspect), va_arg(vap, tort_v), io);
done = 1;
break;
default:
{
tort_v sym = tort_send(tort__s(get), tort_(_printf_dispatch), tort_c(c));
if ( sym != tort_nil ) {
tort_send(sym, io, va_arg(vap, tort_v));
done = 1;
} else {
return tort_error(tort_ta "invalid format char '%c' in \"%s\"", c, format);
}
}
break;
}
} while ( ! done );
}
}
tort_v _tort_m_initializer__mtable(tort_tp tort_v init)
{
tort_mtable *obj_mt, *cls_mt;
/* Create mtable method table. */
obj_mt = tort_mtable_new_0(0);
cls_mt = tort_h_mtable(obj_mt);
tort_h(cls_mt)->mtable = obj_mt;
tort_h(obj_mt)->mtable = obj_mt;
tort__mt(mtable) = obj_mt;
/* Create object method table. */
// obj_mt = tort_mtable_new_class(0);
// cls_mt = tort_h_mtable(obj_mt);
// cls_mt->delegate = obj_mt;
obj_mt = tort_mtable_new_0(0);
tort__mt(object) = obj_mt;
/*************************************************/
/* Create core method tables. */
tort__mt(vector_base) = tort_mtable_new_class(tort__mt(object));
tort__mt(pair) = tort_mtable_new_class(tort__mt(object));
tort__mt(vector) = tort_mtable_new_class(tort__mt(vector_base));
tort__mt(map) = tort_mtable_new_class(tort__mt(vector));
_tort_m_mtable__delegateSET(tort_ta tort__mt(mtable), tort__mt(map));
// tort_mtable_set_class_delegate(tort__mt(mtable), tort__mt(map)); // ???
/* Initialize nil object header. */
tort__mt(nil) = tort_mtable_new_class(tort__mt(object));
tort_(nil_header).mtable = tort__mt(nil);
tort_(nil_header).applyf = _tort_m_object___cannot_apply;
/* Initialize tagged object headers. */
tort__mt(tagged) = tort_mtable_new_class(tort__mt(object));
{
int i;
for ( i = 0; i < 1 << TORT_TAG_BITS; ++ i ) {
tort_(tagged_header[i]).mtable = tort_mtable_new_class(tort__mt(tagged));
tort_(tagged_header[i]).applyf = _tort_m_object___cannot_apply;
}
}
#ifdef tort_tag_fixnum
tort__mt(fixnum) = tort_(tagged_header[tort_tag_fixnum]).mtable;
#endif
#ifdef tort_tag_locative
tort__mt(locative) = tort_(tagged_header[tort_tag_locative]).mtable;
tort_(tagged_header[tort_tag_locative]).applyf = (void*) _tort_m_locative___applyf;
#endif
/* Other core. */
tort__mt(word) = tort_mtable_new_class(tort__mt(object));
tort__mt(ptr) = tort_mtable_new_class(tort__mt(word));
tort__mt(u8vector) = tort_mtable_new_class(tort__mt(vector_base));
tort__mt(string) = tort_mtable_new_class(tort__mt(u8vector));
tort__mt(symbol) = tort_mtable_new_class(tort__mt(object));
tort__mt(symbol_encoder) = tort_mtable_new_class(tort__mt(object));
tort__mt(method) = tort_mtable_new_class(tort__mt(object));
tort__mt(slot) = tort_mtable_new_class(tort__mt(object));
tort__mt(slot)->instance_size = sizeof(tort_slot);
tort__mt(value) = tort_mtable_new_class(tort__mt(method));
tort__mt(message) = tort_mtable_new_class(tort__mt(object));
tort__mt(message)->instance_size = sizeof(tort_message);
tort__mt(caller_info) = tort_mtable_new_class(tort__mt(object));
tort__mt(caller_info)->instance_size = sizeof(tort_caller_info);
tort__mt(boolean) = tort_mtable_new_class(tort__mt(object));
tort__mt(initializer) = tort_mtable_new_class(tort__mt(map));
tort__mt(initializer)->instance_size = sizeof(tort_map);
/* io */
tort__mt(io) = tort_mtable_new_class(tort__mt(object));
tort__mt(eos) = tort_mtable_new_class(tort__mt(object));
/* dynlib */
tort__mt(dynlib) = tort_mtable_new_class(tort__mt(map));
/* gc */
tort__mt(gc) = tort_mtable_new_class(tort__mt(object));
/* force references for extensions. */
(void) tort__mt(block);
return init;
}
tort_mtable* tort_mtable_get(const char *name)
{
tort_v sym = tort_symbol_new(name);
tort_v mt = _tort_m_map__get(tort_ta tort_(m_mtable), sym);
return mt;
}
tort_v tort_runtime_create_ (int *argcp, char ***argvp, char ***envp)
{
tort_mtable *obj_mt, *cls_mt;
tort_v init_backlog[10]; int init_backlog_n = 0;
{
char *s;
if ( (s = getenv("TORT_INIT_DEBUG")) && *s )
_tort_init_debug = atoi(s);
}
assert(sizeof(tort_header) % sizeof(tort_v) == 0);
INIT(malloc);
/* Create runtime object. */
#if TORT_MULTIPLICITY
_tort = tort_ref(tort_runtime, tort_allocate(0, sizeof(tort_runtime)));
#endif
tort_(_initialized) = 0;
INIT(error);
/* Setup environment from main. */
tort_(_argc) = *argcp;
tort_(_argv) = *argvp;
tort_(_env) = *envp;
tort_(stack_bottom) = envp;
/* Allocate and initialize mtables */
INIT(mtable);
tort_h(_tort)->mtable = tort__mt(runtime);
tort_h(_tort)->applyf = _tort_m_object___cannot_apply;
#if ! TORT_NIL_IS_ZERO
/* Create the nil object. */
tort_nil = tort_allocate(tort__mt(nil), sizeof(tort_object));
#endif
/* Create the boolean objects. */
tort_true = tort_allocate(tort__mt(boolean), sizeof(tort_object));
#if ! TORT_FALSE_IS_NIL
tort_false = tort_allocate(tort__mt(boolean), sizeof(tort_object));
#endif
/* Backpatch object delegate as nil. */
tort_ref(tort_mtable, tort__mt(object))->delegate = tort_nil;
/* Initialize the message reference. */
_tort_message = tort_nil;
tort_(message) = tort_nil;
/* Initialize lookup(). */
INIT(lookup);
/*******************************************************/
/* Messaging Boot strap. */
/* Create the symbol table. */
tort_(symbols) = tort_map_new();
obj_mt = tort__mt(mtable);
cls_mt = tort_h_mtable(obj_mt);
tort__s(lookup) = tort_symbol_new("lookup");
tort_add_method(cls_mt, "lookup", _tort_m_mtable__lookup);
tort__s(add_method) = tort_symbol_new("add_method");
tort_add_method(cls_mt, "add_method", _tort_m_mtable__add_method);
tort__s(allocate) = tort_symbol_new("allocate");
tort_send(tort__s(add_method), cls_mt, tort__s(allocate), tort_method_new(_tort_M_object__allocate, 0));
/******************************************************/
/* Create the core symbols. */
INIT(symbol);
/* Create the mtable map. */
tort_(m_mtable) = tort_map_new();
#define tort_d_mt(X) \
if ( tort__mt(X) ) _tort_m_map__set(tort_ta tort_(m_mtable), tort_symbol_new(#X), tort__mt(X));
#include "tort/d_mt.h"
/* Install core methods. */
INIT(method);
/* Start initializer. */
tort_(initializer) = tort_send(tort__s(new), tort__mt(initializer));
while ( init_backlog_n > 0 )
tort_send(tort__s(set), tort_(initializer), init_backlog[-- init_backlog_n], tort__s(initialized));
INIT(eq);
INIT(cmp);
/* Add core slots. */
INIT(slot);
/* Create the root table. */
tort_(root) = tort_map_new();
/* Symbol Encoder. */
INIT(symbol_encoder);
/* Uncloneable objects. */
tort_add_method(tort__mt(symbol), "clone", _tort_m_object__identity);
tort_add_method(tort__mt(nil), "clone", _tort_m_object__identity);
tort_add_method(tort__mt(ptr), "clone", _tort_m_object__identity);
tort_add_method(tort__mt(tagged), "clone", _tort_m_object__identity);
tort_add_method(tort__mt(boolean), "clone", _tort_m_object__identity);
/* Initialize system method table. */
tort_h(_tort)->mtable = tort_mtable_new_class(tort__mt(object));
/* Subsystem initialization. */
INIT(gc);
/* unknown caller_info */
tort_(unknown_caller_info) = tort_send(tort__s(_allocate), tort__mt(caller_info), tort_i(sizeof(tort_caller_info)));
tort_(unknown_caller_info)->file = "<unknown>";
/* Setup the root namespace. */
#define ROOT(N,V) tort_send(tort__s(set), tort_(root), tort_symbol_new(#N), (V))
ROOT(runtime, tort_ref_box(_tort));
ROOT(initializer, tort_(initializer));
ROOT(nil, tort_nil);
ROOT(true, tort_true);
ROOT(false, tort_false);
ROOT(symbols, tort_(symbols));
ROOT(mtable, tort_(m_mtable));
ROOT(unknown_caller_info, tort_(unknown_caller_info));
ROOT(tag_bits, tort_i(TORT_TAG_BITS));
ROOT(word_size, tort_i(sizeof(tort_v)));
ROOT(object_header_size, tort_i(sizeof(tort_header)));
INIT(io);
INIT(printf);
INIT(debug);
INIT(dynlib);
{
int i; tort_v m = tort_map_new();
for ( i = 0; i < 1 << TORT_TAG_BITS; ++ i ) {
tort_v k = tort_i(i), v = tort_(tagged_header)[i].mtable;
if ( ! v ) v = tort_nil;
tort_send(tort__s(set), m, k, v);
tort_send(tort__s(set), m, v, k);
}
ROOT(tagged_mtables, m);
}
{
int i; tort_v v = tort_vector_new(0, 0);
for ( i = 0; i < tort_(_argc) && tort_(_argv)[i]; ++ i ) {
tort_send(tort__s(add), v, tort_string_new_cstr(tort_(_argv)[i]));
}
ROOT(argv, v);
}
INIT(gc_ready);
tort_(_initialized) = tort_true;
// fprintf(stderr, "\ntort: initialized\n");
#undef ROOT
#undef INIT
return tort_ref_box(_tort);
}
void smal_collect_before_inner(void *top_of_stack)
{
smal_thread *thr = smal_thread_self();
thr->top_of_stack = top_of_stack;
thr->bottom_of_stack = tort_(stack_bottom);
}
