OOP.txt 30 KB

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