0,0 → 1,1618 |
(* |
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. |