Esempio n. 1
0
File: object.c Progetto: hsk/docs
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));
	}
}
Esempio n. 2
0
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));
	}
}
Esempio n. 3
0
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);
}
Esempio n. 4
0
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;
}
Esempio n. 5
0
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;
}
Esempio n. 6
0
File: object.c Progetto: hsk/docs
/* 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;
	}
}
Esempio n. 7
0
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);
}
Esempio n. 8
0
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;
}
Esempio n. 9
0
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];
}
Esempio n. 10
0
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;
}
Esempio n. 11
0
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);
}
Esempio n. 12
0
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;
}
Esempio n. 13
0
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);
}
Esempio n. 14
0
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;
}
Esempio n. 15
0
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);
}
Esempio n. 16
0
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;
}
Esempio n. 17
0
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 */
}
Esempio n. 18
0
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);
}
Esempio n. 19
0
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);
}
Esempio n. 20
0
//#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));
    }
}
Esempio n. 21
0
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;
}
Esempio n. 22
0
File: object.c Progetto: hsk/docs
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;
}
Esempio n. 23
0
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);
}
Esempio n. 24
0
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 */
}
Esempio n. 25
0
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 */
}
Esempio n. 26
0
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;
}
Esempio n. 27
0
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;
}
Esempio n. 28
0
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;
}
Esempio n. 29
0
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;
}
Esempio n. 30
0
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;
}