+ added generic exception support (still does not work!)

  + more documentation

compiler/cgbase.pas

@@ -92,6 +92,31 @@ unit cgbase;
 
           {# true, if we can not use fast exit code }
           no_fast_exit : boolean;
+          
+          {# Holds the environment reference for default exceptions 
+             
+             The exception reference is created when ansistrings
+             or classes are used. It holds buffer for exception
+             frames. It is allocted by g_new_exception.
+          }
+          exception_env_ref : treference;
+          {# Holds the environment reference for default exceptions 
+             
+             The exception reference is created when ansistrings
+             or classes are used. It holds buffer for setjmp
+             It is allocted by g_new_exception.
+          }
+          exception_jmp_ref :treference;
+          {# Holds the environment reference for default exceptions 
+             
+             The exception reference is created when ansistrings
+             or classes are used. It holds the location where
+             temporary storage of the setjmp result is stored.
+             
+             This reference can be nil, if the result is instead
+             saved on the stack.
+          }
+          exception_result_ref :treference;
 
           aktproccode,aktentrycode,
           aktexitcode,aktlocaldata : taasmoutput;
@@ -172,6 +197,7 @@ implementation
      uses
         systems,
         cresstr,
+        rgobj,
         defbase
 {$ifdef fixLeaksOnError}
         ,comphook
@@ -310,6 +336,9 @@ implementation
         aktexitcode:=Taasmoutput.Create;
         aktproccode:=Taasmoutput.Create;
         aktlocaldata:=Taasmoutput.Create;
+        reference_reset(exception_env_ref);
+        reference_reset(exception_jmp_ref);
+        reference_reset(exception_result_ref);
       end;
 
 
@@ -525,7 +554,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.19  2002-07-20 11:57:53  florian
+  Revision 1.20  2002-08-04 19:06:41  carl
+    + added generic exception support (still does not work!)
+    + more documentation
+
+  Revision 1.19  2002/07/20 11:57:53  florian
     * types.pas renamed to defbase.pas because D6 contains a types
       unit so this would conflicts if D6 programms are compiled
     + Willamette/SSE2 instructions to assembler added

compiler/cginfo.pas

@@ -30,7 +30,10 @@ interface
   uses cpuinfo,symconst;
 
     type
-       {# Generic opcodes, which must be supporrted by all processors }
+       {# Generic opcodes, which must be supported by all processors 
+          The order of this table should not be changed, since table
+          lookups are used in the different CPU code generators!
+       }   
        TOpCg =
        (
           OP_NONE,
@@ -106,7 +109,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  2002-07-07 09:52:32  florian
+  Revision 1.14  2002-08-04 19:06:41  carl
+    + added generic exception support (still does not work!)
+    + more documentation
+
+  Revision 1.13  2002/07/07 09:52:32  florian
     * powerpc target fixed, very simple units can be compiled
     * some basic stuff for better callparanode handling, far from being finished
 

compiler/cgobj.pas

@@ -1,5 +1,6 @@
 {
     $Id$
+
     Copyright (c) 1998-2002 by Florian Klaempfl
     Member of the Free Pascal development team
 
@@ -240,13 +241,54 @@ unit cgobj;
           procedure g_flags2reg(list: taasmoutput; size: TCgSize; const f: tresflags; reg: TRegister); virtual; abstract;
           procedure g_flags2ref(list: taasmoutput; size: TCgSize; const f: tresflags; const ref:TReference); virtual;
 
-          { some processors like the PPC doesn't allow to change the stack in }
-          { a procedure, so we need to maintain an extra stack for the        }
-          { result values of setjmp in exception code                         }
-          { this two procedures are for pushing an exception value,           }
-          { they can use the scratch registers                                }
-          procedure g_push_exception(list : taasmoutput;const exceptbuf:treference;l:AWord; exceptlabel:TAsmLabel);virtual;abstract;
-          procedure g_pop_exception(list : taasmoutput;endexceptlabel:tasmlabel);virtual;abstract;
+          {#
+              Allocate the buffers for exception management and setjmp environment.
+              Return a pointer to these buffers, send them to the utility routine
+              so they are registered, and then call setjmp.
+  
+              Then compare the result of setjmp with 0, and if not equal
+              to zero, then jump to exceptlabel.
+       
+              Also store the result of setjmp to a temporary space by calling g_save_exception_reason
+              
+              It is to note that this routine may be called *after* the stackframe of a
+              routine has been called, therefore on machines where the stack cannot
+              be modified, all temps should be allocated on the heap instead of the
+              stack.
+          }
+          procedure g_new_exception(list : taasmoutput;var jmpbuf,envbuf, href : treference;
+              a : aword; exceptlabel : tasmlabel);virtual;
+          procedure g_free_exception(list : taasmoutput;var jmpbuf, envbuf, href : treference;
+           a : aword ; endexceptlabel : tasmlabel; onlyfree : boolean);virtual;
+          
+         {#
+             This routine is used in exception management nodes. It should
+             save the exception reason currently in the accumulator. The
+             save should be done either to a temp (pointed to by href). 
+             or on the stack (pushing the value on the stack).
+             
+             The size of the value to save is OS_S32. 
+          }
+         procedure g_exception_reason_save(list : taasmoutput; const href : treference);virtual;
+         {#
+             This routine is used in exception management nodes. It should
+             save the exception reason constant. The
+             save should be done either to a temp (pointed to by href). 
+             or on the stack (pushing the value on the stack).
+             
+             The size of the value to save is OS_S32
+          }
+         procedure g_exception_reason_save_const(list : taasmoutput; const href : treference; a: aword);virtual;
+         {#
+             This routine is used in exception management nodes. It should
+             load the exception reason to the accumulator. The saved value
+             should either be in the temp. area (pointed to by href , href should
+             *NOT* be freed) or on the stack (the value should be popped).
+             
+             The size of the value to restore is OS_S32. 
+          }
+         procedure g_exception_reason_load(list : taasmoutput; const href : treference);virtual;
+          
 
           procedure g_maybe_loadself(list : taasmoutput);virtual;
           {# This should emit the opcode to copy len bytes from the source
@@ -372,6 +414,8 @@ unit cgobj;
         procedure a_param64_const(list : taasmoutput;value : qword;const loc : tparalocation);virtual;abstract;
         procedure a_param64_ref(list : taasmoutput;const r : treference;const loc : tparalocation);virtual;abstract;
         procedure a_param64_loc(list : taasmoutput;const l : tlocation;const loc : tparalocation);virtual;abstract;
+        
+        
 
         { override to catch 64bit rangechecks }
         procedure g_rangecheck64(list: taasmoutput; const p: tnode;
@@ -1378,6 +1422,58 @@ unit cgobj;
     procedure tcg.g_profilecode(list : taasmoutput);
       begin
       end;
+      
+      
+    procedure tcg.g_exception_reason_save(list : taasmoutput; const href : treference);
+     begin
+       a_load_reg_ref(exprasmlist, OS_S32, accumulator, href);
+     end;
+     
+    procedure tcg.g_exception_reason_save_const(list : taasmoutput; const href : treference; a: aword);
+     begin
+       a_load_const_ref(list, OS_S32, a, href);
+     end;
+     
+    procedure tcg.g_exception_reason_load(list : taasmoutput; const href : treference);
+     begin
+       a_load_ref_reg(list, OS_S32, href, accumulator);
+     end;
+     
+    
+    procedure tcg.g_new_exception(list : taasmoutput;var jmpbuf,envbuf, href : treference;
+      a : aword; exceptlabel : tasmlabel);
+     begin
+       tg.gettempofsizereferencepersistant(exprasmlist,24,jmpbuf);
+       tg.gettempofsizereferencepersistant(exprasmlist,12,envbuf);
+       a_paramaddr_ref(exprasmlist,envbuf,paramanager.getintparaloc(3));
+       a_paramaddr_ref(exprasmlist,jmpbuf,paramanager.getintparaloc(2));
+       { push type of exceptionframe }
+       a_param_const(exprasmlist,OS_S32,1,paramanager.getintparaloc(1));
+       a_call_name(exprasmlist,'FPC_PUSHEXCEPTADDR');
+
+       a_param_reg(exprasmlist,OS_ADDR,accumulator,paramanager.getintparaloc(1));
+       a_call_name(exprasmlist,'FPC_SETJMP');
+         
+       tg.gettempofsizereferencepersistant(exprasmlist,sizeof(aword),href);
+       g_exception_reason_save(list, href);
+       a_cmp_const_reg_label(exprasmlist,OS_S32,OC_NE,0,accumulator,exceptlabel);
+     end;
+     
+     
+    procedure tcg.g_free_exception(list : taasmoutput;var jmpbuf, envbuf, href : treference;
+     a : aword ; endexceptlabel : tasmlabel; onlyfree : boolean);
+     begin
+         cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+         tg.ungetpersistanttempreference(exprasmlist,jmpbuf);
+         tg.ungetpersistanttempreference(exprasmlist,envbuf);
+         
+         if not onlyfree then
+          begin
+            g_exception_reason_load(list, href);
+            cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,a,accumulator,endexceptlabel);
+          end;
+     end;
+      
 
 
     procedure tcg64.a_op64_const_reg_reg(list: taasmoutput;op:TOpCG;value : qword;regsrc,regdst : tregister64);
@@ -1392,6 +1488,8 @@ unit cgobj;
         a_load64_reg_reg(list,regsrc2,regdst);
         a_op64_reg_reg(list,op,regsrc1,regdst);
       end;
+      
+      
 
 
 finalization
@@ -1400,7 +1498,11 @@ finalization
 end.
 {
   $Log$
-  Revision 1.41  2002-07-30 20:50:43  florian
+  Revision 1.42  2002-08-04 19:08:21  carl
+    + added generic exception support (still does not work!)
+    + more documentation
+
+  Revision 1.41  2002/07/30 20:50:43  florian
     * the code generator knows now if parameters are in registers
 
   Revision 1.40  2002/07/29 21:16:02  florian

compiler/ncgflw.pas

@@ -66,6 +66,24 @@ interface
        tcgfailnode = class(tfailnode)
           procedure pass_2;override;
        end;
+       
+       tcgraisenode = class(traisenode)
+          procedure pass_2;override;
+       end;
+
+       tcgtryexceptnode = class(ttryexceptnode)
+          procedure pass_2;override;
+       end;
+
+       tcgtryfinallynode = class(ttryfinallynode)
+          procedure pass_2;override;
+       end;
+
+       tcgonnode = class(tonnode)
+          procedure pass_2;override;
+       end;
+
+       
 
 implementation
 
@@ -77,7 +95,7 @@ implementation
       nld,ncon,
       ncgutil,
       cga,
-      tgobj,rgobj,
+      tgobj,rgobj,paramgr,
       regvars,cgobj,cgcpu,cg64f32;
 
 {*****************************************************************************
@@ -612,6 +630,566 @@ do_jmp:
       end;
 
 
+{*****************************************************************************
+                             SecondRaise
+*****************************************************************************}
+
+    procedure tcgraisenode.pass_2;
+
+      var
+         a : tasmlabel;
+         href : treference;
+         href2: treference;
+      begin
+         if assigned(left) then
+           begin
+              { multiple parameters? }
+              if assigned(right) then
+                begin
+                  { push frame }
+                  if assigned(frametree) then
+                    begin
+                      secondpass(frametree);
+                      if codegenerror then
+                       exit;
+                      cg.a_param_loc(exprasmlist,frametree.location,paramanager.getintparaloc(2));
+                    end
+                  else
+                    cg.a_param_const(exprasmlist,OS_INT,0,paramanager.getintparaloc(2));
+                  { push address }
+                  secondpass(right);
+                  if codegenerror then
+                   exit;
+                  cg.a_param_loc(exprasmlist,right.location,paramanager.getintparaloc(1));
+                end
+              else
+                begin
+                   getaddrlabel(a);
+                   cg.a_label(exprasmlist,a);
+                   reference_reset_symbol(href2,a,0);
+                   cg.a_paramaddr_ref(exprasmlist,href2,paramanager.getintparaloc(2));
+                   cg.a_param_reg(exprasmlist,OS_ADDR,FRAME_POINTER_REG,paramanager.getintparaloc(3));
+                end;
+              { push object }
+              secondpass(left);
+              if codegenerror then
+                exit;
+              cg.a_param_loc(exprasmlist,left.location,paramanager.getintparaloc(1));
+              cg.a_call_name(exprasmlist,'FPC_RAISEEXCEPTION');
+           end
+         else
+           begin
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+              cg.a_call_name(exprasmlist,'FPC_RERAISE');
+           end;
+       end;
+
+
+{*****************************************************************************
+                             SecondTryExcept
+*****************************************************************************}
+
+    var
+       endexceptlabel : tasmlabel;
+       
+       
+     
+     
+
+    { does the necessary things to clean up the object stack }
+    { in the except block                                    }
+    procedure cleanupobjectstack;
+
+      begin
+         cg.a_call_name(exprasmlist,'FPC_POPOBJECTSTACK');
+         cg.a_param_reg(exprasmlist,OS_ADDR,accumulator,paramanager.getintparaloc(1));
+         cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
+         cg.g_maybe_loadself(exprasmlist);
+      end;
+
+
+    procedure tcgtryexceptnode.pass_2;
+
+      var
+         exceptlabel,doexceptlabel,oldendexceptlabel,
+         lastonlabel,
+         exitexceptlabel,
+         continueexceptlabel,
+         breakexceptlabel,
+         exittrylabel,
+         continuetrylabel,
+         breaktrylabel,
+         doobjectdestroy,
+         doobjectdestroyandreraise,
+         oldaktexitlabel,
+         oldaktexit2label,
+         oldaktcontinuelabel,
+         oldaktbreaklabel : tasmlabel;
+         oldflowcontrol,tryflowcontrol,
+         exceptflowcontrol : tflowcontrol;
+         tempbuf,tempaddr : treference;
+         href : treference;
+
+      label
+         errorexit;
+      begin
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[];
+         { this can be called recursivly }
+         oldendexceptlabel:=endexceptlabel;
+
+         { save the old labels for control flow statements }
+         oldaktexitlabel:=aktexitlabel;
+         oldaktexit2label:=aktexit2label;
+         if assigned(aktbreaklabel) then
+           begin
+              oldaktcontinuelabel:=aktcontinuelabel;
+              oldaktbreaklabel:=aktbreaklabel;
+           end;
+
+         { get new labels for the control flow statements }
+         getlabel(exittrylabel);
+         getlabel(exitexceptlabel);
+         if assigned(aktbreaklabel) then
+           begin
+              getlabel(breaktrylabel);
+              getlabel(continuetrylabel);
+              getlabel(breakexceptlabel);
+              getlabel(continueexceptlabel);
+           end;
+
+         getlabel(exceptlabel);
+         getlabel(doexceptlabel);
+         getlabel(endexceptlabel);
+         getlabel(lastonlabel);
+
+         cg.g_new_exception(exprasmlist,tempbuf,tempaddr,href,1,exceptlabel);
+         
+         { try block }
+         { set control flow labels for the try block }
+         aktexitlabel:=exittrylabel;
+         aktexit2label:=exittrylabel;
+         if assigned(oldaktbreaklabel) then
+          begin
+            aktcontinuelabel:=continuetrylabel;
+            aktbreaklabel:=breaktrylabel;
+          end;
+
+         flowcontrol:=[];
+         secondpass(left);
+         tryflowcontrol:=flowcontrol;
+         if codegenerror then
+           goto errorexit;
+
+         cg.a_label(exprasmlist,exceptlabel);
+
+                 
+         cg.g_free_exception(exprasmlist,tempbuf,tempaddr,href,0,endexceptlabel,false);
+         
+         
+         cg.a_label(exprasmlist,doexceptlabel);
+
+         { set control flow labels for the except block }
+         { and the on statements                        }
+         aktexitlabel:=exitexceptlabel;
+         aktexit2label:=exitexceptlabel;
+         if assigned(oldaktbreaklabel) then
+          begin
+            aktcontinuelabel:=continueexceptlabel;
+            aktbreaklabel:=breakexceptlabel;
+          end;
+
+         flowcontrol:=[];
+         { on statements }
+         if assigned(right) then
+           secondpass(right);
+
+         cg.a_label(exprasmlist,lastonlabel);
+         { default handling except handling }
+         if assigned(t1) then
+           begin
+              { FPC_CATCHES must be called with
+                'default handler' flag (=-1)
+              }
+              cg.a_param_const(exprasmlist,OS_ADDR,aword(-1),paramanager.getintparaloc(1));
+              cg.a_call_name(exprasmlist,'FPC_CATCHES');
+              cg.g_maybe_loadself(exprasmlist);
+
+              { the destruction of the exception object must be also }
+              { guarded by an exception frame                        }
+              getlabel(doobjectdestroy);
+              getlabel(doobjectdestroyandreraise);
+              
+              cg.g_new_exception(exprasmlist,tempbuf,tempaddr,href,1,exceptlabel);
+
+              { here we don't have to reset flowcontrol           }
+              { the default and on flowcontrols are handled equal }
+              secondpass(t1);
+              exceptflowcontrol:=flowcontrol;
+
+              cg.a_label(exprasmlist,doobjectdestroyandreraise);
+              
+              cg.g_free_exception(exprasmlist,tempbuf,tempaddr,href,0,doobjectdestroy,false);
+
+              cg.a_call_name(exprasmlist,'FPC_POPSECONDOBJECTSTACK');
+
+              cg.a_param_reg(exprasmlist, OS_ADDR, accumulator, paramanager.getintparaloc(1));
+              cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
+              { we don't need to restore esi here because reraise never }
+              { returns                                                 }
+              cg.a_call_name(exprasmlist,'FPC_RERAISE');
+
+              cg.a_label(exprasmlist,doobjectdestroy);
+              cleanupobjectstack;
+              cg.a_jmp_always(exprasmlist,endexceptlabel);
+           end
+         else
+           begin
+              cg.a_call_name(exprasmlist,'FPC_RERAISE');
+              exceptflowcontrol:=flowcontrol;
+           end;
+
+         if fc_exit in exceptflowcontrol then
+           begin
+              { do some magic for exit in the try block }
+              cg.a_label(exprasmlist,exitexceptlabel);
+              { we must also destroy the address frame which guards }
+              { exception object                                    }
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+              cg.g_exception_reason_load(exprasmlist,href);
+              cleanupobjectstack;
+              cg.a_jmp_always(exprasmlist,oldaktexitlabel);
+           end;
+
+         if fc_break in exceptflowcontrol then
+           begin
+              cg.a_label(exprasmlist,breakexceptlabel);
+              { we must also destroy the address frame which guards }
+              { exception object                                    }
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+              cg.g_exception_reason_load(exprasmlist,href);
+              cleanupobjectstack;
+              cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
+           end;
+
+         if fc_continue in exceptflowcontrol then
+           begin
+              cg.a_label(exprasmlist,continueexceptlabel);
+              { we must also destroy the address frame which guards }
+              { exception object                                    }
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+              cg.g_exception_reason_load(exprasmlist,href);
+              cleanupobjectstack;
+              cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
+           end;
+
+         if fc_exit in tryflowcontrol then
+           begin
+              { do some magic for exit in the try block }
+              cg.a_label(exprasmlist,exittrylabel);
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+              cg.g_exception_reason_load(exprasmlist,href);
+              cg.a_jmp_always(exprasmlist,oldaktexitlabel);
+           end;
+
+         if fc_break in tryflowcontrol then
+           begin
+              cg.a_label(exprasmlist,breaktrylabel);
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+              cg.g_exception_reason_load(exprasmlist,href);
+              cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
+           end;
+
+         if fc_continue in tryflowcontrol then
+           begin
+              cg.a_label(exprasmlist,continuetrylabel);
+              cg.a_call_name(exprasmlist,'FPC_POPADDRSTACK');
+              cg.g_exception_reason_load(exprasmlist,href);
+              cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
+           end;
+
+         cg.a_label(exprasmlist,endexceptlabel);
+
+       errorexit:
+         { restore all saved labels }
+         endexceptlabel:=oldendexceptlabel;
+
+         { restore the control flow labels }
+         aktexitlabel:=oldaktexitlabel;
+         aktexit2label:=oldaktexit2label;
+         if assigned(oldaktbreaklabel) then
+          begin
+            aktcontinuelabel:=oldaktcontinuelabel;
+            aktbreaklabel:=oldaktbreaklabel;
+          end;
+
+         { return all used control flow statements }
+         flowcontrol:=oldflowcontrol+exceptflowcontrol+
+           tryflowcontrol;
+      end;
+
+    procedure tcgonnode.pass_2;
+      var
+         nextonlabel,
+         exitonlabel,
+         continueonlabel,
+         breakonlabel,
+         oldaktexitlabel,
+         oldaktexit2label,
+         oldaktcontinuelabel,
+         doobjectdestroyandreraise,
+         doobjectdestroy,
+         oldaktbreaklabel : tasmlabel;
+         ref : treference;
+         oldflowcontrol : tflowcontrol;
+         tempbuf,tempaddr : treference;
+         href : treference;
+         href2: treference;
+
+      begin
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[];
+         getlabel(nextonlabel);
+
+         { send the vmt parameter }
+         reference_reset_symbol(href2,newasmsymbol(excepttype.vmt_mangledname),0);
+         cg.a_paramaddr_ref(exprasmlist,href2,paramanager.getintparaloc(1));
+         cg.a_call_name(exprasmlist,'FPC_CATCHES');
+         
+         { is it this catch? No. go to next onlabel }
+         cg.a_cmp_const_reg_label(exprasmlist,OS_ADDR,OC_EQ,0,accumulator,nextonlabel);
+         ref.symbol:=nil;
+         tg.gettempofsizereference(exprasmlist,pointer_size,ref);
+
+         { what a hack ! }
+         if assigned(exceptsymtable) then
+           tvarsym(exceptsymtable.symindex.first).address:=ref.offset;
+         cg.a_load_reg_ref(exprasmlist, OS_ADDR, accumulator, ref);
+         
+
+         { in the case that another exception is risen }
+         { we've to destroy the old one                }
+         getlabel(doobjectdestroyandreraise);
+         
+         { call setjmp, and jump to finally label on non-zero result }
+         cg.g_new_exception(exprasmlist,tempbuf,tempaddr,href,1,doobjectdestroyandreraise);
+         
+         if assigned(right) then
+           begin
+              oldaktexitlabel:=aktexitlabel;
+              oldaktexit2label:=aktexit2label;
+              getlabel(exitonlabel);
+              aktexitlabel:=exitonlabel;
+              aktexit2label:=exitonlabel;
+              if assigned(aktbreaklabel) then
+               begin
+                 oldaktcontinuelabel:=aktcontinuelabel;
+                 oldaktbreaklabel:=aktbreaklabel;
+                 getlabel(breakonlabel);
+                 getlabel(continueonlabel);
+                 aktcontinuelabel:=continueonlabel;
+                 aktbreaklabel:=breakonlabel;
+               end;
+
+              { esi is destroyed by FPC_CATCHES }
+              cg.g_maybe_loadself(exprasmlist);
+              secondpass(right);
+           end;
+         getlabel(doobjectdestroy);
+         cg.a_label(exprasmlist,doobjectdestroyandreraise);
+         
+         cg.g_free_exception(exprasmlist,tempbuf,tempaddr,href,0,doobjectdestroy,false);
+
+         cg.a_call_name(exprasmlist,'FPC_POPSECONDOBJECTSTACK');
+         cg.a_param_reg(exprasmlist, OS_ADDR, accumulator, paramanager.getintparaloc(1));
+         cg.a_call_name(exprasmlist,'FPC_DESTROYEXCEPTION');
+         { we don't need to restore esi here because reraise never }
+         { returns                                                 }
+         cg.a_call_name(exprasmlist,'FPC_RERAISE');
+
+         cg.a_label(exprasmlist,doobjectdestroy);
+         cleanupobjectstack;
+         { clear some stuff }
+         tg.ungetiftemp(exprasmlist,ref);
+         cg.a_jmp_always(exprasmlist,endexceptlabel);
+
+         if assigned(right) then
+           begin
+              { special handling for control flow instructions }
+              if fc_exit in flowcontrol then
+                begin
+                   { the address and object pop does secondtryexcept }
+                   cg.a_label(exprasmlist,exitonlabel);
+                   cg.a_jmp_always(exprasmlist,oldaktexitlabel);
+                end;
+
+              if fc_break in flowcontrol then
+                begin
+                   { the address and object pop does secondtryexcept }
+                   cg.a_label(exprasmlist,breakonlabel);
+                   cg.a_jmp_always(exprasmlist,oldaktbreaklabel);
+                end;
+
+              if fc_continue in flowcontrol then
+                begin
+                   { the address and object pop does secondtryexcept }
+                   cg.a_label(exprasmlist,continueonlabel);
+                   cg.a_jmp_always(exprasmlist,oldaktcontinuelabel);
+                end;
+
+              aktexitlabel:=oldaktexitlabel;
+              aktexit2label:=oldaktexit2label;
+              if assigned(oldaktbreaklabel) then
+               begin
+                 aktcontinuelabel:=oldaktcontinuelabel;
+                 aktbreaklabel:=oldaktbreaklabel;
+               end;
+           end;
+
+         cg.a_label(exprasmlist,nextonlabel);
+         flowcontrol:=oldflowcontrol+flowcontrol;
+         { next on node }
+         if assigned(left) then
+           begin
+              rg.cleartempgen;
+              secondpass(left);
+           end;
+      end;
+
+{*****************************************************************************
+                             SecondTryFinally
+*****************************************************************************}
+
+    procedure tcgtryfinallynode.pass_2;
+      var
+         reraiselabel,
+         finallylabel,
+         endfinallylabel,
+         exitfinallylabel,
+         continuefinallylabel,
+         breakfinallylabel,
+         oldaktexitlabel,
+         oldaktexit2label,
+         oldaktcontinuelabel,
+         oldaktbreaklabel : tasmlabel;
+         oldflowcontrol,tryflowcontrol : tflowcontrol;
+         decconst : longint;
+         tempbuf,tempaddr : treference;
+         href : treference;
+
+      begin
+         { check if child nodes do a break/continue/exit }
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[];
+         getlabel(finallylabel);
+         getlabel(endfinallylabel);
+         getlabel(reraiselabel);
+
+         { the finally block must catch break, continue and exit }
+         { statements                                            }
+         oldaktexitlabel:=aktexitlabel;
+         oldaktexit2label:=aktexit2label;
+         getlabel(exitfinallylabel);
+         aktexitlabel:=exitfinallylabel;
+         aktexit2label:=exitfinallylabel;
+         if assigned(aktbreaklabel) then
+          begin
+            oldaktcontinuelabel:=aktcontinuelabel;
+            oldaktbreaklabel:=aktbreaklabel;
+            getlabel(breakfinallylabel);
+            getlabel(continuefinallylabel);
+            aktcontinuelabel:=continuefinallylabel;
+            aktbreaklabel:=breakfinallylabel;
+          end;
+
+         { call setjmp, and jump to finally label on non-zero result }
+         cg.g_new_exception(exprasmlist,tempbuf,tempaddr,href,1,finallylabel);
+
+         { try code }
+         if assigned(left) then
+           begin
+              secondpass(left);
+              tryflowcontrol:=flowcontrol;
+              if codegenerror then
+                exit;
+           end;
+
+         cg.a_label(exprasmlist,finallylabel);
+         { just free the frame information }
+         cg.g_free_exception(exprasmlist,tempbuf,tempaddr,href,1,finallylabel,true);
+
+         { finally code }
+         flowcontrol:=[];
+         secondpass(right);
+         if flowcontrol<>[] then
+           CGMessage(cg_e_control_flow_outside_finally);
+         if codegenerror then
+           exit;
+    
+         { the value should now be in the exception handler }
+         cg.g_exception_reason_load(exprasmlist,href);  
+         cg.a_cmp_reg_reg_label(exprasmlist,OS_S32,OC_NE,accumulator,accumulator,finallylabel);
+         cg.a_op_const_reg(exprasmlist,OP_SUB,1,accumulator);
+         cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,0,accumulator,reraiselabel);
+         if fc_exit in tryflowcontrol then
+           begin
+              cg.a_op_const_reg(exprasmlist,OP_SUB,1,accumulator);
+              cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,0,accumulator,oldaktexitlabel);
+              decconst:=1;
+           end
+         else
+           decconst:=2;
+         if fc_break in tryflowcontrol then
+           begin
+              cg.a_op_const_reg(exprasmlist,OP_SUB,decconst,accumulator);
+              cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,0,accumulator,oldaktbreaklabel);
+              decconst:=1;
+           end
+         else
+           inc(decconst);
+         if fc_continue in tryflowcontrol then
+           begin
+              cg.a_op_const_reg(exprasmlist,OP_SUB,decconst,accumulator);
+              cg.a_cmp_const_reg_label(exprasmlist,OS_S32,OC_EQ,0,accumulator,oldaktcontinuelabel);
+           end;
+         cg.a_label(exprasmlist,reraiselabel);
+         cg.a_call_name(exprasmlist,'FPC_RERAISE');
+         { do some magic for exit,break,continue in the try block }
+         if fc_exit in tryflowcontrol then
+           begin
+              cg.a_label(exprasmlist,exitfinallylabel);
+              cg.g_exception_reason_load(exprasmlist,href);
+              cg.g_exception_reason_save_const(exprasmlist,href,2);
+              cg.a_jmp_always(exprasmlist,finallylabel);
+           end;
+         if fc_break in tryflowcontrol then
+          begin
+             cg.a_label(exprasmlist,breakfinallylabel);
+             cg.g_exception_reason_load(exprasmlist,href);
+             cg.g_exception_reason_save_const(exprasmlist,href,3);
+             cg.a_jmp_always(exprasmlist,finallylabel);
+           end;
+         if fc_continue in tryflowcontrol then
+           begin
+              cg.a_label(exprasmlist,continuefinallylabel);
+              cg.g_exception_reason_load(exprasmlist,href);
+              cg.g_exception_reason_save_const(exprasmlist,href,4);
+              cg.a_jmp_always(exprasmlist,finallylabel);
+           end;
+
+         cg.a_label(exprasmlist,endfinallylabel);
+
+         aktexitlabel:=oldaktexitlabel;
+         aktexit2label:=oldaktexit2label;
+         if assigned(aktbreaklabel) then
+          begin
+            aktcontinuelabel:=oldaktcontinuelabel;
+            aktbreaklabel:=oldaktbreaklabel;
+          end;
+         flowcontrol:=oldflowcontrol+tryflowcontrol;
+      end;
+
+
 
 
 begin
@@ -624,10 +1202,18 @@ begin
    cgotonode:=tcggotonode;
    clabelnode:=tcglabelnode;
    cfailnode:=tcgfailnode;
+   craisenode:=tcgraisenode;
+   ctryexceptnode:=tcgtryexceptnode;
+   ctryfinallynode:=tcgtryfinallynode;
+   connode:=tcgonnode;
 end.
 {
   $Log$
-  Revision 1.30  2002-07-27 19:53:51  jonas
+  Revision 1.31  2002-08-04 19:06:41  carl
+    + added generic exception support (still does not work!)
+    + more documentation
+
+  Revision 1.30  2002/07/27 19:53:51  jonas
     + generic implementation of tcg.g_flags2ref()
     * tcg.flags2xxx() now also needs a size parameter
 

compiler/ncginl.pas

@@ -272,9 +272,9 @@ implementation
               getlabel(lengthlab);
               cg.a_cmp_const_reg_label(exprasmlist,OS_ADDR,OC_EQ,0,hregister,lengthlab);
               reference_reset_base(href,hregister,-8);
-              cg.a_load_ref_reg(exprasmlist,OS_INT,href,hregister);
+              cg.a_load_ref_reg(exprasmlist,OS_32,href,hregister);
               cg.a_label(exprasmlist,lengthlab);
-              location_reset(location,LOC_REGISTER,OS_INT);
+              location_reset(location,LOC_REGISTER,OS_32);
               location.register:=hregister;
             end
          else
@@ -441,10 +441,11 @@ implementation
           WriteLn('Exiting assigned node!');
         end;
 
-
+*)
 {*****************************************************************************
                      INCLUDE/EXCLUDE GENERIC HANDLING
 *****************************************************************************}
+(*
       procedure tcginlinenode.second_IncludeExclude;
         var
          scratch_reg : boolean;
@@ -453,6 +454,7 @@ implementation
          L : longint;
          pushedregs : TMaybesave;
          cgop : topcg;
+         addrreg, hregister2: tregister;
          {!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
         begin
           location_copy(location,left.location);
@@ -485,48 +487,100 @@ implementation
             end
           else
             begin
+             use_small:=
+                 { set type }
+                 (tsetdef(tcallparanode(left).left.resulttype.def).settype=smallset) 
+                  and
+                   { elemenut number between 1 and 32 } 
+                  ((tcallparanode(tcallparanode(left).right).left.resulttype.def.deftype=orddef) and 
+                   (torddef(tcallparanode(tcallparanode(left).right).left.resulttype.def).high<=32) or
+                   (tcallparanode(tcallparanode(left).right).left.resulttype.def.deftype=enumdef) and 
+                   (tenumdef(tcallparanode(tcallparanode(left).right).left.resulttype.def).max<=32));
+            
               { generate code for the element to set }
               maybe_save(exprasmlist,tcallparanode(tcallparanode(left).right).left.registers32,
                         tcallparanode(left).left.location,pushedregs);
               secondpass(tcallparanode(tcallparanode(left).right).left);
               maybe_restore(exprasmlist,tcallparanode(left).left.location,pushedregs);
-              { determine asm operator }
-              if inlinenumber=in_include_x_y then
-                 asmop:=A_BTS
-              else
-                 asmop:=A_BTR;
-
-              if tcallparanode(tcallparanode(left).right).left.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
-                { we don't need a mod 32 because this is done automatically  }
-                { by the bts instruction. For proper checking we would       }
-
-                { note: bts doesn't do any mod'ing, that's why we can also use }
-                { it for normalsets! (JM)                                      }
-
-                { need a cmp and jmp, but this should be done by the         }
-                { type cast code which does range checking if necessary (FK) }
+              
+              { bitnumber - which must be loaded into register }
+              hregister := cg.get_scratch_reg_int(exprasmlist);
+              hregister2 := rg.getregisterint(exprasmlist);
+              
+              case tcallparanode(tcallparanode(left).right).left.location.loc of
+                 LOC_CREGISTER,
+                 LOC_REGISTER
+                   begin
+                     cg.a_load_reg_reg(exprasmlist,OS_INT,
+                       tcallparanode(tcallparanode(left).right).left.location.loc.register),hregister);
+                   end;
+                 LOC_REFERENCE:
+                   begin
+                     cgsize := def_cgsize(tcallparanode(tcallparanode(left).right).left.resulttype.def);
+                     cg.a_load_ref_reg(exprasmlist,cgsize,
+                       tcallparanode(tcallparanode(left).right).left.location.loc.reference),hregister);
+                   end;
+               else
+                 internalerror(20020727);
+               end;
+               { hregister contains the bitnumber to add }
+               cg.a_load_const_reg(exprasmlist, OS_INT, 1, hregister2);
+               cg.a_op_reg_reg(exprasmlist, OP_SHL, OS_INT, hregister, hregister2);
+              
+              
+              if use_small then
                 begin
-                  scratch_reg := FALSE;
-                  WriteLn('HELLO!');
-                  hregister := rg.makeregsize(tcallparanode(tcallparanode(left).right).left.location.register,OS_INT);
+                  { possiblities : 
+                       bitnumber : LOC_REFERENCE, LOC_REGISTER, LOC_CREGISTER
+                       set value : LOC_REFERENCE, LOC_REGISTER
+                  }
+                  { location of set }
+                  if (tcallparanode(left).left.location.loc=LOC_REFERENCE) then
+                    begin
+                     if inlinenumber=in_include_x_y then
+                       begin
+                         cg.a_op_reg_ref(exprasmlist, OP_OR, OS_32, hregister2, 
+                         tcallparanode(left).left.location.loc.reference);
+                       end
+                     else
+                       begin
+                         cg.a_op_reg_reg(exprasmlist, OP_NOT, OS_32, hregister2, 
+                         hregister2);
+                         cg.a_op_reg_ref(exprasmlist, OP_AND, OS_32, hregister2, 
+                         tcallparanode(left).left.location.loc.reference);
+                       end;
+                      
+                    end
+                  else
+                    internalerror(20020728);
                 end
               else
                 begin
-                  scratch_reg := TRUE;
-                  hregister:=cg.get_scratch_reg_int(exprasmlist);
-                end;
-              cg.a_load_loc_reg(exprasmlist,tcallparanode(tcallparanode(left).right).left.location,hregister);
-              if (tcallparanode(left).left.location.loc=LOC_REFERENCE) then
-                emit_reg_ref(asmop,S_L,hregister,tcallparanode(left).left.location.reference)
-              else
-                emit_reg_reg(asmop,S_L,hregister,tcallparanode(left).left.location.register);
-              if scratch_reg then
-                cg.free_scratch_reg(exprasmlist,hregister);
-            end;
-          location_reset(location,LOC_REGISTER,def_cgsize(resulttype.def));
-          location.register := rg.makeregsize(hreg,def_cgsize(resulttype.def));
+                  { possiblities : 
+                       bitnumber : LOC_REFERENCE, LOC_REGISTER, LOC_CREGISTER
+                       set value : LOC_REFERENCE
+                  }
+                  { hregister contains the bitnumber (div 32 to get the correct offset) }
+                  cg.a_op_const_reg(exprasmlist, OP_SHR, OS_INT, 5, hregister);
+                  { calculate the correct address of the operand }
+                  cg.a_loadaddr_ref_reg(exprasmlist, tcallparanode(left).left.location.loc.reference,addrreg);
+                  cg.a_op_reg_reg(exprasmlist, OP_ADD, OS_INT, hregister, addrreg);
+                  reference_reset_base(href,addrreg,0);
+                  
+                  if inlinenumber=in_include_x_y then
+                       begin
+                         cg.a_op_reg_ref(exprasmlist, OP_OR, OS_32, hregister2, href);
+                       end
+                     else
+                       begin
+                         cg.a_op_reg_reg(exprasmlist, OP_NOT, OS_32, hregister2, 
+                         hregister2);
+                         cg.a_op_reg_ref(exprasmlist, OP_AND, OS_32, hregister2, href);
+                       end;
+                       
+                  end;
+                  
         end;
-
 *)
 {*****************************************************************************
                             FLOAT GENERIC HANDLING
@@ -583,7 +637,11 @@ end.
 
 {
   $Log$
-  Revision 1.8  2002-07-31 07:54:59  jonas
+  Revision 1.9  2002-08-04 19:06:41  carl
+    + added generic exception support (still does not work!)
+    + more documentation
+
+  Revision 1.8  2002/07/31 07:54:59  jonas
     * re-enabled second_assigned()
 
   Revision 1.7  2002/07/30 20:50:43  florian

compiler/ncgutil.pas

@@ -1071,29 +1071,6 @@ implementation
       end;
 
 
-    procedure gen_exception_frame(list : taasmoutput);
-      var
-        tempbuf : treference;
-        tmpreg : tregister;
-      begin
-         include(rg.usedinproc,accumulator);
-
-         { allocate exception frame buffer }
-         { this isn't generic, several APIs doesn't }
-         { allow to change the stack pointer inside }
-         { a procedure                              }
-         { we should allocate a persistent temp.    }
-         { instead                                  }
-         cg.a_op_const_reg(list,OP_SUB,36,STACK_POINTER_REG);
-         tmpreg:=rg.getaddressregister(list);
-         cg.a_load_reg_reg(list,OS_ADDR,STACK_POINTER_REG,tmpreg);
-         reference_reset_base(tempbuf,tmpreg,0);
-         cg.g_push_exception(list,tempbuf,1,aktexitlabel);
-         reference_release(list,tempbuf);
-
-         { probably we've to reload self here }
-         cg.g_maybe_loadself(list);
-      end;
 
     procedure genentrycode(list : TAAsmoutput;
                            make_global:boolean;
@@ -1276,7 +1253,14 @@ implementation
            if ((procinfo^.flags and pi_needs_implicit_finally)<>0) and
               { but it's useless in init/final code of units }
               not(aktprocdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) then
-             gen_exception_frame(list);
+            begin
+              include(rg.usedinproc,accumulator);
+              cg.g_new_exception(list,procinfo^.exception_jmp_ref,
+                  procinfo^.exception_env_ref,
+                  procinfo^.exception_result_ref,1,aktexitlabel);
+              { probably we've to reload self here }
+              cg.g_maybe_loadself(list);
+            end;
 
 {$ifdef GDB}
            if (cs_debuginfo in aktmoduleswitches) then
@@ -1355,7 +1339,11 @@ implementation
              { the exception helper routines modify all registers }
              aktprocdef.usedregisters:=all_registers;
              getlabel(noreraiselabel);
-             cg.g_pop_exception(list,noreraiselabel);
+             cg.g_free_exception(list,
+                  procinfo^.exception_jmp_ref,
+                  procinfo^.exception_env_ref,
+                  procinfo^.exception_result_ref,0
+                ,noreraiselabel,false);
 
              if (aktprocdef.proctypeoption=potype_constructor) then
                begin
@@ -1638,7 +1626,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.28  2002-07-29 21:23:42  florian
+  Revision 1.29  2002-08-04 19:09:22  carl
+    + added generic exception support (still does not work!)
+    + more documentation
+
+  Revision 1.28  2002/07/29 21:23:42  florian
     * more fixes for the ppc
     + wrappers for the tcnvnode.first_* stuff introduced
 

compiler/rgobj.pas

@@ -46,6 +46,15 @@ unit rgobj;
 
        tpushedsaved = array[firstreg..lastreg] of tpushedsavedloc;
 
+       {# 
+          This class implements the abstract register allocator
+          It is used by the code generator to allocate and free
+          registers which might be valid across nodes. It also
+          contains utility routines related to registers.
+          
+          Some of the methods in this class should be overriden
+          by cpu-specific implementations.
+       }
        trgobj = class
           { The "usableregsxxx" contain all registers of type "xxx" that }
           { aren't currently allocated to a regvar. The "unusedregsxxx"  }
@@ -75,15 +84,37 @@ unit rgobj;
 
           constructor create;
 
+          {# Allocate a general purpose register 
+             
+             An internalerror will be generated if there
+             is no more free registers which can be allocated
+          }
           function getregisterint(list: taasmoutput) : tregister; virtual;
+          {# Free a general purpose register }
           procedure ungetregisterint(list: taasmoutput; r : tregister); virtual;
 
+          {# Allocate a floating point register 
+
+             An internalerror will be generated if there
+             is no more free registers which can be allocated
+          }
           function getregisterfpu(list: taasmoutput) : tregister; virtual;
+          {# Free a floating point register }
           procedure ungetregisterfpu(list: taasmoutput; r : tregister); virtual;
 
           function getregistermm(list: taasmoutput) : tregister; virtual;
           procedure ungetregistermm(list: taasmoutput; r : tregister); virtual;
 
+          {# Allocate an address register. 
+          
+             Address registers are the only registers which can
+             be used as a base register in references (treference).
+             On most cpu's this is the same as a general purpose
+             register.
+
+             An internalerror will be generated if there
+             is no more free registers which can be allocated
+          }
           function getaddressregister(list: taasmoutput): tregister; virtual;
           procedure ungetaddressregister(list: taasmoutput; r: tregister); virtual;
           { the following must only be called for address and integer }
@@ -106,10 +137,10 @@ unit rgobj;
           function makeregsize(reg: tregister; size: tcgsize): tregister; virtual;
 
 
-          { saves register variables (restoring happens automatically) }
+          {# saves register variables (restoring happens automatically) }
           procedure saveregvars(list: taasmoutput; const s: tregisterset);
 
-          { saves and restores used registers }
+          {# saves and restores used registers }
           procedure saveusedregisters(list: taasmoutput;
             var saved : tpushedsaved;const s: tregisterset);virtual;
           procedure restoreusedregisters(list: taasmoutput;
@@ -152,7 +183,12 @@ unit rgobj;
        rg: trgobj;
 
      { trerefence handling }
+     
+     {# Clear to zero a treference }
      procedure reference_reset(var ref : treference);
+     {# Clear to zero a treference, and set is base address
+        to base register.
+     }
      procedure reference_reset_base(var ref : treference;base : tregister;offset : longint);
      procedure reference_reset_symbol(var ref : treference;sym : tasmsymbol;offset : longint);
      procedure reference_release(list: taasmoutput; const ref : treference);
@@ -856,7 +892,11 @@ end.
 
 {
   $Log$
-  Revision 1.13  2002-07-07 09:52:32  florian
+  Revision 1.14  2002-08-04 19:06:41  carl
+    + added generic exception support (still does not work!)
+    + more documentation
+
+  Revision 1.13  2002/07/07 09:52:32  florian
     * powerpc target fixed, very simple units can be compiled
     * some basic stuff for better callparanode handling, far from being finished