Dev/Mod/CPS.odc

MODULE DevCPS; (* SP410 *)
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	references	= "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps"
	changes	= "
	- 20111211, Fyodor Tkachov, switched from National to i21sysCharacters
	- 20100407, Fyodor Tkachov, minor fine-tuning
	- 20100402, E.E.Temirgaleev, automatic indent checks
	- 20080215, Fyodor Tkachov, reviewed
	- 20050626, Fyodor Tkachov, russification edited
	- 20050430, Ivan Goryachev, russification
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)

	IMPORT SYSTEM, Math, DevCPM, DevCPT, i21sysCharacters;
	
	CONST
		MaxIdLen = 256;
	
	TYPE
(*
		Name* = ARRAY MaxIdLen OF SHORTCHAR;
		String* = POINTER TO ARRAY OF SHORTCHAR;
*)

	(* name, str, numtyp, intval, realval, realval are implicit results of Get *)

	VAR
		name*: DevCPT.Name;
		str*: DevCPT.String;
		numtyp*: SHORTINT; (* 1 = char, 2 = integer, 4 = real, 5 = int64, 6 = real32, 7 = real64 *)
		intval*: INTEGER;	(* integer value or string length (incl. 0X) *)
		realval*: REAL;
		checkIndent*: BOOLEAN;
		indentLevel: INTEGER;
		newLine: BOOLEAN;	(*   .     *)
		tabs: INTEGER;	(*        *)

	CONST
		(* numtyp values *)
		char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;

		(*symbol values*)
		null = 0; times = 1; slash = 2; div = 3; mod = 4;
		and = 5; plus = 6; minus = 7; or = 8; eql = 9;
		neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
		in = 15; is = 16; arrow = 17; dollar = 18; period = 19;
		comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
		rbrace = 25; of = 26; then = 27; do = 28; to = 29;
		by = 30; not = 33;
		lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
		number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
		bar = 50; end = 51; else = 52; elsif = 53; until = 54;
		if = 55; case = 56; while = 57; repeat = 58; for = 59;
		loop = 60; with = 61; exit = 62; return = 63; array = 64;
		record = 65; pointer = 66; begin = 67; const = 68; type = 69;
		var = 70; out = 71; procedure = 72; close = 73; import = 74;
		module = 75; eof = 76;

	VAR
		ch: SHORTCHAR;     (*current character*)

	PROCEDURE err(n: SHORTINT);
	BEGIN DevCPM.err(n)
	END err;
	
	PROCEDURE Str(VAR sym: BYTE);
		VAR i: SHORTINT; och: SHORTCHAR; s: DevCPT.Name; t: DevCPT.String;
	BEGIN i := 0; och := ch;
		LOOP DevCPM.Get(ch);
			IF ch = och THEN EXIT END ;
			IF (ch < " ") & (ch # 9X) THEN err(3); EXIT END ;
			IF i < LEN(s) - 1 THEN s[i] := ch
			ELSIF i = LEN(s) - 1 THEN s[i] := 0X; NEW(str, 2 * LEN(s)); str^ := s$; str[i] := ch
			ELSIF i < LEN(str^) - 1 THEN str[i] := ch
			ELSE t := str; t[i] := 0X; NEW(str, 2 * LEN(t^)); str^ := t^$; str[i] := ch
			END;
			INC(i)
		END ;
		IF i = 1 THEN sym := number; numtyp := 1; intval := ORD(s[0])
		ELSE
			sym := string; numtyp := 0; intval := i + 1;
			IF i < LEN(s) THEN s[i] := 0X; NEW(str, intval); str^ := s$
			ELSE str[i] := 0X
			END
		END;
		DevCPM.Get(ch)
	END Str;

	PROCEDURE Identifier(VAR sym: BYTE);
		VAR i: SHORTINT;
	BEGIN i := 0;
		REPEAT
			name[i] := ch; INC(i); DevCPM.Get(ch)
		UNTIL ~i21sysCharacters.IsIdentChar(ch) OR (i = MaxIdLen);
		IF i = MaxIdLen THEN err(240); DEC(i) END ;
		name[i] := 0X; sym := ident
	END Identifier;

	PROCEDURE Number;
		VAR i, j, m, n, d, e, a: INTEGER; f, g, x: REAL; expCh, tch: SHORTCHAR; neg: BOOLEAN; r: SHORTREAL;
			dig: ARRAY 30 OF SHORTCHAR; arr: ARRAY 2 OF INTEGER;

		PROCEDURE Ord(ch: SHORTCHAR; hex: BOOLEAN): SHORTINT;
		BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *)
			IF ch <= "9" THEN RETURN SHORT(ORD(ch) - ORD("0"))
			ELSIF hex THEN RETURN SHORT(ORD(ch) - ORD("A") + 10)
			ELSE err(2); RETURN 0
			END
		END Ord;
		
	BEGIN (* ("0" <= ch) & (ch <= "9") *)
		i := 0; m := 0; n := 0; d := 0;
		LOOP (* read mantissa *)
			IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN
				IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *)
					IF n < LEN(dig) THEN dig[n] := ch; INC(n) END;
					INC(m)
				END;
				DevCPM.Get(ch); INC(i)
			ELSIF ch = "." THEN DevCPM.Get(ch);
				IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT
				ELSIF d = 0 THEN (* i > 0 *) d := i
				ELSE err(2)
				END
			ELSE EXIT
			END
		END; (* 0 <= n <= m <= i, 0 <= d <= i *)
		IF d = 0 THEN (* integer *) realval := 0; numtyp := integer;
			IF n = m THEN intval := 0; i := 0;
				IF ch = "X" THEN (* character *) DevCPM.Get(ch); numtyp := char;
					IF n <= 4 THEN
						WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END
					ELSE err(203)
					END
				ELSIF (ch = "H") OR (ch = "S") THEN	(* hex 32bit *)
					tch := ch; DevCPM.Get(ch);
					IF (ch = "L") & (DevCPM.oberon IN DevCPM.options) THEN	(* old syntax: hex 64bit *)
						DevCPM.searchpos := DevCPM.curpos - 2; DevCPM.Get(ch);
						IF n <= 16 THEN
							IF (n = 16) & (dig[0] > "7") THEN realval := -1 END;
							WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END;
							WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END;
							numtyp := int64
						ELSE err(203)
						END
					ELSIF n <= 8 THEN
						IF (n = 8) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END;
						WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END;
						IF tch = "S" THEN	(* 32 bit hex float *)
							r := SYSTEM.VAL(SHORTREAL, intval);
							realval := r; intval := 0; numtyp := real32
						END
					ELSE err(203)
					END
				ELSIF ch = "L" THEN	(* hex 64bit *)
					DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch);
					IF n <= 16 THEN
						IF (n = 16) & (dig[0] > "7") THEN realval := -1 END;
						WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END;
						WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END;
						numtyp := int64
					ELSE err(203)
					END
				ELSIF ch = "R" THEN	(* hex float 64bit *)
					DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch);
					IF n <= 16 THEN
						a := 0; IF (n = 16) & (dig[0] > "7") THEN (* prevent overflow *) a := -1 END;
						WHILE i < n-8 DO a := a*10H + Ord(dig[i], TRUE); INC(i) END;
						IF DevCPM.LEHost THEN arr[1] := a ELSE arr[0] := a END;
						a := 0; IF (n >= 8) & (dig[i] > "7") THEN (* prevent overflow *) a := -1 END;
						WHILE i < n DO a := a*10H + Ord(dig[i], TRUE); INC(i) END;
						IF DevCPM.LEHost THEN arr[0] := a ELSE arr[1] := a END;
						realval := SYSTEM.VAL(REAL, arr);
						intval := 0; numtyp := real64
					ELSE err(203)
					END
				ELSE	(* decimal *) 
					WHILE i < n DO d := Ord(dig[i], FALSE); INC(i);
						a := (MAX(INTEGER) - d) DIV 10;
						IF intval > a THEN
							a := (intval - a + 65535) DIV 65536 * 65536;
							realval := realval + a; intval := intval - a
						END;
						realval := realval * 10; intval := intval * 10 + d
					END;
					IF realval = 0 THEN numtyp := integer
					ELSIF intval < 9223372036854775808.0E0 - realval THEN numtyp := int64	(* 2^63 *)
					ELSE intval := 0; err(203)
					END
				END
			ELSE err(203)
			END
		ELSE (* fraction *)
			f := 0; g := 0; e := 0; j := 0; expCh := "E";
			WHILE (j < 15) & (j < n) DO g := g * 10 + Ord(dig[j], FALSE); INC(j) END;	(* !!! *)
			WHILE n > j DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END;
			IF (ch = "E") OR (ch = "D") & (DevCPM.oberon IN DevCPM.options) THEN
				expCh := ch; DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); neg := FALSE;
				IF ch = "-" THEN neg := TRUE; DevCPM.Get(ch)
				ELSIF ch = "+" THEN DevCPM.Get(ch)
				END;
				IF ("0" <= ch) & (ch <= "9") THEN
					REPEAT n := Ord(ch, FALSE); DevCPM.Get(ch);
						IF e <= (MAX(SHORTINT) - n) DIV 10 THEN e := SHORT(e*10 + n)
						ELSE err(203)
						END
					UNTIL (ch < "0") OR ("9" < ch);
					IF neg THEN e := -e END
				ELSE err(2)
				END
			END;
			DEC(e, i-d-m); (* decimal point shift *)
			IF e < -308 - 16 THEN
				realval := 0.0
			ELSIF e < -308 + 14 THEN
				realval := (f + g) / Math.IntPower(10, j-e-30) / 1.0E15 / 1.0E15
			ELSIF e < j THEN
				realval := (f + g) / Math.IntPower(10, j-e)	(* Ten(j-e) *)
			ELSIF e <= 308 THEN
				realval := (f + g) * Math.IntPower(10, e-j)	(* Ten(e-j) *)
			ELSIF e = 308 + 1 THEN
				realval := (f + g) * (Math.IntPower(10, e-j) / 16);
				IF realval <= DevCPM.MaxReal64 / 16 THEN realval := realval * 16
				ELSE err(203)
				END
			ELSE err(203)
			END;
			numtyp := real
		END
	END Number;

	PROCEDURE IndentErr (n: INTEGER);
		VAR	p: INTEGER;
	BEGIN
		p := DevCPM.errpos;
		DevCPM.errpos := DevCPM.curpos - 1;
		err(SHORT(1000 + n));
		DevCPM.errpos := p
	END IndentErr;
	
	PROCEDURE Indent* (ops: INTEGER);
		VAR	i: INTEGER;
	BEGIN
		IF checkIndent THEN
			i := 0;
			WHILE i < 3 DO
				CASE ops MOD 8 OF
				| 0:	(*  *)
				| 1:	(*  *)
					IF indentLevel # tabs THEN
						IndentErr(1)	(*   *)
					END
				| 2:	(*  *)
					INC(indentLevel)
				| 3:	(*  *)
					DEC(indentLevel)
				| 4:	(*      *)
					IF newLine & (indentLevel # tabs) OR ~newLine & (indentLevel - 1 # tabs) THEN
						IndentErr(1)	(*   *)
					END
				| 5:	(*  .  *)
					newLine := FALSE
				END;
				ops := ops DIV 8; INC(i)
			END;
			ASSERT(ops = 0, 100)
		END
	END Indent;
	
	PROCEDURE Get*(VAR sym: BYTE);
		VAR s: BYTE; old: INTEGER;  t: INTEGER;

		PROCEDURE Comment;	(* do not read after end of file *)
		BEGIN DevCPM.Get(ch);
			LOOP
				LOOP
					WHILE ch = "(" DO DevCPM.Get(ch);
						IF ch = "*" THEN Comment END
					END ;
					IF ch = "*" THEN DevCPM.Get(ch); EXIT END ;
					IF ch = DevCPM.Eot THEN EXIT END ;
					DevCPM.Get(ch)
				END ;
				IF ch = ")" THEN DevCPM.Get(ch); EXIT END ;
				IF ch = DevCPM.Eot THEN err(5); EXIT END
			END
		END Comment;

	BEGIN
		DevCPM.errpos := DevCPM.curpos-1;
		WHILE (ch <= " ") OR (ch = 0A0X) DO (*ignore control characters*)
			IF checkIndent & ((ch = 0DX) OR (ch = 0EX)) THEN
				newLine := TRUE;
				tabs := 0; DevCPM.Get(ch);
				WHILE ch = 9X DO
					INC(tabs); DevCPM.Get(ch)
				END;
				t := 0;
				WHILE (ch # DevCPM.Eot) & ~((ch = 0DX) OR (ch = 0EX)) & ((ch <= " ") OR (ch = 0A0X)) DO
					INC(t); DevCPM.Get(ch)
				END;
				IF ch = DevCPM.Eot THEN
					sym := eof; RETURN
				ELSIF (ch = 0DX) OR (ch = 0EX) THEN	(*   *)
					newLine := TRUE
				ELSIF (*    & *) t # 0 THEN
					IndentErr(0)	(* т       *)
				END
			ELSE
				IF ch = DevCPM.Eot THEN sym := eof; RETURN
				ELSE DevCPM.Get(ch)
				END
			END
		END ;
		DevCPM.startpos := DevCPM.curpos - 1;
		CASE ch OF   (* ch > " " *)
			| 22X, 27X  : Str(s)
			| "#"  : s := neq; DevCPM.Get(ch)
			| "&"  : s :=  and; DevCPM.Get(ch)
			| "("  : DevCPM.Get(ch);
					 IF ch = "*" THEN Comment; old := DevCPM.errpos; Get(s); DevCPM.errpos := old; 
					 ELSE s := lparen
					 END
			| ")"  : s := rparen; DevCPM.Get(ch)
			| "*"  : s :=  times; DevCPM.Get(ch)
			| "+"  : s :=  plus; DevCPM.Get(ch)
			| ","  : s := comma; DevCPM.Get(ch)
			| "-"  : s :=  minus; DevCPM.Get(ch)
			| "."  : DevCPM.Get(ch);
							 IF ch = "." THEN DevCPM.Get(ch); s := upto ELSE s := period END
			| "/"  : s := slash;  DevCPM.Get(ch)
			| "0".."9": Number; s := number
			| ":"  : DevCPM.Get(ch);
							 IF ch = "=" THEN DevCPM.Get(ch); s := becomes ELSE s := colon END
			| ";"  : s := semicolon; DevCPM.Get(ch)
			| "<"  : DevCPM.Get(ch);
							 IF ch = "=" THEN DevCPM.Get(ch); s := leq ELSE s := lss END
			| "="  : s :=  eql; DevCPM.Get(ch)
			| ">"  : DevCPM.Get(ch);
							 IF ch = "=" THEN DevCPM.Get(ch); s := geq ELSE s := gtr END
			| "A": Identifier(s); IF name = "ARRAY" THEN s := array END
			| "B": Identifier(s);
						IF name = "BEGIN" THEN s := begin
						ELSIF name = "BY" THEN s := by
						END
			| "C": Identifier(s);
						IF name = "CASE" THEN s := case
						ELSIF name = "CONST" THEN s := const
						ELSIF name = "CLOSE" THEN s := close
						END
			| "D": Identifier(s);
						IF name = "DO" THEN s := do
						ELSIF name = "DIV" THEN s := div
						END
			| "E": Identifier(s);
						IF name = "END" THEN s := end
						ELSIF name = "ELSE" THEN s := else
						ELSIF name = "ELSIF" THEN s := elsif
						ELSIF name = "EXIT" THEN s := exit
						END
			| "F": Identifier(s); IF name = "FOR" THEN s := for END
			| "I": Identifier(s);
						IF name = "IF" THEN s := if
						ELSIF name = "IN" THEN s := in
						ELSIF name = "IS" THEN s := is
						ELSIF name = "IMPORT" THEN s := import
						END
			| "L": Identifier(s); IF name = "LOOP" THEN s := loop END
			| "M": Identifier(s);
						IF name = "MOD" THEN s := mod
						ELSIF name = "MODULE" THEN s := module
						END
			| "N": Identifier(s); IF name = "NIL" THEN s := nil END
			| "O": Identifier(s);
						IF name = "OR" THEN s := or
						ELSIF name = "OF" THEN s := of
						ELSIF name = "OUT" THEN s := out
						END
			| "P": Identifier(s);
						IF name = "PROCEDURE" THEN s := procedure
						ELSIF name = "POINTER" THEN s := pointer
						END
			| "R": Identifier(s);
						IF name = "RECORD" THEN s := record
						ELSIF name = "REPEAT" THEN s := repeat
						ELSIF name = "RETURN" THEN s := return
						END
			| "T": Identifier(s);
						IF name = "THEN" THEN s := then
						ELSIF name = "TO" THEN s := to
						ELSIF name = "TYPE" THEN s := type
						END
			| "U": Identifier(s); IF name = "UNTIL" THEN s := until END
			| "V": Identifier(s); IF name = "VAR" THEN s := var END
			| "W": Identifier(s);
						IF name = "WHILE" THEN s := while
						ELSIF name = "WITH" THEN s := with
						END
(*
			| "G".."H", "J", "K", "Q", "S", "X".."Z", "a".."z", "_", "А".."я", "ё", "Ё": Identifier(s) (*-> ELSE IF*)
*)
			| "["  : s := lbrak; DevCPM.Get(ch)
			| "]"  : s := rbrak; DevCPM.Get(ch)
			| "^"  : s := arrow; DevCPM.Get(ch)
			| "$"  : s := dollar; DevCPM.Get(ch)
			| "{"  : s := lbrace; DevCPM.Get(ch);
			| "|"  : s := bar; DevCPM.Get(ch)
			| "}"  : s := rbrace; DevCPM.Get(ch)
			| "~"  : s := not; DevCPM.Get(ch)
			| 7FX  : s := upto; DevCPM.Get(ch)
		ELSE 
			IF i21sysCharacters.IsFirstIdentChar(ch) THEN
				Identifier(s)
			ELSE
				s :=  null; DevCPM.Get(ch)
			END;
		END ;
		sym := s
	END Get;

	PROCEDURE Init*;
	BEGIN (* ch := " " *)ch := 0DX;
		indentLevel := 0
	END Init;
	
(* (* как трудно сделать просто :) *)
	PROCEDURE SetIndentCheck* (check: INTEGER);
	BEGIN
		ASSERT(check IN {0,1}, 20);
		checkIndent := check = 1
	END SetIndentCheck;
*)
	PROCEDURE IndentChecksOn*;
	BEGIN
		checkIndent := TRUE
	END IndentChecksOn;

	PROCEDURE IndentChecksOff*;
	BEGIN
		checkIndent := FALSE
	END IndentChecksOff;

END DevCPS.