Aren/kolibrios
1
0
Fork 0
mirror of https://github.com/KolibriOS/kolibrios.git synced 2024-12-24 23:56:49 +03:00
Code Issues Packages Projects Releases Wiki Activity
ba50660e2b
kolibrios/programs/develop/oberon07/Source/DECL.ob07
Kirill Lipatov (Leency) 31a4eb5247 upload oberon07 by akron1, add to ISO 
git-svn-id: svn://kolibrios.org@6613 a494cfbc-eb01-0410-851d-a64ba20cac60
2016-10-23 23:30:27 +00:00

1618 lines
41 KiB
Plaintext
Raw Blame History

(*
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.
Reference in New Issue View Git Blame Copy Permalink