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                            `((memv ,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 string
 188   (lambda chars
 189     (#%list->string chars)))
 190
 191 (define string->list
 192   (lambda (str)
 193     (#%string->list str)))
 194
 195 (define list->string
 196   (lambda (chars)
 197     (#%list->string chars)))
 198
 199 (define string-length ;; TODO are all these string operations efficient ? they all convert to lists. use true vectors when we have them ?
 200   (lambda (str)
 201     (length (#%string->list str))))
 202
 203 (define string-append
 204   (lambda (str1 str2)
 205     (#%list->string (append (#%string->list str1) (#%string->list str2)))))
 206
 207 (define substring
 208   (lambda (str start end)
 209     (#%list->string
 210      (#%substring-aux2
 211       (#%substring-aux1 (#%string->list str) start)
 212       (#%- end start)))))
 213
 214 (define #%substring-aux1
 215   (lambda (lst n)
 216     (if (>= n 1)
 217         (#%substring-aux1 (#%cdr lst) (#%- n 1))
 218         lst)))
 219
 220 (define #%substring-aux2
 221   (lambda (lst n)
 222     (if (>= n 1)
 223         (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1)))
 224         '())))
 225
 226 (define map
 227   (lambda (f lst)
 228     (if (#%pair? lst)
 229         (#%cons (f (#%car lst))
 230                 (map f (#%cdr lst)))
 231         '())))
 232
 233 (define for-each
 234   (lambda (f lst)
 235     (if (#%pair? lst)
 236         (begin
 237           (f (#%car lst))
 238           (for-each f (#%cdr lst)))
 239         #f)))
 240
 241 (define call/cc
 242   (lambda (receiver)
 243     (let ((k (#%get-cont)))
 244       (receiver
 245        (lambda (r)
 246          (#%return-to-cont k r))))))
 247
 248 (define root-k #f)
 249 (define readyq #f)
 250
 251 (define start-first-process
 252   (lambda (thunk)
 253     (set! root-k (#%get-cont))
 254     (set! readyq (#%cons #f #f))
 255     (#%set-cdr! readyq readyq)
 256     (thunk)))
 257
 258 (define spawn
 259   (lambda (thunk)
 260     (let* ((k (#%get-cont))
 261            (next (#%cons k (#%cdr readyq))))
 262       (#%set-cdr! readyq next)
 263       (#%graft-to-cont root-k thunk))))
 264
 265 (define exit
 266   (lambda ()
 267     (let ((next (#%cdr readyq)))
 268       (if (#%eq? next readyq)
 269           (#%halt)
 270           (begin
 271             (#%set-cdr! readyq (#%cdr next))
 272             (#%return-to-cont (#%car next) #f))))))
 273
 274 (define yield
 275   (lambda ()
 276     (let ((k (#%get-cont)))
 277       (#%set-car! readyq k)
 278       (set! readyq (#%cdr readyq))
 279       (let ((next-k (#%car readyq)))
 280         (#%set-car! readyq #f)
 281         (#%return-to-cont next-k #f)))))
 282
 283 (define clock
 284   (lambda ()
 285     (#%clock)))
 286
 287 (define beep
 288   (lambda (freq-div duration)
 289     (#%beep freq-div duration)))
 290
 291 (define light
 292   (lambda (sensor)
 293     (#%adc sensor)))
 294
 295 (define adc
 296   (lambda (sensor)
 297     (#%adc sensor)))
 298
 299 (define sernum
 300   (lambda ()
 301     (#%sernum)))
 302
 303 (define putchar
 304   (lambda (c)
 305     (#%putchar c 3)))
 306
 307 (define getchar
 308   (lambda ()
 309     (or (#%getchar-wait 0 3)
 310         (getchar))))
 311
 312 (define getchar-wait
 313   (lambda (duration)
 314     (#%getchar-wait duration 3)))
 315
 316 (define sleep
 317   (lambda (duration)
 318     (#%sleep-aux (#%+ (#%clock) duration))))
 319
 320 (define #%sleep-aux
 321   (lambda (wake-up)
 322     (if (#%< (#%clock) wake-up)
 323         (#%sleep-aux wake-up)
 324         #f)))
 325
 326 (define motor
 327   (lambda (id power)
 328     (#%motor id power)))
 329
 330
 331 (define led
 332   (lambda (id duty period)
 333     (#%led id duty period)))
 334
 335 (define led2-color
 336   (lambda (state)
 337     (if (#%eq? state 'red)
 338         (#%led2-color 1)
 339         (#%led2-color 0))))
 340
 341 (define display
 342   (lambda (x)
 343     (if (#%string? x)
 344         (for-each putchar (#%string->list x))
 345         (write x))))
 346
 347 (define write
 348   (lambda (x)
 349     (cond ((#%string? x)
 350            (begin (#%putchar #\" 3)
 351                   (display x)
 352                   (#%putchar #\" 3)))
 353           ((#%number? x)
 354            (display (number->string x)))
 355           ((#%pair? x)
 356            (begin (#%putchar #\( 3)
 357                   (write (#%car x))
 358                   (#%write-list (#%cdr x))))
 359           ((#%symbol? x)
 360            (display "#<symbol>"))
 361           (else
 362            (display "#<object>")))))
 363 ;; TODO have vectors and co ?
 364
 365 (define #%write-list
 366   (lambda (lst)
 367     (cond ((#%null? lst)
 368            (#%putchar #\) 3))
 369           ((#%pair? lst)
 370            (begin (#%putchar #\space 3)
 371                   (write (#%car lst))
 372                   (#%write-list (#%cdr lst))))
 373           (else
 374            (begin (display " . ")
 375                   (write lst)
 376                   (#%putchar #\) 3))))))
 377
 378 (define number->string
 379   (lambda (n)
 380     (#%list->string
 381      (if (#%< n 0)
 382          (#%cons #\- (#%number->string-aux (#%neg n) '()))
 383          (#%number->string-aux n '())))))
 384
 385 (define #%number->string-aux
 386   (lambda (n lst)
 387     (let ((rest (#%cons (#%+ #\0 (#%remainder n 10)) lst)))
 388       (if (#%< n 10)
 389           rest
 390           (#%number->string-aux (#%quotient n 10) rest)))))
 391
 392 (define pp
 393   (lambda (x)
 394     (write x)
 395     (#%putchar #\newline 3)))
 396
 397 (define caar
 398   (lambda (p)
 399     (#%car (#%car p))))
 400 (define cadr
 401   (lambda (p)
 402     (#%car (#%cdr p))))
 403 (define cdar
 404   (lambda (p)
 405     (#%cdr (#%car p))))
 406 (define cddr
 407   (lambda (p)
 408     (#%cdr (#%cdr p))))
 409 (define caaar
 410   (lambda (p)
 411     (#%car (#%car (#%car p)))))
 412 (define caadr
 413   (lambda (p)
 414     (#%car (#%car (#%cdr p)))))
 415 (define cadar
 416   (lambda (p)
 417     (#%car (#%cdr (#%car p)))))
 418 (define caddr
 419   (lambda (p)
 420     (#%car (#%cdr (#%cdr p)))))
 421 (define cdaar
 422   (lambda (p)
 423     (#%cdr (#%car (#%car p)))))
 424 (define cdadr
 425   (lambda (p)
 426     (#%cdr (#%car (#%cdr p)))))
 427 (define cddar
 428   (lambda (p)
 429     (#%cdr (#%cdr (#%car p)))))
 430 (define cdddr
 431   (lambda (p)
 432     (#%cdr (#%cdr (#%cdr p)))))
 433
 434 (define equal?
 435   (lambda (x y)
 436     (cond ((#%eq? x y)
 437            #t)
 438           ((and (#%pair? x) (#%pair? y))
 439            (and (equal? (#%car x) (#%car y))
 440                 (equal? (#%cdr x) (#%cdr y))))
 441           ((and (#%u8vector? x) (#%u8vector? y))
 442            (u8vector-equal? x y))
 443           (else
 444            #f))))
 445
 446 (define u8vector-equal?
 447   (lambda (x y)
 448     (let ((lx (#%u8vector-length x)))
 449       (if (#%= lx (#%u8vector-length y))
 450           (u8vector-equal?-loop x y lx)
 451           #f))))
 452 (define u8vector-equal?-loop
 453   (lambda (x y l)
 454     (if (#%= l 0)
 455         #t
 456         (and (#%= (#%u8vector-ref x l) (#%u8vector-ref y l))
 457              (u8vector-equal?-loop x y (#%- l 1)))))) ;; TODO test this
 458
 459 (define assoc
 460   (lambda (t l)
 461     (cond ((#%null? l)
 462            #f)
 463           ((equal? t (caar l))
 464            (#%car l))
 465           (else
 466            (assoc t (#%cdr l))))))
 467
 468 ;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable
 469 (define vector list)
 470 (define vector-ref list-ref)
 471 (define vector-set! list-set!)
 472
 473 (define bitwise-ior (lambda (x y) (#%ior x y)))
 474 (define bitwise-xor (lambda (x y) (#%xor x y)))
 475 ;; TODO add bitwise-and ? bitwise-not ?
 476
 477 (define current-time (lambda () (#%clock)))
 478 (define time->seconds (lambda (t) (#%quotient t 100))) ;; TODO no floats, is that a problem ?
 479
 480 (define u8vector
 481   (lambda x
 482     (list->u8vector x)))
 483 (define list->u8vector ;; TODO not used except for server
 484   (lambda (x)
 485     (let* ((n (length x))
 486            (v (#%make-u8vector n 0)))
 487       (list->u8vector-loop v 0 x)
 488       v)))
 489 (define list->u8vector-loop
 490   (lambda (v n x)
 491     (#%u8vector-set! v n (#%car x))
 492     (if (#%not (#%null? (#%cdr x)))
 493         (list->u8vector-loop v (#%+ n 1) (#%cdr x)))))
 494 (define u8vector-length (lambda (x) (#%u8vector-length x)))
 495 (define u8vector-ref (lambda (x y) (#%u8vector-ref x y)))
 496 (define u8vector-set! (lambda (x y z) (#%u8vector-set! x y z)))
 497 ;; (define make-u8vector
 498 ;;   (lambda (n x)
 499 ;;     (let ((v (#%make-u8vector n)))
 500 ;;       (make-u8vector-loop v (#%- n 1) x)
 501 ;;       v)))
 502 (define make-u8vector
 503   (lambda (n x)
 504     (#%make-u8vector n x)))
 505 ;; (define make-u8vector-loop
 506 ;;   (lambda (v n x)
 507 ;; ;;;     (display "ok:")
 508 ;; ;;;     (display n)
 509 ;; ;;;     (display "\n")
 510 ;;     (if (>= n 0) (#%u8vector-set! v n x)) ;; TODO safety, should not be needed
 511 ;;     (if (#%> n 0)
 512 ;;      (begin ;; (display "loop\n")
 513 ;;             (make-u8vector-loop v (#%- n 1) x)))))
 514 ;; ;; TODO with named lets ?