astrings.inc 20 KB

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