Added generic input buffer words IB and #IB.
[forth.jl.git] / src / lib_4_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