\ numout.v4 -- printing numbers: pictured output, the . words, and .S
\
\ DECOMPOSITION.md 5.8: <# # #S HOLD SIGN #>  . .R U. U.R D. D.R  ?  SPACES
\ DECIMAL HEX OCTAL, each the definition given there and executed on the mesh
\ node by test_pictured.c, test_numout.c and test_printing.c; and .S, which
\ D-16 makes possible again.  Part of the compiler capsule.  Rests on core.v4
\ and forth.v4.
\
\ Constants the loader supplies:
\   HEND      byte address just past the hold buffer, which is 64 bytes
\   -HFLOOR   minus the lowest address HOLD may store at: -(HEND - 62)
\   HLD       word address of the variable: where the picture has got to
\   (W)       word address of three cells of scratch for this file:
\             (W)+0 the width a number is to be printed in
\             (W)+1 whether a blank follows it      (W)+2 .S's count

macro (-ROT)   SWAP push SWAP pop   endmacro

\ ---- unsigned division (section 4) ----
\ One step a bit, the divisor in A.  Exact for uhi < ud.
: UM/MOD ( ulo uhi ud -- urem uquot )
  a!  N-1 FOR
    -if L0
      2* over -if L1  drop 1 + jump L2
      L1: drop  L2: push 2* pop
      jump SUB
    L0:
      2* over -if L3  drop 1 + jump L4
      L3: drop  L4: push 2* pop
      dup a xor -if L5
        drop -if NOSUB  jump SUB
      L5: drop dup inv a + inv -if L6
        drop jump NOSUB
      L6: push drop pop jump SETBIT
    SUB:    inv a + inv
    SETBIT: push 1 + pop
    NOSUB:
  NEXT
  over push push drop pop pop ;

\ ---- pictured output ----
header <#
: <#   ( -- )       HEND HLD b! !b ;
header HOLD
: HOLD ( c -- )
  dup -256 and if OKC  drop drop  NODE-ERROR b! 4 !b ;       \ not a character
  OKC: drop  HLD b! @b  -HFLOOR + -if ROOM
       drop drop  NODE-ERROR b! 3 !b ;                       \ the buffer is full
  ROOM: drop  HLD b! @b -1 + dup !b  jump C!
header SIGN
: SIGN ( n -- )     -if L1  drop 45 jump HOLD   L1: drop ;
header #
: #    ( ud1 -- ud2 )
  0 (BASE) UM/MOD  (-ROT)                    \ qhi lo rem1
  (BASE) UM/MOD  (-ROT)                      \ qlo qhi rem
  dup -10 + -if L1  drop 48 + jump L2   L1: drop 55 +   L2:  jump HOLD
header #S
: #S   ( ud -- 0 0 )   L: #  over over OR if L1  drop jump L   L1: drop ;
header #>
: #>   ( ud -- baddr u )   drop drop  HLD b! @b  HEND over  push inv pop + inv ;

\ ---- spaces and the number base ----
header SPACES
: SPACES ( n -- )   -if L  drop ;   L: if DONE  SPACE  -1 +  jump L   DONE: drop ;
header DECIMAL
: DECIMAL   10 BASE a! ! ;
header HEX
: HEX       16 BASE a! ! ;
header OCTAL
: OCTAL     8 BASE a! ! ;

\ ---- numbers ----
\ One picture for signed singles, one for unsigned, one for doubles.  Each
\ plain word is its .R word with a width of 0 and the blank flag set, and all
\ six share one tail, which prints the blank only when the flag is set.

\ ( baddr u -- )   right-justified in the width, then the blank if wanted
: (.TAIL)
  (W) b! @b  -if POS  drop jump OUT          \ width < 0
  POS:  over -  SPACES                       \ width - u spaces
  OUT:  TYPE  (W)+1 b! @b  if DONE  drop jump SPACE
  DONE: drop ;
: (.BODY)  ( n width -- )
  (W) b! !b  dup push  -if A inv 1 + A:  0 <# #S pop SIGN #>  jump (.TAIL)
: (U.BODY) ( u width -- )
  (W) b! !b  0 <# #S #>  jump (.TAIL)
: (D.BODY) ( d width -- )
  (W) b! !b  dup push  -if A DNEGATE A:  <# #S pop SIGN #>  jump (.TAIL)

header .R
: DOT-R   ( n width -- )   0 (W)+1 b! !b  jump (.BODY)
header .
: DOT     ( n -- )         -1 (W)+1 b! !b  0 jump (.BODY)
header U.R
: U-DOT-R ( u width -- )   0 (W)+1 b! !b  jump (U.BODY)
header U.
: U-DOT   ( u -- )         -1 (W)+1 b! !b  0 jump (U.BODY)
header D.R
: D-DOT-R ( d width -- )   0 (W)+1 b! !b  jump (D.BODY)
header D.
: D-DOT   ( d -- )         -1 (W)+1 b! !b  0 jump (D.BODY)

\ ( addr -- )   print what the cell holds
header ?
: QUESTION   a! @  jump DOT

\ ( -- )   as v3: the depth between < and >, then every value on the stack,
\ the deepest first, each followed by a blank; then a new line.  The stack is
\ left as it was.  It reads each value with PICK, so it needs a few cells of
\ the stack free to work in.
header .S
: DOT-S
  60 EMIT  DEPTH 0 U-DOT-R  62 EMIT SPACE
  DEPTH (W)+2 b! !b
  L: (W)+2 b! @b if DONE
     PICK DOT
     (W)+2 b! @b -1 + !b  jump L
  DONE: drop  jump CR

\ ---- DUMP ----
\ ( baddr u -- )   u bytes from the byte address baddr, sixteen to a line: the
\ address, the bytes in hex, and the bytes as characters between bars.
\ Everything it keeps between words is in (DP): the saved BASE, the address,
\ the count and the column.  ADDR-DIGITS is two for each byte of a cell.
: (DB) ( -- c )   (DP)+1 b! @b  (DP)+3 b! @b  +  jump C@
header DUMP
: DUMP
  -if OK  drop drop  NODE-ERROR b! 1 !b ;
  OK: (DP)+2 b! !b  (DP)+1 b! !b
      BASE b! @b (DP) b! !b  16 BASE b! !b
  LINE: (DP)+2 b! @b  if DONE  drop
      (DP)+1 b! @b 0 <#  ADDR-DIGITS (DP)+3 b! !b
      AD: #  (DP)+3 b! @b -1 + dup !b  if ADX  drop jump AD
      ADX: drop  #> TYPE  58 EMIT SPACE
      0 (DP)+3 b! !b
      HX: (DP)+2 b! @b  (DP)+3 b! @b inv +  -if HAVE
          drop SPACE SPACE SPACE jump HN
      HAVE: drop (DB) 0 <# # # #> TYPE SPACE
      HN: (DP)+3 b! @b 1 + dup !b  -16 + -if HXX  drop jump HX
      HXX: drop  SPACE 124 EMIT
      0 (DP)+3 b! !b
      CH: (DP)+2 b! @b  (DP)+3 b! @b inv +  -if HAVC  jump CHX
      HAVC: drop (DB)
          dup -32 + -if GE  drop drop 46 jump EM
          GE: drop  dup -127 + -if BIG  drop jump EM
          BIG: drop drop 46
          EM: EMIT
          (DP)+3 b! @b 1 + dup !b  -16 + -if CHX  drop jump CH
      CHX: drop  124 EMIT CR
      (DP)+1 b! @b 16 + !b
      (DP)+2 b! @b -16 +  -if MORE  jump DONE
      MORE: !b  jump LINE
  DONE: drop  (DP) b! @b BASE b! !b ;