Adding posix signal handling.

Makefile

@@ -345,6 +345,8 @@ $(WEB)/ueforth.js: \
 
 # ---- POSIX ----
 
+POSIX_CFLAGS = -DHAS_SIGNALS
+
 posix: posix_target posix_tests
 posix_target: $(POSIX)/ueforth
 
@@ -363,7 +365,7 @@ $(POSIX)/ueforth: \
     common/bits.h \
     common/core.h \
     $(GEN)/posix_boot.h | $(POSIX)
-	$(CXX) $(CFLAGS) $< -o $@ $(LIBS)
+	$(CXX) $(CFLAGS) $(POSIX_CFLAGS) $< -o $@ $(LIBS)
 	strip $(STRIP_ARGS) $@
 
 # ---- WINDOWS ----

common/bits.h

@@ -29,6 +29,7 @@ typedef struct {
   int argc;
   char **argv;
   cell_t *(*runner)(cell_t *rp);  // pointer to forth_run
+  cell_t **throw_handler;
 
   // Layout not used by Forth.
   cell_t *rp;  // spot to park main thread

common/boot.fs

@@ -81,6 +81,7 @@ create I ' r@ @ ' i !  ( i is same as r@ )
 
 ( Exceptions )
 variable handler
+handler 'throw-handler !
 : catch ( xt -- n )
   fp@ >r sp@ >r handler @ >r rp@ handler ! execute
   r> handler ! rdrop rdrop 0 ;

common/interp.h

@@ -12,10 +12,28 @@
 // See the License for the specific language governing permissions and
 // limitations under the License.
 
+#ifdef HAS_SIGNALS
+#include <setjmp.h>
+#include <signal.h>
+#endif
+
 #define JMPW goto **(void **) w
 #define NEXT w = *ip++; JMPW
 #define ADDROF(x) (&& OP_ ## x)
 
+#ifdef HAS_SIGNALS
+static __thread jmp_buf g_forth_fault;
+static __thread int g_forth_signal;
+
+static void forth_signal_handler(int sig) {
+  g_forth_signal = sig;
+  sigset_t ss;
+  sigemptyset(&ss);
+  sigprocmask(SIG_SETMASK, &ss, 0);
+  longjmp(g_forth_fault, 1);
+}
+#endif
+
 static cell_t *forth_run(cell_t *init_rp) {
   static const BUILTIN_WORD builtins[] = {
 #define Z(flags, name, op, code) \
@@ -32,11 +50,30 @@ static cell_t *forth_run(cell_t *init_rp) {
   if (!init_rp) {
     g_sys->DOCREATE_OP = ADDROF(DOCREATE);
     g_sys->builtins = builtins;
+#ifdef HAS_SIGNALS
+    struct sigaction sa;
+    memset(&sa, 0, sizeof(sa));
+    sa.sa_handler = forth_signal_handler;
+    sigaction(SIGSEGV, &sa, 0);
+    sigaction(SIGBUS, &sa, 0);
+    sigaction(SIGINT, &sa, 0);
+#endif
     return 0;
   }
   register cell_t *ip, *rp, *sp, tos, w;
   register float *fp, ft;
-  rp = init_rp; UNPARK; NEXT;
+  rp = init_rp; UNPARK;
+#ifdef HAS_SIGNALS
+  if (setjmp(g_forth_fault)) {
+    rp = *g_sys->throw_handler;
+    *g_sys->throw_handler = (cell_t *) *rp--;
+    sp = (cell_t *) *rp--;
+    fp = (float *) *rp--;
+    --sp;
+    tos = -g_forth_signal;
+  }
+#endif
+  NEXT;
 #define Z(flags, name, op, code) OP_ ## op: { code; } NEXT;
   PLATFORM_OPCODE_LIST
   TIER2_OPCODE_LIST

common/io.fs

@@ -104,9 +104,13 @@ sp0 'stack-cells @ 2 3 */ cells + constant sp-limit
 : evaluate ( a n -- ) 'tib @ >r #tib @ >r >in @ >r
                       #tib ! 'tib ! 0 >in ! evaluate-buffer
                       r> >in ! r> #tib ! r> 'tib ! ;
-: quit    begin ['] evaluate-buffer catch
+: evaluate&fill
-          if 0 state ! sp0 sp! fp0 fp! rp0 rp! ." ERROR" cr then
+   begin >in @ #tib @ >= if prompt refill drop then evaluate-buffer again ;
-          prompt refill drop again ;
+: quit
+   #tib @ >in !
+   begin ['] evaluate&fill catch
+         if 0 state ! sp0 sp! fp0 fp! rp0 rp! ."  ERROR " cr then
+   again ;
 variable boot-prompt
 : free. ( nf nu -- ) 2dup swap . ." free + " . ." used = " 2dup + . ." total ("
                      over + 100 -rot */ n. ." % free)" ;
@@ -114,4 +118,4 @@ variable boot-prompt
            boot-prompt @ if boot-prompt @ execute then
            ." Forth dictionary: " remaining used free. cr
            ." 3 x Forth stacks: " 'stack-cells @ cells . ." bytes each" cr
-           prompt refill drop quit ;
+           quit ;

common/tier1_opcodes.h

@@ -80,6 +80,7 @@
   XV(internals, "'argc", ARGC, DUP; tos = (cell_t) &g_sys->argc) \
   XV(internals, "'argv", ARGV, DUP; tos = (cell_t) &g_sys->argv) \
   XV(internals, "'runner", RUNNER, DUP; tos = (cell_t) &g_sys->runner) \
+  XV(internals, "'throw-handler", TTHROW_HANDLER, DUP; tos = (cell_t) &g_sys->throw_handler) \
   Y(context, DUP; tos = (cell_t) (g_sys->context + 1)) \
   Y(latestxt, DUP; tos = (cell_t) g_sys->latestxt) \
   XV(forth_immediate, "[", LBRACKET, g_sys->state = 0) \

common/vocabulary.fs

@@ -55,7 +55,7 @@ transfer{
   voc-stack-end last-vocabulary notfound
   *key *emit wascr eat-till-cr
   immediate? input-buffer ?echo ?arrow. arrow
-  evaluate-buffer aliteral value-bind
+  evaluate-buffer evaluate&fill aliteral value-bind
   leaving( )leaving leaving leaving,
   parse-quote digit $@ raw.s
   tib-setup input-limit sp-limit ?stack

posix/autoboot.fs

@@ -13,12 +13,12 @@
 \ limitations under the License.
 
 ( Include first argument if any )
-internals definitions
+posix also internals definitions
 : autoexec
    ( Open passed file if any. )
-   argc 2 >= if 1 argv included exit then
+   argc 2 >= if 1 argv ['] included catch if 1 sysexit then exit then
    ( Open remembered file if any. )
    ['] revive catch drop
 ;
 ' autoexec ( leave on dstack for fini.fs )
-forth definitions
+only forth definitions

web/dump_web_opcodes.c

@@ -97,6 +97,7 @@ int main(int argc, char *argv[]) {
     EMITSYS(argc);
     EMITSYS(argv);
     EMITSYS(runner);
+    EMITSYS(throw_handler);
     EMITSYS(rp);
     EMITSYS(DOLIT_XT);
     EMITSYS(DOFLIT_XT);