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