Syntax10.Scn.Fnt
Syntax10i.Scn.Fnt
Syntax10b.Scn.Fnt
MODULE Class;	(** HM 16-May-91 **)
(*---------------------------------------------------------------------
Extracts class interfaces from a source module (record types with type-bound procedures)
Class.Show *
	shows the interface of all record types in the marked source text.
Class.Show modulename.typename
	shows the interface of the specified type.
Class.Show ^
	shows the interface of the specified type. The selection may be
	- a type name directly in the source text.
	- a combination modulename.typename in any text.
----------------------------------------------------------------------*)
	IMPORT
		Oberon, Viewers, Texts, TextFrames, MenuViewers;
	CONST
		StdMenu = "System.Close  System.Copy  System.Grow  Edit.Search  Edit.Store";
		TAB = 9X;  CR = 0DX;
		eot = 0; procedure = 1;  record = 2;  pointer = 3;  end = 4; colon = 5;
		lparen = 6;  rparen = 7;  semicolon = 8; eql = 9; arrow = 10; star = 11;
		ident = 12; none = 99;
	TYPE
		Name = ARRAY 64 OF CHAR;
		Class = POINTER TO ClassDesc;
		Method = POINTER TO MethodDesc;
		ClassDesc = RECORD
			name: Name;
			kind: INTEGER;
			beg, end: LONGINT;
			methods: Method;
			link, next: Class
		END;
		MethodDesc = RECORD
			beg, end: LONGINT;
			next: Method
		END;
		ch: CHAR;
		sym, lastSym: INTEGER;
		pos, lastPos: LONGINT;
		B: Texts.Buffer;
		TMod, TOut: Texts.Text;
		R: Texts.Reader;
		W: Texts.Writer;
		id: Name;
		lineBeg: LONGINT;
		lastID: Name;
		lastIDline: LONGINT;
		type: Name;
		classes: Class;
(* scanner *)
	PROCEDURE Ch;
	BEGIN
		Texts.Read(R, ch); INC(pos)
	END Ch;
	PROCEDURE Start(n: LONGINT);
	BEGIN
		pos := n; Texts.OpenReader(R, TMod, pos)
	END Start;
	PROCEDURE Comment;
	BEGIN
		LOOP
			IF R.eot THEN RETURN
			ELSIF ch = "*" THEN Ch; IF ch = ")" THEN Ch; RETURN END
			ELSIF ch = "(" THEN Ch; IF ch = "*" THEN Ch; Comment END
			ELSE Ch
			END
		END
	END Comment;
	PROCEDURE Ident;
		VAR i: INTEGER;
	BEGIN sym := ident; i := 0;
		REPEAT id[i] := ch; Ch; INC(i) UNTIL (ch < "0") & (ch # ".") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z");
		id[i] := 0X
	END Ident;
	PROCEDURE Sym;
		VAR ch0: CHAR;
	BEGIN
		lastSym := sym; lastPos := pos; sym := none;
		WHILE sym = none DO
			CASE ch OF
			|  0X: sym := eot
			|  1X.." ": REPEAT IF ch = CR THEN lineBeg := pos END; Ch UNTIL (ch > " ") OR (ch = 0X)
			|  "a".."z", "A".."Z": Ident;
					CASE id[0] OF
					| "E": IF id = "END" THEN sym := end END
					| "P": IF id = "PROCEDURE" THEN sym := procedure ELSIF id = "POINTER" THEN sym := pointer END
					| "R": IF id = "RECORD" THEN sym := record END
					ELSE
					END;
					IF sym = ident THEN lastID := id; lastIDline := lineBeg END
			|  "'", '"': ch0 := ch; REPEAT Ch UNTIL (ch = ch0) OR (ch < " ") OR R.eot; Ch
			|  "(": Ch; IF ch = "*" THEN Ch; Comment ELSE sym := lparen END
			|  ")": sym := rparen; Ch
			|  ":": sym := colon; Ch
			| "=": sym := eql; Ch
			|  ";": sym := semicolon; Ch
			| "^": sym := arrow; Ch
			| "*": sym := star; Ch
			ELSE Ch
			END
		END
	END Sym;
(* parser *)
	PROCEDURE FindClass(VAR id: Name; VAR c: Class);
	BEGIN c := classes;
		WHILE (c # NIL) & (c.name # id) DO c := c.next END
	END FindClass;
	PROCEDURE FindLink(VAR id: Name; VAR c: Class);
		VAR p: Class;
	BEGIN p := classes;
		WHILE (p # NIL) & ((p.link = NIL) OR (p.link.name # id)) DO p := p.next END;
		IF p = NIL THEN c := NIL ELSE c := p.link END
	END FindLink;
	PROCEDURE RecordType(VAR c: Class);
		VAR ok: BOOLEAN; c0: Class;
	BEGIN c := NIL;
		ok := lastSym IN {eql, ident};
		IF lastSym = eql THEN FindLink(lastID, c) END;
		IF c = NIL THEN NEW(c); c.name := lastID; c.kind := record END;
		c.beg := lastIDline;
		LOOP Sym;
			IF sym IN {end, eot} THEN c.end := lastPos - 1; EXIT
			ELSIF sym = record THEN RecordType(c0) (*ignore nested records*)
			END
		END;
		IF ~ok THEN c := NIL END
	END RecordType;
	PROCEDURE PointerType(VAR c: Class);
		VAR ok: BOOLEAN; c0: Class;
	BEGIN
		ok := lastSym = eql;
		NEW(c); c.name := lastID; c.kind := pointer; c.beg := lastIDline;
		Sym; Sym;
		IF sym = ident THEN
			FindClass(id, c0);
			IF c0 = NIL THEN NEW(c0); c0.name := id; c0.kind := record END;
			c.link := c0; Sym; c.end := pos - 1;
		ELSIF sym = record THEN
			RecordType(c0); c.link := c0; c0.name := "";
			c.end := lastPos - 1;
			IF ok THEN c0.next := classes; classes := c0 END
		ELSE ok := FALSE
		END;
		IF ~ok THEN c := NIL END
	END PointerType;
	PROCEDURE Procedure;
		VAR m: Method; className: Name; c: Class;
	BEGIN 
		NEW(m); m.beg := pos-10;
		Sym; IF sym # lparen THEN RETURN END;
		REPEAT Sym UNTIL sym IN {colon, eot};
		Sym; className := id;
		REPEAT Sym UNTIL sym IN {lparen, semicolon, eot};
		IF sym = lparen THEN REPEAT Sym UNTIL sym IN {rparen, eot};
			Sym; IF sym = colon THEN Sym; Sym END
		END;
		m.end := pos - 1;
		FindClass(className, c); IF c = NIL THEN RETURN END;
		IF c.kind = pointer THEN c := c.link END;
		m.next := c.methods; c.methods := m
	END Procedure;
(* output routines *)
	PROCEDURE Wr(ch: CHAR);
	BEGIN Texts.Write(W, ch); Texts.Append(TOut, W.buf)
	END Wr;
	PROCEDURE Str(s: ARRAY OF CHAR);
	BEGIN Texts.WriteString(W, s); Texts.Append(TOut, W.buf)
	END Str;
	PROCEDURE Lead(pos: LONGINT): INTEGER;
		VAR n: INTEGER;
	BEGIN Start(pos); n := -1;
		REPEAT Ch; INC(n) UNTIL (ch > " ") OR (ch = CR) OR R.eot;
		RETURN n
	END Lead;
	PROCEDURE OutStretch(from, to: LONGINT; VAR ind, nLines: INTEGER; VAR leadCh: CHAR);
		VAR lead, i: INTEGER; pos: LONGINT;
	BEGIN
		lead := Lead(from); nLines := 0;
		REPEAT
			ind := Lead(from) - lead; INC(nLines);
			Start(from); FOR i := 1 TO lead DO Ch; INC(from) END;
			IF ch = " " THEN leadCh := " " ELSE leadCh := TAB END;
			pos := from;
			WHILE (from < to) & (ch # CR) DO Ch; INC(from) END;
			Texts.Save(TMod, pos, from, B); Texts.Append(TOut, B)
		UNTIL from >= to;
	END OutStretch;
	PROCEDURE OutMethod(m: Method; ind: INTEGER; leadCh: CHAR);
		VAR i, j: INTEGER; k: CHAR;
	BEGIN
		IF m # NIL THEN OutMethod(m.next, ind, leadCh);
			FOR i := 1 TO ind DO Wr(leadCh) END;
			OutStretch(m.beg, m.end, i, j, k); Wr(CR)
		END;
	END OutMethod;
	PROCEDURE OutClass(c: Class);
		VAR ind, nLines, i: INTEGER; leadCh: CHAR;
	BEGIN
		OutStretch(c.beg, c.end, ind, nLines, leadCh); Wr(CR);
		IF nLines = 1 THEN INC(ind) END; 
		IF (c.kind = pointer) & (c.link # NIL) THEN
			IF c.link.name = "" THEN c := c.link ELSIF type # "" THEN OutClass(c.link); RETURN END
		END;
		IF c.kind = record THEN
			OutMethod(c.methods, ind, leadCh);
			Str("END;"); Wr(CR)
		END
	END OutClass;
	PROCEDURE OutAll(c: Class);
	BEGIN
		IF c # NIL THEN OutAll(c.next);
			IF c.name # "" THEN OutClass(c) END
		END
	END OutAll;
(* main *)
	PROCEDURE PrepName(s: ARRAY OF CHAR; VAR mod, type: ARRAY OF CHAR);
		VAR i, j: INTEGER;
	BEGIN i := 0;
		REPEAT mod[i] := s[i]; INC(i) UNTIL (s[i-1] = 0X) OR (s[i-1] = ".");
		IF s[i-1] = "." THEN mod[i] := "M"; mod[i+1] := "o"; mod[i+2] := "d"; mod[i+3] := 0X;
			j := 0; REPEAT type[j] := s[i]; INC(i); INC(j) UNTIL s[i-1] = 0X
		ELSE COPY(mod, type); mod[0] := 0X
		END
	END PrepName;
	PROCEDURE Show*;	(** ( "*" | "^" | name ) **)
		VAR S: Texts.Scanner; V: Viewers.Viewer; text: Texts.Text; Menu, Text: TextFrames.Frame; x, y: INTEGER;
			selbeg, selend, time: LONGINT; c: Class; m: Method; mod: Name;
	BEGIN Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
		IF (S.class = Texts.Char) & (S.c = "*") & (S.line = 0) THEN V := Oberon.MarkedViewer();
			IF (V # NIL) & (V.dsc # NIL) & (V.dsc.next # NIL) & (V.dsc.next IS TextFrames.Frame) THEN
				TMod := V.dsc.next(TextFrames.Frame).text; type := ""
			ELSE RETURN
			END
		ELSIF (S.class = Texts.Name) & (S.line = 0) THEN
			PrepName(S.s, mod, type); TMod := TextFrames.Text(mod)
		ELSE Oberon.GetSelection(text, selbeg, selend, time);
			IF time > 0 THEN Texts.OpenScanner(S, text, selbeg); Texts.Scan(S);
				IF (S.class # Texts.Name) OR (S.line > 0) THEN RETURN END
			ELSE RETURN
			END;
			PrepName(S.s, mod, type);
			IF mod = "" THEN TMod := text ELSE TMod := TextFrames.Text(mod) END
		END;
		Start(0); Ch; sym := none; lineBeg := 0; lastID := ""; lastIDline := 0; lastSym := none; classes := NIL;
		LOOP Sym;
			CASE sym OF
				procedure: Procedure
			| record: RecordType(c); IF c # NIL THEN c.next := classes; classes := c END
			| pointer: PointerType(c); IF c # NIL THEN c.next := classes; classes := c END
			| eot: EXIT
			ELSE
			END
		END;
		TOut := TextFrames.Text(""); NEW(B); Texts.OpenBuf(B);
		Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
		V := MenuViewers.New(TextFrames.NewMenu(type, StdMenu), TextFrames.NewText(TOut, 0),
			TextFrames.menuH, x, y);
		IF type = "" THEN OutAll(classes)
		ELSE FindClass(type, c); IF c # NIL THEN OutClass(c) END
		END;
		TMod := NIL; TOut := NIL; B := NIL; classes := NIL
	END Show;
BEGIN Texts.OpenWriter(W)
END Class.