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