c/stepA_interop.c

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