urflibs/init/bootstrap/35-num-print.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;; additional math
  10 ;;
  11
  12 : MIN  ( a b -- max-of-a-b )  2DUP > IF SWAP ENDIF DROP ;
  13 : MAX  ( a b -- max-of-a-b )  2DUP < IF SWAP ENDIF DROP ;
  14 : CLAMP  ( val a b -- clamped-val )  SWAP ROT MAX MIN ;
  15
  16 : UMIN  ( a b -- max-of-a-b )  2DUP U> IF SWAP ENDIF DROP ;
  17 : UMAX  ( a b -- max-of-a-b )  2DUP U< IF SWAP ENDIF DROP ;
  18 : UCLAMP  ( val a b -- clamped-val )  SWAP ROT UMAX UMIN ;
  19
  20
  21 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;; print number to buffer
  23 ;;
  24
  25 <HIDDEN-WORDS>
  26 ;; the buffer is right before PAD
  27 ;; allocate number translation buffer
  28 \ 0x3464_97AF HANDLE:NEW CONSTANT (#BUF)  ;; arbitrary typeid
  29 \ FORTH:(MAX-HANDLE-OFS) 1+ CONSTANT (#BUF-SIZE)
  30 \ (#BUF-SIZE) (#BUF) HANDLE:SIZE!
  31 (#BUF) (#BUF-SIZE) + CONSTANT (#BUF-END)
  32 \ 0 VARIABLE (#BUF-OFS)
  33 (#BUF) 4- CONSTANT (#BUF-OFS)
  34 <PUBLIC-WORDS>
  35
  36
  37 : HOLD  ( ch -- )
  38   (#BUF-END)
  39   (#BUF-OFS) @  DUP (#BUF-SIZE) U>= " number too long" ?ERROR
  40   1+ DUP (#BUF-OFS) !
  41   - C!
  42 ;
  43
  44 : HOLDS ( addr u -- )  BEGIN DUP WHILE 1- 2DUP + C@ HOLD REPEAT 2DROP ;
  45
  46 ;; add '-'
  47 : SIGN  ( n -- )
  48   0< IF [CHAR] - HOLD ENDIF
  49 ;
  50
  51 : <#  ( n -- n )
  52   (#BUF-OFS) 0!
  53 ;
  54
  55 : #>  ( n -- addr count )
  56   DROP
  57   (#BUF-OFS) @ (#BUF-END) OVER - SWAP
  58 ;
  59
  60 : #  ( n -- n )
  61   BASE @ U/MOD  ( n/base n%base )
  62   48 + DUP 57 > IF 7 + ENDIF
  63   HOLD
  64 ;
  65
  66 : #S  ( n -- 0 )
  67   BEGIN # DUP NOT-UNTIL
  68 ;
  69
  70 : #SIGNED  ( n -- 0 )
  71   DUP 0< DUP >R IF NEGATE ENDIF
  72   #S R> IF [CHAR] - HOLD ENDIF
  73 ;
  74
  75 : .  ( n -- )  <# #SIGNED #> TYPE SPACE ;
  76
  77 : .R  ( n width -- )
  78   >R <# #SIGNED #>   ( addr count | width )
  79   DUP R> SWAP - SPACES TYPE
  80 ;
  81
  82 : U.  ( n -- )  <# #S #> TYPE SPACE ;
  83
  84 : U.R  ( n width -- )
  85   >R <# #S #>   ( addr count | width )
  86   DUP R> SWAP - SPACES TYPE
  87 ;
  88
  89 : 0.R  ( n -- )  <# #SIGNED #> TYPE ;
  90 : 0U.R  ( n -- )  <# #S #> TYPE ;
  91
  92 \ " AAAAAAAAAAAAAAAAAAAAAAAAAAAA\n" TYPE
  93 \ 669 . cr
  94 \ " AAAAAAAAAAAAAAAAAAAAAAAAAAAA\n" TYPE