working on PowerPC overflow checks

library/bootstrap/primitives.factor

@@ -103,10 +103,21 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
     { "update-xt" "words"                   }
     { "compiled?" "words"                   }
     { "drop" "kernel"                       }
+    { "2drop" "kernel"                      }
+    { "3drop" "kernel"                      }
     { "dup" "kernel"                        }
-    { "swap" "kernel"                       }
+    { "2dup" "kernel"                       }
+    { "3dup" "kernel"                       }
+    { "rot" "kernel"                        }
+    { "-rot" "kernel"                       }
+    { "dupd" "kernel"                       }
+    { "swapd" "kernel"                      }
+    { "nip" "kernel"                        }
+    { "2nip" "kernel"                       }
+    { "tuck" "kernel"                       }
     { "over" "kernel"                       }
     { "pick" "kernel"                       }
+    { "swap" "kernel"                       }
     { ">r" "kernel"                         }
     { "r>" "kernel"                         }
     { "eq?" "kernel"                        }
@@ -202,10 +213,21 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
 
 {
     { "drop" "kernel" " x -- " }
+    { "2drop" "kernel" " x y -- " }
+    { "3drop" "kernel" " x y z -- " }
     { "dup" "kernel"  " x -- x x " }
-    { "swap" "kernel" " x y -- y x " }
+    { "2dup" "kernel"  " x y -- x y x y " }
+    { "3dup" "kernel"  " x y z -- x y z x y z " }
+    { "rot" "kernel"  " x y z -- y z x " }
+    { "-rot" "kernel"  " x y z -- z x y " }
+    { "dupd" "kernel"  " x y -- x x y " }
+    { "swapd" "kernel"  " x y z -- y x z " }
+    { "nip" "kernel"  " x y -- y " }
+    { "2nip" "kernel"  " x y z -- z " }
+    { "tuck" "kernel"  " x y -- y x y " }
     { "over" "kernel" " x y -- x y x " }
     { "pick" "kernel" " x y z -- x y z x " }
+    { "swap" "kernel" " x y -- y x " }
     { ">r" "kernel"   " x -- r: x " }
     { "r>" "kernel"   " r: x -- x " }
     { "datastack" "kernel" " -- ds " }

library/collections/hashtables.factor

@@ -13,7 +13,7 @@ kernel-internals ;
 ! if it is somewhat 'implementation detail', is in the
 ! public 'hashtables' vocabulary.
 
-: bucket-count ( hash -- n ) hash-array length ;
+: bucket-count ( hash -- n ) hash-array array-capacity ;
 
 IN: kernel-internals
 

library/compiler/assembler.factor

@@ -9,13 +9,13 @@ SYMBOL: interned-literals
 : compiled-header HEX: 01c3babe ; inline
 
 : compiled-byte ( a -- n )
-    <alien> 0 alien-signed-1 ; inline
+    f swap alien-signed-1 ; inline
 : set-compiled-byte ( n a -- )
-    <alien> 0 set-alien-signed-1 ; inline
+    f swap set-alien-signed-1 ; inline
 : compiled-cell ( a -- n )
-    <alien> 0 alien-signed-cell ; inline
+    f swap alien-signed-cell ; inline
 : set-compiled-cell ( n a -- )
-    <alien> 0 set-alien-signed-cell ; inline
+    f swap set-alien-signed-cell ; inline
 
 : compile-aligned ( n -- )
     compiled-offset cell 2 * align set-compiled-offset ; inline

library/compiler/ppc/assembler.factor

@@ -70,7 +70,7 @@ USING: compiler errors generic kernel math memory words ;
 
 : (DIVW) 491 xo-form 31 insn ;
 : DIVW 0 0 (DIVW) ;  : DIVW. 0 1 (DIVW) ;
-: DIVWO 1 0 (DIVW) ; : DIVWO 1 1 (DIVW) ;
+: DIVWO 1 0 (DIVW) ; : DIVWO. 1 1 (DIVW) ;
 
 : (DIVWU) 459 xo-form 31 insn ;
 : DIVWU 0 0 (DIVWU) ;  : DIVWU. 0 1 (DIVWU) ;

library/compiler/ppc/fixnum.factor

@@ -41,22 +41,39 @@ M: %fixnum* generate-node ( vop -- )
     #! Note that this assumes the output will be in r3.
     >3-vop< dup dup tag-bits SRAWI
     0 MTXER
-    [ >r >r drop 4 r> r> MULLWO. 3 ] 2keep
+    [ >r >r drop 6 r> r> MULLWO. 3 ] 2keep
     <label> "end" set
     "end" get BNO
     MULHW
+    4 6 MR
     "s48_long_long_to_bignum" f compile-c-call
     ! now we have to shift it by three bits to remove the second
     ! tag
     tag-bits neg 4 LI
     "s48_bignum_arithmetic_shift" f compile-c-call
     ! An untagged pointer to the bignum is now in r3; tag it
-    3 4 bignum-tag ORI
+    3 6 bignum-tag ORI
-    "end" get save-xt ;
+    "end" get save-xt
+    3 6 MR ;
+
+: most-negative-fixnum ( -- n )
+      1 cell 8 * tag-bits - 1 - shift neg ; inline
 
 M: %fixnum/i generate-node ( vop -- )
-    dup >3-vop< swap DIVW
+    #! This has specific vreg requirements.
-    vop-out-1 v>operand dup tag-fixnum ;
+    drop
+    0 MTXER
+    5 3 4 DIVWO.
+    <label> "overflow" set
+    <label> "end" set
+    "overflow" get BO
+    3 5 tag-fixnum
+    "end" get B
+    "overflow" get save-xt
+    most-negative-fixnum neg 3 LOAD
+    "s48_long_to_bignum" f compile-c-call
+    3 3 bignum-tag ORI
+    "end" get save-xt ;
 
 : generate-fixnum/mod ( -- )
     #! The same code is used for %fixnum/i and %fixnum/mod.
@@ -64,7 +81,7 @@ M: %fixnum/i generate-node ( vop -- )
     #! precise vreg requirements.
     6 3 4 DIVW  ! divide in2 by in1, store result in out1
     7 6 4 MULLW ! multiply out1 by in1, store result in in1
-    5 8 3 SUBF  ! subtract in2 from in1, store result in out1.
+    5 7 3 SUBF  ! subtract in2 from in1, store result in out1.
     ;
 
 M: %fixnum-mod generate-node ( vop -- )
@@ -95,22 +112,23 @@ M: %fixnum<< generate-node ( vop -- )
     <label> "end" set
     vop-in-1
     ! check for potential overflow
-    dup shift-add dup 19 LOAD
+    dup shift-add dup 5 LOAD
-    18 17 19 ADD
+    4 3 5 ADD
-    0 18 rot 2 * 1 - CMPLI
+    2 * 1 - 5 LOAD
+    5 0 4 CMPL
     ! is there going to be an overflow?
     "no-overflow" get BGE
     ! there is going to be an overflow, make a bignum
-    3 17 tag-bits SRAWI
+    3 3 tag-bits SRAWI
     "s48_long_to_bignum" f compile-c-call
     dup 4 LI
     "s48_bignum_arithmetic_shift" f compile-c-call
     ! tag the result
-    3 17 bignum-tag ORI
+    3 3 bignum-tag ORI
     "end" get B
     ! there is not going to be an overflow
     "no-overflow" get save-xt
-    17 17 rot SLWI
+    3 3 rot SLWI
     "end" get save-xt ;
 
 M: %fixnum>> generate-node ( vop -- )

library/generic/early-generic.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: generic
-USING: kernel kernel-internals ;
+USING: errors kernel kernel-internals ;
 
 DEFER: standard-combination
 
@@ -11,4 +11,8 @@ DEFER: math-combination
     dup tuple? [ 3 slot ] [ drop f ] ifte ; inline
 
 : set-delegate ( delegate tuple -- )
-    dup tuple? [ 3 set-slot ] [ drop drop ] ifte ; inline
+    dup tuple? [
+        3 set-slot
+    ] [
+        "Only tuples can have delegates" throw
+    ] ifte ; inline

library/io/buffer.factor

@@ -82,7 +82,7 @@ C: buffer ( size -- buffer )
 
 : ch>buffer ( char buffer -- )
     1 over check-overflow
-    [ buffer-end <alien> 0 set-alien-unsigned-1 ] keep
+    [ buffer-end f swap set-alien-unsigned-1 ] keep
     [ buffer-fill 1 + ] keep set-buffer-fill ;
 
 : n>buffer ( count buffer -- )
@@ -90,7 +90,7 @@ C: buffer ( size -- buffer )
     [ buffer-fill + ] keep set-buffer-fill ;
 
 : buffer-peek ( buffer -- char )
-    buffer@ <alien> 0 alien-unsigned-1 ;
+    buffer@ f swap alien-unsigned-1 ;
 
 : buffer-pop ( buffer -- char )
     [ buffer-peek  1 ] keep buffer-consume ;

library/kernel.factor

@@ -3,18 +3,6 @@
 IN: kernel
 USING: generic kernel-internals vectors ;
 
-: 2drop ( x x -- ) drop drop ;
-: 3drop ( x x x -- ) drop drop drop ;
-: 2dup ( x y -- x y x y ) over over ;
-: 3dup ( x y z -- x y z x y z ) pick pick pick ;
-: rot ( x y z -- y z x ) >r swap r> swap ;
-: -rot ( x y z -- z x y ) swap >r swap r> ;
-: dupd ( x y -- x x y ) >r dup r> ;
-: swapd ( x y z -- y x z ) >r swap r> ;
-: nip ( x y -- y ) swap drop ;
-: 2nip ( x y z -- z ) >r drop drop r> ;
-: tuck ( x y -- y x y ) dup >r swap r> ;
-
 : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
 
 : clear ( -- )

native/primitives.c

@@ -82,10 +82,21 @@ void* primitives[] = {
 	primitive_update_xt,
 	primitive_word_compiledp,
 	primitive_drop,
+	primitive_2drop,
+	primitive_3drop,
 	primitive_dup,
-	primitive_swap,
+	primitive_2dup,
+	primitive_3dup,
+	primitive_rot,
+	primitive__rot,
+	primitive_dupd,
+	primitive_swapd,
+	primitive_nip,
+	primitive_2nip,
+	primitive_tuck,
 	primitive_over,
 	primitive_pick,
+	primitive_swap,
 	primitive_to_r,
 	primitive_from_r,
 	primitive_eq,

native/stack.c

@@ -37,17 +37,98 @@ void primitive_drop(void)
 	dpop();
 }
 
+void primitive_2drop(void)
+{
+	ds -= 2 * CELLS;
+}
+
+void primitive_3drop(void)
+{
+	ds -= 3 * CELLS;
+}
+
 void primitive_dup(void)
 {
 	dpush(dpeek());
 }
 
-void primitive_swap(void)
+void primitive_2dup(void)
+{
+	CELL top = dpeek();
+	CELL next = get(ds - CELLS);
+	ds += CELLS * 2;
+	put(ds - CELLS,next);
+	put(ds,top);
+}
+
+void primitive_3dup(void)
+{
+	CELL c1 = dpeek();
+	CELL c2 = get(ds - CELLS);
+	CELL c3 = get(ds - CELLS * 2);
+	ds += CELLS * 3;
+	put (ds,c1);
+	put (ds - CELLS,c2);
+	put (ds - CELLS * 2,c3);
+}
+
+void primitive_rot(void)
+{
+	CELL c1 = dpeek();
+	CELL c2 = get(ds - CELLS);
+	CELL c3 = get(ds - CELLS * 2);
+	put(ds,c3);
+	put(ds - CELLS,c1);
+	put(ds - CELLS * 2,c2);
+}
+
+void primitive__rot(void)
+{
+	CELL c1 = dpeek();
+	CELL c2 = get(ds - CELLS);
+	CELL c3 = get(ds - CELLS * 2);
+	put(ds,c2);
+	put(ds - CELLS,c3);
+	put(ds - CELLS * 2,c1);
+}
+
+void primitive_dupd(void)
+{
+	CELL top = dpeek();
+	CELL next = get(ds - CELLS);
+	put(ds,next);
+	put(ds - CELLS,next);
+	dpush(top);
+}
+
+void primitive_swapd(void)
+{
+	CELL top = get(ds - CELLS);
+	CELL next = get(ds - CELLS * 2);
+	put(ds - CELLS,next);
+	put(ds - CELLS * 2,top);
+}
+
+void primitive_nip(void)
+{
+	CELL top = dpop();
+	drepl(top);
+}
+
+void primitive_2nip(void)
+{
+	CELL top = dpeek();
+	ds -= CELLS * 2;
+	drepl(top);
+}
+
+void primitive_tuck(void)
 {
 	CELL top = dpeek();
 	CELL next = get(ds - CELLS);
 	put(ds,next);
 	put(ds - CELLS,top);
+	dpush(top);
 }
 
 void primitive_over(void)
@@ -60,6 +141,14 @@ void primitive_pick(void)
 	dpush(get(ds - CELLS * 2));
 }
 
+void primitive_swap(void)
+{
+	CELL top = dpeek();
+	CELL next = get(ds - CELLS);
+	put(ds,next);
+	put(ds - CELLS,top);
+}
+
 void primitive_to_r(void)
 {
 	cpush(dpop());

native/stack.h

@@ -9,10 +9,21 @@ void fix_stacks(void);
 void init_stacks(CELL ds_size, CELL cs_size);
 
 void primitive_drop(void);
+void primitive_2drop(void);
+void primitive_3drop(void);
 void primitive_dup(void);
-void primitive_swap(void);
+void primitive_2dup(void);
+void primitive_3dup(void);
+void primitive_rot(void);
+void primitive__rot(void);
+void primitive_dupd(void);
+void primitive_swapd(void);
+void primitive_nip(void);
+void primitive_2nip(void);
+void primitive_tuck(void);
 void primitive_over(void);
 void primitive_pick(void);
+void primitive_swap(void);
 void primitive_to_r(void);
 void primitive_from_r(void);
 F_VECTOR* stack_to_vector(CELL bottom, CELL top);