library.scm

   1 ; File: "library.scm"
   2
   3 (define-macro (cond . a)
   4   (if (null? a) '(if #f #f)
   5       (cond ((eq? (caar a) 'else) `(begin . ,(cdar a)))
   6             ((and (not (null? (cdar a))) (eq? (cadar a) '=>))
   7              (let ((x (gensym)))
   8                `(let ((,x ,(caar a)))
   9                   (if ,x (,(caddar a) ,x) (cond . ,(cdr a))))))
  10             (else `(if ,(caar a) (begin . ,(cdar a)) (cond . ,(cdr a)))))))
  11
  12 (define-macro (case a . cs)
  13   (let ((x (gensym)))
  14     `(let ((,x ,a))
  15        (cond . ,(map (lambda (c)
  16                        (if (eq? (car c) 'else) c
  17                            `((memq ,x ',(car c)) . ,(cdr c))))
  18                      cs)))))
  19
  20 (define number?
  21   (lambda (x)
  22     (#%number? x)))
  23
  24 (define +
  25   (lambda (x . rest)
  26     (if (#%pair? rest)
  27         (#%+-aux x rest)
  28         x)))
  29
  30 (define #%+-aux
  31   (lambda (x rest)
  32     (if (#%pair? rest)
  33         (#%+-aux (#%+ x (#%car rest)) (#%cdr rest))
  34         x)))
  35
  36 (define neg
  37   (lambda (x)
  38     (- 0 x)))
  39
  40 (define -
  41   (lambda (x . rest)
  42     (if (#%pair? rest)
  43         (#%--aux x rest)
  44         (neg x))))
  45
  46 (define #%--aux
  47   (lambda (x rest)
  48     (if (#%pair? rest)
  49         (#%--aux (#%- x (#%car rest)) (#%cdr rest))
  50         x)))
  51
  52 (define *
  53   (lambda (x . rest)
  54     (if (#%pair? rest)
  55         (#%*-aux x rest)
  56         x)))
  57
  58 (define #%*-aux
  59   (lambda (x rest)
  60     (if (#%pair? rest)
  61         (#%*-aux (#%mul x (#%car rest)) (#%cdr rest))
  62         x)))
  63
  64 (define #%mul
  65   (lambda (x y)
  66     (let* ((x-neg? (< x 0))
  67            (y-neg? (< y 0))
  68            (x      (if x-neg? (neg x) x))
  69            (y      (if y-neg? (neg y) y)))
  70       (let ((prod   (#%mul-non-neg x y)))
  71         (cond ((and x-neg? y-neg?)
  72                prod)
  73               ((or x-neg? y-neg?)
  74                (neg prod))
  75               (else
  76                prod))))))
  77
  78 (define / quotient)
  79
  80 (define quotient ;; TODO similar to #%mul, abstract ?
  81   (lambda (x y)
  82     (let* ((x-neg? (< x 0))
  83            (y-neg? (< y 0))
  84            (x      (if x-neg? (neg x) x))
  85            (y      (if y-neg? (neg y) y)))
  86       (let ((quot   (#%quotient x y)))
  87         (cond ((and x-neg? y-neg?)
  88                quot)
  89               ((or x-neg? y-neg?)
  90                (neg quot))
  91               (else
  92                quot))))))
  93
  94 (define remainder
  95   (lambda (x y)
  96     (#%remainder x y)))
  97
  98 (define =
  99   (lambda (x y)
 100     (#%= x y)))
 101
 102 (define <
 103   (lambda (x y)
 104     (#%< x y)))
 105
 106 (define <=
 107   (lambda (x y)
 108     (or (< x y) (= x y))))
 109
 110 (define >
 111   (lambda (x y)
 112     (#%> x y)))
 113
 114 (define >=
 115   (lambda (x y)
 116     (or (> x y) (= x y))))
 117
 118 (define pair?
 119   (lambda (x)
 120     (#%pair? x)))
 121
 122 (define cons
 123   (lambda (x y)
 124     (#%cons x y)))
 125
 126 (define car
 127   (lambda (x)
 128     (#%car x)))
 129
 130 (define cdr
 131   (lambda (x)
 132     (#%cdr x)))
 133
 134 (define set-car!
 135   (lambda (x y)
 136     (#%set-car! x y)))
 137
 138 (define set-cdr!
 139   (lambda (x y)
 140     (#%set-cdr! x y)))
 141
 142 (define null?
 143   (lambda (x)
 144     (#%null? x)))
 145
 146 (define eq?
 147   (lambda (x y)
 148     (#%eq? x y)))
 149
 150 (define not
 151   (lambda (x)
 152     (#%not x)))
 153
 154 (define list
 155   (lambda lst lst))
 156
 157 (define length
 158   (lambda (lst)
 159     (#%length-aux lst 0)))
 160
 161 (define #%length-aux
 162   (lambda (lst n)
 163     (if (#%pair? lst)
 164         (#%length-aux (cdr lst) (#%+ n 1))
 165         n)))
 166
 167 (define append
 168   (lambda (lst1 lst2)
 169     (if (#%pair? lst1)
 170         (#%cons (#%car lst1) (append (#%cdr lst1) lst2))
 171         lst2)))
 172
 173 (define reverse
 174   (lambda (lst)
 175     (reverse-aux lst '())))
 176
 177 (define reverse-aux
 178   (lambda (lst rev)
 179     (if (#%pair? lst)
 180         (reverse-aux (#%cdr lst) (#%cons (#%car lst) rev))
 181         rev)))
 182
 183 (define list-ref
 184   (lambda (lst i)
 185     (if (#%= i 0)
 186         (#%car lst)
 187         (list-ref (#%cdr lst) (#%- i 1)))))
 188
 189 (define list-set!
 190   (lambda (lst i x)
 191     (if (#%= i 0)
 192         (#%set-car! lst x)
 193         (list-set! (#%cdr lst) (#%- i 1) x))))
 194
 195 (define max
 196   (lambda (x y)
 197     (if (#%> x y) x y)))
 198
 199 (define min
 200   (lambda (x y)
 201     (if (#%< x y) x y)))
 202
 203 (define abs
 204   (lambda (x)
 205     (if (#%< x 0) (neg x) x)))
 206
 207 (define modulo
 208   (lambda (x y)
 209     (#%remainder x y)))
 210
 211 (define #%box (lambda (a) (#%cons a '())))
 212
 213 (define #%unbox (lambda (a) (#%car a)))
 214
 215 (define #%box-set! (lambda (a b) (#%set-car! a b)))
 216
 217 (define symbol?
 218   (lambda (x)
 219     (#%symbol? x)))
 220
 221 (define string?
 222   (lambda (x)
 223     (#%string? x)))
 224
 225 (define string
 226   (lambda chars
 227     (#%list->string chars)))
 228
 229 (define string->list
 230   (lambda (str)
 231     (#%string->list str)))
 232
 233 (define list->string
 234   (lambda (chars)
 235     (#%list->string chars)))
 236
 237 (define string-length
 238   (lambda (str)
 239     (length (#%string->list str))))
 240
 241 (define string-append
 242   (lambda (str1 str2)
 243     (#%list->string (append (#%string->list str1) (#%string->list str2)))))
 244
 245 (define substring
 246   (lambda (str start end)
 247     (#%list->string
 248      (#%substring-aux2
 249       (#%substring-aux1 (#%string->list str) start)
 250       (#%- end start)))))
 251
 252 (define #%substring-aux1
 253   (lambda (lst n)
 254     (if (>= n 1)
 255         (#%substring-aux1 (#%cdr lst) (#%- n 1))
 256         lst)))
 257
 258 (define #%substring-aux2
 259   (lambda (lst n)
 260     (if (>= n 1)
 261         (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1)))
 262         '())))
 263
 264 (define boolean?
 265   (lambda (x)
 266     (#%boolean? x)))
 267
 268 (define map
 269   (lambda (f lst)
 270     (if (#%pair? lst)
 271         (#%cons (f (#%car lst))
 272                 (map f (#%cdr lst)))
 273         '())))
 274
 275 (define for-each
 276   (lambda (f lst)
 277     (if (#%pair? lst)
 278         (begin
 279           (f (#%car lst))
 280           (for-each f (#%cdr lst)))
 281         #f)))
 282
 283 (define call/cc
 284   (lambda (receiver)
 285     (let ((k (#%get-cont)))
 286       (receiver
 287        (lambda (r)
 288          (#%return-to-cont k r))))))
 289
 290 (define root-k #f)
 291 (define readyq #f)
 292
 293 (define start-first-process
 294   (lambda (thunk)
 295     (set! root-k (#%get-cont))
 296     (set! readyq (#%cons #f #f))
 297     (#%set-cdr! readyq readyq)
 298     (thunk)))
 299
 300 (define spawn
 301   (lambda (thunk)
 302     (let* ((k (#%get-cont))
 303            (next (#%cons k (#%cdr readyq))))
 304       (#%set-cdr! readyq next)
 305       (#%graft-to-cont root-k thunk))))
 306
 307 (define exit
 308   (lambda ()
 309     (let ((next (#%cdr readyq)))
 310       (if (#%eq? next readyq)
 311           (#%halt)
 312           (begin
 313             (#%set-cdr! readyq (#%cdr next))
 314             (#%return-to-cont (#%car next) #f))))))
 315
 316 (define yield
 317   (lambda ()
 318     (let ((k (#%get-cont)))
 319       (#%set-car! readyq k)
 320       (set! readyq (#%cdr readyq))
 321       (let ((next-k (#%car readyq)))
 322         (#%set-car! readyq #f)
 323         (#%return-to-cont next-k #f)))))
 324
 325 (define clock
 326   (lambda ()
 327     (#%clock)))
 328
 329 (define beep
 330   (lambda (freq-div duration)
 331     (#%beep freq-div duration)))
 332
 333 (define light
 334   (lambda (sensor)
 335     (#%adc sensor)))
 336
 337 (define adc
 338   (lambda (sensor)
 339     (#%adc sensor)))
 340
 341 (define sernum
 342   (lambda ()
 343     (#%sernum)))
 344
 345 (define putchar
 346   (lambda (c)
 347     (#%putchar c 3)))
 348
 349 (define getchar
 350   (lambda ()
 351     (or (#%getchar-wait 0 3)
 352         (getchar))))
 353
 354 (define getchar-wait
 355   (lambda (duration)
 356     (#%getchar-wait duration 3)))
 357
 358 (define sleep
 359   (lambda (duration)
 360     (#%sleep-aux (#%+ (#%clock) duration))))
 361
 362 (define #%sleep-aux
 363   (lambda (wake-up)
 364     (if (#%< (#%clock) wake-up)
 365         (#%sleep-aux wake-up)
 366         #f)))
 367
 368 (define motor
 369   (lambda (id power)
 370     (#%motor id power)))
 371
 372
 373 (define led
 374   (lambda (id duty period)
 375     (#%led id duty period)))
 376
 377 (define led2-color
 378   (lambda (state)
 379     (if (#%eq? state 'red)
 380         (#%led2-color 1)
 381         (#%led2-color 0))))
 382
 383 (define display
 384   (lambda (x)
 385     (if (#%string? x)
 386         (for-each putchar (#%string->list x))
 387         (write x))))
 388
 389 (define write
 390   (lambda (x)
 391     (cond ((#%string? x)
 392            (begin (#%putchar #\" 3)
 393                   (display x)
 394                   (#%putchar #\" 3)))
 395           ((#%number? x)
 396            (display (number->string x)))
 397           ((#%pair? x)
 398            (begin (#%putchar #\( 3)
 399                   (write (#%car x))
 400                   (#%write-list (#%cdr x))))
 401           ((#%symbol? x)
 402            (display "#<symbol>"))
 403           ((#%boolean? x)
 404            (display (if x "#t" "#f")))
 405           (else
 406            (display "#<object>")))))
 407 ;; TODO have vectors and co ?
 408
 409 (define #%write-list
 410   (lambda (lst)
 411     (cond ((#%null? lst)
 412            (#%putchar #\) 3))
 413           ((#%pair? lst)
 414            (begin (#%putchar #\space 3)
 415                   (write (#%car lst))
 416                   (#%write-list (#%cdr lst))))
 417           (else
 418            (begin (display " . ")
 419                   (write lst)
 420                   (#%putchar #\) 3))))))
 421
 422 (define number->string
 423   (lambda (n)
 424     (#%list->string
 425      (if (#%< n 0)
 426          (#%cons #\- (#%number->string-aux (neg n) '()))
 427          (#%number->string-aux n '())))))
 428
 429 (define #%number->string-aux
 430   (lambda (n lst)
 431     (let ((rest (#%cons (#%+ #\0 (remainder n 10)) lst)))
 432       (if (#%< n 10)
 433           rest
 434           (#%number->string-aux (quotient n 10) rest)))))
 435
 436 (define pp
 437   (lambda (x)
 438     (write x)
 439     (#%putchar #\newline 3)))
 440
 441 (define caar
 442   (lambda (p)
 443     (#%car (#%car p))))
 444 (define cadr
 445   (lambda (p)
 446     (#%car (#%cdr p))))
 447 (define cdar
 448   (lambda (p)
 449     (#%cdr (#%car p))))
 450 (define cddr
 451   (lambda (p)
 452     (#%cdr (#%cdr p))))
 453 (define caaar
 454   (lambda (p)
 455     (#%car (#%car (#%car p)))))
 456 (define caadr
 457   (lambda (p)
 458     (#%car (#%car (#%cdr p)))))
 459 (define cadar
 460   (lambda (p)
 461     (#%car (#%cdr (#%car p)))))
 462 (define caddr
 463   (lambda (p)
 464     (#%car (#%cdr (#%cdr p)))))
 465 (define cdaar
 466   (lambda (p)
 467     (#%cdr (#%car (#%car p)))))
 468 (define cdadr
 469   (lambda (p)
 470     (#%cdr (#%car (#%cdr p)))))
 471 (define cddar
 472   (lambda (p)
 473     (#%cdr (#%cdr (#%car p)))))
 474 (define cdddr
 475   (lambda (p)
 476     (#%cdr (#%cdr (#%cdr p)))))
 477
 478 (define equal?
 479   (lambda (x y)
 480     (cond ((#%eq? x y)
 481            #t)
 482           ((and (#%pair? x) (#%pair? y))
 483            (and (equal? (#%car x) (#%car y))
 484                 (equal? (#%cdr x) (#%cdr y))))
 485           ((and (#%u8vector? x) (#%u8vector? y))
 486            (u8vector-equal? x y))
 487           (else
 488            #f))))
 489
 490 (define u8vector-equal?
 491   (lambda (x y)
 492     (let ((lx (#%u8vector-length x)))
 493       (if (#%= lx (#%u8vector-length y))
 494           (u8vector-equal?-loop x y (- lx 1))
 495           #f))))
 496 (define u8vector-equal?-loop
 497   (lambda (x y l)
 498     (if (#%= l 0)
 499         #t
 500         (and (#%= (#%u8vector-ref x l) (#%u8vector-ref y l))
 501              (u8vector-equal?-loop x y (#%- l 1))))))
 502
 503 (define assoc
 504   (lambda (t l)
 505     (cond ((#%null? l)
 506            #f)
 507           ((equal? t (caar l))
 508            (#%car l))
 509           (else
 510            (assoc t (#%cdr l))))))
 511
 512 (define memq
 513   (lambda (t l)
 514     (cond ((#%null? l)
 515            #f)
 516           ((#%eq? (#%car l) t)
 517            l)
 518           (else
 519            (memq t (#%cdr l))))))
 520
 521 (define vector list)
 522 (define vector-ref list-ref)
 523 (define vector-set! list-set!)
 524
 525 (define bitwise-ior (lambda (x y) (#%ior x y)))
 526 (define bitwise-xor (lambda (x y) (#%xor x y)))
 527 ;; TODO add bitwise-and ? bitwise-not ?
 528
 529 (define current-time (lambda () (#%clock)))
 530 (define time->seconds (lambda (t) (quotient t 100)))
 531
 532 (define u8vector
 533   (lambda x
 534     (list->u8vector x)))
 535 (define list->u8vector
 536   (lambda (x)
 537     (let* ((n (length x))
 538            (v (#%make-u8vector n)))
 539       (list->u8vector-loop v 0 x)
 540       v)))
 541 (define list->u8vector-loop
 542   (lambda (v n x)
 543     (#%u8vector-set! v n (#%car x))
 544     (if (#%not (#%null? (#%cdr x)))
 545         (list->u8vector-loop v (#%+ n 1) (#%cdr x)))))
 546 (define u8vector-length (lambda (x) (#%u8vector-length x)))
 547 (define u8vector-ref (lambda (x y) (#%u8vector-ref x y)))
 548 (define u8vector-set! (lambda (x y z) (#%u8vector-set! x y z)))
 549 (define make-u8vector
 550   (lambda (n x)
 551     (make-u8vector-loop (#%make-u8vector n) (- n 1) x)))
 552 (define make-u8vector-loop
 553   (lambda (v n x)
 554     (if (>= n 0)
 555         (begin (u8vector-set! v n x)
 556                (make-u8vector-loop v (- n 1) x))
 557         v)))
 558 (define u8vector-copy!
 559   (lambda (source source-start target target-start n)
 560     (if (> n 0)
 561         (begin (u8vector-set! target target-start
 562                               (u8vector-ref source source-start))
 563                (u8vector-copy! source (+ source-start 1)
 564                                target (+ target-start 1)
 565                                (- n 1))))))
 566
 567 (define network-init (lambda () (#%network-init)))
 568 (define network-cleanup (lambda () (#%network-cleanup)))
 569 (define receive-packet-to-u8vector
 570   (lambda (x)
 571     (#%receive-packet-to-u8vector x)))
 572 (define send-packet-from-u8vector
 573   (lambda (x y)
 574     (#%send-packet-from-u8vector x y)))