kolibrios/programs/develop/oberon07/Source/Compiler.ob07

1958 lines
50 KiB
Plaintext
Raw Normal View History

(*
Copyright 2016, 2017, 2018 Anton Krotov
This file is part of Compiler.
Compiler is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Compiler is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Compiler. If not, see <http://www.gnu.org/licenses/>.
*)
MODULE Compiler;
IMPORT DECL, SCAN, UTILS, X86, SYSTEM;
CONST
Slash = UTILS.Slash;
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7;
TNIL = 8; TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14;
TNUM = {TINTEGER, TREAL, TLONGREAL};
TFLOAT = {TREAL, TLONGREAL};
TOBJECT = {TRECORD, TPOINTER};
TSTRUCT = {TARRAY, TRECORD};
eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6;
IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9;
stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8;
stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15;
stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
stBITS = 23; stLSR = 24; stLENGTH = 25; stMIN = 26; stMAX = 27;
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCOPY = 109;
TYPE
LABEL = POINTER TO RECORD (UTILS.rITEM)
a, b: INTEGER
END;
VAR
pExpr, pFactor: PROCEDURE (VAR e: DECL.EXPRESSION);
pOpSeq: PROCEDURE;
sttypes: DECL.stTYPES;
voidtype, inttype, booltype, strtype, settype, realtype, longrealtype, chartype, niltype: DECL.pTYPE;
PROCEDURE Load(e: DECL.EXPRESSION);
BEGIN
IF e.eType = eVAR THEN
X86.Load(e.T.tType)
END
END Load;
PROCEDURE LenString(adr: LONGREAL): INTEGER;
VAR s: UTILS.STRCONST;
BEGIN
s := DECL.GetString(adr)
RETURN s.Len
END LenString;
PROCEDURE Assert(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, coord, code)
END
END Assert;
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, SCAN.coord, code)
END
END Assert2;
PROCEDURE IntType(T: DECL.pTYPE; coord: SCAN.TCoord);
BEGIN
Assert(T.tType = TINTEGER, coord, 52)
END IntType;
PROCEDURE Next;
BEGIN
DECL.Next
END Next;
PROCEDURE Coord(VAR coord: SCAN.TCoord);
BEGIN
coord := SCAN.coord
END Coord;
PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
BEGIN
DECL.Next;
coord := SCAN.coord
END NextCoord;
PROCEDURE Check(key: INTEGER);
BEGIN
DECL.Check(key)
END Check;
PROCEDURE NextCheck(key: INTEGER);
BEGIN
DECL.Next;
DECL.Check(key)
END NextCheck;
PROCEDURE BaseOf(T0, T1: DECL.pTYPE): BOOLEAN;
BEGIN
IF (T0.tType = T1.tType) & (T0.tType IN TOBJECT) THEN
IF T0.tType = TPOINTER THEN
T0 := T0.Base;
T1 := T1.Base
END;
WHILE (T1 # NIL) & (T1 # T0) DO
T1 := T1.Base
END
END
RETURN T0 = T1
END BaseOf;
PROCEDURE Designator(VAR e: DECL.EXPRESSION);
VAR id, id2: DECL.IDENT; name: SCAN.NODE; e1: DECL.EXPRESSION;
coord: SCAN.TCoord; i, n, bases, glob, loc, idx: INTEGER;
imp, break, guard: BOOLEAN; f: DECL.FIELD;
T, BaseT: DECL.pTYPE; s: UTILS.STRCONST;
PROCEDURE LoadVar;
BEGIN
IF glob # -1 THEN
X86.GlobalAdr(glob);
glob := -1
ELSIF loc # -1 THEN
X86.LocalAdr(loc, bases);
loc := -1
END
END LoadVar;
BEGIN
glob := -1;
loc := -1;
Coord(coord);
Check(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
IF (id # NIL) & (id.iType = IDMOD) THEN
NextCheck(lxDot);
NextCheck(lxIDENT);
Coord(coord);
name := SCAN.id;
imp := id.Unit # DECL.unit;
id := DECL.GetQIdent(id.Unit, name)
END;
Assert(id # NIL, coord, 42);
e.vparam := FALSE;
e.deref := FALSE;
e.id := id;
Next;
CASE id.iType OF
|IDVAR:
e.eType := eVAR;
e.T := id.T;
IF id.VarKind = 0 THEN
e.Read := imp
ELSE
e.Read := (id.VarKind = DECL.param) & (id.T.tType IN TSTRUCT);
e.vparam := id.VarKind = DECL.paramvar
END;
bases := DECL.unit.Level - id.Level;
IF id.Level = 3 THEN
glob := id.Offset
ELSIF (id.VarKind = 0) OR (id.VarKind = DECL.param) & ~(id.T.tType IN TSTRUCT) THEN
loc := id.Offset
ELSIF (id.VarKind = DECL.paramvar) OR (id.T.tType IN TSTRUCT) THEN
IF DECL.Dim(e.T) > 0 THEN
n := DECL.Dim(e.T);
FOR i := n TO 1 BY -1 DO
X86.LocalAdr(id.Offset + i * 4, bases);
X86.Load(TINTEGER)
END
END;
X86.LocalAdr(id.Offset, bases);
X86.Load(TINTEGER)
END
|IDCONST:
Assert(id.T # NIL, coord, 75);
e.eType := eCONST;
e.T := id.T;
e.Value := id.Value;
IF id.T.tType IN {TINTEGER, TSET, TBOOLEAN} THEN
X86.PushConst(FLOOR(e.Value))
ELSIF id.T.tType IN TFLOAT THEN
X86.PushFlt(e.Value)
ELSIF id.T.tType = TSTRING THEN
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
END
|IDPROC:
e.eType := ePROC;
NEW(id2);
UTILS.MemErr(id2 = NIL);
id2^ := id^;
UTILS.Push(DECL.curproc.Procs, id2);
e.T := voidtype
|IDTYPE:
Assert(FALSE, coord, 101)
|IDSTPROC:
e.eType := eSTPROC;
e.T := voidtype
|IDSYSPROC:
e.eType := eSYSPROC;
e.T := voidtype
ELSE
END;
break := FALSE;
guard := FALSE;
REPEAT
CASE SCAN.tLex OF
|lxDot:
e.deref := FALSE;
Assert2(e.T.tType IN TOBJECT, 105);
IF e.T.tType = TPOINTER THEN
e.Read := FALSE;
LoadVar;
e.T := e.T.Base;
X86.Load(TINTEGER);
IF ~guard THEN
X86.CheckNIL
END
END;
NextCheck(lxIDENT);
Coord(coord);
name := SCAN.id;
T := e.T;
REPEAT
f := DECL.GetField(T, name);
T := T.Base
UNTIL (f # NIL) OR (T = NIL);
Assert(f # NIL, coord, 99);
IF f.Unit # DECL.unit THEN
Assert(f.Export, coord, 99)
END;
IF glob # -1 THEN
glob := glob + f.Offset
ELSIF loc # -1 THEN
loc := loc + f.Offset
ELSE
X86.Field(f.Offset)
END;
e.T := f.T;
e.vparam := FALSE;
guard := FALSE;
Next
|lxLSquare:
LoadVar;
REPEAT
Assert2(e.T.tType = TARRAY, 102);
NextCoord(coord);
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e.T.Len = 0 THEN
IF e1.eType = eCONST THEN
idx := FLOOR(e1.Value);
Assert(idx >= 0, coord, 159)
END;
BaseT := DECL.OpenBase(e.T);
X86.PushConst(BaseT.Size);
X86.OpenIdx(DECL.Dim(e.T))
ELSE
IF e1.eType = eCONST THEN
idx := FLOOR(e1.Value);
Assert((idx >= 0) & (idx < e.T.Len), coord, 159);
IF e.T.Base.Size # 1 THEN
X86.Drop;
X86.PushConst(e.T.Base.Size * idx)
END;
X86.Idx
ELSE
X86.FixIdx(e.T.Len, e.T.Base.Size)
END
END;
e.T := e.T.Base
UNTIL SCAN.tLex # lxComma;
Check(lxRSquare);
e.vparam := FALSE;
guard := FALSE;
Next
|lxCaret:
LoadVar;
Assert2(e.T.tType = TPOINTER, 104);
e.Read := FALSE;
X86.Load(TINTEGER);
IF ~guard THEN
X86.CheckNIL
END;
e.T := e.T.Base;
e.vparam := FALSE;
e.deref := TRUE;
guard := FALSE;
Next
|lxLRound:
LoadVar;
IF e.T.tType IN TOBJECT THEN
IF e.T.tType = TRECORD THEN
Assert2(e.vparam, 108)
END;
NextCheck(lxIDENT);
Coord(coord);
T := DECL.IdType(coord);
Assert(T # NIL, coord, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord, 106)
ELSE
Assert(T.tType = TPOINTER, coord, 107)
END;
Assert(BaseOf(e.T, T), coord, 108);
e.T := T;
Check(lxRRound);
Next;
IF e.T.tType = TPOINTER THEN
IF (SCAN.tLex = lxDot) OR (SCAN.tLex = lxCaret) THEN
X86.DupLoadCheck
ELSE
X86.DupLoad
END;
guard := TRUE;
T := T.Base
ELSE
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
X86.Guard(T.Number, FALSE)
ELSE
break := TRUE
END
ELSE
break := TRUE
END
UNTIL break;
LoadVar
END Designator;
PROCEDURE Set(VAR e: DECL.EXPRESSION);
VAR a, b: DECL.EXPRESSION; coord: SCAN.TCoord; fpu: INTEGER; s: SET; flag: BOOLEAN;
beg: X86.ASMLINE;
BEGIN
Next;
e.eType := eEXP;
e.T := settype;
e.Value := 0.0D0;
e.vparam := FALSE;
s := {};
flag := TRUE;
fpu := X86.fpu;
beg := X86.current;
X86.PushConst(0);
WHILE SCAN.tLex # lxRCurly DO
Coord(coord);
pExpr(a);
IntType(a.T, coord);
IF a.eType = eCONST THEN
Assert(ASR(FLOOR(a.Value), 5) = 0, coord, 53)
END;
Load(a);
b := a;
IF SCAN.tLex = lxDbl THEN
NextCoord(coord);
pExpr(b);
IntType(b.T, coord);
IF b.eType = eCONST THEN
Assert(ASR(FLOOR(b.Value), 5) = 0, coord, 53);
IF a.eType = eCONST THEN
Assert(a.Value <= b.Value, coord, 54)
END
END;
Load(b)
ELSE
X86.Dup
END;
X86.rset;
X86.Set(lxPlus);
flag := (a.eType = eCONST) & (b.eType = eCONST) & flag;
IF flag THEN
s := s + {FLOOR(a.Value) .. FLOOR(b.Value)}
END;
IF SCAN.tLex = lxComma THEN
Next;
Assert2(SCAN.tLex # lxRCurly, 36)
ELSE
Check(lxRCurly)
END
END;
IF flag THEN
e.Value := LONG(FLT(ORD(s)));
e.eType := eCONST;
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
X86.PushConst(ORD(s))
END
END;
Next
END Set;
PROCEDURE IsString(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) OR (a.T.tType = TARRAY) & (a.T.Base.tType = TCHAR)
END IsString;
PROCEDURE Str(e: DECL.EXPRESSION);
VAR A: X86.TIDX;
BEGIN
IF (e.T.tType = TARRAY) & (e.T.Base.tType = TCHAR) & (e.T.Len # 0) THEN
A[0] := e.T.Len;
X86.OpenArray(A, 1)
ELSIF e.T.tType = TSTRING THEN
A[0] := LenString(e.Value) + 1;
IF A[0] # 2 THEN
X86.OpenArray(A, 1)
END
END
END Str;
PROCEDURE StFunc(VAR e: DECL.EXPRESSION; func: INTEGER);
VAR coord, coord2: SCAN.TCoord; a, b, p: INTEGER; e1, e2: DECL.EXPRESSION;
T: DECL.pTYPE; str, str2: UTILS.STRCONST;
BEGIN
e.vparam := FALSE;
e.eType := eEXP;
Coord(coord2);
Check(lxLRound);
NextCoord(coord);
CASE func OF
|stABS:
pExpr(e1);
Assert(e1.T.tType IN TNUM, coord, 57);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := ABS(e1.Value);
e.eType := eCONST;
Assert(~((e1.T.tType = TINTEGER) & (e1.Value = LONG(FLT(SCAN.minINT)))), coord, DECL.IOVER)
END;
IF e1.T.tType = TINTEGER THEN
X86.StFunc(X86.stABS)
ELSE
X86.StFunc(X86.stFABS)
END;
e.T := e1.T
|stODD:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := LONG(FLT(ORD(ODD(FLOOR(e1.Value)))));
e.eType := eCONST
END;
X86.StFunc(X86.stODD);
e.T := booltype
|stLEN:
Designator(e1);
Assert((e1.eType = eVAR) & (e1.T.tType = TARRAY), coord, 102);
IF e1.T.Len > 0 THEN
X86.Len(-e1.T.Len)
ELSE
X86.Len(DECL.Dim(e1.T))
END;
e.T := inttype
|stLSL, stASR, stROR, stLSR:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
pExpr(e2);
IntType(e2.T, coord);
Load(e2);
IF (e1.eType = eCONST) & (e2.eType = eCONST) THEN
a := FLOOR(e1.Value);
b := FLOOR(e2.Value);
CASE func OF
|stLSL: a := LSL(a, b)
|stASR: a := ASR(a, b)
|stROR: a := ROR(a, b)
|stLSR: a := LSR(a, b)
ELSE
END;
e.Value := LONG(FLT(a));
e.eType := eCONST
END;
CASE func OF
|stLSL: X86.StFunc(X86.stLSL)
|stASR: X86.StFunc(X86.stASR)
|stROR: X86.StFunc(X86.stROR)
|stLSR: X86.StFunc(X86.stLSR)
ELSE
END;
e.T := inttype
|stFLOOR:
pExpr(e1);
Assert(e1.T.tType IN TFLOAT, coord, 66);
Load(e1);
IF e1.eType = eCONST THEN
Assert((e1.Value - 1.0D0 < LONG(FLT(SCAN.maxINT))) & (e1.Value >= LONG(FLT(SCAN.minINT))), coord, 74);
e.Value := LONG(FLT(FLOOR(e1.Value)));
e.eType := eCONST
END;
X86.StFunc(X86.stFLOOR);
e.T := inttype
|stFLT:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
X86.StFunc(X86.stFLT);
e.T := realtype
|stORD:
pExpr(e1);
Assert(e1.T.tType IN {TCHAR, TBOOLEAN, TSET, TSTRING}, coord, 68);
IF e1.T.tType = TSTRING THEN
Assert(LenString(e1.Value) = 1, coord, 94)
END;
Load(e1);
IF e1.eType = eCONST THEN
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
e.Value := LONG(FLT(ORD(str.Str[0])))
ELSE
e.Value := e1.Value
END;
e.eType := eCONST
END;
IF e1.T.tType = TBOOLEAN THEN
X86.StFunc(X86.stORD)
END;
e.T := inttype
|stBITS:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
e.T := settype
|stCHR:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
e.T := chartype;
IF e1.eType = eCONST THEN
Assert(ASR(FLOOR(e1.Value), 8) = 0, coord, 76);
str2 := DECL.AddMono(CHR(FLOOR(e1.Value)));
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
e.T := strtype;
e.eType := eCONST
END
|stLONG:
pExpr(e1);
Assert(e1.T.tType = TREAL, coord, 71);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
Load(e1);
e.T := longrealtype
|stSHORT:
pExpr(e1);
Assert(e1.T.tType = TLONGREAL, coord, 70);
IF e1.eType = eCONST THEN
Assert(ABS(e1.Value) <= LONG(SCAN.maxREAL), coord, DECL.FOVER);
Assert(ABS(e1.Value) >= LONG(SCAN.minREAL), coord, DECL.UNDER);
e.Value := e1.Value;
e.eType := eCONST
END;
Load(e1);
e.T := realtype
|stLENGTH:
pExpr(e1);
Assert(IsString(e1), coord, 141);
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Mono(str.Number);
X86.StrMono
END;
e.Value := LONG(FLT(LENGTH(str.Str)));
e.eType := eCONST
END;
Str(e1);
e.T := inttype;
X86.StFunc(X86.stLENGTH)
|stMIN, stMAX:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
pExpr(e2);
IntType(e2.T, coord);
Load(e2);
IF (e1.eType = eCONST) & (e2.eType = eCONST) THEN
a := FLOOR(e1.Value);
b := FLOOR(e2.Value);
CASE func OF
|stMIN: a := MIN(a, b)
|stMAX: a := MAX(a, b)
ELSE
END;
e.Value := LONG(FLT(a));
e.eType := eCONST
END;
IF func = stMIN THEN
X86.StFunc(X86.stMIN)
ELSE
X86.StFunc(X86.stMAX)
END;
e.T := inttype
|sysADR:
Assert((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxSTRING) OR (SCAN.tLex = lxCHX), coord, 43);
IF SCAN.tLex = lxIDENT THEN
Designator(e1);
Assert((e1.eType = eVAR) OR (e1.eType = ePROC) OR (e1.T = strtype), coord, 43);
IF e1.eType = ePROC THEN
X86.PushInt(e1.id.Number)
END
ELSE
pFactor(e1)
END;
IF e1.T = strtype THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Drop;
X86.PushInt(str.Number)
END
END;
e.T := inttype;
X86.ADR(DECL.Dim(e1.T))
|sysSIZE, sysTYPEID, sysINF:
DECL.SetSizeFunc;
Check(lxIDENT);
T := DECL.IdType(coord);
Assert(T # NIL, coord, 42);
e.eType := eCONST;
IF func = sysTYPEID THEN
e.T := inttype;
Assert(T.tType IN TOBJECT, coord, 47);
IF T.tType = TPOINTER THEN
T := T.Base
END;
e.Value := LONG(FLT(T.Number));
X86.PushConst(T.Number)
ELSIF func = sysSIZE THEN
e.T := inttype;
e.Value := LONG(FLT(T.Size));
X86.PushConst(T.Size)
ELSIF func = sysINF THEN
Assert(T.tType IN TFLOAT, coord, 91);
e.T := T;
e.Value := SYSTEM.INF(LONGREAL);
X86.PushFlt(e.Value)
END
ELSE
Assert(FALSE, coord2, 73)
END;
Check(lxRRound);
Next
END StFunc;
PROCEDURE ProcTypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE;
PROCEDURE ProcTypeComp1(T1, T2: DECL.pTYPE): BOOLEAN;
VAR fp, ft: DECL.FIELD; Res: BOOLEAN;
PROCEDURE TypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (T1.tType = TARRAY) & (T2.tType = TARRAY) & (T1.Len = 0) & (T2.Len = 0) THEN
Res := TypeComp(T1.Base, T2.Base)
ELSE
Res := ProcTypeComp1(T1, T2)
END
RETURN Res
END TypeComp;
PROCEDURE Check(): BOOLEAN;
VAR i: INTEGER; res: BOOLEAN;
BEGIN
i := 0;
res := FALSE;
WHILE (i < sp) & ~res DO
res := ((stk[i][0] = T1) & (stk[i][1] = T2)) OR ((stk[i][0] = T2) & (stk[i][1] = T1));
INC(i)
END
RETURN res
END Check;
BEGIN
INC(sp);
stk[sp][0] := T1;
stk[sp][1] := T2;
IF Check() THEN
Res := TRUE
ELSE
IF (T1.tType = TPROC) & (T2.tType = TPROC) & (T1 # T2) THEN
Res := (T1.Call = T2.Call) & (T1.Fields.Count = T2.Fields.Count) & ProcTypeComp1(T1.Base, T2.Base);
fp := T1.Fields.First(DECL.FIELD);
ft := T2.Fields.First(DECL.FIELD);
WHILE Res & (fp # NIL) DO
Res := (fp.ByRef = ft.ByRef) & TypeComp(fp.T, ft.T);
fp := fp.Next(DECL.FIELD);
ft := ft.Next(DECL.FIELD)
END
ELSE
Res := T1 = T2
END
END;
DEC(sp)
RETURN Res
END ProcTypeComp1;
BEGIN
sp := -1
RETURN ProcTypeComp1(T1, T2)
END ProcTypeComp;
PROCEDURE ArrComp(Ta, Tf: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (Tf.tType = TARRAY) & (Tf.Len = 0) & (Ta.tType = TARRAY) THEN
Res := ArrComp(Ta.Base, Tf.Base)
ELSE
Res := ProcTypeComp(Ta, Tf)
END
RETURN Res
END ArrComp;
PROCEDURE AssComp(e: DECL.EXPRESSION; T: DECL.pTYPE; param: BOOLEAN): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TSET, TBOOLEAN, TCARD16:
Res := e.T = T
|TCHAR:
IF e.T.tType = TSTRING THEN
Res := LenString(e.Value) = 1
ELSE
Res := e.T.tType = TCHAR
END
|TARRAY:
IF param THEN
IF T.Len = 0 THEN
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := TRUE
ELSE
Res := ArrComp(e.T, T)
END
ELSE
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len
ELSE
Res := e.T = T
END
END
ELSE
IF T.Len = 0 THEN
Res := FALSE
ELSIF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len
ELSE
Res := e.T = T
END
END
|TRECORD: Res := BaseOf(T, e.T)
|TPOINTER: Res := BaseOf(T, e.T) OR (e.T.tType = TNIL)
|TPROC: Res := (e.T.tType = TNIL) OR (e.eType = ePROC) & ProcTypeComp(e.id.T, T) OR
(e.eType # ePROC) & ProcTypeComp(e.T, T)
ELSE
Res := FALSE
END
RETURN Res
END AssComp;
PROCEDURE ParamComp(e: DECL.EXPRESSION; T: DECL.pTYPE; ByRef: BOOLEAN): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF ByRef THEN
IF e.eType = eVAR THEN
CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TCHAR,
TSET, TBOOLEAN, TPOINTER, TCARD16:
Res := e.T = T
|TARRAY:
IF T.Len > 0 THEN
Res := e.T = T
ELSE
Res := ArrComp(e.T, T)
END
|TRECORD:
Res := BaseOf(T, e.T)
|TPROC:
Res := ProcTypeComp(e.T, T)
ELSE
END
ELSE
Res := FALSE
END
ELSE
Res := AssComp(e, T, TRUE)
END
RETURN Res
END ParamComp;
PROCEDURE Call(param: DECL.FIELD);
VAR coord: SCAN.TCoord; i, n: INTEGER; e1: DECL.EXPRESSION; s: UTILS.STRCONST; A: X86.TIDX; TA: DECL.pTYPE;
BEGIN
WHILE param # NIL DO
Coord(coord);
X86.Param;
pExpr(e1);
Assert(ParamComp(e1, param.T, param.ByRef), coord, 114);
Assert(~(param.ByRef & e1.Read), coord, 115);
Assert(~((e1.eType = ePROC) & (e1.id.Level > 3)), coord, 116);
IF (e1.eType = eVAR) & ~param.ByRef THEN
X86.Load(e1.T.tType)
END;
IF param.ByRef & (e1.T.tType = TRECORD) THEN
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(0)
ELSE
X86.PushConst(e1.T.Number)
END
END;
IF ~param.ByRef & (param.T.tType IN TFLOAT) THEN
X86.DropFpu(param.T.tType = TLONGREAL)
END;
IF (e1.T.tType = TSTRING) & (param.T.tType = TARRAY) THEN
IF param.T.Len > X86.maxstrlen THEN
X86.set_maxstrlen(param.T.Len)
END;
s := DECL.GetString(e1.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
END;
IF param.T.Len = 0 THEN
A[0] := s.Len + 1;
X86.OpenArray(A, 1)
END
END;
IF (e1.T.tType = TARRAY) & (DECL.Dim(param.T) > DECL.Dim(e1.T)) THEN
n := DECL.Dim(param.T) - DECL.Dim(e1.T);
TA := DECL.OpenBase(e1.T);
FOR i := 0 TO n - 1 DO
A[i] := TA.Len;
TA := TA.Base
END;
IF DECL.Dim(e1.T) = 0 THEN
X86.OpenArray(A, n)
ELSE
X86.ExtArray(A, n, DECL.Dim(e1.T))
END
END;
param := param.Next(DECL.FIELD);
IF param # NIL THEN
Check(lxComma);
Next
END
END;
Check(lxRRound);
Next
END Call;
PROCEDURE Factor(VAR e: DECL.EXPRESSION);
VAR coord: SCAN.TCoord; ccall, p: INTEGER; begcall: X86.ASMLINE; s, str2: UTILS.STRCONST;
BEGIN
e.eType := eCONST;
e.vparam := FALSE;
CASE SCAN.tLex OF
|lxIDENT:
begcall := X86.current;
Designator(e);
IF e.eType = ePROC THEN
IF SCAN.tLex = lxLRound THEN
Assert2(e.id.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.id.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
e.T := e.id.T.Base;
IF e.id.Level = 3 THEN
ccall := 0
ELSIF e.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
X86.Call(e.id.Number, TRUE, e.T.tType IN TFLOAT, e.id.T.Call, ccall, e.id.Level - 3,
DECL.curBlock.Level - 3, e.id.ParamSize, DECL.curBlock.LocalSize)
ELSE
X86.PushInt(e.id.Number)
END
ELSIF (e.eType = eVAR) & (e.T.tType = TPROC) & (SCAN.tLex = lxLRound) THEN
Assert2(e.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
X86.CallVar(TRUE, e.T.Base.tType IN TFLOAT, e.T.Call, e.T.Len, DECL.curBlock.LocalSize);
e.T := e.T.Base;
ELSIF e.eType IN {eSTPROC, eSYSPROC} THEN
StFunc(e, e.id.StProc)
END
|lxNIL:
e.T := niltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxTRUE:
e.T := booltype;
e.Value := 1.0D0;
X86.PushConst(1);
Next
|lxFALSE:
e.T := booltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxCHX, lxSTRING:
IF SCAN.tLex = lxSTRING THEN
str2 := DECL.AddString(SCAN.Lex);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
str2 := DECL.AddMono(SCAN.vCHX);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
X86.PushConst(ORD(SCAN.vCHX))
END;
e.T := strtype;
Next
|lxREAL:
e.T := realtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxLONGREAL:
e.T := longrealtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxINT, lxHEX:
e.T := inttype;
e.Value := LONG(FLT(SCAN.vINT));
X86.PushConst(SCAN.vINT);
Next
|lxLRound:
Next;
pExpr(e);
Check(lxRRound);
Next
|lxNot:
NextCoord(coord);
Factor(e);
Assert(e.T.tType = TBOOLEAN, coord, 37);
Load(e);
IF e.eType = eCONST THEN
e.Value := LONG(FLT(ORD(e.Value = 0.0D0)))
ELSE
e.eType := eEXP
END;
X86.Not;
e.vparam := FALSE
|lxLCurly:
Set(e)
ELSE
Assert2(FALSE, 36)
END
END Factor;
PROCEDURE IsChr(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) & (LenString(a.Value) = 1) OR (a.T.tType = TCHAR)
END IsChr;
PROCEDURE StrRel(a, b: DECL.EXPRESSION; Op: INTEGER);
BEGIN
IF ~(IsChr(a) OR IsChr(b)) THEN
X86.strcmp(Op, 0)
ELSIF IsChr(a) & IsChr(b) THEN
X86.CmpInt(Op)
ELSIF IsChr(a) THEN
X86.strcmp(Op, 1)
ELSE
X86.strcmp(Op, -1)
END
END StrRel;
PROCEDURE log2(n: INTEGER): INTEGER;
VAR x, i: INTEGER;
BEGIN
x := 1;
i := 0;
WHILE (x # n) & (i < 31) DO
x := LSL(x, 1);
INC(i)
END;
IF x # n THEN
i := -1
END
RETURN i
END log2;
PROCEDURE Operation(VAR a, b: DECL.EXPRESSION; Op: INTEGER; coord: SCAN.TCoord);
VAR n, m: INTEGER;
BEGIN
CASE Op OF
|lxPlus, lxMinus, lxMult, lxSlash:
Assert((a.T.tType IN (TNUM + {TSET})) & (a.T.tType = b.T.tType), coord, 37);
Assert(~((Op = lxSlash) & (a.T.tType = TINTEGER)), coord, 37);
CASE a.T.tType OF
|TINTEGER: X86.Int(Op)
|TSET: X86.Set(Op)
|TREAL, TLONGREAL: X86.farith(Op)
ELSE
END
|lxDIV, lxMOD:
Assert((a.T.tType = TINTEGER) & (b.T.tType = TINTEGER), coord, 37);
IF b.eType = eCONST THEN
m := FLOOR(b.Value);
Assert(m # 0, coord, 48);
n := log2(m);
IF n = -1 THEN
X86.idivmod(Op = lxMOD)
ELSE
X86.Drop;
IF Op = lxMOD THEN
n := ORD(-BITS(LSL(-1, n)));
X86.PushConst(n);
X86.Set(lxMult)
ELSE
X86.PushConst(n);
X86.StFunc(X86.stASR)
END
END
ELSE
X86.idivmod(Op = lxMOD)
END
|lxAnd, lxOR:
Assert((a.T.tType = TBOOLEAN) & (b.T.tType = TBOOLEAN), coord, 37)
|lxIN:
Assert((a.T.tType = TINTEGER) & (b.T.tType = TSET), coord, 37);
X86.inset
|lxLT, lxLE, lxGT, lxGE:
Assert(((a.T.tType IN TNUM) & (a.T.tType = b.T.tType)) OR
(IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR
(a.T.tType = TSET) & (b.T.tType = TSET) & ((Op = lxLE) OR (Op = lxGE)), coord, 37);
IF a.T.tType IN TFLOAT THEN
X86.fcmp(Op)
ELSIF a.T.tType = TSET THEN
X86.Inclusion(Op)
ELSIF IsString(a) OR IsString(b) THEN
StrRel(a, b, Op)
ELSE
X86.CmpInt(Op)
END
|lxEQ, lxNE:
Assert(((a.T.tType IN (TNUM + {TSET, TBOOLEAN})) & (a.T.tType = b.T.tType)) OR
(IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR
(a.T.tType IN {TPOINTER, TPROC, TNIL}) & (b.T.tType = TNIL) OR
(b.T.tType IN {TPOINTER, TPROC, TNIL}) & (a.T.tType = TNIL) OR
(a.T.tType = TPOINTER) & (b.T.tType = TPOINTER) & (BaseOf(a.T, b.T) OR BaseOf(b.T, a.T)) OR
(a.T.tType = TPROC) & ProcTypeComp(b.T, a.T) OR (a.eType = ePROC) & ProcTypeComp(b.T, a.id.T) OR
(b.eType = ePROC) & ProcTypeComp(a.T, b.id.T), coord, 37);
IF a.T.tType IN TFLOAT THEN
X86.fcmp(Op)
ELSIF IsString(a) OR IsString(b) THEN
StrRel(a, b, Op)
ELSE
X86.CmpInt(Op)
END
ELSE
END;
IF (a.eType # eCONST) OR (b.eType # eCONST) THEN
a.eType := eEXP;
IF DECL.Relation(Op) THEN
a.T := booltype
END
ELSE
DECL.Calc(a.Value, b.Value, a.T, b.T, Op, coord, a.Value, a.T)
END;
a.vparam := FALSE
END Operation;
PROCEDURE Term(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, L: INTEGER; coord: SCAN.TCoord;
BEGIN
Factor(e);
WHILE (SCAN.tLex = lxMult) OR (SCAN.tLex = lxSlash) OR
(SCAN.tLex = lxDIV) OR (SCAN.tLex = lxMOD) OR
(SCAN.tLex = lxAnd) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxAnd THEN
L := X86.NewLabel();
X86.IfWhile(L, FALSE)
END;
Factor(a);
Load(a);
IF Op = lxAnd THEN
X86.Label(L)
END;
Operation(e, a, Op, coord)
END
END Term;
PROCEDURE Simple(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, uOp, L: INTEGER; coord, ucoord: SCAN.TCoord;
BEGIN
uOp := 0;
IF (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) THEN
Coord(ucoord);
uOp := SCAN.tLex;
Next
END;
Term(e);
IF uOp # 0 THEN
Assert(e.T.tType IN (TNUM + {TSET}), ucoord, 37);
Load(e);
IF uOp = lxMinus THEN
CASE e.T.tType OF
|TINTEGER: X86.NegInt
|TSET: X86.NegSet
|TREAL, TLONGREAL: X86.fneg
ELSE
END
END;
IF (uOp = lxMinus) & (e.eType = eCONST) THEN
CASE e.T.tType OF
|TINTEGER:
Assert(e.Value # LONG(FLT(SCAN.minINT)), ucoord, DECL.IOVER)
|TSET:
e.Value := -LONG(FLT(ORD(-BITS(FLOOR(e.Value)))))
ELSE
END;
e.Value := -e.Value
END;
IF e.eType # eCONST THEN
e.eType := eEXP
END;
e.vparam := FALSE
END;
WHILE (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) OR (SCAN.tLex = lxOR) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxOR THEN
L := X86.NewLabel();
X86.IfWhile(L, TRUE)
END;
Term(a);
Load(a);
IF Op = lxOR THEN
X86.Label(L)
END;
Operation(e, a, Op, coord)
END
END Simple;
PROCEDURE Expr(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; coord, coord2: SCAN.TCoord; Op, fpu: INTEGER; T: DECL.pTYPE; beg: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
fpu := X86.fpu;
beg := X86.current;
Simple(e);
IF DECL.Relation(SCAN.tLex) THEN
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxIS THEN
Assert(e.T.tType IN TOBJECT, coord, 37);
IF e.T.tType = TRECORD THEN
Assert(e.vparam, coord, 37)
END;
Check(lxIDENT);
Coord(coord2);
T := DECL.IdType(coord2);
Assert(T # NIL, coord2, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord2, 106)
ELSE
Assert(T.tType = TPOINTER, coord2, 107)
END;
Assert(BaseOf(e.T, T), coord, 37);
IF e.T.tType = TRECORD THEN
X86.Drop;
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
Load(e);
IF e.T.tType = TPOINTER THEN
T := T.Base
END;
X86.Guard(T.Number, TRUE);
e.T := booltype;
e.eType := eEXP;
e.vparam := FALSE
ELSE
Load(e);
Str(e);
Simple(a);
Load(a);
Str(a);
Operation(e, a, Op, coord)
END
END;
IF e.eType = eCONST THEN
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
CASE e.T.tType OF
|TREAL, TLONGREAL:
X86.PushFlt(e.Value)
|TINTEGER, TSET, TBOOLEAN, TNIL:
X86.PushConst(FLOOR(e.Value))
|TSTRING:
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
END
END
END
END Expr;
PROCEDURE IfWhileOper(wh: BOOLEAN);
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L, L3: INTEGER;
BEGIN
L := X86.NewLabel();
IF wh THEN
X86.Label(L)
END;
REPEAT
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
IF wh THEN
Check(lxDO)
ELSE
Check(lxTHEN)
END;
L3 := X86.NewLabel();
X86.ifwh(L3);
Next;
pOpSeq;
X86.jmp(X86.JMP, L);
X86.Label(L3)
UNTIL SCAN.tLex # lxELSIF;
IF ~wh & (SCAN.tLex = lxELSE) THEN
Next;
pOpSeq
END;
Check(lxEND);
IF ~wh THEN
X86.Label(L)
END;
Next
END IfWhileOper;
PROCEDURE RepeatOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L: INTEGER;
BEGIN
Next;
L := X86.NewLabel();
X86.Label(L);
pOpSeq;
Check(lxUNTIL);
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
X86.ifwh(L)
END RepeatOper;
PROCEDURE ForOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; LBeg, LEnd, iValue: INTEGER; Value: LONGREAL;
T: DECL.pTYPE; name: SCAN.NODE; id: DECL.IDENT;
BEGIN
NextCheck(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
Assert2(id # NIL, 42);
Assert2(id.iType = IDVAR, 126);
Assert2(id.VarKind = 0, 127);
Assert2(id.T.tType = TINTEGER, 128);
Assert2(id.Level = DECL.unit.Level, 129);
NextCheck(lxAssign);
NextCoord(coord);
IF id.Level = 3 THEN
X86.GlobalAdr(id.Offset)
ELSE
X86.LocalAdr(id.Offset, 0)
END;
X86.Dup;
Expr(e);
IntType(e.T, coord);
Load(e);
X86.Save(TINTEGER);
Check(lxTO);
NextCoord(coord);
Expr(e);
IntType(e.T, coord);
Load(e);
iValue := 1;
IF SCAN.tLex = lxBY THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122)
END;
Check(lxDO);
Next;
X86.For(iValue > 0, LBeg, LEnd);
pOpSeq;
X86.NextFor(iValue, LBeg, LEnd);
Check(lxEND);
Next
END ForOper;
PROCEDURE CheckLabel(a, b: INTEGER; Labels: UTILS.LIST): BOOLEAN;
VAR cur: LABEL;
BEGIN
cur := Labels.First(LABEL);
WHILE (cur # NIL) & ((b < cur.a) OR (a > cur.b)) DO
cur := cur.Next(LABEL)
END
RETURN cur = NIL
END CheckLabel;
PROCEDURE LabelVal(VAR a: INTEGER; int: BOOLEAN);
VAR Value: LONGREAL; T: DECL.pTYPE; s: UTILS.STRCONST; coord: SCAN.TCoord;
BEGIN
Coord(coord);
DECL.ConstExpr(Value, T);
IF int THEN
Assert(T.tType = TINTEGER, coord, 161);
a := FLOOR(Value)
ELSE
Assert(T.tType = TSTRING, coord, 55);
s := DECL.GetString(Value);
Assert(s.Len = 1, coord, 94);
a := ORD(s.Str[0])
END
END LabelVal;
PROCEDURE Label(int: BOOLEAN; Labels: UTILS.LIST; LBeg: INTEGER);
VAR a, b: INTEGER; label: LABEL; coord: SCAN.TCoord;
BEGIN
Coord(coord);
LabelVal(a, int);
b := a;
IF SCAN.tLex = lxDbl THEN
Next;
LabelVal(b, int)
END;
Assert(a <= b, coord, 54);
Assert(CheckLabel(a, b, Labels), coord, 100);
NEW(label);
DECL.MemErr(label = NIL);
label.a := a;
label.b := b;
UTILS.Push(Labels, label);
X86.CaseLabel(a, b, LBeg)
END Label;
PROCEDURE Variant(int: BOOLEAN; Labels: UTILS.LIST; EndCase: INTEGER);
VAR LBeg, LEnd: INTEGER;
BEGIN
LBeg := X86.NewLabel();
LEnd := X86.NewLabel();
IF ~((SCAN.tLex = lxStick) OR (SCAN.tLex = lxEND)) THEN
Label(int, Labels, LBeg);
WHILE SCAN.tLex = lxComma DO
Next;
Label(int, Labels, LBeg)
END;
Check(lxColon);
Next;
X86.jmp(X86.JMP, LEnd);
X86.Label(LBeg);
pOpSeq;
X86.jmp(X86.JMP, EndCase);
X86.Label(LEnd)
END
END Variant;
PROCEDURE CaseOper;
VAR e: DECL.EXPRESSION; int: BOOLEAN; coord: SCAN.TCoord; EndCase: INTEGER; Labels: UTILS.LIST;
BEGIN
NextCoord(coord);
Expr(e);
Assert(e.T.tType IN {TCHAR, TSTRING, TINTEGER}, coord, 156);
Assert(~((e.T.tType = TSTRING) & (LenString(e.Value) # 1)), coord, 94);
int := e.T.tType = TINTEGER;
Check(lxOF);
Load(e);
X86.Drop;
Labels := UTILS.CreateList();
Next;
EndCase := X86.NewLabel();
Variant(int, Labels, EndCase);
WHILE SCAN.tLex = lxStick DO
Next;
Variant(int, Labels, EndCase)
END;
IF SCAN.tLex = lxELSE THEN
Next;
pOpSeq
ELSE
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
X86.OnError(7)
END;
Check(lxEND);
X86.Label(EndCase);
Next;
UTILS.Clear(Labels)
END CaseOper;
PROCEDURE CheckCode(Code: UTILS.STRING; Len: INTEGER; coord: SCAN.TCoord);
VAR i: INTEGER;
BEGIN
Assert(~ODD(Len), coord, 34);
FOR i := 0 TO Len - 1 DO
Assert(SCAN.HexDigit(Code[i]), coord, 34)
END
END CheckCode;
PROCEDURE StProc(proc: INTEGER);
VAR coord, coord2: SCAN.TCoord; iValue: INTEGER; e1, e2: DECL.EXPRESSION; Value: LONGREAL;
T: DECL.pTYPE; str: UTILS.STRCONST; begcall: X86.ASMLINE;
BEGIN
Coord(coord2);
Check(lxLRound);
NextCoord(coord);
CASE proc OF
|stINC, stDEC:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TINTEGER, coord, 128);
IF SCAN.tLex = lxComma THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122);
IF iValue < 0 THEN
IF proc = stINC THEN
proc := stDEC
ELSE
proc := stINC
END;
iValue := -iValue
END;
IF iValue # 1 THEN
X86.PushConst(iValue);
IF proc = stDEC THEN
X86.StProc(X86.stDEC)
ELSE
X86.StProc(X86.stINC)
END
ELSE
IF proc = stDEC THEN
X86.StProc(X86.stDEC1)
ELSE
X86.StProc(X86.stINC1)
END
END
ELSE
IF proc = stDEC THEN
X86.StProc(X86.stDEC1)
ELSE
X86.StProc(X86.stINC1)
END
END
|stINCL, stEXCL:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TSET, coord, 138);
Check(lxComma);
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(ASR(iValue, 5) = 0, coord, 53);
IF proc = stINCL THEN
X86.PushConst(ORD({iValue}));
X86.StProc(X86.stINCL)
ELSE
X86.PushConst(ORD(-{iValue}));
X86.StProc(X86.stEXCL)
END
|stCOPY:
Expr(e1);
Assert(IsString(e1), coord, 141);
Check(lxComma);
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Mono(str.Number);
X86.StrMono
END
END;
Str(e1);
NextCoord(coord);
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(IsString(e2), coord, 143);
Assert(~e2.Read, coord, 115);
Str(e2);
X86.StProc(X86.stCOPY)
|stNEW, stDISPOSE:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TPOINTER, coord, 145);
IF proc = stNEW THEN
X86.PushConst(e1.T.Base.Number);
X86.PushConst(X86.Align(e1.T.Base.Size + 8, 32));
X86.newrec
ELSE
X86.disprec
END
|stASSERT:
Expr(e1);
Assert(e1.T.tType = TBOOLEAN, coord, 117);
Load(e1);
IF SCAN.tLex = lxComma THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
Assert((Value >= 0.0D0) & (Value <= 127.0D0), coord, 95);
X86.Assert(X86.stASSERT, FLOOR(Value))
ELSE
X86.Assert(X86.stASSERT1, 0)
END
|stPACK, stUNPK:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(e1.T.tType IN TFLOAT, coord, 149);
Assert(~e1.Read, coord, 115);
Check(lxComma);
NextCoord(coord);
IF proc = stUNPK THEN
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(e2.T.tType = TINTEGER, coord, 128);
Assert(~e2.Read, coord, 115);
IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stUNPK)
ELSE
X86.StProc(X86.stUNPK1)
END
ELSE
Expr(e2);
IntType(e2.T, coord);
Load(e2);
IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stPACK)
ELSE
X86.StProc(X86.stPACK1)
END
END
|sysPUT, sysGET:
begcall := X86.current;
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
IF proc = sysGET THEN
X86.PushCall(begcall);
X86.Param;
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
Assert(~e2.Read, coord, 115);
X86.EndCall;
X86.Load(e2.T.tType);
X86.Save(e2.T.tType)
ELSE
Expr(e2);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
IF e2.T.tType = TSTRING THEN
Assert(LenString(e2.Value) = 1, coord, 94)
ELSIF e2.T.tType = TVOID THEN
e2.T := inttype
END;
Load(e2);
X86.Save(e2.T.tType)
END
|sysCODE:
Assert(SCAN.tLex = lxSTRING, coord, 150);
CheckCode(SCAN.Lex, SCAN.count - 1, coord);
X86.Asm(SCAN.Lex);
Next
|sysMOVE:
begcall := X86.current;
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
X86.PushCall(begcall);
X86.Param;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
X86.EndCall;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
|sysCOPY:
begcall := X86.current;
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Check(lxComma);
X86.PushCall(begcall);
X86.Param;
NextCoord(coord);
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Check(lxComma);
X86.EndCall;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
ELSE
Assert(FALSE, coord2, 132)
END;
Check(lxRRound);
Next;
IF (proc = sysMOVE) OR (proc = sysCOPY) THEN
X86.StProc(X86.sysMOVE)
END
END StProc;
PROCEDURE IdentOper;
VAR e1, e2: DECL.EXPRESSION; coord: SCAN.TCoord; ccall: INTEGER; begcall: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
Coord(coord);
begcall := X86.current;
Designator(e1);
Assert(e1.eType # eCONST, coord, 130);
IF (e1.eType = eVAR) & (e1.T.tType # TPROC) THEN
Check(lxAssign);
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Load(e2);
IF e1.T.tType = TRECORD THEN
X86.PushConst(e1.T.Size);
X86.PushConst(e1.T.Number);
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(12)
ELSE
X86.PushConst(e1.T.Number)
END
ELSIF e2.T.tType = TARRAY THEN
X86.PushConst(e2.T.Size)
ELSIF (e2.T.tType = TSTRING) & (e1.T.tType = TARRAY) THEN
s := DECL.GetString(e2.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
END;
X86.PushConst(MIN(s.Len + 1, e1.T.Len))
END;
X86.Save(e1.T.tType)
ELSIF e1.eType = ePROC THEN
Assert((e1.id.T.Base.tType = TVOID) OR (e1.id.T.Call = DECL.winapi), coord, 132);
IF e1.id.ParamCount > 0 THEN
Check(lxLRound);
Next;
X86.PushCall(begcall);
Call(e1.id.T.Fields.First(DECL.FIELD));
X86.EndCall
ELSIF SCAN.tLex = lxLRound THEN
NextCheck(lxRRound);
Next
END;
IF e1.id.Level = 3 THEN
ccall := 0
ELSIF e1.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
X86.Call(e1.id.Number, FALSE, FALSE, e1.id.T.Call, ccall, e1.id.Level - 3, DECL.curBlock.Level - 3, e1.id.ParamSize, DECL.curBlock.LocalSize)
ELSIF e1.eType IN {eSTPROC, eSYSPROC} THEN
StProc(e1.id.StProc)
ELSIF (e1.eType = eVAR) & (e1.T.tType = TPROC) THEN
IF SCAN.tLex = lxLRound THEN
Next;
Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132);
X86.PushCall(begcall);
Call(e1.T.Fields.First(DECL.FIELD));
X86.EndCall;
X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize)
ELSIF SCAN.tLex = lxAssign THEN
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Assert(~((e2.eType = ePROC) & (e2.id.Level > 3)), coord, 116);
IF e2.eType = eVAR THEN
X86.Load(TPROC)
END;
X86.Save(TPROC)
ELSE
Assert2(e1.T.Fields.Count = 0, 155);
Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132);
X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize)
END
END
END IdentOper;
PROCEDURE Operator;
BEGIN
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
CASE SCAN.tLex OF
|lxIDENT: IdentOper
|lxIF, lxWHILE: IfWhileOper(SCAN.tLex = lxWHILE)
|lxREPEAT: RepeatOper
|lxFOR: ForOper
|lxCASE: CaseOper
ELSE
END
END Operator;
PROCEDURE OpSeq;
BEGIN
Operator;
WHILE SCAN.tLex = lxSemi DO
Next;
Operator
END
END OpSeq;
PROCEDURE Start;
VAR SelfName, SelfPath, CName, CExt, FName, Path, StdPath,
Name, Ext, temp, system, stk: UTILS.STRING;
platform, stksize: INTEGER;
PROCEDURE getstksize(): INTEGER;
VAR res, i: INTEGER;
BEGIN
res := 0;
i := 0;
WHILE SCAN.Digit(stk[i]) DO
INC(i)
END;
IF stk[i] <= 20X THEN
stk[i] := 0X;
res := SCAN.StrToInt(stk)
END;
IF res = 0 THEN
res := 1
END
RETURN res
END getstksize;
PROCEDURE getver(): INTEGER;
VAR res, i: INTEGER; err: BOOLEAN;
PROCEDURE hexdgt(c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR
("A" <= c) & (c <= "F") OR
("a" <= c) & (c <= "f")
END hexdgt;
PROCEDURE hex(c: CHAR): INTEGER;
VAR res: INTEGER;
BEGIN
IF ("0" <= c) & (c <= "9") THEN
res := ORD(c) - ORD("0")
ELSIF ("A" <= c) & (c <= "F") THEN
res := ORD(c) - ORD("A") + 10
ELSIF ("a" <= c) & (c <= "f") THEN
res := ORD(c) - ORD("a") + 10
END
RETURN res
END hex;
BEGIN
res := 0;
i := 0;
err := stk[i] # "0"; INC(i);
err := err OR (stk[i] # "x"); INC(i);
WHILE ~err & hexdgt(stk[i]) DO
INC(i)
END;
err := err OR (i = 2);
IF stk[i] <= 20X THEN
stk[i] := 0X
ELSE
err := TRUE
END;
i := 2;
WHILE ~err & (stk[i] # 0X) DO
res := LSL(res, 4) + hex(stk[i]);
INC(i)
END;
IF res = 0 THEN
res := 65536
END
RETURN res
END getver;
BEGIN
IF UTILS.ParamCount < 2 THEN
UTILS.ErrMsg(59);
UTILS.HALT(1)
END;
UTILS.ParamStr(SelfName, 0);
UTILS.ParamStr(FName, 1);
UTILS.ParamStr(system, 2);
UTILS.ParamStr(stk, 3);
pExpr := Expr;
pFactor := Factor;
pOpSeq := OpSeq;
UTILS.Split(FName, Path, Name, Ext);
IF Ext # UTILS.Ext THEN
UTILS.ErrMsg(121);
UTILS.HALT(1)
END;
UTILS.Split(SelfName, SelfPath, CName, CExt);
temp := Name;
IF UTILS.streq(system, "kem") THEN
X86.setkem;
platform := 4;
UTILS.concat(temp, ".kex")
ELSIF UTILS.streq(system, "obj") THEN
platform := 6;
UTILS.concat(temp, ".obj")
ELSIF UTILS.streq(system, "elf") THEN
platform := 5
ELSIF UTILS.streq(system, "kos") THEN
platform := 4;
UTILS.concat(temp, ".kex")
ELSIF UTILS.streq(system, "con") THEN
platform := 3;
UTILS.concat(temp, ".exe")
ELSIF UTILS.streq(system, "gui") THEN
platform := 2;
UTILS.concat(temp, ".exe")
ELSIF UTILS.streq(system, "dll") THEN
platform := 1;
UTILS.concat(temp, ".dll")
ELSE
UTILS.ErrMsg(60);
UTILS.HALT(1)
END;
IF platform IN {1, 2, 3, 4} THEN
stksize := getstksize()
ELSE
stksize := 1
END;
IF platform = 6 THEN
stksize := getver()
END;
UTILS.concat(SelfPath, "Lib");
UTILS.concat(SelfPath, UTILS.Slash);
IF platform = 5 THEN
UTILS.concat(SelfPath, "Linux32")
ELSIF platform IN {4, 6} THEN
UTILS.concat(SelfPath, "KolibriOS")
ELSIF platform IN {1, 2, 3} THEN
UTILS.concat(SelfPath, "Windows32")
END;
UTILS.concat(SelfPath, UTILS.Slash);
X86.set_maxstrlen(0);
X86.Init(platform);
X86.Prolog(temp);
DECL.Program(SelfPath, Path, Name, Ext, platform IN {1, 2, 3}, OpSeq, Expr, AssComp, sttypes);
voidtype := sttypes[TVOID];
inttype := sttypes[TINTEGER];
booltype := sttypes[TBOOLEAN];
strtype := sttypes[TSTRING];
settype := sttypes[TSET];
realtype := sttypes[TREAL];
longrealtype := sttypes[TLONGREAL];
chartype := sttypes[TCHAR];
niltype := sttypes[TNIL];
DECL.Compile(platform, stksize);
UTILS.OutString("success"); UTILS.Ln;
UTILS.HALT(0)
END Start;
BEGIN
Start
END Compiler.