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#> ;