Ejemplo n.º 1
0
LISPTR lisp_print(LISPTR x, FILE* out)
{
	if (consp(x)) {
		fputwc('(', out);
		while (true) {
			lisp_print(car(x), out);
			x = cdr(x);
			if (!consp(x)) {
				if (x != NIL) {
					fputws(L" . ", out);
					lisp_print(x, out);
				}
				break;
			}
			fputwc(' ', out);
		}
		fputwc(')', out);
	} else if (symbolp(x)) {
		fputws(string_text(symbol_name(x)), out);
	} else if (numberp(x)) {
		fwprintf(out, L"%g", number_value(x));
	} else if (stringp(x)) {
		fputwc('"', out);
		fputws(string_text(x), out);
		fputwc('"', out);
	} else {
		fputws(L"*UNKOBJ*", out);
	}
	return x;
}
Ejemplo n.º 2
0
void lisp_REPL(FILE* in, FILE* out, FILE* err)
{
    while (true) {
        LISPTR m = lisp_read(in);
        // debugging - trace what we just read:
        fputs("lisp_read => ", out);
        lisp_print(m, out);
        fputs("\n", out);
        // NIL means end-of-job:
        if (m==NIL) break;
        LISPTR v = lisp_eval(m);
        fputs("lisp_eval => ", out);
        lisp_print(v, out);
        fputs("\n", out);
    }
}
Ejemplo n.º 3
0
Archivo: io.c Proyecto: cmatei/yalfs
void lisp_display(object exp, FILE *out)
{

	switch (type_of(exp)) {

	case T_STRING:
		fprintf(out, "%.*s", (int) string_length(exp), string_value(exp));
		break;

	case T_CHARACTER:
		fputc(character_value(exp), out);
		break;

	case T_PAIR:
		if (is_finite_list(exp, NULL)) {
			fprintf(out, "(");
			display_pair(exp, out);
			fprintf(out, ")");
		} else {
			fprintf(out, "#<unprintable-structure>");
		}
		break;

	default:
		lisp_print(exp, out);
		break;
	}
}
Ejemplo n.º 4
0
int main(int argc, char **argv)
{
  lisp_runtime rt;
  lisp_init(&rt);
  lisp_scope *scope = (lisp_scope*)lisp_new(&rt, type_scope);
  lisp_scope_populate_builtins(&rt, scope);

  while (true) {
    char *input = readline("> ");
    if (input == NULL) {
      break;
    }
    lisp_value *value = lisp_parse(&rt, input);
    add_history(input);
    free(input);
    lisp_value *result = lisp_eval(&rt, scope, value);
    lisp_print(stdout, result);
    fprintf(stdout, "\n");
    lisp_mark(&rt, (lisp_value*)scope);
    lisp_sweep(&rt);
  }

  lisp_destroy(&rt);
  return 0;
}
Ejemplo n.º 5
0
Archivo: io.c Proyecto: cmatei/yalfs
static void write_pair(object pair, FILE *out)
{
	object car_obj, cdr_obj;

	car_obj = car(pair);
	cdr_obj = cdr(pair);

	lisp_print(car_obj, out);

	if (is_pair(cdr_obj)) {
		fprintf(out, " ");
		write_pair(cdr_obj, out);
	}
	else if (is_null(cdr_obj)) {
		return;
	}
	else {
		fprintf(out, " . ");
		lisp_print(cdr_obj, out);
	}
}
Ejemplo n.º 6
0
int main(int argc,char *argv[])
  {
  FILE *f=fopen(argv[1],"r");

  // Parse XML file
  struct foo *b=(struct foo *)xml_parse(f,"root",&myschema,metafind(&myschema, "foo"),1);
  struct item *i;

  // Access values in foo
  printf("root->val = %d\n",b->val);
  printf("root->val_name = %s\n",b->val_name);
  printf("root->items->val = %d\n",b->items->val);
  printf("root->items->next->val = %d\n",b->items->next->val);
  printf("root->items->next->next->val = %d\n",b->items->next->next->val);

  // Print in various formats
  xml_print(stdout,"root",0,(struct base *)b);

  lisp_print(stdout,"root",0,(struct base *)b);

  lisp_print_untagged(stdout,"root",0,(struct base *)b);

  indent_print(stdout,"root",0,(struct base *)b);

  indent_print_untagged(stdout,"root",0,(struct base *)b);

  json_print(stdout,NULL,0,(struct base *)b,0);

  // Create a database within C
  b=mk(&myschema, "foo");
  b->val=10;
  b->val_name=strdup("Hello");

  // Build list
  i=b->items=mk(&myschema, "item");
  i->val=7;
  i=i->next=mk(&myschema, "item");
  i->val=8;
  i=i->next=mk(&myschema, "item");
  i->val=9;

  // Print it
  xml_print(stdout,"root",0,(struct base *)b);

  return 0;
  }
Ejemplo n.º 7
0
void symbol_table_stats()
{
	unsigned long i;
	unsigned long nel, total = 0;

	fprintf(stderr, "Symbol table: %lu buckets\n", symbol_table.nbuckets);

	for (i = 0; i < symbol_table.nbuckets; i++) {
		nel = length(symbol_table.buckets[i]);
		if (nel > 1) {
			fprintf(stderr, "    bucket %lu: %lu entries ", i, nel);
			lisp_print(symbol_table.buckets[i], stderr);
			fprintf(stderr, "\n");
		}

		total += nel;
	}

	fprintf(stderr, "Number of symbols: %lu\n", total);
}
Ejemplo n.º 8
0
static inline lisp_obj *trampoline(lisp_obj *obj, lisp_err *err)
{
    int i = 0;
    while (obj && obj->type == THUNK){
        lisp_expr *body = obj->value.l.declaration;
        lisp_env *env = obj->value.l.context;
        lisp_obj *res = eval_expression(body, env, err);
        
        if (enable_debug && i > 0){
            printf("Trampolined [%d] -> ", i);
            lisp_print(res);
            printf("\n");
        }

        release(obj);
        obj = res;
        i++;
    }

    if (enable_debug && i > 0){
        printf("=== End of trampoline\n");
    }
    return obj;
}
Ejemplo n.º 9
0
static lisp_obj *apply(lisp_expr_application *app, lisp_env *env, lisp_err *err)
{
    lisp_obj *callable = FORCE_VALUE(app->proc, env, err);
    if (! callable){
        return NULL;
    }

    lisp_obj *res = NIL;

    /* Internal procedure */
    if (callable->type == PROC){
        /* Eval args */
        lisp_obj **args = calloc(app->nparams, sizeof(lisp_obj*));
        for (size_t i=0; i<app->nparams; i++){
            lisp_obj *arg = FORCE_VALUE(app->params[i], env, err);
            if (! arg){
                for (size_t j=0; j<i; j++){
                    release(args[j]);
                }
                free(args);
                return NULL;
            }
            args[i] = arg;
        }

        /* Eval internal */
        res = callable->value.p(app->nparams, args);
        
        /* Free args */
        for (size_t i=0; i<app->nparams; i++){
            release(args[i]);
        }
        free(args);
    }

    /* Lisp func */
    else if (callable->type == LAMBDA){
        lisp_lambda *lambda = &(callable->value.l);
        lisp_expr_lambda *lambda_expr = &(lambda->declaration->value.mklambda);

        /* Check arity */
        if (app->nparams != lambda_expr->nparams){
            raise_error(err, WRONG_ARITY, "Arity error ! Expected %d params, got %d",
                lambda_expr->nparams, app->nparams);
            return NULL;
        }

        /* Extend env */
        lisp_env *locals = create_env(lambda->context);
        for (size_t i=0; i<lambda_expr->nparams; i++){
            lisp_obj *param = eval_expression(app->params[i], env, err);
            if (! param){
                release_env(locals);
                return NULL;
            }
            DEBUG("Extend env with %s", lambda_expr->param_names[i]);
            release(set_env(locals, lambda_expr->param_names[i], param));
        }

        if (enable_debug){
            printf("\033[1mCALL\033[0m ");
            dump_expr(lambda_expr->body);
            printf(" with env\n");
            dump_env(locals);
        }

        /* Wrap in thunk for trampoline */
        res = make_thunk(lambda_expr->body, locals);
        release_env(locals);
    }
    else {
        lisp_print(callable);
        raise_error(err, NOT_CALLABLE, "CANNOT CALL obj %p", callable);
        return NULL;
    }

    release(callable);
    return res;
}
Ejemplo n.º 10
0
Archivo: io.c Proyecto: cmatei/yalfs
void io_write(object obj, object port)
{
	lisp_print(obj, port_implementation(port));
	fflush(port_implementation(port));
}
Ejemplo n.º 11
0
Archivo: io.c Proyecto: cmatei/yalfs
void lisp_print(object exp, FILE *out)
{
	unsigned long i, len;
	char c;
	char *str;
	object *vptr;

	switch (type_of(exp)) {
	case T_NIL:
		fprintf(out, "()");
		break;

	case T_FIXNUM:
		fprintf(out, "%ld", fixnum_value(exp));
		break;

	case T_CHARACTER:
		c = character_value(exp);
		fprintf(out, "#\\");
		switch (c) {
		case '\n':
			fprintf(out, "newline");
			break;
		case ' ':
			fprintf(out, "space");
			break;
		default:
			fprintf(out, "%c", c);
		}
		break;

	case T_PAIR:
		if (is_finite_list(exp, NULL)) {
			fprintf(out, "(");
			write_pair(exp, out);
			fprintf(out, ")");
		} else {
			fprintf(out, "#<unprintable-structure>");
		}
		break;

	case T_BOOLEAN:
		fprintf(out, is_false(exp) ? "#f" : "#t");
		break;

	case T_STRING:
		fprintf(out, "\"");
		str = string_value(exp);
		len = string_length(exp);
		for (i = 0; i < len; i++) {
			switch (str[i]) {
			case '\n':
				fprintf(out, "\\n");
				break;
			case '"':
				fprintf(out, "\\\"");
				break;
			case '\\':
				fprintf(out, "\\\\");
				break;
			default:
				fprintf(out, "%c", str[i]);
			}
		}
		fprintf(out, "\"");
		break;

	case T_VECTOR:
		fprintf(out, "#(");
		len  = vector_length(exp);
		vptr = vector_ptr(exp);
		for (i = 0; i < len; i++) {
			if (i)
				fputc(' ', out);

			lisp_print(*vptr++, out);
		}
		fprintf(out, ")");
		break;


	case T_SYMBOL:
		fprintf(out, "%.*s", (int) string_length(symbol_string(exp)),
			string_value(symbol_string(exp)));
		break;

	case T_FOREIGN_PTR:
		fprintf(out, "#<foreign-pointer %p>", foreign_ptr_value(exp));
		break;

	case T_PRIMITIVE:
		fprintf(out, "#<primitive-procedure %p>", primitive_implementation(exp));
		break;

	case T_PROCEDURE:
		fprintf(out, "#<procedure ");
		lisp_print(procedure_parameters(exp), out);
		fprintf(out, ">");
		break;

	case T_EOF:
		fprintf(out, "#<eof>");
		break;

	case T_PORT:
		fprintf(out, "#<%s-port %p>",
			is_input_port(exp) ? "input" : "output",
			port_implementation(exp));
		break;

	case T_UNSPECIFIED:
		/* actually, I could read this back... */
		fprintf(out, "#<unspecified>");
		break;

	case T_MACRO:
		fprintf(out, "#<macro ");
		lisp_print(macro_parameters(exp), out);
		fprintf(out, ">");
		break;

	case T_MAX_TYPE:
		break;
	}
}