1618 lines
41 KiB
Plaintext
1618 lines
41 KiB
Plaintext
(*
|
|
Copyright 2016 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 DECL;
|
|
|
|
IMPORT SCAN, UTILS, X86, SYSTEM;
|
|
|
|
CONST
|
|
|
|
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;
|
|
|
|
lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106;
|
|
lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120;
|
|
|
|
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;
|
|
|
|
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
|
|
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108;
|
|
|
|
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};
|
|
TSTRUCT = {TARRAY, TRECORD};
|
|
|
|
paramvar* = 1; param* = 2;
|
|
|
|
defcall = 0; stdcall = 1; cdecl = 2; winapi* = 3;
|
|
|
|
record = 0; union = 1; noalign = 2;
|
|
|
|
eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6;
|
|
|
|
IOVER* = lxERR5 - lxERR0;
|
|
FOVER* = lxERR7 - lxERR0;
|
|
UNDER* = lxERR9 - lxERR0;
|
|
|
|
TYPE
|
|
|
|
pTYPE* = POINTER TO RECORD (UTILS.rITEM)
|
|
tType*, Size*, Len*, Number*, Align, Call*, Rec: INTEGER;
|
|
Base*: pTYPE;
|
|
Fields*: UTILS.LIST
|
|
END;
|
|
|
|
IDENT* = POINTER TO rIDENT;
|
|
|
|
UNIT* = POINTER TO RECORD (UTILS.rITEM)
|
|
Name: SCAN.NODE;
|
|
File: UTILS.STRING;
|
|
Idents: UTILS.LIST;
|
|
Import: UTILS.LIST;
|
|
IdentBegin: IDENT;
|
|
scanner: SCAN.SCANNER;
|
|
Level*: INTEGER;
|
|
Closed, typedecl, Std, sys: BOOLEAN
|
|
END;
|
|
|
|
rIDENT* = RECORD (UTILS.rITEM)
|
|
Name*: SCAN.NODE;
|
|
T*: pTYPE;
|
|
Unit*: UNIT;
|
|
Parent*: IDENT;
|
|
Proc*: UTILS.ITEM;
|
|
Value*: LONGREAL;
|
|
coord*: SCAN.TCoord;
|
|
Number*, iType*, StProc*, VarSize, ParamSize*,
|
|
LocalSize*, Offset*, VarKind*, Level*, ParamCount*: INTEGER;
|
|
Export: BOOLEAN
|
|
END;
|
|
|
|
PTRBASE = POINTER TO RECORD (UTILS.rITEM)
|
|
Name: SCAN.NODE;
|
|
coord: SCAN.TCoord;
|
|
Ptr: pTYPE
|
|
END;
|
|
|
|
STRITEM = POINTER TO RECORD (UTILS.rITEM)
|
|
Str: UTILS.STRING
|
|
END;
|
|
|
|
FIELD* = POINTER TO RECORD (UTILS.rITEM)
|
|
Name: SCAN.NODE;
|
|
T*: pTYPE;
|
|
Offset*: INTEGER;
|
|
ByRef*, Export*: BOOLEAN;
|
|
Unit*: UNIT
|
|
END;
|
|
|
|
EXPRESSION* = RECORD
|
|
id*: IDENT;
|
|
T*: pTYPE;
|
|
eType*: INTEGER;
|
|
Value*: LONGREAL;
|
|
Read*, vparam*, deref*: BOOLEAN
|
|
END;
|
|
|
|
opPROC = PROCEDURE;
|
|
expPROC = PROCEDURE (VAR e: EXPRESSION);
|
|
assPROC = PROCEDURE (e: EXPRESSION; T: pTYPE; param: BOOLEAN): BOOLEAN;
|
|
|
|
stTYPES* = ARRAY 11 OF pTYPE;
|
|
|
|
Proc* = POINTER TO RECORD (UTILS.rITEM)
|
|
used: BOOLEAN;
|
|
beg, end: X86.ASMLINE;
|
|
Procs*: UTILS.LIST
|
|
END;
|
|
|
|
VAR
|
|
|
|
sttypes: stTYPES; unit*, sys: UNIT; curBlock*: IDENT;
|
|
Path, Main, Std, ExtMain: UTILS.STRING;
|
|
NamePtrBase: SCAN.NODE; ProgSize*, RecCount, UnitNumber*: INTEGER;
|
|
PtrBases, Strings, types, prog, procs: UTILS.LIST; OpSeq: opPROC; Expr: expPROC;
|
|
AssComp: assPROC; main, sizefunc, winplatf, Const*: BOOLEAN;
|
|
pParseType: PROCEDURE (VAR coord: SCAN.TCoord): pTYPE;
|
|
pReadModule: PROCEDURE (Path, Name, Ext: UTILS.STRING): BOOLEAN;
|
|
Platform: INTEGER; voidtype: pTYPE; zcoord: SCAN.TCoord;
|
|
curproc*: Proc;
|
|
|
|
PROCEDURE SetSizeFunc*;
|
|
BEGIN
|
|
sizefunc := TRUE
|
|
END SetSizeFunc;
|
|
|
|
PROCEDURE MemErr*(err: BOOLEAN);
|
|
BEGIN
|
|
IF err THEN
|
|
UTILS.MemErr(TRUE)
|
|
END
|
|
END MemErr;
|
|
|
|
PROCEDURE GetString*(adr: LONGREAL): UTILS.STRCONST;
|
|
VAR str: UTILS.STRCONST;
|
|
BEGIN
|
|
SYSTEM.PUT(SYSTEM.ADR(str), FLOOR(adr))
|
|
RETURN str
|
|
END GetString;
|
|
|
|
PROCEDURE AddString*(str: UTILS.STRING): UTILS.STRCONST;
|
|
VAR nov: UTILS.STRCONST;
|
|
BEGIN
|
|
nov := UTILS.GetStr(Strings, str);
|
|
IF nov = NIL THEN
|
|
NEW(nov);
|
|
MemErr(nov = NIL);
|
|
nov.Str := str;
|
|
nov.Len := SCAN.count - 1;
|
|
nov.Number := X86.NewLabel();
|
|
UTILS.Push(Strings, nov);
|
|
X86.String(nov.Number, nov.Len, nov.Str)
|
|
END
|
|
RETURN nov
|
|
END AddString;
|
|
|
|
PROCEDURE AddMono*(c: CHAR): UTILS.STRCONST;
|
|
VAR nov: UTILS.STRCONST; s: UTILS.STRING;
|
|
BEGIN
|
|
s[0] := c;
|
|
s[1] := 0X;
|
|
nov := UTILS.GetStr(Strings, s);
|
|
IF nov = NIL THEN
|
|
NEW(nov);
|
|
MemErr(nov = NIL);
|
|
nov.Str := s;
|
|
nov.Len := 1;
|
|
nov.Number := X86.NewLabel();
|
|
UTILS.Push(Strings, nov);
|
|
X86.String(nov.Number, nov.Len, nov.Str)
|
|
END
|
|
RETURN nov
|
|
END AddMono;
|
|
|
|
PROCEDURE Coord(VAR coord: SCAN.TCoord);
|
|
BEGIN
|
|
coord := SCAN.coord
|
|
END Coord;
|
|
|
|
PROCEDURE GetModule(Name: SCAN.NODE): UNIT;
|
|
VAR cur, res: UNIT;
|
|
BEGIN
|
|
res := NIL;
|
|
cur := prog.First(UNIT);
|
|
WHILE (cur # NIL) & UTILS.streq(cur.Name.Name, Name.Name) DO
|
|
res := cur;
|
|
cur := NIL
|
|
ELSIF cur # NIL DO
|
|
cur := cur.Next(UNIT)
|
|
END
|
|
RETURN res
|
|
END GetModule;
|
|
|
|
PROCEDURE Assert*(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
|
|
BEGIN
|
|
IF ~cond THEN
|
|
UTILS.ErrMsgPos(coord.line, coord.col, code);
|
|
UTILS.HALT(1)
|
|
END
|
|
END Assert;
|
|
|
|
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
|
|
BEGIN
|
|
IF ~cond THEN
|
|
Assert(FALSE, SCAN.coord, code)
|
|
END
|
|
END Assert2;
|
|
|
|
PROCEDURE Next*;
|
|
VAR coord: SCAN.TCoord;
|
|
BEGIN
|
|
SCAN.GetLex;
|
|
IF (SCAN.tLex > lxERR0) & (SCAN.tLex < lxERR20) THEN
|
|
coord.line := SCAN.coord.line;
|
|
coord.col := SCAN.coord.col + SCAN.count;
|
|
Assert(FALSE, coord, SCAN.tLex - lxERR0)
|
|
END;
|
|
Assert2(SCAN.tLex # lxEOF, 27)
|
|
END Next;
|
|
|
|
PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
|
|
BEGIN
|
|
Next;
|
|
coord := SCAN.coord
|
|
END NextCoord;
|
|
|
|
PROCEDURE Check*(key: INTEGER);
|
|
VAR code: INTEGER;
|
|
BEGIN
|
|
IF SCAN.tLex # key THEN
|
|
CASE key OF
|
|
|lxMODULE: code := 21
|
|
|lxIDENT: code := 22
|
|
|lxSemi: code := 23
|
|
|lxEND: code := 24
|
|
|lxDot: code := 25
|
|
|lxEQ: code := 35
|
|
|lxRRound: code := 38
|
|
|lxTO: code := 40
|
|
|lxOF: code := 41
|
|
|lxRCurly: code := 51
|
|
|lxLRound: code := 56
|
|
|lxComma: code := 61
|
|
|lxTHEN: code := 98
|
|
|lxRSquare: code := 109
|
|
|lxDO: code := 118
|
|
|lxUNTIL: code := 119
|
|
|lxAssign: code := 120
|
|
|lxRETURN: code := 124
|
|
|lxColon: code := 157
|
|
ELSE
|
|
END;
|
|
Assert2(FALSE, code)
|
|
END
|
|
END Check;
|
|
|
|
PROCEDURE NextCheck(key: INTEGER);
|
|
BEGIN
|
|
Next;
|
|
Check(key)
|
|
END NextCheck;
|
|
|
|
PROCEDURE CheckIdent(Name: SCAN.NODE): BOOLEAN;
|
|
VAR cur: IDENT;
|
|
BEGIN
|
|
cur := unit.Idents.Last(IDENT);
|
|
WHILE (cur.iType # IDGUARD) & (cur.Name # Name) DO
|
|
cur := cur.Prev(IDENT)
|
|
END
|
|
RETURN cur.iType = IDGUARD
|
|
END CheckIdent;
|
|
|
|
PROCEDURE Guard;
|
|
VAR ident: IDENT;
|
|
BEGIN
|
|
NEW(ident);
|
|
MemErr(ident = NIL);
|
|
ident.Name := NIL;
|
|
ident.iType := IDGUARD;
|
|
ident.T := voidtype;
|
|
UTILS.Push(unit.Idents, ident);
|
|
INC(unit.Level)
|
|
END Guard;
|
|
|
|
PROCEDURE PushIdent(Name: SCAN.NODE; coord: SCAN.TCoord; iType: INTEGER; T: pTYPE; u: UNIT; Export: BOOLEAN; StProc: INTEGER);
|
|
VAR ident: IDENT; i: INTEGER;
|
|
BEGIN
|
|
Assert(CheckIdent(Name), coord, 30);
|
|
NEW(ident);
|
|
MemErr(ident = NIL);
|
|
ident.Name := Name;
|
|
ident.coord := coord;
|
|
IF iType IN {IDPROC, IDMOD} THEN
|
|
ident.Number := X86.NewLabel();
|
|
i := X86.NewLabel();
|
|
i := X86.NewLabel();
|
|
i := X86.NewLabel()
|
|
END;
|
|
ident.iType := iType;
|
|
ident.T := T;
|
|
ident.Unit := u;
|
|
ident.Export := Export;
|
|
ident.StProc := StProc;
|
|
ident.Level := unit.Level;
|
|
UTILS.Push(unit.Idents, ident)
|
|
END PushIdent;
|
|
|
|
PROCEDURE StTypes;
|
|
VAR type: pTYPE; i: INTEGER;
|
|
BEGIN
|
|
sttypes[0] := NIL;
|
|
FOR i := TINTEGER TO TSTRING DO
|
|
NEW(type);
|
|
MemErr(type = NIL);
|
|
type.tType := i;
|
|
UTILS.Push(types, type);
|
|
sttypes[i] := type
|
|
END;
|
|
sttypes[TINTEGER].Size := 4;
|
|
sttypes[TREAL].Size := 4;
|
|
sttypes[TLONGREAL].Size := 8;
|
|
sttypes[TBOOLEAN].Size := 1;
|
|
sttypes[TCHAR].Size := 1;
|
|
sttypes[TSET].Size := 4;
|
|
sttypes[TVOID].Size := 0;
|
|
sttypes[TSTRING].Size := 0;
|
|
sttypes[TNIL].Size := 4;
|
|
sttypes[TCARD16].Size := 2;
|
|
FOR i := TINTEGER TO TSTRING DO
|
|
sttypes[i].Align := sttypes[i].Size
|
|
END
|
|
END StTypes;
|
|
|
|
PROCEDURE PushStProc(Name: UTILS.STRING; StProc: INTEGER);
|
|
BEGIN
|
|
PushIdent(SCAN.AddNode(Name), zcoord, IDSTPROC, voidtype, NIL, FALSE, StProc)
|
|
END PushStProc;
|
|
|
|
PROCEDURE PushStType(Name: UTILS.STRING; T: INTEGER);
|
|
BEGIN
|
|
PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, FALSE, 0)
|
|
END PushStType;
|
|
|
|
PROCEDURE PushSysProc(Name: UTILS.STRING; StProc: INTEGER);
|
|
BEGIN
|
|
PushIdent(SCAN.AddNode(Name), zcoord, IDSYSPROC, voidtype, NIL, TRUE, StProc)
|
|
END PushSysProc;
|
|
|
|
PROCEDURE PushSysType(Name: UTILS.STRING; T: INTEGER);
|
|
BEGIN
|
|
PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, TRUE, 0)
|
|
END PushSysType;
|
|
|
|
PROCEDURE StIdent;
|
|
BEGIN
|
|
Guard;
|
|
PushStProc("ABS", stABS);
|
|
PushStProc("ASR", stASR);
|
|
PushStProc("ASSERT", stASSERT);
|
|
PushStType("BOOLEAN", TBOOLEAN);
|
|
PushStType("CHAR", TCHAR);
|
|
PushStProc("CHR", stCHR);
|
|
PushStProc("COPY", stCOPY);
|
|
PushStProc("DEC", stDEC);
|
|
PushStProc("DISPOSE", stDISPOSE);
|
|
PushStProc("EXCL", stEXCL);
|
|
PushStProc("FLOOR", stFLOOR);
|
|
PushStProc("FLT", stFLT);
|
|
PushStProc("INC", stINC);
|
|
PushStProc("INCL", stINCL);
|
|
PushStType("INTEGER", TINTEGER);
|
|
PushStProc("LEN", stLEN);
|
|
PushStProc("LSL", stLSL);
|
|
PushStProc("LONG", stLONG);
|
|
PushStType("LONGREAL", TLONGREAL);
|
|
PushStProc("NEW", stNEW);
|
|
PushStProc("ODD", stODD);
|
|
PushStProc("ORD", stORD);
|
|
PushStProc("PACK", stPACK);
|
|
PushStType("REAL", TREAL);
|
|
PushStProc("ROR", stROR);
|
|
PushStType("SET", TSET);
|
|
PushStProc("SHORT", stSHORT);
|
|
PushStProc("UNPK", stUNPK);
|
|
PushStProc("BITS", stBITS);
|
|
PushStProc("LSR", stLSR);
|
|
PushStProc("LENGTH", stLENGTH);
|
|
Guard
|
|
END StIdent;
|
|
|
|
PROCEDURE GetQIdent*(Unit: UNIT; Name: SCAN.NODE): IDENT;
|
|
VAR cur, res: IDENT;
|
|
BEGIN
|
|
res := NIL;
|
|
cur := Unit.IdentBegin.Next(IDENT);
|
|
WHILE (cur # NIL) & (cur.iType # IDGUARD) DO
|
|
IF cur.Name = Name THEN
|
|
IF (Unit # unit) & ~cur.Export THEN
|
|
res := NIL
|
|
ELSE
|
|
res := cur
|
|
END;
|
|
cur := NIL
|
|
ELSE
|
|
cur := cur.Next(IDENT)
|
|
END
|
|
END
|
|
RETURN res
|
|
END GetQIdent;
|
|
|
|
PROCEDURE GetIdent*(Name: SCAN.NODE): IDENT;
|
|
VAR cur, res: IDENT;
|
|
BEGIN
|
|
res := NIL;
|
|
cur := unit.Idents.Last(IDENT);
|
|
WHILE (cur # NIL) & (cur.Name = Name) DO
|
|
res := cur;
|
|
cur := NIL
|
|
ELSIF cur # NIL DO
|
|
cur := cur.Prev(IDENT)
|
|
END
|
|
RETURN res
|
|
END GetIdent;
|
|
|
|
PROCEDURE Relation*(Op: INTEGER): BOOLEAN;
|
|
VAR Res: BOOLEAN;
|
|
BEGIN
|
|
CASE Op OF
|
|
|lxEQ, lxNE, lxLT, lxGT,
|
|
lxLE, lxGE, lxIN, lxIS:
|
|
Res := TRUE
|
|
ELSE
|
|
Res := FALSE
|
|
END
|
|
RETURN Res
|
|
END Relation;
|
|
|
|
PROCEDURE Arith(a, b: LONGREAL; T: pTYPE; Op: INTEGER; coord: SCAN.TCoord): LONGREAL;
|
|
CONST max = SCAN.maxDBL;
|
|
VAR res: LONGREAL;
|
|
BEGIN
|
|
CASE Op OF
|
|
|lxPlus: res := a + b
|
|
|lxMinus: res := a - b
|
|
|lxMult: res := a * b
|
|
|lxSlash:
|
|
Assert(b # 0.0D0, coord, 46);
|
|
res := a / b
|
|
|lxDIV:
|
|
Assert(~((a = LONG(FLT(SCAN.minINT))) & (b = -1.0D0)), coord, IOVER);
|
|
res := LONG(FLT(FLOOR(a) DIV FLOOR(b)))
|
|
|lxMOD:
|
|
res := LONG(FLT(FLOOR(a) MOD FLOOR(b)))
|
|
ELSE
|
|
END;
|
|
Assert(~UTILS.IsInf(res), coord, FOVER);
|
|
CASE T.tType OF
|
|
|TINTEGER: Assert((res <= LONG(FLT(SCAN.maxINT))) & (res >= LONG(FLT(SCAN.minINT))), coord, IOVER)
|
|
|TREAL: Assert((res <= LONG(SCAN.maxREAL)) & (res >= -LONG(SCAN.maxREAL)), coord, FOVER)
|
|
|TLONGREAL: Assert((res <= max) & (res >= -max), coord, FOVER)
|
|
ELSE
|
|
END;
|
|
IF (res = 0.0D0) & (T.tType IN TFLOAT) OR (ABS(res) < LONG(SCAN.minREAL)) & (T.tType = TREAL) THEN
|
|
CASE Op OF
|
|
|lxPlus: Assert(a = -b, coord, UNDER)
|
|
|lxMinus: Assert(a = b, coord, UNDER)
|
|
|lxMult: Assert((a = 0.0D0) OR (b = 0.0D0), coord, UNDER)
|
|
|lxSlash: Assert((a = 0.0D0), coord, UNDER)
|
|
ELSE
|
|
END
|
|
END
|
|
RETURN res
|
|
END Arith;
|
|
|
|
PROCEDURE strcmp(a, b: LONGREAL; Op: INTEGER): LONGREAL;
|
|
VAR sa, sb: UTILS.STRCONST; Res: LONGREAL;
|
|
BEGIN
|
|
sa := GetString(a);
|
|
sb := GetString(b);
|
|
CASE Op OF
|
|
|lxEQ, lxNE: Res := LONG(FLT(ORD(sa.Str = sb.Str)))
|
|
|lxLT, lxGT: Res := LONG(FLT(ORD(sa.Str < sb.Str)))
|
|
|lxLE, lxGE: Res := LONG(FLT(ORD(sa.Str <= sb.Str)))
|
|
ELSE
|
|
END
|
|
RETURN Res
|
|
END strcmp;
|
|
|
|
PROCEDURE Calc*(a, b: LONGREAL; Ta, Tb: pTYPE; Op: INTEGER; coord: SCAN.TCoord; VAR Res: LONGREAL; VAR TRes: pTYPE);
|
|
VAR c: LONGREAL; ai, bi: INTEGER;
|
|
BEGIN
|
|
ai := FLOOR(a);
|
|
bi := FLOOR(b);
|
|
IF Op # lxIN THEN
|
|
Assert(Ta = Tb, coord, 37)
|
|
END;
|
|
CASE Op OF
|
|
|lxPlus, lxMinus, lxMult, lxSlash:
|
|
Assert(~((Op = lxSlash) & (Ta.tType = TINTEGER)), coord, 37);
|
|
IF Ta.tType IN TNUM THEN
|
|
Res := Arith(a, b, Ta, Op, coord)
|
|
ELSIF Ta.tType = TSET THEN
|
|
CASE Op OF
|
|
|lxPlus: Res := LONG(FLT(ORD(BITS(ai) + BITS(bi))))
|
|
|lxMinus: Res := LONG(FLT(ORD(BITS(ai) - BITS(bi))))
|
|
|lxMult: Res := LONG(FLT(ORD(BITS(ai) * BITS(bi))))
|
|
|lxSlash: Res := LONG(FLT(ORD(BITS(ai) / BITS(bi))))
|
|
ELSE
|
|
END
|
|
ELSE
|
|
Assert(FALSE, coord, 37)
|
|
END;
|
|
TRes := Ta
|
|
|lxDIV, lxMOD:
|
|
Assert(Ta.tType = TINTEGER, coord, 37);
|
|
Assert(bi # 0, coord, 48);
|
|
TRes := Ta;
|
|
Res := Arith(a, b, Ta, Op, coord)
|
|
|lxAnd:
|
|
Assert(Ta.tType = TBOOLEAN, coord, 37);
|
|
Res := LONG(FLT(ORD((ai # 0) & (bi # 0))))
|
|
|lxOR:
|
|
Assert(Ta.tType = TBOOLEAN, coord, 37);
|
|
Res := LONG(FLT(ORD((ai # 0) OR (bi # 0))))
|
|
|lxEQ, lxNE:
|
|
IF Ta.tType = TSTRING THEN
|
|
Res := strcmp(a, b, Op)
|
|
ELSE
|
|
Res := LONG(FLT(ORD(a = b)))
|
|
END;
|
|
IF Op = lxNE THEN
|
|
Res := LONG(FLT(ORD(Res = 0.0D0)))
|
|
END
|
|
|lxLT, lxGT:
|
|
IF Op = lxGT THEN
|
|
c := a;
|
|
a := b;
|
|
b := c
|
|
END;
|
|
Assert(Ta.tType IN (TNUM + {TSTRING}), coord, 37);
|
|
IF Ta.tType = TSTRING THEN
|
|
Res := strcmp(a, b, Op)
|
|
ELSE
|
|
Res := LONG(FLT(ORD(a < b)))
|
|
END
|
|
|lxLE, lxGE:
|
|
IF Op = lxGE THEN
|
|
c := a;
|
|
a := b;
|
|
b := c
|
|
END;
|
|
Assert(Ta.tType IN (TNUM + {TSTRING, TSET}), coord, 37);
|
|
IF Ta.tType = TSTRING THEN
|
|
Res := strcmp(a, b, Op)
|
|
ELSIF Ta.tType = TSET THEN
|
|
Res := LONG(FLT(ORD(BITS(FLOOR(a)) <= BITS(FLOOR(b)))))
|
|
ELSE
|
|
Res := LONG(FLT(ORD(a <= b)))
|
|
END
|
|
|lxIN:
|
|
Assert((Ta.tType = TINTEGER) & (Tb.tType = TSET), coord, 37);
|
|
Assert(ASR(ai, 5) = 0, coord, 49);
|
|
Res := LONG(FLT(ORD(ai IN BITS(bi))))
|
|
ELSE
|
|
END;
|
|
IF Relation(Op) OR (Op = lxAnd) OR (Op = lxOR) THEN
|
|
TRes := sttypes[TBOOLEAN]
|
|
END
|
|
END Calc;
|
|
|
|
PROCEDURE ConstExpr*(VAR Value: LONGREAL; VAR T: pTYPE);
|
|
VAR e: EXPRESSION; coord: SCAN.TCoord;
|
|
BEGIN
|
|
Const := TRUE;
|
|
Coord(coord);
|
|
sizefunc := FALSE;
|
|
Expr(e);
|
|
Assert(~sizefunc & (e.eType = eCONST), coord, 62);
|
|
Value := e.Value;
|
|
T := e.T;
|
|
Const := FALSE
|
|
END ConstExpr;
|
|
|
|
PROCEDURE IdType*(VAR coord: SCAN.TCoord): pTYPE;
|
|
VAR id: IDENT; Name: SCAN.NODE; Unit: UNIT; Res: pTYPE;
|
|
BEGIN
|
|
Res := NIL;
|
|
Name := SCAN.id;
|
|
id := GetIdent(Name);
|
|
IF id = NIL THEN
|
|
Coord(coord);
|
|
NamePtrBase := Name;
|
|
Next
|
|
ELSE
|
|
IF id.iType = IDTYPE THEN
|
|
Coord(coord);
|
|
Next;
|
|
Res := id.T
|
|
ELSIF id.iType = IDMOD THEN
|
|
Unit := id.Unit;
|
|
NextCheck(lxDot);
|
|
NextCheck(lxIDENT);
|
|
Name := SCAN.id;
|
|
NamePtrBase := Name;
|
|
id := GetQIdent(Unit, Name);
|
|
IF Unit # unit THEN
|
|
Assert2(id # NIL, 42);
|
|
Assert2(id.iType = IDTYPE, 77);
|
|
Coord(coord);
|
|
Next;
|
|
Res := id.T
|
|
ELSE
|
|
IF id = NIL THEN
|
|
Assert2((unit.Level = 3) & unit.typedecl, 42);
|
|
Coord(coord);
|
|
Next;
|
|
Res := NIL
|
|
ELSE
|
|
Assert2(id.iType = IDTYPE, 77);
|
|
Coord(coord);
|
|
Next;
|
|
Res := id.T
|
|
END
|
|
END
|
|
ELSE
|
|
Assert2(FALSE, 77)
|
|
END
|
|
END
|
|
RETURN Res
|
|
END IdType;
|
|
|
|
PROCEDURE FieldOffset(Align, RecSize: INTEGER): INTEGER;
|
|
BEGIN
|
|
Assert2(RecSize <= SCAN.maxINT - (Align - RecSize MOD Align) MOD Align, 83)
|
|
RETURN RecSize + (Align - RecSize MOD Align) MOD Align
|
|
END FieldOffset;
|
|
|
|
PROCEDURE Dim*(T: pTYPE): INTEGER;
|
|
VAR n: INTEGER;
|
|
BEGIN
|
|
n := 0;
|
|
WHILE (T.tType = TARRAY) & (T.Len = 0) DO
|
|
INC(n);
|
|
T := T.Base
|
|
END
|
|
RETURN n
|
|
END Dim;
|
|
|
|
PROCEDURE SetFields(Tr, Tf: pTYPE; Rec: BOOLEAN);
|
|
VAR cur: FIELD;
|
|
BEGIN
|
|
cur := Tr.Fields.First(FIELD);
|
|
WHILE cur.T # NIL DO
|
|
cur := cur.Next(FIELD)
|
|
END;
|
|
WHILE cur # NIL DO
|
|
cur.T := Tf;
|
|
IF Rec THEN
|
|
IF Tf.Align > Tr.Align THEN
|
|
Tr.Align := Tf.Align
|
|
END;
|
|
IF Tr.Rec = record THEN
|
|
cur.Offset := FieldOffset(Tf.Align, Tr.Size);
|
|
Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
|
|
Tr.Size := cur.Offset + Tf.Size
|
|
ELSIF Tr.Rec = noalign THEN
|
|
cur.Offset := FieldOffset(1, Tr.Size);
|
|
Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
|
|
Tr.Size := cur.Offset + Tf.Size
|
|
ELSIF Tr.Rec = union THEN
|
|
IF Tf.Size > Tr.Size THEN
|
|
Tr.Size := Tf.Size
|
|
END;
|
|
cur.Offset := 0
|
|
END
|
|
ELSE
|
|
Tr.Len := Tr.Len + 4 * (ORD((Tf.tType = TRECORD) & cur.ByRef) + Dim(Tf) + ORD((Tf.tType = TLONGREAL) & ~cur.ByRef) + 1)
|
|
END;
|
|
cur := cur.Next(FIELD)
|
|
END
|
|
END SetFields;
|
|
|
|
PROCEDURE GetField*(T: pTYPE; Name: SCAN.NODE): FIELD;
|
|
VAR cur, Res: FIELD;
|
|
BEGIN
|
|
Res := NIL;
|
|
cur := T.Fields.First(FIELD);
|
|
WHILE (cur # NIL) & (cur.Name = Name) DO
|
|
Res := cur;
|
|
cur := NIL
|
|
ELSIF cur # NIL DO
|
|
cur := cur.Next(FIELD)
|
|
END
|
|
RETURN Res
|
|
END GetField;
|
|
|
|
PROCEDURE Unique(T: pTYPE; Name: SCAN.NODE): BOOLEAN;
|
|
VAR field: FIELD; res: BOOLEAN;
|
|
BEGIN
|
|
res := TRUE;
|
|
WHILE (T # NIL) & res DO
|
|
field := GetField(T, Name);
|
|
IF field # NIL THEN
|
|
IF (field.Unit = unit) OR field.Export THEN
|
|
res := FALSE
|
|
END
|
|
END;
|
|
T := T.Base
|
|
END
|
|
RETURN res
|
|
END Unique;
|
|
|
|
PROCEDURE notrecurs(id: BOOLEAN; T: pTYPE): BOOLEAN;
|
|
RETURN ~(id & (unit.Idents.Last(IDENT).iType = IDTYPE) & (unit.Idents.Last(IDENT).T = T) &
|
|
(T.tType IN TSTRUCT))
|
|
END notrecurs;
|
|
|
|
PROCEDURE ReadFields(T: pTYPE);
|
|
VAR Name: SCAN.NODE; field: FIELD; Tf: pTYPE; coord: SCAN.TCoord; id_T: BOOLEAN;
|
|
BEGIN
|
|
WHILE SCAN.tLex = lxIDENT DO
|
|
Name := SCAN.id;
|
|
Assert2(Unique(T, Name), 30);
|
|
NEW(field);
|
|
MemErr(field = NIL);
|
|
UTILS.Push(T.Fields, field);
|
|
field.Name := Name;
|
|
field.T := NIL;
|
|
field.Export := FALSE;
|
|
field.Unit := unit;
|
|
Next;
|
|
IF SCAN.tLex = lxMult THEN
|
|
Assert2(unit.Level = 3, 89);
|
|
field.Export := TRUE;
|
|
Next
|
|
END;
|
|
IF SCAN.tLex = lxComma THEN
|
|
NextCheck(lxIDENT)
|
|
ELSIF SCAN.tLex = lxColon THEN
|
|
NextCoord(coord);
|
|
id_T := SCAN.tLex = lxIDENT;
|
|
Tf:= pParseType(coord);
|
|
Assert(Tf # NIL, coord, 42);
|
|
Assert(notrecurs(id_T, Tf), coord, 96);
|
|
SetFields(T, Tf, TRUE);
|
|
IF SCAN.tLex = lxSemi THEN
|
|
NextCheck(lxIDENT)
|
|
ELSE
|
|
Assert2(SCAN.tLex = lxEND, 86)
|
|
END
|
|
ELSE
|
|
Assert2(FALSE, 85)
|
|
END
|
|
END
|
|
END ReadFields;
|
|
|
|
PROCEDURE OpenBase*(T: pTYPE): pTYPE;
|
|
BEGIN
|
|
WHILE (T.tType = TARRAY) & (T.Len = 0) DO
|
|
T := T.Base
|
|
END
|
|
RETURN T
|
|
END OpenBase;
|
|
|
|
PROCEDURE SetVars(T: pTYPE);
|
|
VAR cur: IDENT; n: INTEGER;
|
|
BEGIN
|
|
cur := unit.Idents.Last(IDENT);
|
|
WHILE cur.T = NIL DO
|
|
cur := cur.Prev(IDENT)
|
|
END;
|
|
cur := cur.Next(IDENT);
|
|
WHILE cur # NIL DO
|
|
cur.T := T;
|
|
IF(cur.VarKind = paramvar) OR (cur.VarKind = param) & (T.tType IN TSTRUCT) THEN
|
|
n := 4 * (1 + Dim(T) + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
|
|
ELSE
|
|
n := T.Size;
|
|
Assert2(n <= SCAN.maxINT - UTILS.Align(n), 93);
|
|
n := n + UTILS.Align(n)
|
|
END;
|
|
IF cur.Level = 3 THEN
|
|
cur.Offset := ProgSize;
|
|
Assert2(ProgSize <= SCAN.maxINT - n, 93);
|
|
ProgSize := ProgSize + n;
|
|
Assert2(ProgSize <= SCAN.maxINT - UTILS.Align(ProgSize), 93);
|
|
ProgSize := ProgSize + UTILS.Align(ProgSize)
|
|
ELSE
|
|
IF cur.VarKind = 0 THEN
|
|
cur.Offset := curBlock.ParamSize - curBlock.VarSize - n
|
|
ELSE
|
|
cur.Offset := curBlock.VarSize - 8 + 4 * (cur.Level + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
|
|
END
|
|
END;
|
|
Assert2(curBlock.VarSize <= SCAN.maxINT - n, 93);
|
|
curBlock.VarSize := curBlock.VarSize + n;
|
|
Assert2(curBlock.VarSize <= SCAN.maxINT - UTILS.Align(curBlock.VarSize), 93);
|
|
curBlock.VarSize := curBlock.VarSize + UTILS.Align(curBlock.VarSize);
|
|
IF cur.VarKind # 0 THEN
|
|
curBlock.ParamSize := curBlock.VarSize
|
|
END;
|
|
cur := cur.Next(IDENT)
|
|
END
|
|
END SetVars;
|
|
|
|
PROCEDURE CreateType(tType, Len, Size, Number: INTEGER; Base: pTYPE; Fields: BOOLEAN; NewType: pTYPE): pTYPE;
|
|
VAR nov: pTYPE;
|
|
BEGIN
|
|
IF NewType = NIL THEN
|
|
NEW(nov);
|
|
MemErr(nov = NIL)
|
|
ELSE
|
|
nov := NewType
|
|
END;
|
|
UTILS.Push(types, nov);
|
|
nov.tType := tType;
|
|
nov.Len := Len;
|
|
nov.Size := Size;
|
|
nov.Base := Base;
|
|
nov.Fields := NIL;
|
|
nov.Number := Number;
|
|
IF Fields THEN
|
|
nov.Fields := UTILS.CreateList()
|
|
END
|
|
RETURN nov
|
|
END CreateType;
|
|
|
|
PROCEDURE FormalType(VAR coord: SCAN.TCoord): pTYPE;
|
|
VAR TA: pTYPE;
|
|
BEGIN
|
|
IF SCAN.tLex = lxARRAY THEN
|
|
NextCheck(lxOF);
|
|
Next;
|
|
TA := CreateType(TARRAY, 0, 0, 0, FormalType(coord), FALSE, NIL)
|
|
ELSE
|
|
Check(lxIDENT);
|
|
TA := IdType(coord);
|
|
Assert(TA # NIL, coord, 42);
|
|
END
|
|
RETURN TA
|
|
END FormalType;
|
|
|
|
PROCEDURE Section(T: pTYPE);
|
|
VAR Name: SCAN.NODE; ByRef, cont: BOOLEAN; field: FIELD;
|
|
Tf: pTYPE; fp: IDENT; coord: SCAN.TCoord; proc: BOOLEAN;
|
|
BEGIN
|
|
proc := T = NIL;
|
|
IF proc THEN
|
|
T := curBlock.T
|
|
END;
|
|
Assert2((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR), 84);
|
|
ByRef := FALSE;
|
|
IF SCAN.tLex = lxVAR THEN
|
|
ByRef := TRUE;
|
|
NextCheck(lxIDENT)
|
|
END;
|
|
cont := TRUE;
|
|
WHILE cont DO
|
|
Name := SCAN.id;
|
|
Assert2(GetField(T, Name) = NIL, 30);
|
|
NEW(field);
|
|
MemErr(field = NIL);
|
|
UTILS.Push(T.Fields, field);
|
|
field.Name := Name;
|
|
field.T := NIL;
|
|
field.ByRef := ByRef;
|
|
IF proc THEN
|
|
PushIdent(Name, coord, IDVAR, NIL, NIL, FALSE, 0);
|
|
INC(curBlock.ParamCount);
|
|
fp := unit.Idents.Last(IDENT);
|
|
IF ByRef THEN
|
|
fp.VarKind := paramvar
|
|
ELSE
|
|
fp.VarKind := param
|
|
END
|
|
END;
|
|
Next;
|
|
IF SCAN.tLex = lxComma THEN
|
|
NextCheck(lxIDENT)
|
|
ELSIF SCAN.tLex = lxColon THEN
|
|
Next;
|
|
Tf := FormalType(coord);
|
|
Assert(Dim(Tf) <= X86.ADIM, coord, 110);
|
|
SetFields(T, Tf, FALSE);
|
|
IF proc THEN
|
|
SetVars(Tf)
|
|
END;
|
|
cont := FALSE
|
|
ELSE
|
|
Assert2(FALSE, 85)
|
|
END
|
|
END
|
|
END Section;
|
|
|
|
PROCEDURE ParamType(T: pTYPE);
|
|
VAR break: BOOLEAN;
|
|
BEGIN
|
|
IF (SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR) THEN
|
|
break := FALSE;
|
|
REPEAT
|
|
Section(T);
|
|
IF SCAN.tLex = lxSemi THEN
|
|
Next
|
|
ELSE
|
|
break := TRUE
|
|
END
|
|
UNTIL break
|
|
END
|
|
END ParamType;
|
|
|
|
PROCEDURE AddPtrBase(Name: SCAN.NODE; coord: SCAN.TCoord; T: pTYPE);
|
|
VAR nov: PTRBASE;
|
|
BEGIN
|
|
NEW(nov);
|
|
MemErr(nov = NIL);
|
|
nov.Name := Name;
|
|
nov.coord := coord;
|
|
nov.Ptr := T;
|
|
UTILS.Push(PtrBases, nov)
|
|
END AddPtrBase;
|
|
|
|
PROCEDURE FormalList(T: pTYPE; VAR Res: pTYPE);
|
|
VAR coord: SCAN.TCoord;
|
|
BEGIN
|
|
IF SCAN.tLex = lxLRound THEN
|
|
Next;
|
|
ParamType(T);
|
|
Check(lxRRound);
|
|
Next;
|
|
IF SCAN.tLex = lxColon THEN
|
|
NextCheck(lxIDENT);
|
|
Res := IdType(coord);
|
|
Assert(Res # NIL, coord, 42);
|
|
Assert(~(Res.tType IN TSTRUCT), coord, 82)
|
|
END
|
|
END
|
|
END FormalList;
|
|
|
|
PROCEDURE CallFlag(VAR Call: INTEGER): BOOLEAN;
|
|
VAR res: BOOLEAN;
|
|
BEGIN
|
|
res := SCAN.tLex = lxLSquare;
|
|
IF res THEN
|
|
Next;
|
|
IF SCAN.Lex = "cdecl" THEN
|
|
Call := cdecl
|
|
ELSIF SCAN.Lex = "stdcall" THEN
|
|
Call := stdcall
|
|
ELSIF SCAN.Lex = "winapi" THEN
|
|
Assert2(winplatf, 50);
|
|
Call := winapi
|
|
ELSE
|
|
Assert2(FALSE, 44)
|
|
END;
|
|
NextCheck(lxRSquare);
|
|
Next;
|
|
ELSE
|
|
Call := defcall
|
|
END
|
|
RETURN res
|
|
END CallFlag;
|
|
|
|
PROCEDURE RecFlag(VAR rec: INTEGER): BOOLEAN;
|
|
VAR res: BOOLEAN;
|
|
BEGIN
|
|
res := SCAN.tLex = lxLSquare;
|
|
IF res THEN
|
|
Next;
|
|
IF SCAN.Lex = "union" THEN
|
|
rec := union
|
|
ELSIF SCAN.Lex = "noalign" THEN
|
|
rec := noalign
|
|
ELSE
|
|
Assert2(FALSE, 103)
|
|
END;
|
|
NextCheck(lxRSquare);
|
|
Next;
|
|
ELSE
|
|
rec := record
|
|
END
|
|
RETURN res
|
|
END RecFlag;
|
|
|
|
PROCEDURE StructType(Comma: BOOLEAN; NewType: pTYPE): pTYPE;
|
|
VAR v: LONGREAL; T, nov: pTYPE; coord, coord2: SCAN.TCoord; id_T: BOOLEAN;
|
|
BEGIN
|
|
CASE SCAN.tLex OF
|
|
|lxARRAY, lxComma:
|
|
IF SCAN.tLex = lxComma THEN
|
|
Assert2(Comma, 39)
|
|
END;
|
|
NextCoord(coord);
|
|
ConstExpr(v, T);
|
|
Assert(T.tType = TINTEGER, coord, 52);
|
|
Assert(v > 0.0D0, coord, 78);
|
|
nov := CreateType(TARRAY, FLOOR(v), 0, 0, NIL, FALSE, NewType);
|
|
IF SCAN.tLex = lxComma THEN
|
|
nov.Base := StructType(TRUE, NIL)
|
|
ELSIF SCAN.tLex = lxOF THEN
|
|
NextCoord(coord);
|
|
id_T := SCAN.tLex = lxIDENT;
|
|
nov.Base := pParseType(coord);
|
|
Assert(nov.Base # NIL, coord, 42);
|
|
Assert(notrecurs(id_T, nov.Base), coord, 96)
|
|
ELSE
|
|
Assert2(FALSE, 79)
|
|
END;
|
|
Assert2(nov.Base.Size <= SCAN.maxINT DIV nov.Len, 83);
|
|
nov.Size := nov.Base.Size * nov.Len;
|
|
nov.Align := nov.Base.Align
|
|
|lxRECORD:
|
|
NextCoord(coord);
|
|
INC(RecCount);
|
|
nov := CreateType(TRECORD, 0, 0, RecCount, NIL, TRUE, NewType);
|
|
nov.Align := 1;
|
|
IF RecFlag(nov.Rec) THEN
|
|
Assert(unit.sys, coord, 111)
|
|
END;
|
|
Coord(coord);
|
|
IF SCAN.tLex = lxLRound THEN
|
|
NextCoord(coord2);
|
|
Check(lxIDENT);
|
|
nov.Base := IdType(coord);
|
|
Assert(nov.Base # NIL, coord, 42);
|
|
Assert(nov.Base.tType = TRECORD, coord, 80);
|
|
Assert(notrecurs(TRUE, nov.Base), coord, 96);
|
|
nov.Size := nov.Base.Size;
|
|
nov.Align := nov.Base.Align;
|
|
Check(lxRRound);
|
|
Next;
|
|
Assert(nov.Rec = record, coord, 112);
|
|
Assert(nov.Base.Rec = record, coord2, 113)
|
|
END;
|
|
ReadFields(nov);
|
|
Check(lxEND);
|
|
nov.Size := X86.Align(nov.Size, nov.Align);
|
|
IF nov.Base # NIL THEN
|
|
X86.AddRec(nov.Base.Number)
|
|
ELSE
|
|
X86.AddRec(0)
|
|
END;
|
|
Next
|
|
|lxPOINTER:
|
|
NextCheck(lxTO);
|
|
NextCoord(coord);
|
|
nov := CreateType(TPOINTER, 0, 4, 0, NIL, FALSE, NewType);
|
|
nov.Align := 4;
|
|
nov.Base := pParseType(coord);
|
|
IF nov.Base = NIL THEN
|
|
Assert(unit.typedecl, coord, 42);
|
|
AddPtrBase(NamePtrBase, coord, nov)
|
|
ELSE
|
|
Assert(nov.Base.tType = TRECORD, coord, 81)
|
|
END
|
|
|lxPROCEDURE:
|
|
NextCoord(coord);
|
|
nov := CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NewType);
|
|
IF CallFlag(nov.Call) THEN
|
|
Assert(unit.sys, coord, 111)
|
|
END;
|
|
nov.Align := 4;
|
|
FormalList(nov, nov.Base)
|
|
ELSE
|
|
Assert2(FALSE, 39)
|
|
END
|
|
RETURN nov
|
|
END StructType;
|
|
|
|
PROCEDURE ParseType(VAR coord: SCAN.TCoord): pTYPE;
|
|
VAR Res: pTYPE;
|
|
BEGIN
|
|
IF SCAN.tLex = lxIDENT THEN
|
|
Res := IdType(coord)
|
|
ELSE
|
|
Res := StructType(FALSE, NIL)
|
|
END
|
|
RETURN Res
|
|
END ParseType;
|
|
|
|
PROCEDURE PopBlock;
|
|
VAR cur: IDENT; n: INTEGER;
|
|
BEGIN
|
|
cur := unit.Idents.Last(IDENT);
|
|
n := 0;
|
|
WHILE cur.iType # IDGUARD DO
|
|
cur := cur.Prev(IDENT);
|
|
INC(n)
|
|
END;
|
|
cur := cur.Prev(IDENT);
|
|
INC(n);
|
|
unit.Idents.Count := unit.Idents.Count - n;
|
|
unit.Idents.Last := cur;
|
|
cur.Next := NIL;
|
|
DEC(unit.Level)
|
|
END PopBlock;
|
|
|
|
PROCEDURE LinkPtr;
|
|
VAR cur: PTRBASE; id: IDENT;
|
|
BEGIN
|
|
cur := PtrBases.First(PTRBASE);
|
|
WHILE cur # NIL DO
|
|
id := GetIdent(cur.Name);
|
|
Assert(id # NIL, cur.coord, 42);
|
|
Assert(id.T.tType = TRECORD, cur.coord, 81);
|
|
cur.Ptr.Base := id.T;
|
|
cur := cur.Next(PTRBASE)
|
|
END;
|
|
UTILS.Clear(PtrBases)
|
|
END LinkPtr;
|
|
|
|
PROCEDURE addproc;
|
|
VAR proc: Proc;
|
|
BEGIN
|
|
NEW(proc);
|
|
MemErr(proc = NIL);
|
|
proc.used := FALSE;
|
|
proc.Procs := UTILS.CreateList();
|
|
UTILS.Push(procs, proc);
|
|
curproc := proc
|
|
END addproc;
|
|
|
|
PROCEDURE DeclSeq;
|
|
VAR Value: LONGREAL; T, NewType: pTYPE; Name: SCAN.NODE; coord: SCAN.TCoord; Call: INTEGER;
|
|
Export, func: BOOLEAN; last, id: IDENT; e: EXPRESSION;
|
|
|
|
PROCEDURE IdentDef;
|
|
BEGIN
|
|
Name := SCAN.id;
|
|
Coord(coord);
|
|
Next;
|
|
Export := FALSE;
|
|
IF SCAN.tLex = lxMult THEN
|
|
Assert2(unit.Level = 3, 89);
|
|
Export := TRUE;
|
|
Next
|
|
END
|
|
END IdentDef;
|
|
|
|
BEGIN
|
|
IF SCAN.tLex = lxCONST THEN
|
|
Next;
|
|
WHILE SCAN.tLex = lxIDENT DO
|
|
IdentDef;
|
|
PushIdent(Name, coord, IDCONST, NIL, NIL, Export, 0);
|
|
last := unit.Idents.Last(IDENT);
|
|
Check(lxEQ);
|
|
Next;
|
|
ConstExpr(Value, T);
|
|
Check(lxSemi);
|
|
last.Value := Value;
|
|
last.T := T;
|
|
Next
|
|
END
|
|
END;
|
|
IF SCAN.tLex = lxTYPE THEN
|
|
UTILS.Clear(PtrBases);
|
|
unit.typedecl := TRUE;
|
|
Next;
|
|
WHILE SCAN.tLex = lxIDENT DO
|
|
IdentDef;
|
|
PushIdent(Name, coord, IDTYPE, NIL, NIL, Export, 0);
|
|
last := unit.Idents.Last(IDENT);
|
|
Check(lxEQ);
|
|
Next;
|
|
NEW(NewType);
|
|
MemErr(NewType = NIL);
|
|
last.T := NewType;
|
|
T := StructType(FALSE, NewType);
|
|
Check(lxSemi);
|
|
Next
|
|
END
|
|
END;
|
|
LinkPtr;
|
|
unit.typedecl := FALSE;
|
|
IF SCAN.tLex = lxVAR THEN
|
|
Next;
|
|
WHILE SCAN.tLex = lxIDENT DO
|
|
IdentDef;
|
|
PushIdent(Name, coord, IDVAR, NIL, NIL, Export, 0);
|
|
IF SCAN.tLex = lxComma THEN
|
|
NextCheck(lxIDENT)
|
|
ELSIF SCAN.tLex = lxColon THEN
|
|
NextCoord(coord);
|
|
T := ParseType(coord);
|
|
Assert(T # NIL, coord, 42);
|
|
SetVars(T);
|
|
Check(lxSemi);
|
|
Next
|
|
ELSE
|
|
Assert2(FALSE, 85)
|
|
END
|
|
END
|
|
END;
|
|
WHILE SCAN.tLex = lxPROCEDURE DO
|
|
NextCoord(coord);
|
|
IF CallFlag(Call) THEN
|
|
Assert(unit.Level = 3, coord, 45);
|
|
Assert(unit.sys, coord, 111)
|
|
END;
|
|
Check(lxIDENT);
|
|
IdentDef;
|
|
PushIdent(Name, coord, IDPROC, CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NIL), NIL, Export, 0);
|
|
id := unit.Idents.Last(IDENT);
|
|
addproc;
|
|
id.Proc := curproc;
|
|
IF id.Export & main THEN
|
|
IF Platform IN {1, 6} THEN
|
|
curproc.used := TRUE;
|
|
Assert((Name # SCAN._START) & (Name # SCAN._version), coord, 133)
|
|
END;
|
|
X86.ProcExport(id.Number, Name, X86.NewLabel())
|
|
END;
|
|
id.Parent := curBlock;
|
|
curBlock := id;
|
|
Guard;
|
|
FormalList(NIL, curBlock.T.Base);
|
|
id.T.Call := Call;
|
|
Check(lxSemi);
|
|
Next;
|
|
DeclSeq;
|
|
id.LocalSize := id.VarSize - id.ParamSize;
|
|
X86.Label(X86.NewLabel());
|
|
curproc.beg := X86.current;
|
|
X86.ProcBeg(id.Number, id.LocalSize, FALSE);
|
|
IF SCAN.tLex = lxBEGIN THEN
|
|
Next;
|
|
OpSeq
|
|
END;
|
|
func := curBlock.T.Base.tType # TVOID;
|
|
IF func THEN
|
|
Check(lxRETURN);
|
|
UTILS.UnitLine(UnitNumber, SCAN.coord.line);
|
|
NextCoord(coord);
|
|
Expr(e);
|
|
Assert(AssComp(e, curBlock.T.Base, FALSE), coord, 125);
|
|
IF e.eType = eVAR THEN
|
|
X86.Load(e.T.tType)
|
|
END
|
|
ELSE
|
|
Assert2(SCAN.tLex # lxRETURN, 123)
|
|
END;
|
|
Check(lxEND);
|
|
NextCheck(lxIDENT);
|
|
Assert2(SCAN.id = Name, 87);
|
|
NextCheck(lxSemi);
|
|
Next;
|
|
X86.ProcEnd(id.Number, (id.ParamSize + (id.Level - 3) * 4) * ORD(curBlock.T.Call IN {stdcall, winapi, defcall}), func, curBlock.T.Base.tType IN TFLOAT);
|
|
X86.Label(X86.NewLabel());
|
|
curproc.end := X86.current;
|
|
PopBlock;
|
|
curBlock := curBlock.Parent;
|
|
curproc := curBlock.Proc(Proc);
|
|
END
|
|
END DeclSeq;
|
|
|
|
PROCEDURE Rtl(u: UNIT);
|
|
|
|
PROCEDURE AddProc(name: UTILS.STRING; num: INTEGER);
|
|
VAR id: IDENT;
|
|
BEGIN
|
|
id := GetQIdent(u, SCAN.AddNode(name));
|
|
id.Proc(Proc).used := TRUE;
|
|
IF id = NIL THEN
|
|
UTILS.ErrMsg(158);
|
|
UTILS.HALT(1)
|
|
END;
|
|
X86.AddRtlProc(num, id.Number)
|
|
END AddProc;
|
|
|
|
BEGIN
|
|
AddProc("_newrec", X86._newrec);
|
|
AddProc("_disprec", X86._disprec);
|
|
AddProc("_rset", X86._rset);
|
|
AddProc("_inset", X86._inset);
|
|
AddProc("_saverec", X86._saverec);
|
|
AddProc("_checktype", X86._checktype);
|
|
AddProc("_strcmp", X86._strcmp);
|
|
AddProc("_lstrcmp", X86._lstrcmp);
|
|
AddProc("_rstrcmp", X86._rstrcmp);
|
|
AddProc("_savearr", X86._savearr);
|
|
AddProc("_arrayidx", X86._arrayidx);
|
|
AddProc("_arrayidx1", X86._arrayidx1);
|
|
AddProc("_arrayrot", X86._arrayrot);
|
|
AddProc("_assrt", X86._assrt);
|
|
AddProc("_strcopy", X86._strcopy);
|
|
AddProc("_init", X86._init);
|
|
AddProc("_close", X86._close);
|
|
AddProc("_halt", X86._halt);
|
|
AddProc("_length", X86._length);
|
|
END Rtl;
|
|
|
|
PROCEDURE ImportList;
|
|
VAR cond: INTEGER; coord, namecoord: SCAN.TCoord;
|
|
name, alias: SCAN.NODE; u, self: UNIT;
|
|
FName: UTILS.STRING;
|
|
|
|
PROCEDURE AddUnit(newcond: INTEGER);
|
|
VAR str: STRITEM;
|
|
BEGIN
|
|
u := GetModule(name);
|
|
IF u = NIL THEN
|
|
self := unit;
|
|
SCAN.Backup(unit.scanner);
|
|
COPY(name.Name, FName);
|
|
IF ~((~self.Std & pReadModule(Path, FName, UTILS.Ext)) OR pReadModule(Std, FName, UTILS.Ext)) THEN
|
|
IF FName = "SYSTEM" THEN
|
|
unit := sys;
|
|
self.sys := TRUE
|
|
ELSE
|
|
Assert(FALSE, namecoord, 32)
|
|
END
|
|
END;
|
|
SCAN.Recover(self.scanner);
|
|
u := unit;
|
|
unit := self;
|
|
UTILS.SetFile(unit.File)
|
|
ELSE
|
|
Assert(u.Closed, namecoord, 31)
|
|
END;
|
|
PushIdent(alias, coord, IDMOD, voidtype, u, FALSE, 0);
|
|
NEW(str);
|
|
MemErr(str = NIL);
|
|
str.Str := name.Name;
|
|
UTILS.Push(unit.Import, str);
|
|
cond := newcond
|
|
END AddUnit;
|
|
|
|
BEGIN
|
|
cond := 0;
|
|
WHILE cond # 4 DO
|
|
Next;
|
|
CASE cond OF
|
|
|0: Check(lxIDENT);
|
|
name := SCAN.id;
|
|
Coord(coord);
|
|
Coord(namecoord);
|
|
alias := name;
|
|
cond := 1
|
|
|1: CASE SCAN.tLex OF
|
|
|lxComma: AddUnit(0)
|
|
|lxSemi: AddUnit(4); Next
|
|
|lxAssign: cond := 2
|
|
ELSE
|
|
Assert2(FALSE, 28)
|
|
END
|
|
|2: Check(lxIDENT);
|
|
name := SCAN.id;
|
|
Coord(namecoord);
|
|
cond := 3
|
|
|3: CASE SCAN.tLex OF
|
|
|lxComma: AddUnit(0)
|
|
|lxSemi: AddUnit(4); Next
|
|
ELSE
|
|
Assert2(FALSE, 29)
|
|
END
|
|
ELSE
|
|
END
|
|
END
|
|
END ImportList;
|
|
|
|
PROCEDURE Header(Name: SCAN.NODE);
|
|
BEGIN
|
|
NEW(unit);
|
|
MemErr(unit = NIL);
|
|
unit.Idents := UTILS.CreateList();
|
|
unit.Level := 0;
|
|
unit.Name := Name;
|
|
Guard; Guard;
|
|
PushIdent(unit.Name, zcoord, IDMOD, voidtype, unit, FALSE, 0);
|
|
Guard;
|
|
unit.IdentBegin := unit.Idents.Last(IDENT);
|
|
unit.Closed := TRUE
|
|
END Header;
|
|
|
|
PROCEDURE Pseudo;
|
|
VAR temp: UNIT;
|
|
BEGIN
|
|
temp := unit;
|
|
Header(SCAN.AddNode("SYSTEM"));
|
|
PushSysProc("ADR", sysADR);
|
|
PushSysProc("SIZE", sysSIZE);
|
|
PushSysProc("TYPEID", sysTYPEID);
|
|
PushSysProc("GET", sysGET);
|
|
PushSysProc("PUT", sysPUT);
|
|
PushSysProc("CODE", sysCODE);
|
|
PushSysProc("MOVE", sysMOVE);
|
|
PushSysProc("INF", sysINF);
|
|
PushSysType("CARD16", TCARD16);
|
|
sys := unit;
|
|
unit := temp
|
|
END Pseudo;
|
|
|
|
PROCEDURE ReadModule(Path, Name1, Ext: UTILS.STRING): BOOLEAN;
|
|
VAR FHandle: INTEGER; name, Name, b: UTILS.STRING; idmod: IDENT; Res, temp: BOOLEAN; coord: SCAN.TCoord;
|
|
BEGIN
|
|
Res := FALSE;
|
|
name := Name1;
|
|
Name := Name1;
|
|
b := Path;
|
|
UTILS.concat(b, Name);
|
|
Name := b;
|
|
UTILS.concat(Name, Ext);
|
|
|
|
IF SCAN.Open(Name, FHandle) THEN
|
|
NEW(unit);
|
|
MemErr(unit = NIL);
|
|
unit.sys := FALSE;
|
|
unit.Std := Path = Std;
|
|
UTILS.Push(prog, unit);
|
|
unit.Idents := UTILS.CreateList();
|
|
unit.Import := UTILS.CreateList();
|
|
NEW(unit.scanner);
|
|
MemErr(unit.scanner = NIL);
|
|
unit.Closed := FALSE;
|
|
unit.Level := 0;
|
|
unit.typedecl := FALSE;
|
|
COPY(Name, unit.File);
|
|
UTILS.SetFile(unit.File);
|
|
StIdent;
|
|
NextCheck(lxMODULE);
|
|
NextCheck(lxIDENT);
|
|
Assert2(UTILS.streq(SCAN.id.Name, name), 33);
|
|
unit.Name := SCAN.id;
|
|
coord := SCAN.coord;
|
|
PushIdent(unit.Name, coord, IDMOD, voidtype, unit, FALSE, 0);
|
|
idmod := unit.Idents.Last(IDENT);
|
|
Guard;
|
|
NextCheck(lxSemi);
|
|
Next;
|
|
IF SCAN.tLex = lxIMPORT THEN
|
|
temp := main;
|
|
main := FALSE;
|
|
ImportList;
|
|
main := temp
|
|
END;
|
|
UTILS.OutString("compiling "); UTILS.OutString(unit.Name.Name); UTILS.Ln;
|
|
X86.Module(idmod.Name.Name, idmod.Number);
|
|
UnitNumber := idmod.Number;
|
|
unit.IdentBegin := unit.Idents.Last(IDENT);
|
|
curBlock := idmod;
|
|
DeclSeq;
|
|
X86.ProcBeg(idmod.Number, 0, TRUE);
|
|
IF SCAN.tLex = lxBEGIN THEN
|
|
addproc;
|
|
curproc.used := TRUE;
|
|
Next;
|
|
OpSeq
|
|
END;
|
|
Check(lxEND);
|
|
NextCheck(lxIDENT);
|
|
Assert2(SCAN.id = unit.Name, 26);
|
|
NextCheck(lxDot);
|
|
X86.Leave;
|
|
unit.Closed := TRUE;
|
|
UTILS.Clear(unit.Import);
|
|
Res := TRUE
|
|
END
|
|
RETURN Res
|
|
END ReadModule;
|
|
|
|
PROCEDURE Program*(StdPath, FilePath, NameFile, ExtFile: UTILS.STRING; windows: BOOLEAN;
|
|
OpSeqProc: opPROC; ExprProc: expPROC; AssCompProc: assPROC; VAR stypes: stTYPES);
|
|
BEGIN
|
|
winplatf := windows;
|
|
Path := FilePath;
|
|
Main := NameFile;
|
|
ExtMain := ExtFile;
|
|
Std := StdPath;
|
|
OpSeq := OpSeqProc;
|
|
Expr := ExprProc;
|
|
AssComp := AssCompProc;
|
|
prog := UTILS.CreateList();
|
|
PtrBases := UTILS.CreateList();
|
|
types := UTILS.CreateList();
|
|
procs := UTILS.CreateList();
|
|
StTypes;
|
|
voidtype := sttypes[TVOID];
|
|
Strings := UTILS.CreateList();
|
|
Pseudo;
|
|
stypes := sttypes
|
|
END Program;
|
|
|
|
PROCEDURE delfirstchar(VAR s: UTILS.STRING);
|
|
VAR i: INTEGER;
|
|
BEGIN
|
|
FOR i := 0 TO LENGTH(s) - 1 DO
|
|
s[i] := s[i + 1]
|
|
END
|
|
END delfirstchar;
|
|
|
|
PROCEDURE DelProcs;
|
|
VAR cur: Proc;
|
|
|
|
PROCEDURE ProcHandling(proc: Proc);
|
|
VAR cur: IDENT; p: Proc;
|
|
BEGIN
|
|
proc.used := TRUE;
|
|
cur := proc.Procs.First(IDENT);
|
|
WHILE cur # NIL DO
|
|
p := cur.Proc(Proc);
|
|
IF ~p.used THEN
|
|
ProcHandling(p)
|
|
END;
|
|
cur := cur.Next(IDENT)
|
|
END;
|
|
END ProcHandling;
|
|
|
|
BEGIN
|
|
cur := procs.First(Proc);
|
|
WHILE cur # NIL DO
|
|
IF cur.used THEN
|
|
ProcHandling(cur)
|
|
END;
|
|
cur := cur.Next(Proc)
|
|
END;
|
|
cur := procs.First(Proc);
|
|
WHILE cur # NIL DO
|
|
IF ~cur.used THEN
|
|
X86.DelProc(cur.beg, cur.end)
|
|
END;
|
|
cur := cur.Next(Proc)
|
|
END
|
|
END DelProcs;
|
|
|
|
PROCEDURE Compile*(platform, stksize: INTEGER);
|
|
VAR full, path, name, ext, temp, path2: UTILS.STRING;
|
|
BEGIN
|
|
Platform := platform;
|
|
main := FALSE;
|
|
IF ReadModule(Path, "RTL", UTILS.Ext) OR ReadModule(Std, "RTL", UTILS.Ext) THEN
|
|
Rtl(unit)
|
|
ELSE
|
|
UTILS.ErrMsg(65);
|
|
UTILS.HALT(1)
|
|
END;
|
|
main := TRUE;
|
|
IF ~ReadModule(Path, Main, ExtMain) THEN
|
|
path2 := Path;
|
|
UTILS.ParamStr(full, 0);
|
|
UTILS.Split(full, path, name, ext);
|
|
IF path[0] # 0X THEN
|
|
path[LENGTH(path) - 1] := 0X
|
|
END;
|
|
IF Path[0] = UTILS.Slash THEN
|
|
delfirstchar(Path)
|
|
END;
|
|
UTILS.concat(path, UTILS.Slash);
|
|
full := path;
|
|
UTILS.concat(full, Path);
|
|
Path := full;
|
|
IF (UTILS.OS = "WIN") & (Path[0] = UTILS.Slash) THEN
|
|
delfirstchar(Path)
|
|
END;
|
|
IF ~ReadModule(Path, Main, ExtMain) THEN
|
|
UTILS.ErrMsg(64);
|
|
UTILS.OutString(path2);
|
|
UTILS.OutString(Main);
|
|
UTILS.OutString(ExtMain);
|
|
UTILS.Ln;
|
|
UTILS.HALT(1)
|
|
END
|
|
END;
|
|
temp := Path;
|
|
UTILS.concat(temp, Main);
|
|
IF platform IN {2, 3} THEN
|
|
UTILS.concat(temp, ".exe")
|
|
ELSIF platform = 1 THEN
|
|
UTILS.concat(temp, ".dll")
|
|
ELSIF platform = 4 THEN
|
|
UTILS.concat(temp, ".kex")
|
|
ELSIF platform = 6 THEN
|
|
UTILS.concat(temp, ".obj")
|
|
END;
|
|
IF platform IN {1, 2, 3, 4} THEN
|
|
stksize := stksize * 100000H
|
|
END;
|
|
DelProcs;
|
|
X86.Epilog(ProgSize, temp, stksize)
|
|
END Compile;
|
|
|
|
BEGIN
|
|
pParseType := ParseType;
|
|
pReadModule := ReadModule;
|
|
zcoord.line := 0;
|
|
zcoord.col := 0
|
|
END DECL. |