prelude.scm (4708 bytes)
1 ; prelude.scm -- the rest of the Z80 Scheme, written in Scheme; loaded one form per line. 2 ; Derived syntax is define-macro over lists; each expansion replaces its call form in place. 3 (define (caar x) (car (car x))) 4 (define (cdar x) (cdr (car x))) 5 (define (cadr x) (car (cdr x))) 6 (define (cddr x) (cdr (cdr x))) 7 (define (caddr x) (car (cddr x))) 8 (define (cdddr x) (cdr (cddr x))) 9 (define (zero? n) (= n 0)) 10 (define (positive? n) (> n 0)) 11 (define (negative? n) (< n 0)) 12 (define (even? n) (= (remainder n 2) 0)) 13 (define (odd? n) (not (even? n))) 14 (define (abs n) (if (< n 0) (- n) n)) 15 (define (square x) (* x x)) 16 (define (max x . r) (if (null? r) x (apply max (if (> x (car r)) x (car r)) (cdr r)))) 17 (define (min x . r) (if (null? r) x (apply min (if (< x (car r)) x (car r)) (cdr r)))) 18 (define (gcd2 a b) (if (= b 0) a (gcd2 b (remainder a b)))) 19 (define (gcd . ns) (if (null? ns) 0 (gcd2 (abs (car ns)) (abs (apply gcd (cdr ns)))))) 20 (define (lcm2 a b) (if (= a 0) 0 (if (= b 0) 0 (quotient (* a b) (gcd2 a b))))) 21 (define (lcm . ns) (if (null? ns) 1 (lcm2 (abs (car ns)) (apply lcm (cdr ns))))) 22 (define (sqrt n) (define (lp i) (if (> (* i i) n) (- i 1) (lp (+ i 1)))) (lp 0)) 23 (define (floor x) x) 24 (define (symbol=? a b) (eq? a b)) 25 (define (list? l) (if (null? l) #t (if (pair? l) (list? (cdr l)) #f))) 26 (define (length l) (define (lp l n) (if (pair? l) (lp (cdr l) (+ n 1)) n)) (lp l 0)) 27 (define (reverse l) (define (lp l a) (if (null? l) a (lp (cdr l) (cons (car l) a)))) (lp l '())) 28 (define (append2 a b) (define (lp r b) (if (null? r) b (lp (cdr r) (cons (car r) b)))) (lp (reverse a) b)) 29 (define (append . ls) (if (null? ls) '() (if (null? (cdr ls)) (car ls) (append2 (car ls) (apply append (cdr ls)))))) 30 (define (list-tail l k) (if (zero? k) l (list-tail (cdr l) (- k 1)))) 31 (define (list-ref l k) (car (list-tail l k))) 32 (define (memq x l) (if (null? l) #f (if (eq? x (car l)) l (memq x (cdr l))))) 33 (define (memv x l) (if (null? l) #f (if (eqv? x (car l)) l (memv x (cdr l))))) 34 (define (member x l) (if (null? l) #f (if (equal? x (car l)) l (member x (cdr l))))) 35 (define (assq x l) (if (null? l) #f (if (eq? x (caar l)) (car l) (assq x (cdr l))))) 36 (define (assv x l) (if (null? l) #f (if (eqv? x (caar l)) (car l) (assv x (cdr l))))) 37 (define (assoc x l) (if (null? l) #f (if (equal? x (caar l)) (car l) (assoc x (cdr l))))) 38 (define (map1 f l) (if (null? l) '() (cons (f (car l)) (map1 f (cdr l))))) 39 (define (map f . ls) (if (null? (cdr ls)) (map1 f (car ls)) (if (null? (car ls)) '() (cons (apply f (map1 car ls)) (apply map f (map1 cdr ls)))))) 40 (define (for-each f l) (if (null? l) #t (begin (f (car l)) (for-each f (cdr l))))) 41 (define (list-copy l) (map1 (lambda (x) x) l)) 42 (define (make-list n x) (if (zero? n) '() (cons x (make-list (- n 1) x)))) 43 (define-macro when (lambda (f) (list 'if (cadr f) (cons 'begin (cddr f))))) 44 (define-macro unless (lambda (f) (list 'if (list 'not (cadr f)) (cons 'begin (cddr f))))) 45 (define (named-let f) (list (list 'lambda '() (list 'define (cadr f) (cons 'lambda (cons (map1 car (caddr f)) (cdddr f)))) (cons (cadr f) (map1 cadr (caddr f)))))) 46 (define-macro let (lambda (f) (if (symbol? (cadr f)) (named-let f) (cons (cons 'lambda (cons (map1 car (cadr f)) (cddr f))) (map1 cadr (cadr f)))))) 47 (define-macro let* (lambda (f) (if (null? (cadr f)) (cons 'let (cons '() (cddr f))) (list 'let (list (car (cadr f))) (cons 'let* (cons (cdr (cadr f)) (cddr f))))))) 48 (define (letrec-x f) (list (cons 'lambda (cons '() (append (map1 (lambda (b) (cons 'define b)) (cadr f)) (cddr f)))))) 49 (define-macro letrec letrec-x) 50 (define-macro letrec* letrec-x) 51 (define-macro and (lambda (f) (if (null? (cdr f)) #t (if (null? (cddr f)) (cadr f) (list 'if (cadr f) (cons 'and (cddr f)) #f))))) 52 (define-macro or (lambda (f) (if (null? (cdr f)) #f (if (null? (cddr f)) (cadr f) (list 'let (list (list '%t (cadr f))) (list 'if '%t '%t (cons 'or (cddr f)))))))) 53 (define (cond1 c r) (if (eq? (car c) 'else) (cons 'begin (cdr c)) (if (null? (cdr c)) (list 'or (car c) r) (if (eq? (cadr c) '=>) (list 'let (list (list '%c (car c))) (list 'if '%c (list (caddr c) '%c) r)) (list 'if (car c) (cons 'begin (cdr c)) r))))) 54 (define-macro cond (lambda (f) (if (null? (cdr f)) (list 'if #f #f) (cond1 (cadr f) (cons 'cond (cddr f)))))) 55 (define-macro case (lambda (f) (list 'let (list (list '%k (cadr f))) (cons 'cond (map1 (lambda (c) (if (eq? (car c) 'else) c (cons (list 'memv '%k (list 'quote (car c))) (cdr c)))) (cddr f)))))) 56 (define-macro do (lambda (f) (list 'let '%do (map1 (lambda (b) (list (car b) (cadr b))) (cadr f)) (list 'if (car (caddr f)) (cons 'begin (cdr (caddr f))) (append (cons 'begin (cdddr f)) (list (cons '%do (map1 (lambda (b) (if (null? (cddr b)) (car b) (caddr b))) (cadr f)))))))))