* some changes to compile with Delphi

compiler/cobjects.pas

@@ -284,7 +284,7 @@ unit cobjects;
          i : longint;
 
       begin
-         w:=ord(p^[0]);
+         w:=length(p^[0]);
          for i:=1 to w do
            p^[i-1]:=p^[i];
          p^[w]:=#0;
@@ -1142,7 +1142,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.13  1998-08-12 19:28:16  peter
+  Revision 1.14  1998-09-18 16:03:37  florian
+    * some changes to compile with Delphi
+
+  Revision 1.13  1998/08/12 19:28:16  peter
     * better libc support
 
   Revision 1.12  1998/07/14 14:46:47  peter

compiler/dmisc.pas

@@ -0,0 +1,854 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team.
+
+    Dos unit for BP7 compatible RTL
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit dmisc;
+
+interface
+
+uses
+   windows,sysutils;
+
+Const
+  Max_Path = 255;
+
+  {Bitmasks for CPU Flags}
+  fcarry     = $0001;
+  fparity    = $0004;
+  fauxiliary = $0010;
+  fzero      = $0040;
+  fsign      = $0080;
+  foverflow  = $0800;
+
+  {Bitmasks for file attribute}
+  readonly  = $01;
+  hidden    = $02;
+  sysfile   = $04;
+  volumeid  = $08;
+  directory = $10;
+  archive   = $20;
+  anyfile   = $3F;
+
+  {File Status}
+  fmclosed = $D7B0;
+  fminput  = $D7B1;
+  fmoutput = $D7B2;
+  fminout  = $D7B3;
+
+
+Type
+{ Needed for Win95 LFN Support }
+  ComStr  = String[255];
+  PathStr = String[255];
+  DirStr  = String[255];
+  NameStr = String[255];
+  ExtStr  = String[255];
+
+  FileRec = TFileRec;
+
+  DateTime = packed record
+    Year,
+    Month,
+    Day,
+    Hour,
+    Min,
+    Sec   : word;
+  End;
+
+  PWin32FindData = ^TWin32FindData;
+  TWin32FindData = packed record
+    dwFileAttributes: Cardinal;
+    ftCreationTime: TFileTime;
+    ftLastAccessTime: TFileTime;
+    ftLastWriteTime: TFileTime;
+    nFileSizeHigh: Cardinal;
+    nFileSizeLow: Cardinal;
+    dwReserved0: Cardinal;
+    dwReserved1: Cardinal;
+    cFileName: array[0..MAX_PATH - 1] of Char;
+    cAlternateFileName: array[0..13] of Char;
+  end;
+
+  Searchrec = Packed Record
+    FindHandle  : THandle;
+    W32FindData : TWin32FindData;
+    time : longint;
+    size : longint;
+    attr : longint;
+    name : string;
+  end;
+
+
+  registers = packed record
+    case i : integer of
+     0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
+     1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
+     2 : (eax,  ebx,  ecx,  edx,  ebp,  esi,  edi : longint);
+    end;
+
+Var
+  DosError : integer;
+
+{Interrupt}
+Procedure Intr(intno: byte; var regs: registers);
+Procedure MSDos(var regs: registers);
+
+{Info/Date/Time}
+Function  DosVersion: Word;
+Procedure GetDate(var year, month, mday, wday: word);
+Procedure GetTime(var hour, minute, second, sec100: word);
+procedure SetDate(year,month,day: word);
+Procedure SetTime(hour,minute,second,sec100: word);
+Procedure UnpackTime(p: longint; var t: datetime);
+Procedure PackTime(var t: datetime; var p: longint);
+
+{Exec}
+Procedure Exec(const path: pathstr; const comline: comstr);
+Function  DosExitCode: word;
+
+{Disk}
+Function  DiskFree(drive: byte) : longint;
+Function  DiskSize(drive: byte) : longint;
+Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
+Procedure FindNext(var f: searchRec);
+Procedure FindClose(Var f: SearchRec);
+
+{File}
+Procedure GetFAttr(var f; var attr: word);
+Procedure GetFTime(var f; var time: longint);
+Function  FSearch(path: pathstr; dirlist: string): pathstr;
+Function  FExpand(const path: pathstr): pathstr;
+Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
+
+{Environment}
+Function  EnvCount: longint;
+Function  EnvStr(index: integer): string;
+Function  GetEnv(envvar: string): string;
+
+{Misc}
+Procedure SetFAttr(var f; attr: word);
+Procedure SetFTime(var f; time: longint);
+Procedure GetCBreak(var breakvalue: boolean);
+Procedure SetCBreak(breakvalue: boolean);
+Procedure GetVerify(var verify: boolean);
+Procedure SetVerify(verify: boolean);
+
+{Do Nothing Functions}
+Procedure SwapVectors;
+Procedure GetIntVec(intno: byte; var vector: pointer);
+Procedure SetIntVec(intno: byte; vector: pointer);
+Procedure Keep(exitcode: word);
+
+implementation
+uses strings,globals;
+
+{******************************************************************************
+                           --- Conversion ---
+******************************************************************************}
+
+   function GetLastError : DWORD;
+     external 'kernel32' name 'GetLastError';
+   function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : boolean;
+     external 'kernel32' name 'FileTimeToDosDateTime';
+   function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : boolean;
+     external 'kernel32' name 'DosDateTimeToFileTime';
+   function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : boolean;
+     external 'kernel32' name 'FileTimeToLocalFileTime';
+   function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : boolean;
+     external 'kernel32' name 'LocalFileTimeToFileTime';
+
+type
+  Longrec=packed record
+    lo,hi : word;
+  end;
+
+function Last2DosError(d:dword):integer;
+begin
+  Last2DosError:=d;
+end;
+
+
+Function DosToWinAttr (Const Attr : Longint) : longint;
+begin
+  DosToWinAttr:=Attr;
+end;
+
+
+Function WinToDosAttr (Const Attr : Longint) : longint;
+begin
+  WinToDosAttr:=Attr;
+end;
+
+
+Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):boolean;
+var
+  lft : TFileTime;
+begin
+  DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
+                LocalFileTimeToFileTime(lft,Wtime);
+end;
+
+
+Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):boolean;
+var
+  lft : TFileTime;
+begin
+  WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
+                FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
+end;
+
+
+{******************************************************************************
+                           --- Dos Interrupt ---
+******************************************************************************}
+
+procedure intr(intno : byte;var regs : registers);
+begin
+  { !!!!!!!! }
+end;
+
+procedure msdos(var regs : registers);
+begin
+  { !!!!!!!! }
+end;
+
+
+{******************************************************************************
+                        --- Info / Date / Time ---
+******************************************************************************}
+
+   function GetVersion : longint;
+     external 'kernel32' name 'GetVersion';
+   procedure GetLocalTime(var t : TSystemTime);
+     external 'kernel32' name 'GetLocalTime';
+   function SetLocalTime(const t : TSystemTime) : boolean;
+     external 'kernel32' name 'SetLocalTime';
+
+function dosversion : word;
+begin
+  dosversion:=GetVersion;
+end;
+
+
+procedure getdate(var year,month,mday,wday : word);
+var
+  t : TSystemTime;
+begin
+  GetLocalTime(t);
+  year:=t.wYear;
+  month:=t.wMonth;
+  mday:=t.wDay;
+  wday:=t.wDayOfWeek;
+end;
+
+
+procedure setdate(year,month,day : word);
+var
+  t : TSystemTime;
+begin
+  { we need the time set privilege   }
+  { so this function crash currently }
+  {!!!!!}
+  GetLocalTime(t);
+  t.wYear:=year;
+  t.wMonth:=month;
+  t.wDay:=day;
+  { only a quite good solution, we can loose some ms }
+  SetLocalTime(t);
+end;
+
+
+procedure gettime(var hour,minute,second,sec100 : word);
+var
+  t : TSystemTime;
+begin
+   GetLocalTime(t);
+   hour:=t.wHour;
+   minute:=t.wMinute;
+   second:=t.wSecond;
+   sec100:=t.wMilliSeconds div 10;
+end;
+
+
+procedure settime(hour,minute,second,sec100 : word);
+var
+   t : TSystemTime;
+begin
+   { we need the time set privilege   }
+   { so this function crash currently }
+   {!!!!!}
+   GetLocalTime(t);
+   t.wHour:=hour;
+   t.wMinute:=minute;
+   t.wSecond:=second;
+   t.wMilliSeconds:=sec100*10;
+   SetLocalTime(t);
+end;
+
+
+Procedure packtime(var t : datetime;var p : longint);
+Begin
+  p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
+End;
+
+
+Procedure unpacktime(p : longint;var t : datetime);
+Begin
+  with t do
+   begin
+     sec:=(p and 31) shl 1;
+     min:=(p shr 5) and 63;
+     hour:=(p shr 11) and 31;
+     day:=(p shr 16) and 31;
+     month:=(p shr 21) and 15;
+     year:=(p shr 25)+1980;
+   end;
+End;
+
+
+{******************************************************************************
+                               --- Exec ---
+******************************************************************************}
+var
+  lastdosexitcode : word;
+
+procedure exec(const path : pathstr;const comline : comstr);
+var
+  SI: TStartupInfo;
+  PI: TProcessInformation;
+  Proc : THandle;
+  l    : Longint;
+  AppPath,
+  AppParam : array[0..255] of char;
+begin
+  FillChar(SI, SizeOf(SI), 0);
+  SI.cb:=SizeOf(SI);
+  SI.wShowWindow:=1;
+  Move(Path[1],AppPath,length(Path));
+  AppPath[Length(Path)]:=#0;
+  AppParam[0]:='-';
+  AppParam[1]:=' ';
+  Move(ComLine[1],AppParam[2],length(Comline));
+  AppParam[Length(ComLine)+2]:=#0;
+  if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then
+   begin
+     DosError:=Last2DosError(GetLastError);
+     exit;
+   end;
+  Proc:=PI.hProcess;
+  CloseHandle(PI.hThread);
+  if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
+    GetExitCodeProcess(Proc,l)
+  else
+    l:=-1;
+  CloseHandle(Proc);
+  LastDosExitCode:=l;
+end;
+
+
+function dosexitcode : word;
+begin
+  dosexitcode:=lastdosexitcode;
+end;
+
+
+procedure getcbreak(var breakvalue : boolean);
+begin
+{ !! No Win32 Function !! }
+end;
+
+
+procedure setcbreak(breakvalue : boolean);
+begin
+{ !! No Win32 Function !! }
+end;
+
+
+procedure getverify(var verify : boolean);
+begin
+{ !! No Win32 Function !! }
+end;
+
+
+procedure setverify(verify : boolean);
+begin
+{ !! No Win32 Function !! }
+end;
+
+
+{******************************************************************************
+                               --- Disk ---
+******************************************************************************}
+
+function diskfree(drive : byte) : longint;
+var
+  disk : array[1..4] of char;
+  secs,bytes,
+  free,total : longint;
+begin
+  if drive=0 then
+   begin
+     disk[1]:='\';
+     disk[2]:=#0;
+   end
+  else
+   begin
+     disk[1]:=chr(drive+64);
+     disk[2]:=':';
+     disk[3]:='\';
+     disk[4]:=#0;
+   end;
+  if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
+   diskfree:=free*secs*bytes
+  else
+   diskfree:=-1;
+end;
+
+
+function disksize(drive : byte) : longint;
+var
+  disk : array[1..4] of char;
+  secs,bytes,
+  free,total : longint;
+begin
+  if drive=0 then
+   begin
+     disk[1]:='\';
+     disk[2]:=#0;
+   end
+  else
+   begin
+     disk[1]:=chr(drive+64);
+     disk[2]:=':';
+     disk[3]:='\';
+     disk[4]:=#0;
+   end;
+  if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
+   disksize:=total*secs*bytes
+  else
+   disksize:=-1;
+end;
+
+
+{******************************************************************************
+                         --- Findfirst FindNext ---
+******************************************************************************}
+
+{ Needed kernel calls }
+
+   function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle;
+     external 'kernel32' name 'FindFirstFileA';
+   function FindNextFile  (hFindFile: THandle; var lpFindFileData: TWIN32FindData): Boolean;
+     external 'kernel32' name 'FindNextFileA';
+   function FindCloseFile (hFindFile: THandle): Boolean;
+     external 'kernel32' name 'FindClose';
+
+Procedure StringToPchar (Var S : String);
+Var L : Longint;
+begin
+  L:=ord(S[0]);
+  Move (S[1],S[0],L);
+  S[L]:=#0;
+end;
+
+
+procedure FindMatch(var f:searchrec);
+Var
+  TheAttr : Longint;
+begin
+  TheAttr:=DosToWinAttr(F.Attr);
+{ Find file with correct attribute }
+  While (F.W32FindData.dwFileAttributes and TheAttr)=0 do
+   begin
+     if not FindNextFile (F.FindHandle,F.W32FindData) then
+      begin
+        DosError:=Last2DosError(GetLastError);
+        exit;
+      end;
+   end;
+{ Convert some attributes back }
+  f.size:=F.W32FindData.NFileSizeLow;
+  f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
+  WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
+  f.Name:=StrPas(@F.W32FindData.cFileName);
+end;
+
+
+procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
+begin
+{ no error }
+  doserror:=0;
+  F.Name:=Path;
+  F.Attr:=attr;
+  StringToPchar(f.name);
+{ FindFirstFile is a Win32 Call. }
+  F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData);
+  If longint(F.FindHandle)=Invalid_Handle_value then
+   begin
+     DosError:=Last2DosError(GetLastError);
+     exit;
+   end;
+{ Find file with correct attribute }
+  FindMatch(f);
+end;
+
+
+procedure findnext(var f : searchRec);
+begin
+{ no error }
+  doserror:=0;
+  if not FindNextFile (F.FindHandle,F.W32FindData) then
+   begin
+     DosError:=Last2DosError(GetLastError);
+     exit;
+   end;
+{ Find file with correct attribute }
+  FindMatch(f);
+end;
+
+
+procedure swapvectors;
+begin
+end;
+
+
+Procedure FindClose(Var f: SearchRec);
+begin
+  If longint(F.FindHandle)<>Invalid_Handle_value then
+   FindCloseFile(F.FindHandle);
+end;
+
+
+{******************************************************************************
+                               --- File ---
+******************************************************************************}
+
+   function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean;
+     external 'kernel32' name 'GetFileTime';
+   function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean;
+     external 'kernel32' name 'SetFileTime';
+   function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : boolean;
+     external 'kernel32' name 'SetFileAttributesA';
+   function GetFileAttributes(lpFileName : pchar) : longint;
+     external 'kernel32' name 'GetFileAttributesA';
+
+procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
+var
+   p1,i : longint;
+begin
+   { allow slash as backslash }
+   for i:=1 to length(path) do
+    if path[i]='/' then path[i]:='\';
+   { get drive name }
+   p1:=pos(':',path);
+   if p1>0 then
+     begin
+        dir:=path[1]+':';
+        delete(path,1,p1);
+     end
+   else
+     dir:='';
+   { split the path and the name, there are no more path informtions }
+   { if path contains no backslashes                                 }
+   while true do
+     begin
+        p1:=pos('\',path);
+        if p1=0 then
+          break;
+        dir:=dir+copy(path,1,p1);
+        delete(path,1,p1);
+     end;
+   { try to find out a extension }
+   p1:=pos('.',path);
+   if p1>0 then
+     begin
+        ext:=copy(path,p1,4);
+        delete(path,p1,length(path)-p1+1);
+     end
+   else
+     ext:='';
+   name:=path;
+end;
+
+
+function fexpand(const path : pathstr) : pathstr;
+
+var
+   s,pa : string[79];
+   i,j  : longint;
+begin
+   getdir(0,s);
+   pa:=upper(path);
+   { allow slash as backslash }
+   for i:=1 to length(pa) do
+    if pa[i]='/' then
+     pa[i]:='\';
+
+   if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
+     begin
+        { we must get the right directory }
+        getdir(ord(pa[1])-ord('A')+1,s);
+        if (ord(pa[0])>2) and (pa[3]<>'\') then
+          if pa[1]=s[1] then
+            pa:=s+'\'+copy (pa,3,length(pa))
+          else
+            pa:=pa[1]+':\'+copy (pa,3,length(pa))
+     end
+   else
+     if pa[1]='\' then
+       pa:=s[1]+':'+pa
+     else if s[0]=#3 then
+       pa:=s+pa
+     else
+       pa:=s+'\'+pa;
+
+ { Turbo Pascal gives current dir on drive if only drive given as parameter! }
+ if length(pa) = 2 then
+  begin
+    getdir(byte(pa[1])-64,s);
+    pa := s;
+  end;
+
+ {First remove all references to '\.\'}
+   while pos ('\.\',pa)<>0 do
+    delete (pa,pos('\.\',pa),2);
+ {Now remove also all references to '\..\' + of course previous dirs..}
+   repeat
+     i:=pos('\..\',pa);
+     if i<>0 then
+      begin
+        j:=i-1;
+        while (j>1) and (pa[j]<>'\') do
+         dec (j);
+        if pa[j+1] = ':' then j := 3;
+        delete (pa,j,i-j+3);
+      end;
+   until i=0;
+
+   { Turbo Pascal gets rid of a \.. at the end of the path }
+   { Now remove also any reference to '\..'  at end of line 
+     + of course previous dir.. }
+   i:=pos('\..',pa);
+   if i<>0 then
+    begin
+      if i = length(pa) - 2 then
+       begin
+         j:=i-1;
+         while (j>1) and (pa[j]<>'\') do
+          dec (j);
+         delete (pa,j,i-j+3);
+       end;
+       pa := pa + '\';
+     end;
+   { Remove End . and \}
+   if (length(pa)>0) and (pa[length(pa)]='.') then
+    dec(byte(pa[0]));
+   { if only the drive + a '\' is left then the '\' should be left to prevtn the program 
+     accessing the current directory on the drive rather than the root!}
+   { if the last char of path = '\' then leave it in as this is what TP does! }
+   if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
+    dec(byte(pa[0]));
+   { if only a drive is given in path then there should be a '\' at the
+     end of the string given back }
+   if length(path) = 2 then pa := pa + '\';
+   fexpand:=pa;
+end;
+
+Function FSearch(path: pathstr; dirlist: string): pathstr;
+var
+   i,p1   : longint;
+   s      : searchrec;
+   newdir : pathstr;
+begin
+{ No wildcards allowed in these things }
+   if (pos('?',path)<>0) or (pos('*',path)<>0) then
+     fsearch:=''
+   else
+     begin
+        { allow slash as backslash }
+        for i:=1 to length(dirlist) do
+          if dirlist[i]='/' then dirlist[i]:='\';
+        repeat
+          p1:=pos(';',dirlist);
+          if p1=0 then
+           begin
+             newdir:=copy(dirlist,1,p1-1);
+             delete(dirlist,1,p1);
+           end
+          else
+           begin
+             newdir:=dirlist;
+             dirlist:='';
+           end;
+          if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
+           newdir:=newdir+'\';
+          findfirst(newdir+path,anyfile,s);
+          if doserror=0 then
+           newdir:=newdir+path
+          else
+           newdir:='';
+        until (dirlist='') or (newdir<>'');
+        fsearch:=newdir;
+     end;
+end;
+
+
+procedure getftime(var f;var time : longint);
+var
+   ft : TFileTime;
+begin
+  if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
+     WinToDosTime(ft,time) then
+    exit
+  else
+    time:=0;
+end;
+
+
+procedure setftime(var f;time : longint);
+var
+  ft : TFileTime;
+begin
+  if DosToWinTime(time,ft) then
+   SetFileTime(filerec(f).Handle,nil,nil,@ft);
+end;
+
+
+procedure getfattr(var f;var attr : word);
+var
+   l : longint;
+begin
+  l:=GetFileAttributes(filerec(f).name);
+  if l=$ffffffff then
+   doserror:=getlasterror;
+  attr:=l;
+end;
+
+
+procedure setfattr(var f;attr : word);
+begin
+  doserror:=0;
+  if not(SetFileAttributes(filerec(f).name,attr)) then
+    doserror:=getlasterror;
+end;
+
+
+{******************************************************************************
+                             --- Environment ---
+******************************************************************************}
+
+{
+  The environment is a block of zero terminated strings
+  terminated by a #0
+}
+
+   function GetEnvironmentStrings : pchar;
+     external 'kernel32' name 'GetEnvironmentStringsA';
+   function FreeEnvironmentStrings(p : pchar) : boolean;
+     external 'kernel32' name 'FreeEnvironmentStringsA';
+
+function envcount : longint;
+var
+   hp,p : pchar;
+   count : longint;
+begin
+   p:=GetEnvironmentStrings;
+   hp:=p;
+   count:=0;
+   while  hp^<>#0 do
+     begin
+        { next string entry}
+        hp:=hp+strlen(hp)+1;
+        inc(count);
+     end;
+   FreeEnvironmentStrings(p);
+   envcount:=count;
+end;
+
+
+Function  EnvStr(index: integer): string;
+var
+   hp,p : pchar;
+   count,i : longint;
+begin
+   { envcount takes some time in win32 }
+   count:=envcount;
+
+   { range checking }
+   if (index<=0) or (index>count) then
+     begin
+        envstr:='';
+        exit;
+     end;
+   p:=GetEnvironmentStrings;
+   hp:=p;
+
+   { retrive the string with the given index }
+   for i:=2 to index do
+     hp:=hp+strlen(hp)+1;
+
+   envstr:=strpas(hp);
+   FreeEnvironmentStrings(p);
+end;
+
+
+Function  GetEnv(envvar: string): string;
+var
+   s : string;
+   i : longint;
+   hp,p : pchar;
+begin
+   getenv:='';
+   p:=GetEnvironmentStrings;
+   hp:=p;
+   while hp^<>#0 do
+     begin
+        s:=strpas(hp);
+        i:=pos('=',s);
+        if copy(s,1,i-1)=envvar then
+          begin
+             getenv:=copy(s,i+1,length(s)-i);
+             break;
+          end;
+        { next string entry}
+        hp:=hp+strlen(hp)+1;
+     end;
+   FreeEnvironmentStrings(p);
+end;
+
+
+{******************************************************************************
+                             --- Not Supported ---
+******************************************************************************}
+
+Procedure keep(exitcode : word);
+Begin
+End;
+
+Procedure getintvec(intno : byte;var vector : pointer);
+Begin
+End;
+
+Procedure setintvec(intno : byte;vector : pointer);
+Begin
+End;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-09-18 16:03:38  florian
+    * some changes to compile with Delphi
+
+}

compiler/mppc386.bat

@@ -1,4 +1,4 @@
-ppc386 -al -OGp22 -Ch8000000 -dI386 -dGDB -a -Sg pp.pas %1 %2 %3 %4 %5 %6 %7 %8 %9
+ppc386 -OG2p2 -al -Ch8000000 -dI386 -dGDB -a -Sg pp.pas %1 %2 %3 %4 %5 %6 %7 %8 %9
 if errorlevel 0 goto success
 goto failed
 :success

compiler/msgtxt.inc

@@ -39,425 +39,424 @@ const msgtxt : array[0..00087,1..240] of char=(+
   'I_User defined: $1'#000+
   'E_Keyword redefined as macro has no effect'#000+
   'F_Macro buffer overflow while reading or expanding a macro'#000+
-  'W_Ex','tension of macros exceeds a deep of 16, perhaps there is a recur'+
-  'sive macro definition (crashes the compiler)'#000+
+  'W_Ex','tension of macros exceeds a deep of 16.'#000+
   'E_compiler switches aren'#039't allowed in (* ... *) styled comments'#000+
   'D_Handling switch "$1"'#000+
   'C_ENDIF $1 found'#000+
   'C_IFDEF $1 found, $2'#000+
-  'C_IFOP','T $1 found, $2'#000+
+  'C_IFOPT $1 found, $2'#000+
   'C_IF $1 found, $2'#000+
   'C_IFNDEF $1 found, $2'#000+
-  'C_ELSE $1 found, $2'#000+
+  'C_ELSE $1 foun','d, $2'#000+
   'C_Skipping until...'#000+
   'I_Press <return> to continue'#000+
   'W_Unsupported switch $1'#000+
   'W_Illegal compiler directive $1'#000+
   'D_Back in $1'#000+
   'W_Unsupported assembler style specified $1'#000+
-  'E_Wr','ong switch toggle, use ON/OFF or +/-'#000+
+  'E_Wrong switch toggle, use ON/OFF or +/-'#000+
   'E_Parser - Syntax Error'#000+
-  'W_Procedure type FAR ignored'#000+
+  'W_Proced','ure type FAR ignored'#000+
   'W_Procedure type NEAR ignored'#000+
   'E_No DLL File specified'#000+
   'E_Constructor name must be INIT'#000+
   'E_Destructor name must be DONE'#000+
   'E_Illegal open parameter'#000+
-  'E_Proced','ure type INLINE not supported'#000+
-  'W_Private methods shouldn'#039't be VIRTUAL'#000+
+  'E_Procedure type INLINE not supported'#000+
+  'W_Private methods shouldn'#039't be VIRTUAL'#000,+
   'W_Constructor should be public'#000+
   'W_Destructor should be public'#000+
   'N_Class should have one destructor only'#000+
   'E_Local class definitions are not allowed'#000+
-  'E_Anonym class definitions a','re not allowed'#000+
+  'E_Anonym class definitions are not allowed'#000+
   'E_Illegal parameter list'#000+
-  'E_Wrong parameter type specified'#000+
+  'E_Wrong parameter type specif','ied'#000+
   'E_Wrong amount of parameters specified'#000+
   'E_overloaded identifier isn'#039't a function identifier'#000+
   'E_overloaded functions have the same parameter list'#000+
-  'E_function header doesn'#039,'t match the forward declaration $1'#000+
-  'N_only values can be jumped over in enumeration types'#000+
+  'E_function header doesn'#039't match the forward declaration $1'#000+
+  'N_only values can be jumped over i','n enumeration types'#000+
   'N_Interface and implementation names are different !'#000+
   'E_function nesting > 31'#000+
   'E_range check error while evaluating constants'#000+
   'E_duplicate case label'#000+
-  'E_ty','ped constants of classes are not allowed'#000+
-  'E_functions variables of overloaded functions are not allowed'#000+
+  'E_typed constants of classes are not allowed'#000+
+  'E_functions variables of ove','rloaded functions are not allowed'#000+
   'E_string length must be a value from 1 to 255'#000+
   'W_use extended syntax of DISPOSE and NEW to generate instances of obje'+
   'cts'#000+
-  'E_class identifie','r expected'#000+
+  'E_class identifier expected'#000+
   'E_method identifier expected'#000+
-  'E_function header doesn'#039't match any method of this class'#000+
+  'E_function header doesn'#039't mat','ch any method of this class'#000+
   'P_procedure/function $1'#000+
   'E_Illegal floating point constant'#000+
   'E_FAIL can be used in constructors only'#000+
   'E_Destructors can'#039't have parameters'#000+
-  'E_Only cl','ass methods can be referred with class references'#000+
-  'E_Only class methods can be accessed in class methods'#000+
+  'E_Only class methods can be referred with class references'#000+
+  'E_Only class method','s can be accessed in class methods'#000+
   'E_Constant and CASE types do not match'#000+
   'E_The symbol can'#039't be exported from a library'#000+
   'W_A inherited method is hidden by $1'#000+
-  'E_There is no ','method in an ancestor class to be overridden: $1'#000+
-  'E_No member is provided to access property'#000+
+  'E_There is no method in an ancestor class to be overridden: $1'#000+
+  'E_No member is provi','ded to access property'#000+
   'E_Illegal symbol for property access'#000+
   'E_Cannot access a protected field of an object here'#000+
   'E_Cannot access a private field of an object here'#000+
-  'W_overloa','ded of virtual method must be virtual: $1'#000+
-  'E_overloaded methods which are virtual must have the same return type:'+
-  ' $1'#000+
+  'W_overloaded of virtual method must be virtual: $1'#000+
+  'E_overloaded methods which ','are virtual must have the same return typ'+
+  'e: $1'#000+
   'E_EXPORT declared functions can'#039't be nested'#000+
   'E_methods can'#039't be EXPORTed'#000+
   'E_call by var parameters have to match exactly'#000+
-  'E_Cla','ss isn'#039't a super class of the current class'#000+
-  'E_SELF is only allowed in methods'#000+
+  'E_Class isn'#039't a parent class of the current class'#000+
+  'E_SELF is only allowed i','n methods'#000+
   'E_methods can be only in other methods called direct with type identif'+
   'ier of the class'#000+
   'E_Illegal use of '#039':'#039#000+
-  'E_range check error in set constructor or duplicate se','t element'#000+
-  'E_Pointer to class expected'#000+
-  'E_Expression must be constructor call'#000+
+  'E_range check error in set constructor or duplicate set element'#000+
+  'E_Pointer to object expected'#000+
+  'E_Expression must be construc','tor call'#000+
   'E_Expression must be destructor call'#000+
   'E_Illegal order of record elements'#000+
-  'E_Expression type must by class or record type'#000+
-  'E_Functions with void return value can'#039't retu','rn any value'#000+
+  'E_Expression type must be class or record type'#000+
+  'E_Functions with void return value can'#039't return any value'#000+
   'E_constructors and destructors must be methods'#000+
-  'E_Operator is not overloaded'#000+
+  'E_Opera','tor is not overloaded'#000+
   'E_Re-raise isn'#039't possible there'#000+
   'E_The extended syntax of new or dispose isn'#039't allowed for a class'#000+
   'E_Assembler incompatible with function return value'#000+
-  'E','_Procedure overloading is switched off'#000+
-  'E_It is not possible to overload this operator (overload = instead)'#000+
+  'E_Procedure overloading is switched off'#000+
+  'E_It is not possible to over','load this operator (overload = instead)'#000+
   'E_Comparative operator must return a boolean value'#000+
   'E_Only virtual methods can be abstract'#000+
   'F_Use of unsupported feature!'#000+
-  'E_The mix of ','CLASSES and OBJECTS isn'#039't allowed'#000+
-  'W_Unknown procedure directive had to be ignored: $1'#000+
+  'E_The mix of CLASSES and OBJECTS isn'#039't allowed'#000+
+  'W_Unknown procedure directive had',' to be ignored: $1'#000+
   'E_absolute can only be associated to ONE variable'#000+
   'E_absolute can only be associated a var or const'#000+
-  'E_Abtract methods shouldn'#039't have any definition (with f','unction b'+
-  'ody)'#000+
-  'E_This overloaded function can'#039't be local (must be exported)'#000+
+  'E_Abtract methods shouldn'#039't have any definition (with function bod'+
+  'y)'#000+
+  'E_This overloaded function can'#039't be local (must be ex','ported)'#000+
   'W_Virtual methods are used without a constructor in $1'#000+
   'M_Macro defined: $1'#000+
   'M_Macro undefined: $1'#000+
   'M_Macro $1 set to $2'#000+
   'I_Compiling $1'#000+
-  'D_Compiling $1 for the second ti','me'#000+
+  'D_Compiling $1 for the second time'#000+
   'E_Array properties aren'#039't allowed at this point'#000+
-  'E_No property found to override'#000+
+  'E_No property fo','und to override'#000+
   'E_Only one default property is allowed, found inherited default proper'+
-  'ty in class %1'#000+
+  'ty in class $1'#000+
   'E_The default property must be an array property'#000+
-  'E_Virtual constructors ','are only supported in class object model'#000+
-  'E_No default property available'#000+
+  'E_Virtual constructors are only supported in class object model'#000+
+  'E_No default property avai','lable'#000+
   'E_The class can'#039't have a published section, use the {$M+} switch'#000+
   'E_Forward declaration of class $1 must be resolved here to use the cla'+
-  'ss as anchestor'#000+
-  'E_Local operator','s not supported'#000+
-  'E_Procedure directive $1 not allowed in interface section'#000+
+  'ss as ancestor'#000+
+  'E_Local operators not supported'#000+
+  'E_Procedure directive $1 not allowed in interface se','ction'#000+
   'E_Procedure directive $1 not allowed in implementation section'#000+
   'E_Procedure directive $1 not allowed in procvar declaration'#000+
-  'E_Function is already declared Public/Forwa','rd $1'#000+
+  'E_Function is already declared Public/Forward $1'#000+
   'E_Can'#039't use both EXPORT and EXTERNAL'#000+
   'E_NAME keyword expected'#000+
-  'W_$1 not yet supported inside inline procedure/function'#000+
+  'W','_$1 not yet supported inside inline procedure/function'#000+
   'W_Inlining disabled'#000+
   'I_Writing Browser log $1'#000+
-  'H_may be pointer deref ^ is missing'#000+
-  'F_Selected assembler reader not supp','orted'#000+
-  'E_Procedure directive $1 has conflicts with other directives'#000+
+  'H_may be pointer dereference is missing'#000+
+  'F_Selected assembler reader not supported'#000+
+  'E_Procedure directive $1 has conflicts with other directiv','es'#000+
   'E_Calling convention doesn'#039't match forward'#000+
   'E_Register calling (fastcall) not supported'#000+
   'E_Property can'#039't have a default value'#000+
-  'E_The default value of a property must be consta','nt'#000+
+  'E_The default value of a property must be constant'#000+
   'E_Symbol can'#039't be published, can be only a class'#000+
-  'E_That kind of property can'#039't be published'#000+
+  'E_That kind ','of property can'#039't be published'#000+
   'E_Type mismatch'#000+
   'E_Integer expression expected'#000+
   'E_Ordinal expression expected'#000+
   'E_Type identifier expected'#000+
   'E_Variable identifier expected'#000+
-  'E_pointer t','ype expected'#000+
+  'E_pointer type expected'#000+
   'E_class type expected'#000+
-  'E_Variable or type indentifier expected'#000+
+  'E_Variable or type indentifie','r expected'#000+
   'E_Can'#039't evaluate constant expression'#000+
   'E_Set elements are not compatible'#000+
   'W_Automatic type conversion from floating type to COMP which is an int'+
   'eger type'#000+
-  'W_Using / will',' give a floating point result'#000+
-  'H_use DIV instead to get an integer result'#000+
+  'W_Using / will give a floating point result'#000+
+  'H_use DIV instead to get an intege','r result'#000+
   'E_string types doesn'#039't match, because of $V+ mode'#000+
   'E_succ or pred on enums with assignments not possible'#000+
   'E_Can'#039't read or write variables of this type'#000+
-  'E_Type conflict be','tween set elements'#000+
+  'E_Type conflict between set elements'#000+
   'E_Integer or real expression expected'#000+
-  'E_Identifier not found $1'#000+
+  'E_Ident','ifier not found $1'#000+
   'F_Internal Error in SymTableStack()'#000+
   'E_Duplicate identifier $1'#000+
   'E_Unknown identifier $1'#000+
   'E_Forward declaration not solved: $1'#000+
-  'F_Identifier type already defined ','as type'#000+
+  'F_Identifier type already defined as type'#000+
   'E_Error in type defenition'#000+
-  'E_Type identifier not defined'#000+
+  'E_Type identifier not defined',#000+
   'E_Only static variables can be used in static methods or outside metho'+
   'ds'#000+
   'E_Invalid call to tvarsym.mangledname()'#000+
   'F_record or class type expected'#000+
-  'E_To generate an instance of a',' class or an object with an abtract me'+
-  'thod isn'#039't allowed'#000+
-  'E_Label not defined $1'#000+
+  'E_Instances of classes or objects with an abtsract method are not allo'+
+  'wed'#000+
+  'E_Label not defined ','$1'#000+
   'E_Illegal label declaration'#000+
   'E_GOTO und LABEL are not supported (use command line switch -Sg)'#000+
   'E_Label not found'#000+
   'E_identifier isn'#039't a label'#000+
-  'E_label already define','d'#000+
+  'E_label already defined'#000+
   'E_illegal type declaration of set elements'#000+
-  'E_Forward class definition not resolved $1'#000+
+  'E_Forward class definition not r','esolved $1'#000+
   'H_Parameter not used $1'#000+
   'W_Local variable not used $1'#000+
   'E_Set type expected'#000+
   'W_Function result does not seem to be set'#000+
   'E_Unknown field identifier'#000+
-  'W_Local va','riable $1 does not seem to be initialized'#000+
+  'W_Local variable $1 does not seem to be initialized'#000+
   'E_identifier idents no member $1'#000+
-  'B_Found declaration: $1'#000+
+  'B_','Found declaration: $1'#000+
   'E_BREAK not allowed'#000+
   'E_CONTINUE not allowed'#000+
   'E_Expression too complicated - FPU stack overflow'#000+
   'E_Illegal expression'#000+
   'E_Invalid integer'#000+
-  'E_Illegal',' qualifier'#000+
+  'E_Illegal qualifier'#000+
   'E_High range limit < low range limit'#000+
   'E_Illegal counter variable'#000+
-  'E_Can'#039't determine which overloaded function to call'#000+
+  'E_','Can'#039't determine which overloaded function to call'#000+
   'E_Parameter list size exceeds 65535 bytes'#000+
   'E_Illegal type conversion'#000+
   'E_File types must be var parameters'#000+
-  'E_The use',' of a far pointer isn'#039't allowed there'#000+
-  'E_illegal call by reference parameters'#000+
+  'E_The use of a far pointer isn'#039't allowed there'#000+
+  'E_illegal call by reference parameters'#000,+
   'E_EXPORT declared functions can'#039't be called'#000+
   'W_Possible illegal call of constructor or destructor (doesn'#039't matc'+
   'h to this context)'#000+
   'N_Inefficient code'#000+
-  'W_unreachable c','ode'#000+
+  'W_unreachable code'#000+
   'E_procedure call with stackframe ESP/SP'#000+
-  'E_Abstract methods can'#039't be called directly'#000+
+  'E_Abstract methods can'#039't be calle','d directly'#000+
   'F_Internal Error in getfloatreg(), allocation failure'#000+
   'F_Unknown float type'#000+
   'F_SecondVecn() base defined twice'#000+
   'F_Extended cg68k not supported'#000+
-  'F_32-bit uns','igned not supported in MC68000 mode'#000+
+  'F_32-bit unsigned not supported in MC68000 mode'#000+
   'F_Internal Error in secondinline()'#000+
-  'D_Register $1 weight $2 $3'#000+
+  'D_Regi','ster $1 weight $2 $3'#000+
   'E_Stack limit excedeed in local routine'#000+
   'D_Stack frame is omited'#000+
   'E_Unable to inline object methods'#000+
   'E_Unable to inline procvar calls'#000+
-  'E_No code f','or inline procedure stored'#000+
+  'E_No code for inline procedure stored'#000+
   'F_Divide by zero in asm evaluator'#000+
-  'F_Evaluator stack overflow'#000+
+  'F_Evaluator stac','k overflow'#000+
   'F_Evaluator stack underflow'#000+
   'F_Invalid numeric format in asm evaluator'#000+
   'F_Invalid Operator in asm evaluator'#000+
   'F_Unknown error in asm evaluator'#000+
-  'W_Invalid num','eric value'#000+
+  'W_Invalid numeric value'#000+
   'E_escape sequence ignored: $1'#000+
-  'E_Asm syntax error - Prefix not found'#000+
+  'E_Asm syntax error - Prefix not foun','d'#000+
   'E_Asm syntax error - Trying to add more than one prefix'#000+
   'E_Asm syntax error - Opcode not found'#000+
   'E_Invalid symbol reference'#000+
-  'W_Calling an overload function in an asm',#000+
+  'W_Calling an overload function in an asm'#000+
   'E_Constant value out of bounds'#000+
   'E_Non-label pattern contains @'#000+
-  'E_Invalid Operand: $1'#000+
+  'E_Invalid Oper','and: $1'#000+
   'W_Override operator not supported'#000+
   'E_Error in binary constant: $1'#000+
   'E_Error in octal constant: $1'#000+
   'E_Error in hexadecimal constant: $1'#000+
-  'E_Error in integer const','ant: $1'#000+
+  'E_Error in integer constant: $1'#000+
   'E_Invalid labeled opcode'#000+
   'F_Internal error in Findtype()'#000+
-  'E_Invalid size for MOVSX/MOVZX'#000+
+  'E_Invalid siz','e for MOVSX/MOVZX'#000+
   'E_16-bit base in 32-bit segment'#000+
   'E_16-bit index in 32-bit segment'#000+
   'E_Invalid Opcode'#000+
   'E_Constant reference not allowed'#000+
-  'W_Fwait can cause emulation pr','oblems with emu387'#000+
+  'W_Fwait can cause emulation problems with emu387'#000+
   'E_Invalid combination of opcode and operands'#000+
-  'W_Opcode $1 not in table, operands not checked'#000+
+  'W_Opcode $1 n','ot in table, operands not checked'#000+
   'F_Internal Error in ConcatOpcode()'#000+
   'E_Invalid size in reference'#000+
   'E_Invalid middle sized operand'#000+
   'E_Invalid three operand opcode'#000+
-  'E_As','sembler syntax error'#000+
+  'E_Assembler syntax error'#000+
   'E_Invalid operand type'#000+
-  'E_Segment overrides not supported'#000+
+  'E_Segment overrides not supported',#000+
   'E_Invalid constant symbol $1'#000+
   'F_Internal Errror converting binary'#000+
   'F_Internal Errror converting hexadecimal'#000+
   'F_Internal Errror converting octal'#000+
-  'E_Invalid constant ex','pression'#000+
+  'E_Invalid constant expression'#000+
   'E_Unknown identifier: $1'#000+
-  'E_Trying to define an index register more than once'#000+
+  'E_Trying to define an index register more t','han once'#000+
   'E_Invalid field specifier'#000+
   'F_Internal Error in BuildScaling()'#000+
   'E_Invalid scaling factor'#000+
   'E_Invalid scaling value'#000+
   'E_Scaling value only allowed with index'#000+
-  'E_In','valid assembler syntax. No ref with brackets)'#000+
-  'E_Expressions of the form [sreg:reg...] are currently not supported'#000+
+  'E_Invalid assembler syntax. No ref with brackets)'#000+
+  'E_Expressions of the form [sreg',':reg...] are currently not supported'#000+
   'E_Trying to define a segment register twice'#000+
   'E_Trying to define a base register twice'#000+
-  'E_Trying to use a negative index register',#000+
+  'E_Trying to use a negative index register'#000+
   'E_Asm syntax error - error in reference'#000+
-  'E_Local symbols not allowed as references'#000+
+  'E_Local symbols not allowed as refer','ences'#000+
   'E_Invalid operand in bracket expression'#000+
   'E_Invalid symbol name: $1'#000+
   'E_Invalid Reference syntax'#000+
   'E_Invalid string as opcode operand: $1'#000+
-  'W_@CODE and @DATA not sup','ported'#000+
+  'W_@CODE and @DATA not supported'#000+
   'E_Null label references are not allowed'#000+
-  'W_Calling of an overloaded function in direct assembler'#000+
+  'W_Calling of an overloaded fun','ction in direct assembler'#000+
   'E_Cannot use SELF outside a method'#000+
   'E_Asm syntax error - Should start with bracket'#000+
   'E_Asm syntax error - register: $1'#000+
-  'E_SEG and OFFSET not ','supported'#000+
+  'E_SEG and OFFSET not supported'#000+
   'E_Asm syntax error - in opcode operand'#000+
-  'E_Invalid String expression'#000+
+  'E_Invalid String expression'#000,+
   'E_Constant expression out of bounds'#000+
   'F_Internal Error in BuildConstant()'#000+
   'W_A repeat prefix and a segment override on <= i386 may result in erro'+
-  'rs if an interrupt oc','curs'#000+
+  'rs if an interrupt occurs'#000+
   'E_Invalid or missing opcode'#000+
-  'E_Invalid combination of prefix and opcode: $1'#000+
+  'E_Invalid combination of prefix and opcode: ','$1'#000+
   'E_Invalid combination of override and opcode: $1'#000+
   'E_Too many operands on line'#000+
   'E_Duplicate local symbol: $1'#000+
   'E_Unknown label identifer: $1'#000+
-  'E_Assemble node syntax e','rror'#000+
+  'E_Assemble node syntax error'#000+
   'E_Undefined local symbol: $1'#000+
-  'D_Starting intel styled assembler parsing...'#000+
+  'D_Starting intel styled assembler parsing..','.'#000+
   'D_Finished intel styled assembler parsing...'#000+
   'E_Not a directive or local symbol: $1'#000+
   'E_/ at beginning of line not allowed'#000+
   'E_NOR not supported'#000+
-  'E_Invalid floating po','int register name'#000+
+  'E_Invalid floating point register name'#000+
   'W_Modulo not supported'#000+
-  'E_Invalid floating point constant: $1'#000+
+  'E_Invalid floating point constant: $','1'#000+
   'E_Size suffix and destination register do not match'#000+
   'E_Internal error in ConcatLabeledInstr()'#000+
   'W_Floating point binary representation ignored'#000+
-  'W_Floating point hexa','decimal representation ignored'#000+
-  'W_Floating point octal representation ignored'#000+
+  'W_Floating point hexadecimal representation ignored'#000+
+  'W_Floating point octal representation ignored'#000,+
   'E_Invalid real constant expression'#000+
   'E_Parenthesis are not allowed'#000+
   'E_Invalid Reference'#000+
   'E_Cannot use __SELF outside a method'#000+
-  'E_Cannot use __OLDEBP outside a nested pr','ocedure'#000+
+  'E_Cannot use __OLDEBP outside a nested procedure'#000+
   'W_Identifier $1 supposed external'#000+
-  'E_Invalid segment override expression'#000+
+  'E_Invalid segment override expressi','on'#000+
   'E_Strings not allowed as constants'#000+
   'D_Starting AT&T styled assembler parsing...'#000+
   'D_Finished AT&T styled assembler parsing...'#000+
-  'E_Switching sections is not allowed i','n an assembler block'#000+
+  'E_Switching sections is not allowed in an assembler block'#000+
   'E_Invalid global definition'#000+
   'E_Line separator expected'#000+
-  'W_globl not supported'#000+
+  'W_','globl not supported'#000+
   'W_align not supported'#000+
   'W_lcomm not supported'#000+
   'W_comm not supported'#000+
   'E_Invalid local common definition'#000+
   'E_Invalid global common definition'#000+
-  'E_local s','ymbol: $1 not found inside asm statement'#000+
-  'E_assembler code not returned to text'#000+
+  'E_local symbol: $1 not found inside asm statement'#000+
+  'E_assembler code not returned to tex','t'#000+
   'F_internal error in BuildReference()'#000+
   'E_invalid opcode size'#000+
   'W_NEAR ignored'#000+
   'W_FAR ignored'#000+
   'D_Creating inline asm lookup tables'#000+
-  'W_Using a defined name as a local lab','el'#000+
+  'W_Using a defined name as a local label'#000+
   'F_internal error in HandleExtend()'#000+
   'E_Invalid character: <'#000+
-  'E_Invalid character: >'#000+
+  'E_Invalid charac','ter: >'#000+
   'E_Unsupported opcode'#000+
   'E_Increment and Decrement mode not allowed together'#000+
   'E_Invalid Register list in movem/fmovem'#000+
   'E_Invalid Register list for opcode'#000+
-  'E_68020+',' mode required to assemble'#000+
+  'E_68020+ mode required to assemble'#000+
   'D_Starting Motorola styled assembler parsing...'#000+
-  'D_Finished Motorola styled assembler parsing...'#000+
+  'D_','Finished Motorola styled assembler parsing...'#000+
   'W_XDEF not supported'#000+
   'W_Functions with void return value can'#039't return any value in asm c'+
   'ode'#000+
-  'E_Invalid suffix for intel',' assembler'#000+
+  'E_Invalid suffix for intel assembler'#000+
   'E_Extended not supported in this mode'#000+
-  'E_Comp not supported in this mode'#000+
+  'E_Comp not supported in this',' mode'#000+
   'W_You need GNU as version >= 2.81 to compile this MMX code'#000+
   'F_Too many assembler files'#000+
   'F_Selected assembler output not supported'#000+
-  'E_Unsupported symbol type for',' operand'#000+
+  'E_Unsupported symbol type for operand'#000+
   'I_Assembling (pipe) $1'#000+
   'E_Can'#039't create assember file $1'#000+
-  'W_Assembler $1 not found, switching to external assembling'#000+
+  'W_Assembler $','1 not found, switching to external assembling'#000+
   'U_Using assembler: $1'#000+
   'W_Error while assembling exitcode $1'#000+
-  'W_Can'#039't call the assembler, error $1 switching to external',' assem'+
-  'bling'#000+
+  'W_Can'#039't call the assembler, error $1 switching to external assembl'+
+  'ing'#000+
   'I_Assembling $1'#000+
-  'W_Linker $1 not found, switching to external linking'#000+
+  'W_Linker $1 not found, switching to external link','ing'#000+
   'U_Using linker: $1'#000+
   'W_Object $1 not found, Linking may fail !'#000+
   'W_Library $1 not found, Linking may fail !'#000+
   'W_Error while linking'#000+
-  'W_Can'#039't call the linker, switchin','g to external linking'#000+
+  'W_Can'#039't call the linker, switching to external linking'#000+
   'I_Linking $1'#000+
-  'W_binder not found, switching to external binding'#000+
+  'W_binder not found, switching to external ','binding'#000+
   'W_ar not found, switching to external ar'#000+
   'E_Dynamic Libraries not supported'#000+
   'I_Closing script $1'#000+
   'U_PPU Loading $1'#000+
   'D_PPU Time: $1'#000+
   'D_PPU File too short'#000+
-  'D_PPU I','nvalid Header (no PPU at the begin)'#000+
+  'D_PPU Invalid Header (no PPU at the begin)'#000+
   'D_PPU Invalid Version $1'#000+
-  'D_PPU Flags: $1'#000+
+  'D_PPU Flags: $1'#000,+
   'D_PPU Crc: $1'#000+
   'T_PPU Source: $1'#000+
   'D_objectfile and assemblerfile are older than ppufile'#000+
   'D_objectfile is older than assemblerfile'#000+
   'T_Unitsearch: $1'#000+
   'U_Writing $1'#000+
-  'F_Can'#039't',' Write PPU-File'#000+
+  'F_Can'#039't Write PPU-File'#000+
   'F_reading PPU-File'#000+
   'F_Invalid PPU-File entry: $1'#000+
-  'F_PPU Dbx count problem'#000+
+  'F_PPU Dbx cou','nt problem'#000+
   'E_Illegal unit name: $1'#000+
   'F_Too much units'#000+
   'F_Circular unit reference'#000+
   'F_Can'#039't compile unit $1, no sources available'#000+
-  'W_Compiling the system unit requires th','e -Us switch'#000+
+  'W_Compiling the system unit requires the -Us switch'#000+
   'F_There were $1 errors compiling module, stopping'#000+
-  '$1 [options] <inputfile> [options]'#000+
+  '$1 [options] <','inputfile> [options]'#000+
   'W_Only one source file supported'#000+
   'W_DEF file can be created only for OS/2'#000+
   'E_nested response files are not supported'#000+
-  'F_No source file name in co','mmand line'#000+
+  'F_No source file name in command line'#000+
   'E_Illegal parameter: $1'#000+
   'H_-? writes help pages'#000+
-  'F_Too many config files nested'#000+
+  'F_Too many config f','iles nested'#000+
   'F_Unable to open file $1'#000+
   'N_Reading further options from $1'#000+
   'W_Target is already set to: $1'#000+
-  'W_Shared libs not supported on DOS platform, reverting to sta','tic'#000+
+  'W_Shared libs not supported on DOS platform, reverting to static'#000+
   'F_too many IF(N)DEFs'#000+
   'F_too many ENDIFs'#000+
-  'F_open conditional at the end of the file'#000+
+  'F_open conditional at the end of t','he file'#000+
   'W_Debug information generation is not supported by this executable'#000+
   'H_Try recompiling with -dGDB'#000+
-  'Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTAR','GET'#000+
+  'Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'#000+
   'Copyright (c) 1993-98 by Florian Klaempfl'#000+
-  'Free Pascal Compiler version $FPCVER'#000+
+  'Free Pascal Compiler version $F','PCVER'#000+
   #000+
   'Compiler Date  : $FPCDATE'#000+
   'Compiler Target: $FPCTARGET'#000+
@@ -465,39 +464,39 @@ const msgtxt : array[0..00087,1..240] of char=(+
   'This program comes under the GNU General Public Licence'#000+
   'For more information read COPYING.FPC'#000+
   #000+
-  'Report',' bugs,suggestions etc to:'#000+
+  'Report bugs,suggestions etc to:'#000+
   '                [email protected]'#000+
-  '**0*_+ switch option on, - off'#000+
+  '**','0*_+ switch option on, - off'#000+
   '**1a_the compiler doesn'#039't delete the generated assembler file'#000+
   '**2al_list sourcecode lines in assembler file  (still BETA !!)'#000+
-  '*t1b_use ','EMS'#000+
+  '*t1b_use EMS'#000+
   '**1B_build all modules'#000+
   '**1C_code generation options'#000+
-  '3*2CD_create dynamic library'#000+
+  '3*2CD_create dynamic ','library'#000+
   '**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#000+
   '**2Ci_IO-checking'#000+
   '**2Cn_omit linking stage'#000+
   '**2Co_check overflow of integer operations'#000+
-  '**2Cr_range check','ing'#000+
+  '**2Cr_range checking'#000+
   '**2Cs<n>_set stack size to <n>'#000+
   '**2Ct_stack checking'#000+
-  '3*2CS_create static library'#000+
+  '3*2CS_create static l','ibrary'#000+
   '3*2Cx_use smartlinking'#000+
   '**1d<x>_defines the symbol <x>'#000+
   '*O1D_generate a DEF file'#000+
   '*O2Dd<x>_set description to <x>'#000+
   '*O2Dw_PM application'#000+
-  '**1e<x>_set path to exec','utable'#000+
+  '**1e<x>_set path to executable'#000+
   '**1E_same as -Cn'#000+
   '**1F_set file names and paths'#000+
-  '**2Fe<x>_redirect error output to <x>'#000+
+  '**2Fe<x>_redirect error',' output to <x>'#000+
   '*L2Fg<x>_same as -Fl'#000+
   '**2Fi<x>_adds <x> to include path'#000+
   '**2Fl<x>_adds <x> to library path'#000+
   '*L2FL<x>_uses <x> as dynamic linker'#000+
-  '**2Fo<x>_adds <x> to ob','ject path'#000+
+  '**2Fo<x>_adds <x> to object path'#000+
   '**2Fr<x>_load error message file <x>'#000+
-  '**2Fu<x>_adds <x> to unit path'#000+
+  '**2Fu<x>_adds <x> to unit path',#000+
   '*g1g_generate debugger information'#000+
   '*g2gg_use gsym'#000+
   '*g2gd_use dbx'#000+
@@ -505,90 +504,89 @@ const msgtxt : array[0..00087,1..240] of char=(+
   '**1I<x>_adds <x> to include path'#000+
   '**1k<x>_Pass <x> to the linker'#000+
   '**1l_write logo'#000+
-  '*','*1n_don'#039't read the default config file'#000+
-  '**1o<x>_change the name of the executable produced to <x>'#000+
+  '**1n_don'#039't read the default config file'#000+
+  '**1o<x>_change the name of the executa','ble produced to <x>'#000+
   '**1pg_generate profile code for gprof'#000+
   '*L1P_use pipes instead of creating temporary assembler files'#000+
   '**1S_syntax options'#000+
-  '**2S2_switch some Delphi',' 2 extensions on'#000+
+  '**2S2_switch some Delphi 2 extensions on'#000+
   '**2Sc_supports operators like C (*=,+=,/= and -=)'#000+
-  '**2Sd_compiler disposes asm lists (uses less memory but slower)'#000+
+  '**2Sd_comp','iler disposes asm lists (uses less memory but slower)'#000+
   '**2Se_compiler stops after the first error'#000+
   '**2Sg_allow LABEL and GOTO'#000+
   '**2Si_support C++ stlyed INLINE'#000+
-  '**2Sm_s','upport macros like C (global)'#000+
+  '**2Sm_support macros like C (global)'#000+
   '**2So_tries to be TP/BP 7.0 compatible'#000+
-  '**2Sp_tries to be gpc compatible'#000+
+  '**2Sp_tr','ies to be gpc compatible'#000+
   '**2Ss_constructor name must be init (destructor must be done)'#000+
   '**2St_allow static keyword in objects'#000+
-  '**2Sv_allow variable directives (cvar,','external,public,export)'#000+
+  '**2Sv_allow variable directives (cvar,external,public,export)'#000+
   '**1s_don'#039't call assembler and linker (only with -a)'#000+
-  '**1T<x>_Target operating system'#000+
+  '*','*1T<x>_Target operating system'#000+
   '3*2TGO32V1_version 1 of DJ Delorie DOS extender'#000+
   '3*2TGO32V2_version 2 of DJ Delorie DOS extender'#000+
   '3*2TLINUX_Linux'#000+
   '3*2TOS2_OS/2 2.x'#000+
-  '3*2','TWin32_Windows 32 Bit'#000+
+  '3*2TWin32_Windows 32 Bit'#000+
   '6*2TAMIGA_Commodore Amiga'#000+
   '6*2TATARI_Atari ST/STe/TT'#000+
-  '6*2TMACOS_Macintosh m68k'#000+
+  '6*2','TMACOS_Macintosh m68k'#000+
   '6*2TLINUX_Linux-68k'#000+
   '**1u<x>_undefines the symbol <x>'#000+
   '**1U_unit options'#000+
   '**2Un_don'#039't check the unit name'#000+
   '**2Up<x>_same as -Fu<x>'#000+
-  '**2Us_compile ','a system unit'#000+
-  '**1v<x>_Be verbose. <x> is a combination of the following letters :'#000+
+  '**2Us_compile a system unit'#000+
+  '**1v<x>_Be verbose. <x> is a combination of the following lette','rs :'#000+
   '**2*_e : Show errors (default)       d : Show debug info'#000+
   '**2*_w : Show warnings               u : Show used files'#000+
-  '**2*_n : Show notes                  t : Sho','w tried files'#000+
+  '**2*_n : Show notes                  t : Show tried files'#000+
   '**2*_h : Show hints                  m : Show defined macros'#000+
-  '**2*_i : Show general info           p : Show compiled procedures'#000+
+  '**','2*_i : Show general info           p : Show compiled procedures'#000+
   '**2*_l : Show linenumbers            c : Show conditionals'#000+
-  '**2*_a : Show everything             0 :',' Show nothing (except errors'+
-  ')'#000+
+  '**2*_a : Show everything             0 : Show nothing (except errors)'#000+
   '**2*_b : Show all procedure'#000+
-  '**2*_    declarations if an error'#000+
+  '**2*_    declaratio','ns if an error'#000+
   '**2*_    occurs'#000+
   '**1X_executable options'#000+
   '*L2Xc_link with the c library'#000+
   '**2XD_link with dynamic libraries (defines FPC_LINK_DYNAMIC)'#000+
-  '**2Xs_strip all s','ymbols from executable'#000+
-  '**2XS_link with static libraries (defines FPC_LINK_STATIC)'#000+
+  '**2Xs_strip all symbols from executable'#000+
+  '**2XS_link with static libraries (defines FPC_LINK_STA','TIC)'#000+
   '**0*_Processor specific options:'#000+
   '3*1A_output format'#000+
   '3*2Ao_coff file using GNU AS'#000+
   '3*2Anasmcoff_coff file using Nasm'#000+
   '3*2Anasmelf_elf32 (linux) file using Nasm'#000+
-  '3','*2Anasmobj_obj file using Nasm'#000+
+  '3*2Anasmobj_obj file using Nasm'#000+
   '3*2Amasm_obj using Masm (Mircosoft)'#000+
-  '3*2Atasm_obj using Tasm (Borland)'#000+
+  '3*2Atasm_o','bj using Tasm (Borland)'#000+
   '3*1R_assembler reading style'#000+
   '3*2Ratt_read AT&T style assembler'#000+
   '3*2Rintel_read Intel style assembler'#000+
-  '3*2Rdirect_copy assembler text directly',' to assembler file'#000+
+  '3*2Rdirect_copy assembler text directly to assembler file'#000+
   '3*1O<x>_optimizations'#000+
   '3*2Og_generate smaller code'#000+
-  '3*2OG_generate faster code (default)'#000+
+  '3*2OG_ge','nerate faster code (default)'#000+
   '3*2Or_keep certain variables in registers (still BUGGY!!!)'#000+
   '3*2Ou_enable uncertain optimizations (see docs)'#000+
-  '3*2O1_level 1 optimizations',' (quick optimizations)'#000+
-  '3*2O2_level 2 optimizations (-O1 + slower optimizations)'#000+
+  '3*2O1_level 1 optimizations (quick optimizations)'#000+
+  '3*2O2_level 2 optimizations (-O1 + slower optimization','s)'#000+
   '3*2O3_level 3 optimizations (same as -O2u)'#000+
   '3*2Op_target processor'#000+
   '3*3Op1_set target processor to 386/486'#000+
-  '3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#000,+
+  '3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#000+
   '3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)'#000+
   '6*1A_output format'#000+
-  '6*2Ao_Unix o-file using GNU AS'#000+
+  '6*2A','o_Unix o-file using GNU AS'#000+
   '6*2Agas_GNU Motorola assembler'#000+
   '6*2Amit_MIT Syntax (old GAS)'#000+
   '6*2Amot_Standard Motorola assembler'#000+
   '6*1O_optimizations'#000+
-  '6*2Oa_turn on the opt','imizer'#000+
+  '6*2Oa_turn on the optimizer'#000+
   '6*2Og_generate smaller code'#000+
   '6*2OG_generate faster code (default)'#000+
-  '6*2Ox_optimize maximum (still BUGGY!!!)'#000+
+  '6*2Ox','_optimize maximum (still BUGGY!!!)'#000+
   '6*2O2_set target processor to a MC68020+'#000+
   '**1*_'#000+
   '**1?_shows this help'#000+

compiler/pexpr.pas

@@ -655,7 +655,7 @@ unit pexpr;
          l        : longint;
          oldp1,
          p1,p2,p3 : ptree;
-         code     : word;
+         code     : integer;
          pd,pd2   : pdef;
          possible_error,
          unit_specific,
@@ -1856,7 +1856,10 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.50  1998-09-17 13:41:18  pierre
+  Revision 1.51  1998-09-18 16:03:43  florian
+    * some changes to compile with Delphi
+
+  Revision 1.50  1998/09/17 13:41:18  pierre
   sizeof(TPOINT) problem
 
   Revision 1.49.2.1  1998/09/17 08:42:31  pierre

compiler/ppc.dpr

@@ -0,0 +1,356 @@
+{$MINSTACKSIZE $00004000}
+{$MAXSTACKSIZE $00100000}
+{$IMAGEBASE $00400000}
+{$APPTYPE CONSOLE}
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    Commandline compiler for Free Pascal
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************}
+
+{
+  possible compiler switches (* marks a currently required switch):
+  -----------------------------------------------------------------
+  USE_RHIDE           generates errors and warning in an format recognized
+                      by rhide
+  TP                  to compile the compiler with Turbo or Borland Pascal
+  GDB*                support of the GNU Debugger
+  I386                generate a compiler for the Intel i386+
+  M68K                generate a compiler for the M68000
+  USEOVERLAY          compiles a TP version which uses overlays
+  EXTDEBUG            some extra debug code is executed
+  SUPPORT_MMX         only i386: releases the compiler switch
+                      MMX which allows the compiler to generate
+                      MMX instructions
+  EXTERN_MSG          Don't compile the msgfiles in the compiler, always
+                      use external messagefiles, default for TP
+  NOAG386INT          no Intel Assembler output
+  NOAG386NSM          no NASM output
+  -----------------------------------------------------------------
+
+  Required switches for a i386 compiler be compiled by Free Pascal Compiler:
+  GDB;I386
+
+  Required switches for a i386 compiler be compiled by Turbo Pascal:
+  GDB;I386;TP
+
+  Required switches for a 68000 compiler be compiled by Turbo Pascal:
+  GDB;M68k;TP
+
+  To compile the compiler with Delphi do the following:
+  
+}
+
+{$ifdef FPC}
+   {$ifndef GDB}
+      { people can try to compile without GDB }
+      { $error The compiler switch GDB must be defined}
+   {$endif GDB}
+   { but I386 or M68K must be defined }
+   { and only one of the two }
+   {$ifndef I386}
+      {$ifndef M68K}
+        {$fatal One of the switches I386 or M68K must be defined}
+      {$endif M68K}
+   {$endif I386}
+   {$ifdef I386}
+      {$ifdef M68K}
+        {$fatal ONLY one of the switches I386 or M68K must be defined}
+      {$endif M68K}
+   {$endif I386}
+   {$ifdef support_mmx}
+     {$ifndef i386}
+       {$fatal I386 switch must be on for MMX support}
+     {$endif i386}
+   {$endif support_mmx}
+{$endif}
+
+{$ifdef TP}
+  {$IFNDEF DPMI}
+    {$M 24000,0,655360}
+  {$ELSE}
+    {$M 65000}
+  {$ENDIF DPMI}
+  {$E+,N+,F+,S-,R-}
+{$endif TP}
+
+
+program pp;
+
+{$IFDEF TP}
+  {$UNDEF PROFILE}
+  {$IFDEF DPMI}
+    {$UNDEF USEOVERLAY}
+  {$ENDIF}
+{$ENDIF}
+{$ifdef FPC}
+  {$UNDEF USEOVERLAY}
+{$ENDIF}
+
+uses
+{$ifdef useoverlay}
+  {$ifopt o+}
+    Overlay,ppovin,
+  {$else}
+    {$error You must compile with the $O+ switch}
+  {$endif}
+{$endif useoverlay}
+{$ifdef profile}
+  profile,
+{$endif profile}
+  globals,compiler;
+
+{$ifdef useoverlay}
+  {$O files}
+  {$O globals}
+  {$O hcodegen}
+  {$O pass_1}
+  {$O tree}
+  {$O types}
+  {$O objects}
+  {$O options}
+  {$O cobjects}
+  {$O globals}
+  {$O systems}
+  {$O parser}
+  {$O pbase}
+  {$O pdecl}
+  {$O pexports}
+  {$O pexpr}
+  {$O pmodules}
+  {$O pstatmnt}
+  {$O psub}
+  {$O psystem}
+  {$O ptconst}
+  {$O script}
+  {$O switches}
+  {$O temp_gen}
+  {$O comphook}
+  {$O dos}
+  {$O scanner}
+  {$O symtable}
+  {$O objects}
+  {$O aasm}
+  {$O link}
+  {$O assemble}
+  {$O messages}
+  {$O gendef}
+  {$O import}
+  {$O os2_targ}
+  {$O win_targ}
+  {$O asmutils}
+  {$ifdef gdb}
+        {$O gdb}
+  {$endif gdb}
+  {$ifdef i386}
+        {$O opts386}
+        {$O cgi386}
+        {$O cg386add}
+        {$O cg386cal}
+        {$O cg386cnv}
+        {$O cg386con}
+        {$O cg386flw}
+        {$O cg386ld}
+        {$O cg386mat}
+        {$O cg386set}
+{$ifndef NOOPT}
+        {$O aopt386}
+{$endif NOOPT}
+        {$O cgai386}
+        {$O i386}
+{$IfNDef Nora386dir}
+        {$O ra386dir}
+{$endif Nora386dir}
+{$IfNDef Nora386int}
+        {$O ra386int}
+{$endif Nora386int}
+{$IfNDef Nora386att}
+        {$O ra386att}
+{$endif Nora386att}
+        {$O tgeni386}
+{$ifndef NoAg386Int}
+        {$O ag386int}
+{$endif NoAg386Int}
+        {$O ag386att}
+{$ifndef NoAg386Nsm}
+        {$O ag386nsm}
+{$endif}
+  {$endif}
+  {$ifdef m68k}
+        {$O opts68k}
+        {$O cg68k}
+        {$O ra68kmot}
+        {$O ag68kgas}
+        {$O ag68kmot}
+        {$O ag68kmit}
+  {$endif}
+{$endif useoverlay}
+
+var
+  oldexit : pointer;
+procedure myexit;{$ifndef FPC}far;{$endif}
+begin
+  exitproc:=oldexit;
+{ Show Runtime error if there was an error }
+  if (erroraddr<>nil) then
+   begin
+     case exitcode of
+      202 : begin
+              erroraddr:=nil;
+              Writeln('Error: Stack Overflow');
+            end;
+      203 : begin
+              erroraddr:=nil;
+              Writeln('Error: Out of memory');
+            end;
+     end;
+     Writeln('Compilation aborted at line ',aktfilepos.line);
+   end;
+end;
+
+begin
+  oldexit:=exitproc;
+  exitproc:=@myexit;
+{$ifndef VER0_99_5}
+  {$ifndef TP}
+    heapblocks:=true;
+  {$endif}
+{$endif}
+{$ifdef UseOverlay}
+  InitOverlay;
+{$endif}
+
+{ Call the compiler with empty command, so it will take the parameters }
+  Halt(Compile(''));
+end.
+{
+  $Log$
+  Revision 1.1  1998-09-18 16:03:44  florian
+    * some changes to compile with Delphi
+
+  Revision 1.28  1998/08/26 15:31:17  peter
+    * heapblocks for >0.99.5
+
+  Revision 1.27  1998/08/11 00:00:00  peter
+    * fixed dup log
+
+  Revision 1.26  1998/08/10 15:49:40  peter
+    * small fixes for 0.99.5
+
+  Revision 1.25  1998/08/10 14:50:16  peter
+    + localswitches, moduleswitches, globalswitches splitting
+
+  Revision 1.24  1998/08/10 10:18:32  peter
+    + Compiler,Comphook unit which are the new interface units to the
+      compiler
+
+  Revision 1.23  1998/08/05 16:00:16  florian
+    * some fixes for ansi strings
+
+  Revision 1.22  1998/08/04 16:28:40  jonas
+  * added support for NoRa386* in the $O ... section
+
+  Revision 1.21  1998/07/18 17:11:12  florian
+    + ansi string constants fixed
+    + switch $H partial implemented
+
+  Revision 1.20  1998/07/14 14:46:55  peter
+    * released NEWINPUT
+
+  Revision 1.19  1998/07/07 11:20:04  peter
+    + NEWINPUT for a better inputfile and scanner object
+
+  Revision 1.18  1998/06/24 14:06:33  peter
+    * fixed the name changes
+
+  Revision 1.17  1998/06/23 08:59:22  daniel
+    * Recommitted.
+
+  Revision 1.16  1998/06/17 14:10:17  peter
+    * small os2 fixes
+    * fixed interdependent units with newppu (remake3 under linux works now)
+
+  Revision 1.15  1998/06/16 11:32:18  peter
+    * small cosmetic fixes
+
+  Revision 1.14  1998/06/15 13:43:45  daniel
+
+
+  * Updated overlays.
+
+  Revision 1.12  1998/05/23 01:21:23  peter
+    + aktasmmode, aktoptprocessor, aktoutputformat
+    + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches
+    + $LIBNAME to set the library name where the unit will be put in
+    * splitted cgi386 a bit (codeseg to large for bp7)
+    * nasm, tasm works again. nasm moved to ag386nsm.pas
+
+  Revision 1.11  1998/05/20 09:42:35  pierre
+    + UseTokenInfo now default
+    * unit in interface uses and implementation uses gives error now
+    * only one error for unknown symbol (uses lastsymknown boolean)
+      the problem came from the label code !
+    + first inlined procedures and function work
+      (warning there might be allowed cases were the result is still wrong !!)
+    * UseBrower updated gives a global list of all position of all used symbols
+      with switch -gb
+
+  Revision 1.10  1998/05/12 10:47:00  peter
+    * moved printstatus to verb_def
+    + V_Normal which is between V_Error and V_Warning and doesn't have a
+      prefix like error: warning: and is included in V_Default
+    * fixed some messages
+    * first time parameter scan is only for -v and -T
+    - removed old style messages
+
+  Revision 1.9  1998/05/11 13:07:56  peter
+    + $ifdef NEWPPU for the new ppuformat
+    + $define GDB not longer required
+    * removed all warnings and stripped some log comments
+    * no findfirst/findnext anymore to remove smartlink *.o files
+
+  Revision 1.8  1998/05/08 09:21:57  michael
+  + Librarysearchpath is now a linker object field;
+
+  Revision 1.7  1998/05/04 17:54:28  peter
+    + smartlinking works (only case jumptable left todo)
+    * redesign of systems.pas to support assemblers and linkers
+    + Unitname is now also in the PPU-file, increased version to 14
+
+  Revision 1.6  1998/04/29 13:40:23  peter
+    + heapblocks:=true
+
+  Revision 1.5  1998/04/29 10:33:59  pierre
+    + added some code for ansistring (not complete nor working yet)
+    * corrected operator overloading
+    * corrected nasm output
+    + started inline procedures
+    + added starstarn : use ** for exponentiation (^ gave problems)
+    + started UseTokenInfo cond to get accurate positions
+
+  Revision 1.3  1998/04/21 10:16:48  peter
+    * patches from strasbourg
+    * objects is not used anymore in the fpc compiled version
+
+  Revision 1.2  1998/04/07 13:19:47  pierre
+    * bugfixes for reset_gdb_info
+      in MEM parsing for go32v2
+      better external symbol creation
+      support for rhgdb.exe (lowercase file names)
+}

compiler/scandir.inc

@@ -218,7 +218,7 @@ const
          hs1,hs2 : string;
          b : boolean;
          t : ttoken;
-         w : word;
+         w : integer;
          l1,l2 : longint;
       begin
          hs1:=read_simple_expr;
@@ -622,7 +622,9 @@ const
             1 : aktpackrecords:=1;
             2 : aktpackrecords:=2;
             4 : aktpackrecords:=4;
+            8 : aktpackrecords:=8;
            16 : aktpackrecords:=16;
+           32 : aktpackrecords:=32;
            else
             Message(scan_w_only_pack_records);
            end;
@@ -903,7 +905,10 @@ const
 
 {
   $Log$
-  Revision 1.30  1998-09-16 16:41:47  peter
+  Revision 1.31  1998-09-18 16:03:44  florian
+    * some changes to compile with Delphi
+
+  Revision 1.30  1998/09/16 16:41:47  peter
     * merged fixes
 
   Revision 1.28.2.1  1998/09/16 16:09:51  peter

compiler/scanner.pas

@@ -738,7 +738,7 @@ implementation
     function tscannerfile.readval:longint;
       var
         l : longint;
-        w : word;
+        w : integer;
       begin
         readnumber;
         valint(pattern,l,w);
@@ -947,7 +947,7 @@ implementation
     function tscannerfile.yylex : ttoken;
       var
         y       : ttoken;
-        code    : word;
+        code    : integer;
         l       : longint;
         mac     : pmacrosym;
         asciinr : string[3];
@@ -1510,7 +1510,10 @@ exit_label:
 end.
 {
   $Log$
-  Revision 1.51  1998-09-16 16:41:49  peter
+  Revision 1.52  1998-09-18 16:03:45  florian
+    * some changes to compile with Delphi
+
+  Revision 1.51  1998/09/16 16:41:49  peter
     * merged fixes
 
   Revision 1.50.2.1  1998/09/16 16:09:49  peter

compiler/symsym.inc

@@ -1024,12 +1024,26 @@
                                 address:=owner^.datasize;
                                 inc(owner^.datasize,l);
                               end
+                            else
+                             if (l<=8) or (aktpackrecords=8) then
+                              begin
+                                owner^.datasize:=(owner^.datasize+7) and (not 7);
+                                address:=owner^.datasize;
+                                inc(owner^.datasize,l);
+                              end
                             else
                              if (l<=16) or (aktpackrecords=16) then
                               begin
                                 owner^.datasize:=(owner^.datasize+15) and (not 15);
                                 address:=owner^.datasize;
                                 inc(owner^.datasize,l);
+                              end
+                            else
+                             if (l<=32) or (aktpackrecords=32) then
+                              begin
+                                owner^.datasize:=(owner^.datasize+31) and (not 31);
+                                address:=owner^.datasize;
+                                inc(owner^.datasize,l);
                               end;
                           end;
            parasymtable : begin
@@ -1655,7 +1669,10 @@
 
 {
   $Log$
-  Revision 1.43  1998-09-18 08:01:38  pierre
+  Revision 1.44  1998-09-18 16:03:47  florian
+    * some changes to compile with Delphi
+
+  Revision 1.43  1998/09/18 08:01:38  pierre
     + improvement on the usebrowser part
       (does not work correctly for now)