aria.c

00001 /**
00002  * Copyright (c) 2016 rxi
00003  *
00004  * This library is free software; you can redistribute it and/or modify it
00005  * under the terms of the MIT license. See LICENSE for details.
00006  */
00007 
00008 #include "aria.h"
00009 
00010 #define MAX_STACK 1024
00011 #define CHUNK_LEN 1024
00012 
00013 #define UNUSED(x) ((void) x)
00014 
00015 
00016 struct ar_Chunk {
00017   ar_Value values[CHUNK_LEN];
00018   struct ar_Chunk *next;
00019 };
00020 
00021 
00022 static void *zrealloc(ar_State *S, void *ptr, size_t n) {
00023   void *p = S->alloc(S->udata, ptr, n);
00024   if (!p) ar_error(S, S->oom_error);
00025   return p;
00026 }
00027 
00028 static void zfree(ar_State *S, void *ptr) {
00029   S->alloc(S, ptr, 0);
00030 }
00031 
00032 
00033 /*===========================================================================
00034  * Value
00035  *===========================================================================*/
00036 
00037 static void push_value_to_stack(ar_State *S, ar_Value *v) {
00038   /* Expand stack's capacity? */
00039   if (S->gc_stack_idx == S->gc_stack_cap) {
00040     int n = (S->gc_stack_cap << 1) | !S->gc_stack_cap;
00041     S->gc_stack = zrealloc(S, S->gc_stack, n * sizeof(*S->gc_stack));
00042     S->gc_stack_cap = n;
00043   }
00044   /* Push value */
00045   S->gc_stack[S->gc_stack_idx++] = v;
00046 }
00047 
00048 
00049 static ar_Value *new_value(ar_State *S, int type) {
00050   ar_Value *v;
00051   /* Run garbage collector? */
00052   S->gc_count--;
00053   if (!S->gc_pool && S->gc_count < 0) {
00054     ar_gc(S);
00055   }
00056   /* No values in pool? Create and init new chunk */
00057   if (!S->gc_pool) {
00058     int i;
00059     ar_Chunk *c = zrealloc(S, NULL, sizeof(*c));
00060     c->next = S->gc_chunks;
00061     S->gc_chunks = c;
00062     /* Init all chunk's values and link them together, set the currently-empty
00063      * pool to point to this new list */
00064     for (i = 0; i < CHUNK_LEN; i++) {
00065       c->values[i].type = AR_TNIL;
00066       c->values[i].u.pair.cdr = (c->values + i + 1);
00067     }
00068     c->values[CHUNK_LEN - 1].u.pair.cdr = NULL;
00069     S->gc_pool = c->values;
00070   }
00071   /* Get value from pool */
00072   v = S->gc_pool;
00073   S->gc_pool = v->u.pair.cdr;
00074   /* Init */
00075   v->type = type;
00076   v->mark = 0;
00077   push_value_to_stack(S, v);
00078   return v;
00079 }
00080 
00081 
00082 ar_Value *ar_new_env(ar_State *S, ar_Value *parent) {
00083   ar_Value *res = new_value(S, AR_TENV);
00084   res->u.env.parent = parent;
00085   res->u.env.map = NULL;
00086   return res;
00087 }
00088 
00089 
00090 ar_Value *ar_new_pair(ar_State *S, ar_Value *car, ar_Value *cdr) {
00091   ar_Value *res = new_value(S, AR_TPAIR);
00092   res->u.pair.car = car;
00093   res->u.pair.cdr = cdr;
00094   res->u.pair.dbg = NULL;
00095   return res;
00096 }
00097 
00098 
00099 ar_Value *ar_new_list(ar_State *S, size_t n, ...) {
00100   va_list args;
00101   ar_Value *res = NULL, **last = &res;
00102   va_start(args, n);
00103   while (n--) {
00104     last = ar_append_tail(S, last, va_arg(args, ar_Value*));
00105   }
00106   va_end(args);
00107   return res;
00108 }
00109 
00110 
00111 ar_Value *ar_new_number(ar_State *S, double n) {
00112   ar_Value *res = new_value(S, AR_TNUMBER);
00113   res->u.num.n = n;
00114   return res;
00115 }
00116 
00117 
00118 ar_Value *ar_new_udata(ar_State *S, void *ptr, ar_CFunc gc, ar_CFunc mark) {
00119   ar_Value *res = new_value(S, AR_TUDATA);
00120   res->u.udata.ptr = ptr;
00121   res->u.udata.gc = gc;
00122   res->u.udata.mark = mark;
00123   return res;
00124 }
00125 
00126 
00127 ar_Value *ar_new_stringl(ar_State *S, const char *str, size_t len) {
00128   ar_Value *v = new_value(S, AR_TSTRING);
00129   v->u.str.s = NULL;
00130   v->u.str.s = zrealloc(S, NULL, len + 1);
00131   v->u.str.s[len] = '\0';
00132   if (str) {
00133     memcpy(v->u.str.s, str, len);
00134   }
00135   v->u.str.len = len;
00136   return v;
00137 }
00138 
00139 
00140 ar_Value *ar_new_string(ar_State *S, const char *str) {
00141   if (str == NULL) return NULL;
00142   return ar_new_stringl(S, str, strlen(str));
00143 }
00144 
00145 
00146 ar_Value *ar_new_symbol(ar_State *S, const char *name) {
00147   ar_Value *v;
00148   /* Build hash of string */
00149   unsigned hash = 5381;
00150   const char *p = name;
00151   while (*p) hash = ((hash << 5) + hash) ^ *p++;
00152   /* Create and init symbol */
00153   v = ar_new_string(S, name);
00154   v->type = AR_TSYMBOL;
00155   v->u.str.hash = hash;
00156   return v;
00157 }
00158 
00159 
00160 ar_Value *ar_new_cfunc(ar_State *S, ar_CFunc fn) {
00161   ar_Value *v = new_value(S, AR_TCFUNC);
00162   v->u.cfunc.fn = fn;
00163   return v;
00164 }
00165 
00166 
00167 ar_Value *ar_new_prim(ar_State *S, ar_Prim fn) {
00168   ar_Value *v = new_value(S, AR_TPRIM);
00169   v->u.prim.fn = fn;
00170   return v;
00171 }
00172 
00173 
00174 int ar_type(ar_Value *v) {
00175   return v ? v->type : AR_TNIL;
00176 }
00177 
00178 
00179 const char *ar_type_str(int type) {
00180   switch (type) {
00181     case AR_TNIL    : return "nil";
00182     case AR_TPAIR   : return "pair";
00183     case AR_TNUMBER : return "number";
00184     case AR_TSTRING : return "string";
00185     case AR_TSYMBOL : return "symbol";
00186     case AR_TFUNC   : return "function";
00187     case AR_TMACRO  : return "macro";
00188     case AR_TPRIM   : return "primitive";
00189     case AR_TCFUNC  : return "cfunction";
00190     case AR_TENV    : return "env";
00191     case AR_TUDATA  : return "udata";
00192   }
00193   return "?";
00194 }
00195 
00196 
00197 ar_Value *ar_check(ar_State *S, ar_Value *v, int type) {
00198   if (ar_type(v) != type) {
00199     ar_error_str(S, "expected %s, got %s",
00200                  ar_type_str(type), ar_type_str(ar_type(v)));
00201   }
00202   return v;
00203 }
00204 
00205 
00206 ar_Value *ar_car(ar_Value *v) {
00207   return (ar_type(v) == AR_TPAIR) ? v->u.pair.car : v;
00208 }
00209 
00210 
00211 ar_Value *ar_cdr(ar_Value *v) {
00212   return (ar_type(v) == AR_TPAIR) ? v->u.pair.cdr : NULL;
00213 }
00214 
00215 
00216 ar_Value *ar_nth(ar_Value *v, int idx) {
00217   while (v) {
00218     if (idx-- == 0) return ar_car(v);
00219     v = ar_cdr(v);
00220   }
00221   return NULL;
00222 }
00223 
00224 
00225 ar_Value **ar_append_tail(ar_State *S, ar_Value **last, ar_Value *v) {
00226   *last = ar_new_pair(S, v, NULL);
00227   return &(*last)->u.pair.cdr;
00228 }
00229 
00230 
00231 static ar_Value *join_list_of_strings(ar_State *S, ar_Value *list) {
00232   ar_Value *res;
00233   /* Get combined length of strings */
00234   ar_Value *v = list;
00235   size_t len = 0;
00236   while (v) {
00237     len += v->u.pair.car->u.str.len;
00238     v = v->u.pair.cdr;
00239   }
00240   /* Join list of strings */
00241   res = ar_new_stringl(S, NULL, len);
00242   v = list;
00243   len = 0;
00244   while (v) {
00245     ar_Value *x = v->u.pair.car;
00246     memcpy(res->u.str.s + len, x->u.str.s, x->u.str.len);
00247     len += x->u.str.len;
00248     v = v->u.pair.cdr;
00249   }
00250   return res;
00251 }
00252 
00253 
00254 static int escape_char(int chr) {
00255   switch (chr) {
00256     case '\t' : return 't';
00257     case '\n' : return 'n';
00258     case '\r' : return 'r';
00259     case '\\' :
00260     case '"'  : return chr;
00261   }
00262   return 0;
00263 }
00264 
00265 
00266 ar_Value *ar_to_string_value(ar_State *S, ar_Value *v, int quotestr) {
00267   ar_Value *res, **last;
00268   char buf[128];
00269   char *p, *q;
00270   size_t len, sz;
00271   switch (ar_type(v)) {
00272     case AR_TNIL:
00273       return ar_new_string(S, "nil");
00274 
00275     case AR_TSYMBOL:
00276       return ar_new_string(S, v->u.str.s);
00277 
00278     case AR_TPAIR:
00279       /* Handle empty pair */
00280       if (!ar_car(v) && !ar_cdr(v)) {
00281         return ar_new_string(S, "()");
00282       }
00283       /* Build list of strings */
00284       res = NULL;
00285       last = ar_append_tail(S, &res, ar_new_string(S, "("));
00286       while (v) {
00287         if (v->type == AR_TPAIR) {
00288           last = ar_append_tail(S, last, ar_to_string_value(S, ar_car(v), 1));
00289           if (ar_cdr(v)) {
00290             last = ar_append_tail(S, last, ar_new_string(S, " "));
00291           }
00292         } else {
00293           last = ar_append_tail(S, last, ar_new_string(S, ". "));
00294           last = ar_append_tail(S, last, ar_to_string_value(S, v, 1));
00295         }
00296         v = ar_cdr(v);
00297       }
00298       last = ar_append_tail(S, last, ar_new_string(S, ")"));
00299       return join_list_of_strings(S, res);
00300 
00301     case AR_TNUMBER:
00302       sprintf(buf, "%.14g", v->u.num.n);
00303       return ar_new_string(S, buf);
00304 
00305     case AR_TSTRING:
00306       if (quotestr) {
00307         /* Get string length + escapes and quotes */
00308         len = 2;
00309         p = v->u.str.s;
00310         sz = v->u.str.len;
00311         while (sz--) {
00312           len += escape_char(*p++) ? 2 : 1;
00313         }
00314         /* Build quoted string */
00315         res = ar_new_stringl(S, NULL, len);
00316         p = v->u.str.s;
00317         sz = v->u.str.len;
00318         q = res->u.str.s;
00319         *q++ = '"';
00320         while (sz--) {
00321           if (escape_char(*p)) {
00322             *q++ = '\\';
00323             *q++ = escape_char(*p);
00324           } else {
00325             *q++ = *p;
00326           }
00327           p++;
00328         }
00329         *q = '"';
00330         return res;
00331       }
00332       return v;
00333 
00334     default:
00335       sprintf(buf, "[%s %p]", ar_type_str(ar_type(v)), (void*) v);
00336       return ar_new_string(S, buf);
00337   }
00338 }
00339 
00340 
00341 const char *ar_to_stringl(ar_State *S, ar_Value *v, size_t *len) {
00342   v = ar_to_string_value(S, v, 0);
00343   if (len) *len = v->u.str.len;
00344   return v->u.str.s;
00345 }
00346 
00347 
00348 const char *ar_to_string(ar_State *S, ar_Value *v) {
00349   return ar_to_stringl(S, v, NULL);
00350 }
00351 
00352 
00353 void *ar_to_udata(ar_State *S, ar_Value *v) {
00354   UNUSED(S);
00355   return (ar_type(v) == AR_TUDATA) ? v->u.udata.ptr : NULL;
00356 }
00357 
00358 
00359 double ar_to_number(ar_State *S, ar_Value *v) {
00360   UNUSED(S);
00361   switch (ar_type(v)) {
00362     case AR_TNUMBER : return v->u.num.n;
00363     case AR_TSTRING : return strtod(v->u.str.s, NULL);
00364   }
00365   return 0;
00366 }
00367 
00368 
00369 #define OPT_FUNC(NAME, CTYPE, TYPE, FIELD)          \
00370   CTYPE NAME(ar_State *S, ar_Value *v, CTYPE def) { \
00371     if (!v) return def;                             \
00372     return ar_check(S, v, TYPE)->FIELD;             \
00373   }
00374 
00375 OPT_FUNC( ar_opt_string,  const char*,  AR_TSTRING, u.str.s     )
00376 OPT_FUNC( ar_opt_udata,   void*,        AR_TUDATA,  u.udata.ptr )
00377 OPT_FUNC( ar_opt_number,  double,       AR_TNUMBER, u.num.n     )
00378 
00379 
00380 static int is_equal(ar_Value *v1, ar_Value *v2) {
00381   int v1type, v2type;
00382   if (v1 == v2) return 1;
00383   v1type = ar_type(v1);
00384   v2type = ar_type(v2);
00385   if (v1type != v2type) return 0;
00386   switch (v1type) {
00387     case AR_TNUMBER : return v1->u.num.n == v2->u.num.n;
00388     case AR_TSYMBOL :
00389     case AR_TSTRING : return (v1->u.str.len == v2->u.str.len) &&
00390                              !memcmp(v1->u.str.s, v2->u.str.s, v1->u.str.len);
00391   }
00392   return 0;
00393 }
00394 
00395 
00396 static ar_Value *debug_location(ar_State *S, ar_Value *v) {
00397   if (ar_type(v) != AR_TPAIR || !v->u.pair.dbg) {
00398     return ar_new_string(S, "?");
00399   }
00400   return join_list_of_strings(S, ar_new_list(S, 3,
00401     v->u.pair.dbg->u.dbg.name,
00402     ar_new_string(S, ":"),
00403     ar_to_string_value(S, ar_new_number(S, v->u.pair.dbg->u.dbg.line), 0)));
00404 }
00405 
00406 
00407 /*===========================================================================
00408  * Garbage collector
00409  *===========================================================================*/
00410 
00411 static void gc_free(ar_State *S, ar_Value *v) {
00412   /* Deinit value */
00413   switch (v->type) {
00414     case AR_TSYMBOL:
00415     case AR_TSTRING:
00416       zfree(S, v->u.str.s);
00417       break;
00418     case AR_TUDATA:
00419       if (v->u.udata.gc) v->u.udata.gc(S, v);
00420       break;
00421   }
00422   /* Set type to nil (ignored by GC) and add to dead values pool */
00423   v->type = AR_TNIL;
00424   v->u.pair.cdr = S->gc_pool;
00425   S->gc_pool = v;
00426 }
00427 
00428 
00429 static void gc_deinit(ar_State *S) {
00430   int i;
00431   ar_Chunk *c, *next;
00432   /* Free all values in all chunks and free the chunks themselves */
00433   c = S->gc_chunks;
00434   while (c) {
00435     next = c->next;
00436     for (i = 0; i < CHUNK_LEN; i++) {
00437       gc_free(S, c->values + i);
00438     }
00439     zfree(S, c);
00440     c = next;
00441   }
00442   /* Free stack */
00443   zfree(S, S->gc_stack);
00444 }
00445 
00446 
00447 void ar_mark(ar_State *S, ar_Value *v) {
00448 begin:
00449   if ( !v || v->mark ) return;
00450   v->mark = 1;
00451   switch (v->type) {
00452     case AR_TDBGINFO:
00453       v = v->u.dbg.name;
00454       goto begin;
00455     case AR_TMAPNODE:
00456       ar_mark(S, v->u.map.pair);
00457       ar_mark(S, v->u.map.left);
00458       v = v->u.map.right;
00459       goto begin;
00460     case AR_TPAIR:
00461       ar_mark(S, v->u.pair.dbg);
00462       ar_mark(S, v->u.pair.car);
00463       v = v->u.pair.cdr;
00464       goto begin;
00465     case AR_TMACRO:
00466     case AR_TFUNC:
00467       ar_mark(S, v->u.func.params);
00468       ar_mark(S, v->u.func.body);
00469       v = v->u.func.env;
00470       goto begin;
00471     case AR_TENV:
00472       ar_mark(S, v->u.env.map);
00473       v = v->u.env.parent;
00474       goto begin;
00475     case AR_TUDATA:
00476       if (v->u.udata.mark) v->u.udata.mark(S, v);
00477       break;
00478   }
00479 }
00480 
00481 
00482 void ar_gc(ar_State *S) {
00483   int i, count;
00484   ar_Chunk *c;
00485   /* Mark roots */
00486   for (i = 0; i < S->gc_stack_idx; i++) ar_mark(S, S->gc_stack[i]);
00487   ar_mark(S, S->global);
00488   ar_mark(S, S->oom_error);
00489   ar_mark(S, S->oom_args);
00490   ar_mark(S, S->t);
00491   /* Sweep: free still-unmarked values, unmark and count remaining values */
00492   count = 0;
00493   c = S->gc_chunks;
00494   while (c) {
00495     for (i = 0; i < CHUNK_LEN; i++) {
00496       if (c->values[i].type != AR_TNIL) {
00497         if (!c->values[i].mark) {
00498           gc_free(S, c->values + i);
00499         } else {
00500           c->values[i].mark = 0;
00501           count++;
00502         }
00503       }
00504     }
00505     c = c->next;
00506   }
00507   /* Reset gc counter */
00508   S->gc_count = count;
00509 }
00510 
00511 
00512 /*===========================================================================
00513  * Environment
00514  *===========================================================================*/
00515 
00516 static ar_Value *new_mapnode(ar_State *S, ar_Value *k, ar_Value *v) {
00517   /* The pair for the node is created *first* as this may trigger garbage
00518    * collection which expects all values to be in an intialised state */
00519   ar_Value *p = ar_new_pair(S, k, v);
00520   ar_Value *x = new_value(S, AR_TMAPNODE);
00521   x->u.map.left = x->u.map.right = NULL;
00522   x->u.map.pair = p;
00523   return x;
00524 }
00525 
00526 
00527 static ar_Value **get_map_ref(ar_Value **m, ar_Value *k) {
00528   unsigned h = k->u.str.hash;
00529   while (*m) {
00530     ar_Value *k2 = (*m)->u.map.pair->u.pair.car;
00531     if (k2->u.str.hash == h && is_equal(k, k2)) {
00532       return m;
00533     } else if (k2->u.str.hash < h) {
00534       m = &(*m)->u.map.left;
00535     } else {
00536       m = &(*m)->u.map.right;
00537     }
00538   }
00539   return m;
00540 }
00541 
00542 
00543 static ar_Value *get_bound_value(ar_Value *sym, ar_Value *env) {
00544   do {
00545     ar_Value *x = *get_map_ref(&env->u.env.map, sym);
00546     if (x) return x->u.map.pair->u.pair.cdr;
00547     env = env->u.env.parent;
00548   } while (env);
00549   return NULL;
00550 }
00551 
00552 
00553 ar_Value *ar_bind(ar_State *S, ar_Value *sym, ar_Value *v, ar_Value *env) {
00554   ar_Value **x = get_map_ref(&env->u.env.map, sym);
00555   if (*x) {
00556     (*x)->u.map.pair->u.pair.cdr = v;
00557   } else {
00558     *x = new_mapnode(S, sym, v);
00559   }
00560   return v;
00561 }
00562 
00563 
00564 ar_Value *ar_set(ar_State *S, ar_Value *sym, ar_Value *v, ar_Value *env) {
00565   for (;;) {
00566     ar_Value *x = *get_map_ref(&env->u.env.map, sym);
00567     if (x) return x->u.map.pair->u.pair.cdr = v;
00568     if (!env->u.env.parent) return ar_bind(S, sym, v, env);
00569     env = env->u.env.parent;
00570   }
00571 }
00572 
00573 
00574 /*===========================================================================
00575  * Parser
00576  *===========================================================================*/
00577 
00578 #define WHITESPACE  " \n\t\r"
00579 #define DELIMITER   (WHITESPACE "();")
00580 
00581 static ar_Value parse_end;
00582 
00583 static ar_Value *parse(ar_State *S, const char **str) {
00584   ar_Value *res, **last, *v;
00585   char buf[512];
00586   size_t i;
00587   char *q;
00588   const char *p = *str;
00589 
00590   /* Skip whitespace */
00591   while (*p && strchr(WHITESPACE, *p)) {
00592     if (*p++ == '\n') S->parse_line++;
00593   }
00594 
00595   switch (*p) {
00596     case '\0':
00597       return &parse_end;
00598 
00599     case '(':
00600       res = NULL;
00601       last = &res;
00602       *str = p + 1;
00603       while ((v = parse(S, str)) != &parse_end) {
00604         if (ar_type(v) == AR_TSYMBOL && !strcmp(v->u.str.s, ".")) {
00605           /* Handle dotted pair */
00606           *last = parse(S, str);
00607         } else {
00608           /* Handle proper pair */
00609           int first = !res;
00610           *last = ar_new_pair(S, v, NULL);
00611           if (first) {
00612             /* This is the first pair in the list, attach debug info */
00613             ar_Value *dbg = new_value(S, AR_TDBGINFO);
00614             dbg->u.dbg.name = S->parse_name;
00615             dbg->u.dbg.line = S->parse_line;
00616             (*last)->u.pair.dbg = dbg;
00617           }
00618           last = &(*last)->u.pair.cdr;
00619         }
00620       }
00621       return res ? res : ar_new_pair(S, NULL, NULL);
00622 
00623     case '\'':
00624       *str = p + 1;
00625       return ar_new_list(S, 2, ar_new_symbol(S, "quote"), parse(S, str));
00626 
00627     case ')':
00628       *str = p + 1;
00629       return &parse_end;
00630 
00631     case ';':
00632       *str = p + strcspn(p, "\n");
00633       return parse(S, str);
00634 
00635     case '.': case '-':
00636     case '1': case '2': case '3': case '4': case '5':
00637     case '6': case '7': case '8': case '9': case '0':
00638       res = ar_new_number(S, strtod(p, &q));
00639       /* Not a valid number? treat as symbol */
00640       if ( *q && !strchr(DELIMITER, *q) ) {
00641         goto parse_symbol;
00642       }
00643       break;
00644 
00645     case '"':
00646       /* Get string length */
00647       p++;
00648       *str = p;
00649       i = 0;
00650       while (*p && *p != '"') {
00651         if (*p == '\\') p++;
00652         i++, p++;
00653       }
00654       /* Copy string */
00655       res = ar_new_stringl(S, NULL, i);
00656       p = *str;
00657       q = res->u.str.s;
00658       while (*p && *p != '"') {
00659         if (*p == '\\') {
00660           switch (*(++p)) {
00661             case 'r' : { *q++ = '\r'; p++; continue; }
00662             case 'n' : { *q++ = '\n'; p++; continue; }
00663             case 't' : { *q++ = '\t'; p++; continue; }
00664           }
00665         }
00666         if (*p == '\n') S->parse_line++;
00667         *q++ = *p++;
00668       }
00669       *str = p;
00670       break;
00671 
00672     default:
00673 parse_symbol:
00674       *str = p + strcspn(p, DELIMITER);
00675       i = *str - p;
00676       if (i >= sizeof(buf)) i = sizeof(buf) - 1;
00677       memcpy(buf, p, i);
00678       buf[i] = '\0';
00679       if (!strcmp(buf, "nil")) return NULL;
00680       return ar_new_symbol(S, buf);
00681   }
00682 
00683   *str = p + strcspn(p, DELIMITER);
00684   return res;
00685 }
00686 
00687 
00688 ar_Value *ar_parse(ar_State *S, const char *str, const char *name) {
00689   ar_Value *res;
00690   S->parse_name = ar_new_string(S, name ? name : "?");
00691   S->parse_line = 1;
00692   res = parse(S, &str);
00693   return (res == &parse_end) ? NULL : res;
00694 }
00695 
00696 
00697 /*===========================================================================
00698  * Eval
00699  *===========================================================================*/
00700 
00701 static ar_Value *eval_list(ar_State *S, ar_Value *list, ar_Value *env) {
00702   ar_Value *res = NULL, **last = &res;
00703   while (list) {
00704     last = ar_append_tail(S, last, ar_eval(S, ar_car(list), env));
00705     list = ar_cdr(list);
00706   }
00707   return res;
00708 }
00709 
00710 
00711 static ar_Value *args_to_env(
00712   ar_State *S, ar_Value *params, ar_Value *args, ar_Value *env
00713 ) {
00714   ar_Value *e = ar_new_env(S, env);
00715   /* No params? */
00716   if (ar_car(params) == AR_TNIL) {
00717     return e;
00718   }
00719   /* Handle arg list */
00720   while (params) {
00721     /* Symbol instead of pair? Bind remaining args to symbol */
00722     if (ar_type(params) == AR_TSYMBOL) {
00723       ar_bind(S, params, args, e);
00724       return e;
00725     }
00726     /* Handle normal param */
00727     ar_bind(S, ar_car(params), ar_car(args), e);
00728     params = ar_cdr(params);
00729     args = ar_cdr(args);
00730   }
00731   return e;
00732 }
00733 
00734 
00735 static void push_frame(ar_State *S, ar_Frame *f, ar_Value *caller) {
00736   if (S->frame_idx == MAX_STACK) {
00737     ar_error_str(S, "stack overflow");
00738   }
00739   S->frame_idx++;
00740   f->parent = S->frame;
00741   f->caller = caller;
00742   f->stack_idx = S->gc_stack_idx;
00743   f->err_env = NULL;
00744   S->frame = f;
00745 }
00746 
00747 
00748 static void pop_frame(ar_State *S, ar_Value *rtn) {
00749   S->gc_stack_idx = S->frame->stack_idx;
00750   S->frame = S->frame->parent;
00751   S->frame_idx--;
00752   /* Reached the base frame? Clear protected-value-stack of all values */
00753   if (S->frame == &S->base_frame) S->gc_stack_idx = 0;
00754   if (rtn) push_value_to_stack(S, rtn);
00755 }
00756 
00757 
00758 static ar_Value *raw_call(
00759   ar_State *S, ar_Value *caller, ar_Value *fn, ar_Value *args, ar_Value *env
00760 ) {
00761   ar_Value *e, *res;
00762   ar_Frame frame;
00763   push_frame(S, &frame, caller);
00764 
00765   switch (ar_type(fn)) {
00766     case AR_TCFUNC:
00767       res = fn->u.cfunc.fn(S, args);
00768       break;
00769 
00770     case AR_TPRIM:
00771       res = fn->u.prim.fn(S, args, env);
00772       break;
00773 
00774     case AR_TFUNC:
00775       e = args_to_env(S, fn->u.func.params, args, fn->u.func.env);
00776       res = ar_do_list(S, fn->u.func.body, e);
00777       break;
00778 
00779     case AR_TMACRO:
00780       e = args_to_env(S, fn->u.func.params, args, fn->u.func.env);
00781       res = ar_eval(S, ar_do_list(S, fn->u.func.body, e), env);
00782       break;
00783 
00784     default:
00785       ar_error_str(S, "expected primitive, function or macro; got %s",
00786                    ar_type_str(ar_type(fn)));
00787       res = NULL;
00788   }
00789   pop_frame(S, res);
00790   return res;
00791 }
00792 
00793 
00794 ar_Value *ar_eval(ar_State *S, ar_Value *v, ar_Value *env) {
00795   ar_Value *fn, *args;
00796 
00797   switch (ar_type(v)) {
00798     case AR_TPAIR   : break;
00799     case AR_TSYMBOL : return get_bound_value(v, env);
00800     default         : return v;
00801   }
00802 
00803   fn = ar_eval(S, v->u.pair.car, env);
00804   switch (ar_type(fn)) {
00805     case AR_TCFUNC  :
00806     case AR_TFUNC   : args = eval_list(S, v->u.pair.cdr, env);  break;
00807     default         : args = v->u.pair.cdr;                     break;
00808   }
00809   return raw_call(S, v, fn, args, env);
00810 }
00811 
00812 
00813 ar_Value *ar_call(ar_State *S, ar_Value *fn, ar_Value *args) {
00814   int t = ar_type(fn);
00815   if (t != AR_TFUNC && t != AR_TCFUNC) {
00816     ar_error_str(S, "expected function, got %s", ar_type_str(t));
00817   }
00818   return raw_call(S, ar_new_pair(S, fn, args), fn, args, NULL);
00819 }
00820 
00821 
00822 ar_Value *ar_do_list(ar_State *S, ar_Value *body, ar_Value *env) {
00823   ar_Value *res = NULL;
00824   while (body) {
00825     res = ar_eval(S, ar_car(body), env);
00826     body = ar_cdr(body);
00827   }
00828   return res;
00829 }
00830 
00831 
00832 ar_Value *ar_do_string(ar_State *S, const char *str) {
00833   return ar_eval(S, ar_parse(S, str, "(string)"), S->global);
00834 }
00835 
00836 
00837 ar_Value *ar_do_file(ar_State *S, const char *filename) {
00838   ar_Value *args = ar_new_list(S, 1, ar_new_string(S, filename));
00839   ar_Value *str = ar_call_global(S, "loads", args);
00840   return ar_eval(S, ar_parse(S, str->u.str.s, filename), S->global);
00841 }
00842 
00843 
00844 /*===========================================================================
00845  * Built-in primitives and funcs
00846  *===========================================================================*/
00847 
00848 static ar_Value *p_do(ar_State *S, ar_Value *args, ar_Value *env) {
00849   return ar_do_list(S, args, env);
00850 }
00851 
00852 
00853 static ar_Value *p_set(ar_State *S, ar_Value *args, ar_Value *env) {
00854   ar_Value *sym, *v;
00855   do {
00856     sym = ar_check(S, ar_car(args), AR_TSYMBOL);
00857     v = ar_eval(S, ar_car(args = ar_cdr(args)), env);
00858     ar_set(S, sym, v, env);
00859   } while ( (args = ar_cdr(args)) );
00860   return v;
00861 }
00862 
00863 
00864 static ar_Value *p_quote(ar_State *S, ar_Value *args, ar_Value *env) {
00865   UNUSED(S);
00866   UNUSED(env);
00867   return ar_car(args);
00868 }
00869 
00870 
00871 static ar_Value *p_eval(ar_State *S, ar_Value *args, ar_Value *env) {
00872   ar_Value *e = ar_eval(S, ar_nth(args, 1), env);
00873   e = e ? ar_check(S, e, AR_TENV) : env;
00874   return ar_eval(S, ar_eval(S, ar_car(args), env), e);
00875 }
00876 
00877 
00878 static ar_Value *p_fn(ar_State *S, ar_Value *args, ar_Value *env) {
00879   ar_Value *v = ar_car(args);
00880   int t = ar_type(v);
00881   /* Type check */
00882   if (t != AR_TPAIR && t != AR_TSYMBOL) {
00883     ar_error_str(S, "expected pair or symbol, got %s", ar_type_str(t));
00884   }
00885     
00886   if (t == AR_TPAIR && (ar_car(v) || ar_cdr(v))) {
00887     while (v) {
00888       ar_check(S, ar_car(v), AR_TSYMBOL);
00889       v = ar_cdr(v);
00890     }
00891   }
00892   /* Init function */
00893   v = new_value(S, AR_TFUNC);
00894   v->u.func.params = ar_car(args);
00895   v->u.func.body = ar_cdr(args);
00896   v->u.func.env = env;
00897   return v;
00898 }
00899 
00900 
00901 static ar_Value *p_macro(ar_State *S, ar_Value *args, ar_Value *env) {
00902   ar_Value *v = p_fn(S, args, env);
00903   v->type = AR_TMACRO;
00904   return v;
00905 }
00906 
00907 
00908 static ar_Value *p_apply(ar_State *S, ar_Value *args, ar_Value *env) {
00909   ar_Value *fn = ar_eval(S, ar_car(args), env);
00910   return ar_call(S, fn, ar_eval(S, ar_nth(args, 1), env));
00911 }
00912 
00913 
00914 static ar_Value *p_if(ar_State *S, ar_Value *args, ar_Value *env) {
00915   ar_Value *cond, *next, *v = args;
00916   while (v) {
00917     cond = ar_eval(S, ar_car(v), env);
00918     next = ar_cdr(v);
00919     if (cond) {
00920       return next ? ar_eval(S, ar_car(next), env) : cond;
00921     }
00922     v = ar_cdr(next);
00923   }
00924   return NULL;
00925 }
00926 
00927 
00928 static ar_Value *p_and(ar_State *S, ar_Value *args, ar_Value *env) {
00929   ar_Value *res = NULL;
00930   while (args) {
00931     if ( !(res = ar_eval(S, ar_car(args), env)) ) return NULL;
00932     args = ar_cdr(args);
00933   }
00934   return res;
00935 }
00936 
00937 
00938 static ar_Value *p_or(ar_State *S, ar_Value *args, ar_Value *env) {
00939   ar_Value *res;
00940   while (args) {
00941     if ( (res = ar_eval(S, ar_car(args), env)) ) return res;
00942     args = ar_cdr(args);
00943   }
00944   return NULL;
00945 }
00946 
00947 
00948 static ar_Value *p_let(ar_State *S, ar_Value *args, ar_Value *env) {
00949   ar_Value *vars = ar_check(S, ar_car(args), AR_TPAIR);
00950   env = ar_new_env(S, env);
00951   while (vars) {
00952     ar_Value *sym = ar_check(S, ar_car(vars), AR_TSYMBOL);
00953     vars = ar_cdr(vars);
00954     ar_bind(S, sym, ar_eval(S, ar_car(vars), env), env);
00955     vars = ar_cdr(vars);
00956   }
00957   return ar_do_list(S, ar_cdr(args), env);
00958 }
00959 
00960 
00961 static ar_Value *p_while(ar_State *S, ar_Value *args, ar_Value *env) {
00962   ar_Value *cond = ar_car(args);
00963   ar_Value *body = ar_cdr(args);
00964   int orig_stack_idx = S->gc_stack_idx;
00965   while ( ar_eval(S, cond, env) ) {
00966     ar_do_list(S, body, env);
00967     /* Truncate stack so we don't accumulate protected values */
00968     S->gc_stack_idx = orig_stack_idx;
00969   }
00970   return NULL;
00971 }
00972 
00973 
00974 static ar_Value *p_pcall(ar_State *S, ar_Value *args, ar_Value *env) {
00975   ar_Value *res;
00976   ar_try(S, err, {
00977     res = ar_call(S, ar_eval(S, ar_car(args), env), NULL);
00978   }, {
00979     res = ar_call(S, ar_eval(S, ar_nth(args, 1), env), err);
00980   });
00981   return res;
00982 }
00983 
00984 
00985 static ar_Value *f_list(ar_State *S, ar_Value *args) {
00986   UNUSED(S);
00987   return args;
00988 }
00989 
00990 
00991 static ar_Value *f_type(ar_State *S, ar_Value *args) {
00992   return ar_new_symbol(S, ar_type_str(ar_type(ar_car(args))));
00993 }
00994 
00995 
00996 static ar_Value *f_print(ar_State *S, ar_Value *args) {
00997   while (args) {
00998     size_t len;
00999     const char *str = ar_to_stringl(S, ar_car(args), &len);
01000     fwrite(str, len, 1, stdout);
01001     if (!ar_cdr(args)) break;
01002     printf(" ");
01003     args = ar_cdr(args);
01004   }
01005   printf("\n");
01006   return ar_car(args);
01007 }
01008 
01009 
01010 static ar_Value *f_parse(ar_State *S, ar_Value *args) {
01011   return ar_parse(S, ar_check_string(S, ar_car(args)),
01012                      ar_opt_string(S, ar_nth(args, 1), "(string)"));
01013 }
01014 
01015 
01016 static ar_Value *f_error(ar_State *S, ar_Value *args) {
01017   ar_error(S, ar_car(args));
01018   return NULL;
01019 }
01020 
01021 
01022 static ar_Value *f_dbgloc(ar_State *S, ar_Value *args) {
01023   return debug_location(S, ar_car(args));
01024 }
01025 
01026 
01027 static ar_Value *f_cons(ar_State *S, ar_Value *args) {
01028   return ar_new_pair(S, ar_car(args), ar_nth(args, 1));
01029 }
01030 
01031 
01032 static ar_Value *f_car(ar_State *S, ar_Value *args) {
01033   ar_Value *v = ar_car(args);
01034   if (!v) return NULL;
01035   return ar_check(S, v, AR_TPAIR)->u.pair.car;
01036 }
01037 
01038 
01039 static ar_Value *f_cdr(ar_State *S, ar_Value *args) {
01040   ar_Value *v = ar_car(args);
01041   if (!v) return NULL;
01042   return ar_check(S, v, AR_TPAIR)->u.pair.cdr;
01043 }
01044 
01045 
01046 static ar_Value *f_setcar(ar_State *S, ar_Value *args) {
01047   return ar_check(S, ar_car(args), AR_TPAIR)->u.pair.car = ar_nth(args, 1);
01048 }
01049 
01050 
01051 static ar_Value *f_setcdr(ar_State *S, ar_Value *args) {
01052   return ar_check(S, ar_car(args), AR_TPAIR)->u.pair.cdr = ar_nth(args, 1);
01053 }
01054 
01055 
01056 static ar_Value *f_string(ar_State *S, ar_Value *args) {
01057   ar_Value *res = NULL, **last = &res;
01058   ar_Value *v = args;
01059   while (v) {
01060     last = ar_append_tail(S, last, ar_to_string_value(S, ar_car(v), 0));
01061     v = ar_cdr(v);
01062   }
01063   return join_list_of_strings(S, res);
01064 }
01065 
01066 
01067 static ar_Value *f_substr(ar_State *S, ar_Value *args) {
01068   ar_Value *str = ar_check(S, ar_car(args), AR_TSTRING);
01069   int slen = str->u.str.len;
01070   int start = ar_opt_number(S, ar_nth(args, 1), 0);
01071   int len = ar_opt_number(S, ar_nth(args, 2), str->u.str.len);
01072   if (start < 0) start = slen + start;
01073   if (start < 0) len += start, start = 0;
01074   if (start + len > slen) len = slen - start;
01075   if (len < 0) len = 0;
01076   return ar_new_stringl(S, &str->u.str.s[start], len);
01077 }
01078 
01079 
01080 static ar_Value *f_strlen(ar_State *S, ar_Value *args) {
01081   return ar_new_number(S, ar_check(S, ar_car(args), AR_TSTRING)->u.str.len);
01082 }
01083 
01084 
01085 static ar_Value *f_strpos(ar_State *S, ar_Value *args) {
01086   ar_Value *haystack = ar_check(S, ar_car(args),  AR_TSTRING);
01087   ar_Value *needle = ar_check(S, ar_nth(args, 1), AR_TSTRING);
01088   unsigned offset = ar_opt_number(S, ar_nth(args, 2), 0);
01089   const char *p;
01090   if (offset >= haystack->u.str.len) return NULL;
01091   p = strstr(haystack->u.str.s + offset, needle->u.str.s);
01092   return p ? ar_new_number(S, p - haystack->u.str.s) : NULL;
01093 }
01094 
01095 
01096 static ar_Value *f_chr(ar_State *S, ar_Value *args) {
01097   char c = ar_check_number(S, ar_car(args));
01098   return ar_new_stringl(S, &c, 1);
01099 }
01100 
01101 
01102 static ar_Value *f_ord(ar_State *S, ar_Value *args) {
01103   return ar_new_number(S, *ar_check_string(S, ar_car(args)));
01104 }
01105 
01106 
01107 #define STRING_MAP_FUNC(NAME, FUNC)                           \
01108   static ar_Value *NAME(ar_State *S, ar_Value *args) {        \
01109     ar_Value *str = ar_check(S, ar_car(args), AR_TSTRING);    \
01110     ar_Value *res = ar_new_stringl(S, NULL, str->u.str.len);  \
01111     size_t i;                                                 \
01112     for (i = 0; i < res->u.str.len; i++) {                    \
01113       res->u.str.s[i] = FUNC(str->u.str.s[i]);                \
01114     }                                                         \
01115     return res;                                               \
01116   }
01117 
01118 STRING_MAP_FUNC( f_lower, tolower )
01119 STRING_MAP_FUNC( f_upper, toupper )
01120 
01121 
01122 static ar_Value *f_loads(ar_State *S, ar_Value *args) {
01123   ar_Value *res;
01124   int r, size;
01125   FILE *fp = fopen(ar_check_string(S, ar_car(args)), "rb");
01126   if (!fp) ar_error_str(S, "could not open file");
01127   /* Get size */
01128   fseek(fp, 0, SEEK_END);
01129   size = ftell(fp);
01130   fseek(fp, 0, SEEK_SET);
01131   /* Load file into string value */
01132   res = ar_new_stringl(S, NULL, size);
01133   r = fread(res->u.str.s, 1, size, fp);
01134   fclose(fp);
01135   if (r != size) ar_error_str(S, "could not read file");
01136   return res;
01137 }
01138 
01139 
01140 static ar_Value *f_dumps(ar_State *S, ar_Value *args) {
01141   const char *name, *data;
01142   int r;
01143   size_t len;
01144   FILE *fp;
01145   name = ar_to_string( S, ar_check(S, ar_nth(args, 0), AR_TSTRING));
01146   data = ar_to_stringl(S, ar_check(S, ar_nth(args, 1), AR_TSTRING), &len);
01147   fp = fopen(name, ar_nth(args, 2) ? "ab" : "wb");
01148   if (!fp) ar_error_str(S, "could not open file");
01149   r = fwrite(data, len, 1, fp);
01150   fclose(fp);
01151   if (r != 1) ar_error_str(S, "could not write file");
01152   return NULL;
01153 }
01154 
01155 
01156 static ar_Value *f_is(ar_State *S, ar_Value *args) {
01157   return is_equal(ar_car(args), ar_nth(args, 1)) ?  S->t : NULL;
01158 }
01159 
01160 static ar_Value *f_is_not(ar_State *S, ar_Value *args) {
01161   return !is_equal(ar_car(args), ar_nth(args, 1)) ?  S->t : NULL;
01162 }
01163 
01164 
01165 #define NUM_COMPARE_FUNC(NAME, OP)                                \
01166   static ar_Value *NAME(ar_State *S, ar_Value *args) {            \
01167     return ( ar_check_number(S, ar_car(args)) OP                  \
01168              ar_check_number(S, ar_nth(args, 1)) ) ? S->t : NULL; \
01169   }
01170 
01171 NUM_COMPARE_FUNC( f_lt,  <  )
01172 NUM_COMPARE_FUNC( f_gt,  >  )
01173 NUM_COMPARE_FUNC( f_lte, <= )
01174 NUM_COMPARE_FUNC( f_gte, >= )
01175 
01176 
01177 #define NUM_ARITH_FUNC(NAME, OP)                        \
01178   static ar_Value *NAME(ar_State *S, ar_Value *args) {  \
01179     double res = ar_check_number(S, ar_car(args));      \
01180     while ( (args = ar_cdr(args)) ) {                   \
01181       res = res OP ar_check_number(S, ar_car(args));    \
01182     }                                                   \
01183     return ar_new_number(S, res);                       \
01184   }
01185 
01186 NUM_ARITH_FUNC( f_add, + )
01187 NUM_ARITH_FUNC( f_sub, - )
01188 NUM_ARITH_FUNC( f_mul, * )
01189 NUM_ARITH_FUNC( f_div, / )
01190 
01191 static ar_Value *f_mod(ar_State *S, ar_Value *args) {
01192   double a = ar_check_number(S, ar_car(args));
01193   double b = ar_check_number(S, ar_nth(args, 1));
01194   if (b == 0.) ar_error_str(S, "expected a non-zero divisor");
01195   return ar_new_number(S, a - b * (long) (a / b));
01196 }
01197 
01198 
01199 static ar_Value *f_exit(ar_State *S, ar_Value *args) {
01200   exit(ar_opt_number(S, ar_car(args), EXIT_SUCCESS));
01201   return NULL;
01202 }
01203 
01204 
01205 static void register_builtin(ar_State *S) {
01206   int i;
01207   /* Primitives */
01208   struct { const char *name; ar_Prim fn; } 
01209   prims[] = {
01210     { "=",        p_set     },
01211     { "do",       p_do      },
01212     { "quote",    p_quote   },
01213     { "eval",     p_eval    },
01214     { "fn",       p_fn      },
01215     { "macro",    p_macro   },
01216     { "apply",    p_apply   },
01217     { "if",       p_if      },
01218     { "and",      p_and     },
01219     { "or",       p_or      },
01220     { "let",      p_let     },
01221     { "while",    p_while   },
01222     { "pcall",    p_pcall   },
01223     { NULL, NULL }
01224   };
01225   /* Functions */
01226   struct { const char *name; ar_CFunc fn; } funcs[] = {
01227     { "list",     f_list    },
01228     { "type",     f_type    },
01229     { "print",    f_print   },
01230     { "parse",    f_parse   },
01231     { "error",    f_error   },
01232     { "dbgloc",   f_dbgloc  },
01233     { "cons",     f_cons    },
01234     { "car",      f_car     },
01235     { "cdr",      f_cdr     },
01236     { "setcar",   f_setcar  },
01237     { "setcdr",   f_setcdr  },
01238     { "string",   f_string  },
01239     { "substr",   f_substr  },
01240     { "strlen",   f_strlen  },
01241     { "strpos",   f_strpos  },
01242     { "chr",      f_chr     },
01243     { "ord",      f_ord     },
01244     { "lower",    f_lower   },
01245     { "upper",    f_upper   },
01246     { "loads",    f_loads   },
01247     { "dumps",    f_dumps   },
01248     { "is",       f_is      },
01249     { "==",       f_is      },
01250     { "!=",       f_is_not  },
01251     { "<",        f_lt      },
01252     { ">",        f_gt      },
01253     { "<=",       f_lte     },
01254     { ">=",       f_gte     },
01255     { "+",        f_add     },
01256     { "-",        f_sub     },
01257     { "*",        f_mul     },
01258     { "/",        f_div     },
01259     { "mod",      f_mod     },
01260     { "exit",     f_exit    },
01261     { NULL, NULL }
01262   };
01263   /* Register */
01264   for (i = 0; prims[i].name; i++) {
01265     ar_bind_global(S, prims[i].name, ar_new_prim(S, prims[i].fn));
01266   }
01267   for (i = 0; funcs[i].name; i++) {
01268     ar_bind_global(S, funcs[i].name, ar_new_cfunc(S, funcs[i].fn));
01269   }
01270 }
01271 
01272 
01273 /*===========================================================================
01274  * State
01275  *===========================================================================*/
01276 
01277 static void *alloc_(void *udata, void *ptr, size_t size) {
01278   UNUSED(udata);
01279   if (ptr && size == 0) {
01280     free(ptr);
01281     return NULL;
01282   }
01283   return realloc(ptr, size);
01284 }
01285 
01286 
01287 ar_State *ar_new_state(ar_Alloc alloc, void *udata) {
01288   ar_State *volatile S;
01289   if (!alloc) {
01290     alloc = alloc_;
01291   }
01292   S = alloc(udata, NULL, sizeof(*S));
01293   if (!S) return NULL;
01294   memset(S, 0, sizeof(*S));
01295   S->alloc = alloc;
01296   S->udata = udata;
01297   S->frame = &S->base_frame;
01298   /* We use the ar_try macro in case an out-of-memory error occurs -- you
01299    * shouldn't usually return from inside the ar_try macro */
01300   ar_try(S, err, {
01301     /* Init global env; add constants, primitives and funcs */
01302     S->global = ar_new_env(S, NULL);
01303     S->oom_error = ar_new_string(S, "out of memory");
01304     S->oom_args = ar_new_pair(S, S->oom_error, NULL);
01305     S->t = ar_new_symbol(S, "t");
01306     ar_bind(S, S->t, S->t, S->global);
01307     ar_bind_global(S, "global", S->global);
01308     register_builtin(S);
01309   }, {
01310     UNUSED(err);
01311     ar_close_state(S);
01312     return NULL;
01313   });
01314   return S;
01315 }
01316 
01317 
01318 void ar_close_state(ar_State *S) {
01319   gc_deinit(S);
01320   zfree(S, S);
01321 }
01322 
01323 
01324 ar_CFunc ar_at_panic(ar_State *S, ar_CFunc fn) {
01325   ar_CFunc old = S->panic;
01326   S->panic = fn;
01327   return old;
01328 }
01329 
01330 
01331 static ar_Value *traceback(ar_State *S, ar_Frame *until) {
01332   ar_Value *res = NULL, **last = &res;
01333   ar_Frame *f = S->frame;
01334   while (f != until) {
01335     last = ar_append_tail(S, last, f->caller);
01336     f = f->parent;
01337   }
01338   return res;
01339 }
01340 
01341 
01342 void ar_error(ar_State *S, ar_Value *err) {
01343   ar_Frame *f;
01344   ar_Value *args;
01345   /* Create arguments to pass to error handler */
01346   if (err == S->oom_error) {
01347     args = S->oom_args;
01348   } else {
01349     /* String error? Add debug location string to start */
01350     if (ar_type(err) == AR_TSTRING) {
01351       err = join_list_of_strings(S, ar_new_list(S, 3,
01352         debug_location(S, S->frame->caller),
01353         ar_new_string(S, ": "),
01354         err));
01355     }
01356     args = ar_new_list(S, 2, err, NULL);
01357   }
01358   /* Unwind stack, create traceback list and jump to error env if it exists */
01359   f = S->frame;
01360   while (f) {
01361     if (f->err_env) {
01362       if (err != S->oom_error) {
01363         ar_cdr(args)->u.pair.car = traceback(S, f);
01364       }
01365       S->err_args = args;
01366       while (S->frame != f) pop_frame(S, args);
01367       if (err == S->oom_error) ar_gc(S);
01368       longjmp(*f->err_env, -1);
01369     }
01370     f = f->parent;
01371   }
01372   /* No error env found -- if we have a panic callback we unwind the stack and
01373    * call it else the error and traceback is printed */
01374   if (S->panic) {
01375     while (S->frame != &S->base_frame) pop_frame(S, args);
01376     S->panic(S, args);
01377   } else {
01378     printf("error: %s\n", ar_to_string(S, err));
01379     if (err != S->oom_error) {
01380       ar_Value *v = traceback(S, &S->base_frame);
01381       printf("traceback:\n");
01382       while (v) {
01383         printf("  [%s] %.50s\n", ar_to_string(S, debug_location(S, ar_car(v))),
01384                                  ar_to_string(S, ar_car(v)));
01385         v = ar_cdr(v);
01386       }
01387     }
01388   }
01389   exit(EXIT_FAILURE);
01390 }
01391 
01392 
01393 void ar_error_str(ar_State *S, const char *fmt, ...) {
01394   char buf[512];
01395   va_list args;
01396   va_start(args, fmt);
01397   vsprintf(buf, fmt, args);
01398   va_end(args);
01399   ar_error(S, ar_new_string(S, buf));
01400 }
01401 
01402 
01403 /*===========================================================================
01404  * Standalone
01405  *===========================================================================*/
01406 #undef AR_STANDALONE
01407 
01408 #ifdef AR_STANDALONE
01409 
01410 static ar_Value *f_readline(ar_State *S, ar_Value *args) {
01411   char buf[512];
01412   UNUSED(args);
01413   printf("> ");
01414   return ar_new_string(S, fgets(buf, sizeof(buf) - 1, stdin));
01415 }
01416 
01417 
01418 int main(int argc, char **argv) {
01419   ar_State *S = ar_new_state(NULL, NULL);
01420   if (!S) {
01421     printf("out of memory\n");
01422     return EXIT_FAILURE;
01423   }
01424   ar_bind_global(S, "readline", ar_new_cfunc(S, f_readline));
01425 
01426   if (argc < 2) {
01427     /* Init REPL */
01428     printf("aria " AR_VERSION "\n");
01429     ar_do_string(S, "(while t (pcall "
01430                     "  (fn () (print (eval (parse (readline)) global))) "
01431                     "  (fn (err tr) "
01432                     "    (print \"error:\" err) "
01433                     "    (print \"traceback:\") "
01434                     "    (while tr "
01435                     "      (print (string \"  [\" (dbgloc (car tr)) \"] \" "
01436                     "                     (substr (string (car tr)) 0 50))) "
01437                     "      (= tr (cdr tr))))))" );
01438 
01439 
01440   } else {
01441     /* Store arguments at global list `argv` */
01442     int i;
01443     ar_Value *v = NULL, **last = &v;
01444     for (i = 1; i < argc; i++) {
01445       last = ar_append_tail(S, last, ar_new_string(S, argv[i]));
01446     }
01447     ar_bind_global(S, "argv", v);
01448     /* Load and do file from argv[1] */
01449     ar_do_file(S, argv[1]);
01450   }
01451   ar_close_state(S);
01452   return EXIT_SUCCESS;
01453 }
01454 
01455 #endif
01456