Skip to content
This repository
Newer
Older
100644 271 lines (236 sloc) 7.599 kb
fc550b59 » Mikael Bung
2010-04-23 Master merge
1 (function(primitives, ast, interpreter){
2 primitives.prim = function(env) {
3 // data Char#
4
5 // gtChar# :: Char# -> Char# -> Bool
6 env.bind("gtChar#", ["a", "b"], gtPrim);
7
8 // geChar# :: Char# -> Char# -> Bool
9 env.bind("geChar#", ["a", "b"], gePrim);
10
11 // eqChar# :: Char# -> Char# -> Bool
12 env.bind("eqChar#", ["a", "b"], eqPrim);
13
14 // neChar# :: Char# -> Char# -> Bool
15 env.bind("neChar#", ["a", "b"], nePrim);
16
17 // ltChar# :: Char# -> Char# -> Bool
18 env.bind("ltChar#", ["a", "b"], ltPrim);
19
20 // leChar# :: Char# -> Char# -> Bool
21 env.bind("leChar#", ["a", "b"], lePrim);
22
23 // ord# :: Char# -> Int#
24 env.bind("ord#", ["a"],
25 function(env) {
26 var a = env.lookup("a");
27 return a.charCodeAt(0);
28 });
29
30 // data Int#
31 var intSize = 32;
32 // (+#) :: Int# -> Int# -> Int#
33 env.bind("+#", ["a", "b"], primAdd(intSize, true));
34 // (-#) :: Int# -> Int# -> Int#
35 env.bind("-#", ["a", "b"], primSub(intSize, true));
36 // (*#) :: Int# -> Int# -> Int#
37 env.bind("*#", ["a", "b"], primMul(intSize, true));
38 // mulIntMayOflo# :: Int# -> Int# -> Int#
39 // quotInt# :: Int# -> Int# -> Int#
40 env.bind("quotInt#", ["a", "b"], primQuot(intSize, true));
41 // remInt# :: Int# -> Int# -> Int#
42 env.bind("remInt#", ["a", "b"], primRem(intSize, true));
43 // negateInt# :: Int# -> Int#
44 env.bind("negateInt#", ["a", "b"], primNegate(intSize, true));
45 // addIntC# :: Int# -> Int# -> (#Int#, Int##)
46 // subIntC# :: Int# -> Int# -> (#Int#, Int##)
47 // (>#) :: Int# -> Int# -> Bool
48 env.bind(">#", ["a", "b"], gtPrim);
49 // (>=#) :: Int# -> Int# -> Bool
50 env.bind(">=#", ["a", "b"], gePrim);
51 // (==#) :: Int# -> Int# -> Bool
52 env.bind("==#", ["a", "b"], eqPrim);
53 // (/=#) :: Int# -> Int# -> Bool
54 env.bind("/=#", ["a", "b"], nePrim);
55 // (<#) :: Int# -> Int# -> Bool
56 env.bind("<#", ["a", "b"], ltPrim);
57 // (<=#) :: Int# -> Int# -> Bool
58 env.bind("<=#", ["a", "b"], lePrim);
59 // chr# :: Int# -> Char#
60 // int2Word# :: Int# -> Word#
61 env.bind("int2Word#", ["a"], primNarrow(32, false));
62 // int2Float# :: Int# -> Float#
63 env.bind("int2Word#", ["a"], primNarrow(32, true));
64 // int2Double# :: Int# -> Double#
65 env.bind("int2Word#", ["a"], primNarrow(64, true));
66 // uncheckedIShiftL# :: Int# -> Int# -> Int#
67 // uncheckedIShiftRA# :: Int# -> Int# -> Int#
68 // uncheckedIShiftRL# :: Int# -> Int# -> Int#
69 };
70
71 primitives.init = function(env) {
72 primitives.prim(env);
73 // (+) :: Num a => a -> a -> a
74 env.bind("+", createPrimitive(env, ["a", "b"],
75 function(env) {
76 var a = forceHead(env.lookup("a"));
77 var b = forceHead(env.lookup("b"));
78 return new interpreter.ConstantThunk(new ast.Num(a.value.num+b.value.num));
79 }));
80
81 // (-) :: Num a => a -> a -> a
82 env.bind("-", createPrimitive(env, ["a", "b"],
83 function(env) {
84 var a = forceHead(env.lookup("a"));
85 var b = forceHead(env.lookup("b"));
86 return new interpreter.ConstantThunk(new ast.Num(a.value.num-b.value.num));
87 }));
88 // (*) :: Num a => a -> a -> a
89 env.bind("*", createPrimitive(env, ["a", "b"],
90 function(env) {
91 var a = forceHead(env.lookup("a"));
92 var b = forceHead(env.lookup("b"));
93 return new interpreter.ConstantThunk(new ast.Num(a.value.num*b.value.num));
94 }));
95 // primAlert :: String -> a
96 env.bind("alert", createPrimitive(env, ["l"],
97 function(env) {
98 var l = forceHead(env.lookup("l"));
99 alert(l.value.num);
100 return new interpreter.Data("()", []);
101 }));
102
103 // seq :: a -> b -> b
104 env.bind("seq", createPrimitive(env, ["a", "b"],
105 function(env) {
106 env.lookup("a").forceHead();
107 return env.lookup("b");
108 }));
109
110 // Can print all different haskell types (including functions...)
111 // Should be hidden away and only used for the deriving Show implementation.
112 // defaultShow :: a -> String
113 env.bind("defaultShow", createPrimitive(env, ["s"],
114 function(env) {
115 var t = env.lookup("s");
116 }));
117
118 env.bind(":", createDataConstructor(env, ":", 2));
119 env.bind("[]", createDataConstructor(env, "[]", 0));
120 };
121
122 function createPrimitive(env, args, func) {
123 var expr = new ast.Primitive(func);
124 var argsR = [].concat(args).reverse();
125 for (var i in argsR) {
126 expr = new ast.Lambda(new ast.VariableBinding(argsR[i]), expr);
127 };
128 return new interpreter.Closure(env, expr);
129 };
130
131
132 function createDataConstructor(env, ident, num) {
133 var args = [];
134 for (var i = 0; i<num; i++) {
135 args[i] = "__p" + i;
136 };
137 var prim = function(env) {
138 var givenArgs=[];
139 for (var i in args) {
140 givenArgs[i] = env.lookup(args[i]);
141 };
142 return new interpreter.Data(ident, givenArgs);
143 };
144 return createPrimitive(env, args, prim);
145 };
146
147 function forceHead(thunk) {
148 while(thunk.type!="ConstantThunk" && thunk.type!="Data") {
149 thunk=thunk.force();
150 };
151 return thunk;
152 };
153
154
155 function boxBool(env, b) {
156 if (b) {
157 return env.lookup("True");
158 };
159 return env.lookup("False");
160 };
161
162 function gtPrim(env) {
163 var a = env.lookup("a");
164 var b = env.lookup("b");
165 return boxBool(env, a > b);
166 };
167
168 function gePrim(env) {
169 var a = env.lookup("a");
170 var b = env.lookup("b");
171 return boxBool(env, a >= b);
172 };
173
174 function eqPrim(env) {
175 var a = env.lookup("a");
176 var b = env.lookup("b");
177 return boxBool(env, a == b);
178 };
179
180 function nePrim(env) {
181 var a = env.lookup("a");
182 var b = env.lookup("b");
183 return boxBool(env, a != b);
184 };
185
186 function ltPrim(env) {
187 var a = env.lookup("a");
188 var b = env.lookup("b");
189 return boxBool(env, a < b);
190 };
191
192 function lePrim(env) {
193 var a = env.lookup("a");
194 var b = env.lookup("b");
195 return boxBool(env, a <= b);
196 };
197
198 function primAdd(bits, twoComplement) {
199 return function(env) {
200 var a = env.lookup("a");
201 var b = env.lookup("b");
202 var result = a + b;
203 return doPrimOverflow(bits, twoComplement, result);
204 };
205 };
206
207 function primSub(bits, twoComplement) {
208 return function(env) {
209 var a = env.lookup("a");
210 var b = env.lookup("b");
211 var result = a - b;
212 return doPrimOverflow(bits, twoComplement, result);
213 };
214 };
215
216 function primMul(bits, twoComplement) {
217 return function(env) {
218 var a = env.lookup("a");
219 var b = env.lookup("b");
220 var result = a * b;
221 return doPrimOverflow(bits, twoComplement, result);
222 };
223 };
224
225 function primQuot(bits, twoComplement) {
226 return function(env) {
227 var a = env.lookup("a");
228 var b = env.lookup("b");
229 var result = parseInt(a / b);
230 return doPrimOverflow(bits, twoComplement, result);
231 };
232 };
233
234 function primRem(bits, twoComplement) {
235 return function(env) {
236 var a = env.lookup("a");
237 var b = env.lookup("b");
238 var result = a % b;
239 return doPrimOverflow(bits, twoComplement, result);
240 };
241 };
242
243 function primNegate(bits, twoComplement) {
244 return function(env) {
245 var a = env.lookup("a");
246 var result = -a;
247 return doPrimOverflow(bits, twoComplement, result);
248 };
249 };
250
251 function primNarrow(bits, twoComplement) {
252 return function(env) {
253 return doPrimNarrow(bits, twoComplement, env.lookup("a"));
254 };
255 };
256
257 // Narrows a number by chopping of the higher bits
258 function doPrimNarrow(bits, twoComplement, num) {
259 num = num & (Math.pow(2, bits+1) - 1);
260 if (twoComplement && (num & Math.pow(2, bits))) {
261 return num - Math.pow(2, bits);
262 };
263 return num;
264 };
265
266 // Narrows a number by overflowing it
267 function doPrimOverflow(bits, twoComplement, num) {
268 return doPrimNarrow(bits, twoComplement, num);
269 };
270
271 })(haskell.primitives, haskell.ast, haskell.interpreter);
Something went wrong with that request. Please try again.