astrings.inc 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1993,97 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. {
  14. This file contains the implementation of the AnsiString type,
  15. and all things that are needed for it.
  16. AnsiString is defined as a 'silent' pchar :
  17. a pchar that points to :
  18. @-12 : Longint for maximum size;
  19. @-8 : Longint for size;
  20. @-4 : Longint for reference count;
  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. Maxlen,
  31. len,
  32. ref : Longint;
  33. First : Char;
  34. end;
  35. Const
  36. AnsiRecLen = SizeOf(TAnsiRec);
  37. FirstOff = SizeOf(TAnsiRec)-1;
  38. {****************************************************************************
  39. Internal functions, not in interface.
  40. ****************************************************************************}
  41. {$ifdef AnsiStrDebug}
  42. Procedure DumpAnsiRec(S : Pointer);
  43. begin
  44. If S=Nil then
  45. Writeln ('String is nil')
  46. Else
  47. Begin
  48. With PAnsiRec(S-Firstoff)^ do
  49. begin
  50. Write ('(Maxlen: ',maxlen);
  51. Write (' Len:',len);
  52. Writeln (' Ref: ',ref,')');
  53. end;
  54. end;
  55. end;
  56. {$endif}
  57. Function NewAnsiString(Len : Longint) : Pointer;
  58. {
  59. Allocate a new AnsiString on the heap.
  60. initialize it to zero length and reference count 1.
  61. }
  62. Var
  63. P : Pointer;
  64. begin
  65. { Also add +1 for a terminating zero }
  66. GetMem(P,Len+AnsiRecLen);
  67. If P<>Nil then
  68. begin
  69. PAnsiRec(P)^.Maxlen:=Len; { Maximal length }
  70. PAnsiRec(P)^.Len:=0; { Initial length }
  71. PAnsiRec(P)^.Ref:=1; { Set reference count }
  72. PAnsiRec(P)^.First:=#0; { Terminating #0 }
  73. P:=P+FirstOff; { Points to string now }
  74. end;
  75. NewAnsiString:=P;
  76. end;
  77. Procedure DisposeAnsiString(Var S : Pointer);
  78. {
  79. Deallocates a AnsiString From the heap.
  80. }
  81. begin
  82. If S=Nil then
  83. exit;
  84. Dec (Longint(S),FirstOff);
  85. FreeMem (S,PAnsiRec(S)^.Maxlen+AnsiRecLen);
  86. S:=Nil;
  87. end;
  88. Procedure AnsiStr_Decr_Ref (Var S : Pointer);[Public,Alias:'FPC_ANSISTR_DECR_REF'];
  89. {
  90. Decreases the ReferenceCount of a non constant ansistring;
  91. If the reference count is zero, deallocate the string;
  92. }
  93. Type
  94. plongint = ^longint;
  95. Var
  96. l : plongint;
  97. Begin
  98. { Zero string }
  99. If S=Nil then exit;
  100. { check for constant strings ...}
  101. l:=@PANSIREC(S-FirstOff)^.Ref;
  102. If l^<0 then exit;
  103. Dec(l^);
  104. If l^=0 then
  105. { Ref count dropped to zero }
  106. DisposeAnsiString (S); { Remove...}
  107. { this pointer is not valid anymore, so set it to zero }
  108. S:=nil;
  109. end;
  110. Procedure AnsiStr_Incr_Ref (Var S : Pointer);[Public,Alias:'FPC_ANSISTR_INCR_REF'];
  111. Begin
  112. If S=Nil then
  113. exit;
  114. { Let's be paranoid : Constant string ??}
  115. If PAnsiRec(S-FirstOff)^.Ref<0 then exit;
  116. Inc(PAnsiRec(S-FirstOff)^.Ref);
  117. end;
  118. Procedure AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[Public,Alias:'FPC_ANSISTR_ASSIGN'];
  119. {
  120. Assigns S2 to S1 (S1:=S2), taking in account reference counts.
  121. }
  122. begin
  123. If S2<>nil then
  124. If PAnsiRec(S2-FirstOff)^.Ref>0 then
  125. Inc(PAnsiRec(S2-FirstOff)^.ref);
  126. { Decrease the reference count on the old S1 }
  127. ansistr_decr_ref (S1);
  128. { And finally, have S1 pointing to S2 (or its copy) }
  129. S1:=S2;
  130. end;
  131. Procedure AnsiStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC_ANSISTR_CONCAT'];
  132. {
  133. Concatenates 2 AnsiStrings : S1+S2.
  134. Result Goes to S3;
  135. }
  136. Var
  137. Size,Location : Longint;
  138. begin
  139. if S3<>nil then
  140. begin
  141. AnsiStr_Decr_Ref(S3);
  142. S3:=nil;
  143. end;
  144. if (S1=Nil) then
  145. AnsiStr_Assign(S3,S2)
  146. else
  147. if (S2=Nil) then
  148. AnsiStr_Assign(S3,S1)
  149. else
  150. begin
  151. Size:=PAnsiRec(S2-FirstOff)^.Len;
  152. Location:=Length(AnsiString(S1));
  153. SetLength (AnsiString(S3),Size+Location);
  154. Move (S1^,S3^,Location);
  155. Move (S2^,(S3+location)^,Size+1);
  156. end;
  157. end;
  158. Procedure AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString);
  159. {
  160. Concatenates a Ansi with a short string; : S2 + S2
  161. }
  162. Var
  163. Size,Location : Longint;
  164. begin
  165. Size:=Length(S2);
  166. Location:=Length(S1);
  167. If Size=0 then
  168. exit;
  169. { Setlength takes case of uniqueness
  170. and alllocated memory. We need to use length,
  171. to take into account possibility of S1=Nil }
  172. SetLength (S1,Size+Length(S1));
  173. Move (S2[1],Pointer(Pointer(S1)+Location)^,Size);
  174. PByte( Pointer(S1)+length(S1) )^:=0; { Terminating Zero }
  175. end;
  176. Procedure AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR'];
  177. {
  178. Converts a AnsiString to a ShortString;
  179. }
  180. Var
  181. Size : Longint;
  182. begin
  183. if S2=nil then
  184. S1:=''
  185. else
  186. begin
  187. Size:=PAnsiRec(S2-FirstOff)^.Len;
  188. If Size>high(S1) then
  189. Size:=high(S1);
  190. Move (S2^,S1[1],Size);
  191. byte(S1[0]):=Size;
  192. end;
  193. end;
  194. Procedure ShortStr_To_AnsiStr (Var S1 : Pointer; Const S2 : ShortString);[Public, alias: 'FPC_SHORTSTR_TO_ANSISTR'];
  195. {
  196. Converts a ShortString to a AnsiString;
  197. }
  198. Var
  199. Size : Longint;
  200. begin
  201. Size:=Length(S2);
  202. Setlength (AnsiString(S1),Size);
  203. if Size>0 then
  204. begin
  205. Move (S2[1],Pointer(S1)^,Size);
  206. { Terminating Zero }
  207. PByte(Pointer(S1)+Size)^:=0;
  208. end;
  209. end;
  210. Procedure Char_To_AnsiStr(var S1 : Pointer; c : Char);[Public, alias: 'FPC_CHAR_TO_ANSISTR'];
  211. {
  212. Converts a ShortString to a AnsiString;
  213. }
  214. begin
  215. Setlength (AnsiString(S1),1);
  216. PByte(Pointer(S1))^:=byte(c);
  217. { Terminating Zero }
  218. PByte(Pointer(S1)+1)^:=0;
  219. end;
  220. Procedure PChar_To_AnsiStr(var a : ansistring;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_ANSISTR'];
  221. Var
  222. L : Longint;
  223. begin
  224. if pointer(a)<>nil then
  225. begin
  226. AnsiStr_Decr_Ref(Pointer(a));
  227. pointer(a):=nil;
  228. end;
  229. if (not assigned(p)) or (p[0]=#0) Then
  230. Pointer(a):=nil
  231. else
  232. begin
  233. //!! Horribly inneficient, but I see no other way...
  234. L:=1;
  235. While P[l]<>#0 do
  236. inc (l);
  237. Pointer(a):=NewAnsistring(L);
  238. SetLength(A,L);
  239. Move (P[0],Pointer(A)^,L)
  240. end;
  241. end;
  242. Procedure CharArray_To_AnsiStr(var a : ansistring;p : pchar;l:longint);[Public,Alias : 'FPC_CHARARRAY_TO_ANSISTR'];
  243. var
  244. i : longint;
  245. hp : pchar;
  246. begin
  247. if p[0]=#0 Then
  248. Pointer(a):=nil
  249. else
  250. begin
  251. Pointer(a):=NewAnsistring(L);
  252. hp:=p;
  253. i:=0;
  254. while (i<l) and (hp^<>#0) do
  255. begin
  256. inc(hp);
  257. inc(i);
  258. end;
  259. SetLength(A,i);
  260. Move (P[0],Pointer(A)^,i)
  261. end;
  262. end;
  263. Function AnsiStr_Compare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_ANSISTR_COMPARE'];
  264. {
  265. Compares 2 AnsiStrings;
  266. The result is
  267. <0 if S1<S2
  268. 0 if S1=S2
  269. >0 if S1>S2
  270. }
  271. Var
  272. i,MaxI,Temp : Longint;
  273. begin
  274. i:=0;
  275. Maxi:=Length(AnsiString(S1));
  276. temp:=Length(AnsiString(S2));
  277. If MaxI>Temp then
  278. MaxI:=Temp;
  279. Temp:=0;
  280. While (i<MaxI) and (Temp=0) do
  281. begin
  282. Temp:= PByte(S1+I)^ - PByte(S2+i)^;
  283. inc(i);
  284. end;
  285. if temp=0 then
  286. temp:=Length(AnsiString(S1))-Length(AnsiString(S2));
  287. AnsiStr_Compare:=Temp;
  288. end;
  289. Procedure AnsiStr_CheckZero(p : pointer);[Public,Alias : 'FPC_ANSISTR_CHECKZERO'];
  290. begin
  291. if p=nil then
  292. HandleErrorFrame(201,get_frame);
  293. end;
  294. Procedure AnsiStr_CheckRange(len,index : longint);[Public,Alias : 'FPC_ANSISTR_RANGECHECK'];
  295. begin
  296. if (index>len) or (Index<1) then
  297. HandleErrorFrame(201,get_frame);
  298. end;
  299. Function AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): Longint;
  300. {
  301. Compares a AnsiString with a ShortString;
  302. The result is
  303. <0 if S1<S2
  304. 0 if S1=S2
  305. >0 if S1>S2
  306. }
  307. Var
  308. i,MaxI,Temp : Longint;
  309. begin
  310. Temp:=0;
  311. i:=0;
  312. MaxI:=Length(AnsiString(S1));
  313. if MaxI>byte(S2[0]) then
  314. MaxI:=Byte(S2[0]);
  315. While (i<MaxI) and (Temp=0) do
  316. begin
  317. Temp:= PByte(S1+I)^ - Byte(S2[i+1]);
  318. inc(i);
  319. end;
  320. AnsiStr_ShortStr_Compare:=Temp;
  321. end;
  322. {*****************************************************************************
  323. Public functions, In interface.
  324. *****************************************************************************}
  325. Function Length (Const S : AnsiString) : Longint;
  326. {
  327. Returns the length of an AnsiString.
  328. Takes in acount that zero strings are NIL;
  329. }
  330. begin
  331. If Pointer(S)=Nil then
  332. Length:=0
  333. else
  334. Length:=PAnsiRec(Pointer(S)-FirstOff)^.Len;
  335. end;
  336. Procedure SetLength (Var S : AnsiString; l : Longint);
  337. {
  338. Sets The length of string S to L.
  339. Makes sure S is unique, and contains enough room.
  340. }
  341. Var
  342. Temp : Pointer;
  343. begin
  344. if (l>0) then
  345. begin
  346. if Pointer(S)=nil then
  347. begin
  348. { Need a complete new string...}
  349. Pointer(s):=NewAnsiString(l);
  350. end
  351. else
  352. If (PAnsiRec(Pointer(S)-FirstOff)^.Maxlen < L) or
  353. (PAnsiRec(Pointer(S)-FirstOff)^.Ref <> 1) then
  354. begin
  355. { Reallocation is needed... }
  356. Temp:=Pointer(NewAnsiString(L));
  357. if Length(S)>0 then
  358. Move(Pointer(S)^,Temp^,L);
  359. ansistr_decr_ref(Pointer(S));
  360. Pointer(S):=Temp;
  361. end;
  362. { Force nil termination in case it gets shorter }
  363. PByte(Pointer(S)+l)^:=0;
  364. PAnsiRec(Pointer(S)-FirstOff)^.Len:=l;
  365. end
  366. else
  367. begin
  368. { Length=0 }
  369. if Pointer(S)<>nil then
  370. ansistr_decr_ref (Pointer(S));
  371. Pointer(S):=Nil;
  372. end;
  373. end;
  374. Procedure UniqueAnsiString(Var S : AnsiString); [Public,Alias : 'FPC_ANSISTR_UNIQUE'];
  375. {
  376. Make sure reference count of S is 1,
  377. using copy-on-write semantics.
  378. }
  379. Var
  380. SNew : Pointer;
  381. begin
  382. If Pointer(S)=Nil then
  383. exit;
  384. if PAnsiRec(Pointer(S)-Firstoff)^.Ref<>1 then
  385. begin
  386. SNew:=NewAnsiString (PAnsiRec(Pointer(S)-FirstOff)^.len);
  387. Move (Pointer(S)^,SNew^,PAnsiRec(Pointer(S)-FirstOff)^.len+1);
  388. PAnsiRec(SNew-FirstOff)^.len:=PAnsiRec(Pointer(S)-FirstOff)^.len;
  389. ansistr_decr_ref (Pointer(S)); { Thread safe }
  390. Pointer(S):=SNew;
  391. end;
  392. end;
  393. Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString;
  394. var
  395. ResultAddress : Pointer;
  396. begin
  397. ResultAddress:=Nil;
  398. dec(index);
  399. { Check Size. Accounts for Zero-length S }
  400. if Length(S)<Index+Size then
  401. Size:=Length(S)-Index;
  402. If Size>0 then
  403. begin
  404. If Index<0 Then
  405. Index:=0;
  406. ResultAddress:=Pointer(NewAnsiString (Size));
  407. if ResultAddress<>Nil then
  408. begin
  409. Move (Pointer(Pointer(S)+index)^,ResultAddress^,Size);
  410. PAnsiRec(ResultAddress-FirstOff)^.Len:=Size;
  411. PByte(ResultAddress+Size)^:=0;
  412. end;
  413. end;
  414. Pointer(Copy):=ResultAddress;
  415. end;
  416. Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint;
  417. var
  418. i,j : longint;
  419. e : boolean;
  420. S : AnsiString;
  421. se : Pointer;
  422. begin
  423. i := 0;
  424. j := 0;
  425. e := true;
  426. if Length(SubStr)=0 then e := false;
  427. while (e) and (i <= length (Source) - length (substr)) do
  428. begin
  429. inc (i);
  430. S:=copy(Source,i,length(Substr));
  431. Se:=pointer(SubStr);
  432. if AnsiStr_Compare(se,Pointer(S))=0 then
  433. begin
  434. j := i;
  435. e := false;
  436. end;
  437. end;
  438. pos := j;
  439. end;
  440. {$IfDef ValInternCompiled}
  441. Function ValAnsiFloat(Const S : AnsiString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR'];
  442. Var
  443. SS : String;
  444. begin
  445. AnsiStr_To_ShortStr(SS,Pointer(S));
  446. ValAnsiFloat := ValFloat(SS,Code);
  447. end;
  448. Function ValAnsiUnsigendInt (Const S : AnsiString; Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_ANSISTR'];
  449. Var
  450. SS : ShortString;
  451. begin
  452. AnsiStr_To_ShortStr(SS,Pointer(S));
  453. ValAnsiUnsigendInt := ValUnsignedInt(SS,Code);
  454. end;
  455. Function ValAnsiSignedInt (DestSize: longint; Const S : AnsiString; Var Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_ANSISTR'];
  456. Var
  457. SS : ShortString;
  458. begin
  459. AnsiStr_To_ShortStr (SS,Pointer(S));
  460. ValAnsiSignedInt := ValSignedInt(DestSize,SS,Code);
  461. end;
  462. {$IfDef SUPPORT_FIXED}
  463. Function ValAnsiFixed(Const S : AnsiString; Var Code : ValSint): ValReal; [public, alias:'FPC_VAL_FIXED_ANSISTR'];
  464. Var
  465. SS : String;
  466. begin
  467. AnsiStr_To_ShortStr (SS,Pointer(S));
  468. ValAnsiFixed := Fixed(ValFloat(SS,Code));
  469. end;
  470. {$EndIf SUPPORT_FIXED}
  471. {$Else ValInternCompiled}
  472. Procedure Val (Const S : AnsiString; var R : real; Var Code : Integer);
  473. Var
  474. SS : String;
  475. begin
  476. AnsiStr_To_ShortStr (SS,Pointer(S));
  477. Val(SS,R,Code);
  478. end;
  479. {
  480. Procedure Val (var S : AnsiString; var D : Double; Var Code : Integer);
  481. Var SS : ShortString;
  482. begin
  483. AnsiStr_To_ShortStr (SS,S);
  484. Val(SS,D,Code);
  485. end;
  486. }
  487. Procedure Val (Const S : AnsiString; var E : Extended; Code : Integer);
  488. Var SS : ShortString;
  489. begin
  490. AnsiStr_To_ShortStr (SS,Pointer(S));
  491. Val(SS,E,Code);
  492. end;
  493. Procedure Val (Const S : AnsiString; var C : Cardinal; Code : Integer);
  494. Var SS : ShortString;
  495. begin
  496. AnsiStr_To_ShortStr (SS,Pointer(S));
  497. Val(SS,C,Code);
  498. end;
  499. Procedure Val (Const S : AnsiString; var L : Longint; Var Code : Integer);
  500. Var SS : ShortString;
  501. begin
  502. AnsiStr_To_ShortStr (SS,Pointer(S));
  503. Val(SS,L,Code);
  504. end;
  505. Procedure Val (Const S : AnsiString; var W : Word; Var Code : Integer);
  506. Var SS : ShortString;
  507. begin
  508. AnsiStr_To_ShortStr (SS,Pointer(S));
  509. Val(SS,W,Code);
  510. end;
  511. Procedure Val (Const S : AnsiString; var I : Integer; Var Code : Integer);
  512. Var SS : ShortString;
  513. begin
  514. AnsiStr_To_ShortStr (SS,Pointer(S));
  515. Val(SS,I,Code);
  516. end;
  517. Procedure Val (Const S : AnsiString; var B : Byte; Var Code : Integer);
  518. Var SS : ShortString;
  519. begin
  520. AnsiStr_To_ShortStr (SS,Pointer(S));
  521. Val(SS,B,Code);
  522. end;
  523. Procedure Val (Const S : AnsiString; var SI : ShortInt; Var Code : Integer);
  524. Var SS : ShortString;
  525. begin
  526. AnsiStr_To_ShortStr (SS,Pointer(S));
  527. Val(SS,SI,Code);
  528. end;
  529. {$EndIf ValInternCompiled}
  530. {$ifdef INTERNDOUBLE}
  531. procedure AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT'];
  532. var
  533. ss : shortstring;
  534. begin
  535. str_real(len,fr,d,treal_type(rt),ss);
  536. s:=ss;
  537. end;
  538. {$else INTERNDOUBLE}
  539. Procedure ACoStr (Co : Comp;Len,fr: Longint; Var S : AnsiString);
  540. [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI_'{$endif}+'COMP'];
  541. Var SS : ShortString;
  542. begin
  543. ShortStr_comp (Co,Len,fr,SS);
  544. S:=SS;
  545. end;
  546. Procedure ASiStr (Si : Single;Len,fr: Longint; Var S : AnsiString);
  547. [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_SINGLE'];
  548. Var SS : ShortString;
  549. begin
  550. ShortStr_Single (Si,Len,fr,SS);
  551. S:=SS;
  552. end;
  553. {$IfDef Support_Fixed}
  554. Procedure AFiStr (fi : Comp;Len,fr: Longint; Var S : AnsiString);
  555. [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_FIXED'];
  556. Var SS : ShortString;
  557. begin
  558. ShortStr_Fixed (fi,Len,fr,SS);
  559. S:=SS;
  560. end;
  561. {$EndIf Support_Fixed}
  562. Procedure ARStr (D : Real;Len,fr: Longint; Var S : AnsiString);
  563. [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_REAL'];
  564. Var SS : ShortString;
  565. begin
  566. ShortStr_real (D,Len,fr,SS);
  567. S:=SS;
  568. end;
  569. Procedure AEStr (E : Extended;Len,Fr: Longint; Var S : AnsiString);
  570. [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_EXTENDED'];
  571. Var SS : ShortString;
  572. begin
  573. ShortStr_Extended (E,Len,fr,SS);
  574. S:=SS;
  575. end;
  576. {$endif INTERNDOUBLE}
  577. Procedure ACStr (C : Cardinal;Len : Longint; Var S : AnsiString);
  578. [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_CARDINAL'];
  579. Var SS : ShortString;
  580. begin
  581. int_str_cardinal(C,Len,SS);
  582. S:=SS;
  583. end;
  584. Procedure ALStr (L : Longint; Len : Longint; Var S : AnsiString);
  585. [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_LONGINT'];
  586. Var SS : ShortString;
  587. begin
  588. int_Str_Longint (L,Len,SS);
  589. S:=SS;
  590. end;
  591. Procedure Delete (Var S : AnsiString; Index,Size: Longint);
  592. Var LS : Longint;
  593. begin
  594. If Length(S)=0 then exit;
  595. if index<=0 then
  596. begin
  597. Size:=Size+index-1;
  598. index:=1;
  599. end;
  600. LS:=PAnsiRec(Pointer(S)-FirstOff)^.Len;
  601. if (Index<=LS) and (Size>0) then
  602. begin
  603. UniqueAnsiString (S);
  604. if Size+Index>LS then
  605. Size:=LS-Index+1;
  606. if Index+Size<=LS then
  607. begin
  608. Dec(Index);
  609. Move(PByte(Pointer(S))[Index+Size],
  610. PByte(Pointer(S))[Index],LS-Index+1);
  611. end;
  612. Setlength(s,LS-Size);
  613. end;
  614. end;
  615. Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint);
  616. var Temp : AnsiString;
  617. LS : Longint;
  618. begin
  619. If Length(Source)=0 then exit;
  620. if index <= 0 then index := 1;
  621. Ls:=Length(S);
  622. if index > LS then index := LS+1;
  623. Dec(Index);
  624. Pointer(Temp) := NewAnsiString(Length(Source)+LS);
  625. SetLength(Temp,Length(Source)+LS);
  626. If Index>0 then
  627. move (Pointer(S)^,Pointer(Temp)^,Index);
  628. Move (Pointer(Source)^,PByte(Temp)[Index],Length(Source));
  629. If (LS-Index)>0 then
  630. Move(PByte(Pointer(S))[Index],PByte(temp)[Length(Source)+index],LS-Index);
  631. S:=Temp;
  632. end;
  633. {
  634. $Log$
  635. Revision 1.29 1999-06-14 00:47:33 peter
  636. * merged
  637. Revision 1.28.2.1 1999/06/14 00:39:07 peter
  638. * setlength finally fixed when l < length(s)
  639. Revision 1.28 1999/06/09 23:00:16 peter
  640. * small ansistring fixes
  641. * val_ansistr_sint destsize changed to longint
  642. * don't write low/hi ascii with -al
  643. Revision 1.27 1999/06/05 20:48:56 michael
  644. Copy checks index now for negative values.
  645. Revision 1.26 1999/05/31 20:37:39 peter
  646. * fixed decr_ansistr which didn't set s to nil
  647. Revision 1.25 1999/05/17 22:41:24 florian
  648. * small fixes for the new ansistring temp. management
  649. Revision 1.24 1999/05/17 21:52:35 florian
  650. * most of the Object Pascal stuff moved to the system unit
  651. Revision 1.23 1999/05/06 09:05:11 peter
  652. * generic write_float str_float
  653. Revision 1.22 1999/04/22 10:51:17 peter
  654. * fixed pchar 2 ansi
  655. Revision 1.21 1999/04/13 09:02:06 michael
  656. + 1 byte too much allocated in new_ansiStringastrings.inc
  657. Revision 1.20 1999/04/09 07:33:15 michael
  658. * More fixes and optimizing for ansistr_concat
  659. Revision 1.19 1999/04/08 15:57:53 peter
  660. + subrange checking for readln()
  661. Revision 1.18 1999/04/08 10:19:55 peter
  662. * fixed concat when s1 or s2 was nil
  663. Revision 1.17 1999/04/06 11:23:58 peter
  664. * fixed insert on last char
  665. * saver chararray 2 ansi
  666. Revision 1.16 1999/04/06 10:06:51 michael
  667. * Fixed chararray to ansistring conversion
  668. Revision 1.15 1999/04/01 22:00:48 peter
  669. * universal names for str/val (ansistr instead of stransi)
  670. * '1.' support for val() this is compatible with tp7
  671. Revision 1.14 1999/03/16 17:49:40 jonas
  672. * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
  673. * in text.inc: changed RTE 106 when read integer values are out of bounds to RTE 201
  674. * in systemh.inc: disabled "support_fixed" for the i386 because it gave internal errors,
  675. Revision 1.13 1999/03/02 18:24:51 peter
  676. * function names cleanup
  677. + chararray -> ansistring
  678. Revision 1.12 1999/03/01 15:41:02 peter
  679. * use external names
  680. * removed all direct assembler modes
  681. Revision 1.11 1999/02/04 14:55:42 michael
  682. * Fixed pos
  683. Revision 1.10 1999/02/04 10:49:21 florian
  684. + routines for range checking added
  685. Revision 1.9 1999/02/02 11:37:34 peter
  686. * fixed ansi2short
  687. Revision 1.8 1999/01/06 14:48:43 michael
  688. + Implemented more str() functions
  689. Revision 1.7 1999/01/06 13:03:39 peter
  690. * fixed str() and made it working
  691. Revision 1.6 1999/01/06 12:25:02 florian
  692. * naming for str(...) routines inserted
  693. * don't know what in int64 changed
  694. Revision 1.5 1998/12/15 22:43:01 peter
  695. * removed temp symbols
  696. Revision 1.4 1998/11/18 10:56:46 michael
  697. + Fixed pchar2ansi
  698. Revision 1.3 1998/11/17 12:16:07 michael
  699. + Fixed copy. Now reference count is correct
  700. Revision 1.2 1998/11/17 11:33:22 peter
  701. + several checks for empty string
  702. Revision 1.1 1998/11/17 10:34:18 michael
  703. + renamed from astrings.pp to astrings.inc
  704. Revision 1.34 1998/11/17 00:41:11 peter
  705. * renamed string functions
  706. Revision 1.33 1998/11/16 15:42:04 peter
  707. + char2ansi
  708. Revision 1.32 1998/11/16 11:11:47 michael
  709. + Fix for Insert and Delete functions
  710. Revision 1.31 1998/11/13 14:37:11 michael
  711. + Insert procedure corrected
  712. Revision 1.30 1998/11/05 14:20:36 peter
  713. * removed warnings
  714. Revision 1.29 1998/11/04 20:34:04 michael
  715. + Removed ifdef useansistrings
  716. Revision 1.28 1998/11/04 15:39:44 michael
  717. + Small fixes to assign and add
  718. Revision 1.27 1998/11/04 10:20:48 peter
  719. * ansistring fixes
  720. Revision 1.26 1998/11/02 09:46:12 michael
  721. + Fix for assign of null string
  722. Revision 1.25 1998/10/30 21:42:48 michael
  723. Fixed assignment of NIL string.
  724. Revision 1.24 1998/10/22 11:32:23 michael
  725. + AssignAnsistring no longer copies constant ansistrings;
  726. + CompareAnsiString is now faster (1 call to length less)
  727. + UniqueAnsiString is fixed.
  728. Revision 1.23 1998/10/21 23:01:54 michael
  729. + Some more corrections
  730. Revision 1.22 1998/10/21 09:03:11 michael
  731. + more fixes so it compiles
  732. Revision 1.21 1998/10/21 08:56:58 michael
  733. + Fix so it compiles
  734. Revision 1.20 1998/10/21 08:38:46 florian
  735. * ansistringconcat fixed
  736. Revision 1.19 1998/10/20 12:46:11 florian
  737. * small fixes to ansicompare
  738. Revision 1.18 1998/09/28 14:02:34 michael
  739. + AnsiString changes
  740. Revision 1.17 1998/09/27 22:44:50 florian
  741. * small fixes
  742. * made UniqueAnsistring public
  743. * ...
  744. Revision 1.16 1998/09/20 17:49:08 florian
  745. * some ansistring fixes
  746. Revision 1.15 1998/09/19 08:33:17 florian
  747. * some internal procedures take now an pointer instead of a
  748. ansistring
  749. Revision 1.14 1998/09/14 10:48:14 peter
  750. * FPC_ names
  751. * Heap manager is now system independent
  752. Revision 1.13 1998/08/23 20:58:51 florian
  753. + rtti for objects and classes
  754. + TObject.GetClassName implemented
  755. Revision 1.12 1998/08/22 09:32:12 michael
  756. + minor fixes typos, and ansi2pchar
  757. Revision 1.11 1998/08/08 12:28:10 florian
  758. * a lot small fixes to the extended data type work
  759. Revision 1.10 1998/07/29 21:44:34 michael
  760. + Implemented reading/writing of ansistrings
  761. Revision 1.9 1998/07/20 23:36:56 michael
  762. changes for ansistrings
  763. Revision 1.8 1998/07/13 21:19:09 florian
  764. * some problems with ansi string support fixed
  765. Revision 1.7 1998/07/06 14:29:08 michael
  766. + Added Public,Alias directives for some calls
  767. Revision 1.6 1998/06/25 08:41:44 florian
  768. * better rtti
  769. Revision 1.5 1998/06/12 07:39:13 michael
  770. + Added aliases for Incr/Decr ref.
  771. Revision 1.4 1998/06/08 19:35:02 michael
  772. Some changes to integrate in system unit
  773. Revision 1.3 1998/06/08 12:38:22 michael
  774. Implemented rtti, inserted ansistrings again
  775. Revision 1.2 1998/05/12 10:42:44 peter
  776. * moved getopts to inc/, all supported OS's need argc,argv exported
  777. + strpas, strlen are now exported in the systemunit
  778. * removed logs
  779. * removed $ifdef ver_above
  780. }