paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-01 22:09:28 +01:00
Code Issues Packages Projects Releases Wiki Activity

* support of iso pascal like i/o in iso mode

Browse Source 
git-svn-id: trunk@15685 -
This commit is contained in:
florian 2010-07-31 20:46:27 +00:00
parent c506913e9b
commit 79fa2eb539
4 changed files with 315 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
compiler/ninl.pas
View File

@ -390,7 +390,7 @@ implementation
fracpara:Tcallparanode;
temp:Ttempcreatenode;
readfunctype:Tdef;
name:string[31];
name:string[63];
begin
para:=Tcallparanode(params);
@ -446,11 +446,6 @@ implementation
else
begin
name := procprefixes[do_read]+'float';
{ iso pascal needs a different handler due to upper/lower E differences }
if (m_iso in current_settings.modeswitches) and not(do_read) then
name:=name+'_iso';
readfunctype:=pbestrealtype^;
end;
end;
@ -485,6 +480,9 @@ implementation
uchar :
begin
name := procprefixes[do_read]+'char';
{ iso pascal needs a different handler }
if (m_iso in current_settings.modeswitches) and do_read then
name:=name+'_iso';
readfunctype:=cchartype;
end;
uwidechar :
@ -523,11 +521,6 @@ implementation
else
begin
name := procprefixes[do_read]+'boolean';
{ iso pascal needs a different handler }
if (m_iso in current_settings.modeswitches) and not(do_read) then
name:=name+'_iso';
readfunctype:=booltype;
end
else
@ -560,6 +553,10 @@ implementation
end;
end;
{ iso pascal needs a different handler }
if (m_iso in current_settings.modeswitches) and not(do_read) then
name:=name+'_iso';
{ check for length/fractional colon para's }
fracpara:=nil;
lenpara:=nil;
@ -607,8 +604,14 @@ implementation
if not is_real then
begin
if not assigned(lenpara) then
lenpara := ccallparanode.create(
cordconstnode.create(0,s32inttype,false),nil)
begin
if m_iso in current_settings.modeswitches then
lenpara := ccallparanode.create(
cordconstnode.create(-1,s32inttype,false),nil)
else
lenpara := ccallparanode.create(
cordconstnode.create(0,s32inttype,false),nil);
end
else
{ make sure we don't pass the successive }
{ parameters too. We also already have a }
@ -779,7 +782,11 @@ implementation
in_writestr_x:
name:='fpc_write_end';
in_readln_x:
name:='fpc_readln_end';
begin
name:='fpc_readln_end';
if m_iso in current_settings.modeswitches then
name:=name+'_iso';
end;
in_writeln_x:
name:='fpc_writeln_end';
end;

9
rtl/inc/compproc.inc
View File

@ -462,7 +462,9 @@ Function fpc_get_output:PText;compilerproc;
Procedure fpc_Write_End(var f:Text); compilerproc;
Procedure fpc_Writeln_End(var f:Text); compilerproc;
Procedure fpc_Write_Text_ShortStr(Len : Longint;var f : Text;const s : String); compilerproc;
Procedure fpc_Write_Text_ShortStr_Iso(Len : Longint;var f : Text;const s : String); compilerproc;
Procedure fpc_Write_Text_Pchar_as_Array(Len : Longint;var f : Text;const s : array of char; zerobased: boolean = true); compilerproc;
Procedure fpc_Write_Text_Pchar_as_Array_Iso(Len : Longint;var f : Text;const s : array of char; zerobased: boolean = true); compilerproc;
Procedure fpc_Write_Text_PChar_As_Pointer(Len : Longint;var f : Text;p : PChar); compilerproc;
Procedure fpc_Write_Text_AnsiStr (Len : Longint; Var f : Text; const S : AnsiString); compilerproc;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
@ -473,9 +475,13 @@ Procedure fpc_Write_Text_UnicodeStr (Len : Longint; Var f : Text; const S : Wide
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); compilerproc;
Procedure fpc_Write_Text_UInt(Len : Longint;var t : Text;l : ValUInt); compilerproc;
Procedure fpc_Write_Text_SInt_Iso(Len : Longint;var t : Text;l : ValSInt); compilerproc;
Procedure fpc_Write_Text_UInt_Iso(Len : Longint;var t : Text;l : ValUInt); compilerproc;
{$ifndef CPU64}
procedure fpc_write_text_qword(len : longint;var t : text;q : qword); compilerproc;
procedure fpc_write_text_int64(len : longint;var t : text;i : int64); compilerproc;
procedure fpc_write_text_qword_iso(len : longint;var t : text;q : qword); compilerproc;
procedure fpc_write_text_int64_iso(len : longint;var t : text;i : int64); compilerproc;
{$endif CPU64}
{$ifndef FPUNONE}
Procedure fpc_Write_Text_Float(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); compilerproc;
@ -488,6 +494,7 @@ Procedure fpc_Write_Text_Currency(fixkomma,Len : Longint;var t : Text;c : Curren
Procedure fpc_Write_Text_Boolean(Len : Longint;var t : Text;b : Boolean); compilerproc;
Procedure fpc_Write_Text_Boolean_Iso(Len : Longint;var t : Text;b : Boolean); compilerproc;
Procedure fpc_Write_Text_Char(Len : Longint;var t : Text;c : Char); compilerproc;
Procedure fpc_Write_Text_Char_Iso(Len : Longint;var t : Text;c : Char); compilerproc;
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
@ -527,6 +534,7 @@ procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata; calld
{$ifdef FPC_HAS_FEATURE_TEXTIO}
Procedure fpc_Read_End(var f:Text); compilerproc;
Procedure fpc_ReadLn_End(var f : Text); compilerproc;
Procedure fpc_ReadLn_End_Iso(var f : Text); compilerproc;
Procedure fpc_Read_Text_ShortStr(var f : Text;out s : String); compilerproc;
Procedure fpc_Read_Text_PChar_As_Pointer(var f : Text; const s : PChar); compilerproc;
Procedure fpc_Read_Text_PChar_As_Array(var f : Text;out s : array of char; zerobased: boolean = false); compilerproc;
@ -534,6 +542,7 @@ Procedure fpc_Read_Text_PChar_As_Array(var f : Text;out s : array of char; zerob
Procedure fpc_Read_Text_AnsiStr(var f : Text;out s : AnsiString); compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure fpc_Read_Text_Char(var f : Text; out c : char); compilerproc;
Procedure fpc_Read_Text_Char_Iso(var f : Text; out c : char); compilerproc;
Procedure fpc_Read_Text_SInt(var f : Text; out l :ValSInt); compilerproc;
Procedure fpc_Read_Text_UInt(var f : Text; out u :ValUInt); compilerproc;
{$ifndef FPUNONE}

30
rtl/inc/iso7185.pp
View File

@ -29,6 +29,9 @@ unit iso7185;
Procedure Reset(var f : TypedFile); [INTERNPROC: fpc_in_Reset_TypedFile];
Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
Function Eof(Var t: Text): Boolean;
Function Eof:Boolean;
implementation
{$i textrec.inc}
@ -52,13 +55,34 @@ unit iso7185;
Procedure Reset(var t : Text);[IOCheck];
Begin
{ create file name? }
if Textrec(t).mode=0 then
DoAssign(t);
case Textrec(t).mode of
{ create file name? }
0:
DoAssign(t);
fmOutput:
Write(t,#26);
end;
System.Reset(t);
End;
Function Eof(Var t: Text): Boolean;[IOCheck];
var
OldCtrlZMarksEof : Boolean;
Begin
OldCtrlZMarksEof:=CtrlZMarksEOF;
CtrlZMarksEof:=false;
Eof:=System.Eof(t);
CtrlZMarksEof:=OldCtrlZMarksEOF;
end;
Function Eof:Boolean;
Begin
Eof:=Eof(Input);
End;
begin
{ we shouldn't do this because it might confuse user programs, but for now it
is good enough to get pretty unique tmp file names }

263
rtl/inc/text.inc
View File

@ -538,9 +538,38 @@ Begin
end;
End;
Procedure fpc_Write_Text_ShortStr_Iso(Len : Longint;var f : Text;const s : String); iocheck; [Public,Alias:'FPC_WRITE_TEXT_SHORTSTR_ISO']; compilerproc;
Begin
If (InOutRes<>0) then
exit;
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
{ default value? }
If Len=-1 then
Len:=length(s);
If Len>Length(s) Then
begin
fpc_WriteBlanks(f,Len-Length(s));
fpc_WriteBuffer(f,s[1],Length(s));
end
else
fpc_WriteBuffer(f,s[1],Len);
end;
fmInput: InOutRes:=105
else InOutRes:=103;
end;
End;
{ provide local access to write_str }
procedure Write_Str(Len : Longint;var f : Text;const s : String); iocheck; [external name 'FPC_WRITE_TEXT_SHORTSTR'];
{ provide local access to write_str_iso }
procedure Write_Str_Iso(Len : Longint;var f : Text;const s : String); iocheck; [external name 'FPC_WRITE_TEXT_SHORTSTR_ISO'];
Procedure fpc_Write_Text_Pchar_as_Array(Len : Longint;var f : Text;const s : array of char; zerobased: boolean = true); iocheck; compilerproc;
var
ArrayLen : longint;
@ -552,7 +581,7 @@ Begin
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
p:=pchar(@s);
if (zerobased) then
if zerobased then
begin
{ can't use StrLen, since that one could try to read past the end }
{ of the heap (JM) }
@ -573,6 +602,47 @@ Begin
End;
Procedure fpc_Write_Text_Pchar_as_Array_Iso(Len : Longint;var f : Text;const s : array of char; zerobased: boolean = true); iocheck; compilerproc;
var
ArrayLen : longint;
p : pchar;
Begin
If (InOutRes<>0) then
exit;
case TextRec(f).mode of
fmOutput { fmAppend gets changed to fmOutPut in do_open (JM) }:
begin
p:=pchar(@s);
if zerobased then
begin
{ can't use StrLen, since that one could try to read past the end }
{ of the heap (JM) }
ArrayLen:=IndexByte(p^,high(s)+1,0);
{ IndexByte returns -1 if not found (JM) }
if ArrayLen = -1 then
ArrayLen := high(s)+1;
end
else
ArrayLen := high(s)+1;
{ default value? }
If Len=-1 then
Len:=ArrayLen;
If Len>ArrayLen Then
begin
fpc_WriteBlanks(f,Len-ArrayLen);
fpc_WriteBuffer(f,p^,ArrayLen);
end
else
fpc_WriteBuffer(f,p^,Len);
end;
fmInput: InOutRes:=105
else InOutRes:=103;
end;
End;
Procedure fpc_Write_Text_PChar_As_Pointer(Len : Longint;var f : Text;p : PChar); iocheck; compilerproc;
var
PCharLen : longint;
@ -694,8 +764,38 @@ Begin
End;
{$ifndef CPU64}
Procedure fpc_Write_Text_SInt_Iso(Len : Longint;var t : Text;l : ValSInt); iocheck; compilerproc;
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str(l,s);
{ default value? }
if len=-1 then
len:=11
else if len<length(s) then
len:=length(s);
Write_Str_Iso(Len,t,s);
End;
Procedure fpc_Write_Text_UInt_Iso(Len : Longint;var t : Text;l : ValUInt); iocheck; compilerproc;
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str(L,s);
{ default value? }
if len=-1 then
len:=11
else if len<length(s) then
len:=length(s);
Write_Str_Iso(Len,t,s);
End;
{$ifndef CPU64}
procedure fpc_write_text_qword(len : longint;var t : text;q : qword); iocheck; compilerproc;
var
s : string;
@ -706,6 +806,7 @@ begin
write_str(len,t,s);
end;
procedure fpc_write_text_int64(len : longint;var t : text;i : int64); iocheck; compilerproc;
var
s : string;
@ -716,6 +817,38 @@ begin
write_str(len,t,s);
end;
procedure fpc_write_text_qword_iso(len : longint;var t : text;q : qword); iocheck; compilerproc;
var
s : string;
begin
if (InOutRes<>0) then
exit;
str(q,s);
{ default value? }
if len=-1 then
len:=20
else if len<length(s) then
len:=length(s);
write_str_iso(len,t,s);
end;
procedure fpc_write_text_int64_iso(len : longint;var t : text;i : int64); iocheck; compilerproc;
var
s : string;
begin
if (InOutRes<>0) then
exit;
str(i,s);
{ default value? }
if len=-1 then
len:=20
else if len<length(s) then
len:=length(s);
write_str_iso(len,t,s);
end;
{$endif CPU64}
{$ifndef FPUNONE}
@ -863,11 +996,14 @@ Procedure fpc_Write_Text_Boolean_Iso(Len : Longint;var t : Text;b : Boolean); io
Begin
If (InOutRes<>0) then
exit;
{ Can't use array[boolean] because b can be >0 ! }
{ Can't use array[boolean] because b can be >0 ! }
{ default value? }
If Len=-1 then
Len:=5;
if b then
Write_Str(Len,t,'true')
Write_Str_Iso(Len,t,'true')
else
Write_Str(Len,t,'false');
Write_Str_Iso(Len,t,'false');
End;
@ -892,6 +1028,32 @@ Begin
End;
Procedure fpc_Write_Text_Char_Iso(Len : Longint;var t : Text;c : Char); iocheck; compilerproc;
Begin
If (InOutRes<>0) then
exit;
if (TextRec(t).mode<>fmOutput) Then
begin
if TextRec(t).mode=fmClosed then
InOutRes:=103
else
InOutRes:=105;
exit;
end;
{ default value? }
If Len=-1 then
Len:=1;
If Len>1 Then
fpc_WriteBlanks(t,Len-1)
else If Len<1 Then
exit;
If TextRec(t).BufPos>=TextRec(t).BufSize Then
FileFunc(TextRec(t).InOutFunc)(TextRec(t));
TextRec(t).Bufptr^[TextRec(t).BufPos]:=c;
Inc(TextRec(t).BufPos);
End;
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); iocheck; compilerproc;
var
@ -1064,6 +1226,64 @@ Begin
End;
Procedure fpc_ReadLn_End_Iso(var f : Text);[Public,Alias:'FPC_READLN_END_ISO']; iocheck; compilerproc;
var prev: char;
Begin
If not CheckRead(f) then
exit;
if (TextRec(f).BufPos>=TextRec(f).BufEnd) then
{ Flush if set }
begin
if (TextRec(f).FlushFunc<>nil) then
FileFunc(TextRec(f).FlushFunc)(TextRec(f));
exit;
end;
if TextRec (F).BufPtr^ [TextRec (F).BufPos] = #26 then
begin
inc(TextRec(f).BufPos);
Exit;
end;
repeat
prev := TextRec(f).BufPtr^[TextRec(f).BufPos];
inc(TextRec(f).BufPos);
{ no system uses #10#13 as line seperator (#10 = *nix, #13 = Mac, }
{ #13#10 = Dos), so if we've got #10, we can safely exit }
if prev = #10 then
exit;
{$ifdef MACOS}
if prev = #13 then
{StdInput on macos never have dos line ending, so this is safe.}
if TextRec(f).Handle = StdInputHandle then
exit;
{$endif MACOS}
if TextRec(f).BufPos>=TextRec(f).BufEnd Then
begin
FileFunc(TextRec(f).InOutFunc)(TextRec(f));
if (TextRec(f).BufPos>=TextRec(f).BufEnd) then
{ Flush if set }
begin
if (TextRec(f).FlushFunc<>nil) then
FileFunc(TextRec(f).FlushFunc)(TextRec(f));
exit;
end;
end;
if TextRec (F).BufPtr^ [TextRec (F).BufPos] = #26 then
begin
inc(TextRec(f).BufPos);
Exit;
end;
if (prev=#13) then
{ is there also a #10 after it? }
begin
if (TextRec(f).BufPtr^[TextRec(f).BufPos]=#10) then
{ yes, skip that one as well }
inc(TextRec(f).BufPos);
exit;
end;
until false;
End;
Function ReadPCharLen(var f:Text;s:pchar;maxlen:longint):longint;
var
sPos,len : Longint;
@ -1172,6 +1392,39 @@ Begin
end;
procedure fpc_Read_Text_Char_Iso(var f : Text; out c: char); iocheck;compilerproc;
Begin
c:=' ';
If not CheckRead(f) then
exit;
If TextRec(f).BufPos>=TextRec(f).BufEnd Then
begin
c:=' ';
exit;
end;
c:=TextRec(f).Bufptr^[TextRec(f).BufPos];
inc(TextRec(f).BufPos);
if c=#13 then
begin
c:=' ';
If not CheckRead(f) or
(TextRec(f).BufPos>=TextRec(f).BufEnd) then
exit;
If TextRec(f).Bufptr^[TextRec(f).BufPos]=#10 then
inc(TextRec(f).BufPos);
{ ignore #26 following a new line }
If not CheckRead(f) or
(TextRec(f).BufPos>=TextRec(f).BufEnd) then
exit;
If TextRec(f).Bufptr^[TextRec(f).BufPos]=#26 then
inc(TextRec(f).BufPos);
end
else if c in [#10,#26] then
c:=' ';
end;
Procedure fpc_Read_Text_SInt(var f : Text; out l : ValSInt); iocheck; compilerproc;
var
hs : String;