+ implementation of raise and try..finally

+ some misc. exception stuff

compiler/cg386flw.pas

@@ -484,6 +484,7 @@ do_jmp:
 *****************************************************************************}
 
     procedure secondgoto(var p : ptree);
+
        begin
          emitl(A_JMP,p^.labelnr);
        end;
@@ -506,8 +507,10 @@ do_jmp:
 *****************************************************************************}
 
     procedure secondraise(var p : ptree);
+
       var
          a : plabel;
+
       begin
          if assigned(p^.left) then
            begin
@@ -515,13 +518,13 @@ do_jmp:
               if assigned(p^.right) then
                 begin
                    secondpass(p^.right);
-                       if codegenerror then
+                   if codegenerror then
-                          exit;
+                     exit;
                 end
               else
-                        begin
+                begin
                    getlabel(a);
-                           emitl(A_LABEL,a);
+                   emitl(A_LABEL,a);
                    exprasmlist^.concat(new(pai386,
                      op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(a),0))));
                 end;
@@ -536,10 +539,12 @@ do_jmp:
                        p^.left^.location.register)));
                  else Message(sym_e_type_mismatch);
               end;
-                 emitcall('DO_RAISE',true);
+              emitcall('FPC_RAISEEXCEPTION',true);
              end
            else
-             emitcall('DO_RERAISE',true);
+             begin
+                emitcall('FPC_RERAISE',true);
+             end;
        end;
 
 
@@ -548,16 +553,118 @@ do_jmp:
 *****************************************************************************}
 
     procedure secondtryexcept(var p : ptree);
-      begin
-      end;
 
+      var
+         exceptlabel,doexceptlabel,endexceptlabel,
+         nextonlabel,lastonlabel : plabel;
+
+      begin
+         { we modify EAX }
+         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
+
+         getlabel(exceptlabel);
+         getlabel(doexceptlabel);
+         getlabel(endexceptlabel);
+         getlabel(lastonlabel);
+         emitcall('FPC_PUSHEXCEPTADDR',true);
+         exprasmlist^.concat(new(pai386,
+           op_reg(A_PUSH,S_L,R_EAX)));
+         emitcall('FPC_SETJMP',true);
+         exprasmlist^.concat(new(pai386,
+           op_reg(A_PUSH,S_L,R_EAX)));
+         exprasmlist^.concat(new(pai386,
+           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+         emitl(A_JNE,exceptlabel);
+
+         { try code }
+         secondpass(p^.left);
+         if codegenerror then
+           exit;
+
+         emitl(A_LABEL,exceptlabel);
+         exprasmlist^.concat(new(pai386,
+           op_reg(A_POP,S_L,R_EAX)));
+         exprasmlist^.concat(new(pai386,
+           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+         emitl(A_JNE,doexceptlabel);
+         emitcall('FPC_POPADDRSTACK',true);
+         emitl(A_JMP,endexceptlabel);
+         emitl(A_LABEL,doexceptlabel);
+
+         { for each object: }
+         while false do
+           begin
+              getlabel(nextonlabel);
+           end;
+{
+for each 'on object' do :
+----------------
+
+pushl objectclass;  // pass object class, or -1 if no class specified.
+call FPC_CATCHES    // Does this object tacth the exception ?
+testl %eax,%eax
+je .nexton          // No, jump to next on...
+... code for on handler...
+.nexton
+...
+}
+         emitl(A_LABEL,lastonlabel);
+         { default handling }
+         if assigned(p^.t1) then
+           secondpass(p^.t1)
+         else
+           emitcall('FPC_RERAISE',true);
+         emitl(A_LABEL,endexceptlabel);
+
+      end;
 
 {*****************************************************************************
                              SecondTryFinally
 *****************************************************************************}
 
     procedure secondtryfinally(var p : ptree);
+
+      var
+         finallylabel,noreraiselabel,endfinallylabel : plabel;
+
       begin
+         { we modify EAX }
+         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
+
+         getlabel(finallylabel);
+         getlabel(noreraiselabel);
+         getlabel(endfinallylabel);
+         emitcall('FPC_PUSHEXCEPTADDR',true);
+         exprasmlist^.concat(new(pai386,
+           op_reg(A_PUSH,S_L,R_EAX)));
+         emitcall('FPC_SETJMP',true);
+         exprasmlist^.concat(new(pai386,
+           op_reg(A_PUSH,S_L,R_EAX)));
+         exprasmlist^.concat(new(pai386,
+           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+         emitl(A_JNE,finallylabel);
+
+         { try code }
+         secondpass(p^.left);
+         if codegenerror then
+           exit;
+
+         emitl(A_LABEL,finallylabel);
+
+         { finally code }
+         secondpass(p^.right);
+         if codegenerror then
+           exit;
+         exprasmlist^.concat(new(pai386,
+           op_reg(A_POP,S_L,R_EAX)));
+         exprasmlist^.concat(new(pai386,
+           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+         emitl(A_JE,noreraiselabel);
+         emitcall('FPC_RERAISE',true);
+         emitl(A_JMP,endfinallylabel);
+         emitl(A_LABEL,noreraiselabel);
+         emitcall('FPC_POPADDRSTACK',true);
+         emitl(A_LABEL,endfinallylabel);
       end;
 
 
@@ -590,7 +697,11 @@ do_jmp:
 end.
 {
   $Log$
-  Revision 1.4  1998-07-24 22:16:53  florian
+  Revision 1.5  1998-07-28 21:52:49  florian
+    + implementation of raise and try..finally
+    + some misc. exception stuff
+
+  Revision 1.4  1998/07/24 22:16:53  florian
     * internal error 10 together with array access fixed. I hope
       that's the final fix.
 

compiler/cgi386.pas

@@ -316,15 +316,17 @@ implementation
            end;
       end;
 
-
     procedure generatecode(var p : ptree);
+
       var
          i       : longint;
          regsize : topsize;
          regi    : tregister;
          hr      : preference;
+
       label
          nextreg;
+
       begin
          cleartempgen;
          { when size optimization only count occurrence }
@@ -353,8 +355,9 @@ implementation
            begin
               { max. optimizations     }
               { only if no asm is used }
+              { and no try statement   }
               if (cs_maxoptimieren in aktswitches) and
-                ((procinfo.flags and pi_uses_asm)=0) then
+                ((procinfo.flags and (pi_uses_asm or pi_uses_exceptions))=0) then
                 begin
                    { can we omit the stack frame ? }
                    { conditions:
@@ -502,7 +505,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.42  1998-07-15 16:06:44  jonas
+  Revision 1.43  1998-07-28 21:52:50  florian
+    + implementation of raise and try..finally
+    + some misc. exception stuff
+
+  Revision 1.42  1998/07/15 16:06:44  jonas
   * fixed bug that caused the stackframe never to be omitted
 
   Revision 1.41  1998/07/14 14:46:44  peter

compiler/hcodegen.pas

@@ -40,6 +40,8 @@ unit hcodegen;
        pi_do_call   = $4;       { set, if the procedure does a call }
        pi_operator  = $8;       { set, if the procedure is an operator   }
        pi_C_import  = $10;      { set, if the procedure is an external C function }
+       pi_uses_exceptions = $20;{ set, if the procedure has a try statement => }
+                                { no register variables                        }
 
     type
        pprocinfo = ^tprocinfo;
@@ -403,7 +405,11 @@ end.
 
 {
   $Log$
-  Revision 1.10  1998-07-20 18:40:13  florian
+  Revision 1.11  1998-07-28 21:52:51  florian
+    + implementation of raise and try..finally
+    + some misc. exception stuff
+
+  Revision 1.10  1998/07/20 18:40:13  florian
     * handling of ansi string constants should now work
 
   Revision 1.9  1998/06/05 16:13:34  pierre

compiler/pass_1.pas

@@ -4769,6 +4769,20 @@ unit pass_1;
     procedure firsttryfinally(var p : ptree);
 
       begin
+         cleartempgen;
+         must_be_valid:=true;
+         firstpass(p^.left);
+
+         cleartempgen;
+         must_be_valid:=true;
+         firstpass(p^.right);
+         if codegenerror then
+           exit;
+         p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+         p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
       end;
 
     procedure firstis(var p : ptree);
@@ -5100,7 +5114,11 @@ unit pass_1;
 end.
 {
   $Log$
-  Revision 1.45  1998-07-26 21:58:59  florian
+  Revision 1.46  1998-07-28 21:52:52  florian
+    + implementation of raise and try..finally
+    + some misc. exception stuff
+
+  Revision 1.45  1998/07/26 21:58:59  florian
    + better support for switch $H
    + index access to ansi strings added
    + assigment of data (records/arrays) containing ansi strings

compiler/pexpr.pas

@@ -683,7 +683,7 @@ unit pexpr;
       procedure postfixoperators;
 
         begin
-             check_tokenpos;
+           check_tokenpos;
            while again do
              begin
                 case token of
@@ -1788,7 +1788,11 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.29  1998-07-27 21:57:13  florian
+  Revision 1.30  1998-07-28 21:52:54  florian
+    + implementation of raise and try..finally
+    + some misc. exception stuff
+
+  Revision 1.29  1998/07/27 21:57:13  florian
     * fix to allow tv like stream registration:
         @tmenu.load doesn't work if load had parameters or if load was only
         declared in an anchestor class of tmenu

compiler/pstatmnt.pas

@@ -483,6 +483,9 @@ unit pstatmnt;
          old_in_except_block : boolean;
 
       begin
+         procinfo.flags:=procinfo.flags or
+           pi_uses_exceptions;
+
          p_default:=nil;
          p_specific:=nil;
 
@@ -541,11 +544,11 @@ unit pstatmnt;
                           { !!!!! }
                        end;
                      consume(_DO);
-                                         statement;
+                     statement;
-                                         if token<>SEMICOLON then
+                     if token<>SEMICOLON then
-                                           break;
+                       break;
-                                         emptystats;
+                     emptystats;
-                                   until false;
+                   until false;
                    if token=_ELSE then
                      { catch the other exceptions }
                      begin
@@ -1168,7 +1171,11 @@ unit pstatmnt;
 end.
 {
   $Log$
-  Revision 1.26  1998-07-27 21:57:14  florian
+  Revision 1.27  1998-07-28 21:52:55  florian
+    + implementation of raise and try..finally
+    + some misc. exception stuff
+
+  Revision 1.26  1998/07/27 21:57:14  florian
     * fix to allow tv like stream registration:
         @tmenu.load doesn't work if load had parameters or if load was only
         declared in an anchestor class of tmenu