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)) ;; TODO had an error and looped
 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) ;; TODO had an off-by-one
 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 dac
 277   (lambda (level)
 278     (#%dac level)))
 279
 280 (define sernum
 281   (lambda ()
 282     (#%sernum)))
 283
 284 (define putchar
 285   (lambda (c)
 286     (#%putchar c 3)))
 287
 288 (define getchar
 289   (lambda ()
 290     (or (#%getchar-wait 0 3)
 291         (getchar))))
 292
 293 (define getchar-wait
 294   (lambda (duration)
 295     (#%getchar-wait duration 3)))
 296
 297 (define sleep
 298   (lambda (duration)
 299     (#%sleep-aux (#%+ (#%clock) duration))))
 300
 301 (define #%sleep-aux
 302   (lambda (wake-up)
 303     (if (#%< (#%clock) wake-up)
 304         (#%sleep-aux wake-up)
 305         #f)))
 306
 307 (define motor
 308   (lambda (id power)
 309     (#%motor id power)))
 310
 311
 312 (define led
 313   (lambda (id duty period)
 314     (#%led id duty period)))
 315
 316 (define led2-color
 317   (lambda (state)
 318     (if (#%eq? state 'red)
 319         (#%led2-color 1)
 320         (#%led2-color 0))))
 321
 322 (define display
 323   (lambda (x)
 324     (if (#%string? x)
 325         (for-each putchar (#%string->list x))
 326         (write x))))
 327
 328 (define write
 329   (lambda (x)
 330     (if (#%string? x)
 331         (begin
 332           (#%putchar #\" 3)
 333           (display x)
 334           (#%putchar #\" 3))
 335         (if (#%number? x)
 336             (display (number->string x))
 337             (if (#%pair? x)
 338                 (begin
 339                   (#%putchar #\( 3)
 340                   (write (#%car x))
 341                   (#%write-list (#%cdr x)))
 342                 (if (#%symbol? x)
 343                     (display "#<symbol>")
 344                     (display "#<object>")))))))
 345
 346 (define #%write-list
 347   (lambda (lst)
 348     (if (#%null? lst)
 349         (#%putchar #\) 3)
 350         (if (#%pair? lst)
 351             (begin
 352               (#%putchar #\space 3)
 353               (write (#%car lst))
 354               (#%write-list (#%cdr lst)))
 355             (begin
 356               (display " . ")
 357               (write lst)
 358               (#%putchar #\) 3))))))
 359
 360 (define number->string
 361   (lambda (n)
 362     (#%list->string
 363      (if (#%< n 0)
 364          (#%cons #\- (#%number->string-aux (#%neg n) '()))
 365          (#%number->string-aux n '())))))
 366
 367 (define #%number->string-aux
 368   (lambda (n lst)
 369     (let ((rest (#%cons (#%+ #\0 (#%remainder n 10)) lst)))
 370       (if (#%< n 10)
 371           rest
 372           (#%number->string-aux (#%quotient n 10) rest)))))
 373
 374 (define pp
 375   (lambda (x)
 376     (write x)
 377     (#%putchar #\newline 3)))
 378
 379 (define caar
 380   (lambda (p)
 381     (car (car p))))
 382 (define cadr
 383   (lambda (p)
 384     (car (cdr p))))
 385 (define cdar
 386   (lambda (p)
 387     (cdr (car p))))
 388 (define cddr ;; TODO implement all of them up to 4 chars ?
 389   (lambda (p)
 390     (cdr (cdr p))))
 391 (define caadr
 392   (lambda (p)
 393     (car (car (cdr p)))))
 394 (define cdadr
 395   (lambda (p)
 396     (cdr (car (cdr p)))))
 397
 398 (define equal?
 399   (lambda (x y) ;; TODO rewrite once we have cond, also add vectors
 400     (if (eq? x y)
 401         #t
 402         (if (and (pair? x) (pair? y))
 403             (and (equal? (car x) (car y))
 404                  (equal? (cdr x) (cdr y)))
 405             #f)))) ;; TODO could this have a problem ?
 406
 407 (define assoc
 408   (lambda (t l) ;; TODO rewrite once we have cond
 409     (if (null? l)
 410         #f
 411         (if (equal? t (caar l))
 412             (car l)
 413             (assoc t (cdr l))))))
 414
 415 ;; TODO ordinary vectors are never more that 6 elements long in the stack, so implementing them as lists is acceptable
 416 (define vector list)
 417 (define vector-ref list-ref)
 418 (define vector-set! list-set!)
 419
 420 (define bitwise-ior (lambda (x y) (#%ior x y)))
 421 (define bitwise-xor (lambda (x y) (#%xor x y)))
 422 ;; TODO add bitwise-and ? bitwise-not ?
 423
 424 (define current-time (lambda () (clock)))
 425 (define time->seconds (lambda (t) (quotient t 100))) ;; TODO no floats, is that a problem ?
 426
 427 (define else #t) ; for cond, among others
 428
 429 ;; TODO temporary, using lists since triplets are gone
 430 (define u8vector (lambda x (list x)))
 431 (define list->u8vector (lambda (x) x))
 432 (define u8vector-length (lambda (x) (length x)))
 433 (define u8vector-ref (lambda (x y) (list-ref x y)))
 434 (define u8vector-set! (lambda (x y z) (list-set! x y z)))
 435 (define make-u8vector
 436   (lambda (n x)
 437     (if (= n 0)
 438         '()
 439         (cons x (make-u8vector (- n 1) x)))))
 440
 441
 442 ;; ROM VECTORS
 443 ;; TODO make sure constant vectors end up in rom
 444 ;; (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
 445 ;;   (lambda (first . rest) ;; TODO can't we have all in the same arg ?
 446 ;;     (list->u8vector (cons first rest))))
 447 ;; ;; 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)
 448
 449 ;; (define u8vector-ref
 450 ;;   (lambda (u8 i)
 451 ;;     (#%car (#%substring-aux1 (#%string->list u8) i))))
 452 ;; ;; 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
 453
 454 (define print display) ;; TODO watch out for differences between the 2