OOP.txt 30 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781
  1. ClassDecl ::=
  2. CLASS Classidentifier ['(' Classidentifier { ',' Classidentifier } ')'] ';'
  3. [ClassFieldDefList]
  4. [MethodDecList]
  5. END Classidentifier ';'
  6. ClassFieldDefList ::=
  7. ClassFieldDef {';' ClassFieldDef }
  8. ClassFieldDef ::=
  9. IdentifierList ':' TypeIdentifier |
  10. Identifier '=' Identifier
  11. MethodDecList ::=
  12. MethodDec {';' MethodDec }
  13. MethodDec ::=
  14. [VIRTUAL] PROCEDURE MethodIdentifier
  15. ['(' [FormalParams] ')' [':' TypeIdentifier]] ';'
  16. FormalParams ::=
  17. [VAR] IdentifierList ':' TypeIdentifier { ';' [VAR] IdentifierList ':' TypeIdentifier }
  18. ClassImpl ::=
  19. CLASS IMPLEMENTATION Classidentifier ';'
  20. {MethodImpl ';'}
  21. [BEGIN [StatementSeq] ]
  22. END Classidentifier ';'
  23. MethodImpl ::=
  24. [VIRTUAL] PROCEDURE MethodIdentifier
  25. ['(' [FormalParams] ')' [':' TypeIdentifier]] ';'
  26. (FORWARD | Block Identifier)
  27. NOTES (V3 implementation, m2compiler-V3):
  28. - Method separators are ';' (as in the Table example below),
  29. not ',' as earlier drafts of this sketch had it.
  30. - "PEOCEDURE" typo in the original sketch fixed to PROCEDURE.
  31. - Single inheritance only: extra parents are rejected (230).
  32. - Classic identifiers only (no '_'); the Table example's
  33. _Find-style names are lexically out of reach for now.
  34. - Class lowering (vtable, dispatch, THIS) is deferred; the
  35. construct parses, scopes and checks, ending in 230.
  36. Example:
  37. (* ========================================== *)
  38. (* (c) 1990-1992 Clarion Software Corporation *)
  39. (* ========================================== *)
  40. DEFINITION MODULE Table;
  41. (*
  42. This module implements classes that allow the creation and maintenance
  43. of homogeneous tables of ordered objects. The internal structure of the
  44. table is an AVL Balanced Tree. The algorithms are based on an example
  45. given in Niklaus Wirth's "Algorithms + Data Structures = Programs". That
  46. book also gives a detailed description of AVL Balanced Trees.
  47. *)
  48. TYPE
  49. BalanceFlag = SHORTINT [-1..1];
  50. ElementPtr = POINTER TO Element;
  51. CLASS Element;
  52. Right : ElementPtr; (* Pointer to right sub-tree *)
  53. Left : ElementPtr; (* Pointer to left sub-tree *)
  54. Bal : BalanceFlag; (* Tree balance flag *)
  55. VIRTUAL PROCEDURE Compare( p : ElementPtr ) : INTEGER;
  56. (*
  57. Must be implemented by the client. This
  58. procedure should return one of the
  59. following integer values:
  60. <0 if 'THIS' is less than 'p'
  61. 0 if 'THIS' is equal to 'p'
  62. >0 if 'THIS' is greater than 'p'
  63. *)
  64. END Element ;
  65. TYPE
  66. Action = PROCEDURE ( ElementPtr );
  67. (* This procedure type is used by 'Apply' *)
  68. CLASS TABLE;
  69. Root : ElementPtr; (* The root of this tree *)
  70. PROCEDURE Insert( VAR x : Element );
  71. (* Insert the element 'x' into this table *)
  72. PROCEDURE Find( VAR p : Element ) : BOOLEAN;
  73. (* Search table for a element matching 'p'.
  74. Returns 'TRUE' and sets all fields of 'p' if
  75. found; otherwise returns 'FALSE'
  76. *)
  77. PROCEDURE Delete( VAR x : Element );
  78. (* Delete the element matching 'p' from table *)
  79. PROCEDURE Apply( p : Action );
  80. (* Apply procedure 'p' to all elements in order *)
  81. PROCEDURE Init;
  82. (* Initialize the table *)
  83. PROCEDURE Eq( t2 : TABLE ) : INTEGER;
  84. (* Compare 'THIS' with 't2'. The return values
  85. are:
  86. <0 'THIS' is less than 't2'
  87. 0 'THIS' is equal to 't2'
  88. >0 'THIS' is greater than 't2'
  89. ** RESTRICTION : Table must not generate a
  90. tree greater than 32 levels deep (around
  91. 2^32 elements
  92. *)
  93. PROCEDURE SubSet( t2 : TABLE ) : BOOLEAN;
  94. (* Are the elements in this table a subset of
  95. the elememts in table 't2'? *)
  96. PROCEDURE Copy() : TABLE;
  97. (* Make a copy this table *)
  98. PROCEDURE Incl( t2 : TABLE );
  99. (* Include elements from table 't2' in this
  100. table *)
  101. PROCEDURE Excl( t2 : TABLE );
  102. (* Exclude elements from table 't2' from this
  103. table *)
  104. PROCEDURE Empty() : BOOLEAN;
  105. (* Is this table empty? *)
  106. PROCEDURE Dispose;
  107. (* Dispose of all elements of this table *)
  108. END TABLE ;
  109. END Table.
  110. (* ==================================================== *)
  111. (* Copyright (C) 1990-1992 Clarion Software Corporation *)
  112. (* ==================================================== *)
  113. IMPLEMENTATION MODULE Table;
  114. IMPORT Lib;
  115. FROM Storage IMPORT ALLOCATE, DEALLOCATE;
  116. CLASS IMPLEMENTATION Element;
  117. VIRTUAL PROCEDURE Compare( p : ElementPtr ) : INTEGER;
  118. (* It is an error not to supply an implementation of this
  119. method. The client MUST supply a method to compare
  120. 'THIS' with 'p'.
  121. *)
  122. BEGIN
  123. Lib.FatalError(' implemeted by client ');
  124. RETURN 0;
  125. END Compare;
  126. BEGIN
  127. END Element ;
  128. CLASS GenElem (Element) ;
  129. GenericData : CHAR;
  130. END GenElem;
  131. CLASS IMPLEMENTATION GenElem;
  132. BEGIN
  133. END GenElem;
  134. TYPE
  135. GenElemPtr = POINTER TO GenElem;
  136. (* The above definitions are a skeleton for all the
  137. implementation of the 'Element' CLASS. This enables
  138. the 'TABLE' class to successfully copy any client
  139. implementation of 'Element'
  140. *)
  141. CLASS IMPLEMENTATION TABLE;
  142. PROCEDURE Insert( VAR x : Element );
  143. (* Insert a new element 'x' in 'THIS' table *)
  144. PROCEDURE Search( VAR p : ElementPtr; VAR h : BOOLEAN);
  145. (* Searches a tree 'p' for the element 'x'. If it is found
  146. then the new value replaces the old. If 'x' is not
  147. in the tree, then 'x' becomes a new leaf of the tree.
  148. *)
  149. VAR
  150. p1 : ElementPtr;
  151. p2 : ElementPtr;
  152. BEGIN
  153. IF (p = NIL) THEN (* Create new leaf *)
  154. ALLOCATE(p,SIZE(x));
  155. Lib.Move(ADR(x),p,SIZE(x));
  156. p^.Bal := 0;
  157. p^.Left := NIL;
  158. p^.Right := NIL;
  159. h := TRUE; (* Tree requires balancing *)
  160. ELSE
  161. IF (x.Compare(p) < 0) THEN (* 'THIS' is < 'p' *)
  162. (* Search the 'Left' branch of 'p' recursively
  163. until 'x' is either found or created.
  164. *)
  165. Search(p^.Left,h);
  166. IF h THEN (* i.e. requires balancing *)
  167. CASE p^.Bal OF
  168. | 1 :
  169. p^.Bal := 0;
  170. h := FALSE;
  171. | 0 :
  172. p^.Bal := -1;
  173. | -1 :
  174. p1 := p^.Left;
  175. IF (p1^.Bal = -1) THEN
  176. p^.Left := p1^.Right;
  177. p1^.Right := p;
  178. p^.Bal := 0;
  179. p := p1;
  180. ELSE
  181. p2 := p1^.Right;
  182. p1^.Right := p2^.Left;
  183. p2^.Left := p1;
  184. p^.Left := p2^.Right;
  185. p2^.Right := p;
  186. IF (p2^.Bal = -1) THEN
  187. p^.Bal := 1;
  188. ELSE
  189. p^.Bal := 0;
  190. END;
  191. IF (p2^.Bal = 1) THEN
  192. p1^.Bal := -1;
  193. ELSE
  194. p1^.Bal := 0;
  195. END;
  196. p := p2;
  197. END;
  198. p^.Bal := 0;
  199. h := FALSE; (* Balancing done *)
  200. END (* CASE *);
  201. END (* of balancing 'Left' sub-tree *);
  202. ELSIF (x.Compare(p) > 0) THEN (* 'THIS' > 'p' *)
  203. (* Search the 'Right' branch of 'p' recursively
  204. until 'x' is either found or created.
  205. *)
  206. Search( p^.Right,h);
  207. IF h THEN (* i.e. tree needs balancing *)
  208. CASE p^.Bal OF
  209. | -1 :
  210. p^.Bal := 0;
  211. h := FALSE;
  212. | 0 :
  213. p^.Bal := 1;
  214. | 1 :
  215. p1 := p^.Right;
  216. IF (p1^.Bal = 1) THEN
  217. p^.Right := p1^.Left;
  218. p1^.Left := p;
  219. p^.Bal := 0;
  220. p := p1;
  221. ELSE
  222. p2 := p1^.Left;
  223. p1^.Left := p2^.Right;
  224. p2^.Right := p1;
  225. p^.Right := p2^.Left;
  226. p2^.Left := p;
  227. IF (p2^.Bal = 1) THEN
  228. p^.Bal := -1;
  229. ELSE
  230. p^.Bal := 0;
  231. END;
  232. IF (p2^.Bal = -1) THEN
  233. p1^.Bal := 1;
  234. ELSE
  235. p1^.Bal := 0;
  236. END;
  237. p := p2;
  238. END;
  239. p^.Bal := 0;
  240. h := FALSE; (* Tree balanced *)
  241. END (* CASE *);
  242. END (* Balancing 'Right' sub-tree *);
  243. ELSE (* 'THIS' and 'p' are the same *)
  244. h := FALSE;
  245. Lib.Move(ADR(GenElemPtr(ADR(x))^.GenericData),
  246. ADR(GenElemPtr(p)^.GenericData),
  247. SIZE(x)-VSIZE(Element.Bal));
  248. END (* Possible comaprison results *);
  249. END;
  250. END Search;
  251. VAR
  252. h : BOOLEAN;
  253. BEGIN
  254. IF (Root # NIL) AND (ADR(Root^.Compare) # ADR(x.Compare)) THEN
  255. (* All table elements must be homogeneous; i.e. they must be of
  256. the same CLASS
  257. *)
  258. Lib.FatalError('object not compatible with table');
  259. END;
  260. Search(Root,h);
  261. END Insert;
  262. PROCEDURE Find( VAR x : Element ) : BOOLEAN;
  263. (* Search for 'x' in 'THIS' tree; if 'x' is found in
  264. 'THIS' tree then the function returns 'TRUE' and 'x'
  265. is set to the mathing element. Otherwise the
  266. method returns 'FALSE'.
  267. *)
  268. PROCEDURE _Find( r : ElementPtr ) : ElementPtr;
  269. (* Implements the search algorithm *)
  270. BEGIN
  271. LOOP
  272. IF (r = NIL) THEN (* No match *)
  273. RETURN r;
  274. ELSIF (x.Compare(r) < 0) THEN (* 'THIS' < r *)
  275. r := r^.Left;
  276. ELSIF (x.Compare(r) > 0) THEN (* 'THIS' > r *)
  277. r := r^.Right;
  278. ELSE (* FOUND IT! *)
  279. RETURN r;
  280. END;
  281. END (* LOOP *);
  282. END _Find;
  283. VAR
  284. p : ElementPtr;
  285. BEGIN
  286. p := _Find(Root);
  287. IF (p # NIL) THEN (* Element Located *)
  288. Lib.Move(p,ADR(x),SIZE(x));
  289. RETURN TRUE;
  290. ELSE
  291. RETURN FALSE;
  292. END;
  293. END Find;
  294. PROCEDURE Delete( VAR x : Element );
  295. (* Locate the element 'x' in 'THIS' tree and delete it *)
  296. VAR
  297. q : ElementPtr;
  298. PROCEDURE r_Balance( VAR p : ElementPtr; VAR h : BOOLEAN);
  299. (* Blance a right sub-tree *)
  300. VAR
  301. p1 : ElementPtr;
  302. p2 : ElementPtr;
  303. b1 : BalanceFlag;
  304. b2 : BalanceFlag;
  305. BEGIN
  306. CASE p^.Bal OF
  307. | -1 :
  308. p^.Bal := 0;
  309. | 0 :
  310. p^.Bal := 1;
  311. h := FALSE;
  312. | 1 :
  313. p1 := p^.Right;
  314. b1 := p1^.Bal;
  315. IF (b1 >= 0) THEN
  316. p^.Right := p1^.Left;
  317. p1^.Left := p;
  318. IF (b1 = 0) THEN
  319. p^.Bal := 1;
  320. p1^.Bal := -1;
  321. h := FALSE
  322. ELSE
  323. p^.Bal := 0;
  324. p1^.Bal := 0;
  325. END;
  326. p := p1;
  327. ELSE
  328. p2 := p1^.Left;
  329. b2 := p2^.Bal;
  330. p1^.Left := p2^.Right;
  331. p2^.Right := p1;
  332. p^.Right := p2^.Left;
  333. p2^.Left := p;
  334. IF (b2 = 1) THEN
  335. p^.Bal := -1;
  336. ELSE
  337. p^.Bal := 0;
  338. END;
  339. IF (b2 = -1) THEN
  340. p1^.Bal := 1;
  341. ELSE
  342. p1^.Bal := 0;
  343. END;
  344. p := p2;
  345. p2^.Bal := 0;
  346. END;
  347. END (* CASE *);
  348. END r_Balance;
  349. PROCEDURE l_Balance( VAR p : ElementPtr; VAR h : BOOLEAN);
  350. (* Balance a left sub-tree *)
  351. VAR
  352. p1 : ElementPtr;
  353. p2 : ElementPtr;
  354. b1 : BalanceFlag;
  355. b2 : BalanceFlag;
  356. BEGIN
  357. CASE p^.Bal OF
  358. | 1 :
  359. p^.Bal := 0;
  360. | 0 :
  361. p^.Bal := -1;
  362. h := FALSE;
  363. | -1 :
  364. p1 := p^.Left;
  365. b1 := p1^.Bal;
  366. IF (b1 <= 0) THEN
  367. p^.Left := p1^.Right;
  368. p1^.Right := p;
  369. IF (b1 = 0) THEN
  370. p^.Bal := -1;
  371. p1^.Bal := 1;
  372. h := FALSE
  373. ELSE
  374. p^.Bal := 0;
  375. p1^.Bal := 0;
  376. END;
  377. p := p1;
  378. ELSE
  379. p2 := p1^.Right;
  380. b2 := p2^.Bal;
  381. p1^.Right := p2^.Left;
  382. p2^.Left := p1;
  383. p^.Left := p2^.Right;
  384. p2^.Right := p;
  385. IF (b2 = -1) THEN
  386. p^.Bal := 1;
  387. ELSE
  388. p^.Bal := 0;
  389. END;
  390. IF (b2 = 1) THEN
  391. p1^.Bal := -1;
  392. ELSE
  393. p1^.Bal := 0;
  394. END;
  395. p := p2;
  396. p2^.Bal := 0;
  397. END;
  398. END (* CASE *);
  399. END l_Balance;
  400. PROCEDURE DeleteLeaf( VAR r : ElementPtr; VAR h : BOOLEAN );
  401. (* Recursively search for extreme right-hand node of
  402. the sub-tree 'r' and move data into 'q'
  403. *)
  404. BEGIN
  405. IF (r^.Right # NIL) THEN
  406. DeleteLeaf(r^.Right,h);
  407. IF h THEN
  408. l_Balance(r,h);
  409. END;
  410. ELSE
  411. Lib.Move(ADR(GenElemPtr(r)^.GenericData),
  412. ADR(GenElemPtr(q)^.GenericData),
  413. SIZE(x)-VSIZE(Element.Bal));
  414. q := r;
  415. r := r^.Left;
  416. h := TRUE;
  417. END;
  418. END DeleteLeaf;
  419. PROCEDURE _Delete( VAR p : ElementPtr; VAR h : BOOLEAN );
  420. (* Main recursive deletion procedure *)
  421. BEGIN
  422. IF (p = NIL) THEN (* Not found *)
  423. h := FALSE;
  424. ELSIF (x.Compare(p) < 0) THEN (* 'THIS' < 'p' *)
  425. _Delete(p^.Left,h);
  426. IF h THEN
  427. r_Balance(p,h);
  428. END;
  429. ELSIF (x.Compare(p) > 0) THEN (* 'THIS' > 'p' *)
  430. _Delete(p^.Right,h);
  431. IF h THEN
  432. l_Balance(p,h);
  433. END;
  434. ELSE (* Found it! *)
  435. q := p;
  436. IF (q^.Right = NIL) THEN
  437. p := q^.Left;
  438. h := TRUE;
  439. ELSIF (q^.Left = NIL) THEN
  440. p := q^.Right;
  441. h := TRUE;
  442. ELSE
  443. DeleteLeaf(q^.Left,h);
  444. IF h THEN
  445. r_Balance(p,h);
  446. END;
  447. END;
  448. DISPOSE(q);
  449. END;
  450. END _Delete;
  451. VAR
  452. h : BOOLEAN;
  453. BEGIN
  454. IF (Root = NIL) THEN
  455. RETURN;
  456. END;
  457. IF (Root # NIL) AND (ADR(x.Compare) # ADR(Root^.Compare)) THEN
  458. (* 'x' is not the same type as tree members *)
  459. Lib.FatalError('object not compatible with table');
  460. END;
  461. _Delete(Root,h);
  462. END Delete;
  463. PROCEDURE Apply( p : Action );
  464. (* Apply a procedure to all table elements in order *)
  465. PROCEDURE ApplyToElement( s : ElementPtr );
  466. (* Apply 'p' to left sub-tree of s, then s, then the
  467. right sub-tree of s.
  468. *)
  469. BEGIN
  470. IF (s = NIL) THEN
  471. RETURN;
  472. ELSE
  473. ApplyToElement(s^.Left);
  474. p(s);
  475. ApplyToElement(s^.Right);
  476. END;
  477. END ApplyToElement;
  478. BEGIN
  479. ApplyToElement(Root);
  480. END Apply;
  481. PROCEDURE Init;
  482. (* Initialise a tree *)
  483. BEGIN
  484. Root := NIL;
  485. END Init;
  486. PROCEDURE Eq( t2 : TABLE ) : INTEGER;
  487. (* Compare 'THIS' to 't2'. Return values:
  488. <0 'THIS' is less than 't2'
  489. 0 'THIS' is equal to 't2'
  490. >0 'THIS' is greater than 't2'
  491. The trees are searched from the bottom up (i.e. in
  492. order) and the elements compared. The procedure
  493. returns immediately a difference is detected or
  494. when both trees are exhausted (and, therefore, they
  495. must be equal). This process is implemented iteratively
  496. rather than recursively.
  497. *)
  498. VAR
  499. S1,
  500. S2 : ARRAY [1..32] OF ElementPtr;
  501. r1,
  502. r2 : ElementPtr;
  503. sp1,
  504. sp2 : CARDINAL;
  505. res : INTEGER;
  506. BEGIN
  507. r1 := Root;
  508. r2 := t2.Root;
  509. IF (r1 # NIL) AND (r1 # r2) AND (ADR(r1^.Compare) # ADR(r2^.Compare)) THEN
  510. (* Both trees must contain the same sort of element *)
  511. Lib.FatalError(' not compareable ');
  512. END;
  513. sp1 := 0;
  514. sp2 := 0;
  515. LOOP
  516. WHILE (r1 # NIL) DO (* Build left edge array for 'THIS' *)
  517. INC(sp1);
  518. S1[sp1] := r1;
  519. r1 := r1^.Left;
  520. END;
  521. WHILE (r2 # NIL) DO (* Build left edge array for 't2' *)
  522. INC(sp2);
  523. S2[sp2] := r2;
  524. r2 := r2^.Left;
  525. END;
  526. IF (sp1 = 0) THEN (* No left sub-tree for 'THIS' *)
  527. IF (sp2 = 0) THEN (* No left sub-tree for 't2' *)
  528. RETURN 0; (* Implies they are equal *)
  529. ELSE
  530. RETURN -1; (* 'THIS' < 't2' *)
  531. END;
  532. ELSIF (sp2 = 0) THEN (* No left sub-tree for 't2' *)
  533. RETURN 1; (* 'THIS' > 't2' *)
  534. ELSE
  535. r1 := S1[sp1];
  536. DEC(sp1);
  537. r2 := S2[sp2];
  538. DEC(sp2);
  539. END;
  540. res := r1^.Compare(r2); (* Compare extreme left of both *)
  541. IF (res # 0) THEN (* These are different! *)
  542. RETURN res; (* Return how they are different *)
  543. END;
  544. r1 := r1^.Right;
  545. r2 := r2^.Right;
  546. END (* LOOP *);
  547. END Eq;
  548. PROCEDURE SubSet( t2 : TABLE ) : BOOLEAN;
  549. (* Are the elements of 'THIS' table a sub set of the elements
  550. of the table 't2'?
  551. The procedure scans scans the trees in order looking for
  552. an initial point of equality. Then 'THIS' is compared to
  553. this sub-tree of 't2' until either an element greater than
  554. the current 'THIS' element is found, or 'THIS' is exhuasted.
  555. The process is implemented iteratively rather than
  556. recursively.
  557. *)
  558. VAR
  559. S1,
  560. S2 : ARRAY [1..32] OF ElementPtr;
  561. r1,
  562. r2,
  563. cr : ElementPtr;
  564. sp1,
  565. sp2 : CARDINAL;
  566. res : INTEGER;
  567. BEGIN
  568. IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN
  569. (* Both trees must contain the same type of element *)
  570. Lib.FatalError('different types');
  571. END;
  572. r1 := Root;
  573. r2 := t2.Root;
  574. sp1 := 0;
  575. sp2 := 0;
  576. LOOP
  577. WHILE (r1 # NIL) DO
  578. INC(sp1);
  579. S1[sp1] := r1;
  580. r1 := r1^.Left;
  581. END;
  582. IF (sp1 = 0) THEN (* End of 'THIS' => is a sub-tree *)
  583. RETURN TRUE;
  584. END;
  585. r1 := S1[sp1];
  586. DEC(sp1);
  587. cr := r1;
  588. r1 := r1^.Right;
  589. LOOP
  590. WHILE (r2 # NIL) DO
  591. INC(sp2);
  592. S2[sp2] := r2;
  593. r2 := r2^.Left;
  594. END;
  595. IF (sp2 = 0) THEN (* End of 't2' => not a sub-tree *)
  596. RETURN FALSE;
  597. ELSE
  598. r2 := S2[sp2];
  599. DEC(sp2);
  600. END;
  601. res := cr^.Compare(r2);
  602. r2 := r2^.Right;
  603. IF (res < 0) THEN
  604. RETURN FALSE;
  605. ELSIF (res = 0) THEN
  606. EXIT;
  607. END;
  608. END (* LOOP *);
  609. END (* LOOP *);
  610. END SubSet;
  611. PROCEDURE Copy() : TABLE;
  612. (* Make a copy of 'THIS' *)
  613. PROCEDURE _Copy( r : ElementPtr ) : ElementPtr;
  614. (* Recursively generate a copy of 'r' *)
  615. VAR
  616. x : ElementPtr;
  617. BEGIN
  618. IF (r # NIL) THEN
  619. ALLOCATE(x,SIZE(r^));
  620. Lib.Move(r,x,SIZE(r^));
  621. x^.Left := _Copy(r^.Left);
  622. x^.Right := _Copy(r^.Right);
  623. RETURN x;
  624. ELSE
  625. RETURN r;
  626. END;
  627. END _Copy;
  628. VAR
  629. NewTree : TABLE;
  630. BEGIN
  631. NewTree.Root := _Copy(Root);
  632. RETURN NewTree;
  633. END Copy;
  634. PROCEDURE Incl( t2 : TABLE);
  635. (* Include 't2' in 'THIS' tree *)
  636. PROCEDURE _Incl( r : ElementPtr );
  637. (* Recursively insert 'r' into 'THIS' *)
  638. BEGIN
  639. IF (r # NIL) THEN
  640. _Incl(r^.Left);
  641. _Incl(r^.Right);
  642. Insert(r^);
  643. END;
  644. END _Incl;
  645. BEGIN
  646. IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN
  647. Lib.FatalError('different types');
  648. END;
  649. _Incl(t2.Root);
  650. END Incl;
  651. PROCEDURE Excl( t2 : TABLE);
  652. (* Exclude elements of 't2' from 'THIS' *)
  653. PROCEDURE _Excl( r: ElementPtr );
  654. (* Recursively exclude 'r' from 'THIS' *)
  655. BEGIN
  656. IF (r # NIL) THEN
  657. _Excl(r^.Left);
  658. _Excl(r^.Right);
  659. Delete(r^);
  660. END;
  661. END _Excl;
  662. BEGIN
  663. IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN
  664. Lib.FatalError('different types');
  665. END;
  666. _Excl(t2.Root);
  667. END Excl;
  668. PROCEDURE Empty() : BOOLEAN;
  669. (* Is 'THIS' empty? *)
  670. BEGIN
  671. RETURN (Root = NIL);
  672. END Empty;
  673. PROCEDURE Dispose;
  674. (* Dispose of entire tree *)
  675. PROCEDURE _Dispose( r : ElementPtr );
  676. (* Recursively dispose of each element of 'r' *)
  677. BEGIN
  678. IF (r # NIL) THEN
  679. _Dispose(r^.Left); (* Delete left sub-tree *)
  680. _Dispose(r^.Right); (* Delete right sub-tree *)
  681. DISPOSE(r);
  682. END;
  683. END _Dispose;
  684. BEGIN
  685. _Dispose(Root);
  686. END Dispose;
  687. BEGIN
  688. END TABLE ;
  689. END Table.