library.scm

   1 ; File: "library.scm"
   2
   3 (define number?
   4   (lambda (x)
   5     (#%number? x)))
   6
   7 (define +
   8   (lambda (x . rest)
   9     (if (#%pair? rest)
  10         (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
  11         x)))
  12
  13 (define #%+-aux
  14   (lambda (x rest)
  15     (if (#%pair? rest)
  16         (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
  17         x)))
  18
  19 (define -
  20   (lambda (x . rest)
  21     (if (#%pair? rest)
  22         (#%--aux (#%- x (#%car rest)) (#%cdr rest))
  23         (#%neg x))))
  24
  25 (define #%--aux
  26   (lambda (x rest)
  27     (if (#%pair? rest)
  28         (#%--aux (#%- x (#%car rest)) (#%cdr rest))
  29         x)))
  30
  31 (define *
  32   (lambda (x . rest)
  33     (if (#%pair? rest)
  34         (#%*-aux (#%* x (#%car rest)) (#%cdr rest))
  35         x)))
  36
  37 (define #%*-aux
  38   (lambda (x rest)
  39     (if (#%pair? rest)
  40         (#%*-aux (#%* x (#%car rest)) (#%cdr rest))
  41         x)))
  42
  43 (define quotient
  44   (lambda (x y)
  45     (#%quotient x y)))
  46
  47 (define remainder
  48   (lambda (x y)
  49     (#%remainder x y)))
  50
  51 (define =
  52   (lambda (x y)
  53     (#%= x y)))
  54
  55 (define <
  56   (lambda (x y)
  57     (#%< x y)))
  58
  59 (define <=
  60   (lambda (x y)
  61     ;; (#%<= x y) ;; ADDED not a primitive anymore
  62     (or (< x y) (= x y))))
  63
  64 (define >
  65   (lambda (x y)
  66     (#%> x y)))
  67
  68 (define >=
  69   (lambda (x y)
  70     ;; (#%>= x y) ;; ADDED, not a primitive anymore
  71     (or (> x y) (= x y))))
  72
  73 (define pair?
  74   (lambda (x)
  75     (#%pair? x)))
  76
  77 (define cons
  78   (lambda (x y)
  79     (#%cons x y)))
  80
  81 (define car
  82   (lambda (x)
  83     (#%car x)))
  84
  85 (define cdr
  86   (lambda (x)
  87     (#%cdr x)))
  88
  89 (define set-car!
  90   (lambda (x y)
  91     (#%set-car! x y)))
  92
  93 (define set-cdr!
  94   (lambda (x y)
  95     (#%set-cdr! x y)))
  96
  97 (define null?
  98   (lambda (x)
  99     (#%null? x)))
 100
 101 (define eq?
 102   (lambda (x y)
 103     (#%eq? x y)))
 104
 105 (define not
 106   (lambda (x)
 107     (#%not x)))
 108
 109 (define list
 110   (lambda lst lst))
 111
 112 (define length
 113   (lambda (lst)
 114     (#%length-aux lst 0)))
 115
 116 (define #%length-aux
 117   (lambda (lst n)
 118     (if (#%pair? lst)
 119         (#%length-aux (cdr lst) (#%+ n 1)) ;; TODO had an error and looped
 120         n)))
 121
 122 (define append
 123   (lambda (lst1 lst2)
 124     (if (#%pair? lst1)
 125         (#%cons (#%car lst1) (append (#%cdr lst1) lst2))
 126         lst2)))
 127
 128 (define reverse
 129   (lambda (lst)
 130     (reverse-aux lst '())))
 131
 132 (define reverse-aux
 133   (lambda (lst rev)
 134     (if (#%pair? lst)
 135         (reverse-aux (#%cdr lst) (#%cons (#%car lst) rev))
 136         rev)))
 137
 138 (define list-ref
 139   (lambda (lst i)
 140     (if (#%= i 0)
 141         (#%car lst)
 142         (list-ref (#%cdr lst) (#%- i 1)))))
 143
 144 (define list-set!
 145   (lambda (lst i x)
 146     (if (#%= i 0)
 147         (#%set-car! lst x)
 148         (list-set! (#%cdr lst) (#%- i 1) x))))
 149
 150 (define max
 151   (lambda (x y)
 152     (if (#%> x y) x y)))
 153
 154 (define min
 155   (lambda (x y)
 156     (if (#%< x y) x y)))
 157
 158 (define abs
 159   (lambda (x)
 160     (if (#%< x 0) (#%neg x) x)))
 161
 162 (define modulo
 163   (lambda (x y)
 164     (#%remainder x y)))
 165
 166 (define string
 167   (lambda chars
 168     (#%list->string chars)))
 169
 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 ?
 171   (lambda (str)
 172     (length (#%string->list str))))
 173
 174 (define string-append
 175   (lambda (str1 str2)
 176     (#%list->string (append (#%string->list str1) (#%string->list str2)))))
 177
 178 (define substring
 179   (lambda (str start end)
 180     (#%list->string
 181      (#%substring-aux2
 182       (#%substring-aux1 (#%string->list str) start)
 183       (#%- end start)))))
 184
 185 (define #%substring-aux1
 186   (lambda (lst n)
 187     (if (>= n 1) ;; TODO had an off-by-one
 188         (#%substring-aux1 (#%cdr lst) (#%- n 1))
 189         lst)))
 190
 191 (define #%substring-aux2
 192   (lambda (lst n)
 193     (if (>= n 1) ;; TODO had an off-by-one
 194         (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1)))
 195         '())))
 196
 197 (define map
 198   (lambda (f lst)
 199     (if (#%pair? lst)
 200         (#%cons (f (#%car lst))
 201                 (map f (#%cdr lst)))
 202         '())))
 203
 204 (define for-each
 205   (lambda (f lst)
 206     (if (#%pair? lst)
 207         (begin
 208           (f (#%car lst))
 209           (for-each f (#%cdr lst)))
 210         #f)))
 211
 212 (define call/cc
 213   (lambda (receiver)
 214     (let ((k (#%get-cont)))
 215       (receiver
 216        (lambda (r)
 217          (#%return-to-cont k r))))))
 218
 219 (define root-k #f)
 220 (define readyq #f)
 221
 222 (define start-first-process
 223   (lambda (thunk)
 224     (set! root-k (#%get-cont))
 225     (set! readyq (#%cons #f #f))
 226     (#%set-cdr! readyq readyq)
 227     (thunk)))
 228
 229 (define spawn
 230   (lambda (thunk)
 231     (let* ((k (#%get-cont))
 232            (next (#%cons k (#%cdr readyq))))
 233       (#%set-cdr! readyq next)
 234       (#%graft-to-cont root-k thunk))))
 235
 236 (define exit
 237   (lambda ()
 238     (let ((next (#%cdr readyq)))
 239       (if (#%eq? next readyq)
 240           (#%halt)
 241           (begin
 242             (#%set-cdr! readyq (#%cdr next))
 243             (#%return-to-cont (#%car next) #f))))))
 244
 245 (define yield
 246   (lambda ()
 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)))))
 253
 254 (define clock
 255   (lambda ()
 256     (#%clock)))
 257
 258 (define light
 259   (lambda ()
 260     (#%light)))
 261
 262 (define putchar
 263   (lambda (c)
 264     (#%putchar c)))
 265
 266 (define getchar
 267   (lambda ()
 268     (or (#%getchar-wait 0)
 269         (getchar))))
 270
 271 (define getchar-wait
 272   (lambda (duration)
 273     (#%getchar-wait duration)))
 274
 275 (define sleep
 276   (lambda (duration)
 277     (#%sleep-aux (#%+ (#%clock) duration))))
 278
 279 (define #%sleep-aux
 280   (lambda (wake-up)
 281     (if (#%< (#%clock) wake-up)
 282         (#%sleep-aux wake-up)
 283         #f)))
 284
 285 (define motor
 286   (lambda (x y z)
 287     (#%motor x y z)))
 288
 289 (define led
 290   (lambda (state)
 291     (if (#%eq? state 'red)
 292         (#%led 1)
 293         (if (#%eq? state 'green)
 294             (#%led 2)
 295             (#%led 0)))))
 296
 297 (define display
 298   (lambda (x)
 299     (if (#%string? x)
 300         (for-each putchar (#%string->list x))
 301         (write x))))
 302
 303 (define write
 304   (lambda (x)
 305     (if (#%string? x)
 306         (begin
 307           (#%putchar #\")
 308           (display x)
 309           (#%putchar #\"))
 310         (if (#%number? x)
 311             (display (number->string x))
 312             (if (#%pair? x)
 313                 (begin
 314                   (#%putchar #\()
 315                   (write (#%car x))
 316                   (#%write-list (#%cdr x)))
 317                 (if (#%symbol? x)
 318                     (display "#<symbol>")
 319                     (display "#<object>")))))))
 320
 321 (define #%write-list
 322   (lambda (lst)
 323     (if (#%null? lst)
 324         (#%putchar #\))
 325         (if (#%pair? lst)
 326             (begin
 327               (#%putchar #\space)
 328               (write (#%car lst))
 329               (#%write-list (#%cdr lst)))
 330             (begin
 331               (display " . ")
 332               (write lst)
 333               (#%putchar #\)))))))
 334
 335 (define number->string
 336   (lambda (n)
 337     (#%list->string
 338      (if (#%< n 0)
 339          (#%cons #\- (#%number->string-aux (#%neg n) '()))
 340          (#%number->string-aux n '())))))
 341
 342 (define #%number->string-aux
 343   (lambda (n lst)
 344     (let ((rest (#%cons (#%+ #\0 (#%remainder n 10)) lst)))
 345       (if (#%< n 10)
 346           rest
 347           (#%number->string-aux (#%quotient n 10) rest)))))
 348
 349 (define pp
 350   (lambda (x)
 351     (write x)
 352     (#%putchar #\newline)))
 353
 354 (define caar
 355   (lambda (p)
 356     (car (car p))))
 357 (define cadr
 358   (lambda (p)
 359     (car (cdr p))))
 360 (define cdar
 361   (lambda (p)
 362     (cdr (car p))))
 363 (define cddr ;; TODO implement all of them up to 4 chars ?
 364   (lambda (p)
 365     (cdr (cdr p))))
 366 (define caadr
 367   (lambda (p)
 368     (car (car (cdr p)))))
 369 (define cdadr
 370   (lambda (p)
 371     (cdr (car (cdr p)))))
 372
 373 (define equal?
 374   (lambda (x y) ;; TODO rewrite once we have cond
 375     (if (eq? x y)
 376         #t
 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 ?
 385
 386 (define assoc
 387   (lambda (t l) ;; TODO rewrite once we have cond
 388     (if (null? l)
 389         #f
 390         (if (equal? t (caar l))
 391             (car l)
 392             (assoc t (cdr l))))))
 393
 394 ;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable
 395 (define vector list)
 396 (define vector-ref list-ref)
 397 (define vector-set! list-set!)
 398
 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))
 415
 416
 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 ?
 420
 421 (define current-time (lambda () (clock)))
 422 (define time->seconds (lambda (t) (quotient t 100))) ;; TODO no floats, is that a problem ?
 423
 424 (define else #t) ; for cond, among others
 425
 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
 434   (lambda (n x)
 435     (if (= n 0)
 436         '()
 437         (r-a-cons x (make-u8vector (- n 1) x)))))
 438
 439
 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
 446
 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))))))
 450
 451 (define r-a-cons
 452   (lambda (x y)
 453     (if (and (pair? y)
 454              (pair? (cdr y))
 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)))
 459               (cddr y))
 460         ;; the first 2 trees are not of the same size, insert in front
 461         (cons (cons 1 (triplet x '() '()))
 462               y))))
 463
 464 (define r-a-length
 465   (lambda (l) (if (null? l) 0 (+ (caar l) (r-a-length (cdr l))))))
 466
 467 (define r-a-ref
 468   (lambda (r i)
 469     (if (null? r)
 470         #f ; out of bounds
 471         (let ((size (caar r)))
 472           (if (< i size)
 473               ;; what we want is in the 1st tree
 474               (r-a-tree-ref size (cdar r) i)
 475               ;; keep looking
 476               (r-a-ref (cdr r) (- i size)))))))
 477 (define r-a-tree-ref
 478   (lambda (s r i)
 479     (if (= i 0)
 480         (fst r)
 481         (let ((s2 (quotient s 2)))
 482           (if (<= i s2)
 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)))))))
 486
 487 (define r-a-set! ; unlike Okasaki, we do the change in-place
 488   (lambda (r i v)
 489     (if (null? r)
 490         #f ; out of bounds
 491         (let ((size (caar r)))
 492           (if (< i size)
 493               ;; what we want is in the 1st tree
 494               (r-a-tree-set! size (cdar r) i v)
 495               ;; keep looking
 496               (r-a-set! (cdr r) (- i size) v))))))
 497 (define r-a-tree-set!
 498   (lambda (s r i v)
 499     (if (= i 0)
 500         (set-fst! r v)
 501         (let ((s2 (quotient s 2)))
 502           (if (<= i s2)
 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))))))
 506
 507
 508 ;; ROM VECTORS
 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)
 513
 514 ;; (define u8vector-ref
 515 ;;   (lambda (u8 i)
 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
 518
 519 (define print display) ;; TODO watch out for differences between the 2