several mods

tests/tbs0105.pp

@@ -3,13 +3,31 @@
 { but an error because the type casting is not considered at all!   }
 { Must be compiled with -Cr                                         }
 
+{$ifdef go32v2}
+ uses dpmiexcp;
+{$endif go32v2}
+{$ifdef linux}
+ uses linux;
+{$endif linux}
 
+  function our_sig(l : longint) : longint;
+    begin
+       { If we land here the program works correctly !! }
+       Writeln('Bound check error signal recieved');
+       Halt(0);
+    end;
+    
 Var
  Sel: Word;
  v: longint;
 Begin
+ Signal(SIGSEGV,our_sig);
  v:=$00ffffff;
  Sel:=word(v);
  writeln(sel);
+ { should trigger Bound check error }
  sel:=v;
+ { we should not go to here }
+ Writeln('Error : signal not called');
+ Halt(1);
 end.

tests/tbs0115.pp

@@ -4,7 +4,8 @@ var
 begin
    c:=1234;
    writeln(c);
-   readln(c);
+   {readln(c);}
+   c:=-258674;
    writeln(c);
 end.
    

tests/tbs0171.pp

@@ -4,4 +4,9 @@ const
   drivestr:string='c:';
   pdrivestr:pstring=pstring(@drivestr);
 begin
+  if pdrivestr^<>'c:' then
+    begin
+       Writeln('Error in typecast of const');
+       Halt(1);
+    end;
 end.

tests/tbs0187.pp

@@ -1,21 +1,34 @@
+{ $OPT=-Cr }
 program test;
 
+{$ifdef go32v2}
+  uses dpmiexcp;
+{$endif go32v2}
+
 type
         Tbaseclass = object
+                base_arg : longint;
+                st_count : longint;static;
                 constructor     Init;
                 destructor      Done;
                 procedure       Run;                            virtual;
 
         end;
         Totherclass = object(Tbaseclass)
+                other_arg : longint;
                 procedure       Run;                            virtual;
 
         end;
 
+const
+    BaseRunCount : integer = 0;
+    OtherRunCount : integer = 0;
+
 constructor Tbaseclass.Init;
 
 begin
   writeln('Init');
+  Inc(st_count);
   Run;
 end;
 
@@ -23,12 +36,14 @@ destructor Tbaseclass.Done;
 
 begin
   writeln('Done');
+  dec(st_count);
 end;
 
 procedure Tbaseclass.Run;
 
 begin
   writeln('Base method');
+  inc(BaseRunCount);
 end;
 
 
@@ -36,11 +51,41 @@ procedure Totherclass.Run;
 
 begin
   writeln('Inherited method');
+  inc(OtherRunCount);
 end;
 
+ { try this as local vars }
+
+ procedure test_local_class_init;
+  var base1 : TbaseClass;
+  var other1 : TOtherClass;
+  begin
+     with other1 do
+          Init;  
+     with base1 do
+          Init;
+     with other1 do
+        begin
+           Writeln('number of objects = ',st_count);
+           base_arg:=2;
+           other_arg:=6;
+           Run;  
+        end;
+     { test if changed !! }
+     
+     if (other1.base_arg<>2) or (other1.other_arg<>6) then
+       Halt(1);
+       
+     with base1 do
+        begin
+           Run;  
+           Done;
+        end;
+     other1.done;
+   end;
+  
 var     base            : Tbaseclass;
         other           : Totherclass;
-//        asmrec          : Tasmrec;
         testfield       : longint;
 
 begin
@@ -61,6 +106,11 @@ begin
     Done;
   end;
 
+ test_local_class_init;
 { Calls Tbaseclass.Run when it should call Totherclass.Run }
-
+  If (BaseRunCount<>4) or (OtherRunCount<>4) then
+    Begin
+       Writeln('Error in tbs0187');
+       Halt(1);
+    End;
 end.

tests/tbs0191.pp

@@ -18,9 +18,11 @@ const
   pc : pchar = @s[1];
 
 begin
-  if (l^<>2) or (pc[1]<>'t') then
+  Writeln(' l^ = ',l^);
+  Writeln('pc[0] = ',pc[0]); 
+  if (l^<>2) or (pc[0]<>'t') then
     Begin
-       Writeln('Wrong code genrated');
+       Writeln('Wrong code generated');
        RunError(1);
     End;
 end.

tests/tbs0201.pp

@@ -7,17 +7,22 @@ type rec = record
          b : Word;
      end;
 
-function x(r1 : rec; r2 : rec; var r3 : rec); assembler;
+{ this is really for tests but 
+  this should be coded with const r1 and r2 !! }
+
+function x(r1 : rec; r2 : rec; var r3 : rec) : integer; assembler;
 asm
    movl r3, %edi
-   
-   movl r1.a, %eax
-   addl r2.a, %eax
+   movl r1, %ebx
+   movl r2, %ecx
+   movl rec.a(%ebx), %eax
+   addl rec.a(%ecx), %eax
    movl %eax, rec.a(%edi)
 
-   movw r1.b, %cx
-   addw r2.b, %cx
-   movw %cx, rec.b(%edi)
+   movw rec.b(%ecx), %ax
+   addw rec.b(%edx), %ax
+   movw %ax, rec.b(%edi)
+   movw $1,%ax
 end;
 
 var r1, r2, r3 : rec;