10 (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
16 (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
22 (#%--aux (#%- x (#%car rest)) (#%cdr rest))
28 (#%--aux (#%- x (#%car rest)) (#%cdr rest))
34 (#%*-aux (#%* x (#%car rest)) (#%cdr rest))
40 (#%*-aux (#%* x (#%car rest)) (#%cdr rest))
61 ;; (#%<= x y) ;; ADDED not a primitive anymore
62 (or (< x y) (= x y))))
70 ;; (#%>= x y) ;; ADDED, not a primitive anymore
71 (or (> x y) (= x y))))
114 (#%length-aux lst 0)))
119 (#%length-aux (cdr lst) (#%+ n 1)) ;; TODO had an error and looped
125 (#%cons (#%car lst1) (append (#%cdr lst1) lst2))
130 (reverse-aux lst '())))
135 (reverse-aux (#%cdr lst) (#%cons (#%car lst) rev))
142 (list-ref (#%cdr lst) (#%- i 1)))))
148 (list-set! (#%cdr lst) (#%- i 1) x))))
160 (if (#%< x 0) (#%neg x) x)))
168 (#%list->string chars)))
170 (define string-length ;; TODO are all these string operations efficient ? they all convert to lists. Since we have the equivalent of a vector, isn't there a way to do better ?
172 (length (#%string->list str))))
174 (define string-append
176 (#%list->string (append (#%string->list str1) (#%string->list str2)))))
179 (lambda (str start end)
182 (#%substring-aux1 (#%string->list str) start)
185 (define #%substring-aux1
187 (if (>= n 1) ;; TODO had an off-by-one
188 (#%substring-aux1 (#%cdr lst) (#%- n 1))
191 (define #%substring-aux2
193 (if (>= n 1) ;; TODO had an off-by-one
194 (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1)))
200 (#%cons (f (#%car lst))
209 (for-each f (#%cdr lst)))
214 (let ((k (#%get-cont)))
217 (#%return-to-cont k r))))))
222 (define start-first-process
224 (set! root-k (#%get-cont))
225 (set! readyq (#%cons #f #f))
226 (#%set-cdr! readyq readyq)
231 (let* ((k (#%get-cont))
232 (next (#%cons k (#%cdr readyq))))
233 (#%set-cdr! readyq next)
234 (#%graft-to-cont root-k thunk))))
238 (let ((next (#%cdr readyq)))
239 (if (#%eq? next readyq)
242 (#%set-cdr! readyq (#%cdr next))
243 (#%return-to-cont (#%car next) #f))))))
247 (let ((k (#%get-cont)))
248 (#%set-car! readyq k)
249 (set! readyq (#%cdr readyq))
250 (let ((next-k (#%car readyq)))
251 (#%set-car! readyq #f)
252 (#%return-to-cont next-k #f)))))
268 (or (#%getchar-wait 0)
273 (#%getchar-wait duration)))
277 (#%sleep-aux (#%+ (#%clock) duration))))
281 (if (#%< (#%clock) wake-up)
282 (#%sleep-aux wake-up)
291 (if (#%eq? state 'red)
293 (if (#%eq? state 'green)
300 (for-each putchar (#%string->list x))
311 (display (number->string x))
316 (#%write-list (#%cdr x)))
318 (display "#<symbol>")
319 (display "#<object>")))))))
329 (#%write-list (#%cdr lst)))
335 (define number->string
339 (#%cons #\- (#%number->string-aux (#%neg n) '()))
340 (#%number->string-aux n '())))))
342 (define #%number->string-aux
344 (let ((rest (#%cons (#%+ #\0 (#%remainder n 10)) lst)))
347 (#%number->string-aux (#%quotient n 10) rest)))))
352 (#%putchar #\newline)))
363 (define cddr ;; TODO implement all of them up to 4 chars ?
368 (car (car (cdr p)))))
371 (cdr (car (cdr p)))))
374 (lambda (x y) ;; TODO rewrite once we have cond
377 (if (and (pair? x) (pair? y))
378 (and (equal? (car x) (car y))
379 (equal? (cdr x) (cdr y)))
380 (if (and (triplet? x) (triplet? y))
381 (and (equal? (fst x) (fst y))
382 (equal? (snd x) (snd y))
383 (equal? (trd x) (trd y)))
384 #f))))) ;; TODO could this have a problem ?
387 (lambda (t l) ;; TODO rewrite once we have cond
390 (if (equal? t (caar l))
392 (assoc t (cdr l))))))
394 ;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable
396 (define vector-ref list-ref)
397 (define vector-set! list-set!)
399 (define triplet? (lambda (t) (#%triplet? t)))
400 (define triplet (lambda (x y z) (#%triplet x y z)))
401 (define fst (lambda (t) (#%fst t)))
402 (define snd (lambda (t) (#%snd t)))
403 (define trd (lambda (t) (#%trd t)))
404 (define set-fst! (lambda (t v) (#%set-fst! t v)))
405 (define set-snd! (lambda (t v) (#%set-snd! t v)))
406 (define set-trd! (lambda (t v) (#%set-trd! t v)))
407 ;; TODO for tests on gambit
408 ;; (define (triplet x y z) (vector x y z))
409 ;; (define (fst t) (vector-ref t 0))
410 ;; (define (snd t) (vector-ref t 1))
411 ;; (define (trd t) (vector-ref t 2))
412 ;; (define (set-fst! t v) (vector-set! t 0 v))
413 ;; (define (set-snd! t v) (vector-set! t 1 v))
414 ;; (define (set-trd! t v) (vector-set! t 2 v))
417 (define bitwise-ior (lambda (x y) (#%ior x y)))
418 (define bitwise-xor (lambda (x y) (#%xor x y)))
419 ;; TODO add bitwise-and ? bitwise-not ?
421 (define current-time (lambda () (clock)))
422 (define time->seconds (lambda (t) (quotient t 100))) ;; TODO no floats, is that a problem ?
424 (define else #t) ; for cond, among others
426 ;; vectors are implemented using r-a-lists
427 ;; TODO takes only marginally more code space than lists made from triplets, maybe 150 bytes more in the stack (the total is in the order of 10.5k)
428 (define u8vector (lambda x (list->u8vector x)))
429 (define list->u8vector (lambda (x) (list->r-a-list x)))
430 (define u8vector-length (lambda (x) (r-a-length x)))
431 (define u8vector-ref (lambda (x y) (r-a-ref x y)))
432 (define u8vector-set! (lambda (x y z) (r-a-set! x y z)))
433 (define make-u8vector
437 (r-a-cons x (make-u8vector (- n 1) x)))))
440 ;; implementation of Chris Okasaki's random access lists
441 ;; basically, we have a list (made from pairs) of pairs of complete binary
442 ;; trees (made from triplets) and their number of elements (length first)
443 ;; the trees are represented : (root left right)
444 ;; however, unlike Okasaki, our lists are not purely functional, since we do
445 ;; the changes in-place
447 (define r-a-list (lambda x (list->r-a-list x)))
448 (define list->r-a-list
449 (lambda (l) (if (null? l) '() (r-a-cons (car l) (list->r-a-list (cdr l))))))
455 (= (caar y) (caadr y)))
456 ;; the first 2 trees are of the same size, merge them
457 (cons (cons (+ 1 (caar y) (caadr y))
458 (triplet x (cdar y) (cdadr y)))
460 ;; the first 2 trees are not of the same size, insert in front
461 (cons (cons 1 (triplet x '() '()))
465 (lambda (l) (if (null? l) 0 (+ (caar l) (r-a-length (cdr l))))))
471 (let ((size (caar r)))
473 ;; what we want is in the 1st tree
474 (r-a-tree-ref size (cdar r) i)
476 (r-a-ref (cdr r) (- i size)))))))
481 (let ((s2 (quotient s 2)))
483 ;; these 2 will break if the tree is malformed
484 (r-a-tree-ref s2 (snd r) (- i 1))
485 (r-a-tree-ref s2 (trd r) (- i 1 s2)))))))
487 (define r-a-set! ; unlike Okasaki, we do the change in-place
491 (let ((size (caar r)))
493 ;; what we want is in the 1st tree
494 (r-a-tree-set! size (cdar r) i v)
496 (r-a-set! (cdr r) (- i size) v))))))
497 (define r-a-tree-set!
501 (let ((s2 (quotient s 2)))
503 ;; these 2 will break if the tree is malformed
504 (r-a-tree-set! s2 (snd r) (- i 1) v)
505 (r-a-tree-set! s2 (trd r) (- i 1 s2) v))))))
509 ;; (define u8vector ;; TODO use chris okasaki's random access lists for mutable vectors, and in-rom vectors (strings) for the rest, these functions are for the in-rom vectors
510 ;; (lambda (first . rest) ;; TODO can't we have all in the same arg ?
511 ;; (list->u8vector (cons first rest))))
512 ;; ;; TODO maybe still use the parser hack for the in-rom vectors, since they are known at compile time (but some might have variables inside instead of only numbers, would not work then)
514 ;; (define u8vector-ref
516 ;; (#%car (#%substring-aux1 (#%string->list u8) i))))
517 ;; ;; TODO yuck, this is O(n), do better, since we have contiguous memory for in-rom vectors, but not that important since these rom vectors are all small
519 (define print display) ;; TODO watch out for differences between the 2