cclasses.pas 68 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl and Peter Vreman
  3. This module provides some basic classes
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  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. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit cclasses;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. SysUtils,
  22. CUtils,CStreams;
  23. {********************************************
  24. TMemDebug
  25. ********************************************}
  26. type
  27. tmemdebug = class
  28. private
  29. totalmem,
  30. startmem : integer;
  31. infostr : string[40];
  32. public
  33. constructor Create(const s:string);
  34. destructor Destroy;override;
  35. procedure show;
  36. procedure start;
  37. procedure stop;
  38. end;
  39. {*******************************************************
  40. TFPObjectList (From rtl/objpas/classes/classesh.inc)
  41. ********************************************************}
  42. const
  43. MaxListSize = Maxint div 16;
  44. SListIndexError = 'List index exceeds bounds (%d)';
  45. SListCapacityError = 'The maximum list capacity is reached (%d)';
  46. SListCountError = 'List count too large (%d)';
  47. type
  48. EListError = class(Exception);
  49. type
  50. PPointerList = ^TPointerList;
  51. TPointerList = array[0..MaxListSize - 1] of Pointer;
  52. TListSortCompare = function (Item1, Item2: Pointer): Integer;
  53. TListCallback = procedure(data,arg:pointer) of object;
  54. TListStaticCallback = procedure(data,arg:pointer);
  55. TFPList = class(TObject)
  56. private
  57. FList: PPointerList;
  58. FCount: Integer;
  59. FCapacity: Integer;
  60. protected
  61. function Get(Index: Integer): Pointer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  62. procedure Put(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  63. procedure SetCapacity(NewCapacity: Integer);
  64. procedure SetCount(NewCount: Integer);
  65. Procedure RaiseIndexError(Index : Integer);
  66. public
  67. destructor Destroy; override;
  68. function Add(Item: Pointer): Integer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  69. procedure Clear;
  70. procedure Delete(Index: Integer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  71. class procedure Error(const Msg: string; Data: PtrInt);
  72. procedure Exchange(Index1, Index2: Integer);
  73. function Expand: TFPList; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  74. function Extract(item: Pointer): Pointer;
  75. function First: Pointer;
  76. function IndexOf(Item: Pointer): Integer;
  77. procedure Insert(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  78. function Last: Pointer;
  79. procedure Move(CurIndex, NewIndex: Integer);
  80. procedure Assign(Obj:TFPList);
  81. function Remove(Item: Pointer): Integer;
  82. procedure Pack;
  83. procedure Sort(Compare: TListSortCompare);
  84. procedure ForEachCall(proc2call:TListCallback;arg:pointer);
  85. procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
  86. property Capacity: Integer read FCapacity write SetCapacity;
  87. property Count: Integer read FCount write SetCount;
  88. property Items[Index: Integer]: Pointer read Get write Put; default;
  89. property List: PPointerList read FList;
  90. end;
  91. {*******************************************************
  92. TFPObjectList (From fcl/inc/contnrs.pp)
  93. ********************************************************}
  94. TObjectListCallback = procedure(data:TObject;arg:pointer) of object;
  95. TObjectListStaticCallback = procedure(data:TObject;arg:pointer);
  96. TFPObjectList = class(TObject)
  97. private
  98. FFreeObjects : Boolean;
  99. FList: TFPList;
  100. function GetCount: integer;
  101. procedure SetCount(const AValue: integer);
  102. protected
  103. function GetItem(Index: Integer): TObject; {$ifdef CLASSESINLINE}inline;{$endif}
  104. procedure SetItem(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif}
  105. procedure SetCapacity(NewCapacity: Integer);
  106. function GetCapacity: integer;
  107. public
  108. constructor Create;
  109. constructor Create(FreeObjects : Boolean);
  110. destructor Destroy; override;
  111. procedure Clear;
  112. function Add(AObject: TObject): Integer; {$ifdef CLASSESINLINE}inline;{$endif}
  113. procedure Delete(Index: Integer); {$ifdef CLASSESINLINE}inline;{$endif}
  114. procedure Exchange(Index1, Index2: Integer);
  115. function Expand: TFPObjectList;
  116. function Extract(Item: TObject): TObject;
  117. function Remove(AObject: TObject): Integer;
  118. function IndexOf(AObject: TObject): Integer;
  119. function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer;
  120. procedure Insert(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif}
  121. function First: TObject;
  122. function Last: TObject;
  123. procedure Move(CurIndex, NewIndex: Integer);
  124. procedure Assign(Obj:TFPObjectList);
  125. procedure Pack;
  126. procedure Sort(Compare: TListSortCompare);
  127. procedure ForEachCall(proc2call:TObjectListCallback;arg:pointer);
  128. procedure ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
  129. property Capacity: Integer read GetCapacity write SetCapacity;
  130. property Count: Integer read GetCount write SetCount;
  131. property OwnsObjects: Boolean read FFreeObjects write FFreeObjects;
  132. property Items[Index: Integer]: TObject read GetItem write SetItem; default;
  133. property List: TFPList read FList;
  134. end;
  135. {********************************************
  136. TLinkedList
  137. ********************************************}
  138. type
  139. TLinkedListItem = class
  140. public
  141. Previous,
  142. Next : TLinkedListItem;
  143. Constructor Create;
  144. Destructor Destroy;override;
  145. Function GetCopy:TLinkedListItem;virtual;
  146. end;
  147. TLinkedListItemClass = class of TLinkedListItem;
  148. TLinkedList = class
  149. private
  150. FCount : integer;
  151. FFirst,
  152. FLast : TLinkedListItem;
  153. FNoClear : boolean;
  154. public
  155. constructor Create;
  156. destructor Destroy;override;
  157. { true when the List is empty }
  158. function Empty:boolean;
  159. { deletes all Items }
  160. procedure Clear;
  161. { inserts an Item }
  162. procedure Insert(Item:TLinkedListItem);
  163. { inserts an Item before Loc }
  164. procedure InsertBefore(Item,Loc : TLinkedListItem);
  165. { inserts an Item after Loc }
  166. procedure InsertAfter(Item,Loc : TLinkedListItem);virtual;
  167. { concats an Item }
  168. procedure Concat(Item:TLinkedListItem);
  169. { deletes an Item }
  170. procedure Remove(Item:TLinkedListItem);
  171. { Gets First Item }
  172. function GetFirst:TLinkedListItem;
  173. { Gets last Item }
  174. function GetLast:TLinkedListItem;
  175. { inserts another List at the begin and make this List empty }
  176. procedure insertList(p : TLinkedList);
  177. { inserts another List before the provided item and make this List empty }
  178. procedure insertListBefore(Item:TLinkedListItem;p : TLinkedList);
  179. { inserts another List after the provided item and make this List empty }
  180. procedure insertListAfter(Item:TLinkedListItem;p : TLinkedList);
  181. { concats another List at the end and make this List empty }
  182. procedure concatList(p : TLinkedList);
  183. { concats another List at the start and makes a copy
  184. the list is ordered in reverse.
  185. }
  186. procedure insertListcopy(p : TLinkedList);
  187. { concats another List at the end and makes a copy }
  188. procedure concatListcopy(p : TLinkedList);
  189. property First:TLinkedListItem read FFirst;
  190. property Last:TLinkedListItem read FLast;
  191. property Count:Integer read FCount;
  192. property NoClear:boolean write FNoClear;
  193. end;
  194. {********************************************
  195. TStringList
  196. ********************************************}
  197. { string containerItem }
  198. TStringListItem = class(TLinkedListItem)
  199. FPStr : PString;
  200. public
  201. constructor Create(const s:string);
  202. destructor Destroy;override;
  203. function GetCopy:TLinkedListItem;override;
  204. function Str:string;
  205. end;
  206. { string container }
  207. TStringList = class(TLinkedList)
  208. private
  209. FDoubles : boolean; { if this is set to true, doubles are allowed }
  210. public
  211. constructor Create;
  212. constructor Create_No_Double;
  213. { inserts an Item }
  214. procedure Insert(const s:string);
  215. { concats an Item }
  216. procedure Concat(const s:string);
  217. { deletes an Item }
  218. procedure Remove(const s:string);
  219. { Gets First Item }
  220. function GetFirst:string;
  221. { Gets last Item }
  222. function GetLast:string;
  223. { true if string is in the container, compare case sensitive }
  224. function FindCase(const s:string):TStringListItem;
  225. { true if string is in the container }
  226. function Find(const s:string):TStringListItem;
  227. { inserts an item }
  228. procedure InsertItem(item:TStringListItem);
  229. { concats an item }
  230. procedure ConcatItem(item:TStringListItem);
  231. property Doubles:boolean read FDoubles write FDoubles;
  232. procedure readstream(f:TCStream);
  233. procedure writestream(f:TCStream);
  234. end;
  235. {********************************************
  236. Dictionary
  237. ********************************************}
  238. const
  239. { the real size will be [0..hasharray-1] ! }
  240. hasharraysize = 512;
  241. type
  242. { namedindexobect for use with dictionary and indexarray }
  243. TNamedIndexItem=class
  244. private
  245. { indexarray }
  246. FIndexNr : integer;
  247. FIndexNext : TNamedIndexItem;
  248. { dictionary }
  249. FLeft,
  250. FRight : TNamedIndexItem;
  251. FSpeedValue : cardinal;
  252. FName : Pstring;
  253. protected
  254. function GetName:string;virtual;
  255. procedure SetName(const n:string);virtual;
  256. public
  257. constructor Create;
  258. constructor CreateName(const n:string);
  259. destructor Destroy;override;
  260. property IndexNr:integer read FIndexNr write FIndexNr;
  261. property IndexNext:TNamedIndexItem read FIndexNext write FIndexNext;
  262. property Name:string read GetName write SetName;
  263. property SpeedValue:cardinal read FSpeedValue;
  264. property Left:TNamedIndexItem read FLeft write FLeft;
  265. property Right:TNamedIndexItem read FRight write FRight;
  266. end;
  267. Pdictionaryhasharray=^Tdictionaryhasharray;
  268. Tdictionaryhasharray=array[0..hasharraysize-1] of TNamedIndexItem;
  269. TnamedIndexCallback = procedure(p:TNamedIndexItem;arg:pointer) of object;
  270. TnamedIndexStaticCallback = procedure(p:TNamedIndexItem;arg:pointer);
  271. Tdictionary=class
  272. private
  273. FRoot : TNamedIndexItem;
  274. FCount : longint;
  275. FHashArray : Pdictionaryhasharray;
  276. procedure cleartree(var obj:TNamedIndexItem);
  277. function insertNode(NewNode:TNamedIndexItem;var currNode:TNamedIndexItem):TNamedIndexItem;
  278. procedure inserttree(currtree,currroot:TNamedIndexItem);
  279. public
  280. noclear : boolean;
  281. delete_doubles : boolean;
  282. constructor Create;
  283. destructor Destroy;override;
  284. procedure usehash;
  285. procedure clear;
  286. function delete(const s:string):TNamedIndexItem;
  287. function empty:boolean;
  288. procedure foreach(proc2call:TNamedIndexcallback;arg:pointer);
  289. procedure foreach_static(proc2call:TNamedIndexStaticCallback;arg:pointer);
  290. function insert(obj:TNamedIndexItem):TNamedIndexItem;
  291. function replace(oldobj,newobj:TNamedIndexItem):boolean;
  292. function rename(const olds,News : string):TNamedIndexItem;
  293. function search(const s:string):TNamedIndexItem;
  294. function speedsearch(const s:string;SpeedValue:cardinal):TNamedIndexItem;
  295. property Items[const s:string]:TNamedIndexItem read Search;default;
  296. property Count:longint read FCount;
  297. end;
  298. tindexobjectarray=array[1..16000] of TNamedIndexItem;
  299. pnamedindexobjectarray=^tindexobjectarray;
  300. tindexarray=class
  301. noclear : boolean;
  302. First : TNamedIndexItem;
  303. count : integer;
  304. constructor Create(Agrowsize:integer);
  305. destructor destroy;override;
  306. procedure clear;
  307. procedure foreach(proc2call : Tnamedindexcallback;arg:pointer);
  308. procedure foreach_static(proc2call : Tnamedindexstaticcallback;arg:pointer);
  309. procedure deleteindex(p:TNamedIndexItem);
  310. procedure delete(var p:TNamedIndexItem);
  311. procedure insert(p:TNamedIndexItem);
  312. procedure replace(oldp,newp:TNamedIndexItem);
  313. function search(nr:integer):TNamedIndexItem;
  314. property Items[Index: Integer]: TNamedIndexItem read Search; default;
  315. private
  316. growsize,
  317. size : integer;
  318. data : pnamedindexobjectarray;
  319. procedure grow(gsize:integer);
  320. end;
  321. {********************************************
  322. DynamicArray
  323. ********************************************}
  324. const
  325. dynamicblockbasesize = 12;
  326. type
  327. pdynamicblock = ^tdynamicblock;
  328. tdynamicblock = record
  329. pos,
  330. used : integer;
  331. Next : pdynamicblock;
  332. { can't use sizeof(integer) because it crashes gdb }
  333. data : array[0..1024*1024] of byte;
  334. end;
  335. tdynamicarray = class
  336. private
  337. FPosn : integer;
  338. FPosnblock : pdynamicblock;
  339. FBlocksize : integer;
  340. FFirstblock,
  341. FLastblock : pdynamicblock;
  342. procedure grow;
  343. public
  344. constructor Create(Ablocksize:integer);
  345. destructor Destroy;override;
  346. procedure reset;
  347. function size:integer;
  348. procedure align(i:integer);
  349. procedure seek(i:integer);
  350. function read(var d;len:integer):integer;
  351. procedure write(const d;len:integer);
  352. procedure writestr(const s:string);
  353. procedure readstream(f:TCStream;maxlen:longint);
  354. procedure writestream(f:TCStream);
  355. property BlockSize : integer read FBlocksize;
  356. property FirstBlock : PDynamicBlock read FFirstBlock;
  357. property Pos : integer read FPosn;
  358. end;
  359. implementation
  360. {*****************************************************************************
  361. Memory debug
  362. *****************************************************************************}
  363. constructor tmemdebug.create(const s:string);
  364. begin
  365. infostr:=s;
  366. totalmem:=0;
  367. Start;
  368. end;
  369. procedure tmemdebug.start;
  370. var
  371. status : TFPCHeapStatus;
  372. begin
  373. status:=GetFPCHeapStatus;
  374. startmem:=status.CurrHeapUsed;
  375. end;
  376. procedure tmemdebug.stop;
  377. var
  378. status : TFPCHeapStatus;
  379. begin
  380. if startmem<>0 then
  381. begin
  382. status:=GetFPCHeapStatus;
  383. inc(TotalMem,startmem-status.CurrHeapUsed);
  384. startmem:=0;
  385. end;
  386. end;
  387. destructor tmemdebug.destroy;
  388. begin
  389. Stop;
  390. show;
  391. end;
  392. procedure tmemdebug.show;
  393. begin
  394. write('memory [',infostr,'] ');
  395. if TotalMem>0 then
  396. writeln(DStr(TotalMem shr 10),' Kb released')
  397. else
  398. writeln(DStr((-TotalMem) shr 10),' Kb allocated');
  399. end;
  400. {*****************************************************************************
  401. TFPObjectList (Copied from rtl/objpas/classes/lists.inc)
  402. *****************************************************************************}
  403. Const
  404. // Ratio of Pointer and Word Size.
  405. WordRatio = SizeOf(Pointer) Div SizeOf(Word);
  406. procedure TFPList.RaiseIndexError(Index : Integer);
  407. begin
  408. Error(SListIndexError, Index);
  409. end;
  410. function TFPList.Get(Index: Integer): Pointer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  411. begin
  412. If (Index < 0) or (Index >= FCount) then
  413. RaiseIndexError(Index);
  414. Result:=FList^[Index];
  415. end;
  416. procedure TFPList.Put(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  417. begin
  418. if (Index < 0) or (Index >= FCount) then
  419. RaiseIndexError(Index);
  420. Flist^[Index] := Item;
  421. end;
  422. function TFPList.Extract(item: Pointer): Pointer;
  423. var
  424. i : Integer;
  425. begin
  426. result := nil;
  427. i := IndexOf(item);
  428. if i >= 0 then
  429. begin
  430. Result := item;
  431. FList^[i] := nil;
  432. Delete(i);
  433. end;
  434. end;
  435. procedure TFPList.SetCapacity(NewCapacity: Integer);
  436. begin
  437. If (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
  438. Error (SListCapacityError, NewCapacity);
  439. if NewCapacity = FCapacity then
  440. exit;
  441. ReallocMem(FList, SizeOf(Pointer)*NewCapacity);
  442. FCapacity := NewCapacity;
  443. end;
  444. procedure TFPList.SetCount(NewCount: Integer);
  445. begin
  446. if (NewCount < 0) or (NewCount > MaxListSize)then
  447. Error(SListCountError, NewCount);
  448. If NewCount > FCount then
  449. begin
  450. If NewCount > FCapacity then
  451. SetCapacity(NewCount);
  452. If FCount < NewCount then
  453. FillWord(Flist^[FCount], (NewCount-FCount) * WordRatio, 0);
  454. end;
  455. FCount := Newcount;
  456. end;
  457. destructor TFPList.Destroy;
  458. begin
  459. Self.Clear;
  460. inherited Destroy;
  461. end;
  462. function TFPList.Add(Item: Pointer): Integer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  463. begin
  464. if FCount = FCapacity then
  465. Self.Expand;
  466. FList^[FCount] := Item;
  467. Result := FCount;
  468. FCount := FCount + 1;
  469. end;
  470. procedure TFPList.Clear;
  471. begin
  472. if Assigned(FList) then
  473. begin
  474. SetCount(0);
  475. SetCapacity(0);
  476. FList := nil;
  477. end;
  478. end;
  479. procedure TFPList.Delete(Index: Integer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  480. begin
  481. If (Index<0) or (Index>=FCount) then
  482. Error (SListIndexError, Index);
  483. FCount := FCount-1;
  484. System.Move (FList^[Index+1], FList^[Index], (FCount - Index) * SizeOf(Pointer));
  485. // Shrink the list if appropriate
  486. if (FCapacity > 256) and (FCount < FCapacity shr 2) then
  487. begin
  488. FCapacity := FCapacity shr 1;
  489. ReallocMem(FList, SizeOf(Pointer) * FCapacity);
  490. end;
  491. end;
  492. class procedure TFPList.Error(const Msg: string; Data: PtrInt);
  493. begin
  494. Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
  495. end;
  496. procedure TFPList.Exchange(Index1, Index2: Integer);
  497. var
  498. Temp : Pointer;
  499. begin
  500. If ((Index1 >= FCount) or (Index1 < 0)) then
  501. Error(SListIndexError, Index1);
  502. If ((Index2 >= FCount) or (Index2 < 0)) then
  503. Error(SListIndexError, Index2);
  504. Temp := FList^[Index1];
  505. FList^[Index1] := FList^[Index2];
  506. FList^[Index2] := Temp;
  507. end;
  508. function TFPList.Expand: TFPList; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  509. var
  510. IncSize : Longint;
  511. begin
  512. if FCount < FCapacity then exit;
  513. IncSize := 4;
  514. if FCapacity > 3 then IncSize := IncSize + 4;
  515. if FCapacity > 8 then IncSize := IncSize+8;
  516. if FCapacity > 127 then Inc(IncSize, FCapacity shr 2);
  517. SetCapacity(FCapacity + IncSize);
  518. Result := Self;
  519. end;
  520. function TFPList.First: Pointer;
  521. begin
  522. If FCount = 0 then
  523. Result := Nil
  524. else
  525. Result := Items[0];
  526. end;
  527. function TFPList.IndexOf(Item: Pointer): Integer;
  528. begin
  529. Result := 0;
  530. while(Result < FCount) and (Flist^[Result] <> Item) do Result := Result + 1;
  531. If Result = FCount then Result := -1;
  532. end;
  533. procedure TFPList.Insert(Index: Integer; Item: Pointer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
  534. begin
  535. if (Index < 0) or (Index > FCount )then
  536. Error(SlistIndexError, Index);
  537. iF FCount = FCapacity then Self.Expand;
  538. if Index<FCount then
  539. System.Move(Flist^[Index], Flist^[Index+1], (FCount - Index) * SizeOf(Pointer));
  540. FList^[Index] := Item;
  541. FCount := FCount + 1;
  542. end;
  543. function TFPList.Last: Pointer;
  544. begin
  545. { Wouldn't it be better to return nil if the count is zero ?}
  546. If FCount = 0 then
  547. Result := nil
  548. else
  549. Result := Items[FCount - 1];
  550. end;
  551. procedure TFPList.Move(CurIndex, NewIndex: Integer);
  552. var
  553. Temp : Pointer;
  554. begin
  555. if ((CurIndex < 0) or (CurIndex > Count - 1)) then
  556. Error(SListIndexError, CurIndex);
  557. if (NewINdex < 0) then
  558. Error(SlistIndexError, NewIndex);
  559. Temp := FList^[CurIndex];
  560. FList^[CurIndex] := nil;
  561. Self.Delete(CurIndex);
  562. Self.Insert(NewIndex, nil);
  563. FList^[NewIndex] := Temp;
  564. end;
  565. function TFPList.Remove(Item: Pointer): Integer;
  566. begin
  567. Result := IndexOf(Item);
  568. If Result <> -1 then
  569. Self.Delete(Result);
  570. end;
  571. procedure TFPList.Pack;
  572. Var
  573. {Last,I,J,}
  574. Runner : Longint;
  575. begin
  576. // Not the fastest; but surely correct
  577. for Runner := Fcount - 1 downto 0 do
  578. if Items[Runner] = Nil then
  579. Self.Delete(Runner);
  580. { The following may be faster in case of large and defragmented lists
  581. If count=0 then exit;
  582. Runner:=0;I:=0;
  583. TheLast:=Count;
  584. while runner<count do
  585. begin
  586. // Find first Nil
  587. While (FList^[Runner]<>Nil) and (Runner<Count) do Runner:=Runner+1;
  588. if Runner<Count do
  589. begin
  590. // Start searching for non-nil from last known nil+1
  591. if i<Runner then I:=Runner+1;
  592. While (Flist[I]^=Nil) and (I<Count) do I:=I+1;
  593. // Start looking for last non-nil of block.
  594. J:=I+1;
  595. While (Flist^[J]<>Nil) and (J<Count) do J:=J+1;
  596. // Move block and zero out
  597. Move (Flist^[I],Flist^[Runner],J*SizeOf(Pointer));
  598. FillWord (Flist^[I],(J-I)*WordRatio,0);
  599. // Update Runner and Last to point behind last block
  600. TheLast:=Runner+(J-I);
  601. If J=Count then
  602. begin
  603. // Shortcut, when J=Count we checked all pointers
  604. Runner:=Count
  605. else
  606. begin
  607. Runner:=TheLast;
  608. I:=j;
  609. end;
  610. end;
  611. Count:=TheLast;
  612. }
  613. end;
  614. // Needed by Sort method.
  615. Procedure QuickSort(FList: PPointerList; L, R : Longint;
  616. Compare: TListSortCompare);
  617. var
  618. I, J : Longint;
  619. P, Q : Pointer;
  620. begin
  621. repeat
  622. I := L;
  623. J := R;
  624. P := FList^[ (L + R) div 2 ];
  625. repeat
  626. while Compare(P, FList^[i]) > 0 do
  627. I := I + 1;
  628. while Compare(P, FList^[J]) < 0 do
  629. J := J - 1;
  630. If I <= J then
  631. begin
  632. Q := FList^[I];
  633. Flist^[I] := FList^[J];
  634. FList^[J] := Q;
  635. I := I + 1;
  636. J := J - 1;
  637. end;
  638. until I > J;
  639. if L < J then
  640. QuickSort(FList, L, J, Compare);
  641. L := I;
  642. until I >= R;
  643. end;
  644. procedure TFPList.Sort(Compare: TListSortCompare);
  645. begin
  646. if Not Assigned(FList) or (FCount < 2) then exit;
  647. QuickSort(Flist, 0, FCount-1, Compare);
  648. end;
  649. procedure TFPList.Assign(Obj: TFPList);
  650. var
  651. i: Integer;
  652. begin
  653. Clear;
  654. for I := 0 to Obj.Count - 1 do
  655. Add(Obj[i]);
  656. end;
  657. procedure TFPList.ForEachCall(proc2call:TListCallback;arg:pointer);
  658. var
  659. i : integer;
  660. p : pointer;
  661. begin
  662. For I:=0 To Count-1 Do
  663. begin
  664. p:=FList^[i];
  665. if assigned(p) then
  666. proc2call(p,arg);
  667. end;
  668. end;
  669. procedure TFPList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
  670. var
  671. i : integer;
  672. p : pointer;
  673. begin
  674. For I:=0 To Count-1 Do
  675. begin
  676. p:=FList^[i];
  677. if assigned(p) then
  678. proc2call(p,arg);
  679. end;
  680. end;
  681. {*****************************************************************************
  682. TFPObjectList (Copied from rtl/objpas/classes/lists.inc)
  683. *****************************************************************************}
  684. constructor TFPObjectList.Create(FreeObjects : boolean);
  685. begin
  686. Create;
  687. FFreeObjects := Freeobjects;
  688. end;
  689. destructor TFPObjectList.Destroy;
  690. begin
  691. if (FList <> nil) then
  692. begin
  693. Clear;
  694. FList.Destroy;
  695. end;
  696. inherited Destroy;
  697. end;
  698. procedure TFPObjectList.Clear;
  699. var
  700. i: integer;
  701. begin
  702. if FFreeObjects then
  703. for i := 0 to FList.Count - 1 do
  704. TObject(FList[i]).Free;
  705. FList.Clear;
  706. end;
  707. constructor TFPObjectList.Create;
  708. begin
  709. inherited Create;
  710. FList := TFPList.Create;
  711. FFreeObjects := True;
  712. end;
  713. function TFPObjectList.GetCount: integer;
  714. begin
  715. Result := FList.Count;
  716. end;
  717. procedure TFPObjectList.SetCount(const AValue: integer);
  718. begin
  719. if FList.Count <> AValue then
  720. FList.Count := AValue;
  721. end;
  722. function TFPObjectList.GetItem(Index: Integer): TObject; {$ifdef CLASSESINLINE}inline;{$endif}
  723. begin
  724. Result := TObject(FList[Index]);
  725. end;
  726. procedure TFPObjectList.SetItem(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif}
  727. begin
  728. if OwnsObjects then
  729. TObject(FList[Index]).Free;
  730. FList[index] := AObject;
  731. end;
  732. procedure TFPObjectList.SetCapacity(NewCapacity: Integer);
  733. begin
  734. FList.Capacity := NewCapacity;
  735. end;
  736. function TFPObjectList.GetCapacity: integer;
  737. begin
  738. Result := FList.Capacity;
  739. end;
  740. function TFPObjectList.Add(AObject: TObject): Integer; {$ifdef CLASSESINLINE}inline;{$endif}
  741. begin
  742. Result := FList.Add(AObject);
  743. end;
  744. procedure TFPObjectList.Delete(Index: Integer); {$ifdef CLASSESINLINE}inline;{$endif}
  745. begin
  746. if OwnsObjects then
  747. TObject(FList[Index]).Free;
  748. FList.Delete(Index);
  749. end;
  750. procedure TFPObjectList.Exchange(Index1, Index2: Integer);
  751. begin
  752. FList.Exchange(Index1, Index2);
  753. end;
  754. function TFPObjectList.Expand: TFPObjectList;
  755. begin
  756. FList.Expand;
  757. Result := Self;
  758. end;
  759. function TFPObjectList.Extract(Item: TObject): TObject;
  760. begin
  761. Result := TObject(FList.Extract(Item));
  762. end;
  763. function TFPObjectList.Remove(AObject: TObject): Integer;
  764. begin
  765. Result := IndexOf(AObject);
  766. if (Result <> -1) then
  767. begin
  768. if OwnsObjects then
  769. TObject(FList[Result]).Free;
  770. FList.Delete(Result);
  771. end;
  772. end;
  773. function TFPObjectList.IndexOf(AObject: TObject): Integer;
  774. begin
  775. Result := FList.IndexOf(Pointer(AObject));
  776. end;
  777. function TFPObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt : Integer): Integer;
  778. var
  779. I : Integer;
  780. begin
  781. I:=AStartAt;
  782. Result:=-1;
  783. If AExact then
  784. while (I<Count) and (Result=-1) do
  785. If Items[i].ClassType=AClass then
  786. Result:=I
  787. else
  788. Inc(I)
  789. else
  790. while (I<Count) and (Result=-1) do
  791. If Items[i].InheritsFrom(AClass) then
  792. Result:=I
  793. else
  794. Inc(I);
  795. end;
  796. procedure TFPObjectList.Insert(Index: Integer; AObject: TObject); {$ifdef CLASSESINLINE}inline;{$endif}
  797. begin
  798. FList.Insert(Index, Pointer(AObject));
  799. end;
  800. procedure TFPObjectList.Move(CurIndex, NewIndex: Integer);
  801. begin
  802. FList.Move(CurIndex, NewIndex);
  803. end;
  804. procedure TFPObjectList.Assign(Obj: TFPObjectList);
  805. var
  806. i: Integer;
  807. begin
  808. Clear;
  809. for I := 0 to Obj.Count - 1 do
  810. Add(Obj[i]);
  811. end;
  812. procedure TFPObjectList.Pack;
  813. begin
  814. FList.Pack;
  815. end;
  816. procedure TFPObjectList.Sort(Compare: TListSortCompare);
  817. begin
  818. FList.Sort(Compare);
  819. end;
  820. function TFPObjectList.First: TObject;
  821. begin
  822. Result := TObject(FList.First);
  823. end;
  824. function TFPObjectList.Last: TObject;
  825. begin
  826. Result := TObject(FList.Last);
  827. end;
  828. procedure TFPObjectList.ForEachCall(proc2call:TObjectListCallback;arg:pointer);
  829. begin
  830. FList.ForEachCall(TListCallBack(proc2call),arg);
  831. end;
  832. procedure TFPObjectList.ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
  833. begin
  834. FList.ForEachCall(TListStaticCallBack(proc2call),arg);
  835. end;
  836. {****************************************************************************
  837. TLinkedListItem
  838. ****************************************************************************}
  839. constructor TLinkedListItem.Create;
  840. begin
  841. Previous:=nil;
  842. Next:=nil;
  843. end;
  844. destructor TLinkedListItem.Destroy;
  845. begin
  846. end;
  847. function TLinkedListItem.GetCopy:TLinkedListItem;
  848. var
  849. p : TLinkedListItem;
  850. l : integer;
  851. begin
  852. p:=TLinkedListItemClass(ClassType).Create;
  853. l:=InstanceSize;
  854. Move(pointer(self)^,pointer(p)^,l);
  855. Result:=p;
  856. end;
  857. {****************************************************************************
  858. TLinkedList
  859. ****************************************************************************}
  860. constructor TLinkedList.Create;
  861. begin
  862. FFirst:=nil;
  863. Flast:=nil;
  864. FCount:=0;
  865. FNoClear:=False;
  866. end;
  867. destructor TLinkedList.destroy;
  868. begin
  869. if not FNoClear then
  870. Clear;
  871. end;
  872. function TLinkedList.empty:boolean;
  873. begin
  874. Empty:=(FFirst=nil);
  875. end;
  876. procedure TLinkedList.Insert(Item:TLinkedListItem);
  877. begin
  878. if FFirst=nil then
  879. begin
  880. FLast:=Item;
  881. Item.Previous:=nil;
  882. Item.Next:=nil;
  883. end
  884. else
  885. begin
  886. FFirst.Previous:=Item;
  887. Item.Previous:=nil;
  888. Item.Next:=FFirst;
  889. end;
  890. FFirst:=Item;
  891. inc(FCount);
  892. end;
  893. procedure TLinkedList.InsertBefore(Item,Loc : TLinkedListItem);
  894. begin
  895. Item.Previous:=Loc.Previous;
  896. Item.Next:=Loc;
  897. Loc.Previous:=Item;
  898. if assigned(Item.Previous) then
  899. Item.Previous.Next:=Item
  900. else
  901. { if we've no next item, we've to adjust FFist }
  902. FFirst:=Item;
  903. inc(FCount);
  904. end;
  905. procedure TLinkedList.InsertAfter(Item,Loc : TLinkedListItem);
  906. begin
  907. Item.Next:=Loc.Next;
  908. Loc.Next:=Item;
  909. Item.Previous:=Loc;
  910. if assigned(Item.Next) then
  911. Item.Next.Previous:=Item
  912. else
  913. { if we've no next item, we've to adjust FLast }
  914. FLast:=Item;
  915. inc(FCount);
  916. end;
  917. procedure TLinkedList.Concat(Item:TLinkedListItem);
  918. begin
  919. if FFirst=nil then
  920. begin
  921. FFirst:=Item;
  922. Item.Previous:=nil;
  923. Item.Next:=nil;
  924. end
  925. else
  926. begin
  927. Flast.Next:=Item;
  928. Item.Previous:=Flast;
  929. Item.Next:=nil;
  930. end;
  931. Flast:=Item;
  932. inc(FCount);
  933. end;
  934. procedure TLinkedList.remove(Item:TLinkedListItem);
  935. begin
  936. if Item=nil then
  937. exit;
  938. if (FFirst=Item) and (Flast=Item) then
  939. begin
  940. FFirst:=nil;
  941. Flast:=nil;
  942. end
  943. else if FFirst=Item then
  944. begin
  945. FFirst:=Item.Next;
  946. if assigned(FFirst) then
  947. FFirst.Previous:=nil;
  948. end
  949. else if Flast=Item then
  950. begin
  951. Flast:=Flast.Previous;
  952. if assigned(Flast) then
  953. Flast.Next:=nil;
  954. end
  955. else
  956. begin
  957. Item.Previous.Next:=Item.Next;
  958. Item.Next.Previous:=Item.Previous;
  959. end;
  960. Item.Next:=nil;
  961. Item.Previous:=nil;
  962. dec(FCount);
  963. end;
  964. procedure TLinkedList.clear;
  965. var
  966. NewNode : TLinkedListItem;
  967. begin
  968. NewNode:=FFirst;
  969. while assigned(NewNode) do
  970. begin
  971. FFirst:=NewNode.Next;
  972. NewNode.Free;
  973. NewNode:=FFirst;
  974. end;
  975. FLast:=nil;
  976. FFirst:=nil;
  977. FCount:=0;
  978. end;
  979. function TLinkedList.GetFirst:TLinkedListItem;
  980. begin
  981. if FFirst=nil then
  982. GetFirst:=nil
  983. else
  984. begin
  985. GetFirst:=FFirst;
  986. if FFirst=FLast then
  987. FLast:=nil;
  988. FFirst:=FFirst.Next;
  989. dec(FCount);
  990. end;
  991. end;
  992. function TLinkedList.GetLast:TLinkedListItem;
  993. begin
  994. if FLast=nil then
  995. Getlast:=nil
  996. else
  997. begin
  998. Getlast:=FLast;
  999. if FLast=FFirst then
  1000. FFirst:=nil;
  1001. FLast:=FLast.Previous;
  1002. dec(FCount);
  1003. end;
  1004. end;
  1005. procedure TLinkedList.insertList(p : TLinkedList);
  1006. begin
  1007. { empty List ? }
  1008. if (p.FFirst=nil) then
  1009. exit;
  1010. p.Flast.Next:=FFirst;
  1011. { we have a double Linked List }
  1012. if assigned(FFirst) then
  1013. FFirst.Previous:=p.Flast;
  1014. FFirst:=p.FFirst;
  1015. if (FLast=nil) then
  1016. Flast:=p.Flast;
  1017. inc(FCount,p.FCount);
  1018. { p becomes empty }
  1019. p.FFirst:=nil;
  1020. p.Flast:=nil;
  1021. p.FCount:=0;
  1022. end;
  1023. procedure TLinkedList.insertListBefore(Item:TLinkedListItem;p : TLinkedList);
  1024. begin
  1025. { empty List ? }
  1026. if (p.FFirst=nil) then
  1027. exit;
  1028. if (Item=nil) then
  1029. begin
  1030. { Insert at begin }
  1031. InsertList(p);
  1032. exit;
  1033. end
  1034. else
  1035. begin
  1036. p.FLast.Next:=Item;
  1037. p.FFirst.Previous:=Item.Previous;
  1038. if assigned(Item.Previous) then
  1039. Item.Previous.Next:=p.FFirst
  1040. else
  1041. FFirst:=p.FFirst;
  1042. Item.Previous:=p.FLast;
  1043. inc(FCount,p.FCount);
  1044. end;
  1045. { p becomes empty }
  1046. p.FFirst:=nil;
  1047. p.Flast:=nil;
  1048. p.FCount:=0;
  1049. end;
  1050. procedure TLinkedList.insertListAfter(Item:TLinkedListItem;p : TLinkedList);
  1051. begin
  1052. { empty List ? }
  1053. if (p.FFirst=nil) then
  1054. exit;
  1055. if (Item=nil) then
  1056. begin
  1057. { Insert at begin }
  1058. InsertList(p);
  1059. exit;
  1060. end
  1061. else
  1062. begin
  1063. p.FFirst.Previous:=Item;
  1064. p.FLast.Next:=Item.Next;
  1065. if assigned(Item.Next) then
  1066. Item.Next.Previous:=p.FLast
  1067. else
  1068. FLast:=p.FLast;
  1069. Item.Next:=p.FFirst;
  1070. inc(FCount,p.FCount);
  1071. end;
  1072. { p becomes empty }
  1073. p.FFirst:=nil;
  1074. p.Flast:=nil;
  1075. p.FCount:=0;
  1076. end;
  1077. procedure TLinkedList.concatList(p : TLinkedList);
  1078. begin
  1079. if (p.FFirst=nil) then
  1080. exit;
  1081. if FFirst=nil then
  1082. FFirst:=p.FFirst
  1083. else
  1084. begin
  1085. FLast.Next:=p.FFirst;
  1086. p.FFirst.Previous:=Flast;
  1087. end;
  1088. Flast:=p.Flast;
  1089. inc(FCount,p.FCount);
  1090. { make p empty }
  1091. p.Flast:=nil;
  1092. p.FFirst:=nil;
  1093. p.FCount:=0;
  1094. end;
  1095. procedure TLinkedList.insertListcopy(p : TLinkedList);
  1096. var
  1097. NewNode,NewNode2 : TLinkedListItem;
  1098. begin
  1099. NewNode:=p.First;
  1100. while assigned(NewNode) do
  1101. begin
  1102. NewNode2:=NewNode.Getcopy;
  1103. if assigned(NewNode2) then
  1104. Insert(NewNode2);
  1105. NewNode:=NewNode.Next;
  1106. end;
  1107. end;
  1108. procedure TLinkedList.concatListcopy(p : TLinkedList);
  1109. var
  1110. NewNode,NewNode2 : TLinkedListItem;
  1111. begin
  1112. NewNode:=p.First;
  1113. while assigned(NewNode) do
  1114. begin
  1115. NewNode2:=NewNode.Getcopy;
  1116. if assigned(NewNode2) then
  1117. Concat(NewNode2);
  1118. NewNode:=NewNode.Next;
  1119. end;
  1120. end;
  1121. {****************************************************************************
  1122. TStringListItem
  1123. ****************************************************************************}
  1124. constructor TStringListItem.Create(const s:string);
  1125. begin
  1126. inherited Create;
  1127. FPStr:=stringdup(s);
  1128. end;
  1129. destructor TStringListItem.Destroy;
  1130. begin
  1131. stringdispose(FPStr);
  1132. end;
  1133. function TStringListItem.Str:string;
  1134. begin
  1135. Str:=FPStr^;
  1136. end;
  1137. function TStringListItem.GetCopy:TLinkedListItem;
  1138. begin
  1139. Result:=(inherited GetCopy);
  1140. TStringListItem(Result).FPStr:=stringdup(FPstr^);
  1141. end;
  1142. {****************************************************************************
  1143. TSTRINGList
  1144. ****************************************************************************}
  1145. constructor tstringList.Create;
  1146. begin
  1147. inherited Create;
  1148. FDoubles:=true;
  1149. end;
  1150. constructor tstringList.Create_no_double;
  1151. begin
  1152. inherited Create;
  1153. FDoubles:=false;
  1154. end;
  1155. procedure tstringList.insert(const s : string);
  1156. begin
  1157. if (s='') or
  1158. ((not FDoubles) and (find(s)<>nil)) then
  1159. exit;
  1160. inherited insert(tstringListItem.create(s));
  1161. end;
  1162. procedure tstringList.concat(const s : string);
  1163. begin
  1164. if (s='') or
  1165. ((not FDoubles) and (find(s)<>nil)) then
  1166. exit;
  1167. inherited concat(tstringListItem.create(s));
  1168. end;
  1169. procedure tstringList.remove(const s : string);
  1170. var
  1171. p : tstringListItem;
  1172. begin
  1173. if s='' then
  1174. exit;
  1175. p:=find(s);
  1176. if assigned(p) then
  1177. begin
  1178. inherited Remove(p);
  1179. p.Free;
  1180. end;
  1181. end;
  1182. function tstringList.GetFirst : string;
  1183. var
  1184. p : tstringListItem;
  1185. begin
  1186. p:=tstringListItem(inherited GetFirst);
  1187. if p=nil then
  1188. GetFirst:=''
  1189. else
  1190. begin
  1191. GetFirst:=p.FPStr^;
  1192. p.free;
  1193. end;
  1194. end;
  1195. function tstringList.Getlast : string;
  1196. var
  1197. p : tstringListItem;
  1198. begin
  1199. p:=tstringListItem(inherited Getlast);
  1200. if p=nil then
  1201. Getlast:=''
  1202. else
  1203. begin
  1204. Getlast:=p.FPStr^;
  1205. p.free;
  1206. end;
  1207. end;
  1208. function tstringList.FindCase(const s:string):TstringListItem;
  1209. var
  1210. NewNode : tstringListItem;
  1211. begin
  1212. result:=nil;
  1213. if s='' then
  1214. exit;
  1215. NewNode:=tstringListItem(FFirst);
  1216. while assigned(NewNode) do
  1217. begin
  1218. if NewNode.FPStr^=s then
  1219. begin
  1220. result:=NewNode;
  1221. exit;
  1222. end;
  1223. NewNode:=tstringListItem(NewNode.Next);
  1224. end;
  1225. end;
  1226. function tstringList.Find(const s:string):TstringListItem;
  1227. var
  1228. NewNode : tstringListItem;
  1229. ups : string;
  1230. begin
  1231. result:=nil;
  1232. if s='' then
  1233. exit;
  1234. ups:=upper(s);
  1235. NewNode:=tstringListItem(FFirst);
  1236. while assigned(NewNode) do
  1237. begin
  1238. if upper(NewNode.FPStr^)=ups then
  1239. begin
  1240. result:=NewNode;
  1241. exit;
  1242. end;
  1243. NewNode:=tstringListItem(NewNode.Next);
  1244. end;
  1245. end;
  1246. procedure TStringList.InsertItem(item:TStringListItem);
  1247. begin
  1248. inherited Insert(item);
  1249. end;
  1250. procedure TStringList.ConcatItem(item:TStringListItem);
  1251. begin
  1252. inherited Concat(item);
  1253. end;
  1254. procedure TStringList.readstream(f:TCStream);
  1255. const
  1256. BufSize = 16384;
  1257. var
  1258. Hsp,
  1259. p,maxp,
  1260. Buf : PChar;
  1261. Prev : Char;
  1262. HsPos,
  1263. ReadLen,
  1264. BufPos,
  1265. BufEnd : Longint;
  1266. hs : string;
  1267. procedure ReadBuf;
  1268. begin
  1269. if BufPos<BufEnd then
  1270. begin
  1271. Move(Buf[BufPos],Buf[0],BufEnd-BufPos);
  1272. Dec(BufEnd,BufPos);
  1273. BufPos:=0;
  1274. end;
  1275. ReadLen:=f.Read(buf[BufEnd],BufSize-BufEnd);
  1276. inc(BufEnd,ReadLen);
  1277. end;
  1278. begin
  1279. Getmem(Buf,Bufsize);
  1280. BufPos:=0;
  1281. BufEnd:=0;
  1282. HsPos:=1;
  1283. ReadBuf;
  1284. repeat
  1285. hsp:=@hs[hsPos];
  1286. p:=@Buf[BufPos];
  1287. maxp:=@Buf[BufEnd];
  1288. while (p<maxp) and not(P^ in [#10,#13]) do
  1289. begin
  1290. hsp^:=p^;
  1291. inc(p);
  1292. if hsp-@hs[1]<255 then
  1293. inc(hsp);
  1294. end;
  1295. inc(BufPos,maxp-p);
  1296. inc(HsPos,maxp-p);
  1297. prev:=p^;
  1298. inc(BufPos);
  1299. { no system uses #10#13 as line seperator (#10 = *nix, #13 = Mac, }
  1300. { #13#10 = Dos), so if we've got #10, we can safely exit }
  1301. if (prev<>#10) then
  1302. begin
  1303. if (BufPos>=BufEnd) then
  1304. begin
  1305. ReadBuf;
  1306. if BufPos>=BufEnd then
  1307. break;
  1308. end;
  1309. { is there also a #10 after it? }
  1310. if prev=#13 then
  1311. begin
  1312. if (Buf[BufPos]=#10) then
  1313. inc(BufPos);
  1314. prev:=#10;
  1315. end;
  1316. end;
  1317. if prev=#10 then
  1318. begin
  1319. hs[0]:=char(hsp-@hs[1]);
  1320. Concat(hs);
  1321. HsPos:=1;
  1322. end;
  1323. until BufPos>=BufEnd;
  1324. hs[0]:=char(hsp-@hs[1]);
  1325. Concat(hs);
  1326. freemem(buf);
  1327. end;
  1328. procedure TStringList.writestream(f:TCStream);
  1329. var
  1330. Node : TStringListItem;
  1331. LineEnd : string[2];
  1332. begin
  1333. Case DefaultTextLineBreakStyle Of
  1334. tlbsLF: LineEnd := #10;
  1335. tlbsCRLF: LineEnd := #13#10;
  1336. tlbsCR: LineEnd := #13;
  1337. End;
  1338. Node:=tstringListItem(FFirst);
  1339. while assigned(Node) do
  1340. begin
  1341. f.Write(Node.FPStr^[1],Length(Node.FPStr^));
  1342. f.Write(LineEnd[1],length(LineEnd));
  1343. Node:=tstringListItem(Node.Next);
  1344. end;
  1345. end;
  1346. {****************************************************************************
  1347. TNamedIndexItem
  1348. ****************************************************************************}
  1349. constructor TNamedIndexItem.Create;
  1350. begin
  1351. { index }
  1352. Findexnr:=-1;
  1353. FindexNext:=nil;
  1354. { dictionary }
  1355. Fleft:=nil;
  1356. Fright:=nil;
  1357. FName:=nil;
  1358. Fspeedvalue:=cardinal($ffffffff);
  1359. end;
  1360. constructor TNamedIndexItem.Createname(const n:string);
  1361. begin
  1362. { index }
  1363. Findexnr:=-1;
  1364. FindexNext:=nil;
  1365. { dictionary }
  1366. Fleft:=nil;
  1367. Fright:=nil;
  1368. fspeedvalue:=getspeedvalue(n);
  1369. {$ifdef compress}
  1370. FName:=stringdup(minilzw_encode(n));
  1371. {$else}
  1372. FName:=stringdup(n);
  1373. {$endif}
  1374. end;
  1375. destructor TNamedIndexItem.destroy;
  1376. begin
  1377. stringdispose(FName);
  1378. end;
  1379. procedure TNamedIndexItem.setname(const n:string);
  1380. begin
  1381. if assigned(FName) then
  1382. stringdispose(FName);
  1383. fspeedvalue:=getspeedvalue(n);
  1384. {$ifdef compress}
  1385. FName:=stringdup(minilzw_encode(n));
  1386. {$else}
  1387. FName:=stringdup(n);
  1388. {$endif}
  1389. end;
  1390. function TNamedIndexItem.GetName:string;
  1391. begin
  1392. if assigned(FName) then
  1393. {$ifdef compress}
  1394. Getname:=minilzw_decode(FName^)
  1395. {$else}
  1396. Getname:=FName^
  1397. {$endif}
  1398. else
  1399. Getname:='';
  1400. end;
  1401. {****************************************************************************
  1402. TDICTIONARY
  1403. ****************************************************************************}
  1404. constructor Tdictionary.Create;
  1405. begin
  1406. FRoot:=nil;
  1407. FHashArray:=nil;
  1408. noclear:=false;
  1409. delete_doubles:=false;
  1410. end;
  1411. procedure Tdictionary.usehash;
  1412. begin
  1413. if not(assigned(FRoot)) and
  1414. not(assigned(FHashArray)) then
  1415. begin
  1416. New(FHashArray);
  1417. fillchar(FHashArray^,sizeof(FHashArray^),0);
  1418. end;
  1419. end;
  1420. function counttree(p: tnamedindexitem): longint;
  1421. begin
  1422. counttree:=0;
  1423. if not assigned(p) then
  1424. exit;
  1425. result := 1;
  1426. inc(result,counttree(p.fleft));
  1427. inc(result,counttree(p.fright));
  1428. end;
  1429. destructor Tdictionary.destroy;
  1430. begin
  1431. if not noclear then
  1432. clear;
  1433. if assigned(FHashArray) then
  1434. begin
  1435. dispose(FHashArray);
  1436. end;
  1437. end;
  1438. procedure Tdictionary.cleartree(var obj:TNamedIndexItem);
  1439. begin
  1440. if assigned(obj.Fleft) then
  1441. cleartree(obj.FLeft);
  1442. if assigned(obj.FRight) then
  1443. cleartree(obj.FRight);
  1444. obj.free;
  1445. obj:=nil;
  1446. end;
  1447. procedure Tdictionary.clear;
  1448. var
  1449. w : integer;
  1450. begin
  1451. if assigned(FRoot) then
  1452. cleartree(FRoot);
  1453. if assigned(FHashArray) then
  1454. for w:= low(FHashArray^) to high(FHashArray^) do
  1455. if assigned(FHashArray^[w]) then
  1456. cleartree(FHashArray^[w]);
  1457. end;
  1458. function Tdictionary.delete(const s:string):TNamedIndexItem;
  1459. var
  1460. p,SpeedValue : cardinal;
  1461. n : TNamedIndexItem;
  1462. {$ifdef compress}
  1463. senc:string;
  1464. {$else}
  1465. senc:string absolute s;
  1466. {$endif}
  1467. procedure insert_right_bottom(var root,Atree:TNamedIndexItem);
  1468. begin
  1469. while root.FRight<>nil do
  1470. root:=root.FRight;
  1471. root.FRight:=Atree;
  1472. end;
  1473. function delete_from_tree(root:TNamedIndexItem):TNamedIndexItem;
  1474. type
  1475. leftright=(left,right);
  1476. var
  1477. lr : leftright;
  1478. oldroot : TNamedIndexItem;
  1479. begin
  1480. oldroot:=nil;
  1481. while (root<>nil) and (root.SpeedValue<>SpeedValue) do
  1482. begin
  1483. oldroot:=root;
  1484. if SpeedValue<root.SpeedValue then
  1485. begin
  1486. root:=root.FRight;
  1487. lr:=right;
  1488. end
  1489. else
  1490. begin
  1491. root:=root.FLeft;
  1492. lr:=left;
  1493. end;
  1494. end;
  1495. while (root<>nil) and (root.FName^<>senc) do
  1496. begin
  1497. oldroot:=root;
  1498. if senc<root.FName^ then
  1499. begin
  1500. root:=root.FRight;
  1501. lr:=right;
  1502. end
  1503. else
  1504. begin
  1505. root:=root.FLeft;
  1506. lr:=left;
  1507. end;
  1508. end;
  1509. if root<>nil then
  1510. begin
  1511. dec(FCount);
  1512. if root.FLeft<>nil then
  1513. begin
  1514. { Now the Node pointing to root must point to the left
  1515. subtree of root. The right subtree of root must be
  1516. connected to the right bottom of the left subtree.}
  1517. if lr=left then
  1518. oldroot.FLeft:=root.FLeft
  1519. else
  1520. oldroot.FRight:=root.FLeft;
  1521. if root.FRight<>nil then
  1522. insert_right_bottom(root.FLeft,root.FRight);
  1523. end
  1524. else
  1525. begin
  1526. { There is no left subtree. So we can just replace the Node to
  1527. delete with the right subtree.}
  1528. if lr=left then
  1529. oldroot.FLeft:=root.FRight
  1530. else
  1531. oldroot.FRight:=root.FRight;
  1532. end;
  1533. end;
  1534. delete_from_tree:=root;
  1535. end;
  1536. begin
  1537. {$ifdef compress}
  1538. senc:=minilzw_encode(s);
  1539. {$endif}
  1540. SpeedValue:=GetSpeedValue(s);
  1541. n:=FRoot;
  1542. if assigned(FHashArray) then
  1543. begin
  1544. { First, check if the Node to delete directly located under
  1545. the hasharray.}
  1546. p:=SpeedValue mod hasharraysize;
  1547. n:=FHashArray^[p];
  1548. if (n<>nil) and (n.SpeedValue=SpeedValue) and
  1549. (n.FName^=senc) then
  1550. begin
  1551. { The Node to delete is directly located under the
  1552. hasharray. Make the hasharray point to the left
  1553. subtree of the Node and place the right subtree on
  1554. the right-bottom of the left subtree.}
  1555. if n.FLeft<>nil then
  1556. begin
  1557. FHashArray^[p]:=n.FLeft;
  1558. if n.FRight<>nil then
  1559. insert_right_bottom(n.FLeft,n.FRight);
  1560. end
  1561. else
  1562. FHashArray^[p]:=n.FRight;
  1563. delete:=n;
  1564. dec(FCount);
  1565. exit;
  1566. end;
  1567. end
  1568. else
  1569. begin
  1570. { First check if the Node to delete is the root.}
  1571. if (FRoot<>nil) and (n.SpeedValue=SpeedValue) and
  1572. (n.FName^=senc) then
  1573. begin
  1574. if n.FLeft<>nil then
  1575. begin
  1576. FRoot:=n.FLeft;
  1577. if n.FRight<>nil then
  1578. insert_right_bottom(n.FLeft,n.FRight);
  1579. end
  1580. else
  1581. FRoot:=n.FRight;
  1582. delete:=n;
  1583. dec(FCount);
  1584. exit;
  1585. end;
  1586. end;
  1587. delete:=delete_from_tree(n);
  1588. end;
  1589. function Tdictionary.empty:boolean;
  1590. var
  1591. w : integer;
  1592. begin
  1593. if assigned(FHashArray) then
  1594. begin
  1595. empty:=false;
  1596. for w:=low(FHashArray^) to high(FHashArray^) do
  1597. if assigned(FHashArray^[w]) then
  1598. exit;
  1599. empty:=true;
  1600. end
  1601. else
  1602. empty:=(FRoot=nil);
  1603. end;
  1604. procedure Tdictionary.foreach(proc2call:TNamedIndexcallback;arg:pointer);
  1605. procedure a(p:TNamedIndexItem;arg:pointer);
  1606. begin
  1607. proc2call(p,arg);
  1608. if assigned(p.FLeft) then
  1609. a(p.FLeft,arg);
  1610. if assigned(p.FRight) then
  1611. a(p.FRight,arg);
  1612. end;
  1613. var
  1614. i : integer;
  1615. begin
  1616. if assigned(FHashArray) then
  1617. begin
  1618. for i:=low(FHashArray^) to high(FHashArray^) do
  1619. if assigned(FHashArray^[i]) then
  1620. a(FHashArray^[i],arg);
  1621. end
  1622. else
  1623. if assigned(FRoot) then
  1624. a(FRoot,arg);
  1625. end;
  1626. procedure Tdictionary.foreach_static(proc2call:TNamedIndexStaticCallback;arg:pointer);
  1627. procedure a(p:TNamedIndexItem;arg:pointer);
  1628. begin
  1629. proc2call(p,arg);
  1630. if assigned(p.FLeft) then
  1631. a(p.FLeft,arg);
  1632. if assigned(p.FRight) then
  1633. a(p.FRight,arg);
  1634. end;
  1635. var
  1636. i : integer;
  1637. begin
  1638. if assigned(FHashArray) then
  1639. begin
  1640. for i:=low(FHashArray^) to high(FHashArray^) do
  1641. if assigned(FHashArray^[i]) then
  1642. a(FHashArray^[i],arg);
  1643. end
  1644. else
  1645. if assigned(FRoot) then
  1646. a(FRoot,arg);
  1647. end;
  1648. function Tdictionary.replace(oldobj,newobj:TNamedIndexItem):boolean;
  1649. var
  1650. hp : TNamedIndexItem;
  1651. begin
  1652. hp:=nil;
  1653. Replace:=false;
  1654. { must be the same name and hash }
  1655. if (oldobj.FSpeedValue<>newobj.FSpeedValue) or
  1656. (oldobj.FName^<>newobj.FName^) then
  1657. exit;
  1658. { copy tree info }
  1659. newobj.FLeft:=oldobj.FLeft;
  1660. newobj.FRight:=oldobj.FRight;
  1661. { update treeroot }
  1662. if assigned(FHashArray) then
  1663. begin
  1664. hp:=FHashArray^[newobj.FSpeedValue mod hasharraysize];
  1665. if hp=oldobj then
  1666. begin
  1667. FHashArray^[newobj.FSpeedValue mod hasharraysize]:=newobj;
  1668. hp:=nil;
  1669. end;
  1670. end
  1671. else
  1672. begin
  1673. hp:=FRoot;
  1674. if hp=oldobj then
  1675. begin
  1676. FRoot:=newobj;
  1677. hp:=nil;
  1678. end;
  1679. end;
  1680. { update parent entry }
  1681. while assigned(hp) do
  1682. begin
  1683. { is the node to replace the left or right, then
  1684. update this node and stop }
  1685. if hp.FLeft=oldobj then
  1686. begin
  1687. hp.FLeft:=newobj;
  1688. break;
  1689. end;
  1690. if hp.FRight=oldobj then
  1691. begin
  1692. hp.FRight:=newobj;
  1693. break;
  1694. end;
  1695. { First check SpeedValue, to allow a fast insert }
  1696. if hp.SpeedValue>oldobj.SpeedValue then
  1697. hp:=hp.FRight
  1698. else
  1699. if hp.SpeedValue<oldobj.SpeedValue then
  1700. hp:=hp.FLeft
  1701. else
  1702. begin
  1703. if (hp.FName^=oldobj.FName^) then
  1704. begin
  1705. { this can never happend, return error }
  1706. exit;
  1707. end
  1708. else
  1709. if oldobj.FName^>hp.FName^ then
  1710. hp:=hp.FLeft
  1711. else
  1712. hp:=hp.FRight;
  1713. end;
  1714. end;
  1715. Replace:=true;
  1716. end;
  1717. function Tdictionary.insert(obj:TNamedIndexItem):TNamedIndexItem;
  1718. begin
  1719. inc(FCount);
  1720. if assigned(FHashArray) then
  1721. insert:=insertNode(obj,FHashArray^[obj.SpeedValue mod hasharraysize])
  1722. else
  1723. insert:=insertNode(obj,FRoot);
  1724. end;
  1725. function tdictionary.insertNode(NewNode:TNamedIndexItem;var currNode:TNamedIndexItem):TNamedIndexItem;
  1726. begin
  1727. if currNode=nil then
  1728. begin
  1729. currNode:=NewNode;
  1730. insertNode:=NewNode;
  1731. end
  1732. { First check SpeedValue, to allow a fast insert }
  1733. else
  1734. if currNode.SpeedValue>NewNode.SpeedValue then
  1735. insertNode:=insertNode(NewNode,currNode.FRight)
  1736. else
  1737. if currNode.SpeedValue<NewNode.SpeedValue then
  1738. insertNode:=insertNode(NewNode,currNode.FLeft)
  1739. else
  1740. begin
  1741. if currNode.FName^>NewNode.FName^ then
  1742. insertNode:=insertNode(NewNode,currNode.FRight)
  1743. else
  1744. if currNode.FName^<NewNode.FName^ then
  1745. insertNode:=insertNode(NewNode,currNode.FLeft)
  1746. else
  1747. begin
  1748. if (delete_doubles) and
  1749. assigned(currNode) then
  1750. begin
  1751. NewNode.FLeft:=currNode.FLeft;
  1752. NewNode.FRight:=currNode.FRight;
  1753. if delete_doubles then
  1754. begin
  1755. currnode.FLeft:=nil;
  1756. currnode.FRight:=nil;
  1757. currnode.free;
  1758. end;
  1759. currNode:=NewNode;
  1760. insertNode:=NewNode;
  1761. end
  1762. else
  1763. insertNode:=currNode;
  1764. end;
  1765. end;
  1766. end;
  1767. procedure tdictionary.inserttree(currtree,currroot:TNamedIndexItem);
  1768. begin
  1769. if assigned(currtree) then
  1770. begin
  1771. inserttree(currtree.FLeft,currroot);
  1772. inserttree(currtree.FRight,currroot);
  1773. currtree.FRight:=nil;
  1774. currtree.FLeft:=nil;
  1775. insertNode(currtree,currroot);
  1776. end;
  1777. end;
  1778. function tdictionary.rename(const olds,News : string):TNamedIndexItem;
  1779. var
  1780. spdval : cardinal;
  1781. lasthp,
  1782. hp,hp2,hp3 : TNamedIndexItem;
  1783. {$ifdef compress}
  1784. oldsenc,newsenc:string;
  1785. {$else}
  1786. oldsenc:string absolute olds;
  1787. newsenc:string absolute news;
  1788. {$endif}
  1789. begin
  1790. {$ifdef compress}
  1791. oldsenc:=minilzw_encode(olds);
  1792. newsenc:=minilzw_encode(news);
  1793. {$endif}
  1794. spdval:=GetSpeedValue(olds);
  1795. if assigned(FHashArray) then
  1796. hp:=FHashArray^[spdval mod hasharraysize]
  1797. else
  1798. hp:=FRoot;
  1799. lasthp:=nil;
  1800. while assigned(hp) do
  1801. begin
  1802. if spdval>hp.SpeedValue then
  1803. begin
  1804. lasthp:=hp;
  1805. hp:=hp.FLeft
  1806. end
  1807. else
  1808. if spdval<hp.SpeedValue then
  1809. begin
  1810. lasthp:=hp;
  1811. hp:=hp.FRight
  1812. end
  1813. else
  1814. begin
  1815. if (hp.FName^=oldsenc) then
  1816. begin
  1817. { Get in hp2 the replacer for the root or hasharr }
  1818. hp2:=hp.FLeft;
  1819. hp3:=hp.FRight;
  1820. if not assigned(hp2) then
  1821. begin
  1822. hp2:=hp.FRight;
  1823. hp3:=hp.FLeft;
  1824. end;
  1825. { remove entry from the tree }
  1826. if assigned(lasthp) then
  1827. begin
  1828. if lasthp.FLeft=hp then
  1829. lasthp.FLeft:=hp2
  1830. else
  1831. lasthp.FRight:=hp2;
  1832. end
  1833. else
  1834. begin
  1835. if assigned(FHashArray) then
  1836. FHashArray^[spdval mod hasharraysize]:=hp2
  1837. else
  1838. FRoot:=hp2;
  1839. end;
  1840. { reinsert the hp3 in the tree from hp2 }
  1841. inserttree(hp3,hp2);
  1842. { reset Node with New values }
  1843. hp.FLeft:=nil;
  1844. hp.FRight:=nil;
  1845. stringdispose(hp.FName);
  1846. hp.FName:=stringdup(newsenc);
  1847. hp.FSpeedValue:=GetSpeedValue(news);
  1848. { reinsert }
  1849. if assigned(FHashArray) then
  1850. rename:=insertNode(hp,FHashArray^[hp.SpeedValue mod hasharraysize])
  1851. else
  1852. rename:=insertNode(hp,FRoot);
  1853. exit;
  1854. end
  1855. else
  1856. if oldsenc>hp.FName^ then
  1857. begin
  1858. lasthp:=hp;
  1859. hp:=hp.FLeft
  1860. end
  1861. else
  1862. begin
  1863. lasthp:=hp;
  1864. hp:=hp.FRight;
  1865. end;
  1866. end;
  1867. end;
  1868. result := nil;
  1869. end;
  1870. function Tdictionary.search(const s:string):TNamedIndexItem;
  1871. begin
  1872. search:=speedsearch(s,getspeedvalue(s));
  1873. end;
  1874. function Tdictionary.speedsearch(const s:string;SpeedValue:cardinal):TNamedIndexItem;
  1875. var
  1876. NewNode:TNamedIndexItem;
  1877. {$ifdef compress}
  1878. decn:string;
  1879. {$endif}
  1880. begin
  1881. if assigned(FHashArray) then
  1882. NewNode:=FHashArray^[SpeedValue mod hasharraysize]
  1883. else
  1884. NewNode:=FRoot;
  1885. while assigned(NewNode) do
  1886. begin
  1887. if SpeedValue>NewNode.SpeedValue then
  1888. NewNode:=NewNode.FLeft
  1889. else
  1890. if SpeedValue<NewNode.SpeedValue then
  1891. NewNode:=NewNode.FRight
  1892. else
  1893. begin
  1894. {$ifdef compress}
  1895. decn:=minilzw_decode(newnode.fname^);
  1896. if (decn=s) then
  1897. begin
  1898. speedsearch:=NewNode;
  1899. exit;
  1900. end
  1901. else
  1902. if s>decn then
  1903. NewNode:=NewNode.FLeft
  1904. else
  1905. NewNode:=NewNode.FRight;
  1906. {$else}
  1907. if (NewNode.FName^=s) then
  1908. begin
  1909. speedsearch:=NewNode;
  1910. exit;
  1911. end
  1912. else
  1913. if s>NewNode.FName^ then
  1914. NewNode:=NewNode.FLeft
  1915. else
  1916. NewNode:=NewNode.FRight;
  1917. {$endif}
  1918. end;
  1919. end;
  1920. speedsearch:=nil;
  1921. end;
  1922. {****************************************************************************
  1923. tindexarray
  1924. ****************************************************************************}
  1925. constructor tindexarray.create(Agrowsize:integer);
  1926. begin
  1927. growsize:=Agrowsize;
  1928. size:=0;
  1929. count:=0;
  1930. data:=nil;
  1931. First:=nil;
  1932. noclear:=false;
  1933. end;
  1934. destructor tindexarray.destroy;
  1935. begin
  1936. if assigned(data) then
  1937. begin
  1938. if not noclear then
  1939. clear;
  1940. freemem(data);
  1941. data:=nil;
  1942. end;
  1943. end;
  1944. function tindexarray.search(nr:integer):TNamedIndexItem;
  1945. begin
  1946. if nr<=count then
  1947. search:=data^[nr]
  1948. else
  1949. search:=nil;
  1950. end;
  1951. procedure tindexarray.clear;
  1952. var
  1953. i : integer;
  1954. begin
  1955. for i:=1 to count do
  1956. if assigned(data^[i]) then
  1957. begin
  1958. data^[i].free;
  1959. data^[i]:=nil;
  1960. end;
  1961. count:=0;
  1962. First:=nil;
  1963. end;
  1964. procedure tindexarray.foreach(proc2call : Tnamedindexcallback;arg:pointer);
  1965. var
  1966. i : integer;
  1967. begin
  1968. for i:=1 to count do
  1969. if assigned(data^[i]) then
  1970. proc2call(data^[i],arg);
  1971. end;
  1972. procedure tindexarray.foreach_static(proc2call : Tnamedindexstaticcallback;arg:pointer);
  1973. var
  1974. i : integer;
  1975. begin
  1976. for i:=1 to count do
  1977. if assigned(data^[i]) then
  1978. proc2call(data^[i],arg);
  1979. end;
  1980. procedure tindexarray.grow(gsize:integer);
  1981. var
  1982. osize : integer;
  1983. begin
  1984. osize:=size;
  1985. inc(size,gsize);
  1986. reallocmem(data,size*sizeof(pointer));
  1987. fillchar(data^[osize+1],gsize*sizeof(pointer),0);
  1988. end;
  1989. procedure tindexarray.deleteindex(p:TNamedIndexItem);
  1990. var
  1991. i : integer;
  1992. begin
  1993. i:=p.Findexnr;
  1994. { update counter }
  1995. if i=count then
  1996. dec(count);
  1997. { update Linked List }
  1998. while (i>0) do
  1999. begin
  2000. dec(i);
  2001. if (i>0) and assigned(data^[i]) then
  2002. begin
  2003. data^[i].FindexNext:=data^[p.Findexnr].FindexNext;
  2004. break;
  2005. end;
  2006. end;
  2007. if i=0 then
  2008. First:=p.FindexNext;
  2009. data^[p.FIndexnr]:=nil;
  2010. { clear entry }
  2011. p.FIndexnr:=-1;
  2012. p.FIndexNext:=nil;
  2013. end;
  2014. procedure tindexarray.delete(var p:TNamedIndexItem);
  2015. begin
  2016. deleteindex(p);
  2017. p.free;
  2018. p:=nil;
  2019. end;
  2020. procedure tindexarray.insert(p:TNamedIndexItem);
  2021. var
  2022. i : integer;
  2023. begin
  2024. if p.FIndexnr=-1 then
  2025. begin
  2026. inc(count);
  2027. p.FIndexnr:=count;
  2028. end;
  2029. if p.FIndexnr>count then
  2030. count:=p.FIndexnr;
  2031. if count>size then
  2032. grow(((count div growsize)+1)*growsize);
  2033. Assert(not assigned(data^[p.FIndexnr]) or (p=data^[p.FIndexnr]));
  2034. data^[p.FIndexnr]:=p;
  2035. { update Linked List backward }
  2036. i:=p.FIndexnr;
  2037. while (i>0) do
  2038. begin
  2039. dec(i);
  2040. if (i>0) and assigned(data^[i]) then
  2041. begin
  2042. data^[i].FIndexNext:=p;
  2043. break;
  2044. end;
  2045. end;
  2046. if i=0 then
  2047. First:=p;
  2048. { update Linked List forward }
  2049. i:=p.FIndexnr;
  2050. while (i<=count) do
  2051. begin
  2052. inc(i);
  2053. if (i<=count) and assigned(data^[i]) then
  2054. begin
  2055. p.FIndexNext:=data^[i];
  2056. exit;
  2057. end;
  2058. end;
  2059. if i>count then
  2060. p.FIndexNext:=nil;
  2061. end;
  2062. procedure tindexarray.replace(oldp,newp:TNamedIndexItem);
  2063. var
  2064. i : integer;
  2065. begin
  2066. newp.FIndexnr:=oldp.FIndexnr;
  2067. newp.FIndexNext:=oldp.FIndexNext;
  2068. data^[newp.FIndexnr]:=newp;
  2069. if First=oldp then
  2070. First:=newp;
  2071. { update Linked List backward }
  2072. i:=newp.FIndexnr;
  2073. while (i>0) do
  2074. begin
  2075. dec(i);
  2076. if (i>0) and assigned(data^[i]) then
  2077. begin
  2078. data^[i].FIndexNext:=newp;
  2079. break;
  2080. end;
  2081. end;
  2082. end;
  2083. {****************************************************************************
  2084. tdynamicarray
  2085. ****************************************************************************}
  2086. constructor tdynamicarray.create(Ablocksize:integer);
  2087. begin
  2088. FPosn:=0;
  2089. FPosnblock:=nil;
  2090. FFirstblock:=nil;
  2091. FLastblock:=nil;
  2092. Fblocksize:=Ablocksize;
  2093. grow;
  2094. end;
  2095. destructor tdynamicarray.destroy;
  2096. var
  2097. hp : pdynamicblock;
  2098. begin
  2099. while assigned(FFirstblock) do
  2100. begin
  2101. hp:=FFirstblock;
  2102. FFirstblock:=FFirstblock^.Next;
  2103. Freemem(hp);
  2104. end;
  2105. end;
  2106. function tdynamicarray.size:integer;
  2107. begin
  2108. if assigned(FLastblock) then
  2109. size:=FLastblock^.pos+FLastblock^.used
  2110. else
  2111. size:=0;
  2112. end;
  2113. procedure tdynamicarray.reset;
  2114. var
  2115. hp : pdynamicblock;
  2116. begin
  2117. while assigned(FFirstblock) do
  2118. begin
  2119. hp:=FFirstblock;
  2120. FFirstblock:=FFirstblock^.Next;
  2121. Freemem(hp);
  2122. end;
  2123. FPosn:=0;
  2124. FPosnblock:=nil;
  2125. FFirstblock:=nil;
  2126. FLastblock:=nil;
  2127. grow;
  2128. end;
  2129. procedure tdynamicarray.grow;
  2130. var
  2131. nblock : pdynamicblock;
  2132. begin
  2133. Getmem(nblock,blocksize+dynamicblockbasesize);
  2134. if not assigned(FFirstblock) then
  2135. begin
  2136. FFirstblock:=nblock;
  2137. FPosnblock:=nblock;
  2138. nblock^.pos:=0;
  2139. end
  2140. else
  2141. begin
  2142. FLastblock^.Next:=nblock;
  2143. nblock^.pos:=FLastblock^.pos+FLastblock^.used;
  2144. end;
  2145. nblock^.used:=0;
  2146. nblock^.Next:=nil;
  2147. fillchar(nblock^.data,blocksize,0);
  2148. FLastblock:=nblock;
  2149. end;
  2150. procedure tdynamicarray.align(i:integer);
  2151. var
  2152. j : integer;
  2153. begin
  2154. j:=(FPosn mod i);
  2155. if j<>0 then
  2156. begin
  2157. j:=i-j;
  2158. if FPosnblock^.used+j>blocksize then
  2159. begin
  2160. dec(j,blocksize-FPosnblock^.used);
  2161. FPosnblock^.used:=blocksize;
  2162. grow;
  2163. FPosnblock:=FLastblock;
  2164. end;
  2165. inc(FPosnblock^.used,j);
  2166. inc(FPosn,j);
  2167. end;
  2168. end;
  2169. procedure tdynamicarray.seek(i:integer);
  2170. begin
  2171. if (i<FPosnblock^.pos) or (i>=FPosnblock^.pos+blocksize) then
  2172. begin
  2173. { set FPosnblock correct if the size is bigger then
  2174. the current block }
  2175. if FPosnblock^.pos>i then
  2176. FPosnblock:=FFirstblock;
  2177. while assigned(FPosnblock) do
  2178. begin
  2179. if FPosnblock^.pos+blocksize>i then
  2180. break;
  2181. FPosnblock:=FPosnblock^.Next;
  2182. end;
  2183. { not found ? then increase blocks }
  2184. if not assigned(FPosnblock) then
  2185. begin
  2186. repeat
  2187. { the current FLastblock is now also fully used }
  2188. FLastblock^.used:=blocksize;
  2189. grow;
  2190. FPosnblock:=FLastblock;
  2191. until FPosnblock^.pos+blocksize>=i;
  2192. end;
  2193. end;
  2194. FPosn:=i;
  2195. if FPosn mod blocksize>FPosnblock^.used then
  2196. FPosnblock^.used:=FPosn mod blocksize;
  2197. end;
  2198. procedure tdynamicarray.write(const d;len:integer);
  2199. var
  2200. p : pchar;
  2201. i,j : integer;
  2202. begin
  2203. p:=pchar(@d);
  2204. while (len>0) do
  2205. begin
  2206. i:=FPosn mod blocksize;
  2207. if i+len>=blocksize then
  2208. begin
  2209. j:=blocksize-i;
  2210. move(p^,FPosnblock^.data[i],j);
  2211. inc(p,j);
  2212. inc(FPosn,j);
  2213. dec(len,j);
  2214. FPosnblock^.used:=blocksize;
  2215. if assigned(FPosnblock^.Next) then
  2216. FPosnblock:=FPosnblock^.Next
  2217. else
  2218. begin
  2219. grow;
  2220. FPosnblock:=FLastblock;
  2221. end;
  2222. end
  2223. else
  2224. begin
  2225. move(p^,FPosnblock^.data[i],len);
  2226. inc(p,len);
  2227. inc(FPosn,len);
  2228. i:=FPosn mod blocksize;
  2229. if i>FPosnblock^.used then
  2230. FPosnblock^.used:=i;
  2231. len:=0;
  2232. end;
  2233. end;
  2234. end;
  2235. procedure tdynamicarray.writestr(const s:string);
  2236. begin
  2237. write(s[1],length(s));
  2238. end;
  2239. function tdynamicarray.read(var d;len:integer):integer;
  2240. var
  2241. p : pchar;
  2242. i,j,res : integer;
  2243. begin
  2244. res:=0;
  2245. p:=pchar(@d);
  2246. while (len>0) do
  2247. begin
  2248. i:=FPosn mod blocksize;
  2249. if i+len>=FPosnblock^.used then
  2250. begin
  2251. j:=FPosnblock^.used-i;
  2252. move(FPosnblock^.data[i],p^,j);
  2253. inc(p,j);
  2254. inc(FPosn,j);
  2255. inc(res,j);
  2256. dec(len,j);
  2257. if assigned(FPosnblock^.Next) then
  2258. FPosnblock:=FPosnblock^.Next
  2259. else
  2260. break;
  2261. end
  2262. else
  2263. begin
  2264. move(FPosnblock^.data[i],p^,len);
  2265. inc(p,len);
  2266. inc(FPosn,len);
  2267. inc(res,len);
  2268. len:=0;
  2269. end;
  2270. end;
  2271. read:=res;
  2272. end;
  2273. procedure tdynamicarray.readstream(f:TCStream;maxlen:longint);
  2274. var
  2275. i,left : integer;
  2276. begin
  2277. if maxlen=-1 then
  2278. maxlen:=maxlongint;
  2279. repeat
  2280. left:=blocksize-FPosnblock^.used;
  2281. if left>maxlen then
  2282. left:=maxlen;
  2283. i:=f.Read(FPosnblock^.data[FPosnblock^.used],left);
  2284. dec(maxlen,i);
  2285. inc(FPosnblock^.used,i);
  2286. if FPosnblock^.used=blocksize then
  2287. begin
  2288. if assigned(FPosnblock^.Next) then
  2289. FPosnblock:=FPosnblock^.Next
  2290. else
  2291. begin
  2292. grow;
  2293. FPosnblock:=FLastblock;
  2294. end;
  2295. end;
  2296. until (i<left) or (maxlen=0);
  2297. end;
  2298. procedure tdynamicarray.writestream(f:TCStream);
  2299. var
  2300. hp : pdynamicblock;
  2301. begin
  2302. hp:=FFirstblock;
  2303. while assigned(hp) do
  2304. begin
  2305. f.Write(hp^.data,hp^.used);
  2306. hp:=hp^.Next;
  2307. end;
  2308. end;
  2309. end.