1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; Standard Library Procedures and Macros ;;
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5 ;; MISC ESSENTIAL PROCEDURES
14 (cons (proc (car l)) (map proc (cdr l))))))
20 (cons (car l1) (join-lists (cdr l1) l2)))))
22 ; Append an arbitrary number of lists together
27 (if (null? (cdr lists))
29 (join-lists (car lists) (apply append (cdr lists)))))))
36 (define-macro (define args . body)
38 (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
48 (define-macro (let args . body)
50 (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
51 (map (lambda (x) (car (cdr x))) args)))
53 ;; quasiquote/unquote (one nesting level only)
63 (if (eq? (car head) 'unquote)
64 (list 'cons (car (cdr head)) (qqhelper tail))
65 (if (eq? (car head) 'unquote-splicing)
66 (list 'join-lists (car (cdr head)) (qqhelper tail))
67 (list 'cons (list 'quasiquote head) (qqhelper tail))))
69 (list 'cons (list 'quote head) (qqhelper tail))
70 (list 'cons head (qqhelper tail)))))))
72 (define-macro (quasiquote arg)
79 (define-macro (begin . sequence)
80 `((lambda () ,@sequence)))
84 (define-macro (caar l) `(car (car ,l)))
85 (define-macro (cadr l) `(car (cdr ,l)))
86 (define-macro (cdar l) `(cdr (car ,l)))
87 (define-macro (cddr l) `(cdr (cdr ,l)))
88 (define-macro (caaar l) `(car (car (car ,l))))
89 (define-macro (caadr l) `(car (car (cdr ,l))))
90 (define-macro (cadar l) `(car (cdr (car ,l))))
91 (define-macro (caddr l) `(car (cdr (cdr ,l))))
92 (define-macro (cdaar l) `(cdr (car (car ,l))))
93 (define-macro (cdadr l) `(cdr (car (cdr ,l))))
94 (define-macro (cddar l) `(cdr (cdr (car ,l))))
95 (define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
96 (define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
100 (define-macro (let* args . body)
104 (let* ,(cdr args) ,@body))))
108 (define-macro (while condition . body)
109 (let ((loop (gensym)))
113 (begin ,@body (,loop))))
119 (define (cond-predicate clause) (car clause))
120 (define (cond-actions clause) (cdr clause))
121 (define (cond-else-clause? clause)
122 (eq? (cond-predicate clause) 'else))
124 (define (expand-clauses clauses)
127 (let ((first (car clauses))
128 (rest (cdr clauses)))
129 (if (cond-else-clause? first)
131 `(begin ,@(cond-actions first))
132 (error "else clause isn't last in cond expression."))
133 `(if ,(cond-predicate first)
134 (begin ,@(cond-actions first))
135 ,(expand-clauses rest))))))
137 (define-macro (cond . clauses)
139 (error "cond requires at least one clause.")
140 (expand-clauses clauses)))))
145 (define (expand-and-expressions expressions)
146 (let ((first (car expressions))
147 (rest (cdr expressions)))
151 ,(expand-and-expressions rest)
154 (define-macro (and . expressions)
155 (if (null? expressions)
157 (expand-and-expressions expressions)))))
162 (define (expand-or-expressions expressions)
163 (let ((first (car expressions))
164 (rest (cdr expressions)))
169 ,(expand-or-expressions rest)))))
171 (define-macro (or . expressions)
172 (if (null? expressions)
174 (expand-or-expressions expressions)))))
176 ;; FUNCTIONAL PROGRAMMING
178 (define (fold-left proc init l)
181 (fold-left proc (proc init (car l)) (cdr l))))
183 (define (reduce-left proc init l)
188 (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
193 ; Rational primitives
195 (define (numerator x)
200 (define (denominator x)
208 (make-rational (fix:+ (fix:* (numerator x) (denominator y))
209 (fix:* (denominator x) (numerator y)))
210 (fix:* (denominator x) (denominator y))))
213 (make-rational (fix:- (fix:* (numerator x) (denominator y))
214 (fix:* (denominator x) (numerator y)))
215 (fix:* (denominator x) (denominator y))))
218 (make-rational (fix:* (numerator x) (numerator y))
219 (fix:* (denominator x) (denominator y))))
222 (make-rational (fix:* (numerator x) (denominator y))
223 (fix:* (denominator x) (numerator y))))
226 (make-rational (denominator x) (numerator x)))
228 ; Type dispatch and promotion
230 (define (type-dispatch ops x)
235 (define (promote-dispatch ops x y)
239 ((cdr ops) x (fixnum->flonum y)))
241 ((cdr ops) (fixnum->flonum x) y)
247 (type-dispatch (cons fix:neg flo:neg) x))
250 (type-dispatch (cons fix:abs flo:abs) x))
252 (define (flo:1+ x) (flo:+ x 1.0))
253 (define (flo:1- x) (flo:- x 1.0))
256 (type-dispatch (cons fix:1+ flo:1+) n))
259 (type-dispatch (cons fix:1- flo:1-) n))
261 (define (apply-to-flonum op x)
262 (if (flonum? x) (op x) x))
265 (apply-to-flonum flo:round x))
267 (apply-to-flonum flo:floor x))
269 (apply-to-flonum flo:ceiling x))
271 (apply-to-flonum flo:truncate x))
275 (define (fix:/ x y) ; Non-standard definition while we don't have rationals
276 (if (fix:= 0 (fix:remainder x y))
278 (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
280 (define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
281 (define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
282 (define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
283 (define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
285 (define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
286 (define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
287 (define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
288 (define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
289 (define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
295 (fold-left pair+ 0 args))
297 (define (- first . rest)
300 (pair- first (apply + rest))))
303 (fold-left pair* 1 args))
305 (define (/ first . rest)
308 (pair/ first (apply * rest))))
310 (define (quotient n1 n2)
311 (fix:quotient n1 n2))
313 (define (remainder n1 n2)
314 (fix:remainder n1 n2))
316 (define modulo remainder)
320 (define (test-relation rel l)
325 (if (rel (car l) (car (cdr l)))
326 (test-relation rel (cdr l))
330 (test-relation pair= args))
333 (test-relation pair> args))
336 (test-relation pair< args))
339 (test-relation pair>= args))
342 (test-relation pair<= args))
346 (define (zero? x) (pair= x 0.0))
347 (define (positive x) (pair> x 0.0))
348 (define (odd? n) (pair= (remainder n 2) 0))
349 (define (odd? n) (not (pair= (remainder n 2) 0)))
352 ; Current state of the numerical tower
353 (define (complex? x) #f)
354 (define (real? x) #t)
355 (define (rational? x) #t)
356 (define (integer? x) (= x (round x)))
357 (define (exact? x) (fixnum? x))
358 (define (inexact? x) (flonum? x))
362 (if (ratnum? x) #t #f))))
367 ; Return number of items in list
369 (define (iter a count)
372 (iter (cdr a) (fix:+ count 1))))
375 ; Reverse the contents of a list
379 (append (reverse (cdr l)) (list (car l)))))
384 ; Test for the while macro.
388 (display counter) (newline)
389 (set! counter (- counter 1))))
391 ; Basic iterative summation. Run this on large numbers to
392 ; test garbage collection and tail-call optimization.
395 (define (sum-iter total count maxcount)
396 (if (fix:> count maxcount)
398 (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
402 ; Recursive summation. Use this to compare with tail call
403 ; optimized iterative algorithm.
404 (define (sum-recurse n)
407 (fix:+ n (sum-recurse (fix:- n 1)))))
414 "This program is free software; you can redistribute it and/or modify
415 it under the terms of the GNU General Public License as published by
416 the Free Software Foundation; either version 3 of the License, or
417 (at your option) any later version.
419 This program is distributed in the hope that it will be useful,
420 but WITHOUT ANY WARRANTY; without even the implied warranty of
421 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
422 GNU General Public License for more details.
424 You should have received a copy of the GNU General Public License
425 along with this program. If not, see http://www.gnu.org/licenses/.
430 "Welcome to scheme.forth.jl!
432 Copyright (C) 2016 Tim Vaughan.
433 This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'.