Оберон-клуб «ВЄДАsoft»

TYPE
	ConstArray = POINTER TO EXTENSIBLE RECORD END;
	ConstArrayOfByte = POINTER TO RECORD(ConstArray)
		data*: POINTER TO ARRAY OF BYTE;
	END;
	ConstArrayOfSInt = POINTER TO RECORD(ConstArray)
		data*: POINTER TO ARRAY OF SHORTINT;
	END;
	ConstArrayOfInt = POINTER TO RECORD(ConstArray)
		data*: POINTER TO ARRAY OF INTEGER;
	END;
	ConstArrayOfLInt = POINTER TO RECORD(ConstArray)
		data*: POINTER TO ARRAY OF LONGINT;
	END;
...
		ConstDesc* = RECORD
			ext*: ConstExt;	(* string or code for code proc *)
			intval*: INTEGER;	(* constant value or adr, proc par size, text position or least case label *)
			intval2*: INTEGER;	(* string length, proc var size or larger case label *)
			setval*: SET;	(* constant value, procedure body present or "ELSE" present in case *)
			realval*: REAL;	(* real or longreal constant value *)
			array*: ConstArray;
		END ; 

NEW(x^.conval^.array(ConstArrayOfLInt)); NEW(x^.conval^.array(ConstArrayOfLInt).data, size);

VAR  y: OPT.ConstArrayOfLInt;
...
NEW(y); NEW(y.data,n);
...
y.data[k]:=apar^.conval^.intval; 
...
x^.conval^.array := y; (* присвоить предку потомка можно, все поля потомка сохранятся*)
...
ci := x^.conval^.array(OPT.ConstArrayOfLInt).data[i]  (* потом можно вытащить любой элемент массива*)
 

CASE elemsize OF (* Размер элементов массива в байтах (для BlackBox). *)
  | 1:	WITH x^.conval^.arr: ConstArrOfByte DO (* BOOLEAN, CHAR, SYSTEM.BYTE (для Ofront'а) *)
		NEW(x^.conval^.arr); NEW(x^.conval^.arr.val, size);
	END;
  | 2:	WITH x^.conval^.arr: ConstArrOfSInt DO (* типы с размером в 2 байта *)
		NEW(x^.conval^.arr); NEW(x^.conval^.arr.val, size);
	END;
  | 4:	WITH x^.conval^.arr: ConstArrOfInt DO (* типы с размером в 4 байта *)
		NEW(x^.conval^.arr); NEW(x^.conval^.arr.val, size);
	END;
  | 8:	WITH x^.conval^.arr: ConstArrOfLInt DO (* типы с размером в 8 байт *)
		NEW(x^.conval^.arr); NEW(x^.conval^.arr.val, size);
	END;
END;

		ConstArray* = POINTER TO EXTENSIBLE RECORD END;
 
		ConstArrayOfByte* = POINTER TO RECORD(ConstArray)
			val*: POINTER TO ARRAY OF BYTE;
		END;
 
		ConstArrayOfSInt*= POINTER TO RECORD(ConstArray)
			val*: POINTER TO ARRAY OF SHORTINT;
		END;
 
		ConstArrayOfInt* = POINTER TO RECORD(ConstArray)
			val*: POINTER TO ARRAY OF INTEGER;
		END;
 
		ConstArrayOfLInt* = POINTER TO RECORD(ConstArray)
			val*: POINTER TO ARRAY OF LONGINT;
		END;		
 
		ConstDesc* = RECORD
			ext*: ConstExt;	(* string or code for code proc *)
			intval*: INTEGER;	(* constant value or adr, proc par size, text position or least case label *)
			intval2*: INTEGER;	(* string length, proc var size or larger case label *)
			setval*: SET;	(* constant value, procedure body present or "ELSE" present in case *)
			realval*: REAL;	(* real or longreal constant value *)
			arr*: ConstArray; (*  для данных константного массива *)
		END ;

	PROCEDURE ConstArray (VAR x: OPT.Node);
		VAR apar:  OPT.Node; n,size,i: INTEGER; fp: OPT.Object;  y: OPT.ConstArrayOfInt;
	BEGIN
		IF  x^.obj^.typ^.BaseTyp^.form IN intSet THEN (* массив из целых, позднее добавим BYTE *)
			n:=x^.obj^.typ^.n; (* количество элементов массива *)		
			CheckSym(lparen); (* скобка (  *)
			fp := OPT.NewObj(); fp^.typ :=  x^.obj^.typ^.BaseTyp;
			fp^.mode := Var;  (*  fp  - переменная, элемент массива *)
			(* тут нужно бы выделить кусок  памяти для n элементов массива *)
			NEW(y); NEW(y.val, n);
			IF sym # rparen THEN
				i := 0;
				LOOP  ConstExpression(apar); (* берем очередной элемент *)
					IF i < n THEN
						OPB.Param(apar,fp); (* проверим на совместимость*)
						(* тут нужно положить элемент в кусок памяти *)
						y.val[i] := apar^.conval^.intval; 
						INC(i);
					ELSE err(64)
					END ;
					IF sym = comma THEN OPS.Get(sym)
					ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
					ELSE EXIT
					END
				END
			END ;
			(* x - тип массив, y -элементы массива в памяти, *)
			fp := x^.obj; (* запомним тип "массив"*)
			x := OPB.NewIntConst(n); 
			x^.conval^.arr := y;
			x^.obj := fp; (* константа с типом "массив" *)
			IF i # n THEN err(65) END;
			CheckSym(rparen);
		ELSE  err(51)
		END;
	END ConstArray;

	PROCEDURE Block(VAR procdec, statseq: OPT.Node);
		VAR typ: OPT.Struct;
			obj, first, last: OPT.Object;
			x, lastdec: OPT.Node;
			i: SHORTINT;
 
	BEGIN first := NIL; last := NIL; nofFwdPtr := 0;
		LOOP
			IF sym = const THEN
				OPS.Get(sym);
				WHILE sym = ident DO
					OPT.Insert(OPS.name, obj); CheckMark(obj^.vis);
					obj^.typ := OPT.sinttyp; obj^.mode := Var;	(* Var to avoid recursive definition *)
					IF sym = eql THEN
						OPS.Get(sym);
						IF sym = ident THEN  (* если это идентификатор *)
									x := OPT.NewNode(Ntype); qualident(x^.obj); (* берем его как идентификатор типа *)
									IF (x^.obj^.mode = Typ)  & (x^.obj^.typ^.form = Comp) & (x^.obj^.typ^.comp = Array) 
									THEN  ConstArray(x)
									ELSE 	 ConstExpression(x) (* обрабатываем стандартным образом *)
									END
 
						ELSE
						 ConstExpression(x)
						END
					ELSIF sym = becomes THEN
						err(eql); OPS.Get(sym); ConstExpression(x)
					ELSE err(eql); x := OPB.NewIntConst(1)
					END ;
					obj^.mode := Con; obj^.typ := x^.typ; obj^.conval := x^.conval; (* ConstDesc ist not copied *)
					IF obj^.conval^.arr # NIL THEN 
						obj^.mode := Var; (* как будто это переменная *)
						obj^.typ :=  x^.obj^.typ;
						obj^.typ^.pvused := TRUE; (* не знаю, нужно ли это *)
								IF last = NIL THEN OPT.topScope^.scope := obj ELSE last^.link := obj END ;
							last := obj;
					first := NIL;
					END;
					CheckSym(semicolon)
				END	
			END;
			IF sym = type THEN
...

	PROCEDURE IdentList (obj: OPT.Object; vis: SHORTINT);
	(* generate var and param lists; vis: 0 all global vars, local var, 1 exported(R) var, 2 par list, 3 scope var *)
		VAR base: OPT.Struct; first: BOOLEAN; lastvis: SHORTINT; i: INTEGER;
	BEGIN  
		base := NIL; first := TRUE;
		WHILE (obj # NIL) & (obj^.mode # TProc) DO
			IF (vis IN {0, 2}) OR ((vis = 1) & (obj^.vis # 0)) OR ((vis = 3) & ~obj^.leaf) THEN
				IF (obj^.typ # base) OR (obj^.vis # lastvis) OR 
				((obj^.conval # NIL) & (obj^.conval^.arr # NIL)) THEN	(* каждый конст.массив отдельно*)
				(* new variable base type definition required *)
					IF ~first THEN EndStat END ;
					first := FALSE;
					base := obj^.typ; lastvis := obj^.vis;
					BegStat;
					IF (vis = 1) & (obj^.vis # internal) THEN OPM.WriteString(Extern)
					ELSIF (obj^.mnolev = 0) & (vis = 0) THEN
						IF (obj^.conval # NIL) & (obj^.conval^.arr # NIL)  THEN  (* конст.массив *)
							OPM.WriteString("const "); 
						ELSIF obj^.vis = internal THEN OPM.WriteString(Static)
						ELSE OPM.WriteString(Export)
						END
					END;
					IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.WriteString("double")
					ELSE DeclareBase(obj)
					END
				ELSE OPM.Write(",");
				END;
				OPM.Write(Blank);
				IF (vis = 2) & (obj^.mode = Var) & (base^.form = Real) THEN OPM.Write("_") END ;
				DeclareObj(obj, vis = 3);
				IF obj^.typ^.comp = DynArr THEN (* declare len parameter(s) *)
					EndStat; BegStat;
					base := OPT.linttyp;
					OPM.WriteString("LONGINT "); LenList(obj, FALSE, TRUE)
				ELSIF (obj^.mode = VarPar) & (obj^.typ^.comp = Record) THEN
					EndStat; BegStat;
					OPM.WriteString("LONGINT *"); Ident(obj); OPM.WriteString(TagExt);
					base := NIL
				ELSIF ptrinit & (vis = 0) & (obj^.mnolev > 0) & (obj^.typ^.form = Pointer) THEN
					OPM.WriteString(" = NIL")
				ELSIF   (obj^.conval # NIL) & (obj^.conval^.arr # NIL)  THEN (* элементы конст.массива *)
					OPM.WriteString(" ="); OPM.WriteLn; OPM.WriteString("     {");
 
					FOR i := 0 TO obj^.conval^.intval-2 DO 
						OPM.WriteInt(obj^.conval^.arr(OPT.ConstArrayOfInt).val[i]);	
						OPM.WriteString(",");
						IF (i+1) MOD 10 = 0 THEN OPM.WriteLn; OPM.WriteString("      ") END;
					END;
					OPM.WriteInt( obj^.conval^.arr (OPT.ConstArrayOfInt) .val[obj^.conval^.intval-1]);	
					OPM.WriteString("}"); 
				END
			END;
			obj := obj^.link
		END;
		IF ~first THEN EndStat END
	END IdentList;

TYPE TheClocks = ARRAY 23 OF INTEGER;
CONST 	AnimClockData = TheClocks (00400, 00070, 00000,17, 00100, 00380, 00000,	00700, 03008, 00099, 100, 00170, 00010,12, 00103, 0030, 00300, 00400, 031, 00019,1,2,3);
	AnimClockData1 = TheClocks(00402, 00070, 00000,17, 00100, 00380, 00000,	00700, 03008, 00990,  100, 00170, 00010,12, 00103, 0030, 00300, 00400, 031, 00019,5,6,7);
 

typedef
	INTEGER Unsigned_TheClocks[23];
 
const Unsigned_TheClocks Unsigned_AnimClockData =
     {400,70,0,17,100,380,0,700,3008,99,
      100,170,10,12,103,30,300,400,31,19,
      1,2,3};
const Unsigned_TheClocks Unsigned_AnimClockData1 =
     {402,70,0,17,100,380,0,700,3008,990,
      100,170,10,12,103,30,300,400,31,19,
      5,6,7};

MODULE Unsigned; (*$MAIN*)
IMPORT SYSTEM, P := Platform, B := Basic;
 
TYPE TheClocks = ARRAY 23 OF INTEGER;
CONST 	AnimClockData = TheClocks (00400, 00070, 00000,17, 00100, 00380, 00000,	00700, 03008, 00099, 100, 00170, 00010,12, 00103, 0030, 00300, 00400, 031, 00019,1,2,3);
	AnimClockData1 = TheClocks(00402, 00070, 00000,17, 00100, 00380, 00000,	00700, 03008, 00990,  100, 00170, 00010,12, 00103, 0030, 00300, 00400, 031, 00019,5,6,7);
 
VAR
 
	i: INTEGER;
BEGIN
	i:= AnimClockData [1];
	B.PRWORD(i);
END Unsigned. 

/*  Ofront 1.2 -xtspkaem */
#include "SYSTEM.h"
#include "Basic.h"
#include "Platform.h"
 
typedef
	INTEGER Unsigned_TheClocks[23];
 
 
const Unsigned_TheClocks Unsigned_AnimClockData =
     {400,70,0,17,100,380,0,700,3008,99,
      100,170,10,12,103,30,300,400,31,19,
      1,2,3};
const Unsigned_TheClocks Unsigned_AnimClockData1 =
     {402,70,0,17,100,380,0,700,3008,990,
      100,170,10,12,103,30,300,400,31,19,
      5,6,7};
static INTEGER Unsigned_i;
 
 
 
 
/*============================================================================*/
 
 
export main(int argc, char **argv)
{
	__INIT(argc, argv);
	__IMPORT(Basic__init);
	__IMPORT(Platform__init);
	__REGMAIN("Unsigned", 0);
/* BEGIN */
	Unsigned_i = Unsigned_AnimClockData[1];
	Basic_PRWORD(Unsigned_i);
	__FINI;
}

AnimClockData1[2] := i;

	IF x^.obj^.typ^.BaseTyp^.form IN intSet THEN (* массив из целых, позднее добавим тип BYTE *)

	IF x^.obj^.typ^.BaseTyp^.form IN intSet THEN (* массив из целых (с типом BYTE, оказывается, тоже уже работает!) *)

PROCEDURE FlipBytes(VAR src, dest: ARRAY OF BYTE);
...
END FlipBytes;
`
PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
		VAR b: ARRAY 4 OF CHAR;
BEGIN FlipBytes(x, b); ...
(*              ^ x: REAL, но совместим с ARRAY OF BYTE! *)
(*                 ^ b: ARRAY OF CHAR, но совместим с ARRAY OF BYTE! *)
END WriteReal;

VAR a: BYTE; BEGIN
  a := 254 - 100H;
  a := 0FEX;