From 59ed031ca49c8fd68f37f1177336c97f2d37ac5d Mon Sep 17 00:00:00 2001
From: Jesse McDonald <nybble41@gmail.com>
Date: Sat, 24 Oct 2020 14:12:30 -0500
Subject: [PATCH] add parsing for binary, octal, and hexadecimal literals

---
 startup.4th | 68 ++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 52 insertions(+), 16 deletions(-)

diff --git a/startup.4th b/startup.4th
index d6db7dc..b7ffc29 100644
--- a/startup.4th
+++ b/startup.4th
@@ -74,6 +74,8 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER!
 
 \ Decrement the array size and increment the address by the same amount
 : /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ;
+\ Semantically equivalent to "1 /STRING"
+: 1/STRING ( c-addr u -- c-addr+1 u-1 ) 1- SWAP 1+ SWAP ;
 
 \ Standard (ANS FORTH) THROW code assignments (-255 ... -1)
 -1 CONSTANT EXCP-ABORT
@@ -929,6 +931,51 @@ CREATE LEAVE-ORIG 0 ,
    LOOP
    2DROP R> SIGNUM ;
 
+\ True if n1 >= n2 && n1 <= n3, false otherwise
+: WITHIN ( n1|u1 n2|u2 n3|u3 -- flag )
+   OVER - -ROT - U>= ;
+
+\ Convert a character to lowercase or uppercase, respectively
+: TO-LOWER ( ch1 -- ch2 )
+   DUP [CHAR] A [CHAR] Z WITHIN IF [ CHAR a CHAR A - ] LITERAL + THEN ;
+: TO-UPPER ( ch1 -- ch2 )
+   DUP [CHAR] a [CHAR] z WITHIN IF [ CHAR a CHAR A - ] LITERAL - THEN ;
+
+\ If ch is a digit (any base) return the value in range [0, 36) and TRUE
+\ Otherwise just return FALSE
+: >DIGIT ( ch -- u TRUE | FALSE )
+   DUP [CHAR] 0 [CHAR] 9 WITHIN IF [CHAR] 0 - TRUE EXIT THEN
+   DUP [CHAR] A [CHAR] Z WITHIN IF [ CHAR A 10 - ] LITERAL - TRUE EXIT THEN
+   DUP [CHAR] a [CHAR] z WITHIN IF [ CHAR a 10 - ] LITERAL - TRUE EXIT THEN
+   DROP FALSE ;
+
+\ Convert a string in the given base to an unsigned double-cell number
+\ Stop at the end of the string or when the next character is not valid for the base
+\ Return the double-cell number and the remainder of the string
+: >NUMBER-BASE ( c-addr1 u1 base -- ud c-addr2 u2 )
+   >R 0 0 2SWAP
+   BEGIN
+      DUP 0= IF RDROP EXIT THEN
+      OVER C@ >DIGIT 0= IF RDROP EXIT THEN
+      DUP R@ U>= IF RDROP DROP EXIT THEN
+      >R 1/STRING 2SWAP 2R@ DROP 0 D* R> 0 D+ 2SWAP
+   AGAIN ;
+
+: >NUMBER ( c-addr1 u1 -- ud c-addr2 u2 )
+   DUP 0= IF 0 0 2SWAP EXIT THEN
+   OVER C@ [CHAR] 0 = IF
+      1/STRING
+      DUP 0= IF 0 0 2SWAP EXIT THEN
+      OVER C@ TO-UPPER CASE
+         [CHAR] B OF 1/STRING 2 ENDOF
+         [CHAR] X OF 1/STRING 16 ENDOF
+         8 SWAP
+      ENDCASE
+   ELSE
+      10
+   THEN
+   >NUMBER-BASE ;
+
 \ Copy the bootstrap SOURCE values into variables to allow changing the input buffer
 CREATE INPUT-BUFFER SOURCE 2,
 
@@ -1765,22 +1812,11 @@ CREATE TIB-LEFTOVER-BYTES 0 ,
 
 : PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE )
    DUP 0= IF FALSE EXIT THEN
-   2>R 2R@ DROP C@ [CHAR] - = 0
-   ( S: neg-flag accum ) ( R: c-addr u )
-   OVER IF R@ 1 = IF 2DROP 2R> FALSE EXIT THEN THEN
-   OVER 2R@ ROT IF 1- SWAP 1+ SWAP THEN
-   ( S: neg-flag accum c-addr' u' ) ( R: c-addr u )
-   BEGIN ?DUP WHILE
-      OVER -ROT 2>R C@ [CHAR] 0 -
-      ( S: neg-flag accum digit ) ( R: c-addr u c-addr' u' )
-      DUP 9 U> IF DROP 2DROP 2RDROP 2R> FALSE EXIT THEN
-      SWAP 10 * + 2R>
-      ( S: neg-flag accum' c-addr' u' ) ( R: c-addr u )
-      1- SWAP 1+ SWAP
-   REPEAT
-   ( S: neg-flag accum c-addr' ) ( R: c-addr u )
-   2RDROP DROP SWAP IF NEGATE THEN
-   TRUE ;
+   2DUP OVER C@ [CHAR] - = DUP >R IF
+      1/STRING DUP 0= IF 2DROP RDROP FALSE EXIT THEN
+   THEN
+   >NUMBER DUP 0<> IF 2DROP 2DROP RDROP FALSE EXIT THEN
+   2DROP 2NIP DROP R> IF NEGATE THEN TRUE ;
 
 \ Read a word, number, or string and either execute it or compile it
 \ The stack effect depends on the input and the current value of STATE