first web bugs in webtbs

tests/webtbs/tbug555.pp

@@ -0,0 +1,50 @@
+{ FPC behaves interestingly once encountered virtual method
+ declared as
+  procedure TWhateverObject.Method1; assembler; asm ... end;
+ if you ever try to overload such method _in another unit_,
+ than compile _second unit_, and than try to compile it again (???)-
+ you will end up with the message "Function header does not match
+ forward declaration of TNewObject.Method1" although in reality
+ it does match perfectly.
+ sometimes i encounter the same message even on non-assembler methods,
+ but i have not been able to reproduce them cleanly nor find the
+ reason for such behavior.}
+
+ unit tbug555;
+
+
+ interface
+ uses
+   tbug555a;
+
+ type
+   TBugObjChild = Object(TBugObj)
+     procedure Method1;
+     procedure Method2;virtual;
+     procedure Method3;
+     procedure Method4;virtual;
+    end;
+
+ implementation
+
+  procedure TBugObjChild.Method1;
+  begin
+  end;
+
+  procedure TBugObjChild.Method2;
+  begin
+  end;
+
+{$ASMMODE ATT}
+  procedure TBugObjChild.Method3;assembler;
+  asm
+     movl $1,%eax
+  end;
+
+  procedure TBugObjChild.Method4;assembler;
+  asm
+     movl $1,%eax
+  end;
+
+
+end.

tests/webtbs/tbug555a.pp

@@ -0,0 +1,57 @@
+{ FPC behaves interestingly once encountered virtual method
+ declared as
+  procedure TWhateverObject.Method1; assembler; asm ... end;
+ if you ever try to overload such method _in another unit_,
+ than compile _second unit_, and than try to compile it again (???)-
+ you will end up with the message "Function header does not match
+ forward declaration of TNewObject.Method1" although in reality
+ it does match perfectly.
+ sometimes i encounter the same message even on non-assembler methods,
+ but i have not been able to reproduce them cleanly nor find the
+ reason for such behavior.}
+
+ unit tbug555a;
+
+ interface
+
+ type
+
+   TBugObj = Object
+     constructor Init;
+     procedure Method1;
+     procedure Method2;virtual;
+     procedure Method3;
+     procedure Method4;virtual;
+     destructor Done;virtual;
+    end;
+
+ implementation
+
+  Constructor TBugObj.Init;
+  begin
+  end;
+
+{$ASMMODE ATT}
+  procedure TBugObj.Method1;assembler;
+  asm
+     movl $1,%eax
+  end;
+
+  procedure TBugObj.Method2;assembler;
+  asm
+     movl $1,%eax
+  end;
+
+  procedure TBugObj.Method3;
+  begin
+  end;
+
+  procedure TBugObj.Method4;
+  begin
+  end;
+
+  Destructor TBugObj.Done;
+  begin
+  end;
+
+end.

tests/webtbs/tbug630.pp

@@ -0,0 +1,34 @@
+{ Program 1 : memory waste
+ dummy test }
+
+USES SysUtils;
+
+procedure test_it;
+var
+	sRec : TSearchRec;
+begin
+	writeln(memAvail);
+	findFirst('c:\*.*',faVolumeId,sRec);
+	findClose(sRec);
+	writeln(sRec.name);
+	writeln(memAvail);      { 288 bytes waste ! }
+end;
+
+begin
+  Writeln('Before call ',MemAvail);
+  test_it;
+  Writeln('After call : ',MemAvail);
+end.
+(*{ Program 2 : correct }
+
+USES Dos;
+
+var
+	sRec : searchRec;
+begin
+	writeln(memAvail);
+	findFirst('c:\*.*',volumeid,sRec);
+	findClose(sRec);
+	writeln(sRec.name);
+	writeln(memAvail);      { no memory waste ! }
+end. *)

tests/webtbs/tbug701a.pp

@@ -0,0 +1,18 @@
+var
+   s : string;
+
+  procedure UseString(const as : string);
+  begin
+    s:=as;
+  end;
+
+  procedure MyExit;
+  begin
+    Writeln('Last call to UseString was with as = ',s);
+  end;
+
+begin
+  exitproc:=@MyExit;
+  UseString('Dummy test');
+end.
+

tests/webtbs/tbug711.pp

@@ -0,0 +1,78 @@
+program TestGetPutim; {Compiled with the 0.99.13 version under GO32V2!}
+
+
+
+uses
+{$ifdef go32v2}
+  dpmiexcp,
+{$endif go32v2}
+ graph;
+
+
+
+
+
+var graphdriver,graphmode :integer;
+
+    imsize:longint;
+
+    im:pointer;
+
+
+
+begin
+{$ifdef win32}
+ graphdriver:=VGA;
+ graphmode:=detect;
+{$else not  win32}
+ graphdriver:=VESA;
+ graphmode:=$103;
+{$endif}
+ Initgraph(graphdriver,graphmode,'');
+
+ {************}
+(*
+ setcolor(6);
+
+ moveto(0,0);	{Some drawing}
+
+ lineto(500,500);
+
+ circle(95,95,80);
+
+{************}
+
+
+
+{!!!!!!!!!!!!}
+
+ imsize:= imagesize(0,0,300,300); {This is the part we have problem with.}
+
+ getmem(im,imsize);	    {The result we get after PutImage is}
+
+ getimage(0,0,300,300,im^);       {chaotic independently from the graphmode!}
+
+  putimage(50,50,im^,0);	   {We tested this on a S3Trio 3D videcard,}
+
+				  {which is VESA compatible.}
+
+{!!!!!!!!!!!!}
+
+
+
+readln;
+ {repeat until keypressed;}
+   *)
+ closegraph;
+
+end.
+
+{
+
+							I. Groma
+
+							groma@metal.elte.hu
+
+							Budapest 11/24/1999
+
+}

tests/webtbs/tbug719.pp

@@ -0,0 +1,17 @@
+uses
+  sysutils;
+
+var
+  S : string;
+  SR : TSearchRec;
+  r : longint;
+begin
+r:=FindFirst('*.*',faAnyFile,SR);
+while r=0 do
+  begin
+    S:=DateTimeToStr(FileDateToDateTime(FileAge(SR.Name)));
+    Writeln(SR.Name,' has Date ',S);
+    r:=FindNext(SR);
+  end;
+FindClose(SR);
+end.

tests/webtbs/tbug744.pp

@@ -0,0 +1,9 @@
+Unit tbug744;
+
+Interface
+
+Uses tbug744a;
+
+Implementation
+
+end.

tests/webtbs/tbug744a.pp

@@ -0,0 +1,10 @@
+Unit tbug744a;
+
+Interface
+
+Uses tbug744;
+
+Implementation
+
+end.
+

tests/webtbs/tbug748.pp

@@ -0,0 +1,4 @@
+begin
+  writeln('Hello World');
+end.
+{this comment produces Unexpected end of file}

tests/webtbs/tbug751.pp

@@ -0,0 +1,6 @@
+var x,y:integer;
+begin
+
+y:=5;
+for x:=0 to 10 do if x<y then writeln(x);
+end.

tests/webtbs/tbug753.pp

@@ -0,0 +1,40 @@
+{$MODE objfpc}
+{$H+}
+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.