src/lib_5_printnum.4th

   1 \ Displaying numbers
   2
   3 ( Write n spaces to stdout. )
   4 : SPACES        ( n -- )
   5         DUP 0> IF
   6             0 DO SPACE LOOP
   7         ELSE
   8             DROP
   9         THEN
  10 ;
  11 ( This is the underlying recursive definition of U. )
  12 : U.            ( u -- )
  13         BASE @ /MOD     ( width rem quot )
  14         ?DUP IF                 ( if quotient <> 0 then )
  15                 RECURSE         ( print the quotient )
  16         THEN
  17
  18         ( print the remainder )
  19         DUP 10 < IF
  20                 [CHAR] 0             ( decimal digits 0..9 )
  21         ELSE
  22                 10 -            ( hex and beyond digits A..Z )
  23                 [CHAR] A
  24         THEN
  25         +
  26         EMIT
  27 ;
  28
  29 ( This word returns the width (in characters) of an unsigned number in the current base )
  30 : UWIDTH        ( u -- width )
  31         BASE @ /        ( rem quot )
  32         ?DUP IF         ( if quotient <> 0 then )
  33                 RECURSE 1+      ( return 1+recursive call )
  34         ELSE
  35                 1               ( return 1 )
  36         THEN
  37 ;
  38
  39 : U.R           ( u width -- )
  40         SWAP            ( width u )
  41         DUP             ( width u u )
  42         UWIDTH          ( width u uwidth )
  43         ROT            ( u uwidth width )
  44         SWAP -          ( u width-uwidth )
  45         ( At this point if the requested width is narrower, we'll have a negative number on the stack.
  46           Otherwise the number on the stack is the number of spaces to print.  But SPACES won't print
  47           a negative number of spaces anyway, so it's now safe to call SPACES ... )
  48         SPACES
  49         ( ... and then call the underlying implementation of U. )
  50         U.
  51 ;
  52
  53 : .R            ( n width -- )
  54         SWAP            ( width n )
  55         DUP 0< IF
  56                 NEGATE          ( width u )
  57                 1               ( save a flag to remember that it was negative | width n 1 )
  58                 -ROT             ( 1 width u )
  59                 SWAP            ( 1 u width )
  60                 1-              ( 1 u width-1 )
  61         ELSE
  62                 0               ( width u 0 )
  63                 -ROT             ( 0 width u )
  64                 SWAP            ( 0 u width )
  65         THEN
  66         SWAP            ( flag width u )
  67         DUP             ( flag width u u )
  68         UWIDTH          ( flag width u uwidth )
  69         ROT            ( flag u uwidth width )
  70         SWAP -          ( flag u width-uwidth )
  71
  72         SPACES          ( flag u )
  73         SWAP            ( u flag )
  74
  75         IF                      ( was it negative? print the - character )
  76                 [CHAR] - EMIT
  77         THEN
  78
  79         U.
  80 ;
  81
  82 : . 0 .R SPACE ;
  83
  84 : .S            ( -- )
  85         [CHAR] < EMIT DEPTH U. [CHAR] > EMIT SPACE
  86         PSP0 1+
  87         BEGIN
  88                 DUP PSP@ 2 - <=
  89         WHILE
  90                 DUP @ .
  91                 1+
  92         REPEAT
  93         DROP
  94 ;
  95
  96 : U. U. SPACE ;
  97
  98 ( ? fetches the integer at an address and prints it. )
  99 : ? ( addr -- ) @ . ;
 100
 101 ( c a b WITHIN returns true if a <= c and c < b )
 102 : WITHIN
 103         -ROT             ( b c a )
 104         OVER            ( b c a c )
 105         <= IF
 106                 > IF            ( b c -- )
 107                         TRUE
 108                 ELSE
 109                         FALSE
 110                 THEN
 111         ELSE
 112                 2DROP           ( b c -- )
 113                 FALSE
 114         THEN
 115 ;
 116