mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-02 10:49:33 +01:00
* better readln/writeln
This commit is contained in:
peter
parent
4d36bc1cc3
commit
5a638754f4
@ -442,6 +442,25 @@ begin
|
||||
do_seekend(filerec(f).handle);
|
||||
end;
|
||||
|
||||
|
||||
function do_isdevice(handle : longint):boolean;assembler;
|
||||
asm
|
||||
movl $0x4400,%eax
|
||||
movl handle,%ebx
|
||||
pushl %ebp
|
||||
int $0x21
|
||||
popl %ebp
|
||||
jnc .LDOSSEEK1
|
||||
movw %ax,inoutres
|
||||
xorl %edx,%edx
|
||||
.LDOSSEEK1:
|
||||
movl %edx,%eax
|
||||
shrl $7,%eax
|
||||
andl $1,%eax
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
UnTyped File Handling
|
||||
*****************************************************************************}
|
||||
@ -555,20 +574,7 @@ end;
|
||||
SystemUnit Initialization
|
||||
*****************************************************************************}
|
||||
|
||||
procedure OpenStdIO(var f:text;mode:word;hdl:longint);
|
||||
begin
|
||||
Assign(f,'');
|
||||
TextRec(f).Handle:=hdl;
|
||||
TextRec(f).Mode:=mode;
|
||||
TextRec(f).InOutFunc:=@FileInOutFunc;
|
||||
TextRec(f).FlushFunc:=@FileInOutFunc;
|
||||
TextRec(f).Closefunc:=@fileclosefunc;
|
||||
end;
|
||||
|
||||
|
||||
Begin
|
||||
{ Initialize ExitProc }
|
||||
ExitProc:=Nil;
|
||||
{ to test stack depth }
|
||||
loweststack:=maxlongint;
|
||||
{ Setup heap }
|
||||
@ -582,7 +588,10 @@ Begin
|
||||
End.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.4 1998-05-31 14:18:19 peter
|
||||
Revision 1.5 1998-07-01 15:29:56 peter
|
||||
* better readln/writeln
|
||||
|
||||
Revision 1.4 1998/05/31 14:18:19 peter
|
||||
* force att or direct assembling
|
||||
* cleanup of some files
|
||||
|
||||
|
||||
@ -168,7 +168,7 @@ _is_not_lowest:
|
||||
{$endif SYSTEMDEBUG}
|
||||
movl __stkbottom,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jae __short_on_stack
|
||||
jae __short_on_stack
|
||||
popl %ebx
|
||||
popl %eax
|
||||
leave
|
||||
@ -244,7 +244,7 @@ end;
|
||||
movw dseg,%ax
|
||||
movw %ax,%es
|
||||
movw sseg,%ax
|
||||
movw %ax,%ds
|
||||
movw %ax,%ds
|
||||
movl %ecx,%eax
|
||||
shrl $2,%ecx
|
||||
rep
|
||||
@ -282,7 +282,7 @@ end;
|
||||
rep
|
||||
movsb
|
||||
incl %esi
|
||||
incl %edi
|
||||
incl %edi
|
||||
.LSEG_MOVE1:
|
||||
subl $4,%esi
|
||||
subl $4,%edi
|
||||
@ -316,11 +316,11 @@ end;
|
||||
procedure setup_arguments;
|
||||
type arrayword = array [0..0] of word;
|
||||
var psp : word;
|
||||
i,j : byte;
|
||||
quote : char;
|
||||
proxy_s : string[7];
|
||||
tempargv : ppchar;
|
||||
al,proxy_argc,proxy_seg,proxy_ofs,lin : longint;
|
||||
i,j : byte;
|
||||
quote : char;
|
||||
proxy_s : string[7];
|
||||
tempargv : ppchar;
|
||||
al,proxy_argc,proxy_seg,proxy_ofs,lin : longint;
|
||||
largs : array[0..127] of pchar;
|
||||
rm_argv : ^arrayword;
|
||||
begin
|
||||
@ -342,7 +342,7 @@ for i:=1 to length(doscmd) do
|
||||
quote := #0;
|
||||
doscmd[i] := #0;
|
||||
largs[argc]:=@doscmd[j];
|
||||
inc(argc);
|
||||
inc(argc);
|
||||
j := i+1;
|
||||
end else
|
||||
if (quote = #0) and ((doscmd[i] = '''') or (doscmd[i]='"')) then
|
||||
@ -380,7 +380,7 @@ if (argc > 1) and (far_strlen(get_ds,longint(largs[1])) = 6) then
|
||||
Writeln('proxy command line ');
|
||||
{$EndIf SYSTEMDEBUG}
|
||||
proxy_argc := atohex(largs[2]);
|
||||
proxy_seg := atohex(largs[3]);
|
||||
proxy_seg := atohex(largs[3]);
|
||||
proxy_ofs := atohex(largs[4]);
|
||||
getmem(rm_argv,proxy_argc*sizeof(word));
|
||||
sysseg_move(dos_selector,proxy_seg*16+proxy_ofs, get_ds,longint(rm_argv),proxy_argc*sizeof(word));
|
||||
@ -418,7 +418,7 @@ function strcopy(dest,source : pchar) : pchar;
|
||||
movl 12(%ebp),%edi
|
||||
movl $0xffffffff,%ecx
|
||||
xorb %al,%al
|
||||
repne
|
||||
repne
|
||||
scasb
|
||||
not %ecx
|
||||
movl 8(%ebp),%edi
|
||||
@ -494,7 +494,7 @@ end;
|
||||
begin
|
||||
if len > tb_size then runerror(217);
|
||||
sysseg_move(dos_selector,tb,get_ds,addr,len);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure sysrealintr(intnr : word;var regs : trealregs);
|
||||
|
||||
@ -653,24 +653,24 @@ 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 and 15;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realebx:=h;
|
||||
regs.realeax:=$4000;
|
||||
sysrealintr($21,regs);
|
||||
if (regs.realflags and carryflag) <> 0 then
|
||||
begin
|
||||
InOutRes:=lo(regs.realeax);
|
||||
exit(writesize);
|
||||
end;
|
||||
len:=len-size;
|
||||
writesize:=writesize+size;
|
||||
if len>tb_size then
|
||||
size:=tb_size
|
||||
else
|
||||
size:=len;
|
||||
syscopytodos(addr+writesize,size);
|
||||
regs.realecx:=size;
|
||||
regs.realedx:=tb and 15;
|
||||
regs.realds:=tb shr 4;
|
||||
regs.realebx:=h;
|
||||
regs.realeax:=$4000;
|
||||
sysrealintr($21,regs);
|
||||
if (regs.realflags and carryflag) <> 0 then
|
||||
begin
|
||||
InOutRes:=lo(regs.realeax);
|
||||
exit(writesize);
|
||||
end;
|
||||
len:=len-size;
|
||||
writesize:=writesize+size;
|
||||
end;
|
||||
Do_Write:=WriteSize
|
||||
end;
|
||||
@ -702,7 +702,7 @@ begin
|
||||
exit;
|
||||
end
|
||||
else
|
||||
if regs.realeax<size then
|
||||
if regs.realeax<size then
|
||||
begin
|
||||
syscopyfromdos(addr+readsize,regs.realeax);
|
||||
do_read:=readsize+regs.realeax;
|
||||
@ -816,7 +816,7 @@ begin
|
||||
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
|
||||
fmclosed : ;
|
||||
else
|
||||
begin
|
||||
begin
|
||||
inoutres:=102; {not assigned}
|
||||
exit;
|
||||
end;
|
||||
@ -865,8 +865,8 @@ begin
|
||||
sysrealintr($21,regs);
|
||||
if (regs.realflags and carryflag) <> 0 then
|
||||
begin
|
||||
InOutRes:=lo(regs.realeax);
|
||||
exit;
|
||||
InOutRes:=lo(regs.realeax);
|
||||
exit;
|
||||
end
|
||||
else
|
||||
filerec(f).handle:=regs.realeax;
|
||||
@ -881,19 +881,33 @@ begin
|
||||
{ append mode }
|
||||
if (flags and $10)<>0 then
|
||||
begin
|
||||
do_seekend(filerec(f).handle);
|
||||
filerec(f).mode:=fmoutput; {fool fmappend}
|
||||
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
|
||||
UnTyped File Handling
|
||||
*****************************************************************************}
|
||||
|
||||
{$i file.inc}
|
||||
|
||||
{*****************************************************************************
|
||||
Typed File Handling
|
||||
Typed File Handling
|
||||
*****************************************************************************}
|
||||
|
||||
{$i typefile.inc}
|
||||
@ -969,8 +983,8 @@ begin
|
||||
sysrealintr($21,regs);
|
||||
if (regs.realflags and carryflag) <> 0 then
|
||||
Begin
|
||||
InOutRes:=lo(regs.realeax);
|
||||
exit;
|
||||
InOutRes:=lo(regs.realeax);
|
||||
exit;
|
||||
end
|
||||
else
|
||||
syscopyfromdos(longint(@temp),251);
|
||||
@ -978,10 +992,10 @@ begin
|
||||
i:=0;
|
||||
while (temp[i]<>#0) do
|
||||
begin
|
||||
if temp[i]='/' then
|
||||
temp[i]:='\';
|
||||
dir[i+4]:=temp[i];
|
||||
inc(i);
|
||||
if temp[i]='/' then
|
||||
temp[i]:='\';
|
||||
dir[i+4]:=temp[i];
|
||||
inc(i);
|
||||
end;
|
||||
dir[2]:=':';
|
||||
dir[3]:='\';
|
||||
@ -994,16 +1008,16 @@ begin
|
||||
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);
|
||||
regs.realeax:=$1900;
|
||||
sysrealintr($21,regs);
|
||||
i:= (regs.realeax and $ff) + ord('A');
|
||||
dir[1]:=chr(i);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
SystemUnit Initialization
|
||||
SystemUnit Initialization
|
||||
*****************************************************************************}
|
||||
|
||||
{$ifndef RTLLITE}
|
||||
@ -1018,20 +1032,7 @@ end;
|
||||
{$endif RTLLITE}
|
||||
|
||||
|
||||
procedure OpenStdIO(var f:text;mode:word;hdl:longint);
|
||||
begin
|
||||
Assign(f,'');
|
||||
TextRec(f).Handle:=hdl;
|
||||
TextRec(f).Mode:=mode;
|
||||
TextRec(f).InOutFunc:=@FileInOutFunc;
|
||||
TextRec(f).FlushFunc:=@FileInOutFunc;
|
||||
TextRec(f).Closefunc:=@fileclosefunc;
|
||||
end;
|
||||
|
||||
|
||||
Begin
|
||||
{ Initialize ExitProc }
|
||||
ExitProc:=Nil;
|
||||
{ to test stack depth }
|
||||
loweststack:=maxlongint;
|
||||
{ Setup heap }
|
||||
@ -1050,7 +1051,10 @@ Begin
|
||||
End.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.8 1998-06-26 08:19:10 pierre
|
||||
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
|
||||
@ -1059,7 +1063,6 @@ End.
|
||||
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
|
||||
|
||||
@ -687,6 +687,7 @@ end ['EAX'];
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFNDEF NEW_READWRITE}
|
||||
procedure f1;[public,alias: 'FLUSH_STDOUT'];
|
||||
|
||||
begin
|
||||
@ -698,6 +699,7 @@ end ['EAX'];
|
||||
popal
|
||||
end;
|
||||
end;
|
||||
{$ENDIF NEW_READWRITE}
|
||||
|
||||
|
||||
Function Sptr : Longint;
|
||||
@ -728,7 +730,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.13 1998-06-26 08:20:57 daniel
|
||||
Revision 1.14 1998-07-01 15:29:58 peter
|
||||
* better readln/writeln
|
||||
|
||||
Revision 1.13 1998/06/26 08:20:57 daniel
|
||||
- Doerror removed.
|
||||
|
||||
Revision 1.12 1998/05/31 14:15:47 peter
|
||||
|
||||
@ -120,11 +120,11 @@ Procedure incr_ansi_ref (P : pointer);[Alias : 'INCR_ANSI_REF'];
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Run-Time Type Information (RTTI)
|
||||
Run-Time Type Information (RTTI)
|
||||
****************************************************************************}
|
||||
|
||||
{$i rtti.inc}
|
||||
|
||||
{$i rtti.inc}
|
||||
|
||||
{****************************************************************************
|
||||
Math Routines
|
||||
@ -332,14 +332,7 @@ Begin
|
||||
Halt(0);
|
||||
End;
|
||||
|
||||
{ Seems not to be used (PFV)
|
||||
Procedure Initexception;[Public,Alias: 'INITEXCEPTION'];
|
||||
Begin
|
||||
Writeln('Exception occurred during program initialization.');
|
||||
halt(216);
|
||||
End;
|
||||
}
|
||||
{$ifndef RTLLITE}
|
||||
|
||||
Procedure dump_stack(bp : Longint);
|
||||
|
||||
Procedure dump_frame(addr : Longint);
|
||||
@ -365,7 +358,6 @@ Begin
|
||||
End;
|
||||
End;
|
||||
|
||||
{$endif RTLLITE}
|
||||
|
||||
Procedure Do_exit;[Public,Alias: '__EXIT'];
|
||||
{
|
||||
@ -381,23 +373,17 @@ Begin
|
||||
exitProc:=nil;
|
||||
current_exit();
|
||||
End;
|
||||
If erroraddr<>nil Then
|
||||
If DoError Then
|
||||
Begin
|
||||
{$ifndef RTLLITE}
|
||||
Writeln('Run time error ',Errorcode,' at 0x',hexstr(Longint(Erroraddr),8));
|
||||
dump_stack(ErrorBase);
|
||||
{$else RTLLITE}
|
||||
writeln('Runerror ',errorcode,' at ',longint(erroraddr));
|
||||
{$endif RTLLITE}
|
||||
End;
|
||||
{$IFNDEF NEW_READWRITE}
|
||||
Flush(stderr);
|
||||
|
||||
{$ENDIF NEW_READWRITE}
|
||||
End;
|
||||
|
||||
|
||||
{$ifndef RTLLITE}
|
||||
|
||||
|
||||
Type
|
||||
PExitProcInfo = ^TExitProcInfo;
|
||||
TExitProcInfo = Record
|
||||
@ -434,11 +420,12 @@ Begin
|
||||
ExitProc:=@DoExitProc;
|
||||
End;
|
||||
|
||||
{$endif RTLLITE}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.13 1998-06-26 08:21:09 daniel
|
||||
Revision 1.14 1998-07-01 15:29:59 peter
|
||||
* better readln/writeln
|
||||
|
||||
Revision 1.13 1998/06/26 08:21:09 daniel
|
||||
- Doerror removed.
|
||||
|
||||
Revision 1.12 1998/06/25 14:04:25 peter
|
||||
@ -448,7 +435,6 @@ End;
|
||||
+ RTLLITE directive to compile minimal RTL.
|
||||
|
||||
Revision 1.10 1998/06/15 15:16:26 daniel
|
||||
|
||||
* RTLLITE conditional added to produce smaller RTL
|
||||
|
||||
Revision 1.9 1998/06/10 07:46:45 michael
|
||||
|
||||
375
rtl/inc/text.inc
375
rtl/inc/text.inc
@ -1,4 +1,5 @@
|
||||
{ $Id$
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal Run time library.
|
||||
Copyright (c) 1993,97 by the Free Pascal development team
|
||||
|
||||
@ -35,42 +36,54 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure FileInOutFunc(var t:TextRec);
|
||||
Procedure FileReadFunc(var t:TextRec);
|
||||
Begin
|
||||
Case t.mode Of
|
||||
fmoutput : Do_Write(t.Handle,Longint(t.Bufptr),t.BufPos);
|
||||
fminput : t.BufEnd:=Do_Read(t.Handle,Longint(t.Bufptr),t.BufSize);
|
||||
else
|
||||
RunError(102);
|
||||
End;
|
||||
t.BufEnd:=Do_Read(t.Handle,Longint(t.Bufptr),t.BufSize);
|
||||
t.BufPos:=0;
|
||||
End;
|
||||
|
||||
|
||||
Procedure FileWriteFunc(var t:TextRec);
|
||||
Begin
|
||||
Do_Write(t.Handle,Longint(t.Bufptr),t.BufPos);
|
||||
t.BufPos:=0;
|
||||
End;
|
||||
|
||||
|
||||
|
||||
Procedure FileOpenFunc(var t:TextRec);
|
||||
var
|
||||
Flags : Longint;
|
||||
Begin
|
||||
t.InOutFunc:=@FileInOutFunc;
|
||||
t.FlushFunc:=@FileInOutFunc;
|
||||
t.CloseFunc:=@FileCloseFunc;
|
||||
Case t.mode Of
|
||||
fmInput : Flags:=$1000;
|
||||
fmOutput : Flags:=$1101;
|
||||
fmAppend : Flags:=$1011;
|
||||
else
|
||||
RunError(102);
|
||||
End;
|
||||
Do_Open(t,PChar(@TextRec(t).Name),Flags);
|
||||
Do_Open(t,PChar(@t.Name),Flags);
|
||||
t.CloseFunc:=@FileCloseFunc;
|
||||
t.FlushFunc:=nil;
|
||||
if t.Mode=fmInput then
|
||||
t.InOutFunc:=@FileReadFunc
|
||||
else
|
||||
begin
|
||||
t.InOutFunc:=@FileWriteFunc;
|
||||
{ Only install flushing if its a NOT a file }
|
||||
if Do_Isdevice(t.Handle) then
|
||||
t.FlushFunc:=@FileWriteFunc;
|
||||
end;
|
||||
End;
|
||||
|
||||
|
||||
Procedure assign(var t:Text;const s:String);
|
||||
Begin
|
||||
FillChar(t,SizEof(TextRec),0);
|
||||
{ only set things that are not zero }
|
||||
TextRec(t).Handle:=UnusedHandle;
|
||||
TextRec(t).mode:=fmClosed;
|
||||
TextRec(t).BufSize:=128;
|
||||
TextRec(t).Bufpos:=0;
|
||||
TextRec(T).Bufend:=0;
|
||||
TextRec(t).Bufptr:=@TextRec(t).Buffer;
|
||||
TextRec(t).OpenFunc:=@FileOpenFunc;
|
||||
Move(s[1],TextRec(t).Name,Length(s));
|
||||
@ -93,9 +106,10 @@ Procedure Close(var t : Text);[Public,Alias: 'CLOSE_TEXT',IOCheck];
|
||||
Begin
|
||||
If (TextRec(t).mode<>fmClosed) Then
|
||||
Begin
|
||||
FileFunc(TextRec(t).FlushFunc)(TextRec(t));
|
||||
{ Write pending buffer }
|
||||
FileFunc(TextRec(t).InOutFunc)(TextRec(t));
|
||||
TextRec(t).mode:=fmClosed;
|
||||
{ Only close functions not connected to stdout.}
|
||||
{ Only close functions not connected to stdout.}
|
||||
If ((TextRec(t).Handle<>StdInputHandle) or
|
||||
(TextRec(t).Handle<>StdOutputHandle) or
|
||||
(TextRec(t).Handle<>StdErrorHandle)) Then
|
||||
@ -116,15 +130,7 @@ Begin
|
||||
End;
|
||||
End;
|
||||
TextRec(t).mode:=word(mode);
|
||||
{ If TextRec(t).Name[0]<>#0 Then }
|
||||
FileFunc(TextRec(t).OpenFunc)(TextRec(t))
|
||||
{ else
|
||||
Begin
|
||||
TextRec(t).Handle:=defHdl;
|
||||
TextRec(t).InOutFunc:=@FileInOutFunc;
|
||||
TextRec(t).FlushFunc:=@FileInOutFunc;
|
||||
TextRec(t).CloseFunc:=@FileCloseFunc;
|
||||
End; }
|
||||
FileFunc(TextRec(t).OpenFunc)(TextRec(t))
|
||||
End;
|
||||
|
||||
|
||||
@ -150,7 +156,9 @@ Procedure Flush(var t : Text);[IOCheck];
|
||||
Begin
|
||||
If TextRec(t).mode<>fmOutput Then
|
||||
exit;
|
||||
FileFunc(TextRec(t).FlushFunc)(TextRec(t));
|
||||
{ Not the flushfunc but the inoutfunc should be used, becuase that
|
||||
writes the data, flushfunc doesn't need to be assigned }
|
||||
FileFunc(TextRec(t).InOutFunc)(TextRec(t));
|
||||
End;
|
||||
|
||||
|
||||
@ -342,101 +350,120 @@ End;
|
||||
Write(Ln)
|
||||
*****************************************************************************}
|
||||
|
||||
Procedure w(Len : Longint;var f : TextRec;var s : String);[Public,Alias: 'WRITE_TEXT_STRING'];
|
||||
Procedure WriteBuffer(var f:TextRec;var b;len:longint);
|
||||
var
|
||||
hbytes,Pos,copybytes : Longint;
|
||||
hs : String;
|
||||
p : pchar;
|
||||
left,
|
||||
idx : longint;
|
||||
begin
|
||||
p:=pchar(@b);
|
||||
idx:=0;
|
||||
left:=f.BufSize-f.BufPos;
|
||||
while len>left do
|
||||
begin
|
||||
move(p[idx],f.Bufptr^[f.BufPos],left);
|
||||
dec(len,left);
|
||||
inc(idx,left);
|
||||
inc(f.BufPos,left);
|
||||
FileFunc(f.InOutFunc)(f);
|
||||
left:=f.BufSize-f.BufPos;
|
||||
end;
|
||||
move(p[idx],f.Bufptr^[f.BufPos],len);
|
||||
inc(f.BufPos,len);
|
||||
end;
|
||||
|
||||
|
||||
Procedure WriteBlanks(var f:TextRec;len:longint);
|
||||
var
|
||||
left : longint;
|
||||
begin
|
||||
left:=f.BufSize-f.BufPos;
|
||||
while len>left do
|
||||
begin
|
||||
FillChar(f.Bufptr^[f.BufPos],left,' ');
|
||||
dec(len,left);
|
||||
inc(f.BufPos,left);
|
||||
FileFunc(f.InOutFunc)(f);
|
||||
left:=f.BufSize-f.BufPos;
|
||||
end;
|
||||
FillChar(f.Bufptr^[f.BufPos],len,' ');
|
||||
inc(f.BufPos,len);
|
||||
end;
|
||||
|
||||
|
||||
Procedure Write_End(var f:TextRec);[Public,Alias:'WRITE_END'];
|
||||
begin
|
||||
if f.FlushFunc<>nil then
|
||||
FileFunc(f.FlushFunc)(f);
|
||||
end;
|
||||
|
||||
|
||||
Procedure Writeln_End(var f:TextRec);[Public,Alias:'WRITELN_END'];
|
||||
const
|
||||
{$IFDEF SHORT_LINEBREAK}
|
||||
eollen=1;
|
||||
eol : array[0..0] of char=(#10);
|
||||
{$ELSE SHORT_LINEBREAK}
|
||||
eollen=2;
|
||||
eol : array[0..1] of char=(#13,#10);
|
||||
{$ENDIF SHORT_LINEBREAK}
|
||||
begin
|
||||
{ Write EOL }
|
||||
WriteBuffer(f,eol,eollen);
|
||||
{ Flush }
|
||||
if f.FlushFunc<>nil then
|
||||
FileFunc(f.FlushFunc)(f);
|
||||
end;
|
||||
|
||||
|
||||
Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias: 'WRITE_TEXT_STRING'];
|
||||
Begin
|
||||
If f.mode<>fmOutput Then
|
||||
exit;
|
||||
copybytes:=Length(s);
|
||||
If Len>copybytes Then
|
||||
Begin
|
||||
hs:=Space(Len-copybytes);
|
||||
w(0,f,hs);
|
||||
End;
|
||||
Pos:=1;
|
||||
hbytes:=f.BufSize-f.BufPos;
|
||||
{ If no room in Buffer, do a flush. }
|
||||
If hbytes=0 Then
|
||||
FileFunc(f.FlushFunc)(f);
|
||||
while copybytes>hbytes Do
|
||||
Begin
|
||||
Move(s[Pos],f.Bufptr^[f.BufPos],hbytes);
|
||||
f.BufPos:=f.BufPos+hbytes;
|
||||
copybytes:=copybytes-hbytes;
|
||||
pos:=pos+hbytes;
|
||||
FileFunc(f.InOutFunc)(f);
|
||||
hbytes:=f.BufSize-f.BufPos;
|
||||
End;
|
||||
Move(s[Pos],f.Bufptr^[f.BufPos],copybytes);
|
||||
f.BufPos:=f.BufPos+copybytes;
|
||||
End;
|
||||
|
||||
|
||||
Procedure w(var t : TextRec);[Public,Alias: 'WRITELN_TEXT'];
|
||||
var
|
||||
hs : String;
|
||||
Begin
|
||||
{$IFDEF SHORT_LINEBREAK}
|
||||
hs:=#10;
|
||||
{$ELSE}
|
||||
hs:=#13#10;
|
||||
{$ENDIF}
|
||||
w(0,t,hs);
|
||||
If Len>Length(s) Then
|
||||
WriteBlanks(f,Len-Length(s));
|
||||
WriteBuffer(f,s[1],Length(s));
|
||||
End;
|
||||
|
||||
|
||||
Type
|
||||
array00 = array[0..0] Of Char;
|
||||
Procedure w(Len : Longint;var f : TextRec;const p : array00);[Public,Alias: 'WRITE_TEXT_PCHAR_AS_ARRAY'];
|
||||
Procedure Write_Array(Len : Longint;var f : TextRec;const p : array00);[Public,Alias: 'WRITE_TEXT_PCHAR_AS_ARRAY'];
|
||||
var
|
||||
hbytes,Pos,copybytes : Longint;
|
||||
hs : String;
|
||||
ArrayLen : longint;
|
||||
Begin
|
||||
If f.mode<>fmOutput Then
|
||||
exit;
|
||||
copybytes:=StrLen(p);
|
||||
If Len>copybytes Then
|
||||
Begin
|
||||
hs:=Space(Len-copybytes);
|
||||
w(0,f,hs);
|
||||
End;
|
||||
Pos:=0;
|
||||
hbytes:=f.BufSize-f.BufPos;
|
||||
{ If no room in buffer , do a flush. }
|
||||
If hbytes=0 Then
|
||||
FileFunc(f.FlushFunc)(f);
|
||||
while copybytes>hbytes Do
|
||||
Begin
|
||||
Move(p[Pos],f.Bufptr^[f.BufPos],hbytes);
|
||||
f.BufPos:=f.BufPos+hbytes;
|
||||
copybytes:=copybytes-hbytes;
|
||||
pos:=pos+hbytes;
|
||||
FileFunc(f.InOutFunc)(f);
|
||||
hbytes:=f.BufSize-f.BufPos;
|
||||
End;
|
||||
Move(p[Pos],f.Bufptr^[f.BufPos],copybytes);
|
||||
f.BufPos:=f.BufPos+copybytes;
|
||||
ArrayLen:=StrLen(p);
|
||||
If Len>ArrayLen Then
|
||||
WriteBlanks(f,Len-ArrayLen);
|
||||
WriteBuffer(f,p,ArrayLen);
|
||||
End;
|
||||
|
||||
|
||||
Procedure wa(Len : Longint;var f : TextRec;p : PChar);[Public,Alias: 'WRITE_TEXT_PCHAR_AS_POINTER'];
|
||||
Procedure Write_PChar(Len : Longint;var f : TextRec;p : PChar);[Public,Alias: 'WRITE_TEXT_PCHAR_AS_POINTER'];
|
||||
var
|
||||
PCharLen : longint;
|
||||
Begin
|
||||
w(Len,f,p);
|
||||
If f.mode<>fmOutput Then
|
||||
exit;
|
||||
PCharLen:=StrLen(p);
|
||||
If Len>PCharLen Then
|
||||
WriteBlanks(f,Len-PCharLen);
|
||||
WriteBuffer(f,p^,PCharLen);
|
||||
End;
|
||||
|
||||
|
||||
Procedure w(Len : Longint;var t : TextRec;l : Longint);[Public,Alias: 'WRITE_TEXT_LONGINT'];
|
||||
Procedure Write_LongInt(Len : Longint;var t : TextRec;l : Longint);[Public,Alias: 'WRITE_TEXT_LONGINT'];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
Str(l,s);
|
||||
w(Len,t,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
|
||||
|
||||
Procedure w(fixkomma,Len : Longint;var t : TextRec;r : real);[Public,Alias: 'WRITE_TEXT_REAL'];
|
||||
Procedure Write_Real(fixkomma,Len : Longint;var t : TextRec;r : real);[Public,Alias: 'WRITE_TEXT_REAL'];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
@ -445,88 +472,97 @@ Begin
|
||||
{$else}
|
||||
Str_real(Len,fixkomma,r,rt_s32real,s);
|
||||
{$endif}
|
||||
w(Len,t,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
|
||||
|
||||
Procedure w(Len : Longint;var t : TextRec;l : cardinal);[Public,Alias: 'WRITE_TEXT_CARDINAL'];
|
||||
Procedure Write_Cardinal(Len : Longint;var t : TextRec;l : cardinal);[Public,Alias: 'WRITE_TEXT_CARDINAL'];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
Str(L,s);
|
||||
w(Len,t,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
|
||||
|
||||
Procedure w(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias: 'WRITE_TEXT_SINGLE'];
|
||||
Procedure Write_Single(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias: 'WRITE_TEXT_SINGLE'];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
Str_real(Len,fixkomma,r,rt_s32real,s);
|
||||
w(Len,t,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
|
||||
|
||||
{$ifdef SUPPORT_EXTENDED}
|
||||
Procedure w(fixkomma,Len : Longint;var t : TextRec;r : extended);[Public,Alias: 'WRITE_TEXT_EXTENDED'];
|
||||
Procedure Write_Extended(fixkomma,Len : Longint;var t : TextRec;r : extended);[Public,Alias: 'WRITE_TEXT_EXTENDED'];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
Str_real(Len,fixkomma,r,rt_s80real,s);
|
||||
w(Len,t,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
{$endif SUPPORT_EXTENDED}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_COMP}
|
||||
Procedure w(fixkomma,Len : Longint;var t : TextRec;r : comp);[Public,Alias: 'WRITE_TEXT_COMP'];
|
||||
Procedure Write_Comp(fixkomma,Len : Longint;var t : TextRec;r : comp);[Public,Alias: 'WRITE_TEXT_COMP'];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
Str_real(Len,fixkomma,r,rt_s64bit,s);
|
||||
w(Len,t,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
{$endif SUPPORT_COMP}
|
||||
|
||||
Procedure w(fixkomma,Len : Longint;var t : TextRec;r : fixed);[Public,Alias: 'WRITE_TEXT_FIXED'];
|
||||
|
||||
Procedure Write_Fixed(fixkomma,Len : Longint;var t : TextRec;r : fixed);[Public,Alias: 'WRITE_TEXT_FIXED'];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
Str_real(Len,fixkomma,r,rt_f32bit,s);
|
||||
w(Len,t,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
|
||||
|
||||
{ Is called wc to avoid recursive calling. }
|
||||
Procedure wc(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias: 'WRITE_TEXT_BOOLEAN'];
|
||||
const
|
||||
BoolString:array[0..1] Of String[5]=('FALSE','TRUE');
|
||||
Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias: 'WRITE_TEXT_BOOLEAN'];
|
||||
Begin
|
||||
if b then
|
||||
w(Len,t,String(BoolString[1]))
|
||||
else
|
||||
w(Len,t,String(BoolString[0]));
|
||||
{ Can't use array[boolean] because b can be >0 ! }
|
||||
if b then
|
||||
Write_Str(Len,t,'TRUE')
|
||||
else
|
||||
Write_Str(Len,t,'FALSE');
|
||||
End;
|
||||
|
||||
|
||||
Procedure wc(Len : Longint;var t : TextRec;c : Char);[Public,Alias: 'WRITE_TEXT_CHAR'];
|
||||
var
|
||||
hs : String;
|
||||
Procedure Write_Char(Len : Longint;var t : TextRec;c : Char);[Public,Alias: 'WRITE_TEXT_CHAR'];
|
||||
Begin
|
||||
If t.mode<>fmOutput Then
|
||||
exit;
|
||||
If Len>1 Then
|
||||
Begin
|
||||
hs:=Space(Len-1);
|
||||
w(0,t,hs);
|
||||
End;
|
||||
WriteBlanks(t,Len-1);
|
||||
If t.BufPos+1>=t.BufSize Then
|
||||
FileFunc(t.FlushFunc)(t);
|
||||
FileFunc(t.InOutFunc)(t);
|
||||
t.Bufptr^[t.BufPos]:=c;
|
||||
Inc(t.BufPos);
|
||||
End;
|
||||
|
||||
|
||||
{$IFNDEF NEW_READWRITE}
|
||||
Procedure w(var t : TextRec);[Public,Alias: 'WRITELN_TEXT'];
|
||||
var
|
||||
hs : String;
|
||||
Begin
|
||||
{$IFDEF SHORT_LINEBREAK}
|
||||
hs:=#10;
|
||||
{$ELSE}
|
||||
hs:=#13#10;
|
||||
{$ENDIF}
|
||||
Write_Str(0,t,hs);
|
||||
End;
|
||||
{$ENDIF NEW_READWRITE}
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Read(Ln)
|
||||
*****************************************************************************}
|
||||
@ -624,10 +660,18 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec);[Public,Alias: 'READLN_TEXT'];
|
||||
Procedure Read_End(var f:TextRec);[Public,Alias:'READ_END'];
|
||||
begin
|
||||
if f.FlushFunc<>nil then
|
||||
FileFunc(f.FlushFunc)(f);
|
||||
end;
|
||||
|
||||
|
||||
Procedure ReadLn_End(var f : TextRec);[Public,Alias: 'READLN_END'];
|
||||
Begin
|
||||
if not OpenInput(f) then
|
||||
exit;
|
||||
{ Read until a linebreak }
|
||||
while (f.BufPos<f.BufEnd) do
|
||||
begin
|
||||
inc(f.BufPos);
|
||||
@ -636,10 +680,13 @@ Begin
|
||||
If f.BufPos>=f.BufEnd Then
|
||||
FileFunc(f.InOutFunc)(f);
|
||||
end;
|
||||
{ Flush if set }
|
||||
if f.FlushFunc<>nil then
|
||||
FileFunc(f.FlushFunc)(f);
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var s : String);[Public,Alias: 'READ_TEXT_STRING'];
|
||||
Procedure Read_String(var f : TextRec;var s : String);[Public,Alias: 'READ_TEXT_STRING'];
|
||||
var
|
||||
Temp,sPos : Word;
|
||||
Begin
|
||||
@ -659,6 +706,7 @@ Begin
|
||||
Begin
|
||||
Move (f.Bufptr^[f.BufPos],s[sPos],Temp-f.BufPos);
|
||||
sPos:=sPos+Temp-f.BufPos;
|
||||
{ Remove #13 from a #13#10 break }
|
||||
If s[sPos-1]=#13 Then
|
||||
dec(sPos);
|
||||
End
|
||||
@ -680,7 +728,7 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var c : Char);[Public,Alias: 'READ_TEXT_CHAR'];
|
||||
Procedure Read_Char(var f : TextRec;var c : Char);[Public,Alias: 'READ_TEXT_CHAR'];
|
||||
Begin
|
||||
c:=#0;
|
||||
if not OpenInput(f) then
|
||||
@ -693,7 +741,7 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var s : PChar);[Public,Alias:'READ_TEXT_PCHAR_AS_POINTER'];
|
||||
Procedure Read_PChar(var f : TextRec;var s : PChar);[Public,Alias:'READ_TEXT_PCHAR_AS_POINTER'];
|
||||
var
|
||||
p : PChar;
|
||||
Temp : byte;
|
||||
@ -711,7 +759,7 @@ Begin
|
||||
inc(Temp);
|
||||
{ copy string. }
|
||||
Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos);
|
||||
longint(p):=longint(p)+(temp-f.bufpos);
|
||||
Inc(Longint(p),Temp-f.BufPos);
|
||||
If pchar(p-1)^=#13 Then
|
||||
dec(p);
|
||||
{ update f.BufPos }
|
||||
@ -726,7 +774,7 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var s : array00);[Public,Alias:'READ_TEXT_PCHAR_AS_ARRAY'];
|
||||
Procedure Read_Array(var f : TextRec;var s : array00);[Public,Alias:'READ_TEXT_PCHAR_AS_ARRAY'];
|
||||
var
|
||||
p : PChar;
|
||||
Temp : byte;
|
||||
@ -744,7 +792,7 @@ Begin
|
||||
inc(Temp);
|
||||
{ copy string. }
|
||||
Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos);
|
||||
longint(p):=longint(p)+(temp-f.bufpos);
|
||||
Inc(Longint(p),Temp-f.BufPos);
|
||||
If pchar(p-1)^=#13 Then
|
||||
dec(p);
|
||||
{ update f.BufPos }
|
||||
@ -759,7 +807,7 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var l : Longint);[Public,Alias: 'READ_TEXT_LONGINT'];
|
||||
Procedure Read_Longint(var f : TextRec;var l : Longint);[Public,Alias: 'READ_TEXT_LONGINT'];
|
||||
var
|
||||
hs : String;
|
||||
code : Word;
|
||||
@ -777,11 +825,11 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var l : Integer);[Public,Alias: 'READ_TEXT_INTEGER'];
|
||||
Procedure Read_Integer(var f : TextRec;var l : Integer);[Public,Alias: 'READ_TEXT_INTEGER'];
|
||||
var
|
||||
ll : Longint;
|
||||
Begin
|
||||
r(f,ll);
|
||||
Read_Longint(f,ll);
|
||||
l:=0;
|
||||
If (ll<-32768) or (ll>32767) Then
|
||||
RunError(106);
|
||||
@ -789,11 +837,11 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var l : Word);[Public,Alias: 'READ_TEXT_WORD'];
|
||||
Procedure Read_Word(var f : TextRec;var l : Word);[Public,Alias: 'READ_TEXT_WORD'];
|
||||
var
|
||||
ll : Longint;
|
||||
Begin
|
||||
r(f,ll);
|
||||
Read_Longint(f,ll);
|
||||
l:=0;
|
||||
If (ll<0) or (ll>$ffff) Then
|
||||
RunError(106);
|
||||
@ -801,11 +849,11 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var l : byte);[Public,Alias: 'READ_TEXT_BYTE'];
|
||||
Procedure Read_Byte(var f : TextRec;var l : byte);[Public,Alias: 'READ_TEXT_BYTE'];
|
||||
var
|
||||
ll : Longint;
|
||||
Begin
|
||||
r(f,ll);
|
||||
Read_Longint(f,ll);
|
||||
l:=0;
|
||||
If (ll<0) or (ll>255) Then
|
||||
RunError(106);
|
||||
@ -813,11 +861,11 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var l : shortint);[Public,Alias: 'READ_TEXT_SHORTINT'];
|
||||
Procedure Read_Shortint(var f : TextRec;var l : shortint);[Public,Alias: 'READ_TEXT_SHORTINT'];
|
||||
var
|
||||
ll : Longint;
|
||||
Begin
|
||||
r(f,ll);
|
||||
Read_Longint(f,ll);
|
||||
l:=0;
|
||||
If (ll<-128) or (ll>127) Then
|
||||
RunError(106);
|
||||
@ -825,7 +873,7 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var l : cardinal);[Public,Alias: 'READ_TEXT_CARDINAL'];
|
||||
Procedure Read_Cardinal(var f : TextRec;var l : cardinal);[Public,Alias: 'READ_TEXT_CARDINAL'];
|
||||
var
|
||||
hs : String;
|
||||
code : Word;
|
||||
@ -843,7 +891,7 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure r(var f : TextRec;var d : Real);[Public,Alias: 'READ_TEXT_REAL'];
|
||||
Procedure Read_Real(var f : TextRec;var d : Real);[Public,Alias: 'READ_TEXT_REAL'];
|
||||
var
|
||||
hs : String;
|
||||
code : Word;
|
||||
@ -881,7 +929,7 @@ End;
|
||||
|
||||
|
||||
{$ifdef SUPPORT_EXTENDED}
|
||||
Procedure r(var f : TextRec;var d : extended);[Public,Alias: 'READ_TEXT_EXTENDED'];
|
||||
Procedure Read_Extended(var f : TextRec;var d : extended);[Public,Alias: 'READ_TEXT_EXTENDED'];
|
||||
var
|
||||
hs : String;
|
||||
code : Word;
|
||||
@ -920,7 +968,7 @@ End;
|
||||
|
||||
|
||||
{$ifdef SUPPORT_COMP}
|
||||
Procedure r(var f : TextRec;var d : comp);[Public,Alias: 'READ_TEXT_COMP'];
|
||||
Procedure Read_Comp(var f : TextRec;var d : comp);[Public,Alias: 'READ_TEXT_COMP'];
|
||||
var
|
||||
hs : String;
|
||||
code : Word;
|
||||
@ -957,9 +1005,52 @@ Begin
|
||||
End;
|
||||
{$endif SUPPORT_COMP}
|
||||
|
||||
|
||||
{$IFNDEF NEW_READWRITE}
|
||||
Procedure r(var f : TextRec);[Public,Alias: 'READLN_TEXT'];
|
||||
Begin
|
||||
if not OpenInput(f) then
|
||||
exit;
|
||||
while (f.BufPos<f.BufEnd) do
|
||||
begin
|
||||
inc(f.BufPos);
|
||||
if (f.BufPtr^[f.BufPos-1]=#10) then
|
||||
exit;
|
||||
If f.BufPos>=f.BufEnd Then
|
||||
FileFunc(f.InOutFunc)(f);
|
||||
end;
|
||||
End;
|
||||
{$ENDIF NEW_READWRITE}
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Initializing
|
||||
*****************************************************************************}
|
||||
|
||||
procedure OpenStdIO(var f:text;mode:word;hdl:longint);
|
||||
begin
|
||||
Assign(f,'');
|
||||
TextRec(f).Handle:=hdl;
|
||||
TextRec(f).Mode:=mode;
|
||||
TextRec(f).Closefunc:=@FileCloseFunc;
|
||||
case mode of
|
||||
fmInput : TextRec(f).InOutFunc:=@FileReadFunc;
|
||||
fmOutput : begin
|
||||
TextRec(f).InOutFunc:=@FileWriteFunc;
|
||||
TextRec(f).FlushFunc:=@FileWriteFunc;
|
||||
end;
|
||||
else
|
||||
RunError(102);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.12 1998-07-01 14:48:10 carl
|
||||
Revision 1.13 1998-07-01 15:30:00 peter
|
||||
* better readln/writeln
|
||||
|
||||
Revision 1.12 1998/07/01 14:48:10 carl
|
||||
* bugfix of WRITE_TEXT_BOOLEAN , was not TP compatible
|
||||
+ added explicit typecast in OpenText
|
||||
|
||||
|
||||
@ -461,11 +461,32 @@ Begin
|
||||
begin
|
||||
Oflags:=Oflags and not(Open_RDWR);
|
||||
FileRec(f).Handle:=sys_open(p,oflags,438);
|
||||
end;
|
||||
end;
|
||||
|
||||
Errno2Inoutres;
|
||||
{$endif}
|
||||
End;
|
||||
|
||||
|
||||
Function Do_IsDevice(Handle:Longint):boolean;
|
||||
{
|
||||
Interface to Unix ioctl call.
|
||||
Performs various operations on the filedescriptor Handle.
|
||||
Ndx describes the operation to perform.
|
||||
Data points to data needed for the Ndx function. The structure of this
|
||||
data is function-dependent.
|
||||
}
|
||||
var
|
||||
sr: SysCallRegs;
|
||||
Data : array[0..255] of byte; {Large enough for termios info}
|
||||
begin
|
||||
sr.reg2:=Handle;
|
||||
sr.reg3:=$5401; {=TCGETS}
|
||||
sr.reg4:=Longint(@Data);
|
||||
Do_IsDevice:=(SysCall(Syscall_nr_ioctl,sr)=0);
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
UnTyped File Handling
|
||||
*****************************************************************************}
|
||||
@ -639,34 +660,23 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure OpenStdIO(var f:text;mode:word;const std:string;hdl:longint);
|
||||
begin
|
||||
Assign(f,std);
|
||||
TextRec(f).Handle:=hdl;
|
||||
TextRec(f).Mode:=mode;
|
||||
TextRec(f).InOutFunc:=@FileInOutFunc;
|
||||
TextRec(f).FlushFunc:=@FileInOutFunc;
|
||||
TextRec(f).Closefunc:=@fileclosefunc;
|
||||
end;
|
||||
|
||||
|
||||
Begin
|
||||
{ Set up segfault Handler }
|
||||
InstallSegFaultHandler;
|
||||
{ Setup heap }
|
||||
InitHeap;
|
||||
{ Setup stdin, stdout and stderr }
|
||||
OpenStdIO(Input,fmInput,'stdin',StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,'stdout',StdOutputHandle);
|
||||
OpenStdIO(StdErr,fmOutput,'stderr',StdErrorHandle);
|
||||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
{ Reset IO Error }
|
||||
InOutRes:=0;
|
||||
End.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.5 1998-06-23 16:57:17 peter
|
||||
* fixed the filesize() problems under linux and filerec.size=0 error
|
||||
Revision 1.6 1998-07-01 15:30:01 peter
|
||||
* better readln/writeln
|
||||
|
||||
Revision 1.4 1998/05/30 14:18:43 peter
|
||||
* fixed to remake with -Rintel in the ppc386.cfg
|
||||
|
||||
@ -18,6 +18,7 @@
|
||||
unit syswin32;
|
||||
|
||||
{$I os.inc}
|
||||
{$DEFINE WINHEAP}
|
||||
|
||||
interface
|
||||
|
||||
@ -25,6 +26,11 @@ interface
|
||||
|
||||
{$I systemh.inc}
|
||||
|
||||
{$ifndef WinHeap}
|
||||
{ include heap support headers }
|
||||
{$I heaph.inc}
|
||||
{$endif}
|
||||
|
||||
const
|
||||
{ Default filehandles }
|
||||
UnusedHandle : longint = -1;
|
||||
@ -55,16 +61,25 @@ type
|
||||
end;
|
||||
|
||||
var
|
||||
{ C compatible arguments }
|
||||
argc : longint;
|
||||
argv : ppchar;
|
||||
{ Win32 Info }
|
||||
startupinfo : tstartupinfo;
|
||||
hprevinst,
|
||||
hinstance,
|
||||
cmdshow : longint;
|
||||
heaperror : pointer;
|
||||
|
||||
{$ifdef WinHeap}
|
||||
var
|
||||
heaperror : pointer;
|
||||
|
||||
function HeapSize:longint;
|
||||
{$endif}
|
||||
|
||||
implementation
|
||||
|
||||
{ include system independent routines }
|
||||
|
||||
{$I system.inc}
|
||||
|
||||
{ some declarations for Win32 API calls }
|
||||
@ -79,12 +94,10 @@ type
|
||||
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
|
||||
external 'user32' name 'MessageBoxA';
|
||||
|
||||
{ command line/enviroment functions }
|
||||
function GetCommandLine : LPTSTR;
|
||||
external 'kernel32' name 'GetCommandLineA';
|
||||
{ time and date functions }
|
||||
function GetTickCount : longint;
|
||||
external 'kernel32' name 'GetTickCount';
|
||||
|
||||
{ process functions }
|
||||
procedure ExitProcess(uExitCode : UINT);
|
||||
external 'kernel32' name 'ExitProcess';
|
||||
@ -131,92 +144,22 @@ end;
|
||||
procedure halt(errnum : byte);
|
||||
begin
|
||||
do_exit;
|
||||
flush(stderr);
|
||||
ExitProcess(errnum);
|
||||
end;
|
||||
|
||||
|
||||
function paramcount : longint;
|
||||
var
|
||||
count : longint;
|
||||
cmdline : pchar;
|
||||
quote : set of char;
|
||||
begin
|
||||
cmdline:=GetCommandLine;
|
||||
count:=0;
|
||||
while true do
|
||||
begin
|
||||
{ skip leading spaces }
|
||||
while cmdline^ in [' ',#9] do
|
||||
cmdline:=cmdline+1;
|
||||
if cmdline^='"' then
|
||||
begin
|
||||
quote:=['"'];
|
||||
cmdline:=cmdline+1;
|
||||
end
|
||||
else
|
||||
quote:=[' ',#9];
|
||||
if cmdline^=#0 then
|
||||
break;
|
||||
inc(count);
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
cmdline:=cmdline+1;
|
||||
{ skip quote }
|
||||
if cmdline^ in quote then
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
paramcount:=count-1;
|
||||
paramcount := argc - 1;
|
||||
end;
|
||||
|
||||
|
||||
function paramstr(l : longint) : string;
|
||||
var
|
||||
s : string;
|
||||
count : longint;
|
||||
cmdline : pchar;
|
||||
quote : set of char;
|
||||
begin
|
||||
s:='';
|
||||
if (l>=0) and (l<=paramcount) then
|
||||
begin
|
||||
cmdline:=GetCommandLine;
|
||||
count:=0;
|
||||
while true do
|
||||
begin
|
||||
{ skip leading spaces }
|
||||
while cmdline^ in [' ',#9] do
|
||||
cmdline:=cmdline+1;
|
||||
if cmdline^='"' then
|
||||
begin
|
||||
quote:=['"'];
|
||||
cmdline:=cmdline+1;
|
||||
end
|
||||
else
|
||||
quote:=[' ',#9];
|
||||
if cmdline^=#0 then
|
||||
break;
|
||||
if count=l then
|
||||
begin
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
begin
|
||||
s:=s+cmdline^;
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
break;
|
||||
end
|
||||
else
|
||||
begin
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
cmdline:=cmdline+1;
|
||||
end;
|
||||
{ skip quote }
|
||||
if cmdline^ in quote then
|
||||
cmdline:=cmdline+1;
|
||||
inc(count);
|
||||
end;
|
||||
|
||||
end;
|
||||
paramstr:=s;
|
||||
if (l>=0) and (l+1<=argc) then
|
||||
paramstr:=strpas(argv[l])
|
||||
else
|
||||
paramstr:='';
|
||||
end;
|
||||
|
||||
|
||||
@ -230,8 +173,50 @@ end;
|
||||
Heap Management
|
||||
*****************************************************************************}
|
||||
|
||||
{ Include Windows Heap manager }
|
||||
{$I winheap.inc}
|
||||
{$ifdef WinHeap}
|
||||
|
||||
{$i winheap.inc}
|
||||
|
||||
{$else}
|
||||
|
||||
{ memory functions }
|
||||
function GlobalAlloc(mode,size:longint):longint;
|
||||
external 'kernel32' name 'GlobalAlloc';
|
||||
function GlobalReAlloc(mode,size:longint):longint;
|
||||
external 'kernel32' name 'GlobalReAlloc';
|
||||
function GlobalHandle(p:pointer):longint;
|
||||
external 'kernel32' name 'GlobalHandle';
|
||||
function GlobalLock(handle:longint):pointer;
|
||||
external 'kernel32' name 'GlobalLock';
|
||||
function GlobalUnlock(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalUnlock';
|
||||
function GlobalFree(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalFree';
|
||||
function GlobalSize(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalSize';
|
||||
procedure GlobalMemoryStatus(p:pointer);
|
||||
external 'kernel32' name 'GlobalMemoryStatus';
|
||||
function LocalAlloc(uFlags : UINT;uBytes :UINT) : HLOCAL;
|
||||
external 'kernel32' name 'LocalAlloc';
|
||||
function LocalFree(hMem:HLOCAL):HLOCAL;
|
||||
external 'kernel32' name 'LocalFree';
|
||||
|
||||
function Sbrk(size : longint):longint;
|
||||
var
|
||||
h,l : longint;
|
||||
begin
|
||||
h:=GlobalAlloc(258,size);
|
||||
GlobalLock(h);
|
||||
l:=GlobalSize(h);
|
||||
writeln(l);
|
||||
sbrk:=l;
|
||||
end;
|
||||
|
||||
{ include standard heap management }
|
||||
{$I heap.inc}
|
||||
|
||||
{$endif WinHeap}
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Low Level File Routines
|
||||
@ -258,6 +243,8 @@ end;
|
||||
external 'kernel32' name 'CreateFileA';
|
||||
function SetEndOfFile(h : longint) : boolean;
|
||||
external 'kernel32' name 'SetEndOfFile';
|
||||
function GetFileType(Handle:DWORD):DWord;
|
||||
external 'kernel32' name 'GetFileType';
|
||||
|
||||
|
||||
procedure AllowSlash(p:pchar);
|
||||
@ -442,6 +429,14 @@ begin
|
||||
inoutres:=GetLastError;
|
||||
end;
|
||||
|
||||
|
||||
function do_isdevice(handle:longint):boolean;
|
||||
begin
|
||||
do_isdevice:=(getfiletype(handle)=2);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
UnTyped File Handling
|
||||
*****************************************************************************}
|
||||
@ -539,15 +534,80 @@ procedure getdir(drivenr:byte;var dir:string);
|
||||
function GetStdHandle(nStdHandle:DWORD):THANDLE;
|
||||
external 'kernel32' name 'GetStdHandle';
|
||||
|
||||
{ command line/enviroment functions }
|
||||
function GetCommandLine : pchar;
|
||||
external 'kernel32' name 'GetCommandLineA';
|
||||
|
||||
{ module functions }
|
||||
function GetModuleFileName(l1:longint;p:pointer;l2:longint):longint;
|
||||
external 'kernel32' name 'GetModuleFileNameA';
|
||||
function GetModuleHandle(p : pointer) : longint;
|
||||
external 'kernel32' name 'GetModuleHandleA';
|
||||
|
||||
var
|
||||
ModuleName : array[0..255] of char;
|
||||
function GetCommandFile:pchar;
|
||||
begin
|
||||
GetModuleFileName(0,@ModuleName,255);
|
||||
GetCommandFile:=@ModuleName;
|
||||
end;
|
||||
|
||||
|
||||
procedure setup_arguments;
|
||||
var
|
||||
arglen,
|
||||
count : longint;
|
||||
argstart,
|
||||
cmdline : pchar;
|
||||
quote : set of char;
|
||||
argsbuf : array[0..127] of pchar;
|
||||
begin
|
||||
{ create commandline, it starts with the executed filename which is argv[0] }
|
||||
cmdline:=GetCommandLine;
|
||||
count:=0;
|
||||
repeat
|
||||
{ skip leading spaces }
|
||||
while cmdline^ in [' ',#9,#13] do
|
||||
inc(longint(cmdline));
|
||||
case cmdline^ of
|
||||
#0 : break;
|
||||
'"' : begin
|
||||
quote:=['"'];
|
||||
inc(longint(cmdline));
|
||||
end;
|
||||
'''' : begin
|
||||
quote:=[''''];
|
||||
inc(longint(cmdline));
|
||||
end;
|
||||
else
|
||||
quote:=[' ',#9,#13];
|
||||
end;
|
||||
{ scan until the end of the argument }
|
||||
argstart:=cmdline;
|
||||
while (cmdline^<>#0) and not(cmdline^ in quote) do
|
||||
inc(longint(cmdline));
|
||||
{ reserve some memory }
|
||||
arglen:=cmdline-argstart;
|
||||
getmem(argsbuf[count],arglen+1);
|
||||
move(argstart^,argsbuf[count]^,arglen);
|
||||
argsbuf[count][arglen]:=#0;
|
||||
{ skip quote }
|
||||
if cmdline^ in quote then
|
||||
inc(longint(cmdline));
|
||||
inc(count);
|
||||
until false;
|
||||
{ create argc }
|
||||
argc:=count;
|
||||
{ create an nil entry }
|
||||
argsbuf[count]:=nil;
|
||||
inc(count);
|
||||
{ create the argv }
|
||||
getmem(argv,count shl 2);
|
||||
move(argsbuf,argv^,count shl 2);
|
||||
end;
|
||||
|
||||
|
||||
{$ASMMODE DIRECT}
|
||||
|
||||
procedure Entry;[public,alias: '_mainCRTStartup'];
|
||||
begin
|
||||
{ call to the pascal main }
|
||||
@ -557,32 +617,22 @@ begin
|
||||
{ that's all folks }
|
||||
ExitProcess(0);
|
||||
end;
|
||||
|
||||
{$ASMMODE ATT}
|
||||
|
||||
|
||||
procedure OpenStdIO(var f:text;mode:word;hdl:longint);
|
||||
begin
|
||||
Assign(f,'');
|
||||
TextRec(f).Handle:=hdl;
|
||||
TextRec(f).Mode:=mode;
|
||||
TextRec(f).InOutFunc:=@FileInOutFunc;
|
||||
TextRec(f).FlushFunc:=@FileInOutFunc;
|
||||
TextRec(f).Closefunc:=@fileclosefunc;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
s : string;
|
||||
begin
|
||||
{ get some helpful informations }
|
||||
GetStartupInfo(@startupinfo);
|
||||
{ Initialize ExitProc }
|
||||
ExitProc:=Nil;
|
||||
{ some misc Win32 stuff }
|
||||
hprevinst:=0;
|
||||
hinstance:=getmodulehandle(GetCommandFile);
|
||||
cmdshow:=startupinfo.wshowwindow;
|
||||
{ to test stack depth }
|
||||
loweststack:=maxlongint;
|
||||
{ Setup heap }
|
||||
{!!! InitHeap; }
|
||||
{$ifndef WinHeap}
|
||||
InitHeap;
|
||||
{$endif WinHeap}
|
||||
{ Setup stdin, stdout and stderr }
|
||||
StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE));
|
||||
StdOutputHandle:=longint(GetStdHandle(STD_OUTPUT_HANDLE));
|
||||
@ -590,18 +640,18 @@ begin
|
||||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
{ Arguments }
|
||||
setup_arguments;
|
||||
{ Reset IO Error }
|
||||
InOutRes:=0;
|
||||
{ some misc Win32 stuff }
|
||||
hprevinst:=0;
|
||||
getmodulefilename(0,@s,256);
|
||||
hinstance:=getmodulehandle(@s);
|
||||
cmdshow:=startupinfo.wshowwindow;
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.9 1998-06-10 10:39:17 peter
|
||||
Revision 1.10 1998-07-01 15:30:02 peter
|
||||
* better readln/writeln
|
||||
|
||||
Revision 1.9 1998/06/10 10:39:17 peter
|
||||
* working w32 rtl
|
||||
|
||||
Revision 1.8 1998/06/08 23:07:47 peter
|
||||
|
||||
@ -24,13 +24,9 @@
|
||||
function GlobalUnlock(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalUnlock';
|
||||
function GlobalFree(h:longint):longint;
|
||||
external 'kernel32' name 'GlobalUnlock';
|
||||
external 'kernel32' name 'GlobalFree';
|
||||
procedure GlobalMemoryStatus(p:pointer);
|
||||
external 'kernel32' name 'GlobalMemoryStatus';
|
||||
function LocalAlloc(uFlags : UINT;uBytes :UINT) : HLOCAL;
|
||||
external 'kernel32' name 'LocalAlloc';
|
||||
function LocalFree(hMem:HLOCAL):HLOCAL;
|
||||
external 'kernel32' name 'LocalFree';
|
||||
|
||||
|
||||
type
|
||||
@ -56,7 +52,7 @@ end;
|
||||
|
||||
procedure getmem(var p:pointer;size:longint);[public,alias: 'GETMEM'];
|
||||
begin
|
||||
p:=GlobalLock(GlobalAlloc(258,size));
|
||||
p:=GlobalLock(GlobalAlloc($102,size));
|
||||
if p=nil then
|
||||
memerror(size)
|
||||
end;
|
||||
@ -67,13 +63,11 @@ var
|
||||
h:longint;
|
||||
begin
|
||||
h:=GlobalHandle(p);
|
||||
if h<>0 then
|
||||
if globalunlock(h)=0 then
|
||||
if GlobalFree(h)=0 then
|
||||
begin
|
||||
p:=nil;
|
||||
exit{allways if success!!!}
|
||||
end;
|
||||
if (h<>0) and (globalunlock(h)=0) and (GlobalFree(h)=0) then
|
||||
begin
|
||||
p:=nil;
|
||||
exit;
|
||||
end;
|
||||
p:=nil;
|
||||
memerror(size);
|
||||
end;
|
||||
@ -112,6 +106,12 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function HeapSize:longint;
|
||||
begin
|
||||
HeapSize:=memmax(true);
|
||||
end;
|
||||
|
||||
|
||||
function growheap(size:longint):integer;
|
||||
begin
|
||||
growheap:=0;
|
||||
@ -119,7 +119,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 1998-06-10 10:39:19 peter
|
||||
Revision 1.4 1998-07-01 15:30:03 peter
|
||||
* better readln/writeln
|
||||
|
||||
Revision 1.3 1998/06/10 10:39:19 peter
|
||||
* working w32 rtl
|
||||
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user