OOP.txt 30 KB

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