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