(* BSD 2-Clause License Copyright (c) 2018, 2019, Anton Krotov All rights reserved. *) MODULE STATEMENTS; IMPORT PARS, PROG, SCAN, ARITH, STRINGS, LISTS, CODE, X86, AMD64, ERRORS, MACHINE, AVL := AVLTREES, CONSOLE, C := COLLECTIONS, mConst := CONSTANTS; 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; chkALL* = {chkIDX, chkGUARD, chkPTR, chkCHR, chkWCHR, chkBYTE}; 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: CODE.COMMAND; processed: BOOLEAN END; VAR begcall, endcall: CODE.COMMAND; checking: SET; CaseLabels, CaseVar: C.COLLECTION; CaseVariants: LISTS.LIST; 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.typ = PROG.tBOOLEAN) END isBoolean; PROCEDURE isInteger (e: PARS.EXPR): BOOLEAN; RETURN isExpr(e) & (e.type.typ = PROG.tINTEGER) END isInteger; PROCEDURE isByte (e: PARS.EXPR): BOOLEAN; RETURN isExpr(e) & (e.type.typ = PROG.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.typ = PROG.tREAL) END isReal; PROCEDURE isSet (e: PARS.EXPR): BOOLEAN; RETURN isExpr(e) & (e.type.typ = PROG.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.typ = PROG.tCHAR) END isChar; PROCEDURE isCharArray (e: PARS.EXPR): BOOLEAN; RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ = PROG.tCHAR) END isCharArray; PROCEDURE isCharW (e: PARS.EXPR): BOOLEAN; RETURN isExpr(e) & (e.type.typ = PROG.tWCHAR) END isCharW; PROCEDURE isCharArrayW (e: PARS.EXPR): BOOLEAN; RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ = PROG.tWCHAR) END isCharArrayW; PROCEDURE isCharArrayX (e: PARS.EXPR): BOOLEAN; RETURN isExpr(e) & (e.type.typ = PROG.tARRAY) & (e.type.base.typ IN {PROG.tCHAR, PROG.tWCHAR}) END isCharArrayX; 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 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 getpos (parser: PARS.PARSER; VAR pos: SCAN.POSITION); BEGIN pos := parser.lex.pos END getpos; PROCEDURE NextPos (parser: PARS.PARSER; VAR pos: SCAN.POSITION); BEGIN PARS.NextPos(parser, pos) END NextPos; PROCEDURE strlen (e: PARS.EXPR): INTEGER; VAR res: INTEGER; BEGIN ASSERT(isString(e)); IF e.type.typ = PROG.tCHAR THEN res := 1 ELSE res := LENGTH(e.value.string(SCAN.IDENT).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.IDENT).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 (e.obj = eCONST) & isString(e) & (utf8strlen(e) = 1) & (strlen(e) > 1) END isStringW1; PROCEDURE assigncomp (e: PARS.EXPR; t: PROG.TYPE_): BOOLEAN; VAR res: BOOLEAN; PROCEDURE arrcomp (src, dst: PROG.TYPE_): BOOLEAN; RETURN (dst.typ = PROG.tARRAY) & PROG.isOpenArray(src) & ~PROG.isOpenArray(src.base) & ~PROG.isOpenArray(dst.base) & PROG.isTypeEq(src.base, dst.base) END arrcomp; BEGIN IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN IF arrcomp(e.type, t) THEN res := TRUE ELSIF isInt(e) & (t.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN IF (e.obj = eCONST) & (t.typ = PROG.tBYTE) THEN res := ARITH.range(e.value, 0, 255) ELSE res := TRUE END ELSIF isSet(e) & (t.typ = PROG.tSET) THEN res := TRUE ELSIF isBoolean(e) & (t.typ = PROG.tBOOLEAN) THEN res := TRUE ELSIF isReal(e) & (t.typ = PROG.tREAL) THEN res := TRUE ELSIF isChar(e) & (t.typ = PROG.tCHAR) THEN res := TRUE ELSIF (e.obj = eCONST) & isChar(e) & (t.typ = PROG.tWCHAR) THEN res := TRUE ELSIF isStringW1(e) & (t.typ = PROG.tWCHAR) THEN res := TRUE ELSIF isCharW(e) & (t.typ = PROG.tWCHAR) THEN res := TRUE ELSIF PROG.isBaseOf(t, e.type) THEN res := TRUE ELSIF ~PROG.isOpenArray(t) & ~PROG.isOpenArray(e.type) & PROG.isTypeEq(t, e.type) THEN res := TRUE ELSIF isNil(e) & (t.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN res := TRUE ELSIF isString(e) & ((t.typ = PROG.tARRAY) & (t.base.typ = PROG.tCHAR) & (t.length > strlen(e))) THEN res := TRUE ELSIF isStringW(e) & ((t.typ = PROG.tARRAY) & (t.base.typ = PROG.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.IDENT; BEGIN IF strlen(e) # 1 THEN string := e.value.string(SCAN.IDENT); IF string.offset = -1 THEN string.offset := CODE.putstr(string.s); END; offset := string.offset ELSE offset := CODE.putstr1(ARITH.Int(e.value)) END RETURN offset END String; PROCEDURE StringW (e: PARS.EXPR): INTEGER; VAR offset: INTEGER; string: SCAN.IDENT; BEGIN IF utf8strlen(e) # 1 THEN string := e.value.string(SCAN.IDENT); IF string.offsetW = -1 THEN string.offsetW := CODE.putstrW(string.s); END; offset := string.offsetW ELSE IF e.type.typ IN {PROG.tWCHAR, PROG.tCHAR} THEN offset := CODE.putstrW1(ARITH.Int(e.value)) ELSE (* e.type.typ = PROG.tSTRING *) string := e.value.string(SCAN.IDENT); IF string.offsetW = -1 THEN string.offsetW := CODE.putstrW(string.s); END; offset := string.offsetW END END RETURN offset END StringW; PROCEDURE CheckRange (range, line, errno: INTEGER); VAR label: INTEGER; BEGIN label := CODE.NewLabel(); CODE.AddCmd2(CODE.opCHKIDX, label, range); CODE.OnError(line, errno); CODE.SetLabel(label) END CheckRange; PROCEDURE assign (e: PARS.EXPR; VarType: PROG.TYPE_; line: INTEGER): BOOLEAN; VAR res: BOOLEAN; label: INTEGER; PROCEDURE arrcomp (src, dst: PROG.TYPE_): BOOLEAN; RETURN (dst.typ = PROG.tARRAY) & PROG.isOpenArray(src) & ~PROG.isOpenArray(src.base) & ~PROG.isOpenArray(dst.base) & PROG.isTypeEq(src.base, dst.base) END arrcomp; BEGIN IF isExpr(e) OR (e.obj IN {ePROC, eIMP}) THEN res := TRUE; IF arrcomp(e.type, VarType) THEN IF ~PROG.isOpenArray(VarType) THEN CODE.AddCmd(CODE.opCONST, VarType.length) END; CODE.AddCmd(CODE.opCOPYA, VarType.base.size); label := CODE.NewLabel(); CODE.AddJmpCmd(CODE.opJE, label); CODE.OnError(line, errCOPY); CODE.SetLabel(label) ELSIF isInt(e) & (VarType.typ IN {PROG.tBYTE, PROG.tINTEGER}) THEN IF VarType.typ = PROG.tINTEGER THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value)) ELSE CODE.AddCmd0(CODE.opSAVE) END ELSE IF e.obj = eCONST THEN res := ARITH.range(e.value, 0, 255); IF res THEN CODE.AddCmd(CODE.opSAVE8C, ARITH.Int(e.value)) END ELSE IF chkBYTE IN checking THEN label := CODE.NewLabel(); CODE.AddCmd2(CODE.opCHKBYTE, label, 0); CODE.OnError(line, errBYTE); CODE.SetLabel(label) END; CODE.AddCmd0(CODE.opSAVE8) END END ELSIF isSet(e) & (VarType.typ = PROG.tSET) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value)) ELSE CODE.AddCmd0(CODE.opSAVE) END ELSIF isBoolean(e) & (VarType.typ = PROG.tBOOLEAN) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opSBOOLC, ARITH.Int(e.value)) ELSE CODE.AddCmd0(CODE.opSBOOL) END ELSIF isReal(e) & (VarType.typ = PROG.tREAL) THEN IF e.obj = eCONST THEN CODE.Float(ARITH.Float(e.value)) END; CODE.savef ELSIF isChar(e) & (VarType.typ = PROG.tCHAR) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opSAVE8C, ARITH.Int(e.value)) ELSE CODE.AddCmd0(CODE.opSAVE8) END ELSIF (e.obj = eCONST) & isChar(e) & (VarType.typ = PROG.tWCHAR) THEN CODE.AddCmd(CODE.opSAVE16C, ARITH.Int(e.value)) ELSIF isStringW1(e) & (VarType.typ = PROG.tWCHAR) THEN CODE.AddCmd(CODE.opSAVE16C, StrToWChar(e.value.string(SCAN.IDENT).s)) ELSIF isCharW(e) & (VarType.typ = PROG.tWCHAR) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opSAVE16C, ARITH.Int(e.value)) ELSE CODE.AddCmd0(CODE.opSAVE16) END ELSIF PROG.isBaseOf(VarType, e.type) THEN IF VarType.typ = PROG.tPOINTER THEN CODE.AddCmd0(CODE.opSAVE) ELSE CODE.AddCmd(CODE.opCOPY, VarType.size) END ELSIF (e.type.typ = PROG.tCARD32) & (VarType.typ = PROG.tCARD32) THEN CODE.AddCmd0(CODE.opSAVE32) ELSIF (e.type.typ = PROG.tCARD16) & (VarType.typ = PROG.tCARD16) THEN CODE.AddCmd0(CODE.opSAVE16) ELSIF ~PROG.isOpenArray(VarType) & ~PROG.isOpenArray(e.type) & PROG.isTypeEq(VarType, e.type) THEN IF e.obj = ePROC THEN CODE.AssignProc(e.ident.proc.label) ELSIF e.obj = eIMP THEN CODE.AssignImpProc(e.ident.import) ELSE IF VarType.typ = PROG.tPROCEDURE THEN CODE.AddCmd0(CODE.opSAVE) ELSE CODE.AddCmd(CODE.opCOPY, VarType.size) END END ELSIF isNil(e) & (VarType.typ IN {PROG.tPOINTER, PROG.tPROCEDURE}) THEN CODE.AddCmd(CODE.opSAVEC, 0) ELSIF isString(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base.typ = PROG.tCHAR) & (VarType.length > strlen(e))) THEN CODE.saves(String(e), strlen(e) + 1) ELSIF isStringW(e) & ((VarType.typ = PROG.tARRAY) & (VarType.base.typ = PROG.tWCHAR) & (VarType.length > utf8strlen(e))) THEN CODE.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 CODE.AddCmd(CODE.opCONST, ARITH.Int(e.value)) END LoadConst; PROCEDURE paramcomp (parser: PARS.PARSER; pos: SCAN.POSITION; e: PARS.EXPR; p: PROG.PARAM); 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: INTEGER; d1, d2: INTEGER; BEGIN IF t.length # 0 THEN CODE.AddCmd(CODE.opPARAM, 1); n := PROG.Dim(t2) - 1; WHILE n >= 0 DO CODE.AddCmd(CODE.opCONST, ArrLen(t, n)); CODE.AddCmd(CODE.opPARAM, 1); DEC(n) END ELSE d1 := PROG.Dim(t); d2 := PROG.Dim(t2); IF d1 # d2 THEN n := d2 - d1; WHILE d2 > d1 DO CODE.AddCmd(CODE.opCONST, ArrLen(t, d2 - 1)); DEC(d2) END; d2 := PROG.Dim(t2); WHILE n > 0 DO CODE.AddCmd(CODE.opROT, d2); DEC(n) END END; CODE.AddCmd(CODE.opPARAM, PROG.Dim(t2) + 1) END END OpenArray; BEGIN IF p.vPar THEN PARS.check(isVar(e), parser, pos, 93); IF p.type.typ = PROG.tRECORD THEN PARS.check(PROG.isBaseOf(p.type, e.type), parser, pos, 66); IF e.obj = eVREC THEN IF e.ident # NIL THEN CODE.AddCmd(CODE.opVADR, e.ident.offset - 1) ELSE CODE.AddCmd0(CODE.opPUSHT) END ELSE CODE.AddCmd(CODE.opCONST, e.type.num) END; CODE.AddCmd(CODE.opPARAM, 2) ELSIF PROG.isOpenArray(p.type) THEN PARS.check(arrcomp(e, p), parser, pos, 66); OpenArray(e.type, p.type) ELSE PARS.check(PROG.isTypeEq(e.type, p.type), parser, pos, 66); CODE.AddCmd(CODE.opPARAM, 1) END; PARS.check(~e.readOnly, parser, pos, 94) ELSE PARS.check(isExpr(e) OR isProc(e), parser, pos, 66); IF PROG.isOpenArray(p.type) THEN IF e.type.typ = PROG.tARRAY THEN PARS.check(arrcomp(e, p), parser, pos, 66); OpenArray(e.type, p.type) ELSIF isString(e) & (p.type.typ = PROG.tARRAY) & (p.type.base.typ = PROG.tCHAR) THEN CODE.AddCmd(CODE.opSADR, String(e)); CODE.AddCmd(CODE.opPARAM, 1); CODE.AddCmd(CODE.opCONST, strlen(e) + 1); CODE.AddCmd(CODE.opPARAM, 1) ELSIF isStringW(e) & (p.type.typ = PROG.tARRAY) & (p.type.base.typ = PROG.tWCHAR) THEN CODE.AddCmd(CODE.opSADR, StringW(e)); CODE.AddCmd(CODE.opPARAM, 1); CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1); CODE.AddCmd(CODE.opPARAM, 1) ELSE PARS.error(parser, pos, 66) END ELSE PARS.check(~PROG.isOpenArray(e.type), parser, pos, 66); PARS.check(assigncomp(e, p.type), parser, pos, 66); IF e.obj = eCONST THEN IF e.type.typ = PROG.tREAL THEN CODE.Float(ARITH.Float(e.value)); CODE.pushf ELSIF e.type.typ = PROG.tNIL THEN CODE.AddCmd(CODE.opCONST, 0); CODE.AddCmd(CODE.opPARAM, 1) ELSIF isStringW1(e) & (p.type.typ = PROG.tWCHAR) THEN CODE.AddCmd(CODE.opCONST, StrToWChar(e.value.string(SCAN.IDENT).s)); CODE.AddCmd(CODE.opPARAM, 1) 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 CODE.SetMinDataSize(p.type.size); IF p.type.base.typ = PROG.tCHAR THEN CODE.AddCmd(CODE.opSADR, String(e)) ELSE (* WCHAR *) CODE.AddCmd(CODE.opSADR, StringW(e)) END; CODE.AddCmd(CODE.opPARAM, 1) ELSE LoadConst(e); CODE.AddCmd(CODE.opPARAM, 1) END ELSIF e.obj = ePROC THEN PARS.check(e.ident.global, parser, pos, 85); CODE.PushProc(e.ident.proc.label); CODE.AddCmd(CODE.opPARAM, 1) ELSIF e.obj = eIMP THEN CODE.PushImpProc(e.ident.import); CODE.AddCmd(CODE.opPARAM, 1) ELSIF isExpr(e) & (e.type.typ = PROG.tREAL) THEN CODE.pushf ELSE IF (p.type.typ = PROG.tBYTE) & (e.type.typ = PROG.tINTEGER) & (chkBYTE IN checking) THEN CheckRange(256, pos.line, errBYTE) END; CODE.AddCmd(CODE.opPARAM, 1) END END END END paramcomp; PROCEDURE stProc (parser: PARS.PARSER; VAR e: PARS.EXPR); VAR e2: PARS.EXPR; pos: SCAN.POSITION; proc: INTEGER; label: INTEGER; n, i: INTEGER; code: ARITH.VALUE; e1: PARS.EXPR; wchar: BOOLEAN; cmd1, cmd2: CODE.COMMAND; PROCEDURE varparam (parser: PARS.PARSER; pos: SCAN.POSITION; isfunc: isXXX; readOnly: BOOLEAN; VAR e: PARS.EXPR); BEGIN parser.designator(parser, e); PARS.check(isVar(e), parser, pos, 93); PARS.check(isfunc(e), parser, pos, 66); IF readOnly THEN PARS.check(~e.readOnly, parser, 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}); getpos(parser, pos); proc := e.stproc; IF e.obj IN {eSYSPROC, eSYSFUNC} THEN IF parser.unit.scopeLvl > 0 THEN parser.unit.scopes[parser.unit.scopeLvl].enter(CODE.COMMAND).allocReg := FALSE END END; IF e.obj IN {eSTPROC, eSYSPROC} THEN CASE proc OF |PROG.stASSERT: parser.expression(parser, e); PARS.check(isBoolean(e), parser, pos, 66); IF e.obj = eCONST THEN IF ~ARITH.getBool(e.value) THEN CODE.OnError(pos.line, errASSERT) END ELSE label := CODE.NewLabel(); CODE.AddJmpCmd(CODE.opJE, label); CODE.OnError(pos.line, errASSERT); CODE.SetLabel(label) END |PROG.stINC, PROG.stDEC: CODE.pushBegEnd(begcall, endcall); varparam(parser, pos, isInt, TRUE, e); IF e.type.typ = PROG.tINTEGER THEN IF parser.sym = SCAN.lxCOMMA THEN NextPos(parser, pos); CODE.setlast(begcall); parser.expression(parser, e2); CODE.setlast(endcall.prev(CODE.COMMAND)); PARS.check(isInt(e2), parser, pos, 66); IF e2.obj = eCONST THEN CODE.AddCmd(CODE.opINCC + ORD(proc = PROG.stDEC), ARITH.Int(e2.value)) ELSE CODE.AddCmd0(CODE.opINC + ORD(proc = PROG.stDEC)) END ELSE CODE.AddCmd0(CODE.opINC1 + ORD(proc = PROG.stDEC)) END ELSE (* e.type.typ = PROG.tBYTE *) IF parser.sym = SCAN.lxCOMMA THEN NextPos(parser, pos); CODE.setlast(begcall); parser.expression(parser, e2); CODE.setlast(endcall.prev(CODE.COMMAND)); PARS.check(isInt(e2), parser, pos, 66); IF e2.obj = eCONST THEN CODE.AddCmd(CODE.opINCCB + ORD(proc = PROG.stDEC), ARITH.Int(e2.value)) ELSE CODE.AddCmd0(CODE.opINCB + ORD(proc = PROG.stDEC)) END ELSE CODE.AddCmd0(CODE.opINC1B + ORD(proc = PROG.stDEC)) END END; CODE.popBegEnd(begcall, endcall) |PROG.stINCL, PROG.stEXCL: CODE.pushBegEnd(begcall, endcall); varparam(parser, pos, isSet, TRUE, e); PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos); CODE.setlast(begcall); parser.expression(parser, e2); CODE.setlast(endcall.prev(CODE.COMMAND)); PARS.check(isInt(e2), parser, pos, 66); IF e2.obj = eCONST THEN PARS.check(ARITH.range(e2.value, 0, MACHINE.target.maxSet), parser, pos, 56); CODE.AddCmd(CODE.opINCLC + ORD(proc = PROG.stEXCL), ARITH.Int(e2.value)) ELSE CODE.AddCmd0(CODE.opINCL + ORD(proc = PROG.stEXCL)) END; CODE.popBegEnd(begcall, endcall) |PROG.stNEW: varparam(parser, pos, isPtr, TRUE, e); CODE.New(e.type.base.size, e.type.base.num) |PROG.stDISPOSE: varparam(parser, pos, isPtr, TRUE, e); CODE.AddCmd0(CODE.opDISP) |PROG.stPACK: varparam(parser, pos, isReal, TRUE, e); PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos); parser.expression(parser, e2); PARS.check(isInt(e2), parser, pos, 66); IF e2.obj = eCONST THEN CODE.AddCmd(CODE.opPACKC, ARITH.Int(e2.value)) ELSE CODE.AddCmd0(CODE.opPACK) END |PROG.stUNPK: varparam(parser, pos, isReal, TRUE, e); PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos); varparam(parser, pos, isInteger, TRUE, e2); CODE.AddCmd0(CODE.opUNPK) |PROG.stCOPY: parser.expression(parser, e); IF isString(e) OR isCharArray(e) THEN wchar := FALSE ELSIF isStringW(e) OR isCharArrayW(e) THEN wchar := TRUE ELSE PARS.check(FALSE, parser, pos, 66) END; IF isCharArrayX(e) & ~PROG.isOpenArray(e.type) THEN CODE.AddCmd(CODE.opCONST, e.type.length) END; PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos); 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.typ = PROG.tWCHAR END; IF ~PROG.isOpenArray(e1.type) THEN CODE.AddCmd(CODE.opCONST, e1.type.length) END; IF e.obj = eCONST THEN IF wchar THEN CODE.AddCmd(CODE.opSADR, StringW(e)); CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1) ELSE CODE.AddCmd(CODE.opSADR, String(e)); CODE.AddCmd(CODE.opCONST, strlen(e) + 1) END; CODE.AddCmd(CODE.opCOPYS2, e1.type.base.size) ELSE CODE.AddCmd(CODE.opCOPYS, e1.type.base.size) END |PROG.sysGET: parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); IF e.obj = eCONST THEN LoadConst(e) END; PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos); parser.designator(parser, e2); PARS.check(isVar(e2), parser, pos, 93); PARS.check((e2.type.typ IN PROG.BASICTYPES) OR (e2.type.typ = PROG.tPOINTER) OR (e2.type.typ = PROG.tPROCEDURE), parser, pos, 66); CODE.SysGet(e2.type.size) |PROG.sysPUT, PROG.sysPUT8, PROG.sysPUT16, PROG.sysPUT32: CODE.pushBegEnd(begcall, endcall); parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); IF e.obj = eCONST THEN LoadConst(e) END; PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos); CODE.setlast(begcall); parser.expression(parser, e2); PARS.check(isExpr(e2), parser, pos, 66); IF proc = PROG.sysPUT THEN PARS.check((e2.type.typ IN PROG.BASICTYPES) OR (e2.type.typ = PROG.tPOINTER) OR (e2.type.typ = PROG.tPROCEDURE), parser, pos, 66); IF e2.obj = eCONST THEN IF e2.type.typ = PROG.tREAL THEN CODE.setlast(endcall.prev(CODE.COMMAND)); CODE.Float(ARITH.Float(e2.value)); CODE.savef ELSE LoadConst(e2); CODE.setlast(endcall.prev(CODE.COMMAND)); CODE.SysPut(e2.type.size) END ELSE CODE.setlast(endcall.prev(CODE.COMMAND)); IF e2.type.typ = PROG.tREAL THEN CODE.savef ELSIF e2.type.typ = PROG.tBYTE THEN CODE.SysPut(PARS.program.stTypes.tINTEGER.size) ELSE CODE.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.tWCHAR, PROG.tCARD16, PROG.tCARD32}, parser, pos, 66); IF e2.obj = eCONST THEN LoadConst(e2) END; CODE.setlast(endcall.prev(CODE.COMMAND)); IF proc = PROG.sysPUT8 THEN CODE.SysPut(1) ELSIF proc = PROG.sysPUT16 THEN CODE.SysPut(2) ELSIF proc = PROG.sysPUT32 THEN CODE.SysPut(4) END END; CODE.popBegEnd(begcall, endcall) |PROG.sysMOVE: FOR i := 1 TO 2 DO parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); IF e.obj = eCONST THEN LoadConst(e) END; PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos) END; parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); IF e.obj = eCONST THEN LoadConst(e) END; CODE.AddCmd0(CODE.opMOVE) |PROG.sysCOPY: FOR i := 1 TO 2 DO parser.designator(parser, e); PARS.check(isVar(e), parser, pos, 93); n := PROG.Dim(e.type); WHILE n > 0 DO CODE.drop; DEC(n) END; PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos) END; parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); IF e.obj = eCONST THEN LoadConst(e) END; CODE.AddCmd0(CODE.opMOVE) |PROG.sysCODE: REPEAT getpos(parser, pos); PARS.ConstExpression(parser, code); PARS.check(code.typ = ARITH.tINTEGER, parser, pos, 43); PARS.check(ARITH.range(code, 0, 255), parser, pos, 42); IF parser.sym = SCAN.lxCOMMA THEN PARS.Next(parser) ELSE PARS.checklex(parser, SCAN.lxRROUND) END; CODE.AddCmd(CODE.opCODE, ARITH.getInt(code)) UNTIL parser.sym = SCAN.lxRROUND END; e.obj := eEXPR; e.type := NIL ELSIF e.obj IN {eSTFUNC, eSYSFUNC} THEN CASE e.stproc OF |PROG.stABS: parser.expression(parser, e); PARS.check(isInt(e) OR isReal(e), parser, pos, 66); IF e.obj = eCONST THEN PARS.check(ARITH.abs(e.value), parser, pos, 39) ELSE CODE.abs(isReal(e)) END |PROG.stASR, PROG.stLSL, PROG.stROR, PROG.stLSR, PROG.stMIN, PROG.stMAX: parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); PARS.checklex(parser, SCAN.lxCOMMA); NextPos(parser, pos); parser.expression(parser, e2); PARS.check(isInt(e2), parser, pos, 66); e.type := PARS.program.stTypes.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 CODE.shift_minmax1(shift_minmax(proc), ARITH.Int(e.value)) ELSIF e2.obj = eCONST THEN CODE.shift_minmax2(shift_minmax(proc), ARITH.Int(e2.value)) ELSE CODE.shift_minmax(shift_minmax(proc)) END; e.obj := eEXPR END |PROG.stCHR: parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); e.type := PARS.program.stTypes.tCHAR; IF e.obj = eCONST THEN ARITH.setChar(e.value, ARITH.getInt(e.value)); PARS.check(ARITH.check(e.value), parser, pos, 107) ELSE IF chkCHR IN checking THEN CheckRange(256, pos.line, errCHR) ELSE CODE.AddCmd0(CODE.opCHR) END END |PROG.stWCHR: parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); e.type := PARS.program.stTypes.tWCHAR; IF e.obj = eCONST THEN ARITH.setWChar(e.value, ARITH.getInt(e.value)); PARS.check(ARITH.check(e.value), parser, pos, 101) ELSE IF chkWCHR IN checking THEN CheckRange(65536, pos.line, errWCHR) ELSE CODE.AddCmd0(CODE.opWCHR) END END |PROG.stFLOOR: parser.expression(parser, e); PARS.check(isReal(e), parser, pos, 66); e.type := PARS.program.stTypes.tINTEGER; IF e.obj = eCONST THEN PARS.check(ARITH.floor(e.value), parser, pos, 39) ELSE CODE.floor END |PROG.stFLT: parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); e.type := PARS.program.stTypes.tREAL; IF e.obj = eCONST THEN ARITH.flt(e.value) ELSE PARS.check(CODE.flt(), parser, pos, 41) END |PROG.stLEN: cmd1 := CODE.getlast(); varparam(parser, pos, isArr, FALSE, e); IF e.type.length > 0 THEN cmd2 := CODE.getlast(); CODE.delete2(cmd1.next, cmd2); CODE.setlast(cmd1); ASSERT(ARITH.setInt(e.value, e.type.length)); e.obj := eCONST ELSE CODE.len(PROG.Dim(e.type)) END; e.type := PARS.program.stTypes.tINTEGER |PROG.stLENGTH: parser.expression(parser, e); IF isCharArray(e) THEN IF e.type.length > 0 THEN CODE.AddCmd(CODE.opCONST, e.type.length) END; CODE.AddCmd0(CODE.opLENGTH) ELSIF isCharArrayW(e) THEN IF e.type.length > 0 THEN CODE.AddCmd(CODE.opCONST, e.type.length) END; CODE.AddCmd0(CODE.opLENGTHW) ELSE PARS.check(FALSE, parser, pos, 66); END; e.type := PARS.program.stTypes.tINTEGER |PROG.stODD: parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); e.type := PARS.program.stTypes.tBOOLEAN; IF e.obj = eCONST THEN ARITH.odd(e.value) ELSE CODE.odd END |PROG.stORD: parser.expression(parser, e); PARS.check(isChar(e) OR isBoolean(e) OR isSet(e) OR isCharW(e) OR isStringW1(e), parser, pos, 66); IF e.obj = eCONST THEN IF isStringW1(e) THEN ASSERT(ARITH.setInt(e.value, StrToWChar(e.value.string(SCAN.IDENT).s))) ELSE ARITH.ord(e.value) END ELSE IF isBoolean(e) THEN CODE.ord END END; e.type := PARS.program.stTypes.tINTEGER |PROG.stBITS: parser.expression(parser, e); PARS.check(isInt(e), parser, pos, 66); IF e.obj = eCONST THEN ARITH.bits(e.value) END; e.type := PARS.program.stTypes.tSET |PROG.sysADR: parser.designator(parser, e); IF isVar(e) THEN n := PROG.Dim(e.type); WHILE n > 0 DO CODE.drop; DEC(n) END ELSIF e.obj = ePROC THEN CODE.PushProc(e.ident.proc.label) ELSIF e.obj = eIMP THEN CODE.PushImpProc(e.ident.import) ELSE PARS.check(FALSE, parser, pos, 108) END; e.type := PARS.program.stTypes.tINTEGER |PROG.sysSADR: parser.expression(parser, e); PARS.check(isString(e), parser, pos, 66); CODE.AddCmd(CODE.opSADR, String(e)); e.type := PARS.program.stTypes.tINTEGER; e.obj := eEXPR |PROG.sysWSADR: parser.expression(parser, e); PARS.check(isStringW(e), parser, pos, 66); CODE.AddCmd(CODE.opSADR, StringW(e)); e.type := PARS.program.stTypes.tINTEGER; e.obj := eEXPR |PROG.sysTYPEID: parser.expression(parser, e); PARS.check(e.obj = eTYPE, parser, 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.check(FALSE, parser, pos, 52) END; e.obj := eCONST; e.type := PARS.program.stTypes.tINTEGER |PROG.sysINF: PARS.check(CODE.inf(), parser, pos, 41); e.obj := eEXPR; e.type := PARS.program.stTypes.tREAL |PROG.sysSIZE: parser.expression(parser, e); PARS.check(e.obj = eTYPE, parser, pos, 68); ASSERT(ARITH.setInt(e.value, e.type.size)); e.obj := eCONST; e.type := PARS.program.stTypes.tINTEGER END END; PARS.checklex(parser, SCAN.lxRROUND); PARS.Next(parser); 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: SCAN.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); CODE.setlast(begcall); IF param(PROG.PARAM).vPar THEN parser.designator(parser, e1) ELSE parser.expression(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 PARS.Next(parser); 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; import: BOOLEAN; pos: SCAN.POSITION; BEGIN PARS.checklex(parser, SCAN.lxIDENT); getpos(parser, pos); import := FALSE; ident := parser.unit.idents.get(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 := ident.unit.idents.get(ident.unit, parser.lex.ident, FALSE); PARS.check1((ident # NIL) & ident.export, parser, 48); import := 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 := import |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.stproc := ident.stproc |PROG.idSTFUNC: e.obj := eSTFUNC; e.stproc := ident.stproc |PROG.idSYSPROC: e.obj := eSYSPROC; e.stproc := ident.stproc |PROG.idSYSFUNC: PARS.check(~parser.constexp, parser, pos, 109); e.obj := eSYSFUNC; e.stproc := ident.stproc |PROG.idNONE: PARS.check(FALSE, parser, pos, 115) END; IF isVar(e) THEN PARS.check(e.ident.global OR (e.ident.scopeLvl = parser.unit.scopeLvl), parser, pos, 105) END END qualident; PROCEDURE deref (pos: SCAN.POSITION; e: PARS.EXPR; load: BOOLEAN; error: INTEGER); VAR label: INTEGER; BEGIN IF load THEN CODE.load(e.type.size) END; IF chkPTR IN checking THEN label := CODE.NewLabel(); CODE.AddJmpCmd(CODE.opJNZ, label); CODE.OnError(pos.line, error); CODE.SetLabel(label) END END deref; PROCEDURE designator (parser: PARS.PARSER; VAR e: PARS.EXPR); VAR field: PROG.FIELD; pos: SCAN.POSITION; t, idx: PARS.EXPR; 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 CODE.AddCmd(CODE.opVADR, offset); DEC(offset); DEC(n) END END OpenArray; BEGIN IF e.obj = eVAR THEN offset := PROG.getOffset(PARS.program, e.ident); IF e.ident.global THEN CODE.AddCmd(CODE.opGADR, offset) ELSE CODE.AddCmd(CODE.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 CODE.AddCmd(CODE.opVADR, e.ident.offset) ELSIF PROG.isOpenArray(e.type) THEN OpenArray(e) ELSE CODE.AddCmd(CODE.opLADR, e.ident.offset) END ELSIF e.obj IN {eVPAR, eVREC} THEN IF PROG.isOpenArray(e.type) THEN OpenArray(e) ELSE CODE.AddCmd(CODE.opVADR, e.ident.offset) END END END LoadAdr; PROCEDURE OpenIdx (parser: PARS.PARSER; pos: SCAN.POSITION; e: PARS.EXPR); VAR label: INTEGER; type: PROG.TYPE_; n, offset, k: INTEGER; BEGIN IF chkIDX IN checking THEN label := CODE.NewLabel(); CODE.AddCmd2(CODE.opCHKIDX2, label, 0); CODE.OnError(pos.line, errIDX); CODE.SetLabel(label) ELSE CODE.AddCmd(CODE.opCHKIDX2, -1) END; type := PROG.OpenBase(e.type); IF type.size # 1 THEN CODE.AddCmd(CODE.opMULC, type.size) END; n := PROG.Dim(e.type) - 1; k := n; WHILE n > 0 DO CODE.AddCmd0(CODE.opMUL); DEC(n) END; CODE.AddCmd0(CODE.opADD); offset := e.ident.offset - 1; n := k; WHILE n > 0 DO CODE.AddCmd(CODE.opVADR, offset); DEC(offset); DEC(n) END END OpenIdx; BEGIN qualident(parser, e); IF e.obj IN {ePROC, eIMP} THEN PROG.UseProc(parser.unit, e.ident.proc) END; IF isVar(e) 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 := e.type.fields.get(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 CODE.AddCmd(CODE.opADDR, 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); parser.expression(parser, idx); PARS.check(isInt(idx), parser, pos, 76); IF idx.obj = eCONST THEN IF e.type.length > 0 THEN PARS.check(ARITH.range(idx.value, 0, e.type.length - 1), parser, pos, 83); IF ARITH.Int(idx.value) > 0 THEN CODE.AddCmd(CODE.opADDR, ARITH.Int(idx.value) * e.type.base.size) END ELSE PARS.check(ARITH.range(idx.value, 0, MACHINE.target.maxInt), parser, pos, 83); LoadConst(idx); OpenIdx(parser, pos, e) END ELSE IF e.type.length > 0 THEN IF chkIDX IN checking THEN CheckRange(e.type.length, pos.line, errIDX) END; IF e.type.base.size # 1 THEN CODE.AddCmd(CODE.opMULC, e.type.base.size) END; CODE.AddCmd0(CODE.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); e.ident := NIL 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, parser, pos, 79); IF e.type.typ = PROG.tRECORD THEN PARS.check(t.type.typ = PROG.tRECORD, parser, pos, 80); IF chkGUARD IN checking THEN IF e.ident = NIL THEN CODE.TypeGuard(CODE.opTYPEGD, t.type.num, pos.line, errGUARD) ELSE CODE.AddCmd(CODE.opVADR, e.ident.offset - 1); CODE.TypeGuard(CODE.opTYPEGR, t.type.num, pos.line, errGUARD) END END; ELSE PARS.check(t.type.typ = PROG.tPOINTER, parser, pos, 81); IF chkGUARD IN checking THEN CODE.TypeGuard(CODE.opTYPEGP, t.type.base.num, pos.line, errGUARD) END END; PARS.check(PROG.isBaseOf(e.type, t.type), parser, 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; VAR fregs: INTEGER; parser: PARS.PARSER; pos: SCAN.POSITION; CallStat: BOOLEAN); VAR cconv: INTEGER; params: INTEGER; callconv: INTEGER; fparams: INTEGER; int, flt: INTEGER; stk_par: INTEGER; BEGIN cconv := procType.call; params := procType.params.size; IF cconv IN {PROG._win64, PROG.win64} THEN callconv := CODE.call_win64; fparams := LSL(ORD(procType.params.getfparams(procType, 3, int, flt)), 5) + MIN(params, 4) ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN callconv := CODE.call_sysv; fparams := LSL(ORD(procType.params.getfparams(procType, PROG.MAXSYSVPARAM - 1, int, flt)), 5) + params; stk_par := MAX(0, int - 6) + MAX(0, flt - 8) ELSE callconv := CODE.call_stack; fparams := 0 END; CODE.setlast(begcall); fregs := CODE.precall(isfloat); IF cconv IN {PROG._ccall16, PROG.ccall16} THEN CODE.AddCmd(CODE.opALIGN16, params) ELSIF cconv IN {PROG._win64, PROG.win64} THEN CODE.AddCmd(CODE.opWIN64ALIGN16, params) ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN CODE.AddCmd(CODE.opSYSVALIGN16, params + stk_par) END; CODE.setlast(endcall.prev(CODE.COMMAND)); IF e.obj = eIMP THEN CODE.CallImp(e.ident.import, callconv, fparams) ELSIF e.obj = ePROC THEN CODE.Call(e.ident.proc.label, callconv, fparams) ELSIF isExpr(e) THEN deref(pos, e, CallStat, errPROC); CODE.CallP(callconv, fparams) END; IF cconv IN {PROG._ccall16, PROG.ccall16} THEN CODE.AddCmd(CODE.opCLEANUP, params); CODE.AddCmd0(CODE.opPOPSP) ELSIF cconv IN {PROG._win64, PROG.win64} THEN CODE.AddCmd(CODE.opCLEANUP, MAX(params + params MOD 2, 4) + 1); CODE.AddCmd0(CODE.opPOPSP) ELSIF cconv IN {PROG._systemv, PROG.systemv} THEN CODE.AddCmd(CODE.opCLEANUP, params + stk_par); CODE.AddCmd0(CODE.opPOPSP) ELSIF cconv IN {PROG._ccall, PROG.ccall} THEN CODE.AddCmd(CODE.opCLEANUP, params) END; IF ~CallStat THEN IF isfloat THEN PARS.check(CODE.resf(fregs), parser, pos, 41) ELSE CODE.res(fregs) END END END ProcCall; PROCEDURE expression (parser: PARS.PARSER; VAR e: PARS.EXPR); VAR pos, pos0, pos1: SCAN.POSITION; op: INTEGER; e1: PARS.EXPR; constant: BOOLEAN; operator: ARITH.RELATION; error: INTEGER; 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: SCAN.POSITION; range: BOOLEAN; BEGIN range := FALSE; getpos(parser, pos); expression(parser, e1); PARS.check(isInt(e1), parser, pos, 76); IF e1.obj = eCONST THEN PARS.check(ARITH.range(e1.value, 0, MACHINE.target.maxSet), parser, pos, 44) END; range := parser.sym = SCAN.lxRANGE; IF range THEN NextPos(parser, pos); expression(parser, e2); PARS.check(isInt(e2), parser, pos, 76); IF e2.obj = eCONST THEN PARS.check(ARITH.range(e2.value, 0, MACHINE.target.maxSet), parser, pos, 44) END ELSE IF e1.obj = eCONST THEN e2 := e1 END END; e.type := PARS.program.stTypes.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 CODE.AddCmd(CODE.opRSETL, ARITH.Int(e1.value)) ELSIF e2.obj = eCONST THEN CODE.AddCmd(CODE.opRSETR, ARITH.Int(e2.value)) ELSE CODE.AddCmd0(CODE.opRSET) END ELSE CODE.AddCmd0(CODE.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 := PARS.program.stTypes.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 CODE.AddCmd(CODE.opADDSL, ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opADDSR, ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.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: SCAN.POSITION; e1: PARS.EXPR; isfloat: BOOLEAN; fregs: INTEGER; PROCEDURE LoadVar (e: PARS.EXPR; parser: PARS.PARSER; pos: SCAN.POSITION); BEGIN IF ~(e.type.typ IN {PROG.tRECORD, PROG.tARRAY}) THEN IF e.type.typ = PROG.tREAL THEN PARS.check(CODE.loadf(), parser, pos, 41) ELSE CODE.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 := PARS.program.getType(PARS.program, e.value.typ); PARS.Next(parser) ELSIF sym = SCAN.lxNIL THEN e.obj := eCONST; e.type := PARS.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 := PARS.program.stTypes.tBOOLEAN; PARS.Next(parser) ELSIF sym = SCAN.lxLCURLY THEN set(parser, e) ELSIF sym = SCAN.lxIDENT THEN getpos(parser, pos); CODE.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, parser, pos, 59); isfloat := e.type.typ = PROG.tREAL; IF e1.obj IN {ePROC, eIMP} THEN ProcCall(e1, e1.ident.type, isfloat, fregs, parser, pos, FALSE) ELSIF isExpr(e1) THEN ProcCall(e1, e1.type, isfloat, fregs, parser, pos, FALSE) END END; CODE.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), parser, pos, 72); IF e.obj # eCONST THEN CODE.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: SCAN.POSITION; op: INTEGER; e1: PARS.EXPR; label: INTEGER; 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 := CODE.NewLabel() END; IF e.obj = eCONST THEN CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e.value))) END; CODE.AddCmd0(CODE.opACC); CODE.AddJmpCmd(CODE.opJZ, label); CODE.drop 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), parser, 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, "*"), parser, pos, 39) |ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, "*"), parser, pos, 40) |ARITH.tSET: ARITH.opSet(e.value, e1.value, "*") END ELSE IF isInt(e) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opMULC, ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opMULC, ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.opMUL) END ELSIF isReal(e) THEN IF e.obj = eCONST THEN CODE.Float(ARITH.Float(e.value)) ELSIF e1.obj = eCONST THEN CODE.Float(ARITH.Float(e1.value)) END; CODE.fbinop(CODE.opMULF) ELSIF isSet(e) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opMULSC, ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opMULSC, ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.opMULS) END END; e.obj := eEXPR END |SCAN.lxSLASH: PARS.check(isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), parser, pos, 37); IF (e1.obj = eCONST) & isReal(e1) THEN PARS.check(~ARITH.isZero(e1.value), parser, 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, "/"), parser, pos, 40) |ARITH.tSET: ARITH.opSet(e.value, e1.value, "/") END ELSE IF isReal(e) THEN IF e.obj = eCONST THEN CODE.Float(ARITH.Float(e.value)); CODE.fbinop(CODE.opDIVFI) ELSIF e1.obj = eCONST THEN CODE.Float(ARITH.Float(e1.value)); CODE.fbinop(CODE.opDIVF) ELSE CODE.fbinop(CODE.opDIVF) END ELSIF isSet(e) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opDIVSC, ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opDIVSC, ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.opDIVS) END END; e.obj := eEXPR END |SCAN.lxDIV, SCAN.lxMOD: PARS.check(isInt(e) & isInt(e1), parser, pos, 37); IF e1.obj = eCONST THEN PARS.check(~ARITH.isZero(e1.value), parser, pos, 46) END; IF (e.obj = eCONST) & (e1.obj = eCONST) THEN IF op = SCAN.lxDIV THEN PARS.check(ARITH.opInt(e.value, e1.value, "D"), parser, pos, 39) ELSE ASSERT(ARITH.opInt(e.value, e1.value, "M")) END ELSE IF e1.obj # eCONST THEN label1 := CODE.NewLabel(); CODE.AddJmpCmd(CODE.opJNZ, label1) END; IF e.obj = eCONST THEN CODE.OnError(pos.line, errDIV); CODE.SetLabel(label1); CODE.AddCmd(CODE.opDIVL + ORD(op = SCAN.lxMOD), ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opDIVR + ORD(op = SCAN.lxMOD), ARITH.Int(e1.value)) ELSE CODE.OnError(pos.line, errDIV); CODE.SetLabel(label1); CODE.AddCmd0(CODE.opDIV + ORD(op = SCAN.lxMOD)) END; e.obj := eEXPR END |SCAN.lxAND: PARS.check(isBoolean(e) & isBoolean(e1), parser, pos, 37); IF (e.obj = eCONST) & (e1.obj = eCONST) THEN ARITH.opBoolean(e.value, e1.value, "&") ELSE e.obj := eEXPR; IF e1.obj = eCONST THEN CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e1.value))) END; CODE.AddCmd0(CODE.opACC) END END END; IF label # -1 THEN CODE.SetLabel(label) END END term; PROCEDURE SimpleExpression (parser: PARS.PARSER; VAR e: PARS.EXPR); VAR pos: SCAN.POSITION; op: INTEGER; e1: PARS.EXPR; plus, minus: BOOLEAN; label: 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), parser, pos, 36); IF minus & (e.obj = eCONST) THEN PARS.check(ARITH.neg(e.value), parser, pos, 39) END; IF e.obj # eCONST THEN IF minus THEN IF isInt(e) THEN CODE.AddCmd0(CODE.opUMINUS) ELSIF isReal(e) THEN CODE.AddCmd0(CODE.opUMINF) ELSIF isSet(e) THEN CODE.AddCmd0(CODE.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 := CODE.NewLabel() END; IF e.obj = eCONST THEN CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e.value))) END; CODE.AddCmd0(CODE.opACC); CODE.AddJmpCmd(CODE.opJNZ, label); CODE.drop END END; term(parser, e1); CASE op OF |SCAN.lxPLUS, SCAN.lxMINUS: IF op = SCAN.lxPLUS THEN op := ORD("+") ELSE op := ORD("-") END; PARS.check(isInt(e) & isInt(e1) OR isReal(e) & isReal(e1) OR isSet(e) & isSet(e1), parser, 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)), parser, pos, 39) |ARITH.tREAL: PARS.check(ARITH.opFloat(e.value, e1.value, CHR(op)), parser, pos, 40) |ARITH.tSET: ARITH.opSet(e.value, e1.value, CHR(op)) END ELSE IF isInt(e) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opADDL + ORD(op = ORD("-")), ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opADDR + ORD(op = ORD("-")), ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.opADD + ORD(op = ORD("-"))) END ELSIF isReal(e) THEN IF e.obj = eCONST THEN CODE.Float(ARITH.Float(e.value)); CODE.fbinop(CODE.opADDFI + ORD(op = ORD("-"))) ELSIF e1.obj = eCONST THEN CODE.Float(ARITH.Float(e1.value)); CODE.fbinop(CODE.opADDF + ORD(op = ORD("-"))) ELSE CODE.fbinop(CODE.opADDF + ORD(op = ORD("-"))) END ELSIF isSet(e) THEN IF e.obj = eCONST THEN CODE.AddCmd(CODE.opADDSL + ORD(op = ORD("-")), ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opADDSR + ORD(op = ORD("-")), ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.opADDS + ORD(op = ORD("-"))) END END; e.obj := eEXPR END |SCAN.lxOR: PARS.check(isBoolean(e) & isBoolean(e1), parser, pos, 37); IF (e.obj = eCONST) & (e1.obj = eCONST) THEN ARITH.opBoolean(e.value, e1.value, "|") ELSE e.obj := eEXPR; IF e1.obj = eCONST THEN CODE.AddCmd(CODE.opCONST, ORD(ARITH.getBool(e1.value))) END; CODE.AddCmd0(CODE.opACC) END END END; IF label # -1 THEN CODE.SetLabel(label) END END SimpleExpression; PROCEDURE cmpcode (op: INTEGER): INTEGER; VAR res: INTEGER; BEGIN CASE op OF |SCAN.lxEQ: res := 0 |SCAN.lxNE: res := 1 |SCAN.lxLT: res := 2 |SCAN.lxLE: res := 3 |SCAN.lxGT: res := 4 |SCAN.lxGE: res := 5 END RETURN res END cmpcode; PROCEDURE BoolCmp (eq, val: BOOLEAN); BEGIN IF eq = val THEN CODE.AddCmd0(CODE.opNER) ELSE CODE.AddCmd0(CODE.opEQR) END END BoolCmp; PROCEDURE strcmp (VAR e, e1: PARS.EXPR; op: INTEGER): BOOLEAN; VAR res: BOOLEAN; BEGIN res := TRUE; IF isString(e) & isCharArray(e1) THEN CODE.AddCmd(CODE.opSADR, String(e)); CODE.AddCmd(CODE.opCONST, strlen(e) + 1); CODE.AddCmd0(CODE.opEQS2 + cmpcode(op)) ELSIF isString(e) & isCharArrayW(e1) THEN CODE.AddCmd(CODE.opSADR, StringW(e)); CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1); CODE.AddCmd0(CODE.opEQSW2 + cmpcode(op)) ELSIF isStringW(e) & isCharArrayW(e1) THEN CODE.AddCmd(CODE.opSADR, StringW(e)); CODE.AddCmd(CODE.opCONST, utf8strlen(e) + 1); CODE.AddCmd0(CODE.opEQSW2 + cmpcode(op)) ELSIF isCharArray(e) & isString(e1) THEN CODE.AddCmd(CODE.opSADR, String(e1)); CODE.AddCmd(CODE.opCONST, strlen(e1) + 1); CODE.AddCmd0(CODE.opEQS + cmpcode(op)) ELSIF isCharArrayW(e) & isString(e1) THEN CODE.AddCmd(CODE.opSADR, StringW(e1)); CODE.AddCmd(CODE.opCONST, utf8strlen(e1) + 1); CODE.AddCmd0(CODE.opEQSW + cmpcode(op)) ELSIF isCharArrayW(e) & isStringW(e1) THEN CODE.AddCmd(CODE.opSADR, StringW(e1)); CODE.AddCmd(CODE.opCONST, utf8strlen(e1) + 1); CODE.AddCmd0(CODE.opEQSW + cmpcode(op)) ELSIF isCharArrayW(e) & isCharArrayW(e1) THEN CODE.AddCmd0(CODE.opEQSW + cmpcode(op)) ELSIF isCharArray(e) & isCharArray(e1) THEN CODE.AddCmd0(CODE.opEQS + cmpcode(op)) 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 CODE.AddCmd(CODE.opCONST, e.type.length) END; op := parser.sym; getpos(parser, pos); PARS.Next(parser); pos1 := parser.lex.pos; SimpleExpression(parser, e1); IF (isCharArray(e1) OR isCharArrayW(e1)) & (e1.type.length # 0) THEN CODE.AddCmd(CODE.opCONST, e1.type.length) END; constant := (e.obj = eCONST) & (e1.obj = eCONST); CASE op OF |SCAN.lxEQ: operator := "=" |SCAN.lxNE: operator := "#" |SCAN.lxLT: operator := "<" |SCAN.lxLE: operator := "<=" |SCAN.lxGT: operator := ">" |SCAN.lxGE: operator := ">=" |SCAN.lxIN: operator := "IN" |SCAN.lxIS: operator := "" END; error := 0; CASE op OF |SCAN.lxEQ, SCAN.lxNE: 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, operator, error) ELSE IF e.obj = eCONST THEN CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.opEQ + cmpcode(op)) END END ELSIF isStringW1(e) & isCharW(e1) THEN CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, StrToWChar(e.value.string(SCAN.IDENT).s)) ELSIF isStringW1(e1) & isCharW(e) THEN CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, StrToWChar(e1.value.string(SCAN.IDENT).s)) ELSIF isBoolean(e) & isBoolean(e1) THEN IF constant THEN ARITH.relation(e.value, e1.value, operator, error) ELSE IF e.obj = eCONST THEN BoolCmp(op = SCAN.lxEQ, ARITH.Int(e.value) # 0) ELSIF e1.obj = eCONST THEN BoolCmp(op = SCAN.lxEQ, ARITH.Int(e1.value) # 0) ELSE IF op = SCAN.lxEQ THEN CODE.AddCmd0(CODE.opEQB) ELSE CODE.AddCmd0(CODE.opNEB) END END END ELSIF isReal(e) & isReal(e1) THEN IF constant THEN ARITH.relation(e.value, e1.value, operator, error) ELSE IF e.obj = eCONST THEN CODE.Float(ARITH.Float(e.value)); CODE.fcmp(CODE.opEQF + cmpcode(op) + 6) ELSIF e1.obj = eCONST THEN CODE.Float(ARITH.Float(e1.value)); CODE.fcmp(CODE.opEQF + cmpcode(op)) ELSE CODE.fcmp(CODE.opEQF + cmpcode(op)) END END ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN IF ~strcmp(e, e1, op) THEN PARS.error(parser, pos, 37) END ELSIF isPtr(e) & isNil(e1) OR isNil(e) & isPtr(e1) THEN CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6) ELSIF isProc(e) & isNil(e1) THEN IF e.obj IN {ePROC, eIMP} THEN PARS.check(e.ident.global, parser, pos0, 85); constant := TRUE; e.obj := eCONST; ARITH.setbool(e.value, op = SCAN.lxNE) ELSE CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6) END ELSIF isNil(e) & isProc(e1) THEN IF e1.obj IN {ePROC, eIMP} THEN PARS.check(e1.ident.global, parser, pos1, 85); constant := TRUE; e.obj := eCONST; ARITH.setbool(e.value, op = SCAN.lxNE) ELSE CODE.AddCmd0(CODE.opEQ + cmpcode(op) + 6) END ELSIF isProc(e) & isProc(e1) & PROG.isTypeEq(e.type, e1.type) THEN IF e.obj = ePROC THEN PARS.check(e.ident.global, parser, pos0, 85) END; IF e1.obj = ePROC THEN PARS.check(e1.ident.global, parser, pos1, 85) END; IF (e.obj IN {ePROC, eIMP}) & (e1.obj IN {ePROC, eIMP}) THEN constant := TRUE; e.obj := eCONST; IF op = SCAN.lxEQ THEN ARITH.setbool(e.value, e.ident = e1.ident) ELSE ARITH.setbool(e.value, e.ident # e1.ident) END ELSIF e.obj = ePROC THEN CODE.ProcCmp(e.ident.proc.label, cmpcode(op) = 0) ELSIF e1.obj = ePROC THEN CODE.ProcCmp(e1.ident.proc.label, cmpcode(op) = 0) ELSIF e.obj = eIMP THEN CODE.ProcImpCmp(e.ident.import, cmpcode(op) = 0) ELSIF e1.obj = eIMP THEN CODE.ProcImpCmp(e1.ident.import, cmpcode(op) = 0) ELSE CODE.AddCmd0(CODE.opEQ + cmpcode(op)) END ELSIF isNil(e) & isNil(e1) THEN constant := TRUE; e.obj := eCONST; ARITH.setbool(e.value, op = SCAN.lxEQ) ELSE PARS.error(parser, 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, operator, error) ELSE IF e.obj = eCONST THEN CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.opEQ + cmpcode(op)) END END ELSIF isStringW1(e) & isCharW(e1) THEN CODE.AddCmd(CODE.opEQ + cmpcode(op) + 6, StrToWChar(e.value.string(SCAN.IDENT).s)) ELSIF isStringW1(e1) & isCharW(e) THEN CODE.AddCmd(CODE.opEQ + cmpcode(op) + 12, StrToWChar(e1.value.string(SCAN.IDENT).s)) ELSIF isReal(e) & isReal(e1) THEN IF constant THEN ARITH.relation(e.value, e1.value, operator, error) ELSE IF e.obj = eCONST THEN CODE.Float(ARITH.Float(e.value)); CODE.fcmp(CODE.opEQF + cmpcode(op) + 6) ELSIF e1.obj = eCONST THEN CODE.Float(ARITH.Float(e1.value)); CODE.fcmp(CODE.opEQF + cmpcode(op)) ELSE CODE.fcmp(CODE.opEQF + cmpcode(op)) END END ELSIF (isStringW(e) OR isCharArrayX(e)) & (isStringW(e1) OR isCharArrayX(e1)) THEN IF ~strcmp(e, e1, op) THEN PARS.error(parser, pos, 37) END ELSE PARS.error(parser, pos, 37) END |SCAN.lxIN: PARS.check(isInt(e) & isSet(e1), parser, pos, 37); IF e.obj = eCONST THEN PARS.check(ARITH.range(e.value, 0, MACHINE.target.maxSet), parser, pos0, 56) END; IF constant THEN ARITH.relation(e.value, e1.value, operator, error) ELSE IF e.obj = eCONST THEN CODE.AddCmd(CODE.opINL, ARITH.Int(e.value)) ELSIF e1.obj = eCONST THEN CODE.AddCmd(CODE.opINR, ARITH.Int(e1.value)) ELSE CODE.AddCmd0(CODE.opIN) END END |SCAN.lxIS: PARS.check(isExpr(e) & (e.type.typ IN {PROG.tRECORD, PROG.tPOINTER}), parser, pos, 73); IF e.type.typ = PROG.tRECORD THEN PARS.check(e.obj = eVREC, parser, pos0, 78) END; PARS.check(e1.obj = eTYPE, parser, pos1, 79); IF e.type.typ = PROG.tRECORD THEN PARS.check(e1.type.typ = PROG.tRECORD, parser, pos1, 80); IF e.ident = NIL THEN CODE.TypeCheck(e1.type.num) ELSE CODE.AddCmd(CODE.opVADR, e.ident.offset - 1); CODE.TypeCheckRec(e1.type.num) END ELSE PARS.check(e1.type.typ = PROG.tPOINTER, parser, pos1, 81); CODE.TypeCheck(e1.type.base.num) END; PARS.check(PROG.isBaseOf(e.type, e1.type), parser, pos1, 82) END; ASSERT(error = 0); e.type := PARS.program.stTypes.tBOOLEAN; IF ~constant THEN e.obj := eEXPR END END END expression; PROCEDURE ElementaryStatement (parser: PARS.PARSER); VAR e, e1: PARS.EXPR; pos: SCAN.POSITION; line: INTEGER; call: BOOLEAN; fregs: INTEGER; BEGIN getpos(parser, pos); CODE.pushBegEnd(begcall, endcall); designator(parser, e); IF parser.sym = SCAN.lxASSIGN THEN line := parser.lex.pos.line; PARS.check(isVar(e), parser, pos, 93); PARS.check(~e.readOnly, parser, pos, 94); CODE.setlast(begcall); NextPos(parser, pos); expression(parser, e1); CODE.setlast(endcall.prev(CODE.COMMAND)); PARS.check(assign(e1, e.type, line), parser, pos, 91); IF e1.obj = ePROC THEN PARS.check(e1.ident.global, parser, 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), parser, pos, 92); call := TRUE ELSE PARS.check(isProc(e), parser, pos, 86); PARS.check((e.type.base = NIL) OR ODD(e.type.call), parser, pos, 92); PARS.check1(e.type.params.first = NIL, parser, 64); call := TRUE END; IF call THEN IF e.obj IN {ePROC, eIMP} THEN ProcCall(e, e.ident.type, FALSE, fregs, parser, pos, TRUE) ELSIF isExpr(e) THEN ProcCall(e, e.type, FALSE, fregs, parser, pos, TRUE) END END; CODE.popBegEnd(begcall, endcall) END ElementaryStatement; PROCEDURE IfStatement (parser: PARS.PARSER; if: BOOLEAN); VAR e: PARS.EXPR; pos: SCAN.POSITION; label, L: INTEGER; BEGIN L := CODE.NewLabel(); IF ~if THEN CODE.AddCmd0(CODE.opLOOP); CODE.SetLabel(L) END; REPEAT NextPos(parser, pos); label := CODE.NewLabel(); expression(parser, e); PARS.check(isBoolean(e), parser, pos, 72); IF e.obj = eCONST THEN IF ~ARITH.getBool(e.value) THEN CODE.AddJmpCmd(CODE.opJMP, label) END ELSE CODE.AddJmpCmd(CODE.opJNE, label) END; IF if THEN PARS.checklex(parser, SCAN.lxTHEN) ELSE PARS.checklex(parser, SCAN.lxDO) END; PARS.Next(parser); parser.StatSeq(parser); CODE.AddJmpCmd(CODE.opJMP, L); CODE.SetLabel(label) UNTIL parser.sym # SCAN.lxELSIF; IF if THEN IF parser.sym = SCAN.lxELSE THEN PARS.Next(parser); parser.StatSeq(parser) END; CODE.SetLabel(L) END; PARS.checklex(parser, SCAN.lxEND); IF ~if THEN CODE.AddCmd0(CODE.opENDLOOP) END; PARS.Next(parser) END IfStatement; PROCEDURE RepeatStatement (parser: PARS.PARSER); VAR e: PARS.EXPR; pos: SCAN.POSITION; label: INTEGER; BEGIN CODE.AddCmd0(CODE.opLOOP); label := CODE.NewLabel(); CODE.SetLabel(label); PARS.Next(parser); parser.StatSeq(parser); PARS.checklex(parser, SCAN.lxUNTIL); NextPos(parser, pos); expression(parser, e); PARS.check(isBoolean(e), parser, pos, 72); IF e.obj = eCONST THEN IF ~ARITH.getBool(e.value) THEN CODE.AddJmpCmd(CODE.opJMP, label) END ELSE CODE.AddJmpCmd(CODE.opJNE, label) END; CODE.AddCmd0(CODE.opENDLOOP) 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: CODE.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: SCAN.POSITION; PROCEDURE isRecPtr (caseExpr: PARS.EXPR): BOOLEAN; RETURN isRec(caseExpr) OR isPtr(caseExpr) END isRecPtr; PROCEDURE Label (parser: PARS.PARSER; caseExpr: PARS.EXPR; VAR type: PROG.TYPE_): INTEGER; VAR a: INTEGER; label: PARS.EXPR; pos: SCAN.POSITION; value: ARITH.VALUE; BEGIN getpos(parser, pos); type := NIL; IF isChar(caseExpr) THEN PARS.ConstExpression(parser, value); PARS.check(value.typ = ARITH.tCHAR, parser, pos, 99); a := ARITH.getInt(value) ELSIF isCharW(caseExpr) THEN PARS.ConstExpression(parser, value); IF (value.typ = ARITH.tSTRING) & (_length(value.string(SCAN.IDENT).s) = 1) & (LENGTH(value.string(SCAN.IDENT).s) > 1) THEN ASSERT(ARITH.setInt(value, StrToWChar(value.string(SCAN.IDENT).s))) ELSE PARS.check(value.typ IN {ARITH.tWCHAR, ARITH.tCHAR}, parser, pos, 99) END; a := ARITH.getInt(value) ELSIF isInt(caseExpr) THEN PARS.ConstExpression(parser, value); PARS.check(value.typ = ARITH.tINTEGER, parser, pos, 99); a := ARITH.getInt(value) ELSIF isRecPtr(caseExpr) THEN qualident(parser, label); PARS.check(label.obj = eTYPE, parser, pos, 79); PARS.check(PROG.isBaseOf(caseExpr.type, label.type), parser, 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: SCAN.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)), parser, 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: SCAN.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 := CODE.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, parser, 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, parser, 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: CODE.COMMAND; BEGIN sym := parser.sym; IF sym # SCAN.lxBAR THEN variant := CODE.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 := CODE.getlast(); CODE.SetLabel(variant); IF ~isRecPtr(caseExpr) THEN LISTS.push(CaseVariants, NewVariant(variant, last)) END; parser.StatSeq(parser); CODE.AddJmpCmd(CODE.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: CODE.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 := CODE.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)); CODE.setlast(v.cmd); CODE.SetLabel(node.data(CASE_LABEL).self); CODE.case(range.a, range.b, L, R); IF v.processed THEN CODE.AddJmpCmd(CODE.opJMP, node.data(CASE_LABEL).variant) END; v.processed := TRUE; CODE.setlast(last); Table(left, else); Table(right, else) END END Table; PROCEDURE TableT (node: AVL.NODE); BEGIN IF node # NIL THEN CODE.caset(node.data(CASE_LABEL).range.a, node.data(CASE_LABEL).variant); TableT(node.left); TableT(node.right) END END TableT; PROCEDURE ParseCase (parser: PARS.PARSER; e: PARS.EXPR; pos: SCAN.POSITION); VAR table, end, else: INTEGER; tree: AVL.NODE; item: LISTS.ITEM; BEGIN LISTS.push(CaseVariants, NewVariant(0, NIL)); end := CODE.NewLabel(); else := CODE.NewLabel(); table := CODE.NewLabel(); CODE.AddCmd(CODE.opSWITCH, ORD(isRecPtr(e))); CODE.AddJmpCmd(CODE.opJMP, table); tree := NIL; case(parser, e, tree, end); WHILE parser.sym = SCAN.lxBAR DO PARS.Next(parser); case(parser, e, tree, end) END; CODE.SetLabel(else); IF parser.sym = SCAN.lxELSE THEN PARS.Next(parser); parser.StatSeq(parser); CODE.AddJmpCmd(CODE.opJMP, end) ELSE CODE.OnError(pos.line, errCASE) END; PARS.checklex(parser, SCAN.lxEND); PARS.Next(parser); IF isRecPtr(e) THEN CODE.SetLabel(table); TableT(tree); CODE.AddJmpCmd(CODE.opJMP, else) ELSE tree.data(CASE_LABEL).self := table; Table(tree, else) END; AVL.destroy(tree, DestroyLabel); CODE.SetLabel(end); CODE.AddCmd0(CODE.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), parser, pos, 95); IF isRecPtr(e) THEN PARS.check(isVar(e), parser, pos, 93); PARS.check(e.ident # NIL, parser, pos, 106) END; IF isRec(e) THEN PARS.check(e.obj = eVREC, parser, pos, 78) END; IF e.obj = eCONST THEN LoadConst(e) ELSIF isRec(e) THEN CODE.drop; CODE.AddCmd(CODE.opLADR, e.ident.offset - 1); CODE.load(PARS.program.target.word) ELSIF isPtr(e) THEN deref(pos, e, FALSE, errPTR); CODE.AddCmd(CODE.opSUBR, PARS.program.target.word); CODE.load(PARS.program.target.word) 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: SCAN.POSITION; step: ARITH.VALUE; st: INTEGER; ident: PROG.IDENT; offset: INTEGER; L1, L2: INTEGER; BEGIN CODE.AddCmd0(CODE.opLOOP); L1 := CODE.NewLabel(); L2 := CODE.NewLabel(); PARS.ExpectSym(parser, SCAN.lxIDENT); ident := parser.unit.idents.get(parser.unit, parser.lex.ident, TRUE); PARS.check1(ident # NIL, parser, 48); PARS.check1(ident.typ = PROG.idVAR, parser, 93); PARS.check1(ident.type.typ = PROG.tINTEGER, parser, 97); PARS.ExpectSym(parser, SCAN.lxASSIGN); NextPos(parser, pos); expression(parser, e); PARS.check(isInt(e), parser, pos, 76); offset := PROG.getOffset(PARS.program, ident); IF ident.global THEN CODE.AddCmd(CODE.opGADR, offset) ELSE CODE.AddCmd(CODE.opLADR, -offset) END; IF e.obj = eCONST THEN CODE.AddCmd(CODE.opSAVEC, ARITH.Int(e.value)) ELSE CODE.AddCmd0(CODE.opSAVE) END; CODE.SetLabel(L1); IF ident.global THEN CODE.AddCmd(CODE.opGADR, offset) ELSE CODE.AddCmd(CODE.opLADR, -offset) END; CODE.load(ident.type.size); PARS.checklex(parser, SCAN.lxTO); NextPos(parser, pos); expression(parser, e); PARS.check(isInt(e), parser, pos, 76); IF parser.sym = SCAN.lxBY THEN NextPos(parser, pos); PARS.ConstExpression(parser, step); PARS.check(step.typ = ARITH.tINTEGER, parser, pos, 76); st := ARITH.getInt(step); PARS.check(st # 0, parser, pos, 98) ELSE st := 1 END; IF e.obj = eCONST THEN IF st > 0 THEN CODE.AddCmd(CODE.opLER, ARITH.Int(e.value)) ELSE CODE.AddCmd(CODE.opGER, ARITH.Int(e.value)) END ELSE IF st > 0 THEN CODE.AddCmd0(CODE.opLE) ELSE CODE.AddCmd0(CODE.opGE) END END; CODE.AddJmpCmd(CODE.opJNE, L2); PARS.checklex(parser, SCAN.lxDO); PARS.Next(parser); parser.StatSeq(parser); IF ident.global THEN CODE.AddCmd(CODE.opGADR, offset) ELSE CODE.AddCmd(CODE.opLADR, -offset) END; IF st = 1 THEN CODE.AddCmd0(CODE.opINC1) ELSIF st = -1 THEN CODE.AddCmd0(CODE.opDEC1) ELSE IF st > 0 THEN CODE.AddCmd(CODE.opINCC, st) ELSE CODE.AddCmd(CODE.opDECC, -st) END END; CODE.AddJmpCmd(CODE.opJMP, L1); PARS.checklex(parser, SCAN.lxEND); PARS.Next(parser); CODE.SetLabel(L2); CODE.AddCmd0(CODE.opENDLOOP) 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: SCAN.POSITION): BOOLEAN; VAR res: BOOLEAN; BEGIN res := assigncomp(e, t); IF res THEN IF e.obj = eCONST THEN IF e.type.typ = PROG.tREAL THEN CODE.Float(ARITH.Float(e.value)) ELSIF e.type.typ = PROG.tNIL THEN CODE.AddCmd(CODE.opCONST, 0) ELSE LoadConst(e) END ELSIF (e.type.typ = PROG.tINTEGER) & (t.typ = PROG.tBYTE) & (chkBYTE IN checking) THEN CheckRange(256, pos.line, errBYTE) ELSIF e.obj = ePROC THEN PARS.check(e.ident.global, parser, pos, 85); CODE.PushProc(e.ident.proc.label) ELSIF e.obj = eIMP THEN CODE.PushImpProc(e.ident.import) END; IF e.type.typ = PROG.tREAL THEN CODE.retf END END RETURN res END chkreturn; PROCEDURE setrtl; VAR rtl: PROG.UNIT; PROCEDURE getproc (rtl: PROG.UNIT; name: SCAN.LEXSTR; idx: INTEGER); VAR id: PROG.IDENT; BEGIN id := rtl.idents.get(rtl, SCAN.enterid(name), FALSE); IF (id # NIL) & (id.import # NIL) THEN CODE.codes.rtl[idx] := -id.import(CODE.IMPORT_PROC).label; id.proc.used := TRUE ELSIF (id # NIL) & (id.proc # NIL) THEN CODE.codes.rtl[idx] := id.proc.label; id.proc.used := TRUE ELSE ERRORS.error5("procedure ", mConst.RTL_NAME, ".", name, " not found") END END getproc; BEGIN rtl := PARS.program.rtl; ASSERT(rtl # NIL); getproc(rtl, "_move", CODE._move); getproc(rtl, "_move2", CODE._move2); getproc(rtl, "_set", CODE._set); getproc(rtl, "_set2", CODE._set2); getproc(rtl, "_div", CODE._div); getproc(rtl, "_mod", CODE._mod); getproc(rtl, "_div2", CODE._div2); getproc(rtl, "_mod2", CODE._mod2); getproc(rtl, "_arrcpy", CODE._arrcpy); getproc(rtl, "_rot", CODE._rot); getproc(rtl, "_new", CODE._new); getproc(rtl, "_dispose", CODE._dispose); getproc(rtl, "_strcmp", CODE._strcmp); getproc(rtl, "_error", CODE._error); getproc(rtl, "_is", CODE._is); getproc(rtl, "_isrec", CODE._isrec); getproc(rtl, "_guard", CODE._guard); getproc(rtl, "_guardrec", CODE._guardrec); getproc(rtl, "_length", CODE._length); getproc(rtl, "_init", CODE._init); getproc(rtl, "_dllentry", CODE._dllentry); getproc(rtl, "_strcpy", CODE._strcpy); getproc(rtl, "_exit", CODE._exit); getproc(rtl, "_strcpy2", CODE._strcpy2); getproc(rtl, "_lengthw", CODE._lengthw); getproc(rtl, "_strcmp2", CODE._strcmp2); getproc(rtl, "_strcmpw", CODE._strcmpw); getproc(rtl, "_strcmpw2", CODE._strcmpw2); END setrtl; PROCEDURE compile* (path, lib_path, modname, outname: PARS.PATH; target, version, stack, base: INTEGER; pic: BOOLEAN; chk: SET); VAR parser: PARS.PARSER; ext: PARS.PATH; amd64: BOOLEAN; BEGIN amd64 := target IN {mConst.Target_iConsole64, mConst.Target_iGUI64, mConst.Target_iDLL64, mConst.Target_iELF64}; ext := mConst.FILE_EXT; CaseLabels := C.create(); CaseVar := C.create(); CaseVariants := LISTS.create(NIL); LISTS.push(CaseVariants, NewVariant(0, NIL)); checking := chk; IF amd64 THEN CODE.init(6, CODE.little_endian) ELSE CODE.init(8, CODE.little_endian) END; parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn); IF parser.open(parser, mConst.RTL_NAME) 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, mConst.RTL_NAME) THEN parser.parse(parser); PARS.destroy(parser) ELSE ERRORS.error5("file ", lib_path, mConst.RTL_NAME, mConst.FILE_EXT, " not found") END END; parser := PARS.create(path, lib_path, StatSeq, expression, designator, chkreturn); parser.main := TRUE; IF parser.open(parser, modname) THEN parser.parse(parser) ELSE ERRORS.error5("file ", path, modname, mConst.FILE_EXT, " not found") END; PARS.destroy(parser); IF PARS.program.bss > mConst.MAX_GLOBAL_SIZE THEN ERRORS.error1("size of global variables is too large") END; setrtl; PROG.DelUnused(PARS.program, CODE.DelImport); CODE.codes.bss := PARS.program.bss; IF amd64 THEN AMD64.CodeGen(CODE.codes, outname, target, stack, base) ELSE X86.CodeGen(CODE.codes, outname, target, stack, base, version, pic) END END compile; END STATEMENTS.