All: split types into types, env, printer, core.

- types: low-level mapping to the implementation language.
- core: functions on types that are exposed directly to mal.
- printer: implementation called by pr-str, str, prn, println.
- env: the environment implementation

- Also, unindent all TCO while loops so that the diff of step4 and
  step5 are minimized.

1 files changed, 59 insertions, 361 deletions

diff --git a/php/types.php b/php/types.php
index 4486a18..6094558 100644
--- a/php/types.php
+++ b/php/types.php
@@ -1,101 +1,30 @@
 <?php
 
-function _pr_str($obj, $print_readably=True) {
-    if (list_Q($obj)) {
-        $ret = array();
-        foreach ($obj as $e) {
-            array_push($ret, _pr_str($e, $print_readably));
-        }
-        return "(" . implode(" ", $ret) . ")";
-    } elseif (vector_Q($obj)) {
-        $ret = array();
-        foreach ($obj as $e) {
-            array_push($ret, _pr_str($e, $print_readably));
-        }
-        return "[" . implode(" ", $ret) . "]";
-    } elseif (hash_map_Q($obj)) {
-        $ret = array();
-        foreach (array_keys($obj->getArrayCopy()) as $k) {
-            $ret[] = _pr_str($k, $print_readably);
-            $ret[] = _pr_str($obj[$k], $print_readably);
-        }
-        return "{" . implode(" ", $ret) . "}";
-    } elseif (is_string($obj)) {
-        if ($print_readably) {
-            $obj = preg_replace('/"/', '\\"', preg_replace('/\\\\/', '\\\\\\\\', $obj));
-            return '"' . $obj . '"';
-        } else {
-            return $obj;
-        }
-    } elseif (is_integer($obj)) {
-        return $obj;
-    } elseif ($obj === NULL) {
-        return "nil";
-    } elseif ($obj === true) {
-        return "true";
-    } elseif ($obj === false) {
-        return "false";
-    } elseif (symbol_Q($obj)) {
-        return $obj->value;
-    } elseif (atom_Q($obj)) {
-        return "(atom " . _pr_str($obj->value, $print_readably) . ")";
-    } elseif (function_Q($obj)) {
-        return "(fn* [...] ...)";
-    } elseif (is_callable($obj)) {  // only step4 and below
-        return "#<function ...>";
-    } else {
-        throw new Exception("_pr_str unknown type: " . gettype($obj));
-    }
-}
 
-function pr_str() {
-    $ps = array_map(function ($obj) { return _pr_str($obj, True); },
-                    func_get_args());
-    return implode(" ", $ps);
-}
-
-function str() {
-    $ps = array_map(function ($obj) { return _pr_str($obj, False); },
-                    func_get_args());
-    return implode("", $ps);
-}
-
-function prn() {
-    $ps = array_map(function ($obj) { return _pr_str($obj, True); },
-                    func_get_args());
-    print implode(" ", $ps) . "\n";
-    return null;
-}
-
-function println() {
-    $ps = array_map(function ($obj) { return _pr_str($obj, False); },
-                    func_get_args());
-    print implode(" ", $ps) . "\n";
-    return null;
+// Errors/Exceptions
+class Error extends Exception {
+    public $obj = null;
+    public function __construct($obj) {
+        parent::__construct("Mal Error", 0, null);
+        $this->obj = $obj;
+    }
 }
 
-function with_meta($obj, $m) {
-    $new_obj = clone $obj;
-    $new_obj->meta = $m;
-    return $new_obj;
-}
 
-function meta($obj) {
-    return $obj->meta;
-}
+// General functions
 
-function equal_Q($a, $b) {
+function _equal_Q($a, $b) {
     $ota = gettype($a) === "object" ? get_class($a) : gettype($a);
     $otb = gettype($b) === "object" ? get_class($b) : gettype($b);
-    if (!($ota === $otb or (sequential_Q($a) and sequential_Q($b)))) {
+    if (!($ota === $otb or (_sequential_Q($a) and _sequential_Q($b)))) {
         return false;
-    } elseif (symbol_Q($a)) {
+    } elseif (_symbol_Q($a)) {
         #print "ota: $ota, otb: $otb\n";
         return $a->value === $b->value;
-    } elseif (list_Q($a) or vector_Q($a)) {
+    } elseif (_list_Q($a) or _vector_Q($a)) {
         if ($a->count() !== $b->count()) { return false; }
         for ($i=0; $i<$a->count(); $i++) {
-            if (!equal_Q($a[$i], $b[$i])) { return false; }
+            if (!_equal_Q($a[$i], $b[$i])) { return false; }
         }
         return true;
     } else {
@@ -103,14 +32,17 @@ function equal_Q($a, $b) {
     }
 }
 
-// nil, true, false, string
-function nil_Q($obj) { return $obj === NULL; }
-function true_Q($obj) { return $obj === true; }
-function false_Q($obj) { return $obj === false; }
-function string_Q($obj) { return is_string($obj); }
+function _sequential_Q($seq) { return _list_Q($seq) or _vector_Q($seq); }
 
 
-// symbols
+// Scalars
+function _nil_Q($obj) { return $obj === NULL; }
+function _true_Q($obj) { return $obj === true; }
+function _false_Q($obj) { return $obj === false; }
+function _string_Q($obj) { return is_string($obj); }
+
+
+// Symbols
 class SymbolClass {
     public $value = NULL;
     public $meta = NULL;
@@ -118,10 +50,8 @@ class SymbolClass {
         $this->value = $value;
     }
 }
-
-function new_symbol($name) { return new SymbolClass($name); }
-
-function symbol_Q($obj) { return ($obj instanceof SymbolClass); }
+function _symbol($name) { return new SymbolClass($name); }
+function _symbol_Q($obj) { return ($obj instanceof SymbolClass); }
 
 
 // Functions
@@ -152,11 +82,11 @@ class FunctionClass {
     }
 }
 
-function new_function($func, $type='platform', $meta=NULL, $ismacro=False) {
+function _function($func, $type='platform', $meta=NULL, $ismacro=False) {
     return new FunctionClass($func, $type, $meta, $ismacro);
 }
+function _function_Q($obj) { return $obj instanceof FunctionClass; }
 
-function function_Q($obj) { return $obj instanceof FunctionClass; }
 
 // Parent class of list, vector, hash-map
 // http://www.php.net/manual/en/class.arrayobject.php
@@ -174,24 +104,49 @@ class SeqClass extends ArrayObject {
 }
 
 
+// Lists
+class ListClass extends SeqClass {
+    public $meta = NULL;
+}
+
+function _list() {
+    $v = new ListClass();
+    $v->exchangeArray(func_get_args());
+    return $v;
+}
+function _list_Q($obj) { return $obj instanceof ListClass; }
+
+
+// Vectors
+class VectorClass extends SeqClass {
+    public $meta = NULL;
+}
+
+function _vector() {
+    $v = new VectorClass();
+    $v->exchangeArray(func_get_args());
+    return $v;
+}
+function _vector_Q($obj) { return $obj instanceof VectorClass; }
+
+
 // Hash Maps
 class HashMapClass extends ArrayObject {
     public $meta = NULL;
 }
 
-function new_hash_map() {
+function _hash_map() {
     $args = func_get_args();
     if (count($args) % 2 === 1) {
         throw new Exception("Odd number of hash map arguments");
     }
     $hm = new HashMapClass();
     array_unshift($args, $hm);
-    return call_user_func_array('assoc_BANG', $args);
+    return call_user_func_array('_assoc_BANG', $args);
 }
+function _hash_map_Q($obj) { return $obj instanceof HashMapClass; }
 
-function hash_map_Q($obj) { return $obj instanceof HashMapClass; }
-
-function assoc_BANG($hm) {
+function _assoc_BANG($hm) {
     $args = func_get_args();
     if (count($args) % 2 !== 1) {
         throw new Exception("Odd number of assoc arguments");
@@ -208,14 +163,7 @@ function assoc_BANG($hm) {
     return $hm;
 }
 
-function assoc($src_hm) {
-    $args = func_get_args();
-    $hm = clone $src_hm;
-    $args[0] = $hm;
-    return call_user_func_array('assoc_BANG', $args);
-}
-
-function dissoc_BANG($hm) {
+function _dissoc_BANG($hm) {
     $args = func_get_args();
     for ($i=1; $i<count($args); $i++) {
         $ktoken = $args[$i];
@@ -224,72 +172,8 @@ function dissoc_BANG($hm) {
     return $hm;
 }
 
-function dissoc($src_hm) {
-    $args = func_get_args();
-    $hm = clone $src_hm;
-    $args[0] = $hm;
-    return call_user_func_array('dissoc_BANG', $args);
-}
-
-function get($hm, $k) {
-    if ($hm && $hm->offsetExists($k)) {
-        return $hm[$k];
-    } else {
-        return NULL;
-    }
-}
-
-function contains_Q($hm, $k) { return array_key_exists($k, $hm); }
-
-function keys($hm) {
-    return call_user_func_array('new_list', array_keys($hm->getArrayCopy()));
-}
-function vals($hm) {
-    return call_user_func_array('new_list', array_values($hm->getArrayCopy()));
-}
-
-
-// errors/exceptions
-class Error extends Exception {
-    public $obj = null;
-    public function __construct($obj) {
-        parent::__construct("Mal Error", 0, null);
-        $this->obj = $obj;
-    }
-}
-
-function mal_throw($obj) { throw new Error($obj); }
-
-
-// lists
-class ListClass extends SeqClass {
-    public $meta = NULL;
-}
-
-function new_list() {
-    $v = new ListClass();
-    $v->exchangeArray(func_get_args());
-    return $v;
-}
-
-function list_Q($obj) { return $obj instanceof ListClass; }
-
-// vectors
-class VectorClass extends SeqClass {
-    public $meta = NULL;
-}
-
-function new_vector() {
-    $v = new VectorClass();
-    $v->exchangeArray(func_get_args());
-    return $v;
-}
-
-function vector_Q($obj) { return $obj instanceof VectorClass; }
-
 
 // Atoms
-
 class Atom {
     public $value = NULL;
     public $meta = NULL;
@@ -297,193 +181,7 @@ class Atom {
         $this->value = $value;
     }
 }
-function new_atom($val) { return new Atom($val); }
-function atom_Q($atm) { return $atm instanceof Atom; }
-function deref($atm) { return $atm->value; }
-function reset_BANG($atm, $val) { return $atm->value = $val; }
-function swap_BANG($atm, $f) {
-    $args = array_slice(func_get_args(),2);
-    array_unshift($args, $atm->value);
-    $atm->value = call_user_func_array($f, $args);
-    return $atm->value;
-}
-
-
-// Sequence operations
-function sequential_Q($seq) { return list_Q($seq) or vector_Q($seq); }
-
-function scount($seq) { return ($seq === NULL ? 0 : $seq->count()); }
-
-function empty_Q($seq) { return $seq->count() === 0; }
-
-function cons($a, $b) {
-    $tmp = $b->getArrayCopy();
-    array_unshift($tmp, $a);
-    $l = new ListClass();
-    $l->exchangeArray($tmp);
-    return $l;
-}
-
-function concat() {
-    $args = func_get_args();
-    $tmp = array();
-    foreach ($args as $arg) {
-        $tmp = array_merge($tmp, $arg->getArrayCopy());
-    }
-    $l = new ListClass();
-    $l->exchangeArray($tmp);
-    return $l;
-}
-
-function conj($src) {
-    $args = array_slice(func_get_args(), 1);
-    $tmp = $src->getArrayCopy();
-    if (list_Q($src)) {
-        foreach ($args as $arg) { array_unshift($tmp, $arg); }
-        $s = new ListClass();
-    } else {
-        foreach ($args as $arg) { $tmp[] = $arg; }
-        $s = new VectorClass();
-    }
-    $s->exchangeArray($tmp);
-    return $s;
-}
-
-function first($seq) {
-    if (count($seq) === 0) {
-        return NULL;
-    } else {
-        return $seq[0];
-    }
-}
-
-function rest($seq) {
-    $l = new ListClass();
-    $l->exchangeArray(array_slice($seq->getArrayCopy(), 1));
-    return $l;
-}
-
-function nth($seq, $idx) {
-    return $seq[$idx];
-}
-
-function apply($f) {
-    $args = array_slice(func_get_args(), 1);
-    $last_arg = array_pop($args)->getArrayCopy();
-    return $f->apply(array_merge($args, $last_arg));
-}
-
-function map($f, $seq) {
-    $l = new ListClass();
-    $l->exchangeArray(array_map($f, $seq->getArrayCopy()));
-    return $l;
-}
-
-
-// Environment
-class Env {
-    public $data = array();
-    public $outer = NULL;
-    public function __construct($outer, $binds=NULL, $exprs=NULL) {
-        $this->outer = $outer;
-        if ($binds) {
-            if (sequential_Q($exprs)) {
-                $exprs = $exprs->getArrayCopy();
-            }
-            for ($i=0; $i<count($binds); $i++) {
-                if ($binds[$i]->value === "&") {
-                    if ($exprs !== NULL && $i < count($exprs)) {
-                        $lst = call_user_func_array('new_list', array_slice($exprs, $i));
-                    } else {
-                        $lst = new_list();
-                    }
-                    $this->data[$binds[$i+1]->value] = $lst;
-                    break;
-                } else {
-                    if ($exprs !== NULL && $i < count($exprs)) {
-                        $this->data[$binds[$i]->value] = $exprs[$i];
-                    } else {
-                        $this->data[$binds[$i]->value] = NULL;
-                    }
-                }
-            }
-        }
-    }
-    public function find($key) {
-        if (array_key_exists($key, $this->data)) {
-            return $this;
-        } elseif ($this->outer) {
-            return $this->outer->find($key);
-        } else {
-            return NULL;
-        }
-    }
-    public function set($key, $value) {
-        $this->data[$key] = $value;
-        return $value;
-    }
-    public function get($key) {
-        $env = $this->find($key);
-        if (!$env) {
-            throw new Exception("'" . $key . "' not found");
-        } else {
-            return $env->data[$key];
-        }
-    }
-}
-
-// types_ns is namespace of type functions
-$types_ns = array(
-    'pr-str'=> function () { return call_user_func_array('pr_str', func_get_args()); },
-    'str'=>    function () { return call_user_func_array('str', func_get_args()); },
-    'prn'=>    function () { return call_user_func_array('prn', func_get_args()); },
-    'println'=>function () { return call_user_func_array('println', func_get_args()); },
-    'with-meta'=> function ($a, $b) { return with_meta($a, $b); },
-    'meta'=>   function ($a) { return meta($a); },
-    '='=>      function ($a, $b) { return equal_Q($a, $b); },
-    'nil?'=>   function ($a) { return nil_Q($a); },
-    'true?'=>  function ($a) { return true_Q($a); },
-    'false?'=> function ($a) { return false_Q($a); },
-    '+'=>      function ($a, $b) { return intval($a + $b,10); },
-    '-'=>      function ($a, $b) { return intval($a - $b,10); },
-    '*'=>      function ($a, $b) { return intval($a * $b,10); },
-    '/'=>      function ($a, $b) { return intval($a / $b,10); },
-    '<'=>      function ($a, $b) { return $a < $b; },
-    '<='=>     function ($a, $b) { return $a <= $b; },
-    '>'=>      function ($a, $b) { return $a > $b; },
-    '>='=>     function ($a, $b) { return $a >= $b; },
-    'symbol?'=> function ($a) { return symbol_Q($a); },
-    'string?'=> function ($a) { return string_Q($a); },
-    'hash-map' => function () { return call_user_func_array('new_hash_map', func_get_args()); },
-    'map?'=>   function ($a) { return hash_map_Q($a); },
-    'assoc' => function () { return call_user_func_array('assoc', func_get_args()); },
-    'dissoc' => function () { return call_user_func_array('dissoc', func_get_args()); },
-    'get' =>   function ($a, $b) { return get($a, $b); },
-    'contains?' => function ($a, $b) { return contains_Q($a, $b); },
-    'keys' =>  function ($a) { return keys($a); },
-    'vals' =>  function ($a) { return vals($a); },
-    'throw'=>  function ($a) { return mal_throw($a); },
-    'list'=>   function () { return call_user_func_array('new_list', func_get_args()); },
-    'list?'=>  function ($a) { return list_Q($a); },
-    'vector'=> function () { return call_user_func_array('new_vector', func_get_args()); },
-    'vector?'=> function ($a) { return vector_Q($a); },
-    'atom'=>   function ($a) { return new_atom($a); },
-    'atom?'=>  function ($a) { return atom_Q($a); },
-    'deref'=>  function ($a) { return deref($a); },
-    'reset!'=> function ($a, $b) { return reset_BANG($a, $b); },
-    'swap!'=>  function () { return call_user_func_array('swap_BANG', func_get_args()); },
-    'sequential?'=> function ($a) { return sequential_Q($a); },
-    'count'=>  function ($a) { return scount($a); },
-    'empty?'=> function ($a) { return empty_Q($a); },
-    'cons'=>   function ($a, $b) { return cons($a, $b); },
-    'concat'=> function () { return call_user_func_array('concat', func_get_args()); },
-    'conj'=>   function () { return call_user_func_array('conj', func_get_args()); },
-    'first'=>  function ($a) { return first($a); },
-    'rest'=>   function ($a) { return rest($a); },
-    'nth'=>    function ($a, $b) { return nth($a, $b); },
-    'apply'=>  function () { return call_user_func_array('apply', func_get_args()); },
-    'map'=>    function ($a, $b) { return map($a, $b); }
-);
-
+function _atom($val) { return new Atom($val); }
+function _atom_Q($atm) { return $atm instanceof Atom; }
 
 ?>