1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; Standard Library Procedures and Macros ;;
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 (define (not x) (if x #f #t))
9 (define (list . args) args)
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))))
22 (define (flo:1+ x) (flo:+ x 1.0))
23 (define (flo:1- x) (flo:- x 1.0))
26 (type-dispatch (cons fix:1+ flo:1+) n))
29 (type-dispatch (cons fix:1- flo:1-) n))
31 (define (apply-to-flonum op x)
32 (if (flonum? x) (op x) x))
35 (apply-to-flonum flo:round x))
37 (apply-to-flonum flo:floor x))
39 (apply-to-flonum flo:ceiling x))
41 (apply-to-flonum flo:truncate x))
43 ; Type dispatch and promotion
45 (define (type-dispatch ops x)
50 (define (promote-dispatch ops x y)
54 ((cdr ops) x (fixnum->flonum y)))
56 ((cdr ops) (fixnum->flonum x) y)
61 (define (fix:/ x y) ; Non-standard definition while we don't have rationals
62 (if (fix:= 0 (fix:remainder x y))
64 (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
66 (define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
67 (define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
68 (define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
69 (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 (define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
75 (define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
78 (type-dispatch (cons fix:neg flo:neg) x))
83 (define (fold-left proc init l)
86 (fold-left proc (proc init (car l)) (cdr l))))
88 (define (reduce-left proc init l)
93 (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
96 (fold-left pair+ 0 args))
98 (define (- first . rest)
101 (pair- first (apply + rest))))
104 (fold-left pair* 1 args))
106 (define (/ first . rest)
109 (pair/ first (apply * rest))))
111 (define (quotient n1 n2)
112 (fix:quotient n1 n2))
114 (define (remainder n1 n2)
115 (fix:remainder n1 n2))
117 (define modulo remainder)
121 (define (test-relation rel l)
126 (if (rel (car l) (car (cdr l)))
127 (test-relation rel (cdr l))
131 (test-relation pair= args))
134 (test-relation pair> args))
137 (test-relation pair< args))
140 (test-relation pair>= args))
143 (test-relation pair<= args))
147 (define (zero? x) (pair= x 0.0))
148 (define (positive x) (pair> x 0.0))
149 (define (odd? n) (pair= (remainder n 2) 0))
150 (define (odd? n) (not (pair= (remainder n 2) 0)))
153 ; Current state of the numerical tower
154 (define (complex? x) #f)
155 (define (real? x) #t)
156 (define (rational? x) #t)
157 (define (integer? x) (= x (round x)))
158 (define (exact? x) (fixnum? x))
159 (define (inexact? x) (flonum? x))
163 ; Return number of items in list
165 (define (iter a count)
168 (iter (cdr a) (+ count 1))))
171 ; Join two lists together
175 (cons (car l1) (join (cdr l1) l2))))
177 ; Append an arbitrary number of lists together
178 (define (append . lists)
181 (if (null? (cdr lists))
183 (join (car lists) (apply append (cdr lists))))))
185 ; Reverse the contents of a list
189 (append (reverse (cdr l)) (list (car l)))))
192 ;; LIBRARY SPECIAL FORMS
196 (define (let-vars args)
199 (cons (caar args) (let-vars (cdr args)))))
201 (define (let-inits args)
204 (cons (cadar args) (let-inits (cdr args)))))
206 (define-macro (let args . body)
207 `((lambda ,(let-vars args)
208 ,@body) ,@(let-inits args)))
212 (define-macro (while condition . body)
213 (let ((loop (gensym)))
217 (begin ,@body (,loop))))
222 (define (cond-predicate clause) (car clause))
223 (define (cond-actions clause) (cdr clause))
224 (define (cond-else-clause? clause)
225 (eq? (cond-predicate clause) 'else))
227 (define (expand-clauses clauses)
230 (let ((first (car clauses))
231 (rest (cdr clauses)))
232 (if (cond-else-clause? first)
234 `(begin ,@(cond-actions first))
235 (error "else clause isn't last in cond expression."))
236 `(if ,(cond-predicate first)
237 (begin ,@(cond-actions first))
238 ,(expand-clauses rest))))))
240 (define-macro (cond . clauses)
242 (error "cond requires at least one clause.")
243 (expand-clauses clauses)))
247 (define (expand-and-expressions expressions)
248 (let ((first (car expressions))
249 (rest (cdr expressions)))
253 ,(expand-and-expressions rest)
256 (define-macro (and . expressions)
257 (if (null? expressions)
259 (expand-and-expressions expressions)))
263 (define (expand-or-expressions expressions)
264 (if (null? expressions)
266 (let ((first (car expressions))
267 (rest (cdr expressions))
269 `(let ((,val ,first))
272 ,(expand-or-expressions rest))))))
274 (define-macro (or . expressions)
275 (expand-or-expressions expressions))
280 (define-macro (backwards . body)
281 (cons 'begin (reverse body)))
283 ; Test for the while macro.
287 (display counter) (newline)
288 (set! counter (- counter 1))))
290 ; Basic iterative summation. Run this on large numbers to
291 ; test garbage collection and tail-call optimization.
294 (define (sum-iter total count maxcount)
295 (if (> count maxcount)
297 (sum-iter (+ total count) (+ count 1) maxcount)))
301 ; Recursive summation. Use this to compare with tail call
302 ; optimized iterative algorithm.
303 (define (sum-recurse n)
306 (+ n (sum-recurse (- n 1)))))