urflibs/dbl-dpl-parse.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 ;; very simple and limited support for double numbers, with "DPL"
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10
  11 -1 uservar DPL
  12
  13 vocabulary (dbl-dpl-parser)
  14 also-defs: (dbl-dpl-parser)
  15
  16 ;; convert the ASCII text beginning at addr with regard to BASE.
  17 ;; the new value is accumulated into unsigned double number ud0, being left as ud1.
  18 ;; addr1 and count1 are unparsed part of the string
  19 ;; will never read more than count bytes
  20 ;; doesn't skip any spaces, doesn't parse prefixes and signs
  21 ;; but skips '_'
  22 : dnumber-parse-simple  ( addr count ud0lo ud0hi -- addr1 count1 ud1lo ud1hi )
  23   2over nip 0> if
  24     2>r  ( addr count | ud )
  25     ;; first must be a digit
  26     over c@ base @ string:digit? if
  27       ;; main loop
  28       begin dup while  ( addr count | u )
  29         over c@
  30         dup [char] _ = if drop  ;; skip '_'
  31         else  ;; try digit
  32           base @ string:digit ifnot break endif
  33           2r> base @ uds* rot u>d d+ 2>r
  34         endif
  35         string:/char
  36       repeat
  37     endif
  38     2r>
  39   endif
  40 ;
  41
  42 : >number  ( ud1 c-addr1 count -- ud2 c-addr2 count )
  43   2swap dnumber-parse-simple 2swap
  44 ;
  45
  46 ;; convert a character string left at addr to a signed number, using the current numeric base
  47 : number-dbl-dpl  ( addr count -- ud 1 // d -1 // addr count false )
  48   ;; check length
  49   dup 0> ifnot false exit endif
  50   2dup 2>r  ;; for failure exit
  51   ;; ok, we have at least one char; check for a sign
  52   over c@ case
  53     [char] - of string:/char true endof
  54     [char] + of string:/char false endof
  55     otherwise drop false
  56   endcase nrot  ;; ( negflag addr count )
  57   ;; should have at least one char to work with
  58   dup 0> ifnot 2drop drop 2r> false exit endif
  59   0 u>d 2swap >number  ;; ( negflag ud addr count )
  60   dup ifnot  ;; no more chars
  61     2drop drop  ;; drop str, and convert double to single
  62     swap if negate endif
  63     -1 dpl !  2rdrop true
  64   else  ;; have some more chars
  65     over c@ [char] . = ifnot 2drop 2drop 2r> false exit endif
  66     string:/char dup >r >number  ;; ( negflag ud addr count | oldcount )
  67     if rdrop 2drop 2drop 2r> false exit endif  ;; too many chars
  68     r> dpl ! 2rdrop drop rot if dnegate endif
  69     -1
  70   endif
  71 ;
  72
  73 ..: forth:(interpret-word-not-found)  ( addr count FALSE -- addr count FALSE / TRUE )
  74   ifnot
  75     number-dbl-dpl dup if
  76       compiler:comp? if
  77         0< if swap literal endif literal
  78       else drop endif
  79       true
  80     endif
  81   else false
  82   endif
  83 ;..
  84
  85 prev-defs
  86
  87 $IF 0
  88 1.4 . . cr
  89 $ENDIF