r1428 - forth/kernel

Author: wmb
Date: 2009-10-23 11:20:34 +0200 (Fri, 23 Oct 2009)
New Revision: 1428

Modified:
   forth/kernel/double.fth
   forth/kernel/kernel.fth
Log:
Fixed a couple of longstanding kernel bugs in words that are - apparently -
infrequently used.  Tip o' the hat to Segher Boessenkool.

Modified: forth/kernel/double.fth
===================================================================
--- forth/kernel/double.fth	2009-10-22 23:34:55 UTC (rev 1427)
+++ forth/kernel/double.fth	2009-10-23 09:20:34 UTC (rev 1428)
@@ -8,9 +8,9 @@
 : d0<   ( d -- flag )  nip 0<  ;
 : d=    ( d1 d2 -- flag )  d- d0=  ;
 : d<>   ( d1 d2 -- flag )  d=  0=  ;
-: d<    (  d1  d2 -- flag )  rot  swap  2dup <>  if  2swap  then  2drop  <  ;
+: d<    (  d1  d2 -- flag )  2 pick over  2dup =  if  drop nip u<  else  nip < nip  then  ;
 : du<   ( ud1 ud2 -- flag )  rot  swap  2dup <>  if  2swap  then  2drop u<  ;
-
+: d<    ( d1 d2 -- flag )  2 pick over = if drop nip u< else nip < nip then  ;
 : dnegate  ( d -- -d )  0 0  2swap  d-  ;
 : dabs     ( d -- +d )  2dup  d0<  if  dnegate  then  ;

Modified: forth/kernel/kernel.fth
===================================================================
--- forth/kernel/kernel.fth	2009-10-22 23:34:55 UTC (rev 1427)
+++ forth/kernel/kernel.fth	2009-10-23 09:20:34 UTC (rev 1428)
@@ -130,7 +130,7 @@
 : (.)   (s n -- a len )   dup abs  <# u#s   swap sign   u#>   ;
 : s.    (s n -- )       (.)   type space   ;
 : .r    (s n l -- )     >r   (.)   r> over - spaces   type   ;
-: 0.r   (s n l -- )     >r (u.) r> over - 0  ?do  ascii 0 emit  loop  type ;
+: 0.r   (s n l -- )     0 max  >r (u.) r> over - 0  ?do  ascii 0 emit  loop  type ;

: (.2)  (s u -- a len )  <# u# u# u#>   ;
 : (.4)  (s u -- a len )  <# u# u# u# u# u#>   ;