diff --git a/Makefile b/Makefile index 3321a02..c3e0647 100644 --- a/Makefile +++ b/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 ---- diff --git a/common/bits.h b/common/bits.h index 2015fc1..b05d430 100644 --- a/common/bits.h +++ b/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 diff --git a/common/boot.fs b/common/boot.fs index 4a6f313..3fd7db4 100644 --- a/common/boot.fs +++ b/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 ; diff --git a/common/interp.h b/common/interp.h index bb188dc..febecd5 100644 --- a/common/interp.h +++ b/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 +#include +#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 diff --git a/common/io.fs b/common/io.fs index 3c929b1..e7406ae 100644 --- a/common/io.fs +++ b/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 - if 0 state ! sp0 sp! fp0 fp! rp0 rp! ." ERROR" cr then - prompt refill drop again ; +: evaluate&fill + begin >in @ #tib @ >= if prompt refill drop then evaluate-buffer 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 ; diff --git a/common/tier1_opcodes.h b/common/tier1_opcodes.h index efbea80..cf71fb3 100644 --- a/common/tier1_opcodes.h +++ b/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) \ diff --git a/common/vocabulary.fs b/common/vocabulary.fs index 2086e70..2347bbb 100644 --- a/common/vocabulary.fs +++ b/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 diff --git a/posix/autoboot.fs b/posix/autoboot.fs index 723f51b..298dcd0 100644 --- a/posix/autoboot.fs +++ b/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 diff --git a/web/dump_web_opcodes.c b/web/dump_web_opcodes.c index 7caec38..6fdaa29 100644 --- a/web/dump_web_opcodes.c +++ b/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);