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
  54
  55 // Symbols
  56 class SymbolClass {
  57     public $value = NULL;
  58     public $meta = NULL;
  59     public function __construct($value) {
  60         $this->value = $value;
  61     }
  62 }
  63 function _symbol($name) { return new SymbolClass($name); }
  64 function _symbol_Q($obj) { return ($obj instanceof SymbolClass); }
  65
  66 // Keywords
  67 function _keyword($name) { return chr(0x7f).$name; }
  68 function _keyword_Q($obj) {
  69     return is_string($obj) && strpos($obj, chr(0x7f)) === 0;
  70 }
  71
  72
  73
  74 // Functions
  75 class FunctionClass {
  76     public $func = NULL;
  77     public $type = 'native';   // 'native' or 'platform'
  78     public $meta = NULL;
  79     public $ast = NULL;
  80     public $env = NULL;
  81     public $params = NULL;
  82     public $ismacro = False;
  83     public function __construct($func, $type,
  84                                 $ast, $env, $params, $ismacro=False) {
  85         $this->func = $func;
  86         $this->type = $type;
  87         $this->ast = $ast;
  88         #print_r($ast);
  89         $this->env = $env;
  90         $this->params = $params;
  91         $this->ismacro = $ismacro;
  92     }
  93     public function __invoke() {
  94         $args = func_get_args();
  95         if ($this->type === 'native') {
  96             $fn_env = new Env($this->env,
  97                               $this->params, $args);
  98             $evalf = $this->func;
  99             return $evalf($this->ast, $fn_env);
 100         } else {
 101             return call_user_func_array($this->func, $args);
 102         }
 103     }
 104     public function gen_env($args) {
 105         return new Env($this->env, $this->params, $args);
 106     }
 107     public function apply($args) {
 108         return call_user_func_array(array(&$this, '__invoke'),$args);
 109     }
 110 }
 111
 112 function _function($func, $type='platform',
 113                    $ast=NULL, $env=NULL, $params=NULL, $ismacro=False) {
 114     return new FunctionClass($func, $type, $ast, $env, $params, $ismacro);
 115 }
 116 function _function_Q($obj) { return $obj instanceof FunctionClass; }
 117
 118
 119 // Parent class of list, vector, hash-map
 120 // http://www.php.net/manual/en/class.arrayobject.php
 121 class SeqClass extends ArrayObject {
 122     public function slice($start, $length=NULL) {
 123         $sc = new $this();
 124         if ($start >= count($this)) {
 125             $arr = array();
 126         } else {
 127             $arr = array_slice($this->getArrayCopy(), $start, $length);
 128         }
 129         $sc->exchangeArray($arr);
 130         return $sc;
 131     }
 132 }
 133
 134
 135 // Lists
 136 class ListClass extends SeqClass {
 137     public $meta = NULL;
 138 }
 139
 140 function _list() {
 141     $v = new ListClass();
 142     $v->exchangeArray(func_get_args());
 143     return $v;
 144 }
 145 function _list_Q($obj) { return $obj instanceof ListClass; }
 146
 147
 148 // Vectors
 149 class VectorClass extends SeqClass {
 150     public $meta = NULL;
 151 }
 152
 153 function _vector() {
 154     $v = new VectorClass();
 155     $v->exchangeArray(func_get_args());
 156     return $v;
 157 }
 158 function _vector_Q($obj) { return $obj instanceof VectorClass; }
 159
 160
 161 // Hash Maps
 162 class HashMapClass extends ArrayObject {
 163     public $meta = NULL;
 164 }
 165
 166 function _hash_map() {
 167     $args = func_get_args();
 168     if (count($args) % 2 === 1) {
 169         throw new Exception("Odd number of hash map arguments");
 170     }
 171     $hm = new HashMapClass();
 172     array_unshift($args, $hm);
 173     return call_user_func_array('_assoc_BANG', $args);
 174 }
 175 function _hash_map_Q($obj) { return $obj instanceof HashMapClass; }
 176
 177 function _assoc_BANG($hm) {
 178     $args = func_get_args();
 179     if (count($args) % 2 !== 1) {
 180         throw new Exception("Odd number of assoc arguments");
 181     }
 182     for ($i=1; $i<count($args); $i+=2) {
 183         $ktoken = $args[$i];
 184         $vtoken = $args[$i+1];
 185         // TODO: support more than string keys
 186         if (gettype($ktoken) !== "string") {
 187             throw new Exception("expected hash-map key string, got: " . gettype($ktoken));
 188         }
 189         $hm[$ktoken] = $vtoken;
 190     }
 191     return $hm;
 192 }
 193
 194 function _dissoc_BANG($hm) {
 195     $args = func_get_args();
 196     for ($i=1; $i<count($args); $i++) {
 197         $ktoken = $args[$i];
 198         if ($hm && $hm->offsetExists($ktoken)) {
 199             unset($hm[$ktoken]);
 200         }
 201     }
 202     return $hm;
 203 }
 204
 205
 206 // Atoms
 207 class Atom {
 208     public $value = NULL;
 209     public $meta = NULL;
 210     public function __construct($value) {
 211         $this->value = $value;
 212     }
 213 }
 214 function _atom($val) { return new Atom($val); }
 215 function _atom_Q($atm) { return $atm instanceof Atom; }
 216
 217 ?>