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