c/step5_tco.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) { free(line); }
  29     return ast;
  30 }
  31
  32 // eval
  33 MalVal *eval_ast(MalVal *ast, Env *env) {
  34     if (!ast || mal_error) return NULL;
  35     if (ast->type == MAL_SYMBOL) {
  36         //g_print("EVAL symbol: %s\n", ast->val.string);
  37         return env_get(env, ast);
  38     } else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
  39         //g_print("EVAL sequential: %s\n", _pr_str(ast,1));
  40         MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
  41         if (!el || mal_error) return NULL;
  42         el->type = ast->type;
  43         return el;
  44     } else if (ast->type == MAL_HASH_MAP) {
  45         //g_print("EVAL hash_map: %s\n", _pr_str(ast,1));
  46         GHashTableIter iter;
  47         gpointer key, value;
  48         MalVal *seq = malval_new_list(MAL_LIST,
  49                                     g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
  50                                                         _count(ast)));
  51         g_hash_table_iter_init (&iter, ast->val.hash_table);
  52         while (g_hash_table_iter_next (&iter, &key, &value)) {
  53             MalVal *kname = malval_new_string((char *)key);
  54             g_array_append_val(seq->val.array, kname);
  55             MalVal *new_val = EVAL((MalVal *)value, env);
  56             g_array_append_val(seq->val.array, new_val);
  57         }
  58         return _hash_map(seq);
  59     } else {
  60         //g_print("EVAL scalar: %s\n", _pr_str(ast,1));
  61         return ast;
  62     }
  63 }
  64
  65 MalVal *EVAL(MalVal *ast, Env *env) {
  66     while (TRUE) {
  67
  68     if (!ast || mal_error) return NULL;
  69     //g_print("EVAL: %s\n", _pr_str(ast,1));
  70     if (ast->type != MAL_LIST) {
  71         return eval_ast(ast, env);
  72     }
  73     if (!ast || mal_error) return NULL;
  74
  75     // apply list
  76     //g_print("EVAL apply list: %s\n", _pr_str(ast,1));
  77     int i, len;
  78     if (_count(ast) == 0) { return ast; }
  79     MalVal *a0 = _nth(ast, 0);
  80     if ((a0->type & MAL_SYMBOL) &&
  81         strcmp("def!", a0->val.string) == 0) {
  82         //g_print("eval apply def!\n");
  83         MalVal *a1 = _nth(ast, 1),
  84                *a2 = _nth(ast, 2);
  85         MalVal *res = EVAL(a2, env);
  86         if (mal_error) return NULL;
  87         env_set(env, a1, res);
  88         return res;
  89     } else if ((a0->type & MAL_SYMBOL) &&
  90                strcmp("let*", a0->val.string) == 0) {
  91         //g_print("eval apply let*\n");
  92         MalVal *a1 = _nth(ast, 1),
  93                *a2 = _nth(ast, 2),
  94                *key, *val;
  95         assert_type(a1, MAL_LIST|MAL_VECTOR,
  96                     "let* bindings must be list or vector");
  97         len = _count(a1);
  98         assert((len % 2) == 0, "odd number of let* bindings forms");
  99         Env *let_env = new_env(env, NULL, NULL);
 100         for(i=0; i<len; i+=2) {
 101             key = g_array_index(a1->val.array, MalVal*, i);
 102             val = g_array_index(a1->val.array, MalVal*, i+1);
 103             assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
 104             env_set(let_env, key, EVAL(val, let_env));
 105         }
 106         ast = a2;
 107         env = let_env;
 108         // Continue loop
 109     } else if ((a0->type & MAL_SYMBOL) &&
 110                strcmp("do", a0->val.string) == 0) {
 111         //g_print("eval apply do\n");
 112         eval_ast(_slice(ast, 1, _count(ast)-1), env);
 113         ast = _last(ast);
 114         // Continue loop
 115     } else if ((a0->type & MAL_SYMBOL) &&
 116                strcmp("if", a0->val.string) == 0) {
 117         //g_print("eval apply if\n");
 118         MalVal *a1 = _nth(ast, 1);
 119         MalVal *cond = EVAL(a1, env);
 120         if (!cond || mal_error) return NULL;
 121         if (cond->type & (MAL_FALSE|MAL_NIL)) {
 122             // eval false slot form
 123             if (ast->val.array->len > 3) {
 124                 ast = _nth(ast, 3);
 125             } else {
 126                 return &mal_nil;
 127             }
 128         } else {
 129             // eval true slot form
 130             ast = _nth(ast, 2);
 131         }
 132         // Continue loop
 133     } else if ((a0->type & MAL_SYMBOL) &&
 134                strcmp("fn*", a0->val.string) == 0) {
 135         //g_print("eval apply fn*\n");
 136         MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL);
 137         mf->val.func.evaluator = EVAL;
 138         mf->val.func.args = _nth(ast, 1);
 139         mf->val.func.body = _nth(ast, 2);
 140         mf->val.func.env = env;
 141         return mf;
 142     } else {
 143         //g_print("eval apply\n");
 144         MalVal *el = eval_ast(ast, env);
 145         if (!el || mal_error) { return NULL; }
 146         MalVal *f = _first(el),
 147                *args = _rest(el);
 148         assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL,
 149                     "cannot apply '%s'", _pr_str(f,1));
 150         if (f->type & MAL_FUNCTION_MAL) {
 151             ast = f->val.func.body;
 152             env = new_env(f->val.func.env, f->val.func.args, args);
 153             // Continue loop
 154         } else {
 155             return _apply(f, args);
 156         }
 157     }
 158
 159     } // TCO while loop
 160 }
 161
 162 // print
 163 char *PRINT(MalVal *exp) {
 164     if (mal_error) {
 165         fprintf(stderr, "Error: %s\n", mal_error->val.string);
 166         malval_free(mal_error);
 167         mal_error = NULL;
 168         return NULL;
 169     }
 170     return _pr_str(exp,1);
 171 }
 172
 173 // repl
 174
 175 // read and eval
 176 MalVal *RE(Env *env, char *prompt, char *str) {
 177     MalVal *ast, *exp;
 178     ast = READ(prompt, str);
 179     if (!ast || mal_error) return NULL;
 180     exp = EVAL(ast, env);
 181     if (ast != exp) {
 182         malval_free(ast);    // Free input structure
 183     }
 184     return exp;
 185 }
 186
 187 // Setup the initial REPL environment
 188 Env *repl_env;
 189
 190 void init_repl_env() {
 191     repl_env = new_env(NULL, NULL, NULL);
 192
 193     // core.c: defined using C
 194     int i;
 195     for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
 196         env_set(repl_env,
 197                 malval_new_symbol(core_ns[i].name),
 198                 malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
 199     }
 200
 201     // core.mal: defined using the language itself
 202     RE(repl_env, "", "(def! not (fn* (a) (if a false true)))");
 203 }
 204
 205 int main()
 206 {
 207     MalVal *exp;
 208     char *output;
 209     char prompt[100];
 210
 211     // Set the initial prompt and environment
 212     snprintf(prompt, sizeof(prompt), "user> ");
 213     init_repl_env();
 214
 215     // repl loop
 216     for(;;) {
 217         exp = RE(repl_env, prompt, NULL);
 218         if (mal_error && strcmp("EOF", mal_error->val.string) == 0) {
 219             return 0;
 220         }
 221         output = PRINT(exp);
 222
 223         if (output) {
 224             g_print("%s\n", output);
 225             free(output);        // Free output string
 226         }
 227
 228         //malval_free(exp);    // Free evaluated expression
 229     }
 230 }