--- p/predef.def.orig Sat Jul 16 00:45:03 2005 +++ p/predef.def Sun Feb 5 01:14:42 2006 @@ -437,7 +437,7 @@ PREDEF_ROUTINE (ReadLn, "-,|", ER_IOCRITICAL, ANY_PASCAL) PREDEF_ROUTINE (ReadStr, "-x,|", 0, E_O_PASCAL) PREDEF_ROUTINE_NO_ID (Read_Init, "-Fi", 0) -PREDEF_ROUTINE_NO_ID (ReadStr_Init, "psi", 0) +PREDEF_ROUTINE_NO_ID (ReadStr_Init, "pphi", 0) PREDEF_ROUTINE_NO_ID (ReadWriteStr_Done, "-F", 0) PREDEF_ROUTINE_NO_ID (Val_Done, "iF", 0) PREDEF_ROUTINE_NO_ID (Read_Integer, "lF", 0) --- p/predef.c.orig Sat Jul 16 00:45:34 2005 +++ p/predef.c Sun Feb 5 01:41:05 2006 @@ -94,6 +94,7 @@ static tree get_read_flags (int); static tree actual_set_parameters (tree, int); static tree build_read (int, tree, const char *); +static tree string_par (tree *); static tree build_write (int, tree, const char *); static tree build_val (tree); static tree pascal_unpack_and_pack (int, tree, tree, tree, const char *); @@ -481,6 +482,27 @@ return build_indirect_ref (save_expr (addr), NULL); } +/* If *str is a valid string parameter, put its address in *str and + return its length. Otherwise return NULL_TREE. */ +static tree +string_par (tree *str) +{ + if (is_string_compatible_type (*str, 1)) + { + tree t = save_expr_string (*str); + *str = build1 (ADDR_EXPR, cstring_type_node, PASCAL_STRING_VALUE (t)); + return PASCAL_STRING_LENGTH (t); + } + else if ((co->cstrings_as_strings || (co->pascal_dialect & B_D_M_PASCAL)) + && TYPE_MAIN_VARIANT (base_type (TREE_TYPE (*str))) == cstring_type_node) + { + *str = save_expr (*str); + return build_routine_call (strlen_routine_node, build_tree_list (NULL_TREE, *str)); + } + else + return NULL_TREE; +} + /* Read from files and strings. */ static tree build_read (int r_num, tree params, const char *r_name) @@ -488,26 +510,20 @@ tree file, parm; if (r_num == p_ReadStr) { - if (!params - || !(is_string_compatible_type (TREE_VALUE (params), 1) - || ((co->cstrings_as_strings || (co->pascal_dialect & B_D_M_PASCAL)) - && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_VALUE (params))) == cstring_type_node))) + tree length = params ? string_par (&TREE_VALUE (params)) : NULL_TREE; + if (!length) { error ("argument 1 to `ReadStr' must be the string to read from"); if (params && TYPE_MAIN_VARIANT (TREE_TYPE (TREE_VALUE (params))) == cstring_type_node) cstring_inform (); return error_mark_node; } - /* @@ For backward-compatibility with GPC's previous behaviour. - When we have a more general way to treat CStrings as Strings - (optionally), we can drop this special case. */ - if (TYPE_MAIN_VARIANT (TREE_TYPE (TREE_VALUE (params))) == cstring_type_node) - TREE_VALUE (params) = build_predef_call (p_CString2String, build_tree_list (NULL_TREE, TREE_VALUE (params))); /* This file variable is needed internally. It is no real file, so be careful what you do with it. Don't call `init_any'. */ file = declare_variable (get_unique_identifier ("readstr_tmp_file"), text_type_node, NULL_TREE, VQ_IMPLICIT); expand_expr_stmt (build_modify_expr (build_component_ref (file, get_identifier ("_p_File_")), NOP_EXPR, - build_predef_call (p_ReadStr_Init, tree_cons (NULL_TREE, TREE_VALUE (params), build_tree_list (NULL_TREE, get_read_flags (0)))))); + build_predef_call (p_ReadStr_Init, tree_cons (NULL_TREE, TREE_VALUE (params), + tree_cons (NULL_TREE, length, build_tree_list (NULL_TREE, get_read_flags (0))))))); params = TREE_CHAIN (params); } else @@ -617,9 +633,10 @@ static tree build_val (tree params) { - tree target, type, res_pos, file, t; + tree target, type, res_pos, file, length, t; int r_num; - if (!is_string_compatible_type (TREE_VALUE (params), 1)) + length = string_par (&TREE_VALUE (params)); + if (!length) { error ("argument 1 to `Val' must be a string"); return error_mark_node; @@ -648,7 +665,7 @@ error ("argument 2 to `Val' must be of integer or real type"); return error_mark_node; } - TREE_CHAIN (params) = build_tree_list (NULL_TREE, (get_read_flags (1))); + TREE_CHAIN (params) = tree_cons (NULL_TREE, length, build_tree_list (NULL_TREE, (get_read_flags (1)))); /* This file variable is needed internally. It is no real file, so be careful what you do with it. Don't call `init_any'. */ file = declare_variable (get_unique_identifier ("val_tmp_file"), text_type_node, NULL_TREE, VQ_IMPLICIT); @@ -888,21 +905,9 @@ break; case RECORD_TYPE: case ARRAY_TYPE: - if (is_string_type (p, 1)) - { - p = save_expr_string (p); - length = PASCAL_STRING_LENGTH (p); - p = build1 (ADDR_EXPR, cstring_type_node, PASCAL_STRING_VALUE (p)); - r_num2 = p_Write_String; - } - break; case POINTER_TYPE: - if (TYPE_MAIN_VARIANT (base_type (type)) == cstring_type_node - && (co->cstrings_as_strings || (co->pascal_dialect & B_D_M_PASCAL))) - { - length = TYPE_MAX_VALUE (pascal_cardinal_type_node); - r_num2 = p_Write_String; - } + if ((length = string_par (&p))) + r_num2 = p_Write_String; break; default: break; --- p/rts/files.pas.orig Thu May 19 07:20:18 2005 +++ p/rts/files.pas Sun Feb 5 01:45:10 2006 @@ -191,7 +191,7 @@ procedure Read_FixedString (f: GPC_FDR; Str: PChars0; Capacity: Integer); attribute (name = '_p_Read_FixedString'); procedure Read_Line (f: GPC_FDR); attribute (name = '_p_Read_Line'); procedure Read_Init (f: GPC_FDR; Flags: Integer); attribute (name = '_p_Read_Init'); -function ReadStr_Init (const s: String; aFlags: Integer) = f: GPC_FDR; attribute (name = '_p_ReadStr_Init'); +function ReadStr_Init (s: PChars0; Length: Cardinal; aFlags: Integer) = f: GPC_FDR; attribute (name = '_p_ReadStr_Init'); procedure ReadWriteStr_Done (f: GPC_FDR); attribute (name = '_p_ReadWriteStr_Done'); function Val_Done (f: GPC_FDR): Integer; attribute (name = '_p_Val_Done'); @@ -392,7 +392,7 @@ { Under development } procedure AnyStringTFDD_Reset (var f: GPC_FDR; var Buf: ConstAnyString); attribute (name = '_p_AnyStringTFDD_Reset'); { @@ procedure AnyStringTFDD_Rewrite (var f: GPC_FDR; var Buf: VarAnyString); attribute (name = '_p_AnyStringTFDD_Rewrite'); } -procedure StringTFDD_Reset (var f: GPC_FDR; var Buf: ConstAnyString; const s: String); attribute (name = '_p_StringTFDD_Reset'); +procedure StringTFDD_Reset (var f: GPC_FDR; var Buf: ConstAnyString; var s: array [m .. n: Integer] of Char); attribute (name = '_p_StringTFDD_Reset'); { @@ procedure StringTFDD_Rewrite (var f: GPC_FDR; var Buf: VarAnyString; var s: String); attribute (name = '_p_StringTFDD_Rewrite'); } {@internal} @@ -2323,15 +2323,15 @@ f := InternalNew (SizeOf (f^)) end; -function ReadStr_Init (const s: String; aFlags: Integer) = f: GPC_FDR; +function ReadStr_Init (s: PChars0; Length: Cardinal; aFlags: Integer) = f: GPC_FDR; begin if (aFlags and VAL_MASK) <> 0 then StartTempIOError; f := GetReadWriteStrFDR; ClearStatus (f); with f^ do begin - if s = '' then BufPtr := nil else BufPtr := PChars0 (@s[1]); - BufSize := Length (s); + BufPtr := s; + BufSize := Length; BufPos := 0; Flags := aFlags or READ_STRING_MASK; FilBuf := PChars0 (@InternalBuffer) { only 1 char is actually needed } @@ -2722,11 +2722,7 @@ procedure Write_String (f: GPC_FDR; s: PChars0; Length: Cardinal; Width: Integer); begin - if s = nil then - Length := 0 - else if Length = High (Cardinal) then { CString } - Length := CStringLength (CString (s)); - if Length = 0 then + if (s = nil) or (Length = 0) then WritePadded (f, '', Width, (f^.Flags and CLIP_STRING_MASK) <> 0) else WritePadded (f, s^[0 .. Length - 1], Width, (f^.Flags and CLIP_STRING_MASK) <> 0) @@ -3482,10 +3478,10 @@ Internal_Reset (f, '', False, 1) end; -procedure StringTFDD_Reset (var f: GPC_FDR; var Buf: ConstAnyString; const s: String); +procedure StringTFDD_Reset (var f: GPC_FDR; var Buf: ConstAnyString; var s: array [m .. n: Integer] of Char); begin - Buf.Length := Length (s); - if s = '' then Buf.Chars := nil else Buf.Chars := PChars (@s[1]); + Buf.Length := n - m + 1; + Buf.Chars := PChars (@s[m]); AnyStringTFDD_Reset (f, Buf) end; --- p/test/fjf1099.pas.orig Sun Feb 5 01:10:40 2006 +++ p/test/fjf1099.pas Sun Feb 5 01:10:42 2006 @@ -0,0 +1,15 @@ +program fjf1099; + +uses GPC; + +var + a, r: String (10); + b: ConstAnyString; + f: Text; + +begin + a := 'XOKY'; + StringTFDD_Reset (f, b, a[2 .. 3]); + Read (f, r); + WriteLn (r) +end.