+ 304-309 transfert

tests/tbs/tbs0304.pp

@@ -0,0 +1,20 @@
+{$asmmode intel}
+
+var
+  cb : word;
+
+procedure A(B: word); assembler; inline;
+asm
+   MOV  AX,B
+   CMP  AX,[CB]
+   JZ   @@10
+   CLI
+   MOV  [CB],AX
+   STI
+@@10:
+end;
+
+begin
+  a(1);
+  a(2);
+end.

tests/tbs/tbs0305.pp

@@ -0,0 +1,25 @@
+{$mode objfpc}
+uses
+{$ifdef go32v2}
+dpmiexcp,
+{$endif}
+sysutils;
+var i,j,k:real;
+const except_called : boolean = false;
+begin
+  i:=100;
+  j:=0;
+  try
+    k:=i/j;
+    writeln(k:5:3);
+  except
+    k:=0;
+    writeln('Illegal Input');
+    except_called:=true;
+  end;
+  if not except_called then
+    begin
+      Writeln('Error in except handling');
+      Halt(1);
+    end;
+end.

tests/tbs/tbs0306.pp

@@ -0,0 +1,45 @@
+{$MODE objfpc}
+{$H+}
+
+{
+   Don't forget break,continue support
+}
+
+program stackcrash;
+uses sysutils;
+type
+  TMyClass = class
+  public
+    procedure Proc1;
+    procedure Proc2;
+  end;
+
+procedure TMyClass.Proc1;
+var
+  x, y: Integer;
+begin
+  try
+    exit;
+  except
+    on e: Exception do begin e.Message := '[Proc1]' + e.Message; raise e end;
+  end;
+end;
+
+procedure TMyClass.Proc2;
+var
+  x: array[0..7] of Byte;
+  crash: Boolean;
+begin
+  crash := True;        // <--- ! This corrupts the stack?!?
+  raise Exception.Create('I will crash now...');
+end;
+
+var
+  obj: TMyClass;
+begin
+  obj := TMyClass.Create;
+  obj.Proc1;
+  WriteLn('Proc1 done, calling Proc2...');
+  obj.Proc2;
+  WriteLn('Proc2 done');
+end.

tests/tbs/tbs0307.pp

@@ -0,0 +1,33 @@
+type
+  tobj = object
+    l: longint;
+    constructor init;
+    procedure setV(v: longint);
+    destructor done;
+  end;
+
+constructor tobj.init;
+begin
+  l := 0;
+end;
+
+procedure tobj.setV(v: longint);
+begin
+  l := v;
+end;
+
+destructor tobj.done;
+begin
+end;
+
+var t: tobj;
+
+begin
+  t.init;
+  with t do
+    setV(5);
+  writeln(t.l, ' (should be 5!)');
+  if t.L<>5 then
+    Halt(1);
+  t.done;
+end.

tests/tbs/tbs0308.pp

@@ -0,0 +1,5 @@
+uses tbs0308a;
+
+begin
+  writeln(coursedb.name(60));
+end.

tests/tbs/tbs0308a.pp

@@ -0,0 +1,26 @@
+unit tbs0308a;
+
+interface
+
+type
+  tcourses = object
+    function index(cName: string): integer;
+    function name(cIndex: integer): string;
+  end;
+
+var coursedb: tcourses;
+    l: longint;
+
+implementation
+
+function tcourses.index(cName: string): integer;
+begin
+  index := byte(cName[0]);
+end;
+
+function tcourses.name(cIndex: integer): string;
+begin
+  name := char(byte(cIndex));
+end;
+
+end.

tests/tbs/tbs0309.pp

@@ -0,0 +1,33 @@
+{ This code was first written by Florian
+  to test the GDB output for FPU
+  he thought first that FPU output was wrong
+  but in fact it is a bug in FPC :( }
+program bug0309;
+
+var
+   a,b : double;
+
+begin
+   asm
+      fninit;
+   end;
+   a:=1;
+   b:=2;
+   asm
+      movl $1,%eax
+      fldl a
+      fldl b
+      fadd
+      fstpl a
+   end;
+   { the above generates wrong code in binary writer
+     fldl is replaced by flds !!
+     if using -alt option to force assembler output
+     all works correctly PM }
+   writeln('a = ',a,' should be 3');
+   if a<>3.0 then
+     Halt(1);
+   a:=1.0;
+   a:=a+b;
+   writeln('a = ',a,' should be 3');
+end.