Added Etienne's error messages to the vm, which give the name of the
[picobit/chj.git] / library.scm
blob38fe8c10887bfaf37fa4a85be7fa9e430afac04b
1 ; File: "library.scm"
3 (define number?
4   (lambda (x)
5     (#%number? x)))
7 (define +
8   (lambda (x . rest)
9     (if (#%pair? rest)
10         (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
11         x)))
13 (define #%+-aux
14   (lambda (x rest)
15     (if (#%pair? rest)
16         (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
17         x)))
19 (define -
20   (lambda (x . rest)
21     (if (#%pair? rest)
22         (#%--aux (#%- x (#%car rest)) (#%cdr rest))
23         (#%neg x))))
25 (define #%--aux
26   (lambda (x rest)
27     (if (#%pair? rest)
28         (#%--aux (#%- x (#%car rest)) (#%cdr rest))
29         x)))
31 (define *
32   (lambda (x . rest)
33     (if (#%pair? rest)
34         (#%*-aux (#%* x (#%car rest)) (#%cdr rest))
35         x)))
37 (define #%*-aux
38   (lambda (x rest)
39     (if (#%pair? rest)
40         (#%*-aux (#%* x (#%car rest)) (#%cdr rest))
41         x)))
43 (define quotient
44   (lambda (x y)
45     (#%quotient x y)))
47 (define remainder
48   (lambda (x y)
49     (#%remainder x y)))
51 (define =
52   (lambda (x y)
53     (#%= x y)))
55 (define <
56   (lambda (x y)
57     (#%< x y)))
59 (define <=
60   (lambda (x y)
61     (or (#%< x y) (#%= x y))))
63 (define >
64   (lambda (x y)
65     (#%> x y)))
67 (define >=
68   (lambda (x y)
69     (or (#%> x y) (#%= x y))))
71 (define pair?
72   (lambda (x)
73     (#%pair? x)))
75 (define cons
76   (lambda (x y)
77     (#%cons x y)))
79 (define car
80   (lambda (x)
81     (#%car x)))
83 (define cdr
84   (lambda (x)
85     (#%cdr x)))
87 (define set-car!
88   (lambda (x y)
89     (#%set-car! x y)))
91 (define set-cdr!
92   (lambda (x y)
93     (#%set-cdr! x y)))
95 (define null?
96   (lambda (x)
97     (#%null? x)))
99 (define eq?
100   (lambda (x y)
101     (#%eq? x y)))
103 (define not
104   (lambda (x)
105     (#%not x)))
107 (define list
108   (lambda lst lst))
110 (define length
111   (lambda (lst)
112     (#%length-aux lst 0)))
114 (define #%length-aux
115   (lambda (lst n)
116     (if (#%pair? lst)
117         (#%length-aux (cdr lst) (#%+ n 1))
118         n)))
120 (define append
121   (lambda (lst1 lst2)
122     (if (#%pair? lst1)
123         (#%cons (#%car lst1) (append (#%cdr lst1) lst2))
124         lst2)))
126 (define reverse
127   (lambda (lst)
128     (reverse-aux lst '())))
130 (define reverse-aux
131   (lambda (lst rev)
132     (if (#%pair? lst)
133         (reverse-aux (#%cdr lst) (#%cons (#%car lst) rev))
134         rev)))
136 (define list-ref
137   (lambda (lst i)
138     (if (#%= i 0)
139         (#%car lst)
140         (list-ref (#%cdr lst) (#%- i 1)))))
142 (define list-set!
143   (lambda (lst i x)
144     (if (#%= i 0)
145         (#%set-car! lst x)
146         (list-set! (#%cdr lst) (#%- i 1) x))))
148 (define max
149   (lambda (x y)
150     (if (#%> x y) x y)))
152 (define min
153   (lambda (x y)
154     (if (#%< x y) x y)))
156 (define abs
157   (lambda (x)
158     (if (#%< x 0) (#%neg x) x)))
160 (define modulo
161   (lambda (x y)
162     (#%remainder x y)))
164 (define string
165   (lambda chars
166     (#%list->string chars)))
168 (define string->list
169   (lambda (str)
170     (#%string->list str)))
172 (define list->string
173   (lambda (chars)
174     (#%list->string chars)))
176 (define string-length ;; TODO are all these string operations efficient ? they all convert to lists. use true vectors when we have them ?
177   (lambda (str)
178     (length (#%string->list str))))
180 (define string-append
181   (lambda (str1 str2)
182     (#%list->string (append (#%string->list str1) (#%string->list str2)))))
184 (define substring
185   (lambda (str start end)
186     (#%list->string
187      (#%substring-aux2
188       (#%substring-aux1 (#%string->list str) start)
189       (#%- end start)))))
191 (define #%substring-aux1
192   (lambda (lst n)
193     (if (>= n 1) ;; TODO had an off-by-one
194         (#%substring-aux1 (#%cdr lst) (#%- n 1))
195         lst)))
197 (define #%substring-aux2
198   (lambda (lst n)
199     (if (>= n 1)
200         (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1)))
201         '())))
203 (define map
204   (lambda (f lst)
205     (if (#%pair? lst)
206         (#%cons (f (#%car lst))
207                 (map f (#%cdr lst)))
208         '())))
210 (define for-each
211   (lambda (f lst)
212     (if (#%pair? lst)
213         (begin
214           (f (#%car lst))
215           (for-each f (#%cdr lst)))
216         #f)))
218 (define call/cc
219   (lambda (receiver)
220     (let ((k (#%get-cont)))
221       (receiver
222        (lambda (r)
223          (#%return-to-cont k r))))))
225 (define root-k #f)
226 (define readyq #f)
228 (define start-first-process
229   (lambda (thunk)
230     (set! root-k (#%get-cont))
231     (set! readyq (#%cons #f #f))
232     (#%set-cdr! readyq readyq)
233     (thunk)))
235 (define spawn
236   (lambda (thunk)
237     (let* ((k (#%get-cont))
238            (next (#%cons k (#%cdr readyq))))
239       (#%set-cdr! readyq next)
240       (#%graft-to-cont root-k thunk))))
242 (define exit
243   (lambda ()
244     (let ((next (#%cdr readyq)))
245       (if (#%eq? next readyq)
246           (#%halt)
247           (begin
248             (#%set-cdr! readyq (#%cdr next))
249             (#%return-to-cont (#%car next) #f))))))
251 (define yield
252   (lambda ()
253     (let ((k (#%get-cont)))
254       (#%set-car! readyq k)
255       (set! readyq (#%cdr readyq))
256       (let ((next-k (#%car readyq)))
257         (#%set-car! readyq #f)
258         (#%return-to-cont next-k #f)))))
260 (define clock
261   (lambda ()
262     (#%clock)))
264 (define beep
265   (lambda (freq-div duration)
266     (#%beep freq-div duration)))
268 (define light
269   (lambda (sensor)
270     (#%adc sensor)))
272 (define adc
273   (lambda (sensor)
274     (#%adc sensor)))
276 (define sernum
277   (lambda ()
278     (#%sernum)))
280 (define putchar
281   (lambda (c)
282     (#%putchar c 3)))
284 (define getchar
285   (lambda ()
286     (or (#%getchar-wait 0 3)
287         (getchar))))
289 (define getchar-wait
290   (lambda (duration)
291     (#%getchar-wait duration 3)))
293 (define sleep
294   (lambda (duration)
295     (#%sleep-aux (#%+ (#%clock) duration))))
297 (define #%sleep-aux
298   (lambda (wake-up)
299     (if (#%< (#%clock) wake-up)
300         (#%sleep-aux wake-up)
301         #f)))
303 (define motor
304   (lambda (id power)
305     (#%motor id power)))
308 (define led
309   (lambda (id duty period)
310     (#%led id duty period)))
312 (define led2-color
313   (lambda (state)
314     (if (#%eq? state 'red)
315         (#%led2-color 1)
316         (#%led2-color 0))))
318 (define display
319   (lambda (x)
320     (if (#%string? x)
321         (for-each putchar (#%string->list x))
322         (write x))))
324 (define write
325   (lambda (x)
326     (if (#%string? x)
327         (begin
328           (#%putchar #\" 3)
329           (display x)
330           (#%putchar #\" 3))
331         (if (#%number? x)
332             (display (number->string x))
333             (if (#%pair? x)
334                 (begin
335                   (#%putchar #\( 3)
336                   (write (#%car x))
337                   (#%write-list (#%cdr x)))
338                 (if (#%symbol? x)
339                     (display "#<symbol>")
340                     (display "#<object>")))))))
342 (define #%write-list
343   (lambda (lst)
344     (if (#%null? lst)
345         (#%putchar #\) 3)
346         (if (#%pair? lst)
347             (begin
348               (#%putchar #\space 3)
349               (write (#%car lst))
350               (#%write-list (#%cdr lst)))
351             (begin
352               (display " . ")
353               (write lst)
354               (#%putchar #\) 3))))))
356 (define number->string
357   (lambda (n)
358     (#%list->string
359      (if (#%< n 0)
360          (#%cons #\- (#%number->string-aux (#%neg n) '()))
361          (#%number->string-aux n '())))))
363 (define #%number->string-aux
364   (lambda (n lst)
365     (let ((rest (#%cons (#%+ #\0 (#%remainder n 10)) lst)))
366       (if (#%< n 10)
367           rest
368           (#%number->string-aux (#%quotient n 10) rest)))))
370 (define pp
371   (lambda (x)
372     (write x)
373     (#%putchar #\newline 3)))
375 (define caar
376   (lambda (p)
377     (#%car (#%car p))))
378 (define cadr
379   (lambda (p)
380     (#%car (#%cdr p))))
381 (define cdar
382   (lambda (p)
383     (#%cdr (#%car p))))
384 (define cddr
385   (lambda (p)
386     (#%cdr (#%cdr p))))
387 (define caaar
388   (lambda (p)
389     (#%car (#%car (#%car p)))))
390 (define caadr
391   (lambda (p)
392     (#%car (#%car (#%cdr p)))))
393 (define cadar
394   (lambda (p)
395     (#%car (#%cdr (#%car p)))))
396 (define caddr
397   (lambda (p)
398     (#%car (#%cdr (#%cdr p)))))
399 (define cdaar
400   (lambda (p)
401     (#%cdr (#%car (#%car p)))))
402 (define cdadr
403   (lambda (p)
404     (#%cdr (#%car (#%cdr p)))))
405 (define cddar
406   (lambda (p)
407     (#%cdr (#%cdr (#%car p)))))
408 (define cdddr
409   (lambda (p)
410     (#%cdr (#%cdr (#%cdr p)))))
412 (define equal?
413   (lambda (x y) ;; TODO rewrite once we have cond, also add vectors, actually, we do have cond, but I don't really trust it
414     (if (#%eq? x y)
415         #t
416         (if (and (#%pair? x) (#%pair? y))
417             (and (equal? (#%car x) (#%car y))
418                  (equal? (#%cdr x) (#%cdr y)))
419             (if (and (#%u8vector? x) (#%u8vector? y))
420                 (u8vector-equal? x y)
421                 #f))))) ;; TODO could this have a problem ?
423 (define u8vector-equal?
424   (lambda (x y)
425     (let ((lx (#%u8vector-length x)))
426       (if (#%= lx (#%u8vector-length y))
427           (u8vector-equal?-loop x y lx)
428           #f))))
429 (define u8vector-equal?-loop
430   (lambda (x y l)
431     (if (#%= l 0)
432         #t
433         (and (#%= (#%u8vector-ref x l) (#%u8vector-ref y l))
434              (u8vector-equal?-loop x y (#%- l 1)))))) ;; TODO test this
436 (define assoc
437   (lambda (t l) ;; TODO rewrite once we have cond
438     (if (#%null? l)
439         #f
440         (if (equal? t (caar l))
441             (#%car l)
442             (assoc t (#%cdr l))))))
444 ;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable
445 (define vector list)
446 (define vector-ref list-ref)
447 (define vector-set! list-set!)
449 (define bitwise-ior (lambda (x y) (#%ior x y)))
450 (define bitwise-xor (lambda (x y) (#%xor x y)))
451 ;; TODO add bitwise-and ? bitwise-not ?
453 (define current-time (lambda () (#%clock)))
454 (define time->seconds (lambda (t) (#%quotient t 100))) ;; TODO no floats, is that a problem ?
456 (define else #t) ; for cond, among others
458 (define u8vector
459   (lambda x
460     (list->u8vector x)))
461 (define list->u8vector ;; TODO not used except for server
462   (lambda (x)
463     (let* ((n (length x))
464            (v (#%make-u8vector n)))
465       (list->u8vector-loop v 0 x)
466       v)))
467 (define list->u8vector-loop
468   (lambda (v n x)
469     (#%u8vector-set! v n (#%car x))
470     (if (#%not (#%null? (#%cdr x)))
471         (list->u8vector-loop v (#%+ n 1) (#%cdr x)))))
472 (define u8vector-length (lambda (x) (#%u8vector-length x)))
473 (define u8vector-ref (lambda (x y) (#%u8vector-ref x y)))
474 (define u8vector-set! (lambda (x y z) (#%u8vector-set! x y z)))
475 (define make-u8vector
476   (lambda (n x)
477     (make-u8vector-loop (#%make-u8vector n) n x)))
478 (define make-u8vector-loop
479   (lambda (v n x)
480     (#%u8vector-set! v n x)
481     (if (#%> n 0) (make-u8vector-loop v (#%- n 1) x))))