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           ch))))
 178
 179 (define char-downcase
 180   (let ((char-aA (- (char->integer #\a) (char->integer #\A))))
 181     (lambda (ch)
 182       (if (char-uppercase? ch)
 183           (integer->char
 184            (+ (char->integer ch) char-aA))
 185           ch))))
 186
 187 (define char-ci<=?
 188   (order
 189    (lambda (ch1 ch2)
 190      (char<=? (char-upcase ch1) (char-upcase ch2)))))
 191
 192 (define char-ci<?
 193   (order
 194    (lambda (ch1 ch2)
 195      (char<? (char-upcase ch1) (char-upcase ch2)))))
 196
 197 (define char-ci=?
 198   (order
 199    (lambda (ch1 ch2)
 200      (char=? (char-upcase ch1) (char-upcase ch2)))))
 201
 202 (define char-ci>?
 203   (order
 204    (lambda (ch1 ch2)
 205      (char>? (char-upcase ch1) (char-upcase ch2)))))
 206
 207 (define char-ci>=?
 208   (order
 209    (lambda (ch1 ch2)
 210      (char>=? (char-upcase ch1) (char-upcase ch2)))))
 211
 212 (define string-upcase
 213   (lambda (string)
 214     (list->string
 215      (map char-upcase (string->list string)))))
 216
 217 (define string-downcase
 218   (lambda (string)
 219     (list->string
 220      (map char-downcase (string->list string)))))
 221
 222 (define even?
 223   (lambda (n)
 224     (zero? (remainder n 2))))
 225
 226 (define odd?
 227   (lambda (n)
 228     (not (zero? (remainder n 2)))))
 229
 230 (define length
 231   (lambda (s)
 232     (if (null? s) 0
 233         (add1 (length (cdr s))))))
 234
 235 (define list (lambda args args))
 236
 237 (define list-ref
 238   (lambda (s i)
 239     (if (zero? i) (car s)
 240         (list-ref (cdr s) (- i 1)))))
 241
 242 (define list?
 243   (lambda (e)
 244     (or (null? e)
 245         (and (pair? e)
 246              (list? (cdr e))))))
 247
 248 (define map
 249   (letrec ((map-list
 250             (lambda (f lists)
 251               (if (null? (car lists)) '()
 252                   (cons (apply f (map-one car lists))
 253                         (map-list f (map-one cdr lists))))))
 254            (map-one
 255             (lambda (f s)
 256               (if (null? s) '()
 257                   (cons (f (car s))
 258                         (map-one f (cdr s)))))))
 259     (lambda (f . args)
 260       (map-list f args))))
 261
 262 (define member?
 263   (lambda (a s)
 264     (ormap (lambda (b) (eq? a b)) s)))
 265
 266 (define negative? (lambda (n) (< n 0)))
 267
 268 (define positive? (lambda (n) (> n 0)))
 269
 270 (define zero? (lambda (x) (= x 0)))
 271
 272 (define vector (lambda args (list->vector args)))
 273
 274 (define ormap
 275   (lambda (f . s)
 276     (letrec ((loop
 277               (lambda (s)
 278                 (and (pair? (car s))
 279                      (or (apply f (map car s))
 280                          (loop (map cdr s)))))))
 281       (loop s))))
 282
 283 (define andmap
 284   (lambda (f . s)
 285     (letrec ((loop
 286               (lambda (s)
 287                 (or (null? (car s))
 288                     (and (apply f (map car s))
 289                          (loop (map cdr s)))))))
 290       (loop s))))
 291
 292 (define string->list
 293   (letrec ((loop
 294             (lambda (str n s)
 295               (if (= n -1) s
 296                   (loop str
 297                         (- n 1)
 298                         (cons (string-ref str n) s))))))
 299     (lambda (str)
 300       (loop str (- (string-length str) 1) '()))))
 301
 302 (define binary-string=?
 303   (lambda (str1 str2)
 304     (let ((n1 (string-length str1))
 305           (n2 (string-length str2)))
 306       (and (= n1 n2)
 307            (let ((s1 (string->list str1))
 308                  (s2 (string->list str2)))
 309              (andmap char=? s1 s2))))))
 310
 311 (define binary-string<?
 312   (lambda (str1 str2)
 313     (letrec ((loop
 314               (lambda (s1 s2)
 315                 (cond ((null? s1) (pair? s2))
 316                       ((null? s2) #f)
 317                       ((char=? (car s1) (car s2))
 318                        (loop (cdr s1) (cdr s2)))
 319                       (else (char<? (car s1) (car s2)))))))
 320       (loop (string->list str1)
 321             (string->list str2)))))
 322
 323 (define binary-string>? (lambda (str1 str2) (binary-string<? str2 str1)))
 324
 325 (define binary-string<=?
 326   (lambda (str1 str2) (not (binary-string>? str1 str2))))
 327
 328 (define binary-string>=?
 329   (lambda (str1 str2) (not (binary-string<? str1 str2))))
 330
 331 (define string=? (order binary-string=?))
 332 (define string<? (order binary-string<?))
 333 (define string>? (order binary-string>?))
 334 (define string<=? (order binary-string<=?))
 335 (define string>=? (order binary-string>=?))
 336
 337 (define vector->list
 338   (letrec ((loop
 339             (lambda (v n s)
 340               (if (= n -1) s
 341                   (loop v
 342                         (- n 1)
 343                         (cons (vector-ref v n) s))))))
 344     (lambda (v)
 345       (loop v (- (vector-length v) 1) '()))))
 346
 347 (define list->string
 348   (lambda (s)
 349     (let* ((n (length s))
 350            (str (make-string n)))
 351       (letrec ((loop
 352                 (lambda (s i)
 353                   (if (= i n) str
 354                       (begin
 355                         (string-set! str i (car s))
 356                         (loop (cdr s) (+ i 1)))))))
 357         (loop s 0)))))
 358
 359 (define list->vector
 360   (lambda (s)
 361     (let* ((n (length s))
 362            (v (make-vector n)))
 363       (letrec ((loop
 364                 (lambda (s i)
 365                   (if (= i n) v
 366                       (begin
 367                         (vector-set! v i (car s))
 368                         (loop (cdr s) (+ i 1)))))))
 369         (loop s 0)))))
 370
 371 (define member
 372   (lambda (a s)
 373     (cond ((null? s) #f)
 374           ((equal? (car s) a) s)
 375           (else (member a (cdr s))))))
 376
 377 (define assoc
 378   (lambda (a s)
 379     (cond ((null? s) #f)
 380           ((eq? (caar s) a) (car s))
 381           (else (assoc a (cdr s))))))
 382
 383 (define equal?
 384   (lambda (e1 e2)
 385     (cond ((and (pair? e1) (pair? e2))
 386            (and (equal? (car e1) (car e2))
 387                 (equal? (cdr e1) (cdr e2))))
 388           ((and (vector? e1) (vector? e2)
 389                 (= (vector-length e1) (vector-length e2)))
 390            (equal? (vector->list e1) (vector->list e2)))
 391           ((and (null? e1) (null? e2)) #t)
 392           ((and (boolean? e1) (boolean? e2)) (and e1 e2))
 393           ((and (char? e1) (char? e2))
 394            (char=? e1 e2))
 395           ((and (number? e1) (number? e2))
 396            (= e1 e2))
 397           ((and (string? e1) (string? e2))
 398            (string=? e1 e2))
 399           ((and (symbol? e1) (symbol? e2))
 400            (eq? e1 e2))
 401           ((and (void? e1) (void? e2)) #t)
 402           (else #f))))
 403
 404 (define void
 405   (let ((void-object
 406          (if #f #f)))
 407     (lambda () void-object)))
 408
 409 (define void?
 410   (let ((void-object (void)))
 411     (lambda (x) (eq? x void-object))))
 412
 413 (define string-append
 414   (lambda s
 415     (list->string (apply append (map string->list s)))))
 416
 417 (define vector-append
 418   (lambda s
 419     (list->vector (apply append (map vector->list s)))))
 420
 421 (define append
 422   (letrec ((binary-append
 423             (lambda (s1 s2)
 424               (if (null? s1) s2
 425                   (cons (car s1) (binary-append (cdr s1) s2))))))
 426     (lambda s
 427       (foldr binary-append '() s))))
 428
 429 (define reverse
 430   (letrec ((loop
 431             (lambda (s r)
 432               (if (null? s) r
 433                   (loop (cdr s) (cons (car s) r))))))
 434     (lambda (s)
 435       (loop s '()))))
 436
 437 (define string-reverse
 438   (compose
 439    list->string
 440    reverse
 441    string->list))
 442
 443 (define list-ref
 444   (lambda (s i)
 445     (if (zero? i) (car s)
 446         (list-ref (cdr s) (- i 1)))))
 447
 448 (define list-set!
 449   (lambda (s i x)
 450     (if (zero? i) (set-car! s x)
 451         (list-set! (cdr s) (- i 1) x))))
 452
 453 (define max
 454   (let ((binary-max (lambda (a b) (if (> a b) a b))))
 455     (lambda (a . s)
 456       (foldr binary-max a s))))
 457
 458 (define min
 459   (let ((binary-min (lambda (a b) (if (< a b) a b))))
 460     (lambda (a . s)
 461       (foldr binary-min a s))))
 462
 463 (define gcd
 464   (letrec ((binary-gcd
 465             (lambda (a b)
 466               (if (zero? b) a
 467                   (let ((r (remainder a b)))
 468                     (if (zero? r) b
 469                         (binary-gcd b r)))))))
 470     (lambda (a . s)
 471       (foldr binary-gcd a s))))
 472
 473 (define lcm
 474   (lambda s
 475     (/ (apply * s)
 476        (apply gcd s))))