From 5a638754f459283448a7bcec42934c2d9ec95b36 Mon Sep 17 00:00:00 2001 From: peter Date: Wed, 1 Jul 1998 15:29:56 +0000 Subject: [PATCH] * better readln/writeln --- rtl/dos/go32v1/system.pp | 37 ++-- rtl/dos/go32v2/system.pp | 131 +++++++------- rtl/i386/i386.inc | 7 +- rtl/inc/system.inc | 34 ++-- rtl/inc/text.inc | 375 ++++++++++++++++++++++++--------------- rtl/linux/syslinux.pp | 44 +++-- rtl/win32/syswin32.pp | 262 ++++++++++++++++----------- rtl/win32/winheap.inc | 31 ++-- 8 files changed, 539 insertions(+), 382 deletions(-) diff --git a/rtl/dos/go32v1/system.pp b/rtl/dos/go32v1/system.pp index 3180bb1d64..062fd0db9a 100644 --- a/rtl/dos/go32v1/system.pp +++ b/rtl/dos/go32v1/system.pp @@ -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 diff --git a/rtl/dos/go32v2/system.pp b/rtl/dos/go32v2/system.pp index 62abb7f6d0..b18c9e5fa0 100644 --- a/rtl/dos/go32v2/system.pp +++ b/rtl/dos/go32v2/system.pp @@ -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 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 diff --git a/rtl/i386/i386.inc b/rtl/i386/i386.inc index 7a2eb6b169..2cb9a937a0 100644 --- a/rtl/i386/i386.inc +++ b/rtl/i386/i386.inc @@ -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 diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc index 5974b2a075..dec481c6d8 100644 --- a/rtl/inc/system.inc +++ b/rtl/inc/system.inc @@ -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 diff --git a/rtl/inc/text.inc b/rtl/inc/text.inc index 2b94b89a11..d1920e2c0d 100644 --- a/rtl/inc/text.inc +++ b/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 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 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 diff --git a/rtl/linux/syslinux.pp b/rtl/linux/syslinux.pp index 7129c02f1a..3e4bf81d8d 100644 --- a/rtl/linux/syslinux.pp +++ b/rtl/linux/syslinux.pp @@ -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 diff --git a/rtl/win32/syswin32.pp b/rtl/win32/syswin32.pp index 0977b06059..21f3baee0a 100644 --- a/rtl/win32/syswin32.pp +++ b/rtl/win32/syswin32.pp @@ -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 diff --git a/rtl/win32/winheap.inc b/rtl/win32/winheap.inc index d15e06d79b..8a698f0556 100644 --- a/rtl/win32/winheap.inc +++ b/rtl/win32/winheap.inc @@ -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 }