void *
sml_obj_dup(void *obj)
{
void **slot, *newobj;
size_t obj_size;
switch (OBJ_TYPE(obj)) {
case OBJTYPE_UNBOXED_ARRAY:
case OBJTYPE_BOXED_ARRAY:
case OBJTYPE_UNBOXED_VECTOR:
case OBJTYPE_BOXED_VECTOR:
obj_size = OBJ_SIZE(obj);
slot = sml_push_tmp_rootset(1);
*slot = obj;
newobj = sml_obj_alloc(OBJ_TYPE(obj), obj_size);
memcpy(newobj, *slot, obj_size);
sml_pop_tmp_rootset(slot);
return newobj;
case OBJTYPE_RECORD:
obj_size = OBJ_SIZE(obj);
slot = sml_push_tmp_rootset(1);
*slot = obj;
newobj = sml_record_alloc(obj_size);
memcpy(newobj, *slot,
obj_size + SIZEOF_BITMAP * OBJ_BITMAPS_LEN(obj_size));
sml_pop_tmp_rootset(slot);
return newobj;
default:
sml_fatal(0, "BUG: invalid object type : %d", OBJ_TYPE(obj));
}
}
void
sml_obj_enum_ptr(void *obj, void (*trace)(void **, void *), void *data)
{
unsigned int i;
unsigned int *bitmaps;
/*
DBG("%p: size=%lu, type=%08x",
obj, (unsigned long)OBJ_SIZE(obj), (unsigned int)OBJ_TYPE(obj));
*/
switch (OBJ_TYPE(obj)) {
case OBJTYPE_UNBOXED_ARRAY:
case OBJTYPE_UNBOXED_VECTOR:
case OBJTYPE_INTINF:
break;
case OBJTYPE_BOXED_ARRAY:
case OBJTYPE_BOXED_VECTOR:
for (i = 0; i < OBJ_SIZE(obj) / sizeof(void*); i++)
trace((void**)obj + i, data);
break;
case OBJTYPE_RECORD:
bitmaps = OBJ_BITMAP(obj);
for (i = 0; i < OBJ_SIZE(obj) / sizeof(void*); i++) {
if (BITMAP_BIT(bitmaps, i) != TAG_UNBOXED)
trace((void**)obj + i, data);
}
break;
default:
sml_fatal(0, "BUG: invalid object type : %d", OBJ_TYPE(obj));
}
}
int
prim_IntInf_cmp(sml_intinf_t *x, sml_intinf_t *y)
{
ASSERT(OBJ_TYPE(x) == OBJTYPE_INTINF);
ASSERT(OBJ_TYPE(y) == OBJTYPE_INTINF);
return sml_intinf_cmp(x, y);
}
static void print_list(struct lispobj *obj)
{
if(print_bracket) {
printf("(");
}
print_bracket = 0;
if(CAR(obj) != NULL && OBJ_TYPE(CAR(obj)) == CONS) {
printf("(");
}
print(CAR(obj));
if(CDR(obj) == NULL) {
printf(")");
print_bracket = 1;
return;
}
if(OBJ_TYPE(CDR(obj)) == CONS) {
printf(" ");
} else {
printf(" . ");
}
print_bracket = 0;
print(CDR(obj));
if(!print_bracket) {
printf(")");
}
print_bracket = 1;
return;
}
static struct lispobj* eval_cond(struct lispobj *exps, struct lispobj *env)
{
struct lispobj *ret = OBJ_FALSE;
if(exps != NULL) {
struct lispobj *cond;
cond = CAR(exps);
if(cond != NULL && OBJ_TYPE(cond) == CONS) {
struct lispobj *pred;
pred = eval(CAR(cond), env);
if(pred != NULL && OBJ_TYPE(pred) == ERROR) {
ret = pred;
} else {
if(pred) {
if(length(cond) == 1) {
ret = OBJ_TRUE;
} else {
ret = eval(CADR(cond), env);
}
} else {
ret = eval_cond(CDR(exps), env);
}
heap_release(pred);
}
} else {
ret = NEW_ERROR("Bad cond clause.\n");
}
}
return ret;
}
/* for debug */
static void
obj_dump__(int indent, void *obj)
{
unsigned int i;
unsigned int *bitmap;
void **field = obj;
char *buf;
if (obj == NULL) {
sml_debug("%*sNULL\n", indent, "");
return;
}
switch (OBJ_TYPE(obj)) {
case OBJTYPE_UNBOXED_ARRAY:
case OBJTYPE_UNBOXED_VECTOR:
sml_debug("%*s%p:%u:%s\n",
indent, "", obj, OBJ_SIZE(obj),
(OBJ_TYPE(obj) == OBJTYPE_UNBOXED_ARRAY)
? "UNBOXED_ARRAY" : "UNBOXED_VECTOR");
for (i = 0; i < OBJ_SIZE(obj) / sizeof(unsigned int); i++)
sml_debug("%*s0x%08x\n",
indent + 2, "", ((unsigned int *)field)[i]);
for (i = i * sizeof(unsigned int); i < OBJ_SIZE(obj); i++)
sml_debug("%*s0x%02x\n",
indent + 2, "", ((unsigned char*)field)[i]);
break;
case OBJTYPE_BOXED_ARRAY:
case OBJTYPE_BOXED_VECTOR:
sml_debug("%*s%p:%u:%s\n",
indent, "", obj, OBJ_SIZE(obj),
(OBJ_TYPE(obj) == OBJTYPE_BOXED_ARRAY)
? "BOXED_ARRAY" : "BOXED_VECTOR");
for (i = 0; i < OBJ_SIZE(obj) / sizeof(void*); i++)
obj_dump__(indent + 2, field[i]);
for (i = i * sizeof(void*); i < OBJ_SIZE(obj); i++)
sml_debug("%*s0x%02x\n",
indent + 2, "", ((char*)field)[i]);
break;
case OBJTYPE_RECORD:
sml_debug("%*s%p:%u:RECORD\n",
indent, "", obj, OBJ_SIZE(obj));
bitmap = OBJ_BITMAP(obj);
for (i = 0; i < OBJ_SIZE(obj) / sizeof(void*); i++) {
if (BITMAP_BIT(bitmap, i) != TAG_UNBOXED)
obj_dump__(indent + 2, field[i]);
else
sml_debug("%*s%p\n", indent + 2, "", field[i]);
}
break;
default:
sml_debug("%*s%p:%u:unknown type %u",
indent, "", obj, OBJ_SIZE(obj), OBJ_TYPE(obj));
break;
}
}
int
prim_String_size(const char *str)
{
/* used for not only CharVector but CharArray */
ASSERT(OBJ_TYPE(str) == OBJTYPE_UNBOXED_VECTOR
|| OBJ_TYPE(str) == OBJTYPE_UNBOXED_ARRAY);
return OBJ_STR_SIZE(str);
}
void
prim_String_update(char *str, int index, char ch)
{
/* used for not only CharVector but CharArray */
ASSERT(OBJ_TYPE(str) == OBJTYPE_UNBOXED_ARRAY
|| OBJ_TYPE(str) == OBJTYPE_UNBOXED_VECTOR);
ASSERT(index >= 0 && (size_t)index < OBJ_STR_SIZE(str));
str[index] = ch;
}
char
prim_String_sub(const char *str, int n)
{
/* used for not only CharVector but CharArray */
ASSERT(OBJ_TYPE(str) == OBJTYPE_UNBOXED_ARRAY
|| OBJ_TYPE(str) == OBJTYPE_UNBOXED_VECTOR);
ASSERT(n >= 0 && (size_t)n < OBJ_STR_SIZE(str));
return str[n];
}
sml_intinf_t *
prim_IntInf_andb(sml_intinf_t *x, sml_intinf_t *y)
{
sml_intinf_t xv, yv, *z;
ASSERT(OBJ_TYPE(x) == OBJTYPE_INTINF);
ASSERT(OBJ_TYPE(y) == OBJTYPE_INTINF);
xv = *x, yv = *y; /* rescue from garbage collector */
z = sml_intinf_new();
sml_intinf_and(z, &xv, &yv);
return z;
}
void
prim_String_copy(const char *src, int si, char *dst, int di, int len)
{
/* used for not only CharVector but CharArray */
ASSERT(OBJ_TYPE(src) == OBJTYPE_UNBOXED_ARRAY
|| OBJ_TYPE(src) == OBJTYPE_UNBOXED_VECTOR);
ASSERT(OBJ_TYPE(dst) == OBJTYPE_UNBOXED_ARRAY
|| OBJ_TYPE(dst) == OBJTYPE_UNBOXED_VECTOR);
ASSERT(len >= 0);
ASSERT(si >= 0 && (size_t)(si + len) <= OBJ_STR_SIZE(src));
ASSERT(di >= 0 && (size_t)(di + len) <= OBJ_STR_SIZE(dst));
memcpy(dst + di, src + si, len);
}
void *
prim_UnmanagedMemory_export(const char *str, unsigned int offset,
unsigned int size)
{
void *p;
ASSERT(OBJ_TYPE(str) == OBJTYPE_UNBOXED_VECTOR
|| OBJ_TYPE(str) == OBJTYPE_UNBOXED_ARRAY);
ASSERT(offset < OBJ_STR_SIZE(str) && size < OBJ_STR_SIZE(str) - offset);
p = xmalloc(size);
memcpy(p, str + offset, size);
return p;
}
int
prim_GenericOS_write(int fd, const char *buf,
unsigned int offset, unsigned int len)
{
ASSERT(OBJ_TYPE(buf) == OBJTYPE_UNBOXED_ARRAY
|| OBJ_TYPE(buf) == OBJTYPE_UNBOXED_VECTOR);
ASSERT(offset + len <= OBJ_SIZE(buf));
#ifdef HAVE_INTERACTIVE_MODE
if (interactive_mode && fd == 0)
return interact_prim_write(fd, buf, offset, len);
#endif /* HAVE_INTERACTIVE_MODE */
return write(fd, buf + offset, len);
}
struct lispobj *env_var_define(struct lispobj *var, struct lispobj *val, struct lispobj *env)
{
struct lispobj *frame, *pair, *cell, *lookup;
/* Checking on variable existence. */
lookup = env_var_lookup(var, env);
/* If variable exists return error. */
if(OBJ_TYPE(lookup) != ERROR) {
char error[64];
snprintf(error, 64, "Variable already exists: %s.\n", SYMBOL_VALUE(var));
return NEW_ERROR(error);
}
/* Remove not necessary object. */
heap_release(lookup);
/* Get top frame from environment. */
frame = ENV_FIRST(env);
/* Creating cell for new variable. */
cell = NEW_CONS(var, val);
/* Appending new cell into the frame. */
pair = NEW_CONS(cell, frame);
frame = heap_grab(pair);
/* Appending the frame into the environment. */
CAR(env) = frame;
return val;
}
struct lispobj *subr_apply(struct lispobj *args)
{
if(length(args) != 2)
return ERROR_ARGS;
struct lispobj *proc, *params;
proc = CAR(args);
params = CADR(args);
if((proc != NULL && OBJ_TYPE(proc) != CONS) ||
(params != NULL && OBJ_TYPE(params) != CONS)) {
return NEW_ERROR("Wrong arguments type.\n");
}
return apply(proc, params);
}
struct lispobj *subr_minus(struct lispobj *args)
{
if(length(args) == 0)
return ERROR_ARGS;
struct lispobj *num;
char num_value[30];
snprintf(num_value, 30, "%d", NUMBER_VALUE(CAR(args)));
num = NEW_NUMBER(num_value);
args = CDR(args);
if(args == NULL) {
NUMBER_VALUE(num) = 0 - NUMBER_VALUE(num);
} else {
while(args != NULL) {
if(CAR(args) != NULL && OBJ_TYPE(CAR(args)) == NUMBER) {
NUMBER_VALUE(num) -= NUMBER_VALUE(CAR(args));
args = CDR(args);
} else {
object_delete(num);
return NEW_ERROR("Argument is not a number.\n");
}
}
}
return num;
}
STRING
prim_GenericOS_readlink(const char *filename)
{
#if !defined(HAVE_CONFIG_H) || defined(HAVE_READLINK)
char buf[128], *p;
ssize_t n, len;
void *obj;
ASSERT(OBJ_TYPE(filename) == OBJTYPE_UNBOXED_VECTOR);
n = readlink(filename, buf, sizeof(buf));
if (n < 0)
return NULL;
if ((size_t)n < sizeof(buf))
return sml_str_new2(buf, n);
p = NULL;
for (len = sizeof(buf); n >= len; len *= 2) {
p = xrealloc(p, len);
n = readlink(filename, buf, len);
}
if (n < 0) {
free(p);
return NULL;
}
obj = sml_str_new2(buf, n);
free(p);
return obj;
#else
errno = EIO;
return NULL;
#endif /* HAVE_READLINK */
}
int
prim_IntInf_log2(sml_intinf_t *x)
{
sml_intinf_t xv;
ASSERT(OBJ_TYPE(x) == OBJTYPE_INTINF);
xv = *x; /* rescue from garbage collector */
return sml_intinf_log2(&xv);
}
STRING
prim_String_substring(const char *str, int beg, int len)
{
ASSERT(OBJ_TYPE(str) == OBJTYPE_UNBOXED_VECTOR);
ASSERT(beg >= 0 && len >= 0);
ASSERT((size_t)(beg + len) <= OBJ_STR_SIZE(str));
return sml_str_new2(&str[beg], len);
}
//#ifdef __DEBUG_HEAP__
void heap_debug_object(struct lispobj *obj)
{
if(obj == NULL) {
printf(" null pointer");
} else {
printf(" [%p ", obj);
if(OBJ_TYPE(obj) == SYMBOL) {
printf("(symbol %s) ", SYMBOL_VALUE(obj));
} else if(OBJ_TYPE(obj) == NUMBER) {
printf("(number %d) ", NUMBER_VALUE(obj));
} else if(OBJ_TYPE(obj) == STRING) {
printf("(string %s) ", STRING_VALUE(obj));
} else {
printf("(cons) ");
}
printf("%d] ", OBJ_REFS(obj));
}
}
struct lispobj *eval_let(struct lispobj *exps, struct lispobj *env)
{
struct lispobj *binds, *body, *vars, *vals, *lambda, *ret, *evals;
binds = CAR(exps);
body = CDR(exps);
if(length(binds) > 0) {
struct lispobj *tvars, *tvals;
vars = heap_grab(NEW_CONS(NULL, NULL));
vals = heap_grab(NEW_CONS(NULL, NULL));
tvars = vars; tvals = vals;
while(binds != NULL) {
struct lispobj *bind = CAR(binds);
if(length(bind) != 2) {
ret = NEW_ERROR("Bad binding in the let exp.\n");
goto exit;
}
CAR(tvars) = heap_grab(CAR(bind));
CAR(tvals) = heap_grab(CADR(bind));
CDR(tvars) = heap_grab(NEW_CONS(NULL, NULL));
CDR(tvals) = heap_grab(NEW_CONS(NULL, NULL));
tvars = CDR(tvars);
tvals = CDR(tvals);
binds = CDR(binds);
}
tvars = NULL;
tvals = NULL;
} else {
return NEW_ERROR("Empty bindgings in the let exp.\n");
}
lambda = heap_grab(env_proc_make(vars, body, env));
evals = heap_grab(env_val_list(vals, env));
if(evals != NULL && OBJ_TYPE(evals) == ERROR) {
ret = evals;
} else {
ret = apply(lambda, evals);
heap_release(evals);
}
heap_release(lambda);
exit:
heap_release(vals);
heap_release(vars);
return ret;
}
void *
sml_obj_alloc(unsigned int objtype, size_t payload_size)
{
void *obj;
ASSERT(((unsigned int)payload_size & OBJ_SIZE_MASK) == payload_size);
obj = sml_alloc(payload_size, sml_load_frame_pointer());
OBJ_HEADER(obj) = OBJ_HEADER_WORD(objtype, payload_size);
ASSERT(OBJ_SIZE(obj) == payload_size);
ASSERT(OBJ_TYPE(obj) == OBJTYPE_UNBOXED_VECTOR
|| OBJ_TYPE(obj) == OBJTYPE_BOXED_VECTOR
|| OBJ_TYPE(obj) == OBJTYPE_UNBOXED_ARRAY
|| OBJ_TYPE(obj) == OBJTYPE_BOXED_ARRAY);
ASSERT(OBJ_GC1(obj) == 0 && OBJ_GC2(obj) == 0);
return obj;
}
int
prim_GenericOS_open(const char *filename, const char *fmode)
{
const char *str;
int flags, subflags;
ASSERT(OBJ_TYPE(filename) == OBJTYPE_UNBOXED_VECTOR);
ASSERT(OBJ_TYPE(fmode) == OBJTYPE_UNBOXED_VECTOR);
str = fmode;
switch (*(str++)) {
case 'r':
flags = O_RDONLY, subflags = 0;
break;
case 'w':
flags = O_WRONLY, subflags = O_TRUNC | O_CREAT;
break;
case 'a':
flags = O_WRONLY, subflags = O_APPEND | O_CREAT;
break;
default:
errno = EINVAL;
return -1;
}
if (*str == 'b') {
#ifdef O_BINARY
subflags |= O_BINARY;
#endif
str++;
}
if (*str == '+') {
flags = O_RDWR;
str++;
}
#ifdef O_BINARY
if (*str == 'b')
subflags |= O_BINARY;
#endif
return open(filename, flags | subflags, 0777);
}
int
prim_GenericOS_mkdir(const char *dirname, /*mode_t*/ int mode)
{
ASSERT(OBJ_TYPE(dirname) == OBJTYPE_UNBOXED_VECTOR);
#ifdef MINGW32
return _mkdir(dirname);
#else
return mkdir(dirname, mode);
#endif /* MINGW32 */
}
int
prim_Timer_getTimes(int *ret)
{
#ifdef HAVE_TIMES
struct tms tms;
static long clocks_per_sec = 0;
clock_t clk;
ASSERT(OBJ_TYPE(ret) == OBJTYPE_UNBOXED_ARRAY);
ASSERT(OBJ_SIZE(ret) >= sizeof(int) * 6);
if (clocks_per_sec == 0)
clocks_per_sec = sysconf(_SC_CLK_TCK);
clk = times(&tms);
ret[0] = tms.tms_stime / clocks_per_sec;
ret[1] = (tms.tms_stime % clocks_per_sec) * 1000000 / clocks_per_sec;
ret[2] = tms.tms_utime / clocks_per_sec;
ret[3] = (tms.tms_utime % clocks_per_sec) * 1000000 / clocks_per_sec;
/* FIXME: do we put GC time still here? */
ret[4] = 0; /* GC seconds */
ret[5] = 0; /* GC microseconds */
return (clk == (clock_t)-1 ? -1 : 0);
#else
struct timeval tv;
int err;
ASSERT(OBJ_TYPE(ret) == OBJTYPE_UNBOXED_ARRAY);
ASSERT(OBJ_SIZE(ret) >= sizeof(int) * 6);
err = gettimeofday(&tv, NULL);
ret[0] = 0; /* sys seconds */
ret[1] = 0; /* sys microseconds */
ret[2] = tv.tv_sec;
ret[3] = tv.tv_usec;
/* FIXME: do we put GC time still here? */
ret[4] = 0; /* GC seconds */
ret[5] = 0; /* GC microseconds */
return err;
#endif /* HAVE_TIMES */
}
sml_intinf_t *
prim_IntInf_notb(sml_intinf_t *x)
{
sml_intinf_t xv, *z;
ASSERT(OBJ_TYPE(x) == OBJTYPE_INTINF);
xv = *x; /* rescue from garbage collector */
z = sml_intinf_new();
sml_intinf_com(z, &xv);
return z;
}
STRING
prim_IntInf_toString(sml_intinf_t *n)
{
char *buf, *ret;
ASSERT(OBJ_TYPE(n) == OBJTYPE_INTINF);
buf = sml_intinf_fmt(n, 10);
ret = sml_str_new(buf);
free(buf);
return ret;
}
struct lispobj *env_var_assign(struct lispobj *var, struct lispobj *val, struct lispobj *env)
{
struct lispobj *cell;
if(var == NULL || OBJ_TYPE(var) != SYMBOL) {
return NEW_ERROR("Variable name is not a symbol.\n");
}
/* Checking on variable existence. */
cell = env_var_lookup(var, env);
/* If variable not exists return error. */
if(OBJ_TYPE(cell) == ERROR) {
return cell;
}
/* Remove old value. */
heap_release(CDR(cell));
/* Assign new value. */
CDR(cell) = heap_grab(val);
return val;
}
int
prim_String_cmp(const char *str1, const char *str2)
{
int len1, len2, len, cmp;
ASSERT(OBJ_TYPE(str1) == OBJTYPE_UNBOXED_VECTOR);
ASSERT(OBJ_TYPE(str2) == OBJTYPE_UNBOXED_VECTOR);
len1 = OBJ_STR_SIZE(str1);
len2 = OBJ_STR_SIZE(str2);
len = len1 < len2 ? len1 : len2;
cmp = memcmp(str1, str2, len1);
if (cmp == 0) {
/* this is OK because both len1 and len2 are signed integer
* but never negative. */
return len1 - len2;
}
return cmp;
}
void *
sml_obj_alloc(unsigned int objtype, size_t payload_size)
{
void *obj;
assert(sml_saved());
assert(((unsigned int)payload_size & OBJ_SIZE_MASK) == payload_size);
obj = sml_alloc(payload_size);
OBJ_HEADER(obj) = OBJ_HEADER_WORD(objtype, payload_size);
assert(OBJ_SIZE(obj) == payload_size);
assert(OBJ_TYPE(obj) == OBJTYPE_UNBOXED_VECTOR
|| OBJ_TYPE(obj) == OBJTYPE_BOXED_VECTOR
|| OBJ_TYPE(obj) == OBJTYPE_UNBOXED_ARRAY
|| OBJ_TYPE(obj) == OBJTYPE_BOXED_ARRAY
|| OBJ_TYPE(obj) == OBJTYPE_INTINF);
return obj;
}