O7/voc-O7/O7ARMv7MP.Mod

MODULE O7ARMv7MP; (*N. Wirth 1.7.97 / 8.2.2020	Oberon compiler for RISC in Oberon-07*)

	(* Translated for BlackBox by Alexander Shiryaev,
		2016.05.07, 2017.09.26, 2019.10.21 *)

	IMPORT ORS := O7S, ORB := O7B, ORG := O7ARMv7MG, Texts (*:= O7Texts*), Oberon (*:= O7Oberon*)(*, Kernel, Dialog, StdLog, DevCommanders, TextMappers, TextModels, TextViews, DevMarkers, TextControllers, Views, Files, StdDialog*);

	(*Author: Niklaus Wirth, 2014.
		Parser of Oberon-RISC compiler. Uses Scanner ORS to obtain symbols (tokens),
		ORB for definition of data structures and for handling import and export, and
		ORG to produce binary code. ORP performs type checking and data allocation.
		Parser is target-independent, except for part of the handling of allocations.*)

	TYPE
		LONGINT = INTEGER;
		(* REAL = SHORTREAL; *)
		LONGREAL = REAL;
		(* BYTE = SHORTCHAR; *)
		BYTE = CHAR;

	CONST
		(* compiler options: *)
			newsf = 0;
			defopt = {newsf};

(*
		(* DevCompiler: additional scanner types *)
			import = 100; module = 101; semicolon = 102; becomes = 103; comEnd = 104;
*)

	TYPE PtrBase = POINTER TO PtrBaseDesc;
		PtrBaseDesc = RECORD	(*list of names of pointer base types*)
			name: ORS.Ident; type: ORB.Type; next: PtrBase
		END;

(*
	VAR
		s: TextMappers.Scanner;
*)

	VAR sym: INTEGER;	 (*last symbol read*)
		dc: LONGINT;		(*data counter*)
		level, exno, version: INTEGER;
		newSF: BOOLEAN;	(*option flag*)
		expression: PROCEDURE (VAR x: ORG.Item);	(*to avoid forward reference*)
		Type: PROCEDURE (VAR type: ORB.Type);
		FormalType: PROCEDURE (VAR typ: ORB.Type; dim: INTEGER);
		modid: ORS.Ident;
		pbsList: PtrBase;	 (*list of names of pointer base types*)
		dummy: ORB.Object;
		W: Texts.Writer;

	PROCEDURE Check (s: INTEGER; (*IN*) msg: ARRAY OF CHAR);
	BEGIN
		IF sym = s THEN ORS.Get(sym) ELSE ORS.Mark(msg) END
	END Check;

	PROCEDURE qualident (VAR obj: ORB.Object);
	BEGIN obj := ORB.thisObj(); ORS.Get(sym);
		IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END;
		IF (sym = ORS.period) & (obj.class = ORB.Mod) THEN
			ORS.Get(sym);
			IF sym = ORS.ident THEN obj := ORB.thisimport(obj); ORS.Get(sym);
				IF obj = NIL THEN ORS.Mark("undef"); obj := dummy END
			ELSE ORS.Mark("identifier expected"); obj := dummy
			END
		END
	END qualident;

	PROCEDURE CheckBool (VAR x: ORG.Item);
	BEGIN
		IF x.type.form # ORB.Bool THEN ORS.Mark("not Boolean"); x.type := ORB.boolType END
	END CheckBool;

	PROCEDURE CheckInt (VAR x: ORG.Item);
	BEGIN
		IF x.type.form # ORB.Int THEN ORS.Mark("not Integer"); x.type := ORB.intType END
	END CheckInt;

	PROCEDURE CheckReal (VAR x: ORG.Item);
	BEGIN
		IF x.type.form # ORB.Real THEN ORS.Mark("not Real"); x.type := ORB.realType END
	END CheckReal;

	PROCEDURE CheckSet (VAR x: ORG.Item);
	BEGIN
		IF x.type.form # ORB.Set THEN ORS.Mark("not Set"); x.type := ORB.setType END
	END CheckSet;

	PROCEDURE CheckSetVal (VAR x: ORG.Item);
	BEGIN
		IF x.type.form # ORB.Int THEN ORS.Mark("not Int"); x.type := ORB.setType
		ELSIF x.mode = ORB.Const THEN
			IF (x.a < 0) OR (x.a >= 32) THEN ORS.Mark("invalid set") END
		END
	END CheckSetVal;

	PROCEDURE CheckConst (VAR x: ORG.Item);
	BEGIN
		IF x.mode # ORB.Const THEN ORS.Mark("not a constant"); x.mode := ORB.Const END
	END CheckConst;

	PROCEDURE CheckReadOnly (VAR x: ORG.Item);
	BEGIN
		IF x.rdo THEN ORS.Mark("read-only") END
	END CheckReadOnly;

	PROCEDURE CheckExport (VAR expo: BOOLEAN);
	BEGIN
		IF sym = ORS.times THEN
			expo := TRUE; ORS.Get(sym);
			IF level # 0 THEN ORS.Mark("remove asterisk") END
		ELSE expo := FALSE
		END
	END CheckExport;

	PROCEDURE IsExtension (t0, t1: ORB.Type): BOOLEAN;
	BEGIN (*t1 is an extension of t0*)
		RETURN (t0 = t1) OR (t1 # NIL) & IsExtension(t0, t1.base)
	END IsExtension;

	(* expressions *)

	PROCEDURE TypeTest (VAR x: ORG.Item; T: ORB.Type; guard: BOOLEAN);
		VAR xt: ORB.Type;
	BEGIN xt := x.type;
		IF (T.form = xt.form ) & ((T.form = ORB.Pointer) OR (T.form = ORB.Record) & (x.mode = ORB.Par)) THEN
			WHILE (xt # T) & (xt # NIL) DO xt := xt.base END;
			IF xt # T THEN xt := x.type;
				IF xt.form = ORB.Pointer THEN
					IF IsExtension(xt.base, T.base) THEN ORG.TypeTest(x, T.base, FALSE, guard); x.type := T
					ELSE ORS.Mark("not an extension")
					END
				ELSIF (xt.form = ORB.Record) & (x.mode = ORB.Par) THEN
					IF IsExtension(xt, T) THEN	ORG.TypeTest(x, T, TRUE, guard); x.type := T
					ELSE ORS.Mark("not an extension")
					END
				ELSE ORS.Mark("incompatible types")
				END
			ELSIF ~guard THEN ORG.TypeTest(x, NIL, FALSE, FALSE)
			END
		ELSE ORS.Mark("type mismatch")
		END;
		IF ~guard THEN x.type := ORB.boolType END
	END TypeTest;

	PROCEDURE selector (VAR x: ORG.Item);
		VAR y: ORG.Item; obj: ORB.Object;
	BEGIN
		WHILE (sym = ORS.lbrak) OR (sym = ORS.period) OR (sym = ORS.arrow)
				OR (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) DO
			IF sym = ORS.lbrak THEN
				REPEAT ORS.Get(sym); expression(y);
					IF x.type.form = ORB.Array THEN
						CheckInt(y); ORG.Index(x, y); x.type := x.type.base
					ELSE ORS.Mark("not an array")
					END
				UNTIL sym # ORS.comma;
				Check(ORS.rbrak, "no ]")
			ELSIF sym = ORS.period THEN ORS.Get(sym);
				IF sym = ORS.ident THEN
					IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base END;
					IF x.type.form = ORB.Record THEN
						obj := ORB.thisfield(x.type); ORS.Get(sym);
						IF obj # NIL THEN ORG.Field(x, obj); x.type := obj.type
						ELSE ORS.Mark("undef")
						END
					ELSE ORS.Mark("not a record")
					END
				ELSE ORS.Mark("ident?")
				END
			ELSIF sym = ORS.arrow THEN
				ORS.Get(sym);
				IF x.type.form = ORB.Pointer THEN ORG.DeRef(x); x.type := x.type.base
				ELSE ORS.Mark("not a pointer")
				END
			ELSIF (sym = ORS.lparen) & (x.type.form IN {ORB.Record, ORB.Pointer}) THEN (*type guard*)
				ORS.Get(sym);
				IF sym = ORS.ident THEN
					qualident(obj);
					IF obj.class = ORB.Typ THEN TypeTest(x, obj.type, TRUE)
					ELSE ORS.Mark("guard type expected")
					END
				ELSE ORS.Mark("not an identifier")
				END;
				Check(ORS.rparen, " ) missing")
			END
		END
	END selector;

	PROCEDURE EqualSignatures (t0, t1: ORB.Type): BOOLEAN;
		VAR p0, p1: ORB.Object; com: BOOLEAN;
	BEGIN com := TRUE;
		IF (t0.base = t1.base) & (t0.nofpar = t1.nofpar) THEN
			p0 := t0.dsc; p1 := t1.dsc;
			WHILE p0 # NIL DO
				IF (p0.class = p1.class) &	(p0.rdo = p1.rdo) &
					((p0.type = p1.type) OR
					(p0.type.form = ORB.Array) & (p1.type.form = ORB.Array) & (p0.type.len = p1.type.len) & (p0.type.base = p1.type.base) OR
					(p0.type.form = ORB.Proc) & (p1.type.form = ORB.Proc) & EqualSignatures(p0.type, p1.type))
				THEN p0 := p0.next; p1 := p1.next
				ELSE p0 := NIL; com := FALSE
				END
			END
		ELSE com := FALSE
		END;
		RETURN com
	END EqualSignatures;

	PROCEDURE CompTypes (t0, t1: ORB.Type; varpar: BOOLEAN): BOOLEAN;
	BEGIN (*check for assignment compatibility*)
		RETURN (t0 = t1) (*openarray assignment disallowed in ORG*)
			OR (t0.form = ORB.Array) & (t1.form = ORB.Array) & (t0.base =  t1.base) & (t0.len = t1.len)
			OR (t0.form = ORB.Record) & (t1.form = ORB.Record)	& IsExtension(t0, t1)
			OR ~varpar &
				((t0.form = ORB.Pointer) & (t1.form = ORB.Pointer)	& IsExtension(t0.base, t1.base)
				OR (t0.form = ORB.Proc) & (t1.form = ORB.Proc) & EqualSignatures(t0, t1)
				OR (t0.form IN {ORB.Pointer, ORB.Proc}) & (t1.form = ORB.NilTyp))
	END CompTypes;

	PROCEDURE Parameter (par: ORB.Object);
		VAR x: ORG.Item; varpar: BOOLEAN;
	BEGIN expression(x);
		IF par # NIL THEN
			varpar := par.class = ORB.Par;
			IF CompTypes(par.type, x.type, varpar) THEN
				IF ~varpar THEN ORG.ValueParam(x)
				ELSE (*par.class = Par*)
					IF ~par.rdo THEN CheckReadOnly(x) END;
					ORG.VarParam(x, par.type)
				END
			ELSIF (x.type.form = ORB.Array) & (par.type.form = ORB.Array) &
					(x.type.base = par.type.base) & (par.type.len < 0) THEN
				IF ~par.rdo THEN CheckReadOnly(x) END;
				ORG.OpenArrayParam(x)
			ELSIF (x.type.form = ORB.String) & varpar & par.rdo & (par.type.form = ORB.Array) &
					(par.type.base.form = ORB.Char) & (par.type.len < 0) THEN ORG.StringParam(x)
			ELSIF ~varpar & (par.type.form = ORB.Int) & (x.type.form = ORB.Int) THEN ORG.ValueParam(x) (*BYTE*)
			ELSIF (x.type.form = ORB.String) & (x.b = 2) & (par.class = ORB.Var) & (par.type.form = ORB.Char) THEN
				ORG.StrToChar(x); ORG.ValueParam(x)
			ELSIF (par.type.form = ORB.Array) & (par.type.base = ORB.byteType) &
					(par.type.len >= 0) & (par.type.size = x.type.size) THEN
				ORG.VarParam(x, par.type)
			ELSE ORS.Mark("incompatible parameters")
			END
		END
	END Parameter;

	PROCEDURE ParamList (VAR x: ORG.Item);
		VAR n: INTEGER; par: ORB.Object;
	BEGIN par := x.type.dsc; n := 0;
		IF sym # ORS.rparen THEN
			Parameter(par); n := 1;
			WHILE sym <= ORS.comma DO
				Check(ORS.comma, "comma?");
				IF par # NIL THEN par := par.next END;
				INC(n); Parameter(par)
			END;
			Check(ORS.rparen, ") missing")
		ELSE ORS.Get(sym);
		END;
		IF n < x.type.nofpar THEN ORS.Mark("too few params")
		ELSIF n > x.type.nofpar THEN ORS.Mark("too many params")
		END
	END ParamList;

	PROCEDURE StandFunc (VAR x: ORG.Item; fct: LONGINT; restyp: ORB.Type);
		VAR y: ORG.Item; n, npar: LONGINT;
	BEGIN Check(ORS.lparen, "no (");
		npar := fct MOD 10; fct := fct DIV 10; expression(x); n := 1;
		WHILE sym = ORS.comma DO ORS.Get(sym); expression(y); INC(n) END;
		Check(ORS.rparen, "no )");
		IF n = npar THEN
			IF fct = 0 THEN (*ABS*)
				IF x.type.form IN {ORB.Int, ORB.Real} THEN ORG.Abs(x); restyp := x.type ELSE ORS.Mark("bad type") END
			ELSIF fct = 1 THEN (*ODD*) CheckInt(x); ORG.Odd(x)
			ELSIF fct = 2 THEN (*FLOOR*) CheckReal(x); ORG.Floor(x)
			ELSIF fct = 3 THEN (*FLT*) CheckInt(x); ORG.Float(x)
			ELSIF fct = 4 THEN (*ORD*)
				IF x.type.form <= ORB.Proc THEN ORG.Ord(x)
				ELSIF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x)
				ELSE ORS.Mark("bad type")
				END
			ELSIF fct = 5 THEN (*CHR*) CheckInt(x); ORG.Ord(x)
			ELSIF fct = 6 THEN (*LEN*)
					IF x.type.form = ORB.Array THEN ORG.Len(x) ELSE ORS.Mark("not an array") END
			ELSIF fct IN {7, 8, 9} THEN (*LSL, ASR, ROR*) CheckInt(y);
				IF x.type.form IN {ORB.Int, ORB.Set} THEN ORG.Shift(fct-7, x, y); restyp := x.type ELSE ORS.Mark("bad type") END
			ELSIF fct = 11 THEN (*ADC*) ORG.ADC(x, y)
			ELSIF fct = 12 THEN (*SBC*) ORG.SBC(x, y)
			ELSIF fct = 13 THEN (*UML*) ORG.UML(x, y)
			ELSIF fct = 14 THEN (*BIT*) CheckInt(x); CheckInt(y); ORG.Bit(x, y)
			ELSIF fct = 15 THEN (*REG*) CheckConst(x); CheckInt(x); ORG.Register(x)
			ELSIF fct = 16 THEN (*VAL*)
				IF (x.mode= ORB.Typ) & (x.type.size <= y.type.size) THEN restyp := x.type; x := y
				ELSE ORS.Mark("casting not allowed")
				END
			ELSIF fct = 17 THEN (*ADR*) ORG.Adr(x)
			ELSIF fct = 18 THEN (*SIZE*)
				IF x.mode = ORB.Typ THEN ORG.MakeConstItem(x, ORB.intType, x.type.size)
				ELSE ORS.Mark("must be a type")
				END
			ELSIF fct = 19 THEN (*COND*) CheckConst(x); CheckInt(x); ORG.Condition(x)
			ELSIF fct = 20 THEN (*H*) CheckConst(x); CheckInt(x); ORG.H(x)
			END;
			x.type := restyp
		ELSE ORS.Mark("wrong nof params")
		END
	END StandFunc;

	PROCEDURE element (VAR x: ORG.Item);
		VAR y: ORG.Item;
	BEGIN expression(x); CheckSetVal(x);
		IF sym = ORS.upto THEN ORS.Get(sym); expression(y); CheckSetVal(y); ORG.Set(x, y)
		ELSE ORG.Singleton(x)
		END;
		x.type := ORB.setType
	END element;

	PROCEDURE set (VAR x: ORG.Item);
		VAR y: ORG.Item;
	BEGIN
		IF sym >= ORS.if THEN
			IF sym # ORS.rbrace THEN ORS.Mark(" } missing") END;
			ORG.MakeConstItem(x, ORB.setType, 0) (*empty set*)
		ELSE element(x);
			WHILE (sym < ORS.rparen) OR (sym > ORS.rbrace) DO
				IF sym = ORS.comma THEN ORS.Get(sym)
				ELSIF sym # ORS.rbrace THEN ORS.Mark("missing comma")
				END;
				element(y); ORG.SetOp(ORS.plus, x, y)
			END
		END
	END set;

	PROCEDURE factor(VAR x: ORG.Item);
		VAR obj: ORB.Object; rx: LONGINT;
	BEGIN (*sync*)
		IF (sym < ORS.char) OR (sym > ORS.ident) THEN ORS.Mark("expression expected");
			REPEAT ORS.Get(sym) UNTIL (sym >= ORS.char) & (sym <= ORS.for) OR (sym >= ORS.then)
		END;
		IF sym = ORS.ident THEN
			qualident(obj);
			IF obj.class = ORB.SFunc THEN StandFunc(x, obj.val, obj.type)
			ELSE ORG.MakeItem(x, obj, level); selector(x);
				IF sym = ORS.lparen THEN
					ORS.Get(sym);
					IF (x.type.form = ORB.Proc) & (x.type.base.form # ORB.NoTyp) THEN
						ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx); x.type := x.type.base
					ELSE ORS.Mark("not a function"); ParamList(x)
					END
				END
			END
		ELSIF sym = ORS.int THEN ORG.MakeConstItem(x, ORB.intType, ORS.ival); ORS.Get(sym)
		ELSIF sym = ORS.real THEN ORG.MakeRealItem(x, ORS.rval); ORS.Get(sym)
		ELSIF sym = ORS.char THEN ORG.MakeConstItem(x, ORB.charType, ORS.ival); ORS.Get(sym)
		ELSIF sym = ORS.nil THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.nilType, 0)
		ELSIF sym = ORS.string THEN ORG.MakeStringItem(x, ORS.slen); ORS.Get(sym)
		ELSIF sym = ORS.lparen THEN ORS.Get(sym); expression(x); Check(ORS.rparen, "no )")
		ELSIF sym = ORS.lbrace THEN ORS.Get(sym); set(x); Check(ORS.rbrace, "no }")
		ELSIF sym = ORS.not THEN ORS.Get(sym); factor(x); CheckBool(x); ORG.Not(x)
		ELSIF sym = ORS.false THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 0)
		ELSIF sym = ORS.true THEN ORS.Get(sym); ORG.MakeConstItem(x, ORB.boolType, 1)
		ELSE ORS.Mark("not a factor"); ORG.MakeConstItem(x, ORB.intType, 0)
		END
	END factor;

	PROCEDURE term (VAR x: ORG.Item);
		VAR y: ORG.Item; op, f: INTEGER;
	BEGIN factor(x); f := x.type.form;
		WHILE (sym >= ORS.times) & (sym <= ORS.and) DO
			op := sym; ORS.Get(sym);
			IF op = ORS.times THEN
				IF f = ORB.Int THEN factor(y); CheckInt(y); ORG.MulOp(x, y)
				ELSIF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
				ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
				ELSE ORS.Mark("bad type")
				END
			ELSIF (op = ORS.div) OR (op = ORS.mod) THEN
				CheckInt(x); factor(y); CheckInt(y); ORG.DivOp(op, x, y)
			ELSIF op = ORS.rdiv THEN
				IF f = ORB.Real THEN factor(y); CheckReal(y); ORG.RealOp(op, x, y)
				ELSIF f = ORB.Set THEN factor(y); CheckSet(y); ORG.SetOp(op, x, y)
				ELSE ORS.Mark("bad type")
				END
			ELSE (*op = and*) CheckBool(x); ORG.And1(x); factor(y); CheckBool(y); ORG.And2(x, y)
			END
		END
	END term;

	PROCEDURE SimpleExpression (VAR x: ORG.Item);
		VAR y: ORG.Item; op: INTEGER;
	BEGIN
		IF sym = ORS.minus THEN ORS.Get(sym); term(x);
			IF x.type.form IN {ORB.Int, ORB.Real, ORB.Set} THEN ORG.Neg(x) ELSE CheckInt(x) END
		ELSIF sym = ORS.plus THEN ORS.Get(sym); term(x);
		ELSE term(x)
		END;
		WHILE (sym >= ORS.plus) & (sym <= ORS.or) DO
			op := sym; ORS.Get(sym);
			IF op = ORS.or THEN ORG.Or1(x); CheckBool(x); term(y); CheckBool(y); ORG.Or2(x, y)
			ELSIF x.type.form = ORB.Int THEN term(y); CheckInt(y); ORG.AddOp(op, x, y)
			ELSIF x.type.form = ORB.Real THEN term(y); CheckReal(y); ORG.RealOp(op, x, y)
			ELSE CheckSet(x); term(y); CheckSet(y); ORG.SetOp(op, x, y)
			END
		END
	END SimpleExpression;

	PROCEDURE expression0 (VAR x: ORG.Item);
		VAR y: ORG.Item; obj: ORB.Object; rel, xf, yf: INTEGER;
	BEGIN SimpleExpression(x);
		IF (sym >= ORS.eql) & (sym <= ORS.geq) THEN
			rel := sym; ORS.Get(sym); SimpleExpression(y); xf := x.type.form; yf := y.type.form;
			IF x.type = y.type THEN
				IF (xf IN {ORB.Char, ORB.Int}) THEN ORG.IntRelation(rel, x, y)
				ELSIF xf = ORB.Real THEN ORG.RealRelation(rel, x, y)
				ELSIF (xf IN {ORB.Set, ORB.Pointer, ORB.Proc, ORB.NilTyp, ORB.Bool}) THEN
					IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END
				ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) OR (xf = ORB.String) THEN ORG.StringRelation(rel, x, y)
				ELSE ORS.Mark("illegal comparison")
				END
			ELSIF (xf IN {ORB.Pointer, ORB.Proc}) & (yf = ORB.NilTyp)
					OR (yf IN {ORB.Pointer, ORB.Proc}) & (xf = ORB.NilTyp) THEN
				IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END
			ELSIF (xf = ORB.Pointer) & (yf = ORB.Pointer) &
					(IsExtension(x.type.base, y.type.base) OR IsExtension(y.type.base, x.type.base)) OR (xf = ORB.Proc) & (yf = ORB.Proc) & EqualSignatures(x.type, y.type) THEN
				IF rel <= ORS.neq THEN ORG.IntRelation(rel, x, y) ELSE ORS.Mark("only = or #") END
			ELSIF (xf = ORB.Array) & (x.type.base.form = ORB.Char) &
						((yf = ORB.String) OR (yf = ORB.Array) & (y.type.base.form = ORB.Char))
					OR (yf = ORB.Array) & (y.type.base.form = ORB.Char) & (xf = ORB.String) THEN
				ORG.StringRelation(rel, x, y)
			ELSIF (xf = ORB.Char) & (yf = ORB.String) & (y.b = 2) THEN
				ORG.StrToChar(y); ORG.IntRelation(rel, x, y)
			ELSIF (yf = ORB.Char) & (xf = ORB.String) & (x.b = 2) THEN
				ORG.StrToChar(x); ORG.IntRelation(rel, x, y)
			ELSIF (xf = ORB.Int) & (yf = ORB.Int) THEN ORG.IntRelation(rel, x, y)	(*BYTE*)
			ELSE ORS.Mark("illegal comparison")
			END;
			x.type := ORB.boolType
		ELSIF sym = ORS.in THEN
			ORS.Get(sym); CheckInt(x); SimpleExpression(y); CheckSet(y); ORG.In(x, y);
			x.type := ORB.boolType
		ELSIF sym = ORS.is THEN
			ORS.Get(sym); qualident(obj); TypeTest(x, obj.type, FALSE);
			x.type := ORB.boolType
		END
	END expression0;

	(* statements *)

	PROCEDURE StandProc (pno: LONGINT);
		VAR nap, npar: LONGINT; (*nof actual/formal parameters*)
			x, y, z: ORG.Item;
	BEGIN Check(ORS.lparen, "no (");
		npar := pno MOD 10; pno := pno DIV 10; expression(x); nap := 1;
		IF sym = ORS.comma THEN
			ORS.Get(sym); expression(y); nap := 2; z.type := ORB.noType;
			WHILE sym = ORS.comma DO ORS.Get(sym); expression(z); INC(nap) END
		ELSE y.type := ORB.noType
		END;
		Check(ORS.rparen, "no )");
		IF (npar = nap) OR (pno IN {0, 1}) THEN
			IF pno IN {0, 1} THEN (*INC, DEC*)
				CheckInt(x); CheckReadOnly(x);
				IF y.type # ORB.noType THEN CheckInt(y) END;
				ORG.Increment(pno, x, y)
			ELSIF pno IN {2, 3} THEN (*INCL, EXCL*)
				CheckSet(x); CheckReadOnly(x); CheckInt(y); ORG.Include(pno-2, x, y)
			ELSIF pno = 4 THEN CheckBool(x); ORG.Assert(x)
			ELSIF pno = 5 THEN(*NEW*) CheckReadOnly(x);
				 IF (x.type.form = ORB.Pointer) & (x.type.base.form = ORB.Record) THEN ORG.New(x)
				 ELSE ORS.Mark("not a pointer to record")
				 END
			ELSIF pno = 6 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Pack(x, y)
			ELSIF pno = 7 THEN CheckReal(x); CheckInt(y); CheckReadOnly(x); ORG.Unpk(x, y)
			ELSIF pno = 8 THEN
				IF x.type.form <= ORB.Set THEN ORG.Led(x) ELSE ORS.Mark("bad type") END
			ELSIF pno = 10 THEN CheckInt(x); ORG.Get(x, y)
			ELSIF pno = 11 THEN CheckInt(x); ORG.Put(x, y)
			ELSIF pno = 12 THEN CheckInt(x); CheckInt(y); CheckInt(z); ORG.Copy(x, y, z)
			ELSIF pno = 13 THEN CheckConst(x); CheckInt(x); ORG.LDPSR(x)
			ELSIF pno = 14 THEN CheckInt(x); ORG.LDREG(x, y)
			END
		ELSE ORS.Mark("wrong nof parameters")
		END
	END StandProc;

	PROCEDURE StatSequence;
		VAR obj: ORB.Object;
			orgtype: ORB.Type; (*original type of case var*)
			x, y, z, w: ORG.Item;
			L0, L1, rx: LONGINT;

		PROCEDURE TypeCase(obj: ORB.Object; VAR x: ORG.Item);
			VAR typobj: ORB.Object;
		BEGIN
			IF sym = ORS.ident THEN
				qualident(typobj); ORG.MakeItem(x, obj, level);
				IF typobj.class # ORB.Typ THEN ORS.Mark("not a type") END;
				TypeTest(x, typobj.type, FALSE); obj.type := typobj.type;
				ORG.CFJump(x); Check(ORS.colon, ": expected"); StatSequence
			ELSE ORG.CFJump(x); ORS.Mark("type id expected")
			END
		 END TypeCase;

		PROCEDURE SkipCase;
		BEGIN
			WHILE sym # ORS.colon DO ORS.Get(sym) END;
			ORS.Get(sym); StatSequence
		END SkipCase;

	BEGIN (* StatSequence *)
		REPEAT (*sync*) obj := NIL;
			IF ~((sym >= ORS.ident)  & (sym <= ORS.for) OR (sym >= ORS.semicolon)) THEN
				ORS.Mark("statement expected");
				REPEAT ORS.Get(sym) UNTIL (sym >= ORS.ident)
			END ;
			IF sym = ORS.ident THEN
				qualident(obj); ORG.MakeItem(x, obj, level);
				IF x.mode = ORB.SProc THEN StandProc(obj.val)
				ELSE selector(x);
					IF sym = ORS.becomes THEN (*assignment*)
						ORS.Get(sym); CheckReadOnly(x); expression(y);
						IF CompTypes(x.type, y.type, FALSE) THEN
							IF (x.type.form <= ORB.Pointer) OR (x.type.form = ORB.Proc) THEN ORG.Store(x, y)
							ELSE ORG.StoreStruct(x, y)
							END
						ELSIF (x.type.form = ORB.Array) & (y.type.form = ORB.Array) & (x.type.base = y.type.base) & (y.type.len < 0) THEN
							ORG.StoreStruct(x, y)
						ELSIF (x.type.form = ORB.Array) & (x.type.base.form = ORB.Char) & (y.type.form = ORB.String) THEN
							ORG.CopyString(x, y)
						ELSIF (x.type.form = ORB.Int) & (y.type.form = ORB.Int) THEN ORG.Store(x, y)	(*BYTE*)
						ELSIF (x.type.form = ORB.Char) & (y.type.form = ORB.String) & (y.b = 2) THEN
							ORG.StrToChar(y); ORG.Store(x, y)
						ELSE ORS.Mark("illegal assignment")
						END
					ELSIF sym = ORS.eql THEN ORS.Mark("should be :="); ORS.Get(sym); expression(y)
					ELSIF sym = ORS.lparen THEN (*procedure call*)
						ORS.Get(sym);
						IF (x.type.form = ORB.Proc) & (x.type.base.form = ORB.NoTyp) THEN
							ORG.PrepCall(x, rx); ParamList(x); ORG.Call(x, rx)
						ELSE ORS.Mark("not a procedure"); ParamList(x)
						END
					ELSIF x.type.form = ORB.Proc THEN (*procedure call without parameters*)
						IF x.type.nofpar > 0 THEN ORS.Mark("missing parameters") END ;
						IF x.type.base.form = ORB.NoTyp THEN ORG.PrepCall(x, rx); ORG.Call(x, rx) ELSE ORS.Mark("not a procedure") END
					ELSIF x.mode = ORB.Typ THEN ORS.Mark("illegal assignment")
					ELSE ORS.Mark("not a procedure")
					END
				END
			ELSIF sym = ORS.if THEN
				ORS.Get(sym); expression(x); CheckBool(x); ORG.CFJump(x);
				Check(ORS.then, "no THEN");
				StatSequence; L0 := 0;
				WHILE sym = ORS.elsif DO
					ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); expression(x); CheckBool(x);
					ORG.CFJump(x); Check(ORS.then, "no THEN"); StatSequence
				END ;
				IF sym = ORS.else THEN ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); StatSequence
				ELSE ORG.Fixup(x)
				END ;
				ORG.FixLink(L0); Check(ORS.end, "no END")
			ELSIF sym = ORS.while THEN
				ORS.Get(sym); L0 := ORG.Here(); expression(x); CheckBool(x); ORG.CFJump(x);
				Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0);
				WHILE sym = ORS.elsif DO
					ORS.Get(sym); ORG.Fixup(x); expression(x); CheckBool(x); ORG.CFJump(x);
					Check(ORS.do, "no DO"); StatSequence; ORG.BJump(L0)
				END ;
				ORG.Fixup(x); Check(ORS.end, "no END")
			ELSIF sym = ORS.repeat THEN
				ORS.Get(sym); L0 := ORG.Here(); StatSequence;
				IF sym = ORS.until THEN
					ORS.Get(sym); expression(x); CheckBool(x); ORG.CBJump(x, L0)
				ELSE ORS.Mark("missing UNTIL")
				END
			ELSIF sym = ORS.for THEN
				ORS.Get(sym);
				IF sym = ORS.ident THEN
					qualident(obj); ORG.MakeItem(x, obj, level); CheckInt(x); CheckReadOnly(x);
					IF sym = ORS.becomes THEN
						ORS.Get(sym); expression(y); CheckInt(y); ORG.For0(x, y); L0 := ORG.Here();
						Check(ORS.to, "no TO"); expression(z); CheckInt(z); obj.rdo := TRUE;
						IF sym = ORS.by THEN ORS.Get(sym); expression(w); CheckConst(w); CheckInt(w)
						ELSE ORG.MakeConstItem(w, ORB.intType, 1)
						END ;
						Check(ORS.do, "no DO"); ORG.For1(x, y, z, w, L1);
						StatSequence; Check(ORS.end, "no END");
						ORG.For2(x, y, w); ORG.BJump(L0); ORG.FixLink(L1); obj.rdo := FALSE
					ELSE ORS.Mark(":= expected")
					END
				ELSE ORS.Mark("identifier expected")
				END
			ELSIF sym = ORS.case THEN
				ORS.Get(sym);
				IF sym = ORS.ident THEN
					qualident(obj); orgtype := obj.type;
					IF (orgtype.form = ORB.Pointer) OR (orgtype.form = ORB.Record) & (obj.class = ORB.Par) THEN
						Check(ORS.of, "OF expected"); TypeCase(obj, x); L0 := 0;
						WHILE sym = ORS.bar DO
							ORS.Get(sym); ORG.FJump(L0); ORG.Fixup(x); obj.type := orgtype; TypeCase(obj, x)
						END ;
						ORG.Fixup(x); ORG.FixLink(L0); obj.type := orgtype
					ELSE ORS.Mark("numeric case not implemented");
						Check(ORS.of, "OF expected"); SkipCase;
						WHILE sym = ORS.bar DO SkipCase END
					END
				ELSE ORS.Mark("ident expected")
				END ;
				Check(ORS.end, "no END")
			END ;
			ORG.CheckRegs;
			IF sym = ORS.semicolon THEN ORS.Get(sym)
			ELSIF sym < ORS.semicolon THEN ORS.Mark("missing semicolon?")
			END
		UNTIL sym > ORS.semicolon
	END StatSequence;

	(* Types and declarations *)

	PROCEDURE IdentList (class: INTEGER; VAR first: ORB.Object);
		VAR obj: ORB.Object;
	BEGIN
		IF sym = ORS.ident THEN
			ORB.NewObj(first, ORS.id, class); ORS.Get(sym); CheckExport(first.expo);
			WHILE sym = ORS.comma DO
				ORS.Get(sym);
				IF sym = ORS.ident THEN ORB.NewObj(obj, ORS.id, class); ORS.Get(sym); CheckExport(obj.expo)
				ELSE ORS.Mark("ident?")
				END
			END;
			IF sym = ORS.colon THEN ORS.Get(sym) ELSE ORS.Mark(":?") END
		ELSE first := NIL
		END
	END IdentList;

	PROCEDURE ArrayType (VAR type: ORB.Type);
		VAR x: ORG.Item; typ: ORB.Type; len: LONGINT;
	BEGIN NEW(typ); typ.form := ORB.NoTyp;
		expression(x);
		IF (x.mode = ORB.Const) & (x.type.form = ORB.Int) & (x.a >= 0) THEN len := x.a
		ELSE len := 1; ORS.Mark("not a valid length")
		END;
		IF sym = ORS.of THEN ORS.Get(sym); Type(typ.base);
			IF (typ.base.form = ORB.Array) & (typ.base.len < 0) THEN ORS.Mark("dyn array not allowed") END
		ELSIF sym = ORS.comma THEN ORS.Get(sym); ArrayType(typ.base)
		ELSE ORS.Mark("missing OF"); typ.base := ORB.intType
		END;
		typ.size := (len * typ.base.size + 3) DIV 4 * 4;
		typ.form := ORB.Array; typ.len := len; type := typ
	END ArrayType;

	PROCEDURE RecordType(VAR type: ORB.Type);
		VAR obj, obj0, new, bot, base: ORB.Object;
			typ, tp: ORB.Type;
			offset, off, n: LONGINT;
	BEGIN NEW(typ); typ.form := ORB.NoTyp; typ.base := NIL; typ.mno := -level; typ.nofpar := 0; offset := 0; bot := NIL;
		IF sym = ORS.lparen THEN
			ORS.Get(sym); (*record extension*)
			IF level # 0 THEN ORS.Mark("extension of local types not implemented") END;
			IF sym = ORS.ident THEN
				qualident(base);
				IF base.class = ORB.Typ THEN
					IF base.type.form = ORB.Record THEN typ.base := base.type
					ELSE typ.base := ORB.intType; ORS.Mark("invalid extension")
					END;
					typ.nofpar := typ.base.nofpar + 1; (*"nofpar" here abused for extension level*)
					bot := typ.base.dsc; offset := typ.base.size
				ELSE ORS.Mark("type expected")
				END
			ELSE ORS.Mark("ident expected")
			END;
			Check(ORS.rparen, "no )")
		END;
		WHILE sym = ORS.ident DO	(*fields*)
			n := 0; obj := bot;
			WHILE sym = ORS.ident DO
				obj0 := obj;
				WHILE (obj0 # NIL) & (obj0.name # ORS.id) DO obj0 := obj0.next END;
				IF obj0 # NIL THEN ORS.Mark("mult def") END;
				NEW(new); ORS.CopyId(new.name); new.class := ORB.Fld; new.next := obj; obj := new; INC(n);
				ORS.Get(sym); CheckExport(new.expo);
				IF (sym # ORS.comma) & (sym # ORS.colon) THEN ORS.Mark("comma expected")
				ELSIF sym = ORS.comma THEN ORS.Get(sym)
				END
			END;
			Check(ORS.colon, "colon expected"); Type(tp);
			IF (tp.form = ORB.Array) & (tp.len < 0) THEN ORS.Mark("dyn array not allowed") END;
			IF tp.size > 1 THEN offset := (offset+3) DIV 4 * 4 END;
			offset := offset + n * tp.size; off := offset; obj0 := obj;
			WHILE obj0 # bot DO obj0.type := tp; obj0.lev := 0; off := off - tp.size; obj0.val := off; obj0 := obj0.next END;
			bot := obj;
			IF sym = ORS.semicolon THEN ORS.Get(sym) ELSIF sym # ORS.end THEN ORS.Mark(" ; or END") END
		END;
		typ.form := ORB.Record; typ.dsc := bot; typ.size := (offset + 3) DIV 4 * 4; type := typ
	END RecordType;

	PROCEDURE FPSection (VAR adr: LONGINT; VAR nofpar: INTEGER);
		VAR obj, first: ORB.Object; tp: ORB.Type;
			parsize: LONGINT; cl: INTEGER; rdo: BOOLEAN;
	BEGIN
		IF sym = ORS.var THEN ORS.Get(sym); cl := ORB.Par ELSE cl := ORB.Var END;
		IdentList(cl, first); FormalType(tp, 0); rdo := FALSE;
		IF (cl = ORB.Var) & (tp.form >= ORB.Array) THEN cl := ORB.Par; rdo := TRUE END;
		IF (tp.form = ORB.Array) & (tp.len < 0) OR (tp.form = ORB.Record) THEN
			parsize := 2*ORG.WordSize	(*open array or record, needs second word for length or type tag*)
		ELSE parsize := ORG.WordSize
		END;
		obj := first;
		WHILE obj # NIL DO
			INC(nofpar); obj.class := cl; obj.type := tp; obj.rdo := rdo; obj.lev := level; obj.val := adr;
			adr := adr + parsize; obj := obj.next
		END;
		IF adr >= 52 THEN ORS.Mark("too many parameters") END
	END FPSection;

	PROCEDURE ProcedureType (ptype: ORB.Type; VAR parblksize: LONGINT);
		VAR obj: ORB.Object; size: LONGINT; nofpar: INTEGER;
	BEGIN ptype.base := ORB.noType; size := parblksize; nofpar := 0; ptype.dsc := NIL;
		IF sym = ORS.lparen THEN
			ORS.Get(sym);
			IF sym = ORS.rparen THEN ORS.Get(sym)
			ELSE FPSection(size, nofpar);
				WHILE sym = ORS.semicolon DO ORS.Get(sym); FPSection(size, nofpar) END;
				Check(ORS.rparen, "no )")
			END;
			IF sym = ORS.colon THEN (*function*)
				ORS.Get(sym);
				IF sym = ORS.ident THEN
					qualident(obj); ptype.base := obj.type;
					IF ~((obj.class = ORB.Typ) & (obj.type.form IN {ORB.Byte .. ORB.Pointer, ORB.Proc})) THEN
						ORS.Mark("illegal function type")
					END
				ELSE ORS.Mark("type identifier expected")
				END
			END
		END;
		ptype.nofpar := nofpar; parblksize := size
	END ProcedureType;

	PROCEDURE FormalType0 (VAR typ: ORB.Type; dim: INTEGER);
		VAR obj: ORB.Object; dmy: LONGINT;
	BEGIN
		IF sym = ORS.ident THEN
			qualident(obj);
			IF obj.class = ORB.Typ THEN typ := obj.type ELSE ORS.Mark("not a type"); typ := ORB.intType END
		ELSIF sym = ORS.array THEN
			ORS.Get(sym); Check(ORS.of, "OF ?");
			IF dim >= 1 THEN ORS.Mark("multi-dimensional open arrays not implemented") END;
			NEW(typ); typ.form := ORB.Array; typ.len := -1; typ.size := 2*ORG.WordSize;
			FormalType(typ.base, dim+1)
		ELSIF sym = ORS.procedure THEN
			ORS.Get(sym); ORB.OpenScope;
			NEW(typ); typ.form := ORB.Proc; typ.size := ORG.WordSize; dmy := 0; ProcedureType(typ, dmy);
			typ.dsc := ORB.topScope.next; ORB.CloseScope
		ELSE ORS.Mark("identifier expected"); typ := ORB.noType
		END
	END FormalType0;

	PROCEDURE CheckRecLevel(lev: INTEGER);
	BEGIN
		IF lev # 0 THEN ORS.Mark("ptr base must be global") END
	END CheckRecLevel;

	PROCEDURE Type0 (VAR type: ORB.Type);
		VAR dmy: LONGINT; obj: ORB.Object; ptbase: PtrBase;
	BEGIN type := ORB.intType; (*sync*)
		IF (sym # ORS.ident) & (sym < ORS.array) THEN ORS.Mark("not a type");
			REPEAT ORS.Get(sym) UNTIL (sym = ORS.ident) OR (sym >= ORS.array)
		END ;
		IF sym = ORS.ident THEN
			qualident(obj);
			IF obj.class = ORB.Typ THEN
				IF (obj.type # NIL) & (obj.type.form # ORB.NoTyp) THEN type := obj.type END
			ELSE ORS.Mark("not a type or undefined")
			END
		ELSIF sym = ORS.array THEN ORS.Get(sym); ArrayType(type)
		ELSIF sym = ORS.record THEN
			ORS.Get(sym); RecordType(type); Check(ORS.end, "no END")
		ELSIF sym = ORS.pointer THEN
			ORS.Get(sym); Check(ORS.to, "no TO");
			NEW(type);	type.form := ORB.Pointer; type.size := ORG.WordSize; type.base := ORB.intType;
			IF sym = ORS.ident THEN
				obj := ORB.thisObj();
				IF obj # NIL THEN
					IF (obj.class = ORB.Typ) & (obj.type.form IN {ORB.Record, ORB.NoTyp}) THEN
						CheckRecLevel(obj.lev); type.base := obj.type
					ELSIF obj.class = ORB.Mod THEN ORS.Mark("external base type not implemented")
					ELSE ORS.Mark("no valid base type")
					END
				ELSE CheckRecLevel(level); (*enter into list of forward references to be fixed in Declarations*)
					NEW(ptbase); ORS.CopyId(ptbase.name); ptbase.type := type; ptbase.next := pbsList; pbsList := ptbase
				END ;
				ORS.Get(sym)
			ELSE Type(type.base);
				IF (type.base.form # ORB.Record) OR (type.base.typobj = NIL) THEN ORS.Mark("must point to named record") END ;
				CheckRecLevel(level)
			END
		ELSIF sym = ORS.procedure THEN
			ORS.Get(sym); ORB.OpenScope;
			NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize; dmy := 0;
			ProcedureType(type, dmy); type.dsc := ORB.topScope.next; ORB.CloseScope
		ELSE ORS.Mark("illegal type")
		END
	END Type0;

	PROCEDURE Declarations (VAR varsize: LONGINT);
		VAR obj, first: ORB.Object;
			x: ORG.Item; tp: ORB.Type; ptbase: PtrBase;
			expo: BOOLEAN; id: ORS.Ident;
	BEGIN (*sync*) pbsList := NIL;
		IF (sym < ORS.const) & (sym # ORS.end) & (sym # ORS.return) THEN ORS.Mark("declaration?");
			REPEAT ORS.Get(sym) UNTIL (sym >= ORS.const) OR (sym = ORS.end) OR (sym = ORS.return)
		END;
		IF sym = ORS.const THEN
			ORS.Get(sym);
			WHILE sym = ORS.ident DO
				ORS.CopyId(id); ORS.Get(sym); CheckExport(expo);
				IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("= ?") END;
				expression(x);
				IF (x.type.form = ORB.String) & (x.b = 2) THEN ORG.StrToChar(x) END;
				ORB.NewObj(obj, id, ORB.Const); obj.expo := expo;
				IF x.mode = ORB.Const THEN obj.val := x.a; obj.lev := x.b; obj.type := x.type
				ELSE ORS.Mark("expression not constant"); obj.type := ORB.intType
				END;
				Check(ORS.semicolon, "; missing")
			END
		END;
		IF sym = ORS.type THEN
			ORS.Get(sym);
			WHILE sym = ORS.ident DO
				ORS.CopyId(id); ORS.Get(sym); CheckExport(expo);
				IF sym = ORS.eql THEN ORS.Get(sym) ELSE ORS.Mark("=?") END;
				Type(tp);
				ORB.NewObj(obj, id, ORB.Typ); obj.type := tp; obj.expo := expo; obj.lev := level;
				IF tp.typobj = NIL THEN tp.typobj := obj END;
				IF expo & (obj.type.form = ORB.Record) THEN obj.exno := exno; INC(exno) ELSE obj.exno := 0 END;
				IF tp.form = ORB.Record THEN
					ptbase := pbsList;	(*check whether this is base of a pointer type; search and fixup*)
					WHILE ptbase # NIL DO
						IF obj.name = ptbase.name THEN ptbase.type.base := obj.type END;
						ptbase := ptbase.next
					END;
					IF level = 0 THEN ORG.BuildTD(tp, dc) END		(*type descriptor; len used as its address*)
				END;
				Check(ORS.semicolon, "; missing")
			END
		END;
		IF sym = ORS.var THEN
			ORS.Get(sym);
			WHILE sym = ORS.ident DO
				IdentList(ORB.Var, first); Type(tp);
				obj := first;
				WHILE obj # NIL DO
					obj.type := tp; obj.lev := level;
					IF tp.size > 1 THEN varsize := (varsize + 3) DIV 4 * 4 (*align*) END;
					obj.val := varsize; varsize := varsize + obj.type.size;
					IF obj.expo THEN obj.exno := exno; INC(exno) END;
					obj := obj.next
				END;
				Check(ORS.semicolon, "; missing")
			END
		END;
		varsize := (varsize + 3) DIV 4 * 4;
		ptbase := pbsList;
		WHILE ptbase # NIL DO
			IF ptbase.type.base.form = ORB.Int THEN ORS.Mark("undefined pointer base of") END;
			ptbase := ptbase.next
		END;
		IF (sym >= ORS.const) & (sym <= ORS.var) THEN ORS.Mark("declaration in bad order") END
	END Declarations;

	PROCEDURE ProcedureDecl;
		VAR proc: ORB.Object;
			type: ORB.Type;
			procid: ORS.Ident;
			x: ORG.Item;
			locblksize, parblksize, L: LONGINT;
			int: BOOLEAN;
	BEGIN (* ProcedureDecl *) int := FALSE; ORS.Get(sym);
		IF sym = ORS.times THEN ORS.Get(sym); int := TRUE END;
		IF sym = ORS.ident THEN
			ORS.CopyId(procid); ORS.Get(sym);
			ORB.NewObj(proc, ORS.id, ORB.Const);
			IF int THEN parblksize := ORG.parblksize0Int
			ELSE parblksize := ORG.parblksize0Proc
			END;
			NEW(type); type.form := ORB.Proc; type.size := ORG.WordSize;
			proc.type := type; proc.val := -1; proc.lev := level;
			CheckExport(proc.expo);
			IF proc.expo THEN proc.exno := exno; INC(exno) END;
			ORB.OpenScope; INC(level); type.base := ORB.noType;
			ProcedureType(type, parblksize);	(*formal parameter list*)
			Check(ORS.semicolon, "no ;"); locblksize := parblksize;
			Declarations(locblksize);
			proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next;
			IF sym = ORS.procedure THEN
				L := 0; ORG.FJump(L);
				REPEAT ProcedureDecl; Check(ORS.semicolon, "no ;") UNTIL sym # ORS.procedure;
				ORG.FixOne(L); proc.val := ORG.Here() * 4; proc.type.dsc := ORB.topScope.next
			END;
			ORG.Enter(parblksize, locblksize, int);
			IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END;
			IF sym = ORS.return THEN
				ORS.Get(sym); expression(x);
				IF type.base = ORB.noType THEN ORS.Mark("this is not a function")
				ELSIF ~CompTypes(type.base, x.type, FALSE) THEN ORS.Mark("wrong result type")
				END
			ELSIF type.base.form # ORB.NoTyp THEN
				ORS.Mark("function without result"); type.base := ORB.noType
			END;
			ORG.Return(type.base.form, x, locblksize, int);
			ORB.CloseScope; DEC(level); Check(ORS.end, "no END");
			IF sym = ORS.ident THEN
				IF ORS.id # procid THEN ORS.Mark("no match") END;
				ORS.Get(sym)
			ELSE ORS.Mark("no proc id")
			END
		ELSE ORS.Mark("proc id expected")
		END
	END ProcedureDecl;

	PROCEDURE Import;
		VAR impid, impid1: ORS.Ident;
	BEGIN
		IF sym = ORS.ident THEN
			ORS.CopyId(impid); ORS.Get(sym);
			IF sym = ORS.becomes THEN
				ORS.Get(sym);
				IF sym = ORS.ident THEN ORS.CopyId(impid1); ORS.Get(sym)
				ELSE ORS.Mark("id expected"); impid1 := impid
				END
			ELSE impid1 := impid
			END;
			ORB.Import(impid, impid1)
		ELSE ORS.Mark("id expected")
		END
	END Import;

	PROCEDURE Module;
		VAR key: LONGINT;
	BEGIN Texts.WriteString(W, "  compiling "); ORS.Get(sym);
		IF sym = ORS.module THEN
			ORS.Get(sym);
			IF sym = ORS.times THEN version := 0; dc := 8; Texts.Write(W, "*"); ORS.Get(sym) ELSE dc := 0; version := 1 END;
			ORB.Init; ORB.OpenScope;
			IF sym = ORS.ident THEN
				ORS.CopyId(modid); ORS.Get(sym);
				Texts.WriteString(W, modid); Texts.Append(Oberon.Log(**), W.buf)
			ELSE ORS.Mark("identifier expected")
			END;
			Check(ORS.semicolon, "no ;"); level := 0; exno := 1; key := 0;
			IF sym = ORS.import THEN
				ORS.Get(sym); Import;
				WHILE sym = ORS.comma DO ORS.Get(sym); Import END;
				Check(ORS.semicolon, "; missing")
			END;
			ORG.Open(version); Declarations(dc); ORG.SetDataSize((dc + 3) DIV 4 * 4);
			WHILE sym = ORS.procedure DO ProcedureDecl; Check(ORS.semicolon, "no ;") END;
			ORG.Header;
			IF sym = ORS.begin THEN ORS.Get(sym); StatSequence END;
			Check(ORS.end, "no END");
			IF sym = ORS.ident THEN
				IF ORS.id # modid THEN ORS.Mark("no match") END;
				ORS.Get(sym)
			ELSE ORS.Mark("identifier missing")
			END;
			IF sym # ORS.period THEN ORS.Mark("period missing") END;
			IF (ORS.errcnt = 0) & (version # 0) THEN
				ORB.Export(modid, newSF, key);
				IF newSF THEN Texts.WriteString(W, " new symbol file") END
			END;
			IF ORS.errcnt = 0 THEN
				ORG.Close(modid, key, exno);
				Texts.WriteInt(W, ORG.pc, 6); Texts.WriteInt(W, dc, 6); Texts.WriteHex(W, key)
			ELSE Texts.WriteLn(W); Texts.WriteString(W, "compilation FAILED")
			END;
			Texts.WriteLn(W); Texts.Append(Oberon.Log(**), W.buf);
			ORB.CloseScope; pbsList := NIL
		ELSE ORS.Mark("must start with MODULE")
		END
	END Module;

	PROCEDURE Option (VAR S: Texts.Scanner);
	BEGIN newSF := FALSE;
		IF S.nextCh = "/" THEN
			Texts.Scan(S); Texts.Scan(S);
			IF (S.class = Texts.Name) & (S.s[0] = "s") THEN newSF := TRUE END
		END
	END Option;

	PROCEDURE Compile*;
		VAR beg, end, time: LONGINT;
			T: Texts.Text;
			S: Texts.Scanner;
	BEGIN (*Oberon.GetPar;*) Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
		Texts.Scan(S);
		IF S.class = Texts.Char THEN
			(*
			IF S.c = "@" THEN
				Option(S); Oberon.GetSelection(T, beg, end, time);
				IF time >= 0 THEN ORS.Init(T, beg); Module END
			ELSIF S.c = "^" THEN
				Option(S); Oberon.GetSelection(T, beg, end, time);
				IF time >= 0 THEN
					Texts.OpenScanner(S, T, beg); Texts.Scan(S);
					IF S.class = Texts.Name THEN
						Texts.WriteString(W, S.s); NEW(T); Texts.Open(T, S.s);
						IF T.len > 0 THEN ORS.Init(T, 0); Module END
					END
				END
			END
			*)
		ELSE
			WHILE S.class = Texts.Name DO
				NEW(T); Texts.Open(T, S.s);
				IF T.len > 0 THEN Option(S); ORS.Init(T, 0); Module
				ELSE Texts.WriteString(W, S.s); Texts.WriteString(W, " not found");
					Texts.WriteLn(W); Texts.Append(Oberon.Log(**), W.buf)
				END;
				IF (T.len # 0) & (ORS.errcnt = 0) THEN Texts.Scan(S) ELSE S.class := 0 END
			END
		END;
		(* Oberon.Collect(0) *)
	END Compile;

(*
	(* DevCompiler *)

		PROCEDURE Scan (VAR s: TextMappers.Scanner);
		BEGIN
			s.Scan;
			IF s.type = TextMappers.string THEN
				IF s.string = "MODULE" THEN s.type := module END
			ELSIF s.type = TextMappers.char THEN
				IF s.char = "(" THEN
					IF s.rider.char = "*" THEN
						s.rider.Read;
						REPEAT Scan(s) UNTIL (s.type = TextMappers.eot) OR (s.type = comEnd);
						Scan(s)
					END
				ELSIF s.char = "*" THEN
					IF s.rider.char = ")" THEN s.rider.Read; s.type := comEnd END
				END
			END
		END Scan;

		PROCEDURE Do (source, log: TextModels.Model; beg: INTEGER; opt: SET; VAR error: BOOLEAN);
			VAR s: TextMappers.Scanner;
				str: Dialog.String;
		BEGIN
			(*
			Dialog.MapString("#Dev:Compiling", str);
			StdLog.String(str); StdLog.Char(" ");
			s.ConnectTo(source); s.SetPos(beg);
			Scan(s);
			WHILE (s.type # TextMappers.eot) & (s.type # module) DO Scan(s) END;
			IF s.type = module THEN
				Scan(s);
				IF s.type = TextMappers.string THEN
					StdLog.Char('"'); StdLog.String(s.string); StdLog.Char('"')
				END
			END;
			*)

			(*
			Module(sourceR, opt, log, error)
			*)
				ORS.Init(Texts.NewText(source), beg);
				newSF := newsf IN opt;
				Module;
				error := ORS.errcnt # 0
		END Do;

		PROCEDURE Open;
		BEGIN
			Dialog.ShowStatus("#Dev:Compiling");
			StdLog.buf.Delete(0, StdLog.buf.Length())
		END Open;

		PROCEDURE Close;
		BEGIN
			StdLog.text.Append(StdLog.buf);
			TextViews.ShowRange(StdLog.text,
				StdLog.text.Length(), StdLog.text.Length(), TextViews.any);
			IF ORS.errcnt = 0 THEN Dialog.ShowStatus("#Dev:Ok")
			END;
			(* sourceR := NIL; *)
			Kernel.Cleanup
		END Close;

		PROCEDURE Compile2*;
			VAR t: TextModels.Model; error: BOOLEAN;
		BEGIN
			Open;
			t := TextViews.FocusText();
			IF t # NIL THEN
				Do(t, StdLog.text, 0, defopt, error);
				IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END
			ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
			END;
			Close
		END Compile2;

		PROCEDURE CompileText* (text: TextModels.Model; beg: INTEGER; OUT error: BOOLEAN);
		BEGIN
			ASSERT(text # NIL, 20); ASSERT((beg >= 0) & (beg <= text.Length()), 21);
			Open;
			Do(text, StdLog.text, beg, defopt, error);
			IF error THEN DevMarkers.ShowFirstError(text, TextViews.focusOnly) END;
			Close
		END CompileText;

		PROCEDURE CompileSelection*;
			VAR c: TextControllers.Controller; t: TextModels.Model; beg, end: INTEGER; error: BOOLEAN;
		BEGIN
			Open;
			c := TextControllers.Focus();
			IF c # NIL THEN
				t := c.text;
				IF c.HasSelection() THEN
					c.GetSelection(beg, end); Do(t, StdLog.text, beg, defopt, error);
					IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END
				ELSE Dialog.ShowMsg("#Dev:NoSelectionFound")
				END
			ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
			END;
			Close
		END CompileSelection;

		PROCEDURE CompileList (beg, end: INTEGER; c: TextControllers.Controller);
			VAR v: Views.View; i: INTEGER; error, one: BOOLEAN; name: Files.Name; loc: Files.Locator;
				t: TextModels.Model; opts: SET;
		BEGIN
			s.SetPos(beg); s.Scan; one := FALSE;
			WHILE (s.start < end) & (s.type = TextMappers.string) & (s.len < LEN(name)) DO
				s.Scan; one := TRUE;
				WHILE (s.start < end) & (s.type = TextMappers.char) &
					((s.char = "-") OR (s.char = "+") OR
					(s.char = "!") OR (s.char = "*") OR (s.char = "?") OR (s.char = "^") OR (s.char = "("))
				DO
					IF s.char = "(" THEN
						WHILE (s.start < end) & ((s.type # TextMappers.char) OR (s.char # ")")) DO s.Scan END
					END;
					s.Scan
				END
			END;
			IF one & (s.start >= end) THEN
				s.SetPos(beg); s.Scan; error := FALSE;
				WHILE (s.start < end) & (s.type = TextMappers.string) & ~error DO
					i := 0; WHILE i < LEN(name) DO name[i] := 0X; INC(i) END;
					StdDialog.GetSubLoc(s.string, "Mod", loc, name);
					t := NIL;
					IF loc # NIL THEN
						v := Views.OldView(loc, name);
						IF v # NIL THEN
							WITH v: TextViews.View DO t := v.ThisModel()
							ELSE Dialog.ShowParamMsg("#Dev:NoTextFileFound", name, "", ""); error := TRUE
							END
						ELSE Dialog.ShowParamMsg("#Dev:CannotOpenFile", name, "", ""); error := TRUE
						END
					ELSE Dialog.ShowParamMsg("#System:FileNotFound", name, "", ""); error := TRUE
					END;
					s.Scan; opts := defopt;
					(*
					WHILE (s.start < end) & (s.type = TextMappers.char) DO
						IF s.char = "-" THEN
							IF srcpos IN opts THEN EXCL(opts, srcpos)
							ELSIF allref IN opts THEN EXCL(opts, allref)
							ELSIF ref IN opts THEN EXCL(opts, ref)
							ELSE EXCL(opts, obj)
							END
						ELSIF s.char = "!" THEN
							IF assert IN opts THEN EXCL(opts, assert)
							ELSE EXCL(opts, checks)
							END
						ELSIF s.char = "+" THEN INCL(opts, allchecks)
						ELSIF s.char = "?" THEN INCL(opts, hint)
						ELSIF s.char = "@" THEN INCL(opts, errorTrap)
						ELSIF s.char = "$" THEN INCL(opts, oberon)
						ELSIF s.char = "(" THEN
							s.Scan;
							WHILE (s.start < end) & (s.type = TextMappers.string) DO
								title := s.string$; s.Scan;
								IF (s.start < end) & (s.type = TextMappers.char) & (s.char = ":") THEN
									s.Scan;
									IF (s.start < end) & (s.type = TextMappers.string) THEN
										entry := s.string$; s.Scan;
										IF t # NIL THEN DevSelectors.ChangeTo(t, title, entry) END
									END
								END;
								IF (s.start < end) & (s.type = TextMappers.char) & (s.char = ",") THEN s.Scan END
							END
						END;
						s.Scan
					END;
					*)
					IF t # NIL THEN
						Do(t, StdLog.text, 0, opts, error)
					END
				END
			ELSE Dialog.ShowMsg("#Dev:NotOnlyFileNames")
			END;
			s.ConnectTo(NIL);
			IF error & (c # NIL) & c.HasSelection() & (s.start < end) THEN
				c.SetSelection(s.start, end)
			END;
			IF error & (v # NIL) THEN
				Views.Open(v, loc, name, NIL);
				DevMarkers.ShowFirstError(t, TextViews.any)
			END
		END CompileList;

		PROCEDURE CompileModuleList*;
			VAR c: TextControllers.Controller; beg, end: INTEGER;
		BEGIN
			Open;
			c := TextControllers.Focus();
			IF c # NIL THEN
				s.ConnectTo(c.text);
				IF c.HasSelection() THEN c.GetSelection(beg, end)
				ELSE beg := 0; end := c.text.Length()
				END;
				CompileList(beg, end, c)
			ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
			END;
			Close
		END CompileModuleList;

		PROCEDURE CompileThis*;
			VAR p: DevCommanders.Par; beg, end: INTEGER;
		BEGIN
			Open;
			p := DevCommanders.par;
			IF p # NIL THEN
				DevCommanders.par := NIL;
				s.ConnectTo(p.text); beg := p.beg; end := p.end;
				CompileList(beg, end, NIL)
			ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
			END;
			Close
		END CompileThis;
*)

BEGIN Texts.OpenWriter(W); Texts.WriteString(W, "Oberon -> ARMv7-M Compiler  8.2.2020");
	Texts.WriteLn(W); Texts.Append(Oberon.Log(**), W.buf);
	NEW(dummy); dummy.class := ORB.Var; dummy.type := ORB.intType;
	expression := expression0; Type := Type0; FormalType := FormalType0
END O7ARMv7MP.