1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; and now
for something completely different
...
3 ;; UrForth
/C Forth Engine
!
4 ;; Copyright
(C
) 2023 Ketmar Dark
// Invisible Vector
6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 ;; very simple and limited support
for double numbers
, with
"DPL"
8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 VOCABULARY
(DBL
-DPL
-PARSER
)
14 ALSO
-DEFS
: (DBL
-DPL
-PARSER
)
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
22 : dnumber
-parse
-simple
( addr count ud0lo ud0hi
-- addr1 count1 ud1lo ud1hi
)
24 2>r
( addr count | ud
)
25 ;; first must be a digit
26 over c@ base @ string
:digit?
if
28 begin dup
while ( addr count | u
)
30 dup
[char
] _
= if drop
;; skip
'_'
32 base @ string
:digit ifnot
break endif
33 2r
> base @ uds* rot u
>d d
+ 2>r
42 : >number
( ud1 c
-addr1 count
-- ud2 c
-addr2 count
)
43 2swap dnumber
-parse
-simple
2swap
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
)
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
53 [char
] - of string
:/char true endof
54 [char
] + of string
:/char false endof
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
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
73 ..: FORTH
:(INTERPRET
-WORD
-NOT
-FOUND
) ( addr count FALSE
-- addr count FALSE
/ TRUE
)
77 0< if swap
[compile
] literal
endif [compile
] literal