diff --git a/basis/math/primes/factors/factors-tests.factor b/basis/math/primes/factors/factors-tests.factor
index 983de51216..8e2e10711a 100644
--- a/basis/math/primes/factors/factors-tests.factor
+++ b/basis/math/primes/factors/factors-tests.factor
@@ -7,3 +7,4 @@ USING: math.primes.factors tools.test ;
 { 999967000236000612 } [ 999969000187000867 totient ] unit-test
 { 0 } [ 1 totient ] unit-test
 { { 425612003 } } [ 425612003 factors ] unit-test
+{ { 13 4253 15823 32472893749823741 } } [ 28408516453955558205925627 factors ] unit-test
diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor
index beab0ac5a6..199b72b7e1 100644
--- a/basis/math/primes/factors/factors.factor
+++ b/basis/math/primes/factors/factors.factor
@@ -10,21 +10,30 @@ IN: math.primes.factors
     [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop
     swap ;
 
-: write-factor ( n d -- n' d )
-    2dup mod zero? [ [ [ count-factor ] keep swap 2array , ] keep ] when ;
+: write-factor ( n d -- n' d' )
+    2dup mod zero? [
+        [ [ count-factor ] keep swap 2array , ] keep
+        ! If the remainder is a prime number, increase d so that
+        ! the caller stops looking for factors.
+        over prime? [ drop dup ] when
+    ] when ;
 
-PRIVATE>
-
-: group-factors ( n -- seq )
+: (group-factors) ( n -- seq )
     [
         2
         [ 2dup sq < ] [ write-factor next-prime ] until
         drop dup 2 < [ drop ] [ 1 2array , ] if
     ] { } make ;
 
-: unique-factors ( n -- seq ) group-factors [ first ] map ;
+PRIVATE>
 
-: factors ( n -- seq ) group-factors [ first2 swap <array> ] map concat ;
+: group-factors ( n -- seq )
+    dup prime? [ 1 2array 1array ] [ (group-factors) ] if ; flushable
+
+: unique-factors ( n -- seq ) group-factors [ first ] map ; flushable
+
+: factors ( n -- seq )
+    group-factors [ first2 swap <array> ] map concat ; flushable
 
 : totient ( n -- t )
     {