scsh-0.6/scheme/vm/arith.scm

135 lines
4.1 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Arithmetic that checks for overflow
(define (carefully op)
(lambda (x y succ fail)
(let ((z (op (extract-fixnum x) (extract-fixnum y))))
(if (or (too-big-for-fixnum? z)
(too-small-for-fixnum? z))
(goto fail x y)
(goto succ (enter-fixnum z))))))
(define add-carefully (carefully +))
(define subtract-carefully (carefully -))
(define half-word-size (quotient bits-per-cell 2))
(define half-word-mask (- (shift-left 1 half-word-size) 1))
(define max-middle (shift-left 1 (- (- bits-per-fixnum 1) half-word-size)))
; Uses SMALL* to do half-word multiplies. Some implementations
; really care about this.
(define (multiply-carefully x y succ fail)
(let* ((a (extract-fixnum x))
(b (extract-fixnum y))
(positive-result? (if (>= a 0)
(>= b 0)
(< b 0)))
(a (abs a))
(b (abs b))
(lo-a (bitwise-and half-word-mask a))
(lo-b (bitwise-and half-word-mask b))
(hi-a (bitwise-and half-word-mask (high-bits a half-word-size)))
(hi-b (bitwise-and half-word-mask (high-bits b half-word-size)))
(lo-c (small* lo-a lo-b))
(mid-c (+ (small* lo-a hi-b) (small* lo-b hi-a)))
(c (+ lo-c (shift-left mid-c half-word-size))))
(cond ((or (and (> hi-a 0) (> hi-b 0))
(too-big-for-fixnum? lo-c)
(> 0 lo-c)
(> mid-c max-middle))
(goto fail x y))
(positive-result?
(if (too-big-for-fixnum? c)
(goto fail x y)
(goto succ (enter-fixnum c))))
(else
(if (too-small-for-fixnum? (- 0 c))
(goto fail x y)
(goto succ (enter-fixnum (- 0 c))))))))
(define small*
(external "SMALL_MULTIPLY" (=> (integer integer) integer) *))
; Test cases for bits-per-cell = 28, bits-per-fixnum = 26
; (do ((i 2 (* i 2))
; (j (* -2 (expt 2 23)) (/ j 2)))
; ((>= j 0) 'ok)
; (write `((* ,i ,j) ?=? ,(* i j)))
; (newline))
(define (divide-carefully x y succ fail)
(if (= y (enter-fixnum 0))
(fail x y)
(let* ((a (extract-fixnum x))
(b (extract-fixnum y))
(positive-result? (if (>= a 0)
(>= b 0)
(< b 0)))
(a (abs a))
(b (abs b))
(c (quotient a b)))
(cond ((not (= 0 (remainder a b)))
(goto fail x y))
((not positive-result?)
(goto succ (enter-fixnum (- 0 c))))
((too-big-for-fixnum? c) ; (divide least-fixnum -1)
(goto fail x y))
(else
(goto succ (enter-fixnum c)))))))
; Watch out for (quotient least-fixnum -1)
(define (quotient-carefully x y succ fail)
(if (= y (enter-fixnum 0))
(fail x y)
(let* ((a (extract-fixnum x))
(b (extract-fixnum y))
(positive-result? (if (>= a 0)
(>= b 0)
(< b 0)))
(a (abs a))
(b (abs b))
(c (quotient a b)))
(cond ((not positive-result?)
(goto succ (enter-fixnum (- 0 c))))
((too-big-for-fixnum? c) ; (quotient least-fixnum -1)
(goto fail x y))
(else
(goto succ (enter-fixnum c)))))))
; Overflow check not necessary
(define (remainder-carefully x y succ fail)
(if (= y (enter-fixnum 0))
(goto fail x y)
(let* ((a (extract-fixnum x))
(b (extract-fixnum y))
(positive-result? (>= a 0))
(a (abs a))
(b (abs b))
(c (remainder a b)))
(goto succ (enter-fixnum (if positive-result? c (- 0 c)))))))
(define (shift-carefully value+tag count+tag succ fail)
(let ((value (extract-fixnum value+tag))
(count (extract-fixnum count+tag)))
(if (< count 0)
(goto succ (enter-fixnum (arithmetic-shift-right value (- 0 count))))
(let ((result (extract-fixnum (enter-fixnum (shift-left value count)))))
(if (and (= value (arithmetic-shift-right result count))
(if (>= value 0)
(>= result 0)
(< result 0)))
(goto succ (enter-fixnum result))
(goto fail value+tag count+tag))))))
; beware of (abs least-fixnum)
(define (abs-carefully n succ fail)
(let ((r (abs (extract-fixnum n))))
(if (too-big-for-fixnum? r)
(goto fail n)
(goto succ (enter-fixnum r)))))