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;
}
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);
}
}
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;
}
}
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;
}
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);
}
}
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;
}
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);
}
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;
}
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;
}
void io_write(object obj, object port)
{
lisp_print(obj, port_implementation(port));
fflush(port_implementation(port));
}
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;
}
}