OOP.txt 30 KB

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