level1/28_print_number.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 $uservar "(HLD)" ua_ofs_hld 0
   8 (hidden)
   9
  10
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12 : HEX     ( -- )  16 base ! ;
  13 : DECIMAL ( -- )  10 base ! ;
  14 : OCTAL   ( -- )  8 base ! ;
  15 : BINARY  ( -- )  2 base ! ;
  16
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 : (HLD-INIT-ADDR)  ( -- addr )  pad 1-  ;
  20
  21 : HOLD  ( ch -- )
  22   (hld) @ 1- dup (hld) ! c!
  23 ;
  24
  25 ;; prepend the string
  26 : HOLDS  ( addr count -- )
  27   begin dup +while 1- 2dup + c@ hold repeat 2drop
  28 ;
  29
  30 : SIGN  ( n -- )
  31   -if [char] - hold endif
  32 ;
  33
  34 : <#  ( d -- d )
  35   (hld-init-addr) (hld) !
  36 ;
  37
  38 : <#U  ( n -- d )
  39   0 <#
  40 ;
  41
  42 : #>  ( d -- addr count )
  43   2drop (hld) @ (hld-init-addr) over -
  44 ;
  45
  46 : #  ( d -- n )
  47   base @ uds/mod dup 9 > if 7 + endif
  48   48 + hold
  49 ;
  50
  51 : #S  ( d -- d )
  52   begin # 2dup or not-until
  53 ;
  54
  55
  56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57 : (U.)  ( u -- addr count )  <#u #s #> ;
  58 : (.)  ( n -- addr count )  dup abs <#u #s rot sign #> ;
  59
  60 : (x.r)  ( fldlen addr count -- )  rot over - spaces type ;
  61
  62 : U.R  ( u fldlen -- )  swap (u.) (x.r) ;
  63 : .R  ( n fldlen -- )  swap (.) (x.r) ;
  64
  65 : U.  ( u -- )  (u.) type space ;
  66 : .  ( n -- )  (.) type space ;
  67
  68
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70 : (UD.)  ( ud -- addr count )  <# #s #> ;
  71 : (D.)  ( d -- addr count )  dup nrot dabs <# #s rot sign #> ;
  72
  73 : UD.R  ( ud fldlen -- )  nrot (ud.) (x.r) ;
  74 : D.R  ( d fldlen -- )  nrot (d.) (x.r) ;
  75
  76 : UD.  ( ud -- ) (ud.) type space ;
  77 : D.  ( ud -- ) (d.) type space ;
  78
  79
  80 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81 ;; 8 bytes
  82 $uservar "(hex-print-buf)" ua_ofs_hexprbuf 0
  83 (hidden)
  84 $userallot 4
  85
  86 ;; uses (hex-print-buf)
  87 code: (.HEX8)  ( u -- addr count )
  88   lea   edi,[ua_ofs_hexprbuf+8]
  89   ld    ebx,TOS
  90   ld    ecx,8    ;; digits
  91 .digloop:
  92   ld    eax,ebx  ;; to break register dependency
  93   Nibble2Hex
  94   dec   edi
  95   ld    ts:[edi],al
  96   shr   ebx,4
  97   dec   ecx
  98   jr    nz,.digloop
  99  $if URFORTH_TLS_TYPE = URFORTH_TLS_TYPE_FS
 100   ;; convert from TLS to real address
 101   add   edi,ts:[ua_ofs_baseaddr]
 102  $endif
 103   push  edi
 104   ld    TOS,8
 105   urnext
 106 endcode
 107
 108 : .HEX8  ( u -- )  (.hex8) type ;
 109
 110 : (.HEX2)  ( u -- addr count )  (.hex8) drop 6 + 2 ;
 111 : .HEX2  ( u -- )  (.hex2) type ;
 112
 113 : (.HEX4)  ( u -- addr count )  (.hex8) drop 4 + 4 ;
 114 : .HEX4  ( u -- )  (.hex4) type ;