From 79fa2eb539886c157ffa34c2f53253fe3a8bf3b0 Mon Sep 17 00:00:00 2001 From: florian Date: Sat, 31 Jul 2010 20:46:27 +0000 Subject: [PATCH] * support of iso pascal like i/o in iso mode git-svn-id: trunk@15685 - --- compiler/ninl.pas | 35 +++--- rtl/inc/compproc.inc | 9 ++ rtl/inc/iso7185.pp | 30 ++++- rtl/inc/text.inc | 263 ++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 315 insertions(+), 22 deletions(-) diff --git a/compiler/ninl.pas b/compiler/ninl.pas index d733e2d8ed..a66568d1dd 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -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; diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc index b1a79ac1ec..e8fe6db36b 100644 --- a/rtl/inc/compproc.inc +++ b/rtl/inc/compproc.inc @@ -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} diff --git a/rtl/inc/iso7185.pp b/rtl/inc/iso7185.pp index a54ecefe66..e1b8500ee1 100644 --- a/rtl/inc/iso7185.pp +++ b/rtl/inc/iso7185.pp @@ -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 } diff --git a/rtl/inc/text.inc b/rtl/inc/text.inc index 5d08cf417f..fda424bba9 100644 --- a/rtl/inc/text.inc +++ b/rtl/inc/text.inc @@ -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 len0) then + exit; + Str(L,s); + { default value? } + if len=-1 then + len:=11 + else if len0) then + exit; + str(q,s); + { default value? } + if len=-1 then + len:=20 + else if len0) then + exit; + str(i,s); + { default value? } + if len=-1 then + len:=20 + else if len0) 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;