diff --git a/compiler/cg386flw.pas b/compiler/cg386flw.pas index dab1c08a03..14894e2879 100644 --- a/compiler/cg386flw.pas +++ b/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 : ----------------- + if assigned(p^.right) then + secondpass(p^.right); -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 @@ -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 diff --git a/compiler/cgi386.pas b/compiler/cgi386.pas index 99491d093a..60795eaf92 100644 --- a/compiler/cgi386.pas +++ b/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 diff --git a/compiler/pass_1.pas b/compiler/pass_1.pas index 3812796f1b..f705eac30e 100644 --- a/compiler/pass_1.pas +++ b/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 diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index da7e983621..36f0e7bae6 100644 --- a/compiler/pstatmnt.pas +++ b/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 - consume(COLON); - e2:=comp_expr(true); - { !!!!! } + 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 + 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 diff --git a/compiler/symsym.inc b/compiler/symsym.inc index 91f22bad7e..24597bd2f6 100644 --- a/compiler/symsym.inc +++ b/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 diff --git a/compiler/todo.txt b/compiler/todo.txt index 8bc6a22015..876cae34fe 100644 --- a/compiler/todo.txt +++ b/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 diff --git a/compiler/tree.pas b/compiler/tree.pas index 78c63dbbaf..4a362043fe 100644 --- a/compiler/tree.pas +++ b/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.