فهرست منبع

+ support for <text>^ in iso mode

git-svn-id: trunk@22512 -
florian 13 سال پیش
والد
کامیت
420cd9bd27
5فایلهای تغییر یافته به همراه43 افزوده شده و 2 حذف شده
  1. 1 0
      .gitattributes
  2. 9 1
      compiler/pexpr.pas
  3. 1 0
      rtl/inc/compproc.inc
  4. 12 1
      rtl/inc/text.inc
  5. 20 0
      tests/test/tisobuf1.pp

+ 1 - 0
.gitattributes

@@ -10906,6 +10906,7 @@ tests/test/tintfcdecl1.pp svneol=native#text/plain
 tests/test/tintfcdecl2.pp svneol=native#text/plain
 tests/test/tintfdef.pp svneol=native#text/plain
 tests/test/tintuint.pp svneol=native#text/plain
+tests/test/tisobuf1.pp svneol=native#text/pascal
 tests/test/tisogoto1.pp svneol=native#text/pascal
 tests/test/tisogoto2.pp svneol=native#text/pascal
 tests/test/tisogoto3.pp svneol=native#text/pascal

+ 9 - 1
compiler/pexpr.pas

@@ -1653,7 +1653,15 @@ implementation
                    typecheckpass(p1);
                  end;
 
-               if (p1.resultdef.typ<>pointerdef) then
+               { iso file buf access? }
+               if (m_iso in current_settings.modeswitches) and
+                 (p1.resultdef.typ=filedef) and
+                 (tfiledef(p1.resultdef).filetyp=ft_text) then
+                 begin
+                   p1:=cderefnode.create(ccallnode.createintern('fpc_getbuf',ccallparanode.create(p1,nil)));
+                   typecheckpass(p1);
+                 end
+               else if (p1.resultdef.typ<>pointerdef) then
                  begin
                     { ^ as binary operator is a problem!!!! (FK) }
                     again:=false;

+ 1 - 0
rtl/inc/compproc.inc

@@ -471,6 +471,7 @@ procedure fpc_Read_Text_Currency(var f : Text; out v : Currency); compilerproc;
 Procedure fpc_Read_Text_QWord(var f : text; out q : qword); compilerproc;
 Procedure fpc_Read_Text_Int64(var f : text; out i : int64); compilerproc;
 {$endif CPU64}
+function fpc_GetBuf(var f : Text) : pchar; compilerproc;
 {$endif FPC_HAS_FEATURE_TEXTIO}
 
 {$ifdef FPC_INCLUDE_SOFTWARE_MOD_DIV}

+ 12 - 1
rtl/inc/text.inc

@@ -1388,7 +1388,7 @@ Begin
 End;
 {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
 
-procedure fpc_Read_Text_Char(var f : Text; out c: char); [public, alias: 'FPC_READ_TEXT_CHAR']; iocheck;compilerproc;
+procedure fpc_Read_Text_Char(var f : Text; out c: char); [public, alias: 'FPC_READ_TEXT_CHAR']; iocheck; compilerproc;
 Begin
   c:=#0;
   If not CheckRead(f) then
@@ -1405,6 +1405,17 @@ end;
 procedure fpc_Read_Text_Char_intern(var f : Text; out c: char); iocheck; [external name 'FPC_READ_TEXT_CHAR'];
 
 
+function fpc_GetBuf(var f : Text) : pchar; iocheck; compilerproc;
+Begin
+  Result:=@TextRec(f).Bufptr^[TextRec(f).BufEnd];
+  If not CheckRead(f) then
+    exit;
+  If TextRec(f).BufPos>=TextRec(f).BufEnd Then
+    exit;
+  Result:=@TextRec(f).Bufptr^[TextRec(f).BufPos];
+end;
+
+
 {$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
 procedure fpc_Read_Text_WideChar(var f : Text; out wc: widechar); iocheck;compilerproc;
 var

+ 20 - 0
tests/test/tisobuf1.pp

@@ -0,0 +1,20 @@
+{$mode iso}
+program test(input, output);
+
+  var
+    t : text;
+
+  begin
+    assign(t,'tisobuf1.tmp');
+    rewrite(t);
+    writeln(t,'{Test}');
+    close(t);
+    reset(t);
+    if t^<>'{' then
+      halt(1);
+    close(t);
+    erase(t);
+    writeln('ok');
+  end.
+
+