+tbs271.pp to tbs0279.pp

tests/tbf0272.pp

@@ -0,0 +1,36 @@
+program test_const_string;
+
+const
+   conststring = 'Constant string';
+
+function astring(s :string) : string;
+
+begin
+  astring:='Test string'+s;
+end;
+
+procedure testvar(var s : string);
+begin
+  writeln('testvar s is "',s,'"');
+end;
+
+procedure testconst(const s : string);
+begin
+  writeln('testconst s is "',s,'"');
+end;
+
+procedure testvalue(s : string);
+begin
+  writeln('testvalue s is "',s,'"');
+end;
+
+const
+  s : string = 'test';
+
+begin
+  testvalue(astring('e'));
+  testconst(astring(s));
+  testconst(conststring);
+  testvar(conststring);{ refused a compile time }
+end.
+

tests/tbs0271.pp

@@ -0,0 +1,31 @@
+{$mode fpc}
+  type
+    tproc = procedure;
+
+procedure proc1;
+begin
+end;
+
+var
+  _copyscan : tproc;
+
+procedure setproc;
+begin
+    _copyscan := @proc1;
+end;
+
+procedure testproc;
+begin
+  if not (_copyscan=@proc1) then
+    begin
+      Writeln(' Problem procvar equality');
+      Halt(1);
+    end
+  else
+    Writeln(' No problem with procedure equality');
+end;
+
+begin
+  setproc;
+  testproc;
+end.

tests/tbs0272.pp

@@ -0,0 +1,33 @@
+program test_const_string;
+
+
+function astring(s :string) : string;
+
+begin
+  astring:='Test string'+s;
+end;
+
+procedure testvar(var s : string);
+begin
+  writeln('testvar s is "',s,'"');
+end;
+
+procedure testconst(const s : string);
+begin
+  writeln('testconst s is "',s,'"');
+end;
+
+procedure testvalue(s : string);
+begin
+  writeln('testvalue s is "',s,'"');
+end;
+
+const
+  s : string = 'test';
+  conststr = 'Const test';
+begin
+  testvalue(astring('e'));
+  testconst(astring(s));
+  testconst(conststr);
+end.
+

tests/tbs0273.pp

@@ -0,0 +1,13 @@
+Program CharArr;
+
+Var CharArray : Array[1..4] Of Char;
+
+    S : String;
+
+Begin
+ CharArray:='BUG?';
+ S:=CharArray;
+ WriteLn(S);         { * This is O.K. * }
+ WriteLn(CharArray); { * GENERAL PROTECTION FAULT. * }
+End.
+

tests/tbs0274.pp

@@ -0,0 +1,13 @@
+type
+  proc=procedure(a:longint);
+
+procedure prc(a:longint);
+begin
+end;
+
+var
+  p : proc;  
+begin
+  p:=@prc;
+  p:=@(prc);  { should this be allowed ? }
+end.

tests/tbs0275.pp

@@ -0,0 +1,5 @@
+var
+  d : single;
+begin
+  writeln(longint(d));
+end.

tests/tbs0276.pp

@@ -0,0 +1,46 @@
+{$asmmode intel}
+type
+  trec = record
+    ypos,
+    xpos : longint;
+  end;
+
+  z80cont = record
+     dummy : longint;
+     page: array [0..11,0..16383] of byte;
+  end;
+
+var
+  rec : tRec;
+  myz80 : z80cont;
+  error : boolean;
+  test  : byte;
+begin
+  error:=false;
+  test:=23;
+  rec.xpos:=1;
+  myz80.page[0,5]:=15;
+  asm
+     lea   edi, Rec
+     cmp   byte ptr [edi+tRec.Xpos], 1
+     jne   @error
+     cmp   byte ptr [edi].trec.Xpos, 1
+     jne   @error
+     mov   ecx, 5
+     mov   dh,byte ptr myz80.page[ecx]
+     cmp   dh,15
+     jne   @error
+     mov   byte ptr myz80.page[ecx],51
+     jmp   @noerror
+     @error:
+     mov   byte ptr error,1
+     @noerror:
+  end;
+  if error or (test<>23) or (myz80.page[0,5]<>51) then
+    begin
+      Writeln('Error in assembler code generation');
+      Halt(1);
+    end
+  else
+    Writeln('Correct assembler generated');
+end.

tests/tbs0277.pp

@@ -0,0 +1,5 @@
+  program bug0277;
+  const test_byte=pchar(1);
+  begin
+    writeln('Hello world');
+  end.

tests/tbs0278.pp

@@ -0,0 +1,29 @@
+{$ifdef fpc}{$mode tp}{$endif}
+unit tbs0278;
+
+interface
+
+{
+a string constant within $IFDEF that
+contains "(*" causes an error;
+compile it with "ppc386 test -So"  or  "-Sd"
+}
+
+var
+  c : char;
+
+{$IFDEF not_defined}
+const
+   c = 'b''(*
+
+{ $else}
+
+var
+  c : char;
+
+{$ENDIF}
+
+
+implementation
+
+end.

tests/tbs0279.pp

@@ -0,0 +1,33 @@
+{$H+}
+Program AnsiTest;
+
+Type
+   PS=^String;
+
+procedure test;
+var
+  P:PS;
+Begin
+  New(P);
+  P^:='';
+  P^:=P^+'BLAH';
+  P^:=P^+' '+P^;
+  Writeln(P^);
+  Dispose(P);
+end;
+
+var
+  membefore : longint;
+
+begin
+  membefore:=memavail;
+  test;
+  if membefore<>memavail then
+    begin
+      Writeln('Memory hole using pointers to ansi strings');
+      Halt(1);
+    end
+  else
+    Writeln('No memory hole with pointers to ansi strings');
+end.
+