\ printf
\ Neal Bridges, 1999.
decimal

: binary  2 base ! ;
: octal  8 base ! ;

[undefined] ud.r [if]
\ Same function as D.R, but unsigned.
: ud.r  rot rot <# #s #> rot over -  spaces  type ;
: u.r  0 swap ud.r ;
: .r  >r s>d  r> d.r ;
[then]

variable .numbervector

: .number ( x1...x? index fieldwidth -- index )
\ Display stack items x1...x? using the xt in .numbervector.
\ Right align the data in a field of fieldwidth spaces.
  swap >r  .numbervector @
  execute r> ;

: parsenum ( caddr -- nextcaddr dnum )
\ Parse and extract from a string a leading double-cell unsigned number.
  0 s>d  rot  255 \ max string length of number
  ( 0. caddr 255 -- )  >number
  drop \ residual length of string -- not valid
  rot rot ( nextcaddr dnum -- ) ;

: %spec ( caddr -- caddr+1 )
\ Handle most printf-style % format specifiers.
  \ Default to single cell unsigned representation:
  ['] .r .numbervector !
  char+
  decimal parsenum drop \ extract field width specifier (if present)
  over c@ case
  [char] c of  drop swap emit  endof
  [char] s of  swap >r >r dup r>  swap - spaces type  r>  endof
  [char] % of  drop [char] % emit endof
  [char] d of  decimal rot 
    s>d rot d.r  endof  \ Signed
  [char] u of  decimal .number  endof
  [char] p of  drop 0 hex ." 0x" .number endof
  [char] X of  hex .number endof
  [char] o of  octal .number endof
  [char] b of  binary .number  endof  \ not ANSI C
  \ Default:
    abort" Unsupported format specifier."
  endcase ;

: \spec ( caddr -- caddr+1 )
\ Handle most printf-style \ escapes.
  char+ dup  c@ case
    [char] x of  char+  hex parsenum drop  emit  
    \ Backup one char to compensate for parsenum:
    -1 chars +
  endof
  [char] n of  cr   endof  \ Newline
  [char] f of  page    endof  \ Form feed

\ These work properly under Linux, etc. :
\  [char] a of  beep  endof  \ Bell
\  [char] b of  8 emit  endof  \ Backspace
\  [char] t of  9 emit  endof  \ Tab
  dup [char] 0 - dup 7 and =  \ Octal?
  if  drop octal parsenum drop
  \ Backup one char to compensate for parsenum:
  swap -1 chars + swap
  then \ fall through to Default
\ Default:
  emit
  0 endcase ;

: printf ( c u )
  base @ >r
  chars over + ( index limit -- )
  begin  2dup < while
    >r  dup c@ case
      [char] % of  %spec  endof
      [char] \ of  \spec  endof	
      emit
  0 endcase
  char+ r>  repeat
  2drop  r> base ! ;