yhara-tickets 0.1.0

Sign up to get free protection for your applications and to get access to all the features.
@@ -0,0 +1,2388 @@
1
+ //
2
+ // R6RS Base library
3
+ //
4
+ function dump(){}
5
+
6
+ if( typeof(BiwaScheme)!='object' ) BiwaScheme={}; with(BiwaScheme) {
7
+ /* --------------------------------------- namespace webscheme */
8
+
9
+ ///
10
+ /// Utility functions
11
+ ///
12
+
13
+ //
14
+ // Iterator - external iterator
15
+ //
16
+ BiwaScheme.Iterator = {
17
+ ForArray: Class.create({
18
+ initialize: function(arr){
19
+ this.arr = arr;
20
+ this.i = 0;
21
+ },
22
+ has_next: function(){
23
+ return this.i < this.arr.length;
24
+ },
25
+ next: function(){
26
+ return this.arr[this.i++];
27
+ }
28
+ }),
29
+ ForString: Class.create({
30
+ initialize: function(str){
31
+ this.str = str;
32
+ this.i = 0;
33
+ },
34
+ has_next: function(){
35
+ return this.i < this.str.length;
36
+ },
37
+ next: function(){
38
+ return Char.get(this.str.charAt(this.i++));
39
+ }
40
+ }),
41
+ ForList: Class.create({
42
+ initialize: function(ls){
43
+ this.ls = ls;
44
+ },
45
+ has_next: function(){
46
+ return (this.ls instanceof Pair) && this.ls != nil;
47
+ },
48
+ next: function(){
49
+ var pair = this.ls;
50
+ this.ls = this.ls.cdr;
51
+ return pair;
52
+ }
53
+ }),
54
+ ForMulti: Class.create({
55
+ initialize: function(objs){
56
+ this.objs = objs;
57
+ this.size = objs.length;
58
+ this.iterators = objs.map(function(x){
59
+ return Iterator.of(x);
60
+ })
61
+ },
62
+ has_next: function(){
63
+ for(var i=0; i<this.size; i++)
64
+ if(!this.iterators[i].has_next())
65
+ return false;
66
+
67
+ return true;
68
+ },
69
+ next: function(){
70
+ return this.iterators.map(function(ite){
71
+ return ite.next();
72
+ })
73
+ }
74
+ }),
75
+ of: function(obj){
76
+ switch(true){
77
+ case (obj instanceof Array):
78
+ return new this.ForArray(obj);
79
+ case (typeof(obj) == "string"):
80
+ return new this.ForString(obj);
81
+ case (obj instanceof Pair):
82
+ return new this.ForList(obj);
83
+ default:
84
+ throw new Bug("Iterator.of: unknown class: "+Object.inspect(obj));
85
+ }
86
+ }
87
+ }
88
+
89
+ //
90
+ // Call.foreach - wrapper of Call
91
+ //
92
+ BiwaScheme.Call.default_callbacks = {
93
+ call: function(x){ return new Call(this.proc, [x]) },
94
+ result: Prototype.emptyFunction,
95
+ finish: Prototype.emptyFunction
96
+ }
97
+ BiwaScheme.Call.foreach = function(obj, callbacks, is_multi){
98
+ is_multi || (is_multi = false);
99
+ ["call", "result", "finish"].each(function(key){
100
+ if(!callbacks[key])
101
+ callbacks[key] = Call.default_callbacks[key];
102
+ })
103
+
104
+ var iterator = null;
105
+ var x = null;
106
+
107
+ var loop = function(ar){
108
+ if(iterator){
109
+ var ret = callbacks["result"](ar[0], x);
110
+ if(ret !== undefined) return ret;
111
+ }
112
+ else{
113
+ if(is_multi)
114
+ iterator = new Iterator.ForMulti(obj);
115
+ else
116
+ iterator = Iterator.of(obj);
117
+ }
118
+
119
+ if(!iterator.has_next())
120
+ return callbacks["finish"]();
121
+ else{
122
+ x = iterator.next();
123
+ var result = callbacks["call"](x);
124
+ result.after = loop;
125
+ return result;
126
+ }
127
+ }
128
+ return loop(null);
129
+ }
130
+ BiwaScheme.Call.multi_foreach = function(obj, callbacks){
131
+ return Call.foreach(obj, callbacks, true);
132
+ }
133
+
134
+ //
135
+ // define_*func - define library functions
136
+ //
137
+ BiwaScheme.check_arity = function(len, min, max){
138
+ var fname = arguments.callee.caller
139
+ ? arguments.callee.caller.fname
140
+ : "";
141
+ if(len < min){
142
+ if(max && max == min)
143
+ throw new Error(fname+": wrong number of arguments (expected: "+min+" got: "+len+")");
144
+ else
145
+ throw new Error(fname+": too few arguments (at least: "+min+" got: "+len+")");
146
+ }
147
+ else if(max && max < len)
148
+ throw new Error(fname+": too many arguments (at most: "+max+" got: "+len+")");
149
+ }
150
+ BiwaScheme.define_libfunc = function(fname, min, max, func){
151
+ var f = function(ar, intp){
152
+ check_arity(ar.length, min, max);
153
+ var result = func(ar, intp);
154
+ return (result === undefined) ? BiwaScheme.undef : result;
155
+ };
156
+
157
+ func["fname"] = fname; // for assert_*
158
+ f["fname"] = fname; // for check_arity
159
+ f["inspect"] = function(){ return this.fname; }
160
+ CoreEnv[fname] = f;
161
+ }
162
+ BiwaScheme.define_syntax = function(name, func){
163
+ TopEnv[name] = new Syntax(func);
164
+ }
165
+ BiwaScheme.define_scmfunc = function(fname, min, max, str){
166
+ (new Interpreter).evaluate("(define "+fname+" "+str+"\n)");
167
+ }
168
+
169
+ define_scmfunc("map+", 2, null,
170
+ "(lambda (proc ls) (if (null? ls) ls (cons (proc (car ls)) (map proc (cdr ls)))))");
171
+
172
+ //
173
+ // assert_* : type assertion
174
+ //
175
+ var make_assert = function(check){
176
+ return function(/*args*/){
177
+ var fname = arguments.callee.caller
178
+ ? arguments.callee.caller.fname
179
+ : "";
180
+ check.apply(this, [fname].concat($A(arguments)));
181
+ }
182
+ }
183
+ var make_simple_assert = function(type, test){
184
+ return make_assert(function(fname, obj){
185
+ if(!test(obj))
186
+ throw new Error(fname + ": " + type + " required, but got " + to_write(obj));
187
+ })
188
+ }
189
+ var assert_number = make_simple_assert("number", function(obj){
190
+ return typeof(obj) == 'number' || (obj instanceof Complex);
191
+ })
192
+ var assert_integer = make_simple_assert("integer", function(obj){
193
+ return typeof(obj) == 'number' && (obj % 1 == 0)
194
+ })
195
+ var assert_symbol = make_simple_assert("symbol", function(obj){
196
+ return obj instanceof Symbol;
197
+ })
198
+ var assert_string = make_simple_assert("string", function(obj){
199
+ return typeof(obj) == 'string';
200
+ })
201
+ var assert_vector = make_simple_assert("vector", function(obj){
202
+ return (obj instanceof Array) && (obj.closure_p !== true);
203
+ })
204
+ var assert_pair = make_simple_assert("pair", function(obj){
205
+ return obj instanceof Pair;
206
+ })
207
+ var assert_char = make_simple_assert("character", function(obj){
208
+ return obj instanceof Char;
209
+ })
210
+ var assert_port = make_simple_assert("port", function(obj){
211
+ return obj instanceof Port;
212
+ })
213
+ var assert_date = make_simple_assert("date", function(obj){
214
+ return obj instanceof Date;
215
+ })
216
+ var assert_hashtable = make_simple_assert("hashtable", function(obj){
217
+ return obj instanceof Hash;
218
+ })
219
+ var assert_function = make_simple_assert("JavaScript function", function(obj){
220
+ return (obj instanceof Function) || (typeof obj == 'function');
221
+ })
222
+ var assert_between = make_assert(function(fname, obj, from, to){
223
+ if( typeof(obj) != 'number' || obj != Math.round(obj) )
224
+ throw new Error(fname + ": " + "number required, but got " + to_write(obj));
225
+
226
+ if( obj < from || to < obj )
227
+ throw new Error(fname + ": " + "number must be between " +
228
+ from + " and " + to + ", but got " + to_write(obj));
229
+ })
230
+ var assert = make_assert(function(fname, test){
231
+ })
232
+
233
+ ///
234
+ /// Classes
235
+ ///
236
+
237
+ BiwaScheme.Complex = Class.create({
238
+ initialize: function(real, imag){
239
+ this.real = real;
240
+ this.imag = imag;
241
+ },
242
+ magnitude: function(){
243
+ return Math.sqrt(z.real * z.real + z.imag * z.imag);
244
+ },
245
+ angle: function(){
246
+ return Math.acos(this.real / this.magnitude());
247
+ }
248
+ })
249
+ BiwaScheme.Complex.from_polar = function(r, theta){
250
+ var real = r * Math.cos(theta);
251
+ var imag = r * Math.sin(theta);
252
+ return new Complex(real, imag);
253
+ }
254
+ BiwaScheme.Complex.assure = function(num){
255
+ if(num instanceof Complex)
256
+ return num
257
+ else
258
+ return new Complex(num, 0);
259
+ }
260
+
261
+ BiwaScheme.Rational = Class.create({
262
+ initialize: function(numerator, denominator){
263
+ this.numerator = numerator;
264
+ this.denominator = denominator;
265
+ }
266
+ })
267
+
268
+ ///
269
+ /// R6RS Base library
270
+ ///
271
+
272
+ //
273
+ // 11.4 Expressions
274
+ //
275
+ // 11.4.1 Quotation
276
+ //(quote)
277
+ // 11.4.2 Procedures
278
+ //(lambda)
279
+ // 11.4.3 Conditionaar
280
+ //(if)
281
+ // 11.4.4 Assignments
282
+ //(set!)
283
+ // 11.4.5 Derived conditionaar
284
+
285
+ define_syntax("cond", function(x){
286
+ var clauses = x.cdr;
287
+ if(!(clauses instanceof Pair) || clauses === nil){
288
+ throw new Error("malformed cond: cond needs list but got " +
289
+ to_write_ss(clauses));
290
+ }
291
+ // TODO: assert that clauses is a proper list
292
+
293
+ var ret = null;
294
+ clauses.to_array().reverse().each(function(clause){
295
+ if(!(clause instanceof Pair)){
296
+ throw new Error("bad clause in cond: " + to_write_ss(clause));
297
+ }
298
+
299
+ if(clause.car === Sym("else")){
300
+ if(ret !== null){
301
+ throw new Error("'else' clause of cond followed by more clauses: " +
302
+ to_write_ss(clauses));
303
+ }
304
+ else if(clause.cdr === nil){
305
+ // pattern A: (else)
306
+ // -> #f ; not specified in R6RS...?
307
+ ret = false;
308
+ }
309
+ else if(clause.cdr.cdr === nil){
310
+ // pattern B: (else expr)
311
+ // -> expr
312
+ ret = clause.cdr.car;
313
+ }
314
+ else{
315
+ // pattern C: (else expr ...)
316
+ // -> (begin expr ...)
317
+ ret = new Pair(Sym("begin"), clause.cdr);
318
+ }
319
+ }
320
+ else if(ret === null){
321
+ // pattern D: no else clause
322
+ // -> #<undef>
323
+ ret = BiwaScheme.undef;
324
+ }
325
+ else{
326
+ var test = clause.car;
327
+ if(clause.cdr === nil){
328
+ // pattern 1: (test)
329
+ // -> (or test ret)
330
+ ret = [Sym("or"), test, ret].to_list();
331
+ }
332
+ else if (clause.cdr.cdr === nil){
333
+ // pattern 2: (test expr)
334
+ // -> (if test expr ret)
335
+ ret = [Sym("if"), test, clause.cdr.car, ret].to_list();
336
+ }
337
+ else if(clause.cdr.car === Sym("=>")){
338
+ // pattern 3: (test => expr)
339
+ // -> (let ((#<gensym1> test))
340
+ // (if test (expr #<gensym1>) ret))
341
+ var test = clause.car, expr = clause.cdr.cdr.car;
342
+ var tmp_sym = BiwaScheme.gensym();
343
+
344
+ ret = List(Sym("let"),
345
+ List( List(tmp_sym, test) ),
346
+ List(Sym("if"), test, List(expr, tmp_sym), ret));
347
+ }
348
+ else{
349
+ // pattern 4: (test expr ...)
350
+ // -> (if test (begin expr ...) ret)
351
+ ret = [Sym("if"), test,
352
+ new Pair(Sym("begin"), clause.cdr),
353
+ ret].to_list();
354
+ }
355
+ }
356
+ });
357
+ return ret;
358
+ });
359
+
360
+ define_syntax("case", function(x){
361
+ var tmp_sym = BiwaScheme.gensym();
362
+
363
+ if(x.cdr === nil){
364
+ throw new Error("case: at least one clause is required");
365
+ }
366
+ else if(!(x.cdr instanceof Pair)){
367
+ throw new Error("case: proper list is required");
368
+ }
369
+ else{
370
+ // (case key clauses ....)
371
+ // -> (let ((#<gensym1> key))
372
+ var key = x.cdr.car;
373
+ var clauses = x.cdr.cdr;
374
+
375
+ var ret = undefined;
376
+ clauses.to_array().reverse().each(function(clause){
377
+ if(clause.car === Sym("else")){
378
+ // pattern 0: (else expr ...)
379
+ // -> (begin expr ...)
380
+ if(ret === undefined){
381
+ ret = new Pair(Sym("begin"), clause.cdr);
382
+ }
383
+ else{
384
+ throw new Error("case: 'else' clause followed by more clauses: " +
385
+ to_write_ss(clauses));
386
+ }
387
+ }
388
+ else{
389
+ // pattern 1: ((datum ...) expr ...)
390
+ // -> (if (or (eqv? key (quote d1)) ...) (begin expr ...) ret)
391
+ ret = [
392
+ Sym("if"),
393
+ new Pair(Sym("or"), clause.car.to_array().map(function(d){
394
+ return [Sym("eqv?"),
395
+ tmp_sym,
396
+ [Sym("quote"), d].to_list() ].to_list();
397
+ }).to_list()),
398
+ new Pair(Sym("begin"), clause.cdr),
399
+ ret
400
+ ].to_list();
401
+ }
402
+ });
403
+ return new Pair(Sym("let1"),
404
+ new Pair(tmp_sym,
405
+ new Pair(key,
406
+ new Pair(ret, nil))));
407
+ }
408
+ });
409
+
410
+ define_syntax("and", function(x){
411
+ // (and a b c) => (if a (if b c #f) #f)
412
+ //todo: check improper list
413
+ if(x.cdr == nil) return true;
414
+
415
+ var objs = x.cdr.to_array();
416
+ var i = objs.length-1;
417
+ var t = objs[i];
418
+ for(i=i-1; i>=0; i--)
419
+ t = [Sym("if"), objs[i], t, false].to_list();
420
+
421
+ return t;
422
+ })
423
+
424
+ define_syntax("or", function(x){
425
+ // (or a b c) => (if a a (if b b (if c c #f)))
426
+ //todo: check improper list
427
+
428
+ var objs = x.cdr.to_array()
429
+ var f = false;
430
+ for(var i=objs.length-1; i>=0; i--)
431
+ f = [Sym("if"), objs[i], objs[i], f].to_list();
432
+
433
+ return f;
434
+ })
435
+
436
+ // 11.4.6 Binding constructs
437
+ define_syntax("let", function(x){
438
+ //(let ((a 1) (b 2)) (print a) (+ a b))
439
+ //=> ((lambda (a b) (print a) (+ a b)) 1 2)
440
+ var name = null;
441
+ if (x.cdr.car instanceof Symbol) {
442
+ name = x.cdr.car;
443
+ x = x.cdr;
444
+ }
445
+ var binds = x.cdr.car, body = x.cdr.cdr;
446
+
447
+ if(!(binds instanceof Pair))
448
+ throw new Error("let: need a pair for bindings: got "+to_write(binds));
449
+
450
+ var vars = nil, vals = nil;
451
+ for(var p=binds; p instanceof Pair && p!=nil; p=p.cdr){
452
+ vars = new Pair(p.car.car, vars);
453
+ vals = new Pair(p.car.cdr.car, vals);
454
+ }
455
+
456
+ var lambda = null;
457
+ if (name) {
458
+ // (let loop ((a 1) (b 2)) body ..)
459
+ //=> (letrec ((loop (lambda (a b) body ..))) (loop 1 2))
460
+ vars = vars.to_array().reverse().to_list();
461
+ vals = vals.to_array().reverse().to_list();
462
+
463
+ var body_lambda = new Pair(Sym("lambda"), new Pair(vars, body));
464
+ var init_call = new Pair(name, vals);
465
+
466
+ lambda = [Sym("letrec"),
467
+ new Pair([name, body_lambda].to_list(), nil),
468
+ init_call
469
+ ].to_list();
470
+ }
471
+ else {
472
+ lambda = new Pair(new Pair(Sym("lambda"),
473
+ new Pair(vars, body)),
474
+ vals);
475
+ }
476
+ return lambda;
477
+ })
478
+
479
+ define_syntax("let*", function(x){
480
+ //(let* ((a 1) (b a)) (print a) (+ a b))
481
+ //-> (let ((a 1))
482
+ // (let ((b a)) (print a) (+ a b)))
483
+ var binds = x.cdr.car, body = x.cdr.cdr;
484
+
485
+ if(!(binds instanceof Pair))
486
+ throw new Error("let*: need a pair for bindings: got "+to_write(binds));
487
+
488
+ var ret = null;
489
+ binds.to_array().reverse().each(function(bind){
490
+ ret = new Pair(Sym("let"),
491
+ new Pair(new Pair(bind, nil),
492
+ ret == null ? body : new Pair(ret, nil)));
493
+ })
494
+ return ret;
495
+ })
496
+
497
+ var expand_letrec_star = function(x){
498
+ var binds = x.cdr.car, body = x.cdr.cdr;
499
+
500
+ if(!(binds instanceof Pair))
501
+ throw new Error("letrec*: need a pair for bindings: got "+to_write(binds));
502
+
503
+ var ret = body;
504
+ binds.to_array().reverse().each(function(bind){
505
+ ret = new Pair(new Pair(Sym("set!"), bind),
506
+ ret);
507
+ })
508
+ var letbody = nil;
509
+ binds.to_array().reverse().each(function(bind){
510
+ letbody = new Pair(new Pair(bind.car,
511
+ new Pair(BiwaScheme.undef, nil)),
512
+ letbody);
513
+ })
514
+ return new Pair(Sym("let"),
515
+ new Pair(letbody,
516
+ ret));
517
+ }
518
+ define_syntax("letrec", expand_letrec_star);
519
+ define_syntax("letrec*", expand_letrec_star);
520
+ //let-values
521
+ //let*-values
522
+ // 11.4.7 Sequencing
523
+ //(begin)
524
+
525
+ //
526
+ // 11.5 Equivalence predicates
527
+ //
528
+ define_libfunc("eqv?", 2, 2, function(ar){
529
+ return ar[0] == ar[1] && (typeof(ar[0]) == typeof(ar[1]));
530
+ })
531
+ define_libfunc("eq?", 2, 2, function(ar){
532
+ return ar[0] === ar[1];
533
+ })
534
+ define_libfunc("equal?", 2, 2, function(ar){
535
+ //TODO: must terminate for cyclic objects
536
+ return to_write(ar[0]) == to_write(ar[1]);
537
+ })
538
+
539
+ //
540
+ // 11.6 Procedure predicate
541
+ //
542
+ //"procedure?", 1, 1
543
+ define_libfunc("procedure?", 1, 1, function(ar){
544
+ return (ar[0] instanceof Array) && (ar[0].closure_p === true);
545
+ })
546
+
547
+ //
548
+ // 11.7 Arithmetic
549
+ //
550
+
551
+ // 11.7.1 Propagation of exactness and inexactness
552
+ // 11.7.2 Representability of infinities and NaNs
553
+ // 11.7.3 Semantics of common operations
554
+ // 11.7.3.1 Integer division
555
+ // 11.7.3.2 Transcendental functions
556
+ //(no functions are introduced by above sections)
557
+
558
+ //
559
+ // 11.7.4 Numerical operations
560
+ //
561
+
562
+ // 11.7.4.1 Numerical type predicates
563
+ define_libfunc("number?", 1, 1, function(ar){
564
+ return (typeof(ar[0]) == 'number') ||
565
+ (ar[0] instanceof Complex) ||
566
+ (ar[0] instanceof Rational);
567
+ });
568
+ define_libfunc("complex?", 1, 1, function(ar){
569
+ return (ar[0] instanceof Complex);
570
+ });
571
+ define_libfunc("real?", 1, 1, function(ar){
572
+ return (typeof(ar[0]) == 'number');
573
+ });
574
+ define_libfunc("rational?", 1, 1, function(ar){
575
+ return (ar[0] instanceof Rational);
576
+ });
577
+ define_libfunc("integer?", 1, 1, function(ar){
578
+ return typeof(ar[0]) == 'number' &&
579
+ ar[0] == Math.round(ar[0]) &&
580
+ ar[0] != Infinity &&
581
+ ar[0] != -Infinity;
582
+ });
583
+
584
+ //(real-valued? obj) procedure
585
+ //(rational-valued? obj) procedure
586
+ //(integer-valued? obj) procedure
587
+ //
588
+ //(exact? z) procedure
589
+ //(inexact? z) procedure
590
+
591
+ // 11.7.4.2 Generic conversions
592
+ //
593
+ //(inexact z) procedure
594
+ //(exact z) procedure
595
+ //
596
+ // 11.7.4.3 Arithmetic operations
597
+
598
+ //inf & nan: ok (for this section)
599
+ define_libfunc("=", 2, null, function(ar){
600
+ var v = ar[0];
601
+ assert_number(ar[0]);
602
+ for(var i=1; i<ar.length; i++){
603
+ assert_number(ar[i]);
604
+ if(ar[i] != v) return false;
605
+ }
606
+ return true;
607
+ });
608
+ define_libfunc("<", 2, null, function(ar){
609
+ assert_number(ar[0]);
610
+ for(var i=1; i<ar.length; i++){
611
+ assert_number(ar[i]);
612
+ if(!(ar[i-1] < ar[i])) return false;
613
+ }
614
+ return true;
615
+ });
616
+ define_libfunc(">", 2, null, function(ar){
617
+ assert_number(ar[0]);
618
+ for(var i=1; i<ar.length; i++){
619
+ assert_number(ar[i]);
620
+ if(!(ar[i-1] > ar[i])) return false;
621
+ }
622
+ return true;
623
+ });
624
+ define_libfunc("<=", 2, null, function(ar){
625
+ assert_number(ar[0]);
626
+ for(var i=1; i<ar.length; i++){
627
+ assert_number(ar[i]);
628
+ if(!(ar[i-1] <= ar[i])) return false;
629
+ }
630
+ return true;
631
+ });
632
+ define_libfunc(">=", 2, null, function(ar){
633
+ assert_number(ar[0]);
634
+ for(var i=1; i<ar.length; i++){
635
+ assert_number(ar[i]);
636
+ if(!(ar[i-1] >= ar[i])) return false;
637
+ }
638
+ return true;
639
+ });
640
+
641
+ define_libfunc("zero?", 1, 1, function(ar){
642
+ assert_number(ar[0]);
643
+ return ar[0] === 0;
644
+ });
645
+ define_libfunc("positive?", 1, 1, function(ar){
646
+ assert_number(ar[0]);
647
+ return (ar[0] > 0);
648
+ });
649
+ define_libfunc("negative?", 1, 1, function(ar){
650
+ assert_number(ar[0]);
651
+ return (ar[0] < 0);
652
+ });
653
+ define_libfunc("odd?", 1, 1, function(ar){
654
+ assert_number(ar[0]);
655
+ return (ar[0] % 2 == 1) || (ar[0] % 2 == -1);
656
+ })
657
+ define_libfunc("even?", 1, 1, function(ar){
658
+ assert_number(ar[0]);
659
+ return ar[0] % 2 == 0;
660
+ })
661
+ define_libfunc("finite?", 1, 1, function(ar){
662
+ assert_number(ar[0]);
663
+ return (ar[0] != Infinity) && (ar[0] != -Infinity) && !isNaN(ar[0]);
664
+ })
665
+ define_libfunc("infinite?", 1, 1, function(ar){
666
+ assert_number(ar[0]);
667
+ return (ar[0] == Infinity) || (ar[0] == -Infinity);
668
+ })
669
+ define_libfunc("nan?", 1, 1, function(ar){
670
+ assert_number(ar[0]);
671
+ return isNaN(ar[0]);
672
+ })
673
+ define_libfunc("max", 2, null, function(ar){
674
+ for(var i=0; i<ar.length; i++)
675
+ assert_number(ar[i]);
676
+
677
+ return Math.max.apply(null, ar)
678
+ });
679
+ define_libfunc("min", 2, null, function(ar){
680
+ for(var i=0; i<ar.length; i++)
681
+ assert_number(ar[i]);
682
+
683
+ return Math.min.apply(null, ar);
684
+ });
685
+
686
+ define_libfunc("+", 0,null, function(ar){
687
+ var n = 0;
688
+ for(var i=0; i<ar.length; i++){
689
+ assert_number(ar[i]);
690
+ n+=ar[i];
691
+ }
692
+ return n;
693
+ });
694
+ define_libfunc("*", 0,null, function(ar){
695
+ var n = 1;
696
+ for(var i=0; i<ar.length; i++){
697
+ assert_number(ar[i]);
698
+ n*=ar[i];
699
+ }
700
+ return n;
701
+ });
702
+ define_libfunc("-", 1,null, function(ar){
703
+ var len = ar.length;
704
+ assert_number(ar[0]);
705
+
706
+ if(len == 1)
707
+ return -ar[0];
708
+ else{
709
+ var n = ar[0];
710
+ for(var i=1; i<len; i++){
711
+ assert_number(ar[i]);
712
+ n-=ar[i];
713
+ }
714
+ return n;
715
+ }
716
+ });
717
+ //for r6rs specification, (/ 0 0) or (/ 3 0) raises '&assertion exception'
718
+ define_libfunc("/", 1,null, function(ar){
719
+ var len = ar.length;
720
+ assert_number(ar[0]);
721
+
722
+ if(len == 1)
723
+ return 1/ar[0];
724
+ else{
725
+ var n = ar[0];
726
+ for(var i=1; i<len; i++){
727
+ assert_number(ar[i]);
728
+ n/=ar[i];
729
+ }
730
+ return n;
731
+ }
732
+ });
733
+
734
+ define_libfunc("abs", 1, 1, function(ar){
735
+ assert_number(ar[0]);
736
+ return Math.abs(ar[0]);
737
+ });
738
+
739
+ var div = function(n, m){
740
+ return Math.floor(n / m);
741
+ }
742
+ var mod = function(n, m){
743
+ return n - Math.floor(n / m) * m;
744
+ }
745
+ var div0 = function(n, m){
746
+ return (n > 0) ? Math.floor(n / m) : Math.ceil(n / m);
747
+ }
748
+ var mod0 = function(n, m){
749
+ return (n > 0) ? n - Math.floor(n / m) * m
750
+ : n - Math.ceil(n / m) * m;
751
+ }
752
+ define_libfunc("div0-and-mod0", 2, 2, function(ar){
753
+ assert_number(ar[0]);
754
+ assert_number(ar[1]);
755
+ return new Values([div(ar[0], ar[1]), mod(ar[0], ar[1])]);
756
+ })
757
+ define_libfunc("div", 2, 2, function(ar){
758
+ assert_number(ar[0]);
759
+ assert_number(ar[1]);
760
+ return div(ar[0], ar[1]);
761
+ })
762
+ define_libfunc("mod", 2, 2, function(ar){
763
+ assert_number(ar[0]);
764
+ assert_number(ar[1]);
765
+ return mod(ar[0], ar[1]);
766
+ })
767
+ define_libfunc("div0-and-mod0", 2, 2, function(ar){
768
+ assert_number(ar[0]);
769
+ assert_number(ar[1]);
770
+ return new Values([div0(ar[0], ar[1]), mod0(ar[0], ar[1])]);
771
+ })
772
+ define_libfunc("div0", 2, 2, function(ar){
773
+ assert_number(ar[0]);
774
+ assert_number(ar[1]);
775
+ return div0(ar[0], ar[1]);
776
+ })
777
+ define_libfunc("mod0", 2, 2, function(ar){
778
+ assert_number(ar[0]);
779
+ assert_number(ar[1]);
780
+ return mod0(ar[0], ar[1]);
781
+ })
782
+
783
+ //(gcd n1 ...) procedure
784
+ //(lcm n1 ...) procedure
785
+
786
+ define_libfunc("numerator", 1, 1, function(ar){
787
+ assert_number(ar[0]);
788
+ if(ar[0] instanceof Rational)
789
+ return ar[0].numerator;
790
+ else
791
+ throw new Bug("todo");
792
+ })
793
+ define_libfunc("denominator", 1, 1, function(ar){
794
+ assert_number(ar[0]);
795
+ if(ar[0] instanceof Rational)
796
+ return ar[0].denominator;
797
+ else
798
+ throw new Bug("todo");
799
+ })
800
+ define_libfunc("floor", 1, 1, function(ar){
801
+ assert_number(ar[0]);
802
+ return Math.floor(ar[0]);
803
+ })
804
+ define_libfunc("ceiling", 1, 1, function(ar){
805
+ assert_number(ar[0]);
806
+ return Math.ceil(ar[0]);
807
+ })
808
+ define_libfunc("truncate", 1, 1, function(ar){
809
+ assert_number(ar[0]);
810
+ return (ar[0] < 0) ? Math.ceil(ar[0]) : Math.floor(ar[0]);
811
+ })
812
+ define_libfunc("round", 1, 1, function(ar){
813
+ assert_number(ar[0]);
814
+ return Math.round(ar[0]);
815
+ })
816
+
817
+ //(rationalize x1 x2) procedure
818
+
819
+ define_libfunc("exp", 1, 1, function(ar){
820
+ assert_number(ar[0]);
821
+ return Math.exp(ar[0]);
822
+ })
823
+ define_libfunc("log", 1, 2, function(ar){
824
+ var num = ar[0], base = ar[1];
825
+ assert_number(num);
826
+
827
+ if(base){ // log b num == log e num / log e b
828
+ assert_number(base);
829
+ return Math.log(num) / Math.log(b)
830
+ }
831
+ else
832
+ return Math.log(num);
833
+ })
834
+ define_libfunc("sin", 1, 1, function(ar){
835
+ assert_number(ar[0]);
836
+ return Math.sin(ar[0]);
837
+ })
838
+ define_libfunc("cos", 1, 1, function(ar){
839
+ assert_number(ar[0]);
840
+ return Math.cos(ar[0]);
841
+ })
842
+ define_libfunc("tan", 1, 1, function(ar){
843
+ assert_number(ar[0]);
844
+ return Math.tan(ar[0]);
845
+ })
846
+ define_libfunc("asin", 1, 1, function(ar){
847
+ assert_number(ar[0]);
848
+ return Math.asin(ar[0]);
849
+ })
850
+ define_libfunc("acos", 1, 1, function(ar){
851
+ assert_number(ar[0]);
852
+ return Math.asos(ar[0]);
853
+ })
854
+ define_libfunc("atan", 1, 2, function(ar){
855
+ assert_number(ar[0]);
856
+ if(ar[1]){
857
+ assert_number(ar[1]);
858
+ return Math.atan2(ar[0], ar[1]);
859
+ }
860
+ else
861
+ return Math.atan(ar[0]);
862
+ })
863
+ define_libfunc("sqrt", 1, 1, function(ar){
864
+ assert_number(ar[0]);
865
+ return Math.sqrt(ar[0]);
866
+ })
867
+ define_libfunc("exact-integer-sqrt", 1, 1, function(ar){
868
+ assert_number(ar[0]);
869
+ var sqrt_f = Math.sqrt(ar[0]);
870
+ var sqrt_i = sqrt_f - (sqrt_f % 1);
871
+ var rest = ar[0] - sqrt_i * sqrt_i;
872
+
873
+ return new Values([sqrt_i, rest]);
874
+ })
875
+ define_libfunc("expt", 2, 2, function(ar){
876
+ assert_number(ar[0]);
877
+ assert_number(ar[1]);
878
+ return Math.pow(ar[0], ar[1]);
879
+ })
880
+ define_libfunc("make-rectangular", 2, 2, function(ar){
881
+ assert_number(ar[0]);
882
+ assert_number(ar[1]);
883
+ return new Complex(ar[0], ar[1]);
884
+ })
885
+ define_libfunc("make-polar", 2, 2, function(ar){
886
+ assert_number(ar[0]);
887
+ assert_number(ar[1]);
888
+ return Complex.from_polar(ar[0], ar[1]);
889
+ })
890
+ define_libfunc("real-part", 1, 1, function(ar){
891
+ assert_number(ar[0]);
892
+ return Complex.assure(ar[0]).real;
893
+ })
894
+ define_libfunc("imag-part", 1, 1, function(ar){
895
+ assert_number(ar[0]);
896
+ return Complex.assure(ar[0]).imag;
897
+ })
898
+ define_libfunc("magnitude", 1, 1, function(ar){
899
+ assert_number(ar[0]);
900
+ return Complex.assure(ar[0]).magnitude();
901
+ })
902
+ define_libfunc("angle", 1, 1, function(ar){
903
+ assert_number(ar[0]);
904
+ return Complex.assure(ar[0]).angle();
905
+ })
906
+
907
+ //
908
+ // 11.7.4.4 Numerical Input and Output
909
+ //
910
+ define_libfunc("number->string", 1, 3, function(ar){
911
+ var z = ar[0], radix = ar[1], precision = ar[2];
912
+ if(precision)
913
+ throw new Bug("number->string: presition is not yet implemented");
914
+
915
+ radix = radix || 10; //TODO: check radix is 2, 8, 10, or 16.
916
+ return z.toString(radix);
917
+ })
918
+ define_libfunc("string->number", 1, 3, function(ar){
919
+ var s = ar[0], radix = ar[1] || 10;
920
+ switch(s){
921
+ case "+inf.0": return Infinity;
922
+ case "-inf.0": return -Infinity;
923
+ case "+nan.0": return NaN;
924
+ default: return parseInt(s, radix);
925
+ }
926
+ })
927
+
928
+ //
929
+ // 11.8 Booleans
930
+ //
931
+
932
+ define_libfunc("not", 1, 1, function(ar){
933
+ return (ar[0] === false) ? true : false;
934
+ });
935
+ define_libfunc("boolean?", 1, 1, function(ar){
936
+ return (ar[0] === false || ar[0] === true) ? true : false;
937
+ });
938
+ define_libfunc("boolean=?", 2, null, function(ar){
939
+ var len = ar.length;
940
+ for(var i=1; i<len; i++){
941
+ if(ar[i] != ar[0]) return false;
942
+ }
943
+ return true;
944
+ });
945
+
946
+ // 11.9 Pairs and lists
947
+
948
+ define_libfunc("pair?", 1, 1, function(ar){
949
+ return (ar[0] instanceof Pair && ar[0] != nil) ? true : false;
950
+ });
951
+ define_libfunc("cons", 2, 2, function(ar){
952
+ return new Pair(ar[0], ar[1]);
953
+ });
954
+ define_libfunc("car", 1, 1, function(ar){
955
+ //should raise &assertion for '()...
956
+ if(!ar[0] instanceof Pair) throw new Error("cannot take car of " + ar[0]);
957
+ return ar[0].car;
958
+ });
959
+ define_libfunc("cdr", 1, 1, function(ar){
960
+ //should raise &assertion for '()...
961
+ if(!ar[0] instanceof Pair) throw new Error("cannot take cdr of " + ar[0]);
962
+ return ar[0].cdr;
963
+ });
964
+ define_libfunc("set-car!", 2, 2, function(ar){
965
+ if(!ar[0] instanceof Pair) throw new Error("cannot take set-car! of " + ar[0]);
966
+ ar[0].car = ar[1];
967
+ });
968
+ define_libfunc("set-cdr!", 2, 2, function(ar){
969
+ if(!ar[0] instanceof Pair) throw new Error("cannot take set-cdr! of " + ar[0]);
970
+ ar[0].cdr = ar[1];
971
+ });
972
+
973
+ define_libfunc("caar", 1, 1, function(ar){ return ar[0].car.car; });
974
+ define_libfunc("cadr", 1, 1, function(ar){ return ar[0].cdr.car; });
975
+ define_libfunc("cdar", 1, 1, function(ar){ return ar[0].car.cdr; });
976
+ define_libfunc("cddr", 1, 1, function(ar){ return ar[0].cdr.cdr; });
977
+ define_libfunc("caaar", 1, 1, function(ar){ return ar[0].car.car.car; });
978
+ define_libfunc("caadr", 1, 1, function(ar){ return ar[0].cdr.car.car; });
979
+ define_libfunc("cadar", 1, 1, function(ar){ return ar[0].car.cdr.car; });
980
+ define_libfunc("caddr", 1, 1, function(ar){ return ar[0].cdr.cdr.car; });
981
+ define_libfunc("cdaar", 1, 1, function(ar){ return ar[0].car.car.cdr; });
982
+ define_libfunc("cdadr", 1, 1, function(ar){ return ar[0].cdr.car.cdr; });
983
+ define_libfunc("cddar", 1, 1, function(ar){ return ar[0].car.cdr.cdr; });
984
+ define_libfunc("cdddr", 1, 1, function(ar){ return ar[0].cdr.cdr.cdr; });
985
+ define_libfunc("caaaar", 1, 1, function(ar){ return ar[0].car.car.car.car; });
986
+ define_libfunc("caaadr", 1, 1, function(ar){ return ar[0].cdr.car.car.car; });
987
+ define_libfunc("caadar", 1, 1, function(ar){ return ar[0].car.cdr.car.car; });
988
+ define_libfunc("caaddr", 1, 1, function(ar){ return ar[0].cdr.cdr.car.car; });
989
+ define_libfunc("cadaar", 1, 1, function(ar){ return ar[0].car.car.cdr.car; });
990
+ define_libfunc("cadadr", 1, 1, function(ar){ return ar[0].cdr.car.cdr.car; });
991
+ define_libfunc("caddar", 1, 1, function(ar){ return ar[0].car.cdr.cdr.car; });
992
+ define_libfunc("cadddr", 1, 1, function(ar){ return ar[0].cdr.cdr.cdr.car; });
993
+ define_libfunc("cdaaar", 1, 1, function(ar){ return ar[0].car.car.car.cdr; });
994
+ define_libfunc("cdaadr", 1, 1, function(ar){ return ar[0].cdr.car.car.cdr; });
995
+ define_libfunc("cdadar", 1, 1, function(ar){ return ar[0].car.cdr.car.cdr; });
996
+ define_libfunc("cdaddr", 1, 1, function(ar){ return ar[0].cdr.cdr.car.cdr; });
997
+ define_libfunc("cddaar", 1, 1, function(ar){ return ar[0].car.car.cdr.cdr; });
998
+ define_libfunc("cddadr", 1, 1, function(ar){ return ar[0].cdr.car.cdr.cdr; });
999
+ define_libfunc("cdddar", 1, 1, function(ar){ return ar[0].car.cdr.cdr.cdr; });
1000
+ define_libfunc("cddddr", 1, 1, function(ar){ return ar[0].cdr.cdr.cdr.cdr; });
1001
+
1002
+ define_libfunc("null?", 1, 1, function(ar){
1003
+ return (ar[0] === nil);
1004
+ });
1005
+ define_libfunc("list?", 1, 1, function(ar){
1006
+ var contents = [];
1007
+ for(var o=ar[0]; o != nil; o=o.cdr){
1008
+ if(!(o instanceof Pair)) return false;
1009
+ if(contents.find(function(item){ return item === o.car}))
1010
+ return false; //cyclic
1011
+ contents.push(o.car);
1012
+ }
1013
+ return true;
1014
+ });
1015
+ define_libfunc("list", 0, null, function(ar){
1016
+ var l = nil;
1017
+ for(var i=ar.length-1; i>=0; i--)
1018
+ l = new Pair(ar[i], l);
1019
+ return l;
1020
+ });
1021
+ define_libfunc("length", 1, 1, function(ar){
1022
+ assert_pair(ar[0]);
1023
+
1024
+ var n = 0;
1025
+ for(var o=ar[0]; o!=nil; o=o.cdr)
1026
+ n++;
1027
+ return n;
1028
+ });
1029
+ define_libfunc("append", 2, null, function(ar){
1030
+ var k = ar.length
1031
+ var ret = ar[--k];
1032
+ while(k--){
1033
+ ar[k].to_array().reverse().each(function(item){
1034
+ ret = new Pair(item, ret);
1035
+ });
1036
+ }
1037
+ return ret;
1038
+ });
1039
+ define_libfunc("reverse", 1, 1, function(ar){
1040
+ if(!ar[0] instanceof Pair) throw new Error("reverse needs pair but got " + ar[0]);
1041
+
1042
+ var l = nil;
1043
+ for(var o=ar[0]; o!=nil; o=o.cdr)
1044
+ l = new Pair(o.car, l);
1045
+ return l;
1046
+ });
1047
+ define_libfunc("list-tail", 2, 2, function(ar){
1048
+ if(!ar[0] instanceof Pair) throw new Error("list-tail needs pair but got " + ar[0]);
1049
+
1050
+ var o = ar[0];
1051
+ for(var i=0; i<ar[1]; i++){
1052
+ if(!o instanceof Pair) throw new Error("list-tail: the list is shorter than " + ar[1]);
1053
+ o = o.cdr;
1054
+ }
1055
+ return o;
1056
+ });
1057
+ define_libfunc("list-ref", 2, 2, function(ar){
1058
+ if(!ar[0] instanceof Pair) throw new Error("list-ref needs pair but got " + ar[0]);
1059
+
1060
+ var o = ar[0];
1061
+ for(var i=0; i<ar[1]; i++){
1062
+ if(!o instanceof Pair) throw new Error("list-ref: the list is shorter than " + ar[1]);
1063
+ o = o.cdr;
1064
+ }
1065
+ return o.car;
1066
+ });
1067
+ define_libfunc("map", 2, null, function(ar){
1068
+ var proc = ar.shift(), lists = ar;
1069
+ lists.each(function(ls){ assert_pair(ls) });
1070
+
1071
+ var a = [];
1072
+ return Call.multi_foreach(lists, {
1073
+ call: function(xs){
1074
+ return new Call(proc, xs.map(function(x){ return x.car }));
1075
+ },
1076
+ result: function(res){ a.push(res); },
1077
+ finish: function(){ return a.to_list(); }
1078
+ })
1079
+ })
1080
+ define_libfunc("for-each", 2, null, function(ar){
1081
+ var proc = ar.shift(), lists = ar;
1082
+ lists.each(function(ls){ assert_pair(ls) });
1083
+
1084
+ return Call.multi_foreach(lists, {
1085
+ call: function(xs){
1086
+ return new Call(proc, xs.map(function(x){ return x.car }));
1087
+ }
1088
+ })
1089
+ })
1090
+
1091
+ // 11.10 Symbols
1092
+
1093
+ define_libfunc("symbol?", 1, 1, function(ar){
1094
+ return (ar[0] instanceof Symbol) ? true : false;
1095
+ });
1096
+ define_libfunc("symbol->string", 1, 1, function(ar){
1097
+ assert_symbol(ar[0]);
1098
+ return ar[0].name;
1099
+ });
1100
+ define_libfunc("symbol=?", 2, null, function(ar){
1101
+ assert_symbol(ar[0]);
1102
+ for(var i=1; i<ar.length; i++){
1103
+ assert_symbol(ar[i]);
1104
+ if(ar[i] != ar[0]) return false;
1105
+ }
1106
+ return true;
1107
+ });
1108
+ define_libfunc("string->symbol", 1, 1, function(ar){
1109
+ assert_string(ar[0]);
1110
+ return Sym(ar[0]);
1111
+ });
1112
+
1113
+ //
1114
+ // 11.11 Characters
1115
+ //
1116
+ define_libfunc('char?', 1, 1, function(ar){
1117
+ return (ar[0] instanceof Char);
1118
+ });
1119
+ define_libfunc('char->integer', 1, 1, function(ar){
1120
+ assert_char(ar[0]);
1121
+ return ar[0].value.charCodeAt(0);
1122
+ })
1123
+ define_libfunc('integer->char', 1, 1, function(ar){
1124
+ assert_integer(ar[0]);
1125
+ return Char.get(String.fromCharCode(ar[0]));
1126
+ })
1127
+
1128
+ var make_char_compare_func = function(test){
1129
+ return function(ar){
1130
+ assert_char(ar[0]);
1131
+ for(var i=1; i<ar.length; i++){
1132
+ assert_char(ar[i]);
1133
+ if(!test(ar[i-1].value, ar[i].value))
1134
+ return false;
1135
+ }
1136
+ return true;
1137
+ }
1138
+ }
1139
+ define_libfunc('char=?', 2, null,
1140
+ make_char_compare_func(function(a, b){ return a == b }))
1141
+ define_libfunc('char<?', 2, null,
1142
+ make_char_compare_func(function(a, b){ return a < b }))
1143
+ define_libfunc('char>?', 2, null,
1144
+ make_char_compare_func(function(a, b){ return a > b }))
1145
+ define_libfunc('char<=?', 2, null,
1146
+ make_char_compare_func(function(a, b){ return a <= b }))
1147
+ define_libfunc('char>=?', 2, null,
1148
+ make_char_compare_func(function(a, b){ return a >= b }))
1149
+
1150
+ //
1151
+ // 11.12 Strings
1152
+ //
1153
+ define_libfunc("string?", 1, 1, function(ar){
1154
+ return (typeof(ar[0]) == "string");
1155
+ })
1156
+ define_libfunc("make-string", 1, 2, function(ar){
1157
+ assert_integer(ar[0]);
1158
+ var c = " ";
1159
+ if(ar[1]){
1160
+ assert_char(ar[1]);
1161
+ c = ar[1].value;
1162
+ }
1163
+ return c.times(ar[0]);
1164
+ })
1165
+ define_libfunc("string", 1, null, function(ar){
1166
+ for(var i=0; i<ar.length; i++)
1167
+ assert_char(ar[i]);
1168
+ return ar.map(function(c){ return c.value }).join("");
1169
+ })
1170
+ define_libfunc("string-length", 1, 1, function(ar){
1171
+ assert_string(ar[0]);
1172
+ return ar[0].length;
1173
+ })
1174
+ define_libfunc("string-ref", 2, 2, function(ar){
1175
+ assert_string(ar[0]);
1176
+ assert_between(ar[1], 0, ar[0].length-1);
1177
+ return Char.get(ar[0].charAt([ar[1]]));
1178
+ })
1179
+ define_libfunc("string=?", 2, null, function(ar){
1180
+ assert_string(ar[0]);
1181
+ for(var i=1; i<ar.length; i++){
1182
+ assert_string(ar[i]);
1183
+ if(ar[0] != ar[i]) return false;
1184
+ }
1185
+ return true;
1186
+ })
1187
+ define_libfunc("string<?", 2, null, function(ar){
1188
+ assert_string(ar[0]);
1189
+ for(var i=1; i<ar.length; i++){
1190
+ assert_string(ar[i]);
1191
+ if(!(ar[i-1] < ar[i])) return false;
1192
+ }
1193
+ return true;
1194
+ })
1195
+ define_libfunc("string>?", 2, null, function(ar){
1196
+ assert_string(ar[0]);
1197
+ for(var i=1; i<ar.length; i++){
1198
+ assert_string(ar[i]);
1199
+ if(!(ar[i-1] > ar[i])) return false;
1200
+ }
1201
+ return true;
1202
+ })
1203
+ define_libfunc("string<=?", 2, null, function(ar){
1204
+ assert_string(ar[0]);
1205
+ for(var i=1; i<ar.length; i++){
1206
+ assert_string(ar[i]);
1207
+ if(!(ar[i-1] <= ar[i])) return false;
1208
+ }
1209
+ return true;
1210
+ })
1211
+ define_libfunc("string>=?", 2, null, function(ar){
1212
+ assert_string(ar[0]);
1213
+ for(var i=1; i<ar.length; i++){
1214
+ assert_string(ar[i]);
1215
+ if(!(ar[i-1] >= ar[i])) return false;
1216
+ }
1217
+ return true;
1218
+ })
1219
+
1220
+ define_libfunc("substring", 3, 3, function(ar){
1221
+ assert_string(ar[0]);
1222
+ assert_integer(ar[1]);
1223
+ assert_integer(ar[2]);
1224
+
1225
+ if(ar[1] < 0) throw new Error("substring: start too small: "+ar[1]);
1226
+ if(ar[2] < 0) throw new Error("substring: end too small: "+ar[2]);
1227
+ if(ar[0].length+1 <= ar[1]) throw new Error("substring: start too big: "+ar[1]);
1228
+ if(ar[0].length+1 <= ar[2]) throw new Error("substring: end too big: "+ar[2]);
1229
+ if(!(ar[1] <= ar[2])) throw new Error("substring: not start <= end: "+ar[1]+", "+ar[2]);
1230
+
1231
+ return ar[0].substring(ar[1], ar[2]);
1232
+ })
1233
+
1234
+ define_libfunc("string-append", 0, null, function(ar){
1235
+ for(var i=0; i<ar.length; i++)
1236
+ assert_string(ar[i]);
1237
+
1238
+ return ar.join("");
1239
+ })
1240
+ define_libfunc("string->list", 1, 1, function(ar){
1241
+ assert_string(ar[0]);
1242
+ var chars = [];
1243
+ ar[0].scan(/./, function(s){ chars.push(Char.get(s[0])) });
1244
+ return chars.to_list();
1245
+ })
1246
+ define_libfunc("list->string", 1, 1, function(ar){
1247
+ assert_pair(ar[0]);
1248
+ return ar[0].to_array().map(function(c){ return c.value; }).join("");
1249
+ })
1250
+ define_libfunc("string-for-each", 2, null, function(ar){
1251
+ var proc = ar.shift(), strs = ar;
1252
+ strs.each(function(str){ assert_string(str) });
1253
+
1254
+ return Call.multi_foreach(strs, {
1255
+ call: function(chars){ return new Call(proc, chars); }
1256
+ })
1257
+ })
1258
+ define_libfunc("string-copy", 1, 1, function(ar){
1259
+ // note: this is useless, because javascript strings are immutable
1260
+ assert_string(ar[0]);
1261
+ return ar[0];
1262
+ })
1263
+
1264
+
1265
+ //
1266
+ // 11.13 Vectors
1267
+ //
1268
+ define_libfunc("vector?", 1, 1, function(ar){
1269
+ return (ar[0] instanceof Array) && (ar[0].closure_p !== true)
1270
+ })
1271
+ define_libfunc("make-vector", 1, 2, function(ar){
1272
+ assert_integer(ar[0]);
1273
+ var vec = new Array(ar[0]);
1274
+
1275
+ if(ar.length == 2){
1276
+ for(var i=0; i<ar[0]; i++)
1277
+ vec[i] = ar[1];
1278
+ }
1279
+ return vec;
1280
+ })
1281
+ define_libfunc("vector", 1, null, function(ar){
1282
+ return ar;
1283
+ })
1284
+ define_libfunc("vector-length", 1, 1, function(ar){
1285
+ assert_vector(ar[0]);
1286
+ return ar[0].length;
1287
+ })
1288
+ define_libfunc("vector-ref", 2, 2, function(ar){
1289
+ assert_vector(ar[0]);
1290
+ assert_integer(ar[1]);
1291
+
1292
+ return ar[0][ar[1]];
1293
+ })
1294
+ define_libfunc("vector-set!", 3, 3, function(ar){
1295
+ assert_vector(ar[0]);
1296
+ assert_integer(ar[1]);
1297
+
1298
+ ar[0][ar[1]] = ar[2];
1299
+ })
1300
+ define_libfunc("vector->list", 1, 1, function(ar){
1301
+ assert_vector(ar[0]);
1302
+ return ar[0].to_list();
1303
+ })
1304
+ define_libfunc("list->vector", 1, 1, function(ar){
1305
+ assert_pair(ar[0]);
1306
+ return ar[0].to_array();
1307
+ })
1308
+ define_libfunc("vector-fill!", 2, 2, function(ar){
1309
+ assert_vector(ar[0]);
1310
+ var vec = ar[0], obj = ar[1];
1311
+
1312
+ for(var i=0; i<vec.length; i++)
1313
+ vec[i] = obj;
1314
+ return vec;
1315
+ })
1316
+ define_libfunc("vector-map", 2, null, function(ar){
1317
+ var proc = ar.shift(), vecs = ar;
1318
+ vecs.each(function(vec){ assert_vector(vec) });
1319
+
1320
+ var a = [];
1321
+ return Call.multi_foreach(vecs, {
1322
+ call: function(objs){ return new Call(proc, objs); },
1323
+ result: function(res){ a.push(res); },
1324
+ finish: function(){ return a; }
1325
+ })
1326
+ })
1327
+ define_libfunc("vector-for-each", 2, null, function(ar){
1328
+ var proc = ar.shift(), vecs = ar;
1329
+ vecs.each(function(vec){ assert_vector(vec) });
1330
+
1331
+ return Call.multi_foreach(vecs, {
1332
+ call: function(objs){ return new Call(proc, objs); }
1333
+ })
1334
+ })
1335
+
1336
+ //
1337
+ // 11.14 Errors and violations
1338
+ //
1339
+ //(error who message irritant1 ...) procedure
1340
+ //(assertion-violation who message irritant1 ...) procedure
1341
+ //(assert <expression>) syntax
1342
+
1343
+ //
1344
+ // 11.15 Control features
1345
+ //
1346
+ define_libfunc("apply", 2, null, function(ar){
1347
+ var proc = ar.shift(), rest_args = ar.pop(), args = ar;
1348
+ args = args.concat(rest_args.to_array());
1349
+
1350
+ return new Call(proc, args);
1351
+ })
1352
+ define_syntax("call-with-current-continuation", function(x){
1353
+ return new Pair(Sym("call/cc"),
1354
+ x.cdr);
1355
+ })
1356
+ define_libfunc("values", 0, null, function(ar){
1357
+ return new Values(ar);
1358
+ })
1359
+ define_libfunc("call-with-values", 2, 2, function(ar){
1360
+ var producer = ar[0], consumer = ar[1];
1361
+ return new Call(producer, [], function(ar){
1362
+ var values = ar[0];
1363
+ if(!(values instanceof Values))
1364
+ throw new Error("values expected, but got "+to_write(values));
1365
+
1366
+ return new Call(consumer, values.content);
1367
+ })
1368
+ })
1369
+
1370
+ //
1371
+ //dynamic-wind
1372
+
1373
+ // 11.16 Iteration
1374
+ //named let
1375
+
1376
+ // 11.17 Quasiquotation
1377
+ //quasiquote
1378
+ var expand_qq = function(f, lv){
1379
+ if(f instanceof Symbol || f === nil){
1380
+ return [Sym("quote"), f].to_list();
1381
+ }
1382
+ else if(f instanceof Pair){
1383
+ var car = f.car;
1384
+ if(car instanceof Pair && car.car === Sym("unquote-splicing")){
1385
+ var lv = lv-1;
1386
+ if(lv == 0)
1387
+ return [ Sym("append"),
1388
+ f.car.cdr.car,
1389
+ expand_qq(f.cdr, lv+1)
1390
+ ].to_list();
1391
+ else
1392
+ return [ Sym("cons"),
1393
+ [Sym("list"), Sym("unquote-splicing"), expand_qq(f.car.cdr.car, lv)].to_list(),
1394
+ expand_qq(f.cdr, lv+1)
1395
+ ].to_list();
1396
+ }
1397
+ else if(car === Sym("unquote")){
1398
+ var lv = lv-1;
1399
+ if(lv == 0)
1400
+ return f.cdr.car;
1401
+ else
1402
+ return [ Sym("list"),
1403
+ [Sym("quote"), Sym("unquote")].to_list(),
1404
+ expand_qq(f.cdr.car, lv)
1405
+ ].to_list();
1406
+ }
1407
+ else if(car === Sym("quasiquote"))
1408
+ return [
1409
+ Sym("list"),
1410
+ Sym("quasiquote"),
1411
+ expand_qq(f.cdr.car, lv+1)
1412
+ ].to_list();
1413
+ else
1414
+ return [
1415
+ Sym("cons"),
1416
+ expand_qq(f.car, lv),
1417
+ expand_qq(f.cdr, lv)
1418
+ ].to_list();
1419
+ }
1420
+ else if(f instanceof Array){
1421
+ throw new Bug("vector quasiquotation is not implemented yet");
1422
+ }
1423
+ // // `#(1 2 (unquote f))
1424
+ // // (vector 1 2 f)
1425
+ // // `#(1 2 (unquote-splicing f) 3)
1426
+ // // (vector-append
1427
+ // // (vector 1 2)
1428
+ // // f
1429
+ // // (vector 3))
1430
+ // // `#(1 2 `#(3 ,,f) 4)
1431
+ // // (vector 1 2 `#(3 ,g) 4)
1432
+ // var len = f.length;
1433
+ // if(len == 0) return f;
1434
+ //
1435
+ // var vecs = [[]];
1436
+ // for(var i=0; i<len; i++){
1437
+ // if(f[i] instanceof Pair){
1438
+ // if(f[i].car === Sym("unquote")){
1439
+ // var lv = lv - 1;
1440
+ // if(lv == 0)
1441
+ // vecs.last().push(f[i]);
1442
+ // else
1443
+ // vecs.push()
1444
+ // }
1445
+ // }
1446
+ //
1447
+ // var car = f[0];
1448
+ // if(car === Sym("unquote")){
1449
+ // var lv = lv - 1;
1450
+ // if(lv == 0)
1451
+ // return f.cdr.car;
1452
+ // else
1453
+ // return [ Sym("vector"),
1454
+ // [Sym("quote"), Sym("unquote")].to_list(),
1455
+ // expand_qq(f.cdr.car, lv)
1456
+ // ].to_list();
1457
+ // }
1458
+ // else{
1459
+ //// return [ Sym("vector"),
1460
+ //// expand_qq(
1461
+ // }
1462
+ // }
1463
+ // }
1464
+ else
1465
+ return f;
1466
+ }
1467
+ define_syntax("quasiquote", function(x){
1468
+ return expand_qq(x.cdr.car, 1);
1469
+ })
1470
+ //unquote
1471
+ define_syntax("unquote", function(x){
1472
+ throw new Error("unquote(,) must be inside quasiquote(`)");
1473
+ })
1474
+ //unquote-splicing
1475
+ define_syntax("unquote-splicing", function(x){
1476
+ throw new Error("unquote-splicing(,@) must be inside quasiquote(`)");
1477
+ })
1478
+
1479
+ // 11.18 Binding constructs for syntactic keywords
1480
+ //let-syntax
1481
+ //letrec-syntax
1482
+
1483
+ // 11.19 Macro transformers
1484
+ //syntax-rules
1485
+ //identifier-syntax
1486
+ //
1487
+
1488
+ // 11.20 Tail calls and tail contexts
1489
+ //(no library function introduced)
1490
+
1491
+
1492
+ ///
1493
+ /// R6RS Standard Libraries
1494
+ ///
1495
+
1496
+ //
1497
+ // Chapter 1 Unicode
1498
+ //
1499
+ //(char-upcase char) procedure
1500
+ //(char-downcase char) procedure
1501
+ //(char-titlecase char) procedure
1502
+ //(char-foldcase char) procedure
1503
+ //
1504
+ //(char-ci=? char1 char2 char3 ...) procedure
1505
+ //(char-ci<? char1 char2 char3 ...) procedure
1506
+ //(char-ci>? char1 char2 char3 ...) procedure
1507
+ //(char-ci<=? char1 char2 char3 ...) procedure
1508
+ //(char-ci>=? char1 char2 char3 ...) procedure
1509
+ //
1510
+ //(char-alphabetic? char) procedure
1511
+ //(char-numeric? char) procedure
1512
+ //(char-whitespace? char) procedure
1513
+ //(char-upper-case? char) procedure
1514
+ //(char-lower-case? char) procedure
1515
+ //(char-title-case? char) procedure
1516
+ //
1517
+ //(char-general-category char) procedure
1518
+
1519
+ //(string-upcase string) procedure
1520
+ //(string-downcase string) procedure
1521
+ //(string-titlecase string) procedure
1522
+ //(string-foldcase string) procedure
1523
+ //
1524
+ //(string-ci=? string1 string2 string3 ...) procedure
1525
+ //(string-ci<? string1 string2 string3 ...) procedure
1526
+ //(string-ci>? string1 string2 string3 ...) procedure
1527
+ //(string-ci<=? string1 string2 string3 ...) procedure
1528
+ //(string-ci>=? string1 string2 string3 ...) procedure
1529
+ //
1530
+ //(string-normalize-nfd string) procedure
1531
+ //(string-normalize-nfkd string) procedure
1532
+ //(string-normalize-nfc string) procedure
1533
+ //(string-normalize-nfkc string) procedure
1534
+
1535
+ //
1536
+ // Chapter 2 Bytevectors
1537
+ //
1538
+
1539
+ //
1540
+ // Chapter 3 List utilities
1541
+ //
1542
+ define_libfunc("find", 2, 2, function(ar){
1543
+ var proc = ar[0], ls = ar[1];
1544
+ assert_pair(ls);
1545
+ return Call.foreach(ls, {
1546
+ call: function(x){ return new Call(proc, [x.car]) },
1547
+ result: function(res, x){ if(res) return x.car; },
1548
+ finish: function(){ return false }
1549
+ })
1550
+ })
1551
+ define_libfunc("for-all", 2, null, function(ar){
1552
+ var proc = ar.shift();
1553
+ var lists = ar;
1554
+ lists.each(function(ls){ assert_pair(ls) });
1555
+
1556
+ var last = true; //holds last result which proc returns
1557
+ return Call.multi_foreach(lists, {
1558
+ call: function(pairs){
1559
+ return new Call(proc, pairs.map(function(x){ return x.car }));
1560
+ },
1561
+ result: function(res, pairs){
1562
+ if(res === false) return false;
1563
+ last = res;
1564
+ },
1565
+ finish: function(){ return last; }
1566
+ })
1567
+ })
1568
+ define_libfunc("exists", 2, null, function(ar){
1569
+ var proc = ar.shift();
1570
+ var lists = ar;
1571
+ lists.each(function(ls){ assert_pair(ls) });
1572
+
1573
+ return Call.multi_foreach(lists, {
1574
+ call: function(pairs){
1575
+ return new Call(proc, pairs.map(function(x){ return x.car }));
1576
+ },
1577
+ result: function(res, pairs){
1578
+ if(res !== false) return res;
1579
+ },
1580
+ finish: function(){ return false; }
1581
+ })
1582
+ })
1583
+ define_libfunc("filter", 2, 2, function(ar){
1584
+ var proc = ar[0], ls = ar[1];
1585
+ assert_pair(ls);
1586
+
1587
+ var a = [];
1588
+ return Call.foreach(ls, {
1589
+ call: function(x){ return new Call(proc, [x.car]) },
1590
+ result: function(res, x){ if(res) a.push(x.car); },
1591
+ finish: function(){ return a.to_list() }
1592
+ })
1593
+ })
1594
+ define_scmfunc("partition+", 2, 2,
1595
+ "(lambda (proc ls) \
1596
+ (define (partition2 proc ls t f) \
1597
+ (if (null? ls) \
1598
+ (values (reverse t) (reverse f)) \
1599
+ (if (proc (car ls)) \
1600
+ (partition2 proc (cdr ls) (cons (car ls) t) f) \
1601
+ (partition2 proc (cdr ls) t (cons (car ls) f))))) \
1602
+ (partition2 proc ls '() '()))");
1603
+
1604
+ define_libfunc("partition", 2, 2, function(ar){
1605
+ var proc = ar[0], ls = ar[1];
1606
+ assert_pair(ls);
1607
+
1608
+ var t = [], f = [];
1609
+ return Call.foreach(ls, {
1610
+ call: function(x){ return new Call(proc, [x.car]) },
1611
+ result: function(res, x){
1612
+ if(res) t.push(x.car);
1613
+ else f.push(x.car);
1614
+ },
1615
+ finish: function(){
1616
+ return new Values([t.to_list(), f.to_list()]);
1617
+ }
1618
+ })
1619
+ })
1620
+ define_libfunc("fold-left", 3, null, function(ar){
1621
+ var proc = ar.shift(), accum = ar.shift(), lists = ar;
1622
+ lists.each(function(ls){ assert_pair(ls) });
1623
+
1624
+ return Call.multi_foreach(lists, {
1625
+ call: function(pairs){
1626
+ var args = pairs.map(function(x){ return x.car });
1627
+ args.unshift(accum);
1628
+ return new Call(proc, args);
1629
+ },
1630
+ result: function(res, pairs){ accum = res; },
1631
+ finish: function(){ return accum; }
1632
+ })
1633
+ })
1634
+ define_libfunc("fold-right", 3, null, function(ar){
1635
+ var proc = ar.shift(), accum = ar.shift();
1636
+ var lists = ar.map(function(ls){
1637
+ // reverse each list
1638
+ assert_pair(ls);
1639
+ return ls.to_array().reverse().to_list();
1640
+ })
1641
+
1642
+ return Call.multi_foreach(lists, {
1643
+ call: function(pairs){
1644
+ var args = pairs.map(function(x){ return x.car });
1645
+ args.push(accum);
1646
+ return new Call(proc, args);
1647
+ },
1648
+ result: function(res, pairs){ accum = res; },
1649
+ finish: function(){ return accum; }
1650
+ })
1651
+ })
1652
+ define_libfunc("remp", 2, 2, function(ar){
1653
+ var proc = ar[0], ls = ar[1];
1654
+ assert_pair(ls);
1655
+
1656
+ var ret = [];
1657
+ return Call.foreach(ls, {
1658
+ call: function(x){ return new Call(proc, [x.car]) },
1659
+ result: function(res, x){ if(!res) ret.push(x.car); },
1660
+ finish: function(){ return ret.to_list(); }
1661
+ })
1662
+ })
1663
+ var make_remover = function(key){
1664
+ return function(ar){
1665
+ var obj = ar[0], ls = ar[1];
1666
+ assert_pair(ls);
1667
+
1668
+ var ret = [];
1669
+ return Call.foreach(ls, {
1670
+ call: function(x){
1671
+ return new Call(TopEnv[key] || CoreEnv[key], [obj, x.car])
1672
+ },
1673
+ result: function(res, x){ if(!res) ret.push(x.car); },
1674
+ finish: function(){ return ret.to_list(); }
1675
+ })
1676
+ }
1677
+ }
1678
+ define_libfunc("remove", 2, 2, make_remover("equal?"));
1679
+ define_libfunc("remv", 2, 2, make_remover("eqv?"));
1680
+ define_libfunc("remq", 2, 2, make_remover("eq?"));
1681
+
1682
+ define_libfunc("memp", 2, 2, function(ar){
1683
+ var proc = ar[0], ls = ar[1];
1684
+ assert_pair(ls);
1685
+
1686
+ var ret = [];
1687
+ return Call.foreach(ls, {
1688
+ call: function(x){ return new Call(proc, [x.car]) },
1689
+ result: function(res, x){ if(res) return x; },
1690
+ finish: function(){ return false; }
1691
+ })
1692
+ })
1693
+ var make_finder = function(key){
1694
+ return function(ar){
1695
+ var obj = ar[0], ls = ar[1];
1696
+ assert_pair(ls);
1697
+
1698
+ var ret = [];
1699
+ return Call.foreach(ls, {
1700
+ call: function(x){
1701
+ return new Call(TopEnv[key] || CoreEnv[key], [obj, x.car])
1702
+ },
1703
+ result: function(res, x){ if(res) return x; },
1704
+ finish: function(){ return false; }
1705
+ })
1706
+ }
1707
+ }
1708
+ define_libfunc("member", 2, 2, make_finder("equal?"));
1709
+ define_libfunc("memv", 2, 2, make_finder("eqv?"));
1710
+ define_libfunc("memq", 2, 2, make_finder("eq?"));
1711
+
1712
+ define_libfunc("assp", 2, 2, function(ar){
1713
+ var proc = ar[0], als = ar[1];
1714
+ assert_pair(als);
1715
+
1716
+ var ret = [];
1717
+ return Call.foreach(als, {
1718
+ call: function(x){
1719
+ if(x.car.car)
1720
+ return new Call(proc, [x.car.car]);
1721
+ else
1722
+ throw new Error("ass*: pair required but got "+to_write(x.car));
1723
+ },
1724
+ result: function(res, x){ if(res) return x.car; },
1725
+ finish: function(){ return false; }
1726
+ })
1727
+ })
1728
+ var make_assoc = function(key){
1729
+ return function(ar){
1730
+ var obj = ar[0], ls = ar[1];
1731
+ assert_pair(ls);
1732
+
1733
+ var ret = [];
1734
+ return Call.foreach(ls, {
1735
+ call: function(x){
1736
+ if(x.car.car)
1737
+ return new Call(TopEnv[key] || CoreEnv[key], [obj, x.car.car])
1738
+ else
1739
+ throw new Error("ass*: pair required but got "+to_write(x.car));
1740
+ },
1741
+ result: function(res, x){ if(res) return x.car; },
1742
+ finish: function(){ return false; }
1743
+ })
1744
+ }
1745
+ }
1746
+ define_libfunc("assoc", 2, 2, make_assoc("equal?"));
1747
+ define_libfunc("assv", 2, 2, make_assoc("eqv?"));
1748
+ define_libfunc("assq", 2, 2, make_assoc("eq?"));
1749
+
1750
+ define_libfunc("cons*", 1, null, function(ar){
1751
+ if(ar.length == 1)
1752
+ return ar[0];
1753
+ else{
1754
+ var ret = null;
1755
+ ar.reverse().each(function(x){
1756
+ if(ret){
1757
+ ret = new Pair(x, ret);
1758
+ }
1759
+ else
1760
+ ret = x;
1761
+ })
1762
+ return ret;
1763
+ }
1764
+ })
1765
+
1766
+ //
1767
+ // Chapter 4 Sorting
1768
+ //
1769
+ //(list-sort proc list) procedure
1770
+ //(vector-sort proc vector) procedure
1771
+ //(vector-sort! proc vector) procedure
1772
+
1773
+ //
1774
+ // Chapter 5 Control Structures
1775
+ //
1776
+ define_syntax("when", function(x){
1777
+ //(when test body ...)
1778
+ //=> (if test (begin body ...) #<undef>)
1779
+ var test = x.cdr.car, body = x.cdr.cdr;
1780
+
1781
+ return new Pair(Sym("if"),
1782
+ new Pair(test,
1783
+ new Pair(new Pair(Sym("begin"), body),
1784
+ new Pair(BiwaScheme.undef, nil))));
1785
+ })
1786
+ define_syntax("unless", function(x){
1787
+ //(unless test body ...)
1788
+ //=> (if (not test) (begin body ...) #<undef>)
1789
+ var test = x.cdr.car, body = x.cdr.cdr;
1790
+
1791
+ return new Pair(Sym("if"),
1792
+ new Pair(new Pair(Sym("not"), new Pair(test, nil)),
1793
+ new Pair(new Pair(Sym("begin"), body),
1794
+ new Pair(BiwaScheme.undef, nil))));
1795
+ })
1796
+ //(do ((<variable1> <init1> <step1>) syntax
1797
+ //(case-lambda <case-lambda clause> ...) syntax
1798
+
1799
+ //
1800
+ // Chapter 6 Records
1801
+ //
1802
+ //eqv, eq
1803
+ //(define-record-type <name spec> <record clause>*) syntax
1804
+ //fields auxiliary syntax
1805
+ //mutable auxiliary syntax
1806
+ //immutable auxiliary syntax
1807
+ //parent auxiliary syntax
1808
+ //protocol auxiliary syntax
1809
+ //sealed auxiliary syntax
1810
+ //opaque auxiliary syntax
1811
+ //nongenerative auxiliary syntax
1812
+ //parent-rtd auxiliary syntax
1813
+ //
1814
+ //(make-record-type-descriptor name procedure
1815
+ //(record-type-descriptor? obj) procedure
1816
+ //(make-record-constructor-descriptor rtd procedure
1817
+ //(record-constructor constructor-descriptor) procedure
1818
+ //(record-predicate rtd) procedure
1819
+ //(record-accessor rtd k) procedure
1820
+ //(record-mutator rtd k) procedure
1821
+ //
1822
+ //(record? obj) procedure
1823
+ //(record-rtd record) procedure
1824
+ //(record-type-name rtd) procedure
1825
+ //(record-type-parent rtd) procedure
1826
+ //(record-type-uid rtd) procedure
1827
+ //(record-type-generative? rtd) procedure
1828
+ //(record-type-sealed? rtd) procedure
1829
+ //(record-type-opaque? rtd) procedure
1830
+ //(record-type-field-names rtd) procedure
1831
+ //(record-field-mutable? rtd k) procedure
1832
+
1833
+ //
1834
+ // Chapter 7 Exceptions and conditions
1835
+ //
1836
+ //(with-exception-handler handler thunk) procedure
1837
+ //(guard (<variable> syntax
1838
+ //(raise obj) procedure
1839
+ //(raise-continuable obj) procedure
1840
+ //
1841
+ //&condition condition type
1842
+ //(condition condition1 ...) procedure
1843
+ //(simple-conditions condition) procedure
1844
+ //(condition? obj) procedure
1845
+ //(condition-predicate rtd) procedure
1846
+ //(condition-accessor rtd proc) procedure
1847
+ //
1848
+ //&message condition type
1849
+ //&warning condition type
1850
+ //&serious condition type
1851
+ //&error condition type
1852
+ //&violation condition type
1853
+ //&assertion condition type
1854
+ //&irritants condition type
1855
+ //&who condition type
1856
+ //&non-continuable condition type
1857
+ //&implementation-restriction condition type
1858
+ //&lexical condition type
1859
+ //&syntax condition type
1860
+ //&undefined condition type
1861
+
1862
+ //
1863
+ // Chapter 8 I/O
1864
+ //
1865
+ // // 8 I/O
1866
+ // // 8.1 Condition types
1867
+ //&i/o condition type
1868
+ //&i/o-read condition type
1869
+ //&i/o-write condition type
1870
+ //&i/o-invalid-position condition type
1871
+ //&i/o-filename condition type
1872
+ //&i/o-file-protection condition type
1873
+ //&i/o-file-is-read-only condition type
1874
+ //&i/o-file-already-exists condition type
1875
+ //&i/o-file-does-not-exist condition type
1876
+ //&i/o-port condition type
1877
+ //
1878
+ // // 8.2 Port I/O
1879
+ // // 8.2.1 File names
1880
+ // //(no function introduced)
1881
+ //
1882
+ // // 8.2.2 File options
1883
+ //(file-options <file-options symbol> ...) syntax
1884
+ //
1885
+ // // 8.2.3 Buffer modes
1886
+ //(buffer-mode <buffer-mode symbol>) syntax
1887
+ //(buffer-mode? obj) procedure
1888
+ //
1889
+ // // 8.2.4 Transcoders
1890
+ //(latin-1-codec) procedure
1891
+ //(utf-8-codec) procedure
1892
+ //(utf-16-codec) procedure
1893
+ //(eol-style <eol-style symbol>) syntax
1894
+ //(native-eol-style) procedure
1895
+ //&i/o-decoding condition type
1896
+ //&i/o-encoding condition type
1897
+ //(error-handling-mode <error-handling-mode symbol>) syntax
1898
+ //(make-transcoder codec) procedure
1899
+ //(make-transcoder codec eol-style) procedure
1900
+ //(make-transcoder codec eol-style handling-mode) procedure
1901
+ //(native-transcoder) procedure
1902
+ //(transcoder-codec transcoder) procedure
1903
+ //(transcoder-eol-style transcoder) procedure
1904
+ //(transcoder-error-handling-mode transcoder) procedure
1905
+ //(bytevector->string bytevector transcoder) procedure
1906
+ //(string->bytevector string transcoder) procedure
1907
+ //
1908
+ // 8.2.5 End-of-file object
1909
+ //8.3 (eof-object) procedure
1910
+ //8.3 (eof-object? obj) procedure
1911
+
1912
+ // 8.2.6 Input and output ports
1913
+ define_libfunc("port?", 1, 1, function(ar){
1914
+ return (ar[0] instanceof Port);
1915
+ })
1916
+ //(port-transcoder port) procedure
1917
+ define_libfunc("textual-port?", 1, 1, function(ar){
1918
+ assert_port(ar[0]);
1919
+ return !ar[0].is_binary;
1920
+ })
1921
+ define_libfunc("binary-port?", 1, 1, function(ar){
1922
+ assert_port(ar[0]);
1923
+ return ar[0].is_binary;
1924
+ })
1925
+ //(transcoded-port binary-port transcoder) procedure
1926
+ //(port-has-port-position? port) procedure
1927
+ //(port-position port) procedure
1928
+ //(port-has-set-port-position!? port) procedure
1929
+ //(set-port-position! port pos) procedure
1930
+ define_libfunc("close-port", 1, 1, function(ar){
1931
+ assert_port(ar[0]);
1932
+ ar[0].close();
1933
+ })
1934
+ //(call-with-port port proc) procedure
1935
+
1936
+ // 8.2.7 Input ports
1937
+ //8.3 (input-port? obj) procedure
1938
+ //(port-eof? input-port) procedure
1939
+ //(open-file-input-port filename) procedure
1940
+ //(open-bytevector-input-port bytevector) procedure
1941
+ //(open-string-input-port string) procedure
1942
+ //(standard-input-port) procedure
1943
+ //8.3 (current-input-port) procedure
1944
+ //(make-custom-binary-input-port id read! procedure
1945
+ //(make-custom-textual-input-port id read! procedure
1946
+ //
1947
+ // // 8.2.8 Binary input
1948
+ //(get-u8 binary-input-port) procedure
1949
+ //(lookahead-u8 binary-input-port) procedure
1950
+ //(get-bytevector-n binary-input-port count) procedure
1951
+ //(get-bytevector-n! binary-input-port procedure
1952
+ //(get-bytevector-some binary-input-port) procedure
1953
+ //(get-bytevector-all binary-input-port) procedure
1954
+ //
1955
+ // // 8.2.9 Textual input
1956
+ //(get-char textual-input-port) procedure
1957
+ //(lookahead-char textual-input-port) procedure
1958
+ //(get-string-n textual-input-port count) procedure
1959
+ //(get-string-n! textual-input-port string start count) procedure
1960
+ //(get-string-all textual-input-port) procedure
1961
+ //(get-line textual-input-port) procedure
1962
+ //(get-datum textual-input-port) procedure
1963
+ //
1964
+ // 8.2.10 Output ports
1965
+ //8.3 (output-port? obj) procedure
1966
+ //(flush-output-port output-port) procedure
1967
+ //(output-port-buffer-mode output-port) procedure
1968
+ //(open-file-output-port filename) procedure
1969
+ //(open-bytevector-output-port) procedure
1970
+ //(call-with-bytevector-output-port proc) procedure
1971
+ //(open-string-output-port) procedure
1972
+ //(call-with-string-output-port proc) procedure
1973
+ //(standard-output-port) procedure
1974
+ //(standard-error-port) procedure
1975
+ //8.3 (current-output-port) procedure
1976
+ //8.3 (current-error-port) procedure
1977
+ //(make-custom-binary-output-port id procedure
1978
+ //(make-custom-textual-output-port id write! get-position set-position! close)
1979
+ // define_libfunc("make-custom-textual-output-port", 5, 5, function(ar){
1980
+ // assert_string(ar[0]);
1981
+ // assert_closure(ar[1]);
1982
+ // assert_closure(ar[2]);
1983
+ // assert_closure(ar[3]);
1984
+ // assert_closure(ar[4]);
1985
+ // return new Port(ar[0], ar[1], ar[2], ar[3], ar[4]);
1986
+ // })
1987
+ //
1988
+ // // 8.2.11 Binary output
1989
+ //(put-u8 binary-output-port octet) procedure
1990
+ //(put-bytevector binary-output-port bytevector) procedure
1991
+ //
1992
+ // 8.2.12 Textual output
1993
+ define_libfunc("put-char", 2, 2, function(ar){
1994
+ assert_port(ar[0]);
1995
+ assert_char(ar[1]);
1996
+ ar[0].put_string(ar[1].value);
1997
+ })
1998
+ define_libfunc("put-string", 2, 2, function(ar){
1999
+ assert_port(ar[0]);
2000
+ assert_string(ar[1]);
2001
+ ar[0].put_string(ar[1]);
2002
+ })
2003
+ define_libfunc("put-datum", 2, 2, function(ar){
2004
+ assert_port(ar[0]);
2005
+ ar[0].put_string(to_write(ar[1]));
2006
+ })
2007
+ //
2008
+ // // 8.2.13 Input/output ports
2009
+ //(open-file-input/output-port filename) procedure
2010
+ //(make-custom-binary-input/output-port procedure
2011
+ //(make-custom-textual-input/output-port procedure
2012
+ //
2013
+ // // 8.3 Simple I/O
2014
+ define_libfunc("eof-object", 0, 0, function(ar){
2015
+ return eof;
2016
+ })
2017
+ define_libfunc("eof-object?", 1, 1, function(ar){
2018
+ return ar[0] === eof;
2019
+ })
2020
+ //(call-with-input-file filename proc) procedure
2021
+ //(call-with-output-file filename proc) procedure
2022
+ define_libfunc("input-port?", 1, 1, function(ar){
2023
+ assert_port(ar[0]);
2024
+ return ar[0].is_input;
2025
+ })
2026
+ define_libfunc("output-port?", 1, 1, function(ar){
2027
+ assert_port(ar[0]);
2028
+ return ar[0].is_output;
2029
+ })
2030
+ define_libfunc("current-input-port", 0, 0, function(ar){
2031
+ return Port.current_input;
2032
+ })
2033
+ define_libfunc("current-output-port", 0, 0, function(ar){
2034
+ return Port.current_output;
2035
+ })
2036
+ define_libfunc("current-error-port", 0, 0, function(ar){
2037
+ return Port.current_error;
2038
+ })
2039
+ //(with-input-from-file filename thunk) procedure
2040
+ //(with-output-to-file filename thunk) procedure
2041
+ //(open-input-file filename) procedure
2042
+ //(open-output-file filename) procedure
2043
+ define_libfunc("close-input-port", 1, 1, function(ar){
2044
+ assert_port(ar[0]);
2045
+ if(!ar[0].is_input)
2046
+ throw new Error("close-input-port: port is not input port");
2047
+ ar[0].close();
2048
+ });
2049
+ define_libfunc("close-output-port", 1, 1, function(ar){
2050
+ assert_port(ar[0]);
2051
+ if(!ar[0].is_output)
2052
+ throw new Error("close-output-port: port is not output port");
2053
+ ar[0].close();
2054
+ });
2055
+ //(read-char) procedure
2056
+ //(peek-char) procedure
2057
+ define_libfunc("read", 0, 0, function(ar){
2058
+ return Port.current_input.get_string(function(str){
2059
+ var parser = new Parser(str);
2060
+ return parser.getObject();
2061
+ })
2062
+ })
2063
+
2064
+ // write-char [1,2]
2065
+ define_libfunc("newline", 0, 1, function(ar){
2066
+ var port = ar[0] || Port.current_output;
2067
+ port.put_string("\n");
2068
+ });
2069
+ define_libfunc("display", 1, 2, function(ar){
2070
+ var port = ar[1] || Port.current_output;
2071
+ port.put_string(to_display(ar[0]));
2072
+ });
2073
+ define_libfunc("write", 1, 2, function(ar){
2074
+ var port = ar[1] || Port.current_output;
2075
+ port.put_string(to_write(ar[0]));
2076
+ });
2077
+
2078
+ //
2079
+ // Chapter 9 File System
2080
+ //
2081
+ //(file-exists? filename) procedure
2082
+ define_libfunc("file-exists?", 1, 1, function(ar){
2083
+ netscape.security.PrivilegeManager.enablePrivilege("UniversalXPConnect"); //TODO: extract to a function
2084
+ assert_string(ar[0]);
2085
+ var fileIn = FileIO.open(ar[0]);
2086
+ return fileIn.exists();
2087
+ });
2088
+ //(delete-file filename) procedure
2089
+ define_libfunc("delete-file", 1, 1, function(ar){
2090
+ netscape.security.PrivilegeManager.enablePrivilege("UniversalXPConnect"); //TODO: extract to a function
2091
+ assert_string(ar[0]);
2092
+ var deleted = FileIO.unlink(FileIO.open(ar[0]));
2093
+ if(!deleted){
2094
+ //TODO: raise %i/o-filename if not found or not deletable
2095
+ puts("delete-file: cannot delete " + ar[0]);
2096
+ }
2097
+ });
2098
+
2099
+ //
2100
+ // Chapter 10 Command-line access and exit values
2101
+ //
2102
+ //(command-line) procedure
2103
+ //(exit) procedure
2104
+ //(exit obj) procedure
2105
+
2106
+ //
2107
+ // Chapter 11 Arithmetic
2108
+ //
2109
+ //// 11.1 Bitwise operations
2110
+ //// 11.2 Fixnums
2111
+ //(fixnum? obj) procedure
2112
+ //(fixnum-width) procedure
2113
+ //(least-fixnum) procedure
2114
+ //(greatest-fixnum) procedure
2115
+ //(fx=? fx1 fx2 fx3 ...) procedure
2116
+ //(fx>? fx1 fx2 fx3 ...) procedure
2117
+ //(fx<? fx1 fx2 fx3 ...) procedure
2118
+ //(fx>=? fx1 fx2 fx3 ...) procedure
2119
+ //(fx<=? fx1 fx2 fx3 ...) procedure
2120
+ //(fxzero? fx) procedure
2121
+ //(fxpositive? fx) procedure
2122
+ //(fxnegative? fx) procedure
2123
+ //(fxodd? fx) procedure
2124
+ //(fxeven? fx) procedure
2125
+ //(fxmax fx1 fx2 ...) procedure
2126
+ //(fxmin fx1 fx2 ...) procedure
2127
+ //(fx+ fx1 fx2) procedure
2128
+ //(fx* fx1 fx2) procedure
2129
+ //(fx- fx1 fx2) procedure
2130
+ //(fxdiv-and-mod fx1 fx2) procedure
2131
+ //(fxdiv fx1 fx2) procedure
2132
+ //(fxmod fx1 fx2) procedure
2133
+ //(fxdiv0-and-mod0 fx1 fx2) procedure
2134
+ //(fxdiv0 fx1 fx2) procedure
2135
+ //(fxmod0 fx1 fx2) procedure
2136
+ //(fx+/carry fx1 fx2 fx3) procedure
2137
+ //(fx-/carry fx1 fx2 fx3) procedure
2138
+ //(fx*/carry fx1 fx2 fx3) procedure
2139
+ //(fxnot fx) procedure
2140
+ //(fxand fx1 ...) procedure
2141
+ //(fxior fx1 ...) procedure
2142
+ //(fxxor fx1 ...) procedure
2143
+ //(fxif fx1 fx2 fx3) procedure
2144
+ //(fxbit-count fx) procedure
2145
+ //(fxlength fx) procedure
2146
+ //(fxfirst-bit-set fx) procedure
2147
+ //(fxbit-set? fx1 fx2) procedure
2148
+ //(fxcopy-bit fx1 fx2 fx3) procedure
2149
+ //(fxbit-field fx1 fx2 fx3) procedure
2150
+ //(fxcopy-bit-field fx1 fx2 fx3 fx4) procedure
2151
+ //(fxarithmetic-shift fx1 fx2) procedure
2152
+ //(fxarithmetic-shift-left fx1 fx2) procedure
2153
+ //(fxarithmetic-shift-right fx1 fx2) procedure
2154
+ //(fxrotate-bit-field fx1 fx2 fx3 fx4) procedure
2155
+ //(fxreverse-bit-field fx1 fx2 fx3) procedure
2156
+ //
2157
+ //// 11.3 Flonums
2158
+ //(flonum? obj) procedure
2159
+ //(real->flonum x) procedure
2160
+ //(fl=? fl1 fl2 fl3 ...) procedure
2161
+ //(fl<? fl1 fl2 fl3 ...) procedure
2162
+ //(fl<=? fl1 fl2 fl3 ...) procedure
2163
+ //(fl>? fl1 fl2 fl3 ...) procedure
2164
+ //(fl>=? fl1 fl2 fl3 ...) procedure
2165
+ //(flinteger? fl) procedure
2166
+ //(flzero? fl) procedure
2167
+ //(flpositive? fl) procedure
2168
+ //(flnegative? fl) procedure
2169
+ //(flodd? ifl) procedure
2170
+ //(fleven? ifl) procedure
2171
+ //(flfinite? fl) procedure
2172
+ //(flinfinite? fl) procedure
2173
+ //(flnan? fl) procedure
2174
+ //(flmax fl1 fl2 ...) procedure
2175
+ //(flmin fl1 fl2 ...) procedure
2176
+ //(fl+ fl1 ...) procedure
2177
+ //(fl* fl1 ...) procedure
2178
+ //(fl- fl1 fl2 ...) procedure
2179
+ //(fl- fl) procedure
2180
+ //(fl/ fl1 fl2 ...) procedure
2181
+ //(fl/ fl) procedure
2182
+ //(flabs fl) procedure
2183
+ //(fldiv-and-mod fl1 fl2) procedure
2184
+ //(fldiv fl1 fl2) procedure
2185
+ //(flmod fl1 fl2) procedure
2186
+ //(fldiv0-and-mod0 fl1 fl2) procedure
2187
+ //(fldiv0 fl1 fl2) procedure
2188
+ //(flmod0 fl1 fl2) procedure
2189
+ //(flnumerator fl) procedure
2190
+ //(fldenominator fl) procedure
2191
+ //(flfloor fl) procedure
2192
+ //(flceiling fl) procedure
2193
+ //(fltruncate fl) procedure
2194
+ //(flround fl) procedure
2195
+ //(flexp fl) procedure
2196
+ //(fllog fl) procedure
2197
+ //(fllog fl1 fl2) procedure
2198
+ //(flsin fl) procedure
2199
+ //(flcos fl) procedure
2200
+ //(fltan fl) procedure
2201
+ //(flasin fl) procedure
2202
+ //(flacos fl) procedure
2203
+ //(flatan fl) procedure
2204
+ //(flatan fl1 fl2) procedure
2205
+ //(flsqrt fl) procedure
2206
+ //(flexpt fl1 fl2) procedure
2207
+ //&no-infinities condition type
2208
+ //&no-nans condition type
2209
+ //(fixnum->flonum fx) procedure
2210
+ //
2211
+ //// 11.4 Exact bitwise arithmetic
2212
+ //(bitwise-not ei) procedure
2213
+ //(bitwise-and ei1 ...) procedure
2214
+ //(bitwise-ior ei1 ...) procedure
2215
+ //(bitwise-xor ei1 ...) procedure
2216
+ //(bitwise-if ei1 ei2 ei3) procedure
2217
+ //(bitwise-bit-count ei) procedure
2218
+ //(bitwise-length ei) procedure
2219
+ //(bitwise-first-bit-set ei) procedure
2220
+ //(bitwise-bit-set? ei1 ei2) procedure
2221
+ //(bitwise-copy-bit ei1 ei2 ei3) procedure
2222
+ //(bitwise-bit-field ei1 ei2 ei3) procedure
2223
+ //(bitwise-copy-bit-field ei1 ei2 ei3 ei4) procedure
2224
+ //(bitwise-arithmetic-shift ei1 ei2) procedure
2225
+ //(bitwise-arithmetic-shift-left ei1 ei2) procedure
2226
+ //(bitwise-arithmetic-shift-right ei1 ei2) procedure
2227
+ //(bitwise-arithmetic-shift-right ei1 ei2)
2228
+ //(bitwise-rotate-bit-field ei1 ei2 ei3 ei4) procedure
2229
+ //(bitwise-reverse-bit-field ei1 ei2 ei3) procedure
2230
+
2231
+
2232
+ //
2233
+ // Chapter 12 syntax-case
2234
+ //
2235
+
2236
+ //
2237
+ // Chapter 13 Hashtables
2238
+ //
2239
+ Hash.prototype.to_write = function(){
2240
+ return "#<Hashtable:size=" + this.keys().length + ">";
2241
+ };
2242
+ //13.1 Constructors
2243
+ //(define h (make-eq-hashtale)
2244
+ //(define h (make-eq-hashtable 1000))
2245
+ define_libfunc("make-eq-hashtable", 0, 1, function(ar){
2246
+ // ar[1] (hashtable size) is just ignored
2247
+ return $H({});
2248
+ });
2249
+ //(make-eqv-hashtable) procedure
2250
+ //(make-eqv-hashtable k) procedure
2251
+ //(make-hashtable hash-function equiv) procedure
2252
+ //(make-hashtable hash-function equiv k) procedure
2253
+
2254
+ //13.2 Procedures
2255
+ // (hashtable? hash)
2256
+ define_libfunc("hashtable?", 1, 1, function(ar){
2257
+ return ar[0] instanceof Hash;
2258
+ });
2259
+ //(hashtable-size hash)
2260
+ define_libfunc("hashtable-size", 1, 1, function(ar){
2261
+ assert_hashtable(ar[0]);
2262
+ return ar[0].keys().length;
2263
+ });
2264
+ //(hashtable-ref hash "foo" #f)
2265
+ define_libfunc("hashtable-ref", 3, 3, function(ar){
2266
+ assert_hashtable(ar[0]);
2267
+ var found = ar[0].get(ar[1]);
2268
+
2269
+ if (found === undefined)
2270
+ return ar[2];
2271
+ else
2272
+ return found;
2273
+ });
2274
+ //(hashtable-set! hash "foo" '(1 2))
2275
+ define_libfunc("hashtable-set!", 3, 3, function(ar){
2276
+ assert_hashtable(ar[0]);
2277
+ ar[0].set(ar[1], ar[2]);
2278
+ });
2279
+ //(hashtable-delete! hash "foo")
2280
+ define_libfunc("hashtable-delete!", 2, 2, function(ar){
2281
+ assert_hashtable(ar[0]);
2282
+ ar[0].unset(ar[1]);
2283
+ });
2284
+ //(hashtable-contains? hash "foo")
2285
+ define_libfunc("hashtable-contains?", 2, 2, function(ar){
2286
+ assert_hashtable(ar[0]);
2287
+ return ar[0].get(ar[1]) !== undefined;
2288
+ });
2289
+ //(hashtable-update! hashtable key proc default) procedure
2290
+ //(hashtable-copy hashtable) procedure
2291
+ //(hashtable-copy hashtable mutable) procedure
2292
+ //(hashtable-clear! hashtable) procedure
2293
+ //(hashtable-clear! hashtable k) procedure
2294
+ //(hashtable-keys hash) ; => vector
2295
+ define_libfunc("hashtable-keys", 1, 1, function(ar){
2296
+ assert_hashtable(ar[0]);
2297
+ return ar[0].keys();
2298
+ });
2299
+ //(hashtable-entries hash) ; => two vectors (keys, values)
2300
+ define_libfunc("hashtable-entries", 1, 1, function(ar){
2301
+ assert_hashtable(ar[0]);
2302
+ return new Values([ar[0].keys(), ar[0].values()]);
2303
+ //Note: Values of two vectors shall correspond to each other.
2304
+ // This code assumes Hash#each to always iterate
2305
+ // hash entries in the same order (is this true?)
2306
+ });
2307
+
2308
+ //13.3 Inspection
2309
+ //(hashtable-equivalence-function hashtable) procedure
2310
+ //(hashtable-hash-function hashtable) procedure
2311
+ //(hashtable-mutable? hashtable) procedure
2312
+ //13.4 Hash functions
2313
+ //(equal-hash obj) procedure
2314
+ //(string-hash string) procedure
2315
+ //(string-ci-hash string) procedure
2316
+ //(symbol-hash symbol) procedure
2317
+
2318
+ //
2319
+ // Chapter 14 Enumerators
2320
+ //
2321
+ //(make-enumeration symbol-list) procedure
2322
+ //(enum-set-universe enum-set) procedure
2323
+ //(enum-set-indexer enum-set) procedure
2324
+ //(enum-set-constructor enum-set) procedure
2325
+ //(enum-set->list enum-set) procedure
2326
+ //(enum-set-member? symbol enum-set) procedure
2327
+ //(enum-set-subset? enum-set1 enum-set2) procedure
2328
+ //(enum-set=? enum-set1 enum-set2) procedure
2329
+ //(enum-set-union enum-set1 enum-set2) procedure
2330
+ //(enum-set-intersection enum-set1 enum-set2) procedure
2331
+ //(enum-set-difference enum-set1 enum-set2) procedure
2332
+ //(enum-set-complement enum-set) procedure
2333
+ //(enum-set-projection enum-set1 enum-set2) procedure
2334
+ //(define-enumeration <type-name> syntax
2335
+ //(<symbol> ...)
2336
+ //<constructor-syntax>)
2337
+
2338
+ //
2339
+ // Chapter 15 Composite library
2340
+ //
2341
+ //(rnrs 6) = all - eval - mutable pairs - mutable strings - r5rs compatibility
2342
+
2343
+ //
2344
+ // Chapter 16 eval
2345
+ //
2346
+ //(eval expression environment) procedure
2347
+ define_libfunc("eval", 1, 1, function(ar, intp){
2348
+ //TODO: environment
2349
+ //TODO: this implementation has a bug that
2350
+ // expressions which contains #<undef>, etc. cannot be evaluated.
2351
+ var expr = ar[0];
2352
+ var intp = new BiwaScheme.Interpreter(intp.on_error);
2353
+
2354
+ return intp.evaluate(expr.to_write());
2355
+ });
2356
+ //(environment import-spec ...) procedure
2357
+
2358
+ //
2359
+ // Chapter 17 Mutable pairs
2360
+ //
2361
+ //(set-car! pair obj) procedure
2362
+ //(set-cdr! pair obj) procedure
2363
+
2364
+ //
2365
+ // Chapter 18 Mutable strings
2366
+ //
2367
+ //(string-set! string k char) procedure
2368
+ // (string-fill! string char) procedure
2369
+
2370
+ //
2371
+ // Chapter 19 R5RS compatibility
2372
+ //
2373
+ //(exact->inexact z) procedure
2374
+ //(inexact->exact z) procedure
2375
+ //
2376
+ //(quotient n1 n2) procedure
2377
+ //(remainder n1 n2) procedure
2378
+ //(modulo n1 n2) procedure
2379
+ //
2380
+ //(delay <expression>) syntax
2381
+ //(force promise) procedure
2382
+ //(make-promise (lambda () <expression>))
2383
+ //
2384
+ //(null-environment n) procedure
2385
+ //(scheme-report-environment n) procedure
2386
+
2387
+ /* --------------------------------------- namespace webscheme */
2388
+ }