Cleaning up throw values around division + faults.

common/base_tests.fs

@@ -157,3 +157,63 @@ e: test-2@2!
   123 =assert
   999 =assert
 ;e
+
+e: test-/
+  101 2 / 50 =assert
+  101 -2 / -51 =assert
+  -101 -2 / 50 =assert
+  -101 2 / -51 =assert
+
+  100 2 / 50 = assert
+  100 -2 / -50 = assert
+  -100 -2 / 50 = assert
+  -100 2 / -50 = assert
+;e
+
+e: test-mod
+  101 2 mod 1 =assert
+  101 -2 mod -1 =assert
+  -101 -2 mod -1 =assert
+  -101 2 mod 1 =assert
+
+  100 2 mod 0 =assert
+  100 -2 mod 0 =assert
+  -100 -2 mod 0 =assert
+  -100 2 mod 0 =assert
+;e
+
+e: test-/mod-consistent
+  101 2 /mod 50 =assert 1 =assert
+  101 -2 /mod -51 =assert -1 =assert
+  -101 -2 /mod 50 =assert -1 =assert
+  -101 2 /mod -51 =assert 1 =assert
+
+  100 2 /mod 50 = assert 0 =assert
+  100 -2 /mod -50 = assert 0 =assert
+  -100 -2 /mod 50 = assert 0 =assert
+  -100 2 /mod -50 = assert 0 =assert
+;e
+
+e: test-/mod-consistent
+  : /mod-check { a b -- } a b /mod b * + a = assert ;
+  101 2 /mod-check
+  101 -2 /mod-check
+  -101 2 /mod-check
+  -101 -2 /mod-check
+  100 2 /mod-check
+  100 -2 /mod-check
+  -100 2 /mod-check
+  -100 -2 /mod-check
+;e
+
+e: test-*/
+  50 2 4 */ 25 =assert
+  -50 2 4 */ -25 =assert
+;e
+
+e: test-/cell
+  10 cells cell/ 10 =assert
+  10 cells 1+ cell/ 10 =assert
+  -10 cells cell/ -10 =assert
+  -10 cells 1- cell/ -11 =assert
+;e

common/throw_values_tests.fs

@@ -23,3 +23,54 @@ e: test-abort"
   ' test catch -2 =assert
   out: doh!
 ;e
+
+( Skip on ESP32 as not emulated. )
+DEFINED? esp 0= [IF]
+
+e: test-0/
+  123 0 ' / catch -10 =assert
+  0 =assert 123 =assert
+;e
+
+e: test-0mod
+  123 0 ' mod catch -10 =assert
+  0 =assert 123 =assert
+;e
+
+e: test-0*/
+  123 456 0 ' */ catch -10 =assert
+  0 =assert 456 =assert 123 =assert
+;e
+
+e: test-0*/mod
+  123 456 0 ' */mod catch -10 =assert
+  0 =assert 456 =assert 123 =assert
+;e
+
+e: test-0/mod
+  123 0 ' /mod catch -10 =assert
+  0 =assert 123 =assert
+;e
+
+e: test-bad-load
+  0 ' @ catch -9 =assert
+  0 =assert
+;e
+
+e: test-bad-store
+  123 0 ' ! catch -9 =assert
+  0 =assert 123 =assert
+;e
+
+( Skip on win64 because wine can't handle these, unsure why. )
+DEFINED? windows 0= cell 4 = or [IF]
+
+e: test-bad-execute
+  internals
+  0 ' call0 catch -9 =assert
+  0 =assert
+;e
+
+[THEN]
+
+[THEN]

common/tier0_opcodes.h

@@ -66,10 +66,30 @@ typedef int64_t dcell_t;
 #  error "unsupported cell size"
 # endif
 # define SSMOD_FUNC dcell_t d = (dcell_t) *sp * (dcell_t) sp[-1]; \
-                    --sp; cell_t a = (cell_t) (d < 0 ? ~(~d / tos) : d / tos); \
+                    --sp; cell_t a = (cell_t) (d / tos); \
+                    a = a * tos == d ? a : a - ((d < 0) ^ (tos < 0)); \
                     *sp = (cell_t) (d - ((dcell_t) a) * tos); tos = a
 #endif
 
+#ifdef WEB_DUMP
+// Use */mod as the base for the web version.
+# define SLASHMOD_FUNC DUP; *sp = 1; SSMOD_FUNC
+# define SLASH_FUNC SLASHMOD_FUNC; NIP
+# define MOD_FUNC SLASHMOD_FUNC; DROP
+# define CELLSLASH_FUNC DUP; tos = sizeof(cell_t); SLASH_FUNC
+#else
+// Use separate versions for non-web so throw has the right depth.
+# define SLASHMOD_FUNC cell_t d = *sp; cell_t a = d / tos; \
+                       cell_t b = a * tos == d ? a : a - ((d < 0) ^ (tos < 0)); \
+                       *sp = d - b * tos; tos = b
+# define SLASH_FUNC cell_t d = *sp; cell_t a = d / tos; NIP; \
+                    tos = a * tos == d ? a : a - ((d < 0) ^ (tos < 0))
+# define MOD_FUNC cell_t d = *sp; cell_t a = d / tos; \
+                  cell_t b = a * tos == d ? a : a - ((d < 0) ^ (tos < 0)); \
+                  NIP; tos = d - b * tos
+# define CELLSLASH_FUNC tos = tos < 0 ? ~(~tos / sizeof(cell_t)) : tos / sizeof(cell_t)
+#endif
+
 typedef struct {
   const char *name;
   union {

common/tier1_opcodes.h

@@ -17,9 +17,9 @@
   Y(rdrop, --rp) \
   XV(forth, "*/", STARSLASH, SSMOD_FUNC; NIP) \
   X("*", STAR, tos *= *sp--) \
-  X("/mod", SLASHMOD, DUP; *sp = 1; SSMOD_FUNC) \
+  X("/mod", SLASHMOD, SLASHMOD_FUNC) \
-  X("/", SLASH, DUP; *sp = 1; SSMOD_FUNC; NIP) \
+  X("/", SLASH, SLASH_FUNC) \
-  Y(mod, DUP; *sp = 1; SSMOD_FUNC; DROP) \
+  X("mod", MOD, MOD_FUNC) \
   Y(invert, tos = ~tos) \
   Y(negate, tos = -tos) \
   X("-", MINUS, tos = (*sp--) - tos) \
@@ -44,7 +44,7 @@
   X("+!", PLUSSTORE, *((cell_t *) tos) += *sp--; DROP) \
   X("cell+", CELLPLUS, tos += sizeof(cell_t)) \
   Y(cells, tos *= sizeof(cell_t)) \
-  X("cell/", CELLSLASH, DUP; tos = sizeof(cell_t); DUP; *sp = 1; SSMOD_FUNC; NIP) \
+  X("cell/", CELLSLASH, CELLSLASH_FUNC) \
   X("2drop", TWODROP, NIP; DROP) \
   X("2dup", TWODUP, DUP; tos = sp[-1]; DUP; tos = sp[-1]) \
   X("2@", TWOAT, DUP; *sp = *(cell_t *) tos; tos = ((cell_t *) tos)[1]) \

esp32/faults.h

@@ -23,10 +23,22 @@ static __thread int g_forth_signal;
 static __thread uint32_t g_forth_setlevel;
 
 #define FAULT_ENTRY \
-  if (setjmp(g_forth_fault)) { THROWIT(-g_forth_signal); }
+  if (setjmp(g_forth_fault)) { THROWIT(g_forth_signal); }
 
 static void IRAM_ATTR forth_exception_handler(XtExcFrame *frame) {
-  g_forth_signal = frame->exccause;
+  switch (frame->exccause) {
+    case EXCCAUSE_LOAD_STORE_ERROR:
+    case EXCCAUSE_LOAD_PROHIBITED:
+    case EXCCAUSE_STORE_PROHIBITED:
+    case EXCCAUSE_LOAD_STORE_DATA_ERROR:
+    case EXCCAUSE_LOAD_STORE_RING:
+    case EXCCAUSE_LOAD_STORE_ADDR_ERROR:
+      g_forth_signal = -9;
+      break;
+    case EXCCAUSE_DIVIDE_BY_ZERO: g_forth_signal = -10; break;
+    case EXCCAUSE_UNALIGNED: g_forth_signal = -23; break;
+    default: g_forth_signal = -256 - frame->exccause; break;
+  }
   XTOS_RESTORE_INTLEVEL(g_forth_setlevel);
   longjmp(g_forth_fault, 1);
 }

posix/faults.h

@@ -19,10 +19,16 @@ static __thread jmp_buf g_forth_fault;
 static __thread int g_forth_signal;
 
 #define FAULT_ENTRY \
-  if (setjmp(g_forth_fault)) { THROWIT(-g_forth_signal); }
+  if (setjmp(g_forth_fault)) { THROWIT(g_forth_signal); }
 
 static void forth_signal_handler(int sig) {
-  g_forth_signal = sig;
+  switch (sig) {
+    case SIGSEGV: g_forth_signal = -9; break;
+    case SIGBUS: g_forth_signal = -23; break;
+    case SIGINT: g_forth_signal = -28; break;
+    case SIGFPE: g_forth_signal = -10; break;
+    default: g_forth_signal = -256 - sig; break;
+  }
   sigset_t ss;
   sigemptyset(&ss);
   sigprocmask(SIG_SETMASK, &ss, 0);

web/dump_web_opcodes.c

@@ -17,6 +17,7 @@
 
 #define JMPW continue decode
 #define SSMOD_FUNC SSMOD_FUNC
+#define WEB_DUMP
 #define COMMA COMMA
 
 #include "common/tier0_opcodes.h"

web/web.template.js

@@ -192,10 +192,6 @@ function SSMOD(sp) {
   a *= b;
   var x = Math.floor(a / c);
   var m = a - x * c;
-  if (m < 0) {
-    x--;
-    m += c;
-  }
   i32[(sp - 8)>>2] = m;
   i32[sp>>2] = x;
 }

windows/interp.h

@@ -62,7 +62,12 @@ work:
         }
       }
     } __except (EXCEPTION_EXECUTE_HANDLER) {
-      THROWIT(GetExceptionCode());
+      DWORD code = GetExceptionCode();
+      switch (code) {
+        case EXCEPTION_INT_DIVIDE_BY_ZERO: THROWIT(-10); break;
+        case EXCEPTION_ACCESS_VIOLATION: THROWIT(-9); break;
+        default: THROWIT(code); break;
+      }
     }
   }
 }