src/scheme-library.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Standard Library Procedures and Macros ;;
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 ;; NUMBERS
   6
   7 ; Arithmetic
   8
   9 (define (null? arg)
  10   (eq? arg '()))
  11
  12 (define (fold-left proc init l)
  13   (if (null? l)
  14     init
  15     (fold-left proc (proc init (car l)) (cdr l))))
  16
  17 (define (reduce-left proc init l)
  18   (if (null? l)
  19     init
  20     (if (null? (cdr l))
  21       (car l)
  22       (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
  23
  24 (define (+ . args)
  25   (fold-left fix:+ 0 args))
  26
  27 (define (- first . rest)
  28   (if (null? rest)
  29     (fix:neg first)
  30     (fix:- first (apply + rest))))
  31
  32 (define (* . args)
  33   (fold-left fix:* 1 args))
  34
  35 (define (quotient n1 n2)
  36   (fix:quotient n1 n2))
  37
  38 (define (remainder n1 n2)
  39   (fix:remainder n1 n2))
  40
  41 (define modulo remainder)
  42
  43 (define (1+ n)
  44   (fix:1+ n))
  45
  46 (define (-1+ n)
  47   (fix:-1+ n))
  48
  49 ; Relations
  50
  51 (define (test-relation rel l)
  52   (if (null? l)
  53     #t
  54     (if (null? (cdr l))
  55       #t
  56       (if (rel (car l) (car (cdr l)))
  57         (test-relation rel (cdr l))
  58         #f))))
  59
  60 (define (= . args)
  61   (test-relation fix:= args))
  62
  63 (define (> . args)
  64   (test-relation fix:> args))
  65
  66 (define (< . args)
  67   (test-relation fix:< args))
  68
  69 (define (>= . args)
  70   (test-relation fix:>= args))
  71
  72 (define (<= . args)
  73   (test-relation fix:<= args))
  74
  75
  76
  77 ; Current state of the numerical tower
  78 (define complex? #f)
  79 (define real? #f)
  80 (define rational? #t)
  81 (define integer? #t)
  82 (define exact? #t)
  83 (define inexact? #t)
  84
  85 ; Logic
  86
  87 (define (not x) (if x #f #t))
  88
  89 ;; LISTS
  90
  91 (define (list . args) args)
  92
  93
  94 (define (caar l) (car (car l)))
  95 (define (cadr l) (car (cdr l)))
  96 (define (cdar l) (cdr (car l)))
  97 (define (cddr l) (cdr (cdr l)))
  98 (define (cadar l) (car (cdr (car l))))
  99
 100 ; Return number of items in list
 101 (define (length l)
 102   (define (iter a count)
 103     (if (null? a)
 104       count
 105       (iter (cdr a) (+ count 1))))
 106   (iter l 0))
 107
 108 ; Join two lists together
 109 (define (join l1 l2)
 110   (if (null? l1)
 111     l2
 112     (cons (car l1) (join (cdr l1) l2))))
 113
 114 ; Append an arbitrary number of lists together
 115 (define (append . lists)
 116   (if (null? lists)
 117     ()
 118     (if (null? (cdr lists))
 119       (car lists)
 120       (join (car lists) (apply append (cdr lists))))))
 121
 122 ; Reverse the contents of a list
 123 (define (reverse l)
 124   (if (null? l)
 125     ()
 126     (append (reverse (cdr l)) (list (car l)))))
 127
 128
 129 ;; LIBRARY SPECIAL FORMS
 130
 131 ; let
 132
 133 (define (let-vars args)
 134   (if (null? args)
 135     '()
 136     (cons (caar args) (let-vars (cdr args)))))
 137
 138 (define (let-inits args)
 139   (if (null? args)
 140     '()
 141   (cons (cadar args) (let-inits (cdr args)))))
 142
 143 (define-macro (let args . body)
 144               `((lambda ,(let-vars args)
 145                  ,@body) ,@(let-inits args)))
 146
 147 ; while
 148
 149 (define-macro (while condition . body)
 150               (let ((loop (gensym)))
 151                 `(begin
 152                    (define (,loop)
 153                      (if ,condition
 154                        (begin ,@body (,loop))))
 155                    (,loop))))
 156
 157 ; cond
 158
 159 (define (cond-predicate clause) (car clause))
 160 (define (cond-actions clause) (cdr clause))
 161 (define (cond-else-clause? clause)
 162   (eq? (cond-predicate clause) 'else))
 163
 164 (define (expand-clauses clauses)
 165   (if (null? clauses)
 166     (none)
 167     (let ((first (car clauses))
 168           (rest (cdr clauses)))
 169       (if (cond-else-clause? first)
 170         (if (null? rest)
 171           `(begin ,@(cond-actions first))
 172           (error "else clause isn't last in cond expression."))
 173         `(if ,(cond-predicate first)
 174            (begin ,@(cond-actions first))
 175            ,(expand-clauses rest))))))
 176
 177 (define-macro (cond . clauses)
 178               (if (null? clauses)
 179                 (error "cond requires at least one clause.")
 180                 (expand-clauses clauses)))
 181
 182 ; and
 183
 184 (define (expand-and-expressions expressions)
 185   (let ((first (car expressions))
 186         (rest (cdr expressions)))
 187     (if (null? rest)
 188       first
 189       `(if ,first
 190          ,(expand-and-expressions rest)
 191          #f))))
 192
 193 (define-macro (and . expressions)
 194               (if (null? expressions)
 195                 #t
 196                 (expand-and-expressions expressions)))
 197
 198 ; or
 199
 200 (define (expand-or-expressions expressions)
 201   (if (null? expressions)
 202     #f
 203     (let ((first (car expressions))
 204           (rest (cdr expressions))
 205           (val (gensym)))
 206       `(let ((,val ,first))
 207          (if ,val
 208             ,val
 209             ,(expand-or-expressions rest))))))
 210
 211 (define-macro (or . expressions)
 212               (expand-or-expressions expressions))
 213
 214
 215 ;; TESTING
 216
 217 (define-macro (backwards . body)
 218               (cons 'begin (reverse body)))
 219
 220 ; Test for the while macro.
 221 (define (count)
 222   (define counter 10)
 223   (while (> counter 0)
 224          (display counter) (newline)
 225          (set! counter (- counter 1))))
 226
 227 ; Basic iterative summation.  Run this on large numbers to
 228 ; test garbage collection and tail-call optimization.
 229 (define (sum n)
 230
 231   (define (sum-iter total count maxcount)
 232     (if (> count maxcount)
 233       total
 234       (sum-iter (+ total count) (+ count 1) maxcount)))
 235
 236   (sum-iter 0 1 n))
 237
 238 ; Recursive summation. Use this to compare with tail call
 239 ; optimized iterative algorithm.
 240 (define (sum-recurse n)
 241   (if (= n 0)
 242     0
 243     (+ n (sum-recurse (- n 1)))))