diff --git a/rtl/go32v2/dos.pp b/rtl/go32v2/dos.pp index 81fa38f8cc..a24a68c195 100644 --- a/rtl/go32v2/dos.pp +++ b/rtl/go32v2/dos.pp @@ -1,1125 +1,1139 @@ -{ - $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 dos; -interface - -Uses - Go32; - -Const - {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 LFN Support } - ComStr = String[255]; - PathStr = String[255]; - DirStr = String[255]; - NameStr = String[255]; - ExtStr = String[255]; - -{ - filerec.inc contains the definition of the filerec. - textrec.inc contains the definition of the textrec. - It is in a separate file to make it available in other units without - having to use the DOS unit for it. -} -{$i filerec.inc} -{$i textrec.inc} - - DateTime = packed record - Year, - Month, - Day, - Hour, - Min, - Sec : word; - End; - - searchrec = packed record - fill : array[1..21] of byte; - attr : byte; - time : longint; - { reserved : word; not in DJGPP V2 } - size : longint; - name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) } - end; - - Registers = Go32.Registers; - -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; - -{$ASMMODE ATT} - -{****************************************************************************** - --- Dos Interrupt --- -******************************************************************************} - -var - dosregs : registers; - -procedure LoadDosError; -begin - if (dosregs.flags and carryflag) <> 0 then - { conversion from word to integer !! - gave a Bound check error if ax is $FFFF !! PM } - doserror:=integer(dosregs.ax) - else - doserror:=0; -end; - - -procedure intr(intno : byte;var regs : registers); -begin - realintr(intno,regs); -end; - - -procedure msdos(var regs : registers); -begin - intr($21,regs); -end; - - -{****************************************************************************** - --- Info / Date / Time --- -******************************************************************************} - -function dosversion : word; -begin - dosregs.ax:=$3000; - msdos(dosregs); - dosversion:=dosregs.ax; -end; - - -procedure getdate(var year,month,mday,wday : word); -begin - dosregs.ax:=$2a00; - msdos(dosregs); - wday:=dosregs.al; - year:=dosregs.cx; - month:=dosregs.dh; - mday:=dosregs.dl; -end; - - -procedure setdate(year,month,day : word); -begin - dosregs.cx:=year; - dosregs.dh:=month; - dosregs.dl:=day; - dosregs.ah:=$2b; - msdos(dosregs); - DosError:=0; -end; - - -procedure gettime(var hour,minute,second,sec100 : word); -begin - dosregs.ah:=$2c; - msdos(dosregs); - hour:=dosregs.ch; - minute:=dosregs.cl; - second:=dosregs.dh; - sec100:=dosregs.dl; - DosError:=0; -end; - - -procedure settime(hour,minute,second,sec100 : word); -begin - dosregs.ch:=hour; - dosregs.cl:=minute; - dosregs.dh:=second; - dosregs.dl:=sec100; - dosregs.ah:=$2d; - msdos(dosregs); - DosError:=0; -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); -type - realptr = packed record - ofs,seg : word; - end; - texecblock = packed record - envseg : word; - comtail : realptr; - firstFCB : realptr; - secondFCB : realptr; - iniStack : realptr; - iniCSIP : realptr; - end; -var - current_dos_buffer_pos, - arg_ofs, - i,la_env, - la_p,la_c,la_e, - fcb1_la,fcb2_la : longint; - execblock : texecblock; - c,p : string; - - function paste_to_dos(src : string) : boolean; - var - c : array[0..255] of char; - begin - paste_to_dos:=false; - if current_dos_buffer_pos+length(src)+1>transfer_buffer+tb_size then - RunError(217); - move(src[1],c[0],length(src)); - c[length(src)]:=#0; - seg_move(get_ds,longint(@c),dosmemselector,current_dos_buffer_pos,length(src)+1); - current_dos_buffer_pos:=current_dos_buffer_pos+length(src)+1; - paste_to_dos:=true; - end; - -begin -{ create command line } - move(comline[0],c[1],length(comline)+1); - c[length(comline)+2]:=#13; - c[0]:=char(length(comline)+2); -{ create path } - p:=path; - for i:=1 to length(p) do - if p[i]='/' then - p[i]:='\'; -{ create buffer } - la_env:=transfer_buffer; - while (la_env and 15)<>0 do - inc(la_env); - current_dos_buffer_pos:=la_env; -{ copy environment } - for i:=1 to envcount do - paste_to_dos(envstr(i)); - paste_to_dos(''); { adds a double zero at the end } -{ allow slash as backslash } - la_p:=current_dos_buffer_pos; - paste_to_dos(p); - la_c:=current_dos_buffer_pos; - paste_to_dos(c); - la_e:=current_dos_buffer_pos; - fcb1_la:=la_e; - la_e:=la_e+16; - fcb2_la:=la_e; - la_e:=la_e+16; -{ allocate FCB see dosexec code } - arg_ofs:=1; - while (c[arg_ofs] in [' ',#9]) do - inc(arg_ofs); - dosregs.ax:=$2901; - dosregs.ds:=(la_c+arg_ofs) shr 4; - dosregs.esi:=(la_c+arg_ofs) and 15; - dosregs.es:=fcb1_la shr 4; - dosregs.edi:=fcb1_la and 15; - msdos(dosregs); -{ allocate second FCB see dosexec code } - repeat - inc(arg_ofs); - until (c[arg_ofs] in [' ',#9,#13]); - if c[arg_ofs]<>#13 then - begin - repeat - inc(arg_ofs); - until not (c[arg_ofs] in [' ',#9]); - end; - dosregs.ax:=$2901; - dosregs.ds:=(la_c+arg_ofs) shr 4; - dosregs.si:=(la_c+arg_ofs) and 15; - dosregs.es:=fcb2_la shr 4; - dosregs.di:=fcb2_la and 15; - msdos(dosregs); - with execblock do - begin - envseg:=la_env shr 4; - comtail.seg:=la_c shr 4; - comtail.ofs:=la_c and 15; - firstFCB.seg:=fcb1_la shr 4; - firstFCB.ofs:=fcb1_la and 15; - secondFCB.seg:=fcb2_la shr 4; - secondFCB.ofs:=fcb2_la and 15; - end; - seg_move(get_ds,longint(@execblock),dosmemselector,la_e,sizeof(texecblock)); - dosregs.edx:=la_p and 15; - dosregs.ds:=la_p shr 4; - dosregs.ebx:=la_e and 15; - dosregs.es:=la_e shr 4; - dosregs.ax:=$4b00; - msdos(dosregs); - LoadDosError; - if DosError=0 then - begin - dosregs.ax:=$4d00; - msdos(dosregs); - LastDosExitCode:=DosRegs.al - end - else - LastDosExitCode:=0; -end; - - -function dosexitcode : word; -begin - dosexitcode:=lastdosexitcode; -end; - - -procedure getcbreak(var breakvalue : boolean); -begin - DosError:=0; - dosregs.ax:=$3300; - msdos(dosregs); - breakvalue:=dosregs.dl<>0; -end; - - -procedure setcbreak(breakvalue : boolean); -begin - DosError:=0; - dosregs.ax:=$3301; - dosregs.dl:=ord(breakvalue); - msdos(dosregs); -end; - - -procedure getverify(var verify : boolean); -begin - DosError:=0; - dosregs.ah:=$54; - msdos(dosregs); - verify:=dosregs.al<>0; -end; - - -procedure setverify(verify : boolean); -begin - DosError:=0; - dosregs.ah:=$2e; - dosregs.al:=ord(verify); - msdos(dosregs); -end; - - -{****************************************************************************** - --- Disk --- -******************************************************************************} - -function diskfree(drive : byte) : longint; -begin - DosError:=0; - dosregs.dl:=drive; - dosregs.ah:=$36; - msdos(dosregs); - if dosregs.ax<>$FFFF then - diskfree:=dosregs.ax*dosregs.bx*dosregs.cx - else - diskfree:=-1; -end; - - -function disksize(drive : byte) : longint; -begin - DosError:=0; - dosregs.dl:=drive; - dosregs.ah:=$36; - msdos(dosregs); - if dosregs.ax<>$FFFF then - disksize:=dosregs.ax*dosregs.cx*dosregs.dx - else - disksize:=-1; -end; - - -{****************************************************************************** - --- LFNFindfirst LFNFindNext --- -******************************************************************************} - -type - LFNSearchRec=packed record - attr, - crtime, - crtimehi, - actime, - actimehi, - lmtime, - lmtimehi, - sizehi, - size : longint; - reserved : array[0..7] of byte; - name : array[0..259] of byte; - shortname : array[0..13] of byte; - end; - -procedure LFNSearchRec2Dos(const w:LFNSearchRec;hdl:longint;var d:Searchrec); -var - Len : longint; -begin - With w do - begin - FillChar(d,sizeof(SearchRec),0); - if DosError=0 then - len:=StrLen(@Name) - else - len:=0; - d.Name[0]:=chr(len); - Move(Name[0],d.Name[1],Len); - d.Time:=lmTime; - d.Size:=Size; - d.Attr:=Attr and $FF; - Move(hdl,d.Fill,4); - end; -end; - - -procedure LFNFindFirst(path:pchar;attr:longint;var s:searchrec); -var - i : longint; - w : LFNSearchRec; -begin - { allow slash as backslash } - for i:=0 to strlen(path) do - if path[i]='/' then path[i]:='\'; - dosregs.si:=1; { use ms-dos time } - { don't include the label if not asked for it, needed for network drives } - if attr=$8 then - dosregs.ecx:=8 - else - dosregs.ecx:=attr and (not 8); - dosregs.edx:=tb_offset+Sizeof(LFNSearchrec)+1; - dosmemput(tb_segment,tb_offset+Sizeof(LFNSearchrec)+1,path^,strlen(path)+1); - dosregs.ds:=tb_segment; - dosregs.edi:=tb_offset; - dosregs.es:=tb_segment; - dosregs.ax:=$714e; - msdos(dosregs); - LoadDosError; - copyfromdos(w,sizeof(LFNSearchRec)); - LFNSearchRec2Dos(w,dosregs.ax,s); -end; - - -procedure LFNFindNext(var s:searchrec); -var - hdl : longint; - w : LFNSearchRec; -begin - Move(s.Fill,hdl,4); - dosregs.si:=1; { use ms-dos time } - dosregs.edi:=tb_offset; - dosregs.es:=tb_segment; - dosregs.ebx:=hdl; - dosregs.ax:=$714f; - msdos(dosregs); - LoadDosError; - copyfromdos(w,sizeof(LFNSearchRec)); - LFNSearchRec2Dos(w,hdl,s); -end; - - -procedure LFNFindClose(var s:searchrec); -var - hdl : longint; -begin - Move(s.Fill,hdl,4); - dosregs.ebx:=hdl; - dosregs.ax:=$71a1; - msdos(dosregs); - LoadDosError; -end; - - -{****************************************************************************** - --- DosFindfirst DosFindNext --- -******************************************************************************} - -procedure dossearchrec2searchrec(var f : searchrec); -var - len : longint; -begin - len:=StrLen(@f.Name); - Move(f.Name[0],f.Name[1],Len); - f.Name[0]:=chr(len); -end; - - -procedure DosFindfirst(path : pchar;attr : word;var f : searchrec); -var - i : longint; -begin - { allow slash as backslash } - for i:=0 to strlen(path) do - if path[i]='/' then path[i]:='\'; - copytodos(f,sizeof(searchrec)); - dosregs.edx:=tb_offset; - dosregs.ds:=tb_segment; - dosregs.ah:=$1a; - msdos(dosregs); - dosregs.ecx:=attr; - dosregs.edx:=tb_offset+Sizeof(searchrec)+1; - dosmemput(tb_segment,tb_offset+Sizeof(searchrec)+1,path^,strlen(path)+1); - dosregs.ds:=tb_segment; - dosregs.ah:=$4e; - msdos(dosregs); - copyfromdos(f,sizeof(searchrec)); - LoadDosError; - dossearchrec2searchrec(f); -end; - - -procedure Dosfindnext(var f : searchrec); -begin - copytodos(f,sizeof(searchrec)); - dosregs.edx:=tb_offset; - dosregs.ds:=tb_segment; - dosregs.ah:=$1a; - msdos(dosregs); - dosregs.ah:=$4f; - msdos(dosregs); - copyfromdos(f,sizeof(searchrec)); - LoadDosError; - dossearchrec2searchrec(f); -end; - - -{****************************************************************************** - --- Findfirst FindNext --- -******************************************************************************} - -procedure findfirst(const path : pathstr;attr : word;var f : searchRec); -var - path0 : array[0..256] of char; -begin - doserror:=0; - strpcopy(path0,path); - if LFNSupport then - LFNFindFirst(path0,attr,f) - else - Dosfindfirst(path0,attr,f); -end; - - -procedure findnext(var f : searchRec); -begin - doserror:=0; - if LFNSupport then - LFNFindnext(f) - else - Dosfindnext(f); -end; - - -Procedure FindClose(Var f: SearchRec); -begin - DosError:=0; - if LFNSupport then - LFNFindClose(f); -end; - - -type swap_proc = procedure; - -var - _swap_in : swap_proc;external name '_swap_in'; - _swap_out : swap_proc;external name '_swap_out'; - _exception_exit : pointer;external name '_exception_exit'; - _v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on'; - -procedure swapvectors; -begin - DosError:=0; - if _exception_exit<>nil then - if _v2prt0_exceptions_on then - _swap_in() - else - _swap_out(); - -(* asm -{ uses four global symbols from v2prt0.as to be able to know the current - exception state without using dpmiexcp unit } - movl _exception_exit,%eax - orl %eax,%eax - je .Lno_excep - movl _v2prt0_exceptions_on,%eax - orl %eax,%eax - je .Lexceptions_off - call *_swap_out - jmp .Lno_excep - .Lexceptions_off: - call *_swap_in - .Lno_excep: - end; *) -end; - - -{****************************************************************************** - --- File --- -******************************************************************************} - -procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr); -var - dotpos,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 } - if LFNSupport then - begin - Ext:=''; - i:=Length(Path); - DotPos:=256; - While (i>0) Do - Begin - If (Path[i]='.') Then - begin - DotPos:=i; - break; - end; - Dec(i); - end; - Ext:=Copy(Path,DotPos,255); - Name:=Copy(Path,1,DotPos - 1); - end - else - begin - 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; -end; - - - function fexpand(const path : pathstr) : pathstr; - var - s,pa : pathstr; - i,j : longint; - begin - getdir(0,s); - i:=ioresult; - if LFNSupport then - begin - pa:=path; - end - else - if FileNameCaseSensitive then - pa:=path - else - pa:=upcase(path); - - { allow slash as backslash } - for i:=1 to length(pa) do - if pa[i]='/' then - pa[i]:='\'; - - if (length(pa)>1) and (pa[2]=':') and (pa[1] in ['A'..'Z','a'..'z']) then - begin - { Always uppercase driveletter } - if (pa[1] in ['a'..'z']) then - pa[1]:=Chr(Ord(Pa[1])-32); - { we must get the right directory } - getdir(ord(pa[1])-ord('A')+1,s); - i:=ioresult; - if (ord(pa[0])>2) and (pa[3]<>'\') then - if pa[1]=s[1] then - begin - { remove ending slash if it already exists } - if s[length(s)]='\' then - dec(s[0]); - pa:=s+'\'+copy (pa,3,length(pa)); - end - 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(pa) = 2 then pa := pa + '\'; - fexpand:=pa; - end; - - -Function FSearch(path: pathstr; dirlist: string): pathstr; -var - i,p1 : longint; - s : searchrec; - newdir : pathstr; -begin -{ check if the file specified exists } - findfirst(path,anyfile,s); - if doserror=0 then - begin - findclose(s); - fsearch:=path; - exit; - end; -{ 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; - findclose(s); -end; - - -{****************************************************************************** - --- Get/Set File Time,Attr --- -******************************************************************************} - -procedure getftime(var f;var time : longint); -begin - dosregs.bx:=textrec(f).handle; - dosregs.ax:=$5700; - msdos(dosregs); - loaddoserror; - time:=(dosregs.dx shl 16)+dosregs.cx; -end; - - -procedure setftime(var f;time : longint); -begin - dosregs.bx:=textrec(f).handle; - dosregs.cx:=time and $ffff; - dosregs.dx:=time shr 16; - dosregs.ax:=$5701; - msdos(dosregs); - loaddoserror; -end; - - -procedure getfattr(var f;var attr : word); -begin - copytodos(filerec(f).name,strlen(filerec(f).name)+1); - dosregs.edx:=tb_offset; - dosregs.ds:=tb_segment; - if LFNSupport then - begin - dosregs.ax:=$7143; - dosregs.bx:=0; - end - else - dosregs.ax:=$4300; - msdos(dosregs); - LoadDosError; - Attr:=dosregs.cx; -end; - - -procedure setfattr(var f;attr : word); -begin - copytodos(filerec(f).name,strlen(filerec(f).name)+1); - dosregs.edx:=tb_offset; - dosregs.ds:=tb_segment; - if LFNSupport then - begin - dosregs.ax:=$7143; - dosregs.bx:=1; - end - else - dosregs.ax:=$4301; - dosregs.cx:=attr; - msdos(dosregs); - LoadDosError; -end; - - -{****************************************************************************** - --- Environment --- -******************************************************************************} - -function envcount : longint; -var - hp : ppchar; -begin - hp:=envp; - envcount:=0; - while assigned(hp^) do - begin - inc(envcount); - inc(hp); - end; -end; - - -function envstr(index : integer) : string; -begin - if (index<=0) or (index>envcount) then - begin - envstr:=''; - exit; - end; - envstr:=strpas(ppchar(pointer(envp)+4*(index-1))^); -end; - - -Function GetEnv(envvar: string): string; -var - hp : ppchar; - hs : string; - eqpos : longint; -begin - envvar:=upcase(envvar); - hp:=envp; - getenv:=''; - while assigned(hp^) do - begin - hs:=strpas(hp^); - eqpos:=pos('=',hs); - if copy(hs,1,eqpos-1)=envvar then - begin - getenv:=copy(hs,eqpos+1,255); - exit; - end; - inc(hp); - end; -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. -{ +{ + $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 dos; +interface + +Uses + Go32; + +Const + {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 LFN Support } + ComStr = String[255]; + PathStr = String[255]; + DirStr = String[255]; + NameStr = String[255]; + ExtStr = String[255]; + +{ + filerec.inc contains the definition of the filerec. + textrec.inc contains the definition of the textrec. + It is in a separate file to make it available in other units without + having to use the DOS unit for it. +} +{$i filerec.inc} +{$i textrec.inc} + + DateTime = packed record + Year, + Month, + Day, + Hour, + Min, + Sec : word; + End; + + searchrec = packed record + fill : array[1..21] of byte; + attr : byte; + time : longint; + { reserved : word; not in DJGPP V2 } + size : longint; + name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) } + end; + + Registers = Go32.Registers; + +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; + +{$ASMMODE ATT} + +{****************************************************************************** + --- Dos Interrupt --- +******************************************************************************} + +var + dosregs : registers; + +procedure LoadDosError; +var + r : registers; +begin + if (dosregs.flags and carryflag) <> 0 then + begin + r.eax:=$5900; + r.ebx:=$0; + realintr($21,r); + { conversion from word to integer !! + gave a Bound check error if ax is $FFFF !! PM } + doserror:=integer(r.ax); + case doserror of + 19 : DosError:=150; + 21 : DosError:=152; + end; + end + else + doserror:=0; +end; + + +procedure intr(intno : byte;var regs : registers); +begin + realintr(intno,regs); +end; + + +procedure msdos(var regs : registers); +begin + intr($21,regs); +end; + + +{****************************************************************************** + --- Info / Date / Time --- +******************************************************************************} + +function dosversion : word; +begin + dosregs.ax:=$3000; + msdos(dosregs); + dosversion:=dosregs.ax; +end; + + +procedure getdate(var year,month,mday,wday : word); +begin + dosregs.ax:=$2a00; + msdos(dosregs); + wday:=dosregs.al; + year:=dosregs.cx; + month:=dosregs.dh; + mday:=dosregs.dl; +end; + + +procedure setdate(year,month,day : word); +begin + dosregs.cx:=year; + dosregs.dh:=month; + dosregs.dl:=day; + dosregs.ah:=$2b; + msdos(dosregs); + DosError:=0; +end; + + +procedure gettime(var hour,minute,second,sec100 : word); +begin + dosregs.ah:=$2c; + msdos(dosregs); + hour:=dosregs.ch; + minute:=dosregs.cl; + second:=dosregs.dh; + sec100:=dosregs.dl; + DosError:=0; +end; + + +procedure settime(hour,minute,second,sec100 : word); +begin + dosregs.ch:=hour; + dosregs.cl:=minute; + dosregs.dh:=second; + dosregs.dl:=sec100; + dosregs.ah:=$2d; + msdos(dosregs); + DosError:=0; +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); +type + realptr = packed record + ofs,seg : word; + end; + texecblock = packed record + envseg : word; + comtail : realptr; + firstFCB : realptr; + secondFCB : realptr; + iniStack : realptr; + iniCSIP : realptr; + end; +var + current_dos_buffer_pos, + arg_ofs, + i,la_env, + la_p,la_c,la_e, + fcb1_la,fcb2_la : longint; + execblock : texecblock; + c,p : string; + + function paste_to_dos(src : string) : boolean; + var + c : array[0..255] of char; + begin + paste_to_dos:=false; + if current_dos_buffer_pos+length(src)+1>transfer_buffer+tb_size then + RunError(217); + move(src[1],c[0],length(src)); + c[length(src)]:=#0; + seg_move(get_ds,longint(@c),dosmemselector,current_dos_buffer_pos,length(src)+1); + current_dos_buffer_pos:=current_dos_buffer_pos+length(src)+1; + paste_to_dos:=true; + end; + +begin +{ create command line } + move(comline[0],c[1],length(comline)+1); + c[length(comline)+2]:=#13; + c[0]:=char(length(comline)+2); +{ create path } + p:=path; + for i:=1 to length(p) do + if p[i]='/' then + p[i]:='\'; +{ create buffer } + la_env:=transfer_buffer; + while (la_env and 15)<>0 do + inc(la_env); + current_dos_buffer_pos:=la_env; +{ copy environment } + for i:=1 to envcount do + paste_to_dos(envstr(i)); + paste_to_dos(''); { adds a double zero at the end } +{ allow slash as backslash } + la_p:=current_dos_buffer_pos; + paste_to_dos(p); + la_c:=current_dos_buffer_pos; + paste_to_dos(c); + la_e:=current_dos_buffer_pos; + fcb1_la:=la_e; + la_e:=la_e+16; + fcb2_la:=la_e; + la_e:=la_e+16; +{ allocate FCB see dosexec code } + arg_ofs:=1; + while (c[arg_ofs] in [' ',#9]) do + inc(arg_ofs); + dosregs.ax:=$2901; + dosregs.ds:=(la_c+arg_ofs) shr 4; + dosregs.esi:=(la_c+arg_ofs) and 15; + dosregs.es:=fcb1_la shr 4; + dosregs.edi:=fcb1_la and 15; + msdos(dosregs); +{ allocate second FCB see dosexec code } + repeat + inc(arg_ofs); + until (c[arg_ofs] in [' ',#9,#13]); + if c[arg_ofs]<>#13 then + begin + repeat + inc(arg_ofs); + until not (c[arg_ofs] in [' ',#9]); + end; + dosregs.ax:=$2901; + dosregs.ds:=(la_c+arg_ofs) shr 4; + dosregs.si:=(la_c+arg_ofs) and 15; + dosregs.es:=fcb2_la shr 4; + dosregs.di:=fcb2_la and 15; + msdos(dosregs); + with execblock do + begin + envseg:=la_env shr 4; + comtail.seg:=la_c shr 4; + comtail.ofs:=la_c and 15; + firstFCB.seg:=fcb1_la shr 4; + firstFCB.ofs:=fcb1_la and 15; + secondFCB.seg:=fcb2_la shr 4; + secondFCB.ofs:=fcb2_la and 15; + end; + seg_move(get_ds,longint(@execblock),dosmemselector,la_e,sizeof(texecblock)); + dosregs.edx:=la_p and 15; + dosregs.ds:=la_p shr 4; + dosregs.ebx:=la_e and 15; + dosregs.es:=la_e shr 4; + dosregs.ax:=$4b00; + msdos(dosregs); + LoadDosError; + if DosError=0 then + begin + dosregs.ax:=$4d00; + msdos(dosregs); + LastDosExitCode:=DosRegs.al + end + else + LastDosExitCode:=0; +end; + + +function dosexitcode : word; +begin + dosexitcode:=lastdosexitcode; +end; + + +procedure getcbreak(var breakvalue : boolean); +begin + DosError:=0; + dosregs.ax:=$3300; + msdos(dosregs); + breakvalue:=dosregs.dl<>0; +end; + + +procedure setcbreak(breakvalue : boolean); +begin + DosError:=0; + dosregs.ax:=$3301; + dosregs.dl:=ord(breakvalue); + msdos(dosregs); +end; + + +procedure getverify(var verify : boolean); +begin + DosError:=0; + dosregs.ah:=$54; + msdos(dosregs); + verify:=dosregs.al<>0; +end; + + +procedure setverify(verify : boolean); +begin + DosError:=0; + dosregs.ah:=$2e; + dosregs.al:=ord(verify); + msdos(dosregs); +end; + + +{****************************************************************************** + --- Disk --- +******************************************************************************} + +function diskfree(drive : byte) : longint; +begin + DosError:=0; + dosregs.dl:=drive; + dosregs.ah:=$36; + msdos(dosregs); + if dosregs.ax<>$FFFF then + diskfree:=dosregs.ax*dosregs.bx*dosregs.cx + else + diskfree:=-1; +end; + + +function disksize(drive : byte) : longint; +begin + DosError:=0; + dosregs.dl:=drive; + dosregs.ah:=$36; + msdos(dosregs); + if dosregs.ax<>$FFFF then + disksize:=dosregs.ax*dosregs.cx*dosregs.dx + else + disksize:=-1; +end; + + +{****************************************************************************** + --- LFNFindfirst LFNFindNext --- +******************************************************************************} + +type + LFNSearchRec=packed record + attr, + crtime, + crtimehi, + actime, + actimehi, + lmtime, + lmtimehi, + sizehi, + size : longint; + reserved : array[0..7] of byte; + name : array[0..259] of byte; + shortname : array[0..13] of byte; + end; + +procedure LFNSearchRec2Dos(const w:LFNSearchRec;hdl:longint;var d:Searchrec); +var + Len : longint; +begin + With w do + begin + FillChar(d,sizeof(SearchRec),0); + if DosError=0 then + len:=StrLen(@Name) + else + len:=0; + d.Name[0]:=chr(len); + Move(Name[0],d.Name[1],Len); + d.Time:=lmTime; + d.Size:=Size; + d.Attr:=Attr and $FF; + Move(hdl,d.Fill,4); + end; +end; + + +procedure LFNFindFirst(path:pchar;attr:longint;var s:searchrec); +var + i : longint; + w : LFNSearchRec; +begin + { allow slash as backslash } + for i:=0 to strlen(path) do + if path[i]='/' then path[i]:='\'; + dosregs.si:=1; { use ms-dos time } + { don't include the label if not asked for it, needed for network drives } + if attr=$8 then + dosregs.ecx:=8 + else + dosregs.ecx:=attr and (not 8); + dosregs.edx:=tb_offset+Sizeof(LFNSearchrec)+1; + dosmemput(tb_segment,tb_offset+Sizeof(LFNSearchrec)+1,path^,strlen(path)+1); + dosregs.ds:=tb_segment; + dosregs.edi:=tb_offset; + dosregs.es:=tb_segment; + dosregs.ax:=$714e; + msdos(dosregs); + LoadDosError; + copyfromdos(w,sizeof(LFNSearchRec)); + LFNSearchRec2Dos(w,dosregs.ax,s); +end; + + +procedure LFNFindNext(var s:searchrec); +var + hdl : longint; + w : LFNSearchRec; +begin + Move(s.Fill,hdl,4); + dosregs.si:=1; { use ms-dos time } + dosregs.edi:=tb_offset; + dosregs.es:=tb_segment; + dosregs.ebx:=hdl; + dosregs.ax:=$714f; + msdos(dosregs); + LoadDosError; + copyfromdos(w,sizeof(LFNSearchRec)); + LFNSearchRec2Dos(w,hdl,s); +end; + + +procedure LFNFindClose(var s:searchrec); +var + hdl : longint; +begin + Move(s.Fill,hdl,4); + dosregs.ebx:=hdl; + dosregs.ax:=$71a1; + msdos(dosregs); + LoadDosError; +end; + + +{****************************************************************************** + --- DosFindfirst DosFindNext --- +******************************************************************************} + +procedure dossearchrec2searchrec(var f : searchrec); +var + len : longint; +begin + len:=StrLen(@f.Name); + Move(f.Name[0],f.Name[1],Len); + f.Name[0]:=chr(len); +end; + + +procedure DosFindfirst(path : pchar;attr : word;var f : searchrec); +var + i : longint; +begin + { allow slash as backslash } + for i:=0 to strlen(path) do + if path[i]='/' then path[i]:='\'; + copytodos(f,sizeof(searchrec)); + dosregs.edx:=tb_offset; + dosregs.ds:=tb_segment; + dosregs.ah:=$1a; + msdos(dosregs); + dosregs.ecx:=attr; + dosregs.edx:=tb_offset+Sizeof(searchrec)+1; + dosmemput(tb_segment,tb_offset+Sizeof(searchrec)+1,path^,strlen(path)+1); + dosregs.ds:=tb_segment; + dosregs.ah:=$4e; + msdos(dosregs); + copyfromdos(f,sizeof(searchrec)); + LoadDosError; + dossearchrec2searchrec(f); +end; + + +procedure Dosfindnext(var f : searchrec); +begin + copytodos(f,sizeof(searchrec)); + dosregs.edx:=tb_offset; + dosregs.ds:=tb_segment; + dosregs.ah:=$1a; + msdos(dosregs); + dosregs.ah:=$4f; + msdos(dosregs); + copyfromdos(f,sizeof(searchrec)); + LoadDosError; + dossearchrec2searchrec(f); +end; + + +{****************************************************************************** + --- Findfirst FindNext --- +******************************************************************************} + +procedure findfirst(const path : pathstr;attr : word;var f : searchRec); +var + path0 : array[0..256] of char; +begin + doserror:=0; + strpcopy(path0,path); + if LFNSupport then + LFNFindFirst(path0,attr,f) + else + Dosfindfirst(path0,attr,f); +end; + + +procedure findnext(var f : searchRec); +begin + doserror:=0; + if LFNSupport then + LFNFindnext(f) + else + Dosfindnext(f); +end; + + +Procedure FindClose(Var f: SearchRec); +begin + DosError:=0; + if LFNSupport then + LFNFindClose(f); +end; + + +type swap_proc = procedure; + +var + _swap_in : swap_proc;external name '_swap_in'; + _swap_out : swap_proc;external name '_swap_out'; + _exception_exit : pointer;external name '_exception_exit'; + _v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on'; + +procedure swapvectors; +begin + DosError:=0; + if _exception_exit<>nil then + if _v2prt0_exceptions_on then + _swap_in() + else + _swap_out(); + +(* asm +{ uses four global symbols from v2prt0.as to be able to know the current + exception state without using dpmiexcp unit } + movl _exception_exit,%eax + orl %eax,%eax + je .Lno_excep + movl _v2prt0_exceptions_on,%eax + orl %eax,%eax + je .Lexceptions_off + call *_swap_out + jmp .Lno_excep + .Lexceptions_off: + call *_swap_in + .Lno_excep: + end; *) +end; + + +{****************************************************************************** + --- File --- +******************************************************************************} + +procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr); +var + dotpos,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 } + if LFNSupport then + begin + Ext:=''; + i:=Length(Path); + DotPos:=256; + While (i>0) Do + Begin + If (Path[i]='.') Then + begin + DotPos:=i; + break; + end; + Dec(i); + end; + Ext:=Copy(Path,DotPos,255); + Name:=Copy(Path,1,DotPos - 1); + end + else + begin + 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; +end; + + + function fexpand(const path : pathstr) : pathstr; + var + s,pa : pathstr; + i,j : longint; + begin + getdir(0,s); + i:=ioresult; + if LFNSupport then + begin + pa:=path; + end + else + if FileNameCaseSensitive then + pa:=path + else + pa:=upcase(path); + + { allow slash as backslash } + for i:=1 to length(pa) do + if pa[i]='/' then + pa[i]:='\'; + + if (length(pa)>1) and (pa[2]=':') and (pa[1] in ['A'..'Z','a'..'z']) then + begin + { Always uppercase driveletter } + if (pa[1] in ['a'..'z']) then + pa[1]:=Chr(Ord(Pa[1])-32); + { we must get the right directory } + getdir(ord(pa[1])-ord('A')+1,s); + i:=ioresult; + if (ord(pa[0])>2) and (pa[3]<>'\') then + if pa[1]=s[1] then + begin + { remove ending slash if it already exists } + if s[length(s)]='\' then + dec(s[0]); + pa:=s+'\'+copy (pa,3,length(pa)); + end + 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(pa) = 2 then pa := pa + '\'; + fexpand:=pa; + end; + + +Function FSearch(path: pathstr; dirlist: string): pathstr; +var + i,p1 : longint; + s : searchrec; + newdir : pathstr; +begin +{ check if the file specified exists } + findfirst(path,anyfile,s); + if doserror=0 then + begin + findclose(s); + fsearch:=path; + exit; + end; +{ 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; + findclose(s); +end; + + +{****************************************************************************** + --- Get/Set File Time,Attr --- +******************************************************************************} + +procedure getftime(var f;var time : longint); +begin + dosregs.bx:=textrec(f).handle; + dosregs.ax:=$5700; + msdos(dosregs); + loaddoserror; + time:=(dosregs.dx shl 16)+dosregs.cx; +end; + + +procedure setftime(var f;time : longint); +begin + dosregs.bx:=textrec(f).handle; + dosregs.cx:=time and $ffff; + dosregs.dx:=time shr 16; + dosregs.ax:=$5701; + msdos(dosregs); + loaddoserror; +end; + + +procedure getfattr(var f;var attr : word); +begin + copytodos(filerec(f).name,strlen(filerec(f).name)+1); + dosregs.edx:=tb_offset; + dosregs.ds:=tb_segment; + if LFNSupport then + begin + dosregs.ax:=$7143; + dosregs.bx:=0; + end + else + dosregs.ax:=$4300; + msdos(dosregs); + LoadDosError; + Attr:=dosregs.cx; +end; + + +procedure setfattr(var f;attr : word); +begin + copytodos(filerec(f).name,strlen(filerec(f).name)+1); + dosregs.edx:=tb_offset; + dosregs.ds:=tb_segment; + if LFNSupport then + begin + dosregs.ax:=$7143; + dosregs.bx:=1; + end + else + dosregs.ax:=$4301; + dosregs.cx:=attr; + msdos(dosregs); + LoadDosError; +end; + + +{****************************************************************************** + --- Environment --- +******************************************************************************} + +function envcount : longint; +var + hp : ppchar; +begin + hp:=envp; + envcount:=0; + while assigned(hp^) do + begin + inc(envcount); + inc(hp); + end; +end; + + +function envstr(index : integer) : string; +begin + if (index<=0) or (index>envcount) then + begin + envstr:=''; + exit; + end; + envstr:=strpas(ppchar(pointer(envp)+4*(index-1))^); +end; + + +Function GetEnv(envvar: string): string; +var + hp : ppchar; + hs : string; + eqpos : longint; +begin + envvar:=upcase(envvar); + hp:=envp; + getenv:=''; + while assigned(hp^) do + begin + hs:=strpas(hp^); + eqpos:=pos('=',hs); + if copy(hs,1,eqpos-1)=envvar then + begin + getenv:=copy(hs,eqpos+1,255); + exit; + end; + inc(hp); + end; +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.11 1999-09-08 18:55:49 peter - * pointer fixes - - Revision 1.10 1999/08/13 21:23:15 peter - * fsearch checks first if the specified file exists and returns that - if it was found - - Revision 1.9 1999/05/16 17:08:58 peter - * fixed driveletter checking - - Revision 1.8 1999/05/08 19:47:22 peter - * check ioresult after getdir calls - - Revision 1.7 1999/05/04 23:55:50 pierre - * unneeded assembler code converted to pascal - - Revision 1.6 1999/04/28 11:42:44 peter - + FileNameCaseSensetive boolean - - Revision 1.5 1999/04/02 00:01:29 peter - * fixed LFNFindfirst on network drives - - Revision 1.4 1999/03/01 15:40:48 peter - * use external names - * removed all direct assembler modes - - Revision 1.3 1999/01/22 15:44:59 pierre - Daniel change removed : broke make cycle !! - - Revision 1.2 1999/01/22 10:07:03 daniel - - Findclose removed: This is TP incompatible!! - - Revision 1.1 1998/12/21 13:07:02 peter - * use -FE - - Revision 1.19 1998/11/23 13:53:59 peter - * more fexpand fixes from marco van de voort - - Revision 1.18 1998/11/23 12:48:02 peter - * fexpand('o:') fixed to return o:\ (from the mailinglist) - - Revision 1.17 1998/11/22 09:33:21 florian - * fexpand bug (temp. strings were too shoort) fixed, was reported - by Marco van de Voort - - Revision 1.16 1998/11/17 09:37:41 pierre - * explicit conversion from word dosreg.ax to integer doserror - - Revision 1.15 1998/11/01 20:27:18 peter - * fixed some doserror settings - - Revision 1.14 1998/10/22 15:05:28 pierre - * fsplit adapted to long filenames - - Revision 1.13 1998/09/16 16:47:24 peter - * merged fixes - - Revision 1.11.2.2 1998/09/16 16:16:04 peter - * go32v1 compiles again - - Revision 1.12 1998/09/11 12:46:44 pierre - * range check problem with LFN attr removed - - Revision 1.11.2.1 1998/09/11 12:38:41 pierre - * conversion from LFN attr to Dos attr did not respect range checking - - Revision 1.11 1998/08/28 10:45:58 peter - * fixed path buffer in findfirst - - Revision 1.10 1998/08/27 10:30:48 pierre - * go32v1 RTL did not compile (LFNsupport outside go32v2 defines !) - I renamed tb_selector to tb_segment because - it is a real mode segment as opposed to - a protected mode selector - Fixed it for go32v1 (remove the $E0000000 offset !) - - Revision 1.9 1998/08/26 10:04:01 peter - * new lfn check from mailinglist - * renamed win95 -> LFNSupport - + tb_selector, tb_offset for easier access to transferbuffer - - Revision 1.8 1998/08/16 20:39:49 peter - + LFN Support - - Revision 1.7 1998/08/16 09:12:13 michael - Corrected fexpand behaviour. - - Revision 1.6 1998/08/05 21:01:50 michael - applied bugfix from maillist to fsearch - - Revision 1.5 1998/05/31 14:18:13 peter - * force att or direct assembling - * cleanup of some files - - Revision 1.4 1998/05/22 00:39:22 peter - * go32v1, go32v2 recompiles with the new objects - * remake3 works again with go32v2 - - removed some "optimizes" from daniel which were wrong - - Revision 1.3 1998/05/21 19:30:47 peter - * objects compiles for linux - + assign(pchar), assign(char), rename(pchar), rename(char) - * fixed read_text_as_array - + read_text_as_pchar which was not yet in the rtl -} - - - + Revision 1.12 1999-09-10 17:14:09 peter + * better errorcode returning using int21h,5900 + + Revision 1.11 1999/09/08 18:55:49 peter + * pointer fixes + + Revision 1.10 1999/08/13 21:23:15 peter + * fsearch checks first if the specified file exists and returns that + if it was found + + Revision 1.9 1999/05/16 17:08:58 peter + * fixed driveletter checking + + Revision 1.8 1999/05/08 19:47:22 peter + * check ioresult after getdir calls + + Revision 1.7 1999/05/04 23:55:50 pierre + * unneeded assembler code converted to pascal + + Revision 1.6 1999/04/28 11:42:44 peter + + FileNameCaseSensetive boolean + + Revision 1.5 1999/04/02 00:01:29 peter + * fixed LFNFindfirst on network drives + + Revision 1.4 1999/03/01 15:40:48 peter + * use external names + * removed all direct assembler modes + + Revision 1.3 1999/01/22 15:44:59 pierre + Daniel change removed : broke make cycle !! + + Revision 1.2 1999/01/22 10:07:03 daniel + - Findclose removed: This is TP incompatible!! + + Revision 1.1 1998/12/21 13:07:02 peter + * use -FE + + Revision 1.19 1998/11/23 13:53:59 peter + * more fexpand fixes from marco van de voort + + Revision 1.18 1998/11/23 12:48:02 peter + * fexpand('o:') fixed to return o:\ (from the mailinglist) + + Revision 1.17 1998/11/22 09:33:21 florian + * fexpand bug (temp. strings were too shoort) fixed, was reported + by Marco van de Voort + + Revision 1.16 1998/11/17 09:37:41 pierre + * explicit conversion from word dosreg.ax to integer doserror + + Revision 1.15 1998/11/01 20:27:18 peter + * fixed some doserror settings + + Revision 1.14 1998/10/22 15:05:28 pierre + * fsplit adapted to long filenames + + Revision 1.13 1998/09/16 16:47:24 peter + * merged fixes + + Revision 1.11.2.2 1998/09/16 16:16:04 peter + * go32v1 compiles again + + Revision 1.12 1998/09/11 12:46:44 pierre + * range check problem with LFN attr removed + + Revision 1.11.2.1 1998/09/11 12:38:41 pierre + * conversion from LFN attr to Dos attr did not respect range checking + + Revision 1.11 1998/08/28 10:45:58 peter + * fixed path buffer in findfirst + + Revision 1.10 1998/08/27 10:30:48 pierre + * go32v1 RTL did not compile (LFNsupport outside go32v2 defines !) + I renamed tb_selector to tb_segment because + it is a real mode segment as opposed to + a protected mode selector + Fixed it for go32v1 (remove the $E0000000 offset !) + + Revision 1.9 1998/08/26 10:04:01 peter + * new lfn check from mailinglist + * renamed win95 -> LFNSupport + + tb_selector, tb_offset for easier access to transferbuffer + + Revision 1.8 1998/08/16 20:39:49 peter + + LFN Support + + Revision 1.7 1998/08/16 09:12:13 michael + Corrected fexpand behaviour. + + Revision 1.6 1998/08/05 21:01:50 michael + applied bugfix from maillist to fsearch + + Revision 1.5 1998/05/31 14:18:13 peter + * force att or direct assembling + * cleanup of some files + + Revision 1.4 1998/05/22 00:39:22 peter + * go32v1, go32v2 recompiles with the new objects + * remake3 works again with go32v2 + - removed some "optimizes" from daniel which were wrong + + Revision 1.3 1998/05/21 19:30:47 peter + * objects compiles for linux + + assign(pchar), assign(char), rename(pchar), rename(char) + * fixed read_text_as_array + + read_text_as_pchar which was not yet in the rtl +} + + + diff --git a/rtl/go32v2/system.pp b/rtl/go32v2/system.pp index 4d027c687b..ec0026ab0b 100644 --- a/rtl/go32v2/system.pp +++ b/rtl/go32v2/system.pp @@ -1,1422 +1,1439 @@ -{ - $Id$ - This file is part of the Free Pascal run time library. - Copyright (c) 1993,97 by the Free Pascal development team. - - 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 system; - -interface - -{ two debug conditionnals can be used - - SYSTEMDEBUG - -for STACK checks - -for non closed files at exit (or at any time with GDB) - - SYSTEM_DEBUG_STARTUP - specifically for - - proxy command line (DJGPP feature) - - list of args - - list of env variables (PM) } - -{ include system-independent routine headers } - -{$I systemh.inc} - -{ include heap support headers } - -{$I heaph.inc} - -const -{ Default filehandles } - UnusedHandle = -1; - StdInputHandle = 0; - StdOutputHandle = 1; - StdErrorHandle = 2; - - FileNameCaseSensitive : boolean = false; - -{ Default memory segments (Tp7 compatibility) } - seg0040 = $0040; - segA000 = $A000; - segB000 = $B000; - segB800 = $B800; - -var -{ Mem[] support } - mem : array[0..$7fffffff] of byte absolute $0:$0; - memw : array[0..$7fffffff] of word absolute $0:$0; - meml : array[0..$7fffffff] of longint absolute $0:$0; -{ C-compatible arguments and environment } - argc : longint; - argv : ppchar; - envp : ppchar; - dos_argv0 : pchar; - -{$ifndef RTLLITE} -{ System info } - LFNSupport : boolean; -{$endif RTLLITE} - -type -{ Dos Extender info } - p_stub_info = ^t_stub_info; - t_stub_info = packed record - magic : array[0..15] of char; - size : longint; - minstack : longint; - memory_handle : longint; - initial_size : longint; - minkeep : word; - ds_selector : word; - ds_segment : word; - psp_selector : word; - cs_selector : word; - env_size : word; - basename : array[0..7] of char; - argv0 : array [0..15] of char; - dpmi_server : array [0..15] of char; - end; - - p_go32_info_block = ^t_go32_info_block; - t_go32_info_block = packed record - size_of_this_structure_in_bytes : longint; {offset 0} - linear_address_of_primary_screen : longint; {offset 4} - linear_address_of_secondary_screen : longint; {offset 8} - linear_address_of_transfer_buffer : longint; {offset 12} - size_of_transfer_buffer : longint; {offset 16} - pid : longint; {offset 20} - master_interrupt_controller_base : byte; {offset 24} - slave_interrupt_controller_base : byte; {offset 25} - selector_for_linear_memory : word; {offset 26} - linear_address_of_stub_info_structure : longint; {offset 28} - linear_address_of_original_psp : longint; {offset 32} - run_mode : word; {offset 36} - run_mode_info : word; {offset 38} - end; - -var - stub_info : p_stub_info; - go32_info_block : t_go32_info_block; - - -{ - necessary for objects.pas, should be removed (at least from the interface - to the implementation) -} - type - trealregs=record - realedi,realesi,realebp,realres, - realebx,realedx,realecx,realeax : longint; - realflags, - reales,realds,realfs,realgs, - realip,realcs,realsp,realss : word; - end; - function do_write(h,addr,len : longint) : longint; - function do_read(h,addr,len : longint) : longint; - procedure syscopyfromdos(addr : longint; len : longint); - procedure syscopytodos(addr : longint; len : longint); - procedure sysrealintr(intnr : word;var regs : trealregs); - function tb : longint; - -implementation - -{ include system independent routines } - -{$I system.inc} - -const - carryflag = 1; - -type - tseginfo=packed record - offset : pointer; - segment : word; - end; - -var - doscmd : string[128]; { Dos commandline copied from PSP, max is 128 chars } - old_int00 : tseginfo;cvar; - old_int75 : tseginfo;cvar; - -{$asmmode ATT} - -{***************************************************************************** - Go32 Helpers -*****************************************************************************} - -function far_strlen(selector : word;linear_address : longint) : longint; -begin -asm - movl linear_address,%edx - movl %edx,%ecx - movw selector,%gs -.Larg19: - movb %gs:(%edx),%al - testb %al,%al - je .Larg20 - incl %edx - jmp .Larg19 -.Larg20: - movl %edx,%eax - subl %ecx,%eax - movl %eax,__RESULT -end; -end; - - -function tb : longint; -begin - tb:=go32_info_block.linear_address_of_transfer_buffer; -end; - - -function tb_segment : longint; -begin - tb_segment:=go32_info_block.linear_address_of_transfer_buffer shr 4; -end; - - -function tb_offset : longint; -begin - tb_offset:=go32_info_block.linear_address_of_transfer_buffer and $f; -end; - - -function tb_size : longint; -begin - tb_size:=go32_info_block.size_of_transfer_buffer; -end; - - -function dos_selector : word; -begin - dos_selector:=go32_info_block.selector_for_linear_memory; -end; - - -function get_ds : word;assembler; -asm - movw %ds,%ax -end; - - -function get_cs : word;assembler; -asm - movw %cs,%ax -end; - - -procedure sysseg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint); -begin - if count=0 then - exit; - if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then - asm - pushw %es - pushw %ds - cld - movl count,%ecx - movl source,%esi - movl dest,%edi - movw dseg,%ax - movw %ax,%es - movw sseg,%ax - movw %ax,%ds - movl %ecx,%eax - shrl $2,%ecx - rep - movsl - movl %eax,%ecx - andl $3,%ecx - rep - movsb - popw %ds - popw %es - end ['ESI','EDI','ECX','EAX'] - else if (source#0) do - begin - v:=byte(s^)-byte('0'); - if (v > 9) then - dec(v,7); - v:=v and 15; { in case it's lower case } - rv:=(rv shl 4) or v; - inc(longint(s)); - end; - atohex:=rv; -end; - -var - _args : ppchar;external name '_args'; - -procedure setup_arguments; -type arrayword = array [0..0] of word; -var psp : word; - i,j : byte; - quote : char; - proxy_s : string[7]; - al,proxy_argc,proxy_seg,proxy_ofs,lin : longint; - largs : array[0..127] of pchar; - rm_argv : ^arrayword; -begin -for i := 1 to 127 do - largs[i] := nil; -psp:=stub_info^.psp_selector; -largs[0]:=dos_argv0; -argc := 1; -sysseg_move(psp, 128, get_ds, longint(@doscmd), 128); -{$IfDef SYSTEM_DEBUG_STARTUP} -Writeln(stderr,'Dos command line is #',doscmd,'# size = ',length(doscmd)); -{$EndIf } - -// setup cmdline variable -sysgetmem(cmdline,length(doscmd)+1); -move(doscmd[1],cmdline^,length(doscmd)); -cmdline[length(doscmd)]:=#0; - -j := 1; -quote := #0; -for i:=1 to length(doscmd) do - Begin - if doscmd[i] = quote then - begin - quote := #0; - if (i>1) and ((doscmd[i-1]='''') or (doscmd[i-1]='"')) then - begin - j := i+1; - doscmd[i] := #0; - continue; - end; - doscmd[i] := #0; - largs[argc]:=@doscmd[j]; - inc(argc); - j := i+1; - end else - if (quote = #0) and ((doscmd[i] = '''') or (doscmd[i]='"')) then - begin - quote := doscmd[i]; - j := i + 1; - end else - if (quote = #0) and ((doscmd[i] = ' ') - or (doscmd[i] = #9) or (doscmd[i] = #10) or - (doscmd[i] = #12) or (doscmd[i] = #9)) then - begin - doscmd[i]:=#0; - if j 1) and (far_strlen(get_ds,longint(largs[1])) = 6) then - begin - move(largs[1]^,proxy_s[1],6); - proxy_s[0] := #6; - if (proxy_s = '!proxy') then - begin -{$IfDef SYSTEM_DEBUG_STARTUP} - Writeln(stderr,'proxy command line '); -{$EndIf SYSTEM_DEBUG_STARTUP} - proxy_argc := atohex(largs[2]); - proxy_seg := atohex(largs[3]); - proxy_ofs := atohex(largs[4]); - sysgetmem(rm_argv,proxy_argc*sizeof(word)); - sysseg_move(dos_selector,proxy_seg*16+proxy_ofs, get_ds,longint(rm_argv),proxy_argc*sizeof(word)); - for i:=0 to proxy_argc - 1 do - begin - lin := proxy_seg*16 + rm_argv^[i]; - al :=far_strlen(dos_selector, lin); - sysgetmem(largs[i],al+1); - sysseg_move(dos_selector, lin, get_ds,longint(largs[i]), al+1); -{$IfDef SYSTEM_DEBUG_STARTUP} - Writeln(stderr,'arg ',i,' #',largs[i],'#'); -{$EndIf SYSTEM_DEBUG_STARTUP} - end; - argc := proxy_argc; - end; - end; -sysgetmem(argv,argc shl 2); -for i := 0 to argc-1 do - argv[i] := largs[i]; - _args:=argv; -end; - - -function strcopy(dest,source : pchar) : pchar; -begin - asm - cld - movl 12(%ebp),%edi - movl $0xffffffff,%ecx - xorb %al,%al - repne - scasb - not %ecx - movl 8(%ebp),%edi - movl 12(%ebp),%esi - movl %ecx,%eax - shrl $2,%ecx - rep - movsl - movl %eax,%ecx - andl $3,%ecx - rep - movsb - movl 8(%ebp),%eax - leave - ret $8 - end; -end; - - -var - __stubinfo : p_stub_info;external name '__stubinfo'; - ___dos_argv0 : pchar;external name '___dos_argv0'; - -procedure setup_environment; -var env_selector : word; - env_count : longint; - dos_env,cp : pchar; -begin - stub_info:=__stubinfo; - sysgetmem(dos_env,stub_info^.env_size); - env_count:=0; - sysseg_move(stub_info^.psp_selector,$2c, get_ds, longint(@env_selector), 2); - sysseg_move(env_selector, 0, get_ds, longint(dos_env), stub_info^.env_size); - cp:=dos_env; - while cp ^ <> #0 do - begin - inc(env_count); - while (cp^ <> #0) do inc(longint(cp)); { skip to NUL } - inc(longint(cp)); { skip to next character } - end; - sysgetmem(envp,(env_count+1) * sizeof(pchar)); - if (envp = nil) then exit; - cp:=dos_env; - env_count:=0; - while cp^ <> #0 do - begin - sysgetmem(envp[env_count],strlen(cp)+1); - strcopy(envp[env_count], cp); -{$IfDef SYSTEM_DEBUG_STARTUP} - Writeln(stderr,'env ',env_count,' = "',envp[env_count],'"'); -{$EndIf SYSTEM_DEBUG_STARTUP} - inc(env_count); - while (cp^ <> #0) do - inc(longint(cp)); { skip to NUL } - inc(longint(cp)); { skip to next character } - end; - envp[env_count]:=nil; - longint(cp):=longint(cp)+3; - sysgetmem(dos_argv0,strlen(cp)+1); - if (dos_argv0 = nil) then halt; - strcopy(dos_argv0, cp); - { update ___dos_argv0 also } - ___dos_argv0:=dos_argv0 -end; - - -procedure syscopytodos(addr : longint; len : longint); -begin - if len > tb_size then - HandleError(217); - sysseg_move(get_ds,addr,dos_selector,tb,len); -end; - - -procedure syscopyfromdos(addr : longint; len : longint); -begin - if len > tb_size then - HandleError(217); - sysseg_move(dos_selector,tb,get_ds,addr,len); -end; - - -procedure sysrealintr(intnr : word;var regs : trealregs); -begin - regs.realsp:=0; - regs.realss:=0; - asm - movw intnr,%bx - xorl %ecx,%ecx - movl regs,%edi - movw $0x300,%ax - int $0x31 - end; -end; - - -procedure set_pm_interrupt(vector : byte;const intaddr : tseginfo); -begin - asm - movl intaddr,%eax - movl (%eax),%edx - movw 4(%eax),%cx - movl $0x205,%eax - movb vector,%bl - int $0x31 - end; -end; - - -procedure get_pm_interrupt(vector : byte;var intaddr : tseginfo); -begin - asm - movb vector,%bl - movl $0x204,%eax - int $0x31 - movl intaddr,%eax - movl %edx,(%eax) - movw %cx,4(%eax) - end; -end; - - - - { Keep Track of open files } - const - max_files = 50; - var - openfiles : array [0..max_files-1] of boolean; -{$ifdef SYSTEMDEBUG} - opennames : array [0..max_files-1] of pchar; - const - free_closed_names : boolean = true; -{$endif SYSTEMDEBUG} - -{***************************************************************************** - System Dependent Exit code -*****************************************************************************} - -procedure ___exit(exitcode:byte);cdecl;external name '___exit'; - -procedure do_close(handle : longint);forward; - -Procedure system_exit; -var - h : byte; -begin - for h:=0 to max_files-1 do - if openfiles[h] then - begin -{$ifdef SYSTEMDEBUG} - writeln(stderr,'file ',opennames[h],' not closed at exit'); -{$endif SYSTEMDEBUG} - if h>=5 then - do_close(h); - end; - { halt is not allways called !! } - { not on normal exit !! PM } - set_pm_interrupt($00,old_int00); - set_pm_interrupt($75,old_int75); - ___exit(exitcode); -end; - - -procedure halt(errnum : byte); -begin - exitcode:=errnum; - do_exit; - { do_exit should call system_exit but this does not hurt } - System_exit; -end; - -procedure new_int00; -begin - HandleError(200); -end; - -procedure new_int75; -begin - asm - xorl %eax,%eax - outb %al,$0x0f0 - movb $0x20,%al - outb %al,$0x0a0 - outb %al,$0x020 - end; - HandleError(200); -end; - - -var - __stkbottom : longint;external name '__stkbottom'; - -procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK']; -{ - called when trying to get local stack if the compiler directive $S - is set this function must preserve esi !!!! because esi is set by - the calling proc for methods it must preserve all registers !! - - With a 2048 byte safe area used to write to StdIo without crossing - the stack boundary -} -begin - asm - pushl %eax - pushl %ebx - movl stack_size,%ebx - addl $2048,%ebx - movl %esp,%eax - subl %ebx,%eax -{$ifdef SYSTEMDEBUG} - movl loweststack,%ebx - cmpl %eax,%ebx - jb .L_is_not_lowest - movl %eax,loweststack -.L_is_not_lowest: -{$endif SYSTEMDEBUG} - movl __stkbottom,%ebx - cmpl %eax,%ebx - jae .L__short_on_stack - popl %ebx - popl %eax - leave - ret $4 -.L__short_on_stack: - { can be usefull for error recovery !! } - popl %ebx - popl %eax - end['EAX','EBX']; - HandleError(202); -end; - - -{***************************************************************************** - ParamStr/Randomize -*****************************************************************************} - -function paramcount : longint; -begin - paramcount := argc - 1; -end; - - -function paramstr(l : longint) : string; -begin - if (l>=0) and (l+1<=argc) then - paramstr:=strpas(argv[l]) - else - paramstr:=''; -end; - - -procedure randomize; -var - hl : longint; - regs : trealregs; -begin - regs.realeax:=$2c00; - sysrealintr($21,regs); - hl:=regs.realedx and $ffff; - randseed:=hl*$10000+ (regs.realecx and $ffff); -end; - -{***************************************************************************** - Heap Management -*****************************************************************************} - -var - int_heap : longint;external name 'HEAP'; - int_heapsize : longint;external name 'HEAPSIZE'; - -function getheapstart:pointer; -begin - getheapstart:=@int_heap; -end; - - -function getheapsize:longint; -begin - getheapsize:=int_heapsize; -end; - - -function ___sbrk(size:longint):longint;cdecl;external name '___sbrk'; - -function Sbrk(size : longint):longint;assembler; -asm - movl size,%eax - pushl %eax - call ___sbrk - addl $4,%esp -end; - - -{ include standard heap management } -{$I heap.inc} - - -{**************************************************************************** - Low level File Routines - ****************************************************************************} - -procedure AllowSlash(p:pchar); -var - i : longint; -begin -{ allow slash as backslash } - for i:=0 to strlen(p) do - if p[i]='/' then p[i]:='\'; -end; - -procedure do_close(handle : longint); -var - regs : trealregs; -begin - regs.realebx:=handle; -{$ifdef SYSTEMDEBUG} - if handle 0 then - InOutRes:=lo(regs.realeax); -end; - - -procedure do_erase(p : pchar); -var - regs : trealregs; -begin - AllowSlash(p); - syscopytodos(longint(p),strlen(p)+1); - regs.realedx:=tb_offset; - regs.realds:=tb_segment; -{$ifndef RTLLITE} - if LFNSupport then - regs.realeax:=$7141 - else -{$endif RTLLITE} - regs.realeax:=$4100; - regs.realesi:=0; - regs.realecx:=0; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - InOutRes:=lo(regs.realeax); -end; - - -procedure do_rename(p1,p2 : pchar); -var - regs : trealregs; -begin - AllowSlash(p1); - AllowSlash(p2); - if strlen(p1)+strlen(p2)+3>tb_size then - HandleError(217); - sysseg_move(get_ds,longint(p2),dos_selector,tb,strlen(p2)+1); - sysseg_move(get_ds,longint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1); - regs.realedi:=tb_offset; - regs.realedx:=tb_offset + strlen(p2)+2; - regs.realds:=tb_segment; - regs.reales:=tb_segment; -{$ifndef RTLLITE} - if LFNSupport then - regs.realeax:=$7156 - else -{$endif RTLLITE} - regs.realeax:=$5600; - regs.realecx:=$ff; { attribute problem here ! } - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - InOutRes:=lo(regs.realeax); -end; - - -function do_write(h,addr,len : longint) : longint; -var - regs : trealregs; - size, - writesize : longint; -begin - writesize:=0; - while len > 0 do - begin - if len>tb_size then - size:=tb_size - else - size:=len; - syscopytodos(addr+writesize,size); - regs.realecx:=size; - regs.realedx:=tb_offset; - regs.realds:=tb_segment; - regs.realebx:=h; - regs.realeax:=$4000; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - begin - InOutRes:=lo(regs.realeax); - exit(writesize); - end; - inc(writesize,regs.realeax); - dec(len,regs.realeax); - { stop when not the specified size is written } - if regs.realeax 0 do - begin - if len>tb_size then - size:=tb_size - else - size:=len; - regs.realecx:=size; - regs.realedx:=tb_offset; - regs.realds:=tb_segment; - regs.realebx:=h; - regs.realeax:=$3f00; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - begin - InOutRes:=lo(regs.realeax); - do_read:=0; - exit; - end; - syscopyfromdos(addr+readsize,regs.realeax); - inc(readsize,regs.realeax); - dec(len,regs.realeax); - { stop when not the specified size is read } - if regs.realeax 0 then - Begin - InOutRes:=lo(regs.realeax); - do_filepos:=0; - end - else - do_filepos:=lo(regs.realedx) shl 16+lo(regs.realeax); -end; - - -procedure do_seek(handle,pos : longint); -var - regs : trealregs; -begin - regs.realebx:=handle; - regs.realecx:=pos shr 16; - regs.realedx:=pos and $ffff; - regs.realeax:=$4200; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - InOutRes:=lo(regs.realeax); -end; - - - -function do_seekend(handle:longint):longint; -var - regs : trealregs; -begin - regs.realebx:=handle; - regs.realecx:=0; - regs.realedx:=0; - regs.realeax:=$4202; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - Begin - InOutRes:=lo(regs.realeax); - do_seekend:=0; - end - else - do_seekend:=lo(regs.realedx) shl 16+lo(regs.realeax); -end; - - -function do_filesize(handle : longint) : longint; -var - aktfilepos : longint; -begin - aktfilepos:=do_filepos(handle); - do_filesize:=do_seekend(handle); - do_seek(handle,aktfilepos); -end; - - -{ truncate at a given position } -procedure do_truncate (handle,pos:longint); -var - regs : trealregs; -begin - do_seek(handle,pos); - regs.realecx:=0; - regs.realedx:=tb_offset; - regs.realds:=tb_segment; - regs.realebx:=handle; - regs.realeax:=$4000; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - InOutRes:=lo(regs.realeax); -end; - - -procedure do_open(var f;p:pchar;flags:longint); -{ - filerec and textrec have both handle and mode as the first items so - they could use the same routine for opening/creating. - when (flags and $100) the file will be append - when (flags and $1000) the file will be truncate/rewritten - when (flags and $10000) there is no check for close (needed for textfiles) -} -var - regs : trealregs; - action : longint; -begin - AllowSlash(p); -{ close first if opened } - if ((flags and $10000)=0) then - begin - case filerec(f).mode of - fminput,fmoutput,fminout : Do_Close(filerec(f).handle); - fmclosed : ; - else - begin - inoutres:=102; {not assigned} - exit; - end; - end; - end; -{ reset file handle } - filerec(f).handle:=UnusedHandle; - action:=$1; -{ convert filemode to filerec modes } - case (flags and 3) of - 0 : filerec(f).mode:=fminput; - 1 : filerec(f).mode:=fmoutput; - 2 : filerec(f).mode:=fminout; - end; - if (flags and $1000)<>0 then - begin - filerec(f).mode:=fmoutput; - action:=$12; {create file function} - end; -{ empty name is special } - if p[0]=#0 then - begin - case filerec(f).mode of - fminput : filerec(f).handle:=StdInputHandle; - fmappend, - fmoutput : begin - filerec(f).handle:=StdOutputHandle; - filerec(f).mode:=fmoutput; {fool fmappend} - end; - end; - exit; - end; -{ real dos call } - syscopytodos(longint(p),strlen(p)+1); -{$ifndef RTLLITE} - if LFNSupport then - regs.realeax:=$716c - else -{$endif RTLLITE} - regs.realeax:=$6c00; - regs.realedx:=action; - regs.realds:=tb_segment; - regs.realesi:=tb_offset; - regs.realebx:=$2000+(flags and $ff); - regs.realecx:=$20; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - begin - InOutRes:=lo(regs.realeax); - exit; - end - else - filerec(f).handle:=regs.realeax; -{$ifdef SYSTEMDEBUG} - if regs.realeax0 then - begin - do_seekend(filerec(f).handle); - filerec(f).mode:=fmoutput; {fool fmappend} - end; -end; - - -function do_isdevice(handle:longint):boolean; -var - regs : trealregs; -begin - regs.realebx:=handle; - regs.realeax:=$4400; - sysrealintr($21,regs); - do_isdevice:=(regs.realedx and $80)<>0; - if (regs.realflags and carryflag) <> 0 then - InOutRes:=lo(regs.realeax); -end; - - -{***************************************************************************** - UnTyped File Handling -*****************************************************************************} - -{$i file.inc} - -{***************************************************************************** - Typed File Handling -*****************************************************************************} - -{$i typefile.inc} - -{***************************************************************************** - Text File Handling -*****************************************************************************} - -{$DEFINE EOF_CTRLZ} - -{$i text.inc} - - -{***************************************************************************** - Generic Handling -*****************************************************************************} - -{$ifdef TEST_GENERIC} -{$i generic.inc} -{$endif TEST_GENERIC} - -{***************************************************************************** - Directory Handling -*****************************************************************************} - -procedure DosDir(func:byte;const s:string); -var - buffer : array[0..255] of char; - regs : trealregs; -begin - move(s[1],buffer,length(s)); - buffer[length(s)]:=#0; - AllowSlash(pchar(@buffer)); - syscopytodos(longint(@buffer),length(s)+1); - regs.realedx:=tb_offset; - regs.realds:=tb_segment; -{$ifndef RTLLITE} - if LFNSupport then - regs.realeax:=$7100+func - else -{$endif RTLLITE} - regs.realeax:=func shl 8; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - InOutRes:=lo(regs.realeax); -end; - - -procedure mkdir(const s : string);[IOCheck]; -begin - If InOutRes <> 0 then - exit; - DosDir($39,s); -end; - - -procedure rmdir(const s : string);[IOCheck]; -begin - If InOutRes <> 0 then - exit; - DosDir($3a,s); -end; - - -procedure chdir(const s : string);[IOCheck]; -var - regs : trealregs; -begin - If InOutRes <> 0 then - exit; -{ First handle Drive changes } - if (length(s)>=2) and (s[2]=':') then - begin - regs.realedx:=(ord(s[1]) and (not 32))-ord('A'); - regs.realeax:=$0e00; - sysrealintr($21,regs); - regs.realeax:=$1900; - sysrealintr($21,regs); - if byte(regs.realeax)<>byte(regs.realedx) then - begin - Inoutres:=15; - exit; - end; - end; -{ do the normal dos chdir } - DosDir($3b,s); -end; - - -procedure getdir(drivenr : byte;var dir : shortstring); -var - temp : array[0..255] of char; - i : longint; - regs : trealregs; -begin - regs.realedx:=drivenr; - regs.realesi:=tb_offset; - regs.realds:=tb_segment; -{$ifndef RTLLITE} - if LFNSupport then - regs.realeax:=$7147 - else -{$endif RTLLITE} - regs.realeax:=$4700; - sysrealintr($21,regs); - if (regs.realflags and carryflag) <> 0 then - Begin - InOutRes:=lo(regs.realeax); - exit; - end - else - syscopyfromdos(longint(@temp),251); -{ conversion to Pascal string including slash conversion } - i:=0; - while (temp[i]<>#0) do - begin - if temp[i]='/' then - temp[i]:='\'; - dir[i+4]:=temp[i]; - inc(i); - end; - dir[2]:=':'; - dir[3]:='\'; - dir[0]:=char(i+3); -{ upcase the string } - if not FileNameCaseSensitive then - dir:=upcase(dir); - if drivenr<>0 then { Drive was supplied. We know it } - dir[1]:=char(65+drivenr-1) - else - begin - { We need to get the current drive from DOS function 19H } - { because the drive was the default, which can be unknown } - regs.realeax:=$1900; - sysrealintr($21,regs); - i:= (regs.realeax and $ff) + ord('A'); - dir[1]:=chr(i); - end; -end; - - -{***************************************************************************** - SystemUnit Initialization -*****************************************************************************} - -{$ifndef RTLLITE} -function CheckLFN:boolean; -var - regs : TRealRegs; - RootName : pchar; -begin -{ Check LFN API on drive c:\ } - RootName:='C:\'; - syscopytodos(longint(RootName),strlen(RootName)+1); -{ Call 'Get Volume Information' ($71A0) } - regs.realeax:=$71a0; - regs.reales:=tb_segment; - regs.realedi:=tb_offset; - regs.realecx:=32; - regs.realds:=tb_segment; - regs.realedx:=tb_offset; - regs.realflags:=carryflag; - sysrealintr($21,regs); -{ If carryflag=0 and LFN API bit in ebx is set then use Long file names } - CheckLFN:=(regs.realflags and carryflag=0) and (regs.realebx and $4000=$4000); -end; -{$endif RTLLITE} - -{$ifdef MT} -{$I thread.inc} -{$endif MT} - -var - temp_int : tseginfo; -Begin -{ save old int 0 and 75 } - get_pm_interrupt($00,old_int00); - get_pm_interrupt($75,old_int75); - temp_int.segment:=get_cs; - temp_int.offset:=@new_int00; - set_pm_interrupt($00,temp_int); -{ temp_int.offset:=@new_int75; - set_pm_interrupt($75,temp_int); } -{ to test stack depth } - loweststack:=maxlongint; -{ Setup heap } - InitHeap; -{$ifdef MT} - { before this, you can't use thread vars !!!! } - { threadvarblocksize is calculate before the initialization } - { of the system unit } - sysgetmem(mainprogramthreadblock,threadvarblocksize); -{$endif MT} - InitExceptions; -{ Setup stdin, stdout and stderr } - OpenStdIO(Input,fmInput,StdInputHandle); - OpenStdIO(Output,fmOutput,StdOutputHandle); - OpenStdIO(StdOut,fmOutput,StdOutputHandle); - OpenStdIO(StdErr,fmOutput,StdErrorHandle); -{ Setup environment and arguments } - Setup_Environment; - Setup_Arguments; -{ Use LFNSupport LFN } - LFNSupport:=CheckLFN; - if LFNSupport then - FileNameCaseSensitive:=true; -{ Reset IO Error } - InOutRes:=0; -End. -{ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1993,97 by the Free Pascal development team. + + 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 system; + +interface + +{ two debug conditionnals can be used + - SYSTEMDEBUG + -for STACK checks + -for non closed files at exit (or at any time with GDB) + - SYSTEM_DEBUG_STARTUP + specifically for + - proxy command line (DJGPP feature) + - list of args + - list of env variables (PM) } + +{ include system-independent routine headers } + +{$I systemh.inc} + +{ include heap support headers } + +{$I heaph.inc} + +const +{ Default filehandles } + UnusedHandle = -1; + StdInputHandle = 0; + StdOutputHandle = 1; + StdErrorHandle = 2; + + FileNameCaseSensitive : boolean = false; + +{ Default memory segments (Tp7 compatibility) } + seg0040 = $0040; + segA000 = $A000; + segB000 = $B000; + segB800 = $B800; + +var +{ Mem[] support } + mem : array[0..$7fffffff] of byte absolute $0:$0; + memw : array[0..$7fffffff] of word absolute $0:$0; + meml : array[0..$7fffffff] of longint absolute $0:$0; +{ C-compatible arguments and environment } + argc : longint; + argv : ppchar; + envp : ppchar; + dos_argv0 : pchar; + +{$ifndef RTLLITE} +{ System info } + LFNSupport : boolean; +{$endif RTLLITE} + +type +{ Dos Extender info } + p_stub_info = ^t_stub_info; + t_stub_info = packed record + magic : array[0..15] of char; + size : longint; + minstack : longint; + memory_handle : longint; + initial_size : longint; + minkeep : word; + ds_selector : word; + ds_segment : word; + psp_selector : word; + cs_selector : word; + env_size : word; + basename : array[0..7] of char; + argv0 : array [0..15] of char; + dpmi_server : array [0..15] of char; + end; + + p_go32_info_block = ^t_go32_info_block; + t_go32_info_block = packed record + size_of_this_structure_in_bytes : longint; {offset 0} + linear_address_of_primary_screen : longint; {offset 4} + linear_address_of_secondary_screen : longint; {offset 8} + linear_address_of_transfer_buffer : longint; {offset 12} + size_of_transfer_buffer : longint; {offset 16} + pid : longint; {offset 20} + master_interrupt_controller_base : byte; {offset 24} + slave_interrupt_controller_base : byte; {offset 25} + selector_for_linear_memory : word; {offset 26} + linear_address_of_stub_info_structure : longint; {offset 28} + linear_address_of_original_psp : longint; {offset 32} + run_mode : word; {offset 36} + run_mode_info : word; {offset 38} + end; + +var + stub_info : p_stub_info; + go32_info_block : t_go32_info_block; + + +{ + necessary for objects.pas, should be removed (at least from the interface + to the implementation) +} + type + trealregs=record + realedi,realesi,realebp,realres, + realebx,realedx,realecx,realeax : longint; + realflags, + reales,realds,realfs,realgs, + realip,realcs,realsp,realss : word; + end; + function do_write(h,addr,len : longint) : longint; + function do_read(h,addr,len : longint) : longint; + procedure syscopyfromdos(addr : longint; len : longint); + procedure syscopytodos(addr : longint; len : longint); + procedure sysrealintr(intnr : word;var regs : trealregs); + function tb : longint; + +implementation + +{ include system independent routines } + +{$I system.inc} + +const + carryflag = 1; + +type + tseginfo=packed record + offset : pointer; + segment : word; + end; + +var + doscmd : string[128]; { Dos commandline copied from PSP, max is 128 chars } + old_int00 : tseginfo;cvar; + old_int75 : tseginfo;cvar; + +{$asmmode ATT} + +{***************************************************************************** + Go32 Helpers +*****************************************************************************} + +function far_strlen(selector : word;linear_address : longint) : longint; +begin +asm + movl linear_address,%edx + movl %edx,%ecx + movw selector,%gs +.Larg19: + movb %gs:(%edx),%al + testb %al,%al + je .Larg20 + incl %edx + jmp .Larg19 +.Larg20: + movl %edx,%eax + subl %ecx,%eax + movl %eax,__RESULT +end; +end; + + +function tb : longint; +begin + tb:=go32_info_block.linear_address_of_transfer_buffer; +end; + + +function tb_segment : longint; +begin + tb_segment:=go32_info_block.linear_address_of_transfer_buffer shr 4; +end; + + +function tb_offset : longint; +begin + tb_offset:=go32_info_block.linear_address_of_transfer_buffer and $f; +end; + + +function tb_size : longint; +begin + tb_size:=go32_info_block.size_of_transfer_buffer; +end; + + +function dos_selector : word; +begin + dos_selector:=go32_info_block.selector_for_linear_memory; +end; + + +function get_ds : word;assembler; +asm + movw %ds,%ax +end; + + +function get_cs : word;assembler; +asm + movw %cs,%ax +end; + + +procedure sysseg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint); +begin + if count=0 then + exit; + if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then + asm + pushw %es + pushw %ds + cld + movl count,%ecx + movl source,%esi + movl dest,%edi + movw dseg,%ax + movw %ax,%es + movw sseg,%ax + movw %ax,%ds + movl %ecx,%eax + shrl $2,%ecx + rep + movsl + movl %eax,%ecx + andl $3,%ecx + rep + movsb + popw %ds + popw %es + end ['ESI','EDI','ECX','EAX'] + else if (source#0) do + begin + v:=byte(s^)-byte('0'); + if (v > 9) then + dec(v,7); + v:=v and 15; { in case it's lower case } + rv:=(rv shl 4) or v; + inc(longint(s)); + end; + atohex:=rv; +end; + +var + _args : ppchar;external name '_args'; + +procedure setup_arguments; +type arrayword = array [0..0] of word; +var psp : word; + i,j : byte; + quote : char; + proxy_s : string[7]; + al,proxy_argc,proxy_seg,proxy_ofs,lin : longint; + largs : array[0..127] of pchar; + rm_argv : ^arrayword; +begin +for i := 1 to 127 do + largs[i] := nil; +psp:=stub_info^.psp_selector; +largs[0]:=dos_argv0; +argc := 1; +sysseg_move(psp, 128, get_ds, longint(@doscmd), 128); +{$IfDef SYSTEM_DEBUG_STARTUP} +Writeln(stderr,'Dos command line is #',doscmd,'# size = ',length(doscmd)); +{$EndIf } + +// setup cmdline variable +sysgetmem(cmdline,length(doscmd)+1); +move(doscmd[1],cmdline^,length(doscmd)); +cmdline[length(doscmd)]:=#0; + +j := 1; +quote := #0; +for i:=1 to length(doscmd) do + Begin + if doscmd[i] = quote then + begin + quote := #0; + if (i>1) and ((doscmd[i-1]='''') or (doscmd[i-1]='"')) then + begin + j := i+1; + doscmd[i] := #0; + continue; + end; + doscmd[i] := #0; + largs[argc]:=@doscmd[j]; + inc(argc); + j := i+1; + end else + if (quote = #0) and ((doscmd[i] = '''') or (doscmd[i]='"')) then + begin + quote := doscmd[i]; + j := i + 1; + end else + if (quote = #0) and ((doscmd[i] = ' ') + or (doscmd[i] = #9) or (doscmd[i] = #10) or + (doscmd[i] = #12) or (doscmd[i] = #9)) then + begin + doscmd[i]:=#0; + if j 1) and (far_strlen(get_ds,longint(largs[1])) = 6) then + begin + move(largs[1]^,proxy_s[1],6); + proxy_s[0] := #6; + if (proxy_s = '!proxy') then + begin +{$IfDef SYSTEM_DEBUG_STARTUP} + Writeln(stderr,'proxy command line '); +{$EndIf SYSTEM_DEBUG_STARTUP} + proxy_argc := atohex(largs[2]); + proxy_seg := atohex(largs[3]); + proxy_ofs := atohex(largs[4]); + sysgetmem(rm_argv,proxy_argc*sizeof(word)); + sysseg_move(dos_selector,proxy_seg*16+proxy_ofs, get_ds,longint(rm_argv),proxy_argc*sizeof(word)); + for i:=0 to proxy_argc - 1 do + begin + lin := proxy_seg*16 + rm_argv^[i]; + al :=far_strlen(dos_selector, lin); + sysgetmem(largs[i],al+1); + sysseg_move(dos_selector, lin, get_ds,longint(largs[i]), al+1); +{$IfDef SYSTEM_DEBUG_STARTUP} + Writeln(stderr,'arg ',i,' #',largs[i],'#'); +{$EndIf SYSTEM_DEBUG_STARTUP} + end; + argc := proxy_argc; + end; + end; +sysgetmem(argv,argc shl 2); +for i := 0 to argc-1 do + argv[i] := largs[i]; + _args:=argv; +end; + + +function strcopy(dest,source : pchar) : pchar; +begin + asm + cld + movl 12(%ebp),%edi + movl $0xffffffff,%ecx + xorb %al,%al + repne + scasb + not %ecx + movl 8(%ebp),%edi + movl 12(%ebp),%esi + movl %ecx,%eax + shrl $2,%ecx + rep + movsl + movl %eax,%ecx + andl $3,%ecx + rep + movsb + movl 8(%ebp),%eax + leave + ret $8 + end; +end; + + +var + __stubinfo : p_stub_info;external name '__stubinfo'; + ___dos_argv0 : pchar;external name '___dos_argv0'; + +procedure setup_environment; +var env_selector : word; + env_count : longint; + dos_env,cp : pchar; +begin + stub_info:=__stubinfo; + sysgetmem(dos_env,stub_info^.env_size); + env_count:=0; + sysseg_move(stub_info^.psp_selector,$2c, get_ds, longint(@env_selector), 2); + sysseg_move(env_selector, 0, get_ds, longint(dos_env), stub_info^.env_size); + cp:=dos_env; + while cp ^ <> #0 do + begin + inc(env_count); + while (cp^ <> #0) do inc(longint(cp)); { skip to NUL } + inc(longint(cp)); { skip to next character } + end; + sysgetmem(envp,(env_count+1) * sizeof(pchar)); + if (envp = nil) then exit; + cp:=dos_env; + env_count:=0; + while cp^ <> #0 do + begin + sysgetmem(envp[env_count],strlen(cp)+1); + strcopy(envp[env_count], cp); +{$IfDef SYSTEM_DEBUG_STARTUP} + Writeln(stderr,'env ',env_count,' = "',envp[env_count],'"'); +{$EndIf SYSTEM_DEBUG_STARTUP} + inc(env_count); + while (cp^ <> #0) do + inc(longint(cp)); { skip to NUL } + inc(longint(cp)); { skip to next character } + end; + envp[env_count]:=nil; + longint(cp):=longint(cp)+3; + sysgetmem(dos_argv0,strlen(cp)+1); + if (dos_argv0 = nil) then halt; + strcopy(dos_argv0, cp); + { update ___dos_argv0 also } + ___dos_argv0:=dos_argv0 +end; + + +procedure syscopytodos(addr : longint; len : longint); +begin + if len > tb_size then + HandleError(217); + sysseg_move(get_ds,addr,dos_selector,tb,len); +end; + + +procedure syscopyfromdos(addr : longint; len : longint); +begin + if len > tb_size then + HandleError(217); + sysseg_move(dos_selector,tb,get_ds,addr,len); +end; + + +procedure sysrealintr(intnr : word;var regs : trealregs); +begin + regs.realsp:=0; + regs.realss:=0; + asm + movw intnr,%bx + xorl %ecx,%ecx + movl regs,%edi + movw $0x300,%ax + int $0x31 + end; +end; + + +procedure set_pm_interrupt(vector : byte;const intaddr : tseginfo); +begin + asm + movl intaddr,%eax + movl (%eax),%edx + movw 4(%eax),%cx + movl $0x205,%eax + movb vector,%bl + int $0x31 + end; +end; + + +procedure get_pm_interrupt(vector : byte;var intaddr : tseginfo); +begin + asm + movb vector,%bl + movl $0x204,%eax + int $0x31 + movl intaddr,%eax + movl %edx,(%eax) + movw %cx,4(%eax) + end; +end; + + +procedure getinoutres; +var + regs : trealregs; +begin + regs.realeax:=$5900; + regs.realebx:=$0; + sysrealintr($21,regs); + InOutRes:=lo(regs.realeax); + case InOutRes of + 19 : InOutRes:=150; + 21 : InOutRes:=152; + end; +end; + + + { Keep Track of open files } + const + max_files = 50; + var + openfiles : array [0..max_files-1] of boolean; +{$ifdef SYSTEMDEBUG} + opennames : array [0..max_files-1] of pchar; + const + free_closed_names : boolean = true; +{$endif SYSTEMDEBUG} + +{***************************************************************************** + System Dependent Exit code +*****************************************************************************} + +procedure ___exit(exitcode:byte);cdecl;external name '___exit'; + +procedure do_close(handle : longint);forward; + +Procedure system_exit; +var + h : byte; +begin + for h:=0 to max_files-1 do + if openfiles[h] then + begin +{$ifdef SYSTEMDEBUG} + writeln(stderr,'file ',opennames[h],' not closed at exit'); +{$endif SYSTEMDEBUG} + if h>=5 then + do_close(h); + end; + { halt is not allways called !! } + { not on normal exit !! PM } + set_pm_interrupt($00,old_int00); + set_pm_interrupt($75,old_int75); + ___exit(exitcode); +end; + + +procedure halt(errnum : byte); +begin + exitcode:=errnum; + do_exit; + { do_exit should call system_exit but this does not hurt } + System_exit; +end; + +procedure new_int00; +begin + HandleError(200); +end; + +procedure new_int75; +begin + asm + xorl %eax,%eax + outb %al,$0x0f0 + movb $0x20,%al + outb %al,$0x0a0 + outb %al,$0x020 + end; + HandleError(200); +end; + + +var + __stkbottom : longint;external name '__stkbottom'; + +procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK']; +{ + called when trying to get local stack if the compiler directive $S + is set this function must preserve esi !!!! because esi is set by + the calling proc for methods it must preserve all registers !! + + With a 2048 byte safe area used to write to StdIo without crossing + the stack boundary +} +begin + asm + pushl %eax + pushl %ebx + movl stack_size,%ebx + addl $2048,%ebx + movl %esp,%eax + subl %ebx,%eax +{$ifdef SYSTEMDEBUG} + movl loweststack,%ebx + cmpl %eax,%ebx + jb .L_is_not_lowest + movl %eax,loweststack +.L_is_not_lowest: +{$endif SYSTEMDEBUG} + movl __stkbottom,%ebx + cmpl %eax,%ebx + jae .L__short_on_stack + popl %ebx + popl %eax + leave + ret $4 +.L__short_on_stack: + { can be usefull for error recovery !! } + popl %ebx + popl %eax + end['EAX','EBX']; + HandleError(202); +end; + + +{***************************************************************************** + ParamStr/Randomize +*****************************************************************************} + +function paramcount : longint; +begin + paramcount := argc - 1; +end; + + +function paramstr(l : longint) : string; +begin + if (l>=0) and (l+1<=argc) then + paramstr:=strpas(argv[l]) + else + paramstr:=''; +end; + + +procedure randomize; +var + hl : longint; + regs : trealregs; +begin + regs.realeax:=$2c00; + sysrealintr($21,regs); + hl:=regs.realedx and $ffff; + randseed:=hl*$10000+ (regs.realecx and $ffff); +end; + +{***************************************************************************** + Heap Management +*****************************************************************************} + +var + int_heap : longint;external name 'HEAP'; + int_heapsize : longint;external name 'HEAPSIZE'; + +function getheapstart:pointer; +begin + getheapstart:=@int_heap; +end; + + +function getheapsize:longint; +begin + getheapsize:=int_heapsize; +end; + + +function ___sbrk(size:longint):longint;cdecl;external name '___sbrk'; + +function Sbrk(size : longint):longint;assembler; +asm + movl size,%eax + pushl %eax + call ___sbrk + addl $4,%esp +end; + + +{ include standard heap management } +{$I heap.inc} + + +{**************************************************************************** + Low level File Routines + ****************************************************************************} + +procedure AllowSlash(p:pchar); +var + i : longint; +begin +{ allow slash as backslash } + for i:=0 to strlen(p) do + if p[i]='/' then p[i]:='\'; +end; + +procedure do_close(handle : longint); +var + regs : trealregs; +begin + regs.realebx:=handle; +{$ifdef SYSTEMDEBUG} + if handle 0 then + GetInOutRes; +end; + + +procedure do_erase(p : pchar); +var + regs : trealregs; +begin + AllowSlash(p); + syscopytodos(longint(p),strlen(p)+1); + regs.realedx:=tb_offset; + regs.realds:=tb_segment; +{$ifndef RTLLITE} + if LFNSupport then + regs.realeax:=$7141 + else +{$endif RTLLITE} + regs.realeax:=$4100; + regs.realesi:=0; + regs.realecx:=0; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + GetInOutRes; +end; + + +procedure do_rename(p1,p2 : pchar); +var + regs : trealregs; +begin + AllowSlash(p1); + AllowSlash(p2); + if strlen(p1)+strlen(p2)+3>tb_size then + HandleError(217); + sysseg_move(get_ds,longint(p2),dos_selector,tb,strlen(p2)+1); + sysseg_move(get_ds,longint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1); + regs.realedi:=tb_offset; + regs.realedx:=tb_offset + strlen(p2)+2; + regs.realds:=tb_segment; + regs.reales:=tb_segment; +{$ifndef RTLLITE} + if LFNSupport then + regs.realeax:=$7156 + else +{$endif RTLLITE} + regs.realeax:=$5600; + regs.realecx:=$ff; { attribute problem here ! } + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + GetInOutRes; +end; + + +function do_write(h,addr,len : longint) : longint; +var + regs : trealregs; + size, + writesize : longint; +begin + writesize:=0; + while len > 0 do + begin + if len>tb_size then + size:=tb_size + else + size:=len; + syscopytodos(addr+writesize,size); + regs.realecx:=size; + regs.realedx:=tb_offset; + regs.realds:=tb_segment; + regs.realebx:=h; + regs.realeax:=$4000; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + begin + GetInOutRes; + exit(writesize); + end; + inc(writesize,regs.realeax); + dec(len,regs.realeax); + { stop when not the specified size is written } + if regs.realeax 0 do + begin + if len>tb_size then + size:=tb_size + else + size:=len; + regs.realecx:=size; + regs.realedx:=tb_offset; + regs.realds:=tb_segment; + regs.realebx:=h; + regs.realeax:=$3f00; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + begin + GetInOutRes; + do_read:=0; + exit; + end; + syscopyfromdos(addr+readsize,regs.realeax); + inc(readsize,regs.realeax); + dec(len,regs.realeax); + { stop when not the specified size is read } + if regs.realeax 0 then + Begin + GetInOutRes; + do_filepos:=0; + end + else + do_filepos:=lo(regs.realedx) shl 16+lo(regs.realeax); +end; + + +procedure do_seek(handle,pos : longint); +var + regs : trealregs; +begin + regs.realebx:=handle; + regs.realecx:=pos shr 16; + regs.realedx:=pos and $ffff; + regs.realeax:=$4200; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + GetInOutRes; +end; + + + +function do_seekend(handle:longint):longint; +var + regs : trealregs; +begin + regs.realebx:=handle; + regs.realecx:=0; + regs.realedx:=0; + regs.realeax:=$4202; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + Begin + GetInOutRes; + do_seekend:=0; + end + else + do_seekend:=lo(regs.realedx) shl 16+lo(regs.realeax); +end; + + +function do_filesize(handle : longint) : longint; +var + aktfilepos : longint; +begin + aktfilepos:=do_filepos(handle); + do_filesize:=do_seekend(handle); + do_seek(handle,aktfilepos); +end; + + +{ truncate at a given position } +procedure do_truncate (handle,pos:longint); +var + regs : trealregs; +begin + do_seek(handle,pos); + regs.realecx:=0; + regs.realedx:=tb_offset; + regs.realds:=tb_segment; + regs.realebx:=handle; + regs.realeax:=$4000; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + GetInOutRes; +end; + + +procedure do_open(var f;p:pchar;flags:longint); +{ + filerec and textrec have both handle and mode as the first items so + they could use the same routine for opening/creating. + when (flags and $100) the file will be append + when (flags and $1000) the file will be truncate/rewritten + when (flags and $10000) there is no check for close (needed for textfiles) +} +var + regs : trealregs; + action : longint; +begin + AllowSlash(p); +{ close first if opened } + if ((flags and $10000)=0) then + begin + case filerec(f).mode of + fminput,fmoutput,fminout : Do_Close(filerec(f).handle); + fmclosed : ; + else + begin + inoutres:=102; {not assigned} + exit; + end; + end; + end; +{ reset file handle } + filerec(f).handle:=UnusedHandle; + action:=$1; +{ convert filemode to filerec modes } + case (flags and 3) of + 0 : filerec(f).mode:=fminput; + 1 : filerec(f).mode:=fmoutput; + 2 : filerec(f).mode:=fminout; + end; + if (flags and $1000)<>0 then + begin + filerec(f).mode:=fmoutput; + action:=$12; {create file function} + end; +{ empty name is special } + if p[0]=#0 then + begin + case filerec(f).mode of + fminput : filerec(f).handle:=StdInputHandle; + fmappend, + fmoutput : begin + filerec(f).handle:=StdOutputHandle; + filerec(f).mode:=fmoutput; {fool fmappend} + end; + end; + exit; + end; +{ real dos call } + syscopytodos(longint(p),strlen(p)+1); +{$ifndef RTLLITE} + if LFNSupport then + regs.realeax:=$716c + else +{$endif RTLLITE} + regs.realeax:=$6c00; + regs.realedx:=action; + regs.realds:=tb_segment; + regs.realesi:=tb_offset; + regs.realebx:=$2000+(flags and $ff); + regs.realecx:=$20; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + begin + GetInOutRes; + exit; + end + else + filerec(f).handle:=regs.realeax; +{$ifdef SYSTEMDEBUG} + if regs.realeax0 then + begin + do_seekend(filerec(f).handle); + filerec(f).mode:=fmoutput; {fool fmappend} + end; +end; + + +function do_isdevice(handle:longint):boolean; +var + regs : trealregs; +begin + regs.realebx:=handle; + regs.realeax:=$4400; + sysrealintr($21,regs); + do_isdevice:=(regs.realedx and $80)<>0; + if (regs.realflags and carryflag) <> 0 then + GetInOutRes; +end; + + +{***************************************************************************** + UnTyped File Handling +*****************************************************************************} + +{$i file.inc} + +{***************************************************************************** + Typed File Handling +*****************************************************************************} + +{$i typefile.inc} + +{***************************************************************************** + Text File Handling +*****************************************************************************} + +{$DEFINE EOF_CTRLZ} + +{$i text.inc} + + +{***************************************************************************** + Generic Handling +*****************************************************************************} + +{$ifdef TEST_GENERIC} +{$i generic.inc} +{$endif TEST_GENERIC} + +{***************************************************************************** + Directory Handling +*****************************************************************************} + +procedure DosDir(func:byte;const s:string); +var + buffer : array[0..255] of char; + regs : trealregs; +begin + move(s[1],buffer,length(s)); + buffer[length(s)]:=#0; + AllowSlash(pchar(@buffer)); + syscopytodos(longint(@buffer),length(s)+1); + regs.realedx:=tb_offset; + regs.realds:=tb_segment; +{$ifndef RTLLITE} + if LFNSupport then + regs.realeax:=$7100+func + else +{$endif RTLLITE} + regs.realeax:=func shl 8; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + GetInOutRes; +end; + + +procedure mkdir(const s : string);[IOCheck]; +begin + If InOutRes <> 0 then + exit; + DosDir($39,s); +end; + + +procedure rmdir(const s : string);[IOCheck]; +begin + If InOutRes <> 0 then + exit; + DosDir($3a,s); +end; + + +procedure chdir(const s : string);[IOCheck]; +var + regs : trealregs; +begin + If InOutRes <> 0 then + exit; +{ First handle Drive changes } + if (length(s)>=2) and (s[2]=':') then + begin + regs.realedx:=(ord(s[1]) and (not 32))-ord('A'); + regs.realeax:=$0e00; + sysrealintr($21,regs); + regs.realeax:=$1900; + sysrealintr($21,regs); + if byte(regs.realeax)<>byte(regs.realedx) then + begin + Inoutres:=15; + exit; + end; + end; +{ do the normal dos chdir } + DosDir($3b,s); +end; + + +procedure getdir(drivenr : byte;var dir : shortstring); +var + temp : array[0..255] of char; + i : longint; + regs : trealregs; +begin + regs.realedx:=drivenr; + regs.realesi:=tb_offset; + regs.realds:=tb_segment; +{$ifndef RTLLITE} + if LFNSupport then + regs.realeax:=$7147 + else +{$endif RTLLITE} + regs.realeax:=$4700; + sysrealintr($21,regs); + if (regs.realflags and carryflag) <> 0 then + Begin + GetInOutRes; + exit; + end + else + syscopyfromdos(longint(@temp),251); +{ conversion to Pascal string including slash conversion } + i:=0; + while (temp[i]<>#0) do + begin + if temp[i]='/' then + temp[i]:='\'; + dir[i+4]:=temp[i]; + inc(i); + end; + dir[2]:=':'; + dir[3]:='\'; + dir[0]:=char(i+3); +{ upcase the string } + if not FileNameCaseSensitive then + dir:=upcase(dir); + if drivenr<>0 then { Drive was supplied. We know it } + dir[1]:=char(65+drivenr-1) + else + begin + { We need to get the current drive from DOS function 19H } + { because the drive was the default, which can be unknown } + regs.realeax:=$1900; + sysrealintr($21,regs); + i:= (regs.realeax and $ff) + ord('A'); + dir[1]:=chr(i); + end; +end; + + +{***************************************************************************** + SystemUnit Initialization +*****************************************************************************} + +{$ifndef RTLLITE} +function CheckLFN:boolean; +var + regs : TRealRegs; + RootName : pchar; +begin +{ Check LFN API on drive c:\ } + RootName:='C:\'; + syscopytodos(longint(RootName),strlen(RootName)+1); +{ Call 'Get Volume Information' ($71A0) } + regs.realeax:=$71a0; + regs.reales:=tb_segment; + regs.realedi:=tb_offset; + regs.realecx:=32; + regs.realds:=tb_segment; + regs.realedx:=tb_offset; + regs.realflags:=carryflag; + sysrealintr($21,regs); +{ If carryflag=0 and LFN API bit in ebx is set then use Long file names } + CheckLFN:=(regs.realflags and carryflag=0) and (regs.realebx and $4000=$4000); +end; +{$endif RTLLITE} + +{$ifdef MT} +{$I thread.inc} +{$endif MT} + +var + temp_int : tseginfo; +Begin +{ save old int 0 and 75 } + get_pm_interrupt($00,old_int00); + get_pm_interrupt($75,old_int75); + temp_int.segment:=get_cs; + temp_int.offset:=@new_int00; + set_pm_interrupt($00,temp_int); +{ temp_int.offset:=@new_int75; + set_pm_interrupt($75,temp_int); } +{ to test stack depth } + loweststack:=maxlongint; +{ Setup heap } + InitHeap; +{$ifdef MT} + { before this, you can't use thread vars !!!! } + { threadvarblocksize is calculate before the initialization } + { of the system unit } + sysgetmem(mainprogramthreadblock,threadvarblocksize); +{$endif MT} + InitExceptions; +{ Setup stdin, stdout and stderr } + OpenStdIO(Input,fmInput,StdInputHandle); + OpenStdIO(Output,fmOutput,StdOutputHandle); + OpenStdIO(StdOut,fmOutput,StdOutputHandle); + OpenStdIO(StdErr,fmOutput,StdErrorHandle); +{ Setup environment and arguments } + Setup_Environment; + Setup_Arguments; +{ Use LFNSupport LFN } + LFNSupport:=CheckLFN; + if LFNSupport then + FileNameCaseSensitive:=true; +{ Reset IO Error } + InOutRes:=0; +End. +{ $Log$ - Revision 1.17 1999-09-10 15:40:33 peter - * fixed do_open flags to be > $100, becuase filemode can be upto 255 - - Revision 1.16 1999/09/08 16:09:18 peter - * do_isdevice not called if already error - - Revision 1.15 1999/08/19 14:03:16 pierre - * use sysgetmem for startup and debug allocations - - Revision 1.14 1999/07/19 07:57:49 michael - + Small fix from Michael Baikov in setup_params - - Revision 1.13 1999/05/19 16:54:21 pierre - * closes all handles >+ 5 - - Revision 1.12 1999/05/17 21:52:33 florian - * most of the Object Pascal stuff moved to the system unit - - Revision 1.11 1999/05/04 23:28:40 pierre - SYSTEM_DEBUG_STARTUP used to output args and env at start - - Revision 1.10 1999/04/28 11:42:45 peter - + FileNameCaseSensetive boolean - - Revision 1.9 1999/04/28 06:01:25 florian - * define MT for multithreading introduced - - Revision 1.8 1999/04/08 12:23:02 peter - * removed os.inc - - Revision 1.7 1999/03/10 22:15:28 florian - + system.cmdline variable for go32v2 and win32 added - - Revision 1.6 1999/03/01 15:40:52 peter - * use external names - * removed all direct assembler modes - - Revision 1.5 1999/01/18 10:05:50 pierre - + system_exit procedure added - - Revision 1.4 1998/12/30 22:17:59 peter - * fixed mem decls to use $0:$0 - - Revision 1.3 1998/12/28 15:50:45 peter - + stdout, which is needed when you write something in the system unit - to the screen. Like the runtime error - - Revision 1.2 1998/12/21 14:22:02 pierre - * old_int?? transformed to cvar to be readable by dpmiexcp - - Revision 1.1 1998/12/21 13:07:03 peter - * use -FE - - Revision 1.25 1998/12/15 22:42:52 peter - * removed temp symbols - - Revision 1.24 1998/11/29 22:28:10 peter - + io-error 103 added - - Revision 1.23 1998/11/16 14:15:02 pierre - * changed getdir(byte,string) to getdir(byte,shortstring) - - Revision 1.22 1998/10/26 14:49:46 pierre - * system debug info output to stderr - - Revision 1.21 1998/10/20 07:34:07 pierre - + systemdebug reports about unclosed files at exit - - Revision 1.20 1998/10/13 21:41:06 peter - + int 0 for divide by zero - - Revision 1.19 1998/09/14 10:48:05 peter - * FPC_ names - * Heap manager is now system independent - - Revision 1.18 1998/08/28 10:48:04 peter - * fixed chdir with drive changing - * updated checklfn from mailinglist - - Revision 1.17 1998/08/27 10:30:51 pierre - * go32v1 RTL did not compile (LFNsupport outside go32v2 defines !) - I renamed tb_selector to tb_segment because - it is a real mode segment as opposed to - a protected mode selector - Fixed it for go32v1 (remove the $E0000000 offset !) - - Revision 1.16 1998/08/26 10:04:03 peter - * new lfn check from mailinglist - * renamed win95 -> LFNSupport - + tb_selector, tb_offset for easier access to transferbuffer - - Revision 1.15 1998/08/19 10:56:34 pierre - + added some special code for C interface - to avoid loading of crt1.o or dpmiexcp.o from the libc.a - - Revision 1.14 1998/08/04 14:34:38 pierre - * small bug fix to get it compiled with bugfix version !! - (again the asmmode problem !!! - Peter it was really not the best idea you had !!) - - Revision 1.13 1998/07/30 13:26:22 michael - + Added support for ErrorProc variable. All internal functions are required - to call HandleError instead of runerror from now on. - This is necessary for exception support. - - Revision 1.12 1998/07/13 21:19:08 florian - * some problems with ansi string support fixed - - Revision 1.11 1998/07/07 12:33:08 carl - * added 2k buffer for stack checking for correct io on error - - Revision 1.10 1998/07/02 12:29:20 carl - * IOCheck for rmdir,chdir and mkdir as in TP - NOTE: I'm pretty SURE this will not compile and link correctly with FPC - 0.99.5 - - Revision 1.9 1998/07/01 15:29:57 peter - * better readln/writeln - - Revision 1.8 1998/06/26 08:19:10 pierre - + all debug in ifdef SYSTEMDEBUG - + added local arrays : - opennames names of opened files - fileopen boolean array to know if still open - usefull with gdb if you get problems about too - many open files !! - - Revision 1.7 1998/06/15 15:17:08 daniel - * RTLLITE conditional added to produce smaller RTL. - - Revision 1.6 1998/05/31 14:18:29 peter - * force att or direct assembling - * cleanup of some files - - Revision 1.5 1998/05/21 19:30:52 peter - * objects compiles for linux - + assign(pchar), assign(char), rename(pchar), rename(char) - * fixed read_text_as_array - + read_text_as_pchar which was not yet in the rtl - - Revision 1.4 1998/05/04 17:58:41 peter - * fix for smartlinking with _ARGS - - Revision 1.3 1998/05/04 16:21:54 florian - + LFNSupport flag to the interface moved -} + Revision 1.18 1999-09-10 17:14:09 peter + * better errorcode returning using int21h,5900 + + Revision 1.17 1999/09/10 15:40:33 peter + * fixed do_open flags to be > $100, becuase filemode can be upto 255 + + Revision 1.16 1999/09/08 16:09:18 peter + * do_isdevice not called if already error + + Revision 1.15 1999/08/19 14:03:16 pierre + * use sysgetmem for startup and debug allocations + + Revision 1.14 1999/07/19 07:57:49 michael + + Small fix from Michael Baikov in setup_params + + Revision 1.13 1999/05/19 16:54:21 pierre + * closes all handles >+ 5 + + Revision 1.12 1999/05/17 21:52:33 florian + * most of the Object Pascal stuff moved to the system unit + + Revision 1.11 1999/05/04 23:28:40 pierre + SYSTEM_DEBUG_STARTUP used to output args and env at start + + Revision 1.10 1999/04/28 11:42:45 peter + + FileNameCaseSensetive boolean + + Revision 1.9 1999/04/28 06:01:25 florian + * define MT for multithreading introduced + + Revision 1.8 1999/04/08 12:23:02 peter + * removed os.inc + + Revision 1.7 1999/03/10 22:15:28 florian + + system.cmdline variable for go32v2 and win32 added + + Revision 1.6 1999/03/01 15:40:52 peter + * use external names + * removed all direct assembler modes + + Revision 1.5 1999/01/18 10:05:50 pierre + + system_exit procedure added + + Revision 1.4 1998/12/30 22:17:59 peter + * fixed mem decls to use $0:$0 + + Revision 1.3 1998/12/28 15:50:45 peter + + stdout, which is needed when you write something in the system unit + to the screen. Like the runtime error + + Revision 1.2 1998/12/21 14:22:02 pierre + * old_int?? transformed to cvar to be readable by dpmiexcp + + Revision 1.1 1998/12/21 13:07:03 peter + * use -FE + + Revision 1.25 1998/12/15 22:42:52 peter + * removed temp symbols + + Revision 1.24 1998/11/29 22:28:10 peter + + io-error 103 added + + Revision 1.23 1998/11/16 14:15:02 pierre + * changed getdir(byte,string) to getdir(byte,shortstring) + + Revision 1.22 1998/10/26 14:49:46 pierre + * system debug info output to stderr + + Revision 1.21 1998/10/20 07:34:07 pierre + + systemdebug reports about unclosed files at exit + + Revision 1.20 1998/10/13 21:41:06 peter + + int 0 for divide by zero + + Revision 1.19 1998/09/14 10:48:05 peter + * FPC_ names + * Heap manager is now system independent + + Revision 1.18 1998/08/28 10:48:04 peter + * fixed chdir with drive changing + * updated checklfn from mailinglist + + Revision 1.17 1998/08/27 10:30:51 pierre + * go32v1 RTL did not compile (LFNsupport outside go32v2 defines !) + I renamed tb_selector to tb_segment because + it is a real mode segment as opposed to + a protected mode selector + Fixed it for go32v1 (remove the $E0000000 offset !) + + Revision 1.16 1998/08/26 10:04:03 peter + * new lfn check from mailinglist + * renamed win95 -> LFNSupport + + tb_selector, tb_offset for easier access to transferbuffer + + Revision 1.15 1998/08/19 10:56:34 pierre + + added some special code for C interface + to avoid loading of crt1.o or dpmiexcp.o from the libc.a + + Revision 1.14 1998/08/04 14:34:38 pierre + * small bug fix to get it compiled with bugfix version !! + (again the asmmode problem !!! + Peter it was really not the best idea you had !!) + + Revision 1.13 1998/07/30 13:26:22 michael + + Added support for ErrorProc variable. All internal functions are required + to call HandleError instead of runerror from now on. + This is necessary for exception support. + + Revision 1.12 1998/07/13 21:19:08 florian + * some problems with ansi string support fixed + + Revision 1.11 1998/07/07 12:33:08 carl + * added 2k buffer for stack checking for correct io on error + + Revision 1.10 1998/07/02 12:29:20 carl + * IOCheck for rmdir,chdir and mkdir as in TP + NOTE: I'm pretty SURE this will not compile and link correctly with FPC + 0.99.5 + + Revision 1.9 1998/07/01 15:29:57 peter + * better readln/writeln + + Revision 1.8 1998/06/26 08:19:10 pierre + + all debug in ifdef SYSTEMDEBUG + + added local arrays : + opennames names of opened files + fileopen boolean array to know if still open + usefull with gdb if you get problems about too + many open files !! + + Revision 1.7 1998/06/15 15:17:08 daniel + * RTLLITE conditional added to produce smaller RTL. + + Revision 1.6 1998/05/31 14:18:29 peter + * force att or direct assembling + * cleanup of some files + + Revision 1.5 1998/05/21 19:30:52 peter + * objects compiles for linux + + assign(pchar), assign(char), rename(pchar), rename(char) + * fixed read_text_as_array + + read_text_as_pchar which was not yet in the rtl + + Revision 1.4 1998/05/04 17:58:41 peter + * fix for smartlinking with _ARGS + + Revision 1.3 1998/05/04 16:21:54 florian + + LFNSupport flag to the interface moved +}