+ first implementation of try ... except on .. do end;

  * limitiation of 65535 bytes parameters for cdecl removed

compiler/cg386flw.pas

@@ -37,6 +37,7 @@ interface
     procedure secondraise(var p : ptree);
     procedure secondtryexcept(var p : ptree);
     procedure secondtryfinally(var p : ptree);
+    procedure secondon(var p : ptree);
     procedure secondfail(var p : ptree);
 
 
@@ -552,13 +553,18 @@ do_jmp:
                              SecondTryExcept
 *****************************************************************************}
 
+    var
+       endexceptlabel : plabel;
+
     procedure secondtryexcept(var p : ptree);
 
       var
-         exceptlabel,doexceptlabel,endexceptlabel,
+         exceptlabel,doexceptlabel,oldendexceptlabel,
          nextonlabel,lastonlabel : plabel;
 
       begin
+         { this can be called recursivly }
+         oldendexceptlabel:=endexceptlabel;
          { we modify EAX }
          usedinproc:=usedinproc or ($80 shr byte(R_EAX));
 
@@ -592,23 +598,9 @@ do_jmp:
          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
-...
-}
+         if assigned(p^.right) then
+           secondpass(p^.right);
+
          emitl(A_LABEL,lastonlabel);
          { default handling }
          if assigned(p^.t1) then
@@ -616,7 +608,37 @@ je .nexton          // No, jump to next on...
          else
            emitcall('FPC_RERAISE',true);
          emitl(A_LABEL,endexceptlabel);
+         endexceptlabel:=oldendexceptlabel;
+      end;
+
+    procedure secondon(var p : ptree);
 
+      var
+         nextonlabel,myendexceptlabel : plabel;
+         ref : treference;
+
+      begin
+         getlabel(nextonlabel);
+         emitcall('FPC_CATCHES',true);
+         exprasmlist^.concat(new(pai386,
+           op_reg_reg(A_TEST,S_L,R_EAX,R_EAX)));
+         emitl(A_JE,nextonlabel);
+         ref.symbol:=nil;
+         gettempofsizereference(4,ref);
+         { what a hack ! }
+         pvarsym(p^.exceptsymtable^.root)^.address:=ref.offset;
+
+         emitpushreferenceaddr(exprasmlist,ref);
+         emitcall('FPC_LOADEXCEPTIONPOINTER',true);
+         if assigned(p^.right) then
+           secondpass(p^.right);
+         { clear some stuff }
+         ungetiftemp(ref);
+         emitl(A_JMP,endexceptlabel);
+         emitl(A_LABEL,nextonlabel);
+         { next on node }
+         if assigned(p^.left) then
+           secondpass(p^.left);
       end;
 
 {*****************************************************************************
@@ -663,7 +685,6 @@ je .nexton          // No, jump to next on...
            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);
@@ -699,7 +720,11 @@ je .nexton          // No, jump to next on...
 end.
 {
   $Log$
-  Revision 1.6  1998-07-29 13:29:11  michael
+  Revision 1.7  1998-07-30 11:18:13  florian
+    + first implementation of try ... except on .. do end;
+    * limitiation of 65535 bytes parameters for cdecl removed
+
+  Revision 1.6  1998/07/29 13:29:11  michael
   + Corrected try.. code. Type of exception fram is pushed
 
   Revision 1.5  1998/07/28 21:52:49  florian

compiler/cgi386.pas

@@ -223,7 +223,8 @@ implementation
              secondstatement,secondnothing,secondifn,secondbreakn,
              secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
              secondexitn,secondwith,secondcase,secondlabel,
-             secondgoto,secondsimplenewdispose,secondtryexcept,secondraise,
+             secondgoto,secondsimplenewdispose,secondtryexcept,
+             secondon,secondraise,
              secondnothing,secondtryfinally,secondis,secondas,seconderror,
              secondfail,secondadd,secondprocinline,
              secondnothing,secondloadvmt);
@@ -505,7 +506,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.43  1998-07-28 21:52:50  florian
+  Revision 1.44  1998-07-30 11:18:15  florian
+    + first implementation of try ... except on .. do end;
+    * limitiation of 65535 bytes parameters for cdecl removed
+
+  Revision 1.43  1998/07/28 21:52:50  florian
     + implementation of raise and try..finally
     + some misc. exception stuff
 

compiler/pass_1.pas

@@ -4764,11 +4764,36 @@ unit pass_1;
     procedure firsttryexcept(var p : ptree);
 
       begin
+         cleartempgen;
+         firstpass(p^.left);
+
+         { on statements }
+         if assigned(p^.right) then
+           begin
+              cleartempgen;
+              firstpass(p^.right);
+              p^.registers32:=max(p^.registers32,p^.right^.registers32);
+              p^.registersfpu:=max(p^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=max(p^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+           end;
+         { else block }
+         if assigned(p^.t1) then
+           begin
+              firstpass(p^.right);
+              p^.registers32:=max(p^.registers32,p^.t1^.registers32);
+              p^.registersfpu:=max(p^.registersfpu,p^.t1^.registersfpu);
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=max(p^.registersmmx,p^.t1^.registersmmx);
+{$endif SUPPORT_MMX}
+           end;
       end;
 
     procedure firsttryfinally(var p : ptree);
 
       begin
+         p^.resulttype:=voiddef;
          cleartempgen;
          must_be_valid:=true;
          firstpass(p^.left);
@@ -4916,6 +4941,39 @@ unit pass_1;
            end;
       end;
 
+    procedure firstonn(var p : ptree);
+
+      begin
+         { that's really an example procedure for a firstpass :) }
+         cleartempgen;
+         p^.resulttype:=voiddef;
+         p^.registers32:=0;
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         if assigned(p^.left) then
+           begin
+              firstpass(p^.left);
+              p^.registers32:=p^.left^.registers32;
+              p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+           end;
+
+         cleartempgen;
+         if assigned(p^.right) then
+           begin
+              firstpass(p^.right);
+              p^.registers32:=max(p^.registers32,p^.right^.registers32);
+              p^.registersfpu:=max(p^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=max(p^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+           end;
+      end;
+
     procedure firstprocinline(var p : ptree);
 
       begin
@@ -5025,7 +5083,8 @@ unit pass_1;
              firststatement,firstnothing,firstif,firstnothing,
              firstnothing,first_while_repeat,first_while_repeat,firstfor,
              firstexitn,firstwith,firstcase,firstlabel,
-             firstgoto,firstsimplenewdispose,firsttryexcept,firstraise,
+             firstgoto,firstsimplenewdispose,firsttryexcept,
+             firstonn,firstraise,
              firstnothing,firsttryfinally,firstis,firstas,firstadd,
              firstnothing,firstadd,firstprocinline,firstnothing,firstloadvmt);
 
@@ -5114,7 +5173,11 @@ unit pass_1;
 end.
 {
   $Log$
-  Revision 1.46  1998-07-28 21:52:52  florian
+  Revision 1.47  1998-07-30 11:18:17  florian
+    + first implementation of try ... except on .. do end;
+    * limitiation of 65535 bytes parameters for cdecl removed
+
+  Revision 1.46  1998/07/28 21:52:52  florian
     + implementation of raise and try..finally
     + some misc. exception stuff
 

compiler/pstatmnt.pas

@@ -478,10 +478,14 @@ unit pstatmnt;
 
       var
          p_try_block,p_finally_block,first,last,
-         p_default,e1,e2,p_specific : ptree;
+         p_default,p_specific : ptree;
+         ot : pobjectdef;
+         sym : pvarsym;
 
          old_in_except_block : boolean;
 
+         exceptsymtable : psymtable;
+
       begin
          procinfo.flags:=procinfo.flags or
            pi_uses_exceptions;
@@ -530,31 +534,98 @@ unit pstatmnt;
               if token=_ON then
                 { catch specific exceptions }
                 begin
+                   p_specific:=nil;
                    repeat
                      consume(_ON);
-                     e1:=comp_expr(true);
-                     if token=COLON then
+                     if token=ID then
+                       begin
+                          getsym(pattern,false);
+
+                          { is a explicit name for the exception given ? }
+                          if not(assigned(srsym)) then
+                            begin
+                               sym:=new(pvarsym,init(pattern,nil));
+                               exceptsymtable:=new(psymtable,init(stt_exceptsymtable));
+                               exceptsymtable^.insert(sym);
+                               consume(COLON);
+                               getsym(pattern,false);
+                               consume(ID);
+                               if srsym^.typ=unitsym then
+                                 begin
+                                    consume(POINT);
+                                    getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
+                                    consume(ID);
+                                 end;
+                               if (srsym^.typ=typesym) and
+                                 (ptypesym(srsym)^.definition^.deftype=objectdef) and
+                                 pobjectdef(ptypesym(srsym)^.definition)^.isclass then
+                                 ot:=pobjectdef(ptypesym(srsym)^.definition)
+                               else
+                                 begin
+                                    message(parser_e_class_type_expected);
+                                    ot:=pobjectdef(generrordef);
+                                 end;
+                               sym^.definition:=ot;
+                               { insert the exception symtable stack }
+                               exceptsymtable^.next:=symtablestack;
+                               symtablestack^.next:=exceptsymtable;
+                            end
+                          else
+                            begin
+                               { only exception type }
+                               if srsym^.typ=unitsym then
+                                 begin
+                                    consume(POINT);
+                                    getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
+                                    consume(ID);
+                                 end;
+                               consume(ID);
+                               if (srsym^.typ=typesym) and
+                                 (ptypesym(srsym)^.definition^.deftype=objectdef) and
+                                 pobjectdef(ptypesym(srsym)^.definition)^.isclass then
+                                 ot:=pobjectdef(ptypesym(srsym)^.definition)
+                               else
+                                 begin
+                                    message(parser_e_class_type_expected);
+                                    ot:=pobjectdef(generrordef);
+                                 end;
+                               exceptsymtable:=nil;
+                            end;
+                       end
+                     else
+                       consume(ID);
+                     consume(_DO);
+                     statement;
+                     if p_specific=nil then
                        begin
-                          consume(COLON);
-                          e2:=comp_expr(true);
-                          { !!!!! }
+                          last:=gennode(onn,nil,statement);
+                          p_specific:=last;
                        end
                      else
                        begin
-                          { !!!!! }
+                          last^.left:=gennode(onn,nil,statement);
+                          last:=last^.left;
                        end;
-                     consume(_DO);
-                     statement;
+                     { set the informations }
+                     last^.excepttype:=ot;
+                     last^.exceptsymtable:=exceptsymtable;
+
+                     { remove exception symtable }
+                     if assigned(exceptsymtable) then
+                       dellexlevel;
                      if token<>SEMICOLON then
                        break;
+                     consume(SEMICOLON);
                      emptystats;
-                   until false;
+                   until (token=_END) or(token=_ELSE);
                    if token=_ELSE then
                      { catch the other exceptions }
                      begin
                         consume(_ELSE);
                         p_default:=statements_til_end;
-                     end;
+                     end
+                   else
+                     consume(_END);
                 end
               else
                 { catch all exceptions }
@@ -1171,7 +1242,11 @@ unit pstatmnt;
 end.
 {
   $Log$
-  Revision 1.27  1998-07-28 21:52:55  florian
+  Revision 1.28  1998-07-30 11:18:18  florian
+    + first implementation of try ... except on .. do end;
+    * limitiation of 65535 bytes parameters for cdecl removed
+
+  Revision 1.27  1998/07/28 21:52:55  florian
     + implementation of raise and try..finally
     + some misc. exception stuff
 

compiler/symsym.inc

@@ -981,6 +981,10 @@
 
              l:=getsize;
              case owner^.symtabletype of
+
+          stt_exceptsymtable:
+            { can contain only one symbol, address calculated later }
+            ;
           localsymtable : begin
                             is_valid := 0;
                             modulo:=owner^.datasize and 3;
@@ -1646,7 +1650,11 @@
 
 {
   $Log$
-  Revision 1.24  1998-07-20 18:40:16  florian
+  Revision 1.25  1998-07-30 11:18:19  florian
+    + first implementation of try ... except on .. do end;
+    * limitiation of 65535 bytes parameters for cdecl removed
+
+  Revision 1.24  1998/07/20 18:40:16  florian
     * handling of ansi string constants should now work
 
   Revision 1.23  1998/07/14 21:37:24  peter

compiler/todo.txt

@@ -23,9 +23,14 @@ compiler version and your short cut.
   - correct handling of access specifiers ........................ 0.99.7 (FK)
   - interface
 * rtti
-  - generation
-  - use when copying etc.
-* AnsiString, LongString and WideString
+          - generation ........................................... 0.99.7 (FK)
+          - use when copying etc. ................................ 0.99.7 (FK)
+  - new/dispose should look for rtti'ed data
+* AnsiString
+  - operators
+  - indexed access
+  - type conversations
+* LongString and WideString
 * MMX support by the compiler
           - unary minus .......................................... 0.99.1 (FK)
           - proper handling of fixed type ........................ 0.99.1 (FK)
@@ -49,6 +54,8 @@ compiler version and your short cut.
 - subrange types of enumerations
 - method pointers (procedure of object)
 - code generation for exceptions
+- assertation
+- sysutils unit for go32v2 (excpetions!)
 - initialisation/finalization for units
 - fixed data type
         - add abstract virtual method runtime

compiler/tree.pas

@@ -114,6 +114,7 @@ unit tree;
                    raisen,          {A raise statement.}
                    switchesn,       {??? Currently unused...}
                    tryfinallyn,     {A try finally statement.}
+                   onn,             { for an on statement in exception code }
                    isn,             {Represents the is operator.}
                    asn,             {Represents the as typecast.}
                    caretn,          {Represents the ^ operator.}
@@ -232,6 +233,7 @@ unit tree;
              casen : (nodes : pcaserecord;elseblock : ptree);
              labeln,goton : (labelnr : plabel);
              withn : (withsymtable : psymtable;tablecount : longint);
+             onn : (exceptsymtable : psymtable;excepttype : pobjectdef);
            end;
 
     procedure init_tree;
@@ -1596,7 +1598,11 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.23  1998-07-24 22:17:01  florian
+  Revision 1.24  1998-07-30 11:18:23  florian
+    + first implementation of try ... except on .. do end;
+    * limitiation of 65535 bytes parameters for cdecl removed
+
+  Revision 1.23  1998/07/24 22:17:01  florian
     * internal error 10 together with array access fixed. I hope
       that's the final fix.