3 ;; define (procedural syntax)
5 (define-macro (define args . body)
7 `(define ,(car args) (lambda ,(cdr args) ,@body))
12 (define-macro (begin . sequence)
13 `((lambda () ,@sequence)))
17 (define-macro (caar l) `(car (car ,l)))
18 (define-macro (cadr l) `(car (cdr ,l)))
19 (define-macro (cdar l) `(cdr (car ,l)))
20 (define-macro (cddr l) `(cdr (cdr ,l)))
21 (define-macro (caaar l) `(car (car (car ,l))))
22 (define-macro (caadr l) `(car (car (cdr ,l))))
23 (define-macro (cadar l) `(car (cdr (car ,l))))
24 (define-macro (caddr l) `(car (cdr (cdr ,l))))
25 (define-macro (cdaar l) `(cdr (car (car ,l))))
26 (define-macro (cdadr l) `(cdr (car (cdr ,l))))
27 (define-macro (cddar l) `(cdr (cdr (car ,l))))
28 (define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
29 (define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
32 ;; Methods used in remaining macro definitions:
37 (cons (proc (car l)) (map proc (cdr l)))))
41 (define-macro (let args . body)
42 `((lambda ,(map (lambda (x) (car x)) args)
43 ,@body) ,@(map (lambda (x) (cadr x)) args)))
47 (define-macro (let* args . body)
51 (let* ,(cdr args) ,@body))))
55 (define-macro (while condition . body)
56 (let ((loop (gensym)))
60 (begin ,@body (,loop))))
66 (define (cond-predicate clause) (car clause))
67 (define (cond-actions clause) (cdr clause))
68 (define (cond-else-clause? clause)
69 (eq? (cond-predicate clause) 'else))
71 (define (expand-clauses clauses)
74 (let ((first (car clauses))
76 (if (cond-else-clause? first)
78 `(begin ,@(cond-actions first))
79 (error "else clause isn't last in cond expression."))
80 `(if ,(cond-predicate first)
81 (begin ,@(cond-actions first))
82 ,(expand-clauses rest))))))
84 (define-macro (cond . clauses)
86 (error "cond requires at least one clause.")
87 (expand-clauses clauses)))))
92 (define (expand-and-expressions expressions)
93 (let ((first (car expressions))
94 (rest (cdr expressions)))
98 ,(expand-and-expressions rest)
101 (define-macro (and . expressions)
102 (if (null? expressions)
104 (expand-and-expressions expressions)))
110 (define (expand-or-expressions expressions)
111 (if (null? expressions)
113 (let ((first (car expressions))
114 (rest (cdr expressions))
116 `(let ((,val ,first))
119 ,(expand-or-expressions rest))))))
121 (define-macro (or . expressions)
122 (expand-or-expressions expressions))
126 ;; FUNCTIONAL PROGRAMMING
128 (define (fold-left proc init l)
131 (fold-left proc (proc init (car l)) (cdr l))))
133 (define (reduce-left proc init l)
138 (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
143 ; Rational primitives
145 (define (numerator x)
150 (define (denominator x)
158 (make-rational (fix:+ (fix:* (numerator x) (denominator y))
159 (fix:* (denominator x) (numerator y)))
160 (fix:* (denominator x) (denominator y))))
163 (make-rational (fix:- (fix:* (numerator x) (denominator y))
164 (fix:* (denominator x) (numerator y)))
165 (fix:* (denominator x) (denominator y))))
168 (make-rational (fix:* (numerator x) (numerator y))
169 (fix:* (denominator x) (denominator y))))
172 (make-rational (fix:* (numerator x) (denominator y))
173 (fix:* (denominator x) (numerator y))))
176 (make-rational (denominator x) (numerator x)))
178 ; Type dispatch and promotion
180 (define (type-dispatch ops x)
185 (define (promote-dispatch ops x y)
189 ((cdr ops) x (fixnum->flonum y)))
191 ((cdr ops) (fixnum->flonum x) y)
197 (type-dispatch (cons fix:neg flo:neg) x))
200 (type-dispatch (cons fix:abs flo:abs) x))
202 (define (flo:1+ x) (flo:+ x 1.0))
203 (define (flo:1- x) (flo:- x 1.0))
206 (type-dispatch (cons fix:1+ flo:1+) n))
209 (type-dispatch (cons fix:1- flo:1-) n))
211 (define (apply-to-flonum op x)
212 (if (flonum? x) (op x) x))
215 (apply-to-flonum flo:round x))
217 (apply-to-flonum flo:floor x))
219 (apply-to-flonum flo:ceiling x))
221 (apply-to-flonum flo:truncate x))
225 (define (fix:/ x y) ; Non-standard definition while we don't have rationals
226 (if (fix:= 0 (fix:remainder x y))
228 (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
230 (define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
231 (define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
232 (define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
233 (define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
235 (define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
236 (define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
237 (define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
238 (define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
239 (define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
245 (fold-left pair+ 0 args))
247 (define (- first . rest)
250 (pair- first (apply + rest))))
253 (fold-left pair* 1 args))
255 (define (/ first . rest)
258 (pair/ first (apply * rest))))
260 (define (quotient n1 n2)
261 (fix:quotient n1 n2))
263 (define (remainder n1 n2)
264 (fix:remainder n1 n2))
266 (define modulo remainder)
270 (define (test-relation rel l)
275 (if (rel (car l) (car (cdr l)))
276 (test-relation rel (cdr l))
280 (test-relation pair= args))
283 (test-relation pair> args))
286 (test-relation pair< args))
289 (test-relation pair>= args))
292 (test-relation pair<= args))
296 (define (zero? x) (pair= x 0.0))
297 (define (positive x) (pair> x 0.0))
298 (define (odd? n) (pair= (remainder n 2) 0))
299 (define (odd? n) (not (pair= (remainder n 2) 0)))
302 ; Current state of the numerical tower
303 (define (complex? x) #f)
304 (define (real? x) #t)
305 (define (rational? x) #t)
306 (define (integer? x) (= x (round x)))
307 (define (exact? x) (fixnum? x))
308 (define (inexact? x) (flonum? x))
312 (if (ratnum? x) #t #f))))
317 ; Return number of items in list
319 (define (iter a count)
322 (iter (cdr a) (fix:+ count 1))))
325 ; Join two lists together
329 (cons (car l1) (join (cdr l1) l2))))
331 ; Append an arbitrary number of lists together
332 (define (append . lists)
335 (if (null? (cdr lists))
337 (join (car lists) (apply append (cdr lists))))))
339 ; Reverse the contents of a list
343 (append (reverse (cdr l)) (list (car l)))))
348 ; Test for the while macro.
352 (display counter) (newline)
353 (set! counter (- counter 1))))
355 ; Basic iterative summation. Run this on large numbers to
356 ; test garbage collection and tail-call optimization.
359 (define (sum-iter total count maxcount)
360 (if (fix:> count maxcount)
362 (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
366 ; Recursive summation. Use this to compare with tail call
367 ; optimized iterative algorithm.
368 (define (sum-recurse n)
371 (fix:+ n (sum-recurse (fix:- n 1)))))
379 "This program is free software; you can redistribute it and/or modify
380 it under the terms of the GNU General Public License as published by
381 the Free Software Foundation; either version 3 of the License, or
382 (at your option) any later version.
384 This program is distributed in the hope that it will be useful,
385 but WITHOUT ANY WARRANTY; without even the implied warranty of
386 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
387 GNU General Public License for more details.
389 You should have received a copy of the GNU General Public License
390 along with this program. If not, see http://www.gnu.org/licenses/.
395 "Welcome to scheme.forth.jl!
397 Copyright (C) 2016 Tim Vaughan.
398 This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'.