astrings.inc 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by Michael Van Canneyt,
  4. member of the Free Pascal development team.
  5. This file implements AnsiStrings for FPC
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. { This will release some functions for special shortstring support }
  13. { define EXTRAANSISHORT}
  14. {
  15. This file contains the implementation of the AnsiString type,
  16. and all things that are needed for it.
  17. AnsiString is defined as a 'silent' pchar :
  18. a pchar that points to :
  19. @-8 : SizeInt for reference count;
  20. @-4 : SizeInt for size;
  21. @ : String + Terminating #0;
  22. Pchar(Ansistring) is a valid typecast.
  23. So AS[i] is converted to the address @AS+i-1.
  24. Constants should be assigned a reference count of -1
  25. Meaning that they can't be disposed of.
  26. }
  27. Type
  28. PAnsiRec = ^TAnsiRec;
  29. TAnsiRec = Packed Record
  30. Ref,
  31. Len : SizeInt;
  32. First : Char;
  33. end;
  34. Const
  35. AnsiRecLen = SizeOf(TAnsiRec);
  36. FirstOff = SizeOf(TAnsiRec)-1;
  37. {****************************************************************************
  38. Internal functions, not in interface.
  39. ****************************************************************************}
  40. Function NewAnsiString(Len : SizeInt) : Pointer;
  41. {
  42. Allocate a new AnsiString on the heap.
  43. initialize it to zero length and reference count 1.
  44. }
  45. Var
  46. P : Pointer;
  47. begin
  48. { request a multiple of 16 because the heap manager alloctes anyways chunks of 16 bytes }
  49. GetMem(P,Len+AnsiRecLen);
  50. If P<>Nil then
  51. begin
  52. PAnsiRec(P)^.Ref:=1; { Set reference count }
  53. PAnsiRec(P)^.Len:=0; { Initial length }
  54. PAnsiRec(P)^.First:=#0; { Terminating #0 }
  55. inc(p,firstoff); { Points to string now }
  56. end;
  57. NewAnsiString:=P;
  58. end;
  59. Procedure DisposeAnsiString(Var S : Pointer); {$IFNDEF VER2_0} Inline; {$ENDIF}
  60. {
  61. Deallocates a AnsiString From the heap.
  62. }
  63. begin
  64. If S=Nil then
  65. exit;
  66. Dec (S,FirstOff);
  67. FreeMem (S);
  68. S:=Nil;
  69. end;
  70. Procedure fpc_AnsiStr_Decr_Ref (Var S : Pointer); [Public,Alias:'FPC_ANSISTR_DECR_REF']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  71. {
  72. Decreases the ReferenceCount of a non constant ansistring;
  73. If the reference count is zero, deallocate the string;
  74. }
  75. Type
  76. pSizeInt = ^SizeInt;
  77. Var
  78. l : pSizeInt;
  79. Begin
  80. { Zero string }
  81. If S=Nil then exit;
  82. { check for constant strings ...}
  83. l:=@PANSIREC(S-FirstOff)^.Ref;
  84. If l^<0 then exit;
  85. { declocked does a MT safe dec and returns true, if the counter is 0 }
  86. If declocked(l^) then
  87. { Ref count dropped to zero }
  88. DisposeAnsiString (S); { Remove...}
  89. end;
  90. { also define alias for internal use in the system unit }
  91. Procedure fpc_AnsiStr_Decr_Ref (Var S : Pointer); [external name 'FPC_ANSISTR_DECR_REF'];
  92. Procedure fpc_AnsiStr_Incr_Ref (S : Pointer); [Public,Alias:'FPC_ANSISTR_INCR_REF']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  93. Begin
  94. If S=Nil then
  95. exit;
  96. { Let's be paranoid : Constant string ??}
  97. If PAnsiRec(S-FirstOff)^.Ref<0 then exit;
  98. inclocked(PAnsiRec(S-FirstOff)^.Ref);
  99. end;
  100. { also define alias which can be used inside the system unit }
  101. Procedure fpc_AnsiStr_Incr_Ref (S : Pointer); [external name 'FPC_ANSISTR_INCR_REF'];
  102. Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_ANSISTR_ASSIGN']; compilerproc;
  103. {
  104. Assigns S2 to S1 (S1:=S2), taking in account reference counts.
  105. }
  106. begin
  107. If S2<>nil then
  108. If PAnsiRec(S2-FirstOff)^.Ref>0 then
  109. inclocked(PAnsiRec(S2-FirstOff)^.ref);
  110. { Decrease the reference count on the old S1 }
  111. fpc_ansistr_decr_ref (S1);
  112. { And finally, have S1 pointing to S2 (or its copy) }
  113. S1:=S2;
  114. end;
  115. { alias for internal use }
  116. Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_ANSISTR_ASSIGN'];
  117. function fpc_AnsiStr_Concat (const S1,S2 : AnsiString): ansistring; compilerproc;
  118. var
  119. S3: ansistring absolute result;
  120. {
  121. Concatenates 2 AnsiStrings : S1+S2.
  122. Result Goes to S3;
  123. }
  124. Var
  125. Size,Location : SizeInt;
  126. begin
  127. { only assign if s1 or s2 is empty }
  128. if (S1='') then
  129. s3 := s2
  130. else if (S2='') then
  131. s3 := s1
  132. else
  133. begin
  134. Size:=length(S2);
  135. Location:=Length(S1);
  136. SetLength (S3,Size+Location);
  137. { the cast to a pointer avoids the unique call }
  138. { and we don't need an unique call }
  139. { because of the SetLength S3 is unique }
  140. Move (S1[1],pointer(S3)^,Location);
  141. Move (S2[1],pointer(pointer(S3)+location)^,Size+1);
  142. end;
  143. end;
  144. {$ifdef EXTRAANSISHORT}
  145. Procedure AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString);
  146. {
  147. Concatenates a Ansi with a short string; : S2 + S2
  148. }
  149. Var
  150. Size,Location : SizeInt;
  151. begin
  152. Size:=Length(S2);
  153. Location:=Length(S1);
  154. If Size=0 then
  155. exit;
  156. { Setlength takes case of uniqueness
  157. and alllocated memory. We need to use length,
  158. to take into account possibility of S1=Nil }
  159. SetLength (S1,Size+Length(S1));
  160. Move (S2[1],Pointer(Pointer(S1)+Location)^,Size);
  161. PByte( Pointer(S1)+length(S1) )^:=0; { Terminating Zero }
  162. end;
  163. {$endif EXTRAANSISHORT}
  164. { the following declaration has exactly the same effect as }
  165. { procedure fpc_AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer); }
  166. { which is what the old helper was, so we don't need an extra implementation }
  167. { of the old helper (JM) }
  168. function fpc_AnsiStr_To_ShortStr (high_of_res: SizeInt;const S2 : Ansistring): shortstring;[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR']; compilerproc;
  169. {
  170. Converts a AnsiString to a ShortString;
  171. }
  172. Var
  173. Size : SizeInt;
  174. begin
  175. if S2='' then
  176. fpc_AnsiStr_To_ShortStr:=''
  177. else
  178. begin
  179. Size:=Length(S2);
  180. If Size>high_of_res then
  181. Size:=high_of_res;
  182. Move (S2[1],fpc_AnsiStr_To_ShortStr[1],Size);
  183. byte(fpc_AnsiStr_To_ShortStr[0]):=byte(Size);
  184. end;
  185. end;
  186. Function fpc_ShortStr_To_AnsiStr (Const S2 : ShortString): ansistring; compilerproc;
  187. {
  188. Converts a ShortString to a AnsiString;
  189. }
  190. Var
  191. Size : SizeInt;
  192. begin
  193. Size:=Length(S2);
  194. Setlength (fpc_ShortStr_To_AnsiStr,Size);
  195. if Size>0 then
  196. Move(S2[1],Pointer(fpc_ShortStr_To_AnsiStr)^,Size);
  197. end;
  198. Function fpc_Char_To_AnsiStr(const c : Char): AnsiString; compilerproc;
  199. {
  200. Converts a Char to a AnsiString;
  201. }
  202. begin
  203. Setlength (fpc_Char_To_AnsiStr,1);
  204. PByte(Pointer(fpc_Char_To_AnsiStr))^:=byte(c);
  205. { Terminating Zero }
  206. PByte(Pointer(fpc_Char_To_AnsiStr)+1)^:=0;
  207. end;
  208. Function fpc_PChar_To_AnsiStr(const p : pchar): ansistring; compilerproc;
  209. Var
  210. L : SizeInt;
  211. begin
  212. if (not assigned(p)) or (p[0]=#0) Then
  213. { result is automatically set to '' }
  214. exit;
  215. l:=IndexChar(p^,-1,#0);
  216. SetLength(fpc_PChar_To_AnsiStr,L);
  217. Move (P[0],Pointer(fpc_PChar_To_AnsiStr)^,L)
  218. end;
  219. Function fpc_CharArray_To_AnsiStr(const arr: array of char): ansistring; compilerproc;
  220. var
  221. i : SizeInt;
  222. begin
  223. if arr[0]=#0 Then
  224. { result is automatically set to '' }
  225. exit;
  226. i:=IndexChar(arr,high(arr)+1,#0);
  227. if i = -1 then
  228. i := high(arr)+1;
  229. SetLength(fpc_CharArray_To_AnsiStr,i);
  230. Move (arr[0],Pointer(fpc_CharArray_To_AnsiStr)^,i);
  231. end;
  232. { note: inside the compiler, the resulttype is modified to be the length }
  233. { of the actual chararray to which we convert (JM) }
  234. function fpc_ansistr_to_chararray(arraysize: SizeInt; const src: ansistring): fpc_big_chararray; [public, alias: 'FPC_ANSISTR_TO_CHARARRAY']; compilerproc;
  235. var
  236. len: SizeInt;
  237. begin
  238. len := length(src);
  239. if len > arraysize then
  240. len := arraysize;
  241. { make sure we don't try to access element 1 of the ansistring if it's nil }
  242. if len > 0 then
  243. move(src[1],fpc_ansistr_to_chararray[0],len);
  244. fillchar(fpc_ansistr_to_chararray[len],arraysize-len,0);
  245. end;
  246. Function fpc_AnsiStr_Compare(const S1,S2 : AnsiString): SizeInt;[Public,Alias : 'FPC_ANSISTR_COMPARE']; compilerproc;
  247. {
  248. Compares 2 AnsiStrings;
  249. The result is
  250. <0 if S1<S2
  251. 0 if S1=S2
  252. >0 if S1>S2
  253. }
  254. Var
  255. MaxI,Temp : SizeInt;
  256. begin
  257. if pointer(S1)=pointer(S2) then
  258. begin
  259. result:=0;
  260. exit;
  261. end;
  262. Maxi:=Length(S1);
  263. temp:=Length(S2);
  264. If MaxI>Temp then
  265. MaxI:=Temp;
  266. if MaxI>0 then
  267. begin
  268. result:=CompareByte(S1[1],S2[1],MaxI);
  269. if result=0 then
  270. result:=Length(S1)-Length(S2);
  271. end
  272. else
  273. result:=Length(S1)-Length(S2);
  274. end;
  275. Procedure fpc_AnsiStr_CheckZero(p : pointer);[Public,Alias : 'FPC_ANSISTR_CHECKZERO']; compilerproc;
  276. begin
  277. if p=nil then
  278. HandleErrorFrame(201,get_frame);
  279. end;
  280. Procedure fpc_AnsiStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_ANSISTR_RANGECHECK']; compilerproc;
  281. begin
  282. if (index>len) or (Index<1) then
  283. HandleErrorFrame(201,get_frame);
  284. end;
  285. Procedure fpc_AnsiStr_SetLength (Var S : AnsiString; l : SizeInt);[Public,Alias : 'FPC_ANSISTR_SETLENGTH']; compilerproc;
  286. {
  287. Sets The length of string S to L.
  288. Makes sure S is unique, and contains enough room.
  289. }
  290. Var
  291. Temp : Pointer;
  292. movelen : SizeInt;
  293. begin
  294. if (l>0) then
  295. begin
  296. if Pointer(S)=nil then
  297. begin
  298. { Need a complete new string...}
  299. Pointer(s):=NewAnsiString(l);
  300. end
  301. else if (PAnsiRec(Pointer(S)-FirstOff)^.Ref = 1) then
  302. begin
  303. Dec(Pointer(S),FirstOff);
  304. if AnsiRecLen+L>MemSize(Pointer(s)) then
  305. reallocmem(pointer(S),AnsiRecLen+L);
  306. Inc(Pointer(S),FirstOff);
  307. end
  308. else
  309. begin
  310. { Reallocation is needed... }
  311. Temp:=Pointer(NewAnsiString(L));
  312. if Length(S)>0 then
  313. begin
  314. if l < succ(length(s)) then
  315. movelen := l
  316. { also move terminating null }
  317. else movelen := succ(length(s));
  318. Move(Pointer(S)^,Temp^,movelen);
  319. end;
  320. fpc_ansistr_decr_ref(Pointer(S));
  321. Pointer(S):=Temp;
  322. end;
  323. { Force nil termination in case it gets shorter }
  324. PByte(Pointer(S)+l)^:=0;
  325. PAnsiRec(Pointer(S)-FirstOff)^.Len:=l;
  326. end
  327. else
  328. begin
  329. { Length=0 }
  330. if Pointer(S)<>nil then
  331. fpc_ansistr_decr_ref (Pointer(S));
  332. Pointer(S):=Nil;
  333. end;
  334. end;
  335. {$ifdef EXTRAANSISHORT}
  336. Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): SizeInt; compilerproc;
  337. {
  338. Compares a AnsiString with a ShortString;
  339. The result is
  340. <0 if S1<S2
  341. 0 if S1=S2
  342. >0 if S1>S2
  343. }
  344. Var
  345. i,MaxI,Temp : SizeInt;
  346. begin
  347. Temp:=0;
  348. i:=0;
  349. MaxI:=Length(AnsiString(S1));
  350. if MaxI>byte(S2[0]) then
  351. MaxI:=Byte(S2[0]);
  352. While (i<MaxI) and (Temp=0) do
  353. begin
  354. Temp:= PByte(S1+I)^ - Byte(S2[i+1]);
  355. inc(i);
  356. end;
  357. AnsiStr_ShortStr_Compare:=Temp;
  358. end;
  359. {$endif EXTRAANSISHORT}
  360. {*****************************************************************************
  361. Public functions, In interface.
  362. *****************************************************************************}
  363. function fpc_truely_ansistr_unique(Var S : Pointer): Pointer;
  364. Var
  365. SNew : Pointer;
  366. L : SizeInt;
  367. begin
  368. L:=PAnsiRec(Pointer(S)-FirstOff)^.len;
  369. SNew:=NewAnsiString (L);
  370. Move (Pointer(S)^,SNew^,L+1);
  371. PAnsiRec(SNew-FirstOff)^.len:=L;
  372. fpc_ansistr_decr_ref (Pointer(S)); { Thread safe }
  373. pointer(S):=SNew;
  374. pointer(result):=SNew;
  375. end;
  376. // MV: inline the basic checks for case that S is already unique.
  377. // Rest is too complex to inline, so factor that out as a call.
  378. Function fpc_ansistr_Unique(Var S : Pointer): Pointer; [Public,Alias : 'FPC_ANSISTR_UNIQUE']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  379. {
  380. Make sure reference count of S is 1,
  381. using copy-on-write semantics.
  382. }
  383. begin
  384. pointer(result) := pointer(s);
  385. If Pointer(S)=Nil then
  386. exit;
  387. if PAnsiRec(Pointer(S)-Firstoff)^.Ref<>1 then
  388. fpc_truely_ansistr_unique(s);
  389. end;
  390. Procedure fpc_ansistr_append_char(Var S : AnsiString;c : char); [Public,Alias : 'FPC_ANSISTR_APPEND_CHAR']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  391. begin
  392. SetLength(S,length(S)+1);
  393. S[length(S)]:=c;
  394. PByte(Pointer(S)+length(S))^:=0; { Terminating Zero }
  395. end;
  396. Procedure fpc_ansistr_append_shortstring(Var S : AnsiString;Str : ShortString); [Public,Alias : 'FPC_ANSISTR_APPEND_SHORTSTRING']; compilerproc;
  397. var
  398. ofs : SizeInt;
  399. begin
  400. if Str='' then
  401. exit;
  402. ofs:=Length(S);
  403. SetLength(S,ofs+length(Str));
  404. move(Str[1],S[ofs+1],length(Str));
  405. PByte(Pointer(S)+length(S))^:=0; { Terminating Zero }
  406. end;
  407. Procedure fpc_ansistr_append_ansistring(Var S : AnsiString;Str : AnsiString); [Public,Alias : 'FPC_ANSISTR_APPEND_ANSISTRING']; compilerproc;
  408. var
  409. ofs : SizeInt;
  410. begin
  411. if Str='' then
  412. exit;
  413. ofs:=Length(S);
  414. SetLength(S,ofs+length(Str));
  415. move(Str[1],S[ofs+1],length(Str)+1);
  416. end;
  417. Function Fpc_Ansistr_Copy (Const S : AnsiString; Index,Size : SizeInt) : AnsiString;compilerproc;
  418. var
  419. ResultAddress : Pointer;
  420. begin
  421. ResultAddress:=Nil;
  422. dec(index);
  423. if Index < 0 then
  424. Index := 0;
  425. { Check Size. Accounts for Zero-length S, the double check is needed because
  426. Size can be maxint and will get <0 when adding index }
  427. if (Size>Length(S)) or
  428. (Index+Size>Length(S)) then
  429. Size:=Length(S)-Index;
  430. If Size>0 then
  431. begin
  432. If Index<0 Then
  433. Index:=0;
  434. ResultAddress:=Pointer(NewAnsiString (Size));
  435. if ResultAddress<>Nil then
  436. begin
  437. Move (Pointer(Pointer(S)+index)^,ResultAddress^,Size);
  438. PAnsiRec(ResultAddress-FirstOff)^.Len:=Size;
  439. PByte(ResultAddress+Size)^:=0;
  440. end;
  441. end;
  442. Pointer(fpc_ansistr_Copy):=ResultAddress;
  443. end;
  444. Function Pos (Const Substr : ShortString; Const Source : AnsiString) : SizeInt;
  445. var
  446. i,MaxLen : SizeInt;
  447. pc : pchar;
  448. begin
  449. Pos:=0;
  450. if Length(SubStr)>0 then
  451. begin
  452. MaxLen:=Length(source)-Length(SubStr);
  453. i:=0;
  454. pc:=@source[1];
  455. while (i<=MaxLen) do
  456. begin
  457. inc(i);
  458. if (SubStr[1]=pc^) and
  459. (CompareByte(Substr[1],pc^,Length(SubStr))=0) then
  460. begin
  461. Pos:=i;
  462. exit;
  463. end;
  464. inc(pc);
  465. end;
  466. end;
  467. end;
  468. Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : SizeInt;
  469. var
  470. i,MaxLen : SizeInt;
  471. pc : pchar;
  472. begin
  473. Pos:=0;
  474. if Length(SubStr)>0 then
  475. begin
  476. MaxLen:=Length(source)-Length(SubStr);
  477. i:=0;
  478. pc:=@source[1];
  479. while (i<=MaxLen) do
  480. begin
  481. inc(i);
  482. if (SubStr[1]=pc^) and
  483. (CompareByte(Substr[1],pc^,Length(SubStr))=0) then
  484. begin
  485. Pos:=i;
  486. exit;
  487. end;
  488. inc(pc);
  489. end;
  490. end;
  491. end;
  492. { Faster version for a char alone. Must be implemented because }
  493. { pos(c: char; const s: shortstring) also exists, so otherwise }
  494. { using pos(char,pchar) will always call the shortstring version }
  495. { (exact match for first argument), also with $h+ (JM) }
  496. Function Pos (c : Char; Const s : AnsiString) : SizeInt;
  497. var
  498. i: SizeInt;
  499. pc : pchar;
  500. begin
  501. pc:=@s[1];
  502. for i:=1 to length(s) do
  503. begin
  504. if pc^=c then
  505. begin
  506. pos:=i;
  507. exit;
  508. end;
  509. inc(pc);
  510. end;
  511. pos:=0;
  512. end;
  513. Function fpc_Val_Real_AnsiStr(Const S : AnsiString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  514. Var
  515. SS : String;
  516. begin
  517. fpc_Val_Real_AnsiStr := 0;
  518. if length(S) > 255 then
  519. code := 256
  520. else
  521. begin
  522. SS := S;
  523. Val(SS,fpc_Val_Real_AnsiStr,code);
  524. end;
  525. end;
  526. Function fpc_Val_UInt_AnsiStr (Const S : AnsiString; Var Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_ANSISTR']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  527. Var
  528. SS : ShortString;
  529. begin
  530. fpc_Val_UInt_AnsiStr := 0;
  531. if length(S) > 255 then
  532. code := 256
  533. else
  534. begin
  535. SS := S;
  536. Val(SS,fpc_Val_UInt_AnsiStr,code);
  537. end;
  538. end;
  539. Function fpc_Val_SInt_AnsiStr (DestSize: SizeInt; Const S : AnsiString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_ANSISTR']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  540. Var
  541. SS : ShortString;
  542. begin
  543. fpc_Val_SInt_AnsiStr:=0;
  544. if length(S)>255 then
  545. code:=256
  546. else
  547. begin
  548. SS := S;
  549. fpc_Val_SInt_AnsiStr := int_Val_SInt_ShortStr(DestSize,SS,Code);
  550. end;
  551. end;
  552. {$ifndef CPU64}
  553. Function fpc_Val_qword_AnsiStr (Const S : AnsiString; Var Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_ANSISTR']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  554. Var
  555. SS : ShortString;
  556. begin
  557. fpc_Val_qword_AnsiStr:=0;
  558. if length(S)>255 then
  559. code:=256
  560. else
  561. begin
  562. SS := S;
  563. Val(SS,fpc_Val_qword_AnsiStr,Code);
  564. end;
  565. end;
  566. Function fpc_Val_int64_AnsiStr (Const S : AnsiString; Var Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_ANSISTR']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  567. Var
  568. SS : ShortString;
  569. begin
  570. fpc_Val_int64_AnsiStr:=0;
  571. if length(S)>255 then
  572. code:=256
  573. else
  574. begin
  575. SS := s;
  576. Val(SS,fpc_Val_int64_AnsiStr,Code);
  577. end;
  578. end;
  579. {$endif CPU64}
  580. procedure fpc_AnsiStr_Float(d : ValReal;len,fr,rt : SizeInt;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  581. var
  582. ss: ShortString;
  583. begin
  584. str_real(len,fr,d,treal_type(rt),ss);
  585. s:=ss;
  586. end;
  587. Procedure fpc_AnsiStr_UInt(v : ValUInt;Len : SizeInt; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_VALUINT']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  588. Var
  589. SS : ShortString;
  590. begin
  591. str(v:Len,SS);
  592. S:=SS;
  593. end;
  594. Procedure fpc_AnsiStr_SInt(v : ValSInt;Len : SizeInt; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_VALSINT']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  595. Var
  596. SS : ShortString;
  597. begin
  598. str (v:Len,SS);
  599. S:=SS;
  600. end;
  601. {$ifndef CPU64}
  602. Procedure fpc_AnsiStr_QWord(v : QWord;Len : SizeInt; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_QWORD']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  603. Var
  604. SS : ShortString;
  605. begin
  606. str(v:Len,SS);
  607. S:=SS;
  608. end;
  609. Procedure fpc_AnsiStr_Int64(v : Int64; Len : SizeInt; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_INT64']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF}
  610. Var
  611. SS : ShortString;
  612. begin
  613. str (v:Len,SS);
  614. S:=SS;
  615. end;
  616. {$endif CPU64}
  617. Procedure Delete (Var S : AnsiString; Index,Size: SizeInt);
  618. Var
  619. LS : SizeInt;
  620. begin
  621. ls:=Length(S);
  622. If (Index>LS) or (Index<=0) or (Size<=0) then
  623. exit;
  624. UniqueString (S);
  625. If (Size>LS-Index) then // Size+Index gives overflow ??
  626. Size:=LS-Index+1;
  627. If (Size<=LS-Index) then
  628. begin
  629. Dec(Index);
  630. Move(PByte(Pointer(S))[Index+Size],PByte(Pointer(S))[Index],LS-Index-Size+1);
  631. end;
  632. Setlength(S,LS-Size);
  633. end;
  634. Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : SizeInt);
  635. var
  636. Temp : AnsiString;
  637. LS : SizeInt;
  638. begin
  639. If Length(Source)=0 then
  640. exit;
  641. if index <= 0 then
  642. index := 1;
  643. Ls:=Length(S);
  644. if index > LS then
  645. index := LS+1;
  646. Dec(Index);
  647. Pointer(Temp) := NewAnsiString(Length(Source)+LS);
  648. SetLength(Temp,Length(Source)+LS);
  649. If Index>0 then
  650. move (Pointer(S)^,Pointer(Temp)^,Index);
  651. Move (Pointer(Source)^,PByte(Temp)[Index],Length(Source));
  652. If (LS-Index)>0 then
  653. Move(PByte(Pointer(S))[Index],PByte(temp)[Length(Source)+index],LS-Index);
  654. S:=Temp;
  655. end;
  656. Function StringOfChar(c : char;l : SizeInt) : AnsiString;
  657. begin
  658. SetLength(StringOfChar,l);
  659. FillChar(Pointer(StringOfChar)^,Length(StringOfChar),c);
  660. end;
  661. Procedure SetString (Var S : AnsiString; Buf : PChar; Len : SizeInt); {$IFNDEF VER2_0} Inline; {$ENDIF}
  662. begin
  663. SetLength(S,Len);
  664. If (Buf<>Nil) then
  665. begin
  666. Move (Buf[0],S[1],Len);
  667. end;
  668. end;
  669. function upcase(const s : ansistring) : ansistring;
  670. var
  671. i : SizeInt;
  672. begin
  673. Setlength(result,length(s));
  674. for i := 1 to length (s) do
  675. result[i] := upcase(s[i]);
  676. end;
  677. function lowercase(const s : ansistring) : ansistring;
  678. var
  679. i : SizeInt;
  680. begin
  681. Setlength(result,length(s));
  682. for i := 1 to length (s) do
  683. result[i] := lowercase(s[i]);
  684. end;