ClassDecl ::= CLASS Classidentifier ['(' Classidentifier { ',' Classidentifier } ')'] ';' [ClassFieldDefList] [MethodDecList] END Classidentifier ';' ClassFieldDefList ::= ClassFieldDef {';' ClassFieldDef } ClassFieldDef ::= IdentifierList ':' TypeIdentifier | Identifier '=' Identifier MethodDecList ::= MethodDec {';' MethodDec } MethodDec ::= [VIRTUAL] PROCEDURE MethodIdentifier ['(' [FormalParams] ')' [':' TypeIdentifier]] ';' FormalParams ::= [VAR] IdentifierList ':' TypeIdentifier { ';' [VAR] IdentifierList ':' TypeIdentifier } ClassImpl ::= CLASS IMPLEMENTATION Classidentifier ';' {MethodImpl ';'} [BEGIN [StatementSeq] ] END Classidentifier ';' MethodImpl ::= [VIRTUAL] PROCEDURE MethodIdentifier ['(' [FormalParams] ')' [':' TypeIdentifier]] ';' (FORWARD | Block Identifier) NOTES (V3 implementation, m2compiler-V3): - Method separators are ';' (as in the Table example below), not ',' as earlier drafts of this sketch had it. - "PEOCEDURE" typo in the original sketch fixed to PROCEDURE. - Single inheritance only: extra parents are rejected (230). - Classic identifiers only (no '_'); the Table example's _Find-style names are lexically out of reach for now. - Class lowering lands (see docs/summary_class-lowering.md): fields, methods (value/VAR formals, results), single inheritance and a hidden THIS receiver all generate code. - VIRTUAL now dispatches dynamically through per-class vtables, with POINTER-TO-Derived -> POINTER-TO-Base subtype assignment (see docs/summary_virtual-dispatch.md). - A bare sibling-method call inside a method body is a call on THIS; a class BEGIN ... END init body runs once at startup (as _init). - Still 230: extra parents (multiple inheritance is out of scope). FUTURE WORK -- multiple inheritance (not planned; recorded for later): Single inheritance is a deliberate choice; extra parents stay 230. If MI is ever wanted, the cost is dominated by ONE thing: pointer adjustment for upcasting to a non-first base. * Tier 1 -- "multiple inclusion" (~1 day): CLASS C (A, B) lays out A's fields then B's, and both sets of methods are callable as obj.M, but you may only upcast along the FIRST parent (POINTER TO B := c stays rejected). No pointer adjustment, so the fixpoint stays a reliable guard. Mostly SymTab/QbeGen: tparent -> a parent list (ParentCount/ParentAt), and FindField / ClassMethodNode / IsSubclass / BuildVTable / ComputeOffsets / TypeSizeD iterating the set; plus an ambiguity check when two paths declare the same name (~10-15 functions). * Tier 2 -- full MI with polymorphic upcasting (several days, higher risk): adds address adjustment on every upcast (pointer assignment, VAR/value actuals, =/#, NEW) and this-adjusting thunks for virtual calls through a secondary base; also forces a decision on DIAMONDS -- note CLASS Multi (Shape, Circle) below IS a diamond (Circle already inherits Shape), needing shared-base dedup or an outright rejection. Clarion reference semantics for multi-parent classes are not fully specified here, so Tier 2 would partly be inventing semantics. Recommendation: Tier 1 only if a real corpus needs multi-parent inclusion; otherwise leave MI out. Example: (* ========================================== *) (* (c) 1990-1992 Clarion Software Corporation *) (* ========================================== *) DEFINITION MODULE Table; (* This module implements classes that allow the creation and maintenance of homogeneous tables of ordered objects. The internal structure of the table is an AVL Balanced Tree. The algorithms are based on an example given in Niklaus Wirth's "Algorithms + Data Structures = Programs". That book also gives a detailed description of AVL Balanced Trees. *) TYPE BalanceFlag = SHORTINT [-1..1]; ElementPtr = POINTER TO Element; CLASS Element; Right : ElementPtr; (* Pointer to right sub-tree *) Left : ElementPtr; (* Pointer to left sub-tree *) Bal : BalanceFlag; (* Tree balance flag *) VIRTUAL PROCEDURE Compare( p : ElementPtr ) : INTEGER; (* Must be implemented by the client. This procedure should return one of the following integer values: <0 if 'THIS' is less than 'p' 0 if 'THIS' is equal to 'p' >0 if 'THIS' is greater than 'p' *) END Element ; TYPE Action = PROCEDURE ( ElementPtr ); (* This procedure type is used by 'Apply' *) CLASS TABLE; Root : ElementPtr; (* The root of this tree *) PROCEDURE Insert( VAR x : Element ); (* Insert the element 'x' into this table *) PROCEDURE Find( VAR p : Element ) : BOOLEAN; (* Search table for a element matching 'p'. Returns 'TRUE' and sets all fields of 'p' if found; otherwise returns 'FALSE' *) PROCEDURE Delete( VAR x : Element ); (* Delete the element matching 'p' from table *) PROCEDURE Apply( p : Action ); (* Apply procedure 'p' to all elements in order *) PROCEDURE Init; (* Initialize the table *) PROCEDURE Eq( t2 : TABLE ) : INTEGER; (* Compare 'THIS' with 't2'. The return values are: <0 'THIS' is less than 't2' 0 'THIS' is equal to 't2' >0 'THIS' is greater than 't2' ** RESTRICTION : Table must not generate a tree greater than 32 levels deep (around 2^32 elements *) PROCEDURE SubSet( t2 : TABLE ) : BOOLEAN; (* Are the elements in this table a subset of the elememts in table 't2'? *) PROCEDURE Copy() : TABLE; (* Make a copy this table *) PROCEDURE Incl( t2 : TABLE ); (* Include elements from table 't2' in this table *) PROCEDURE Excl( t2 : TABLE ); (* Exclude elements from table 't2' from this table *) PROCEDURE Empty() : BOOLEAN; (* Is this table empty? *) PROCEDURE Dispose; (* Dispose of all elements of this table *) END TABLE ; END Table. (* ==================================================== *) (* Copyright (C) 1990-1992 Clarion Software Corporation *) (* ==================================================== *) IMPLEMENTATION MODULE Table; IMPORT Lib; FROM Storage IMPORT ALLOCATE, DEALLOCATE; CLASS IMPLEMENTATION Element; VIRTUAL PROCEDURE Compare( p : ElementPtr ) : INTEGER; (* It is an error not to supply an implementation of this method. The client MUST supply a method to compare 'THIS' with 'p'. *) BEGIN Lib.FatalError(' implemeted by client '); RETURN 0; END Compare; BEGIN END Element ; CLASS GenElem (Element) ; GenericData : CHAR; END GenElem; CLASS IMPLEMENTATION GenElem; BEGIN END GenElem; TYPE GenElemPtr = POINTER TO GenElem; (* The above definitions are a skeleton for all the implementation of the 'Element' CLASS. This enables the 'TABLE' class to successfully copy any client implementation of 'Element' *) CLASS IMPLEMENTATION TABLE; PROCEDURE Insert( VAR x : Element ); (* Insert a new element 'x' in 'THIS' table *) PROCEDURE Search( VAR p : ElementPtr; VAR h : BOOLEAN); (* Searches a tree 'p' for the element 'x'. If it is found then the new value replaces the old. If 'x' is not in the tree, then 'x' becomes a new leaf of the tree. *) VAR p1 : ElementPtr; p2 : ElementPtr; BEGIN IF (p = NIL) THEN (* Create new leaf *) ALLOCATE(p,SIZE(x)); Lib.Move(ADR(x),p,SIZE(x)); p^.Bal := 0; p^.Left := NIL; p^.Right := NIL; h := TRUE; (* Tree requires balancing *) ELSE IF (x.Compare(p) < 0) THEN (* 'THIS' is < 'p' *) (* Search the 'Left' branch of 'p' recursively until 'x' is either found or created. *) Search(p^.Left,h); IF h THEN (* i.e. requires balancing *) CASE p^.Bal OF | 1 : p^.Bal := 0; h := FALSE; | 0 : p^.Bal := -1; | -1 : p1 := p^.Left; IF (p1^.Bal = -1) THEN p^.Left := p1^.Right; p1^.Right := p; p^.Bal := 0; p := p1; ELSE p2 := p1^.Right; p1^.Right := p2^.Left; p2^.Left := p1; p^.Left := p2^.Right; p2^.Right := p; IF (p2^.Bal = -1) THEN p^.Bal := 1; ELSE p^.Bal := 0; END; IF (p2^.Bal = 1) THEN p1^.Bal := -1; ELSE p1^.Bal := 0; END; p := p2; END; p^.Bal := 0; h := FALSE; (* Balancing done *) END (* CASE *); END (* of balancing 'Left' sub-tree *); ELSIF (x.Compare(p) > 0) THEN (* 'THIS' > 'p' *) (* Search the 'Right' branch of 'p' recursively until 'x' is either found or created. *) Search( p^.Right,h); IF h THEN (* i.e. tree needs balancing *) CASE p^.Bal OF | -1 : p^.Bal := 0; h := FALSE; | 0 : p^.Bal := 1; | 1 : p1 := p^.Right; IF (p1^.Bal = 1) THEN p^.Right := p1^.Left; p1^.Left := p; p^.Bal := 0; p := p1; ELSE p2 := p1^.Left; p1^.Left := p2^.Right; p2^.Right := p1; p^.Right := p2^.Left; p2^.Left := p; IF (p2^.Bal = 1) THEN p^.Bal := -1; ELSE p^.Bal := 0; END; IF (p2^.Bal = -1) THEN p1^.Bal := 1; ELSE p1^.Bal := 0; END; p := p2; END; p^.Bal := 0; h := FALSE; (* Tree balanced *) END (* CASE *); END (* Balancing 'Right' sub-tree *); ELSE (* 'THIS' and 'p' are the same *) h := FALSE; Lib.Move(ADR(GenElemPtr(ADR(x))^.GenericData), ADR(GenElemPtr(p)^.GenericData), SIZE(x)-VSIZE(Element.Bal)); END (* Possible comaprison results *); END; END Search; VAR h : BOOLEAN; BEGIN IF (Root # NIL) AND (ADR(Root^.Compare) # ADR(x.Compare)) THEN (* All table elements must be homogeneous; i.e. they must be of the same CLASS *) Lib.FatalError('object not compatible with table'); END; Search(Root,h); END Insert; PROCEDURE Find( VAR x : Element ) : BOOLEAN; (* Search for 'x' in 'THIS' tree; if 'x' is found in 'THIS' tree then the function returns 'TRUE' and 'x' is set to the mathing element. Otherwise the method returns 'FALSE'. *) PROCEDURE _Find( r : ElementPtr ) : ElementPtr; (* Implements the search algorithm *) BEGIN LOOP IF (r = NIL) THEN (* No match *) RETURN r; ELSIF (x.Compare(r) < 0) THEN (* 'THIS' < r *) r := r^.Left; ELSIF (x.Compare(r) > 0) THEN (* 'THIS' > r *) r := r^.Right; ELSE (* FOUND IT! *) RETURN r; END; END (* LOOP *); END _Find; VAR p : ElementPtr; BEGIN p := _Find(Root); IF (p # NIL) THEN (* Element Located *) Lib.Move(p,ADR(x),SIZE(x)); RETURN TRUE; ELSE RETURN FALSE; END; END Find; PROCEDURE Delete( VAR x : Element ); (* Locate the element 'x' in 'THIS' tree and delete it *) VAR q : ElementPtr; PROCEDURE r_Balance( VAR p : ElementPtr; VAR h : BOOLEAN); (* Blance a right sub-tree *) VAR p1 : ElementPtr; p2 : ElementPtr; b1 : BalanceFlag; b2 : BalanceFlag; BEGIN CASE p^.Bal OF | -1 : p^.Bal := 0; | 0 : p^.Bal := 1; h := FALSE; | 1 : p1 := p^.Right; b1 := p1^.Bal; IF (b1 >= 0) THEN p^.Right := p1^.Left; p1^.Left := p; IF (b1 = 0) THEN p^.Bal := 1; p1^.Bal := -1; h := FALSE ELSE p^.Bal := 0; p1^.Bal := 0; END; p := p1; ELSE p2 := p1^.Left; b2 := p2^.Bal; p1^.Left := p2^.Right; p2^.Right := p1; p^.Right := p2^.Left; p2^.Left := p; IF (b2 = 1) THEN p^.Bal := -1; ELSE p^.Bal := 0; END; IF (b2 = -1) THEN p1^.Bal := 1; ELSE p1^.Bal := 0; END; p := p2; p2^.Bal := 0; END; END (* CASE *); END r_Balance; PROCEDURE l_Balance( VAR p : ElementPtr; VAR h : BOOLEAN); (* Balance a left sub-tree *) VAR p1 : ElementPtr; p2 : ElementPtr; b1 : BalanceFlag; b2 : BalanceFlag; BEGIN CASE p^.Bal OF | 1 : p^.Bal := 0; | 0 : p^.Bal := -1; h := FALSE; | -1 : p1 := p^.Left; b1 := p1^.Bal; IF (b1 <= 0) THEN p^.Left := p1^.Right; p1^.Right := p; IF (b1 = 0) THEN p^.Bal := -1; p1^.Bal := 1; h := FALSE ELSE p^.Bal := 0; p1^.Bal := 0; END; p := p1; ELSE p2 := p1^.Right; b2 := p2^.Bal; p1^.Right := p2^.Left; p2^.Left := p1; p^.Left := p2^.Right; p2^.Right := p; IF (b2 = -1) THEN p^.Bal := 1; ELSE p^.Bal := 0; END; IF (b2 = 1) THEN p1^.Bal := -1; ELSE p1^.Bal := 0; END; p := p2; p2^.Bal := 0; END; END (* CASE *); END l_Balance; PROCEDURE DeleteLeaf( VAR r : ElementPtr; VAR h : BOOLEAN ); (* Recursively search for extreme right-hand node of the sub-tree 'r' and move data into 'q' *) BEGIN IF (r^.Right # NIL) THEN DeleteLeaf(r^.Right,h); IF h THEN l_Balance(r,h); END; ELSE Lib.Move(ADR(GenElemPtr(r)^.GenericData), ADR(GenElemPtr(q)^.GenericData), SIZE(x)-VSIZE(Element.Bal)); q := r; r := r^.Left; h := TRUE; END; END DeleteLeaf; PROCEDURE _Delete( VAR p : ElementPtr; VAR h : BOOLEAN ); (* Main recursive deletion procedure *) BEGIN IF (p = NIL) THEN (* Not found *) h := FALSE; ELSIF (x.Compare(p) < 0) THEN (* 'THIS' < 'p' *) _Delete(p^.Left,h); IF h THEN r_Balance(p,h); END; ELSIF (x.Compare(p) > 0) THEN (* 'THIS' > 'p' *) _Delete(p^.Right,h); IF h THEN l_Balance(p,h); END; ELSE (* Found it! *) q := p; IF (q^.Right = NIL) THEN p := q^.Left; h := TRUE; ELSIF (q^.Left = NIL) THEN p := q^.Right; h := TRUE; ELSE DeleteLeaf(q^.Left,h); IF h THEN r_Balance(p,h); END; END; DISPOSE(q); END; END _Delete; VAR h : BOOLEAN; BEGIN IF (Root = NIL) THEN RETURN; END; IF (Root # NIL) AND (ADR(x.Compare) # ADR(Root^.Compare)) THEN (* 'x' is not the same type as tree members *) Lib.FatalError('object not compatible with table'); END; _Delete(Root,h); END Delete; PROCEDURE Apply( p : Action ); (* Apply a procedure to all table elements in order *) PROCEDURE ApplyToElement( s : ElementPtr ); (* Apply 'p' to left sub-tree of s, then s, then the right sub-tree of s. *) BEGIN IF (s = NIL) THEN RETURN; ELSE ApplyToElement(s^.Left); p(s); ApplyToElement(s^.Right); END; END ApplyToElement; BEGIN ApplyToElement(Root); END Apply; PROCEDURE Init; (* Initialise a tree *) BEGIN Root := NIL; END Init; PROCEDURE Eq( t2 : TABLE ) : INTEGER; (* Compare 'THIS' to 't2'. Return values: <0 'THIS' is less than 't2' 0 'THIS' is equal to 't2' >0 'THIS' is greater than 't2' The trees are searched from the bottom up (i.e. in order) and the elements compared. The procedure returns immediately a difference is detected or when both trees are exhausted (and, therefore, they must be equal). This process is implemented iteratively rather than recursively. *) VAR S1, S2 : ARRAY [1..32] OF ElementPtr; r1, r2 : ElementPtr; sp1, sp2 : CARDINAL; res : INTEGER; BEGIN r1 := Root; r2 := t2.Root; IF (r1 # NIL) AND (r1 # r2) AND (ADR(r1^.Compare) # ADR(r2^.Compare)) THEN (* Both trees must contain the same sort of element *) Lib.FatalError(' not compareable '); END; sp1 := 0; sp2 := 0; LOOP WHILE (r1 # NIL) DO (* Build left edge array for 'THIS' *) INC(sp1); S1[sp1] := r1; r1 := r1^.Left; END; WHILE (r2 # NIL) DO (* Build left edge array for 't2' *) INC(sp2); S2[sp2] := r2; r2 := r2^.Left; END; IF (sp1 = 0) THEN (* No left sub-tree for 'THIS' *) IF (sp2 = 0) THEN (* No left sub-tree for 't2' *) RETURN 0; (* Implies they are equal *) ELSE RETURN -1; (* 'THIS' < 't2' *) END; ELSIF (sp2 = 0) THEN (* No left sub-tree for 't2' *) RETURN 1; (* 'THIS' > 't2' *) ELSE r1 := S1[sp1]; DEC(sp1); r2 := S2[sp2]; DEC(sp2); END; res := r1^.Compare(r2); (* Compare extreme left of both *) IF (res # 0) THEN (* These are different! *) RETURN res; (* Return how they are different *) END; r1 := r1^.Right; r2 := r2^.Right; END (* LOOP *); END Eq; PROCEDURE SubSet( t2 : TABLE ) : BOOLEAN; (* Are the elements of 'THIS' table a sub set of the elements of the table 't2'? The procedure scans scans the trees in order looking for an initial point of equality. Then 'THIS' is compared to this sub-tree of 't2' until either an element greater than the current 'THIS' element is found, or 'THIS' is exhuasted. The process is implemented iteratively rather than recursively. *) VAR S1, S2 : ARRAY [1..32] OF ElementPtr; r1, r2, cr : ElementPtr; sp1, sp2 : CARDINAL; res : INTEGER; BEGIN IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN (* Both trees must contain the same type of element *) Lib.FatalError('different types'); END; r1 := Root; r2 := t2.Root; sp1 := 0; sp2 := 0; LOOP WHILE (r1 # NIL) DO INC(sp1); S1[sp1] := r1; r1 := r1^.Left; END; IF (sp1 = 0) THEN (* End of 'THIS' => is a sub-tree *) RETURN TRUE; END; r1 := S1[sp1]; DEC(sp1); cr := r1; r1 := r1^.Right; LOOP WHILE (r2 # NIL) DO INC(sp2); S2[sp2] := r2; r2 := r2^.Left; END; IF (sp2 = 0) THEN (* End of 't2' => not a sub-tree *) RETURN FALSE; ELSE r2 := S2[sp2]; DEC(sp2); END; res := cr^.Compare(r2); r2 := r2^.Right; IF (res < 0) THEN RETURN FALSE; ELSIF (res = 0) THEN EXIT; END; END (* LOOP *); END (* LOOP *); END SubSet; PROCEDURE Copy() : TABLE; (* Make a copy of 'THIS' *) PROCEDURE _Copy( r : ElementPtr ) : ElementPtr; (* Recursively generate a copy of 'r' *) VAR x : ElementPtr; BEGIN IF (r # NIL) THEN ALLOCATE(x,SIZE(r^)); Lib.Move(r,x,SIZE(r^)); x^.Left := _Copy(r^.Left); x^.Right := _Copy(r^.Right); RETURN x; ELSE RETURN r; END; END _Copy; VAR NewTree : TABLE; BEGIN NewTree.Root := _Copy(Root); RETURN NewTree; END Copy; PROCEDURE Incl( t2 : TABLE); (* Include 't2' in 'THIS' tree *) PROCEDURE _Incl( r : ElementPtr ); (* Recursively insert 'r' into 'THIS' *) BEGIN IF (r # NIL) THEN _Incl(r^.Left); _Incl(r^.Right); Insert(r^); END; END _Incl; BEGIN IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN Lib.FatalError('different types'); END; _Incl(t2.Root); END Incl; PROCEDURE Excl( t2 : TABLE); (* Exclude elements of 't2' from 'THIS' *) PROCEDURE _Excl( r: ElementPtr ); (* Recursively exclude 'r' from 'THIS' *) BEGIN IF (r # NIL) THEN _Excl(r^.Left); _Excl(r^.Right); Delete(r^); END; END _Excl; BEGIN IF (Root # NIL) AND (t2.Root # Root) AND (ADR(Root^.Compare) # ADR(t2.Root^.Compare)) THEN Lib.FatalError('different types'); END; _Excl(t2.Root); END Excl; PROCEDURE Empty() : BOOLEAN; (* Is 'THIS' empty? *) BEGIN RETURN (Root = NIL); END Empty; PROCEDURE Dispose; (* Dispose of entire tree *) PROCEDURE _Dispose( r : ElementPtr ); (* Recursively dispose of each element of 'r' *) BEGIN IF (r # NIL) THEN _Dispose(r^.Left); (* Delete left sub-tree *) _Dispose(r^.Right); (* Delete right sub-tree *) DISPOSE(r); END; END _Dispose; BEGIN _Dispose(Root); END Dispose; BEGIN END TABLE ; END Table.