001: package jsint;
002:
003: import java.io.*;
004: import java.lang.reflect.Array;
005:
006: /** Primitive procedures (as defined in the R4RS Scheme report.
007: * NOTE: Primitive.java IS GENERATED FROM primitives.scm. EDIT AT YOUR OWN RISK.
008: * **/
009: public class Primitive extends Procedure {
010: int opcode;
011:
012: /** Constructor **/
013: public Primitive(String name, int opcode, int minArgs, int maxArgs) {
014: this .name = name;
015: this .opcode = opcode;
016: this .minArgs = minArgs;
017: this .maxArgs = maxArgs;
018: // Either fixed number of parms or 1 optional param or a "rest" parameter
019: if (!(maxArgs == minArgs || maxArgs == minArgs + 1 || maxArgs == Integer.MAX_VALUE))
020: E.warn("Bad value of maxArgs: " + maxArgs, name);
021: Symbol.intern(name).setGlobalValue(this );
022: }
023:
024: /** Apply the primitive to a list of arguments. **/
025: public Object apply(Object[] args) {
026: int nArgs = args.length;
027: Object x = (nArgs >= 1) ? args[0] : U.MISSING;
028: Object y = (nArgs >= 2) ? args[1] : U.MISSING;
029: Object z = (nArgs >= 3) ? args[2] : U.MISSING;
030:
031: switch (opcode) {
032: // ========== SECTION 6.1 BOOLEANS ==========
033: case 1 /* not */:
034: return U.not(x);
035: case 2 /* boolean? */:
036: return U.toBool(x instanceof Boolean);
037: // ========== SECTION 6.2 EQUIVALENCE PREDICATES ==========
038: case 3 /* eqv? */:
039: return U.toBool(U.eqv(x, y));
040: case 4 /* eq? */:
041: return U.toBool(x == y || U.TRUE.equals(x)
042: && U.TRUE.equals(y) || U.FALSE.equals(x)
043: && U.FALSE.equals(y));
044: case 5 /* equal? */:
045: return U.toBool(U.equal(x, y));
046: // ========== SECTION 6.3 LISTS AND PAIRS ==========
047: case 6 /* pair? */:
048: return U.toBool(U.isPair(x));
049: case 7 /* cons */:
050: return new Pair(x, y);
051: case 8 /* car first */:
052: return U.toList(x).first;
053: case 9 /* cdr rest */:
054: return U.toList(x).rest;
055: case 10 /* set-car! */:
056: return U.toPair(x).first = y;
057: case 11 /* set-cdr! */:
058: return U.toPair(x).rest = y;
059: case 12 /* second */:
060: return U.toList(x).second();
061: case 13 /* third */:
062: return U.toList(x).third();
063: case 14 /* fourth */:
064: return U.toList(x).nth(3);
065: case 15 /* fifth */:
066: return U.toList(x).nth(4);
067: case 16 /* sixth */:
068: return U.toList(x).nth(5);
069: case 17 /* seventh */:
070: return U.toList(x).nth(6);
071: case 18 /* eighth */:
072: return U.toList(x).nth(7);
073: case 19 /* ninth */:
074: return U.toList(x).nth(8);
075: case 20 /* tenth */:
076: return U.toList(x).nth(9);
077: case 21 /* caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr */:
078: for (int i = name.length() - 2; i >= 1; i--) {
079: x = (name.charAt(i) == 'a') ? U.toList(x).first : U
080: .toList(x).rest;
081: }
082: return x;
083: case 22 /* null? */:
084: return U.toBool(x == Pair.EMPTY);
085: case 23 /* list? */:
086: return U.toBool(U.isList(x));
087: case 24 /* list */:
088: return x;
089: case 25 /* length */:
090: return U.toNum(U.toList(x).length());
091: case 26 /* append */:
092: return U.append(U.toList(x));
093: case 27 /* reverse */:
094: return U.toList(x).reverse();
095: case 28 /* list-tail */:
096: return U.toList(x).listTail(U.toInt(y));
097: case 29 /* list-ref */:
098: return U.toList(x).nth(U.toInt(y));
099: case 30 /* memq */:
100: return U.memberAssoc(x, y, true, 1);
101: case 31 /* memv */:
102: return U.memberAssoc(x, y, true, 2);
103: case 32 /* member */:
104: return U.memberAssoc(x, y, true, 3);
105: case 33 /* assq */:
106: return U.memberAssoc(x, y, false, 1);
107: case 34 /* assv */:
108: return U.memberAssoc(x, y, false, 2);
109: case 35 /* assoc */:
110: return U.memberAssoc(x, y, false, 3);
111: // ========== SECTION 6.4 SYMBOLS ==========
112: case 36 /* symbol? */:
113: return U.toBool(x instanceof Symbol);
114: case 37 /* symbol->string */:
115: return U.toSym(x).toString();
116: case 38 /* string->symbol */:
117: return Symbol.intern(U.toStr(x));
118: // ========== SECTION 6.5 NUMBERS ==========
119: case 39 /* number? complex? real? */:
120: return U.toBool(x instanceof Number);
121: case 40 /* rational? integer? */:
122: return U.toBool(x instanceof Integer
123: || (x instanceof Double && U.toReal(x) == Math
124: .round(U.toReal(x))));
125: case 41 /* exact? */:
126: return U.toBool(x instanceof Integer);
127: case 42 /* inexact? */:
128: return U.toBool(x instanceof Double);
129: case 43 /* = */:
130: return U.toBool(U.numCompute(x, U.toList(y), '='));
131: case 44 /* < */:
132: return U.toBool(U.numCompute(x, U.toList(y), '<'));
133: case 45 /* > */:
134: return U.toBool(U.numCompute(x, U.toList(y), '>'));
135: case 46 /* <= */:
136: return U.toBool(U.numCompute(x, U.toList(y), 'L'));
137: case 47 /* >= */:
138: return U.toBool(U.numCompute(x, U.toList(y), 'G'));
139: case 48 /* zero? */:
140: return U.toBool(U.ZERO.equals(x) || U.toNum(0).equals(x));
141: case 49 /* positive? */:
142: return U.toBool(U.toReal(x) > 0.0);
143: case 50 /* negative? */:
144: return U.toBool(U.toReal(x) < 0.0);
145: case 51 /* odd? */:
146: return U.toBool(Math.abs(U.toInt(x)) % 2 != 0);
147: case 52 /* even? */:
148: return U.toBool(Math.abs(U.toInt(x)) % 2 == 0);
149: case 53 /* max */:
150: return U.numCompute(x, U.toList(y), 'X');
151: case 54 /* min */:
152: return U.numCompute(x, U.toList(y), 'N');
153: case 55 /* + */:
154: return Op.addMulti(U.toList(x));
155: case 56 /* * */:
156: return Op.mulMulti(U.toList(x));
157: case 57 /* - */:
158: return (y == U.MISSING) ? Op.sub(U.toNum(0), x) : Op.sub(x,
159: y);
160: case 58 /* / */:
161: return Op.div(x, y);
162: case 59 /* abs */:
163: if (x instanceof Integer)
164: return U.toNum(Math.abs(U.toInt(x)));
165: else
166: return U.toNum(Math.abs(U.toReal(x)));
167: case 60 /* quotient */:
168: return Op.div(x, y);
169: case 61 /* remainder */:
170: return Op.mod(x, y);
171: case 62 /* modulo */:
172: return Op.modulo(x, y);
173: case 63 /* gcd */:
174: return (nArgs == 0) ? U.toNum(0) : U.toNum(Math.abs(U
175: .gcd((Pair) x)));
176: case 64 /* lcm */:
177: return (nArgs == 0) ? U.toNum(1) : U.toNum(Math.abs(U
178: .lcm((Pair) x)));
179: // inessential numerator, denominator, rationalize not implemented
180: case 65 /* floor */:
181: return U.toNum(Math.floor(U.toReal(x)));
182: case 66 /* ceiling */:
183: return U.toNum(Math.ceil(U.toReal(x)));
184: case 67 /* truncate */:
185: double d = U.toReal(x);
186: return U.toNum((d < 0) ? Math.ceil(d) : Math.floor(d));
187: case 68 /* round */:
188: return U.toNum(Math.round(U.toReal(x)));
189: case 69 /* exp */:
190: return U.toNum(Math.exp(U.toReal(x)));
191: case 70 /* log */:
192: return U.toNum(Math.log(U.toReal(x)));
193: case 71 /* sin */:
194: return U.toNum(Math.sin(U.toReal(x)));
195: case 72 /* cos */:
196: return U.toNum(Math.cos(U.toReal(x)));
197: case 73 /* tan */:
198: return U.toNum(Math.tan(U.toReal(x)));
199: case 74 /* asin */:
200: return U.toNum(Math.asin(U.toReal(x)));
201: case 75 /* acos */:
202: return U.toNum(Math.acos(U.toReal(x)));
203: case 76 /* atan */:
204: return U.toNum(Math.atan(U.toReal(x)));
205: case 77 /* sqrt */:
206: return U.toNum(Math.sqrt(U.toReal(x)));
207: case 78 /* expt */:
208: return U.toNum(Math.pow(U.toReal(x), U.toReal(y)));
209: // inessential complex arithmetic not implemented
210: case 79 /* exact->inexact */:
211: return U.toNum(U.toReal(x));
212: case 80 /* inexact->exact */:
213: return U.toNum(U.toInt(x));
214: case 81 /* number->string */:
215: return U.numberToString(x, y);
216: case 82 /* string->number */:
217: return U.stringToNumber(x, y);
218: // ========== SECTION 6.6 CHARACTERS ==========
219: case 83 /* char? */:
220: return U.toBool(x instanceof Character);
221: case 84 /* char=? */:
222: return U.toBool(U.to_char(x) == U.to_char(y));
223: case 85 /* char<? */:
224: return U.toBool(U.to_char(x) < U.to_char(y));
225: case 86 /* char>? */:
226: return U.toBool(U.to_char(x) > U.to_char(y));
227: case 87 /* char>=? */:
228: return U.toBool(U.to_char(x) >= U.to_char(y));
229: case 88 /* char<=? */:
230: return U.toBool(U.to_char(x) <= U.to_char(y));
231: case 89 /* char-ci=? */:
232: return U.toBool(U.to_lc_char(x) == U.to_lc_char(y));
233: case 90 /* char-ci<? */:
234: return U.toBool(U.to_lc_char(x) < U.to_lc_char(y));
235: case 91 /* char-ci>? */:
236: return U.toBool(U.to_lc_char(x) > U.to_lc_char(y));
237: case 92 /* char-ci>=? */:
238: return U.toBool(U.to_lc_char(x) >= U.to_lc_char(y));
239: case 93 /* char-ci<=? */:
240: return U.toBool(U.to_lc_char(x) <= U.to_lc_char(y));
241: case 94 /* char-alphabetic? */:
242: return U.toBool(Character.isLetter(U.to_char(x)));
243: case 95 /* char-numeric? */:
244: return U.toBool(Character.isDigit(U.to_char(x)));
245: case 96 /* char-whitespace? */:
246: return U.toBool(Character.isWhitespace(U.to_char(x)));
247: case 97 /* char-upper-case? */:
248: return U.toBool(Character.isUpperCase(U.to_char(x)));
249: case 98 /* char-lower-case? */:
250: return U.toBool(Character.isLowerCase(U.to_char(x)));
251: case 99 /* char->integer */:
252: return U.toNum((int) U.to_char(x));
253: case 100 /* integer->char */:
254: return U.toChar((char) U.toInt(x));
255: case 101 /* char-upcase */:
256: return U.toChar(Character.toUpperCase(U.to_char(x)));
257: case 102 /* char-downcase */:
258: return U.toChar(Character.toLowerCase(U.to_char(x)));
259: // ========== SECTION 6.7 STRINGS ==========
260: case 103 /* string? */:
261: return U.toBool(x instanceof String);
262: case 104 /* make-string */:
263: return U.makeString(U.toInt(x), y);
264: case 105 /* string */:
265: return U.listToString(x);
266: case 106 /* string-length */:
267: return U.toNum(U.toStr(x).length());
268: case 107 /* string-ref */:
269: return U.toChar(U.toStr(x).charAt(U.toInt(y)));
270: case 108 /* string=? */:
271: return U.toBool(U.toStr(x).equals(y));
272: case 109 /* string-ci=? */:
273: return U.toBool(U.toStr(x).equalsIgnoreCase(U.toStr(y)));
274: case 110 /* string<? */:
275: return U.toBool(U.toStr(x).compareTo(U.toStr(y)) < 0);
276: case 111 /* string>? */:
277: return U.toBool(U.toStr(x).compareTo(U.toStr(y)) > 0);
278: case 112 /* string>=? */:
279: return U.toBool(U.toStr(x).compareTo(U.toStr(y)) >= 0);
280: case 113 /* string<=? */:
281: return U.toBool(U.toStr(x).compareTo(U.toStr(y)) <= 0);
282: case 114 /* string-ci<? */:
283: return U.toBool(U.stringCompareIgnoreCase(x, y) < 0);
284: case 115 /* string-ci>? */:
285: return U.toBool(U.stringCompareIgnoreCase(x, y) > 0);
286: case 116 /* string-ci>=? */:
287: return U.toBool(U.stringCompareIgnoreCase(x, y) >= 0);
288: case 117 /* string-ci<=? */:
289: return U.toBool(U.stringCompareIgnoreCase(x, y) <= 0);
290: case 118 /* substring */:
291: int start = U.toInt(y);
292: return U.toStr(x).substring(start, U.toInt(z));
293: case 119 /* string-append */:
294: return U.stringAppend(U.toList(x));
295: case 120 /* string->list */:
296: return U.stringToList(x);
297: case 121 /* list->string */:
298: return U.listToString(x);
299: // Inessential string-copy and string-fill! implemented in primprocs.scm
300: // ========== SECTION 6.8 VECTORS ==========
301: case 122 /* vector? */:
302: return U.toBool(x instanceof Object[] || x != null
303: && x.getClass().isArray());
304: case 123 /* vector-fill! */:
305: return U.vectorFill(x, y);
306: case 124 /* make-vector */:
307: return (y == U.MISSING) ? U.makeVector(x) : U.makeVector(x,
308: y);
309: case 125 /* vector */:
310: return U.listToVector(x);
311: case 126 /* vector-length */:
312: return U.vectorLength(x);
313: case 127 /* vector-ref */:
314: return U.vectorRef(x, y);
315: case 128 /* vector-set! */:
316: return U.vectorSet(x, y, z);
317: case 129 /* vector->list */:
318: return U.vectorToList(U.toVec(x));
319: case 130 /* list->vector */:
320: return U.listToVector(x);
321: // ========== SECTION 6.9 CONTROL FEATURES ==========
322: case 131 /* procedure? */:
323: return U.toBool(x instanceof Procedure);
324: case 132 /* apply */:
325: return U.apply(U.toProc(x), U.toList(y));
326: case 133 /* map */:
327: return U.map(U.toProc(x), new Pair(y, z), U.list(U.TRUE));
328: case 134 /* for-each */:
329: return U.map(U.toProc(x), new Pair(y, z), Pair.EMPTY);
330: case 135 /* force */:
331: return (!(x instanceof Procedure)) ? x : U.toProc(x).apply(
332: U.NO_ARGS);
333: case 136 /* call/cc call-with-current-continuation */:
334: return U.callCC(U.toProc(x));
335: case 137 /* eval */:
336: return Scheme.eval(x, y);
337: case 138 /* null-environment */:
338: return Scheme.getNullEnvironment();
339: case 139 /* interaction-environment */:
340: return Scheme.getInteractionEnvironment();
341: // ========== SECTION 6.10 INPUT AND OUPUT ==========
342: case 140 /* call-with-input-file */:
343: return U.callWithInputFile(x, U.toProc(y));
344: case 141 /* call-with-output-file */:
345: return U.callWithOutputFile(x, U.toProc(y));
346: case 142 /* input-port? */:
347: return U.toBool(x instanceof InputPort);
348: case 143 /* output-port? */:
349: return U.toBool(x instanceof PrintWriter);
350: case 144 /* current-input-port */:
351: return U.toInPort(U.MISSING);
352: case 145 /* current-output-port */:
353: return U.toOutPort(U.MISSING);
354: // Inessential with-input-from-file, with-output-to-file not implemented
355: case 146 /* open-input-file */:
356: return U.openInputFile(x);
357: case 147 /* open-output-file */:
358: return U.openOutputFile(x);
359: case 148 /* close-input-port */:
360: return U.toInPort(x).close();
361: case 149 /* close-output-port */:
362: U.toOutPort(x).close();
363: return U.TRUE;
364: case 150 /* read */:
365: return U.toInPort(x).read();
366: case 151 /* read-char */:
367: return U.toInPort(x).readChar();
368: case 152 /* peek-char */:
369: return U.toInPort(x).peekChar();
370: case 153 /* eof-object? */:
371: return U.toBool(x == InputPort.EOF);
372: // Inessential char-ready?, transcript-on, transcript-off not implemented
373: case 154 /* write */:
374: return U.write(x, U.toOutPort(y), true);
375: case 155 /* display */:
376: return U.write(x, U.toOutPort(y), false);
377: case 156 /* newline */:
378: U.toOutPort(x).println();
379: U.toOutPort(x).flush();
380: return U.TRUE;
381: case 157 /* write-char */:
382: U.toOutPort(y).print(U.to_char(x));
383: return U.TRUE;
384: case 158 /* load */:
385: return Scheme.load(x);
386: // ========== EXTENSIONS ==========
387: case 159 /* set-procedure-name! */:
388: ((Procedure) x).setName(y);
389: return x;
390: case 160 /* macroexpand */:
391: return Macro.expand(U.toPair(x));
392: case 161 /* error */:
393: return E.error("", x);
394: case 162 /* class */:
395: return U.maybeToClass(x);
396: case 163 /* import */:
397: Import.addImport(U.toStr(x));
398: return U.TRUE;
399: case 164 /* constructor */:
400: return new RawConstructor(Invoke.findConstructor(x, U
401: .toList(y)));
402: case 165 /* method */:
403: return new RawMethod(Invoke.findMethod(U.toStr(x), y,
404: ((Pair) z)));
405: case 166 /* new */:
406: return Invoke.invokeConstructor(U.toClass(x).getName(), U
407: .listToVector(y));
408: case 167 /* invoke */:
409: return Invoke.invokeInstance(x, y.toString(), U
410: .listToVector(z), false);
411: case 168 /* invoke-static */:
412: return Invoke.invokeStatic(U.toClass(x), y.toString(), U
413: .listToVector(z));
414: case 169 /* peek */:
415: return Invoke.peek(x, U.toStr(y));
416: case 170 /* peek-static */:
417: return Invoke.peekStatic(U.toClass(x), U.toStr(y));
418: case 171 /* poke */:
419: return Invoke.poke(x, U.toStr(y), z);
420: case 172 /* poke-static */:
421: return Invoke.pokeStatic(U.toClass(x), U.toStr(y), z);
422: case 173 /* exit */:
423: return U.toBool(Scheme.currentEvaluator().setExit(true));
424: case 174 /* time-call */:
425: return U.timeCall(U.toProc(x), U.toInt(y, 1));
426: case 175 /* list->array */:
427: return U.listToArray(U.toClass(x), U.toList(y));
428: case 176 /* array->list */:
429: return U.arrayToList(x);
430: case 177 /* % */:
431: return Op.mod(x, y);
432: case 178 /* & */:
433: return Op.and(x, y);
434: case 179 /* | */:
435: return Op.or(x, y);
436: case 180 /* ^ */:
437: return Op.xor(x, y);
438: case 181 /* ~ */:
439: return Op.complement(x);
440: case 182 /* != */:
441: return U.toBool(Op.ne(x, y));
442: case 183 /* << */:
443: return Op.leftShift(x, y);
444: case 184 /* >> */:
445: return Op.rightShift(x, y);
446: case 185 /* >>> */:
447: return Op.rightShiftZ(x, y);
448: case 186 /* throw */:
449: return Procedure
450: .throwRuntimeException(new JschemeThrowable(x));
451: case 187 /* synchronize */:
452: return Procedure.synchronize(x, U.toProc(y));
453: case 188 /* string->expr */:
454: return (x == null) ? null : ((Pair) jscheme.REPL
455: .parseScheme((String) x)).first;
456: case 189 /* string->exprlist */:
457: return (x == null) ? null : jscheme.REPL
458: .parseScheme((String) x);
459: case 190 /* initial-environment */:
460: return Scheme.getInitialEnvironment();
461: case 191 /* load-environment */:
462: return Scheme.loadEnvironment(x);
463: case 192 /* environment-bindings */:
464: return DynamicEnvironment.getBindings(x);
465: case 193 /* environment-import */:
466: return Scheme.environmentImport(x, y);
467: case 194 /* language-import */:
468: return Scheme.languageImport(x);
469: case 195 /* values */:
470: return Values.values(U.toList(x));
471: case 196 /* call-with-values */:
472: return Values.callWithValues(U.toProc(x), U.toProc(y));
473: case 197 /* isNull */:
474: return U.toBool(x == null);
475: case 198 /* !isNull */:
476: return U.toBool(x != null);
477: }
478: return E.error("internal error: unknown primitive opcode"
479: + opcode + " applied to " + args);
480: }
481:
482: /* Create the primitive procedures */
483: static void loadPrimitives() {
484: int n = Integer.MAX_VALUE;
485: new Primitive("!isNull", 198, 1, 1);
486: new Primitive("isNull", 197, 1, 1);
487: new Primitive("call-with-values", 196, 2, 2);
488: new Primitive("values", 195, 0, n);
489: new Primitive("language-import", 194, 1, 1);
490: new Primitive("environment-import", 193, 1, 2);
491: new Primitive("environment-bindings", 192, 1, 1);
492: new Primitive("load-environment", 191, 1, 1);
493: new Primitive("initial-environment", 190, 0, 0);
494: new Primitive("string->exprlist", 189, 1, 1);
495: new Primitive("string->expr", 188, 1, 1);
496: new Primitive("synchronize", 187, 2, 2);
497: new Primitive("throw", 186, 1, 1);
498: new Primitive(">>>", 185, 2, 2);
499: new Primitive(">>", 184, 2, 2);
500: new Primitive("<<", 183, 2, 2);
501: new Primitive("!=", 182, 2, 2);
502: new Primitive("~", 181, 1, 1);
503: new Primitive("^", 180, 2, 2);
504: new Primitive("|", 179, 2, 2);
505: new Primitive("&", 178, 2, 2);
506: new Primitive("%", 177, 2, 2);
507: new Primitive("array->list", 176, 1, 1);
508: new Primitive("list->array", 175, 2, 2);
509: new Primitive("time-call", 174, 2, 2);
510: new Primitive("exit", 173, 0, 0);
511: new Primitive("poke-static", 172, 3, 3);
512: new Primitive("poke", 171, 3, 3);
513: new Primitive("peek-static", 170, 2, 2);
514: new Primitive("peek", 169, 2, 2);
515: new Primitive("invoke-static", 168, 2, n);
516: new Primitive("invoke", 167, 2, n);
517: new Primitive("new", 166, 1, n);
518: new Primitive("method", 165, 2, n);
519: new Primitive("constructor", 164, 1, n);
520: new Primitive("import", 163, 1, 1);
521: new Primitive("class", 162, 1, 1);
522: new Primitive("error", 161, 0, n);
523: new Primitive("macroexpand", 160, 1, 1);
524: new Primitive("set-procedure-name!", 159, 2, 2);
525: new Primitive("load", 158, 1, 1);
526: new Primitive("write-char", 157, 1, 2);
527: new Primitive("newline", 156, 0, 1);
528: new Primitive("display", 155, 1, 2);
529: new Primitive("write", 154, 1, 2);
530: new Primitive("eof-object?", 153, 1, 1);
531: new Primitive("peek-char", 152, 0, 1);
532: new Primitive("read-char", 151, 0, 1);
533: new Primitive("read", 150, 0, 1);
534: new Primitive("close-output-port", 149, 1, 1);
535: new Primitive("close-input-port", 148, 1, 1);
536: new Primitive("open-output-file", 147, 1, 1);
537: new Primitive("open-input-file", 146, 1, 1);
538: new Primitive("current-output-port", 145, 0, 0);
539: new Primitive("current-input-port", 144, 0, 0);
540: new Primitive("output-port?", 143, 1, 1);
541: new Primitive("input-port?", 142, 1, 1);
542: new Primitive("call-with-output-file", 141, 2, 2);
543: new Primitive("call-with-input-file", 140, 2, 2);
544: new Primitive("interaction-environment", 139, 0, 0);
545: new Primitive("null-environment", 138, 0, 0);
546: new Primitive("eval", 137, 1, 2);
547: new Primitive("call-with-current-continuation", 136, 1, 1);
548: new Primitive("call/cc", 136, 1, 1);
549: new Primitive("force", 135, 1, 1);
550: new Primitive("for-each", 134, 2, n);
551: new Primitive("map", 133, 2, n);
552: new Primitive("apply", 132, 1, n);
553: new Primitive("procedure?", 131, 1, 1);
554: new Primitive("list->vector", 130, 1, 1);
555: new Primitive("vector->list", 129, 1, 1);
556: new Primitive("vector-set!", 128, 3, 3);
557: new Primitive("vector-ref", 127, 2, 2);
558: new Primitive("vector-length", 126, 1, 1);
559: new Primitive("vector", 125, 0, n);
560: new Primitive("make-vector", 124, 1, 2);
561: new Primitive("vector-fill!", 123, 2, 2);
562: new Primitive("vector?", 122, 1, 1);
563: new Primitive("list->string", 121, 1, 1);
564: new Primitive("string->list", 120, 1, 1);
565: new Primitive("string-append", 119, 0, n);
566: new Primitive("substring", 118, 3, 3);
567: new Primitive("string-ci<=?", 117, 2, 2);
568: new Primitive("string-ci>=?", 116, 2, 2);
569: new Primitive("string-ci>?", 115, 2, 2);
570: new Primitive("string-ci<?", 114, 2, 2);
571: new Primitive("string<=?", 113, 2, 2);
572: new Primitive("string>=?", 112, 2, 2);
573: new Primitive("string>?", 111, 2, 2);
574: new Primitive("string<?", 110, 2, 2);
575: new Primitive("string-ci=?", 109, 2, 2);
576: new Primitive("string=?", 108, 2, 2);
577: new Primitive("string-ref", 107, 2, 2);
578: new Primitive("string-length", 106, 1, 1);
579: new Primitive("string", 105, 0, n);
580: new Primitive("make-string", 104, 1, 2);
581: new Primitive("string?", 103, 1, 1);
582: new Primitive("char-downcase", 102, 1, 1);
583: new Primitive("char-upcase", 101, 1, 1);
584: new Primitive("integer->char", 100, 1, 1);
585: new Primitive("char->integer", 99, 1, 1);
586: new Primitive("char-lower-case?", 98, 1, 1);
587: new Primitive("char-upper-case?", 97, 1, 1);
588: new Primitive("char-whitespace?", 96, 1, 1);
589: new Primitive("char-numeric?", 95, 1, 1);
590: new Primitive("char-alphabetic?", 94, 1, 1);
591: new Primitive("char-ci<=?", 93, 2, 2);
592: new Primitive("char-ci>=?", 92, 2, 2);
593: new Primitive("char-ci>?", 91, 2, 2);
594: new Primitive("char-ci<?", 90, 2, 2);
595: new Primitive("char-ci=?", 89, 2, 2);
596: new Primitive("char<=?", 88, 2, 2);
597: new Primitive("char>=?", 87, 2, 2);
598: new Primitive("char>?", 86, 2, 2);
599: new Primitive("char<?", 85, 2, 2);
600: new Primitive("char=?", 84, 2, 2);
601: new Primitive("char?", 83, 1, 1);
602: new Primitive("string->number", 82, 1, 2);
603: new Primitive("number->string", 81, 1, 2);
604: new Primitive("inexact->exact", 80, 1, 1);
605: new Primitive("exact->inexact", 79, 1, 1);
606: new Primitive("expt", 78, 2, 2);
607: new Primitive("sqrt", 77, 1, 1);
608: new Primitive("atan", 76, 1, 1);
609: new Primitive("acos", 75, 1, 1);
610: new Primitive("asin", 74, 1, 1);
611: new Primitive("tan", 73, 1, 1);
612: new Primitive("cos", 72, 1, 1);
613: new Primitive("sin", 71, 1, 1);
614: new Primitive("log", 70, 1, 1);
615: new Primitive("exp", 69, 1, 1);
616: new Primitive("round", 68, 1, 1);
617: new Primitive("truncate", 67, 1, 1);
618: new Primitive("ceiling", 66, 1, 1);
619: new Primitive("floor", 65, 1, 1);
620: new Primitive("lcm", 64, 0, n);
621: new Primitive("gcd", 63, 0, n);
622: new Primitive("modulo", 62, 2, 2);
623: new Primitive("remainder", 61, 2, 2);
624: new Primitive("quotient", 60, 2, 2);
625: new Primitive("abs", 59, 1, 1);
626: new Primitive("/", 58, 2, 2);
627: new Primitive("-", 57, 1, 2);
628: new Primitive("*", 56, 0, n);
629: new Primitive("+", 55, 0, n);
630: new Primitive("min", 54, 1, n);
631: new Primitive("max", 53, 1, n);
632: new Primitive("even?", 52, 1, 1);
633: new Primitive("odd?", 51, 1, 1);
634: new Primitive("negative?", 50, 1, 1);
635: new Primitive("positive?", 49, 1, 1);
636: new Primitive("zero?", 48, 1, 1);
637: new Primitive(">=", 47, 1, n);
638: new Primitive("<=", 46, 1, n);
639: new Primitive(">", 45, 1, n);
640: new Primitive("<", 44, 1, n);
641: new Primitive("=", 43, 1, n);
642: new Primitive("inexact?", 42, 1, 1);
643: new Primitive("exact?", 41, 1, 1);
644: new Primitive("integer?", 40, 1, 1);
645: new Primitive("rational?", 40, 1, 1);
646: new Primitive("real?", 39, 1, 1);
647: new Primitive("complex?", 39, 1, 1);
648: new Primitive("number?", 39, 1, 1);
649: new Primitive("string->symbol", 38, 1, 1);
650: new Primitive("symbol->string", 37, 1, 1);
651: new Primitive("symbol?", 36, 1, 1);
652: new Primitive("assoc", 35, 2, 2);
653: new Primitive("assv", 34, 2, 2);
654: new Primitive("assq", 33, 2, 2);
655: new Primitive("member", 32, 2, 2);
656: new Primitive("memv", 31, 2, 2);
657: new Primitive("memq", 30, 2, 2);
658: new Primitive("list-ref", 29, 2, 2);
659: new Primitive("list-tail", 28, 2, 2);
660: new Primitive("reverse", 27, 1, 1);
661: new Primitive("append", 26, 0, n);
662: new Primitive("length", 25, 1, 1);
663: new Primitive("list", 24, 0, n);
664: new Primitive("list?", 23, 1, 1);
665: new Primitive("null?", 22, 1, 1);
666: new Primitive("cddddr", 21, 1, 1);
667: new Primitive("cdddar", 21, 1, 1);
668: new Primitive("cddadr", 21, 1, 1);
669: new Primitive("cddaar", 21, 1, 1);
670: new Primitive("cdaddr", 21, 1, 1);
671: new Primitive("cdadar", 21, 1, 1);
672: new Primitive("cdaadr", 21, 1, 1);
673: new Primitive("cdaaar", 21, 1, 1);
674: new Primitive("cadddr", 21, 1, 1);
675: new Primitive("caddar", 21, 1, 1);
676: new Primitive("cadadr", 21, 1, 1);
677: new Primitive("cadaar", 21, 1, 1);
678: new Primitive("caaddr", 21, 1, 1);
679: new Primitive("caadar", 21, 1, 1);
680: new Primitive("caaadr", 21, 1, 1);
681: new Primitive("caaaar", 21, 1, 1);
682: new Primitive("cdddr", 21, 1, 1);
683: new Primitive("cddar", 21, 1, 1);
684: new Primitive("cdadr", 21, 1, 1);
685: new Primitive("cdaar", 21, 1, 1);
686: new Primitive("caddr", 21, 1, 1);
687: new Primitive("cadar", 21, 1, 1);
688: new Primitive("caadr", 21, 1, 1);
689: new Primitive("caaar", 21, 1, 1);
690: new Primitive("cddr", 21, 1, 1);
691: new Primitive("cdar", 21, 1, 1);
692: new Primitive("cadr", 21, 1, 1);
693: new Primitive("caar", 21, 1, 1);
694: new Primitive("tenth", 20, 1, 1);
695: new Primitive("ninth", 19, 1, 1);
696: new Primitive("eighth", 18, 1, 1);
697: new Primitive("seventh", 17, 1, 1);
698: new Primitive("sixth", 16, 1, 1);
699: new Primitive("fifth", 15, 1, 1);
700: new Primitive("fourth", 14, 1, 1);
701: new Primitive("third", 13, 1, 1);
702: new Primitive("second", 12, 1, 1);
703: new Primitive("set-cdr!", 11, 2, 2);
704: new Primitive("set-car!", 10, 2, 2);
705: new Primitive("rest", 9, 1, 1);
706: new Primitive("cdr", 9, 1, 1);
707: new Primitive("first", 8, 1, 1);
708: new Primitive("car", 8, 1, 1);
709: new Primitive("cons", 7, 2, 2);
710: new Primitive("pair?", 6, 1, 1);
711: new Primitive("equal?", 5, 2, 2);
712: new Primitive("eq?", 4, 2, 2);
713: new Primitive("eqv?", 3, 2, 2);
714: new Primitive("boolean?", 2, 1, 1);
715: new Primitive("not", 1, 1, 1);
716: String derived = "(begin (set! null #null) (set! define (set-procedure-name! (macro (var . body) (if (pair? var) (list 'set! (first var) (list 'set-procedure-name! (cons 'lambda (cons (rest var) body)) (list 'quote (first var)))) (cons 'set! (cons var body)))) 'define)) (define cond (set-procedure-name! (macro clauses (define (process-clause clause else-part) (if (not (pair? clause)) (error '(bad cond clause:) clause) (if (null? (rest clause)) (list 'or (first clause) else-part) (if (eq? (second clause) '=>) ((lambda (tempvar) (list (list 'lambda (list tempvar) (list 'if tempvar (list (third clause) tempvar) else-part)) (first clause))) (string->symbol \"temp var\")) (if (member (first clause) '(#t else)) (cons 'begin (rest clause)) (list 'if (first clause) (cons 'begin (rest clause)) else-part)))))) (if (null? clauses) #f (process-clause (first clauses) (cons 'cond (rest clauses))))) 'cond)) (define tryCatch (set-procedure-name! (macro args (list 'jsint.Procedure.tryCatch (list 'lambda () (first args)) (second args))) 'tryCatch)) (define and (set-procedure-name! (macro args (cond ((null? args) #t) ((null? (rest args)) (list 'U.and1 (first args))) (else (list 'if (first args) (cons 'and (rest args)) #f)))) 'and)) (define quasiquote (set-procedure-name! (macro (x) (define (constant? exp) (if (pair? exp) (eq? (car exp) 'quote) (not (symbol? exp)))) (define (combine-skeletons left right exp) (cond ((and (constant? left) (constant? right)) (if (and (eqv? (eval left) (car exp)) (eqv? (eval right) (cdr exp))) (list 'quote exp) (list 'quote (cons (eval left) (eval right))))) ((null? right) (list 'list left)) ((and (pair? right) (eq? (car right) 'list)) (cons 'list (cons left (cdr right)))) (else (list 'cons left right)))) (define (expand-quasiquote exp nesting) (cond ((vector? exp) (list 'apply 'vector (expand-quasiquote (vector->list exp) nesting))) ((not (pair? exp)) (if (constant? exp) exp (list 'quote exp))) ((and (eq? (car exp) 'unquote) (= (length exp) 2)) (if (= nesting 0) (second exp) (combine-skeletons ''unquote (expand-quasiquote (cdr exp) (- nesting 1)) exp))) ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) (combine-skeletons ''quasiquote (expand-quasiquote (cdr exp) (+ nesting 1)) exp)) ((and (pair? (car exp)) (eq? (caar exp) 'unquote-splicing) (= (length (car exp)) 2)) (if (= nesting 0) (list 'append (second (first exp)) (expand-quasiquote (cdr exp) nesting)) (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) (expand-quasiquote (cdr exp) nesting) exp))) (else (combine-skeletons (expand-quasiquote (car exp) nesting) (expand-quasiquote (cdr exp) nesting) exp)))) (expand-quasiquote x 0)) 'quasiquote)) (define let (set-procedure-name! (macro (bindings . body) (define (varval v) (string->symbol (string-append v \"=\"))) (define (named-let name bindings body) ((lambda (new-bindings) `(let ,(cons `(,name #f) new-bindings) (set! ,name (lambda ,(map first bindings) unquote body)) (,name unquote (map car new-bindings)))) (map (lambda (b) `(,(varval (car b)) ,(cadr b))) bindings))) (if (symbol? bindings) (named-let bindings (first body) (rest body)) `((lambda ,(map first bindings) unquote body) unquote (map second bindings)))) 'let)) (define let* (set-procedure-name! (macro (bindings . body) (if (null? bindings) (jsint.Scheme.toBody body) (if (null? (cdr bindings)) `(let (,(first bindings)) unquote body) `(let (,(first bindings)) (let* ,(rest bindings) unquote body))))) 'let*)) (define letrec (set-procedure-name! (macro (bindings . body) (let ((vars (map first bindings)) (vals (map second bindings))) `(let ,(map (lambda (var) `(,var #f)) vars) ,@(map (lambda (var val) `(set! ,var ,val)) vars vals) ,(jsint.Scheme.toBody body)))) 'letrec)) (define case (set-procedure-name! (macro (exp . cases) (let ((tempvar (string->symbol \"temp var\"))) (define (do-case case) (cond ((not (pair? case)) (error '(bad syntax in case:) case)) ((eq? (first case) 'else) case) (else `((member ,tempvar ',(first case)) unquote (rest case))))) `(let ((,tempvar ,exp)) (cond unquote (map do-case cases))))) 'case)) (define do (set-procedure-name! (macro (bindings test-and-result . body) (let ((variables (map first bindings)) (inits (map second bindings)) (steps (map (lambda (clause) (if (null? (cddr clause)) (first clause) (third clause))) bindings)) (result (if (null? (cdr test-and-result)) ''unspecified `(begin unquote (cdr test-and-result))))) (let ((tempvar '<loop>)) `(letrec ((,tempvar (lambda ,variables (if ,(first test-and-result) ,result (begin ,@body (,tempvar unquote steps)))))) (,tempvar unquote inits))))) 'do)) (define delay (set-procedure-name! (macro (exp) (define (make-promise proc) (let ((result-ready? #f) (result #f)) (lambda () (if result-ready? result (let ((x (proc))) (if result-ready? result (begin (set! result-ready? #t) (set! result x) result))))))) `(,make-promise (lambda () ,exp))) 'delay)) (define time (set-procedure-name! (macro (exp . ntimes) `(time-call (lambda () ,exp) ,(if (pair? ntimes) (car ntimes) 1))) 'time)) (define define-macro (set-procedure-name! (macro (spec . body) (if (pair? spec) `(define ,(first spec) (set-procedure-name! (macro ,(rest spec) unquote body) ',(first spec))) `(define ,spec (set-procedure-name! (macro ,(second (first body)) ,@(rest (rest (first body)))) ',spec)))) 'define-macro)) (define (missing-classes classes sofar) (if (null? classes) sofar (missing-classes (cdr classes) (if (eq? (class (car classes)) #null) (cons (car classes) sofar) sofar)))) (define-macro (if-classes classes then else) (if (null? (missing-classes classes '())) then else)) (define-macro (when-classes classes . then) `(if-classes ,classes (begin ,@then) #f)) (define-macro (class-case varlist . clauses) (define (runtimeClassName c) (string->symbol (string-append (.getName (class c)) \".class\"))) (define (instanceof v c) `(.isInstance ,(runtimeClassName c) ,v)) `(cond ,@(map (lambda (clause) (if (equal? (first clause) 'else) clause `((and ,@(map instanceof varlist (first clause))) ,@(rest clause)))) clauses))) (define (define-method-runtime name type-names f name-args) (let ((missing (missing-classes type-names '()))) (if (null? missing) (jsint.Generic.defineMethod name type-names f) (jsint.E.warn (string-append \"Can't define-method \" name-args \" classes \" missing \" do not exist.\"))))) (define define-method (macro (name-args . body) (define (arg-name x) (if (pair? x) (car x) x)) (define (maybe-second x default) (if (and (pair? x) (pair? (cdr x))) (cadr x) default)) (define (arg-type x) (maybe-second x 'java.lang.Object)) (let* ((name (car name-args)) (args (cdr name-args)) (arg-types (map arg-type args))) `(define-method-runtime ',name ',arg-types (lambda ,(map arg-name args) ,@body) ',name-args)))) (define package (macro args #t)) (define (array a-class . args) (let ((v (make-array a-class (length args)))) (let loop ((i 0) (as args)) (if (null? as) v (begin (vector-set! v i (car as)) (loop (+ i 1) (cdr as))))))) (define (make-array a-class size) (java.lang.reflect.Array.newInstance a-class size)) (define (!{} . args) (let loop ((args args) (sb (StringBuffer.))) (cond ((null? args) (.toString sb)) ((pair? (car args)) (loop (cons (car (car args)) (cons (cdr (car args)) (cdr args))) sb)) ((null? (car args)) (loop (cdr args) sb)) (else (.append sb (U.stringify (car args) #f)) (loop (cdr args) sb))))) (define !#{} !{}) (define (string-set! s i v) (.hash$# s 0) (vector-set! (.value$# s) i v)) (define (string-fill! s x) (.hash$# s 0) (let ((L (string-length s)) (v (.value$# s))) (let loop ((i 0)) (if (< i L) (begin (vector-set! v i x) (loop (+ i 1))))) s)) (define (string-copy s) (.toString (StringBuffer. s))) (define use-module (lambda (filename . R) (case (length R) ((0) (use-module filename 'import 'all #f)) ((1) (use-module filename (first R) 'all #f)) ((2) (use-module filename (first R) (second R) #f)) (else (let* ((specifier (first R)) (symbols (second R)) (prefix (third R)) (symarray (if (or (equal? symbols #null) (equal? symbols 'all)) #null (list->array jsint.Symbol.class symbols)))) (case specifier ((import-procedures) (.environmentImport (Scheme.currentEvaluator) filename prefix #f symarray)) ((import-macros) (.environmentImport (Scheme.currentEvaluator) filename #f #t symarray)) ((import) (.environmentImport (Scheme.currentEvaluator) filename prefix #f symarray) (.environmentImport (Scheme.currentEvaluator) filename #f #t symarray)) (else (error (!{} \"unknown specifier \" specifier \" in (use-module \" filename \" \" specifier \" \" symbols \" \" prefix \")\\n\"))))))))))";
717: //Scheme.load("jsint/primproc.scm");
718: Scheme.load(new InputPort(new java.io.StringReader(derived)));
719: primitives_loaded = true;
720: }
721:
722: static boolean primitives_loaded = false;
723: }
|