void repl() {
char line[100];
char *s;
printf("> ");
while(fgets(line, 100, stdin) != NULL) {
s = line;
if(VERBOSE)
printf("reading...\n"); fflush(stdout);
LispObject *r = read(&s);
if(VERBOSE) {
obj_print(r);
printf("\nevaluating...\n"); fflush(stdout);
}
LispObject *e = eval_sub(r);
if(VERBOSE)
printf("printing...\n"); fflush(stdout);
obj_print(e);
printf("\n");
fflush(stdout);
if(VERBOSE) {
printf("symbol table:\n");
print_symbol_table();
}
collect_garbage();
if(VERBOSE)
printf("amount of memory in in alloc table: %d\n",
memory_in_alloc_table());
printf("> ");
}
}
obj_ptr global_env(void)
{
static obj_ptr _global = 0;
if (!_global)
{
obj_ptr o;
_global = CONS(obj_alloc_map(), NIL);
gc_protect(_global);
_env_add_primitive(_global, "+", _add);
_env_add_primitive(_global, "*", _mul);
_env_add_primitive(_global, "-", _sub);
_env_add_primitive(_global, "/", _div);
_env_add_primitive1(_global, "floor", _floor);
_env_add_primitive1(_global, "++", _increment);
_env_add_primitive1(_global, "--", _decrement);
_env_add_primitive2(_global, "%", _mod);
_env_add_primitive(_global, "<", _lt);
_env_add_primitive(_global, "<=", _lte);
_env_add_primitive(_global, ">", _gt);
_env_add_primitive(_global, ">=", _gte);
_env_add_primitive(_global, "=", _e);
_env_add_primitive2(_global, "cons", _cons);
_env_add_primitive1(_global, "car", _car);
_env_add_primitive1(_global, "cdr", _cdr);
_env_add_primitive1(_global, "null?", _nullp);
_env_add_primitive0(_global, "gc", _gc);
_env_add_primitive1(_global, "load", _load);
_env_add_primitive0(_global, "quit", _quit);
_env_add_primitive(_global, "vec-alloc", _vec_alloc);
_env_add_primitive(_global, "vec-add", _vec_add);
_env_add_primitive1(_global, "vec-length", _vec_length);
_env_add_primitive1(_global, "vec-clear", _vec_clear);
_env_add_primitive2(_global, "vec-get", _vec_get);
_env_add_primitive3(_global, "vec-set", _vec_set);
_env_add_primitive0(_global, "map-alloc", _map_alloc);
_env_add_primitive3(_global, "map-add", _map_add);
_env_add_primitive1(_global, "map-clear", _map_clear);
_env_add_primitive1(_global, "map-size", _map_size);
_env_add_primitive(_global, "map-find", _map_find);
_env_add_primitive2(_global, "map-delete", _map_delete);
_env_add_primitive1(_global, "map-keys", _map_keys);
_env_add_primitive1(_global, "display", _display);
o = _load_imp("prelude.ang", _global);
if (ERRORP(o)) /* TODO */
{
port_ptr p = port_open_stdout();
obj_print(o, p);
port_close(p);
}
}
return _global;
}
object_t *lisp_print (object_t * lst)
{
DOC ("Print object or sexp in parse-able form.");
REQ (lst, 1, c_sym ("print"));
obj_print (CAR (lst), 1);
return NIL;
}
/*------------------------------------------------------------------------- * Function: ptr_print * * Purpose: Prints a pointer type. * * Return: void * * Programmer: Robb Matzke * [email protected] * Dec 6 1996 * * Modifications: * *------------------------------------------------------------------------- */ static void ptr_print (obj_t _self, out_t *f) { obj_ptr_t *self = MYCLASS(_self); out_puts (f, "*"); obj_print (self->sub, f); }
PmReturn_t
dict_print(pPmObj_t pdict)
{
PmReturn_t retval = PM_RET_OK;
int16_t index;
pSeglist_t keys,
vals;
pPmObj_t pobj1;
C_ASSERT(pdict != C_NULL);
/* if it's not a dict, raise TypeError */
if (OBJ_GET_TYPE(pdict) != OBJ_TYPE_DIC)
{
PM_RAISE(retval, PM_RET_EX_TYPE);
return retval;
}
plat_putByte('{');
keys = ((pPmDict_t)pdict)->d_keys;
vals = ((pPmDict_t)pdict)->d_vals;
/* if dict is empty, raise KeyError */
for (index = 0; index < ((pPmDict_t)pdict)->length; index++)
{
if (index != 0)
{
plat_putByte(',');
plat_putByte(' ');
}
retval = seglist_getItem(keys, index, &pobj1);
PM_RETURN_IF_ERROR(retval);
retval = obj_print(pobj1, C_FALSE, C_TRUE);
PM_RETURN_IF_ERROR(retval);
plat_putByte(':');
retval = seglist_getItem(vals, index, &pobj1);
PM_RETURN_IF_ERROR(retval);
retval = obj_print(pobj1, C_FALSE, C_TRUE);
PM_RETURN_IF_ERROR(retval);
}
return plat_putByte('}');
}
void vec_print (object_t * vo)
{
vector_t *v = OVAL (vo);
if (v->len == 0)
{
printf ("[]");
return;
}
printf ("[");
size_t i;
for (i = 0; i < v->len - 1; i++)
{
obj_print (v->v[i], 0);
printf (" ");
}
obj_print (v->v[v->len - 1], 0);
printf ("]");
}
/*------------------------------------------------------------------------- * Function: out_error * * Purpose: Prints an error message followed by an object. * * Return: void * * Programmer: Robb Matzke * [email protected] * Dec 11 1996 * * Modifications: * * Robb Matzke, 3 Feb 1997 * Changed prefix name from `error' to `***ERROR***' to make it * stand out more. * *------------------------------------------------------------------------- */ void out_error (const char *mesg, obj_t obj) { if (!ErrorDisable) { out_reset (OUT_STDERR); out_push (OUT_STDERR, "***ERROR***"); out_putw (OUT_STDERR, mesg); obj_print (obj, OUT_STDERR); out_pop (OUT_STDERR); out_nl (OUT_STDERR); } }
static obj_ptr _display(obj_ptr arg, obj_ptr env)
{
port_ptr p = port_open_stdout();
switch (TYPE(arg))
{
case TYPE_STRING:
port_write_string(p, &STRING(arg));
break;
case TYPE_SYMBOL:
port_write_cptr(p, SYMBOL(arg));
break;
default:
obj_print(arg, p);
}
port_close(p);
return NIL;
}
int main(int argc, char **argv) {
char *file_to_eval = NULL;
int replize = argc < 1;
for(int i = 1; i < argc; i++) {
if(!strcmp("-f", argv[i]))
file_to_eval = argv[++i];
else if(!strcmp("--verbose", argv[i]))
VERBOSE = true;
else if(!strcmp("-i", argv[i]))
replize = true;
}
init_alloc_system();
init_symboltable();
register_builtin_functions();
new_var(new_symbol("nil"), (LispObject*)nil);
new_var(new_symbol("t"), (LispObject*)new_symbol("t"));
nexception_points++;
if(setjmp(exception_points[nexception_points - 1]) == 0) {
eval_file("prelude.l");
if(file_to_eval)
eval_file(file_to_eval);
else
repl();
} else {
fprintf(stderr, "%s", error_string);
printf("Stack trace:\n");
for(int i = 0; i < call_stack->size; i++) {
printf(" ");
obj_print(vector_getitem(call_stack, i));
printf("\n");
}
while(scopes->size > 1)
pop_scope();
while(call_stack->size > 1)
vector_remove(call_stack, -1);
if(replize)
repl();
}
}
/* Use the core functions above to eval each sexp in a file. */
int load_file (FILE * fid, char *filename, int interactive)
{
if (fid == NULL)
{
fid = fopen (filename, "r");
if (fid == NULL)
return 0;
}
reader_t *r = reader_create (fid, NULL, filename, interactive);
while (!r->eof)
{
object_t *sexp = read_sexp (r);
if (sexp != err_symbol)
{
object_t *ret = top_eval (sexp);
if (r->interactive && ret != err_symbol)
obj_print (ret, 1);
obj_destroy (sexp);
obj_destroy (ret);
}
}
reader_destroy (r);
return 1;
}
/*
* Reclaims any object that doesn't have a current mark.
* Puts it in the free list. Coalesces all contiguous free chunks.
*/
static PmReturn_t
heap_gcSweep(void)
{
PmReturn_t retval;
pPmObj_t pobj;
pPmHeapDesc_t pchunk;
uint16_t totalchunksize;
uint16_t additionalheapsize;
/* Start at the base of the heap */
pobj = (pPmObj_t)pmHeap.base;
while ((uint8_t *)pobj < &pmHeap.base[HEAP_SIZE])
{
/* Skip to the next unmarked or free chunk within the heap */
while (!OBJ_GET_FREE(pobj)
&& (OBJ_GET_GCVAL(pobj) == pmHeap.gcval)
&& ((uint8_t *)pobj < &pmHeap.base[HEAP_SIZE]))
{
pobj = (pPmObj_t)((uint8_t *)pobj + OBJ_GET_SIZE(pobj));
/*printf("Object is at addr <%x>\n",(uint32_t)pobj);*/
#if 0
printf("pobj=");obj_print(pobj,0);printf("; type=%x; size=%x\n",OBJ_GET_TYPE(pobj),OBJ_GET_SIZE(pobj));
#endif
}
/* Stop if reached the end of the heap */
if ((uint8_t *)pobj >= &pmHeap.base[HEAP_SIZE])
{
break;
}
/* Accumulate the sizes of all consecutive unmarked or free chunks */
totalchunksize = 0;
additionalheapsize = 0;
/* Coalesce all contiguous free chunks */
pchunk = (pPmHeapDesc_t)pobj;
while (OBJ_GET_FREE(pchunk)
|| (!OBJ_GET_FREE(pchunk)
&& (OBJ_GET_GCVAL(pchunk) != pmHeap.gcval)))
{
totalchunksize += OBJ_GET_SIZE(pchunk);
/*
* If the chunk is already free, unlink it because its size
* is about to change
*/
if (OBJ_GET_FREE(pchunk))
{
retval = heap_unlinkFromFreelist(pchunk);
PM_RETURN_IF_ERROR(retval);
}
/* Otherwise free and reclaim the unmarked chunk */
else
{
OBJ_SET_TYPE(pchunk, 0);
OBJ_SET_FREE(pchunk, 1);
additionalheapsize += OBJ_GET_SIZE(pchunk);
}
C_DEBUG_PRINT(VERBOSITY_HIGH, "heap_gcSweep(), id=%p, s=%d\n",
pchunk, OBJ_GET_SIZE(pchunk));
#if 0
/* It's possible for 0-sized chunks to exist (which makes no sense) TODO:solve */
/* They result in infinite loops, so we must curtail them */
if (OBJ_GET_SIZE(pchunk) == 0)
{
break;
}
#endif
/* Proceed to the next chunk */
pchunk = (pPmHeapDesc_t)
((uint8_t *)pchunk + OBJ_GET_SIZE(pchunk));
/* Stop if it's past the end of the heap */
if ((uint8_t *)pchunk >= &pmHeap.base[HEAP_SIZE])
{
break;
}
}
/* Adjust the heap stats */
pmHeap.avail += additionalheapsize;
/* Set the heap descriptor data */
OBJ_SET_FREE(pobj, 1);
OBJ_SET_SIZE(pobj, totalchunksize);
#if 0
/* avoid loops by breaking on 0-size */
if (totalchunksize == 0)
{
break;
}
#endif
/* Insert chunk into free list */
retval = heap_linkToFreelist((pPmHeapDesc_t)pobj);
PM_RETURN_IF_ERROR(retval);
/* Continue to the next chunk */
pobj = (pPmObj_t)pchunk;
}
return PM_RET_OK;
}
