conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* fx+ now signals an error on overflow properly.

This commit is contained in:
Abdulaziz Ghuloum 2007-09-13 19:25:47 -04:00
parent 3facf76eff
commit cb3b0b3edd
6 changed files with 114 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

105
src/ikarus.fixnums.ss
View File

@ -4,16 +4,24 @@
fxremainder fxmodulo fxlogor fxlogand fxlogxor fxsll fxsra fxremainder fxmodulo fxlogor fxlogand fxlogxor fxsll fxsra
fx= fx< fx<= fx> fx>= fx= fx< fx<= fx> fx>=
fx=? fx<? fx<=? fx>? fx>=? fx=? fx<? fx<=? fx>? fx>=?
fixnum->string) fxior fxand fxxor fxnot
fxpositive? fxnegative?
fxeven? fxodd?
fixnum->string
error@fx+)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $chars) (ikarus system $chars)
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $strings) (ikarus system $strings)
(prefix (only (ikarus) fx+) sys:)
(except (ikarus) fxzero? fxadd1 fxsub1 fxlognot fx+ fx- fx* (except (ikarus) fxzero? fxadd1 fxsub1 fxlognot fx+ fx- fx*
fxquotient fxremainder fxmodulo fxlogor fxlogand fxquotient fxremainder fxmodulo fxlogor fxlogand
fxlogxor fxsll fxsra fx= fx< fx<= fx> fx>= fxlogxor fxsll fxsra fx= fx< fx<= fx> fx>=
fx=? fx<? fx<=? fx>? fx>=? fx=? fx<? fx<=? fx>? fx>=?
fxior fxand fxxor fxnot
fxpositive? fxnegative?
fxeven? fxodd?
fixnum->string)) fixnum->string))
(define fxzero? (define fxzero?
@ -41,13 +49,23 @@
(error 'fxlognot "~s is not a fixnum" x)) (error 'fxlognot "~s is not a fixnum" x))
($fxlognot x))) ($fxlognot x)))
(define fxnot
(lambda (x)
(unless (fixnum? x)
(error 'fxnot "~s is not a fixnum" x))
($fxlognot x)))
(define error@fx+
(lambda (x y)
(if (fixnum? x)
(if (fixnum? y)
(error 'fx+ "overflow when adding ~s and ~s" x y)
(error 'fx+ "~s is not a fixnum" y))
(error 'fx+ "~s is not a fixnum" x))))
(define fx+ (define fx+
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (sys:fx+ x y)))
(error 'fx+ "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx+ "~s is not a fixnum" y))
($fx+ x y)))
(define fx- (define fx-
(lambda (x y) (lambda (x y)
@ -145,30 +163,39 @@
(error 'fxmodulo "zero dividend ~s" y)) (error 'fxmodulo "zero dividend ~s" y))
($fxmodulo x y))) ($fxmodulo x y)))
(define fxlogor (define-syntax fxbitop
(lambda (x y) (syntax-rules ()
(unless (fixnum? x) [(_ who $op identity)
(error 'fxlogor "~s is not a fixnum" x)) (case-lambda
(unless (fixnum? y) [(x y)
(error 'fxlogor "~s is not a fixnum" y)) (if (fixnum? x)
($fxlogor x y))) (if (fixnum? y)
($op x y)
(error 'who "~s is not a fixnum" y))
(error 'who "~s is not a fixnum" x))]
[(x y . ls)
(if (fixnum? x)
(if (fixnum? y)
(let f ([a ($op x y)] [ls ls])
(cond
[(pair? ls)
(let ([b ($car ls)])
(if (fixnum? b)
(f ($op a b) ($cdr ls))
(error 'who "~s is not a fixnum" b)))]
[else a]))
(error 'who "~s is not a fixnum" y))
(error 'who "~s is not a fixnum" x))]
[(x) (if (fixnum? x) x (error 'who "~s is not a fixnum" x))]
[() identity])]))
(define fxlogor (fxbitop fxlogor $fxlogor 0))
(define fxlogand (fxbitop fxlogand $fxlogand -1))
(define fxlogxor (fxbitop fxlogxor $fxlogxor 0))
(define fxior (fxbitop fxior $fxlogor 0))
(define fxand (fxbitop fxand $fxlogand -1))
(define fxxor (fxbitop fxxor $fxlogxor 0))
(define fxlogxor
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogxor "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogxor "~s is not a fixnum" y))
($fxlogxor x y)))
(define fxlogand
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogand "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogand "~s is not a fixnum" y))
($fxlogand x y)))
(define fxsra (define fxsra
(lambda (x y) (lambda (x y)
(unless (fixnum? x) (unless (fixnum? x)
@ -189,6 +216,26 @@
(error 'fxsll "negative shift not allowed, got ~s" y)) (error 'fxsll "negative shift not allowed, got ~s" y))
($fxsll x y))) ($fxsll x y)))
(define (fxpositive? x)
(if (fixnum? x)
($fx> x 0)
(error 'fxpositive? "~s is not a fixnum" x)))
(define (fxnegative? x)
(if (fixnum? x)
($fx< x 0)
(error 'fxnegative? "~s is not a fixnum" x)))
(define (fxeven? x)
(if (fixnum? x)
($fxzero? ($fxlogand x 1))
(error 'fxeven? "~s is not a fixnum" x)))
(define (fxodd? x)
(if (fixnum? x)
(not ($fxzero? ($fxlogand x 1)))
(error 'fxodd? "~s is not a fixnum" x)))
(module (fixnum->string) (module (fixnum->string)
(define f (define f
(lambda (n i j) (lambda (n i j)

10
src/makefile.ss
View File

@ -441,6 +441,15 @@
[utf8-bytevector->string i] [utf8-bytevector->string i]
[native-endianness i] [native-endianness i]
[$two-bignums i] [$two-bignums i]
[fxior i]
[fxand i]
[fxxor i]
[fxnot i]
[fxeven? i]
[fxodd? i]
[fxpositive? i]
[fxnegative? i]
[for-each i r] [for-each i r]
[map i r] [map i r]
@ -923,6 +932,7 @@
[syntax-dispatch ] [syntax-dispatch ]
[make-promise ] [make-promise ]
[force i] [force i]
[error@fx+ ]
)) ))

4
src/pass-specify-rep-primops.ss
View File

@ -978,6 +978,10 @@
[(E) (nop)] [(E) (nop)]
[(E a . a*) (assert-fixnums a a*)]) [(E a . a*) (assert-fixnums a a*)])
(define-primop fx+ safe
[(V x y) (cogen-value-+ x y)])
(define-primop zero? safe (define-primop zero? safe
[(P x) [(P x)
(seq* (seq*

23
src/pass-specify-rep.ss
View File

@ -39,6 +39,16 @@
(define (interrupt) (define (interrupt)
((interrupt-handler)) ((interrupt-handler))
(prm 'interrupt)) (prm 'interrupt))
(define (primop-interrupt-handler x)
(case x
[(fx+) 'error@fx+]
[else x]))
(define (make-interrupt-call op args)
(make-funcall
(V (make-primref (primop-interrupt-handler op)))
args))
(define (make-no-interrupt-call op args)
(make-funcall (V (make-primref op)) args))
(define (with-interrupt-handler p x ctxt args k) (define (with-interrupt-handler p x ctxt args k)
(cond (cond
[(not (PH-interruptable? p)) [(not (PH-interruptable? p))
@ -56,26 +66,25 @@
(cond (cond
[(not interrupted?) body] [(not interrupted?) body]
[(eq? ctxt 'V) [(eq? ctxt 'V)
(let ([h (make-funcall (V (make-primref x)) args)]) (let ([h (make-interrupt-call x args)])
(if (record-case body (if (record-case body
[(primcall op) (eq? op 'interrupt)] [(primcall op) (eq? op 'interrupt)]
[else #f]) [else #f])
h (make-no-interrupt-call x args)
(make-shortcut body h)))] (make-shortcut body h)))]
[(eq? ctxt 'E) [(eq? ctxt 'E)
(let ([h (make-funcall (V (make-primref x)) args)]) (let ([h (make-interrupt-call x args)])
(if (record-case body (if (record-case body
[(primcall op) (eq? op 'interrupt)] [(primcall op) (eq? op 'interrupt)]
[else #f]) [else #f])
h (make-no-interrupt-call x args)
(make-shortcut body h)))] (make-shortcut body h)))]
[(eq? ctxt 'P) [(eq? ctxt 'P)
(let ([h (prm '!= (make-funcall (V (make-primref x)) args) (let ([h (prm '!= (make-interrupt-call x args) (K bool-f))])
(K bool-f))])
(if (record-case body (if (record-case body
[(primcall op) (eq? op 'interrupt)] [(primcall op) (eq? op 'interrupt)]
[else #f]) [else #f])
h (prm '!= (make-no-interrupt-call x args) (K bool-f))
(make-shortcut body h)))] (make-shortcut body h)))]
[else (error 'with-interrupt-handler "invalid context ~s" ctxt)])))])) [else (error 'with-interrupt-handler "invalid context ~s" ctxt)])))]))
(define-syntax with-tmp (define-syntax with-tmp

16
src/todo-r6rs.ss
View File

@ -267,7 +267,7 @@
[fx=? C fx] [fx=? C fx]
[fx>=? C fx] [fx>=? C fx]
[fx>? C fx] [fx>? C fx]
[fxand S fx] [fxand C fx]
[fxarithmetic-shift S fx] [fxarithmetic-shift S fx]
[fxarithmetic-shift-left S fx] [fxarithmetic-shift-left S fx]
[fxarithmetic-shift-right S fx] [fxarithmetic-shift-right S fx]
@ -280,22 +280,22 @@
[fxdiv-and-mod D fx] [fxdiv-and-mod D fx]
[fxdiv0 D fx] [fxdiv0 D fx]
[fxdiv0-and-mod0 D fx] [fxdiv0-and-mod0 D fx]
[fxeven? S fx] [fxeven? C fx]
[fxfirst-bit-set D fx] [fxfirst-bit-set D fx]
[fxif D fx] [fxif D fx]
[fxior S fx] [fxior C fx]
[fxlength D fx] [fxlength D fx]
[fxmax S fx] [fxmax S fx]
[fxmin S fx] [fxmin S fx]
[fxmod D fx] [fxmod D fx]
[fxmod0 S fx] [fxmod0 S fx]
[fxnegative? D fx] [fxnegative? C fx]
[fxnot S fx] [fxnot C fx]
[fxodd? S fx] [fxodd? C fx]
[fxpositive? S fx] [fxpositive? C fx]
[fxreverse-bit-field D fx] [fxreverse-bit-field D fx]
[fxrotate-bit-field D fx] [fxrotate-bit-field D fx]
[fxxor S fx] [fxxor C fx]
[fxzero? C fx] [fxzero? C fx]
;;; ;;;
[fixnum->flonum C fl] [fixnum->flonum C fl]