added a zero? word

library/alien/malloc.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Mackenzie Straight.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: kernel-internals
-USING: alien errors kernel ;
+USING: alien errors kernel math ;
 
 LIBRARY: libc
 FUNCTION: ulong malloc ( ulong size ) ;
@@ -10,4 +10,4 @@ FUNCTION: void free ( ulong ptr ) ;
 FUNCTION: ulong realloc ( ulong ptr, ulong size ) ;
 FUNCTION: void memcpy ( ulong dst, ulong src, ulong size ) ;
 
-: check-ptr dup 0 = [ "Out of memory" throw ] when ;
+: check-ptr dup zero? [ "Out of memory" throw ] when ;

library/alien/primitive-types.factor

@@ -124,7 +124,7 @@ math namespaces ;
 ] "ushort*" define-primitive-type
 
 [
-    [ alien-unsigned-4 0 = not ] "getter" set
+    [ alien-unsigned-4 zero? not ] "getter" set
     [ 1 0 ? set-alien-unsigned-4 ] "setter" set
     bootstrap-cell "width" set
     bootstrap-cell "align" set

library/bootstrap/image.factor

@@ -117,7 +117,7 @@ M: fixnum ' ( n -- tagged ) fixnum-tag immediate ;
 : bignum-radix bignum-bits 1 swap shift 1- ;
 
 : (bignum>seq) ( n -- )
-    dup 0 = [
+    dup zero? [
         drop
     ] [
         dup bignum-radix bitand ,

library/collections/hashtables.factor

@@ -137,7 +137,7 @@ IN: hashtables
 
 : hash-size ( hash -- n ) dup hash-count swap hash-deleted - ;
 
-: hash-empty? ( hash -- ? ) hash-size 0 = ;
+: hash-empty? ( hash -- ? ) hash-size zero? ;
 
 : grow-hash ( hash -- )
     [ dup hash-array swap hash-size 1+ ] keep

library/collections/lists.factor

@@ -67,7 +67,7 @@ M: general-list tail ( n list -- tail )
     swap [ cdr ] times ;
 
 M: general-list nth ( n list -- element )
-    over 0 number= [ nip car ] [ >r 1- r> cdr nth ] if ;
+    over zero? [ nip car ] [ >r 1- r> cdr nth ] if ;
 
 M: cons = ( obj cons -- ? )
     {

library/collections/sequence-combinators.factor

@@ -24,7 +24,7 @@ vectors ;
     inline
 
 : (interleave) ( n -- array )
-    dup 0 = [
+    dup zero? [
         drop { }
     ] [
         t <array> f 0 pick set-nth-unsafe

library/collections/sequence-sort.factor

@@ -61,7 +61,7 @@ C: sorter ( seq start end -- sorter )
     dup length 1 <= [
         2nip slice-from
     ] [
-        3dup >r >r >r midpoint swap call dup 0 = [
+        3dup >r >r >r midpoint swap call dup zero? [
             r> r> 3drop r> dup slice-from swap slice-to + 2 /i
         ] [
             r> swap r> swap r> partition (binsearch)

library/collections/sequences-epilogue.factor

@@ -15,7 +15,7 @@ sequences-internals strings vectors words ;
 
 M: object like drop ;
 
-M: object empty? ( seq -- ? ) length 0 = ;
+M: object empty? ( seq -- ? ) length zero? ;
 
 : (>list) ( n i seq -- list )
     pick pick <= [

library/compiler/basic-blocks.factor

@@ -106,7 +106,7 @@ GENERIC: trim-dead* ( tail vop -- )
 
 M: tuple trim-dead* ( tail vop -- ) dup forget-vregs , drop ;
 
-: simplify-inc ( vop -- ) dup 0 vop-in 0 = not ?, ;
+: simplify-inc ( vop -- ) dup 0 vop-in zero? not ?, ;
 
 M: %inc-d trim-dead* ( tail vop -- ) simplify-inc drop ;
 

library/compiler/intrinsics.factor

@@ -215,7 +215,7 @@ namespaces sequences words ;
     ] if ;
 
 : fast-shift ( n -- )
-    dup 0 = [
+    dup zero? [
         -1 %inc-d ,
         drop
     ] [

library/compiler/x86/alien.factor

@@ -22,4 +22,4 @@ M: %box generate-node
     ESP 1 input reg-size ADD ;
 
 M: %cleanup generate-node
-    drop 0 input dup 0 = [ drop ] [ ESP swap ADD ] if ;
+    drop 0 input dup zero? [ drop ] [ ESP swap ADD ] if ;

library/compiler/x86/assembler.factor

@@ -92,7 +92,7 @@ M: displaced register first register ;
 M: displaced displacement
     second dup byte? [ assemble-1 ] [ assemble-4 ] if ;
 M: displaced canonicalize
-    dup first EBP = not over second 0 = and
+    dup first EBP = not over second zero? and
     [ first 1array ] when ;
 M: displaced extended? first extended? ;
 M: displaced operand-64? first register-64? ;

library/freetype/freetype-gl.factor

@@ -10,7 +10,8 @@ IN: freetype
 SYMBOL: freetype
 SYMBOL: open-fonts
 
-: freetype-error ( n -- ) 0 = [ "FreeType error" throw ] unless ;
+: freetype-error ( n -- )
+    zero? [ "FreeType error" throw ] unless ;
 
 : init-freetype ( -- )
     global [

library/io/buffer.factor

@@ -52,7 +52,7 @@ C: buffer ( size -- buffer )
 : buffer-capacity ( buffer -- int )
     dup buffer-size swap buffer-fill - ;
 
-: buffer-empty? ( buffer -- ? ) buffer-fill 0 = ;
+: buffer-empty? ( buffer -- ? ) buffer-fill zero? ;
 
 : buffer-extend ( length buffer -- )
     2dup buffer-ptr swap realloc check-ptr

library/math/complex.factor

@@ -4,7 +4,7 @@ IN: math-internals
 USING: errors generic kernel kernel-internals math ;
 
 : (rect>) ( xr xi -- x )
-    dup 0 number= [ drop ] [ <complex> ] if ; inline
+    dup zero? [ drop ] [ <complex> ] if ; inline
 
 IN: math
 

library/math/float.factor

@@ -1,5 +1,5 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: math
 USING: generic kernel math-internals ;
 
@@ -11,7 +11,14 @@ M: real absq sq ;
 M: real hashcode ( n -- n ) >fixnum ;
 M: real <=> - ;
 
-M: float number= [ double>bits ] 2apply = ;
+: fp-nan? ( float -- ? )
+    double>bits -51 shift BIN: 111111111111 [ bitand ] keep = ;
+
+M: float zero?
+    double>bits HEX: 8000000000000000 [ bitor ] keep number= ;
+
+M: float number= [ double>bits ] 2apply number= ;
+
 M: float < float< ;
 M: float <= float<= ;
 M: float > float> ;

library/math/integer.factor

@@ -11,7 +11,7 @@ UNION: integer fixnum bignum ;
 : odd? ( n -- ? ) 1 bitand 1 = ;
 
 : (gcd) ( b a y x -- a d )
-    dup 0 number= [
+    dup zero? [
         drop nip
     ] [
         tuck /mod >r pick * swap >r swapd - r> r> (gcd)
@@ -36,7 +36,7 @@ IN: math-internals
 : division-by-zero ( x y -- ) "Division by zero" throw ;
 
 M: integer / ( x y -- x/y )
-    dup 0 number= [
+    dup zero? [
         division-by-zero
     ] [
         dup 0 < [ [ neg ] 2apply ] when
@@ -69,6 +69,8 @@ M: fixnum shift fixnum-shift ;
 
 M: fixnum bitnot fixnum-bitnot ;
 
+M: fixnum zero? 0 eq? ;
+
 M: bignum number= bignum= ;
 M: bignum < bignum< ;
 M: bignum <= bignum<= ;
@@ -93,3 +95,5 @@ M: bignum bitxor bignum-bitxor ;
 M: bignum shift bignum-shift ;
 
 M: bignum bitnot bignum-bitnot ;
+
+M: bignum zero? 0 >bignum bignum= ;

library/math/math.factor

@@ -33,6 +33,9 @@ GENERIC: 1- ( x -- x-1 ) foldable
 GENERIC: abs ( z -- |z| ) foldable
 GENERIC: absq ( n -- |n|^2 ) foldable
 
+GENERIC: zero? ( x -- ? ) foldable
+M: object zero? drop f ;
+
 : sq dup * ; inline
 : neg 0 swap - ; inline
 : recip 1 swap / ; inline

library/math/parse-numbers.factor

@@ -70,14 +70,11 @@ M: ratio >base ( num radix -- string )
 : fix-float
     CHAR: . over member? [ ".0" append ] unless ;
 
-: nan? ( float -- ? )
-    double>bits -51 shift BIN: 111111111111 [ bitand ] keep = ;
-
 M: float >base ( num radix -- string )
     drop {
         { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
         { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
-        { [ dup nan? ] [ drop "0.0/0.0" ] }
+        { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
         { [ t ] [ float>string fix-float ] }
     } cond ;
 

library/math/pow.factor

@@ -22,18 +22,18 @@ GENERIC: ^ ( z w -- z^w ) foldable
 : 0^0 "0^0 is not defined" throw ;
 
 : 0^ ( z w -- )
-    dup 0 number= [
+    dup zero? [
         2drop 0.0/0.0
     ] [
         0 < [ drop 1.0/0.0 ] when
     ] if ;
 
 M: number ^ ( z w -- z^w )
-    over 0 number=
+    over zero?
     [ 0^ ] [ swap >polar 3dup ^theta >r ^mag r> polar> ] if ;
 
 : each-bit ( n quot -- | quot: 0/1 -- )
-    over 0 number= pick -1 number= or [
+    over zero? pick -1 number= or [
         2drop
     ] [
         2dup >r >r >r 1 bitand r> call r> -1 shift r> each-bit
@@ -44,7 +44,7 @@ M: number ^ ( z w -- z^w )
     inline
 
 M: integer ^ ( z w -- z^w )
-    over 0 number=
+    over zero?
     [ 0^ ] [ dup 0 < [ neg ^ recip ] [ (integer^) ] if ] if ;
 
 : power-of-2? ( n -- ? )

library/math/vectors.factor

@@ -23,4 +23,4 @@ USING: arrays generic kernel sequences ;
 : normalize ( vec -- uvec ) dup norm v/n ;
 
 : set-axis ( x y axis -- v )
-    dup length [ >r 0 = pick pick ? r> swap nth ] 2map 2nip ;
+    dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ;

library/opengl/opengl-utils.factor

@@ -36,7 +36,7 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
     >r 0 gl-flags r> with-screen ; inline
 
 : gl-error ( -- )
-    glGetError dup 0 = [ drop ] [ gluErrorString throw ] if ;
+    glGetError dup zero? [ drop ] [ gluErrorString throw ] if ;
 
 : with-gl-surface ( quot -- )
     #! Execute a quotation, locking the current surface if it

library/sdl/sdl-utils.factor

@@ -10,7 +10,7 @@ SYMBOL: height
 SYMBOL: bpp
 
 : sdl-error ( 0/-1 -- )
-    0 = [ SDL_GetError throw ] unless ;
+    zero? [ SDL_GetError throw ] unless ;
 
 : init-keyboard ( -- )
     1 SDL_EnableUNICODE drop
@@ -32,10 +32,10 @@ SYMBOL: bpp
 
 : must-lock-surface? ( -- ? )
     #! This is a macro in SDL_video.h.
-    surface get dup surface-offset 0 = [
+    surface get dup surface-offset zero? [
         surface-flags
         SDL_HWSURFACE SDL_ASYNCBLIT bitor SDL_RLEACCEL bitor
-        bitand 0 = not
+        bitand zero? not
     ] [
         drop t
     ] if ;

library/syntax/prettyprint.factor

@@ -100,7 +100,7 @@ C: block ( -- block )
     [ section-end fresh-line ] [ drop ] if ;
 
 : section-fits? ( section -- ? )
-    margin get dup 0 = [
+    margin get dup zero? [
         2drop t
     ] [
         line-limit? pick block? and [

library/test/benchmark/ack.factor

@@ -6,10 +6,10 @@ USE: test
 ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
 
 : ack ( m n -- x )
-    over 0 = [
+    over zero? [
         nip 1+
     ] [
-        dup 0 = [
+        dup zero? [
             drop 1- 1 ack
         ] [
             dupd 1- ack >r 1- r> ack

library/test/benchmark/fac.factor

@@ -2,7 +2,7 @@ IN: temporary
 USING: compiler kernel math sequences test ;
 
 : (fac) ( n! i -- n! )
-    dup 0 = [
+    dup zero? [
         drop
     ] [
         [ * ] keep 1- (fac)

library/test/math/float.factor

@@ -48,3 +48,10 @@ USE: test
 [ -4.0 ] [ -4.0 truncate ] unit-test
 [ -4.0 ] [ -4.0 floor ] unit-test
 [ -4.0 ] [ -4.0 ceiling ] unit-test
+
+[ t ] [ 0.0/0.0 0.0/0.0 = ] unit-test
+[ t ] [ -0.0 -0.0 = ] unit-test
+[ f ] [ 0.0 -0.0 = ] unit-test
+
+[ t ] [ 0.0 zero? ] unit-test
+[ t ] [ -0.0 zero? ] unit-test

library/test/math/integer.factor

@@ -101,3 +101,7 @@ unit-test
 [ { 0 1 1 0 } ] [ [ -10 [ , ] each-bit ] { } make ] unit-test
 
 [ -351382792 ] [ -43922849 3 shift ] unit-test
+
+[ t ] [ 0 zero? ] unit-test
+[ f ] [ 30 zero? ] unit-test
+[ t ] [ 0 >bignum zero? ] unit-test

library/threads.factor

@@ -22,7 +22,7 @@ namespaces queues sequences vectors ;
 DEFER: next-thread
 
 : do-sleep ( -- continuation )
-    sleep-queue* dup sleep-time dup 0 =
+    sleep-queue* dup sleep-time dup zero?
     [ drop pop cdr ] [ nip io-multiplex next-thread ] if ;
 
 : next-thread ( -- continuation )

library/tools/describe.factor

@@ -10,7 +10,7 @@ GENERIC: summary ( object -- string )
     0 > "a positive " "a negative " ? ;
 
 M: integer summary
-    dup sign-string over 2 mod 0 = "even " "odd " ?
+    dup sign-string over 2 mod zero? "even " "odd " ?
     rot class word-name append3 ;
 
 M: real summary
@@ -72,7 +72,7 @@ M: word summary ( word -- )
 : format-sheet ( sheet -- list )
     #! We use an idiom to notify format-column if it is
     #! formatting the last column.
-    dup length reverse-slice [ 0 = format-column ] 2map
+    dup length reverse-slice [ zero? format-column ] 2map
     flip [ " " join ] map ;
 
 DEFER: describe

library/tools/memory.factor

@@ -93,7 +93,7 @@ M: object each-slot ( obj quot -- )
     [ >r 2dup r> heap-stat-step ] each-object ;
 
 : heap-stat. ( { instances bytes type } -- )
-    dup first 0 = [
+    dup first zero? [
         dup third type>class pprint ": " write
         dup second pprint " bytes, " write
         dup first pprint " instances" print

library/ui/line-editor.factor

@@ -128,7 +128,7 @@ M: document-elt prev-elt* 3drop 0 ;
 
 : history-prev ( -- )
     #! Call this in the line editor scope.
-    history-index get dup 0 = [
+    history-index get dup zero? [
         drop
     ] [
         dup history-length = [ commit-history ] when

library/unix/io.factor

@@ -37,7 +37,7 @@ SYMBOL: write-tasks
 
 : (io-error) err_no strerror throw ;
 
-: check-null ( n -- ) 0 = [ (io-error) ] when ;
+: check-null ( n -- ) zero? [ (io-error) ] when ;
 
 : io-error ( n -- ) 0 < [ (io-error) ] when ;
 
@@ -126,7 +126,7 @@ GENERIC: task-container ( task -- vector )
     ] if ;
 
 : timeout? ( port -- ? )
-    port-cutoff dup 0 = not swap millis < and ;
+    port-cutoff dup zero? not swap millis < and ;
 
 : handle-fdset ( fdset tasks -- )
     [
@@ -169,7 +169,7 @@ GENERIC: task-container ( task -- vector )
 
 : refill ( port -- ? )
     #! Return f if there is a recoverable error
-    dup buffer-length 0 = [
+    dup buffer-length zero? [
         dup (refill)  dup 0 >= [
             swap n>buffer t
         ] [
@@ -259,7 +259,7 @@ C: write-task ( port -- task )
     [ >r <io-task> r> set-delegate ] keep ;
 
 M: write-task do-io-task
-    io-task-port dup buffer-length 0 = over port-error or [
+    io-task-port dup buffer-length zero? over port-error or [
         0 swap buffer-reset t
     ] [
         write-step f

library/win32/win32-io-internals.factor

@@ -110,7 +110,7 @@ C: io-callback ( -- callback )
     pick over r> -rot >r >r GetQueuedCompletionStatus r> r> ;
 
 : overlapped>callback ( overlapped -- callback )
-    indirect-pointer-value dup 0 = [
+    indirect-pointer-value dup zero? [
         drop f
     ] [
         <alien> overlapped-ext-user-data get-io-callback

library/win32/win32-server.factor

@@ -55,12 +55,12 @@ SYMBOL: socket
     AF_INET over set-sockaddr-in-family ;
 
 : bind-socket ( port socket -- )
-    swap setup-sockaddr "sockaddr-in" c-size wsa-bind 0 = [
+    swap setup-sockaddr "sockaddr-in" c-size wsa-bind zero? [
         handle-socket-error
     ] unless ;
 
 : listen-socket ( socket -- )
-    20 wsa-listen 0 = [ handle-socket-error ] unless ;
+    20 wsa-listen zero? [ handle-socket-error ] unless ;
 
 : sockaddr> ( sockaddr -- port host )
     dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa ;

library/win32/win32-stream.factor

@@ -72,7 +72,7 @@ SYMBOL: cutoff
     out-buffer get buffer-length 0 > [ flush-output ] when ;
 
 M: integer do-write ( int -- )
-    out-buffer get [ buffer-capacity 0 = [ flush-output ] when ] keep
+    out-buffer get [ buffer-capacity zero? [ flush-output ] when ] keep
     >r ch>string r> >buffer ;
 
 M: string do-write ( str -- )
@@ -96,7 +96,7 @@ M: string do-write ( str -- )
     dup in-buffer get n>buffer update-file-pointer ;
 
 : consume-input ( count -- str ) 
-    in-buffer get buffer-length 0 = [ fill-input ] when
+    in-buffer get buffer-length zero? [ fill-input ] when
     in-buffer get buffer-size min
     dup in-buffer get buffer-first-n
     swap in-buffer get buffer-consume ;
@@ -105,11 +105,11 @@ M: string do-write ( str -- )
     dup length 0 > [ >string ] [ drop f ] if ;
 
 : do-read-count ( sbuf count -- str )
-    dup 0 = [ 
+    dup zero? [ 
         drop >string 
     ] [
         dup consume-input
-        dup length dup 0 = [
+        dup length dup zero? [
             3drop >string-or-f
         ] [
             >r swap r> - >r swap [ swap nappend ] keep r> do-read-count
@@ -130,7 +130,7 @@ M: win32-stream stream-read ( count stream -- str )
 
 M: win32-stream stream-read1 ( stream -- str )
     win32-stream-this [
-        1 consume-input dup length 0 = [ drop f ] when first 
+        1 consume-input dup length zero? [ drop f ] when first 
     ] bind ;
 
 M: win32-stream stream-readln ( stream -- str )