;; Standard Library Procedures and Macros ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; MISC ESSENTIAL PROCEDURES
-
-(define list
- (lambda args args))
-
-(define map
- (lambda (proc l)
- (if (null? l)
- '()
- (cons (proc (car l)) (map proc (cdr l))))))
-
-(define join-lists
- (lambda (l1 l2)
- (if (null? l1)
- l2
- (cons (car l1) (join-lists (cdr l1) l2)))))
-
-; Append an arbitrary number of lists together
-(define append
- (lambda lists
- (if (null? lists)
- ()
- (if (null? (cdr lists))
- (car lists)
- (join-lists (car lists) (apply append (cdr lists)))))))
-
-
-;; DERIVED FORMS
-
-;; define
-
-(define-macro (define args . body)
- (if (pair? args)
- (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
- 'no-match))
-
-;; not
-
-(define-macro (not x)
- (list 'if x #f #t))
-
-;; let
-
-(define-macro (let args . body)
- (join-lists
- (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
- (map (lambda (x) (car (cdr x))) args)))
-
-;; quasiquote/unquote (one nesting level only)
-
-((lambda ()
- (define (qqhelper l)
- (if (null? l)
- l
- (let ((head (car l))
- (tail (cdr l)))
-
- (if (pair? head)
- (if (eq? (car head) 'unquote)
- (list 'cons (car (cdr head)) (qqhelper tail))
- (if (eq? (car head) 'unquote-splicing)
- (list 'join-lists (car (cdr head)) (qqhelper tail))
- (list 'cons (list 'quasiquote head) (qqhelper tail))))
- (if (symbol? head)
- (list 'cons (list 'quote head) (qqhelper tail))
- (list 'cons head (qqhelper tail)))))))
-
- (define-macro (quasiquote arg)
- (if (not (pair? arg))
- (list 'quote arg)
- (qqhelper arg)))))
-
-;; begin
-
-(define-macro (begin . sequence)
- `((lambda () ,@sequence)))
-
-;; caddr etc.
-
-(define-macro (caar l) `(car (car ,l)))
-(define-macro (cadr l) `(car (cdr ,l)))
-(define-macro (cdar l) `(cdr (car ,l)))
-(define-macro (cddr l) `(cdr (cdr ,l)))
-(define-macro (caaar l) `(car (car (car ,l))))
-(define-macro (caadr l) `(car (car (cdr ,l))))
-(define-macro (cadar l) `(car (cdr (car ,l))))
-(define-macro (caddr l) `(car (cdr (cdr ,l))))
-(define-macro (cdaar l) `(cdr (car (car ,l))))
-(define-macro (cdadr l) `(cdr (car (cdr ,l))))
-(define-macro (cddar l) `(cdr (cdr (car ,l))))
-(define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
-(define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
-
-;; let*
-
-(define-macro (let* args . body)
- (if (null? args)
- `(let () ,@body)
- `(let (,(car args))
- (let* ,(cdr args) ,@body))))
-
-;; while
-
-(define-macro (while condition . body)
- (let ((loop (gensym)))
- `(begin
- (define (,loop)
- (if ,condition
- (begin ,@body (,loop))))
- (,loop))))
-
-;; cond
-
-((lambda ()
- (define (cond-predicate clause) (car clause))
- (define (cond-actions clause) (cdr clause))
- (define (cond-else-clause? clause)
- (eq? (cond-predicate clause) 'else))
-
- (define (expand-clauses clauses)
- (if (null? clauses)
- (none)
- (let ((first (car clauses))
- (rest (cdr clauses)))
- (if (cond-else-clause? first)
- (if (null? rest)
- `(begin ,@(cond-actions first))
- (error "else clause isn't last in cond expression."))
- `(if ,(cond-predicate first)
- (begin ,@(cond-actions first))
- ,(expand-clauses rest))))))
-
- (define-macro (cond . clauses)
- (if (null? clauses)
- (error "cond requires at least one clause.")
- (expand-clauses clauses)))))
-
-;; and
-
-((lambda ()
- (define (expand-and-expressions expressions)
- (let ((first (car expressions))
- (rest (cdr expressions)))
- (if (null? rest)
- first
- `(if ,first
- ,(expand-and-expressions rest)
- #f))))
-
- (define-macro (and . expressions)
- (if (null? expressions)
- #t
- (expand-and-expressions expressions)))))
-
-;; or
-
-((lambda ()
- (define (expand-or-expressions expressions)
- (let ((first (car expressions))
- (rest (cdr expressions)))
- (if (null? rest)
- first
- `(if ,first
- #t
- ,(expand-or-expressions rest)))))
-
- (define-macro (or . expressions)
- (if (null? expressions)
- #f
- (expand-or-expressions expressions)))))
-
-;; FUNCTIONAL PROGRAMMING
-
-(define (fold-left proc init l)
- (if (null? l)
- init
- (fold-left proc (proc init (car l)) (cdr l))))
-
-(define (reduce-left proc init l)
- (if (null? l)
- init
- (if (null? (cdr l))
- (car l)
- (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
-
-
-;; NUMBERS
-
-; Rational primitives
-
-(define (numerator x)
- (if (ratnum? x)
- (rat:numerator x)
- x))
-
-(define (denominator x)
- (if (ratnum? x)
- (rat:denominator x)
- (if (fixnum? x)
- 1
- 1.0)))
-
-(define (rat:+ x y)
- (make-rational (fix:+ (fix:* (numerator x) (denominator y))
- (fix:* (denominator x) (numerator y)))
- (fix:* (denominator x) (denominator y))))
-
-(define (rat:- x y)
- (make-rational (fix:- (fix:* (numerator x) (denominator y))
- (fix:* (denominator x) (numerator y)))
- (fix:* (denominator x) (denominator y))))
-
-(define (rat:* x y)
- (make-rational (fix:* (numerator x) (numerator y))
- (fix:* (denominator x) (denominator y))))
-
-(define (rat:/ x y)
- (make-rational (fix:* (numerator x) (denominator y))
- (fix:* (denominator x) (numerator y))))
-
-(define (rat:1/ x)
- (make-rational (denominator x) (numerator x)))
-
-; Type dispatch and promotion
-
-(define (type-dispatch ops x)
- (if (flonum? x)
- ((cdr ops) x)
- ((car ops) x)))
-
-(define (promote-dispatch ops x y)
- (if (flonum? x)
- (if (flonum? y)
- ((cdr ops) x y)
- ((cdr ops) x (fixnum->flonum y)))
- (if (flonum? y)
- ((cdr ops) (fixnum->flonum x) y)
- ((car ops) x y))))
-
-; Unary ops
-
-(define (neg x)
- (type-dispatch (cons fix:neg flo:neg) x))
-
-(define (abs x)
- (type-dispatch (cons fix:abs flo:abs) x))
-
-(define (flo:1+ x) (flo:+ x 1.0))
-(define (flo:1- x) (flo:- x 1.0))
-
-(define (1+ n)
- (type-dispatch (cons fix:1+ flo:1+) n))
-
-(define (1- n)
- (type-dispatch (cons fix:1- flo:1-) n))
-
-(define (apply-to-flonum op x)
- (if (flonum? x) (op x) x))
-
-(define (round x)
- (apply-to-flonum flo:round x))
-(define (floor x)
- (apply-to-flonum flo:floor x))
-(define (ceiling x)
- (apply-to-flonum flo:ceiling x))
-(define (truncate x)
- (apply-to-flonum flo:truncate x))
-
-; Binary operations
-
-(define (fix:/ x y) ; Non-standard definition while we don't have rationals
- (if (fix:= 0 (fix:remainder x y))
- (fix:quotient x y)
- (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
-
-(define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
-(define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
-(define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
-(define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
-
-(define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
-(define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
-(define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
-(define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
-(define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
-
-(define (null? arg)
- (eq? arg '()))
-
-(define (+ . args)
- (fold-left pair+ 0 args))
-
-(define (- first . rest)
- (if (null? rest)
- (neg first)
- (pair- first (apply + rest))))
-
-(define (* . args)
- (fold-left pair* 1 args))
-
-(define (/ first . rest)
- (if (null? rest)
- (pair/ 1 first)
- (pair/ first (apply * rest))))
-
-(define (quotient n1 n2)
- (fix:quotient n1 n2))
-
-(define (remainder n1 n2)
- (fix:remainder n1 n2))
-
-(define modulo remainder)
-
-; Relations
-
-(define (test-relation rel l)
- (if (null? l)
- #t
- (if (null? (cdr l))
- #t
- (if (rel (car l) (car (cdr l)))
- (test-relation rel (cdr l))
- #f))))
-
-(define (= . args)
- (test-relation pair= args))
-
-(define (> . args)
- (test-relation pair> args))
-
-(define (< . args)
- (test-relation pair< args))
-
-(define (>= . args)
- (test-relation pair>= args))
-
-(define (<= . args)
- (test-relation pair<= args))
-
-; Numeric tests
-
-(define (zero? x) (pair= x 0.0))
-(define (positive x) (pair> x 0.0))
-(define (odd? n) (pair= (remainder n 2) 0))
-(define (odd? n) (not (pair= (remainder n 2) 0)))
-
-
-; Current state of the numerical tower
-(define (complex? x) #f)
-(define (real? x) #t)
-(define (rational? x) #t)
-(define (integer? x) (= x (round x)))
-(define (exact? x) (fixnum? x))
-(define (inexact? x) (flonum? x))
-(define (number? x)
- (if (fixnum? x) #t
- (if (flonum? x) #t
- (if (ratnum? x) #t #f))))
-
-
-;; LISTS
-
-; Return number of items in list
-(define (length l)
- (define (iter a count)
- (if (null? a)
- count
- (iter (cdr a) (fix:+ count 1))))
- (iter l 0))
-
-; Reverse the contents of a list
-(define (reverse l)
- (if (null? l)
- ()
- (append (reverse (cdr l)) (list (car l)))))
-
-
-;; TESTING
-
-; Test for the while macro.
-(define (count)
- (define counter 10)
- (while (> counter 0)
- (display counter) (newline)
- (set! counter (- counter 1))))
-
-; Basic iterative summation. Run this on large numbers to
-; test garbage collection and tail-call optimization.
-(define (sum n)
-
- (define (sum-iter total count maxcount)
- (if (fix:> count maxcount)
- total
- (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
-
- (sum-iter 0 1 n))
-
-; Recursive summation. Use this to compare with tail call
-; optimized iterative algorithm.
-(define (sum-recurse n)
- (if (fix:= n 0)
- 0
- (fix:+ n (sum-recurse (fix:- n 1)))))
-
+(load "scheme-library-1-essential.scm")
+(load "scheme-library-2-derived-forms.scm")
+;(load "scheme-library-3-functional.scm")
+;(load "scheme-library-4-numbers.scm")
+;(load "scheme-library-5-lists.scm")
+;(load "scheme-library-6-testing.scm")
;; MISC
The Lambda Lab / projects / scheme.forth.jl.git / blobdiff