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