Source code: com/memoire/silk/SilkPrimitive.java
1
2
3 package com.memoire.silk;
4 import com.memoire.silk.*;
5
6
7 import java.io.*;
8
9 /** A primitive is a procedure that is defined as part of the SilkScheme report,
10 * and is implemented in Java code.
11 * @author Peter Norvig, peter@norvig.com http://www.norvig.com
12 * Copyright 1998 Peter Norvig, see http://www.norvig.com/license.html **/
13
14 public class SilkPrimitive extends SilkProcedure {
15
16 int minArgs;
17 int maxArgs;
18 int idNumber;
19
20 public SilkPrimitive(int id, int minArgs, int maxArgs) {
21 this.idNumber = id; this.minArgs = minArgs; this.maxArgs = maxArgs;
22 }
23
24 private static final int EQ = 0, LT = 1, GT = 2, GE = 3, LE = 4,
25 ABS = 5, EOF_OBJECT = 6, EQQ = 7, EQUALQ = 8, FORCE = 9,
26 CAR = 10, FLOOR = 11, CEILING = 12, CONS = 13,
27 DIVIDE= 14, LENGTH = 15, LIST = 16, LISTQ = 17, APPLY = 18,
28 MAX = 19, MIN = 20, MINUS = 21, NEWLINE = 22,
29 NOT = 23, NULLQ = 24, NUMBERQ = 25, PAIRQ = 26, PLUS = 27,
30 PROCEDUREQ = 28, READ = 29, CDR = 30, ROUND = 31, SECOND = 32,
31 SYMBOLQ = 33, TIMES = 34, TRUNCATE = 35, WRITE = 36, APPEND = 37,
32 BOOLEANQ = 38, SQRT = 39, EXPT = 40, REVERSE = 41, ASSOC = 42,
33 ASSQ = 43, ASSV = 44, MEMBER = 45, MEMQ = 46, MEMV = 47, EQVQ = 48,
34 LISTREF = 49, LISTTAIL = 50, STRINQ = 51, MAKESTRING = 52, STRING = 53,
35 STRINGLENGTH = 54, STRINGREF = 55, STRINGSET = 56, SUBSTRING = 57,
36 STRINGAPPEND = 58, STRINGTOLIST = 59, LISTTOSTRING = 60,
37 SYMBOLTOSTRING = 61, STRINGTOSYMBOL = 62, EXP = 63, LOG = 64, SIN = 65,
38 COS = 66, TAN = 67, ACOS = 68, ASIN = 69, ATAN = 70,
39 NUMBERTOSTRING = 71, STRINGTONUMBER = 72, CHARQ = 73,
40 CHARALPHABETICQ = 74, CHARNUMERICQ = 75, CHARWHITESPACEQ = 76,
41 CHARUPPERCASEQ = 77, CHARLOWERCASEQ = 78, CHARTOINTEGER = 79,
42 INTEGERTOCHAR = 80, CHARUPCASE = 81, CHARDOWNCASE = 82, STRINGQ = 83,
43 VECTORQ = 84, MAKEVECTOR = 85, VECTOR = 86, VECTORLENGTH = 87,
44 VECTORREF = 88, VECTORSET = 89, LISTTOVECTOR = 90, MAP = 91,
45 FOREACH = 92, CALLCC = 93, VECTORTOLIST = 94, LOAD = 95, DISPLAY = 96,
46 INPUTPORTQ = 98, CURRENTINPUTPORT = 99, OPENINPUTFILE = 100,
47 CLOSEINPUTPORT = 101, OUTPUTPORTQ = 103, CURRENTOUTPUTPORT = 104,
48 OPENOUTPUTFILE = 105, CLOSEOUTPUTPORT = 106, READCHAR = 107,
49 PEEKCHAR = 108, EVAL = 109, QUOTIENT = 110, REMAINDER = 111,
50 MODULO = 112, THIRD = 113, EOFOBJECTQ = 114, GCD = 115, LCM = 116,
51 CXR = 117, ODDQ = 118, EVENQ = 119, ZEROQ = 120, POSITIVEQ = 121,
52 NEGATIVEQ = 122,
53 CHARCMP = 123 /* to 127 */, CHARCICMP = 128 /* to 132 */,
54 STRINGCMP = 133 /* to 137 */, STRINGCICMP = 138 /* to 142 */,
55 EXACTQ = 143, INEXACTQ = 144, INTEGERQ = 145,
56 CALLWITHINPUTFILE = 146, CALLWITHOUTPUTFILE = 147
57 ;
58
59 //////////////// Extensions ////////////////
60
61 static final int NEW = -1, CLASS = -2, METHOD = -3, EXIT = -4,
62 SETCAR = -5, SETCDR = -6, TIMECALL = -11, MACROEXPAND = -12,
63 ERROR = -13, LISTSTAR = -14
64 ;
65
66
67 public static SilkEnvironment installSilkPrimitives(SilkEnvironment env) {
68
69 int n = Integer.MAX_VALUE;
70
71 env
72 .defPrim("*", TIMES, 0, n)
73 .defPrim("*", TIMES, 0, n)
74 .defPrim("+", PLUS, 0, n)
75 .defPrim("-", MINUS, 1, n)
76 .defPrim("/", DIVIDE, 1, n)
77 .defPrim("<", LT, 2, n)
78 .defPrim("<=", LE, 2, n)
79 .defPrim("=", EQ, 2, n)
80 .defPrim(">", GT, 2, n)
81 .defPrim(">=", GE, 2, n)
82 .defPrim("abs", ABS, 1)
83 .defPrim("acos", ACOS, 1)
84 .defPrim("append", APPEND, 0, n)
85 .defPrim("apply", APPLY, 2, n)
86 .defPrim("asin", ASIN, 1)
87 .defPrim("assoc", ASSOC, 2)
88 .defPrim("assq", ASSQ, 2)
89 .defPrim("assv", ASSV, 2)
90 .defPrim("atan", ATAN, 1)
91 .defPrim("boolean?", BOOLEANQ, 1)
92 .defPrim("caaaar", CXR, 1)
93 .defPrim("caaadr", CXR, 1)
94 .defPrim("caaar", CXR, 1)
95 .defPrim("caadar", CXR, 1)
96 .defPrim("caaddr", CXR, 1)
97 .defPrim("caadr", CXR, 1)
98 .defPrim("caar", CXR, 1)
99 .defPrim("cadaar", CXR, 1)
100 .defPrim("cadadr", CXR, 1)
101 .defPrim("cadar", CXR, 1)
102 .defPrim("caddar", CXR, 1)
103 .defPrim("cadddr", CXR, 1)
104 .defPrim("caddr", THIRD, 1)
105 .defPrim("cadr", SECOND, 1)
106 .defPrim("call-with-current-continuation", CALLCC, 1)
107 .defPrim("call-with-input-file", CALLWITHINPUTFILE, 2)
108 .defPrim("call-with-output-file", CALLWITHOUTPUTFILE, 2)
109 .defPrim("car", CAR, 1)
110 .defPrim("cdaaar", CXR, 1)
111 .defPrim("cdaadr", CXR, 1)
112 .defPrim("cdaar", CXR, 1)
113 .defPrim("cdadar", CXR, 1)
114 .defPrim("cdaddr", CXR, 1)
115 .defPrim("cdadr", CXR, 1)
116 .defPrim("cdar", CXR, 1)
117 .defPrim("cddaar", CXR, 1)
118 .defPrim("cddadr", CXR, 1)
119 .defPrim("cddar", CXR, 1)
120 .defPrim("cdddar", CXR, 1)
121 .defPrim("cddddr", CXR, 1)
122 .defPrim("cdddr", CXR, 1)
123 .defPrim("cddr", CXR, 1)
124 .defPrim("cdr", CDR, 1)
125 .defPrim("char->integer", CHARTOINTEGER, 1)
126 .defPrim("char-alphabetic?",CHARALPHABETICQ, 1)
127 .defPrim("char-ci<=?", CHARCICMP+LE, 2)
128 .defPrim("char-ci<?" , CHARCICMP+LT, 2)
129 .defPrim("char-ci=?" , CHARCICMP+EQ, 2)
130 .defPrim("char-ci>=?", CHARCICMP+GE, 2)
131 .defPrim("char-ci>?" , CHARCICMP+GT, 2)
132 .defPrim("char-downcase", CHARDOWNCASE, 1)
133 .defPrim("char-lower-case?",CHARLOWERCASEQ, 1)
134 .defPrim("char-numeric?", CHARNUMERICQ, 1)
135 .defPrim("char-upcase", CHARUPCASE, 1)
136 .defPrim("char-upper-case?",CHARUPPERCASEQ, 1)
137 .defPrim("char-whitespace?",CHARWHITESPACEQ, 1)
138 .defPrim("char<=?", CHARCMP+LE, 2)
139 .defPrim("char<?", CHARCMP+LT, 2)
140 .defPrim("char=?", CHARCMP+EQ, 2)
141 .defPrim("char>=?", CHARCMP+GE, 2)
142 .defPrim("char>?", CHARCMP+GT, 2)
143 .defPrim("char?", CHARQ, 1)
144 .defPrim("close-input-port", CLOSEINPUTPORT, 1)
145 .defPrim("close-output-port", CLOSEOUTPUTPORT, 1)
146 .defPrim("complex?", NUMBERQ, 1)
147 .defPrim("cons", CONS, 2)
148 .defPrim("cos", COS, 1)
149 .defPrim("current-input-port", CURRENTINPUTPORT, 0)
150 .defPrim("current-output-port", CURRENTOUTPUTPORT, 0)
151 .defPrim("display", DISPLAY, 1, 2)
152 .defPrim("eof-object?", EOFOBJECTQ, 1)
153 .defPrim("eq?", EQQ, 2)
154 .defPrim("equal?", EQUALQ, 2)
155 .defPrim("eqv?", EQVQ, 2)
156 .defPrim("eval", EVAL, 1, 2)
157 .defPrim("even?", EVENQ, 1)
158 .defPrim("exact?", INTEGERQ, 1)
159 .defPrim("exp", EXP, 1)
160 .defPrim("expt", EXPT, 2)
161 .defPrim("force", FORCE, 1)
162 .defPrim("for-each", FOREACH, 1, n)
163 .defPrim("gcd", GCD, 0, n)
164 .defPrim("inexact?", INEXACTQ, 1)
165 .defPrim("input-port?", INPUTPORTQ, 1)
166 .defPrim("integer->char", INTEGERTOCHAR, 1)
167 .defPrim("integer?", INTEGERQ, 1)
168 .defPrim("lcm", LCM, 0, n)
169 .defPrim("length", LENGTH, 1)
170 .defPrim("list", LIST, 0, n)
171 .defPrim("list->string", LISTTOSTRING, 1)
172 .defPrim("list->vector", LISTTOVECTOR, 1)
173 .defPrim("list-ref", LISTREF, 2)
174 .defPrim("list-tail", LISTTAIL, 2)
175 .defPrim("list?", LISTQ, 1)
176 .defPrim("load", LOAD, 1)
177 .defPrim("log", LOG, 1)
178 .defPrim("macro-expand", MACROEXPAND,1)
179 .defPrim("make-string", MAKESTRING,1, 2)
180 .defPrim("make-vector", MAKEVECTOR,1, 2)
181 .defPrim("map", MAP, 1, n)
182 .defPrim("max", MAX, 1, n)
183 .defPrim("member", MEMBER, 2)
184 .defPrim("memq", MEMQ, 2)
185 .defPrim("memv", MEMV, 2)
186 .defPrim("min", MIN, 1, n)
187 .defPrim("modulo", MODULO, 2)
188 .defPrim("negative?", NEGATIVEQ, 1)
189 .defPrim("newline", NEWLINE, 0, 1)
190 .defPrim("not", NOT, 1)
191 .defPrim("null?", NULLQ, 1)
192 .defPrim("number->string", NUMBERTOSTRING, 1, 2)
193 .defPrim("number?", NUMBERQ, 1)
194 .defPrim("odd?", ODDQ, 1)
195 .defPrim("open-input-file",OPENINPUTFILE, 1)
196 .defPrim("open-output-file", OPENOUTPUTFILE, 1)
197 .defPrim("output-port?", OUTPUTPORTQ, 1)
198 .defPrim("pair?", PAIRQ, 1)
199 .defPrim("peek-char", PEEKCHAR, 0, 1)
200 .defPrim("positive?", POSITIVEQ, 1)
201 .defPrim("procedure?", PROCEDUREQ,1)
202 .defPrim("quotient", QUOTIENT, 2)
203 .defPrim("rational?", INTEGERQ, 1)
204 .defPrim("read", READ, 0, 1)
205 .defPrim("read-char", READCHAR, 0, 1)
206 .defPrim("real?", NUMBERQ, 1)
207 .defPrim("remainder", REMAINDER, 2)
208 .defPrim("reverse", REVERSE, 1)
209 .defPrim("round", ROUND, 1)
210 .defPrim("set-car!", SETCAR, 2)
211 .defPrim("set-cdr!", SETCDR, 2)
212 .defPrim("sin", SIN, 1)
213 .defPrim("sqrt", SQRT, 1)
214 .defPrim("string", STRING, 0, n)
215 .defPrim("string->list", STRINGTOLIST, 1)
216 .defPrim("string->number", STRINGTONUMBER, 1, 2)
217 .defPrim("string->symbol", STRINGTOSYMBOL, 1)
218 .defPrim("string-append", STRINGAPPEND, 0, n)
219 .defPrim("string-ci<=?", STRINGCICMP+LE, 2)
220 .defPrim("string-ci<?" , STRINGCICMP+LT, 2)
221 .defPrim("string-ci=?" , STRINGCICMP+EQ, 2)
222 .defPrim("string-ci>=?", STRINGCICMP+GE, 2)
223 .defPrim("string-ci>?" , STRINGCICMP+GT, 2)
224 .defPrim("string-length", STRINGLENGTH, 1)
225 .defPrim("string-ref", STRINGREF, 2)
226 .defPrim("string-set!", STRINGSET, 3)
227 .defPrim("string<=?", STRINGCMP+LE, 2)
228 .defPrim("string<?", STRINGCMP+LT, 2)
229 .defPrim("string=?", STRINGCMP+EQ, 2)
230 .defPrim("string>=?", STRINGCMP+GE, 2)
231 .defPrim("string>?", STRINGCMP+GT, 2)
232 .defPrim("string?", STRINGQ, 1)
233 .defPrim("substring", SUBSTRING, 3)
234 .defPrim("symbol->string", SYMBOLTOSTRING, 1)
235 .defPrim("symbol?", SYMBOLQ, 1)
236 .defPrim("tan", TAN, 1)
237 .defPrim("vector", VECTOR, 0, n)
238 .defPrim("vector->list", VECTORTOLIST, 1)
239 .defPrim("vector-length", VECTORLENGTH, 1)
240 .defPrim("vector-ref", VECTORREF, 2)
241 .defPrim("vector-set!", VECTORSET, 3)
242 .defPrim("vector?", VECTORQ, 1)
243 .defPrim("write", WRITE, 1, 2)
244 .defPrim("write-char", DISPLAY, 1, 2)
245 .defPrim("zero?", ZEROQ, 1)
246
247 ///////////// Extensions ////////////////
248
249 .defPrim("new", NEW, 1)
250 .defPrim("class", CLASS, 1)
251 .defPrim("method", METHOD, 2, n)
252 .defPrim("exit", EXIT, 0, 1)
253 .defPrim("error", ERROR, 0, n)
254 .defPrim("time-call", TIMECALL, 1, 2)
255 .defPrim("_list*", LISTSTAR, 0, n)
256 ;
257
258 return env;
259 }
260
261 /** Apply a primitive to a list of arguments. **/
262 public Object apply(SilkScheme interp, Object args) {
263 //First make sure there are the right number of arguments.
264 int nArgs = length(args);
265 if (nArgs < minArgs)
266 return error("too few args, " + nArgs +
267 ", for " + this.name + ": " + args);
268 else if (nArgs > maxArgs)
269 return error("too many args, " + nArgs +
270 ", for " + this.name + ": " + args);
271
272 Object x = first(args);
273 Object y = second(args);
274
275 switch (idNumber) {
276
277 //////////////// SECTION 6.1 BOOLEANS
278 case NOT: return truth(x == FALSE);
279 case BOOLEANQ: return truth(x == TRUE || x == FALSE);
280
281 //////////////// SECTION 6.2 EQUIVALENCE PREDICATES
282 case EQVQ: return truth(eqv(x, y));
283 case EQQ: return truth(x == y);
284 case EQUALQ: return truth(equal(x,y));
285
286 //////////////// SECTION 6.3 LISTS AND PAIRS
287 case PAIRQ: return truth(x instanceof SilkPair);
288 case LISTQ: return truth(isList(x));
289 case CXR: for (int i = name.length()-2; i >= 1; i--)
290 x = (name.charAt(i) == 'a') ? first(x) : rest(x);
291 return x;
292 case CONS: return cons(x, y);
293 case CAR: return first(x);
294 case CDR: return rest(x);
295 case SETCAR: return setFirst(x, y);
296 case SETCDR: return setRest(x, y);
297 case SECOND: return second(x);
298 case THIRD: return third(x);
299 case NULLQ: return truth(x == null);
300 case LIST: return args;
301 case LENGTH: return num(length(x));
302 case APPEND: return (args == null) ? null : append(args);
303 case REVERSE: return reverse(x);
304 case LISTTAIL: for (int k = (int)num(y); k>0; k--) x = rest(x);
305 return x;
306 case LISTREF: for (int k = (int)num(y); k>0; k--) x = rest(x);
307 return first(x);
308 case MEMQ: return memberAssoc(x, y, 'm', 'q');
309 case MEMV: return memberAssoc(x, y, 'm', 'v');
310 case MEMBER: return memberAssoc(x, y, 'm', ' ');
311 case ASSQ: return memberAssoc(x, y, 'a', 'q');
312 case ASSV: return memberAssoc(x, y, 'a', 'v');
313 case ASSOC: return memberAssoc(x, y, 'a', ' ');
314
315 //////////////// SECTION 6.4 SYMBOLS
316 case SYMBOLQ: return truth(x instanceof String);
317 case SYMBOLTOSTRING:return sym(x).toCharArray();
318 case STRINGTOSYMBOL:return new String(str(x)).intern();
319
320 //////////////// SECTION 6.5 NUMBERS
321 case NUMBERQ: return truth(x instanceof Number);
322 case ODDQ: return truth(Math.abs(num(x)) % 2 != 0);
323 case EVENQ: return truth(Math.abs(num(x)) % 2 == 0);
324 case ZEROQ: return truth(num(x) == 0);
325 case POSITIVEQ: return truth(num(x) > 0);
326 case NEGATIVEQ: return truth(num(x) < 0);
327 case INTEGERQ: return truth(isExact(x));
328 case INEXACTQ: return truth(!isExact(x));
329 case LT: return numCompare(args, '<');
330 case GT: return numCompare(args, '>');
331 case EQ: return numCompare(args, '=');
332 case LE: return numCompare(args, 'L');
333 case GE: return numCompare(args, 'G');
334 case MAX: return numCompute(args, 'X', num(x));
335 case MIN: return numCompute(args, 'N', num(x));
336 case PLUS: return numCompute(args, '+', 0.0);
337 case MINUS: return numCompute(rest(args), '-', num(x));
338 case TIMES: return numCompute(args, '*', 1.0);
339 case DIVIDE: return numCompute(rest(args), '/', num(x));
340 case QUOTIENT: double d = num(x)/num(y);
341 return num(d > 0 ? Math.floor(d) : Math.ceil(d));
342 case REMAINDER: return num((long)num(x) % (long)num(y));
343 case MODULO: long xi = (long)num(x), yi = (long)num(y), m = xi % yi;
344 return num((xi*yi > 0 || m == 0) ? m : m + yi);
345 case ABS: return num(Math.abs(num(x)));
346 case FLOOR: return num(Math.floor(num(x)));
347 case CEILING: return num(Math.ceil(num(x)));
348 case TRUNCATE: d = num(x);
349 return num((d < 0.0) ? Math.ceil(d) : Math.floor(d));
350 case ROUND: return num(Math.round(num(x)));
351 case EXP: return num(Math.exp(num(x)));
352 case LOG: return num(Math.log(num(x)));
353 case SIN: return num(Math.sin(num(x)));
354 case COS: return num(Math.cos(num(x)));
355 case TAN: return num(Math.tan(num(x)));
356 case ASIN: return num(Math.asin(num(x)));
357 case ACOS: return num(Math.acos(num(x)));
358 case ATAN: return num(Math.atan(num(x)));
359 case SQRT: return num(Math.sqrt(num(x)));
360 case EXPT: return num(Math.pow(num(x), num(y)));
361 case NUMBERTOSTRING:return numberToString(x, y);
362 case STRINGTONUMBER:return stringToNumber(x, y);
363 case GCD: return (args == null) ? ZERO : gcd(args);
364 case LCM: return (args == null) ? ONE : lcm(args);
365
366 //////////////// SECTION 6.6 CHARACTERS
367 case CHARQ: return truth(x instanceof Character);
368 case CHARALPHABETICQ: return truth(Character.isLetter(chr(x)));
369 case CHARNUMERICQ: return truth(Character.isDigit(chr(x)));
370 case CHARWHITESPACEQ: return truth(Character.isWhitespace(chr(x)));
371 case CHARUPPERCASEQ: return truth(Character.isUpperCase(chr(x)));
372 case CHARLOWERCASEQ: return truth(Character.isLowerCase(chr(x)));
373 case CHARTOINTEGER: return new Double((double)chr(x));
374 case INTEGERTOCHAR: return chr((char)(int)num(x));
375 case CHARUPCASE: return chr(Character.toUpperCase(chr(x)));
376 case CHARDOWNCASE: return chr(Character.toLowerCase(chr(x)));
377 case CHARCMP+EQ: return truth(charCompare(x, y, false) == 0);
378 case CHARCMP+LT: return truth(charCompare(x, y, false) < 0);
379 case CHARCMP+GT: return truth(charCompare(x, y, false) > 0);
380 case CHARCMP+GE: return truth(charCompare(x, y, false) >= 0);
381 case CHARCMP+LE: return truth(charCompare(x, y, false) <= 0);
382 case CHARCICMP+EQ: return truth(charCompare(x, y, true) == 0);
383 case CHARCICMP+LT: return truth(charCompare(x, y, true) < 0);
384 case CHARCICMP+GT: return truth(charCompare(x, y, true) > 0);
385 case CHARCICMP+GE: return truth(charCompare(x, y, true) >= 0);
386 case CHARCICMP+LE: return truth(charCompare(x, y, true) <= 0);
387
388 case ERROR: return error(stringify(args));
389
390 //////////////// SECTION 6.7 STRINGS
391 case STRINGQ: return truth(x instanceof char[]);
392 case MAKESTRING:char[] str = new char[(int)num(x)];
393 if (y != null) {
394 char c = chr(y);
395 for (int i = str.length-1; i >= 0; i--) str[i] = c;
396 }
397 return str;
398 case STRING: return listToString(args);
399 case STRINGLENGTH: return num(str(x).length);
400 case STRINGREF: return chr(str(x)[(int)num(y)]);
401 case STRINGSET: Object z = third(args); str(x)[(int)num(y)] = chr(z);
402 return z;
403 case SUBSTRING: int start = (int)num(y), end = (int)num(third(args));
404 return new String(str(x), start, end-start).toCharArray();
405 case STRINGAPPEND: return stringAppend(args);
406 case STRINGTOLIST: SilkPair result = null;
407 char[] str2 = str(x);
408 for (int i = str2.length-1; i >= 0; i--)
409 result = cons(chr(str2[i]), result);
410 return result;
411 case LISTTOSTRING: return listToString(x);
412 case STRINGCMP+EQ: return truth(stringCompare(x, y, false) == 0);
413 case STRINGCMP+LT: return truth(stringCompare(x, y, false) < 0);
414 case STRINGCMP+GT: return truth(stringCompare(x, y, false) > 0);
415 case STRINGCMP+GE: return truth(stringCompare(x, y, false) >= 0);
416 case STRINGCMP+LE: return truth(stringCompare(x, y, false) <= 0);
417 case STRINGCICMP+EQ:return truth(stringCompare(x, y, true) == 0);
418 case STRINGCICMP+LT:return truth(stringCompare(x, y, true) < 0);
419 case STRINGCICMP+GT:return truth(stringCompare(x, y, true) > 0);
420 case STRINGCICMP+GE:return truth(stringCompare(x, y, true) >= 0);
421 case STRINGCICMP+LE:return truth(stringCompare(x, y, true) <= 0);
422
423 //////////////// SECTION 6.8 VECTORS
424 case VECTORQ: return truth(x instanceof Object[]);
425 case MAKEVECTOR: Object[] vec = new Object[(int)num(x)];
426 if (y != null) {
427 for (int i = 0; i < vec.length; i++) vec[i] = y;
428 }
429 return vec;
430 case VECTOR: return listToVector(args);
431 case VECTORLENGTH: return num(vec(x).length);
432 case VECTORREF: return vec(x)[(int)num(y)];
433 case VECTORSET: return vec(x)[(int)num(y)] = third(args);
434 case VECTORTOLIST: return vectorToList(x);
435 case LISTTOVECTOR: return listToVector(x);
436
437 //////////////// SECTION 6.9 CONTROL FEATURES
438 case EVAL: return interp.eval(x);
439 case FORCE: return (!(x instanceof SilkProcedure)) ? x
440 : proc(x).apply(interp, null);
441 case MACROEXPAND: return SilkMacro.macroExpand(interp, x);
442 case PROCEDUREQ: return truth(x instanceof SilkProcedure);
443 case APPLY: return proc(x).apply(interp, listStar(rest(args)));
444 case MAP: return map(proc(x), rest(args), interp, list(null));
445 case FOREACH: return map(proc(x), rest(args), interp, null);
446 case CALLCC: RuntimeException cc = new RuntimeException();
447 SilkContinuation proc = new SilkContinuation(cc);
448 try { return proc(x).apply(interp, list(proc)); }
449 catch (RuntimeException e) {
450 if (e == cc) return proc.value; else throw e;
451 }
452
453 //////////////// SECTION 6.10 INPUT AND OUPUT
454 case EOFOBJECTQ: return truth(x == SilkInputPort.EOF);
455 case INPUTPORTQ: return truth(x instanceof SilkInputPort);
456 case CURRENTINPUTPORT: return interp.input;
457 case OPENINPUTFILE: return openInputFile(x);
458 case CLOSEINPUTPORT: return inPort(x, interp).close();
459 case OUTPUTPORTQ: return truth(x instanceof PrintWriter);
460 case CURRENTOUTPUTPORT: return interp.output;
461 case OPENOUTPUTFILE: return openOutputFile(x);
462 case CALLWITHOUTPUTFILE: PrintWriter p = null;
463 try { p = openOutputFile(x);
464 z = proc(y).apply(interp, list(p));
465 } finally { if (p != null) p.close(); }
466 return z;
467 case CALLWITHINPUTFILE: SilkInputPort p2 = null;
468 try { p2 = openInputFile(x);
469 z = proc(y).apply(interp, list(p2));
470 } finally { if (p2 != null) p2.close(); }
471 return z;
472 case CLOSEOUTPUTPORT: outPort(x, interp).close(); return TRUE;
473 case READCHAR: return inPort(x, interp).readChar();
474 case PEEKCHAR: return inPort(x, interp).peekChar();
475 case LOAD: return interp.load(x);
476 case READ: return inPort(x, interp).read();
477 case EOF_OBJECT: return truth(SilkInputPort.isEOF(x));
478 case WRITE: return write(x, outPort(y, interp), true);
479 case DISPLAY: return write(x, outPort(y, interp), false);
480 case NEWLINE: outPort(x, interp).println();
481 outPort(x, interp).flush(); return TRUE;
482
483 //////////////// EXTENSIONS
484 case CLASS: try { return Class.forName(stringify(x, false)); }
485 catch (ClassNotFoundException e) { return FALSE; }
486 case NEW: try { return SilkJavaMethod.toClass(x).newInstance(); }
487 catch (ClassCastException e) { ; }
488 catch (NoSuchMethodError e) { ; }
489 catch (InstantiationException e) { ; }
490 catch (ClassNotFoundException e) { ; }
491 catch (IllegalAccessException e) { ; }
492 return FALSE;
493 case METHOD: return new SilkJavaMethod(stringify(x, false), y,
494 rest(rest(args)));
495 case EXIT:
496 //System.exit((x == null) ? 0 : (int)num(x));
497 // @GDX
498 interp.exit();
499 return FALSE;
500 case LISTSTAR: return listStar(args);
501 case TIMECALL: Runtime runtime = Runtime.getRuntime();
502 runtime.gc();
503 long startTime = System.currentTimeMillis();
504 long startMem = runtime.freeMemory();
505 Object ans = FALSE;
506 int nTimes = (y == null ? 1 : (int)num(y));
507 for (int i = 0; i < nTimes; i++) {
508 ans = proc(x).apply(interp, null);
509 }
510 long time = System.currentTimeMillis() - startTime;
511 long mem = startMem - runtime.freeMemory();
512 return cons(ans, list(list(num(time), "msec"),
513 list(num(mem), "bytes")));
514 default: return error("internal error: unknown primitive: "
515 + this + " applied to " + args);
516 }
517 }
518
519 public static char[] stringAppend(Object args) {
520 StringBuffer result = new StringBuffer();
521 for(; args instanceof SilkPair; args = rest(args)) {
522 result.append(stringify(first(args), false));
523 }
524 return result.toString().toCharArray();
525 }
526
527 public static Object memberAssoc(Object obj, Object list, char m, char eq) {
528 while (list instanceof SilkPair) {
529 Object target = (m == 'm') ? first(list) : first(first(list));
530 boolean found;
531 switch (eq) {
532 case 'q': found = (target == obj); break;
533 case 'v': found = eqv(target, obj); break;
534 case ' ': found = equal(target, obj); break;
535 default: warn("Bad option to memberAssoc:" + eq); return FALSE;
536 }
537 if (found) return (m == 'm') ? list : first(list);
538 list = rest(list);
539 }
540 return FALSE;
541 }
542
543 public static Object numCompare(Object args, char op) {
544 while (rest(args) instanceof SilkPair) {
545 double x = num(first(args)); args = rest(args);
546 double y = num(first(args));
547 switch (op) {
548 case '>': if (!(x > y)) return FALSE; break;
549 case '<': if (!(x < y)) return FALSE; break;
550 case '=': if (!(x == y)) return FALSE; break;
551 case 'L': if (!(x <= y)) return FALSE; break;
552 case 'G': if (!(x >= y)) return FALSE; break;
553 default: error("internal error: unrecognized op: " + op); break;
554 }
555 }
556 return TRUE;
557 }
558
559 public static Object numCompute(Object args, char op, double result) {
560 if (args == null) {
561 switch (op) {
562 case '-': return num(0 - result);
563 case '/': return num(1 / result);
564 default: return num(result);
565 }
566 } else {
567 while (args instanceof SilkPair) {
568 double x = num(first(args)); args = rest(args);
569 switch (op) {
570 case 'X': if (x > result) result = x; break;
571 case 'N': if (x < result) result = x; break;
572 case '+': result += x; break;
573 case '-': result -= x; break;
574 case '*': result *= x; break;
575 case '/': result /= x; break;
576 default: error("internal error: unrecognized op: " + op); break;
577 }
578 }
579 return num(result);
580 }
581 }
582
583 /** Return the sign of the argument: +1, -1, or 0. **/
584 static int sign(int x) { return (x > 0) ? +1 : (x < 0) ? -1 : 0; }
585
586 /** Return <0 if x is alphabetically first, >0 if y is first,
587 * 0 if same. Case insensitive iff ci is true. Error if not both chars. **/
588 public static int charCompare(Object x, Object y, boolean ci) {
589 char xc = chr(x), yc = chr(y);
590 if (ci) { xc = Character.toLowerCase(xc); yc = Character.toLowerCase(yc); }
591 return xc - yc;
592 }
593
594 /** Return <0 if x is alphabetically first, >0 if y is first,
595 * 0 if same. Case insensitive iff ci is true. Error if not strings. **/
596 public static int stringCompare(Object x, Object y, boolean ci) {
597 if (x instanceof char[] && y instanceof char[]) {
598 char[] xc = (char[])x, yc = (char[])y;
599 for (int i = 0; i < xc.length; i++) {
600 int diff = (!ci) ? xc[i] - yc[i]
601 : Character.toUpperCase(xc[i]) - Character.toUpperCase(yc[i]);
602 if (diff != 0) return diff;
603 }
604 return xc.length - yc.length;
605 } else {
606 error("expected two strings, got: " + stringify(list(x, y)));
607 return 0;
608 }
609 }
610
611 static Object numberToString(Object x, Object y) {
612 int base = (y instanceof Number) ? (int)num(y) : 10;
613 if (base != 10 || num(x) == Math.round(num(x))) {
614 // An integer
615 return Long.toString((long)num(x), base).toCharArray();
616 } else {
617 // A floating point number
618 return x.toString().toCharArray();
619 }
620 }
621
622 static Object stringToNumber(Object x, Object y) {
623 int base = (y instanceof Number) ? (int)num(y) : 10;
624 try {
625 return (base == 10)
626 ? Double.valueOf(stringify(x, false))
627 : num(Long.parseLong(stringify(x, false), base));
628 } catch (NumberFormatException e) { return FALSE; }
629 }
630
631 static Object gcd(Object args) {
632 long gcd = 0;
633 while (args instanceof SilkPair) {
634 gcd = gcd2(Math.abs((long)num(first(args))), gcd);
635 args = rest(args);
636 }
637 return num(gcd);
638 }
639
640 static long gcd2(long a, long b) {
641 if (b == 0) return a;
642 else return gcd2(b, a % b);
643 }
644
645 static Object lcm(Object args) {
646 long L = 1, g = 1;
647 while (args instanceof SilkPair) {
648 long n = Math.abs((long)num(first(args)));
649 g = gcd2(n, L);
650 L = (g == 0) ? g : (n / g) * L;
651 args = rest(args);
652 }
653 return num(L);
654 }
655
656 static boolean isExact(Object x) {
657 if (!(x instanceof Double)) return false;
658 double d = num(x);
659 return (d == Math.round(d) && Math.abs(d) < 102962884861573423.0);
660 }
661
662 static PrintWriter openOutputFile(Object filename) {
663 try {
664 return new PrintWriter(new FileWriter(stringify(filename, false)));
665 } catch (FileNotFoundException e) {
666 return (PrintWriter)error("No such file: " + stringify(filename));
667 } catch (IOException e) {
668 return (PrintWriter)error("IOException: " + e);
669 }
670 }
671
672 static SilkInputPort openInputFile(Object filename) {
673 try {
674 return new SilkInputPort(new FileInputStream(stringify(filename, false)));
675 } catch (FileNotFoundException e) {
676 return (SilkInputPort)error("No such file: " + stringify(filename));
677 } catch (IOException e) {
678 return (SilkInputPort)error("IOException: " + e);
679 }
680 }
681
682 static boolean isList(Object x) {
683 Object slow = x, fast = x;
684 for(;;) {
685 if (fast == null) return true;
686 if (slow == rest(fast) || !(fast instanceof SilkPair)
687 || !(slow instanceof SilkPair)) return false;
688 slow = rest(slow);
689 fast = rest(fast);
690 if (fast == null) return true;
691 if (!(fast instanceof SilkPair)) return false;
692 fast = rest(fast);
693 }
694 }
695
696 static Object append(Object args) {
697 if (rest(args) == null) return first(args);
698 else return append2(first(args), append(rest(args)));
699 }
700
701 static Object append2(Object x, Object y) {
702 if (x instanceof SilkPair) return cons(first(x), append2(rest(x), y));
703 else return y;
704 }
705
706 /** Map proc over a list of lists of args, in the given interpreter.
707 * If result is non-null, accumulate the results of each call there
708 * and return that at the end. Otherwise, just return null. **/
709 static SilkPair map(SilkProcedure proc, Object args, SilkScheme interp, SilkPair result) {
710 SilkPair accum = result;
711 if (rest(args) == null) {
712 args = first(args);
713 while (args instanceof SilkPair) {
714 Object x = proc.apply(interp, list(first(args)));
715 if (accum != null) accum = (SilkPair) (accum.rest = list(x));
716 args = rest(args);
717 }
718 } else {
719 SilkProcedure car = proc(interp.eval("car")), cdr = proc(interp.eval("cdr"));
720 while (first(args) instanceof SilkPair) {
721 Object x = proc.apply(interp, map(car, list(args), interp, list(null)));
722 if (accum != null) accum = (SilkPair) (accum.rest = list(x));
723 args = map(cdr, list(args), interp, list(null));
724 }
725 }
726 return (SilkPair)rest(result);
727 }
728
729 }
730