ace-dent/kolibrios-gitea
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Activity
a1909c89a2
kolibrios-gitea/programs/develop/oberon07/source/STATEMENTS.ob07
Anton Krotov a1909c89a2 oberon07: lower case by default 
git-svn-id: svn://kolibrios.org@9893 a494cfbc-eb01-0410-851d-a64ba20cac60
2023-01-21 14:34:25 +00:00

3438 lines
103 KiB
Plaintext
Raw Blame History

(*
BSD 2-Clause License
Copyright (c) 2018-2022, Anton Krotov
All rights reserved.
*)
MODULE STATEMENTS;
IMPORT
PARS, PROG, SCAN, ARITH, STRINGS, LISTS, IL, X86, AMD64, MSP430, THUMB, RVMxI,
ERRORS, UTILS, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, TARGETS;
CONST
eCONST = PARS.eCONST; eTYPE = PARS.eTYPE; eVAR = PARS.eVAR;
eEXPR = PARS.eEXPR; eVREC = PARS.eVREC; ePROC = PARS.ePROC;
eVPAR = PARS.eVPAR; ePARAM = PARS.ePARAM; eSTPROC = PARS.eSTPROC;
eSTFUNC = PARS.eSTFUNC; eSYSFUNC = PARS.eSYSFUNC; eSYSPROC = PARS.eSYSPROC;
eIMP = PARS.eIMP;
errASSERT = 1; errPTR = 2; errDIV = 3; errPROC = 4;
errGUARD = 5; errIDX = 6; errCASE = 7; errCOPY = 8;
errCHR = 9; errWCHR = 10; errBYTE = 11;
chkIDX* = 0; chkGUARD* = 1; chkPTR* = 2; chkCHR* = 3; chkWCHR* = 4; chkBYTE* = 5;
chkSTK* = MSP430.chkSTK; (* 6 *)
chkALL* = {chkIDX, chkGUARD, chkPTR, chkCHR, chkWCHR, chkBYTE, chkSTK};
TYPE
isXXX = PROCEDURE (e: PARS.EXPR): BOOLEAN;
RANGE = RECORD
a, b: INTEGER
END;
CASE_LABEL = POINTER TO rCASE_LABEL;
rCASE_LABEL = RECORD (AVL.DATA)
range: RANGE;
variant, self: INTEGER;
_type: PROG._TYPE;
prev: CASE_LABEL
END;
CASE_VARIANT = POINTER TO RECORD (LISTS.ITEM)
label: INTEGER;
cmd: IL.COMMAND;
processed: BOOLEAN
END;
VAR
Options: PROG.OPTIONS;
begcall, endcall: IL.COMMAND;
CaseLabels, CaseVar: C.COLLECTION;
CaseVariants: LISTS.LIST;
CPU: INTEGER;
tINTEGER, tBYTE, tCHAR, tWCHAR, tSET, tBOOLEAN, tREAL: PROG._TYPE;
PROCEDURE isExpr (e: PARS.EXPR): BOOLEAN;
RETURN e.obj IN {eCONST, eVAR, eEXPR, eVPAR, ePARAM, eVREC}
END isExpr;
PROCEDURE isVar (e: PARS.EXPR): BOOLEAN;
RETURN e.obj IN {eVAR, eVPAR, ePARAM, eVREC}
END isVar;
PROCEDURE isBoolean (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tBOOLEAN)
END isBoolean;
PROCEDURE isInteger (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tINTEGER)
END isInteger;
PROCEDURE isByte (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tBYTE)
END isByte;
PROCEDURE isInt (e: PARS.EXPR): BOOLEAN;
RETURN isByte(e) OR isInteger(e)
END isInt;
PROCEDURE isReal (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tREAL)
END isReal;
PROCEDURE isSet (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tSET)
END isSet;
PROCEDURE isString (e: PARS.EXPR): BOOLEAN;
RETURN (e.obj = eCONST) & (e._type.typ IN {PROG.tSTRING, PROG.tCHAR})
END isString;
PROCEDURE isStringW (e: PARS.EXPR): BOOLEAN;
RETURN (e.obj = eCONST) & (e._type.typ IN {PROG.tSTRING, PROG.tCHAR, PROG.tWCHAR})
END isStringW;
PROCEDURE isChar (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tCHAR)
END isChar;
PROCEDURE isCharW (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type = tWCHAR)
END isCharW;
PROCEDURE isPtr (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type.typ = PROG.tPOINTER)
END isPtr;
PROCEDURE isRec (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type.typ = PROG.tRECORD)
END isRec;
PROCEDURE isRecPtr (e: PARS.EXPR): BOOLEAN;
RETURN isRec(e) OR isPtr(e)
END isRecPtr;
PROCEDURE isArr (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type.typ = PROG.tARRAY)
END isArr;
PROCEDURE isProc (e: PARS.EXPR): BOOLEAN;
RETURN isExpr(e) & (e._type.typ = PROG.tPROCEDURE) OR (e.obj IN {ePROC, eIMP})
END isProc;
PROCEDURE isNil (e: PARS.EXPR): BOOLEAN;
RETURN e._type.typ = PROG.tNIL
END isNil;
PROCEDURE isCharArray (e: PARS.EXPR): BOOLEAN;
RETURN isArr(e) & (e._type.base = tCHAR)
END isCharArray;
PROCEDURE isCharArrayW (e: PARS.EXPR): BOOLEAN;
RETURN isArr(e) & (e._type.base = tWCHAR)
END isCharArrayW;
PROCEDURE isCharArrayX (e: PARS.EXPR): BOOLEAN;
RETURN isCharArray(e) OR isCharArrayW(e)
END isCharArrayX;
PROCEDURE getpos (parser: PARS.PARSER; VAR pos: PARS.POSITION);
BEGIN
pos.line := parser.lex.pos.line;
pos.col := parser.lex.pos.col;
pos.parser := parser
END getpos;
PROCEDURE NextPos (parser: PARS.PARSER; VAR pos: PARS.POSITION);
BEGIN
PARS.Next(parser);
getpos(parser, pos)
END NextPos;
PROCEDURE strlen (e: PARS.EXPR): INTEGER;
VAR
res: INTEGER;
BEGIN
ASSERT(isString(e));
IF e._type = tCHAR THEN
res := 1
ELSE
res := LENGTH(e.value.string(SCAN.STRING).s)
END
RETURN res
END strlen;
PROCEDURE _length (s: ARRAY OF CHAR): INTEGER;
VAR
i, res: INTEGER;
BEGIN
i := 0;
res := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
IF (s[i] <= CHR(127)) OR (s[i] >= CHR(192)) THEN
INC(res)
END;
INC(i)
END
RETURN res
END _length;
PROCEDURE utf8strlen (e: PARS.EXPR): INTEGER;
VAR
res: INTEGER;
BEGIN
ASSERT(isStringW(e));
IF e._type.typ IN {PROG.tCHAR, PROG.tWCHAR} THEN
res := 1
ELSE
res := _length(e.value.string(SCAN.STRING).s)
END
RETURN res
END utf8strlen;
PROCEDURE StrToWChar (s: ARRAY OF CHAR): INTEGER;
VAR
res: ARRAY 2 OF WCHAR;
BEGIN
ASSERT(STRINGS.Utf8To16(s, res) = 1)
RETURN ORD(res[0])
END StrToWChar;
PROCEDURE isStringW1 (e: PARS.EXPR): BOOLEAN;
RETURN isString(e) & (utf8strlen(e) = 1) & (strlen(e) > 1)
END isStringW1;
PROCEDURE assigncomp (e: PARS.EXPR; t: PROG._TYPE): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN
IF t = e._type THEN
res := TRUE
ELSIF isInt(e) & (t.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN
IF (e.obj = eCONST) & (t = tBYTE) THEN
res := ARITH.range(e.value, 0, 255)
ELSE
res := TRUE
END
ELSIF
(e.obj = eCONST) & isChar(e) & (t = tWCHAR)
OR isStringW1(e) & (t = tWCHAR)
OR PROG.isBaseOf(t, e._type)
OR ~PROG.isOpenArray(t) & ~PROG.isOpenArray(e._type) & PROG.isTypeEq(t, e._type)
OR isNil(e) & (t.typ IN {PROG.tPOINTER, PROG.tPROCEDURE})
OR PROG.arrcomp(e._type, t)
OR isString(e) & (t.typ = PROG.tARRAY) & (t.base = tCHAR) & (t.length > strlen(e))
OR isStringW(e) & (t.typ = PROG.tARRAY) & (t.base = tWCHAR) & (t.length > utf8strlen(e))
THEN
res := TRUE
ELSE
res := FALSE
END
ELSE
res := FALSE
END
RETURN res
END assigncomp;
PROCEDURE String (e: PARS.EXPR): INTEGER;
VAR
offset: INTEGER;
string: SCAN.STRING;
BEGIN
IF strlen(e) # 1 THEN
string := e.value.string(SCAN.STRING);
IF string.offset = -1 THEN
string.offset := IL.putstr(string.s);
END;
offset := string.offset
ELSE
offset := IL.putstr1(ARITH.Int(e.value))
END
RETURN offset
END String;
PROCEDURE StringW (e: PARS.EXPR): INTEGER;
VAR
offset: INTEGER;
string: SCAN.STRING;
BEGIN
IF utf8strlen(e) # 1 THEN
string := e.value.string(SCAN.STRING);
IF string.offsetW = -1 THEN
string.offsetW := IL.putstrW(string.s);
END;
offset := string.offsetW
ELSE
IF e._type.typ IN {PROG.tWCHAR, PROG.tCHAR} THEN
offset := IL.putstrW1(ARITH.Int(e.value))
ELSE (* e._type.typ = PROG.tSTRING *)
string := e.value.string(SCAN.STRING);
IF string.offsetW = -1 THEN
string.offsetW := IL.putstrW(string.s);
END;
offset := string.offsetW
END
END
RETURN offset
END StringW;
PROCEDURE CheckRange (range, line, errno: INTEGER);
VAR
label: INTEGER;
BEGIN
label := IL.NewLabel();
IL.AddCmd2(IL.opCHKIDX, label, range);
IL.OnError(line, errno);
IL.SetLabel(label)
END CheckRange;
PROCEDURE Float (parser: PARS.PARSER; e: PARS.EXPR);
VAR
pos: PARS.POSITION;
BEGIN
getpos(parser, pos);
IL.Float(ARITH.Float(e.value), pos.line, pos.col)
END Float;
PROCEDURE assign (parser: PARS.PARSER; e: PARS.EXPR; VarType: PROG._TYPE; line: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
label: INTEGER;
BEGIN
IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN
res := TRUE;
IF PROG.arrcomp(e._type, VarType) THEN
IF ~PROG.isOpenArray(VarType) THEN
IL.Const(VarType.length)
END;
IL.AddCmd(IL.opCOPYA, VarType.base.size);
label := IL.NewLabel();
IL.Jmp(IL.opJNZ, label);
IL.OnError(line, errCOPY);
IL.SetLabel(label)
ELSIF isInt(e) & (VarType.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN
IF VarType = tINTEGER THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE)
END
ELSE
IF e.obj = eCONST THEN
res := ARITH.range(e.value, 0, 255);
IF res THEN
IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value))
END
ELSE
IL.AddCmd0(IL.opSAVE8)
END
END
ELSIF isSet(e) & (VarType = tSET) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE)
END
ELSIF isBoolean(e) & (VarType = tBOOLEAN) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSBOOLC, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSBOOL)
END
ELSIF isReal(e) & (VarType = tREAL) THEN
IF e.obj = eCONST THEN
Float(parser, e)
END;
IL.savef(e.obj = eCONST)
ELSIF isChar(e) & (VarType = tCHAR) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVE8C, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE8)
END
ELSIF (e.obj = eCONST) & isChar(e) & (VarType = tWCHAR) THEN
IL.AddCmd(IL.opSAVE16C, ARITH.Int(e.value))
ELSIF isStringW1(e) & (VarType = tWCHAR) THEN
IL.AddCmd(IL.opSAVE16C, StrToWChar(e.value.string(SCAN.STRING).s))
ELSIF isCharW(e) & (VarType = tWCHAR) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVE16C, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE16)
END
ELSIF PROG.isBaseOf(VarType, e._type) THEN
IF VarType.typ = PROG.tPOINTER THEN
IL.AddCmd0(IL.opSAVE)
ELSE
IL.AddCmd(IL.opCOPY, VarType.size)
END
ELSIF (e._type.typ = PROG.tCARD32) & (VarType.typ = PROG.tCARD32) THEN
IL.AddCmd0(IL.opSAVE32)
ELSIF ~PROG.isOpenArray(VarType) & ~PROG.isOpenArray(e._type) & PROG.isTypeEq(VarType, e._type) THEN
IF e.obj = ePROC THEN
IL.AssignProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.AssignImpProc(e.ident._import)
ELSE
IF VarType.typ = PROG.tPROCEDURE THEN
IL.AddCmd0(IL.opSAVE)
ELSE
IL.AddCmd(IL.opCOPY, VarType.size)
END
END
ELSIF isNil(e) & (VarType.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN
IL.AddCmd(IL.opSAVEC, 0)
ELSIF isString(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base = tCHAR) & (VarType.length > strlen(e))) THEN
IL.saves(String(e), strlen(e) + 1)
ELSIF isStringW(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base = tWCHAR) & (VarType.length > utf8strlen(e))) THEN
IL.saves(StringW(e), (utf8strlen(e) + 1) * 2)
ELSE
res := FALSE
END
ELSE
res := FALSE
END
RETURN res
END assign;
PROCEDURE LoadConst (e: PARS.EXPR);
BEGIN
IL.Const(ARITH.Int(e.value))
END LoadConst;
PROCEDURE paramcomp (parser: PARS.PARSER; pos: PARS.POSITION; e: PARS.EXPR; p: PROG.PARAM);
VAR
stroffs: INTEGER;
PROCEDURE arrcomp (e: PARS.EXPR; p: PROG.PARAM): BOOLEAN;
VAR
t1, t2: PROG._TYPE;
BEGIN
t1 := p._type;
t2 := e._type;
WHILE (t2.typ = PROG.tARRAY) & PROG.isOpenArray(t1) DO
t1 := t1.base;
t2 := t2.base
END
RETURN PROG.isTypeEq(t1, t2)
END arrcomp;
PROCEDURE ArrLen (t: PROG._TYPE; n: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
REPEAT
res := t.length;
t := t.base;
DEC(n)
UNTIL (n < 0) OR (t.typ # PROG.tARRAY);
ASSERT(n < 0)
RETURN res
END ArrLen;
PROCEDURE OpenArray (t, t2: PROG._TYPE);
VAR
n, d1, d2: INTEGER;
BEGIN
IF t.length # 0 THEN
IL.Param1;
n := PROG.Dim(t2) - 1;
WHILE n >= 0 DO
IL.Const(ArrLen(t, n));
IL.Param1;
DEC(n)
END
ELSE
d1 := PROG.Dim(t);
d2 := PROG.Dim(t2);
IF d1 # d2 THEN
n := d2 - d1;
WHILE d2 > d1 DO
IL.Const(ArrLen(t, d2 - 1));
DEC(d2)
END;
d2 := PROG.Dim(t2);
WHILE n > 0 DO
IL.AddCmd(IL.opROT, d2);
DEC(n)
END
END;
IL.AddCmd(IL.opPARAM, PROG.Dim(t2) + 1)
END
END OpenArray;
BEGIN
IF p.vPar THEN
PARS.check(isVar(e), pos, 93);
IF p._type.typ = PROG.tRECORD THEN
PARS.check(PROG.isBaseOf(p._type, e._type), pos, 66);
IF e.obj = eVREC THEN
IF e.ident # NIL THEN
IL.AddCmd(IL.opVADR, e.ident.offset - 1)
ELSE
IL.AddCmd0(IL.opPUSHT)
END
ELSE
IL.Const(e._type.num)
END;
IL.AddCmd(IL.opPARAM, 2)
ELSIF PROG.isOpenArray(p._type) THEN
PARS.check(arrcomp(e, p), pos, 66);
OpenArray(e._type, p._type)
ELSE
PARS.check(PROG.isTypeEq(e._type, p._type), pos, 66);
IL.Param1
END;
PARS.check(~e.readOnly, pos, 94)
ELSE
PARS.check(isExpr(e) OR isProc(e), pos, 66);
IF PROG.isOpenArray(p._type) THEN
IF e._type.typ = PROG.tARRAY THEN
PARS.check(arrcomp(e, p), pos, 66);
OpenArray(e._type, p._type)
ELSIF isString(e) & (p._type.typ = PROG.tARRAY) & (p._type.base = tCHAR) THEN
IL.StrAdr(String(e));
IL.Param1;
IL.Const(strlen(e) + 1);
IL.Param1
ELSIF isStringW(e) & (p._type.typ = PROG.tARRAY) & (p._type.base = tWCHAR) THEN
IL.StrAdr(StringW(e));
IL.Param1;
IL.Const(utf8strlen(e) + 1);
IL.Param1
ELSE
PARS.error(pos, 66)
END
ELSE
PARS.check(~PROG.isOpenArray(e._type), pos, 66);
PARS.check(assigncomp(e, p._type), pos, 66);
IF e.obj = eCONST THEN
IF e._type = tREAL THEN
Float(parser, e);
IL.AddCmd0(IL.opPUSHF)
ELSIF e._type.typ = PROG.tNIL THEN
IL.Const(0);
IL.Param1
ELSIF isStringW1(e) & (p._type = tWCHAR) THEN
IL.Const(StrToWChar(e.value.string(SCAN.STRING).s));
IL.Param1
ELSIF (e._type.typ = PROG.tSTRING) OR
(e._type.typ IN {PROG.tCHAR, PROG.tWCHAR}) & (p._type.typ = PROG.tARRAY) & (p._type.base.typ IN {PROG.tCHAR, PROG.tWCHAR}) THEN
IF p._type.base = tCHAR THEN
stroffs := String(e);
IL.StrAdr(stroffs);
IF (CPU = TARGETS.cpuMSP430) & (p._type.size - strlen(e) - 1 > MSP430.IntVectorSize) THEN
ERRORS.WarningMsg(pos.line, pos.col, 0)
END
ELSE (* WCHAR *)
stroffs := StringW(e);
IL.StrAdr(stroffs)
END;
IL.set_dmin(stroffs + p._type.size);
IL.Param1
ELSE
LoadConst(e);
IL.Param1
END
ELSIF e.obj = ePROC THEN
PARS.check(e.ident.global, pos, 85);
IL.PushProc(e.ident.proc.label);
IL.Param1
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident._import);
IL.Param1
ELSIF isExpr(e) & (e._type = tREAL) THEN
IL.AddCmd0(IL.opPUSHF)
ELSE
IF (p._type = tBYTE) & (e._type = tINTEGER) & (chkBYTE IN Options.checking) THEN
CheckRange(256, pos.line, errBYTE)
END;
IL.Param1
END
END
END
END paramcomp;
PROCEDURE PExpression (parser: PARS.PARSER; VAR e: PARS.EXPR);
BEGIN
parser.expression(parser, e)
END PExpression;
PROCEDURE stProc (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
e1, e2: PARS.EXPR;
pos: PARS.POSITION;
proc,
label,
size,
n, i: INTEGER;
code: ARITH.VALUE;
wchar,
comma: BOOLEAN;
cmd1,
cmd2: IL.COMMAND;
PROCEDURE varparam (parser: PARS.PARSER; pos: PARS.POSITION; isfunc: isXXX; readOnly: BOOLEAN; VAR e: PARS.EXPR);
BEGIN
parser.designator(parser, e);
PARS.check(isVar(e), pos, 93);
PARS.check(isfunc(e), pos, 66);
IF readOnly THEN
PARS.check(~e.readOnly, pos, 94)
END
END varparam;
PROCEDURE shift_minmax (proc: INTEGER): CHAR;
VAR
res: CHAR;
BEGIN
CASE proc OF
|PROG.stASR: res := "A"
|PROG.stLSL: res := "L"
|PROG.stROR: res := "O"
|PROG.stLSR: res := "R"
|PROG.stMIN: res := "m"
|PROG.stMAX: res := "x"
END
RETURN res
END shift_minmax;
BEGIN
ASSERT(e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC});
proc := e.stproc;
(* IF (proc # PROG.sysNOP) & (proc # PROG.sysEINT) & (proc # PROG.sysDINT) THEN *)
PARS.checklex(parser, SCAN.lxLROUND);
PARS.Next(parser);
(* END; *)
getpos(parser, pos);
IF e.obj IN {eSTPROC, eSYSPROC} THEN
CASE proc OF
|PROG.stASSERT:
PExpression(parser, e);
PARS.check(isBoolean(e), pos, 66);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
IL.OnError(pos.line, errASSERT)
END
ELSE
label := IL.NewLabel();
IL.not;
IL.AndOrOpt(label);
IL.OnError(pos.line, errASSERT);
IL.SetLabel(label)
END
|PROG.stINC, PROG.stDEC:
IL.pushBegEnd(begcall, endcall);
varparam(parser, pos, isInt, TRUE, e);
IF e._type = tINTEGER THEN
IF parser.sym = SCAN.lxCOMMA THEN
NextPos(parser, pos);
IL.setlast(begcall);
PExpression(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(isInt(e2), pos, 66);
IF e2.obj = eCONST THEN
IL.AddCmd(IL.opINCC, ARITH.Int(e2.value) * (ORD(proc = PROG.stINC) * 2 - 1))
ELSE
IL.AddCmd0(IL.opINC + ORD(proc = PROG.stDEC))
END
ELSE
IL.AddCmd(IL.opINCC, ORD(proc = PROG.stINC) * 2 - 1)
END
ELSE (* e._type = tBYTE *)
IF parser.sym = SCAN.lxCOMMA THEN
NextPos(parser, pos);
IL.setlast(begcall);
PExpression(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(isInt(e2), pos, 66);
IF e2.obj = eCONST THEN
IL.AddCmd(IL.opINCCB + ORD(proc = PROG.stDEC), ARITH.Int(e2.value))
ELSE
IL.AddCmd0(IL.opINCB + ORD(proc = PROG.stDEC))
END
ELSE
IL.AddCmd(IL.opINCCB + ORD(proc = PROG.stDEC), 1)
END
END;
IL.popBegEnd(begcall, endcall)
|PROG.stINCL, PROG.stEXCL:
IL.pushBegEnd(begcall, endcall);
varparam(parser, pos, isSet, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
IL.setlast(begcall);
PExpression(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(isInt(e2), pos, 66);
IF e2.obj = eCONST THEN
PARS.check(ARITH.range(e2.value, 0, UTILS.target.maxSet), pos, 56);
IL.AddCmd(IL.opINCLC + ORD(proc = PROG.stEXCL), ARITH.Int(e2.value))
ELSE
IL.AddCmd0(IL.opINCL + ORD(proc = PROG.stEXCL))
END;
IL.popBegEnd(begcall, endcall)
|PROG.stNEW:
varparam(parser, pos, isPtr, TRUE, e);
IF CPU = TARGETS.cpuMSP430 THEN
PARS.check(e._type.base.size + 16 < Options.ram, pos, 63)
END;
IL.New(e._type.base.size, e._type.base.num)
|PROG.stDISPOSE:
varparam(parser, pos, isPtr, TRUE, e);
IL.AddCmd0(IL.opDISP)
|PROG.stPACK:
varparam(parser, pos, isReal, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
PExpression(parser, e2);
PARS.check(isInt(e2), pos, 66);
IF e2.obj = eCONST THEN
IL.AddCmd(IL.opPACKC, ARITH.Int(e2.value))
ELSE
IL.AddCmd0(IL.opPACK)
END
|PROG.stUNPK:
varparam(parser, pos, isReal, TRUE, e);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
varparam(parser, pos, isInteger, TRUE, e2);
IL.AddCmd0(IL.opUNPK)
|PROG.stCOPY:
IL.pushBegEnd(begcall, endcall);
PExpression(parser, e);
IF isString(e) OR isCharArray(e) THEN
wchar := FALSE
ELSIF isStringW(e) OR isCharArrayW(e) THEN
wchar := TRUE
ELSE
PARS.error(pos, 66)
END;
IF isCharArrayX(e) & ~PROG.isOpenArray(e._type) THEN
IL.Const(e._type.length)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
IL.setlast(begcall);
IF wchar THEN
varparam(parser, pos, isCharArrayW, TRUE, e1)
ELSE
IF e.obj = eCONST THEN
varparam(parser, pos, isCharArrayX, TRUE, e1)
ELSE
varparam(parser, pos, isCharArray, TRUE, e1)
END;
wchar := e1._type.base = tWCHAR
END;
IF ~PROG.isOpenArray(e1._type) THEN
IL.Const(e1._type.length)
END;
IL.setlast(endcall.prev(IL.COMMAND));
IF e.obj = eCONST THEN
IF wchar THEN
IL.StrAdr(StringW(e));
IL.Const(utf8strlen(e) + 1)
ELSE
IL.StrAdr(String(e));
IL.Const(strlen(e) + 1)
END
END;
IL.AddCmd(IL.opCOPYS, e1._type.base.size);
IL.popBegEnd(begcall, endcall)
|PROG.sysGET, PROG.sysGET8, PROG.sysGET16, PROG.sysGET32:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
parser.designator(parser, e2);
PARS.check(isVar(e2), pos, 93);
IF proc = PROG.sysGET THEN
PARS.check(e2._type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66)
ELSE
PARS.check(e2._type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66)
END;
CASE proc OF
|PROG.sysGET: size := e2._type.size
|PROG.sysGET8: size := 1
|PROG.sysGET16: size := 2
|PROG.sysGET32: size := 4
END;
PARS.check(size <= e2._type.size, pos, 66);
IF e.obj = eCONST THEN
IL.AddCmd2(IL.opGETC, ARITH.Int(e.value), size)
ELSE
IL.AddCmd(IL.opGET, size)
END
|PROG.sysPUT, PROG.sysPUT8, PROG.sysPUT16, PROG.sysPUT32:
IL.pushBegEnd(begcall, endcall);
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
IL.setlast(begcall);
PExpression(parser, e2);
PARS.check(isExpr(e2), pos, 66);
IF proc = PROG.sysPUT THEN
PARS.check(e2._type.typ IN PROG.BASICTYPES + {PROG.tPOINTER, PROG.tPROCEDURE}, pos, 66);
IF e2.obj = eCONST THEN
IF e2._type = tREAL THEN
Float(parser, e2);
IL.setlast(endcall.prev(IL.COMMAND));
IL.savef(FALSE)
ELSE
LoadConst(e2);
IL.setlast(endcall.prev(IL.COMMAND));
IL.SysPut(e2._type.size)
END
ELSE
IL.setlast(endcall.prev(IL.COMMAND));
IF e2._type = tREAL THEN
IL.savef(FALSE)
ELSIF e2._type = tBYTE THEN
IL.SysPut(tINTEGER.size)
ELSE
IL.SysPut(e2._type.size)
END
END
ELSIF (proc = PROG.sysPUT8) OR (proc = PROG.sysPUT16) OR (proc = PROG.sysPUT32) THEN
PARS.check(e2._type.typ IN {PROG.tINTEGER, PROG.tBYTE, PROG.tCHAR, PROG.tSET, PROG.tWCHAR, PROG.tCARD32}, pos, 66);
IF e2.obj = eCONST THEN
LoadConst(e2)
END;
IL.setlast(endcall.prev(IL.COMMAND));
CASE proc OF
|PROG.sysPUT8: size := 1
|PROG.sysPUT16: size := 2
|PROG.sysPUT32: size := 4
END;
IL.SysPut(size)
END;
IL.popBegEnd(begcall, endcall)
|PROG.sysMOVE:
FOR i := 1 TO 2 DO
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
LoadConst(e)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos)
END;
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
IL.AddCmd(IL.opCOPY, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opMOVE)
END
|PROG.sysCOPY:
FOR i := 1 TO 2 DO
parser.designator(parser, e);
PARS.check(isVar(e), pos, 93);
n := PROG.Dim(e._type);
WHILE n > 0 DO
IL.drop;
DEC(n)
END;
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos)
END;
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
IL.AddCmd(IL.opCOPY, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opMOVE)
END
|PROG.sysCODE:
REPEAT
getpos(parser, pos);
PARS.ConstExpression(parser, code);
PARS.check(code.typ = ARITH.tINTEGER, pos, 43);
IF TARGETS.WordSize > TARGETS.InstrSize THEN
CASE TARGETS.InstrSize OF
|1: PARS.check(ARITH.range(code, 0, 255), pos, 42)
|2: PARS.check(ARITH.range(code, 0, 65535), pos, 110)
END
END;
IL.AddCmd(IL.opCODE, ARITH.getInt(code));
comma := parser.sym = SCAN.lxCOMMA;
IF comma THEN
PARS.Next(parser)
ELSE
PARS.checklex(parser, SCAN.lxRROUND)
END
UNTIL (parser.sym = SCAN.lxRROUND) & ~comma
(*
|PROG.sysNOP, PROG.sysDINT, PROG.sysEINT:
IF parser.sym = SCAN.lxLROUND THEN
PARS.Next(parser);
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser)
END;
ASSERT(CPU = cpuMSP430);
CASE proc OF
|PROG.sysNOP: IL.AddCmd(IL.opCODE, 4303H)
|PROG.sysDINT: IL.AddCmd(IL.opCODE, 0C232H); IL.AddCmd(IL.opCODE, 4303H)
|PROG.sysEINT: IL.AddCmd(IL.opCODE, 0D232H)
END
*)
END;
e.obj := eEXPR;
e._type := NIL
ELSIF e.obj IN {eSTFUNC, eSYSFUNC} THEN
CASE e.stproc OF
|PROG.stABS:
PExpression(parser, e);
PARS.check(isInt(e) OR isReal(e), pos, 66);
IF e.obj = eCONST THEN
PARS.check(ARITH.abs(e.value), pos, 39)
ELSE
IL.abs(isReal(e))
END
|PROG.stASR, PROG.stLSL, PROG.stROR, PROG.stLSR, PROG.stMIN, PROG.stMAX:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
PARS.checklex(parser, SCAN.lxCOMMA);
NextPos(parser, pos);
PExpression(parser, e2);
PARS.check(isInt(e2), pos, 66);
e._type := tINTEGER;
IF (e.obj = eCONST) & (e2.obj = eCONST) THEN
ASSERT(ARITH.opInt(e.value, e2.value, shift_minmax(proc)))
ELSE
IF e.obj = eCONST THEN
IL.shift_minmax1(shift_minmax(proc), ARITH.Int(e.value))
ELSIF e2.obj = eCONST THEN
IL.shift_minmax2(shift_minmax(proc), ARITH.Int(e2.value))
ELSE
IL.shift_minmax(shift_minmax(proc))
END;
e.obj := eEXPR
END
|PROG.stCHR:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e._type := tCHAR;
IF e.obj = eCONST THEN
ARITH.setChar(e.value, ARITH.getInt(e.value));
PARS.check(ARITH.check(e.value), pos, 107)
ELSE
IF chkCHR IN Options.checking THEN
CheckRange(256, pos.line, errCHR)
ELSE
IL.AddCmd(IL.opMODR, 256)
END
END
|PROG.stWCHR:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e._type := tWCHAR;
IF e.obj = eCONST THEN
ARITH.setWChar(e.value, ARITH.getInt(e.value));
PARS.check(ARITH.check(e.value), pos, 101)
ELSE
IF chkWCHR IN Options.checking THEN
CheckRange(65536, pos.line, errWCHR)
ELSE
IL.AddCmd(IL.opMODR, 65536)
END
END
|PROG.stFLOOR:
PExpression(parser, e);
PARS.check(isReal(e), pos, 66);
e._type := tINTEGER;
IF e.obj = eCONST THEN
PARS.check(ARITH.floor(e.value), pos, 39)
ELSE
IL.AddCmd0(IL.opFLOOR)
END
|PROG.stFLT:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e._type := tREAL;
IF e.obj = eCONST THEN
ARITH.flt(e.value)
ELSE
IL.AddCmd2(IL.opFLT, pos.line, pos.col)
END
|PROG.stLEN:
cmd1 := IL.getlast();
varparam(parser, pos, isArr, FALSE, e);
IF e._type.length > 0 THEN
cmd2 := IL.getlast();
IL.delete2(cmd1.next, cmd2);
IL.setlast(cmd1);
ASSERT(ARITH.setInt(e.value, e._type.length));
e.obj := eCONST
ELSE
IL.len(PROG.Dim(e._type))
END;
e._type := tINTEGER
|PROG.stLENGTH:
PExpression(parser, e);
IF isCharArray(e) THEN
IF e._type.length > 0 THEN
IL.Const(e._type.length)
END;
IL.AddCmd0(IL.opLENGTH)
ELSIF isCharArrayW(e) THEN
IF e._type.length > 0 THEN
IL.Const(e._type.length)
END;
IL.AddCmd0(IL.opLENGTHW)
ELSE
PARS.error(pos, 66);
END;
e._type := tINTEGER
|PROG.stODD:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
e._type := tBOOLEAN;
IF e.obj = eCONST THEN
ARITH.odd(e.value)
ELSE
IL.AddCmd(IL.opMODR, 2)
END
|PROG.stORD:
IL.AddCmd(IL.opPRECALL, 0);
PExpression(parser, e);
PARS.check(isChar(e) OR isBoolean(e) OR isSet(e) OR isCharW(e) OR isStringW1(e), pos, 66);
IF e.obj = eCONST THEN
IF isStringW1(e) THEN
ASSERT(ARITH.setInt(e.value, StrToWChar(e.value.string(SCAN.STRING).s)))
ELSE
ARITH.ord(e.value)
END
ELSE
IF isBoolean(e) THEN
IL._ord
END
END;
e._type := tINTEGER
|PROG.stBITS:
PExpression(parser, e);
PARS.check(isInt(e), pos, 66);
IF e.obj = eCONST THEN
ARITH.bits(e.value)
END;
e._type := tSET
|PROG.sysADR:
parser.designator(parser, e);
IF isVar(e) THEN
n := PROG.Dim(e._type);
WHILE n > 0 DO
IL.drop;
DEC(n)
END
ELSIF e.obj = ePROC THEN
IL.PushProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident._import)
ELSE
PARS.error(pos, 108)
END;
e._type := tINTEGER
|PROG.sysSADR:
PExpression(parser, e);
PARS.check(isString(e), pos, 66);
IL.StrAdr(String(e));
e._type := tINTEGER;
e.obj := eEXPR
|PROG.sysWSADR:
PExpression(parser, e);
PARS.check(isStringW(e), pos, 66);
IL.StrAdr(StringW(e));
e._type := tINTEGER;
e.obj := eEXPR
|PROG.sysTYPEID:
PExpression(parser, e);
PARS.check(e.obj = eTYPE, pos, 68);
IF e._type.typ = PROG.tRECORD THEN
ASSERT(ARITH.setInt(e.value, e._type.num))
ELSIF e._type.typ = PROG.tPOINTER THEN
ASSERT(ARITH.setInt(e.value, e._type.base.num))
ELSE
PARS.error(pos, 52)
END;
e.obj := eCONST;
e._type := tINTEGER
|PROG.sysINF:
IL.AddCmd2(IL.opINF, pos.line, pos.col);
e.obj := eEXPR;
e._type := tREAL
|PROG.sysSIZE:
PExpression(parser, e);
PARS.check(e.obj = eTYPE, pos, 68);
ASSERT(ARITH.setInt(e.value, e._type.size));
e.obj := eCONST;
e._type := tINTEGER
END
END;
(* IF (proc # PROG.sysNOP) & (proc # PROG.sysEINT) & (proc # PROG.sysDINT) THEN *)
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser);
(* END; *)
IF e.obj # eCONST THEN
e.obj := eEXPR
END
END stProc;
PROCEDURE ActualParameters (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
proc: PROG._TYPE;
param: LISTS.ITEM;
e1: PARS.EXPR;
pos: PARS.POSITION;
BEGIN
ASSERT(parser.sym = SCAN.lxLROUND);
IF (e.obj IN {ePROC, eIMP}) OR isExpr(e) THEN
proc := e._type;
PARS.check1(proc.typ = PROG.tPROCEDURE, parser, 86);
PARS.Next(parser);
param := proc.params.first;
WHILE param # NIL DO
getpos(parser, pos);
IL.setlast(begcall);
IF param(PROG.PARAM).vPar THEN
parser.designator(parser, e1)
ELSE
PExpression(parser, e1)
END;
paramcomp(parser, pos, e1, param(PROG.PARAM));
param := param.next;
IF param # NIL THEN
PARS.checklex(parser, SCAN.lxCOMMA);
PARS.Next(parser)
END
END;
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser);
e.obj := eEXPR;
e._type := proc.base
ELSIF e.obj IN {eSTPROC, eSTFUNC, eSYSPROC, eSYSFUNC} THEN
stProc(parser, e)
ELSE
PARS.check1(FALSE, parser, 86)
END
END ActualParameters;
PROCEDURE qualident (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
ident: PROG.IDENT;
imp: BOOLEAN;
pos: PARS.POSITION;
BEGIN
PARS.checklex(parser, SCAN.lxIDENT);
getpos(parser, pos);
imp := FALSE;
ident := PROG.getIdent(parser.unit, parser.lex.ident, FALSE);
PARS.check1(ident # NIL, parser, 48);
IF ident.typ = PROG.idMODULE THEN
PARS.ExpectSym(parser, SCAN.lxPOINT);
PARS.ExpectSym(parser, SCAN.lxIDENT);
ident := PROG.getIdent(ident.unit, parser.lex.ident, FALSE);
PARS.check1((ident # NIL) & ident.export, parser, 48);
imp := TRUE
END;
PARS.Next(parser);
e.readOnly := FALSE;
e.ident := ident;
CASE ident.typ OF
|PROG.idCONST:
e.obj := eCONST;
e._type := ident._type;
e.value := ident.value
|PROG.idTYPE:
e.obj := eTYPE;
e._type := ident._type
|PROG.idVAR:
e.obj := eVAR;
e._type := ident._type;
e.readOnly := imp
|PROG.idPROC:
e.obj := ePROC;
e._type := ident._type
|PROG.idIMP:
e.obj := eIMP;
e._type := ident._type
|PROG.idVPAR:
e._type := ident._type;
IF e._type.typ = PROG.tRECORD THEN
e.obj := eVREC
ELSE
e.obj := eVPAR
END
|PROG.idPARAM:
e.obj := ePARAM;
e._type := ident._type;
e.readOnly := (e._type.typ IN {PROG.tRECORD, PROG.tARRAY})
|PROG.idSTPROC:
e.obj := eSTPROC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSTFUNC:
e.obj := eSTFUNC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSYSPROC:
e.obj := eSYSPROC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idSYSFUNC:
PARS.check(~parser.constexp, pos, 109);
e.obj := eSYSFUNC;
e._type := ident._type;
e.stproc := ident.stproc
|PROG.idNONE:
PARS.error(pos, 115)
END;
IF isVar(e) THEN
PARS.check(e.ident.global OR (e.ident.scopeLvl = parser.unit.scopeLvl), pos, 105)
END
END qualident;
PROCEDURE deref (pos: PARS.POSITION; e: PARS.EXPR; load: BOOLEAN; error: INTEGER);
VAR
label: INTEGER;
BEGIN
IF load THEN
IL.load(e._type.size)
END;
IF chkPTR IN Options.checking THEN
label := IL.NewLabel();
IL.Jmp(IL.opJNZ1, label);
IL.OnError(pos.line, error);
IL.SetLabel(label)
END
END deref;
PROCEDURE designator (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
field: PROG.FIELD;
pos: PARS.POSITION;
t, idx: PARS.EXPR;
sysVal: BOOLEAN;
n: INTEGER;
PROCEDURE LoadAdr (e: PARS.EXPR);
VAR
offset: INTEGER;
PROCEDURE OpenArray (e: PARS.EXPR);
VAR
offset, n: INTEGER;
BEGIN
offset := e.ident.offset;
n := PROG.Dim(e._type);
WHILE n >= 0 DO
IL.AddCmd(IL.opVADR, offset);
DEC(offset);
DEC(n)
END
END OpenArray;
BEGIN
IF e.obj = eVAR THEN
offset := PROG.getOffset(e.ident);
IF e.ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
IL.AddCmd(IL.opLADR, -offset)
END
ELSIF e.obj = ePARAM THEN
IF (e._type.typ = PROG.tRECORD) OR ((e._type.typ = PROG.tARRAY) & (e._type.length > 0)) THEN
IL.AddCmd(IL.opVADR, e.ident.offset)
ELSIF PROG.isOpenArray(e._type) THEN
OpenArray(e)
ELSE
IL.AddCmd(IL.opLADR, e.ident.offset)
END
ELSIF e.obj IN {eVPAR, eVREC} THEN
IF PROG.isOpenArray(e._type) THEN
OpenArray(e)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset)
END
END
END LoadAdr;
PROCEDURE OpenIdx (parser: PARS.PARSER; pos: PARS.POSITION; e: PARS.EXPR);
VAR
label, offset, n, k: INTEGER;
_type: PROG._TYPE;
BEGIN
IF chkIDX IN Options.checking THEN
label := IL.NewLabel();
IL.AddCmd2(IL.opCHKIDX2, label, 0);
IL.OnError(pos.line, errIDX);
IL.SetLabel(label)
ELSE
IL.AddCmd(IL.opCHKIDX2, -1)
END;
_type := PROG.OpenBase(e._type);
IF _type.size # 1 THEN
IL.AddCmd(IL.opMULC, _type.size)
END;
n := PROG.Dim(e._type) - 1;
k := n;
WHILE n > 0 DO
IL.AddCmd0(IL.opMUL);
DEC(n)
END;
IL.AddCmd0(IL.opADD);
offset := e.ident.offset - 1;
n := k;
WHILE n > 0 DO
IL.AddCmd(IL.opVADR, offset);
DEC(offset);
DEC(n)
END
END OpenIdx;
BEGIN
qualident(parser, e);
sysVal := (e.obj = eSYSPROC) & (e.stproc = PROG.sysVAL);
IF sysVal THEN
PARS.checklex(parser, SCAN.lxLROUND);
PARS.Next(parser);
getpos(parser, pos);
designator(parser, e);
PARS.check(isVar(e), pos, 93);
IF PROG.isOpenArray(e._type) THEN
n := PROG.Dim(e._type);
WHILE n > 0 DO
IL.drop;
DEC(n)
END
END;
PARS.checklex(parser, SCAN.lxCOMMA);
PARS.Next(parser);
getpos(parser, pos);
qualident(parser, t);
PARS.check(t.obj = eTYPE, pos, 79);
e._type := t._type;
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser)
END;
IF e.obj IN {ePROC, eIMP} THEN
PROG.UseProc(parser.unit, e.ident.proc)
END;
IF isVar(e) & ~sysVal THEN
LoadAdr(e)
END;
WHILE parser.sym = SCAN.lxPOINT DO
getpos(parser, pos);
PARS.check1(isExpr(e) & (e._type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, 73);
IF e._type.typ = PROG.tPOINTER THEN
deref(pos, e, TRUE, errPTR)
END;
PARS.ExpectSym(parser, SCAN.lxIDENT);
IF e._type.typ = PROG.tPOINTER THEN
e._type := e._type.base;
e.readOnly := FALSE
END;
field := PROG.getField(e._type, parser.lex.ident, parser.unit);
PARS.check1(field # NIL, parser, 74);
e._type := field._type;
IF e.obj = eVREC THEN
e.obj := eVPAR
END;
IF field.offset # 0 THEN
IL.AddCmd(IL.opADDC, field.offset)
END;
PARS.Next(parser);
e.ident := NIL
ELSIF parser.sym = SCAN.lxLSQUARE DO
REPEAT
PARS.check1(isArr(e), parser, 75);
NextPos(parser, pos);
PExpression(parser, idx);
PARS.check(isInt(idx), pos, 76);
IF idx.obj = eCONST THEN
IF e._type.length > 0 THEN
PARS.check(ARITH.range(idx.value, 0, e._type.length - 1), pos, 83);
IF ARITH.Int(idx.value) > 0 THEN
IL.AddCmd(IL.opADDC, ARITH.Int(idx.value) * e._type.base.size)
END
ELSE
PARS.check(ARITH.range(idx.value, 0, UTILS.target.maxInt), pos, 83);
LoadConst(idx);
OpenIdx(parser, pos, e)
END
ELSE
IF e._type.length > 0 THEN
IF chkIDX IN Options.checking THEN
CheckRange(e._type.length, pos.line, errIDX)
END;
IF e._type.base.size # 1 THEN
IL.AddCmd(IL.opMULC, e._type.base.size)
END;
IL.AddCmd0(IL.opADD)
ELSE
OpenIdx(parser, pos, e)
END
END;
e._type := e._type.base
UNTIL parser.sym # SCAN.lxCOMMA;
PARS.checklex(parser, SCAN.lxRSQUARE);
PARS.Next(parser);
IF ~(isArr(e) & (e._type.length = 0) & (parser.sym = SCAN.lxLSQUARE)) THEN
e.ident := NIL
END
ELSIF parser.sym = SCAN.lxCARET DO
getpos(parser, pos);
PARS.check1(isPtr(e), parser, 77);
deref(pos, e, TRUE, errPTR);
e._type := e._type.base;
e.readOnly := FALSE;
PARS.Next(parser);
e.ident := NIL;
e.obj := eVREC
ELSIF (parser.sym = SCAN.lxLROUND) & isExpr(e) & (e._type.typ IN {PROG.tRECORD, PROG.tPOINTER}) DO
IF e._type.typ = PROG.tRECORD THEN
PARS.check1(e.obj = eVREC, parser, 78)
END;
NextPos(parser, pos);
qualident(parser, t);
PARS.check(t.obj = eTYPE, pos, 79);
IF e._type.typ = PROG.tRECORD THEN
PARS.check(t._type.typ = PROG.tRECORD, pos, 80);
IF chkGUARD IN Options.checking THEN
IF e.ident = NIL THEN
IL.TypeGuard(IL.opTYPEGD, t._type.num, pos.line, errGUARD)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset - 1);
IL.TypeGuard(IL.opTYPEGR, t._type.num, pos.line, errGUARD)
END
END;
ELSE
PARS.check(t._type.typ = PROG.tPOINTER, pos, 81);
IF chkGUARD IN Options.checking THEN
IL.TypeGuard(IL.opTYPEGP, t._type.base.num, pos.line, errGUARD)
END
END;
PARS.check(PROG.isBaseOf(e._type, t._type), pos, 82);
e._type := t._type;
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser)
END
END designator;
PROCEDURE ProcCall (e: PARS.EXPR; procType: PROG._TYPE; isfloat: BOOLEAN; parser: PARS.PARSER; pos: PARS.POSITION; CallStat: BOOLEAN);
VAR
cconv,
parSize,
callconv,
fparSize,
int, flt,
stk_par: INTEGER;
BEGIN
cconv := procType.call;
parSize := procType.parSize;
IF cconv IN {PROG._win64, PROG.win64} THEN
callconv := IL.call_win64;
fparSize := LSL(ORD(PROG.getFloatParamsPos(procType, 3, int, flt)), 5) + MIN(parSize, 4)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
callconv := IL.call_sysv;
fparSize := LSL(ORD(PROG.getFloatParamsPos(procType, PROG.MAXSYSVPARAM - 1, int, flt)), 5) + parSize;
stk_par := MAX(0, int - 6) + MAX(0, flt - 8)
ELSIF cconv IN {PROG.fastcall, PROG._fastcall} THEN
IF parSize = 0 THEN
callconv := IL.call_stack
ELSIF parSize = 1 THEN
callconv := IL.call_fast1
ELSIF parSize >= 2 THEN
callconv := IL.call_fast2
END;
fparSize := 0
ELSE
callconv := IL.call_stack;
fparSize := 0
END;
IL.setlast(begcall);
IL.AddCmd(IL.opPRECALL, ORD(isfloat));
IF cconv IN {PROG._ccall, PROG.ccall} THEN
IL.AddCmd(IL.opALIGN16, parSize)
ELSIF cconv IN {PROG._win64, PROG.win64} THEN
IL.AddCmd(IL.opWIN64ALIGN16, parSize)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
IL.AddCmd(IL.opSYSVALIGN16, parSize + stk_par)
END;
IL.setlast(endcall.prev(IL.COMMAND));
IF e.obj = eIMP THEN
IL.CallImp(e.ident._import, callconv, fparSize)
ELSIF e.obj = ePROC THEN
IL.Call(e.ident.proc.label, callconv, fparSize)
ELSIF isExpr(e) THEN
deref(pos, e, CallStat, errPROC);
IL.CallP(callconv, fparSize)
END;
IF cconv IN {PROG._ccall, PROG.ccall} THEN
IL.AddCmd(IL.opCLEANUP, parSize);
IL.AddCmd0(IL.opPOPSP)
ELSIF cconv IN {PROG._win64, PROG.win64} THEN
IL.AddCmd(IL.opCLEANUP, MAX(parSize + parSize MOD 2, 4) + 1);
IL.AddCmd0(IL.opPOPSP)
ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN
IL.AddCmd(IL.opCLEANUP, parSize + stk_par);
IL.AddCmd0(IL.opPOPSP)
ELSIF cconv IN {PROG._cdecl, PROG.cdecl, PROG.default16, PROG.code, PROG._code} THEN
IL.AddCmd(IL.opCLEANUP, parSize)
END;
IF CallStat THEN
IL.AddCmd0(IL.opRES);
IL.drop
ELSE
IF isfloat THEN
IL.AddCmd2(IL.opRESF, pos.line, pos.col)
ELSE
IL.AddCmd0(IL.opRES)
END
END
END ProcCall;
PROCEDURE expression (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos, pos0, pos1: PARS.POSITION;
e1: PARS.EXPR;
op, cmp, error: INTEGER;
constant, eq: BOOLEAN;
PROCEDURE relation (sym: INTEGER): BOOLEAN;
RETURN (sym = SCAN.lxEQ) OR (sym = SCAN.lxNE) OR
(sym = SCAN.lxLT) OR (sym = SCAN.lxLE) OR
(sym = SCAN.lxGT) OR (sym = SCAN.lxGE) OR
(sym = SCAN.lxIN) OR (sym = SCAN.lxIS)
END relation;
PROCEDURE AddOperator (sym: INTEGER): BOOLEAN;
RETURN (sym = SCAN.lxPLUS) OR (sym = SCAN.lxMINUS) OR
(sym = SCAN.lxOR)
END AddOperator;
PROCEDURE MulOperator (sym: INTEGER): BOOLEAN;
RETURN (sym = SCAN.lxMUL) OR (sym = SCAN.lxSLASH) OR
(sym = SCAN.lxDIV) OR (sym = SCAN.lxMOD) OR
(sym = SCAN.lxAND)
END MulOperator;
PROCEDURE element (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
e1, e2: PARS.EXPR;
pos: PARS.POSITION;
range: BOOLEAN;
BEGIN
range := FALSE;
getpos(parser, pos);
expression(parser, e1);
PARS.check(isInt(e1), pos, 76);
IF e1.obj = eCONST THEN
PARS.check(ARITH.range(e1.value, 0, UTILS.target.maxSet), pos, 44)
END;
range := parser.sym = SCAN.lxRANGE;
IF range THEN
NextPos(parser, pos);
expression(parser, e2);
PARS.check(isInt(e2), pos, 76);
IF e2.obj = eCONST THEN
PARS.check(ARITH.range(e2.value, 0, UTILS.target.maxSet), pos, 44)
END
ELSE
IF e1.obj = eCONST THEN
e2 := e1
END
END;
e._type := tSET;
IF (e1.obj = eCONST) & (e2.obj = eCONST) THEN
ARITH.constrSet(e.value, e1.value, e2.value);
e.obj := eCONST
ELSE
IF range THEN
IF e1.obj = eCONST THEN
IL.AddCmd(IL.opRSETL, ARITH.Int(e1.value))
ELSIF e2.obj = eCONST THEN
IL.AddCmd(IL.opRSETR, ARITH.Int(e2.value))
ELSE
IL.AddCmd0(IL.opRSET)
END
ELSE
IL.AddCmd0(IL.opRSET1)
END;
e.obj := eEXPR
END
END element;
PROCEDURE set (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
e1: PARS.EXPR;
BEGIN
ASSERT(parser.sym = SCAN.lxLCURLY);
e.obj := eCONST;
e._type := tSET;
ARITH.emptySet(e.value);
PARS.Next(parser);
IF parser.sym # SCAN.lxRCURLY THEN
element(parser, e1);
IF e1.obj = eCONST THEN
ARITH.opSet(e.value, e1.value, "+")
ELSE
e.obj := eEXPR
END;
WHILE parser.sym = SCAN.lxCOMMA DO
PARS.Next(parser);
element(parser, e1);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
ARITH.opSet(e.value, e1.value, "+")
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDSC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADDS)
END;
e.obj := eEXPR
END
END;
PARS.checklex(parser, SCAN.lxRCURLY)
END;
PARS.Next(parser);
END set;
PROCEDURE factor (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
sym: INTEGER;
pos: PARS.POSITION;
e1: PARS.EXPR;
isfloat: BOOLEAN;
PROCEDURE LoadVar (e: PARS.EXPR; parser: PARS.PARSER; pos: PARS.POSITION);
BEGIN
IF ~(e._type.typ IN {PROG.tRECORD, PROG.tARRAY}) THEN
IF e._type = tREAL THEN
IL.AddCmd2(IL.opLOADF, pos.line, pos.col)
ELSE
IL.load(e._type.size)
END
END
END LoadVar;
BEGIN
sym := parser.sym;
IF (sym = SCAN.lxINTEGER) OR (sym = SCAN.lxHEX) OR (sym = SCAN.lxFLOAT) OR (sym = SCAN.lxCHAR) OR (sym = SCAN.lxSTRING) THEN
e.obj := eCONST;
e.value := parser.lex.value;
e._type := PROG.getType(e.value.typ);
PARS.Next(parser)
ELSIF sym = SCAN.lxNIL THEN
e.obj := eCONST;
e._type := PROG.program.stTypes.tNIL;
PARS.Next(parser)
ELSIF (sym = SCAN.lxTRUE) OR (sym = SCAN.lxFALSE) THEN
e.obj := eCONST;
ARITH.setbool(e.value, sym = SCAN.lxTRUE);
e._type := tBOOLEAN;
PARS.Next(parser)
ELSIF sym = SCAN.lxLCURLY THEN
set(parser, e)
ELSIF sym = SCAN.lxIDENT THEN
getpos(parser, pos);
IL.pushBegEnd(begcall, endcall);
designator(parser, e);
IF isVar(e) THEN
LoadVar(e, parser, pos)
END;
IF parser.sym = SCAN.lxLROUND THEN
e1 := e;
ActualParameters(parser, e);
PARS.check(e._type # NIL, pos, 59);
isfloat := e._type = tREAL;
IF e1.obj IN {ePROC, eIMP} THEN
ProcCall(e1, e1.ident._type, isfloat, parser, pos, FALSE)
ELSIF isExpr(e1) THEN
ProcCall(e1, e1._type, isfloat, parser, pos, FALSE)
END
END;
IL.popBegEnd(begcall, endcall)
ELSIF sym = SCAN.lxLROUND THEN
PARS.Next(parser);
expression(parser, e);
PARS.checklex(parser, SCAN.lxRROUND);
PARS.Next(parser);
IF isExpr(e) & (e.obj # eCONST) THEN
e.obj := eEXPR
END
ELSIF sym = SCAN.lxNOT THEN
NextPos(parser, pos);
factor(parser, e);
PARS.check(isBoolean(e), pos, 72);
IF e.obj # eCONST THEN
IL.not;
e.obj := eEXPR
ELSE
ASSERT(ARITH.neg(e.value))
END
ELSE
PARS.check1(FALSE, parser, 34)
END
END factor;
PROCEDURE term (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos: PARS.POSITION;
e1: PARS.EXPR;
op, label, label1: INTEGER;
BEGIN
factor(parser, e);
label := -1;
WHILE MulOperator(parser.sym) DO
op := parser.sym;
getpos(parser, pos);
PARS.Next(parser);
IF op = SCAN.lxAND THEN
IF ~parser.constexp THEN
IF label = -1 THEN
label := IL.NewLabel()
END;
IF (e.obj = eCONST) & isBoolean(e) THEN
IL.Const(ORD(ARITH.getBool(e.value)))
END;
IL.Jmp(IL.opJZ, label)
END
END;
factor(parser, e1);
CASE op OF
|SCAN.lxMUL:
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
CASE e.value.typ OF
|ARITH.tINTEGER: PARS.check(ARITH.opInt(e.value, e1.value, "*"), pos, 39)
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "*"), pos, 40)
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "*")
END
ELSE
IF isInt(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opMULC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opMULC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opMUL)
END
ELSIF isReal(e) THEN
IF e.obj = eCONST THEN
Float(parser, e)
ELSIF e1.obj = eCONST THEN
Float(parser, e1)
END;
IL.AddCmd0(IL.opMULF)
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opMULSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opMULSC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opMULS)
END
END;
e.obj := eEXPR
END
|SCAN.lxSLASH:
PARS.check(isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), pos, 37);
IF (e1.obj = eCONST) & isReal(e1) THEN
PARS.check(~ARITH.isZero(e1.value), pos, 45)
END;
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
CASE e.value.typ OF
|ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "/"), pos, 40)
|ARITH.tSET: ARITH.opSet(e.value, e1.value, "/")
END
ELSE
IF isReal(e) THEN
IF e.obj = eCONST THEN
Float(parser, e);
IL.AddCmd0(IL.opDIVFI)
ELSIF e1.obj = eCONST THEN
Float(parser, e1);
IL.AddCmd0(IL.opDIVF)
ELSE
IL.AddCmd0(IL.opDIVF)
END
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opDIVSC, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opDIVSC, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opDIVS)
END
END;
e.obj := eEXPR
END
|SCAN.lxDIV, SCAN.lxMOD:
PARS.check(isInt(e) & isInt(e1), pos, 37);
IF e1.obj = eCONST THEN
PARS.check(ARITH.Int(e1.value) > 0, pos, 122)
END;
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
IF op = SCAN.lxDIV THEN
PARS.check(ARITH.opInt(e.value, e1.value, "D"), pos, 39)
ELSE
ASSERT(ARITH.opInt(e.value, e1.value, "M"))
END
ELSE
IF e1.obj # eCONST THEN
label1 := IL.NewLabel();
IL.Jmp(IL.opJG, label1)
END;
IF e.obj = eCONST THEN
IL.OnError(pos.line, errDIV);
IL.SetLabel(label1);
IL.AddCmd(IL.opDIVL + ORD(op = SCAN.lxMOD), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opDIVR + ORD(op = SCAN.lxMOD), ARITH.Int(e1.value))
ELSE
IL.OnError(pos.line, errDIV);
IL.SetLabel(label1);
IL.AddCmd0(IL.opDIV + ORD(op = SCAN.lxMOD))
END;
e.obj := eEXPR
END
|SCAN.lxAND:
PARS.check(isBoolean(e) & isBoolean(e1), pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) & parser.constexp THEN
ARITH.opBoolean(e.value, e1.value, "&")
ELSE
e.obj := eEXPR;
IF e1.obj = eCONST THEN
IL.Const(ORD(ARITH.getBool(e1.value)))
END
END
END
END;
IF label # -1 THEN
label1 := IL.NewLabel();
IL.Jmp(IL.opJNZ, label1);
IL.SetLabel(label);
IL.Const(0);
IL.drop;
label := IL.NewLabel();
IL.Jmp(IL.opJMP, label);
IL.SetLabel(label1);
IL.Const(1);
IL.SetLabel(label);
IL.AddCmd0(IL.opAND)
END
END term;
PROCEDURE SimpleExpression (parser: PARS.PARSER; VAR e: PARS.EXPR);
VAR
pos: PARS.POSITION;
op: INTEGER;
e1: PARS.EXPR;
s, s1: SCAN.TEXTSTR;
plus, minus: BOOLEAN;
label, label1: INTEGER;
BEGIN
plus := parser.sym = SCAN.lxPLUS;
minus := parser.sym = SCAN.lxMINUS;
IF plus OR minus THEN
getpos(parser, pos);
PARS.Next(parser)
END;
term(parser, e);
IF plus OR minus THEN
PARS.check(isInt(e) OR isReal(e) OR isSet(e), pos, 36);
IF minus & (e.obj = eCONST) THEN
PARS.check(ARITH.neg(e.value), pos, 39)
END;
IF e.obj # eCONST THEN
IF minus THEN
IF isInt(e) THEN
IL.AddCmd0(IL.opUMINUS)
ELSIF isReal(e) THEN
IL.AddCmd0(IL.opUMINF)
ELSIF isSet(e) THEN
IL.AddCmd0(IL.opUMINS)
END
END;
e.obj := eEXPR
END
END;
label := -1;
WHILE AddOperator(parser.sym) DO
op := parser.sym;
getpos(parser, pos);
PARS.Next(parser);
IF op = SCAN.lxOR THEN
IF ~parser.constexp THEN
IF label = -1 THEN
label := IL.NewLabel()
END;
IF (e.obj = eCONST) & isBoolean(e) THEN
IL.Const(ORD(ARITH.getBool(e.value)))
END;
IL.Jmp(IL.opJNZ, label)
END
END;
term(parser, e1);
CASE op OF
|SCAN.lxPLUS, SCAN.lxMINUS:
minus := op = SCAN.lxMINUS;
IF minus THEN
op := ORD("-")
ELSE
op := ORD("+")
END;
PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1) OR isString(e) & isString(e1) & ~minus, pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) THEN
CASE e.value.typ OF
|ARITH.tINTEGER:
PARS.check(ARITH.opInt(e.value, e1.value, CHR(op)), pos, 39)
|ARITH.tREAL:
PARS.check(ARITH.opFloat(e.value, e1.value, CHR(op)), pos, 40)
|ARITH.tSET:
ARITH.opSet(e.value, e1.value, CHR(op))
|ARITH.tCHAR, ARITH.tSTRING:
IF e.value.typ = ARITH.tCHAR THEN
ARITH.charToStr(e.value, s)
ELSE
s := e.value.string(SCAN.STRING).s
END;
IF e1.value.typ = ARITH.tCHAR THEN
ARITH.charToStr(e1.value, s1)
ELSE
s1 := e1.value.string(SCAN.STRING).s
END;
PARS.check(ARITH.concat(s, s1), pos, 5);
e.value.string := SCAN.enterStr(s);
e.value.typ := ARITH.tSTRING;
e._type := PROG.program.stTypes.tSTRING
END
ELSE
IF isInt(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDC - ORD(minus), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDC + ORD(minus), ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADD + ORD(minus))
END
ELSIF isReal(e) THEN
IF e.obj = eCONST THEN
Float(parser, e);
IL.AddCmd0(IL.opADDF - ORD(minus))
ELSIF e1.obj = eCONST THEN
Float(parser, e1);
IL.AddCmd0(IL.opADDF + ORD(minus))
ELSE
IL.AddCmd0(IL.opADDF + ORD(minus))
END
ELSIF isSet(e) THEN
IF e.obj = eCONST THEN
IL.AddCmd(IL.opADDSC - ORD(minus), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opADDSC + ORD(minus), ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opADDS + ORD(minus))
END
END;
e.obj := eEXPR
END
|SCAN.lxOR:
PARS.check(isBoolean(e) & isBoolean(e1), pos, 37);
IF (e.obj = eCONST) & (e1.obj = eCONST) & parser.constexp THEN
ARITH.opBoolean(e.value, e1.value, "|")
ELSE
e.obj := eEXPR;
IF e1.obj = eCONST THEN
IL.Const(ORD(ARITH.getBool(e1.value)))
END
END
END
END;
IF label # -1 THEN
label1 := IL.NewLabel();
IL.Jmp(IL.opJZ, label1);
IL.SetLabel(label);
IL.Const(1);
IL.drop;
label := IL.NewLabel();
IL.Jmp(IL.opJMP, label);
IL.SetLabel(label1);
IL.Const(0);
IL.SetLabel(label);
IL.AddCmd0(IL.opOR)
END
END SimpleExpression;
PROCEDURE cmpcode (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|SCAN.lxEQ: res := ARITH.opEQ
|SCAN.lxNE: res := ARITH.opNE
|SCAN.lxLT: res := ARITH.opLT
|SCAN.lxLE: res := ARITH.opLE
|SCAN.lxGT: res := ARITH.opGT
|SCAN.lxGE: res := ARITH.opGE
|SCAN.lxIN: res := ARITH.opIN
|SCAN.lxIS: res := ARITH.opIS
END
RETURN res
END cmpcode;
PROCEDURE invcmpcode (op: INTEGER): INTEGER;
VAR
res: INTEGER;
BEGIN
CASE op OF
|SCAN.lxEQ: res := ARITH.opEQ
|SCAN.lxNE: res := ARITH.opNE
|SCAN.lxLT: res := ARITH.opGT
|SCAN.lxLE: res := ARITH.opGE
|SCAN.lxGT: res := ARITH.opLT
|SCAN.lxGE: res := ARITH.opLE
|SCAN.lxIN: res := ARITH.opIN
|SCAN.lxIS: res := ARITH.opIS
END
RETURN res
END invcmpcode;
PROCEDURE BoolCmp (eq, val: BOOLEAN);
BEGIN
IF eq = val THEN
IL.AddCmd0(IL.opNEC)
ELSE
IL.AddCmd0(IL.opEQC)
END
END BoolCmp;
PROCEDURE strcmp (VAR e, e1: PARS.EXPR; op: INTEGER): BOOLEAN;
VAR
res: BOOLEAN;
cmp: INTEGER;
BEGIN
res := TRUE;
cmp := cmpcode(op);
IF isString(e) & isCharArray(e1) THEN
IL.StrAdr(String(e));
IL.Const(strlen(e) + 1);
IL.AddCmd0(IL.opEQS + invcmpcode(op))
ELSIF (isString(e) OR isStringW(e)) & isCharArrayW(e1) THEN
IL.StrAdr(StringW(e));
IL.Const(utf8strlen(e) + 1);
IL.AddCmd0(IL.opEQSW + invcmpcode(op))
ELSIF isCharArray(e) & isString(e1) THEN
IL.StrAdr(String(e1));
IL.Const(strlen(e1) + 1);
IL.AddCmd0(IL.opEQS + cmp)
ELSIF isCharArrayW(e) & (isString(e1) OR isStringW(e1)) THEN
IL.StrAdr(StringW(e1));
IL.Const(utf8strlen(e1) + 1);
IL.AddCmd0(IL.opEQSW + cmp)
ELSIF isCharArrayW(e) & isCharArrayW(e1) THEN
IL.AddCmd0(IL.opEQSW + cmp)
ELSIF isCharArray(e) & isCharArray(e1) THEN
IL.AddCmd0(IL.opEQS + cmp)
ELSIF isString(e) & isString(e1) THEN
PARS.strcmp(e.value, e1.value, op)
ELSE
res := FALSE
END
RETURN res
END strcmp;
BEGIN
getpos(parser, pos0);
SimpleExpression(parser, e);
IF relation(parser.sym) THEN
IF (isCharArray(e) OR isCharArrayW(e)) & (e._type.length # 0) THEN
IL.Const(e._type.length)
END;
op := parser.sym;
getpos(parser, pos);
PARS.Next(parser);
getpos(parser, pos1);
SimpleExpression(parser, e1);
IF (isCharArray(e1) OR isCharArrayW(e1)) & (e1._type.length # 0) THEN
IL.Const(e1._type.length)
END;
constant := (e.obj = eCONST) & (e1.obj = eCONST);
error := 0;
cmp := cmpcode(op);
CASE op OF
|SCAN.lxEQ, SCAN.lxNE:
eq := op = SCAN.lxEQ;
IF isInt(e) & isInt(e1) OR isSet(e) & isSet(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) OR
isPtr(e) & isPtr(e1) & (PROG.isBaseOf(e._type, e1._type) OR PROG.isBaseOf(e1._type, e._type)) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opEQ + cmp)
END
END
ELSIF isStringW1(e) & isCharW(e1) THEN
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e.value.string(SCAN.STRING).s))
ELSIF isStringW1(e1) & isCharW(e) THEN
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e1.value.string(SCAN.STRING).s))
ELSIF isBoolean(e) & isBoolean(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
BoolCmp(eq, ARITH.Int(e.value) # 0)
ELSIF e1.obj = eCONST THEN
BoolCmp(eq, ARITH.Int(e1.value) # 0)
ELSE
IF eq THEN
IL.AddCmd0(IL.opEQB)
ELSE
IL.AddCmd0(IL.opNEB)
END
END
END
ELSIF isReal(e) & isReal(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
Float(parser, e)
ELSIF e1.obj = eCONST THEN
Float(parser, e1)
END;
IL.AddCmd0(IL.opEQF + cmp)
END
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN
IF ~strcmp(e, e1, op) THEN
PARS.error(pos, 37)
END
ELSIF isPtr(e) & isNil(e1) OR isNil(e) & isPtr(e1) THEN
IL.AddCmd0(IL.opEQC + cmp)
ELSIF isProc(e) & isNil(e1) THEN
IF e.obj IN {ePROC, eIMP} THEN
PARS.check(e.ident.global, pos0, 85);
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, ~eq)
ELSE
IL.AddCmd0(IL.opEQC + cmp)
END
ELSIF isNil(e) & isProc(e1) THEN
IF e1.obj IN {ePROC, eIMP} THEN
PARS.check(e1.ident.global, pos1, 85);
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, ~eq)
ELSE
IL.AddCmd0(IL.opEQC + cmp)
END
ELSIF isProc(e) & isProc(e1) & PROG.isTypeEq(e._type, e1._type) THEN
IF e.obj = ePROC THEN
PARS.check(e.ident.global, pos0, 85)
END;
IF e1.obj = ePROC THEN
PARS.check(e1.ident.global, pos1, 85)
END;
IF (e.obj IN {ePROC, eIMP}) & (e1.obj IN {ePROC, eIMP}) THEN
constant := TRUE;
e.obj := eCONST;
IF eq THEN
ARITH.setbool(e.value, e.ident = e1.ident)
ELSE
ARITH.setbool(e.value, e.ident # e1.ident)
END
ELSIF e.obj = ePROC THEN
IL.ProcCmp(e.ident.proc.label, eq)
ELSIF e1.obj = ePROC THEN
IL.ProcCmp(e1.ident.proc.label, eq)
ELSIF e.obj = eIMP THEN
IL.ProcImpCmp(e.ident._import, eq)
ELSIF e1.obj = eIMP THEN
IL.ProcImpCmp(e1.ident._import, eq)
ELSE
IL.AddCmd0(IL.opEQ + cmp)
END
ELSIF isNil(e) & isNil(e1) THEN
constant := TRUE;
e.obj := eCONST;
ARITH.setbool(e.value, eq)
ELSE
PARS.error(pos, 37)
END
|SCAN.lxLT, SCAN.lxLE, SCAN.lxGT, SCAN.lxGE:
IF isInt(e) & isInt(e1) OR isChar(e) & isChar(e1) OR isCharW(e) & isCharW(e1) OR
isCharW(e) & isChar(e1) & (e1.obj = eCONST) OR isCharW(e1) & isChar(e) & (e.obj = eCONST) OR
isCharW(e1) & (e1.obj = eCONST) & isChar(e) & (e.obj = eCONST) OR
isCharW(e) & (e.obj = eCONST) & isChar(e1) & (e1.obj = eCONST) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opEQC + invcmpcode(op), ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opEQC + cmp, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opEQ + cmp)
END
END
ELSIF isStringW1(e) & isCharW(e1) THEN
IL.AddCmd(IL.opEQC + invcmpcode(op), StrToWChar(e.value.string(SCAN.STRING).s))
ELSIF isStringW1(e1) & isCharW(e) THEN
IL.AddCmd(IL.opEQC + cmp, StrToWChar(e1.value.string(SCAN.STRING).s))
ELSIF isReal(e) & isReal(e1) THEN
IF constant THEN
ARITH.relation(e.value, e1.value, cmp, error)
ELSE
IF e.obj = eCONST THEN
Float(parser, e);
IL.AddCmd0(IL.opEQF + invcmpcode(op))
ELSIF e1.obj = eCONST THEN
Float(parser, e1);
IL.AddCmd0(IL.opEQF + cmp)
ELSE
IL.AddCmd0(IL.opEQF + cmp)
END
END
ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN
IF ~strcmp(e, e1, op) THEN
PARS.error(pos, 37)
END
ELSE
PARS.error(pos, 37)
END
|SCAN.lxIN:
PARS.check(isInt(e) & isSet(e1), pos, 37);
IF e.obj = eCONST THEN
PARS.check(ARITH.range(e.value, 0, UTILS.target.maxSet), pos0, 56)
END;
IF constant THEN
ARITH.relation(e.value, e1.value, ARITH.opIN, error)
ELSE
IF e.obj = eCONST THEN
IL.AddCmd(IL.opINL, ARITH.Int(e.value))
ELSIF e1.obj = eCONST THEN
IL.AddCmd(IL.opINR, ARITH.Int(e1.value))
ELSE
IL.AddCmd0(IL.opIN)
END
END
|SCAN.lxIS:
PARS.check(isRecPtr(e), pos, 73);
PARS.check(e1.obj = eTYPE, pos1, 79);
IF isRec(e) THEN
PARS.check(e.obj = eVREC, pos0, 78);
PARS.check(e1._type.typ = PROG.tRECORD, pos1, 80);
IF e.ident = NIL THEN
IL.TypeCheck(e1._type.num)
ELSE
IL.AddCmd(IL.opVADR, e.ident.offset - 1);
IL.TypeCheckRec(e1._type.num)
END
ELSE
PARS.check(e1._type.typ = PROG.tPOINTER, pos1, 81);
IL.TypeCheck(e1._type.base.num)
END;
PARS.check(PROG.isBaseOf(e._type, e1._type), pos1, 82)
END;
ASSERT(error = 0);
e._type := tBOOLEAN;
IF ~constant THEN
e.obj := eEXPR
END
END
END expression;
PROCEDURE ElementaryStatement (parser: PARS.PARSER);
VAR
e, e1: PARS.EXPR;
pos: PARS.POSITION;
line: INTEGER;
call: BOOLEAN;
BEGIN
getpos(parser, pos);
IL.pushBegEnd(begcall, endcall);
designator(parser, e);
IF parser.sym = SCAN.lxASSIGN THEN
line := parser.lex.pos.line;
PARS.check(isVar(e), pos, 93);
PARS.check(~e.readOnly, pos, 94);
IL.setlast(begcall);
NextPos(parser, pos);
expression(parser, e1);
IF (e._type.typ = PROG.tBYTE) & (e1.obj # eCONST) & (e1._type.typ = PROG.tINTEGER) & (chkBYTE IN Options.checking) THEN
CheckRange(256, pos.line, errBYTE)
END;
IL.setlast(endcall.prev(IL.COMMAND));
PARS.check(assign(parser, e1, e._type, line), pos, 91);
IF e1.obj = ePROC THEN
PARS.check(e1.ident.global, pos, 85)
END;
call := FALSE
ELSIF parser.sym = SCAN.lxEQ THEN
PARS.check1(FALSE, parser, 96)
ELSIF parser.sym = SCAN.lxLROUND THEN
e1 := e;
ActualParameters(parser, e1);
PARS.check((e1._type = NIL) OR ODD(e._type.call), pos, 92);
call := TRUE
ELSE
IF e.obj IN {eSYSPROC, eSTPROC} THEN
stProc(parser, e);
call := FALSE
ELSE
PARS.check(isProc(e), pos, 86);
PARS.check((e._type.base = NIL) OR ODD(e._type.call), pos, 92);
PARS.check1(e._type.params.first = NIL, parser, 64);
call := TRUE
END
END;
IF call THEN
IF e.obj IN {ePROC, eIMP} THEN
ProcCall(e, e.ident._type, FALSE, parser, pos, TRUE)
ELSIF isExpr(e) THEN
ProcCall(e, e._type, FALSE, parser, pos, TRUE)
END
END;
IL.popBegEnd(begcall, endcall)
END ElementaryStatement;
PROCEDURE IfStatement (parser: PARS.PARSER; _if: BOOLEAN);
VAR
e: PARS.EXPR;
pos: PARS.POSITION;
label, L: INTEGER;
BEGIN
L := IL.NewLabel();
IF ~_if THEN
IL.AddCmd(IL.opNOP, IL.begin_loop);
IL.SetLabel(L)
END;
REPEAT
NextPos(parser, pos);
label := IL.NewLabel();
expression(parser, e);
PARS.check(isBoolean(e), pos, 72);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
IL.Jmp(IL.opJMP, label)
END
ELSE
IL.AndOrOpt(label)
END;
IF _if THEN
PARS.checklex(parser, SCAN.lxTHEN)
ELSE
PARS.checklex(parser, SCAN.lxDO)
END;
PARS.Next(parser);
parser.StatSeq(parser);
IF ~_if OR (parser.sym # SCAN.lxEND) THEN
IL.Jmp(IL.opJMP, L)
END;
IL.SetLabel(label)
UNTIL parser.sym # SCAN.lxELSIF;
IF _if THEN
IF parser.sym = SCAN.lxELSE THEN
PARS.Next(parser);
parser.StatSeq(parser)
END;
IL.SetLabel(L)
ELSE
IL.AddCmd(IL.opNOP, IL.end_loop)
END;
PARS.checklex(parser, SCAN.lxEND);
PARS.Next(parser)
END IfStatement;
PROCEDURE RepeatStatement (parser: PARS.PARSER);
VAR
e: PARS.EXPR;
pos: PARS.POSITION;
label: INTEGER;
L: IL.COMMAND;
BEGIN
IL.AddCmd(IL.opNOP, IL.begin_loop);
label := IL.NewLabel();
IL.SetLabel(label);
L := IL.getlast();
PARS.Next(parser);
parser.StatSeq(parser);
PARS.checklex(parser, SCAN.lxUNTIL);
NextPos(parser, pos);
expression(parser, e);
PARS.check(isBoolean(e), pos, 72);
IF e.obj = eCONST THEN
IF ~ARITH.getBool(e.value) THEN
IL.Jmp(IL.opJMP, label)
END
ELSE
IL.AndOrOpt(label);
L.param1 := label
END;
IL.AddCmd(IL.opNOP, IL.end_loop)
END RepeatStatement;
PROCEDURE LabelCmp (a, b: AVL.DATA): INTEGER;
VAR
La, Ra, Lb, Rb, res: INTEGER;
BEGIN
La := a(CASE_LABEL).range.a;
Ra := a(CASE_LABEL).range.b;
Lb := b(CASE_LABEL).range.a;
Rb := b(CASE_LABEL).range.b;
IF (Ra < Lb) OR (La > Rb) THEN
res := ORD(La > Lb) - ORD(La < Lb)
ELSE
res := 0
END
RETURN res
END LabelCmp;
PROCEDURE DestroyLabel (VAR label: AVL.DATA);
BEGIN
C.push(CaseLabels, label);
label := NIL
END DestroyLabel;
PROCEDURE NewVariant (label: INTEGER; cmd: IL.COMMAND): CASE_VARIANT;
VAR
res: CASE_VARIANT;
citem: C.ITEM;
BEGIN
citem := C.pop(CaseVar);
IF citem = NIL THEN
NEW(res)
ELSE
res := citem(CASE_VARIANT)
END;
res.label := label;
res.cmd := cmd;
res.processed := FALSE
RETURN res
END NewVariant;
PROCEDURE CaseStatement (parser: PARS.PARSER);
VAR
e: PARS.EXPR;
pos: PARS.POSITION;
PROCEDURE Label (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR _type: PROG._TYPE): INTEGER;
VAR
a: INTEGER;
label: PARS.EXPR;
pos: PARS.POSITION;
value: ARITH.VALUE;
BEGIN
getpos(parser, pos);
_type := NIL;
IF isChar(caseExpr) THEN
PARS.ConstExpression(parser, value);
PARS.check(value.typ = ARITH.tCHAR, pos, 99);
a := ARITH.getInt(value)
ELSIF isCharW(caseExpr) THEN
PARS.ConstExpression(parser, value);
IF (value.typ = ARITH.tSTRING) & (_length(value.string(SCAN.STRING).s) = 1) & (LENGTH(value.string(SCAN.STRING).s) > 1) THEN
ASSERT(ARITH.setInt(value, StrToWChar(value.string(SCAN.STRING).s)))
ELSE
PARS.check(value.typ IN {ARITH.tWCHAR, ARITH.tCHAR}, pos, 99)
END;
a := ARITH.getInt(value)
ELSIF isInt(caseExpr) THEN
PARS.ConstExpression(parser, value);
PARS.check(value.typ = ARITH.tINTEGER, pos, 99);
a := ARITH.getInt(value)
ELSIF isRecPtr(caseExpr) THEN
qualident(parser, label);
PARS.check(label.obj = eTYPE, pos, 79);
PARS.check(PROG.isBaseOf(caseExpr._type, label._type), pos, 99);
IF isRec(caseExpr) THEN
a := label._type.num
ELSE
a := label._type.base.num
END;
_type := label._type
END
RETURN a
END Label;
PROCEDURE CheckType (node: AVL.NODE; _type: PROG._TYPE; parser: PARS.PARSER; pos: PARS.POSITION);
BEGIN
IF node # NIL THEN
PARS.check(~(PROG.isBaseOf(node.data(CASE_LABEL)._type, _type) OR PROG.isBaseOf(_type, node.data(CASE_LABEL)._type)), pos, 100);
CheckType(node.left, _type, parser, pos);
CheckType(node.right, _type, parser, pos)
END
END CheckType;
PROCEDURE LabelRange (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; variant: INTEGER): AVL.NODE;
VAR
label: CASE_LABEL;
citem: C.ITEM;
pos, pos1: PARS.POSITION;
node: AVL.NODE;
newnode: BOOLEAN;
range: RANGE;
BEGIN
citem := C.pop(CaseLabels);
IF citem = NIL THEN
NEW(label)
ELSE
label := citem(CASE_LABEL)
END;
label.variant := variant;
label.self := IL.NewLabel();
getpos(parser, pos1);
range.a := Label(parser, caseExpr, label._type);
IF parser.sym = SCAN.lxRANGE THEN
PARS.check1(~isRecPtr(caseExpr), parser, 53);
NextPos(parser, pos);
range.b := Label(parser, caseExpr, label._type);
PARS.check(range.a <= range.b, pos, 103)
ELSE
range.b := range.a
END;
label.range := range;
IF isRecPtr(caseExpr) THEN
CheckType(tree, label._type, parser, pos1)
END;
tree := AVL.insert(tree, label, LabelCmp, newnode, node);
PARS.check(newnode, pos1, 100)
RETURN node
END LabelRange;
PROCEDURE CaseLabelList (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; variant: INTEGER): AVL.NODE;
VAR
exit: BOOLEAN;
res: AVL.NODE;
BEGIN
exit := FALSE;
REPEAT
res := LabelRange(parser, caseExpr, tree, variant);
IF parser.sym = SCAN.lxCOMMA THEN
PARS.check1(~isRecPtr(caseExpr), parser, 53);
PARS.Next(parser)
ELSE
exit := TRUE
END
UNTIL exit
RETURN res
END CaseLabelList;
PROCEDURE _case (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR tree: AVL.NODE; _end: INTEGER);
VAR
sym: INTEGER;
t: PROG._TYPE;
variant: INTEGER;
node: AVL.NODE;
last: IL.COMMAND;
BEGIN
sym := parser.sym;
IF sym # SCAN.lxBAR THEN
variant := IL.NewLabel();
node := CaseLabelList(parser, caseExpr, tree, variant);
PARS.checklex(parser, SCAN.lxCOLON);
PARS.Next(parser);
IF isRecPtr(caseExpr) THEN
t := caseExpr._type;
caseExpr.ident._type := node.data(CASE_LABEL)._type
END;
last := IL.getlast();
IL.SetLabel(variant);
IF ~isRecPtr(caseExpr) THEN
LISTS.push(CaseVariants, NewVariant(variant, last))
END;
parser.StatSeq(parser);
IL.Jmp(IL.opJMP, _end);
IF isRecPtr(caseExpr) THEN
caseExpr.ident._type := t
END
END
END _case;
PROCEDURE Table (node: AVL.NODE; _else: INTEGER);
VAR
L, R: INTEGER;
range: RANGE;
left, right: AVL.NODE;
last: IL.COMMAND;
v: CASE_VARIANT;
BEGIN
IF node # NIL THEN
range := node.data(CASE_LABEL).range;
left := node.left;
IF left # NIL THEN
L := left.data(CASE_LABEL).self
ELSE
L := _else
END;
right := node.right;
IF right # NIL THEN
R := right.data(CASE_LABEL).self
ELSE
R := _else
END;
last := IL.getlast();
v := CaseVariants.last(CASE_VARIANT);
WHILE (v # NIL) & (v.label # 0) & (v.label # node.data(CASE_LABEL).variant) DO
v := v.prev(CASE_VARIANT)
END;
ASSERT((v # NIL) & (v.label # 0));
IL.setlast(v.cmd);
IL.SetLabel(node.data(CASE_LABEL).self);
IL._case(range.a, range.b, L, R);
IF v.processed THEN
IL.Jmp(IL.opJMP, node.data(CASE_LABEL).variant)
END;
v.processed := TRUE;
IL.setlast(last);
Table(left, _else);
Table(right, _else)
END
END Table;
PROCEDURE TableT (node: AVL.NODE);
BEGIN
IF node # NIL THEN
IL.AddCmd2(IL.opCASET, node.data(CASE_LABEL).variant, node.data(CASE_LABEL).range.a);
TableT(node.left);
TableT(node.right)
END
END TableT;
PROCEDURE ParseCase (parser: PARS.PARSER; e: PARS.EXPR; pos: PARS.POSITION);
VAR
table, _end, _else: INTEGER;
tree: AVL.NODE;
item: LISTS.ITEM;
BEGIN
LISTS.push(CaseVariants, NewVariant(0, NIL));
_end := IL.NewLabel();
_else := IL.NewLabel();
table := IL.NewLabel();
IL.AddCmd(IL.opSWITCH, ORD(isRecPtr(e)));
IL.Jmp(IL.opJMP, table);
tree := NIL;
_case(parser, e, tree, _end);
WHILE parser.sym = SCAN.lxBAR DO
PARS.Next(parser);
_case(parser, e, tree, _end)
END;
IL.SetLabel(_else);
IF parser.sym = SCAN.lxELSE THEN
PARS.Next(parser);
parser.StatSeq(parser);
IL.Jmp(IL.opJMP, _end)
ELSE
IL.OnError(pos.line, errCASE)
END;
PARS.checklex(parser, SCAN.lxEND);
PARS.Next(parser);
IF isRecPtr(e) THEN
IL.SetLabel(table);
TableT(tree);
IL.Jmp(IL.opJMP, _else)
ELSE
tree.data(CASE_LABEL).self := table;
Table(tree, _else)
END;
AVL.destroy(tree, DestroyLabel);
IL.SetLabel(_end);
IL.AddCmd0(IL.opENDSW);
REPEAT
item := LISTS.pop(CaseVariants);
C.push(CaseVar, item)
UNTIL item(CASE_VARIANT).cmd = NIL
END ParseCase;
BEGIN
NextPos(parser, pos);
expression(parser, e);
PARS.check(isInt(e) OR isChar(e) OR isCharW(e) OR isPtr(e) OR isRec(e), pos, 95);
IF isRecPtr(e) THEN
PARS.check(isVar(e), pos, 93);
PARS.check(e.ident # NIL, pos, 106)
END;
IF isRec(e) THEN
PARS.check(e.obj = eVREC, pos, 78)
END;
IF e.obj = eCONST THEN
LoadConst(e)
ELSIF isRec(e) THEN
IL.drop;
IL.AddCmd(IL.opLADR, e.ident.offset - 1);
IL.load(TARGETS.WordSize)
ELSIF isPtr(e) THEN
deref(pos, e, FALSE, errPTR);
IL.AddCmd(IL.opSUBR, TARGETS.WordSize);
IL.load(TARGETS.WordSize)
END;
PARS.checklex(parser, SCAN.lxOF);
PARS.Next(parser);
ParseCase(parser, e, pos)
END CaseStatement;
PROCEDURE ForStatement (parser: PARS.PARSER);
VAR
e: PARS.EXPR;
pos, pos2: PARS.POSITION;
step: ARITH.VALUE;
st: INTEGER;
ident: PROG.IDENT;
offset: INTEGER;
L1, L2: INTEGER;
BEGIN
IL.AddCmd(IL.opNOP, IL.begin_loop);
L1 := IL.NewLabel();
L2 := IL.NewLabel();
PARS.ExpectSym(parser, SCAN.lxIDENT);
ident := PROG.getIdent(parser.unit, parser.lex.ident, TRUE);
PARS.check1(ident # NIL, parser, 48);
PARS.check1(ident.typ = PROG.idVAR, parser, 93);
PARS.check1(ident._type = tINTEGER, parser, 97);
PARS.ExpectSym(parser, SCAN.lxASSIGN);
NextPos(parser, pos);
expression(parser, e);
PARS.check(isInt(e), pos, 76);
offset := PROG.getOffset(ident);
IF ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
IL.AddCmd(IL.opLADR, -offset)
END;
IF e.obj = eCONST THEN
IL.AddCmd(IL.opSAVEC, ARITH.Int(e.value))
ELSE
IL.AddCmd0(IL.opSAVE)
END;
IL.SetLabel(L1);
IF ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
IL.AddCmd(IL.opLADR, -offset)
END;
IL.load(ident._type.size);
PARS.checklex(parser, SCAN.lxTO);
NextPos(parser, pos2);
expression(parser, e);
PARS.check(isInt(e), pos2, 76);
IF parser.sym = SCAN.lxBY THEN
NextPos(parser, pos);
PARS.ConstExpression(parser, step);
PARS.check(step.typ = ARITH.tINTEGER, pos, 76);
st := ARITH.getInt(step);
PARS.check(st # 0, pos, 98)
ELSE
st := 1
END;
IF e.obj = eCONST THEN
IF st > 0 THEN
IL.AddCmd(IL.opLEC, ARITH.Int(e.value));
IF ARITH.Int(e.value) = UTILS.target.maxInt THEN
ERRORS.WarningMsg(pos2.line, pos2.col, 1)
END
ELSE
IL.AddCmd(IL.opGEC, ARITH.Int(e.value));
IF ARITH.Int(e.value) = UTILS.target.minInt THEN
ERRORS.WarningMsg(pos2.line, pos2.col, 1)
END
END
ELSE
IF st > 0 THEN
IL.AddCmd0(IL.opLE)
ELSE
IL.AddCmd0(IL.opGE)
END
END;
IL.Jmp(IL.opJZ, L2);
PARS.checklex(parser, SCAN.lxDO);
PARS.Next(parser);
parser.StatSeq(parser);
IF ident.global THEN
IL.AddCmd(IL.opGADR, offset)
ELSE
IL.AddCmd(IL.opLADR, -offset)
END;
IL.AddCmd(IL.opINCC, st);
IL.Jmp(IL.opJMP, L1);
PARS.checklex(parser, SCAN.lxEND);
PARS.Next(parser);
IL.SetLabel(L2);
IL.AddCmd(IL.opNOP, IL.end_loop)
END ForStatement;
PROCEDURE statement (parser: PARS.PARSER);
VAR
sym: INTEGER;
BEGIN
sym := parser.sym;
IF sym = SCAN.lxIDENT THEN
ElementaryStatement(parser)
ELSIF sym = SCAN.lxIF THEN
IfStatement(parser, TRUE)
ELSIF sym = SCAN.lxWHILE THEN
IfStatement(parser, FALSE)
ELSIF sym = SCAN.lxREPEAT THEN
RepeatStatement(parser)
ELSIF sym = SCAN.lxCASE THEN
CaseStatement(parser)
ELSIF sym = SCAN.lxFOR THEN
ForStatement(parser)
END
END statement;
PROCEDURE StatSeq (parser: PARS.PARSER);
BEGIN
statement(parser);
WHILE parser.sym = SCAN.lxSEMI DO
PARS.Next(parser);
statement(parser)
END
END StatSeq;
PROCEDURE chkreturn (parser: PARS.PARSER; e: PARS.EXPR; t: PROG._TYPE; pos: PARS.POSITION): BOOLEAN;
VAR
res: BOOLEAN;
BEGIN
res := assigncomp(e, t);
IF res THEN
IF e.obj = eCONST THEN
IF e._type = tREAL THEN
Float(parser, e)
ELSIF e._type.typ = PROG.tNIL THEN
IL.Const(0)
ELSE
LoadConst(e)
END
ELSIF (e._type = tINTEGER) & (t = tBYTE) & (chkBYTE IN Options.checking) THEN
CheckRange(256, pos.line, errBYTE)
ELSIF e.obj = ePROC THEN
PARS.check(e.ident.global, pos, 85);
IL.PushProc(e.ident.proc.label)
ELSIF e.obj = eIMP THEN
IL.PushImpProc(e.ident._import)
END
END
RETURN res
END chkreturn;
PROCEDURE setrtl;
VAR
rtl: PROG.UNIT;
PROCEDURE getproc (rtl: PROG.UNIT; name: SCAN.IDSTR; idx: INTEGER);
VAR
id: PROG.IDENT;
ident: SCAN.IDENT;
BEGIN
SCAN.setIdent(ident, name);
id := PROG.getIdent(rtl, ident, FALSE);
IF (id # NIL) & (id._import # NIL) THEN
IL.set_rtl(idx, -id._import(IL.IMPORT_PROC).label);
id.proc.used := TRUE
ELSIF (id # NIL) & (id.proc # NIL) THEN
IL.set_rtl(idx, id.proc.label);
id.proc.used := TRUE
ELSE
ERRORS.WrongRTL(name)
END
END getproc;
BEGIN
rtl := PROG.program.rtl;
ASSERT(rtl # NIL);
getproc(rtl, "_strcmp", IL._strcmp);
getproc(rtl, "_length", IL._length);
getproc(rtl, "_arrcpy", IL._arrcpy);
getproc(rtl, "_is", IL._is);
getproc(rtl, "_guard", IL._guard);
getproc(rtl, "_guardrec", IL._guardrec);
getproc(rtl, "_new", IL._new);
getproc(rtl, "_rot", IL._rot);
getproc(rtl, "_strcpy", IL._strcpy);
getproc(rtl, "_move", IL._move);
getproc(rtl, "_set", IL._set);
getproc(rtl, "_set1", IL._set1);
getproc(rtl, "_lengthw", IL._lengthw);
getproc(rtl, "_strcmpw", IL._strcmpw);
getproc(rtl, "_init", IL._init);
IF CPU IN {TARGETS.cpuX86, TARGETS.cpuAMD64} THEN
getproc(rtl, "_error", IL._error);
getproc(rtl, "_divmod", IL._divmod);
getproc(rtl, "_exit", IL._exit);
getproc(rtl, "_dispose", IL._dispose);
getproc(rtl, "_isrec", IL._isrec);
getproc(rtl, "_dllentry", IL._dllentry);
getproc(rtl, "_sofinit", IL._sofinit)
ELSIF CPU IN {TARGETS.cpuTHUMB, TARGETS.cpuRVM32I, TARGETS.cpuRVM64I} THEN
getproc(rtl, "_fmul", IL._fmul);
getproc(rtl, "_fdiv", IL._fdiv);
getproc(rtl, "_fdivi", IL._fdivi);
getproc(rtl, "_fadd", IL._fadd);
getproc(rtl, "_fsub", IL._fsub);
getproc(rtl, "_fsubi", IL._fsubi);
getproc(rtl, "_fcmp", IL._fcmp);
getproc(rtl, "_floor", IL._floor);
getproc(rtl, "_flt", IL._flt);
getproc(rtl, "_pack", IL._pack);
getproc(rtl, "_unpk", IL._unpk);
IF CPU IN {TARGETS.cpuRVM32I, TARGETS.cpuRVM64I} THEN
getproc(rtl, "_error", IL._error)
END
END
END setrtl;
PROCEDURE compile* (path, lib_path, modname, outname: PARS.PATH; target: INTEGER; options: PROG.OPTIONS);
VAR
parser: PARS.PARSER;
ext: PARS.PATH;
BEGIN
tINTEGER := PROG.program.stTypes.tINTEGER;
tBYTE := PROG.program.stTypes.tBYTE;
tCHAR := PROG.program.stTypes.tCHAR;
tSET := PROG.program.stTypes.tSET;
tBOOLEAN := PROG.program.stTypes.tBOOLEAN;
tWCHAR := PROG.program.stTypes.tWCHAR;
tREAL := PROG.program.stTypes.tREAL;
Options := options;
CPU := TARGETS.CPU;
ext := UTILS.FILE_EXT;
CaseLabels := C.create();
CaseVar := C.create();
CaseVariants := LISTS.create(NIL);
LISTS.push(CaseVariants, NewVariant(0, NIL));
IL.init(CPU);
IF TARGETS.RTL THEN
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn);
IF parser.open(parser, UTILS.RTL_NAME, UTILS.FILE_EXT) THEN
parser.parse(parser);
PARS.destroy(parser)
ELSE
PARS.destroy(parser);
parser := PARS.create(lib_path, lib_path, StatSeq, expression, designator, chkreturn);
IF parser.open(parser, UTILS.RTL_NAME, UTILS.FILE_EXT) THEN
parser.parse(parser);
PARS.destroy(parser)
ELSE
ERRORS.FileNotFound(lib_path, UTILS.RTL_NAME, UTILS.FILE_EXT)
END
END
END;
parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn);
parser.main := TRUE;
IF parser.open(parser, modname, UTILS.FILE_EXT) THEN
parser.parse(parser)
ELSE
ERRORS.FileNotFound(path, modname, UTILS.FILE_EXT)
END;
PARS.destroy(parser);
IF PROG.program.bss > UTILS.MAX_GLOBAL_SIZE THEN
ERRORS.Error(204)
END;
IF TARGETS.RTL THEN
setrtl
END;
PROG.DelUnused(IL.DelImport);
IL.set_bss(PROG.program.bss);
CASE CPU OF
|TARGETS.cpuAMD64: AMD64.CodeGen(outname, target, options)
|TARGETS.cpuX86: X86.CodeGen(outname, target, options)
|TARGETS.cpuMSP430: MSP430.CodeGen(outname, target, options)
|TARGETS.cpuTHUMB: THUMB.CodeGen(outname, target, options)
|TARGETS.cpuRVM32I,
TARGETS.cpuRVM64I: RVMxI.CodeGen(outname, target, options)
END
END compile;
END STATEMENTS.
View Git Blame Copy Permalink