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