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.

103
src/ikarus.fixnums.ss
View File

@ -4,16 +4,24 @@
fxremainder fxmodulo fxlogor fxlogand fxlogxor fxsll fxsra
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
(ikarus system $fx)
(ikarus system $chars)
(ikarus system $pairs)
(ikarus system $strings)
(prefix (only (ikarus) fx+) sys:)
(except (ikarus) fxzero? fxadd1 fxsub1 fxlognot fx+ fx- fx*
fxquotient fxremainder fxmodulo fxlogor fxlogand
fxlogxor fxsll fxsra fx= fx< fx<= fx> fx>=
fx=? fx<? fx<=? fx>? fx>=?
fxior fxand fxxor fxnot
fxpositive? fxnegative?
fxeven? fxodd?
fixnum->string))
(define fxzero?
@ -41,13 +49,23 @@
(error 'fxlognot "~s is not a fixnum" 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+
(lambda (x y)
(unless (fixnum? x)
(error 'fx+ "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx+ "~s is not a fixnum" y))
($fx+ x y)))
(sys:fx+ x y)))
(define fx-
(lambda (x y)
@ -145,29 +163,38 @@
(error 'fxmodulo "zero dividend ~s" y))
($fxmodulo x y)))
(define fxlogor
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogor "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogor "~s is not a fixnum" y))
($fxlogor x y)))
(define-syntax fxbitop
(syntax-rules ()
[(_ who $op identity)
(case-lambda
[(x y)
(if (fixnum? x)
(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 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 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 fxsra
(lambda (x y)
@ -189,6 +216,26 @@
(error 'fxsll "negative shift not allowed, got ~s" 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)
(define f
(lambda (n i j)

10
src/makefile.ss
View File

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

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

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

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

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

16
src/todo-r6rs.ss
View File

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