php/types.php

   1 <?php
   2
   3
   4 // Errors/Exceptions
   5 class _Error extends Exception {
   6     public $obj = null;
   7     public function __construct($obj) {
   8         parent::__construct("Mal Error", 0, null);
   9         $this->obj = $obj;
  10     }
  11 }
  12
  13
  14 // General functions
  15
  16 function _equal_Q($a, $b) {
  17     $ota = gettype($a) === "object" ? get_class($a) : gettype($a);
  18     $otb = gettype($b) === "object" ? get_class($b) : gettype($b);
  19     if (!($ota === $otb or (_sequential_Q($a) and _sequential_Q($b)))) {
  20         return false;
  21     } elseif (_symbol_Q($a)) {
  22         #print "ota: $ota, otb: $otb\n";
  23         return $a->value === $b->value;
  24     } elseif (_list_Q($a) or _vector_Q($a)) {
  25         if ($a->count() !== $b->count()) { return false; }
  26         for ($i=0; $i<$a->count(); $i++) {
  27             if (!_equal_Q($a[$i], $b[$i])) { return false; }
  28         }
  29         return true;
  30     } elseif (_hash_map_Q($a)) {
  31         if ($a->count() !== $b->count()) { return false; }
  32         $hm1 = $a->getArrayCopy();
  33         $hm2 = $b->getArrayCopy();
  34         foreach (array_keys($hm1) as $k) {
  35             if (!_equal_Q($hm1[$k], $hm2[$k])) { return false; }
  36         }
  37         return true;
  38     } else {
  39         return $a === $b;
  40     }
  41 }
  42
  43 function _sequential_Q($seq) { return _list_Q($seq) or _vector_Q($seq); }
  44
  45
  46 // Scalars
  47 function _nil_Q($obj) { return $obj === NULL; }
  48 function _true_Q($obj) { return $obj === true; }
  49 function _false_Q($obj) { return $obj === false; }
  50 function _string_Q($obj) {
  51     return is_string($obj) && strpos($obj, chr(0x7f)) !== 0;
  52 }
  53 function _number_Q($obj) { return is_int($obj); }
  54
  55
  56 // Symbols
  57 class SymbolClass {
  58     public $value = NULL;
  59     public $meta = NULL;
  60     public function __construct($value) {
  61         $this->value = $value;
  62     }
  63 }
  64 function _symbol($name) { return new SymbolClass($name); }
  65 function _symbol_Q($obj) { return ($obj instanceof SymbolClass); }
  66
  67 // Keywords
  68 function _keyword($name) { return chr(0x7f).$name; }
  69 function _keyword_Q($obj) {
  70     return is_string($obj) && strpos($obj, chr(0x7f)) === 0;
  71 }
  72
  73
  74
  75 // Functions
  76 class FunctionClass {
  77     public $func = NULL;
  78     public $type = 'native';   // 'native' or 'platform'
  79     public $meta = NULL;
  80     public $ast = NULL;
  81     public $env = NULL;
  82     public $params = NULL;
  83     public $ismacro = False;
  84     public function __construct($func, $type,
  85                                 $ast, $env, $params, $ismacro=False) {
  86         $this->func = $func;
  87         $this->type = $type;
  88         $this->ast = $ast;
  89         #print_r($ast);
  90         $this->env = $env;
  91         $this->params = $params;
  92         $this->ismacro = $ismacro;
  93     }
  94     public function __invoke() {
  95         $args = func_get_args();
  96         if ($this->type === 'native') {
  97             $fn_env = new Env($this->env,
  98                               $this->params, $args);
  99             $evalf = $this->func;
 100             return $evalf($this->ast, $fn_env);
 101         } else {
 102             return call_user_func_array($this->func, $args);
 103         }
 104     }
 105     public function gen_env($args) {
 106         return new Env($this->env, $this->params, $args);
 107     }
 108     public function apply($args) {
 109         return call_user_func_array(array(&$this, '__invoke'),$args);
 110     }
 111 }
 112
 113 function _function($func, $type='platform',
 114                    $ast=NULL, $env=NULL, $params=NULL, $ismacro=False) {
 115     return new FunctionClass($func, $type, $ast, $env, $params, $ismacro);
 116 }
 117 function _function_Q($obj) { return $obj instanceof FunctionClass; }
 118 function _fn_Q($obj) { return $obj instanceof Closure; }
 119
 120
 121 // Parent class of list, vector, hash-map
 122 // http://www.php.net/manual/en/class.arrayobject.php
 123 class SeqClass extends ArrayObject {
 124     public function slice($start, $length=NULL) {
 125         $sc = new $this();
 126         if ($start >= count($this)) {
 127             $arr = array();
 128         } else {
 129             $arr = array_slice($this->getArrayCopy(), $start, $length);
 130         }
 131         $sc->exchangeArray($arr);
 132         return $sc;
 133     }
 134 }
 135
 136
 137 // Lists
 138 class ListClass extends SeqClass {
 139     public $meta = NULL;
 140 }
 141
 142 function _list() {
 143     $v = new ListClass();
 144     $v->exchangeArray(func_get_args());
 145     return $v;
 146 }
 147 function _list_Q($obj) { return $obj instanceof ListClass; }
 148
 149
 150 // Vectors
 151 class VectorClass extends SeqClass {
 152     public $meta = NULL;
 153 }
 154
 155 function _vector() {
 156     $v = new VectorClass();
 157     $v->exchangeArray(func_get_args());
 158     return $v;
 159 }
 160 function _vector_Q($obj) { return $obj instanceof VectorClass; }
 161
 162
 163 // Hash Maps
 164 class HashMapClass extends ArrayObject {
 165     public $meta = NULL;
 166 }
 167
 168 function _hash_map() {
 169     $args = func_get_args();
 170     if (count($args) % 2 === 1) {
 171         throw new Exception("Odd number of hash map arguments");
 172     }
 173     $hm = new HashMapClass();
 174     array_unshift($args, $hm);
 175     return call_user_func_array('_assoc_BANG', $args);
 176 }
 177 function _hash_map_Q($obj) { return $obj instanceof HashMapClass; }
 178
 179 function _assoc_BANG($hm) {
 180     $args = func_get_args();
 181     if (count($args) % 2 !== 1) {
 182         throw new Exception("Odd number of assoc arguments");
 183     }
 184     for ($i=1; $i<count($args); $i+=2) {
 185         $ktoken = $args[$i];
 186         $vtoken = $args[$i+1];
 187         // TODO: support more than string keys
 188         if (gettype($ktoken) !== "string") {
 189             throw new Exception("expected hash-map key string, got: " . gettype($ktoken));
 190         }
 191         $hm[$ktoken] = $vtoken;
 192     }
 193     return $hm;
 194 }
 195
 196 function _dissoc_BANG($hm) {
 197     $args = func_get_args();
 198     for ($i=1; $i<count($args); $i++) {
 199         $ktoken = $args[$i];
 200         if ($hm && $hm->offsetExists($ktoken)) {
 201             unset($hm[$ktoken]);
 202         }
 203     }
 204     return $hm;
 205 }
 206
 207
 208 // Atoms
 209 class Atom {
 210     public $value = NULL;
 211     public $meta = NULL;
 212     public function __construct($value) {
 213         $this->value = $value;
 214     }
 215 }
 216 function _atom($val) { return new Atom($val); }
 217 function _atom_Q($atm) { return $atm instanceof Atom; }
 218
 219 ?>