src/scm/support-code.scm

   1 ;;; support-code.scm
   2 ;;; Part of the initial environment that you will need to provide with your
   3 ;;; compiler, but written in [very elementary] Scheme. Put otherwise, your
   4 ;;; compiler will have to be able to compile this code in order to provide it.
   5
   6 ;;; Programmer: Mayer Goldberg, 2009
   7
   8 ;;; (define binary-add #f)
   9 ;;; (define binary-sub #f)
  10 ;;; (define binary-mul #f)
  11 ;;; (define binary-div #f)
  12 ;;; (define binary<? #f)
  13 ;;; (define binary=? #f)
  14 ;;;
  15 ;;; (let ((+ +) (- -) (* *) (/ /) (< <) (= =))
  16 ;;;   (set! binary-add (lambda (a b) (+ a b)))
  17 ;;;   (set! binary-sub (lambda (a b) (- a b)))
  18 ;;;   (set! binary-mul (lambda (a b) (* a b)))
  19 ;;;   (set! binary-div (lambda (a b) (/ a b)))
  20 ;;;   (set! binary<? (lambda (a b) (< a b)))
  21 ;;;   (set! binary=? (lambda (a b) (= a b))))
  22
  23 ;;; Use this procedure for boxing your variables
  24 ;;; when removing set! during the semantic analysis
  25 (define box
  26   (lambda (x)
  27     (let ((v (make-vector 1)))
  28       (vector-set! v 0 x)
  29       v)))
  30
  31 (define foldr
  32   (lambda (binop final s)
  33     (letrec ((loop
  34               (lambda (s)
  35                 (if (null? s) final
  36                     (binop (car s) (loop (cdr s)))))))
  37       (loop s))))
  38
  39 (define add1 (lambda (n) (binary-add n 1)))
  40 (define sub1 (lambda (n) (binary-sub n 1)))
  41
  42 (define order
  43   (lambda (<)
  44     (letrec ((loop
  45               (lambda (a s)
  46                 (or (null? s)
  47                     (and (< a (car s))
  48                          (loop (car s) (cdr s)))))))
  49       (lambda (a . s)
  50         (loop a s)))))
  51
  52 (define < (order binary<?))
  53
  54 (define <=
  55   (let ((binary<=?
  56          (lambda (a b)
  57            (or (binary<? a b)
  58                (binary=? a b)))))
  59     (order binary<=?)))
  60
  61 (define >
  62   (let ((binary>?
  63          (lambda (a b)
  64            (binary<? b a))))
  65     (order binary>?)))
  66
  67 (define >=
  68   (let ((binary>=?
  69          (lambda (a b)
  70            (or (binary=? a b)
  71                (binary<? b a)))))
  72     (order binary>=?)))
  73
  74 (define = (order binary=?))
  75
  76 ;;; extension: a variadic not-equal
  77 (define <>
  78   (letrec ((loop
  79             (lambda (a s)
  80               (or (null? s)
  81                   (and (andmap (lambda (b) (not (= a b))) s)
  82                        (loop (car s) (cdr s)))))))
  83     (lambda s
  84       (loop (car s) (cdr s)))))
  85
  86 (define not (lambda (x) (if x #f #t)))
  87
  88 (define compose
  89   (let ((binary-compose
  90          (lambda (f g)
  91            (lambda (x)
  92              (f (g x))))))
  93     (lambda s
  94       (foldr binary-compose (lambda (x) x) s))))
  95
  96 (define caar (compose car car))
  97 (define cadr (compose car cdr))
  98 (define cdar (compose cdr car))
  99 (define cddr (compose cdr cdr))
 100 (define caaar (compose car caar))
 101 (define caadr (compose car cadr))
 102 (define cadar (compose car cdar))
 103 (define caddr (compose car cddr))
 104 (define cdaar (compose cdr caar))
 105 (define cdadr (compose cdr cadr))
 106 (define cddar (compose cdr cdar))
 107 (define cdddr (compose cdr cddr))
 108 (define caaaar (compose car caaar))
 109 (define caaadr (compose car caadr))
 110 (define caadar (compose car cadar))
 111 (define caaddr (compose car caddr))
 112 (define cadaar (compose car cdaar))
 113 (define cadadr (compose car cdadr))
 114 (define caddar (compose car cddar))
 115 (define cadddr (compose car cdddr))
 116 (define cdaaar (compose cdr caaar))
 117 (define cdaadr (compose cdr caadr))
 118 (define cdadar (compose cdr cadar))
 119 (define cdaddr (compose cdr caddr))
 120 (define cddaar (compose cdr cdaar))
 121 (define cddadr (compose cdr cdadr))
 122 (define cdddar (compose cdr cddar))
 123 (define cddddr (compose cdr cdddr))
 124
 125 (define ^variadic-right-from-binary
 126   (lambda (binary-op base-value)
 127     (letrec ((op-list
 128               (lambda (s)
 129                 (if (null? s) base-value
 130                     (binary-op (car s) (op-list (cdr s)))))))
 131       (lambda args
 132         (op-list args)))))
 133
 134 (define ^variadic-left-from-binary
 135   (lambda (binary-op base-value)
 136     (letrec ((op-list
 137               (lambda (acc s)
 138                 (if (null? s) acc
 139                     (op-list (binary-op acc (car s)) (cdr s))))))
 140       (lambda args
 141         (if (null? args) base-value
 142             (op-list (car args) (cdr args)))))))
 143
 144 (define + (^variadic-right-from-binary binary-add 0))
 145 (define * (^variadic-right-from-binary binary-mul 1))
 146
 147 (define - (^variadic-left-from-binary binary-sub 0))
 148 (define / (^variadic-left-from-binary binary-div 1))
 149
 150 (define ^char-op
 151   (lambda (int-op)
 152     (lambda (ch1 ch2)
 153       (int-op (char->integer ch1) (char->integer ch2)))))
 154
 155 (define char=? (order (^char-op =)))
 156 (define char<=? (order (^char-op <=)))
 157 (define char<? (order (^char-op <)))
 158 (define char>=? (order (^char-op >=)))
 159 (define char>? (order (^char-op >)))
 160
 161 (define char-uppercase?
 162   (lambda (ch)
 163     (and (char<=? #\A ch)
 164          (char<=? ch #\Z))))
 165
 166 (define char-lowercase?
 167   (lambda (ch)
 168     (and (char<=? #\a ch)
 169          (char<=? ch #\z))))
 170
 171 (define char-upcase
 172   (let ((char-aA (- (char->integer #\a) (char->integer #\A))))
 173     (lambda (ch)
 174       (if (char-lowercase? ch)
 175           (integer->char
 176            (- (char->integer ch) char-aA))))))
 177
 178 (define char-downcase
 179   (let ((char-aA (- (char->integer #\a) (char->integer #\A))))
 180     (lambda (ch)
 181       (if (char-uppercase? ch)
 182           (integer->char
 183            (+ (char->integer ch) char-aA))))))
 184
 185 (define char-ci<=?
 186   (order
 187    (lambda (ch1 ch2)
 188      (char<=? (char-upcase ch1) (char-upcase ch2)))))
 189
 190 (define char-ci<?
 191   (order
 192    (lambda (ch1 ch2)
 193      (char<? (char-upcase ch1) (char-upcase ch2)))))
 194
 195 (define char-ci=?
 196   (order
 197    (lambda (ch1 ch2)
 198      (char=? (char-upcase ch1) (char-upcase ch2)))))
 199
 200 (define char-ci>?
 201   (order
 202    (lambda (ch1 ch2)
 203      (char>? (char-upcase ch1) (char-upcase ch2)))))
 204
 205 (define char-ci>=?
 206   (order
 207    (lambda (ch1 ch2)
 208      (char>=? (char-upcase ch1) (char-upcase ch2)))))
 209
 210 (define string-upcase
 211   (lambda (string)
 212     (list->string
 213      (map char-upcase (string->list string)))))
 214
 215 (define string-downcase
 216   (lambda (string)
 217     (list->string
 218      (map char-downcase (string->list string)))))
 219
 220 (define even?
 221   (lambda (n)
 222     (zero? (remainder n 2))))
 223
 224 (define odd?
 225   (lambda (n)
 226     (not (zero? (remainder n 2)))))
 227
 228 (define length
 229   (lambda (s)
 230     (if (null? s) 0
 231         (add1 (length (cdr s))))))
 232
 233 (define list (lambda args args))
 234
 235 (define list-ref
 236   (lambda (s i)
 237     (if (zero? i) (car s)
 238         (list-ref (cdr s) (- i 1)))))
 239
 240 (define list?
 241   (lambda (e)
 242     (or (null? e)
 243         (and (pair? e)
 244              (list? (cdr e))))))
 245
 246 (define map
 247   (letrec ((map-list
 248             (lambda (f lists)
 249               (if (null? (car lists)) '()
 250                   (cons (apply f (map-one car lists))
 251                         (map-list f (map-one cdr lists))))))
 252            (map-one
 253             (lambda (f s)
 254               (if (null? s) '()
 255                   (cons (f (car s))
 256                         (map-one f (cdr s)))))))
 257     (lambda (f . args)
 258       (map-list f args))))
 259
 260 (define member?
 261   (lambda (a s)
 262     (ormap (lambda (b) (eq? a b)) s)))
 263
 264 (define negative? (lambda (n) (< n 0)))
 265
 266 (define positive? (lambda (n) (> n 0)))
 267
 268 (define zero? (lambda (x) (= x 0)))
 269
 270 (define vector (lambda args (list->vector args)))
 271
 272 (define ormap
 273   (lambda (f s)
 274     (and (pair? s)
 275          (or (f (car s))
 276              (ormap f (cdr s))))))
 277
 278 (define andmap
 279   (lambda (f s)
 280     (or (null? s)
 281         (and (f (car s))
 282              (andmap f (cdr s))))))
 283
 284 (define string->list
 285   (letrec ((loop
 286             (lambda (str n s)
 287               (if (= n -1) s
 288                   (loop str
 289                         (- n 1)
 290                         (cons (string-ref str n) s))))))
 291     (lambda (str)
 292       (loop str (- (string-length str) 1) '()))))
 293
 294 (define binary-string=?
 295   (lambda (str1 str2)
 296     (let ((n1 (string-length str1))
 297           (n2 (string-length str2)))
 298       (and (= n1 n2)
 299            (let ((s1 (string->list str1))
 300                  (s2 (string->list str2)))
 301              (andmap char=? s1 s2))))))
 302
 303 (define binary-string<?
 304   (lambda (str1 str2)
 305     (letrec ((loop
 306               (lambda (s1 s2)
 307                 (cond ((null? s1) (pair? s2))
 308                       ((null? s2) #f)
 309                       ((char=? (car s1) (car s2))
 310                        (loop (cdr s1) (cdr s2)))
 311                       (else (char<? (car s1) (car s2)))))))
 312       (loop (string->list str1)
 313             (string->list str2)))))
 314
 315 (define binary-string>? (lambda (str1 str2) (binary-string<? str2 str1)))
 316
 317 (define binary-string<=?
 318   (lambda (str1 str2) (not (binary-string>? str1 str2))))
 319
 320 (define binary-string>=?
 321   (lambda (str1 str2) (not (binary-string<? str1 str2))))
 322
 323 (define string=? (order binary-string=?))
 324 (define string<? (order binary-string<?))
 325 (define string>? (order binary-string>?))
 326 (define string<=? (order binary-string<=?))
 327 (define string>=? (order binary-string>=?))
 328
 329 (define vector->list
 330   (letrec ((loop
 331             (lambda (v n s)
 332               (if (= n -1) s
 333                   (loop v
 334                         (- n 1)
 335                         (cons (vector-ref v n) s))))))
 336     (lambda (v)
 337       (loop v (- (vector-length v) 1) '()))))
 338
 339 (define list->string
 340   (lambda (s)
 341     (let* ((n (length s))
 342            (str (make-string n)))
 343       (letrec ((loop
 344                 (lambda (s i)
 345                   (if (= i n) str
 346                       (begin
 347                         (string-set! str i (car s))
 348                         (loop (cdr s) (+ i 1)))))))
 349         (loop s 0)))))
 350
 351 (define list->vector
 352   (lambda (s)
 353     (let* ((n (length s))
 354            (v (make-vector n)))
 355       (letrec ((loop
 356                 (lambda (s i)
 357                   (if (= i n) v
 358                       (begin
 359                         (vector-set! v i (car s))
 360                         (loop (cdr s) (+ i 1)))))))
 361         (loop s 0)))))
 362
 363 (define member
 364   (lambda (a s)
 365     (cond ((null? s) #f)
 366           ((equal? (car s) a) s)
 367           (else (member a (cdr s))))))
 368
 369 (define assoc
 370   (lambda (a s)
 371     (cond ((null? s) #f)
 372           ((eq? (caar s) a) (car s))
 373           (else (assoc a (cdr s))))))
 374
 375 (define equal?
 376   (lambda (e1 e2)
 377     (cond ((and (pair? e1) (pair? e2))
 378            (and (equal? (car e1) (car e2))
 379                 (equal? (cdr e1) (cdr e2))))
 380           ((and (vector? e1) (vector? e2)
 381                 (= (vector-length e1) (vector-length e2)))
 382            (equal? (vector->list e1) (vector->list e2)))
 383           ((and (null? e1) (null? e2)) #t)
 384           ((and (boolean? e1) (boolean? e2)) (and e1 e2))
 385           ((and (char? e1) (char? e2))
 386            (char=? e1 e2))
 387           ((and (number? e1) (number? e2))
 388            (= e1 e2))
 389           ((and (string? e1) (string? e2))
 390            (string=? e1 e2))
 391           ((and (symbol? e1) (symbol? e2))
 392            (eq? e1 e2))
 393           ((and (void? e1) (void? e2)) #t)
 394           (else #f))))
 395
 396 (define void
 397   (let ((void-object
 398          (if #f #f)))
 399     (lambda () void-object)))
 400
 401 (define void?
 402   (let ((void-object (void)))
 403     (lambda (x) (eq? x void-object))))
 404
 405 (define string-append
 406   (lambda s
 407     (list->string (apply append (map string->list s)))))
 408
 409 (define vector-append
 410   (lambda s
 411     (list->vector (apply append (map vector->list s)))))
 412
 413 (define append
 414   (letrec ((binary-append
 415             (lambda (s1 s2)
 416               (if (null? s1) s2
 417                   (cons (car s1) (binary-append (cdr s1) s2))))))
 418     (lambda s
 419       (foldr binary-append '() s))))
 420
 421 (define reverse
 422   (letrec ((loop
 423             (lambda (s r)
 424               (if (null? s) r
 425                   (loop (cdr s) (cons (car s) r))))))
 426     (lambda (s)
 427       (loop s '()))))
 428
 429 (define string-reverse
 430   (compose
 431    list->string
 432    reverse
 433    string->list))
 434
 435 (define list-ref
 436   (lambda (s i)
 437     (if (zero? i) (car s)
 438         (list-ref (cdr s) (- i 1)))))
 439
 440 (define list-set!
 441   (lambda (s i x)
 442     (if (zero? i) (set-car! s x)
 443         (list-set! (cdr s) (- i 1) x))))
 444
 445 (define max
 446   (let ((binary-max (lambda (a b) (if (> a b) a b))))
 447     (lambda (a . s)
 448       (foldr binary-max a s))))
 449
 450 (define min
 451   (let ((binary-min (lambda (a b) (if (< a b) a b))))
 452     (lambda (a . s)
 453       (foldr binary-min a s))))
 454
 455 (define gcd
 456   (letrec ((binary-gcd
 457             (lambda (a b)
 458               (if (zero? b) a
 459                   (let ((r (remainder a b)))
 460                     (if (zero? r) b
 461                         (binary-gcd b r)))))))
 462     (lambda (a . s)
 463       (foldr binary-gcd a s))))
 464
 465 (define lcm
 466   (lambda s
 467     (/ (apply * s)
 468        (apply gcd s))))