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     (or (#%< x y) (#%= x y))))
  62
  63 (define >
  64   (lambda (x y)
  65     (#%> x y)))
  66
  67 (define >=
  68   (lambda (x y)
  69     (or (#%> x y) (#%= x y))))
  70
  71 (define pair?
  72   (lambda (x)
  73     (#%pair? x)))
  74
  75 (define cons
  76   (lambda (x y)
  77     (#%cons x y)))
  78
  79 (define car
  80   (lambda (x)
  81     (#%car x)))
  82
  83 (define cdr
  84   (lambda (x)
  85     (#%cdr x)))
  86
  87 (define set-car!
  88   (lambda (x y)
  89     (#%set-car! x y)))
  90
  91 (define set-cdr!
  92   (lambda (x y)
  93     (#%set-cdr! x y)))
  94
  95 (define null?
  96   (lambda (x)
  97     (#%null? x)))
  98
  99 (define eq?
 100   (lambda (x y)
 101     (#%eq? x y)))
 102
 103 (define not
 104   (lambda (x)
 105     (#%not x)))
 106
 107 (define list
 108   (lambda lst lst))
 109
 110 (define length
 111   (lambda (lst)
 112     (#%length-aux lst 0)))
 113
 114 (define #%length-aux
 115   (lambda (lst n)
 116     (if (#%pair? lst)
 117         (#%length-aux (cdr lst) (#%+ n 1))
 118         n)))
 119
 120 (define append
 121   (lambda (lst1 lst2)
 122     (if (#%pair? lst1)
 123         (#%cons (#%car lst1) (append (#%cdr lst1) lst2))
 124         lst2)))
 125
 126 (define reverse
 127   (lambda (lst)
 128     (reverse-aux lst '())))
 129
 130 (define reverse-aux
 131   (lambda (lst rev)
 132     (if (#%pair? lst)
 133         (reverse-aux (#%cdr lst) (#%cons (#%car lst) rev))
 134         rev)))
 135
 136 (define list-ref
 137   (lambda (lst i)
 138     (if (#%= i 0)
 139         (#%car lst)
 140         (list-ref (#%cdr lst) (#%- i 1)))))
 141
 142 (define list-set!
 143   (lambda (lst i x)
 144     (if (#%= i 0)
 145         (#%set-car! lst x)
 146         (list-set! (#%cdr lst) (#%- i 1) x))))
 147
 148 (define max
 149   (lambda (x y)
 150     (if (#%> x y) x y)))
 151
 152 (define min
 153   (lambda (x y)
 154     (if (#%< x y) x y)))
 155
 156 (define abs
 157   (lambda (x)
 158     (if (#%< x 0) (#%neg x) x)))
 159
 160 (define modulo
 161   (lambda (x y)
 162     (#%remainder x y)))
 163
 164 (define string
 165   (lambda chars
 166     (#%list->string chars)))
 167
 168 (define string->list
 169   (lambda (str)
 170     (#%string->list str)))
 171
 172 (define list->string
 173   (lambda (chars)
 174     (#%list->string chars)))
 175
 176 (define string-length ;; TODO are all these string operations efficient ? they all convert to lists. use true vectors when we have them ?
 177   (lambda (str)
 178     (length (#%string->list str))))
 179
 180 (define string-append
 181   (lambda (str1 str2)
 182     (#%list->string (append (#%string->list str1) (#%string->list str2)))))
 183
 184 (define substring
 185   (lambda (str start end)
 186     (#%list->string
 187      (#%substring-aux2
 188       (#%substring-aux1 (#%string->list str) start)
 189       (#%- end start)))))
 190
 191 (define #%substring-aux1
 192   (lambda (lst n)
 193     (if (>= n 1) ;; TODO had an off-by-one
 194         (#%substring-aux1 (#%cdr lst) (#%- n 1))
 195         lst)))
 196
 197 (define #%substring-aux2
 198   (lambda (lst n)
 199     (if (>= n 1)
 200         (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1)))
 201         '())))
 202
 203 (define map
 204   (lambda (f lst)
 205     (if (#%pair? lst)
 206         (#%cons (f (#%car lst))
 207                 (map f (#%cdr lst)))
 208         '())))
 209
 210 (define for-each
 211   (lambda (f lst)
 212     (if (#%pair? lst)
 213         (begin
 214           (f (#%car lst))
 215           (for-each f (#%cdr lst)))
 216         #f)))
 217
 218 (define call/cc
 219   (lambda (receiver)
 220     (let ((k (#%get-cont)))
 221       (receiver
 222        (lambda (r)
 223          (#%return-to-cont k r))))))
 224
 225 (define root-k #f)
 226 (define readyq #f)
 227
 228 (define start-first-process
 229   (lambda (thunk)
 230     (set! root-k (#%get-cont))
 231     (set! readyq (#%cons #f #f))
 232     (#%set-cdr! readyq readyq)
 233     (thunk)))
 234
 235 (define spawn
 236   (lambda (thunk)
 237     (let* ((k (#%get-cont))
 238            (next (#%cons k (#%cdr readyq))))
 239       (#%set-cdr! readyq next)
 240       (#%graft-to-cont root-k thunk))))
 241
 242 (define exit
 243   (lambda ()
 244     (let ((next (#%cdr readyq)))
 245       (if (#%eq? next readyq)
 246           (#%halt)
 247           (begin
 248             (#%set-cdr! readyq (#%cdr next))
 249             (#%return-to-cont (#%car next) #f))))))
 250
 251 (define yield
 252   (lambda ()
 253     (let ((k (#%get-cont)))
 254       (#%set-car! readyq k)
 255       (set! readyq (#%cdr readyq))
 256       (let ((next-k (#%car readyq)))
 257         (#%set-car! readyq #f)
 258         (#%return-to-cont next-k #f)))))
 259
 260 (define clock
 261   (lambda ()
 262     (#%clock)))
 263
 264 (define beep
 265   (lambda (freq-div duration)
 266     (#%beep freq-div duration)))
 267
 268 (define light
 269   (lambda (sensor)
 270     (#%adc sensor)))
 271
 272 (define adc
 273   (lambda (sensor)
 274     (#%adc sensor)))
 275
 276 (define sernum
 277   (lambda ()
 278     (#%sernum)))
 279
 280 (define putchar
 281   (lambda (c)
 282     (#%putchar c 3)))
 283
 284 (define getchar
 285   (lambda ()
 286     (or (#%getchar-wait 0 3)
 287         (getchar))))
 288
 289 (define getchar-wait
 290   (lambda (duration)
 291     (#%getchar-wait duration 3)))
 292
 293 (define sleep
 294   (lambda (duration)
 295     (#%sleep-aux (#%+ (#%clock) duration))))
 296
 297 (define #%sleep-aux
 298   (lambda (wake-up)
 299     (if (#%< (#%clock) wake-up)
 300         (#%sleep-aux wake-up)
 301         #f)))
 302
 303 (define motor
 304   (lambda (id power)
 305     (#%motor id power)))
 306
 307
 308 (define led
 309   (lambda (id duty period)
 310     (#%led id duty period)))
 311
 312 (define led2-color
 313   (lambda (state)
 314     (if (#%eq? state 'red)
 315         (#%led2-color 1)
 316         (#%led2-color 0))))
 317
 318 (define display
 319   (lambda (x)
 320     (if (#%string? x)
 321         (for-each putchar (#%string->list x))
 322         (write x))))
 323
 324 (define write
 325   (lambda (x)
 326     (if (#%string? x)
 327         (begin
 328           (#%putchar #\" 3)
 329           (display x)
 330           (#%putchar #\" 3))
 331         (if (#%number? x)
 332             (display (number->string x))
 333             (if (#%pair? x)
 334                 (begin
 335                   (#%putchar #\( 3)
 336                   (write (#%car x))
 337                   (#%write-list (#%cdr x)))
 338                 (if (#%symbol? x)
 339                     (display "#<symbol>")
 340                     (display "#<object>")))))))
 341
 342 (define #%write-list
 343   (lambda (lst)
 344     (if (#%null? lst)
 345         (#%putchar #\) 3)
 346         (if (#%pair? lst)
 347             (begin
 348               (#%putchar #\space 3)
 349               (write (#%car lst))
 350               (#%write-list (#%cdr lst)))
 351             (begin
 352               (display " . ")
 353               (write lst)
 354               (#%putchar #\) 3))))))
 355
 356 (define number->string
 357   (lambda (n)
 358     (#%list->string
 359      (if (#%< n 0)
 360          (#%cons #\- (#%number->string-aux (#%neg n) '()))
 361          (#%number->string-aux n '())))))
 362
 363 (define #%number->string-aux
 364   (lambda (n lst)
 365     (let ((rest (#%cons (#%+ #\0 (#%remainder n 10)) lst)))
 366       (if (#%< n 10)
 367           rest
 368           (#%number->string-aux (#%quotient n 10) rest)))))
 369
 370 (define pp
 371   (lambda (x)
 372     (write x)
 373     (#%putchar #\newline 3)))
 374
 375 (define caar
 376   (lambda (p)
 377     (#%car (#%car p))))
 378 (define cadr
 379   (lambda (p)
 380     (#%car (#%cdr p))))
 381 (define cdar
 382   (lambda (p)
 383     (#%cdr (#%car p))))
 384 (define cddr
 385   (lambda (p)
 386     (#%cdr (#%cdr p))))
 387 (define caaar
 388   (lambda (p)
 389     (#%car (#%car (#%car p)))))
 390 (define caadr
 391   (lambda (p)
 392     (#%car (#%car (#%cdr p)))))
 393 (define cadar
 394   (lambda (p)
 395     (#%car (#%cdr (#%car p)))))
 396 (define caddr
 397   (lambda (p)
 398     (#%car (#%cdr (#%cdr p)))))
 399 (define cdaar
 400   (lambda (p)
 401     (#%cdr (#%car (#%car p)))))
 402 (define cdadr
 403   (lambda (p)
 404     (#%cdr (#%car (#%cdr p)))))
 405 (define cddar
 406   (lambda (p)
 407     (#%cdr (#%cdr (#%car p)))))
 408 (define cdddr
 409   (lambda (p)
 410     (#%cdr (#%cdr (#%cdr p)))))
 411
 412 (define equal?
 413   (lambda (x y) ;; TODO rewrite once we have cond, also add vectors, actually, we do have cond, but I don't really trust it
 414     (if (#%eq? x y)
 415         #t
 416         (if (and (#%pair? x) (#%pair? y))
 417             (and (equal? (#%car x) (#%car y))
 418                  (equal? (#%cdr x) (#%cdr y)))
 419             (if (and (#%u8vector? x) (#%u8vector? y))
 420                 (u8vector-equal? x y)
 421                 #f))))) ;; TODO could this have a problem ?
 422
 423 (define u8vector-equal?
 424   (lambda (x y)
 425     (let ((lx (#%u8vector-length x)))
 426       (if (#%= lx (#%u8vector-length y))
 427           (u8vector-equal?-loop x y lx)
 428           #f))))
 429 (define u8vector-equal?-loop
 430   (lambda (x y l)
 431     (if (#%= l 0)
 432         #t
 433         (and (#%= (#%u8vector-ref x l) (#%u8vector-ref y l))
 434              (u8vector-equal?-loop x y (#%- l 1)))))) ;; TODO test this
 435
 436 (define assoc
 437   (lambda (t l) ;; TODO rewrite once we have cond
 438     (if (#%null? l)
 439         #f
 440         (if (equal? t (caar l))
 441             (#%car l)
 442             (assoc t (#%cdr l))))))
 443
 444 ;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable
 445 (define vector list)
 446 (define vector-ref list-ref)
 447 (define vector-set! list-set!)
 448
 449 (define bitwise-ior (lambda (x y) (#%ior x y)))
 450 (define bitwise-xor (lambda (x y) (#%xor x y)))
 451 ;; TODO add bitwise-and ? bitwise-not ?
 452
 453 (define current-time (lambda () (#%clock)))
 454 (define time->seconds (lambda (t) (#%quotient t 100))) ;; TODO no floats, is that a problem ?
 455
 456 (define else #t) ; for cond, among others
 457
 458 (define u8vector
 459   (lambda x
 460     (list->u8vector x)))
 461 (define list->u8vector ;; TODO not used except for server
 462   (lambda (x)
 463     (let* ((n (length x))
 464            (v (#%make-u8vector n)))
 465       (list->u8vector-loop v 0 x)
 466       v)))
 467 (define list->u8vector-loop
 468   (lambda (v n x)
 469     (#%u8vector-set! v n (#%car x))
 470     (if (#%not (#%null? (#%cdr x)))
 471         (list->u8vector-loop v (#%+ n 1) (#%cdr x)))))
 472 (define u8vector-length (lambda (x) (#%u8vector-length x)))
 473 (define u8vector-ref (lambda (x y) (#%u8vector-ref x y)))
 474 (define u8vector-set! (lambda (x y z) (#%u8vector-set! x y z)))
 475 (define make-u8vector
 476   (lambda (n x)
 477     (make-u8vector-loop (#%make-u8vector n) n x)))
 478 (define make-u8vector-loop
 479   (lambda (v n x)
 480     (#%u8vector-set! v n x)
 481     (if (#%> n 0) (make-u8vector-loop v (#%- n 1) x))))