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