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