scheme-library.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; Standard Library Procedures and Macros ;;
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 ;; LISTS
   6
   7 (define (null? args)
   8   (eq? args ()))
   9
  10 (define (caar l) (car (car l)))
  11 (define (cadr l) (car (cdr l)))
  12 (define (cdar l) (cdr (car l)))
  13 (define (cddr l) (cdr (cdr l)))
  14 (define (cadar l) (car (cdr (car l))))
  15
  16 ; Return number of items in list
  17 (define (length l)
  18   (define (iter a count)
  19     (if (null? a)
  20       count
  21       (iter (cdr a) (+ count 1))))
  22   (iter l 0))
  23
  24 ; Join two lists together
  25 (define (join l1 l2)
  26   (if (null? l1)
  27     l2
  28     (cons (car l1) (join (cdr l1) l2))))
  29
  30 ; Append an arbitrary number of lists together
  31 (define (append . lists)
  32   (if (null? lists)
  33     ()
  34     (if (null? (cdr lists))
  35       (car lists)
  36       (join (car lists) (apply append (cdr lists))))))
  37
  38 ; Reverse the contents of a list
  39 (define (reverse l)
  40   (if (null? l)
  41     ()
  42     (append (reverse (cdr l)) (list (car l)))))
  43
  44
  45 ;; LIBRARY SPECIAL FORMS
  46
  47 ; let
  48
  49 (define (let-vars args)
  50   (if (null? args)
  51     '()
  52     (cons (caar args) (let-vars (cdr args)))))
  53
  54 (define (let-inits args)
  55   (if (null? args)
  56     '()
  57   (cons (cadar args) (let-inits (cdr args)))))
  58
  59 (define-macro (let args . body)
  60               `((lambda ,(let-vars args)
  61                  ,@body) ,@(let-inits args)))
  62
  63 ; while
  64
  65 (define-macro (while condition . body)
  66               (let ((loop (gensym)))
  67                 `(begin
  68                    (define (,loop)
  69                      (if ,condition
  70                        (begin ,@body (,loop))))
  71                    (,loop))))
  72
  73 ; cond
  74
  75 (define (cond-predicate clause) (car clause))
  76 (define (cond-actions clause) (cdr clause))
  77 (define (cond-else-clause? clause)
  78   (eq? (cond-predicate clause) 'else))
  79
  80 (define (expand-clauses clauses)
  81   (if (null? clauses)
  82     (none)
  83     (let ((first (car clauses))
  84           (rest (cdr clauses)))
  85       (if (cond-else-clause? first)
  86         (if (null? rest)
  87           `(begin ,@(cond-actions first))
  88           (error "else clause isn't last in cond expression."))
  89         `(if ,(cond-predicate first)
  90            (begin ,@(cond-actions first))
  91            ,(expand-clauses rest))))))
  92
  93 (define-macro (cond . clauses)
  94               (if (null? clauses)
  95                 (error "cond requires at least one clause.")
  96                 (expand-clauses clauses)))
  97
  98 ; and
  99
 100 (define (expand-and-expressions expressions)
 101   (let ((first (car expressions))
 102         (rest (cdr expressions)))
 103     (if (null? rest)
 104       first
 105       `(if ,first
 106          ,(expand-and-expressions rest)
 107          #f))))
 108
 109 (define-macro (and . expressions)
 110               (if (null? expressions)
 111                 #t
 112                 (expand-and-expressions expressions)))
 113
 114 ; or
 115
 116 (define (expand-or-expressions expressions)
 117   (if (null? expressions)
 118     #f
 119     (let ((first (car expressions))
 120           (rest (cdr expressions))
 121           (val (gensym)))
 122       `(let ((,val ,first))
 123          (if ,val
 124             ,val
 125             ,(expand-or-expressions rest))))))
 126
 127 (define-macro (or . expressions)
 128               (expand-or-expressions expressions))
 129
 130
 131 ;; TESTING
 132
 133 (define-macro (backwards . body)
 134               (cons 'begin (reverse body)))
 135
 136 ; Test for the while macro.
 137 (define (count)
 138   (define counter 10)
 139   (while (> counter 0)
 140          (display counter) (newline)
 141          (set! counter (- counter 1))))
 142
 143 ; Basic iterative summation.  Run this on large numbers to
 144 ; test garbage collection and tail-call optimization.
 145 (define (sum n)
 146
 147   (define (sum-iter total count maxcount)
 148     (if (> count maxcount)
 149       total
 150       (sum-iter (+ total count) (+ count 1) maxcount)))
 151
 152   (sum-iter 0 1 n))
 153
 154 ; Recursive summation. Use this to compare with tail call
 155 ; optimized iterative algorithm.
 156 (define (sum-recurse n)
 157   (if (= n 0)
 158     0
 159     (+ n (sum-recurse (- n 1)))))