src/scheme-library.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Standard Library Procedures and Macros ;;
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 ;; MISC
   6
   7 (define (not x) (if x #f #t))
   8
   9 (define (list . args) args)
  10
  11 (define (caar l) (car (car l)))
  12 (define (cadr l) (car (cdr l)))
  13 (define (cdar l) (cdr (car l)))
  14 (define (cddr l) (cdr (cdr l)))
  15 (define (cadar l) (car (cdr (car l))))
  16
  17
  18 ;; NUMBERS
  19
  20 ; Rational primitives
  21
  22 (define (numerator x)
  23   (if (ratnum? x)
  24     (rat:numerator x)
  25     x))
  26
  27 (define (denominator x)
  28   (if (ratnum? x)
  29     (rat:denominator x)
  30     (if (fixnum? x)
  31       1
  32       1.0)))
  33
  34 (define (rat:+ x y)
  35   (make-rational (fix:+ (fix:* (numerator x) (denominator y))
  36                         (fix:* (denominator x) (numerator y)))
  37                  (fix:* (denominator x) (denominator y))))
  38
  39 (define (rat:- x y)
  40   (make-rational (fix:- (fix:* (numerator x) (denominator y))
  41                         (fix:* (denominator x) (numerator y)))
  42                  (fix:* (denominator x) (denominator y))))
  43
  44 (define (rat:* x y)
  45   (make-rational (fix:* (numerator x) (numerator y))
  46                  (fix:* (denominator x) (denominator y))))
  47
  48 (define (rat:/ x y)
  49   (make-rational (fix:* (numerator x) (denominator y))
  50                  (fix:* (denominator x) (numerator y))))
  51
  52 (define (rat:1/ x)
  53   (make-rational (denominator x) (numerator x)))
  54
  55 ; Type dispatch and promotion
  56
  57 (define (type-dispatch ops x)
  58   (if (flonum? x)
  59     ((cdr ops) x)
  60     ((car ops) x)))
  61
  62 (define (promote-dispatch ops x y)
  63   (if (flonum? x)
  64     (if (flonum? y)
  65       ((cdr ops) x y)
  66       ((cdr ops) x (fixnum->flonum y)))
  67     (if (flonum? y)
  68       ((cdr ops) (fixnum->flonum x) y)
  69       ((car ops) x y))))
  70
  71 ; Unary ops
  72
  73 (define (neg x)
  74   (type-dispatch (cons fix:neg flo:neg) x))
  75
  76 (define (abs x)
  77   (type-dispatch (cons fix:abs flo:abs) x))
  78
  79 (define (flo:1+ x) (flo:+ x 1.0))
  80 (define (flo:1- x) (flo:- x 1.0))
  81
  82 (define (1+ n)
  83   (type-dispatch (cons fix:1+ flo:1+) n))
  84
  85 (define (1- n)
  86   (type-dispatch (cons fix:1- flo:1-) n))
  87
  88 (define (apply-to-flonum op x)
  89   (if (flonum? x) (op x) x))
  90
  91 (define (round x)
  92   (apply-to-flonum flo:round x))
  93 (define (floor x)
  94   (apply-to-flonum flo:floor x))
  95 (define (ceiling x)
  96   (apply-to-flonum flo:ceiling x))
  97 (define (truncate x)
  98   (apply-to-flonum flo:truncate x))
  99
 100 ; Binary operations
 101
 102 (define (fix:/ x y) ; Non-standard definition while we don't have rationals
 103   (if (fix:= 0 (fix:remainder x y))
 104     (fix:quotient x y)
 105     (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
 106
 107 (define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
 108 (define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
 109 (define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
 110 (define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
 111
 112 (define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
 113 (define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
 114 (define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
 115 (define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
 116 (define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
 117
 118 (define (null? arg)
 119   (eq? arg '()))
 120
 121 (define (fold-left proc init l)
 122   (if (null? l)
 123     init
 124     (fold-left proc (proc init (car l)) (cdr l))))
 125
 126 (define (reduce-left proc init l)
 127   (if (null? l)
 128     init
 129     (if (null? (cdr l))
 130       (car l)
 131       (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
 132
 133 (define (+ . args)
 134   (fold-left pair+ 0 args))
 135
 136 (define (- first . rest)
 137   (if (null? rest)
 138     (neg first)
 139     (pair- first (apply + rest))))
 140
 141 (define (* . args)
 142   (fold-left pair* 1 args))
 143
 144 (define (/ first . rest)
 145   (if (null? rest)
 146     (pair/ 1 first)
 147     (pair/ first (apply * rest))))
 148
 149 (define (quotient n1 n2)
 150   (fix:quotient n1 n2))
 151
 152 (define (remainder n1 n2)
 153   (fix:remainder n1 n2))
 154
 155 (define modulo remainder)
 156
 157 ; Relations
 158
 159 (define (test-relation rel l)
 160   (if (null? l)
 161     #t
 162     (if (null? (cdr l))
 163       #t
 164       (if (rel (car l) (car (cdr l)))
 165         (test-relation rel (cdr l))
 166         #f))))
 167
 168 (define (= . args)
 169   (test-relation pair= args))
 170
 171 (define (> . args)
 172   (test-relation pair> args))
 173
 174 (define (< . args)
 175   (test-relation pair< args))
 176
 177 (define (>= . args)
 178   (test-relation pair>= args))
 179
 180 (define (<= . args)
 181   (test-relation pair<= args))
 182
 183 ; Numeric tests
 184
 185 (define (zero? x) (pair= x 0.0))
 186 (define (positive x) (pair> x 0.0))
 187 (define (odd? n) (pair= (remainder n 2) 0))
 188 (define (odd? n) (not (pair= (remainder n 2) 0)))
 189
 190
 191 ; Current state of the numerical tower
 192 (define (complex? x) #f)
 193 (define (real? x) #t)
 194 (define (rational? x) #t)
 195 (define (integer? x) (= x (round x)))
 196 (define (exact? x) (fixnum? x))
 197 (define (inexact? x) (flonum? x))
 198
 199 ;; LISTS
 200
 201 ; Return number of items in list
 202 (define (length l)
 203   (define (iter a count)
 204     (if (null? a)
 205       count
 206       (iter (cdr a) (+ count 1))))
 207   (iter l 0))
 208
 209 ; Join two lists together
 210 (define (join l1 l2)
 211   (if (null? l1)
 212     l2
 213     (cons (car l1) (join (cdr l1) l2))))
 214
 215 ; Append an arbitrary number of lists together
 216 (define (append . lists)
 217   (if (null? lists)
 218     ()
 219     (if (null? (cdr lists))
 220       (car lists)
 221       (join (car lists) (apply append (cdr lists))))))
 222
 223 ; Reverse the contents of a list
 224 (define (reverse l)
 225   (if (null? l)
 226     ()
 227     (append (reverse (cdr l)) (list (car l)))))
 228
 229
 230 ;; LIBRARY SPECIAL FORMS
 231
 232 ; let
 233
 234 (define (let-vars args)
 235   (if (null? args)
 236     '()
 237     (cons (caar args) (let-vars (cdr args)))))
 238
 239 (define (let-inits args)
 240   (if (null? args)
 241     '()
 242   (cons (cadar args) (let-inits (cdr args)))))
 243
 244 (define-macro (let args . body)
 245               `((lambda ,(let-vars args)
 246                  ,@body) ,@(let-inits args)))
 247
 248 ; while
 249
 250 (define-macro (while condition . body)
 251               (let ((loop (gensym)))
 252                 `(begin
 253                    (define (,loop)
 254                      (if ,condition
 255                        (begin ,@body (,loop))))
 256                    (,loop))))
 257
 258 ; cond
 259
 260 (define (cond-predicate clause) (car clause))
 261 (define (cond-actions clause) (cdr clause))
 262 (define (cond-else-clause? clause)
 263   (eq? (cond-predicate clause) 'else))
 264
 265 (define (expand-clauses clauses)
 266   (if (null? clauses)
 267     (none)
 268     (let ((first (car clauses))
 269           (rest (cdr clauses)))
 270       (if (cond-else-clause? first)
 271         (if (null? rest)
 272           `(begin ,@(cond-actions first))
 273           (error "else clause isn't last in cond expression."))
 274         `(if ,(cond-predicate first)
 275            (begin ,@(cond-actions first))
 276            ,(expand-clauses rest))))))
 277
 278 (define-macro (cond . clauses)
 279               (if (null? clauses)
 280                 (error "cond requires at least one clause.")
 281                 (expand-clauses clauses)))
 282
 283 ; and
 284
 285 (define (expand-and-expressions expressions)
 286   (let ((first (car expressions))
 287         (rest (cdr expressions)))
 288     (if (null? rest)
 289       first
 290       `(if ,first
 291          ,(expand-and-expressions rest)
 292          #f))))
 293
 294 (define-macro (and . expressions)
 295               (if (null? expressions)
 296                 #t
 297                 (expand-and-expressions expressions)))
 298
 299 ; or
 300
 301 (define (expand-or-expressions expressions)
 302   (if (null? expressions)
 303     #f
 304     (let ((first (car expressions))
 305           (rest (cdr expressions))
 306           (val (gensym)))
 307       `(let ((,val ,first))
 308          (if ,val
 309             ,val
 310             ,(expand-or-expressions rest))))))
 311
 312 (define-macro (or . expressions)
 313               (expand-or-expressions expressions))
 314
 315
 316 ;; TESTING
 317
 318 (define-macro (backwards . body)
 319               (cons 'begin (reverse body)))
 320
 321 ; Test for the while macro.
 322 (define (count)
 323   (define counter 10)
 324   (while (> counter 0)
 325          (display counter) (newline)
 326          (set! counter (- counter 1))))
 327
 328 ; Basic iterative summation.  Run this on large numbers to
 329 ; test garbage collection and tail-call optimization.
 330 (define (sum n)
 331
 332   (define (sum-iter total count maxcount)
 333     (if (> count maxcount)
 334       total
 335       (sum-iter (+ total count) (+ count 1) maxcount)))
 336
 337   (sum-iter 0 1 n))
 338
 339 ; Recursive summation. Use this to compare with tail call
 340 ; optimized iterative algorithm.
 341 (define (sum-recurse n)
 342   (if (= n 0)
 343     0
 344     (+ n (sum-recurse (- n 1)))))