1{****************************************************************}
2{  CODE GENERATOR TEST PROGRAM                                   }
3{  By Carl Eric Codere                                           }
4{****************************************************************}
5{ NODE TESTED : secondtryexcept()                                }
6{               secondraise()                                    }
7{****************************************************************}
8{ PRE-REQUISITES: secondload()                                   }
9{                 secondassign()                                 }
10{                 secondtypeconv()                               }
11{                 secondtryexcept()                              }
12{                 secondcalln()                                  }
13{                 secondadd()                                    }
14{****************************************************************}
15{ DEFINES:                                                       }
16{            FPC     = Target is FreePascal compiler             }
17{****************************************************************}
18{ REMARKS : Tested with Delphi 3 as reference implementation     }
19{****************************************************************}
20program ttryexc1;
21
22{$ifdef fpc}
23{$mode objfpc}
24{$endif}
25
26Type
27  TAObject = class(TObject)
28    a : longint;
29    end;
30  TBObject = Class(TObject)
31    b : longint;
32      constructor create(c: longint);
33    end;
34
35
36{ The test cases were taken from the SAL internal architecture manual }
37
38    procedure fail;
39    begin
40      WriteLn('Failure.');
41      halt(1);
42    end;
43
44var
45 global_counter : integer;
46
47
48 constructor tbobject.create(c:longint);
49  begin
50    inherited create;
51    b:=c;
52  end;
53
54
55Procedure raiseanexception;
56
57Var A : TAObject;
58var B : TAobject;
59
60begin
61{  Writeln ('Creating exception object');}
62  A:=TAObject.Create;
63{  Writeln ('Raising with this object');}
64  raise A;
65  { this should never happen, if it does there is a problem! }
66  RunError(255);
67end;
68
69
70procedure IncrementCounter(x: integer);
71begin
72  Inc(global_counter);
73end;
74
75procedure DecrementCounter(x: integer);
76begin
77  Dec(global_counter);
78end;
79
80
81Function DoTryExceptOne: boolean;
82var
83 failed : boolean;
84begin
85  Write('Try..Except clause...');
86  global_counter:=0;
87  failed:=true;
88  DoTryExceptOne := failed;
89  Try
90    IncrementCounter(global_counter);
91    DecrementCounter(global_counter);
92  except
93  end;
94  if global_counter = 0 then
95      failed :=false;
96  DoTryExceptOne := failed;
97end;
98
99
100Function DoTryExceptTwo : boolean;
101var
102 failed : boolean;
103begin
104  Write('Try..Except with break statement...');
105  global_counter:=0;
106  failed:=true;
107  DoTryExceptTwo := failed;
108  while (failed) do
109    begin
110      Try
111       IncrementCounter(global_counter);
112       DecrementCounter(global_counter);
113       break;
114      except
115      end;
116  end;
117  if global_counter = 0 then
118    failed :=false;
119  DoTryExceptTwo := failed;
120end;
121
122
123
124
125Function DoTryExceptFour: boolean;
126var
127 failed : boolean;
128begin
129  Write('Try..Except with exit statement...');
130  global_counter:=0;
131  failed:=true;
132  DoTryExceptFour := failed;
133  while (failed) do
134    begin
135      Try
136       IncrementCounter(global_counter);
137       DecrementCounter(global_counter);
138       DoTryExceptFour := false;
139       exit;
140      except
141      end;
142  end;
143end;
144
145
146Function DoTryExceptFive: boolean;
147var
148 failed : boolean;
149 x : integer;
150begin
151  Write('Try..Except nested clauses (three-level nesting)...');
152  global_counter:=0;
153  failed:=true;
154  DoTryExceptFive := failed;
155  x:=0;
156  Try
157    IncrementCounter(global_counter);
158    Try
159        DecrementCounter(global_counter);
160        IncrementCounter(global_counter);
161        Try
162           DecrementCounter(global_counter);
163        except
164          Inc(x);
165        end;
166    except
167      Inc(x);
168    End;
169  except
170  end;
171  if (global_counter = 0) then
172   failed :=false;
173  DoTryExceptFive := failed;
174end;
175
176
177Function DoTryExceptSix : boolean;
178var
179 failed : boolean;
180 x: integer;
181begin
182  Write('Try..Except nested clauses with break statement...');
183  global_counter:=0;
184  x:=0;
185  failed:=true;
186  DoTryExceptSix := failed;
187  while (failed) do
188  begin
189      Try
190        IncrementCounter(global_counter);
191        Try
192          DecrementCounter(global_counter);
193          IncrementCounter(global_counter);
194          Try
195             DecrementCounter(global_counter);
196             break;
197          except
198            Inc(x);
199          end;
200        except
201            Inc(x);
202        End;
203     except
204     end;
205 end;
206 if (global_counter = 0) then
207   failed :=false;
208 DoTryExceptSix := failed;
209end;
210
211
212Function DoTryExceptEight : boolean;
213var
214 failed : boolean;
215 x: integer;
216begin
217  Write('Try..Except nested clauses with exit statement...');
218  global_counter:=0;
219  x:=0;
220  failed:=true;
221  DoTryExceptEight := failed;
222  while (failed) do
223  begin
224      Try
225        IncrementCounter(global_counter);
226        Try
227          DecrementCounter(global_counter);
228          IncrementCounter(global_counter);
229          Try
230             DecrementCounter(global_counter);
231             DoTryExceptEight := false;
232             exit;
233          except
234            Inc(x);
235          end;
236        except
237            Inc(x);
238        End;
239     except
240     end;
241  end;
242end;
243
244
245Function DoTryExceptNine : boolean;
246var
247 failed : boolean;
248 x: integer;
249begin
250  Write('Try..Except nested clauses with break statement in other try-block...');
251  global_counter:=0;
252  x:=0;
253  failed:=true;
254  DoTryExceptNine := failed;
255  Try
256    while (failed) do
257    begin
258        Try
259          IncrementCounter(global_counter);
260          Try
261            DecrementCounter(global_counter);
262            IncrementCounter(global_counter);
263            Try
264               DecrementCounter(global_counter);
265               break;
266            except
267              Inc(x);
268            end;
269          except
270              Inc(x);
271          End;
272       except
273       end;
274    end; {end while }
275  except
276    { normally this should execute! }
277    DoTryExceptNine := failed;
278  end;
279  if (global_counter = 0) and (x = 0) then
280    failed :=false;
281  DoTryExceptNine := failed;
282end;
283
284
285{****************************************************************************}
286
287{***************************************************************************}
288{                          Exception is thrown                              }
289{***************************************************************************}
290Function DoTryExceptTen: boolean;
291var
292 failed : boolean;
293begin
294  Write('Try..Except clause with raise...');
295  global_counter:=0;
296  failed:=true;
297  DoTryExceptTen := failed;
298  Try
299    IncrementCounter(global_counter);
300    RaiseAnException;
301    DecrementCounter(global_counter);
302  except
303      if global_counter = 1 then
304          failed :=false;
305      DoTryExceptTen := failed;
306  end;
307end;
308
309Function DoTryExceptEleven : boolean;
310var
311 failed : boolean;
312begin
313  Write('Try..Except with raise and break statement...');
314  global_counter:=0;
315  failed:=true;
316  DoTryExceptEleven := failed;
317  while (failed) do
318    begin
319      Try
320       IncrementCounter(global_counter);
321       DecrementCounter(global_counter);
322       RaiseAnException;
323       break;
324      except
325       if global_counter = 0 then
326         failed :=false;
327       DoTryExceptEleven := failed;
328      end;
329  end;
330end;
331
332Function DoTryExceptTwelve: boolean;
333var
334 failed : boolean;
335 x : integer;
336begin
337  Write('Try..Except nested clauses (three-level nesting)...');
338  global_counter:=0;
339  failed:=true;
340  DoTryExceptTwelve := failed;
341  x:=0;
342  Try
343    IncrementCounter(global_counter);
344    Try
345        DecrementCounter(global_counter);
346        IncrementCounter(global_counter);
347        Try
348           DecrementCounter(global_counter);
349           RaiseAnException;
350        except
351          if (global_counter = 0) then
352            failed :=false;
353          DoTryExceptTwelve := failed;
354        end;
355    except
356      DoTryExceptTwelve := true;
357    End;
358  except
359      DoTryExceptTwelve := true;
360  end;
361end;
362
363
364Function DoTryExceptThirteen: boolean;
365var
366 failed : boolean;
367 x : integer;
368begin
369  Write('Try..Except nested clauses (three-level nesting)...');
370  global_counter:=0;
371  failed:=true;
372  DoTryExceptThirteen := failed;
373  x:=0;
374  Try
375    IncrementCounter(global_counter);
376    Try
377        DecrementCounter(global_counter);
378        IncrementCounter(global_counter);
379        RaiseAnException;
380        Try
381           DecrementCounter(global_counter);
382        except
383          DoTryExceptThirteen := true;
384        end;
385    except
386      if (global_counter = 1) then
387        failed :=false;
388      DoTryExceptThirteen := failed;
389    End;
390  except
391      DoTryExceptThirteen := true;
392  end;
393end;
394
395{***************************************************************************}
396{                   Exception is thrown in except block                     }
397{***************************************************************************}
398Function DoTryExceptFourteen: boolean;
399var
400 failed : boolean;
401 x : integer;
402begin
403  Write('Try..Except nested clauses with single re-raise...');
404  global_counter:=0;
405  failed:=true;
406  DoTryExceptFourteen := failed;
407  x:=0;
408  Try
409    IncrementCounter(global_counter);
410    Try
411        DecrementCounter(global_counter);
412        IncrementCounter(global_counter);
413        Try
414           DecrementCounter(global_counter);
415           RaiseAnException;
416        except
417          { raise to next block }
418          Raise;
419        end;
420    except
421      if (global_counter = 0) then
422        failed :=false;
423      DoTryExceptFourteen := failed;
424    End;
425  except
426      DoTryExceptFourteen := true;
427  end;
428end;
429
430
431
432Function DoTryExceptFifteen: boolean;
433var
434 failed : boolean;
435 x : integer;
436begin
437  Write('Try..Except nested clauses with re-reraises (1)...');
438  global_counter:=0;
439  failed:=true;
440  DoTryExceptFifteen := failed;
441  x:=0;
442  Try
443    IncrementCounter(global_counter);
444    Try
445        DecrementCounter(global_counter);
446        IncrementCounter(global_counter);
447        Try
448           DecrementCounter(global_counter);
449           RaiseAnException;
450        except
451          { raise to next block }
452          Raise;
453        end;
454    except
455       { re-raise to next block }
456       Raise;
457    End;
458  except
459      if (global_counter = 0) then
460        failed :=false;
461      DoTryExceptFifteen := failed;
462  end;
463end;
464
465procedure nestedtryblock(var global_counter: integer);
466begin
467    IncrementCounter(global_counter);
468    Try
469        DecrementCounter(global_counter);
470        IncrementCounter(global_counter);
471        Try
472           DecrementCounter(global_counter);
473           RaiseAnException;
474        except
475          { raise to next block }
476          Raise;
477        end;
478    except
479       { re-raise to next block }
480       Raise;
481    End;
482end;
483
484
485Function DoTryExceptSixteen: boolean;
486var
487 failed : boolean;
488 x : integer;
489begin
490  Write('Try..Except nested clauses with re-reraises (2)...');
491  global_counter:=0;
492  failed:=true;
493  DoTryExceptSixteen := failed;
494  x:=0;
495  Try
496    NestedTryBlock(global_counter);
497  except
498      if (global_counter = 0) then
499        failed :=false;
500      DoTryExceptSixteen := failed;
501  end;
502end;
503
504
505Function DoTryExceptSeventeen: boolean;
506var
507 failed : boolean;
508 x : integer;
509begin
510  Write('Try..Except nested clauses with raises...');
511  global_counter:=0;
512  failed:=true;
513  DoTryExceptSeventeen := failed;
514  x:=0;
515  Try
516    IncrementCounter(global_counter);
517    Try
518        DecrementCounter(global_counter);
519        IncrementCounter(global_counter);
520        Try
521           DecrementCounter(global_counter);
522           RaiseAnException;
523        except
524          { raise to next block }
525          raise TAObject.Create;
526        end;
527    except
528       { re-raise to next block }
529       raise TBObject.Create(1234);
530    End;
531  except
532      if (global_counter = 0) then
533        failed :=false;
534      DoTryExceptSeventeen := failed;
535  end;
536end;
537
538{***************************************************************************}
539{                  Exception flow control in except block                   }
540{***************************************************************************}
541Function DoTryExceptEighteen: boolean;
542var
543 failed : boolean;
544begin
545  Write('Try..Except clause with raise with break in except block...');
546  global_counter:=0;
547  failed:=true;
548  DoTryExceptEighteen := failed;
549  while (failed) do
550    begin
551        Try
552          IncrementCounter(global_counter);
553          RaiseAnException;
554          DecrementCounter(global_counter);
555        except
556            if global_counter = 1 then
557                failed :=false;
558            DoTryExceptEighteen := failed;
559            break;
560        end;
561    end;
562end;
563
564
565Function DoTryExceptNineteen: boolean;
566var
567 failed : boolean;
568begin
569  Write('Try..Except clause with raise with exit in except block...');
570  global_counter:=0;
571  failed:=true;
572  DoTryExceptNineteen := failed;
573  while (failed) do
574    begin
575        Try
576          IncrementCounter(global_counter);
577          RaiseAnException;
578          DecrementCounter(global_counter);
579        except
580            if global_counter = 1 then
581                failed :=false;
582            DoTryExceptNineteen := failed;
583            exit;
584        end;
585    end;
586end;
587
588
589Function DoTryExceptTwenty: boolean;
590var
591 failed : boolean;
592 x : integer;
593begin
594  Write('Try..Except nested clauses with raises with break in inner try...');
595  global_counter:=0;
596  failed:=true;
597  DoTryExceptTwenty := failed;
598  x:=0;
599  Try
600    IncrementCounter(global_counter);
601    Try
602        while (x = 0) do
603          begin
604            DecrementCounter(global_counter);
605            IncrementCounter(global_counter);
606            Try
607               DecrementCounter(global_counter);
608               RaiseAnException;
609            except
610              { raise to next block }
611              raise TAObject.Create;
612              break;
613            end;
614          end;
615    except
616       { re-raise to next block }
617       raise TBObject.Create(1234);
618    End;
619  except
620      if (global_counter = 0) then
621        failed :=false;
622      DoTryExceptTwenty := failed;
623  end;
624end;
625
626
627Function DoTryExceptTwentyOne: boolean;
628var
629 failed : boolean;
630 x : integer;
631begin
632  Write('Try..Except nested clauses with raises with continue in inner try...');
633  global_counter:=0;
634  failed:=true;
635  DoTryExceptTwentyOne := failed;
636  x:=0;
637  Try
638    IncrementCounter(global_counter);
639    Try
640        while (x = 0) do
641          begin
642            DecrementCounter(global_counter);
643            IncrementCounter(global_counter);
644            Try
645               DecrementCounter(global_counter);
646               RaiseAnException;
647            except
648              { raise to next block }
649              raise TAObject.Create;
650              x:=1;
651              continue;
652            end;
653          end;
654    except
655       { re-raise to next block }
656       raise TBObject.Create(1234);
657    End;
658  except
659      if (global_counter = 0) then
660        failed :=false;
661      DoTryExceptTwentyOne := failed;
662  end;
663end;
664
665
666Function DoTryExceptTwentyTwo: boolean;
667var
668 failed : boolean;
669 x : integer;
670begin
671  Write('Try..Except nested clauses with raises with exit in inner try...');
672  global_counter:=0;
673  failed:=true;
674  DoTryExceptTwentyTwo := failed;
675  x:=0;
676  Try
677    IncrementCounter(global_counter);
678    Try
679        while (x = 0) do
680          begin
681            DecrementCounter(global_counter);
682            IncrementCounter(global_counter);
683            Try
684               DecrementCounter(global_counter);
685               RaiseAnException;
686            except
687              { raise to next block }
688              raise TAObject.Create;
689              exit;
690            end;
691          end;
692    except
693       { re-raise to next block }
694       raise TBObject.Create(1234);
695    End;
696  except
697      if (global_counter = 0) then
698        failed :=false;
699      DoTryExceptTwentyTwo := failed;
700  end;
701end;
702
703
704var
705 failed: boolean;
706begin
707  failed := DoTryExceptOne;
708  if failed then
709   fail
710  else
711   WriteLn('Success!');
712  failed := DoTryExceptTwo;
713  if failed then
714   fail
715  else
716   WriteLn('Success!');
717{  failed := DoTryExceptThree;
718  if failed then
719   fail
720  else
721   WriteLn('Success!');}
722  failed := DoTryExceptFour;
723  if failed then
724   fail
725  else
726   WriteLn('Success!');
727  failed := DoTryExceptFive;
728  if failed then
729   fail
730  else
731   WriteLn('Success!');
732  failed := DoTryExceptSix;
733  if failed then
734   fail
735  else
736   WriteLn('Success!');
737{  failed := DoTryExceptSeven;
738  if failed then
739   fail
740  else
741   WriteLn('Success!');}
742  failed := DoTryExceptEight;
743  if failed then
744   fail
745  else
746   WriteLn('Success!');
747  failed := DoTryExceptNine;
748  if failed then
749   fail
750  else
751   WriteLn('Success!');
752  (************************ Exceptions are created from here ****************************)
753  failed := DoTryExceptTen;
754  if failed then
755   fail
756  else
757   WriteLn('Success!');
758  failed := DoTryExceptEleven;
759  if failed then
760   fail
761  else
762   WriteLn('Success!');
763  failed := DoTryExceptTwelve;
764  if failed then
765   fail
766  else
767   WriteLn('Success!');
768  failed := DoTryExceptThirteen;
769  if failed then
770   fail
771  else
772   WriteLn('Success!');
773  (************************ Exceptions in except block       ****************************)
774  failed := DoTryExceptFourteen;
775  if failed then
776   fail
777  else
778   WriteLn('Success!');
779  failed := DoTryExceptFifteen;
780  if failed then
781   fail
782  else
783   WriteLn('Success!');
784  failed := DoTryExceptSixteen;
785  if failed then
786   fail
787  else
788   WriteLn('Success!');
789  failed := DoTryExceptSeventeen;
790  if failed then
791   fail
792  else
793   WriteLn('Success!');
794  failed := DoTryExceptEighteen;
795  if failed then
796   fail
797  else
798   WriteLn('Success!');
799  failed := DoTryExceptNineteen;
800  if failed then
801   fail
802  else
803   WriteLn('Success!');
804  failed := DoTryExceptTwenty;
805  if failed then
806   fail
807  else
808   WriteLn('Success!');
809  failed := DoTryExceptTwentyOne;
810  if failed then
811   fail
812  else
813   WriteLn('Success!');
814  failed := DoTryExceptTwentyTwo;
815  if failed then
816   fail
817  else
818   WriteLn('Success!');
819end.
820