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 ;; LISTS
  86
  87 (define (list . args) args)
  88
  89
  90 (define (caar l) (car (car l)))
  91 (define (cadr l) (car (cdr l)))
  92 (define (cdar l) (cdr (car l)))
  93 (define (cddr l) (cdr (cdr l)))
  94 (define (cadar l) (car (cdr (car l))))
  95
  96 ; Return number of items in list
  97 (define (length l)
  98   (define (iter a count)
  99     (if (null? a)
 100       count
 101       (iter (cdr a) (+ count 1))))
 102   (iter l 0))
 103
 104 ; Join two lists together
 105 (define (join l1 l2)
 106   (if (null? l1)
 107     l2
 108     (cons (car l1) (join (cdr l1) l2))))
 109
 110 ; Append an arbitrary number of lists together
 111 (define (append . lists)
 112   (if (null? lists)
 113     ()
 114     (if (null? (cdr lists))
 115       (car lists)
 116       (join (car lists) (apply append (cdr lists))))))
 117
 118 ; Reverse the contents of a list
 119 (define (reverse l)
 120   (if (null? l)
 121     ()
 122     (append (reverse (cdr l)) (list (car l)))))
 123
 124
 125 ;; LIBRARY SPECIAL FORMS
 126
 127 ; let
 128
 129 (define (let-vars args)
 130   (if (null? args)
 131     '()
 132     (cons (caar args) (let-vars (cdr args)))))
 133
 134 (define (let-inits args)
 135   (if (null? args)
 136     '()
 137   (cons (cadar args) (let-inits (cdr args)))))
 138
 139 (define-macro (let args . body)
 140               `((lambda ,(let-vars args)
 141                  ,@body) ,@(let-inits args)))
 142
 143 ; while
 144
 145 (define-macro (while condition . body)
 146               (let ((loop (gensym)))
 147                 `(begin
 148                    (define (,loop)
 149                      (if ,condition
 150                        (begin ,@body (,loop))))
 151                    (,loop))))
 152
 153 ; cond
 154
 155 (define (cond-predicate clause) (car clause))
 156 (define (cond-actions clause) (cdr clause))
 157 (define (cond-else-clause? clause)
 158   (eq? (cond-predicate clause) 'else))
 159
 160 (define (expand-clauses clauses)
 161   (if (null? clauses)
 162     (none)
 163     (let ((first (car clauses))
 164           (rest (cdr clauses)))
 165       (if (cond-else-clause? first)
 166         (if (null? rest)
 167           `(begin ,@(cond-actions first))
 168           (error "else clause isn't last in cond expression."))
 169         `(if ,(cond-predicate first)
 170            (begin ,@(cond-actions first))
 171            ,(expand-clauses rest))))))
 172
 173 (define-macro (cond . clauses)
 174               (if (null? clauses)
 175                 (error "cond requires at least one clause.")
 176                 (expand-clauses clauses)))
 177
 178 ; and
 179
 180 (define (expand-and-expressions expressions)
 181   (let ((first (car expressions))
 182         (rest (cdr expressions)))
 183     (if (null? rest)
 184       first
 185       `(if ,first
 186          ,(expand-and-expressions rest)
 187          #f))))
 188
 189 (define-macro (and . expressions)
 190               (if (null? expressions)
 191                 #t
 192                 (expand-and-expressions expressions)))
 193
 194 ; or
 195
 196 (define (expand-or-expressions expressions)
 197   (if (null? expressions)
 198     #f
 199     (let ((first (car expressions))
 200           (rest (cdr expressions))
 201           (val (gensym)))
 202       `(let ((,val ,first))
 203          (if ,val
 204             ,val
 205             ,(expand-or-expressions rest))))))
 206
 207 (define-macro (or . expressions)
 208               (expand-or-expressions expressions))
 209
 210
 211 ;; TESTING
 212
 213 (define-macro (backwards . body)
 214               (cons 'begin (reverse body)))
 215
 216 ; Test for the while macro.
 217 (define (count)
 218   (define counter 10)
 219   (while (> counter 0)
 220          (display counter) (newline)
 221          (set! counter (- counter 1))))
 222
 223 ; Basic iterative summation.  Run this on large numbers to
 224 ; test garbage collection and tail-call optimization.
 225 (define (sum n)
 226
 227   (define (sum-iter total count maxcount)
 228     (if (> count maxcount)
 229       total
 230       (sum-iter (+ total count) (+ count 1) maxcount)))
 231
 232   (sum-iter 0 1 n))
 233
 234 ; Recursive summation. Use this to compare with tail call
 235 ; optimized iterative algorithm.
 236 (define (sum-recurse n)
 237   (if (= n 0)
 238     0
 239     (+ n (sum-recurse (- n 1)))))