source: project/release/4/spock/trunk/spock/library.scm @ 31158

Last change on this file since 31158 was 31158, checked in by felix winkelmann, 6 years ago

spock 0.096: bugfixes in cadXXr, reported by Hugo Arregui

File size: 52.3 KB
Line 
1;;;; library.scm - runtime-library (Scheme part)
2
3
4(let-syntax
5    ((case-lambda   ; this is not the same as the usual `case-lambda'!
6      (letrec-syntax ((scan
7                       (syntax-rules ()
8                         ((_ (x) (lst ...)) (%dispatch lst ... x))
9                         ((_ ((llist . body) . more) (lst ...))
10                          (scan more (lst ... (lambda llist . body)))))))
11        (syntax-rules ()
12          ((_ clause ...)
13           (lambda args
14             (scan (clause ...) ()))))))
15     (define-inline
16         (syntax-rules
17             ___ ()
18             ((_ (name . args) body ___)
19              (define-syntax name
20                (lambda args body ___))))))
21  (begin
22
23    (define-library-section internal-essentials
24
25      (default
26
27        ;; (%string->jstring STRING) -> JSTRING
28        (define-inline (%string->jstring x) (%inline "SPOCK.jstring" x))
29
30        ;; (%jstring->string JSTRING) -> STRING
31        (define-inline (%jstring->string x) (%inline "new SPOCK.String" x))
32
33        ;; (%list ...) -> LIST
34        ;; used for manifest `lambda' with rest argument
35        (define (%list . xs) xs)
36
37        ;; (%car X) -> Y
38        (define-inline (%car x) (%property-ref "car" x))
39
40        ;; (%cdr X) -> Y
41        (define-inline (%cdr x) (%property-ref "cdr" x))
42
43        ))
44
45
46    (define-library-section essentials
47
48      (default
49
50        (define-inline (eq? x y) 
51          (%inline (1 "===" 2) x y))
52
53        (define-inline (eqv? x y)
54          (%inline "SPOCK.eqvp" x y))
55
56        (define-inline (equal? x y) (%inline "SPOCK.equalp" x y))
57        (define-inline (not x) (if x #f #t))
58
59        ))
60
61   
62    (define-library-section basic-type-predicates
63
64      (default
65
66        (define-inline (symbol? x) (%inline (1 "instanceof SPOCK.Symbol") x))
67        (define-inline (pair? x) (%inline (1 "instanceof SPOCK.Pair") x))
68        (define-inline (number? x) (eq? (%inline "typeof" x) "number"))
69        (define-inline (char? x) (%inline (1 "instanceof SPOCK.Char") x))
70        (define-inline (void? x) (%void? x))
71        (define-inline (vector? x) (%inline (1 "instanceof Array") x))
72        (define-inline (procedure? x) (eq? (%inline "typeof" x) "function"))
73        (define-inline (eof-object? x) (eq? x (%host-ref "SPOCK.EOF")))
74        (define-inline (boolean? x) (or (eq? x #t) (eq? x #f)))
75
76        (define-inline (string? x)
77          (or (eq? (%inline "typeof" x) "string")
78              (%inline (1 "instanceof SPOCK.String") x)))
79
80        ))
81
82
83    (define-library-section multiple-values
84
85      (default
86
87        (define values
88          (%native-lambda
89           "return K.apply(SPOCK.global, Array.prototype.slice.call(arguments, 1));"))
90
91        (define call-with-values
92          (%native-lambda
93           "var thunk = arguments[ 1 ];"
94           "var proc = arguments[ 2 ];"
95           "function k2() {"
96           " var args = Array.prototype.slice.call(arguments);"
97           " args.unshift(K);"
98           " return proc.apply(SPOCK.global, args);}"
99           "return thunk(k2);"))
100
101        ))
102
103
104    (define-library-section multiple-value-hacks
105
106      (default
107
108        ;; (%call-with-saved-values THUNK1 THUNK2)
109        (define %call-with-saved-values
110          (%native-lambda
111           "var t1 = arguments[ 1 ];"
112           "var t2 = arguments[ 2 ];"
113           "var args;"
114           "function k2() { return K.apply(SPOCK.global, args); }"
115           "function k1() {"
116           " args = Array.prototype.slice.call(arguments);"
117           " return t2(k2);}"
118           "return t1(k1);"))
119
120        ))
121
122
123    (define-library-section nonstandard-essentials
124
125      (default
126
127        (define-inline (void) (%void))  ; ignores extra arguments
128
129        ))
130
131
132    (define-library-section basic-list-operations
133
134      (default
135
136        (define-inline (null? x) (eq? x '()))
137        (define-inline (car x) (%car (%check ("SPOCK.Pair") x)))
138        (define-inline (cdr x) (%cdr (%check ("SPOCK.Pair") x)))
139        (define-inline (list . xs) xs)
140        (define-inline (cons x y) (%inline "new SPOCK.Pair" x y))
141       
142        (define-inline (set-car! x y)
143          (%inline (1 ".car = " 2) (%check ("SPOCK.Pair") x) y))
144
145        (define-inline (set-cdr! x y)
146          (%inline (1 ".cdr = " 2) (%check ("SPOCK.Pair") x) y))
147
148        (define (list? x)
149          (let loop ((fast x) (slow x))
150            (or (null? fast)
151                (and (pair? fast)
152                     (let ((fast (%cdr fast)))
153                       (or (null? fast)
154                           (and (pair? fast)
155                                (let ((fast (%cdr fast))
156                                      (slow (%cdr slow)))
157                                  (and (not (eq? fast slow))
158                                       (loop fast slow))))))))))
159
160        (define-inline (caar x) (car (car x)))
161        (define-inline (cadr x) (car (cdr x)))
162        (define-inline (cdar x) (cdr (car x)))
163        (define-inline (cddr x) (cdr (cdr x)))
164        (define (caaar x) (car (car (car x))))
165        (define (caadr x) (car (car (cdr x))))
166        (define (cadar x) (car (cdr (car x))))
167        (define (caddr x) (car (cdr (cdr x))))
168        (define (cdaar x) (cdr (car (car x))))
169        (define (cdadr x) (cdr (car (cdr x))))
170        (define (cddar x) (cdr (cdr (car x))))
171        (define (cdddr x) (cdr (cdr (cdr x))))
172        (define (caaaar x) (car (car (car (car x)))))
173        (define (caaadr x) (car (car (car (cdr x)))))
174        (define (caadar x) (car (car (cdr (car x)))))
175        (define (caaddr x) (car (car (cdr (cdr x)))))
176        (define (cadaar x) (car (cdr (car (car x)))))
177        (define (cadadr x) (car (cdr (car (cdr x)))))
178        (define (caddar x) (car (cdr (cdr (car x)))))
179        (define (cadddr x) (car (cdr (cdr (cdr x)))))
180        (define (cdaaar x) (cdr (car (car (car x)))))
181        (define (cdaadr x) (cdr (car (car (cdr x)))))
182        (define (cdadar x) (cdr (car (cdr (car x)))))
183        (define (cdaddr x) (cdr (car (cdr (cdr x)))))
184        (define (cddaar x) (cdr (cdr (car (car x)))))
185        (define (cddadr x) (cdr (cdr (car (cdr x)))))
186        (define (cdddar x) (cdr (cdr (cdr (car x)))))
187        (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
188
189        (define-inline (length lst) (%inline "SPOCK.length" lst))
190
191        (define (append . lsts)
192          (if (null? lsts)
193              '()
194              (let loop ((lsts lsts))
195                (if (null? (%cdr lsts))
196                    (%car lsts)
197                    (let copy ((node (%car lsts)))
198                      (if (pair? node)
199                          (cons (%car node) (copy (%cdr node)))
200                          ;; ignores non-list node
201                          (loop (%cdr lsts))))))))
202
203        (define (reverse lst)
204          (let loop ((lst lst) (rest '()))
205            (if (pair? lst)
206                (loop (%cdr lst) (cons (%car lst) rest))
207                ;; ignores non-list node
208                rest)))
209
210        (define (list-tail lst i)
211          (let loop ((i (%check "number" i))
212                     (lst lst))
213            (if (%inline (1 " <= 0") i)
214                lst
215                (loop (%inline (1 " - 1") i)
216                      (%cdr (%check ("SPOCK.Pair") lst))))))
217
218        (define list-ref
219          (let ((list-tail list-tail))
220            (lambda (lst i)
221              (%car (%check ("SPOCK.Pair") (list-tail lst i))))))
222
223        (define memq
224          (%native-lambda
225           "var x = arguments[ 1 ];"
226           "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
227           "  if(n.car === x) return K(n);"
228           "}"
229           "return K(false);"))
230
231        (define memv
232          (%native-lambda
233           "var x = arguments[ 1 ];"
234           "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
235           "  if(SPOCK.eqvp(n.car, x)) return K(n);"
236           "}"
237           "return K(false);"))
238
239        (define member
240          (%native-lambda
241           "var x = arguments[ 1 ];"
242           "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
243           "  if(SPOCK.equalp(n.car, x)) return K(n);"
244           "}"
245           "return K(false);"))
246
247        (define assq
248          (%native-lambda
249           "var x = arguments[ 1 ];"
250           "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
251           "  var p = n.car;"
252           "  if(p instanceof SPOCK.Pair && p.car === x) return K(p);"
253           "}"
254           "return K(false);"))
255
256        (define assv
257          (%native-lambda
258           "var x = arguments[ 1 ];"
259           "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
260           "  var p = n.car;"
261           "  if(p instanceof SPOCK.Pair && SPOCK.eqvp(p.car, x)) return K(p);"
262           "}"
263           "return K(false);"))
264
265        (define assoc
266          (%native-lambda
267           "var x = arguments[ 1 ];"
268           "for(var n = arguments[ 2 ]; n instanceof SPOCK.Pair; n = n.cdr) {"
269           "  var p = n.car;"
270           "  if(p instanceof SPOCK.Pair && SPOCK.equalp(p.car, x)) return K(p);"
271           "}"
272           "return K(false);"))
273
274        ))
275
276
277    (define-library-section numeric-predicates
278
279      (default
280       
281        (define-inline (zero? x) (eq? 0 (%check "number" x)))
282        (define-inline (positive? x) (%inline (1 ">" 2) (%check "number" x) 0))
283        (define-inline (negative? x) (%inline (1 "<" 2) (%check "number" x) 0))
284        (define-inline (odd? x) (not (eq? 0 (%inline (1 "%" 2) (%check "number" x) 2))))
285        (define-inline (even? x) (eq? 0 (%inline (1 "%" 2) (%check "number" x) 2)))
286        (define-inline (complex? x) (eq? (%inline "typeof" x) "number"))
287        (define-inline (rational? x) (eq? (%inline "typeof" x) "number"))
288        (define-inline (real? x) (eq? (%inline "typeof" x) "number"))
289
290        (define-inline (integer? x) 
291          (and (eq? (%inline "typeof" x) "number")
292               (eq? x (%inline "Math.round" x) x)))
293
294        (define-inline (exact? x)
295          (let ((x (%check "number" x)))
296            (eq? x (%inline "Math.round" x) x)))
297       
298        (define-inline (inexact? x) (not (exact? x)))
299       
300        ))
301
302
303    (define-library-section native-basic-arithmetic
304
305      (debug
306
307        (define %+
308          (%native-lambda
309           "var len = arguments.length;"
310           "switch(len) {"
311           "case 1: return K(0);"
312           "case 2: return K(SPOCK.check(arguments[ 1 ], 'number', '+'));"
313           "default:"
314           " var p = SPOCK.check(arguments[ 1 ], 'number', '+');"
315           " for(var i = 2; i < len; ++i) {"
316           "  p += SPOCK.check(arguments[ i ], 'number', '+');"
317           " }"
318           " return K(p);}"))
319
320        (define %-
321          (%native-lambda
322           "var len = arguments.length;"
323           "switch(len) {"
324           "case 1: SPOCK.error('(-) bad argument count', len);"
325           "case 2: return K(-SPOCK.check(arguments[ 1 ], 'number', '-'));"
326           "default:"
327           " var p = SPOCK.check(arguments[ 1 ], 'number', '-');"
328           " for(var i = 2; i < len; ++i) {"
329           "  p -= SPOCK.check(arguments[ i ], 'number', '-');"
330           " }"
331           " return K(p);}"))
332
333        (define %*
334          (%native-lambda
335           "var len = arguments.length;"
336           "switch(len) {"
337           "case 1: return K(1);"
338           "case 2: return K(SPOCK.check(arguments[ 1 ], 'number', '*'));"
339           "default:"
340           " var p = SPOCK.check(arguments[ 1 ], 'number', '*');"
341           " for(var i = 2; i < len; ++i) {"
342           "  p *= SPOCK.check(arguments[ i ], 'number', '*');"
343           " }"
344           " return K(p);}"))
345
346        (define %/
347          (%native-lambda
348           "var len = arguments.length;"
349           "switch(len) {"
350           "case 1: SPOCK.error('(/) bad argument count', len);"
351           "case 2: return K(1/SPOCK.check(arguments[ 1 ], 'number', '/'));"
352           "default:"
353           " var p = SPOCK.check(arguments[ 1 ], 'number', '/');"
354           " for(var i = 2; i < len; ++i) {"
355           "  p /= SPOCK.check(arguments[ i ], 'number', '/');"
356           " }"
357           " return K(p);}"))
358
359        )
360
361      (default
362
363       (define %+
364         (%native-lambda
365          "var len = arguments.length;"
366          "switch(len) {"
367          "case 1: return K(0);"
368          "case 2: return K(arguments[ 1 ]);"
369          "default:"
370          " var p = arguments[ 1 ];"
371          " for(var i = 2; i < len; ++i) {"
372          "  p += arguments[ i ];"
373          " }"
374          " return K(p);}"))
375
376       (define %-
377         (%native-lambda
378          "var len = arguments.length;"
379          "switch(len) {"
380          "case 2: return K(-arguments[ 1 ]);"
381          "default:"
382          " var p = arguments[ 1 ];"
383          " for(var i = 2; i < len; ++i) {"
384          "  p -= arguments[ i ];"
385          " }"
386          " return K(p);}"))
387
388       (define %*
389         (%native-lambda
390          "var len = arguments.length;"
391          "switch(len) {"
392          "case 1: return K(1);"
393          "case 2: return K(arguments[ 1 ]);"
394          "default:"
395          " var p = arguments[ 1 ];"
396          " for(var i = 2; i < len; ++i) {"
397          "  p *= arguments[ i ];"
398          " }"
399          " return K(p);}"))
400
401       (define %/
402         (%native-lambda
403          "var len = arguments.length;"
404          "switch(len) {"
405          "case 2: return K(1/arguments[ 1 ]);"
406          "default:"
407          " var p = arguments[ 1 ];"
408          " for(var i = 2; i < len; ++i) {"
409          "  p /= arguments[ i ];"
410          " }"
411          " return K(p);}"))
412
413        ))
414
415
416    (define-library-section basic-arithmetic
417
418      (default
419
420        (define-syntax +
421          (case-lambda
422           (() 0)
423           ((n) (%check "number" n))
424           ((n1 n2)
425            (%inline (1 " + " 2) (%check "number" n1) (%check "number" n2)))
426           %+))
427
428        (define-syntax *
429          (case-lambda
430           (() 1)
431           ((n) (%check "number" n))
432           ((n1 n2)
433            (%inline (1 " * " 2) (%check "number" n1) (%check "number" n2)))
434           %*))
435
436        (define-syntax -
437          (case-lambda
438           ((n) (%inline ("-" 1) (%check number n)))
439           ((n1 n2) 
440            (%inline (1 " - " 2) (%check number n1) (%check number n2)))
441           %-))
442
443        (define-syntax /
444          (case-lambda
445           ((n) (%inline ("1 / " 1) (%check number n)))
446           ((n1 n2) 
447            (%inline (1 " / " 2) (%check number n1) (%check number n2)))
448           %/))
449
450        ))
451
452
453    (define-library-section native-numeric-comparison
454
455      ;;XXX need non-debug versions
456      (default
457
458        (define %=
459          (%native-lambda
460           "var argc = arguments.length;"
461           "var last = SPOCK.check(arguments[ 1 ], 'number', '=');"
462           "for(var i = 2; i < argc; ++i) {"
463           " var x = SPOCK.check(arguments[ i ], 'number', '=');"
464           " if(last !== x) return K(false);"
465           " else last = x;}"
466           "return K(true);"))
467
468        (define %>
469          (%native-lambda
470           "var argc = arguments.length;"
471           "var last = SPOCK.check(arguments[ 1 ], 'number', '>');"
472           "for(var i = 2; i < argc; ++i) {"
473           " var x = SPOCK.check(arguments[ i ], 'number', '>');"
474           " if(last <= x) return K(false);"
475           " else last = x;}"
476           "return K(true);"))
477
478        (define %<
479          (%native-lambda
480           "var argc = arguments.length;"
481           "var last = SPOCK.check(arguments[ 1 ], 'number', '<');"
482           "for(var i = 2; i < argc; ++i) {"
483           " var x = SPOCK.check(arguments[ i ], 'number', '<');"
484           " if(last >= x) return K(false);"
485           " else last = x;}"
486           "return K(true);"))
487
488        (define %>=
489          (%native-lambda
490           "var argc = arguments.length;"
491           "var last = SPOCK.check(arguments[ 1 ], 'number', '>=');"
492           "for(var i = 2; i < argc; ++i) {"
493           " var x = SPOCK.check(arguments[ i ], 'number', '>=');"
494           " if(last < x) return K(false);"
495           " else last = x;}"
496           "return K(true);"))
497
498        (define %<=
499          (%native-lambda
500           "var argc = arguments.length;"
501           "var last = SPOCK.check(arguments[ 1 ], 'number', '<=');"
502           "for(var i = 2; i < argc; ++i) {"
503           " var x = SPOCK.check(arguments[ i ], 'number', '<=');"
504           " if(last > x) return K(false);"
505           " else last = x;}"
506           "return K(true);"))
507
508        ))
509
510
511    (define-library-section numeric-comparison
512
513      (default
514
515        (define-syntax =
516          (case-lambda
517           ((n1 n2)
518            (%inline (1 " === " 2) (%check "number" n1) (%check "number" n2)))
519           %=))
520
521        (define-syntax >
522          (case-lambda
523           ((n1 n2)
524            (%inline (1 " > " 2) (%check "number" n1) (%check "number" n2)))
525           %>))
526
527        (define-syntax <
528          (case-lambda
529           ((n1 n2)
530            (%inline (1 " < " 2) (%check "number" n1) (%check "number" n2)))
531           %<))
532
533        (define-syntax >=
534          (case-lambda
535           ((n1 n2)
536            (%inline (1 " >= " 2) (%check "number" n1) (%check "number" n2)))
537           %>=))
538
539        (define-syntax <=
540          (case-lambda
541           ((n1 n2)
542            (%inline (1 " <= " 2) (%check "number" n1) (%check "number" n2)))
543           %<=))
544
545        ))
546
547
548    (define-library-section native-numeric-operations
549
550      (debug
551
552        (define %max
553          (%native-lambda
554           "var argc = arguments.length;"
555           "var n = SPOCK.check(arguments[ 1 ], 'number', 'max');"
556           "for(var i = 2; i < argc; ++i) {"
557           " var x = SPOCK.check(arguments[ i ], 'number', 'max');"
558           " if(n < x) n = x;}"
559           "return K(n);"))
560
561        (define %min
562          (%native-lambda
563           "var argc = arguments.length;"
564           "var n = SPOCK.check(arguments[ 1 ], 'number', 'max');"
565           "for(var i = 2; i < argc; ++i) {"
566           " var x = SPOCK.check(arguments[ i ], 'number', 'max');"
567           " if(n > x) n = x;}"
568           "return K(n);"))
569
570        )
571
572      (default
573
574       (define %max
575         (%native-lambda
576          "return K(Math.max.apply(SPOCK.global, arguments));"))
577
578       (define %max
579         (%native-lambda
580          "return K(Math.min.apply(SPOCK.global, arguments));"))
581
582        ))
583
584
585    (define-library-section numeric-operations
586
587      (default
588
589        (define-inline (round n) (%inline "Math.round" (%check "number" n)))
590        (define-inline (floor n) (%inline "Math.floor" (%check "number" n)))
591        (define-inline (ceiling n) (%inline "Math.ceil" (%check "number" n)))
592
593        (define-inline (truncate n)
594          (%check "number" n)
595          (if (%inline (1 " < 0") n)
596              (%inline "Math.ceil" n)
597              (%inline "Math.floor" n)))
598
599        (define-inline (log n) (%inline "Math.log" (%check "number" n)))
600        (define-inline (abs n) (%inline "Math.abs" (%check "number" n)))
601        (define-inline (sin n) (%inline "Math.sin" (%check "number" n)))
602        (define-inline (cos n) (%inline "Math.cos" (%check "number" n)))
603        (define-inline (tan n) (%inline "Math.tan" (%check "number" n)))
604        (define-inline (asin n) (%inline "Math.asin" (%check "number" n)))
605        (define-inline (acos n) (%inline "Math.acos" (%check "number" n)))
606        (define-inline (sqrt n) (%inline "Math.sqrt" (%check "number" n)))
607
608        (define-inline (expt n m)
609          (%inline "Math.pow" (%check "number" n) (%check "number" m)))
610
611        (define-inline (atan y x)
612          (if (void? x)
613              (%inline "Math.atan" (%check "number" y))
614              (%inline "Math.atan2" (%check "number" y) (%check "number" x))))
615
616        (define-syntax max
617          (case-lambda
618           ((n) (%check "number" n))
619           ((n1 n2)
620            (%inline "Math.max" (%check "number" n1) (%check "number" n2)))
621           %max))
622
623        (define-syntax min
624          (case-lambda
625           ((n) (%check "number" n))
626           ((n1 n2)
627            (%inline "Math.min" (%check "number" n1) (%check "number" n2)))
628           %min))
629
630        (define-inline (quotient x y)
631          (truncate (/ x y)))           ;XXX correct?
632
633        (define-inline (remainder x y)
634          (- x (* (quotient x y) y)))
635
636        (define (modulo a b) ; copied from chibi scheme without asking Alex
637          (let ((res (remainder a b)))
638            (if (< b 0)
639                (if (<= res 0) res (+ res b))
640                (if (>= res 0) res (+ res b)))))
641
642        (define-inline (exact->inexact n) (%check "number" n))
643        (define-inline (inexact->exact n) (truncate n))
644
645        ;; not implemented: numerator denominator rationalize
646        ;; not implemented: make-rectangular make-polar imag-part real-part magnitude angle
647
648        ))
649
650
651    (define-library-section gcd-and-lcm
652
653      (default
654
655        ;;XXX slow
656
657        (define %gcd
658          (let ((remainder remainder))
659            (lambda (x y)
660              (let loop ((x x) (y y))
661                (if (zero? y)
662                    (abs x)
663                    (loop y (remainder x y)) ) ) ) ) )
664
665        (define (gcd . ns)
666          (if (null? ns)
667              0
668              (let loop ((ns ns) (f #t))
669                (let ((head (%car ns))
670                      (next (%cdr ns)))
671                  (when f (%check "number" head))
672                  (if (null? next)
673                      (abs head)
674                      (let ((n2 (%car next)))
675                        (%check "number" n2)
676                        (loop 
677                         (cons (%gcd head n2) (%cdr next))
678                         #f) ) ) ) ) ) )
679
680        (define (%lcm x y)
681          (quotient (* x y) (%gcd x y)) )
682
683        (define (lcm . ns)
684          (if (null? ns)
685              1
686              (let loop ((ns ns) (f #t))
687                (let ((head (%car ns))
688                      (next (%cdr ns)))
689                  (when f (%check "number" head))
690                  (if (null? next)
691                      (abs head)
692                      (let ((n2 (%car next)))
693                        (%check "number" n2)
694                        (loop
695                         (cons (%lcm head n2) (%cdr next))
696                         #f) ) ) ) ) ) )
697
698        ))
699
700
701    (define-library-section characters
702
703      (default
704
705        (define-inline (char->integer c)
706          (%inline ".charCodeAt" (%property-ref "character" (%check ("SPOCK.Char") c)) 0))
707
708        (define-inline (integer->char c)
709          (%inline "new SPOCK.Char" (%inline "String.fromCharCode" (%check "number" c))))
710
711        (define-inline (char=? x y)
712          (eq? (%property-ref "character" (%check ("SPOCK.Char") x))
713               (%property-ref "character" (%check ("SPOCK.Char") y))))
714
715        (define-inline (char>? x y)
716          (%inline
717           (1 " > " 2) 
718           (%property-ref "character" (%check ("SPOCK.Char") x))
719           (%property-ref "character" (%check ("SPOCK.Char") y))))
720
721        (define-inline (char<? x y)
722          (%inline
723           (1 " < " 2) 
724           (%property-ref "character" (%check ("SPOCK.Char") x))
725           (%property-ref "character" (%check ("SPOCK.Char") y))))
726
727        (define-inline (char>=? x y)
728          (%inline
729           (1 " >= " 2) 
730           (%property-ref "character" (%check ("SPOCK.Char") x))
731           (%property-ref "character" (%check ("SPOCK.Char") y))))
732
733        (define-inline (char<=? x y)
734          (%inline
735           (1 " <= " 2) 
736           (%property-ref "character" (%check ("SPOCK.Char") x))
737           (%property-ref "character" (%check ("SPOCK.Char") y))))
738
739        (define-inline (char-ci=? x y)
740          (eq? (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
741               (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
742
743        (define-inline (char-ci>? x y)
744          (%inline
745           (1 " > " 2)
746           (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
747           (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
748
749        (define-inline (char-ci<? x y)
750          (%inline
751           (1 " < " 2)
752           (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
753           (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
754
755        (define-inline (char-ci>=? x y)
756          (%inline
757           (1 " >= " 2)
758           (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
759           (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
760
761        (define-inline (char-ci<=? x y)
762          (%inline
763           (1 " <= " 2)
764           (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") x)))
765           (%inline ".toLowerCase" (%property-ref "character" (%check ("SPOCK.Char") y)))))
766
767        (define-inline (char-upcase c)
768          (%inline 
769           "new SPOCK.Char"
770           (%inline 
771            ".toUpperCase"
772            (%property-ref "character" (%check ("SPOCK.Char") c)))))
773
774        (define-inline (char-downcase c)
775          (%inline 
776           "new SPOCK.Char"
777           (%inline 
778            ".toLowerCase"
779            (%property-ref "character" (%check ("SPOCK.Char") c)))))
780
781        (define-inline (char-alphabetic? c)     ;XXX not unicode aware
782          (not
783           (null?
784            (%inline 
785             (1 ".character.match(/^[A-Za-z]$/)") 
786             (%check ("SPOCK.Char") c)))))
787
788        (define-inline (char-numeric? c)        ;XXX not unicode aware?
789          (not (null? (%inline (1 ".character.match(/^\\d$/)") (%check ("SPOCK.Char") c)))))
790
791        (define-inline (char-whitespace? c)
792          (not (null? (%inline (1 ".character.match(/^\\s$/)") (%check ("SPOCK.Char") c)))))
793
794        (define-inline (char-upper-case? c)     ;XXX not unicode aware
795          (not
796           (null?
797            (%inline 
798             (1 ".character.match(/^[A-Z]$/)")
799             (%check ("SPOCK.Char") c)))))
800
801        (define-inline (char-lower-case? c)     ;XXX not unicode aware
802          (not
803           (null?
804            (%inline
805             (1 ".character.match(/^[a-z]$/)")
806             (%check ("SPOCK.Char") c)))))
807
808        ))
809
810
811    (define-library-section symbols
812
813      (default
814       
815        (define-inline (symbol->string sym)
816          (%property-ref "name" (%check ("SPOCK.Symbol") sym)))
817
818        (define string->symbol
819          (%native-lambda
820           "var str = SPOCK.jstring(arguments[ 1 ]);"
821           "return K(SPOCK.intern(str));"))
822
823        ))
824
825
826    (define-library-section property-lists
827
828      (default
829       
830        (define (get sym prop)
831          (let ((val
832                 (%inline
833                  (1 ".plist[" 2 "]") 
834                  (%check ("SPOCK.Symbol") sym)
835                  (%property-ref "name" (%check ("SPOCK.Symbol") prop)))))
836            (and (not (void? val)) val))) ;XXX doesn't allow storing void
837
838        (define (put! sym prop val)
839          (%inline
840           (1 ".plist[" 2 "] = " 3)
841           (%check ("SPOCK.Symbol") sym)
842           (%property-ref "name" (%check ("SPOCK.Symbol") prop))
843           val))
844
845        ))
846
847
848    (define-library-section strings
849
850      (default
851
852        (define-inline (string-length str)
853          (%property-ref "length" (%string->jstring str)))
854
855        (define string-append
856          (%native-lambda
857           "var args = Array.prototype.slice.call(arguments, 1);"
858           "var strs = SPOCK.map(function(x) { return SPOCK.jstring(x); }, args);"
859           "return K(new SPOCK.String(strs));"))
860
861        ;;XXX does no bounds/exactness check
862        (define-inline (substring str i j)
863          (let ((str (%string->jstring str)))
864            (%inline 
865             ".substring" str
866             (%check "number" i)
867             (if (void? j)
868                 (%property-ref "length" str)
869                 (%check "number" j)))))
870
871        ;;XXX we need non-debug versions of all of these
872
873        (define string
874          (%native-lambda
875           "var str = [];"
876           "var len = arguments.length - 1;"
877           "for(var i = 1; i <= len; ++i) {"
878           " var x = arguments[ i ];"
879           " if(x instanceof SPOCK.Char) str.push(x.character);"
880           " else SPOCK.error('bad argument type - not a character', x);}"
881           "return K(new SPOCK.String(str.join('')));"))
882
883        (define string->list
884          (%native-lambda
885           "var str = SPOCK.jstring(arguments[ 1 ]);"
886           "var lst = null;"
887           "var len = str.length;"
888           "for(var i = len - 1; i >= 0; --i)"
889           " lst = new SPOCK.Pair(new SPOCK.Char(str.charAt(i)), lst);"
890           "return K(lst);"))
891
892        (define list->string
893          (%native-lambda
894           "var lst = arguments[ 1 ];"
895           "var str = [];"
896           "while(lst instanceof SPOCK.Pair) {"
897           " str.push(SPOCK.check(lst.car, SPOCK.Char).character);"
898           " lst = lst.cdr;}"
899           "return K(new SPOCK.String(str.join('')));"))
900
901        (define make-string
902          (%native-lambda
903           "var n = SPOCK.check(arguments[ 1 ], 'number', 'make-string');"
904           "var c = arguments[ 2 ];"
905           "var a = new Array(n);"
906           "if(c !== undefined)"
907           " c = SPOCK.check(c, SPOCK.Char, 'make-string').character;"
908           "else c = ' ';"
909           "for(var i = 0; i < n; ++i) a[ i ] = c;"
910           "return K(new SPOCK.String(a.join('')));"))
911
912        ;;XXX no bounds/exactness checks
913        (define string-ref     ;XXX consider inlining the fast case
914          (%native-lambda
915           "var str = arguments[ 1 ];"
916           "var i = SPOCK.check(arguments[ 2 ], 'number', 'string-ref');"
917           "if(typeof str === 'string')"
918           " return K(new SPOCK.Char(str.charAt(i)));"
919           "else if(str instanceof SPOCK.String) {"
920           " var parts = str.parts;"
921           " for(var p in parts) {"
922           "  var l = parts[ p ].length;"
923           "  if(i <= l) return K(new SPOCK.Char(parts[ p ].charAt(i)));"
924           "  else i -= l;}"
925           " SPOCK.error('`string-ref\\\' out of range', str, i);}"))
926
927        (define string-set!
928          (%native-lambda
929           "var str = arguments[ 1 ];"
930           "var i = SPOCK.check(arguments[ 2 ], 'number', 'string-set!');"
931           "var c = SPOCK.check(arguments[ 3 ], SPOCK.Char, 'string-set!');"
932           "if(typeof str === 'string')"
933           " SPOCK.error('argument to `string-set!\\\' is not a mutable string', str);"
934           "else if(str instanceof SPOCK.String) {"
935           " var parts = str.parts;"
936           " for(var p in parts) {"
937           "  var part = parts[ p ];"
938           "  var l = part.length;"
939           "  if(i <= l) {"
940           "   parts[ p ] = part.substring(0, i) + c.character + part.substring(i + 1);"
941           "   return K(undefined);"
942           "  } else i -= l;}"
943           " SPOCK.error('`string-set!\\\' out of range', str, i);}"))
944
945        (define-inline (string=? s1 s2) 
946          (eq? (%string->jstring s1) (%string->jstring s2))) ;XXX may cons a lot
947
948        (define-inline (string>? s1 s2)
949          (%inline (1 " > " 2) (%string->jstring s1) (%string->jstring s2)))
950
951        (define-inline (string<? s1 s2)
952          (%inline (1 " < " 2) (%string->jstring s1) (%string->jstring s2)))
953
954        (define-inline (string>=? s1 s2)
955          (%inline (1 " >= " 2) (%string->jstring s1) (%string->jstring s2)))
956
957        (define-inline (string<=? s1 s2)
958          (%inline (1 " <= " 2) (%string->jstring s1) (%string->jstring s2)))
959
960        (define-inline (string-ci=? s1 s2) ;XXX ugly
961          (eq?
962           (%inline ".toLowerCase" (%string->jstring s1))
963           (%inline ".toLowerCase" (%string->jstring s2))))
964
965        (define-inline (string-ci>? s1 s2)
966          (%inline 
967           (1 " > " 2)
968           (%inline ".toLowerCase" (%string->jstring s1))
969           (%inline ".toLowerCase" (%string->jstring s2))))
970
971        (define-inline (string-ci<? s1 s2)
972          (%inline 
973           (1 " < " 2)
974           (%inline ".toLowerCase" (%string->jstring s1))
975           (%inline ".toLowerCase" (%string->jstring s2))))
976
977        (define-inline (string-ci>=? s1 s2)
978          (%inline 
979           (1 " >= " 2)
980           (%inline ".toLowerCase" (%string->jstring s1))
981           (%inline ".toLowerCase" (%string->jstring s2))))
982
983        (define-inline (string-ci<=? s1 s2)
984          (%inline 
985           (1 " <= " 2)
986           (%inline ".toLowerCase" (%string->jstring s1))
987           (%inline ".toLowerCase" (%string->jstring s2))))
988
989        (define (string-copy str from to)
990          (let* ((str (%string->jstring str))
991                 (from (if (void? from) 0 (%check "number" from)))
992                 (to (if (void? to) (%property-ref "length" str) (%check "number" to))))
993            (%jstring->string (%inline ".slice" str from to))))
994
995        (define (string-fill! str char from to)
996          (unless (%check (%inline (1 "instanceof SPOCK.String") str))
997            (%error "bad argument type - not a mutable string" str))
998          (let* ((text (%inline ".normalize" str))
999                 (char (%check ("SPOCK.Char") char))
1000                 (from (if (void? from) 0 (%check "number" from)))
1001                 (to (if (void? to) (%property-ref "length" text) (%check "number" to))))
1002            ((%native-lambda
1003              "var str = arguments[ 1 ];"
1004              "var from = arguments[ 2 ];"
1005              "var to = arguments[ 3 ];"
1006              "var c = arguments[ 4 ];"
1007              "var snew = new Array(to - from);"
1008              "for(var i in snew) snew[ i ] = c;"
1009              "str.parts = [str.parts[ 0 ].substring(0, from), snew.join(''),"
1010              " str.parts[ 0 ].substring(to)];"
1011              "return K(str);")
1012             str from to char)))
1013
1014        ))
1015
1016
1017    (define-library-section vectors
1018
1019      ;;XXX add non-debug variants
1020
1021      (default
1022
1023        (define-inline (vector-length v)
1024          (%property-ref "length" (%check ("Array") v)))
1025
1026        ;;XXX make these two safe (bounds-checking and exactness)
1027        (define-inline (vector-ref v i)
1028          (%inline (1 "[" 2 "]") (%check ("Array") v) (%check "number" i)))
1029
1030        (define-inline (vector-set! v i x)
1031          (%inline (1 "[" 2 "] = " 3) (%check ("Array") v) (%check "number" i) x))
1032
1033        (define vector
1034          (%native-lambda
1035           "return K(Array.prototype.slice.call(arguments, 1));"))
1036
1037        (define make-vector
1038          (%native-lambda
1039           "var n = SPOCK.check(arguments[ 1 ], 'number', 'make-vector');"
1040           "var x = arguments[ 2 ];"
1041           "var a = new Array(n);"
1042           "if(x !== undefined) {"
1043           " for(var i = 0; i < n; ++i) a[ i ] = x;}"
1044           "return K(a);"))
1045
1046        (define vector->list
1047          (%native-lambda
1048           "var vec = SPOCK.check(arguments[ 1 ], Array, 'vector->list');"
1049           "var lst = null;"
1050           "var len = vec.length;"
1051           "for(var i = len - 1; i >= 0; --i)"
1052           " lst = new SPOCK.Pair(vec[ i ], lst);"
1053           "return K(lst);"))
1054
1055        (define list->vector
1056          (%native-lambda
1057           "var lst = arguments[ 1 ];"
1058           "var vec = [];"
1059           "while(lst instanceof SPOCK.Pair) {"
1060           " vec.push(lst.car);"
1061           " lst = lst.cdr;}"
1062           "return K(vec);"))
1063
1064        (define vector-fill!
1065          (%native-lambda
1066           "var vec = SPOCK.check(arguments[ 1 ], Array, 'vector-fill!');"
1067           "var x = arguments[ 2 ];"
1068           "var from = arguments[ 3 ];"
1069           "var to = arguments[ 4 ];"
1070           "if(from === undefined) from = 0;"
1071           "if(to === undefined) to = vec.length;"
1072           "for(var i = from; i < to; ++i)"
1073           " vec[ i ] = x;"
1074           "return K(undefined);"))
1075
1076        ))
1077
1078
1079    (define-library-section number-string-conversion
1080
1081      (default
1082
1083        (define-inline (number->string num base)
1084          (%inline 
1085           "new SPOCK.String"
1086           (%inline
1087            ".toString" 
1088            (%check "number" num) 
1089            (if (void? base) 
1090                10
1091                (%check "number" base)))))
1092
1093        ;;XXX add non-debug version?
1094        (define string->number
1095          (%native-lambda
1096           "var str = SPOCK.jstring(arguments[ 1 ]);"
1097           "var base = arguments[ 2 ];"
1098           "if(!base) base = 10;"
1099           "else base = SPOCK.check(base, 'number', 'string->number');"
1100           "var m = true, neg = 1;"
1101           "while(m) {"
1102           " m = str.match(/^#[eboxid]/);"
1103           " if(m) {"
1104           "  switch(str[ 1 ]) {"
1105           "  case 'e':"
1106           "  case 'i': break;"
1107           "  case 'd': base = 10; break;"
1108           "  case 'o': base = 8; break;"
1109           "  case 'x': base = 16; break;"
1110           "  case 'b': base = 2; break;"
1111           "  default: return K(false);}"
1112           "  str = str.substring(2);}}"
1113           "switch(str[ 0 ]) {"
1114           "case '-': neg = -1; str = str.substring(1); break;"
1115           "case '+': str = str.substring(1);}"
1116           "var num, den = false;"
1117           "if((m = str.match(/^([^\\/]+)\\/(.+)$/))) {"
1118           "  str = m[ 1 ];"
1119           "  den = m[ 2 ];}"
1120           "function num3(s) {"
1121           " var tr = null;"
1122           " switch(base) {"
1123           " case 2: tr = /^[0-1]+$/; break;"
1124           " case 8: tr = /^[0-7]+$/; break;"
1125           " case 10: tr = /^[#0-9]*\\.?[#0-9]+([esdfl][-+]?[0-9]+)?$/; break;"
1126           " case 16: tr = /^[0-9a-fA-F]+$/;}"
1127           " if(tr && !s.match(tr)) return false;"
1128           " var s2 = s.replace(/#/g, '0');"
1129           " if(base === 10) s2 = parseFloat(s2.replace(/[esdfl]/g, 'e'));"
1130           " else if(s2 !== s) return false;"
1131           " else s2 = parseInt(s2, base);"
1132           " return isNaN(s2) ? false : s2;}"
1133           "if((num = num3(str)) === false) return K(false);"
1134           "if(den && !(den = num3(den))) return K(false);"
1135           "return K(neg * num / (den || 1));"))
1136
1137        ))
1138
1139
1140    (define-library-section unsafe-internal-i/o
1141
1142      (default
1143
1144        ;; (%show STRING PORT)
1145        (define %show
1146          (%native-lambda
1147           "arguments[ 2 ].write(arguments[ 1 ]);"
1148           "return K(undefined);"))
1149
1150        ;; (%fetch N PORT)
1151        (define %fetch
1152          (%native-lambda
1153           "return K(arguments[ 2 ].read(arguments[ 1 ]));"))
1154
1155        ))
1156
1157
1158    (define-library-section port-checks
1159
1160      (debug
1161
1162        ;; (%check-port X DIR LOC)
1163        (define %check-port
1164          (%native-lambda
1165           "var port = arguments[ 1 ];"
1166           "var dir = arguments[ 2 ];"
1167           "if(port instanceof SPOCK.Port) {"
1168           " if(port.closed)"
1169           "  SPOCK.error('port is already closed', port);"
1170           " else if(port.direction !== dir)"
1171           "  SPOCK.error('bad argument type - not an ' + dir + ' port', port, arguments[ 3 ]);"
1172           "}"
1173           "else SPOCK.error('bad argument type - not a port', port, arguments[ 3 ]);"
1174           "return K(port);"))
1175        )
1176     
1177      (default
1178
1179       (define-inline (%check-port x dir loc) x)
1180
1181        ))
1182
1183
1184    (define-library-section basic-i/o
1185
1186      (default
1187
1188        (define-inline (current-input-port) (%host-ref "SPOCK.stdin"))
1189        (define-inline (current-output-port) (%host-ref "SPOCK.stdout"))
1190
1191        (define (newline port)
1192          (%show 
1193           "\n" 
1194           (if (void? port) 
1195               (%host-ref "SPOCK.stdout")
1196               (%check-port port "output" "newline"))))
1197
1198        (define (read-char port)
1199          (let ((s (%fetch
1200                    1
1201                    (if (void? port)
1202                        (%host-ref "SPOCK.stdin")
1203                        (%check-port port "input" "read-char")))))
1204            (if (eof-object? s)
1205                s
1206                (%inline "new SPOCK.Char" s))))
1207
1208        (define (write-char chr port)
1209          (%show
1210           (%property-ref "character" (%check ("SPOCK.Char") chr))
1211           (if (void? port)
1212               (%host-ref "SPOCK.stdout")
1213               (%check-port port "output" "write-char"))))
1214
1215        (define peek-char
1216          (let ((read-char read-char))
1217            (lambda (port)
1218              (let ((c (read-char port)))
1219                (unless (eof-object? c)
1220                  (%inline (1 ".peeked = " 2) port (%property-ref "character" c)))
1221                c))))
1222
1223        (define (char-ready? port)
1224          (%check-port port "input" "char-ready?")
1225          (%inline ".ready" port))
1226
1227        ))
1228
1229
1230    (define-library-section data-output
1231
1232      (default
1233
1234        ;; (%print-hook X PORT READABLE?)         called for unknown object
1235        (define (%print-hook x port readable)
1236          (%show "#<unknown object>" port))
1237
1238        (define (display x port)
1239          (let ((port (if (void? port)
1240                          (%host-ref "SPOCK.stdout")
1241                          (%check-port port "output" "display"))))
1242            (let show ((x x))
1243              (cond ((null? x) (%show "()" port))
1244                    ((number? x)
1245                     ;;XXX this could be optimized
1246                     (%show (%string->jstring (number->string x)) port))
1247                    ((string? x)
1248                     (%show (%inline "SPOCK.jstring" x) port))
1249                    ((symbol? x)
1250                     (%show (%property-ref "name" x) port))
1251                    ((char? x)
1252                     (%show (%property-ref "character" x) port))
1253                    ((eof-object? x) (%show "#<eof>" port))
1254                    ((procedure? x) (%show "#<procedure>" port))
1255                    ((boolean? x) (%show (if x "#t" "#f") port))
1256                    ((pair? x)
1257                     (%show "(" port)
1258                     (let loop ((y x))
1259                       (cond ((null? y) (%show ")" port))
1260                             ((not (pair? y))
1261                              (%show " . " port)
1262                              (show y)
1263                              (%show ")" port))
1264                             (else
1265                              (unless (eq? x y) (%show " " port))
1266                              (show (%car y))
1267                              (loop (cdr y))))))
1268                    ((void? x) (%show "#<undefined>" port))
1269                    ((vector? x)
1270                     (let ((len (%property-ref "length" x)))
1271                       (%show "#(" port)
1272                       (do ((i 0 (%inline ("1+" 1) i)))
1273                           ((%inline (1 ">=" 2) i len)
1274                            (%show ")" port))
1275                         (unless (eq? i 0) (%show " " port))
1276                         (show (%inline (1 "[" 2 "]") x i)))))
1277                    ((%inline (1 "instanceof SPOCK.Port") x)
1278                     (%show (%inline "SPOCK.stringify" x) port))
1279                    ((%inline (1 "instanceof SPOCK.Promise") x)
1280                     (%show "#<promise>" port))
1281                    ((eq? "object" (%inline "typeof" x))
1282                     (%print-hook x port #f))
1283                    (else (%show "#<unknown object>" port))))))
1284
1285        (define write
1286          (let ((display display))
1287            (define escape 
1288              (%native-lambda 
1289               "var str = arguments[ 1 ];"
1290               "var a = [];"
1291               "var len = str.length;"
1292               "for(var i = 0; i < len; ++i) {"
1293               " var c = str.charAt(i);"
1294               " switch(c) {"
1295               " case '\\n': a.push('\\n'); break;"
1296               " case '\\t': a.push('\\t'); break;"
1297               " case '\\r': a.push('\\r'); break;"
1298               " case '\\\"': a.push('\\\"'); break;"
1299               " case '\\\\': a.push('\\\\'); break;"
1300               " default: a.push(c);}}"
1301               "return K(a.join(''));"))
1302            (lambda (x port)
1303              (let ((port (if (void? port)
1304                              (%host-ref "SPOCK.stdout")
1305                              (%check-port port "output" "write"))))
1306                (let show ((x x))
1307                  (cond ((string? x)
1308                         (%show "\"" port)
1309                         (%show (escape (%inline "SPOCK.jstring" x)) port)
1310                         (%show "\"" port))
1311                        ((char? x)
1312                         (%show "#\\" port)
1313                         (%show
1314                          (let ((c (%property-ref "character" x)))
1315                            (case c
1316                              (("\n") "newline") ; don't worry
1317                              (("\r") "return")
1318                              (("\t") "tab")
1319                              ((" ") "space")
1320                              (else c)))
1321                          port))
1322                        ((pair? x)
1323                         (%show "(" port)
1324                         (let loop ((y x))
1325                           (cond ((null? y) (%show ")" port))
1326                                 ((not (pair? y))
1327                                  (%show " . " port)
1328                                  (show y)
1329                                  (%show ")" port))
1330                                 (else
1331                                  (unless (eq? x y) (%show " " port))
1332                                  (show (%car y))
1333                                  (loop (cdr y))))))
1334                        ((vector? x)
1335                         (let ((len (%property-ref "length" x)))
1336                           (%show "#(" port)
1337                           (do ((i 0 (%inline ("1+" 1) i)))
1338                               ((%inline (1 ">=" 2) i len)
1339                                (%show ")" port))
1340                             (unless (eq? i 0) (%show " " port))
1341                             (show (%inline (1 "[" 2 "]") x i)))))
1342                        (else (display x port))))))))
1343
1344        ))
1345
1346
1347    (define-library-section extended-i/o
1348
1349      (default
1350
1351        (define-inline (current-error-port) (%host-ref "SPOCK.stderr"))
1352
1353        ))
1354
1355
1356    (define-library-section higher-order-operations
1357
1358      (default
1359
1360        (define apply
1361          (%native-lambda
1362           "var proc = arguments[ 1 ];"
1363           "var argc = arguments.length;"
1364           "var lst = arguments[ argc - 1 ];"
1365           "var vec = [K].concat(Array.prototype.slice.call(arguments, 2, argc - 1));"
1366           "if(lst instanceof Array) vec = vec.concat(lst);"
1367           "else{"
1368           " var len = SPOCK.length(lst);"
1369           " var vec2 = new Array(len);"
1370           " for(var i = 0; lst instanceof SPOCK.Pair; lst = lst.cdr)"
1371           "  vec2[ i++ ] = lst.car;"
1372           " vec = vec.concat(vec2);}"
1373           "return proc.apply(SPOCK.global, vec);"))
1374
1375        (define (for-each proc lst1 . lsts)
1376          (if (null? lsts)
1377              (if (vector? lst1)
1378                  (let ((len (vector-length lst1)))
1379                    (do ((i 0 (+ i 1)))
1380                        ((>= i len))
1381                      (proc (vector-ref lst1 i))))
1382                  (let loop ((lst lst1))
1383                    (when (pair? lst)
1384                      (proc (%car lst))
1385                      (loop (%cdr lst)))))
1386              (let loop ((lsts (cons lst1 lsts)))
1387                (let ((hds (let loop2 ((lsts lsts))
1388                             (if (null? lsts)
1389                                 '()
1390                                 (let ((x (%car lsts)))
1391                                   (and (pair? x)
1392                                        (cons (%car x) (loop2 (%cdr lsts)))))))))
1393                  (when hds
1394                    (apply proc hds)
1395                    (loop
1396                     (let loop3 ((lsts lsts))
1397                       (if (null? lsts)
1398                           '()
1399                           (cons (%cdr (%car lsts)) (loop3 (%cdr lsts)))))))))))
1400
1401        (define (map proc lst1 . lsts)
1402          (if (null? lsts)
1403              (if (vector? lst1)
1404                  (let* ((len (vector-length lst1))
1405                         (rv (make-vector len)))
1406                    (do ((i 0 (+ i 1)))
1407                        ((>= i len) rv)
1408                      (vector-set! rv i (proc (vector-ref lst1 i)))))
1409                  (let loop ((lst lst1))
1410                    (if (pair? lst)
1411                        (cons (proc (%car lst))
1412                              (loop (%cdr lst)))
1413                        '())))
1414              (let loop ((lsts (cons lst1 lsts)))
1415                (let ((hds (let loop2 ((lsts lsts))
1416                             (if (null? lsts)
1417                                 '()
1418                                 (let ((x (%car lsts)))
1419                                   (and (pair? x)
1420                                        (cons (%car x) (loop2 (%cdr lsts)))))))))
1421                  (if hds
1422                      (cons
1423                       (apply proc hds)
1424                       (loop
1425                        (let loop3 ((lsts lsts))
1426                          (if (null? lsts)
1427                              '()
1428                              (cons (%cdr (%car lsts)) (loop3 (%cdr lsts)))))))
1429                      '())))))
1430
1431        ))
1432
1433
1434    (define-library-section continuations
1435
1436      (default
1437
1438        (define dynamic-wind
1439          (let ((call-with-values call-with-values)
1440                (values values))
1441            (lambda (before thunk after)
1442              (before)
1443              (%host-set! 
1444               "SPOCK.dynwinds" 
1445               (cons (cons before after) (%host-ref "SPOCK.dynwinds")))
1446              (%call-with-saved-values
1447               thunk
1448               (lambda ()
1449                 (%host-set! "SPOCK.dynwinds" (%cdr (%host-ref "SPOCK.dynwinds")))
1450                 (after))))))
1451
1452        ;; (%call-with-current-continuation PROC)
1453        ;;
1454        ;; - does not unwind
1455        (define %call-with-current-continuation
1456          (%native-lambda
1457           "var proc = arguments[ 1 ];"
1458           "function cont() {"
1459           " return K.apply(SPOCK.global, Array.prototype.slice.call(arguments, 1));}"
1460           "return proc(K, cont);"))
1461
1462        (define call-with-current-continuation
1463          (let ()
1464            (define (unwind winds n)
1465              (cond ((eq? (%host-ref "SPOCK.dynwinds") winds))
1466                    ((< n 0)
1467                     (unwind (%cdr winds) (%inline (1 " + 1") n))
1468                     ((%car (%car winds)))
1469                     (%host-set! "SPOCK.dynwinds" winds))
1470                    (else
1471                     (let ((after (%cdr (%car (%host-ref "SPOCK.dynwinds")))))
1472                       (%host-set! "SPOCK.dynwinds" (%cdr (%host-ref "SPOCK.dynwinds")))
1473                       (after)
1474                       (unwind winds (%inline (1 " - 1") n)) ) )))
1475            (lambda (proc)
1476              (let ((winds (%host-ref "SPOCK.dynwinds")))
1477                (%call-with-current-continuation
1478                 (lambda (cont)
1479                   (proc
1480                    (lambda results     ;XXX suboptimal
1481                      (let ((winds2 (%host-ref "SPOCK.dynwinds")))
1482                        (unless (eq? winds2 winds)
1483                          (unwind winds (- (length winds2) (length winds))) )
1484                        (apply cont results) ) ) ) ) ) ))))
1485
1486        ))
1487
1488
1489    (define-library-section suspensions
1490
1491      (default
1492
1493        (define (%get-context k)
1494          (vector
1495           k
1496           (%host-ref "SPOCK.dynwinds")
1497           (%host-ref "SPOCK.stdin")
1498           (%host-ref "SPOCK.stdout")
1499           (%host-ref "SPOCK.stderr")))
1500
1501        (define %restore-context
1502          (%native-lambda
1503           "var state = arguments[ 1 ];"
1504           "SPOCK.dynwinds = state[ 1 ];"
1505           "SPOCK.stdin = state[ 2 ];"
1506           "SPOCK.stdout = state[ 3 ];"
1507           "SPOCK.stderr = state[ 4 ];"
1508           "return (state[ 0 ])(undefined);")) ; drops K
1509       
1510        ;;XXX currently undocumented and untested
1511        (define (suspend proc)
1512          (%call-with-current-continuation
1513           (lambda (k)
1514             (proc (%get-context k))
1515             ((%native-lambda "return new SPOCK.Result(undefined);")))))
1516
1517        ;;XXX currently undocumented and untested
1518        (define-inline (resume state)
1519          (%restore-context state))
1520
1521        ))
1522
1523
1524    (define-library-section promises
1525
1526      (default
1527
1528        (define (%make-promise thunk)
1529          (%inline
1530           "new SPOCK.Promise"
1531           (let ((ready #f)
1532                 (results #f))
1533             (lambda ()
1534               ;;XXX this can possibly be optimized
1535               (if ready
1536                   (apply values results)
1537                   (call-with-values thunk
1538                     (lambda xs
1539                       (cond (ready (apply values results))
1540                             (else
1541                              (set! ready #t)
1542                              (set! results xs)
1543                              (apply values results))))))))))
1544
1545        (define (force p)
1546          (if (%inline (1 " instanceof SPOCK.Promise") p)
1547              ((%property-ref "thunk" p))
1548              p))
1549
1550        ))
1551
1552
1553    (define-library-section port-redirection
1554
1555      (default
1556
1557        (define with-input-from-port
1558          (let ((dynamic-wind dynamic-wind))
1559            (lambda (port thunk)
1560              (%check-port port "input" "with-input-from-port")
1561              (let ((old #f))
1562                (dynamic-wind
1563                    (lambda ()
1564                      (set! old (%host-ref "SPOCK.stdin"))
1565                      (%host-set! "SPOCK.stdin" port))
1566                    thunk
1567                    (lambda ()
1568                      (%host-set! "SPOCK.stdin" old)))))))
1569
1570        (define with-output-to-port
1571          (let ((dynamic-wind dynamic-wind))
1572            (lambda (port thunk)
1573              (%check-port port "output" "with-output-to-port")
1574              (let ((old #f))
1575                (dynamic-wind
1576                    (lambda ()
1577                      (set! old (%host-ref "SPOCK.stdout"))
1578                      (%host-set! "SPOCK.stdout" port))
1579                    thunk
1580                    (lambda ()
1581                      (%host-set! "SPOCK.stdout" old)))))))
1582
1583        ))
1584
1585
1586    (define-library-section file-operations
1587
1588      (default
1589
1590        (define-inline (input-port? x)
1591          (and (%inline (1 "instanceof SPOCK.Port") x)
1592               (eq? "input" (%property-ref "direction" x))))
1593
1594        (define-inline (output-port? x)
1595          (and (%inline (1 "instanceof SPOCK.Port") x)
1596               (eq? "output" (%property-ref "direction" x))))
1597
1598        (define %close-port
1599          (%native-lambda
1600           "var port = arguments[ 1 ];"
1601           "port.close();"
1602           "port.closed = true;"
1603           "return K(port);"))
1604
1605        (define open-input-file
1606          (%native-lambda
1607           "var fn = SPOCK.check(arguments[ 1 ], 'string', 'open-input-file');"
1608           "return K(SPOCK.openInputFile(fn));"))
1609
1610        (define open-output-file
1611          (%native-lambda
1612           "var fn = SPOCK.check(arguments[ 1 ], 'string', 'open-input-file');"
1613           "var exp = null;"
1614           "if(arguments.length === 3)"
1615           " exp = SPOCK.check(arguments[ 2 ], 'number', 'open-input-file');"
1616           "return K(SPOCK.openOutputFile(fn, exp));"))
1617
1618        (define (close-input-port port)
1619          (let ((port (%check-port port "input" "close-input-port")))
1620            (%close-port port)))
1621
1622        (define (close-output-port port)
1623          (let ((port (%check-port port "output" "close-output-port")))
1624            (%close-port port)))
1625
1626        (define call-with-input-file
1627          (let ((call-with-values call-with-values)
1628                (open-input-file open-input-file)
1629                (values values)
1630                (apply apply))
1631            (lambda (file proc)
1632              (let ((in (open-input-file file)))
1633                (%call-with-saved-values 
1634                 (lambda () (proc in))
1635                 (lambda ()
1636                   (close-input-port in)))))))
1637
1638        (define call-with-output-file
1639          (let ((call-with-values call-with-values)
1640                (open-output-file open-output-file)
1641                (values values)
1642                (apply apply))
1643            (lambda (file proc)
1644              (let ((out (open-output-file file)))
1645                (%call-with-saved-values 
1646                 (lambda () (proc out))
1647                 (lambda ()
1648                   (close-output-port out)))))))
1649
1650        (define with-input-from-file
1651          (let ((with-input-from-port with-input-from-port)
1652                (open-input-file open-input-file)
1653                (apply apply)
1654                (values values)
1655                (call-with-values call-with-values)
1656                (close-input-port close-input-port))
1657            (lambda (filename thunk)
1658              (let ((in (open-input-file filename)))
1659                (with-input-from-port in 
1660                  (lambda ()
1661                    (%call-with-saved-values 
1662                     thunk
1663                     (lambda ()
1664                       (close-input-port in)))))))))
1665
1666        (define with-output-to-file
1667          (let ((with-output-to-port with-output-to-port)
1668                (open-output-file open-output-file)
1669                (apply apply)
1670                (values values)
1671                (call-with-values call-with-values)
1672                (close-output-port close-output-port))
1673            (lambda (filename thunk)
1674              (let ((out (open-output-file filename)))
1675                (with-output-to-port out
1676                  (lambda ()
1677                    (%call-with-saved-values 
1678                     thunk
1679                     (lambda ()
1680                       (close-output-port out)))))))))
1681
1682        ))
1683
1684
1685    (define-library-section string-ports
1686
1687      (default
1688
1689        (define (open-input-string str)
1690          (define open
1691            (%native-lambda
1692             "var buffer = arguments[ 1 ];"
1693             "var pos = 0;"
1694             "var len = buffer.length;"
1695             "function read(n) {"
1696             " if(pos >= len) return SPOCK.EOF;"
1697             " var str = buffer.substring(pos, pos + n);"
1698             " pos += n;"
1699             " return str;}"
1700             "return K(new SPOCK.Port('input', { read: read }));"))
1701          (open (%string->jstring str)))
1702
1703        (define open-output-string
1704          (%native-lambda
1705           "var buffer = [];"
1706           "function write(s) { buffer.push(s); }"
1707           "var port = new SPOCK.Port('output', { write: write });"
1708           "port.buffer = buffer;"
1709           "port.isStringPort = true;"
1710           "return K(port);"))
1711
1712        (define (get-output-string port)
1713          (let ((port (%check ("SPOCK.Port") port)))
1714            (if (not (void? (%property-ref "isStringPort" port)))
1715                (let ((str (%jstring->string
1716                            (%inline ".join" (%property-ref "buffer" port) ""))))
1717                  (%inline (1 ".buffer = []") port)
1718                  str)
1719                ;;XXX unnecessary in non-debug mode
1720                (%inline "SPOCK.error" "bad argument type - not a string port" port))))
1721
1722        (define (with-input-from-string str thunk)
1723          (let ((in (open-input-string str)))
1724            (with-input-from-port in thunk)))
1725
1726        (define (with-output-to-string thunk)
1727          (let ((out (open-output-string)))
1728            (with-output-to-port out thunk)
1729            (get-output-string out)))
1730
1731        ))
1732
1733
1734    (define-library-section reader
1735
1736      (default
1737
1738        (define read
1739          (let ((read-char read-char)
1740                (reverse reverse)
1741                (peek-char peek-char)
1742                (list->vector list->vector)
1743                (list->string list->string)
1744                (current-input-port current-input-port)
1745                (string->number string->number))
1746            (lambda (port)
1747              (let ((port (if (void? port) (current-input-port) port)))
1748                (define (parse-token t)
1749                  (or (string->number t)
1750                      (string->symbol t)))
1751                (define (read1)
1752                  (let ((c (read-char port)))
1753                    (if (eof-object? c) 
1754                        c
1755                        (case c
1756                          ((#\#) (read-sharp))
1757                          ((#\() (read-list #\)))
1758                          ((#\[) (read-list #\]))
1759                          ((#\{) (read-list #\}))
1760                          ((#\,) (if (eqv? (peek-char port) #\@)
1761                                     (list 'unquote-splicing (read1))
1762                                     (list 'unquote (read1))))
1763                          ((#\`) (list 'quasiquote (read1)))
1764                          ((#\') `',(read1))
1765                          ((#\;) (skip-line) (read1))
1766                          ((#\") (read-string))
1767                          ((#\) #\] #\}) (%error "unexpected delimiter" c))
1768                          (else
1769                           (if (char-whitespace? c)
1770                               (read1)
1771                               (parse-token (read-token (list c)))))))))
1772                (define (skip-line)
1773                  (let ((c (read-char port)))
1774                    (unless (or (eof-object? c) (char=? #\newline c))
1775                      (skip-line))))
1776                (define (skip-whitespace) ; returns peeked char
1777                  (let ((c (peek-char port)))
1778                    (cond ((char-whitespace? c)
1779                           (read-char port)
1780                           (skip-whitespace))
1781                          (else c))))
1782                (define (read-sharp)
1783                  (let ((c (read-char port)))
1784                    (if (eof-object? c)
1785                        (%error "unexpected EOF after `#'")
1786                        (case c
1787                          ((#\t #\T) #t)
1788                          ((#\f #\F) #f)
1789                          ((#\() (list->vector (read-list #\))))
1790                          ((#\% #\!) (string->symbol (read-token (list c #\#))))
1791                          ((#\\) 
1792                           (let ((t (read-token '())))
1793                             (cond ((string-ci=? "newline" t) #\newline)
1794                                   ((string-ci=? "tab" t) #\tab)
1795                                   ((string-ci=? "space" t) #\space)
1796                                   ((zero? (string-length t))
1797                                    (%error "invalid character syntax"))
1798                                   (else (string-ref t 0)))))
1799                          (else (%error "invalid `#' syntax" c))))))
1800                (define (read-list delim)
1801                  (let loop ((lst '()))
1802                    (let ((c (skip-whitespace)))
1803                      (cond ((eof-object? c)
1804                             (%error "unexpected EOF while reading list"))
1805                            ((char=? c delim)
1806                             (read-char port)
1807                             (reverse lst))
1808                            (else
1809                             (if (eqv? #\. c)
1810                                 (let ((t (read-token '())))
1811                                   (if (string=? "." t)
1812                                       (let ((rest (read1)))
1813                                         (skip-whitespace)
1814                                         (if (eqv? (read-char port) delim)
1815                                             (append (reverse lst) rest)
1816                                             (%error "missing closing delimiter" delim)))
1817                                       (loop (cons (parse-token t)) lst)))
1818                                 (loop (cons (read1) lst))))))))
1819                (define (read-string)
1820                  (let loop ((lst '()))
1821                    (let ((c (read-char port)))
1822                      (cond ((eof-object? c)
1823                             (%error "unexpected EOF while reading string"))
1824                            ((char=? #\" c) 
1825                             (list->string (reverse lst)))
1826                            ((char=? #\\ c)
1827                             (let ((c (read-char port)))
1828                               (if (eof-object? c)
1829                                   (%error "unexpected EOF while reading string")
1830                                   (case c
1831                                     ((#\n) (loop (cons #\newline lst)))
1832                                     ((#\t) (loop (cons #\tab lst)))
1833                                     (else (loop (cons c lst)))))))
1834                            (else (loop (cons c lst)))))))
1835                (define (read-token prefix)
1836                  (let loop ((lst prefix)) ; prefix must be in reverse order
1837                    (let ((c (peek-char port)))
1838                      (if (or (eof-object? c) 
1839                              (memv c '(#\{ #\} #\( #\) #\[ #\] #\; #\"))
1840                              (char-whitespace? c))
1841                          (list->string (reverse lst))
1842                          (loop (cons (read-char port) lst))))))
1843                (read1)))))
1844
1845        ))
1846
1847
1848    (define-library-section loading
1849     
1850      (default
1851
1852        (define (load file k)
1853          (%inline 
1854           "SPOCK.load"
1855           (%string->jstring file) 
1856           (and (not (%void? k))
1857                (callback k))))
1858
1859        ))
1860
1861
1862    (define-library-section error-handling
1863
1864      (default
1865       
1866        ;; (%error MESSAGE ARGUMENTS ...)
1867        (define %error
1868          (%native-lambda
1869           "SPOCK.error.apply(SPOCK.global, Array.prototype.slice.call(arguments, 1));"))
1870
1871        (define error %error)
1872
1873        ))
1874
1875
1876    (define-library-section miscellaneous
1877
1878      (default
1879
1880        (define (exit code)
1881          (%inline "SPOCK.exit" (if (void? code) 0 (%check "number" code))))
1882
1883        (define (milliseconds thunk)
1884          (let ((t0 (%inline "(new Date()).getTime")))
1885            (if (void? thunk)
1886                t0
1887                (let* ((r (thunk)) ;XXX will not handle multiple values
1888                       (t1 (%inline "(new Date()).getTime")))
1889                  (%inline (1 "-" 2) t1 t0))))) 
1890
1891        (define-inline (callback proc)
1892          (%inline "SPOCK.callback" proc))
1893
1894        (define-inline (callback-method proc)
1895          (%inline "SPOCK.callbackMethod" proc))
1896
1897        (define (print . args)
1898          (for-each display args)
1899          (newline))
1900
1901        (define-inline (id x) x)
1902        (define-inline (const x) (lambda _ x))
1903        (define-inline (compl f) (lambda (x) (not (f x))))
1904       
1905        (define (o . fns)               ;XXX optimize this
1906          (if (null? fns)
1907              id
1908              (let loop ((fns fns))
1909                (let ((h (%car fns))
1910                      (t (%cdr fns)) )
1911                  (if (null? t)
1912                      h
1913                      (lambda (x) (h ((loop t) x))))))))
1914
1915        (define %
1916          (%native-lambda
1917           "var o = {};"
1918           "for(var i = 1; i < arguments.length; i += 2) {"
1919           " var x = arguments[ i ];"
1920           " if(typeof x === 'string') o[ x ] = arguments[ i + 1 ];"
1921           " else if(x instanceof SPOCK.String)"
1922           "  o[ x.name ] = arguments[ i + 1 ];"
1923           " else SPOCK.error('(%) object key not a string or symbol', x);}"
1924           "return K(o);"))
1925
1926        (define native 
1927          (%native-lambda 
1928           "var func = arguments[ 1 ];"
1929           "return K(function(k) {"
1930           " var args = Array.prototype.splice.call(arguments, 1);"
1931           " return k(func.apply(SPOCK.global, args));});"))
1932
1933        (define native-method
1934          (%native-lambda
1935           "var func = arguments[ 1 ];"
1936           "return K(function(k) {"
1937           " var args = Array.prototype.splice.call(arguments, 2);"
1938           " return k(func.apply(arguments[ 1 ], args));});"))
1939
1940        (define bind-method
1941          (%native-lambda
1942           "var func = arguments[ 1 ];"
1943           "var that = arguments[ 2 ];"
1944           "return K(function() { return func.apply(that, arguments); });"))
1945
1946        (define-inline (file-exists? filename)
1947          (%inline "SPOCK.fileExists" (%string->jstring filename)))
1948
1949        (define jstring
1950          (%native-lambda
1951           "var x = arguments[ 1 ];"
1952           "if(typeof x === 'string') return K(x);"
1953           "else if(x instanceof SPOCK.String) return K(x.normalize());"
1954           "else if(x instanceof SPOCK.Char) return K(x.character);"
1955           "else return K(x);"))
1956
1957        ))
1958
1959    ))
Note: See TracBrowser for help on using the repository browser.