Fix CATCH corrupting the stack

.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

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
 

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,15 +746,15 @@ 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;
     cell_t Num;
     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,20 +770,20 @@ 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. */
     {
 /* 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;
 }

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

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
 

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

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
 ;
+