diff options
Diffstat (limited to 'php/types.php')
| -rw-r--r-- | php/types.php | 420 |
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; } ?> |