c/step9_try.c

   1 #include <stdlib.h>
   2 #include <stdio.h>
   3 #include <string.h>
   4 #include <unistd.h>
   5
   6 #include "types.h"
   7 #include "readline.h"
   8 #include "reader.h"
   9 #include "core.h"
  10 #include "interop.h"
  11
  12 // Declarations
  13 MalVal *EVAL(MalVal *ast, Env *env);
  14 MalVal *macroexpand(MalVal *ast, Env *env);
  15
  16 // read
  17 MalVal *READ(char prompt[], char *str) {
  18     char *line;
  19     MalVal *ast;
  20     if (str) {
  21         line = str;
  22     } else {
  23         line = _readline(prompt);
  24         if (!line) {
  25             _error("EOF");
  26             return NULL;
  27         }
  28     }
  29     ast = read_str(line);
  30     if (!str) { free(line); }
  31     return ast;
  32 }
  33
  34 // eval
  35 int is_pair(MalVal *x) {
  36     return _sequential_Q(x) && (_count(x) > 0);
  37 }
  38
  39 MalVal *quasiquote(MalVal *ast) {
  40     if (!is_pair(ast)) {
  41         return _listX(2, malval_new_symbol("quote"), ast);
  42     } else {
  43         MalVal *a0 = _nth(ast, 0);
  44         if ((a0->type & MAL_SYMBOL) &&
  45             strcmp("unquote", a0->val.string) == 0) {
  46             return _nth(ast, 1);
  47         } else if (is_pair(a0)) {
  48             MalVal *a00 = _nth(a0, 0);
  49             if ((a00->type & MAL_SYMBOL) &&
  50                 strcmp("splice-unquote", a00->val.string) == 0) {
  51                 return _listX(3, malval_new_symbol("concat"),
  52                                  _nth(a0, 1),
  53                                  quasiquote(_rest(ast)));
  54             }
  55         }
  56         return _listX(3, malval_new_symbol("cons"),
  57                          quasiquote(a0),
  58                          quasiquote(_rest(ast)));
  59     }
  60 }
  61
  62 int is_macro_call(MalVal *ast, Env *env) {
  63     if (!ast || ast->type != MAL_LIST) { return 0; }
  64     MalVal *a0 = _nth(ast, 0);
  65     return (a0->type & MAL_SYMBOL) &&
  66             env_find(env, a0) &&
  67             env_get(env, a0)->ismacro;
  68 }
  69
  70 MalVal *macroexpand(MalVal *ast, Env *env) {
  71     if (!ast || mal_error) return NULL;
  72     while (is_macro_call(ast, env)) {
  73         MalVal *a0 = _nth(ast, 0);
  74         MalVal *mac = env_get(env, a0);
  75         // TODO: this is weird and limits it to 20. FIXME
  76         ast = _apply(mac, _rest(ast));
  77     }
  78     return ast;
  79 }
  80
  81 MalVal *eval_ast(MalVal *ast, Env *env) {
  82     if (!ast || mal_error) return NULL;
  83     if (ast->type == MAL_SYMBOL) {
  84         //g_print("EVAL symbol: %s\n", ast->val.string);
  85         return env_get(env, ast);
  86     } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
  87         //g_print("EVAL sequential: %s\n", _pr_str(ast,1));
  88         MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
  89         if (!el || mal_error) return NULL;
  90         el->type = ast->type;
  91         return el;
  92     } else if (ast->type == MAL_HASH_MAP) {
  93         //g_print("EVAL hash_map: %s\n", _pr_str(ast,1));
  94         GHashTableIter iter;
  95         gpointer key, value;
  96         MalVal *seq = malval_new_list(MAL_LIST,
  97                                     g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
  98                                                         _count(ast)));
  99         g_hash_table_iter_init (&iter, ast->val.hash_table);
 100         while (g_hash_table_iter_next (&iter, &key, &value)) {
 101             MalVal *kname = malval_new_string((char *)key);
 102             g_array_append_val(seq->val.array, kname);
 103             MalVal *new_val = EVAL((MalVal *)value, env);
 104             g_array_append_val(seq->val.array, new_val);
 105         }
 106         return _hash_map(seq);
 107     } else {
 108         //g_print("EVAL scalar: %s\n", _pr_str(ast,1));
 109         return ast;
 110     }
 111 }
 112
 113 MalVal *EVAL(MalVal *ast, Env *env) {
 114     while (TRUE) {
 115
 116     if (!ast || mal_error) return NULL;
 117     //g_print("EVAL: %s\n", _pr_str(ast,1));
 118     if (ast->type != MAL_LIST) {
 119         return eval_ast(ast, env);
 120     }
 121     if (!ast || mal_error) return NULL;
 122
 123     // apply list
 124     //g_print("EVAL apply list: %s\n", _pr_str(ast,1));
 125     ast = macroexpand(ast, env);
 126     if (!ast || mal_error) return NULL;
 127     if (ast->type != MAL_LIST) {
 128         return eval_ast(ast, env);
 129     }
 130     if (_count(ast) == 0) { return ast; }
 131
 132     int i, len;
 133     MalVal *a0 = _nth(ast, 0);
 134     if ((a0->type & MAL_SYMBOL) &&
 135         strcmp("def!", a0->val.string) == 0) {
 136         //g_print("eval apply def!\n");
 137         MalVal *a1 = _nth(ast, 1),
 138                *a2 = _nth(ast, 2);
 139         MalVal *res = EVAL(a2, env);
 140         if (mal_error) return NULL;
 141         env_set(env, a1, res);
 142         return res;
 143     } else if ((a0->type & MAL_SYMBOL) &&
 144                strcmp("let*", a0->val.string) == 0) {
 145         //g_print("eval apply let*\n");
 146         MalVal *a1 = _nth(ast, 1),
 147                *a2 = _nth(ast, 2),
 148                *key, *val;
 149         assert_type(a1, MAL_LIST|MAL_VECTOR,
 150                     "let* bindings must be list or vector");
 151         len = _count(a1);
 152         assert((len % 2) == 0, "odd number of let* bindings forms");
 153         Env *let_env = new_env(env, NULL, NULL);
 154         for(i=0; i<len; i+=2) {
 155             key = g_array_index(a1->val.array, MalVal*, i);
 156             val = g_array_index(a1->val.array, MalVal*, i+1);
 157             assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
 158             env_set(let_env, key, EVAL(val, let_env));
 159         }
 160         ast = a2;
 161         env = let_env;
 162         // Continue loop
 163     } else if ((a0->type & MAL_SYMBOL) &&
 164                strcmp("quote", a0->val.string) == 0) {
 165         //g_print("eval apply quote\n");
 166         return _nth(ast, 1);
 167     } else if ((a0->type & MAL_SYMBOL) &&
 168                strcmp("quasiquote", a0->val.string) == 0) {
 169         //g_print("eval apply quasiquote\n");
 170         MalVal *a1 = _nth(ast, 1);
 171         ast = quasiquote(a1);
 172         // Continue loop
 173     } else if ((a0->type & MAL_SYMBOL) &&
 174                strcmp("defmacro!", a0->val.string) == 0) {
 175         //g_print("eval apply defmacro!\n");
 176         MalVal *a1 = _nth(ast, 1),
 177                *a2 = _nth(ast, 2);
 178         MalVal *res = EVAL(a2, env);
 179         if (mal_error) return NULL;
 180         res->ismacro = TRUE;
 181         env_set(env, a1, res);
 182         return res;
 183     } else if ((a0->type & MAL_SYMBOL) &&
 184                strcmp("macroexpand", a0->val.string) == 0) {
 185         //g_print("eval apply macroexpand\n");
 186         MalVal *a1 = _nth(ast, 1);
 187         return macroexpand(a1, env);
 188     } else if ((a0->type & MAL_SYMBOL) &&
 189                strcmp("try*", a0->val.string) == 0) {
 190         //g_print("eval apply try*\n");
 191         MalVal *a1 = _nth(ast, 1);
 192         MalVal *a2 = _nth(ast, 2);
 193         MalVal *res = EVAL(a1, env);
 194         if (!mal_error) { return res; }
 195         MalVal *a20 = _nth(a2, 0);
 196         if (strcmp("catch*", a20->val.string) == 0) {
 197             MalVal *a21 = _nth(a2, 1);
 198             MalVal *a22 = _nth(a2, 2);
 199             Env *catch_env = new_env(env,
 200                                      _listX(1, a21),
 201                                      _listX(1, mal_error));
 202             //malval_free(mal_error);
 203             mal_error = NULL;
 204             res = EVAL(a22, catch_env);
 205             return res;
 206         } else {
 207             return &mal_nil;
 208         }
 209     } else if ((a0->type & MAL_SYMBOL) &&
 210                strcmp("do", a0->val.string) == 0) {
 211         //g_print("eval apply do\n");
 212         eval_ast(_slice(ast, 1, _count(ast)-1), env);
 213         ast = _last(ast);
 214         // Continue loop
 215     } else if ((a0->type & MAL_SYMBOL) &&
 216                strcmp("if", a0->val.string) == 0) {
 217         //g_print("eval apply if\n");
 218         MalVal *a1 = _nth(ast, 1);
 219         MalVal *cond = EVAL(a1, env);
 220         if (!cond || mal_error) return NULL;
 221         if (cond->type & (MAL_FALSE|MAL_NIL)) {
 222             // eval false slot form
 223             if (ast->val.array->len > 3) {
 224                 ast = _nth(ast, 3);
 225             } else {
 226                 return &mal_nil;
 227             }
 228         } else {
 229             // eval true slot form
 230             ast = _nth(ast, 2);
 231         }
 232         // Continue loop
 233     } else if ((a0->type & MAL_SYMBOL) &&
 234                strcmp("fn*", a0->val.string) == 0) {
 235         //g_print("eval apply fn*\n");
 236         MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL);
 237         mf->ismacro = FALSE;
 238         mf->val.func.evaluator = EVAL;
 239         mf->val.func.args = _nth(ast, 1);
 240         mf->val.func.body = _nth(ast, 2);
 241         mf->val.func.env = env;
 242         return mf;
 243     } else {
 244         //g_print("eval apply\n");
 245         MalVal *el = eval_ast(ast, env);
 246         if (!el || mal_error) { return NULL; }
 247         MalVal *f = _first(el),
 248                *args = _rest(el);
 249         assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL,
 250                     "cannot apply '%s'", _pr_str(f,1));
 251         if (f->type & MAL_FUNCTION_MAL) {
 252             ast = f->val.func.body;
 253             env = new_env(f->val.func.env, f->val.func.args, args);
 254             // Continue loop
 255         } else {
 256             return _apply(f, args);
 257         }
 258     }
 259
 260     } // TCO while loop
 261 }
 262
 263 // print
 264 char *PRINT(MalVal *exp) {
 265     if (mal_error) {
 266         fprintf(stderr, "Error: %s\n", mal_error->val.string);
 267         malval_free(mal_error);
 268         mal_error = NULL;
 269         return NULL;
 270     }
 271     return _pr_str(exp,1);
 272 }
 273
 274 // repl
 275
 276 // read and eval
 277 MalVal *RE(Env *env, char *prompt, char *str) {
 278     MalVal *ast, *exp;
 279     ast = READ(prompt, str);
 280     if (!ast || mal_error) return NULL;
 281     exp = EVAL(ast, env);
 282     if (ast != exp) {
 283         malval_free(ast);    // Free input structure
 284     }
 285     return exp;
 286 }
 287
 288 // Setup the initial REPL environment
 289 Env *repl_env;
 290
 291 MalVal *do_eval(MalVal *ast) { return EVAL(ast, repl_env); }
 292
 293 void init_repl_env(int argc, char *argv[]) {
 294     repl_env = new_env(NULL, NULL, NULL);
 295
 296     // core.c: defined using C
 297     int i;
 298     for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
 299         env_set(repl_env,
 300                 malval_new_symbol(core_ns[i].name),
 301                 malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
 302     }
 303     env_set(repl_env,
 304             malval_new_symbol("eval"),
 305             malval_new_function((void*(*)(void *))do_eval, 1));
 306
 307     MalVal *_argv = _listX(0);
 308     for (i=2; i < argc; i++) {
 309         MalVal *arg = malval_new_string(argv[i]);
 310         g_array_append_val(_argv->val.array, arg);
 311     }
 312     env_set(repl_env, malval_new_symbol("*ARGV*"), _argv);
 313
 314     // core.mal: defined using the language itself
 315     RE(repl_env, "", "(def! not (fn* (a) (if a false true)))");
 316     RE(repl_env, "",
 317        "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
 318     RE(repl_env, "", "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))");
 319     RE(repl_env, "", "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))");
 320 }
 321
 322 int main(int argc, char *argv[])
 323 {
 324     MalVal *exp;
 325     char *output;
 326     char prompt[100];
 327
 328     // Set the initial prompt and environment
 329     snprintf(prompt, sizeof(prompt), "user> ");
 330     init_repl_env(argc, argv);
 331
 332     if (argc > 1) {
 333         char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]);
 334         RE(repl_env, "", cmd);
 335         return 0;
 336     }
 337
 338     // repl loop
 339     for(;;) {
 340         exp = RE(repl_env, prompt, NULL);
 341         if (mal_error && strcmp("EOF", mal_error->val.string) == 0) {
 342             return 0;
 343         }
 344         output = PRINT(exp);
 345
 346         if (output) {
 347             g_print("%s\n", output);
 348             free(output);        // Free output string
 349         }
 350
 351         //malval_free(exp);    // Free evaluated expression
 352     }
 353 }