forth: implement "0b" number parsing

Modest first step

emul/forth/forth.c

@@ -8,9 +8,13 @@
 // in sync with glue.asm
 #define RAMSTART 0x900
 #define STDIO_PORT 0x00
+// This binary is also used for automated tests and those tests, when
+// failing, send a non-zero value to RET_PORT to indicate failure
+#define RET_PORT 0x01
 
 static int running;
 static FILE *fp;
+static int retcode = 0;
 
 static uint8_t iord_stdio()
 {
@@ -30,6 +34,12 @@ static void iowr_stdio(uint8_t val)
     }
 }
 
+static void iowr_ret(uint8_t val)
+{
+    retcode = val;
+}
+
+
 int main(int argc, char *argv[])
 {
     bool tty = false;
@@ -61,6 +71,7 @@ int main(int argc, char *argv[])
     m->ramstart = RAMSTART;
     m->iord[STDIO_PORT] = iord_stdio;
     m->iowr[STDIO_PORT] = iowr_stdio;
+    m->iowr[RET_PORT] = iowr_ret;
     // initialize memory
     for (int i=0; i<sizeof(KERNEL); i++) {
         m->mem[i] = KERNEL[i];
@@ -78,5 +89,5 @@ int main(int argc, char *argv[])
         emul_printdebug();
     }
     fclose(fp);
-    return 0;
+    return retcode;
 }

forth/dictionary.txt

@@ -194,3 +194,7 @@ PC!         c a --          Spit c to port a
 PC@         a -- c          Fetch c from port a
 WORD        -- a            Read one word from buffered input and push its addr
 
+There are also ascii const emitters:
+LF
+SPC
+

forth/parse.fs

@@ -27,7 +27,7 @@
 : (parseh)          ( a -- n f )
     ( '0': ASCII 0x30 'x': 0x78 0x7830: 30768 )
     DUP @ 30768 = NOT IF 0 EXIT THEN    ( a 0 )
-    ( We have "0x" suffix )
+    ( We have "0x" prefix )
     2 +
     ( validate slen )
     DUP SLEN                            ( a l )
@@ -44,9 +44,40 @@
     AGAIN
 ;
 
+( returns negative value on error )
+: bindig            ( c -- n )
+    ( '0' is ASCII 48 )
+    48 -
+    DUP 0 < IF EXIT THEN                ( bad )
+    DUP 2 < IF EXIT THEN                ( good )
+    ( bad )
+    255 -
+;
+
+: (parseb)          ( a -- n f )
+    ( '0': ASCII 0x30 'b': 0x62 0x6230: 25136 )
+    DUP @ 25136 = NOT IF 0 EXIT THEN    ( a 0 )
+    ( We have "0b" prefix )
+    2 +
+    ( validate slen )
+    DUP SLEN                            ( a l )
+    DUP 0 = IF DROP 0 EXIT THEN         ( a 0 )
+    16 > IF DROP 0 EXIT THEN            ( a 0 )
+    0 ( a r )
+    BEGIN
+    OVER C@
+    DUP 0 = IF DROP SWAP DROP 1 EXIT THEN ( r, 1 )
+    bindig                              ( a r n )
+    DUP 0 < IF DROP DROP 1 EXIT THEN    ( a 0 )
+    SWAP 2 * +                          ( a r*2+n )
+    SWAP 1 + SWAP                       ( a+1 r )
+    AGAIN
+;
+
 : (parse)           ( a -- n )
     (parsec) NOT SKIP? EXIT
     (parseh) NOT SKIP? EXIT
+    (parseb) NOT SKIP? EXIT
     (parsed) NOT SKIP? EXIT
     ( nothing works )
     ABORT" unknown word! "

forth/str.fs

@@ -5,3 +5,6 @@
     1 +
     AGAIN
 ;
+
+: LF 10 EMIT ;
+: SPC 32 EMIT ;

tests/Makefile

@@ -2,8 +2,9 @@ EMULDIR = ../emul
 
 .PHONY: run
 run:
-	$(MAKE) -C $(EMULDIR) zasm/zasm zasm/avra runbin/runbin shell/shell
+	$(MAKE) -C $(EMULDIR) zasm/zasm zasm/avra runbin/runbin shell/shell forth/forth
 	cd unit && ./runtests.sh
 	cd zasm && ./runtests.sh
 	cd avra && ./runtests.sh
 	cd shell && ./runtests.sh
+	cd forth && ./runtests.sh

tests/forth/harness.fs

@@ -0,0 +1,9 @@
+( Forth testing harness
+  "#" means "assert". We stop at first failure, indicating
+  the failure through IO on port 1 )
+
+: fail SPC ." failed" LF 1 1 PC! BYE ;
+
+: # SKIP? fail SPC ." pass" LF ;
+
+: #eq 2DUP SWAP . SPC '=' EMIT SPC . '?' EMIT = # ;

tests/forth/runtests.sh

@@ -0,0 +1,27 @@
+#!/bin/sh -e
+
+BASE=../..
+EXEC="${BASE}/emul/forth/forth"
+FDIR="${BASE}/forth"
+TMP=$(mktemp)
+
+chk() {
+    echo "Running test $1"
+    cat harness.fs $1 > ${TMP}
+    if ! ${EXEC} ${TMP}; then
+        exit 1
+    fi
+}
+
+if [ ! -z $1 ]; then
+    chk $1
+    exit 0
+fi
+
+# those tests run without any builtin
+for fn in test_*.fs; do
+    chk "${fn}"
+done
+
+echo "All tests passed!"
+rm ${TMP}

tests/forth/test_ari.fs

@@ -0,0 +1,5 @@
+48 13 + 61 #eq
+48 13 - 35 #eq
+48 13 * 624 #eq
+48 13 / 3 #eq
+48 13 MOD 9 #eq

tests/forth/test_parse.fs

@@ -0,0 +1,2 @@
+'b' 0x62 #eq
+0b1111010101 981 #eq