cobjects.pas 60 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 by Florian Klaempfl
  4. This module provides some basic objects
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  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. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. {$ifdef tp}
  19. {$E+,N+,D+,F+}
  20. {$endif}
  21. {$I-}
  22. {$R-}{ necessary for crc calculation }
  23. unit cobjects;
  24. { define OLDSPEEDVALUE}
  25. interface
  26. uses
  27. {$ifdef DELPHI4}
  28. dmisc,
  29. sysutils
  30. {$else DELPHI4}
  31. strings
  32. {$ifndef linux}
  33. ,dos
  34. {$else}
  35. ,linux
  36. {$endif}
  37. {$endif DELPHI4}
  38. ;
  39. const
  40. { the real size will be [-hasharray..hasharray] ! }
  41. {$ifdef TP}
  42. hasharraysize = 127;
  43. {$else}
  44. hasharraysize = 2047;
  45. {$endif}
  46. type
  47. pstring = ^string;
  48. {$ifdef TP}
  49. { redeclare dword only in case of emergency, some small things
  50. of the compiler won't work then correctly (FK)
  51. }
  52. dword = longint;
  53. {$endif TP}
  54. pfileposinfo = ^tfileposinfo;
  55. tfileposinfo = record
  56. line : longint;
  57. column : word;
  58. fileindex : word;
  59. end;
  60. pmemdebug = ^tmemdebug;
  61. tmemdebug = object
  62. constructor init(const s:string);
  63. destructor done;
  64. procedure show;
  65. private
  66. startmem : longint;
  67. infostr : string[40];
  68. end;
  69. plinkedlist_item = ^tlinkedlist_item;
  70. tlinkedlist_item = object
  71. next,previous : plinkedlist_item;
  72. { does nothing }
  73. constructor init;
  74. destructor done;virtual;
  75. function getcopy:plinkedlist_item;virtual;
  76. end;
  77. pstring_item = ^tstring_item;
  78. tstring_item = object(tlinkedlist_item)
  79. str : pstring;
  80. constructor init(const s : string);
  81. destructor done;virtual;
  82. end;
  83. { this implements a double linked list }
  84. plinkedlist = ^tlinkedlist;
  85. tlinkedlist = object
  86. first,last : plinkedlist_item;
  87. constructor init;
  88. destructor done;
  89. { destructors the linkedlist without cleaning the items up }
  90. destructor done_noclear;
  91. { disposes the items of the list }
  92. procedure clear;
  93. { concats a new item at the end }
  94. procedure concat(p : plinkedlist_item);
  95. { inserts a new item at the begin }
  96. procedure insert(p : plinkedlist_item);
  97. { inserts another list at the begin and make this list empty }
  98. procedure insertlist(p : plinkedlist);
  99. { concats another list at the end and make this list empty }
  100. procedure concatlist(p : plinkedlist);
  101. procedure concatlistcopy(p : plinkedlist);
  102. { removes p from the list (p isn't disposed) }
  103. { it's not tested if p is in the list ! }
  104. procedure remove(p : plinkedlist_item);
  105. { is the linkedlist empty ? }
  106. function empty:boolean;
  107. { items in the list }
  108. function count:longint;
  109. end;
  110. { some help data types }
  111. pstringqueueitem = ^tstringqueueitem;
  112. tstringqueueitem = object
  113. data : pstring;
  114. next : pstringqueueitem;
  115. end;
  116. { String Queue}
  117. PStringQueue=^TStringQueue;
  118. TStringQueue=object
  119. first,last : PStringqueueItem;
  120. constructor Init;
  121. destructor Done;
  122. function Empty:boolean;
  123. function Get:string;
  124. function Find(const s:string):PStringqueueItem;
  125. function Delete(const s:string):boolean;
  126. procedure Insert(const s:string);
  127. procedure Concat(const s:string);
  128. procedure Clear;
  129. end;
  130. { containeritem }
  131. pcontaineritem = ^tcontaineritem;
  132. tcontaineritem = object
  133. next : pcontaineritem;
  134. constructor init;
  135. destructor done;virtual;
  136. end;
  137. { container }
  138. pcontainer = ^tcontainer;
  139. tcontainer = object
  140. root,
  141. last : pcontaineritem;
  142. constructor init;
  143. destructor done;
  144. { true when the container is empty }
  145. function empty:boolean;
  146. { amount of strings in the container }
  147. function count:longint;
  148. { inserts a string }
  149. procedure insert(item:pcontaineritem);
  150. { gets a string }
  151. function get:pcontaineritem;
  152. { deletes all items }
  153. procedure clear;
  154. end;
  155. { containeritem }
  156. pstringcontaineritem = ^tstringcontaineritem;
  157. tstringcontaineritem = object(tcontaineritem)
  158. data : pstring;
  159. file_info : tfileposinfo;
  160. constructor init(const s:string);
  161. constructor Init_TokenInfo(const s:string;const pos:tfileposinfo);
  162. destructor done;virtual;
  163. end;
  164. { string container }
  165. pstringcontainer = ^tstringcontainer;
  166. tstringcontainer = object(tcontainer)
  167. doubles : boolean; { if this is set to true, doubles are allowed }
  168. constructor init;
  169. constructor init_no_double;
  170. procedure insert(const s : string);
  171. procedure insert_with_tokeninfo(const s : string;const file_info : tfileposinfo);
  172. { gets a string }
  173. function get : string;
  174. function get_with_tokeninfo(var file_info : tfileposinfo) : string;
  175. { true if string is in the container }
  176. function find(const s:string):boolean;
  177. end;
  178. { namedindexobject for use with dictionary and indexarray }
  179. Pnamedindexobject=^Tnamedindexobject;
  180. Tnamedindexobject=object
  181. indexnr : longint;
  182. _name : Pstring;
  183. next,
  184. left,right : Pnamedindexobject;
  185. speedvalue : longint;
  186. constructor init;
  187. constructor initname(const n:string);
  188. destructor done;virtual;
  189. procedure setname(const n:string);virtual;
  190. function name:string;virtual;
  191. end;
  192. Pdictionaryhasharray=^Tdictionaryhasharray;
  193. Tdictionaryhasharray=array[-hasharraysize..hasharraysize] of Pnamedindexobject;
  194. Tnamedindexcallback = procedure(p:Pnamedindexobject);
  195. Pdictionary=^Tdictionary;
  196. Tdictionary=object
  197. noclear : boolean;
  198. replace_existing : boolean;
  199. constructor init;
  200. destructor done;virtual;
  201. procedure usehash;
  202. procedure clear;
  203. function delete(const s:string):Pnamedindexobject;
  204. function empty:boolean;
  205. procedure foreach(proc2call:Tnamedindexcallback);
  206. function insert(obj:Pnamedindexobject):Pnamedindexobject;
  207. function rename(const olds,news : string):Pnamedindexobject;
  208. function search(const s:string):Pnamedindexobject;
  209. function speedsearch(const s:string;speedvalue:longint):Pnamedindexobject;
  210. private
  211. root : Pnamedindexobject;
  212. hasharray : Pdictionaryhasharray;
  213. procedure cleartree(obj:Pnamedindexobject);
  214. function insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject;
  215. procedure inserttree(currtree,currroot:Pnamedindexobject);
  216. end;
  217. pdynamicarray = ^tdynamicarray;
  218. tdynamicarray = object
  219. posn,
  220. count,
  221. limit,
  222. elemlen,
  223. growcount : longint;
  224. data : pchar;
  225. constructor init(Aelemlen,Agrow:longint);
  226. destructor done;
  227. function size:longint;
  228. function usedsize:longint;
  229. procedure grow;
  230. procedure align(i:longint);
  231. procedure seek(i:longint);
  232. procedure write(var d;len:longint);
  233. procedure read(var d;len:longint);
  234. procedure writepos(pos:longint;var d;len:longint);
  235. procedure readpos(pos:longint;var d;len:longint);
  236. end;
  237. tindexobjectarray=array[1..16000] of Pnamedindexobject;
  238. Pnamedindexobjectarray=^tindexobjectarray;
  239. pindexarray=^tindexarray;
  240. tindexarray=object
  241. first : Pnamedindexobject;
  242. count : longint;
  243. constructor init(Agrowsize:longint);
  244. destructor done;
  245. procedure clear;
  246. procedure foreach(proc2call : Tnamedindexcallback);
  247. procedure deleteindex(p:Pnamedindexobject);
  248. procedure delete(p:Pnamedindexobject);
  249. procedure insert(p:Pnamedindexobject);
  250. function search(nr:longint):Pnamedindexobject;
  251. private
  252. growsize,
  253. size : longint;
  254. data : Pnamedindexobjectarray;
  255. procedure grow(gsize:longint);
  256. end;
  257. {$ifdef BUFFEREDFILE}
  258. { this is implemented to allow buffered binary I/O }
  259. pbufferedfile = ^tbufferedfile;
  260. tbufferedfile = object
  261. f : file;
  262. buf : pchar;
  263. bufsize,buflast,bufpos : longint;
  264. { 0 closed, 1 input, 2 output }
  265. iomode : byte;
  266. { true, if the compile should change the endian of the output }
  267. change_endian : boolean;
  268. { calcules a crc for the file, }
  269. { but it's assumed, that there no seek while do_crc is true }
  270. do_crc : boolean;
  271. crc : longint;
  272. { temporary closing feature }
  273. tempclosed : boolean;
  274. tempmode : byte;
  275. temppos : longint;
  276. { inits a buffer with the size bufsize which is assigned to }
  277. { the file filename }
  278. constructor init(const filename : string;_bufsize : longint);
  279. { closes the file, if needed, and releases the memory }
  280. destructor done;virtual;
  281. { opens the file for input, other accesses are rejected }
  282. function reset:boolean;
  283. { opens the file for output, other accesses are rejected }
  284. procedure rewrite;
  285. { reads or writes the buffer from or to disk }
  286. procedure flush;
  287. { writes a string to the file }
  288. { the string is written without a length byte }
  289. procedure write_string(const s : string);
  290. { writes a zero terminated string }
  291. procedure write_pchar(p : pchar);
  292. { write specific data types, takes care of }
  293. { byte order }
  294. procedure write_byte(b : byte);
  295. procedure write_word(w : word);
  296. procedure write_long(l : longint);
  297. procedure write_double(d : double);
  298. { writes any data }
  299. procedure write_data(var data;count : longint);
  300. { reads any data }
  301. procedure read_data(var data;bytes : longint;var count : longint);
  302. { closes the file and releases the buffer }
  303. procedure close;
  304. { temporary closing }
  305. procedure tempclose;
  306. procedure tempreopen;
  307. { goto the given position }
  308. procedure seek(l : longint);
  309. { installes an user defined buffer }
  310. { and releases the old one, but be }
  311. { careful, if the old buffer contains }
  312. { data, this data is lost }
  313. procedure setbuf(p : pchar;s : longint);
  314. { reads the file time stamp of the file, }
  315. { the file must be opened }
  316. function getftime : longint;
  317. { returns filesize }
  318. function getsize : longint;
  319. { returns the path }
  320. function getpath : string;
  321. { resets the crc }
  322. procedure clear_crc;
  323. { returns the crc }
  324. function getcrc : longint;
  325. end;
  326. {$endif BUFFEREDFILE}
  327. {$ifdef fixLeaksOnError}
  328. PStackItem = ^TStackItem;
  329. TStackItem = record
  330. next: PStackItem;
  331. data: pointer;
  332. end;
  333. PStack = ^TStack;
  334. TStack = object
  335. constructor init;
  336. destructor done;
  337. procedure push(p: pointer);
  338. function pop: pointer;
  339. function top: pointer;
  340. function isEmpty: boolean;
  341. private
  342. head: PStackItem;
  343. end;
  344. {$endif fixLeaksOnError}
  345. function getspeedvalue(const s : string) : longint;
  346. { releases the string p and assignes nil to p }
  347. { if p=nil then freemem isn't called }
  348. procedure stringdispose(var p : pstring);
  349. { idem for ansistrings }
  350. procedure ansistringdispose(var p : pchar;length : longint);
  351. { allocates mem for a copy of s, copies s to this mem and returns }
  352. { a pointer to this mem }
  353. function stringdup(const s : string) : pstring;
  354. { allocates memory for s and copies s as zero terminated string
  355. to that mem and returns a pointer to that mem }
  356. function strpnew(const s : string) : pchar;
  357. procedure strdispose(var p : pchar);
  358. { makes a char lowercase, with spanish, french and german char set }
  359. function lowercase(c : char) : char;
  360. { makes zero terminated string to a pascal string }
  361. { the data in p is modified and p is returned }
  362. function pchar2pstring(p : pchar) : pstring;
  363. { ambivalent to pchar2pstring }
  364. function pstring2pchar(p : pstring) : pchar;
  365. implementation
  366. uses
  367. comphook;
  368. {*****************************************************************************
  369. Memory debug
  370. *****************************************************************************}
  371. constructor tmemdebug.init(const s:string);
  372. begin
  373. infostr:=s;
  374. {$ifdef Delphi}
  375. startmem:=0;
  376. {$else}
  377. startmem:=memavail;
  378. {$endif Delphi}
  379. end;
  380. procedure tmemdebug.show;
  381. var
  382. l : longint;
  383. begin
  384. {$ifndef Delphi}
  385. write('memory [',infostr,'] ');
  386. l:=memavail;
  387. if l>startmem then
  388. writeln(l-startmem,' released')
  389. else
  390. writeln(startmem-l,' allocated');
  391. {$endif Delphi}
  392. end;
  393. destructor tmemdebug.done;
  394. begin
  395. show;
  396. end;
  397. {*****************************************************************************
  398. Stack
  399. *****************************************************************************}
  400. {$ifdef fixLeaksOnError}
  401. constructor TStack.init;
  402. begin
  403. head := nil;
  404. end;
  405. procedure TStack.push(p: pointer);
  406. var s: PStackItem;
  407. begin
  408. new(s);
  409. s^.data := p;
  410. s^.next := head;
  411. head := s;
  412. end;
  413. function TStack.pop: pointer;
  414. var s: PStackItem;
  415. begin
  416. pop := top;
  417. if assigned(head) then
  418. begin
  419. s := head^.next;
  420. dispose(head);
  421. head := s;
  422. end
  423. end;
  424. function TStack.top: pointer;
  425. begin
  426. if not isEmpty then
  427. top := head^.data
  428. else top := NIL;
  429. end;
  430. function TStack.isEmpty: boolean;
  431. begin
  432. isEmpty := head = nil;
  433. end;
  434. destructor TStack.done;
  435. var temp: PStackItem;
  436. begin
  437. while head <> nil do
  438. begin
  439. temp := head^.next;
  440. dispose(head);
  441. head := temp;
  442. end;
  443. end;
  444. {$endif fixLeaksOnError}
  445. {$ifndef OLDSPEEDVALUE}
  446. {*****************************************************************************
  447. Crc 32
  448. *****************************************************************************}
  449. var
  450. Crc32Tbl : array[0..255] of longint;
  451. procedure MakeCRC32Tbl;
  452. var
  453. crc : longint;
  454. i,n : byte;
  455. begin
  456. for i:=0 to 255 do
  457. begin
  458. crc:=i;
  459. for n:=1 to 8 do
  460. if odd(crc) then
  461. crc:=(crc shr 1) xor longint($edb88320)
  462. else
  463. crc:=crc shr 1;
  464. Crc32Tbl[i]:=crc;
  465. end;
  466. end;
  467. {$ifopt R+}
  468. {$define Range_check_on}
  469. {$endif opt R+}
  470. {$R- needed here }
  471. {CRC 32}
  472. Function GetSpeedValue(Const s:String):longint;
  473. var
  474. i,InitCrc : longint;
  475. begin
  476. if Crc32Tbl[1]=0 then
  477. MakeCrc32Tbl;
  478. InitCrc:=$ffffffff;
  479. for i:=1 to Length(s) do
  480. InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8);
  481. GetSpeedValue:=InitCrc;
  482. end;
  483. {$ifdef Range_check_on}
  484. {$R+}
  485. {$undef Range_check_on}
  486. {$endif Range_check_on}
  487. {$else}
  488. {$ifndef TP}
  489. function getspeedvalue(const s : string) : longint;
  490. var
  491. p1,p2:^byte;
  492. i : longint;
  493. begin
  494. p1:=@s;
  495. longint(p2):=longint(p1)+p1^+1;
  496. inc(longint(p1));
  497. i:=0;
  498. while p1<>p2 do
  499. begin
  500. i:=i + ord(p1^);
  501. inc(longint(p1));
  502. end;
  503. getspeedvalue:=i;
  504. end;
  505. {$else}
  506. function getspeedvalue(const s : string) : longint;
  507. type
  508. ptrrec=record
  509. ofs,seg:word;
  510. end;
  511. var
  512. l,w : longint;
  513. p1,p2 : ^byte;
  514. begin
  515. p1:=@s;
  516. ptrrec(p2).seg:=ptrrec(p1).seg;
  517. ptrrec(p2).ofs:=ptrrec(p1).ofs+p1^+1;
  518. inc(p1);
  519. l:=0;
  520. while p1<>p2 do
  521. begin
  522. l:=l + ord(p1^);
  523. inc(p1);
  524. end;
  525. getspeedvalue:=l;
  526. end;
  527. {$endif}
  528. {$endif OLDSPEEDVALUE}
  529. function pchar2pstring(p : pchar) : pstring;
  530. var
  531. w,i : longint;
  532. begin
  533. w:=strlen(p);
  534. for i:=w-1 downto 0 do
  535. p[i+1]:=p[i];
  536. p[0]:=chr(w);
  537. pchar2pstring:=pstring(p);
  538. end;
  539. function pstring2pchar(p : pstring) : pchar;
  540. var
  541. w,i : longint;
  542. begin
  543. w:=length(p^);
  544. for i:=1 to w do
  545. p^[i-1]:=p^[i];
  546. p^[w]:=#0;
  547. pstring2pchar:=pchar(p);
  548. end;
  549. function lowercase(c : char) : char;
  550. begin
  551. case c of
  552. #65..#90 : c := chr(ord (c) + 32);
  553. #154 : c:=#129; { german }
  554. #142 : c:=#132; { german }
  555. #153 : c:=#148; { german }
  556. #144 : c:=#130; { french }
  557. #128 : c:=#135; { french }
  558. #143 : c:=#134; { swedish/norge (?) }
  559. #165 : c:=#164; { spanish }
  560. #228 : c:=#229; { greek }
  561. #226 : c:=#231; { greek }
  562. #232 : c:=#227; { greek }
  563. end;
  564. lowercase := c;
  565. end;
  566. function strpnew(const s : string) : pchar;
  567. var
  568. p : pchar;
  569. begin
  570. getmem(p,length(s)+1);
  571. strpcopy(p,s);
  572. strpnew:=p;
  573. end;
  574. procedure strdispose(var p : pchar);
  575. begin
  576. if assigned(p) then
  577. begin
  578. freemem(p,strlen(p)+1);
  579. p:=nil;
  580. end;
  581. end;
  582. procedure stringdispose(var p : pstring);
  583. begin
  584. if assigned(p) then
  585. freemem(p,length(p^)+1);
  586. p:=nil;
  587. end;
  588. procedure ansistringdispose(var p : pchar;length : longint);
  589. begin
  590. if assigned(p) then
  591. freemem(p,length+1);
  592. p:=nil;
  593. end;
  594. function stringdup(const s : string) : pstring;
  595. var
  596. p : pstring;
  597. begin
  598. getmem(p,length(s)+1);
  599. p^:=s;
  600. stringdup:=p;
  601. end;
  602. {****************************************************************************
  603. TStringQueue
  604. ****************************************************************************}
  605. constructor TStringQueue.Init;
  606. begin
  607. first:=nil;
  608. last:=nil;
  609. end;
  610. function TStringQueue.Empty:boolean;
  611. begin
  612. Empty:=(first=nil);
  613. end;
  614. function TStringQueue.Get:string;
  615. var
  616. newnode : pstringqueueitem;
  617. begin
  618. if first=nil then
  619. begin
  620. Get:='';
  621. exit;
  622. end;
  623. Get:=first^.data^;
  624. stringdispose(first^.data);
  625. newnode:=first;
  626. first:=first^.next;
  627. dispose(newnode);
  628. end;
  629. function TStringQueue.Find(const s:string):PStringqueueItem;
  630. var
  631. p : PStringqueueItem;
  632. begin
  633. p:=first;
  634. while assigned(p) do
  635. begin
  636. if p^.data^=s then
  637. break;
  638. p:=p^.next;
  639. end;
  640. Find:=p;
  641. end;
  642. function TStringQueue.Delete(const s:string):boolean;
  643. var
  644. prev,p : PStringqueueItem;
  645. begin
  646. Delete:=false;
  647. prev:=nil;
  648. p:=first;
  649. while assigned(p) do
  650. begin
  651. if p^.data^=s then
  652. begin
  653. if p=last then
  654. last:=prev;
  655. if assigned(prev) then
  656. prev^.next:=p^.next
  657. else
  658. first:=p^.next;
  659. dispose(p);
  660. Delete:=true;
  661. exit;
  662. end;
  663. prev:=p;
  664. p:=p^.next;
  665. end;
  666. end;
  667. procedure TStringQueue.Insert(const s:string);
  668. var
  669. newnode : pstringqueueitem;
  670. begin
  671. new(newnode);
  672. newnode^.next:=first;
  673. newnode^.data:=stringdup(s);
  674. first:=newnode;
  675. if last=nil then
  676. last:=newnode;
  677. end;
  678. procedure TStringQueue.Concat(const s:string);
  679. var
  680. newnode : pstringqueueitem;
  681. begin
  682. new(newnode);
  683. newnode^.next:=nil;
  684. newnode^.data:=stringdup(s);
  685. if first=nil then
  686. first:=newnode
  687. else
  688. last^.next:=newnode;
  689. last:=newnode;
  690. end;
  691. procedure TStringQueue.Clear;
  692. var
  693. newnode : pstringqueueitem;
  694. begin
  695. while (first<>nil) do
  696. begin
  697. newnode:=first;
  698. stringdispose(first^.data);
  699. first:=first^.next;
  700. dispose(newnode);
  701. end;
  702. last:=nil;
  703. end;
  704. destructor TStringQueue.Done;
  705. begin
  706. Clear;
  707. end;
  708. {****************************************************************************
  709. TContainerItem
  710. ****************************************************************************}
  711. constructor TContainerItem.Init;
  712. begin
  713. end;
  714. destructor TContainerItem.Done;
  715. begin
  716. end;
  717. {****************************************************************************
  718. TStringContainerItem
  719. ****************************************************************************}
  720. constructor TStringContainerItem.Init(const s:string);
  721. begin
  722. inherited Init;
  723. data:=stringdup(s);
  724. file_info.fileindex:=0;
  725. file_info.line:=0;
  726. file_info.column:=0;
  727. end;
  728. constructor TStringContainerItem.Init_TokenInfo(const s:string;const pos:tfileposinfo);
  729. begin
  730. inherited Init;
  731. data:=stringdup(s);
  732. file_info:=pos;
  733. end;
  734. destructor TStringContainerItem.Done;
  735. begin
  736. stringdispose(data);
  737. end;
  738. {****************************************************************************
  739. TCONTAINER
  740. ****************************************************************************}
  741. constructor tcontainer.init;
  742. begin
  743. root:=nil;
  744. last:=nil;
  745. end;
  746. destructor tcontainer.done;
  747. begin
  748. clear;
  749. end;
  750. function tcontainer.empty:boolean;
  751. begin
  752. empty:=(root=nil);
  753. end;
  754. function tcontainer.count:longint;
  755. var
  756. i : longint;
  757. p : pcontaineritem;
  758. begin
  759. i:=0;
  760. p:=root;
  761. while assigned(p) do
  762. begin
  763. p:=p^.next;
  764. inc(i);
  765. end;
  766. count:=i;
  767. end;
  768. procedure tcontainer.insert(item:pcontaineritem);
  769. begin
  770. item^.next:=nil;
  771. if root=nil then
  772. root:=item
  773. else
  774. last^.next:=item;
  775. last:=item;
  776. end;
  777. procedure tcontainer.clear;
  778. var
  779. newnode : pcontaineritem;
  780. begin
  781. newnode:=root;
  782. while assigned(newnode) do
  783. begin
  784. root:=newnode^.next;
  785. dispose(newnode,done);
  786. newnode:=root;
  787. end;
  788. last:=nil;
  789. root:=nil;
  790. end;
  791. function tcontainer.get:pcontaineritem;
  792. begin
  793. if root=nil then
  794. get:=nil
  795. else
  796. begin
  797. get:=root;
  798. root:=root^.next;
  799. end;
  800. end;
  801. {****************************************************************************
  802. TSTRINGCONTAINER
  803. ****************************************************************************}
  804. constructor tstringcontainer.init;
  805. begin
  806. inherited init;
  807. doubles:=true;
  808. end;
  809. constructor tstringcontainer.init_no_double;
  810. begin
  811. inherited init;
  812. doubles:=false;
  813. end;
  814. procedure tstringcontainer.insert(const s : string);
  815. var
  816. newnode : pstringcontaineritem;
  817. begin
  818. if (s='') or
  819. ((not doubles) and find(s)) then
  820. exit;
  821. new(newnode,init(s));
  822. inherited insert(newnode);
  823. end;
  824. procedure tstringcontainer.insert_with_tokeninfo(const s : string; const file_info : tfileposinfo);
  825. var
  826. newnode : pstringcontaineritem;
  827. begin
  828. if (not doubles) and find(s) then
  829. exit;
  830. new(newnode,init_tokeninfo(s,file_info));
  831. inherited insert(newnode);
  832. end;
  833. function tstringcontainer.get : string;
  834. var
  835. p : pstringcontaineritem;
  836. begin
  837. p:=pstringcontaineritem(inherited get);
  838. if p=nil then
  839. get:=''
  840. else
  841. begin
  842. get:=p^.data^;
  843. dispose(p,done);
  844. end;
  845. end;
  846. function tstringcontainer.get_with_tokeninfo(var file_info : tfileposinfo) : string;
  847. var
  848. p : pstringcontaineritem;
  849. begin
  850. p:=pstringcontaineritem(inherited get);
  851. if p=nil then
  852. begin
  853. get_with_tokeninfo:='';
  854. file_info.fileindex:=0;
  855. file_info.line:=0;
  856. file_info.column:=0;
  857. end
  858. else
  859. begin
  860. get_with_tokeninfo:=p^.data^;
  861. file_info:=p^.file_info;
  862. dispose(p,done);
  863. end;
  864. end;
  865. function tstringcontainer.find(const s:string):boolean;
  866. var
  867. newnode : pstringcontaineritem;
  868. begin
  869. find:=false;
  870. newnode:=pstringcontaineritem(root);
  871. while assigned(newnode) do
  872. begin
  873. if newnode^.data^=s then
  874. begin
  875. find:=true;
  876. exit;
  877. end;
  878. newnode:=pstringcontaineritem(newnode^.next);
  879. end;
  880. end;
  881. {****************************************************************************
  882. TLINKEDLIST_ITEM
  883. ****************************************************************************}
  884. constructor tlinkedlist_item.init;
  885. begin
  886. previous:=nil;
  887. next:=nil;
  888. end;
  889. destructor tlinkedlist_item.done;
  890. begin
  891. end;
  892. function tlinkedlist_item.getcopy:plinkedlist_item;
  893. var
  894. l : longint;
  895. p : plinkedlist_item;
  896. begin
  897. l:=sizeof(self);
  898. getmem(p,l);
  899. move(self,p^,l);
  900. getcopy:=p;
  901. end;
  902. {****************************************************************************
  903. TSTRING_ITEM
  904. ****************************************************************************}
  905. constructor tstring_item.init(const s : string);
  906. begin
  907. str:=stringdup(s);
  908. end;
  909. destructor tstring_item.done;
  910. begin
  911. stringdispose(str);
  912. inherited done;
  913. end;
  914. {****************************************************************************
  915. TLINKEDLIST
  916. ****************************************************************************}
  917. constructor tlinkedlist.init;
  918. begin
  919. first:=nil;
  920. last:=nil;
  921. end;
  922. destructor tlinkedlist.done;
  923. begin
  924. clear;
  925. end;
  926. destructor tlinkedlist.done_noclear;
  927. begin
  928. end;
  929. procedure tlinkedlist.clear;
  930. var
  931. newnode : plinkedlist_item;
  932. begin
  933. newnode:=first;
  934. while assigned(newnode) do
  935. begin
  936. first:=newnode^.next;
  937. dispose(newnode,done);
  938. newnode:=first;
  939. end;
  940. end;
  941. procedure tlinkedlist.insertlist(p : plinkedlist);
  942. begin
  943. { empty list ? }
  944. if not(assigned(p^.first)) then
  945. exit;
  946. p^.last^.next:=first;
  947. { we have a double linked list }
  948. if assigned(first) then
  949. first^.previous:=p^.last;
  950. first:=p^.first;
  951. if not(assigned(last)) then
  952. last:=p^.last;
  953. { p becomes empty }
  954. p^.first:=nil;
  955. p^.last:=nil;
  956. end;
  957. procedure tlinkedlist.concat(p : plinkedlist_item);
  958. begin
  959. if not(assigned(first)) then
  960. begin
  961. first:=p;
  962. p^.previous:=nil;
  963. p^.next:=nil;
  964. end
  965. else
  966. begin
  967. last^.next:=p;
  968. p^.previous:=last;
  969. p^.next:=nil;
  970. end;
  971. last:=p;
  972. end;
  973. procedure tlinkedlist.insert(p : plinkedlist_item);
  974. begin
  975. if not(assigned(first)) then
  976. begin
  977. last:=p;
  978. p^.previous:=nil;
  979. p^.next:=nil;
  980. end
  981. else
  982. begin
  983. first^.previous:=p;
  984. p^.previous:=nil;
  985. p^.next:=first;
  986. end;
  987. first:=p;
  988. end;
  989. procedure tlinkedlist.remove(p : plinkedlist_item);
  990. begin
  991. if not(assigned(p)) then
  992. exit;
  993. if (first=p) and (last=p) then
  994. begin
  995. first:=nil;
  996. last:=nil;
  997. end
  998. else if first=p then
  999. begin
  1000. first:=p^.next;
  1001. if assigned(first) then
  1002. first^.previous:=nil;
  1003. end
  1004. else if last=p then
  1005. begin
  1006. last:=last^.previous;
  1007. if assigned(last) then
  1008. last^.next:=nil;
  1009. end
  1010. else
  1011. begin
  1012. p^.previous^.next:=p^.next;
  1013. p^.next^.previous:=p^.previous;
  1014. end;
  1015. p^.next:=nil;
  1016. p^.previous:=nil;
  1017. end;
  1018. procedure tlinkedlist.concatlist(p : plinkedlist);
  1019. begin
  1020. if not(assigned(p^.first)) then
  1021. exit;
  1022. if not(assigned(first)) then
  1023. first:=p^.first
  1024. else
  1025. begin
  1026. last^.next:=p^.first;
  1027. p^.first^.previous:=last;
  1028. end;
  1029. last:=p^.last;
  1030. { make p empty }
  1031. p^.last:=nil;
  1032. p^.first:=nil;
  1033. end;
  1034. procedure tlinkedlist.concatlistcopy(p : plinkedlist);
  1035. var
  1036. newnode,newnode2 : plinkedlist_item;
  1037. begin
  1038. newnode:=p^.first;
  1039. while assigned(newnode) do
  1040. begin
  1041. newnode2:=newnode^.getcopy;
  1042. if assigned(newnode2) then
  1043. begin
  1044. if not(assigned(first)) then
  1045. begin
  1046. first:=newnode2;
  1047. newnode2^.previous:=nil;
  1048. newnode2^.next:=nil;
  1049. end
  1050. else
  1051. begin
  1052. last^.next:=newnode2;
  1053. newnode2^.previous:=last;
  1054. newnode2^.next:=nil;
  1055. end;
  1056. last:=newnode2;
  1057. end;
  1058. newnode:=newnode^.next;
  1059. end;
  1060. end;
  1061. function tlinkedlist.empty:boolean;
  1062. begin
  1063. empty:=(first=nil);
  1064. end;
  1065. function tlinkedlist.count:longint;
  1066. var
  1067. i : longint;
  1068. hp : plinkedlist_item;
  1069. begin
  1070. hp:=first;
  1071. i:=0;
  1072. while assigned(hp) do
  1073. begin
  1074. inc(i);
  1075. hp:=hp^.next;
  1076. end;
  1077. count:=i;
  1078. end;
  1079. {****************************************************************************
  1080. Tnamedindexobject
  1081. ****************************************************************************}
  1082. constructor Tnamedindexobject.init;
  1083. begin
  1084. { index }
  1085. indexnr:=-1;
  1086. next:=nil;
  1087. { dictionary }
  1088. left:=nil;
  1089. right:=nil;
  1090. _name:=nil;
  1091. speedvalue:=-1;
  1092. end;
  1093. constructor Tnamedindexobject.initname(const n:string);
  1094. begin
  1095. { index }
  1096. indexnr:=-1;
  1097. next:=nil;
  1098. { dictionary }
  1099. left:=nil;
  1100. right:=nil;
  1101. speedvalue:=-1;
  1102. _name:=stringdup(n);
  1103. end;
  1104. destructor Tnamedindexobject.done;
  1105. begin
  1106. stringdispose(_name);
  1107. end;
  1108. procedure Tnamedindexobject.setname(const n:string);
  1109. begin
  1110. if speedvalue=-1 then
  1111. begin
  1112. if assigned(_name) then
  1113. stringdispose(_name);
  1114. _name:=stringdup(n);
  1115. end;
  1116. end;
  1117. function Tnamedindexobject.name:string;
  1118. begin
  1119. if assigned(_name) then
  1120. name:=_name^
  1121. else
  1122. name:='';
  1123. end;
  1124. {****************************************************************************
  1125. TDICTIONARY
  1126. ****************************************************************************}
  1127. constructor Tdictionary.init;
  1128. begin
  1129. root:=nil;
  1130. hasharray:=nil;
  1131. noclear:=false;
  1132. replace_existing:=false;
  1133. end;
  1134. procedure Tdictionary.usehash;
  1135. begin
  1136. if not(assigned(root)) and
  1137. not(assigned(hasharray)) then
  1138. begin
  1139. new(hasharray);
  1140. fillchar(hasharray^,sizeof(hasharray^),0);
  1141. end;
  1142. end;
  1143. destructor Tdictionary.done;
  1144. begin
  1145. if not noclear then
  1146. clear;
  1147. if assigned(hasharray) then
  1148. dispose(hasharray);
  1149. end;
  1150. procedure Tdictionary.cleartree(obj:Pnamedindexobject);
  1151. begin
  1152. if assigned(obj^.left) then
  1153. cleartree(obj^.left);
  1154. if assigned(obj^.right) then
  1155. cleartree(obj^.right);
  1156. dispose(obj,done);
  1157. obj:=nil;
  1158. end;
  1159. procedure Tdictionary.clear;
  1160. var
  1161. w : longint;
  1162. begin
  1163. if assigned(root) then
  1164. cleartree(root);
  1165. if assigned(hasharray) then
  1166. for w:=-hasharraysize to hasharraysize do
  1167. if assigned(hasharray^[w]) then
  1168. cleartree(hasharray^[w]);
  1169. end;
  1170. function Tdictionary.delete(const s:string):Pnamedindexobject;
  1171. var p,speedvalue:longint;
  1172. n:Pnamedindexobject;
  1173. procedure insert_right_bottom(var root,Atree:Pnamedindexobject);
  1174. begin
  1175. while root^.right<>nil do
  1176. root:=root^.right;
  1177. root^.right:=Atree;
  1178. end;
  1179. function delete_from_tree(root:Pnamedindexobject):Pnamedindexobject;
  1180. type leftright=(left,right);
  1181. var lr:leftright;
  1182. oldroot:Pnamedindexobject;
  1183. begin
  1184. oldroot:=nil;
  1185. while (root<>nil) and (root^.speedvalue<>speedvalue) do
  1186. begin
  1187. oldroot:=root;
  1188. if speedvalue<root^.speedvalue then
  1189. begin
  1190. root:=root^.right;
  1191. lr:=right;
  1192. end
  1193. else
  1194. begin
  1195. root:=root^.left;
  1196. lr:=left;
  1197. end;
  1198. end;
  1199. while (root<>nil) and (root^._name^<>s) do
  1200. begin
  1201. oldroot:=root;
  1202. if s<root^._name^ then
  1203. begin
  1204. root:=root^.right;
  1205. lr:=right;
  1206. end
  1207. else
  1208. begin
  1209. root:=root^.left;
  1210. lr:=left;
  1211. end;
  1212. end;
  1213. if (oldroot=nil) or (root=nil) then
  1214. do_internalerror(218); {Internalerror is not available...}
  1215. if root^.left<>nil then
  1216. begin
  1217. {Now the node pointing to root must point to the left
  1218. subtree of root. The right subtree of root must be
  1219. connected to the right bottom of the left subtree.}
  1220. if lr=left then
  1221. oldroot^.left:=root^.left
  1222. else
  1223. oldroot^.right:=root^.left;
  1224. if root^.right<>nil then
  1225. insert_right_bottom(root^.left,root^.right);
  1226. end
  1227. else
  1228. {There is no left subtree. So we can just replace the node to
  1229. delete with the right subtree.}
  1230. if lr=left then
  1231. oldroot^.left:=root^.right
  1232. else
  1233. oldroot^.right:=root^.right;
  1234. delete_from_tree:=root;
  1235. end;
  1236. begin
  1237. speedvalue:=getspeedvalue(s);
  1238. n:=root;
  1239. if assigned(hasharray) then
  1240. begin
  1241. {First, check if the node to delete directly located under
  1242. the hasharray.}
  1243. p:=speedvalue mod hasharraysize;
  1244. n:=hasharray^[p];
  1245. if (n<>nil) and (n^.speedvalue=speedvalue) and
  1246. (n^._name^=s) then
  1247. begin
  1248. {The node to delete is directly located under the
  1249. hasharray. Make the hasharray point to the left
  1250. subtree of the node and place the right subtree on
  1251. the right-bottom of the left subtree.}
  1252. if n^.left<>nil then
  1253. begin
  1254. hasharray^[p]:=n^.left;
  1255. if n^.right<>nil then
  1256. insert_right_bottom(n^.left,n^.right);
  1257. end
  1258. else
  1259. hasharray^[p]:=n^.right;
  1260. delete:=n;
  1261. exit;
  1262. end;
  1263. end
  1264. else
  1265. begin
  1266. {First check if the node to delete is the root.}
  1267. if (root<>nil) and (n^.speedvalue=speedvalue)
  1268. and (n^._name^=s) then
  1269. begin
  1270. if n^.left<>nil then
  1271. begin
  1272. root:=n^.left;
  1273. if n^.right<>nil then
  1274. insert_right_bottom(n^.left,n^.right);
  1275. end
  1276. else
  1277. root:=n^.right;
  1278. delete:=n;
  1279. exit;
  1280. end;
  1281. end;
  1282. delete:=delete_from_tree(n);
  1283. end;
  1284. function Tdictionary.empty:boolean;
  1285. var
  1286. w : longint;
  1287. begin
  1288. if assigned(hasharray) then
  1289. begin
  1290. empty:=false;
  1291. for w:=-hasharraysize to hasharraysize do
  1292. if assigned(hasharray^[w]) then
  1293. exit;
  1294. empty:=true;
  1295. end
  1296. else
  1297. empty:=(root=nil);
  1298. end;
  1299. procedure Tdictionary.foreach(proc2call:Tnamedindexcallback);
  1300. procedure a(p:Pnamedindexobject);
  1301. begin
  1302. proc2call(p);
  1303. if assigned(p^.left) then
  1304. a(p^.left);
  1305. if assigned(p^.right) then
  1306. a(p^.right);
  1307. end;
  1308. var
  1309. i : longint;
  1310. begin
  1311. if assigned(hasharray) then
  1312. begin
  1313. for i:=-hasharraysize to hasharraysize do
  1314. if assigned(hasharray^[i]) then
  1315. a(hasharray^[i]);
  1316. end
  1317. else
  1318. if assigned(root) then
  1319. a(root);
  1320. end;
  1321. function Tdictionary.insert(obj:Pnamedindexobject):Pnamedindexobject;
  1322. begin
  1323. obj^.speedvalue:=getspeedvalue(obj^._name^);
  1324. if assigned(hasharray) then
  1325. insert:=insertnode(obj,hasharray^[obj^.speedvalue mod hasharraysize])
  1326. else
  1327. insert:=insertnode(obj,root);
  1328. end;
  1329. function tdictionary.insertnode(newnode:Pnamedindexobject;var currnode:Pnamedindexobject):Pnamedindexobject;
  1330. begin
  1331. if currnode=nil then
  1332. begin
  1333. currnode:=newnode;
  1334. insertnode:=newnode;
  1335. end
  1336. { first check speedvalue, to allow a fast insert }
  1337. else
  1338. if currnode^.speedvalue>newnode^.speedvalue then
  1339. insertnode:=insertnode(newnode,currnode^.right)
  1340. else
  1341. if currnode^.speedvalue<newnode^.speedvalue then
  1342. insertnode:=insertnode(newnode,currnode^.left)
  1343. else
  1344. begin
  1345. if currnode^._name^>newnode^._name^ then
  1346. insertnode:=insertnode(newnode,currnode^.right)
  1347. else
  1348. if currnode^._name^<newnode^._name^ then
  1349. insertnode:=insertnode(newnode,currnode^.left)
  1350. else
  1351. begin
  1352. if replace_existing and
  1353. assigned(currnode) then
  1354. begin
  1355. newnode^.left:=currnode^.left;
  1356. newnode^.right:=currnode^.right;
  1357. currnode:=newnode;
  1358. insertnode:=newnode;
  1359. end
  1360. else
  1361. insertnode:=currnode;
  1362. end;
  1363. end;
  1364. end;
  1365. procedure tdictionary.inserttree(currtree,currroot:Pnamedindexobject);
  1366. begin
  1367. if assigned(currtree) then
  1368. begin
  1369. inserttree(currtree^.left,currroot);
  1370. inserttree(currtree^.right,currroot);
  1371. currtree^.right:=nil;
  1372. currtree^.left:=nil;
  1373. insertnode(currtree,currroot);
  1374. end;
  1375. end;
  1376. function tdictionary.rename(const olds,news : string):Pnamedindexobject;
  1377. var
  1378. spdval : longint;
  1379. lasthp,
  1380. hp,hp2,hp3 : Pnamedindexobject;
  1381. begin
  1382. spdval:=getspeedvalue(olds);
  1383. if assigned(hasharray) then
  1384. hp:=hasharray^[spdval mod hasharraysize]
  1385. else
  1386. hp:=root;
  1387. lasthp:=nil;
  1388. while assigned(hp) do
  1389. begin
  1390. if spdval>hp^.speedvalue then
  1391. begin
  1392. lasthp:=hp;
  1393. hp:=hp^.left
  1394. end
  1395. else
  1396. if spdval<hp^.speedvalue then
  1397. begin
  1398. lasthp:=hp;
  1399. hp:=hp^.right
  1400. end
  1401. else
  1402. begin
  1403. if (hp^.name=olds) then
  1404. begin
  1405. { get in hp2 the replacer for the root or hasharr }
  1406. hp2:=hp^.left;
  1407. hp3:=hp^.right;
  1408. if not assigned(hp2) then
  1409. begin
  1410. hp2:=hp^.right;
  1411. hp3:=hp^.left;
  1412. end;
  1413. { remove entry from the tree }
  1414. if assigned(lasthp) then
  1415. begin
  1416. if lasthp^.left=hp then
  1417. lasthp^.left:=hp2
  1418. else
  1419. lasthp^.right:=hp2;
  1420. end
  1421. else
  1422. begin
  1423. if assigned(hasharray) then
  1424. hasharray^[spdval mod hasharraysize]:=hp2
  1425. else
  1426. root:=hp2;
  1427. end;
  1428. { reinsert the hp3 in the tree from hp2 }
  1429. inserttree(hp3,hp2);
  1430. { reset node with new values }
  1431. stringdispose(hp^._name);
  1432. hp^._name:=stringdup(news);
  1433. hp^.speedvalue:=getspeedvalue(news);
  1434. hp^.left:=nil;
  1435. hp^.right:=nil;
  1436. { reinsert }
  1437. if assigned(hasharray) then
  1438. rename:=insertnode(hp,hasharray^[hp^.speedvalue mod hasharraysize])
  1439. else
  1440. rename:=insertnode(hp,root);
  1441. exit;
  1442. end
  1443. else
  1444. if olds>hp^.name then
  1445. begin
  1446. lasthp:=hp;
  1447. hp:=hp^.left
  1448. end
  1449. else
  1450. begin
  1451. lasthp:=hp;
  1452. hp:=hp^.right;
  1453. end;
  1454. end;
  1455. end;
  1456. end;
  1457. function Tdictionary.search(const s:string):Pnamedindexobject;
  1458. begin
  1459. search:=speedsearch(s,getspeedvalue(s));
  1460. end;
  1461. function Tdictionary.speedsearch(const s:string;speedvalue:longint):Pnamedindexobject;
  1462. var
  1463. newnode:Pnamedindexobject;
  1464. begin
  1465. if assigned(hasharray) then
  1466. newnode:=hasharray^[speedvalue mod hasharraysize]
  1467. else
  1468. newnode:=root;
  1469. while assigned(newnode) do
  1470. begin
  1471. if speedvalue>newnode^.speedvalue then
  1472. newnode:=newnode^.left
  1473. else
  1474. if speedvalue<newnode^.speedvalue then
  1475. newnode:=newnode^.right
  1476. else
  1477. begin
  1478. if (newnode^._name^=s) then
  1479. begin
  1480. speedsearch:=newnode;
  1481. exit;
  1482. end
  1483. else
  1484. if s>newnode^._name^ then
  1485. newnode:=newnode^.left
  1486. else
  1487. newnode:=newnode^.right;
  1488. end;
  1489. end;
  1490. speedsearch:=nil;
  1491. end;
  1492. {****************************************************************************
  1493. tdynamicarray
  1494. ****************************************************************************}
  1495. constructor tdynamicarray.init(Aelemlen,Agrow:longint);
  1496. begin
  1497. posn:=0;
  1498. count:=0;
  1499. limit:=0;
  1500. data:=nil;
  1501. elemlen:=Aelemlen;
  1502. growcount:=Agrow;
  1503. grow;
  1504. end;
  1505. function tdynamicarray.size:longint;
  1506. begin
  1507. size:=limit*elemlen;
  1508. end;
  1509. function tdynamicarray.usedsize:longint;
  1510. begin
  1511. usedsize:=count*elemlen;
  1512. end;
  1513. procedure tdynamicarray.grow;
  1514. var
  1515. osize : longint;
  1516. odata : pchar;
  1517. begin
  1518. osize:=size;
  1519. odata:=data;
  1520. inc(limit,growcount);
  1521. getmem(data,size);
  1522. if assigned(odata) then
  1523. begin
  1524. move(odata^,data^,osize);
  1525. freemem(odata,osize);
  1526. end;
  1527. fillchar(data[osize],growcount*elemlen,0);
  1528. end;
  1529. procedure tdynamicarray.align(i:longint);
  1530. var
  1531. j : longint;
  1532. begin
  1533. j:=(posn*elemlen mod i);
  1534. if j<>0 then
  1535. begin
  1536. j:=i-j;
  1537. while limit<(posn+j) do
  1538. grow;
  1539. inc(posn,j);
  1540. if (posn>count) then
  1541. count:=posn;
  1542. end;
  1543. end;
  1544. procedure tdynamicarray.seek(i:longint);
  1545. begin
  1546. while limit<i do
  1547. grow;
  1548. posn:=i;
  1549. if (posn>count) then
  1550. count:=posn;
  1551. end;
  1552. procedure tdynamicarray.write(var d;len:longint);
  1553. begin
  1554. while limit<(posn+len) do
  1555. grow;
  1556. move(d,data[posn*elemlen],len*elemlen);
  1557. inc(posn,len);
  1558. if (posn>count) then
  1559. count:=posn;
  1560. end;
  1561. procedure tdynamicarray.read(var d;len:longint);
  1562. begin
  1563. move(data[posn*elemlen],d,len*elemlen);
  1564. inc(posn,len);
  1565. if (posn>count) then
  1566. count:=posn;
  1567. end;
  1568. procedure tdynamicarray.writepos(pos:longint;var d;len:longint);
  1569. begin
  1570. while limit<(pos+len) do
  1571. grow;
  1572. move(d,data[pos*elemlen],len*elemlen);
  1573. posn:=pos+len;
  1574. if (posn>count) then
  1575. count:=posn;
  1576. end;
  1577. procedure tdynamicarray.readpos(pos:longint;var d;len:longint);
  1578. begin
  1579. while limit<(pos+len) do
  1580. grow;
  1581. move(data[pos*elemlen],d,len*elemlen);
  1582. posn:=pos+len;
  1583. if (posn>count) then
  1584. count:=posn;
  1585. end;
  1586. destructor tdynamicarray.done;
  1587. begin
  1588. if assigned(data) then
  1589. freemem(data,size);
  1590. end;
  1591. {****************************************************************************
  1592. tindexarray
  1593. ****************************************************************************}
  1594. constructor tindexarray.init(Agrowsize:longint);
  1595. begin
  1596. growsize:=Agrowsize;
  1597. size:=0;
  1598. count:=0;
  1599. data:=nil;
  1600. first:=nil;
  1601. end;
  1602. destructor tindexarray.done;
  1603. begin
  1604. if assigned(data) then
  1605. begin
  1606. clear;
  1607. freemem(data,size*4);
  1608. data:=nil;
  1609. end;
  1610. end;
  1611. function tindexarray.search(nr:longint):Pnamedindexobject;
  1612. begin
  1613. if nr<=count then
  1614. search:=data^[nr]
  1615. else
  1616. search:=nil;
  1617. end;
  1618. procedure tindexarray.clear;
  1619. var
  1620. i : longint;
  1621. begin
  1622. for i:=1 to count do
  1623. if assigned(data^[i]) then
  1624. begin
  1625. dispose(data^[i],done);
  1626. data^[i]:=nil;
  1627. end;
  1628. count:=0;
  1629. first:=nil;
  1630. end;
  1631. procedure tindexarray.foreach(proc2call : Tnamedindexcallback);
  1632. var
  1633. i : longint;
  1634. begin
  1635. for i:=1 to count do
  1636. if assigned(data^[i]) then
  1637. proc2call(data^[i]);
  1638. end;
  1639. procedure tindexarray.grow(gsize:longint);
  1640. var
  1641. osize : longint;
  1642. odata : Pnamedindexobjectarray;
  1643. begin
  1644. osize:=size;
  1645. odata:=data;
  1646. inc(size,gsize);
  1647. getmem(data,size*4);
  1648. if assigned(odata) then
  1649. begin
  1650. move(odata^,data^,osize*4);
  1651. freemem(odata,osize*4);
  1652. end;
  1653. fillchar(data^[osize+1],gsize*4,0);
  1654. end;
  1655. procedure tindexarray.deleteindex(p:Pnamedindexobject);
  1656. var
  1657. i : longint;
  1658. begin
  1659. i:=p^.indexnr;
  1660. { update counter }
  1661. if i=count then
  1662. dec(count);
  1663. { update linked list }
  1664. while (i>0) do
  1665. begin
  1666. dec(i);
  1667. if (i>0) and assigned(data^[i]) then
  1668. begin
  1669. data^[i]^.next:=data^[p^.indexnr]^.next;
  1670. break;
  1671. end;
  1672. end;
  1673. if i=0 then
  1674. first:=p^.next;
  1675. data^[p^.indexnr]:=nil;
  1676. { clear entry }
  1677. p^.indexnr:=-1;
  1678. p^.next:=nil;
  1679. end;
  1680. procedure tindexarray.delete(p:Pnamedindexobject);
  1681. begin
  1682. deleteindex(p);
  1683. dispose(p,done);
  1684. p:=nil;
  1685. end;
  1686. procedure tindexarray.insert(p:Pnamedindexobject);
  1687. var
  1688. i : longint;
  1689. begin
  1690. if p^.indexnr=-1 then
  1691. begin
  1692. inc(count);
  1693. p^.indexnr:=count;
  1694. end;
  1695. if p^.indexnr>count then
  1696. count:=p^.indexnr;
  1697. if count>size then
  1698. grow(((count div growsize)+1)*growsize);
  1699. data^[p^.indexnr]:=p;
  1700. { update linked list backward }
  1701. i:=p^.indexnr;
  1702. while (i>0) do
  1703. begin
  1704. dec(i);
  1705. if (i>0) and assigned(data^[i]) then
  1706. begin
  1707. data^[i]^.next:=p;
  1708. break;
  1709. end;
  1710. end;
  1711. if i=0 then
  1712. first:=p;
  1713. { update linked list forward }
  1714. i:=p^.indexnr;
  1715. while (i<=count) do
  1716. begin
  1717. inc(i);
  1718. if (i<=count) and assigned(data^[i]) then
  1719. begin
  1720. p^.next:=data^[i];
  1721. exit;
  1722. end;
  1723. end;
  1724. if i>count then
  1725. p^.next:=nil;
  1726. end;
  1727. {$ifdef BUFFEREDFILE}
  1728. {****************************************************************************
  1729. TBUFFEREDFILE
  1730. ****************************************************************************}
  1731. Const
  1732. crcseed = $ffffffff;
  1733. crctable : array[0..255] of longint = (
  1734. $00000000,$77073096,$ee0e612c,$990951ba,$076dc419,$706af48f,
  1735. $e963a535,$9e6495a3,$0edb8832,$79dcb8a4,$e0d5e91e,$97d2d988,
  1736. $09b64c2b,$7eb17cbd,$e7b82d07,$90bf1d91,$1db71064,$6ab020f2,
  1737. $f3b97148,$84be41de,$1adad47d,$6ddde4eb,$f4d4b551,$83d385c7,
  1738. $136c9856,$646ba8c0,$fd62f97a,$8a65c9ec,$14015c4f,$63066cd9,
  1739. $fa0f3d63,$8d080df5,$3b6e20c8,$4c69105e,$d56041e4,$a2677172,
  1740. $3c03e4d1,$4b04d447,$d20d85fd,$a50ab56b,$35b5a8fa,$42b2986c,
  1741. $dbbbc9d6,$acbcf940,$32d86ce3,$45df5c75,$dcd60dcf,$abd13d59,
  1742. $26d930ac,$51de003a,$c8d75180,$bfd06116,$21b4f4b5,$56b3c423,
  1743. $cfba9599,$b8bda50f,$2802b89e,$5f058808,$c60cd9b2,$b10be924,
  1744. $2f6f7c87,$58684c11,$c1611dab,$b6662d3d,$76dc4190,$01db7106,
  1745. $98d220bc,$efd5102a,$71b18589,$06b6b51f,$9fbfe4a5,$e8b8d433,
  1746. $7807c9a2,$0f00f934,$9609a88e,$e10e9818,$7f6a0dbb,$086d3d2d,
  1747. $91646c97,$e6635c01,$6b6b51f4,$1c6c6162,$856530d8,$f262004e,
  1748. $6c0695ed,$1b01a57b,$8208f4c1,$f50fc457,$65b0d9c6,$12b7e950,
  1749. $8bbeb8ea,$fcb9887c,$62dd1ddf,$15da2d49,$8cd37cf3,$fbd44c65,
  1750. $4db26158,$3ab551ce,$a3bc0074,$d4bb30e2,$4adfa541,$3dd895d7,
  1751. $a4d1c46d,$d3d6f4fb,$4369e96a,$346ed9fc,$ad678846,$da60b8d0,
  1752. $44042d73,$33031de5,$aa0a4c5f,$dd0d7cc9,$5005713c,$270241aa,
  1753. $be0b1010,$c90c2086,$5768b525,$206f85b3,$b966d409,$ce61e49f,
  1754. $5edef90e,$29d9c998,$b0d09822,$c7d7a8b4,$59b33d17,$2eb40d81,
  1755. $b7bd5c3b,$c0ba6cad,$edb88320,$9abfb3b6,$03b6e20c,$74b1d29a,
  1756. $ead54739,$9dd277af,$04db2615,$73dc1683,$e3630b12,$94643b84,
  1757. $0d6d6a3e,$7a6a5aa8,$e40ecf0b,$9309ff9d,$0a00ae27,$7d079eb1,
  1758. $f00f9344,$8708a3d2,$1e01f268,$6906c2fe,$f762575d,$806567cb,
  1759. $196c3671,$6e6b06e7,$fed41b76,$89d32be0,$10da7a5a,$67dd4acc,
  1760. $f9b9df6f,$8ebeeff9,$17b7be43,$60b08ed5,$d6d6a3e8,$a1d1937e,
  1761. $38d8c2c4,$4fdff252,$d1bb67f1,$a6bc5767,$3fb506dd,$48b2364b,
  1762. $d80d2bda,$af0a1b4c,$36034af6,$41047a60,$df60efc3,$a867df55,
  1763. $316e8eef,$4669be79,$cb61b38c,$bc66831a,$256fd2a0,$5268e236,
  1764. $cc0c7795,$bb0b4703,$220216b9,$5505262f,$c5ba3bbe,$b2bd0b28,
  1765. $2bb45a92,$5cb36a04,$c2d7ffa7,$b5d0cf31,$2cd99e8b,$5bdeae1d,
  1766. $9b64c2b0,$ec63f226,$756aa39c,$026d930a,$9c0906a9,$eb0e363f,
  1767. $72076785,$05005713,$95bf4a82,$e2b87a14,$7bb12bae,$0cb61b38,
  1768. $92d28e9b,$e5d5be0d,$7cdcefb7,$0bdbdf21,$86d3d2d4,$f1d4e242,
  1769. $68ddb3f8,$1fda836e,$81be16cd,$f6b9265b,$6fb077e1,$18b74777,
  1770. $88085ae6,$ff0f6a70,$66063bca,$11010b5c,$8f659eff,$f862ae69,
  1771. $616bffd3,$166ccf45,$a00ae278,$d70dd2ee,$4e048354,$3903b3c2,
  1772. $a7672661,$d06016f7,$4969474d,$3e6e77db,$aed16a4a,$d9d65adc,
  1773. $40df0b66,$37d83bf0,$a9bcae53,$debb9ec5,$47b2cf7f,$30b5ffe9,
  1774. $bdbdf21c,$cabac28a,$53b39330,$24b4a3a6,$bad03605,$cdd70693,
  1775. $54de5729,$23d967bf,$b3667a2e,$c4614ab8,$5d681b02,$2a6f2b94,
  1776. $b40bbe37,$c30c8ea1,$5a05df1b,$2d02ef8d);
  1777. constructor tbufferedfile.init(const filename : string;_bufsize : longint);
  1778. begin
  1779. assign(f,filename);
  1780. bufsize:=_bufsize;
  1781. bufpos:=0;
  1782. buflast:=0;
  1783. do_crc:=false;
  1784. iomode:=0;
  1785. tempclosed:=false;
  1786. change_endian:=false;
  1787. clear_crc;
  1788. end;
  1789. destructor tbufferedfile.done;
  1790. begin
  1791. close;
  1792. end;
  1793. procedure tbufferedfile.clear_crc;
  1794. begin
  1795. crc:=crcseed;
  1796. end;
  1797. procedure tbufferedfile.setbuf(p : pchar;s : longint);
  1798. begin
  1799. flush;
  1800. freemem(buf,bufsize);
  1801. bufsize:=s;
  1802. buf:=p;
  1803. end;
  1804. function tbufferedfile.reset:boolean;
  1805. var
  1806. ofm : byte;
  1807. begin
  1808. ofm:=filemode;
  1809. iomode:=1;
  1810. getmem(buf,bufsize);
  1811. filemode:=0;
  1812. {$I-}
  1813. system.reset(f,1);
  1814. {$I+}
  1815. reset:=(ioresult=0);
  1816. filemode:=ofm;
  1817. end;
  1818. procedure tbufferedfile.rewrite;
  1819. begin
  1820. iomode:=2;
  1821. getmem(buf,bufsize);
  1822. system.rewrite(f,1);
  1823. end;
  1824. procedure tbufferedfile.flush;
  1825. var
  1826. {$ifdef FPC}
  1827. count : longint;
  1828. {$else}
  1829. count : integer;
  1830. {$endif}
  1831. begin
  1832. if iomode=2 then
  1833. begin
  1834. if bufpos=0 then
  1835. exit;
  1836. blockwrite(f,buf^,bufpos)
  1837. end
  1838. else if iomode=1 then
  1839. if buflast=bufpos then
  1840. begin
  1841. blockread(f,buf^,bufsize,count);
  1842. buflast:=count;
  1843. end;
  1844. bufpos:=0;
  1845. end;
  1846. function tbufferedfile.getftime : longint;
  1847. var
  1848. l : longint;
  1849. {$ifdef linux}
  1850. Info : Stat;
  1851. {$endif}
  1852. begin
  1853. {$ifndef linux}
  1854. { this only works if the file is open !! }
  1855. dos.getftime(f,l);
  1856. {$else}
  1857. Fstat(f,Info);
  1858. l:=info.mtime;
  1859. {$endif}
  1860. getftime:=l;
  1861. end;
  1862. function tbufferedfile.getsize : longint;
  1863. begin
  1864. getsize:=filesize(f);
  1865. end;
  1866. procedure tbufferedfile.seek(l : longint);
  1867. begin
  1868. if iomode=2 then
  1869. begin
  1870. flush;
  1871. system.seek(f,l);
  1872. end
  1873. else if iomode=1 then
  1874. begin
  1875. { forces a reload }
  1876. bufpos:=buflast;
  1877. system.seek(f,l);
  1878. flush;
  1879. end;
  1880. end;
  1881. type
  1882. {$ifdef tp}
  1883. bytearray1 = array [1..65535] of byte;
  1884. {$else}
  1885. bytearray1 = array [1..10000000] of byte;
  1886. {$endif}
  1887. procedure tbufferedfile.read_data(var data;bytes : longint;var count : longint);
  1888. var
  1889. p : pchar;
  1890. c,i : longint;
  1891. begin
  1892. p:=pchar(@data);
  1893. count:=0;
  1894. while bytes-count>0 do
  1895. begin
  1896. if bytes-count>buflast-bufpos then
  1897. begin
  1898. move((buf+bufpos)^,(p+count)^,buflast-bufpos);
  1899. inc(count,buflast-bufpos);
  1900. bufpos:=buflast;
  1901. flush;
  1902. { can't we read anything ? }
  1903. if bufpos=buflast then
  1904. break;
  1905. end
  1906. else
  1907. begin
  1908. move((buf+bufpos)^,(p+count)^,bytes-count);
  1909. inc(bufpos,bytes-count);
  1910. count:=bytes;
  1911. break;
  1912. end;
  1913. end;
  1914. if do_crc then
  1915. begin
  1916. c:=crc;
  1917. for i:=1 to bytes do
  1918. c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
  1919. crc:=c;
  1920. end;
  1921. end;
  1922. procedure tbufferedfile.write_data(var data;count : longint);
  1923. var
  1924. c,i : longint;
  1925. begin
  1926. if bufpos+count>bufsize then
  1927. flush;
  1928. move(data,(buf+bufpos)^,count);
  1929. inc(bufpos,count);
  1930. if do_crc then
  1931. begin
  1932. c:=crc;
  1933. for i:=1 to count do
  1934. c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
  1935. crc:=c;
  1936. end;
  1937. end;
  1938. function tbufferedfile.getcrc : longint;
  1939. begin
  1940. getcrc:=crc xor crcseed;
  1941. end;
  1942. procedure tbufferedfile.write_string(const s : string);
  1943. begin
  1944. if bufpos+length(s)>bufsize then
  1945. flush;
  1946. { why is there not CRC here ??? }
  1947. move(s[1],(buf+bufpos)^,length(s));
  1948. inc(bufpos,length(s));
  1949. { should be
  1950. write_data(s[1],length(s)); }
  1951. end;
  1952. procedure tbufferedfile.write_pchar(p : pchar);
  1953. var
  1954. l : longint;
  1955. begin
  1956. l:=strlen(p);
  1957. if l>=bufsize then
  1958. do_internalerror(222);
  1959. { why is there not CRC here ???}
  1960. if bufpos+l>bufsize then
  1961. flush;
  1962. move(p^,(buf+bufpos)^,l);
  1963. inc(bufpos,l);
  1964. { should be
  1965. write_data(p^,l); }
  1966. end;
  1967. procedure tbufferedfile.write_byte(b : byte);
  1968. begin
  1969. write_data(b,sizeof(byte));
  1970. end;
  1971. procedure tbufferedfile.write_long(l : longint);
  1972. var
  1973. w1,w2 : word;
  1974. begin
  1975. if change_endian then
  1976. begin
  1977. w1:=l and $ffff;
  1978. w2:=l shr 16;
  1979. l:=swap(w2)+(longint(swap(w1)) shl 16);
  1980. end;
  1981. write_data(l,sizeof(longint));
  1982. end;
  1983. procedure tbufferedfile.write_word(w : word);
  1984. begin
  1985. if change_endian then
  1986. begin
  1987. w:=swap(w);
  1988. end;
  1989. write_data(w,sizeof(word));
  1990. end;
  1991. procedure tbufferedfile.write_double(d : double);
  1992. begin
  1993. write_data(d,sizeof(double));
  1994. end;
  1995. function tbufferedfile.getpath : string;
  1996. begin
  1997. {$ifdef dummy}
  1998. getpath:=strpas(filerec(f).name);
  1999. {$endif}
  2000. getpath:='';
  2001. end;
  2002. procedure tbufferedfile.close;
  2003. begin
  2004. if iomode<>0 then
  2005. begin
  2006. flush;
  2007. system.close(f);
  2008. freemem(buf,bufsize);
  2009. buf:=nil;
  2010. iomode:=0;
  2011. end;
  2012. end;
  2013. procedure tbufferedfile.tempclose;
  2014. begin
  2015. if iomode<>0 then
  2016. begin
  2017. temppos:=system.filepos(f);
  2018. tempmode:=iomode;
  2019. tempclosed:=true;
  2020. system.close(f);
  2021. iomode:=0;
  2022. end
  2023. else
  2024. tempclosed:=false;
  2025. end;
  2026. procedure tbufferedfile.tempreopen;
  2027. var
  2028. ofm : byte;
  2029. begin
  2030. if tempclosed then
  2031. begin
  2032. case tempmode of
  2033. 1 : begin
  2034. ofm:=filemode;
  2035. iomode:=1;
  2036. filemode:=0;
  2037. system.reset(f,1);
  2038. filemode:=ofm;
  2039. end;
  2040. 2 : begin
  2041. iomode:=2;
  2042. system.rewrite(f,1);
  2043. end;
  2044. end;
  2045. system.seek(f,temppos);
  2046. tempclosed:=false;
  2047. end;
  2048. end;
  2049. {$endif BUFFEREDFILE}
  2050. end.
  2051. {
  2052. $Log$
  2053. Revision 1.3 2000-08-02 19:49:58 peter
  2054. * first things for default parameters
  2055. Revision 1.2 2000/07/13 11:32:38 michael
  2056. + removed logs
  2057. }