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