diff --git a/.github/workflows/make32.yml b/.github/workflows/make32.yml index 853dc34..f866b84 100644 --- a/.github/workflows/make32.yml +++ b/.github/workflows/make32.yml @@ -27,7 +27,11 @@ jobs: - uses: actions/checkout@v2 - name: Install MultiLib to support 32-bit builds - run: sudo apt-get install gcc-multilib + run: | + sudo apt-get update + # Try a normal install with a few retries; fall back to fix-missing if needed + sudo apt-get -y --no-install-recommends -o Acquire::Retries=3 install gcc-multilib || \ + (sudo apt-get update && sudo apt-get -y --fix-missing install gcc-multilib) - name: Build and Test working-directory: ${{github.workspace}}/platforms/unix diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c index 4a65b9c..5536238 100644 --- a/csrc/pf_inner.c +++ b/csrc/pf_inner.c @@ -135,15 +135,22 @@ { \ ExceptionReturnCode = (ThrowCode)(err); \ TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \ - STKPTR = InitialDataStack; \ - FP_STKPTR = InitialFloatStack; \ + /* Restore stack depth. TOS is cached in a register so it must be \ + ** reloaded from the restored stack, not just left dangling. */ \ + STKPTR = InitialDataStack - 1; \ + TOS = M_POP; \ + FP_STKPTR = InitialFloatStack - 1; \ + FP_TOS = M_FP_POP; \ } #else #define M_THROW(err) \ { \ ExceptionReturnCode = (err); \ TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \ - STKPTR = InitialDataStack; \ + /* Restore stack depth. TOS is cached in a register so it must be \ + ** reloaded from the restored stack, not just left dangling. */ \ + STKPTR = InitialDataStack - 1; \ + TOS = M_POP; \ } #endif diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c index 4975662..c5d9eca 100644 --- a/csrc/pfcompil.c +++ b/csrc/pfcompil.c @@ -37,7 +37,7 @@ static void ffStringColon( const ForthStringPtr FName ); static cell_t CheckRedefinition( const ForthStringPtr FName ); static void ffUnSmudge( void ); -static cell_t FindAndCompile( const char *theWord ); +static cell_t FindAndCompileOrExecute( const char *theWord ); static cell_t ffCheckDicRoom( void ); #ifndef PF_NO_INIT @@ -746,7 +746,7 @@ void ffFPLiteral( PF_FLOAT fnum ) #endif /* PF_SUPPORT_FP */ /**************************************************************/ -static ThrowCode FindAndCompile( const char *theWord ) +static ThrowCode FindAndCompileOrExecute( const char *theWord ) { cell_t Flag; ExecToken XT; @@ -754,7 +754,7 @@ static ThrowCode FindAndCompile( const char *theWord ) ThrowCode exception = 0; Flag = ffFind( theWord, &XT); -DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag )); +DBUG(("FindAndCompileOrExecute: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag )); /* Is it a normal word ? */ if( Flag == -1 ) @@ -770,7 +770,7 @@ DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag } else if ( Flag == 1 ) /* or is it IMMEDIATE ? */ { -DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord )); +DBUG(("FindAndCompileOrExecute: IMMEDIATE, theWord = 0x%x\n", theWord )); exception = pfCatch( XT ); } else /* try to interpret it as a number. */ @@ -778,12 +778,12 @@ DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord )); /* Call deferred NUMBER? */ cell_t NumResult; -DBUG(("FindAndCompile: not found, try number?\n" )); +DBUG(("FindAndCompileOrExecute: not found, try number?\n" )); PUSH_PTR_DATA_STACK( theWord ); /* Push text of number */ exception = pfCatch( gNumberQ_XT ); if( exception ) goto error; -DBUG(("FindAndCompile: after number?\n" )); +DBUG(("FindAndCompileOrExecute: after number?\n" )); NumResult = POP_DATA_STACK; /* Success? */ switch( NumResult ) { @@ -853,20 +853,23 @@ ThrowCode ffInterpret( void ) { PUSH_PTR_DATA_STACK( theWord ); /* Push word. */ exception = pfCatch( gLocalCompiler_XT ); - if( exception ) goto error; + if( exception ) goto finally; flag = POP_DATA_STACK; /* Compiled local? */ } if( flag == 0 ) { - exception = FindAndCompile( theWord ); - if( exception ) goto error; + exception = FindAndCompileOrExecute( theWord ); + if( exception ) goto finally; } } DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN, gCurrentTask->td_SourceNum ) ); } -error: +finally: + if (exception) { + gVarState = 0; /* Stop compiling. */ + } pfUnlockMemory(saveSource, (const uint8_t *)(uintptr_t) gCurrentTask->td_SourcePtr); return exception; } diff --git a/fth/t_corex.fth b/fth/t_corex.fth index a45114f..748463d 100644 --- a/fth/t_corex.fth +++ b/fth/t_corex.fth @@ -180,6 +180,31 @@ T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T \ ----------------------------------------------------- SPAN T{ ' SPAN 0<> }T{ TRUE }T +\ ----------------------------------------------------- THROW CATCH +\ From https://forth-standard.org/standard/testsuite#test:exception:THROW + +DECIMAL +: t1 9 ; +: c1 1 2 3 ['] t1 CATCH ; +T{ c1 }T{ 1 2 3 9 0 }T \ No THROW executed + +: t2 8 0 THROW ; +: c2 1 2 ['] t2 CATCH ; +T{ c2 }T{ 1 2 8 0 }T \ 0 THROW does nothing + +: t3 7 8 9 99 THROW ; +: c3 1 2 ['] t3 CATCH ; +T{ c3 }T{ 1 2 99 }T \ Restores stack to CATCH depth + +: t4 ( N -- 0 ) 1- DUP 0> IF RECURSE ELSE 999 THROW -222 THEN ; +: c4 3 4 5 10 ['] t4 CATCH -111 ; \ recurse 10 times then throw +T{ c4 }T{ 3 4 5 0 999 -111 }T \ Test return stack unwinding + +: t5 2DROP 2DROP 9999 THROW ; +: c5 1 2 3 4 ['] t5 CATCH \ Test depth restored correctly + DEPTH >R DROP 2DROP 2DROP R> ; \ after stack has been emptied +T{ c5 }T{ 5 }T + \ ----------------------------------------------------- TO VALUE 333 VALUE MY-VALUE T{ MY-VALUE }T{ 333 }T diff --git a/fth/t_floats.fth b/fth/t_floats.fth index 66c49c8..99f449d 100644 --- a/fth/t_floats.fth +++ b/fth/t_floats.fth @@ -95,6 +95,7 @@ T{ 511 S>F -294 S>F F/ -0.0001 T_F. }T{ true }T fover f* LOOP matchCFA >name id. ." T.SERIES final = " fs. cr + fdrop flag ; @@ -167,5 +168,14 @@ T{ my-abcs abc.w2 @ }T{ 98765 }T : TF.123 123.456 ; T{ TF.123 123.456 0.0 F~ }T{ true }T +\ ----------------------------------------------------- CATCH THROW + +: tf99 12.34 99 THROW ; +: cf99 67.89 ['] tf99 CATCH ; +T{ cf99 99 = 67.89 0.0 F~ AND }T{ true }T \ Restores float stack FPTOS + +\ Check FDEPTH at end of tests +T{ FDEPTH }T{ 0 }T + }TEST diff --git a/fth/t_include.fth b/fth/t_include.fth index d060c76..8429441 100644 --- a/fth/t_include.fth +++ b/fth/t_include.fth @@ -25,6 +25,8 @@ T{ ." Intentional error! Test whether INCLUDE can catch an unrecognized word error." cr : F_UNDEF " t_load_undef.fth" ; -T{ F_UNDEF ' $include catch }T{ F_UNDEF -13 }T +\ $INCLUDE consumes the string address, so the cell at the restored +\ CATCH depth is unspecified per the standard. NIP discards it. +T{ 111 F_UNDEF ' $include catch nip }T{ 111 -13 }T }test diff --git a/fth/t_tools.fth b/fth/t_tools.fth index d6e8822..84a5367 100644 --- a/fth/t_tools.fth +++ b/fth/t_tools.fth @@ -22,15 +22,14 @@ variable TEST-FAILED 0 test-failed ! ; - : }TEST + STATE @ abort" STATE is non-zero in }TEST - compiling mode on!" test-passed @ 4 .r ." passed, " test-failed @ 4 .r ." failed." cr test-failed @ 0> IF TEST_EXIT_FAILURE bye-code ! THEN -; - +; immediate VARIABLE actual-depth \ stack record CREATE actual-results 20 CELLS ALLOT @@ -63,7 +62,6 @@ CREATE the-test 128 CHARS ALLOT LOOP \ save them ; - : }T \ ( ... -- ) Compare stack (expected) contents with saved \ (actual) contents. DEPTH @@ -91,3 +89,4 @@ CREATE the-test 128 CHARS ALLOT S" WRONG NUMBER OF RESULTS: " error THEN ; +