prims.lisp (3172 bytes)
1 ;;; prims.lisp -- the chip Scheme's arithmetic and type primitives, in the host dialect. 2 ;;; host.lisp compiles each defun to a Mecrisp Forth word and sends it to the chip, where 3 ;;; lisp.fs registers it with defprim. A primitive takes its argument list (a chip list) 4 ;;; and returns one tagged value. car cdr cons fix num bool pair? sym? proc? fixnum? err 5 ;;; are words from lisp.fs; + - * / mod negate xor = < > are Forth. 6 7 ;; Generic arithmetic: add2 sub2 mul2 div2 lt2 eq2 (lisp.fs) handle fixnums, rationals and 8 ;; flonums. The accumulators here are tagged values: 1 is the fixnum 0, 3 is the fixnum 1. 9 (defun sum (l acc) (if (= l 0) acc (sum (cdr l) (add2 acc (car l))))) 10 (defun prod (l acc) (if (= l 0) acc (prod (cdr l) (mul2 acc (car l))))) 11 (defun diff (l acc) (if (= l 0) acc (diff (cdr l) (sub2 acc (car l))))) 12 (defun quo (l acc) (if (= l 0) acc (quo (cdr l) (div2 acc (car l))))) 13 (defun prim+ (a) (sum a 1)) 14 (defun prim* (a) (prod a 3)) 15 (defun prim- (a) (if (= (cdr a) 0) (sub2 1 (car a)) (diff (cdr a) (car a)))) 16 (defun prim/ (a) (if (= (cdr a) 0) (div2 3 (car a)) (quo (cdr a) (car a)))) 17 (defun divisor (a) (if (= (num (car (cdr a))) 0) (forth "s\" division by zero\" err") (num (car (cdr a))))) 18 (defun prim-quotient (a) (fix (/ (num (car a)) (divisor a)))) 19 (defun prim-remainder (a) (fix (mod (num (car a)) (divisor a)))) 20 (defun floored (r y) (if (if (= r 0) 0 (< (xor r y) 0)) (+ r y) r)) 21 (defun prim-modulo (a) (fix (floored (mod (num (car a)) (divisor a)) (num (car (cdr a)))))) 22 23 ;; Comparison chains: (< 1 2 3) is #t. Each returns a Forth flag for bool. 24 (defun chain= (l) (if (= (cdr l) 0) -1 (if (eq2 (car l) (car (cdr l))) (chain= (cdr l)) 0))) 25 (defun chain< (l) (if (= (cdr l) 0) -1 (if (lt2 (car l) (car (cdr l))) (chain< (cdr l)) 0))) 26 (defun chain> (l) (if (= (cdr l) 0) -1 (if (lt2 (car (cdr l)) (car l)) (chain> (cdr l)) 0))) 27 (defun chain<= (l) (if (= (cdr l) 0) -1 (if (lt2 (car (cdr l)) (car l)) 0 (chain<= (cdr l))))) 28 (defun chain>= (l) (if (= (cdr l) 0) -1 (if (lt2 (car l) (car (cdr l))) 0 (chain>= (cdr l))))) 29 (defun prim= (a) (bool (chain= a))) 30 (defun prim< (a) (bool (chain< a))) 31 (defun prim> (a) (bool (chain> a))) 32 (defun prim<= (a) (bool (chain<= a))) 33 (defun prim>= (a) (bool (chain>= a))) 34 35 (defun prim-eq (a) (bool (= (car a) (car (cdr a))))) 36 (defun prim-car (a) (car (pair (car a)))) 37 (defun prim-cdr (a) (cdr (pair (car a)))) 38 (defun prim-cons (a) (cons (car a) (car (cdr a)))) 39 (defun prim-null (a) (bool (= (car a) 0))) 40 (defun prim-pair (a) (bool (pair? (car a)))) 41 (defun prim-symbol (a) (bool (sym? (car a)))) 42 (defun prim-procedure (a) (bool (proc? (car a)))) 43 (defun prim-boolean (a) (bool (if (= (car a) (forth "#t")) -1 (= (car a) (forth "#f"))))) 44 45 ;; (name forth-word): what defprim registers. Values are tagged words, so eq? and eqv? agree. 46 (defprims (+ prim+) (- prim-) (* prim*) (/ prim/) (quotient prim-quotient) (remainder prim-remainder) 47 (modulo prim-modulo) (= prim=) (< prim<) (> prim>) (<= prim<=) (>= prim>=) 48 (eq? prim-eq) (car prim-car) (cdr prim-cdr) (cons prim-cons) 49 (null? prim-null) (pair? prim-pair) (symbol? prim-symbol) 50 (procedure? prim-procedure) (boolean? prim-boolean))