php/stepA_mal.php

   1 <?php
   2
   3 require_once 'readline.php';
   4 require_once 'types.php';
   5 require_once 'reader.php';
   6 require_once 'printer.php';
   7 require_once 'env.php';
   8 require_once 'core.php';
   9
  10 // read
  11 function READ($str) {
  12     return read_str($str);
  13 }
  14
  15 // eval
  16 function is_pair($x) {
  17     return _sequential_Q($x) and count($x) > 0;
  18 }
  19
  20 function quasiquote($ast) {
  21     if (!is_pair($ast)) {
  22         return _list(_symbol("quote"), $ast);
  23     } elseif (_symbol_Q($ast[0]) && $ast[0]->value === 'unquote') {
  24         return $ast[1];
  25     } elseif (is_pair($ast[0]) && _symbol_Q($ast[0][0]) &&
  26               $ast[0][0]->value === 'splice-unquote') {
  27         return _list(_symbol("concat"), $ast[0][1],
  28                      quasiquote($ast->slice(1)));
  29     } else {
  30         return _list(_symbol("cons"), quasiquote($ast[0]),
  31                      quasiquote($ast->slice(1)));
  32     }
  33 }
  34
  35 function is_macro_call($ast, $env) {
  36     return is_pair($ast) &&
  37            _symbol_Q($ast[0]) &&
  38            $env->find($ast[0]) &&
  39            $env->get($ast[0])->ismacro;
  40 }
  41
  42 function macroexpand($ast, $env) {
  43     while (is_macro_call($ast, $env)) {
  44         $mac = $env->get($ast[0]);
  45         $args = array_slice($ast->getArrayCopy(),1);
  46         $ast = $mac->apply($args);
  47     }
  48     return $ast;
  49 }
  50
  51 function eval_ast($ast, $env) {
  52     if (_symbol_Q($ast)) {
  53         return $env->get($ast);
  54     } elseif (_sequential_Q($ast)) {
  55         if (_list_Q($ast)) {
  56             $el = _list();
  57         } else {
  58             $el = _vector();
  59         }
  60         foreach ($ast as $a) { $el[] = MAL_EVAL($a, $env); }
  61         return $el;
  62     } elseif (_hash_map_Q($ast)) {
  63         $new_hm = _hash_map();
  64         foreach (array_keys($ast->getArrayCopy()) as $key) {
  65             $new_hm[$key] = MAL_EVAL($ast[$key], $env);
  66         }
  67         return $new_hm;
  68     } else {
  69         return $ast;
  70     }
  71 }
  72
  73 function MAL_EVAL($ast, $env) {
  74     while (true) {
  75
  76     #echo "MAL_EVAL: " . _pr_str($ast) . "\n";
  77     if (!_list_Q($ast)) {
  78         return eval_ast($ast, $env);
  79     }
  80
  81     // apply list
  82     $ast = macroexpand($ast, $env);
  83     if (!_list_Q($ast)) { return $ast; }
  84
  85     $a0 = $ast[0];
  86     $a0v = (_symbol_Q($a0) ? $a0->value : $a0);
  87     switch ($a0v) {
  88     case "def!":
  89         $res = MAL_EVAL($ast[2], $env);
  90         return $env->set($ast[1], $res);
  91     case "let*":
  92         $a1 = $ast[1];
  93         $let_env = new Env($env);
  94         for ($i=0; $i < count($a1); $i+=2) {
  95             $let_env->set($a1[$i], MAL_EVAL($a1[$i+1], $let_env));
  96         }
  97         $ast = $ast[2];
  98         $env = $let_env;
  99         break; // Continue loop (TCO)
 100     case "quote":
 101         return $ast[1];
 102     case "quasiquote":
 103         $ast = quasiquote($ast[1]);
 104         break; // Continue loop (TCO)
 105     case "defmacro!":
 106         $func = MAL_EVAL($ast[2], $env);
 107         $func->ismacro = true;
 108         return $env->set($ast[1], $func);
 109     case "macroexpand":
 110         return macroexpand($ast[1], $env);
 111     case "php*":
 112         $res = eval($ast[1]);
 113         switch (gettype($res)) {
 114         case "array":
 115             if ($res !== array_values($res)) {
 116                 $new_res = _hash_map();
 117                 $new_res->exchangeArray($res);
 118                 return $new_res;
 119             } else {
 120                 return call_user_func_array('_list', $res);
 121             }
 122         default:
 123             return $res;
 124         }
 125     case "try*":
 126         $a1 = $ast[1];
 127         $a2 = $ast[2];
 128         if ($a2[0]->value === "catch*") {
 129             try {
 130                 return MAL_EVAL($a1, $env);
 131             } catch (Error $e) {
 132                 $catch_env = new Env($env, array($a2[1]),
 133                                             array($e->obj));
 134                 return MAL_EVAL($a2[2], $catch_env);
 135             } catch (Exception $e) {
 136                 $catch_env = new Env($env, array($a2[1]),
 137                                             array($e->getMessage()));
 138                 return MAL_EVAL($a2[2], $catch_env);
 139             }
 140         } else {
 141             return MAL_EVAL($a1, $env);
 142         }
 143     case "do":
 144         eval_ast($ast->slice(1, -1), $env);
 145         $ast = $ast[count($ast)-1];
 146         break; // Continue loop (TCO)
 147     case "if":
 148         $cond = MAL_EVAL($ast[1], $env);
 149         if ($cond === NULL || $cond === false) {
 150             if (count($ast) === 4) { $ast = $ast[3]; }
 151             else                   { $ast = NULL; }
 152         } else {
 153             $ast = $ast[2];
 154         }
 155         break; // Continue loop (TCO)
 156     case "fn*":
 157         return _function('MAL_EVAL', 'native',
 158                          $ast[2], $env, $ast[1]);
 159     default:
 160         $el = eval_ast($ast, $env);
 161         $f = $el[0];
 162         $args = array_slice($el->getArrayCopy(), 1);
 163         if ($f->type === 'native') {
 164             $ast = $f->ast;
 165             $env = $f->gen_env($args);
 166             // Continue loop (TCO)
 167         } else {
 168             return $f->apply($args);
 169         }
 170     }
 171
 172     }
 173 }
 174
 175 // print
 176 function MAL_PRINT($exp) {
 177     return _pr_str($exp, True);
 178 }
 179
 180 // repl
 181 $repl_env = new Env(NULL);
 182 function rep($str) {
 183     global $repl_env;
 184     return MAL_PRINT(MAL_EVAL(READ($str), $repl_env));
 185 }
 186
 187 // core.php: defined using PHP
 188 foreach ($core_ns as $k=>$v) {
 189     $repl_env->set(_symbol($k), _function($v));
 190 }
 191 $repl_env->set(_symbol('eval'), _function(function($ast) {
 192     global $repl_env; return MAL_EVAL($ast, $repl_env);
 193 }));
 194 $_argv = _list();
 195 for ($i=2; $i < count($argv); $i++) {
 196     $_argv->append($argv[$i]);
 197 }
 198 $repl_env->set(_symbol('*ARGV*'), $_argv);
 199
 200 // core.mal: defined using the language itself
 201 rep("(def! *host-language* \"php\")");
 202 rep("(def! not (fn* (a) (if a false true)))");
 203 rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))");
 204 rep("(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)))))))");
 205 rep("(def! *gensym-counter* (atom 0))");
 206 rep("(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))");
 207 rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))");
 208
 209 if (count($argv) > 1) {
 210     rep('(load-file "' . $argv[1] . '")');
 211     exit(0);
 212 }
 213
 214 // repl loop
 215 rep("(println (str \"Mal [\" *host-language* \"]\"))");
 216 do {
 217     try {
 218         $line = mal_readline("user> ");
 219         if ($line === NULL) { break; }
 220         if ($line !== "") {
 221             print(rep($line) . "\n");
 222         }
 223     } catch (BlankException $e) {
 224         continue;
 225     } catch (Exception $e) {
 226         echo "Error: " . $e->getMessage() . "\n";
 227         echo $e->getTraceAsString() . "\n";
 228     }
 229 } while (true);
 230
 231 ?>