diff --git a/scheme/ikarus.boot.4.prebuilt b/scheme/ikarus.boot.4.prebuilt
index 2d24f8c..67f3c81 100644
Binary files a/scheme/ikarus.boot.4.prebuilt and b/scheme/ikarus.boot.4.prebuilt differ
diff --git a/scheme/ikarus.boot.8.prebuilt b/scheme/ikarus.boot.8.prebuilt
index 559a59b..0528a28 100644
Binary files a/scheme/ikarus.boot.8.prebuilt and b/scheme/ikarus.boot.8.prebuilt differ
diff --git a/scheme/ikarus.fixnums.ss b/scheme/ikarus.fixnums.ss
index 520bb94..d4762c4 100644
--- a/scheme/ikarus.fixnums.ss
+++ b/scheme/ikarus.fixnums.ss
@@ -27,7 +27,9 @@
           fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift
           fxmin fxmax
           error@fx+ error@fx* error@fx- error@fxadd1 error@fxsub1
+
           error@fxarithmetic-shift-left
+          error@fxarithmetic-shift-right
           )
   (import 
     (ikarus system $fx)
@@ -47,6 +49,14 @@
             fxmin fxmax
             fixnum->string))
 
+  (define (die/overflow who . args)
+    (raise
+      (condition
+        (make-implementation-restriction-violation)
+        (make-who-condition who)
+        (make-message-condition "overflow")
+        (make-irritants-condition args))))
+
   (define fxzero?
     (lambda (x)
       (cond
@@ -67,27 +77,24 @@
         (die 'fxnot "not a fixnum" x))
       ($fxlognot x)))
   
-  (define (make-fx-error who msg)
+  (define (make-fx-error who)
     (case-lambda
       [(x y)
        (if (fixnum? x)
            (if (fixnum? y) 
-               (die who msg x y)
+               (die/overflow who x y)
                (die who "not a fixnum" y))
            (die who "not a fixnum" x))]
       [(x) 
        (if (fixnum? x)
-           (die who msg x)
+           (die/overflow who x)
            (die who "not a fixnum" x))]))
 
-  (define error@fx+ 
-    (make-fx-error 'fx+ "overflow during addition"))
-  
-  (define error@fx- 
-    (make-fx-error 'fx- "overflow during subtraction"))
-
-  (define error@fx*
-    (make-fx-error 'fx* "overflow during multiplication"))
+  (define error@fx+    (make-fx-error 'fx+))
+  (define error@fx-    (make-fx-error 'fx-))
+  (define error@fx*    (make-fx-error 'fx*))
+  (define error@fxadd1 (make-fx-error 'fxadd1))
+  (define error@fxsub1 (make-fx-error 'fxsub1))
 
   (define (fx+ x y) (sys:fx+ x y))
 
@@ -98,12 +105,6 @@
       [(x y) (sys:fx- x y)]
       [(x)   (sys:fx- x)]))
 
-  (define error@fxadd1 
-    (make-fx-error 'fxadd1 "overflow during addition"))
-
-  (define error@fxsub1 
-    (make-fx-error 'fxsub1 "overflow during subtraction"))
-
   (define fxadd1
     (lambda (n)
       (import (ikarus))
@@ -173,7 +174,7 @@
         (die 'fxquotient "zero dividend" y))
       (if (eq? y -1)
           (if (eq? x (least-fixnum))
-              (die 'fxquotient "overflow" x y)
+              (die/overflow 'fxquotient x y)
               ($fx- 0 x))
           ($fxquotient x y))))
   
@@ -255,13 +256,8 @@
 
   (define fxarithmetic-shift-right
     (lambda (x y) 
-      (unless (fixnum? x)
-        (die 'fxarithmetic-shift-right "not a fixnum" x))
-      (unless (fixnum? y)
-        (die 'fxarithmetic-shift-right "not a fixnum" y))
-      (unless ($fx>= y 0)
-        (die 'fxarithmetic-shift-right "negative shift not allowed" y))
-      ($fxsra x y)))
+      (import (ikarus))
+      (fxarithmetic-shift-right x y)))
 
   (define fxsll
     (lambda (x y) 
@@ -273,37 +269,48 @@
         (die 'fxsll "negative shift not allowed" y))
       ($fxsll x y))) 
 
-  (define (error@fxarithmetic-shift-left x y)
+
+  (define (error@fxarithmetic-shift who x y)
     (unless (fixnum? x)
-      (die 'fxarithmetic-shift-left "not a fixnum" x))
+      (die who "not a fixnum" x))
     (unless (fixnum? y)
-      (die 'fxarithmetic-shift-left "not a fixnum" y))
+      (die who "not a fixnum" y))
     (unless ($fx>= y 0)
-      (die 'fxarithmetic-shift-left "negative shift not allowed" y))
+      (die who "negative shift not allowed" y))
     (unless ($fx< y (fixnum-width))
-      (die 'fxarithmetic-shift-left 
-        "shift is not less than fixnum-width" y))
-    (die 'fxarithmetic-shift-left "overflow" x y))
+      (die who "shift is not less than fixnum-width" y))
+    (die/overflow who x y))
+ 
+  (define (error@fxarithmetic-shift-left x y)
+    (error@fxarithmetic-shift 'arithmetic-shift-left x y))
+
+  (define (error@fxarithmetic-shift-right x y)
+    (error@fxarithmetic-shift 'arithmetic-shift-right x y))
 
   (define fxarithmetic-shift-left
-    (lambda (x y) 
+    (lambda (x y)
       (import (ikarus))
       (fxarithmetic-shift-left x y)))
 
   (define fxarithmetic-shift
     (lambda (x y) 
-      (unless (fixnum? x)
-        (die 'fxarithmetic-shift "not a fixnum" x))
-      (unless (fixnum? y)
-        (die 'fxarithmetic-shift "not a fixnum" y))
+      (import (ikarus))
+      (define (err str x) (die 'fxarithmetic-shift str x))
+      (unless (fixnum? x) (err "not a fixnum" x))
+      (unless (fixnum? y) (err "not a fixnum" y))
       (if ($fx>= y 0)
-          ($fxsll x y)
-          (if ($fx< x -100) ;;; arbitrary number < (fixnum-width)
-              ($fxsra x 32)
-              ($fxsra x ($fx- 0 y))))))
+          (if ($fx< y (fixnum-width))
+              (let ([r ($fxsll x y)])
+                (if ($fx= x ($fxsra r y))
+                    r
+                    (die/overflow 'fxarithmetic-shift x y)))
+              (err "invalid shift amount" y))
+          (if ($fx> y (- (fixnum-width)))
+              ($fxsra x ($fx- 0 y))
+              (err "invalid shift amount" y)))))
 
   (define (fxpositive? x)
-    (if (fixnum? x) 
+    (if (fixnum? x)
         ($fx> x 0)
         (die 'fxpositive? "not a fixnum" x)))
 
diff --git a/scheme/last-revision b/scheme/last-revision
index d42f634..cd6a6c7 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1845
+1846
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 4edb06f..27fa0e7 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -617,6 +617,7 @@
     [make-traced-macro                           i]
     [error@fx+                                   ]
     [error@fxarithmetic-shift-left               ]
+    [error@fxarithmetic-shift-right              ]
     [error@fx*                                   ]
     [error@fx-                                   ]
     [error@add1                                  ]
diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss
index 046f5b8..f3b278d 100644
--- a/scheme/pass-specify-rep-primops.ss
+++ b/scheme/pass-specify-rep-primops.ss
@@ -1592,6 +1592,33 @@
             x2)))])])
 
 
+
+(define-primop fxarithmetic-shift-right safe
+  [(V x n) 
+   (struct-case n 
+     [(constant i)
+      (cond
+        [(and (fx? i)
+              (>= i 0)
+              (< i (- (* wordsize 8) fx-shift)))
+         (prm 'sll
+              (prm 'sra (T x) (K (+ i fx-shift)))
+              (K fx-shift))]
+        [else
+         (interrupt)])]
+     [else 
+      (with-tmp ([x (T x)] [n (T n)])
+        (assert-fixnums x (list n))
+        (with-tmp ([n (prm 'sra n (K fx-shift))])
+          (interrupt-when 
+            (prm '< n (K 0)))
+          (interrupt-when 
+            (prm '>= n (K (- (* wordsize 8) fx-shift))))
+          (prm 'sll 
+               (prm 'sra x n)
+               (K fx-shift))))])])
+
+
 (define (log2 n) 
   (let f ([n n] [i 0])
     (cond
diff --git a/scheme/pass-specify-rep.ss b/scheme/pass-specify-rep.ss
index 47d48a9..af621fe 100644
--- a/scheme/pass-specify-rep.ss
+++ b/scheme/pass-specify-rep.ss
@@ -212,14 +212,15 @@
   (module (cogen-primop cogen-debug-primop)
     (define (primop-interrupt-handler x)
       (case x
-        [(fx+)                     'error@fx+]
-        [(fx-)                     'error@fx-]
-        [(fx*)                     'error@fx*]
-        [(add1)                    'error@add1]
-        [(sub1)                    'error@sub1]
-        [(fxadd1)                  'error@fxadd1]
-        [(fxsub1)                  'error@fxsub1]
-        [(fxarithmetic-shift-left) 'error@fxarithmetic-shift-left]
+        [(fx+)                      'error@fx+]
+        [(fx-)                      'error@fx-]
+        [(fx*)                      'error@fx*]
+        [(add1)                     'error@add1]
+        [(sub1)                     'error@sub1]
+        [(fxadd1)                   'error@fxadd1]
+        [(fxsub1)                   'error@fxsub1]
+        [(fxarithmetic-shift-left)  'error@fxarithmetic-shift-left]
+        [(fxarithmetic-shift-right) 'error@fxarithmetic-shift-right]
         [else                      x]))
     (define (make-interrupt-call op args)
       (make-funcall