Subversion Repositories Kolibri OS

Compare Revisions

Regard whitespace Rev 6612 → Rev 6613

/programs/develop/oberon07/Source/Compiler.ob07
0,0 → 1,1901
(*
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 Compiler;
 
IMPORT DECL, SCAN, UTILS, X86, SYSTEM;
 
CONST
 
Slash = UTILS.Slash;
 
lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
 
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
 
TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7;
TNIL = 8; TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14;
 
TNUM = {TINTEGER, TREAL, TLONGREAL};
TFLOAT = {TREAL, TLONGREAL};
TOBJECT = {TRECORD, TPOINTER};
TSTRUCT = {TARRAY, TRECORD};
 
eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6;
 
IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9;
 
stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8;
stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15;
stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
stBITS = 23; stLSR = 24; stLENGTH = 25;
 
sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
sysCODE = 106; sysTYPEID = 107; sysMOVE = 108;
 
TYPE
 
LABEL = POINTER TO RECORD (UTILS.rITEM)
a, b: INTEGER
END;
 
VAR
 
pExpr, pFactor: PROCEDURE (VAR e: DECL.EXPRESSION);
pOpSeq: PROCEDURE;
sttypes: DECL.stTYPES;
voidtype, inttype, booltype, strtype, settype, realtype, longrealtype, chartype, niltype: DECL.pTYPE;
 
PROCEDURE Load(e: DECL.EXPRESSION);
BEGIN
IF e.eType = eVAR THEN
X86.Load(e.T.tType)
END
END Load;
 
PROCEDURE LenString(adr: LONGREAL): INTEGER;
VAR s: UTILS.STRCONST;
BEGIN
s := DECL.GetString(adr)
RETURN s.Len
END LenString;
 
PROCEDURE Assert(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, coord, code)
END
END Assert;
 
PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
BEGIN
IF ~cond THEN
DECL.Assert(FALSE, SCAN.coord, code)
END
END Assert2;
 
PROCEDURE IntType(T: DECL.pTYPE; coord: SCAN.TCoord);
BEGIN
Assert(T.tType = TINTEGER, coord, 52)
END IntType;
 
PROCEDURE Next;
BEGIN
DECL.Next
END Next;
 
PROCEDURE Coord(VAR coord: SCAN.TCoord);
BEGIN
coord := SCAN.coord
END Coord;
 
PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
BEGIN
DECL.Next;
coord := SCAN.coord
END NextCoord;
 
PROCEDURE Check(key: INTEGER);
BEGIN
DECL.Check(key)
END Check;
 
PROCEDURE NextCheck(key: INTEGER);
BEGIN
DECL.Next;
DECL.Check(key)
END NextCheck;
 
PROCEDURE BaseOf(T0, T1: DECL.pTYPE): BOOLEAN;
BEGIN
IF (T0.tType = T1.tType) & (T0.tType IN TOBJECT) THEN
IF T0.tType = TPOINTER THEN
T0 := T0.Base;
T1 := T1.Base
END;
WHILE (T1 # NIL) & (T1 # T0) DO
T1 := T1.Base
END
END
RETURN T0 = T1
END BaseOf;
 
PROCEDURE Designator(VAR e: DECL.EXPRESSION);
VAR id, id2: DECL.IDENT; name: SCAN.NODE; e1: DECL.EXPRESSION;
coord: SCAN.TCoord; i, n, bases, glob, loc, idx: INTEGER;
imp, break, guard: BOOLEAN; f: DECL.FIELD;
T, BaseT: DECL.pTYPE; s: UTILS.STRCONST;
 
PROCEDURE LoadVar;
BEGIN
IF glob # -1 THEN
X86.GlobalAdr(glob);
glob := -1
ELSIF loc # -1 THEN
X86.LocalAdr(loc, bases);
loc := -1
END
END LoadVar;
 
BEGIN
glob := -1;
loc := -1;
Coord(coord);
Check(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
IF (id # NIL) & (id.iType = IDMOD) THEN
NextCheck(lxDot);
NextCheck(lxIDENT);
Coord(coord);
name := SCAN.id;
imp := id.Unit # DECL.unit;
id := DECL.GetQIdent(id.Unit, name)
END;
Assert(id # NIL, coord, 42);
e.vparam := FALSE;
e.deref := FALSE;
e.id := id;
Next;
CASE id.iType OF
|IDVAR:
e.eType := eVAR;
e.T := id.T;
IF id.VarKind = 0 THEN
e.Read := imp
ELSE
e.Read := (id.VarKind = DECL.param) & (id.T.tType IN TSTRUCT);
e.vparam := id.VarKind = DECL.paramvar
END;
bases := DECL.unit.Level - id.Level;
IF id.Level = 3 THEN
glob := id.Offset
ELSIF (id.VarKind = 0) OR (id.VarKind = DECL.param) & ~(id.T.tType IN TSTRUCT) THEN
loc := id.Offset
ELSIF (id.VarKind = DECL.paramvar) OR (id.T.tType IN TSTRUCT) THEN
IF DECL.Dim(e.T) > 0 THEN
n := DECL.Dim(e.T);
FOR i := n TO 1 BY -1 DO
X86.LocalAdr(id.Offset + i * 4, bases);
X86.Load(TINTEGER)
END
END;
X86.LocalAdr(id.Offset, bases);
X86.Load(TINTEGER)
END
|IDCONST:
Assert(id.T # NIL, coord, 75);
e.eType := eCONST;
e.T := id.T;
e.Value := id.Value;
IF id.T.tType IN {TINTEGER, TSET, TBOOLEAN} THEN
X86.PushConst(FLOOR(e.Value))
ELSIF id.T.tType IN TFLOAT THEN
X86.PushFlt(e.Value)
ELSIF id.T.tType = TSTRING THEN
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
END
|IDPROC:
e.eType := ePROC;
NEW(id2);
UTILS.MemErr(id2 = NIL);
id2^ := id^;
UTILS.Push(DECL.curproc.Procs, id2);
e.T := voidtype
|IDTYPE:
Assert(FALSE, coord, 101)
|IDSTPROC:
e.eType := eSTPROC;
e.T := voidtype
|IDSYSPROC:
e.eType := eSYSPROC;
e.T := voidtype
ELSE
END;
break := FALSE;
guard := FALSE;
REPEAT
CASE SCAN.tLex OF
|lxDot:
e.deref := FALSE;
Assert2(e.T.tType IN TOBJECT, 105);
IF e.T.tType = TPOINTER THEN
e.Read := FALSE;
LoadVar;
e.T := e.T.Base;
X86.Load(TINTEGER);
IF ~guard THEN
X86.CheckNIL
END
END;
NextCheck(lxIDENT);
Coord(coord);
name := SCAN.id;
T := e.T;
REPEAT
f := DECL.GetField(T, name);
T := T.Base
UNTIL (f # NIL) OR (T = NIL);
Assert(f # NIL, coord, 99);
IF f.Unit # DECL.unit THEN
Assert(f.Export, coord, 99)
END;
IF glob # -1 THEN
glob := glob + f.Offset
ELSIF loc # -1 THEN
loc := loc + f.Offset
ELSE
X86.Field(f.Offset)
END;
e.T := f.T;
e.vparam := FALSE;
guard := FALSE;
Next
|lxLSquare:
LoadVar;
REPEAT
Assert2(e.T.tType = TARRAY, 102);
NextCoord(coord);
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e.T.Len = 0 THEN
BaseT := DECL.OpenBase(e.T);
X86.PushConst(BaseT.Size);
X86.OpenIdx(DECL.Dim(e.T))
ELSE
IF e1.eType = eCONST THEN
idx := FLOOR(e1.Value);
Assert((idx >= 0) & (idx < e.T.Len), coord, 159);
IF e.T.Base.Size # 1 THEN
X86.Drop;
X86.PushConst(e.T.Base.Size * idx)
END;
X86.Idx
ELSE
X86.FixIdx(e.T.Len, e.T.Base.Size)
END
END;
e.T := e.T.Base
UNTIL SCAN.tLex # lxComma;
Check(lxRSquare);
e.vparam := FALSE;
guard := FALSE;
Next
|lxCaret:
LoadVar;
Assert2(e.T.tType = TPOINTER, 104);
e.Read := FALSE;
X86.Load(TINTEGER);
IF ~guard THEN
X86.CheckNIL
END;
e.T := e.T.Base;
e.vparam := FALSE;
e.deref := TRUE;
guard := FALSE;
Next
|lxLRound:
LoadVar;
IF e.T.tType IN TOBJECT THEN
IF e.T.tType = TRECORD THEN
Assert2(e.vparam, 108)
END;
NextCheck(lxIDENT);
Coord(coord);
T := DECL.IdType(coord);
Assert(T # NIL, coord, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord, 106)
ELSE
Assert(T.tType = TPOINTER, coord, 107)
END;
Assert(BaseOf(e.T, T), coord, 108);
e.T := T;
Check(lxRRound);
Next;
IF e.T.tType = TPOINTER THEN
IF (SCAN.tLex = lxDot) OR (SCAN.tLex = lxCaret) THEN
X86.DupLoadCheck
ELSE
X86.DupLoad
END;
guard := TRUE;
T := T.Base
ELSE
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
X86.Guard(T.Number, FALSE)
ELSE
break := TRUE
END
ELSE
break := TRUE
END
UNTIL break;
LoadVar
END Designator;
 
PROCEDURE Set(VAR e: DECL.EXPRESSION);
VAR a, b: DECL.EXPRESSION; coord: SCAN.TCoord; fpu: INTEGER; s: SET; flag: BOOLEAN;
beg: X86.ASMLINE;
BEGIN
Next;
e.eType := eEXP;
e.T := settype;
e.Value := 0.0D0;
e.vparam := FALSE;
s := {};
flag := TRUE;
fpu := X86.fpu;
beg := X86.current;
X86.PushConst(0);
WHILE SCAN.tLex # lxRCurly DO
Coord(coord);
pExpr(a);
IntType(a.T, coord);
IF a.eType = eCONST THEN
Assert(ASR(FLOOR(a.Value), 5) = 0, coord, 53)
END;
Load(a);
b := a;
IF SCAN.tLex = lxDbl THEN
NextCoord(coord);
pExpr(b);
IntType(b.T, coord);
IF b.eType = eCONST THEN
Assert(ASR(FLOOR(b.Value), 5) = 0, coord, 53);
Assert(a.Value <= b.Value, coord, 54)
END;
Load(b)
ELSE
X86.Dup
END;
X86.rset;
X86.Set(lxPlus);
flag := (a.eType = eCONST) & (b.eType = eCONST) & flag;
IF flag THEN
s := s + {FLOOR(a.Value) .. FLOOR(b.Value)}
END;
IF SCAN.tLex = lxComma THEN
Next;
Assert2(SCAN.tLex # lxRCurly, 36)
ELSE
Check(lxRCurly)
END
END;
IF flag THEN
e.Value := LONG(FLT(ORD(s)));
e.eType := eCONST;
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
X86.PushConst(ORD(s))
END
END;
Next
END Set;
 
PROCEDURE IsString(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) OR (a.T.tType = TARRAY) & (a.T.Base.tType = TCHAR)
END IsString;
 
PROCEDURE Str(e: DECL.EXPRESSION);
VAR A: X86.TIDX;
BEGIN
IF (e.T.tType = TARRAY) & (e.T.Base.tType = TCHAR) & (e.T.Len # 0) THEN
A[0] := e.T.Len;
X86.OpenArray(A, 1)
ELSIF e.T.tType = TSTRING THEN
A[0] := LenString(e.Value) + 1;
IF A[0] # 2 THEN
X86.OpenArray(A, 1)
END
END
END Str;
 
PROCEDURE StFunc(VAR e: DECL.EXPRESSION; func: INTEGER);
VAR coord, coord2: SCAN.TCoord; a, b, p: INTEGER; e1, e2: DECL.EXPRESSION;
T: DECL.pTYPE; str, str2: UTILS.STRCONST;
BEGIN
e.vparam := FALSE;
e.eType := eEXP;
Coord(coord2);
Check(lxLRound);
NextCoord(coord);
CASE func OF
|stABS:
pExpr(e1);
Assert(e1.T.tType IN TNUM, coord, 57);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := ABS(e1.Value);
e.eType := eCONST;
Assert(~((e1.T.tType = TINTEGER) & (e1.Value = LONG(FLT(SCAN.minINT)))), coord, DECL.IOVER)
END;
IF e1.T.tType = TINTEGER THEN
X86.StFunc(X86.stABS)
ELSE
X86.StFunc(X86.stFABS)
END;
e.T := e1.T
|stODD:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := LONG(FLT(ORD(ODD(FLOOR(e1.Value)))));
e.eType := eCONST
END;
X86.StFunc(X86.stODD);
e.T := booltype
|stLEN:
Designator(e1);
Assert((e1.eType = eVAR) & (e1.T.tType = TARRAY), coord, 102);
IF e1.T.Len > 0 THEN
X86.Len(-e1.T.Len)
ELSE
X86.Len(DECL.Dim(e1.T))
END;
e.T := inttype
|stLSL, stASR, stROR, stLSR:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
pExpr(e2);
IntType(e2.T, coord);
Load(e2);
IF (e1.eType = eCONST) & (e2.eType = eCONST) THEN
a := FLOOR(e1.Value);
b := FLOOR(e2.Value);
CASE func OF
|stLSL: a := LSL(a, b)
|stASR: a := ASR(a, b)
|stROR: a := ROR(a, b)
|stLSR: a := LSR(a, b)
ELSE
END;
e.Value := LONG(FLT(a));
e.eType := eCONST
END;
CASE func OF
|stLSL: X86.StFunc(X86.stLSL)
|stASR: X86.StFunc(X86.stASR)
|stROR: X86.StFunc(X86.stROR)
|stLSR: X86.StFunc(X86.stLSR)
ELSE
END;
e.T := inttype
|stFLOOR:
pExpr(e1);
Assert(e1.T.tType IN TFLOAT, coord, 66);
Load(e1);
IF e1.eType = eCONST THEN
Assert((e1.Value - 1.0D0 < LONG(FLT(SCAN.maxINT))) & (e1.Value >= LONG(FLT(SCAN.minINT))), coord, 74);
e.Value := LONG(FLT(FLOOR(e1.Value)));
e.eType := eCONST
END;
X86.StFunc(X86.stFLOOR);
e.T := inttype
|stFLT:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
X86.StFunc(X86.stFLT);
e.T := realtype
|stORD:
pExpr(e1);
Assert(e1.T.tType IN {TCHAR, TBOOLEAN, TSET, TSTRING}, coord, 68);
IF e1.T.tType = TSTRING THEN
Assert(LenString(e1.Value) = 1, coord, 94)
END;
Load(e1);
IF e1.eType = eCONST THEN
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
e.Value := LONG(FLT(ORD(str.Str[0])))
ELSE
e.Value := e1.Value
END;
e.eType := eCONST
END;
IF e1.T.tType = TBOOLEAN THEN
X86.StFunc(X86.stORD)
END;
e.T := inttype
|stBITS:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
e.T := settype
|stCHR:
pExpr(e1);
IntType(e1.T, coord);
Load(e1);
e.T := chartype;
IF e1.eType = eCONST THEN
Assert(ASR(FLOOR(e1.Value), 8) = 0, coord, 76);
str2 := DECL.AddMono(CHR(FLOOR(e1.Value)));
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
e.T := strtype;
e.eType := eCONST
END
|stLONG:
pExpr(e1);
Assert(e1.T.tType = TREAL, coord, 71);
IF e1.eType = eCONST THEN
e.Value := e1.Value;
e.eType := eCONST
END;
Load(e1);
e.T := longrealtype
|stSHORT:
pExpr(e1);
Assert(e1.T.tType = TLONGREAL, coord, 70);
IF e1.eType = eCONST THEN
Assert(ABS(e1.Value) <= LONG(SCAN.maxREAL), coord, DECL.FOVER);
Assert(ABS(e1.Value) >= LONG(SCAN.minREAL), coord, DECL.UNDER);
e.Value := e1.Value;
e.eType := eCONST
END;
Load(e1);
e.T := realtype
|stLENGTH:
pExpr(e1);
Assert(IsString(e1), coord, 141);
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Mono(str.Number);
X86.StrMono
END;
e.Value := LONG(FLT(LENGTH(str.Str)));
e.eType := eCONST
END;
Str(e1);
e.T := inttype;
X86.StFunc(X86.stLENGTH)
|sysADR:
Assert((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxSTRING) OR (SCAN.tLex = lxCHX), coord, 43);
IF SCAN.tLex = lxIDENT THEN
Designator(e1);
Assert((e1.eType = eVAR) OR (e1.eType = ePROC) OR (e1.T = strtype), coord, 43);
IF e1.eType = ePROC THEN
X86.PushInt(e1.id.Number)
END
ELSE
pFactor(e1)
END;
IF e1.T = strtype THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Drop;
X86.PushInt(str.Number)
END
END;
e.T := inttype;
X86.ADR(DECL.Dim(e1.T))
|sysSIZE, sysTYPEID, sysINF:
DECL.SetSizeFunc;
Check(lxIDENT);
T := DECL.IdType(coord);
Assert(T # NIL, coord, 42);
e.eType := eCONST;
IF func = sysTYPEID THEN
e.T := inttype;
Assert(T.tType IN TOBJECT, coord, 47);
IF T.tType = TPOINTER THEN
T := T.Base
END;
e.Value := LONG(FLT(T.Number));
X86.PushConst(T.Number)
ELSIF func = sysSIZE THEN
e.T := inttype;
e.Value := LONG(FLT(T.Size));
X86.PushConst(T.Size)
ELSIF func = sysINF THEN
Assert(T.tType IN TFLOAT, coord, 91);
e.T := T;
e.Value := SYSTEM.INF(LONGREAL);
X86.PushFlt(e.Value)
END
ELSE
Assert(FALSE, coord2, 73)
END;
Check(lxRRound);
Next
END StFunc;
 
PROCEDURE ProcTypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR sp: INTEGER; stk: ARRAY 100, 2 OF DECL.pTYPE;
 
PROCEDURE ProcTypeComp1(T1, T2: DECL.pTYPE): BOOLEAN;
VAR fp, ft: DECL.FIELD; Res: BOOLEAN;
 
PROCEDURE TypeComp(T1, T2: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (T1.tType = TARRAY) & (T2.tType = TARRAY) & (T1.Len = 0) & (T2.Len = 0) THEN
Res := TypeComp(T1.Base, T2.Base)
ELSE
Res := ProcTypeComp1(T1, T2)
END
RETURN Res
END TypeComp;
 
PROCEDURE Check(): BOOLEAN;
VAR i: INTEGER; res: BOOLEAN;
BEGIN
i := 0;
res := FALSE;
WHILE (i < sp) & ~res DO
res := ((stk[i][0] = T1) & (stk[i][1] = T2)) OR ((stk[i][0] = T2) & (stk[i][1] = T1));
INC(i)
END
RETURN res
END Check;
 
BEGIN
INC(sp);
stk[sp][0] := T1;
stk[sp][1] := T2;
IF Check() THEN
Res := TRUE
ELSE
IF (T1.tType = TPROC) & (T2.tType = TPROC) & (T1 # T2) THEN
Res := (T1.Call = T2.Call) & (T1.Fields.Count = T2.Fields.Count) & ProcTypeComp1(T1.Base, T2.Base);
fp := T1.Fields.First(DECL.FIELD);
ft := T2.Fields.First(DECL.FIELD);
WHILE Res & (fp # NIL) DO
Res := (fp.ByRef = ft.ByRef) & TypeComp(fp.T, ft.T);
fp := fp.Next(DECL.FIELD);
ft := ft.Next(DECL.FIELD)
END
ELSE
Res := T1 = T2
END
END;
DEC(sp)
RETURN Res
END ProcTypeComp1;
 
BEGIN
sp := -1
RETURN ProcTypeComp1(T1, T2)
END ProcTypeComp;
 
PROCEDURE ArrComp(Ta, Tf: DECL.pTYPE): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF (Tf.tType = TARRAY) & (Tf.Len = 0) & (Ta.tType = TARRAY) THEN
Res := ArrComp(Ta.Base, Tf.Base)
ELSE
Res := ProcTypeComp(Ta, Tf)
END
RETURN Res
END ArrComp;
 
PROCEDURE AssComp(e: DECL.EXPRESSION; T: DECL.pTYPE; param: BOOLEAN): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TSET, TBOOLEAN, TCARD16:
Res := e.T = T
|TCHAR:
IF e.T.tType = TSTRING THEN
Res := LenString(e.Value) = 1
ELSE
Res := e.T.tType = TCHAR
END
|TARRAY:
IF param THEN
IF T.Len = 0 THEN
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := TRUE
ELSE
Res := ArrComp(e.T, T)
END
ELSE
IF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len
ELSE
Res := e.T = T
END
END
ELSE
IF T.Len = 0 THEN
Res := FALSE
ELSIF (T.Base.tType = TCHAR) & (e.T.tType = TSTRING) THEN
Res := LenString(e.Value) <= T.Len
ELSE
Res := e.T = T
END
END
|TRECORD: Res := BaseOf(T, e.T)
|TPOINTER: Res := BaseOf(T, e.T) OR (e.T.tType = TNIL)
|TPROC: Res := (e.T.tType = TNIL) OR (e.eType = ePROC) & ProcTypeComp(e.id.T, T) OR
(e.eType # ePROC) & ProcTypeComp(e.T, T)
ELSE
Res := FALSE
END
RETURN Res
END AssComp;
 
PROCEDURE ParamComp(e: DECL.EXPRESSION; T: DECL.pTYPE; ByRef: BOOLEAN): BOOLEAN;
VAR Res: BOOLEAN;
BEGIN
IF ByRef THEN
IF e.eType = eVAR THEN
CASE T.tType OF
|TINTEGER, TREAL, TLONGREAL, TCHAR,
TSET, TBOOLEAN, TPOINTER, TCARD16:
Res := e.T = T
|TARRAY:
IF T.Len > 0 THEN
Res := e.T = T
ELSE
Res := ArrComp(e.T, T)
END
|TRECORD:
Res := BaseOf(T, e.T)
|TPROC:
Res := ProcTypeComp(e.T, T)
ELSE
END
ELSE
Res := FALSE
END
ELSE
Res := AssComp(e, T, TRUE)
END
RETURN Res
END ParamComp;
 
PROCEDURE Call(param: DECL.FIELD);
VAR coord: SCAN.TCoord; i, n: INTEGER; e1: DECL.EXPRESSION; s: UTILS.STRCONST; A: X86.TIDX; TA: DECL.pTYPE;
BEGIN
WHILE param # NIL DO
Coord(coord);
X86.Param;
pExpr(e1);
Assert(ParamComp(e1, param.T, param.ByRef), coord, 114);
Assert(~(param.ByRef & e1.Read), coord, 115);
Assert(~((e1.eType = ePROC) & (e1.id.Level > 3)), coord, 116);
IF (e1.eType = eVAR) & ~param.ByRef THEN
X86.Load(e1.T.tType)
END;
IF param.ByRef & (e1.T.tType = TRECORD) THEN
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(0)
ELSE
X86.PushConst(e1.T.Number)
END
END;
IF ~param.ByRef & (param.T.tType IN TFLOAT) THEN
X86.DropFpu(param.T.tType = TLONGREAL)
END;
IF (e1.T.tType = TSTRING) & (param.T.tType = TARRAY) THEN
s := DECL.GetString(e1.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
END;
IF param.T.Len = 0 THEN
A[0] := s.Len + 1;
X86.OpenArray(A, 1)
END
END;
IF (e1.T.tType = TARRAY) & (DECL.Dim(param.T) > DECL.Dim(e1.T)) THEN
n := DECL.Dim(param.T) - DECL.Dim(e1.T);
TA := DECL.OpenBase(e1.T);
FOR i := 0 TO n - 1 DO
A[i] := TA.Len;
TA := TA.Base
END;
IF DECL.Dim(e1.T) = 0 THEN
X86.OpenArray(A, n)
ELSE
X86.ExtArray(A, n, DECL.Dim(e1.T))
END
END;
param := param.Next(DECL.FIELD);
IF param # NIL THEN
Check(lxComma);
Next
END
END;
Check(lxRRound);
Next
END Call;
 
PROCEDURE Factor(VAR e: DECL.EXPRESSION);
VAR coord: SCAN.TCoord; ccall, p: INTEGER; begcall: X86.ASMLINE; s, str2: UTILS.STRCONST;
BEGIN
e.eType := eCONST;
e.vparam := FALSE;
CASE SCAN.tLex OF
|lxIDENT:
begcall := X86.current;
Designator(e);
IF e.eType = ePROC THEN
IF SCAN.tLex = lxLRound THEN
Assert2(e.id.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.id.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
e.T := e.id.T.Base;
IF e.id.Level = 3 THEN
ccall := 0
ELSIF e.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
X86.Call(e.id.Number, TRUE, e.T.tType IN TFLOAT, e.id.T.Call, ccall, e.id.Level - 3,
DECL.curBlock.Level - 3, e.id.ParamSize, DECL.curBlock.LocalSize)
ELSE
X86.PushInt(e.id.Number)
END
ELSIF (e.eType = eVAR) & (e.T.tType = TPROC) & (SCAN.tLex = lxLRound) THEN
Assert2(e.T.Base.tType # TVOID, 73);
Next;
X86.PushCall(begcall);
Call(e.T.Fields.First(DECL.FIELD));
X86.EndCall;
e.eType := eEXP;
X86.CallVar(TRUE, e.T.Base.tType IN TFLOAT, e.T.Call, e.T.Len, DECL.curBlock.LocalSize);
e.T := e.T.Base;
ELSIF e.eType IN {eSTPROC, eSYSPROC} THEN
StFunc(e, e.id.StProc)
END
|lxNIL:
e.T := niltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxTRUE:
e.T := booltype;
e.Value := 1.0D0;
X86.PushConst(1);
Next
|lxFALSE:
e.T := booltype;
e.Value := 0.0D0;
X86.PushConst(0);
Next
|lxCHX, lxSTRING:
IF SCAN.tLex = lxSTRING THEN
str2 := DECL.AddString(SCAN.Lex);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
str2 := DECL.AddMono(SCAN.vCHX);
SYSTEM.GET(SYSTEM.ADR(str2), p);
e.Value := LONG(FLT(p));
X86.PushConst(ORD(SCAN.vCHX))
END;
e.T := strtype;
Next
|lxREAL:
e.T := realtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxLONGREAL:
e.T := longrealtype;
e.Value := SCAN.vFLT;
X86.PushFlt(SCAN.vFLT);
Next
|lxINT, lxHEX:
e.T := inttype;
e.Value := LONG(FLT(SCAN.vINT));
X86.PushConst(SCAN.vINT);
Next
|lxLRound:
Next;
pExpr(e);
Check(lxRRound);
Next
|lxNot:
NextCoord(coord);
Factor(e);
Assert(e.T.tType = TBOOLEAN, coord, 37);
Load(e);
IF e.eType = eCONST THEN
e.Value := LONG(FLT(ORD(e.Value = 0.0D0)))
ELSE
e.eType := eEXP
END;
X86.Not;
e.vparam := FALSE
|lxLCurly:
Set(e)
ELSE
Assert2(FALSE, 36)
END
END Factor;
 
PROCEDURE IsChr(a: DECL.EXPRESSION): BOOLEAN;
RETURN (a.T.tType = TSTRING) & (LenString(a.Value) = 1) OR (a.T.tType = TCHAR)
END IsChr;
 
PROCEDURE StrRel(a, b: DECL.EXPRESSION; Op: INTEGER);
BEGIN
IF ~(IsChr(a) OR IsChr(b)) THEN
X86.strcmp(Op, 0)
ELSIF IsChr(a) & IsChr(b) THEN
X86.CmpInt(Op)
ELSIF IsChr(a) THEN
X86.strcmp(Op, 1)
ELSE
X86.strcmp(Op, -1)
END
END StrRel;
 
PROCEDURE log2(n: INTEGER): INTEGER;
VAR x, i: INTEGER;
BEGIN
x := 1;
i := 0;
WHILE (x # n) & (i < 31) DO
x := LSL(x, 1);
INC(i)
END;
IF x # n THEN
i := -1
END
RETURN i
END log2;
 
PROCEDURE Operation(VAR a, b: DECL.EXPRESSION; Op: INTEGER; coord: SCAN.TCoord);
VAR n, m: INTEGER;
BEGIN
CASE Op OF
|lxPlus, lxMinus, lxMult, lxSlash:
Assert((a.T.tType IN (TNUM + {TSET})) & (a.T.tType = b.T.tType), coord, 37);
Assert(~((Op = lxSlash) & (a.T.tType = TINTEGER)), coord, 37);
CASE a.T.tType OF
|TINTEGER: X86.Int(Op)
|TSET: X86.Set(Op)
|TREAL, TLONGREAL: X86.farith(Op)
ELSE
END
|lxDIV, lxMOD:
Assert((a.T.tType = TINTEGER) & (b.T.tType = TINTEGER), coord, 37);
IF b.eType = eCONST THEN
m := FLOOR(b.Value);
Assert(m # 0, coord, 48);
n := log2(m);
IF n = -1 THEN
X86.idivmod(Op = lxMOD)
ELSE
X86.Drop;
IF Op = lxMOD THEN
n := ORD(-BITS(LSL(-1, n)));
X86.PushConst(n);
X86.Set(lxMult)
ELSE
X86.PushConst(n);
X86.StFunc(X86.stASR)
END
END
ELSE
X86.idivmod(Op = lxMOD)
END
|lxAnd, lxOR:
Assert((a.T.tType = TBOOLEAN) & (b.T.tType = TBOOLEAN), coord, 37)
|lxIN:
Assert((a.T.tType = TINTEGER) & (b.T.tType = TSET), coord, 37);
X86.inset
|lxLT, lxLE, lxGT, lxGE:
Assert(((a.T.tType IN TNUM) & (a.T.tType = b.T.tType)) OR
(IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR
(a.T.tType = TSET) & (b.T.tType = TSET) & ((Op = lxLE) OR (Op = lxGE)), coord, 37);
IF a.T.tType IN TFLOAT THEN
X86.fcmp(Op)
ELSIF a.T.tType = TSET THEN
X86.Inclusion(Op)
ELSIF IsString(a) OR IsString(b) THEN
StrRel(a, b, Op)
ELSE
X86.CmpInt(Op)
END
|lxEQ, lxNE:
Assert(((a.T.tType IN (TNUM + {TSET, TBOOLEAN})) & (a.T.tType = b.T.tType)) OR
(IsChr(a) OR IsString(a)) & (IsChr(b) OR IsString(b)) OR
(a.T.tType IN {TPOINTER, TPROC, TNIL}) & (b.T.tType = TNIL) OR
(b.T.tType IN {TPOINTER, TPROC, TNIL}) & (a.T.tType = TNIL) OR
(a.T.tType = TPOINTER) & (b.T.tType = TPOINTER) & (BaseOf(a.T, b.T) OR BaseOf(b.T, a.T)) OR
(a.T.tType = TPROC) & ProcTypeComp(b.T, a.T) OR (a.eType = ePROC) & ProcTypeComp(b.T, a.id.T) OR
(b.eType = ePROC) & ProcTypeComp(a.T, b.id.T), coord, 37);
IF a.T.tType IN TFLOAT THEN
X86.fcmp(Op)
ELSIF IsString(a) OR IsString(b) THEN
StrRel(a, b, Op)
ELSE
X86.CmpInt(Op)
END
ELSE
END;
IF (a.eType # eCONST) OR (b.eType # eCONST) THEN
a.eType := eEXP;
IF DECL.Relation(Op) THEN
a.T := booltype
END
ELSE
DECL.Calc(a.Value, b.Value, a.T, b.T, Op, coord, a.Value, a.T)
END;
a.vparam := FALSE
END Operation;
 
PROCEDURE Term(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, L: INTEGER; coord: SCAN.TCoord;
BEGIN
Factor(e);
WHILE (SCAN.tLex = lxMult) OR (SCAN.tLex = lxSlash) OR
(SCAN.tLex = lxDIV) OR (SCAN.tLex = lxMOD) OR
(SCAN.tLex = lxAnd) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxAnd THEN
L := X86.NewLabel();
X86.IfWhile(L, FALSE)
END;
Factor(a);
Load(a);
IF Op = lxAnd THEN
X86.Label(L)
END;
Operation(e, a, Op, coord)
END
END Term;
 
PROCEDURE Simple(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; Op, uOp, L: INTEGER; coord, ucoord: SCAN.TCoord;
BEGIN
uOp := 0;
IF (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) THEN
Coord(ucoord);
uOp := SCAN.tLex;
Next
END;
Term(e);
IF uOp # 0 THEN
Assert(e.T.tType IN (TNUM + {TSET}), ucoord, 37);
Load(e);
IF uOp = lxMinus THEN
CASE e.T.tType OF
|TINTEGER: X86.NegInt
|TSET: X86.NegSet
|TREAL, TLONGREAL: X86.fneg
ELSE
END
END;
IF (uOp = lxMinus) & (e.eType = eCONST) THEN
CASE e.T.tType OF
|TINTEGER:
Assert(e.Value # LONG(FLT(SCAN.minINT)), ucoord, DECL.IOVER)
|TSET:
e.Value := -LONG(FLT(ORD(-BITS(FLOOR(e.Value)))))
ELSE
END;
e.Value := -e.Value
END;
IF e.eType # eCONST THEN
e.eType := eEXP
END;
e.vparam := FALSE
END;
WHILE (SCAN.tLex = lxPlus) OR (SCAN.tLex = lxMinus) OR (SCAN.tLex = lxOR) DO
Load(e);
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxOR THEN
L := X86.NewLabel();
X86.IfWhile(L, TRUE)
END;
Term(a);
Load(a);
IF Op = lxOR THEN
X86.Label(L)
END;
Operation(e, a, Op, coord)
END
END Simple;
 
PROCEDURE Expr(VAR e: DECL.EXPRESSION);
VAR a: DECL.EXPRESSION; coord, coord2: SCAN.TCoord; Op, fpu: INTEGER; T: DECL.pTYPE; beg: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
fpu := X86.fpu;
beg := X86.current;
Simple(e);
IF DECL.Relation(SCAN.tLex) THEN
Coord(coord);
Op := SCAN.tLex;
Next;
IF Op = lxIS THEN
Assert(e.T.tType IN TOBJECT, coord, 37);
IF e.T.tType = TRECORD THEN
Assert(e.vparam, coord, 37)
END;
Check(lxIDENT);
Coord(coord2);
T := DECL.IdType(coord2);
Assert(T # NIL, coord2, 42);
IF e.T.tType = TRECORD THEN
Assert(T.tType = TRECORD, coord2, 106)
ELSE
Assert(T.tType = TPOINTER, coord2, 107)
END;
Assert(BaseOf(e.T, T), coord, 37);
IF e.T.tType = TRECORD THEN
X86.Drop;
X86.LocalAdr(e.id.Offset, DECL.unit.Level - e.id.Level)
END;
Load(e);
IF e.T.tType = TPOINTER THEN
T := T.Base
END;
X86.Guard(T.Number, TRUE);
e.T := booltype;
e.eType := eEXP;
e.vparam := FALSE
ELSE
Load(e);
Str(e);
Simple(a);
Load(a);
Str(a);
Operation(e, a, Op, coord)
END
END;
IF e.eType = eCONST THEN
X86.Del(beg);
X86.Setfpu(fpu);
IF ~DECL.Const THEN
CASE e.T.tType OF
|TREAL, TLONGREAL:
X86.PushFlt(e.Value)
|TINTEGER, TSET, TBOOLEAN, TNIL:
X86.PushConst(FLOOR(e.Value))
|TSTRING:
s := DECL.GetString(e.Value);
IF s.Len = 1 THEN
X86.PushConst(ORD(s.Str[0]))
ELSE
X86.PushInt(s.Number)
END
ELSE
END
END
END
END Expr;
 
PROCEDURE IfWhileOper(wh: BOOLEAN);
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L, L3: INTEGER;
BEGIN
L := X86.NewLabel();
IF wh THEN
X86.Label(L)
END;
REPEAT
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
IF wh THEN
Check(lxDO)
ELSE
Check(lxTHEN)
END;
L3 := X86.NewLabel();
X86.ifwh(L3);
Next;
pOpSeq;
X86.jmp(X86.JMP, L);
X86.Label(L3)
UNTIL SCAN.tLex # lxELSIF;
IF ~wh & (SCAN.tLex = lxELSE) THEN
Next;
pOpSeq
END;
Check(lxEND);
IF ~wh THEN
X86.Label(L)
END;
Next
END IfWhileOper;
 
PROCEDURE RepeatOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; L: INTEGER;
BEGIN
Next;
L := X86.NewLabel();
X86.Label(L);
pOpSeq;
Check(lxUNTIL);
NextCoord(coord);
Expr(e);
Assert(e.T.tType = TBOOLEAN, coord, 117);
Load(e);
X86.ifwh(L)
END RepeatOper;
 
PROCEDURE ForOper;
VAR e: DECL.EXPRESSION; coord: SCAN.TCoord; LBeg, LEnd, iValue: INTEGER; Value: LONGREAL;
T: DECL.pTYPE; name: SCAN.NODE; id: DECL.IDENT;
BEGIN
NextCheck(lxIDENT);
name := SCAN.id;
id := DECL.GetIdent(name);
Assert2(id # NIL, 42);
Assert2(id.iType = IDVAR, 126);
Assert2(id.VarKind = 0, 127);
Assert2(id.T.tType = TINTEGER, 128);
Assert2(id.Level = DECL.unit.Level, 129);
NextCheck(lxAssign);
NextCoord(coord);
IF id.Level = 3 THEN
X86.GlobalAdr(id.Offset)
ELSE
X86.LocalAdr(id.Offset, 0)
END;
X86.Dup;
Expr(e);
IntType(e.T, coord);
Load(e);
X86.Save(TINTEGER);
Check(lxTO);
NextCoord(coord);
Expr(e);
IntType(e.T, coord);
Load(e);
iValue := 1;
IF SCAN.tLex = lxBY THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122)
END;
Check(lxDO);
Next;
X86.For(iValue > 0, LBeg, LEnd);
pOpSeq;
X86.NextFor(iValue, LBeg, LEnd);
Check(lxEND);
Next
END ForOper;
 
PROCEDURE CheckLabel(a, b: INTEGER; Labels: UTILS.LIST): BOOLEAN;
VAR cur: LABEL;
BEGIN
cur := Labels.First(LABEL);
WHILE (cur # NIL) & ((b < cur.a) OR (a > cur.b)) DO
cur := cur.Next(LABEL)
END
RETURN cur = NIL
END CheckLabel;
 
PROCEDURE LabelVal(VAR a: INTEGER; int: BOOLEAN);
VAR Value: LONGREAL; T: DECL.pTYPE; s: UTILS.STRCONST; coord: SCAN.TCoord;
BEGIN
Coord(coord);
DECL.ConstExpr(Value, T);
IF int THEN
Assert(T.tType = TINTEGER, coord, 161);
a := FLOOR(Value)
ELSE
Assert(T.tType = TSTRING, coord, 55);
s := DECL.GetString(Value);
Assert(s.Len = 1, coord, 94);
a := ORD(s.Str[0])
END
END LabelVal;
 
PROCEDURE Label(int: BOOLEAN; Labels: UTILS.LIST; LBeg: INTEGER);
VAR a, b: INTEGER; label: LABEL; coord: SCAN.TCoord;
BEGIN
Coord(coord);
LabelVal(a, int);
b := a;
IF SCAN.tLex = lxDbl THEN
Next;
LabelVal(b, int)
END;
Assert(a <= b, coord, 54);
Assert(CheckLabel(a, b, Labels), coord, 100);
NEW(label);
DECL.MemErr(label = NIL);
label.a := a;
label.b := b;
UTILS.Push(Labels, label);
X86.CaseLabel(a, b, LBeg)
END Label;
 
PROCEDURE Variant(int: BOOLEAN; Labels: UTILS.LIST; EndCase: INTEGER);
VAR LBeg, LEnd: INTEGER;
BEGIN
LBeg := X86.NewLabel();
LEnd := X86.NewLabel();
IF ~((SCAN.tLex = lxStick) OR (SCAN.tLex = lxEND)) THEN
Label(int, Labels, LBeg);
WHILE SCAN.tLex = lxComma DO
Next;
Label(int, Labels, LBeg)
END;
Check(lxColon);
Next;
X86.jmp(X86.JMP, LEnd);
X86.Label(LBeg);
pOpSeq;
X86.jmp(X86.JMP, EndCase);
X86.Label(LEnd)
END
END Variant;
 
PROCEDURE CaseOper;
VAR e: DECL.EXPRESSION; int: BOOLEAN; coord: SCAN.TCoord; EndCase: INTEGER; Labels: UTILS.LIST;
BEGIN
NextCoord(coord);
Expr(e);
Assert(e.T.tType IN {TCHAR, TSTRING, TINTEGER}, coord, 156);
Assert(~((e.T.tType = TSTRING) & (LenString(e.Value) # 1)), coord, 94);
int := e.T.tType = TINTEGER;
Check(lxOF);
Load(e);
X86.Drop;
Labels := UTILS.CreateList();
Next;
EndCase := X86.NewLabel();
Variant(int, Labels, EndCase);
WHILE SCAN.tLex = lxStick DO
Next;
Variant(int, Labels, EndCase)
END;
IF SCAN.tLex = lxELSE THEN
Next;
pOpSeq
ELSE
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
X86.OnError(7)
END;
Check(lxEND);
X86.Label(EndCase);
Next;
UTILS.Clear(Labels)
END CaseOper;
 
PROCEDURE CheckCode(Code: UTILS.STRING; Len: INTEGER; coord: SCAN.TCoord);
VAR i: INTEGER;
BEGIN
Assert(~ODD(Len), coord, 34);
FOR i := 0 TO Len - 1 DO
Assert(SCAN.HexDigit(Code[i]), coord, 34)
END
END CheckCode;
 
PROCEDURE StProc(proc: INTEGER);
VAR coord, coord2: SCAN.TCoord; iValue: INTEGER; e1, e2: DECL.EXPRESSION; Value: LONGREAL;
T: DECL.pTYPE; str: UTILS.STRCONST; begcall: X86.ASMLINE;
BEGIN
Coord(coord2);
Check(lxLRound);
NextCoord(coord);
CASE proc OF
|stINC, stDEC:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TINTEGER, coord, 128);
IF SCAN.tLex = lxComma THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(iValue # 0, coord, 122);
IF iValue < 0 THEN
IF proc = stINC THEN
proc := stDEC
ELSE
proc := stINC
END;
iValue := -iValue
END;
IF iValue # 1 THEN
X86.PushConst(iValue);
IF proc = stDEC THEN
X86.StProc(X86.stDEC)
ELSE
X86.StProc(X86.stINC)
END
ELSE
IF proc = stDEC THEN
X86.StProc(X86.stDEC1)
ELSE
X86.StProc(X86.stINC1)
END
END
ELSE
IF proc = stDEC THEN
X86.StProc(X86.stDEC1)
ELSE
X86.StProc(X86.stINC1)
END
END
|stINCL, stEXCL:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TSET, coord, 138);
Check(lxComma);
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
iValue := FLOOR(Value);
Assert(ASR(iValue, 5) = 0, coord, 53);
IF proc = stINCL THEN
X86.PushConst(ORD({iValue}));
X86.StProc(X86.stINCL)
ELSE
X86.PushConst(ORD(-{iValue}));
X86.StProc(X86.stEXCL)
END
|stCOPY:
Expr(e1);
Assert(IsString(e1), coord, 141);
Check(lxComma);
IF e1.T.tType = TSTRING THEN
str := DECL.GetString(e1.Value);
IF str.Len = 1 THEN
X86.Mono(str.Number);
X86.StrMono
END
END;
Str(e1);
NextCoord(coord);
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(IsString(e2), coord, 143);
Assert(~e2.Read, coord, 115);
Str(e2);
X86.StProc(X86.stCOPY)
|stNEW, stDISPOSE:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(~e1.Read, coord, 115);
Assert(e1.T.tType = TPOINTER, coord, 145);
IF proc = stNEW THEN
X86.PushConst(e1.T.Base.Number);
X86.PushConst(X86.Align(e1.T.Base.Size + 8, 32));
X86.newrec
ELSE
X86.disprec
END
|stASSERT:
Expr(e1);
Assert(e1.T.tType = TBOOLEAN, coord, 117);
Load(e1);
IF SCAN.tLex = lxComma THEN
NextCoord(coord);
DECL.ConstExpr(Value, T);
IntType(T, coord);
Assert((Value >= 0.0D0) & (Value <= 127.0D0), coord, 95);
X86.Assert(X86.stASSERT, FLOOR(Value))
ELSE
X86.Assert(X86.stASSERT1, 0)
END
|stPACK, stUNPK:
Designator(e1);
Assert(e1.eType = eVAR, coord, 63);
Assert(e1.T.tType IN TFLOAT, coord, 149);
Assert(~e1.Read, coord, 115);
Check(lxComma);
NextCoord(coord);
IF proc = stUNPK THEN
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(e2.T.tType = TINTEGER, coord, 128);
Assert(~e2.Read, coord, 115);
IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stUNPK)
ELSE
X86.StProc(X86.stUNPK1)
END
ELSE
Expr(e2);
IntType(e2.T, coord);
Load(e2);
IF e1.T.tType = TLONGREAL THEN
X86.StProc(X86.stPACK)
ELSE
X86.StProc(X86.stPACK1)
END
END
|sysPUT, sysGET:
begcall := X86.current;
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
NextCoord(coord);
IF proc = sysGET THEN
X86.PushCall(begcall);
X86.Param;
Designator(e2);
Assert(e2.eType = eVAR, coord, 63);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
Assert(~e2.Read, coord, 115);
X86.EndCall;
X86.Load(e2.T.tType);
X86.Save(e2.T.tType)
ELSE
Expr(e2);
Assert(~(e2.T.tType IN TSTRUCT), coord, 90);
IF e2.T.tType = TSTRING THEN
Assert(LenString(e2.Value) = 1, coord, 94)
ELSIF e2.T.tType = TVOID THEN
e2.T := inttype
END;
Load(e2);
X86.Save(e2.T.tType)
END
|sysCODE:
Assert(SCAN.tLex = lxSTRING, coord, 150);
CheckCode(SCAN.Lex, SCAN.count - 1, coord);
X86.Asm(SCAN.Lex);
Next
|sysMOVE:
begcall := X86.current;
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
X86.PushCall(begcall);
X86.Param;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
Check(lxComma);
X86.EndCall;
NextCoord(coord);
Expr(e1);
IntType(e1.T, coord);
Load(e1);
ELSE
Assert(FALSE, coord2, 132)
END;
Check(lxRRound);
Next;
IF proc = sysMOVE THEN
X86.StProc(X86.sysMOVE)
END
END StProc;
 
PROCEDURE IdentOper;
VAR e1, e2: DECL.EXPRESSION; coord: SCAN.TCoord; ccall: INTEGER; begcall: X86.ASMLINE; s: UTILS.STRCONST;
BEGIN
Coord(coord);
begcall := X86.current;
Designator(e1);
Assert(e1.eType # eCONST, coord, 130);
IF (e1.eType = eVAR) & (e1.T.tType # TPROC) THEN
Check(lxAssign);
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Load(e2);
IF e1.T.tType = TRECORD THEN
X86.PushConst(e1.T.Size);
X86.PushConst(e1.T.Number);
IF e1.vparam THEN
X86.LocalAdr(e1.id.Offset - 4, DECL.unit.Level - e1.id.Level);
X86.Load(TINTEGER)
ELSIF e1.deref THEN
X86.DerefType(12)
ELSE
X86.PushConst(e1.T.Number)
END
ELSIF e2.T.tType = TARRAY THEN
X86.PushConst(e2.T.Size)
ELSIF (e2.T.tType = TSTRING) & (e1.T.tType = TARRAY) THEN
s := DECL.GetString(e2.Value);
IF s.Len = 1 THEN
X86.Mono(s.Number)
END;
X86.PushConst(UTILS.min(s.Len + 1, e1.T.Len))
END;
X86.Save(e1.T.tType)
ELSIF e1.eType = ePROC THEN
Assert((e1.id.T.Base.tType = TVOID) OR (e1.id.T.Call = DECL.winapi), coord, 132);
IF e1.id.ParamCount > 0 THEN
Check(lxLRound);
Next;
X86.PushCall(begcall);
Call(e1.id.T.Fields.First(DECL.FIELD));
X86.EndCall
ELSIF SCAN.tLex = lxLRound THEN
NextCheck(lxRRound);
Next
END;
IF e1.id.Level = 3 THEN
ccall := 0
ELSIF e1.id.Level > DECL.curBlock.Level THEN
ccall := 1
ELSE
ccall := 2
END;
X86.Call(e1.id.Number, FALSE, FALSE, e1.id.T.Call, ccall, e1.id.Level - 3, DECL.curBlock.Level - 3, e1.id.ParamSize, DECL.curBlock.LocalSize)
ELSIF e1.eType IN {eSTPROC, eSYSPROC} THEN
StProc(e1.id.StProc)
ELSIF (e1.eType = eVAR) & (e1.T.tType = TPROC) THEN
IF SCAN.tLex = lxLRound THEN
Next;
Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132);
X86.PushCall(begcall);
Call(e1.T.Fields.First(DECL.FIELD));
X86.EndCall;
X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize)
ELSIF SCAN.tLex = lxAssign THEN
Assert(~e1.Read, coord, 115);
NextCoord(coord);
Expr(e2);
Assert(AssComp(e2, e1.T, FALSE), coord, 131);
Assert(~((e2.eType = ePROC) & (e2.id.Level > 3)), coord, 116);
IF e2.eType = eVAR THEN
X86.Load(TPROC)
END;
X86.Save(TPROC)
ELSE
Assert2(e1.T.Fields.Count = 0, 155);
Assert((e1.T.Base.tType = TVOID) OR (e1.T.Call = DECL.winapi), coord, 132);
X86.CallVar(FALSE, FALSE, e1.T.Call, e1.T.Len, DECL.curBlock.LocalSize)
END
END
END IdentOper;
 
PROCEDURE Operator;
BEGIN
UTILS.UnitLine(DECL.UnitNumber, SCAN.coord.line);
CASE SCAN.tLex OF
|lxIDENT: IdentOper
|lxIF, lxWHILE: IfWhileOper(SCAN.tLex = lxWHILE)
|lxREPEAT: RepeatOper
|lxFOR: ForOper
|lxCASE: CaseOper
ELSE
END
END Operator;
 
PROCEDURE OpSeq;
BEGIN
Operator;
WHILE SCAN.tLex = lxSemi DO
Next;
Operator
END
END OpSeq;
 
PROCEDURE Start;
VAR SelfName, SelfPath, CName, CExt, FName, Path, StdPath,
Name, Ext, temp, system, stk: UTILS.STRING;
platform, stksize: INTEGER;
 
PROCEDURE getstksize(): INTEGER;
VAR res, i: INTEGER;
BEGIN
res := 0;
i := 0;
WHILE SCAN.Digit(stk[i]) DO
INC(i)
END;
IF stk[i] <= 20X THEN
stk[i] := 0X;
res := SCAN.StrToInt(stk)
END;
IF res = 0 THEN
res := 1
END
RETURN res
END getstksize;
 
PROCEDURE getver(): INTEGER;
VAR res, i: INTEGER; err: BOOLEAN;
 
PROCEDURE hexdgt(c: CHAR): BOOLEAN;
RETURN ("0" <= c) & (c <= "9") OR
("A" <= c) & (c <= "F") OR
("a" <= c) & (c <= "f")
END hexdgt;
 
PROCEDURE hex(c: CHAR): INTEGER;
VAR res: INTEGER;
BEGIN
IF ("0" <= c) & (c <= "9") THEN
res := ORD(c) - ORD("0")
ELSIF ("A" <= c) & (c <= "F") THEN
res := ORD(c) - ORD("A") + 10
ELSIF ("a" <= c) & (c <= "f") THEN
res := ORD(c) - ORD("a") + 10
END
RETURN res
END hex;
 
BEGIN
res := 0;
i := 0;
err := stk[i] # "0"; INC(i);
err := err OR (stk[i] # "x"); INC(i);
WHILE ~err & hexdgt(stk[i]) DO
INC(i)
END;
err := err OR (i = 2);
IF stk[i] <= 20X THEN
stk[i] := 0X
ELSE
err := TRUE
END;
i := 2;
WHILE ~err & (stk[i] # 0X) DO
res := LSL(res, 4) + hex(stk[i]);
INC(i)
END;
IF res = 0 THEN
res := 65536
END
RETURN res
END getver;
 
BEGIN
IF UTILS.ParamCount < 2 THEN
UTILS.ErrMsg(59);
UTILS.HALT(1)
END;
UTILS.ParamStr(SelfName, 0);
UTILS.ParamStr(FName, 1);
UTILS.ParamStr(system, 2);
UTILS.ParamStr(stk, 3);
pExpr := Expr;
pFactor := Factor;
pOpSeq := OpSeq;
UTILS.Split(FName, Path, Name, Ext);
IF Ext # UTILS.Ext THEN
UTILS.ErrMsg(121);
UTILS.HALT(1)
END;
UTILS.Split(SelfName, SelfPath, CName, CExt);
temp := Name;
IF UTILS.streq(system, "obj") THEN
platform := 6;
UTILS.concat(temp, ".obj")
ELSIF UTILS.streq(system, "elf") THEN
platform := 5
ELSIF UTILS.streq(system, "kos") THEN
platform := 4;
UTILS.concat(temp, ".kex")
ELSIF UTILS.streq(system, "con") THEN
platform := 3;
UTILS.concat(temp, ".exe")
ELSIF UTILS.streq(system, "gui") THEN
platform := 2;
UTILS.concat(temp, ".exe")
ELSIF UTILS.streq(system, "dll") THEN
platform := 1;
UTILS.concat(temp, ".dll")
ELSE
UTILS.ErrMsg(60);
UTILS.HALT(1)
END;
IF platform IN {1, 2, 3, 4} THEN
stksize := getstksize()
ELSE
stksize := 1
END;
IF platform = 6 THEN
stksize := getver()
END;
UTILS.concat(SelfPath, "Lib");
UTILS.concat(SelfPath, UTILS.Slash);
IF platform = 5 THEN
UTILS.concat(SelfPath, "Linux32")
ELSIF platform IN {4, 6} THEN
UTILS.concat(SelfPath, "KolibriOS")
ELSIF platform IN {1, 2, 3} THEN
UTILS.concat(SelfPath, "Windows32")
END;
UTILS.concat(SelfPath, UTILS.Slash);
X86.Init(platform);
X86.Prolog(temp);
DECL.Program(SelfPath, Path, Name, Ext, platform IN {1, 2, 3}, OpSeq, Expr, AssComp, sttypes);
voidtype := sttypes[TVOID];
inttype := sttypes[TINTEGER];
booltype := sttypes[TBOOLEAN];
strtype := sttypes[TSTRING];
settype := sttypes[TSET];
realtype := sttypes[TREAL];
longrealtype := sttypes[TLONGREAL];
chartype := sttypes[TCHAR];
niltype := sttypes[TNIL];
DECL.Compile(platform, stksize);
UTILS.OutString("success"); UTILS.Ln;
UTILS.HALT(0)
END Start;
 
BEGIN
Start
END Compiler.
/programs/develop/oberon07/Source/DECL.ob07
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.
/programs/develop/oberon07/Source/ELF.ob07
0,0 → 1,295
(*
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 ELF;
 
IMPORT SYSTEM;
 
CONST size* = 8346;
 
PROCEDURE [stdcall] data;
BEGIN
SYSTEM.CODE("7F454C4601010100000000000000000002000300010000004086040834000000");
SYSTEM.CODE("A41120000000000034002000080028001D001A00060000003400000034800408");
SYSTEM.CODE("3480040800010000000100000500000004000000030000003401000034810408");
SYSTEM.CODE("3481040813000000130000000400000001000000010000000000000000800408");
SYSTEM.CODE("00800408240C1000240C10000500000000100000010000000C0F10000C9F1408");
SYSTEM.CODE("0C9F1408540110009401900C060000000010000002000000200F1000209F1408");
SYSTEM.CODE("209F1408D0000000D00000000600000004000000040000004801000048810408");
SYSTEM.CODE("488104084400000044000000040000000400000051E574640000000000000000");
SYSTEM.CODE("000000000000000000000000060000000400000052E574640C0F10000C9F1408");
SYSTEM.CODE("0C9F1408F4000000F400000004000000010000002F6C69622F6C642D6C696E75");
SYSTEM.CODE("782E736F2E320000040000001000000001000000474E55000000000002000000");
SYSTEM.CODE("060000000F000000040000001400000003000000474E55006D648AA1A4FF8A62");
SYSTEM.CODE("6855372198B3905D7B4527570300000005000000040000000700000092005000");
SYSTEM.CODE("126388F68400000080044030050000000800000013000000AEC44D0F281D8C1C");
SYSTEM.CODE("4701750FAC4BE3C086F0967C328E750F20CF09FD38F28B1C7C8B730F060204F9");
SYSTEM.CODE("16EA76FE3CAD390D665561103F7E967C7D1B760F000000000000000000000000");
SYSTEM.CODE("000000000C0000000000000000000000200000001B0000000000000000000000");
SYSTEM.CODE("20000000A20000000000000000000000120000006C0000000000000000000000");
SYSTEM.CODE("12000000360000008C85040800000000120000007900000080A0240804000000");
SYSTEM.CODE("110018009C0000001C8604080000000012000000460000000C8C140804000000");
SYSTEM.CODE("11000F00B40000007C8504080000000012000000730000009C85040800000000");
SYSTEM.CODE("1200000080000000AC85040800000000120000008E00000060A0240804000000");
SYSTEM.CODE("110018005A000000BC85040800000000120000002F000000CC85040800000000");
SYSTEM.CODE("1200000095000000FC8504080000000012000000870000000C86040800000000");
SYSTEM.CODE("120000006600000064A024080400000011001800550000002C86040800000000");
SYSTEM.CODE("1200000060000000DC8504080000000012000000006C6962646C2E736F2E3200");
SYSTEM.CODE("5F5F676D6F6E5F73746172745F5F005F4A765F5265676973746572436C617373");
SYSTEM.CODE("657300646C6F70656E00646C73796D006C6962632E736F2E36005F494F5F7374");
SYSTEM.CODE("64696E5F75736564006578697400666F70656E006674656C6C00737464696E00");
SYSTEM.CODE("7072696E746600667365656B007374646F75740066636C6F7365006D616C6C6F");
SYSTEM.CODE("630073746465727200667772697465006672656164005F5F6C6962635F737461");
SYSTEM.CODE("72745F6D61696E006672656500474C4942435F322E3100474C4942435F322E30");
SYSTEM.CODE("0000000000000000020002000300020002000100020002000400020004000500");
SYSTEM.CODE("020002000200020002000000010002000100000010000000300000001169690D");
SYSTEM.CODE("00000500B9000000100000001069690D00000300C30000000000000001000200");
SYSTEM.CODE("3C00000010000000000000001169690D00000400B9000000100000001069690D");
SYSTEM.CODE("00000200C300000000000000F09F14080601000060A02408050C000064A02408");
SYSTEM.CODE("0511000080A024080506000000A014080701000004A014080703000008A01408");
SYSTEM.CODE("070900000CA014080705000010A01408070A000014A01408070B000018A01408");
SYSTEM.CODE("070D00001CA01408070E000020A014080713000024A014080704000028A01408");
SYSTEM.CODE("070F00002CA014080710000030A014080707000034A01408071200005589E553");
SYSTEM.CODE("83EC04E8000000005B81C3CC1A10008B93FCFFFFFF85D27405E81E000000E88D");
SYSTEM.CODE("010000E878061000585BC9C3FF35F89F1408FF25FC9F140800000000FF2500A0");
SYSTEM.CODE("14086800000000E9E0FFFFFFFF2504A014086808000000E9D0FFFFFFFF2508A0");
SYSTEM.CODE("14086810000000E9C0FFFFFFFF250CA014086818000000E9B0FFFFFFFF2510A0");
SYSTEM.CODE("14086820000000E9A0FFFFFFFF2514A014086828000000E990FFFFFFFF2518A0");
SYSTEM.CODE("14086830000000E980FFFFFFFF251CA014086838000000E970FFFFFFFF2520A0");
SYSTEM.CODE("14086840000000E960FFFFFFFF2524A014086848000000E950FFFFFFFF2528A0");
SYSTEM.CODE("14086850000000E940FFFFFFFF252CA014086858000000E930FFFFFFFF2530A0");
SYSTEM.CODE("14086860000000E920FFFFFFFF2534A014086868000000E910FFFFFF00000000");
SYSTEM.CODE("31ED5E89E183E4F050545268B08B140868508B1408515668F4860408E80BFFFF");
SYSTEM.CODE("FFF490909090909090909090909090905589E55383EC04803D84A0240800753F");
SYSTEM.CODE("A188A02408BB189F140881EB149F1408C1FB0283EB0139D8731E8DB600000000");
SYSTEM.CODE("83C001A388A02408FF1485149F1408A188A0240839D872E8C60584A024080183");
SYSTEM.CODE("C4045B5DC38D7426008DBC27000000005589E583EC18A11C9F140885C07412B8");
SYSTEM.CODE("0000000085C07409C704241C9F1408FFD0C9C3905589E583E4F0565383EC38C7");
SYSTEM.CODE("44242CA0A024088B55088B44242C89108344242C048B550C8B44242C89108344");
SYSTEM.CODE("242C048B55108B44242C89108344242C04BACC8504088B44242C89108344242C");
SYSTEM.CODE("04BA8C8504088B44242C89108344242C04BA2C8604088B44242C89108344242C");
SYSTEM.CODE("04A164A0240889C28B44242C89108344242C04A180A0240889C28B44242C8910");
SYSTEM.CODE("8344242C04A160A0240889C28B44242C89108344242C04BA0C8604088B44242C");
SYSTEM.CODE("89108344242C04BA7C8504088B44242C89108344242C04BABC8504088B44242C");
SYSTEM.CODE("89108344242C04BAAC8504088B44242C89108344242C04BAFC8504088B44242C");
SYSTEM.CODE("89108344242C04BA1C8604088B44242C89108344242C04BA9C8504088B44242C");
SYSTEM.CODE("89108344242C04BADC8504088B44242C89108344242C048B35B8A02408BBF486");
SYSTEM.CODE("0408B9A0A02408BA60A01408B8108C140889742410895C240C894C2408895424");
SYSTEM.CODE("04890424E8B9FAEFFFB80000000083C4385B5E89EC5DC3909090909090909090");
SYSTEM.CODE("9090909090905589E5575653E85A00000081C39914000083EC1CE8B3F9EFFF8D");
SYSTEM.CODE("BB18FFFFFF8D8318FFFFFF29C7C1FF0285FF742431F68B4510894424088B450C");
SYSTEM.CODE("894424048B4508890424FF94B318FFFFFF83C60139FE72DE83C41C5B5E5F5DC3");
SYSTEM.CODE("8DB6000000005589E55DC38B1C24C3909090909090905589E55383EC04A10C9F");
SYSTEM.CODE("140883F8FF7413BB0C9F1408669083EB04FFD08B0383F8FF75F483C4045B5DC3");
SYSTEM.CODE("90905589E55383EC04E8000000005B81C3FC130000E86CFAEFFF595BC9C30300");
SYSTEM.CODE("00000100020025750A25750A25750A25750A0000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000FFFFFFFF00000000FFFFFFFF000000000000000001000000010000000100");
SYSTEM.CODE("00003C0000000C0000001C8504080D000000EC8B1408F5FEFF6F8C8104080500");
SYSTEM.CODE("00003483040806000000F48104080A000000CD0000000B000000100000001500");
SYSTEM.CODE("00000000000003000000F49F1408020000007000000014000000110000001700");
SYSTEM.CODE("0000AC840408110000008C84040812000000200000001300000008000000FEFF");
SYSTEM.CODE("FF6F2C840408FFFFFF6F02000000F0FFFF6F0284040800000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("00000000000000000000209F1408000000000000000062850408728504088285");
SYSTEM.CODE("040892850408A2850408B2850408C2850408D2850408E2850408F28504080286");
SYSTEM.CODE("0408128604082286040832860408000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000004743433A20285562756E74");
SYSTEM.CODE("752F4C696E61726F20342E352E322D387562756E7475342920342E352E320047");
SYSTEM.CODE("43433A20285562756E74752F4C696E61726F20342E352E322D387562756E7475");
SYSTEM.CODE("332920342E352E3200002E73796D746162002E737472746162002E7368737472");
SYSTEM.CODE("746162002E696E74657270002E6E6F74652E4142492D746167002E6E6F74652E");
SYSTEM.CODE("676E752E6275696C642D6964002E676E752E68617368002E64796E73796D002E");
SYSTEM.CODE("64796E737472002E676E752E76657273696F6E002E676E752E76657273696F6E");
SYSTEM.CODE("5F72002E72656C2E64796E002E72656C2E706C74002E696E6974002E74657874");
SYSTEM.CODE("002E66696E69002E726F64617461002E65685F6672616D65002E63746F727300");
SYSTEM.CODE("2E64746F7273002E6A6372002E64796E616D6963002E676F74002E676F742E70");
SYSTEM.CODE("6C74002E64617461002E627373002E636F6D6D656E7400000000000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000000000000000000000000000");
SYSTEM.CODE("001B000000010000000200000034810408340100001300000000000000000000");
SYSTEM.CODE("0001000000000000002300000007000000020000004881040848010000200000");
SYSTEM.CODE("0000000000000000000400000000000000310000000700000002000000688104");
SYSTEM.CODE("0868010000240000000000000000000000040000000000000044000000F6FFFF");
SYSTEM.CODE("6F020000008C8104088C01000068000000050000000000000004000000040000");
SYSTEM.CODE("004E0000000B00000002000000F4810408F40100004001000006000000010000");
SYSTEM.CODE("0004000000100000005600000003000000020000003483040834030000CD0000");
SYSTEM.CODE("00000000000000000001000000000000005E000000FFFFFF6F02000000028404");
SYSTEM.CODE("080204000028000000050000000000000002000000020000006B000000FEFFFF");
SYSTEM.CODE("6F020000002C8404082C04000060000000060000000200000004000000000000");
SYSTEM.CODE("007A00000009000000020000008C8404088C0400002000000005000000000000");
SYSTEM.CODE("000400000008000000830000000900000002000000AC840408AC040000700000");
SYSTEM.CODE("00050000000C00000004000000080000008C00000001000000060000001C8504");
SYSTEM.CODE("081C050000300000000000000000000000040000000000000087000000010000");
SYSTEM.CODE("00060000004C8504084C050000F0000000000000000000000004000000040000");
SYSTEM.CODE("009200000001000000060000004086040840060000AC05100000000000000000");
SYSTEM.CODE("001000000000000000980000000100000006000000EC8B1408EC0B10001C0000");
SYSTEM.CODE("00000000000000000004000000000000009E0000000100000002000000088C14");
SYSTEM.CODE("08080C10001500000000000000000000000400000000000000A6000000010000");
SYSTEM.CODE("0002000000208C1408200C100004000000000000000000000004000000000000");
SYSTEM.CODE("00B000000001000000030000000C9F14080C0F10000800000000000000000000");
SYSTEM.CODE("000400000000000000B70000000100000003000000149F1408140F1000080000");
SYSTEM.CODE("0000000000000000000400000000000000BE00000001000000030000001C9F14");
SYSTEM.CODE("081C0F10000400000000000000000000000400000000000000C3000000060000");
SYSTEM.CODE("0003000000209F1408200F1000D0000000060000000000000004000000080000");
SYSTEM.CODE("00CC0000000100000003000000F09F1408F00F10000400000000000000000000");
SYSTEM.CODE("000400000004000000D10000000100000003000000F49F1408F40F1000440000");
SYSTEM.CODE("0000000000000000000400000004000000DA000000010000000300000040A014");
SYSTEM.CODE("08401010002000100000000000000000002000000000000000E0000000080000");
SYSTEM.CODE("000300000060A02408601020004000800C000000000000000020000000000000");
SYSTEM.CODE("00E5000000010000003000000000000000601020005400000000000000000000");
SYSTEM.CODE("00010000000100000011000000030000000000000000000000B4102000EE0000");
SYSTEM.CODE("0000000000000000000100000000000000010000000200000000000000000000");
SYSTEM.CODE("002C162000000500001C0000002C000000040000001000000009000000030000");
SYSTEM.CODE("0000000000000000002C1B2000F9020000000000000000000001000000000000");
SYSTEM.CODE("0000000000000000000000000000000000000000003481040800000000030001");
SYSTEM.CODE("0000000000488104080000000003000200000000006881040800000000030003");
SYSTEM.CODE("00000000008C810408000000000300040000000000F481040800000000030005");
SYSTEM.CODE("0000000000348304080000000003000600000000000284040800000000030007");
SYSTEM.CODE("00000000002C8404080000000003000800000000008C84040800000000030009");
SYSTEM.CODE("0000000000AC8404080000000003000A00000000001C8504080000000003000B");
SYSTEM.CODE("00000000004C8504080000000003000C0000000000408604080000000003000D");
SYSTEM.CODE("0000000000EC8B14080000000003000E0000000000088C14080000000003000F");
SYSTEM.CODE("0000000000208C14080000000003001000000000000C9F140800000000030011");
SYSTEM.CODE("0000000000149F14080000000003001200000000001C9F140800000000030013");
SYSTEM.CODE("0000000000209F1408000000000300140000000000F09F140800000000030015");
SYSTEM.CODE("0000000000F49F140800000000030016000000000040A0140800000000030017");
SYSTEM.CODE("000000000060A024080000000003001800000000000000000000000000030019");
SYSTEM.CODE("000100000000000000000000000400F1FF0C0000000C9F140800000000010011");
SYSTEM.CODE("001A000000149F14080000000001001200280000001C9F140800000000010013");
SYSTEM.CODE("0035000000708604080000000002000D004B00000084A0240801000000010018");
SYSTEM.CODE("005A00000088A02408040000000100180068000000D08604080000000002000D");
SYSTEM.CODE("000100000000000000000000000400F1FF74000000109F140800000000010011");
SYSTEM.CODE("0081000000208C140800000000010010008F0000001C9F140800000000010013");
SYSTEM.CODE("009B000000C08B14080000000002000D00B100000000000000000000000400F1");
SYSTEM.CODE("FFB8000000F49F14080000000001001600CE0000000C9F140800000000000011");
SYSTEM.CODE("00DF0000000C9F14080000000000001100F2000000209F140800000000010014");
SYSTEM.CODE("00FB00000040A01408000000002000170006010000B08B14080500000012000D");
SYSTEM.CODE("0016010000408604080000000012000D001D0100000000000000000000200000");
SYSTEM.CODE("002C01000000000000000000002000000040010000088C14080400000011000F");
SYSTEM.CODE("0047010000EC8B14080000000012000E004D0100000000000000000000120000");
SYSTEM.CODE("006A0100000C8C14080400000011000F00790100007C85040800000000120000");
SYSTEM.CODE("0089010000A0A024080000800C110018008E01000040A0140800000000100017");
SYSTEM.CODE("009B0100008C8504080000000012000000AC0100009C85040800000000120000");
SYSTEM.CODE("00BD010000AC8504080000000012000000CF01000060A0240804000000110018");
SYSTEM.CODE("00E1010000BC8504080000000012000000F201000044A0140800000000110217");
SYSTEM.CODE("00FF010000CC850408000000001200000011020000DC85040800000000120000");
SYSTEM.CODE("0022020000189F140800000000110212002F020000508B14085A00000012000D");
SYSTEM.CODE("003F02000000000000000000001200000051020000FC85040800000000120000");
SYSTEM.CODE("006302000060A02408000000001000F1FF6F0200000C86040800000000120000");
SYSTEM.CODE("008102000060A0140800001000110017008702000064A0240804000000110018");
SYSTEM.CODE("0098020000A0A0A414000000001000F1FF9D02000080A0240804000000110018");
SYSTEM.CODE("00AF0200001C8604080000000012000000C002000060A02408000000001000F1");
SYSTEM.CODE("FFC70200002C8604080000000012000000D7020000B58B14080000000012020D");
SYSTEM.CODE("00EE020000F48604084D04100012000D00F30200001C8504080000000012000B");
SYSTEM.CODE("000063727473747566662E63005F5F43544F525F4C4953545F5F005F5F44544F");
SYSTEM.CODE("525F4C4953545F5F005F5F4A43525F4C4953545F5F005F5F646F5F676C6F6261");
SYSTEM.CODE("6C5F64746F72735F61757800636F6D706C657465642E363135350064746F725F");
SYSTEM.CODE("6964782E36313537006672616D655F64756D6D79005F5F43544F525F454E445F");
SYSTEM.CODE("5F005F5F4652414D455F454E445F5F005F5F4A43525F454E445F5F005F5F646F");
SYSTEM.CODE("5F676C6F62616C5F63746F72735F6175780070726F672E63005F474C4F42414C");
SYSTEM.CODE("5F4F46465345545F5441424C455F005F5F696E69745F61727261795F656E6400");
SYSTEM.CODE("5F5F696E69745F61727261795F7374617274005F44594E414D49430064617461");
SYSTEM.CODE("5F7374617274005F5F6C6962635F6373755F66696E69005F7374617274005F5F");
SYSTEM.CODE("676D6F6E5F73746172745F5F005F4A765F5265676973746572436C6173736573");
SYSTEM.CODE("005F66705F6877005F66696E69005F5F6C6962635F73746172745F6D61696E40");
SYSTEM.CODE("40474C4942435F322E30005F494F5F737464696E5F7573656400667265654040");
SYSTEM.CODE("474C4942435F322E300064617461005F5F646174615F737461727400646C7379");
SYSTEM.CODE("6D4040474C4942435F322E3000667365656B4040474C4942435F322E30006663");
SYSTEM.CODE("6C6F73654040474C4942435F322E31007374646572724040474C4942435F322E");
SYSTEM.CODE("3000666F70656E4040474C4942435F322E31005F5F64736F5F68616E646C6500");
SYSTEM.CODE("646C6F70656E4040474C4942435F322E31006674656C6C4040474C4942435F32");
SYSTEM.CODE("2E30005F5F44544F525F454E445F5F005F5F6C6962635F6373755F696E697400");
SYSTEM.CODE("7072696E74664040474C4942435F322E30006677726974654040474C4942435F");
SYSTEM.CODE("322E30005F5F6273735F7374617274006D616C6C6F634040474C4942435F322E");
SYSTEM.CODE("3000696461746100737464696E4040474C4942435F322E30005F656E64007374");
SYSTEM.CODE("646F75744040474C4942435F322E300066726561644040474C4942435F322E30");
SYSTEM.CODE("005F656461746100657869744040474C4942435F322E30005F5F693638362E67");
SYSTEM.CODE("65745F70635F7468756E6B2E6278006D61696E005F696E697400");
END data;
 
PROCEDURE get*(): INTEGER;
RETURN SYSTEM.ADR(data) + 3
END get;
 
END ELF.
/programs/develop/oberon07/Source/ERRORS.ob07
0,0 → 1,285
(*
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 ERRORS;
 
IMPORT H := HOST;
 
TYPE
 
STRING = ARRAY 1024 OF CHAR;
 
CP = ARRAY 256 OF INTEGER;
 
VAR
 
cp: CP;
 
 
PROCEDURE utf8(code: INTEGER; VAR uchar: STRING);
BEGIN
uchar[0] := 0X;
IF code < 80H THEN
uchar[0] := CHR(code);
uchar[1] := 0X
ELSIF code < 800H THEN
uchar[1] := CHR(ROR(LSL(code, 26), 26) + 80H);
uchar[0] := CHR(ASR(code, 6) + 0C0H);
uchar[2] := 0X
ELSIF code < 10000H THEN
uchar[2] := CHR(ROR(LSL(code, 26), 26) + 80H);
code := ASR(code, 6);
uchar[1] := CHR(ROR(LSL(code, 26), 26) + 80H);
uchar[0] := CHR(ASR(code, 6) + 0E0H);
uchar[3] := 0X
(*
ELSIF code < 200000H THEN
ELSIF code < 4000000H THEN
ELSE *)
END
END utf8;
 
PROCEDURE InitCP(VAR cp: CP);
VAR i: INTEGER;
BEGIN
FOR i := 0H TO 7FH DO
cp[i] := i
END
END InitCP;
 
PROCEDURE Init8(VAR cp: CP; VAR n: INTEGER; a, b, c, d, e, f, g, h: INTEGER);
BEGIN
cp[n] := a; INC(n);
cp[n] := b; INC(n);
cp[n] := c; INC(n);
cp[n] := d; INC(n);
cp[n] := e; INC(n);
cp[n] := f; INC(n);
cp[n] := g; INC(n);
cp[n] := h; INC(n);
END Init8;
 
PROCEDURE InitCP866(VAR cp: CP);
VAR n, i: INTEGER;
BEGIN
FOR i := 0410H TO 043FH DO
cp[i - 0410H + 80H] := i
END;
FOR i := 0440H TO 044FH DO
cp[i - 0440H + 0E0H] := i
END;
 
n := 0B0H;
Init8(cp, n, 2591H, 2592H, 2593H, 2502H, 2524H, 2561H, 2562H, 2556H);
Init8(cp, n, 2555H, 2563H, 2551H, 2557H, 255DH, 255CH, 255BH, 2510H);
Init8(cp, n, 2514H, 2534H, 252CH, 251CH, 2500H, 253CH, 255EH, 255FH);
Init8(cp, n, 255AH, 2554H, 2569H, 2566H, 2560H, 2550H, 256CH, 2567H);
Init8(cp, n, 2568H, 2564H, 2565H, 2559H, 2558H, 2552H, 2553H, 256BH);
Init8(cp, n, 256AH, 2518H, 250CH, 2588H, 2584H, 258CH, 2590H, 2580H);
 
n := 0F0H;
Init8(cp, n, 0401H, 0451H, 0404H, 0454H, 0407H, 0457H, 040EH, 045EH);
Init8(cp, n, 00B0H, 2219H, 00B7H, 221AH, 2116H, 00A4H, 25A0H, 00A0H);
 
InitCP(cp)
END InitCP866;
 
PROCEDURE concat(VAR L: STRING; R: STRING);
VAR i, n, pos: INTEGER;
BEGIN
n := LENGTH(R);
i := 0;
pos := LENGTH(L);
WHILE (i <= n) & (pos < LEN(L)) DO
L[pos] := R[i];
INC(pos);
INC(i)
END
END concat;
 
PROCEDURE Utf8(VAR str: STRING);
VAR i: INTEGER; in, out, u: STRING;
BEGIN
in := str;
out := "";
FOR i := 0 TO LENGTH(in) - 1 DO
utf8(cp[ORD(in[i])], u);
concat(out, u)
END;
str := out
END Utf8;
 
PROCEDURE ErrorMsg*(code: INTEGER; VAR msg: ARRAY OF CHAR);
VAR str: STRING;
BEGIN
CASE code OF
| 1: str := "®¦¨¤ « áì 'H' ¨«¨ 'X'"
| 2: str := "®¦¨¤ « áì æ¨äà "
| 3: str := "áâப  ­¥ ᮤ¥à¦¨â § ªà뢠î饩 ª ¢ë窨"
| 4: str := "­¥¤®¯ãáâ¨¬ë© á¨¬¢®«"
| 5: str := "楫®ç¨á«¥­­®¥ ¯¥à¥¯®«­¥­¨¥"
| 6: str := "᫨誮¬ ¡®«ì讥 §­ ç¥­¨¥ ᨬ¢®«ì­®© ª®­áâ ­âë"
| 7: str := "¢¥é¥á⢥­­®¥ ¯¥à¥¯®«­¥­¨¥"
| 8: str := "¯¥à¥¯®«­¥­¨¥ ¯®à浪  ¢¥é¥á⢥­­®£® ç¨á« "
| 9: str := "¢¥é¥á⢥­­®¥  ­â¨¯¥à¥¯®«­¥­¨¥"
| 10: str := "᫨誮¬ ¤«¨­­ë© ¨¤¥­â¨ä¨ª â®à"
| 11: str := "᫨誮¬ ¤«¨­­ ï áâப®¢ ï ª®­áâ ­â "
 
| 21: str := "®¦¨¤ «®áì 'MODULE'"
| 22: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à"
| 23: str := "®¦¨¤ « áì ';'"
| 24: str := "®¦¨¤ «®áì 'END'"
| 25: str := "®¦¨¤ « áì '.'"
| 26: str := "¨¤¥­â¨ä¨ª â®à ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ¬®¤ã«ï"
| 27: str := "­¥®¦¨¤ ­­ë© ª®­¥æ ä ©« "
| 28: str := "®¦¨¤ « áì ',', ';' ¨«¨ ':='"
| 29: str := "®¦¨¤ « áì ',' ¨«¨ ';'"
| 30: str := "¨¤¥­â¨ä¨ª â®à ¯¥à¥®¯à¥¤¥«¥­"
| 31: str := "横«¨ç¥áª¨© ¨¬¯®àâ"
| 32: str := "¬®¤ã«ì ­¥ ­ ©¤¥­ ¨«¨ ®è¨¡ª  ¤®áâ㯠"
| 33: str := "¨¬ï ¬®¤ã«ï ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ä ©«  ¬®¤ã«ï"
| 34: str := "­¥¯à ¢¨«ì­ë© ä®à¬ â áâப¨ ¬ è¨­­ëå ª®¤®¢"
| 35: str := "®¦¨¤ «®áì '='"
| 36: str := "ᨭ⠪á¨ç¥áª ï ®è¨¡ª  ¢ ¢ëà ¦¥­¨¨"
| 37: str := "®¯¥à æ¨ï ­¥ ¯à¨¬¥­¨¬ "
| 38: str := "®¦¨¤ « áì ')'"
| 39: str := "®¦¨¤ «oáì 'ARRAY', 'RECORD', 'POINTER' ¨«¨ 'PROCEDURE'"
| 40: str := "®¦¨¤ «oáì 'TO'"
| 41: str := "®¦¨¤ «oáì 'OF'"
| 42: str := "­¥®¯à¥¤¥«¥­­ë© ¨¤¥­â¨ä¨ª â®à"
| 43: str := "âॡã¥âáï ¯¥à¥¬¥­­ ï, ¯à®æ¥¤ãà  ¨«¨ áâப®¢ ï ª®­áâ ­â "
| 44: str := "®¦¨¤ «oáì 'cdecl', 'stdcall' ¨«¨ 'winapi'"
| 45: str := "ä« £ ¢ë§®¢  ­¥¤®¯ã᪠¥âáï ¤«ï «®ª «ì­ëå ¯à®æ¥¤ãà"
| 46: str := "¤¥«¥­¨¥ ­  ­ã«ì"
| 47: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨ ¨«¨ ⨯ -㪠§ â¥«ï"
| 48: str := "楫®ç¨á«¥­­®¥ ¤¥«¥­¨¥ ­  ­ã«ì"
| 49: str := "§­ ç¥­¨¥ «¥¢®£® ®¯¥à ­¤  ¢­¥ ¤¨ ¯ §®­  0..31"
| 50: str := "ä« £ [winapi] ¤®áâ㯥­ ⮫쪮 ¤«ï ¯« âä®à¬ë Windows"
| 51: str := "®¦¨¤ « áì '}'"
| 52: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  INTEGER"
| 53: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ ¤¨ ¯ §®­  0..31"
| 54: str := "«¥¢ ï £à ­¨æ  ¤¨ ¯ §®­  ¡®«ìè¥ ¯à ¢®©"
| 55: str := "âॡã¥âáï ª®­áâ ­â  â¨¯  CHAR"
| 56: str := "®¦¨¤ « áì '('"
| 57: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ç¨á«®¢®£® ⨯ "
 
| 59: str := "­¥¤®áâ â®ç­® ¯ à ¬¥â஢"
| 60: str := "­¥¤®¯ãáâ¨¬ë© ¯ à ¬¥âà"
| 61: str := "®¦¨¤ « áì ','"
| 62: str := "âॡã¥âáï ª®­áâ ­â­®¥ ¢ëà ¦¥­¨¥"
| 63: str := "âॡã¥âáï ¯¥à¥¬¥­­ ï"
| 64: str := "ä ©« ­¥ ­ ©¤¥­ ¨«¨ ®è¨¡ª  ¤®áâ㯠"
| 65: str := "¬®¤ã«ì RTL ­¥ ­ ©¤¥­"
| 66: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  REAL ¨«¨ LONGREAL"
| 67: str := "­¥¢®§¬®¦­® ᮧ¤ âì ä ©«, ¢®§¬®¦­® ä ©« ®âªàëâ ¨«¨ ¤¨áª § é¨é¥­ ®â § ¯¨á¨"
| 68: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  CHAR, SET ¨«¨ BOOLEAN"
| 69: str := "­¥¢®§¬®¦­® § ¯¨á âì ä ©«"
| 70: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  LONGREAL"
| 71: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  REAL"
| 72: str := "­¥¤®áâ â®ç­® ¯ ¬ï⨠¤«ï § ¢¥à襭¨ï ª®¬¯¨«ï樨"
| 73: str := "¯à®æ¥¤ãà  ­¥ ¢®§¢à é îé ï १ã«ìâ â ­¥¤®¯ãá⨬  ¢ ¢ëà ¦¥­¨ïå"
| 74: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ 楫®ç¨á«¥­­®£® ¤¨ ¯ §®­ "
| 75: str := "४ãàᨢ­®¥ ®¯à¥¤¥«¥­¨¥ ª®­áâ ­âë"
| 76: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¢­¥ ¤¨ ¯ §®­  0..255"
| 77: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ "
| 78: str := "¤«¨­  ⨯ -¬ áᨢ  ¤®«¦­  ¡ëâì ¡®«ìè¥ ­ã«ï"
| 79: str := "®¦¨¤ «®áì 'OF' ¨«¨ ','"
| 80: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨"
| 81: str := "¡ §®¢ë© ⨯ ⨯ -㪠§ â¥«ï ¤®«¦¥­ ¡ëâì § ¯¨áìî"
| 82: str := "⨯ १ã«ìâ â  ¯à®æ¥¤ãàë ­¥ ¬®¦¥â ¡ëâì § ¯¨áìî ¨«¨ ¬ áᨢ®¬"
| 83: str := "à §¬¥à ⨯  ᫨誮¬ ¢¥«¨ª"
| 84: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ¨«¨ 'VAR'"
| 85: str := "®¦¨¤ « áì ',' ¨«¨ ':'"
| 86: str := "®¦¨¤ «®áì 'END' ¨«¨ ';'"
| 87: str := "¨¤¥­â¨ä¨ª â®à ­¥ ᮢ¯ ¤ ¥â á ¨¬¥­¥¬ ¯à®æ¥¤ãàë"
 
| 89: str := "íªá¯®àâ «®ª «ì­®£® ¨¤¥­â¨ä¨ª â®à  ­¥¤®¯ãá⨬"
| 90: str := "⨯ ARRAY ¨«¨ RECORD ­¥¤®¯ãá⨬"
| 91: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ¢¥é¥á⢥­­®£® ⨯ "
 
| 93: str := "à §¬¥à ¤ ­­ëå ᫨誮¬ ¢¥«¨ª"
| 94: str := "áâப  ¤«¨­ë, ®â«¨ç­®© ®â 1 ­¥¤®¯ãá⨬ "
| 95: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ¤®«¦­® ¡ëâì ¢ ¤¨ ¯ §®­¥ 0..127"
| 96: str := "­¥¤®¯ãá⨬®¥ ४ãàᨢ­®¥ ®¯à¥¤¥«¥­¨¥ ⨯ "
| 97: str := "­¥¤®áâ â®ç­® ¢¥é¥á⢥­­ëå ॣ¨áâ஢, ã¯à®áâ¨â¥ ¢ëà ¦¥­¨¥"
| 98: str := "®¦¨¤ «®áì 'THEN'"
| 99: str := "¯®«¥ § ¯¨á¨ ­¥ ­ ©¤¥­®"
|100: str := "¬¥âª  ¤ã¡«¨à®¢ ­ "
|101: str := "¨¤¥­â¨ä¨ª â®à ⨯  ­¥¤®¯ãá⨬ ¢ ¢ëà ¦¥­¨ïå"
|102: str := "âॡã¥âáï ¬ áᨢ"
|103: str := "®¦¨¤ «oáì 'union' ¨«¨ 'noalign'"
|104: str := "âॡã¥âáï 㪠§ â¥«ì"
|105: str := "âॡã¥âáï § ¯¨áì"
|106: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -§ ¯¨á¨"
|107: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ⨯ -㪠§ â¥«ï"
|108: str := "­¥¤®¯ãá⨬ ï ®åà ­  ⨯ "
|109: str := "®¦¨¤ « áì ']'"
|110: str := "à §¬¥à­®áâì ®âªàë⮣® ¬ áᨢ  ᫨誮¬ ¢¥«¨ª "
|111: str := "á¨á⥬­ë¥ ä« £¨ âॡãîâ ¨¬¯®àâ  ¬®¤ã«ï SYSTEM"
|112: str := "à áè¨à¥­¨¥ § ¯¨á¨ ­¥ ¬®¦¥â ¡ëâì [noalign] ¨«¨ [union]"
|113: str := "¡ §®¢ë© ⨯ § ¯¨á¨ ­¥ ¬®¦¥â ¡ëâì [noalign] ¨«¨ [union]"
|114: str := "­¥á®¢¬¥áâ¨¬ë© ¯ à ¬¥âà"
|115: str := "¯¥à¥¬¥­­ ï ¤®áâ㯭  ⮫쪮 ¤«ï ç⥭¨ï"
|116: str := "­¥«ì§ï ¨á¯®«ì§®¢ âì «®ª «ì­ãî ¯à®æ¥¤ãàã"
|117: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  BOOLEAN"
|118: str := "®¦¨¤ «®áì 'DO'"
|119: str := "®¦¨¤ «®áì 'UNTIL'"
|120: str := "®¦¨¤ «®áì ':='"
|121: str := "à áè¨à¥­¨¥ ¨¬¥­¨ ä ©«  £« ¢­®£® ¬®¤ã«ï ¤®«¦­® ¡ëâì 'ob07'"
|122: str := "§­ ç¥­¨¥ ¢ëà ¦¥­¨ï ­¥ ¬®¦¥â ¡ëâì à ¢­ë¬ ­ã«î"
|123: str := "'RETURN' ­¥¤®¯ãá⨬ ¢ ¯à®æ¥¤ãà¥, ­¥ ¢®§¢à é î饩 १ã«ìâ â"
|124: str := "®¦¨¤ «®áì 'RETURN'"
|125: str := "⨯ ¢ëà ¦¥­¨ï ­¥ ᮮ⢥âáâ¢ã¥â ⨯ã १ã«ìâ â  ¯à®æ¥¤ãàë"
|126: str := "âॡã¥âáï ¨¤¥­â¨ä¨ª â®à ¯¥à¥¬¥­­®©"
|127: str := "áç¥â稪 横«  FOR ­¥ ¤®«¦¥­ ¡ëâì ¯ à ¬¥â஬"
|128: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì INTEGER"
|129: str := "¯¥à¥¬¥­­ ï ¤®«¦­  ¡ëâì «®ª «ì­®©"
|130: str := "­¥«ì§ï ¨á¯®«ì§®¢ âì ª®­áâ ­âã"
|131: str := "­¥á®¢¬¥á⨬®áâì ¯® ¯à¨á¢ ¨¢ ­¨î"
|132: str := "¢ë§®¢ ¯à®æ¥¤ãàë-ä㭪樨 ¤®¯ã᪠¥âáï ⮫쪮 ¢ á®áâ ¢¥ ¢ëà ¦¥­¨ï"
|133: str := "¨¤¥­â¨ä¨ª â®àë 'lib_init' ¨ 'version' § à¥§¥à¢¨à®¢ ­ë"
 
|138: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì SET"
 
|141: str := "âॡã¥âáï áâப  ¨«¨ ᨬ¢®«ì­ë© ¬ áᨢ"
 
|143: str := "âॡã¥âáï ᨬ¢®«ì­ë© ¬ áᨢ"
 
|145: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì POINTER"
 
|149: str := "⨯ ¯¥à¥¬¥­­®© ¤®«¦¥­ ¡ëâì REAL ¨«¨ LONGREAL"
|150: str := "âॡã¥âáï áâப®¢ ï ª®­áâ ­â "
 
|155: str := "®¦¨¤ « áì '(' ¨«¨ ':='"
|156: str := "âॡã¥âáï ¢ëà ¦¥­¨¥ ⨯  INTEGER ¨«¨ CHAR"
|157: str := "®¦¨¤ « áì ':'"
|158: str := "­¥ ­ ©¤¥­  ¯à®æ¥¤ãà  ¢ ¬®¤ã«¥ RTL"
|159: str := "­ àã襭¨¥ £à ­¨æ ¬ áᨢ "
|160: str := "®¦¨¤ «áï ¨¤¥­â¨ä¨ª â®à ª®­áâ ­âë"
|161: str := "âॡã¥âáï ª®­áâ ­â  â¨¯  INTEGER"
END;
IF H.OS = "LNX" THEN
Utf8(str)
END;
COPY(str, msg)
END ErrorMsg;
 
BEGIN
InitCP866(cp)
END ERRORS.
/programs/develop/oberon07/Source/SCAN.ob07
0,0 → 1,699
(*
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 SCAN;
 
IMPORT UTILS, sys := SYSTEM;
 
CONST
 
Tab = 8;
maxINT* = 7FFFFFFFH;
minINT* = 80000000H;
maxREAL* = 3.39E38;
maxDBL* = 1.69D308;
minREAL* = 1.41E-45;
IDLENGTH = 255;
STRLENGTH* = 256;
 
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;
 
TYPE
 
TCoord* = RECORD line*, col*: INTEGER END;
 
NODE* = POINTER TO RECORD
Left, Right: NODE;
tLex: INTEGER;
Name*: UTILS.STRING
END;
 
SCANNER* = POINTER TO RECORD
File, ccol, cline, count, tLex, vINT: INTEGER;
coord: TCoord;
ch, vCHX: CHAR;
Lex: UTILS.STRING;
vFLT: LONGREAL;
id: NODE;
buf, bufpos: INTEGER;
CR, UTF8: BOOLEAN
END;
 
VAR
 
Lex*: UTILS.STRING; File, ccol, cline, count*, tLex*, vINT*: INTEGER;
coord*: TCoord;
vFLT*: LONGREAL; id*: NODE; ch, vCHX*: CHAR;
buf, bufpos: INTEGER; CR, UTF8: BOOLEAN;
Nodes: ARRAY 256 OF NODE;
_START*, _version*: NODE;
 
PROCEDURE AddNode*(Name: UTILS.STRING): NODE;
VAR cur, res: NODE;
 
PROCEDURE NewNode(Right: BOOLEAN);
BEGIN
NEW(res);
UTILS.MemErr(res = NIL);
res.Name := Name;
res.tLex := lxIDENT;
res.Left := NIL;
res.Right := NIL;
IF Right THEN
cur.Right := res
ELSE
cur.Left := res
END
END NewNode;
 
BEGIN
res := NIL;
cur := Nodes[ORD(Name[0])];
REPEAT
IF Name > cur.Name THEN
IF cur.Right # NIL THEN
cur := cur.Right
ELSE
NewNode(TRUE)
END
ELSIF Name < cur.Name THEN
IF cur.Left # NIL THEN
cur := cur.Left
ELSE
NewNode(FALSE)
END
ELSE
res := cur
END
UNTIL res # NIL
RETURN res
END AddNode;
 
PROCEDURE Backup*(scanner: SCANNER);
BEGIN
scanner.File := File;
scanner.ccol := ccol;
scanner.cline := cline;
scanner.ch := ch;
scanner.Lex := Lex;
scanner.count := count;
scanner.coord := coord;
scanner.tLex := tLex;
scanner.vINT := vINT;
scanner.vFLT := vFLT;
scanner.vCHX := vCHX;
scanner.buf := buf;
scanner.bufpos := bufpos;
scanner.CR := CR;
scanner.UTF8 := UTF8
END Backup;
 
PROCEDURE Recover*(scanner: SCANNER);
BEGIN
File := scanner.File;
ccol := scanner.ccol;
cline := scanner.cline;
ch := scanner.ch;
Lex := scanner.Lex;
count := scanner.count;
coord := scanner.coord;
tLex := scanner.tLex;
vINT := scanner.vINT;
vFLT := scanner.vFLT;
vCHX := scanner.vCHX;
buf := scanner.buf;
bufpos := scanner.bufpos;
CR := scanner.CR;
UTF8 := scanner.UTF8
END Recover;
 
PROCEDURE Next;
VAR cr: BOOLEAN;
BEGIN
cr := FALSE;
sys.GET(bufpos, ch);
INC(ccol);
CASE ch OF
|0AX: IF ~CR THEN INC(cline) END; ccol := 0
|0DX: INC(cline); ccol := 0; cr := TRUE
|09X: DEC(ccol); ccol := (ccol DIV Tab) * Tab + Tab
|80X..0BFX: IF UTF8 THEN DEC(ccol) END
ELSE
END;
CR := cr;
INC(bufpos)
END Next;
 
PROCEDURE Open*(FName: ARRAY OF CHAR; VAR FHandle: INTEGER): BOOLEAN;
VAR n, size: INTEGER; c: CHAR;
BEGIN
File := UTILS.OpenF(FName);
FHandle := File;
IF File # 0 THEN
CR := FALSE;
UTF8 := FALSE;
ccol := 0;
cline := 1;
ch := 0X;
size := UTILS.FileSize(File);
buf := UTILS.GetMem(size + 1024);
UTILS.MemErr(buf = 0);
sys.PUT(buf + size, 0X);
n := UTILS.Read(File, buf, size);
UTILS.CloseF(File);
bufpos := buf;
sys.GET(buf, c);
IF c = 0EFX THEN
sys.GET(buf + 1, c);
IF c = 0BBX THEN
sys.GET(buf + 2, c);
IF c = 0BFX THEN
INC(bufpos, 3);
UTF8 := TRUE
END
END
END;
Next
END
RETURN (File # 0) & (n = size)
END Open;
 
PROCEDURE Space(ch: CHAR): BOOLEAN;
RETURN (ch <= 20X) & (ch > 0X)
END Space;
 
PROCEDURE Letter(ch: CHAR): BOOLEAN;
RETURN (ch >= "A") & (ch <= "Z") OR (ch >= "a") & (ch <= "z") OR (ch = "_")
END Letter;
 
PROCEDURE Digit*(ch: CHAR): BOOLEAN;
RETURN (ch >= "0") & (ch <= "9")
END Digit;
 
PROCEDURE HexDigit*(ch: CHAR): BOOLEAN;
RETURN (ch >= "A") & (ch <= "F") OR (ch >= "0") & (ch <= "9")
END HexDigit;
 
PROCEDURE PutChar(ch: CHAR);
BEGIN
Lex[count] := ch;
IF ch # 0X THEN
INC(count)
END
END PutChar;
 
PROCEDURE PutNext(ch: CHAR);
BEGIN
PutChar(ch);
Next
END PutNext;
 
PROCEDURE Ident;
BEGIN
tLex := lxIDENT;
WHILE Letter(ch) OR Digit(ch) DO
PutNext(ch)
END;
PutChar(0X);
IF count > IDLENGTH THEN
tLex := lxERR10
END
END Ident;
 
PROCEDURE hex*(ch: CHAR): INTEGER;
VAR Res: INTEGER;
BEGIN
Res := ORD(ch);
CASE ch OF
|"0".."9": DEC(Res, ORD("0"))
|"A".."F": DEC(Res, ORD("A") - 10)
ELSE
END
RETURN Res
END hex;
 
PROCEDURE StrToInt16(str: UTILS.STRING): INTEGER;
VAR i, res, n: INTEGER; flag: BOOLEAN;
BEGIN
res := 0;
i := 0;
n := 0;
WHILE str[i] = "0" DO
INC(i)
END;
flag := TRUE;
WHILE flag & (str[i] # "X") & (str[i] # "H") DO
INC(n);
IF n > 8 THEN
tLex := lxERR5;
flag := FALSE
ELSE
res := LSL(res, 4) + hex(str[i]);
INC(i)
END
END
RETURN res
END StrToInt16;
 
PROCEDURE StrToChx(str: UTILS.STRING): CHAR;
VAR res: INTEGER;
BEGIN
res := StrToInt16(str);
IF (res < 0) OR (res > 0FFH) THEN
tLex := lxERR6;
res := 0
END
RETURN CHR(res)
END StrToChx;
 
PROCEDURE StrToInt*(str: UTILS.STRING): INTEGER;
VAR i, res: INTEGER; flag: BOOLEAN;
BEGIN
res := 0;
i := 0;
flag := TRUE;
WHILE flag & (str[i] # 0X) DO
IF res > maxINT DIV 10 THEN
tLex := lxERR5;
flag := FALSE;
res := 0
ELSE
res := res * 10;
IF res > maxINT - (ORD(str[i]) - ORD("0")) THEN
tLex := lxERR5;
flag := FALSE;
res := 0
ELSE
res := res + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN res
END StrToInt;
 
PROCEDURE StrToFloat(str: UTILS.STRING): LONGREAL;
VAR i, scale: INTEGER; res, m, d: LONGREAL; minus, nez: BOOLEAN;
 
PROCEDURE Error(e: INTEGER; VAR cont: BOOLEAN);
BEGIN
tLex := e;
res := 0.0D0;
cont := FALSE
END Error;
 
PROCEDURE Inf(VAR cont: BOOLEAN; VAR i: INTEGER);
BEGIN
IF UTILS.IsInf(res) THEN
Error(lxERR7, cont)
END;
INC(i)
END Inf;
 
PROCEDURE part1(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
res := 0.0D0;
i := 0;
d := 1.0D0;
nez := FALSE;
cont := TRUE;
WHILE cont & Digit(str[i]) DO
nez := nez OR (str[i] # "0");
res := res * 10.0D0 + LONG(FLT(ORD(str[i]) - ORD("0")));
Inf(cont, i)
END
RETURN cont
END part1;
 
PROCEDURE part2(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
INC(i);
cont := TRUE;
WHILE cont & Digit(str[i]) DO
nez := nez OR (str[i] # "0");
d := d / 10.0D0;
res := res + LONG(FLT(ORD(str[i]) - ORD("0"))) * d;
Inf(cont, i)
END
RETURN cont
END part2;
 
PROCEDURE part3(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
cont := TRUE;
IF str[i] = 0X THEN
IF res > LONG(maxREAL) THEN
Error(lxERR7, cont)
ELSIF nez & ((res = 0.0D0) OR (res < LONG(minREAL)) & (tLex = lxREAL)) THEN
Error(lxERR9, cont)
END
END
RETURN cont
END part3;
 
PROCEDURE part4(): BOOLEAN;
VAR cont: BOOLEAN;
BEGIN
IF str[i] = "D" THEN
tLex := lxLONGREAL
END;
INC(i);
m := 10.0D0;
minus := FALSE;
IF str[i] = "+" THEN
INC(i)
ELSIF str[i] = "-" THEN
minus := TRUE;
INC(i);
m := 0.1D0
END;
scale := 0;
cont := TRUE;
WHILE cont & Digit(str[i]) DO
IF scale > maxINT DIV 10 THEN
Error(lxERR8, cont)
ELSE
scale := scale * 10;
IF scale > maxINT - (ORD(str[i]) - ORD("0")) THEN
Error(lxERR8, cont)
ELSE
scale := scale + (ORD(str[i]) - ORD("0"));
INC(i)
END
END
END
RETURN cont
END part4;
 
PROCEDURE part5(): BOOLEAN;
VAR cont: BOOLEAN; i: INTEGER;
BEGIN
cont := TRUE;
IF scale = maxINT THEN
Error(lxERR8, cont)
END;
i := 1;
WHILE cont & (i <= scale) DO
res := res * m;
Inf(cont, i)
END;
IF cont & (nez & (res = 0.0D0) OR (res > 0.0D0) & (res < LONG(minREAL)) & (tLex = lxREAL)) THEN
Error(lxERR9, cont)
ELSIF cont & (tLex = lxREAL) & (res > LONG(maxREAL)) THEN
Error(lxERR7, cont)
END
RETURN cont
END part5;
 
BEGIN
IF part1() & part2() & part3() & part4() & part5() THEN END
RETURN res
END StrToFloat;
 
PROCEDURE Number;
VAR nextchr: CHAR;
BEGIN
tLex := lxINT;
WHILE Digit(ch) DO
PutNext(ch)
END;
IF ch = "H" THEN
tLex := lxHEX
ELSIF ch = "X" THEN
tLex := lxCHX
END;
IF tLex # lxINT THEN
PutNext(ch)
ELSE
WHILE HexDigit(ch) DO
tLex := lxHEX;
PutNext(ch)
END;
IF tLex = lxHEX THEN
IF ch = "H" THEN
PutNext(ch)
ELSIF ch = "X" THEN
tLex := lxCHX;
PutNext(ch)
ELSE
tLex := lxERR1
END
ELSIF ch = "." THEN
sys.GET(bufpos, nextchr);
IF nextchr # "." THEN
tLex := lxREAL;
PutNext(ch);
WHILE Digit(ch) DO
PutNext(ch)
END;
IF (ch = "E") OR (ch = "D") THEN
PutNext(ch);
IF (ch = "+") OR (ch = "-") THEN
PutNext(ch)
END;
IF ~Digit(ch) THEN
tLex := lxERR2
ELSE
WHILE Digit(ch) DO
PutNext(ch)
END
END
END
END
END
END;
PutChar(0X)
END Number;
 
PROCEDURE Delim(ch: CHAR): INTEGER;
VAR Res: INTEGER;
BEGIN
CASE ch OF
|"+": Res := lxPlus
|"-": Res := lxMinus
|"*": Res := lxMult
|"/": Res := lxSlash
|"~": Res := lxNot
|"&": Res := lxAnd
|",": Res := lxComma
|";": Res := lxSemi
|"|": Res := lxStick
|"[": Res := lxLSquare
|"{": Res := lxLCurly
|"^": Res := lxCaret
|"=": Res := lxEQ
|"#": Res := lxNE
|")": Res := lxRRound
|"]": Res := lxRSquare
|"}": Res := lxRCurly
|">": Res := lxGT
|"<": Res := lxLT
|":": Res := lxColon
ELSE
END
RETURN Res
END Delim;
 
PROCEDURE Comment;
VAR c, level: INTEGER; cont: BOOLEAN;
BEGIN
c := 1;
level := 1;
cont := TRUE;
WHILE cont & (level > 0) DO
Next;
CASE ch OF
|"(": c := 2
|")": IF c = 3 THEN DEC(level) END; c := 1
|"*": IF c = 2 THEN INC(level); c := 1 ELSE c := 3 END
|0X : cont := FALSE
ELSE
c := 1
END;
END;
IF cont THEN
Next
END
END Comment;
 
PROCEDURE GetLex*;
BEGIN
WHILE Space(ch) DO
Next
END;
coord.col := ccol;
coord.line := cline;
count := 0;
CASE ch OF
|"A".."Z", "a".."z", "_":
Ident;
id := AddNode(Lex);
tLex := id.tLex;
|"0".."9":
Number;
CASE tLex OF
|lxINT: vINT := StrToInt(Lex)
|lxHEX: vINT := StrToInt16(Lex)
|lxCHX: vCHX := StrToChx(Lex)
|lxREAL: vFLT := StrToFloat(Lex)
ELSE
END
|22X:
tLex := lxSTRING;
Next;
WHILE (ch # 22X) & (ch >= 20X) DO
PutNext(ch)
END;
IF ch = 22X THEN
Next
ELSE
tLex := lxERR3
END;
PutChar(0X);
INC(count);
IF count > STRLENGTH THEN
tLex := lxERR11
END
|"/":
tLex := Delim(ch);
PutNext(ch);
IF ch = "/" THEN
WHILE (ch >= 20X) OR (ch = 9X) DO
PutNext(ch)
END;
GetLex
END;
PutChar(0X)
|">", "<", ":":
tLex := Delim(ch);
PutNext(ch);
IF ch = "=" THEN
CASE tLex OF
|lxLT: tLex := lxLE
|lxGT: tLex := lxGE
|lxColon: tLex := lxAssign
ELSE
END;
PutNext(ch)
END;
PutChar(0X)
|".":
tLex := lxDot;
PutNext(ch);
IF ch = "." THEN
tLex := lxDbl;
PutNext(ch)
END;
PutChar(0X)
|"(":
tLex := lxLRound;
PutNext(ch);
IF ch = "*" THEN
Comment;
GetLex
END;
PutChar(0X)
|"+", "-", "*", "~", "&", ",", ";", "|",
"[", "{", "^", "=", "#", ")", "]", "}":
tLex := Delim(ch);
PutChar(ch);
PutNext(0X)
|0X:
tLex := lxEOF;
PutChar(0X)
ELSE
tLex := lxERR4
END
END GetLex;
 
PROCEDURE AddNodeKey(Name: UTILS.STRING; key: INTEGER);
VAR node: NODE;
BEGIN
node := AddNode(Name);
node.tLex := key
END AddNodeKey;
 
PROCEDURE Init;
VAR i: INTEGER; node: NODE;
BEGIN
FOR i := 0 TO LEN(Nodes) - 1 DO
NEW(node);
UTILS.MemErr(node = NIL);
sys.PUT(sys.ADR(node.Name), i);
node.Left := NIL;
node.Right := NIL;
node.tLex := lxIDENT;
Nodes[i] := node
END;
_START := AddNode("lib_init");
_version := AddNode("version");
AddNodeKey("MOD", lxMOD);
AddNodeKey("ELSE", lxELSE);
AddNodeKey("RETURN", lxRETURN);
AddNodeKey("CASE", lxCASE);
AddNodeKey("IF", lxIF);
AddNodeKey("POINTER", lxPOINTER);
AddNodeKey("TYPE", lxTYPE);
AddNodeKey("BEGIN", lxBEGIN);
AddNodeKey("DIV", lxDIV);
AddNodeKey("FALSE", lxFALSE);
AddNodeKey("IN", lxIN);
AddNodeKey("NIL", lxNIL);
AddNodeKey("RECORD", lxRECORD);
AddNodeKey("TO", lxTO);
AddNodeKey("VAR", lxVAR);
AddNodeKey("ARRAY", lxARRAY);
AddNodeKey("DO", lxDO);
AddNodeKey("END", lxEND);
AddNodeKey("IS", lxIS);
AddNodeKey("OF", lxOF);
AddNodeKey("PROCEDURE", lxPROCEDURE);
AddNodeKey("THEN", lxTHEN);
AddNodeKey("WHILE", lxWHILE);
AddNodeKey("BY", lxBY);
AddNodeKey("CONST", lxCONST);
AddNodeKey("ELSIF", lxELSIF);
AddNodeKey("IMPORT", lxIMPORT);
AddNodeKey("MODULE", lxMODULE);
AddNodeKey("OR", lxOR);
AddNodeKey("REPEAT", lxREPEAT);
AddNodeKey("TRUE", lxTRUE);
AddNodeKey("UNTIL", lxUNTIL);
AddNodeKey("FOR", lxFOR)
END Init;
 
BEGIN
Init
END SCAN.
/programs/develop/oberon07/Source/UTILS.ob07
0,0 → 1,426
(*
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 UTILS;
 
IMPORT sys := SYSTEM, H := HOST, ERRORS;
 
CONST
 
OS* = H.OS;
Slash* = H.Slash;
Ext* = ".ob07";
MAX_PATH = 1024;
MAX_PARAM = 1024;
Date* = 1451606400; (* 2016-01-01 *)
 
TYPE
 
STRING* = ARRAY MAX_PATH OF CHAR;
 
ITEM* = POINTER TO rITEM;
 
rITEM* = RECORD
Next*, Prev*: ITEM
END;
 
LIST* = POINTER TO RECORD
First*, Last*: ITEM;
Count*: INTEGER
END;
 
STRCONST* = POINTER TO RECORD (rITEM)
Str*: STRING;
Len*, Number*: INTEGER
END;
 
VAR
 
Params: ARRAY MAX_PARAM, 2 OF INTEGER;
ParamCount*, Line*, Unit*: INTEGER;
FileName: STRING;
 
PROCEDURE SetFile*(F: STRING);
BEGIN
FileName := F
END SetFile;
 
PROCEDURE IsInf*(x: LONGREAL): BOOLEAN;
RETURN ABS(x) = sys.INF(LONGREAL)
END IsInf;
 
PROCEDURE GetChar(adr: INTEGER): CHAR;
VAR res: CHAR;
BEGIN
sys.GET(adr, res)
RETURN res
END GetChar;
 
PROCEDURE ParamParse(count: INTEGER);
VAR c: CHAR; cond, p: INTEGER;
 
PROCEDURE ChangeCond(A, B, C: INTEGER);
BEGIN
cond := C;
CASE c OF
|0X: cond := 6
|1X..20X: cond := A
|22X: cond := B
ELSE
END
END ChangeCond;
 
BEGIN
p := H.GetCommandLine();
cond := 0;
WHILE (count < MAX_PARAM) & (cond # 6) DO
c := GetChar(p);
CASE cond OF
|0: ChangeCond(0, 4, 1); IF cond = 1 THEN Params[count, 0] := p END
|4: ChangeCond(5, 0, 5); IF cond = 5 THEN Params[count, 0] := p END
|1: ChangeCond(0, 3, 1); IF cond IN {0, 6} THEN Params[count, 1] := p - 1; INC(count) END
|3, 5: ChangeCond(cond, 1, cond); IF cond = 6 THEN Params[count, 1] := p - 1; INC(count) END
ELSE
END;
INC(p)
END;
ParamCount := count - 1
END ParamParse;
 
PROCEDURE ParamStr*(VAR str: ARRAY OF CHAR; n: INTEGER);
VAR i, j, len: INTEGER; c: CHAR;
BEGIN
j := 0;
IF n <= ParamCount THEN
len := LEN(str) - 1;
i := Params[n, 0];
WHILE (j < len) & (i <= Params[n, 1]) DO
c := GetChar(i);
IF c # 22X THEN
str[j] := c;
INC(j)
END;
INC(i)
END
END;
str[j] := 0X
END ParamStr;
 
PROCEDURE GetMem*(n: INTEGER): INTEGER;
RETURN H.malloc(n)
END GetMem;
 
PROCEDURE CloseF*(F: INTEGER);
BEGIN
H.CloseFile(F)
END CloseF;
 
PROCEDURE Read*(F, Buffer, Count: INTEGER): INTEGER;
RETURN H.FileRW(F, Buffer, Count, FALSE)
END Read;
 
PROCEDURE Write*(F, Buffer, Count: INTEGER): INTEGER;
RETURN H.FileRW(F, Buffer, Count, TRUE)
END Write;
 
PROCEDURE FileSize*(F: INTEGER): INTEGER;
RETURN H.FileSize(F)
END FileSize;
 
PROCEDURE CharC*(x: CHAR);
VAR str: ARRAY 2 OF CHAR;
BEGIN
str[0] := x;
str[1] := 0X;
H.OutString(str)
END CharC;
 
PROCEDURE Int*(x: INTEGER);
VAR i: INTEGER; buf: ARRAY 11 OF INTEGER;
BEGIN
i := 0;
REPEAT
buf[i] := x MOD 10;
x := x DIV 10;
INC(i)
UNTIL x = 0;
REPEAT
DEC(i);
CharC(CHR(buf[i] + ORD("0")))
UNTIL i = 0
END Int;
 
PROCEDURE Ln*;
BEGIN
CharC(0DX);
CharC(0AX)
END Ln;
 
PROCEDURE OutString*(str: ARRAY OF CHAR);
BEGIN
H.OutString(str)
END OutString;
 
PROCEDURE ErrMsg*(code: INTEGER);
VAR str: ARRAY 1024 OF CHAR;
BEGIN
ERRORS.ErrorMsg(code, str);
OutString("error: ("); Int(code); OutString(") "); OutString(str); Ln
END ErrMsg;
 
PROCEDURE ErrMsgPos*(line, col, code: INTEGER);
VAR s: STRING;
BEGIN
ErrMsg(code);
OutString("file: "); OutString(FileName); Ln;
OutString("line: "); Int(line); Ln;
OutString("pos: "); Int(col); Ln;
END ErrMsgPos;
 
PROCEDURE UnitLine*(newUnit, newLine: INTEGER);
BEGIN
Unit := newUnit;
Line := newLine
END UnitLine;
 
PROCEDURE min*(a, b: INTEGER): INTEGER;
BEGIN
IF a > b THEN
a := b
END
RETURN a
END min;
 
PROCEDURE Align*(n: INTEGER): INTEGER;
RETURN (4 - n MOD 4) MOD 4
END Align;
 
PROCEDURE CAP(x: CHAR): CHAR;
BEGIN
IF (x >= "a") & (x <= "z") THEN
x := CHR(ORD(x) - 32)
END
RETURN x
END CAP;
 
PROCEDURE streq*(a, b: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := -1;
REPEAT
INC(i)
UNTIL (CAP(a[i]) # CAP(b[i])) OR (a[i] = 0X) OR (b[i] = 0X)
RETURN a[i] = b[i]
END streq;
 
PROCEDURE concat*(VAR L: STRING; R: STRING);
VAR i, n, pos: INTEGER;
BEGIN
n := LENGTH(R);
i := 0;
pos := LENGTH(L);
WHILE (i <= n) & (pos < LEN(L)) DO
L[pos] := R[i];
INC(pos);
INC(i)
END
END concat;
 
PROCEDURE GetStr*(this: LIST; str: STRING): STRCONST;
VAR res: STRCONST;
BEGIN
res := this.First(STRCONST);
WHILE (res # NIL) & (res.Str # str) DO
res := res.Next(STRCONST)
END
RETURN res
END GetStr;
 
PROCEDURE Push*(this: LIST; item: ITEM);
BEGIN
IF this.Count = 0 THEN
this.First := item;
item.Prev := NIL
ELSE
this.Last.Next := item;
item.Prev := this.Last
END;
INC(this.Count);
this.Last := item;
item.Next := NIL
END Push;
 
PROCEDURE Insert*(this: LIST; item, prev: ITEM);
BEGIN
IF prev # this.Last THEN
item.Next := prev.Next;
item.Prev := prev;
prev.Next := item;
item.Next.Prev := item;
INC(this.Count)
ELSE
Push(this, item)
END
END Insert;
 
PROCEDURE Clear*(this: LIST);
BEGIN
this.First := NIL;
this.Last := NIL;
this.Count := 0
END Clear;
 
PROCEDURE Revers(VAR str: STRING);
VAR a, b: INTEGER; c: CHAR;
BEGIN
a := 0;
b := LENGTH(str) - 1;
WHILE a < b DO
c := str[a];
str[a] := str[b];
str[b] := c;
INC(a);
DEC(b)
END
END Revers;
 
PROCEDURE Split*(FName: STRING; VAR Path, Name, Ext: STRING);
VAR i, j, k: INTEGER;
BEGIN
i := LENGTH(FName) - 1;
j := 0;
WHILE (i >= 0) & (FName[i] # Slash) DO
Name[j] := FName[i];
DEC(i);
INC(j)
END;
Name[j] := 0X;
Revers(Name);
j := 0;
k := LENGTH(Name) - 1;
WHILE (k >= 0) & (Name[k] # ".") DO
Ext[j] := Name[k];
DEC(k);
INC(j)
END;
IF k >= 0 THEN
Name[k] := 0X;
Ext[j] := ".";
INC(j)
ELSE
j := 0
END;
Ext[j] := 0X;
Revers(Ext);
FOR j := 0 TO i DO
Path[j] := FName[j]
END;
Path[i + 1] := 0X
END Split;
PROCEDURE LinuxParam;
VAR p, i, str: INTEGER; c: CHAR;
BEGIN
p := H.GetCommandLine();
sys.GET(p, ParamCount);
sys.GET(p + 4, p);
FOR i := 0 TO ParamCount - 1 DO
sys.GET(p + i * 4, str);
Params[i, 0] := str;
REPEAT
sys.GET(str, c);
INC(str)
UNTIL c = 0X;
Params[i, 1] := str - 1
END;
DEC(ParamCount)
END LinuxParam;
 
PROCEDURE Time*;
VAR sec, dsec: INTEGER;
BEGIN
OutString("elapsed time ");
H.Time(sec, dsec);
sec := sec - H.sec;
dsec := dsec - H.dsec;
dsec := dsec + sec * 100;
Int(dsec DIV 100); CharC(".");
dsec := dsec MOD 100;
IF dsec < 10 THEN
Int(0)
END;
Int(dsec); OutString(" sec"); Ln
END Time;
 
PROCEDURE HALT*(n: INTEGER);
BEGIN
Time;
H.ExitProcess(n)
END HALT;
 
PROCEDURE MemErr*(err: BOOLEAN);
BEGIN
IF err THEN
ErrMsg(72);
HALT(1)
END
END MemErr;
 
PROCEDURE CreateList*(): LIST;
VAR nov: LIST;
BEGIN
NEW(nov);
MemErr(nov = NIL)
RETURN nov
END CreateList;
 
PROCEDURE CreateF*(FName: ARRAY OF CHAR): INTEGER;
RETURN H.CreateFile(FName)
END CreateF;
 
PROCEDURE OpenF*(FName: ARRAY OF CHAR(*; Mode: INTEGER*)): INTEGER;
RETURN H.OpenFile(FName)
END OpenF;
 
PROCEDURE Init;
VAR p: INTEGER;
 
PROCEDURE last(VAR p: INTEGER);
BEGIN
WHILE GetChar(p) # 0X DO INC(p) END;
DEC(p)
END last;
 
BEGIN
H.init;
IF OS = "WIN" THEN
ParamParse(0)
ELSIF OS = "KOS" THEN
ParamParse(1);
Params[0, 0] := H.GetName();
Params[0, 1] := Params[0, 0];
last(Params[0, 1])
ELSIF OS = "LNX" THEN
LinuxParam
END
END Init;
 
BEGIN
Init
END UTILS.
/programs/develop/oberon07/Source/X86.ob07
0,0 → 1,1986
(*
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 X86;
 
IMPORT UTILS, sys := SYSTEM, SCAN, ELF;
 
CONST
 
ADIM* = 5;
 
lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54;
lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
 
TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7;
TNIL = 8; TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14;
 
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; stFABS* = 23; stINC1* = 24;
stDEC1* = 25; stASSERT1* = 26; stUNPK1* = 27; stPACK1* = 28; stLSR* = 29;
stLENGTH* = 30;
 
sysMOVE* = 108;
 
JMP* = 0E9X; CALL = 0E8X;
JE = 84X; JNE = 85X; JLE = 8EX; JGE = 8DX; JG = 8FX; JL = 8CX;
 
JCMD = 1; LCMD = 2; GCMD = 3; OCMD = 4; ECMD = 5;
PUSHEAX = 6; PUSHECX = 7; PUSHEDX = 8; POPEAX = 9; POPECX = 10; POPEDX = 11;
ICMP1 = 13; ICMP2 = 14;
 
defcall = 0; stdcall = 1; cdecl = 2; winapi = 3;
 
_rset* = 0; _inset* = 1; _saverec* = 2; _length* = 3; _checktype* = 4; _strcmp* = 5;
_lstrcmp* = 6; _rstrcmp* = 7; _savearr* = 8; _newrec* = 9; _disprec* = 10; _arrayidx* = 11;
_arrayrot* = 12; _assrt* = 13; _strcopy* = 14; _arrayidx1* = 15; _init* = 16; _close* = 17; _halt* = 18;
ASSRT = 19; hInstance = 20; SELFNAME = 21; RTABLE = 22;LoadLibrary = 23; GetProcAddress = 24;
Exports = 25; szSTART = 26; START = 27; szversion = 28; _floor = 29; HALT = 30;
 
FREGS = 8;
 
TYPE
 
ASMLINE* = POINTER TO RECORD (UTILS.rITEM)
cmd, clen, varadr, adr, tcmd, codeadr: INTEGER; short: BOOLEAN
END;
 
TFLT = ARRAY 2 OF INTEGER;
 
TIDX* = ARRAY ADIM OF INTEGER;
 
SECTIONNAME = ARRAY 8 OF CHAR;
 
SECTION = RECORD
name: SECTIONNAME;
size, adr, sizealign, OAPfile, reserved6, reserved7, reserved8, attrflags: INTEGER
END;
 
HEADER = RECORD
msdos: ARRAY 180 OF CHAR;
typecomp, seccount: sys.CARD16;
time, reserved1, reserved2: INTEGER;
PEoptsize, infflags, PEfile, compver: sys.CARD16;
codesize, datasize, initdatasize, startadr,
codeadr, rdataadr, loadadr, secalign, filealign,
oldestver, version, oldestverNT, reserved3,
filesize, headersize, dllcrc: INTEGER;
UI, reserved4: sys.CARD16;
stksize, stkalloc, heapsize, heapalloc, reserved5, structcount: INTEGER;
structs: ARRAY 16 OF RECORD adr, size: INTEGER END;
sections: ARRAY 3 OF SECTION
END;
 
COFFHEADER = RECORD
Machine: sys.CARD16;
NumberOfSections: sys.CARD16;
TimeDateStamp,
PointerToSymbolTable,
NumberOfSymbols: INTEGER;
SizeOfOptionalHeader,
Characteristics: sys.CARD16;
text, data, bss: SECTION
END;
 
KOSHEADER = RECORD
menuet01: ARRAY 8 OF CHAR;
ver, start, size, mem, sp, param, path: INTEGER
END;
 
ETABLE = RECORD
reserved1, time, reserved2, dllnameoffset, firstnum, adrcount,
namecount, arradroffset, arrnameptroffset, arrnumoffset: INTEGER;
arradr, arrnameptr: ARRAY 10000H OF INTEGER;
arrnum: ARRAY 10000H OF sys.CARD16;
text: ARRAY 1000000 OF CHAR;
textlen, size: INTEGER
END;
 
RELOC = RECORD
Page, Size: INTEGER;
reloc: ARRAY 1024 OF sys.CARD16
END;
 
VAR asmlist: UTILS.LIST; start: ASMLINE; dll, con, gui, kos, elf, obj: BOOLEAN;
Lcount, reccount, topstk: INTEGER; recarray: ARRAY 2048 OF INTEGER; current*: ASMLINE;
callstk: ARRAY 1024, 2 OF ASMLINE; OutFile: UTILS.STRING;
Code: ARRAY 4000000 OF CHAR; ccount: INTEGER; Data: ARRAY 1000000 OF CHAR; dcount: INTEGER;
Labels: ARRAY 200000 OF INTEGER; rdata: ARRAY 400H OF INTEGER; Header: HEADER; etable: ETABLE;
ExecName: UTILS.STRING; LoadAdr: INTEGER; Reloc: ARRAY 200000 OF CHAR; rcount: INTEGER;
RtlProc: ARRAY 20 OF INTEGER; OutFilePos: INTEGER; RelocSection: SECTION;
fpu*: INTEGER; isfpu: BOOLEAN; maxfpu: INTEGER; fpucmd: ASMLINE;
kosexp: ARRAY 65536 OF RECORD Name: SCAN.NODE; Adr, NameLabel: INTEGER END; kosexpcount: INTEGER;
 
PROCEDURE AddRtlProc*(idx, proc: INTEGER);
BEGIN
RtlProc[idx] := proc
END AddRtlProc;
 
PROCEDURE IntToCard16(i: INTEGER): sys.CARD16;
VAR w: sys.CARD16;
BEGIN
sys.GET(sys.ADR(i), w)
RETURN w
END IntToCard16;
 
PROCEDURE CopyStr(VAR Dest: ARRAY OF CHAR; Source: ARRAY OF CHAR; VAR di: INTEGER; si: INTEGER);
BEGIN
DEC(di);
REPEAT
INC(di);
Dest[di] := Source[si];
INC(si)
UNTIL Dest[di] = 0X
END CopyStr;
 
PROCEDURE exch(VAR a, b: INTEGER);
VAR c: INTEGER;
BEGIN
c := a;
a := b;
b := c
END exch;
 
PROCEDURE Sort(VAR NamePtr, Adr: ARRAY OF INTEGER; Text: ARRAY OF CHAR; LB, RB: INTEGER);
VAR L, R: INTEGER;
 
PROCEDURE strle(s1, s2: INTEGER): BOOLEAN;
VAR S1, S2: ARRAY 256 OF CHAR; i: INTEGER;
BEGIN
i := 0;
CopyStr(S1, Text, i, s1);
i := 0;
CopyStr(S2, Text, i, s2)
RETURN S1 <= S2
END strle;
 
BEGIN
IF LB < RB THEN
L := LB;
R := RB;
REPEAT
WHILE (L < RB) & strle(NamePtr[L], NamePtr[LB]) DO
INC(L)
END;
WHILE (R > LB) & strle(NamePtr[LB], NamePtr[R]) DO
DEC(R)
END;
IF L < R THEN
exch(NamePtr[L], NamePtr[R]);
exch(Adr[L], Adr[R])
END
UNTIL L >= R;
IF R > LB THEN
exch(NamePtr[LB], NamePtr[R]);
exch(Adr[LB], Adr[R]);
Sort(NamePtr, Adr, Text, LB, R - 1)
END;
Sort(NamePtr, Adr, Text, R + 1, RB)
END
END Sort;
 
PROCEDURE PackExport(Name: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN
Sort(etable.arrnameptr, etable.arradr, etable.text, 0, etable.namecount - 1);
FOR i := 0 TO etable.namecount - 1 DO
etable.arrnum[i] := IntToCard16(i)
END;
etable.size := 40 + etable.adrcount * 4 + etable.namecount * 6;
etable.arradroffset := 40;
etable.arrnameptroffset := 40 + etable.adrcount * 4;
etable.arrnumoffset := etable.arrnameptroffset + etable.namecount * 4;
etable.dllnameoffset := etable.size + etable.textlen;
CopyStr(etable.text, Name, etable.textlen, 0);
INC(etable.textlen);
FOR i := 0 TO etable.namecount - 1 DO
etable.arrnameptr[i] := etable.arrnameptr[i] + etable.size
END;
etable.size := etable.size + etable.textlen
END PackExport;
 
PROCEDURE ProcExport*(Number: INTEGER; Name: SCAN.NODE; NameLabel: INTEGER);
BEGIN
IF dll THEN
etable.arradr[etable.adrcount] := Number;
INC(etable.adrcount);
etable.arrnameptr[etable.namecount] := etable.textlen;
INC(etable.namecount);
CopyStr(etable.text, Name.Name, etable.textlen, 0);
INC(etable.textlen)
ELSIF obj THEN
kosexp[kosexpcount].Name := Name;
kosexp[kosexpcount].Adr := Number;
kosexp[kosexpcount].NameLabel := NameLabel;
INC(kosexpcount)
END
END ProcExport;
 
PROCEDURE Err(code: INTEGER);
BEGIN
CASE code OF
|1: UTILS.ErrMsg(67); UTILS.OutString(OutFile)
|2: UTILS.ErrMsg(69); UTILS.OutString(OutFile)
ELSE
END;
UTILS.Ln;
UTILS.HALT(1)
END Err;
 
PROCEDURE Align*(n, m: INTEGER): INTEGER;
RETURN n + (m - n MOD m) MOD m
END Align;
 
PROCEDURE PutReloc(R: RELOC);
VAR i: INTEGER;
BEGIN
sys.PUT(sys.ADR(Reloc[rcount]), R.Page);
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), R.Size);
INC(rcount, 4);
FOR i := 0 TO ASR(R.Size - 8, 1) - 1 DO
sys.PUT(sys.ADR(Reloc[rcount]), R.reloc[i]);
INC(rcount, 2)
END
END PutReloc;
 
PROCEDURE InitArray(VAR adr: INTEGER; chars: UTILS.STRING);
VAR i, x, n: INTEGER;
BEGIN
n := LEN(chars) - 1;
i := 0;
WHILE (i < n) & (chars[i] # 0X) DO
x := SCAN.hex(chars[i]) * 16 + SCAN.hex(chars[i + 1]);
sys.PUT(adr, CHR(x));
INC(adr);
INC(i, 2)
END
END InitArray;
 
PROCEDURE WriteF(F, A, N: INTEGER);
BEGIN
IF UTILS.Write(F, A, N) # N THEN
Err(2)
END
END WriteF;
 
PROCEDURE Write(A, N: INTEGER);
BEGIN
sys.MOVE(A, OutFilePos, N);
OutFilePos := OutFilePos + N
END Write;
 
PROCEDURE Fill(n: INTEGER; c: CHAR);
VAR i: INTEGER;
BEGIN
FOR i := 1 TO n DO
Write(sys.ADR(c), 1)
END
END Fill;
 
PROCEDURE SetSection(VAR Section: SECTION; name: SECTIONNAME; size, adr, sizealign, OAPfile, attrflags: INTEGER);
BEGIN
Section.name := name;
Section.size := size;
Section.adr := adr;
Section.sizealign := sizealign;
Section.OAPfile := OAPfile;
Section.attrflags := attrflags;
END SetSection;
 
PROCEDURE WritePE(FName: ARRAY OF CHAR; stksize, codesize, datasize, rdatasize, gsize: INTEGER);
CONST textattr = 60000020H; rdataattr = 40000040H; dataattr = 0C0000040H; relocattr = 42000040H;
VAR i, F, adr, acodesize, compver, version, stkalloc, heapsize, heapalloc, filesize, filebuf: INTEGER;
cur: ASMLINE;
BEGIN
 
compver := 0;
version := 0;
stkalloc := stksize;
heapsize := 100000H;
heapalloc := 100000H;
acodesize := Align(codesize, 1000H) + 1000H;
adr := sys.ADR(rdata);
filesize := acodesize + Align(rdatasize, 1000H) + Align(datasize, 1000H) + Align(rcount, 1000H);
 
InitArray(adr, "5000000040000000000000003400000000000000000000006200000000000000");
InitArray(adr, "0000000000000000000000000000000000000000500000004000000000000000");
InitArray(adr, "A4014C6F61644C6962726172794100001F0147657450726F6341646472657373");
InitArray(adr, "00006B65726E656C33322E646C6C0000");
 
rdata[ 0] := acodesize + 50H;
rdata[ 1] := acodesize + 40H;
rdata[ 3] := acodesize + 34H;
rdata[ 6] := acodesize + 62H;
rdata[ 7] := acodesize;
rdata[13] := acodesize + 50H;
rdata[14] := acodesize + 40H;
 
adr := sys.ADR(Header.msdos);
InitArray(adr, "4D5A90000300000004000000FFFF0000B8000000000000004000000000000000");
InitArray(adr, "00000000000000000000000000000000000000000000000000000000B0000000");
InitArray(adr, "0E1FBA0E00B409CD21B8014CCD21546869732070726F6772616D2063616E6E6F");
InitArray(adr, "742062652072756E20696E20444F53206D6F64652E0D0D0A2400000000000000");
InitArray(adr, "5DCF9F8719AEF1D419AEF1D419AEF1D497B1E2D413AEF1D4E58EE3D418AEF1D4");
InitArray(adr, "5269636819AEF1D4000000000000000050450000");
Header.typecomp := IntToCard16(014CH);
IF dll THEN
Header.seccount := IntToCard16(0004H);
Header.infflags := IntToCard16(210EH)
ELSE
Header.seccount := IntToCard16(0003H);
Header.infflags := IntToCard16(010FH)
END;
Header.time := UTILS.Date;
Header.PEoptsize := IntToCard16(00E0H);
Header.PEfile := IntToCard16(010BH);
Header.compver := IntToCard16(compver);
Header.codesize := Align(codesize, 200H);
Header.datasize := Align(datasize + gsize, 200H) + Align(rdatasize, 200H) + Align(rcount, 200H);
Header.startadr := 1000H;
Header.codeadr := 1000H;
Header.rdataadr := Header.codeadr + Align(codesize, 1000H);
Header.loadadr := LoadAdr;
Header.secalign := 1000H;
Header.filealign := 0200H;
Header.oldestver := 0004H;
Header.version := version;
Header.oldestverNT := 0004H;
Header.filesize := Align(codesize, 1000H) + Align(datasize + gsize, 1000H) + Align(rdatasize, 1000H) + Align(rcount, 1000H) + 1000H;
Header.headersize := 0400H;
Header.UI := IntToCard16(ORD(con) + 2);
Header.stksize := stksize;
Header.stkalloc := stkalloc;
Header.heapsize := heapsize;
Header.heapalloc := heapalloc;
Header.structcount := 10H;
IF dll THEN
Header.structs[0].adr := Header.rdataadr + 0DAH;
Header.structs[0].size := etable.size
END;
 
Header.structs[1].adr := Header.rdataadr + 0CH;
Header.structs[1].size := 28H;
Header.structs[12].adr := Header.rdataadr;
Header.structs[12].size := 0CH;
 
SetSection(Header.sections[0], ".text", codesize, 1000H, Align(codesize, 200H), 400H, textattr);
SetSection(Header.sections[1], ".rdata", rdatasize, Align(codesize, 1000H) + 1000H, Align(rdatasize, 200H),
Align(codesize, 200H) + 400H, rdataattr);
SetSection(Header.sections[2], ".data", datasize + gsize, Align(codesize, 1000H) + Align(rdatasize, 1000H) + 1000H,
Align(datasize, 200H), Align(codesize, 200H) + Align(rdatasize, 200H) + 400H, dataattr);
 
IF dll THEN
SetSection(RelocSection, ".reloc", rcount, Header.sections[2].adr + Align(datasize + gsize, 1000H), Align(rcount, 200H),
Header.sections[2].OAPfile + Align(datasize, 200H), relocattr);
Header.structs[5].adr := RelocSection.adr;
Header.structs[5].size := rcount
END;
 
F := UTILS.CreateF(FName);
IF F = 0 THEN
Err(1)
END;
OutFilePos := UTILS.GetMem(filesize);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
 
Write(sys.ADR(Header), sys.SIZE(HEADER));
IF dll THEN
Write(sys.ADR(RelocSection), sys.SIZE(SECTION));
Fill(Align(sys.SIZE(HEADER) + sys.SIZE(SECTION), 200H) - (sys.SIZE(HEADER) + sys.SIZE(SECTION)), 0X)
ELSE
Fill(Align(sys.SIZE(HEADER), 200H) - sys.SIZE(HEADER), 0X)
END;
 
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
Fill(Align(codesize, 200H) - codesize, 0X);
Write(sys.ADR(rdata), 0DAH);
IF dll THEN
etable.time := Header.time;
Write(sys.ADR(etable), 40);
Write(sys.ADR(etable.arradr), etable.adrcount * 4);
Write(sys.ADR(etable.arrnameptr), etable.namecount * 4);
Write(sys.ADR(etable.arrnum), etable.namecount * 2);
Write(sys.ADR(etable.text), etable.textlen)
END;
Fill(Align(rdatasize, 200H) - rdatasize, 0X);
Write(sys.ADR(Data), datasize);
Fill(Align(datasize, 200H) - datasize, 0X);
IF dll THEN
Write(sys.ADR(Reloc), rcount);
Fill(Align(rcount, 200H) - rcount, 0X)
END;
WriteF(F, filebuf, OutFilePos - filebuf);
UTILS.CloseF(F)
END WritePE;
 
PROCEDURE New;
VAR nov: ASMLINE;
BEGIN
NEW(nov);
UTILS.MemErr(nov = NIL);
nov.cmd := ccount;
UTILS.Insert(asmlist, nov, current);
current := current.Next(ASMLINE)
END New;
 
PROCEDURE Empty(varadr: INTEGER);
BEGIN
New;
current.clen := 0;
current.tcmd := ECMD;
current.varadr := varadr
END Empty;
 
PROCEDURE OutByte(byte: INTEGER);
BEGIN
New;
current.clen := 1;
Code[ccount] := CHR(byte);
INC(ccount)
END OutByte;
 
PROCEDURE OutInt(int: INTEGER);
BEGIN
New;
current.clen := 4;
sys.PUT(sys.ADR(Code[ccount]), int);
INC(ccount, 4)
END OutInt;
 
PROCEDURE PushEAX;
BEGIN
OutByte(50H);
current.tcmd := PUSHEAX
END PushEAX;
 
PROCEDURE PushECX;
BEGIN
OutByte(51H);
current.tcmd := PUSHECX
END PushECX;
 
PROCEDURE PushEDX;
BEGIN
OutByte(52H);
current.tcmd := PUSHEDX
END PushEDX;
 
PROCEDURE PopEAX;
BEGIN
OutByte(58H);
current.tcmd := POPEAX
END PopEAX;
 
PROCEDURE PopECX;
BEGIN
OutByte(59H);
current.tcmd := POPECX
END PopECX;
 
PROCEDURE PopEDX;
BEGIN
OutByte(5AH);
current.tcmd := POPEDX
END PopEDX;
 
PROCEDURE OutCode(cmd: UTILS.STRING);
VAR a, b: INTEGER;
BEGIN
New;
a := sys.ADR(Code[ccount]);
b := a;
InitArray(a, cmd);
ccount := a - b + ccount;
current.clen := a - b
END OutCode;
 
PROCEDURE Del*(last: ASMLINE);
BEGIN
last.Next := current.Next;
IF current = asmlist.Last THEN
asmlist.Last := last
END;
current := last
END Del;
 
PROCEDURE NewLabel*(): INTEGER;
BEGIN
INC(Lcount)
RETURN Lcount
END NewLabel;
 
PROCEDURE PushCall*(asmline: ASMLINE);
BEGIN
New;
callstk[topstk][0] := asmline;
callstk[topstk][1] := current;
INC(topstk)
END PushCall;
 
PROCEDURE Param*;
BEGIN
current := callstk[topstk - 1][0]
END Param;
 
PROCEDURE EndCall*;
BEGIN
current := callstk[topstk - 1][1];
DEC(topstk)
END EndCall;
 
PROCEDURE Init*(UI: INTEGER);
VAR nov: ASMLINE;
BEGIN
dcount := 4;
dll := UI = 1;
gui := UI = 2;
con := UI = 3;
kos := UI = 4;
elf := UI = 5;
obj := UI = 6;
Lcount := HALT;
asmlist := UTILS.CreateList();
NEW(nov);
UTILS.MemErr(nov = NIL);
UTILS.Push(asmlist, nov);
current := nov;
END Init;
 
PROCEDURE datastr(str: UTILS.STRING);
VAR i, n: INTEGER;
BEGIN
i := 0;
n := LEN(str);
WHILE (i < n) & (str[i] # 0X) DO
Data[dcount] := str[i];
INC(dcount);
INC(i)
END;
Data[dcount] := 0X;
INC(dcount)
END datastr;
 
PROCEDURE dataint(n: INTEGER);
BEGIN
sys.PUT(sys.ADR(Data[dcount]), n);
INC(dcount, 4)
END dataint;
 
PROCEDURE jmp*(jamp: CHAR; label: INTEGER);
VAR n: INTEGER;
BEGIN
New;
CASE jamp OF
|JMP, CALL:
n := 5
|JE, JLE, JGE, JG, JL, JNE:
Code[ccount] := 0FX;
INC(ccount);
n := 6
ELSE
END;
current.clen := n;
Code[ccount] := jamp;
INC(ccount);
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(Labels[label]);
current.tcmd := JCMD;
current.short := TRUE;
INC(ccount, 4)
END jmp;
 
PROCEDURE jmplong(jamp: CHAR; label: INTEGER);
BEGIN
jmp(jamp, label);
current.short := FALSE
END jmplong;
 
PROCEDURE Label*(label: INTEGER);
BEGIN
New;
current.varadr := sys.ADR(Labels[label]);
current.tcmd := LCMD
END Label;
 
PROCEDURE CmdN(Number: INTEGER);
BEGIN
New;
current.clen := 4;
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(Labels[Number]);
current.tcmd := OCMD;
INC(ccount, 4)
END CmdN;
 
PROCEDURE IntByte(bytecode, intcode: UTILS.STRING; n: INTEGER);
BEGIN
IF (n <= 127) & (n >= -128) THEN
OutCode(bytecode);
OutByte(n)
ELSE
OutCode(intcode);
OutInt(n)
END
END IntByte;
 
PROCEDURE DropFpu*(long: BOOLEAN);
BEGIN
IF long THEN
OutCode("83EC08DD1C24")
ELSE
OutCode("83EC04D91C24")
END;
DEC(fpu)
END DropFpu;
 
PROCEDURE AfterRet(func, float: BOOLEAN; callconv, parsize: INTEGER);
BEGIN
IF callconv = cdecl THEN
OutCode("81C4");
OutInt(parsize)
END;
IF func THEN
IF float THEN
OutCode("83EC08DD1C24")
ELSE
PushEAX
END
END
END AfterRet;
 
PROCEDURE FpuSave(local: INTEGER);
VAR i: INTEGER;
BEGIN
IF fpu > maxfpu THEN
maxfpu := fpu
END;
FOR i := 1 TO fpu DO
IntByte("DD5D", "DD9D", -local - i * 8)
END
END FpuSave;
 
PROCEDURE Incfpu;
BEGIN
IF fpu >= FREGS THEN
UTILS.ErrMsgPos(SCAN.coord.line, SCAN.coord.col, 97);
UTILS.HALT(1)
END;
INC(fpu);
isfpu := TRUE
END Incfpu;
 
PROCEDURE FpuLoad(local: INTEGER; float: BOOLEAN);
VAR i: INTEGER;
BEGIN
FOR i := fpu TO 1 BY -1 DO
IntByte("DD45", "DD85", -local - i * 8)
END;
IF float THEN
Incfpu;
OutCode("DD042483C408")
END
END FpuLoad;
 
PROCEDURE Call*(proc: INTEGER; func, float: BOOLEAN; callconv, ccall, bases, level, parsize, local: INTEGER);
VAR i: INTEGER;
BEGIN
IF ccall # 0 THEN
FOR i := level TO level - bases + ORD(ccall = 1) + 1 BY -1 DO
IntByte("FF75", "FFB5", 4 * i + 4)
END;
IF ccall = 1 THEN
OutByte(55H)
END
END;
FpuSave(local);
jmplong(CALL, proc);
AfterRet(func, float, callconv, parsize);
FpuLoad(local, func & float)
END Call;
 
PROCEDURE CallRTL(Proc: INTEGER);
BEGIN
New;
current.clen := 5;
Code[ccount] := CALL;
INC(ccount);
current.codeadr := sys.ADR(Code[ccount]);
current.varadr := sys.ADR(RtlProc[Proc]);
current.tcmd := JCMD;
INC(ccount, 4)
END CallRTL;
 
PROCEDURE PushInt*(n: INTEGER);
BEGIN
OutByte(68H);
CmdN(n)
END PushInt;
 
PROCEDURE Prolog*(exename: UTILS.STRING);
BEGIN
ExecName := exename;
Labels[hInstance] := -dcount;
dataint(0);
Labels[SELFNAME] := -dcount;
datastr(exename);
Label(START);
IF dll THEN
OutCode("558BEC837D0C007507");
CallRTL(_close);
OutCode("EB06837D0C017409B801000000C9C20C00")
ELSIF obj THEN
OutCode("558BEC")
END;
start := asmlist.Last(ASMLINE)
END Prolog;
 
PROCEDURE AddRec*(base: INTEGER);
BEGIN
INC(reccount);
recarray[reccount] := base
END AddRec;
 
PROCEDURE CmpOpt(inv: BOOLEAN): INTEGER;
VAR cur: ASMLINE; c: INTEGER;
BEGIN
c := ORD(Code[current.Prev.Prev(ASMLINE).cmd]);
IF inv THEN
IF ODD(c) THEN
DEC(c)
ELSE
INC(c)
END
END;
cur := current;
REPEAT
cur.tcmd := 0;
cur.clen := 0;
cur := cur.Prev(ASMLINE)
UNTIL cur.tcmd = ICMP1;
cur.tcmd := 0;
cur.clen := 0
RETURN c - 16
END CmpOpt;
 
PROCEDURE ifwh*(L: INTEGER);
VAR c: INTEGER;
BEGIN
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN
c := CmpOpt(TRUE);
OutCode("5A583BC2");
jmp(CHR(c), L)
ELSE
PopECX;
OutCode("85C9");
jmp(JE, L)
END
END ifwh;
 
PROCEDURE PushConst*(Number: INTEGER);
BEGIN
IntByte("6A", "68", Number);
current.Prev(ASMLINE).varadr := Number
END PushConst;
 
PROCEDURE IfWhile*(L: INTEGER; orop: BOOLEAN);
VAR c, L1: INTEGER;
BEGIN
L1 := NewLabel();
IF current.Prev(ASMLINE).tcmd = ICMP2 THEN
c := CmpOpt(orop);
OutCode("5A583BC2");
jmp(CHR(c), L1);
PushConst(ORD(orop))
ELSE
PopECX;
OutCode("85C9");
IF orop THEN
jmp(JE, L1)
ELSE
jmp(JNE, L1)
END;
PushECX
END;
jmp(JMP, L);
Label(L1)
END IfWhile;
 
PROCEDURE newrec*;
BEGIN
CallRTL(_newrec)
END newrec;
 
PROCEDURE disprec*;
BEGIN
CallRTL(_disprec)
END disprec;
 
PROCEDURE String*(Number, Len: INTEGER; str: UTILS.STRING);
BEGIN
Labels[Number] := -dcount;
IF Len > 1 THEN
datastr(str)
ELSIF Len = 1 THEN
dataint(ORD(str[0]))
ELSE
dataint(0)
END
END String;
 
PROCEDURE InsertFpuInit;
VAR t: ASMLINE;
BEGIN
IF isfpu THEN
t := current;
current := fpucmd;
IF maxfpu > 0 THEN
OutCode("83EC");
OutByte(maxfpu * 8)
END;
OutCode("DBE3");
current := t
END
END InsertFpuInit;
 
PROCEDURE ProcBeg*(Number, Local: INTEGER; Module: BOOLEAN);
VAR i: INTEGER;
BEGIN
IF Module THEN
OutCode("EB0C");
Label(Number + 3);
PushInt(Number + 2);
jmplong(JMP, HALT);
Label(Number + 1)
ELSE
Label(Number)
END;
OutCode("558BEC");
IF Local > 12 THEN
IntByte("83EC", "81EC", Local);
OutCode("8BD733C08BFCB9");
OutInt(ASR(Local, 2));
OutCode("9CFCF3AB8BFA9D")
ELSE
FOR i := 4 TO Local BY 4 DO
OutCode("6A00")
END
END;
fpucmd := current;
fpu := 0;
maxfpu := 0;
isfpu := FALSE
END ProcBeg;
 
PROCEDURE Leave*;
BEGIN
OutByte(0C9H);
InsertFpuInit
END Leave;
 
PROCEDURE ProcEnd*(Number, Param: INTEGER; func, float: BOOLEAN);
BEGIN
IF func & ~float THEN
PopEAX
END;
OutByte(0C9H);
IF Param = 0 THEN
OutByte(0C3H)
ELSE
OutByte(0C2H);
OutByte(Param MOD 256);
OutByte(ASR(Param, 8))
END;
InsertFpuInit
END ProcEnd;
 
PROCEDURE Module*(Name: UTILS.STRING; Number: INTEGER);
BEGIN
String(Number + 2, LENGTH(Name), Name);
jmplong(JMP, Number + 1)
END Module;
 
PROCEDURE Asm*(s: UTILS.STRING);
BEGIN
OutCode(s)
END Asm;
 
PROCEDURE GlobalAdr*(offset: INTEGER);
BEGIN
OutByte(0BAH);
OutInt(offset);
current.codeadr := sys.ADR(Code[ccount - 4]);
current.tcmd := GCMD;
PushEDX
END GlobalAdr;
 
PROCEDURE Mono*(Number: INTEGER);
BEGIN
PopEDX;
PushInt(Number)
END Mono;
 
PROCEDURE StrMono*;
BEGIN
PopEDX;
OutCode("6A02");
PushEDX
END StrMono;
 
PROCEDURE Not*;
BEGIN
PopECX;
OutCode("85C90F94C1");
PushECX
END Not;
 
PROCEDURE NegSet*;
BEGIN
OutCode("F71424")
END NegSet;
 
PROCEDURE Int*(Op: INTEGER);
BEGIN
PopEDX;
CASE Op OF
|lxPlus: OutCode("011424")
|lxMinus: OutCode("291424")
|lxMult: OutCode("58F7EA"); PushEAX
ELSE
END
END Int;
 
PROCEDURE Set*(Op: INTEGER);
BEGIN
PopEDX;
OutByte(58H);
CASE Op OF
|lxPlus: OutByte(0BH)
|lxMinus: OutCode("F7D223")
|lxMult: OutByte(23H)
|lxSlash: OutByte(33H)
ELSE
END;
OutByte(0C2H);
PushEAX
END Set;
 
PROCEDURE Setfpu*(newfpu: INTEGER);
BEGIN
fpu := newfpu
END Setfpu;
 
PROCEDURE PushFlt*(x: LONGREAL);
VAR f: TFLT; L: INTEGER;
BEGIN
sys.PUT(sys.ADR(f), x);
Incfpu;
IF x = 0.0D0 THEN
OutCode("D9EE")
ELSIF x = 1.0D0 THEN
OutCode("D9E8")
ELSE
L := NewLabel();
Labels[L] := -dcount;
dataint(f[0]);
dataint(f[1]);
OutByte(0BAH);
CmdN(L);
OutCode("DD02")
END
END PushFlt;
 
PROCEDURE farith*(op: INTEGER);
VAR n: INTEGER;
BEGIN
OutByte(0DEH);
CASE op OF
|lxPlus: n := 0C1H
|lxMinus: n := 0E9H
|lxMult: n := 0C9H
|lxSlash: n := 0F9H
ELSE
END;
OutByte(n);
DEC(fpu)
END farith;
 
PROCEDURE fcmp*(Op: INTEGER);
VAR n: INTEGER;
BEGIN
OutCode("33C9DED9DFE09E0F");
CASE Op OF
|lxEQ: n := 94H
|lxNE: n := 95H
|lxLT: n := 97H
|lxGT: n := 92H
|lxLE: n := 93H
|lxGE: n := 96H
ELSE
END;
DEC(fpu, 2);
OutByte(n);
OutByte(0C1H);
PushECX
END fcmp;
 
PROCEDURE fneg*;
BEGIN
OutCode("D9E0")
END fneg;
 
PROCEDURE OnError*(n: INTEGER);
BEGIN
OutByte(68H);
OutInt(LSL(UTILS.Line, 4) + n);
jmplong(JMP, UTILS.Unit + 3)
END OnError;
 
PROCEDURE idivmod*(opmod: BOOLEAN);
BEGIN
PopECX;
IF opmod THEN
OutCode("58E32E538BD833D9C1FB1F8BD0C1FA1F83F9FF750C3D0000008075055B6A00EB1AF7F985DB740685D2740203D15B52EB0A")
ELSE
OutCode("58E32C538BD833D9C1FB1F8BD0C1FA1F83F9FF750B3D0000008075045B50EB19F7F985DB740585D27401485B50EB0A")
END;
OnError(8)
END idivmod;
 
PROCEDURE rset*;
BEGIN
CallRTL(_rset);
PushEAX
END rset;
 
PROCEDURE inset*;
BEGIN
CallRTL(_inset);
PushEAX
END inset;
 
PROCEDURE Dup*;
BEGIN
PopEDX;
PushEDX;
PushEDX
END Dup;
 
PROCEDURE Inclusion*(Op: INTEGER);
BEGIN
PopEDX;
PopEAX;
IF Op = lxLE THEN
PushEDX
ELSE
PushEAX
END;
OutCode("0BC25933C8E3046A00EB026A01")
END Inclusion;
 
PROCEDURE NegInt*;
BEGIN
OutCode("F71C24")
END NegInt;
 
PROCEDURE CmpInt*(Op: INTEGER);
VAR n: INTEGER;
BEGIN
OutCode("33C95A583BC20F"); current.tcmd := ICMP1;
CASE Op OF
|lxEQ: n := 94H
|lxNE: n := 95H
|lxLT: n := 9CH
|lxGT: n := 9FH
|lxLE: n := 9EH
|lxGE: n := 9DH
ELSE
END;
OutByte(n);
OutByte(0C1H); current.tcmd := ICMP2;
PushECX;
END CmpInt;
 
PROCEDURE CallVar*(func, float: BOOLEAN; callconv, parsize, local: INTEGER);
BEGIN
PopEDX;
OutCode("8B1285D2750A");
OnError(2);
FpuSave(local);
OutCode("FFD2");
AfterRet(func, float, callconv, parsize);
FpuLoad(local, func & float)
END CallVar;
 
PROCEDURE LocalAdr*(offset, bases: INTEGER);
BEGIN
IF bases = 0 THEN
Empty(offset);
OutCode("8BD5")
ELSE
IntByte("8B55", "8B95", 4 * bases + 4)
END;
IntByte("83C2", "81C2", offset);
PushEDX;
IF bases = 0 THEN
Empty(offset)
END
END LocalAdr;
 
PROCEDURE Field*(offset: INTEGER);
BEGIN
IF offset # 0 THEN
IntByte("830424", "810424", offset)
END
END Field;
 
PROCEDURE DerefType*(n: INTEGER);
BEGIN
IntByte("8B5424", "8B9424", n);
OutCode("FF72FC")
END DerefType;
 
PROCEDURE Guard*(T: INTEGER; Check: BOOLEAN);
BEGIN
IF Check THEN
PopEAX;
OutCode("85C074");
IF T <= 127 THEN
OutByte(9)
ELSE
OutByte(12)
END;
PushEAX
END;
PushConst(T);
PushEAX;
CallRTL(_checktype);
IF Check THEN
PushEAX
ELSE
OutCode("85C0750A");
OnError(3)
END
END Guard;
 
PROCEDURE StProc*(proc: INTEGER);
BEGIN
CASE proc OF
|stINC: PopEDX; OutCode("590111")
|stDEC: PopEDX; OutCode("592911")
|stINC1: PopEDX; OutCode("FF02")
|stDEC1: PopEDX; OutCode("FF0A")
|stINCL: PopEDX; OutCode("580910")
|stEXCL: PopEDX; OutCode("582110")
|stPACK: OutCode("DB04245A5ADD02D9FDDD1A"); isfpu := TRUE
|stPACK1: OutCode("DB04245A5AD902D9FDD91A"); isfpu := TRUE
|stUNPK: PopEDX; OutCode("59DD01D9F4DD19DB1A"); isfpu := TRUE
|stUNPK1: PopEDX; OutCode("59D901D9F4D919DB1A"); isfpu := TRUE
|stCOPY: CallRTL(_strcopy)
|sysMOVE: CallRTL(_savearr)
ELSE
END
END StProc;
 
PROCEDURE Assert*(proc, assrt: INTEGER);
BEGIN
PopEDX;
OutCode("85D2751368");
OutInt(UTILS.Line * 16 + 1);
PushInt(UTILS.Unit + 2);
IF proc = stASSERT THEN
OutCode("6A026A")
ELSE
OutCode("6A016A")
END;
OutByte(assrt);
jmplong(JMP, ASSRT)
END Assert;
 
PROCEDURE StFunc*(func: INTEGER);
BEGIN
CASE func OF
|stABS: PopEDX; OutCode("85D27D02F7DA"); PushEDX
|stFABS: OutCode("D9E1")
|stFLT: OutCode("DB0424"); PopEAX; Incfpu;
|stFLOOR: jmplong(CALL, _floor); PushEAX; DEC(fpu)
|stODD: OutCode("83242401")
|stROR: PopECX; OutCode("58D3C8"); PushEAX
|stASR: PopECX; OutCode("58D3F8"); PushEAX
|stLSL: PopECX; OutCode("58D3E0"); PushEAX
|stLSR: PopECX; OutCode("58D3E8"); PushEAX
|stORD: PopEDX; OutCode("85D274036A015A"); PushEDX
|stLENGTH: CallRTL(_length); PushEAX
ELSE
END
END StFunc;
 
PROCEDURE Load*(T: INTEGER);
VAR lastcmd: ASMLINE; offset: INTEGER;
 
PROCEDURE del;
BEGIN
lastcmd.tcmd := 0;
offset := lastcmd.varadr;
lastcmd := lastcmd.Prev(ASMLINE);
WHILE lastcmd.tcmd # ECMD DO
lastcmd.clen := 0;
lastcmd.tcmd := 0;
lastcmd := lastcmd.Prev(ASMLINE)
END;
lastcmd.tcmd := 0
END del;
 
BEGIN
lastcmd := current;
CASE T OF
|TINTEGER, TSET, TPOINTER, TPROC:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("8B55", "8B95", offset);
PushEDX
ELSE
PopEDX;
OutCode("FF32")
END
|TCHAR, TBOOLEAN:
IF lastcmd.tcmd = ECMD THEN
del;
OutCode("33D28A");
IntByte("55", "95", offset);
PushEDX
ELSE
PopEDX;
OutCode("33C98A0A");
PushECX
END
|TLONGREAL:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("DD45", "DD85", offset)
ELSE
PopEDX;
OutCode("DD02")
END;
Incfpu
|TREAL:
IF lastcmd.tcmd = ECMD THEN
del;
IntByte("D945", "D985", offset)
ELSE
PopEDX;
OutCode("D902")
END;
Incfpu
|TCARD16:
IF lastcmd.tcmd = ECMD THEN
del;
OutCode("33D2668B");
IntByte("55", "95", offset);
PushEDX
ELSE
PopEDX;
OutCode("33C9668B0A");
PushECX
END
ELSE
END
END Load;
 
PROCEDURE Save*(T: INTEGER);
BEGIN
CASE T OF
|TINTEGER, TSET, TPOINTER, TPROC:
PopEDX;
OutCode("588910")
|TCHAR, TSTRING, TBOOLEAN:
PopEDX;
OutCode("588810")
|TCARD16:
PopEDX;
OutCode("58668910")
|TLONGREAL:
PopEDX;
OutCode("DD1A");
DEC(fpu)
|TREAL:
PopEDX;
OutCode("D91A");
DEC(fpu)
|TRECORD:
CallRTL(_saverec);
OutCode("85C0750A");
OnError(4)
|TARRAY:
CallRTL(_savearr)
ELSE
END
END Save;
 
PROCEDURE OpenArray*(A: TIDX; n: INTEGER);
VAR i: INTEGER;
BEGIN
PopEDX;
FOR i := n - 1 TO 0 BY -1 DO
PushConst(A[i])
END;
PushEDX
END OpenArray;
 
PROCEDURE OpenIdx*(n: INTEGER);
BEGIN
OutByte(54H);
IF n > 1 THEN
PushConst(n);
CallRTL(_arrayidx)
ELSE
CallRTL(_arrayidx1)
END;
PopEDX;
OutCode("85D2750A");
OnError(5);
PushEDX;
END OpenIdx;
 
PROCEDURE FixIdx*(len, size: INTEGER);
BEGIN
PopEDX;
IntByte("5983FA", "5981FA", len);
OutCode("720A");
OnError(5);
IF size > 1 THEN
IntByte("6BD2", "69D2", size)
END;
OutCode("03D1");
PushEDX
END FixIdx;
 
PROCEDURE Idx*;
BEGIN
PopEDX;
PopECX;
OutCode("03D1");
PushEDX
END Idx;
 
PROCEDURE DupLoadCheck*;
BEGIN
PopEDX;
OutCode("528B125285D2750A");
OnError(6)
END DupLoadCheck;
 
PROCEDURE DupLoad*;
BEGIN
PopEDX;
OutCode("528B12");
PushEDX;
END DupLoad;
 
PROCEDURE CheckNIL*;
BEGIN
PopEDX;
OutCode("85D2750A");
OnError(6);
PushEDX;
END CheckNIL;
 
PROCEDURE ExtArray*(A: TIDX; n, m: INTEGER);
VAR i: INTEGER;
BEGIN
FOR i := n - 1 TO 0 BY -1 DO
PushConst(A[i])
END;
OutByte(54H);
PushConst(n);
PushConst(m);
CallRTL(_arrayrot)
END ExtArray;
 
PROCEDURE ADR*(dim: INTEGER);
BEGIN
IF dim > 0 THEN
PopEDX;
OutCode("83C4");
OutByte(dim * 4);
PushEDX
END
END ADR;
 
PROCEDURE Len*(dim: INTEGER);
BEGIN
PopEDX;
IF dim < 0 THEN
PushConst(-dim)
ELSIF dim > 1 THEN
PopEDX;
OutCode("83C4");
OutByte((dim - 1) * 4);
PushEDX
END
END Len;
 
PROCEDURE For*(inc: BOOLEAN; VAR LBeg, LEnd: INTEGER);
BEGIN
LEnd := NewLabel();
LBeg := NewLabel();
Label(LBeg);
OutCode("8B14248B4424043910");
IF inc THEN
jmp(JG, LEnd)
ELSE
jmp(JL, LEnd)
END
END For;
 
PROCEDURE NextFor*(step, LBeg, LEnd: INTEGER);
BEGIN
OutCode("8B542404");
IF step = 1 THEN
OutCode("FF02")
ELSIF step = -1 THEN
OutCode("FF0A")
ELSE
IntByte("8302", "8102", step)
END;
jmp(JMP, LBeg);
Label(LEnd);
OutCode("83C408")
END NextFor;
 
PROCEDURE CaseLabel*(a, b, LBeg: INTEGER);
VAR L: INTEGER;
BEGIN
L := NewLabel();
IntByte("83FA", "81FA", a);
IF a = b THEN
jmp(JNE, L)
ELSE
jmp(JL, L);
IntByte("83FA", "81FA", b);
jmp(JG, L)
END;
jmp(JMP, LBeg);
Label(L)
END CaseLabel;
 
PROCEDURE Drop*;
BEGIN
PopEDX
END Drop;
 
PROCEDURE strcmp*(Op, LR: INTEGER);
BEGIN
CASE Op OF
|lxEQ: PushConst(0)
|lxNE: PushConst(1)
|lxLT: PushConst(2)
|lxGT: PushConst(3)
|lxLE: PushConst(4)
|lxGE: PushConst(5)
ELSE
END;
CASE LR OF
|-1: CallRTL(_lstrcmp)
| 0: CallRTL(_strcmp)
| 1: CallRTL(_rstrcmp)
ELSE
END;
PushEAX
END strcmp;
 
PROCEDURE Optimization;
VAR cur: ASMLINE; flag: BOOLEAN;
BEGIN
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
flag := FALSE;
CASE cur.tcmd OF
|PUSHEAX:
flag := cur.Next(ASMLINE).tcmd = POPEAX
|PUSHECX:
flag := cur.Next(ASMLINE).tcmd = POPECX
|PUSHEDX:
flag := cur.Next(ASMLINE).tcmd = POPEDX
ELSE
END;
IF flag THEN
cur.clen := 0;
cur.tcmd := 0;
cur := cur.Next(ASMLINE);
cur.clen := 0;
cur.tcmd := 0
END;
cur := cur.Next(ASMLINE)
END
END Optimization;
 
PROCEDURE WriteKOS(FName: ARRAY OF CHAR; stk, size, datasize, gsize: INTEGER; obj: BOOLEAN);
CONST strsize = 2048;
VAR Header: KOSHEADER; F, i, filesize, filebuf, a, sec, adr, size2: INTEGER; cur: ASMLINE;
Coff: COFFHEADER; sym: ARRAY 18 * 4 OF CHAR; FileName: UTILS.STRING;
BEGIN
F := UTILS.CreateF(FName);
IF F <= 0 THEN
Err(1)
END;
OutFilePos := UTILS.GetMem(Align(size, 4) + datasize + 1000H);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
 
IF ~obj THEN
Header.menuet01 := "MENUET01";
Header.ver := 1;
Header.start := sys.SIZE(KOSHEADER);
Header.size := Align(size, 4) + datasize;
Header.mem := Header.size + stk + gsize + strsize * 2 + 1000H;
Header.sp := Header.size + gsize + stk;
Header.param := Header.sp;
Header.path := Header.param + strsize;
 
Write(sys.ADR(Header), sys.SIZE(KOSHEADER));
 
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
Fill(Align(size, 4) - size, 0X);
Write(sys.ADR(Data), datasize);
WriteF(F, filebuf, OutFilePos - filebuf)
 
ELSE
 
size2 := size;
size := Align(size, 4) - sys.SIZE(KOSHEADER);
Coff.Machine := IntToCard16(014CH);
Coff.NumberOfSections := IntToCard16(3);
Coff.TimeDateStamp := UTILS.Date;
Coff.SizeOfOptionalHeader := IntToCard16(0);
Coff.Characteristics := IntToCard16(0184H);
 
Coff.text.name := ".flat";
Coff.text.size := 0;
Coff.text.adr := 0;
Coff.text.sizealign := size;
Coff.text.OAPfile := 8CH;
Coff.text.reserved6 := size + datasize + 8CH;
Coff.text.reserved7 := 0;
Coff.text.attrflags := 40300020H;
 
Coff.data.name := ".data";
Coff.data.size := 0;
Coff.data.adr := 0;
Coff.data.sizealign := datasize;
Coff.data.OAPfile := size + 8CH;
Coff.data.reserved6 := 0;
Coff.data.reserved7 := 0;
Coff.data.reserved8 := 0;
Coff.data.attrflags := 0C0300040H;
 
Coff.bss.name := ".bss";
Coff.bss.size := 0;
Coff.bss.adr := 0;
Coff.bss.sizealign := gsize;
Coff.bss.OAPfile := 0;
Coff.bss.reserved6 := 0;
Coff.bss.reserved7 := 0;
Coff.bss.reserved8 := 0;
Coff.bss.attrflags := 0C03000C0H;
 
size := Align(size2, 4);
rcount := 0;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
IF cur.tcmd IN {OCMD, GCMD} THEN
sys.GET(sys.ADR(Code[cur.cmd]), a);
IF a < size THEN
a := a - sys.SIZE(KOSHEADER);
sec := 1
ELSIF a < size + datasize THEN
a := a - size;
sec := 2
ELSE
a := a - size - datasize;
sec := 3
END;
sys.PUT(sys.ADR(Code[cur.cmd]), a);
sys.PUT(sys.ADR(Reloc[rcount]), cur.adr - sys.SIZE(KOSHEADER));
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), sec);
INC(rcount, 4);
sys.PUT(sys.ADR(Reloc[rcount]), 06X); INC(rcount);
sys.PUT(sys.ADR(Reloc[rcount]), 00X); INC(rcount);
END;
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
size := size2;
Fill(Align(size, 4) - size2, 0X);
Write(sys.ADR(Data), datasize);
Coff.text.reserved8 := rcount DIV 10;
Coff.PointerToSymbolTable := Coff.text.reserved6 + rcount;
Coff.NumberOfSymbols := 4;
 
WriteF(F, sys.ADR(Coff), sys.SIZE(COFFHEADER));
WriteF(F, filebuf, OutFilePos - filebuf);
WriteF(F, sys.ADR(Reloc), rcount);
 
adr := sys.ADR(sym);
InitArray(adr, "4558504F52545300000000000100000002002E666C617400000000000000010000000300");
InitArray(adr, "2E64617461000000000000000200000003002E6273730000000000000000030000000300");
sys.PUT(sys.ADR(sym) + 8, Labels[Exports] - sys.SIZE(KOSHEADER));
 
WriteF(F, sys.ADR(sym), LEN(sym));
i := 4;
WriteF(F, sys.ADR(i), 4)
END;
UTILS.CloseF(F)
END WriteKOS;
 
PROCEDURE WriteELF(FName: ARRAY OF CHAR; code, data, glob: INTEGER);
VAR F, delta, filebuf: INTEGER; cur: ASMLINE; bytes: ARRAY 817H + 55FH + 4900 OF CHAR;
 
PROCEDURE Add(offset: INTEGER);
VAR m: INTEGER;
BEGIN
sys.GET(sys.ADR(bytes[offset]), m);
sys.PUT(sys.ADR(bytes[offset]), m + delta)
END Add;
 
PROCEDURE Sub(offset: INTEGER);
VAR m: INTEGER;
BEGIN
sys.GET(sys.ADR(bytes[offset]), m);
sys.PUT(sys.ADR(bytes[offset]), m - delta)
END Sub;
 
PROCEDURE Add8(a1, a2, a3, a4, a5, a6, a7, a8: INTEGER);
BEGIN
Add(a1); Add(a2); Add(a3); Add(a4);
Add(a5); Add(a6); Add(a7); Add(a8)
END Add8;
 
BEGIN
sys.MOVE(ELF.get(), sys.ADR(bytes[0]), ELF.size);
 
DEC(code, 13);
 
delta := Align(data, 1000H) - 100000H;
Add8(0020H, 00A4H, 00A8H, 0258H, 02B8H, 0308H, 0494H, 049CH);
Add8(04A4H, 0679H, 0681H, 06A4H, 06B0H, 06BAH, 0703H, 0762H);
Add8(0774H, 0786H, 0819H, 0823H, 17C5H, 17E5H, 17E9H, 1811H);
Add8(1839H, 1861H, 1889H, 1A25H, 1A95H, 1AA5H, 1C05H, 1C55H);
Add(1CE5H); Add(1D09H); Add(1D15H); Add(1D25H); Add(1D35H); Add(1D55H);
 
delta := Align(glob, 1000H) - 3200000H;
Add(00A8H); Add(17EDH); Add(1C09H); Add(1D25H);
 
delta := Align(code, 1000H) - 100000H;
Add8(0020H, 0084H, 0088H, 0098H, 009CH, 00A0H, 00B8H, 00BCH);
Add8(00C0H, 0118H, 011CH, 0120H, 0258H, 0278H, 02B8H, 0308H);
Add8(048CH, 0494H, 049CH, 04A4H, 04ACH, 04B4H, 04BCH, 04C4H);
Add8(04CCH, 04D4H, 04DCH, 04E4H, 04ECH, 04F4H, 04FCH, 0504H);
Add8(050CH, 0514H, 052BH, 0544H, 054EH, 0554H, 055EH, 056EH);
Add8(057EH, 058EH, 059EH, 05AEH, 05BEH, 05CEH, 05DEH, 05EEH);
Add8(05FEH, 060EH, 061EH, 062EH, 064CH, 0651H, 0679H, 0681H);
Add8(0686H, 068CH, 06A4H, 06ABH, 06B0H, 06BAH, 06D7H, 06EBH);
Add8(0703H, 0762H, 0774H, 0786H, 0819H, 0823H, 0828H, 082DH);
Add8(1635H, 1655H, 1659H, 167DH, 1681H, 16A5H, 16A9H, 16CDH);
Add8(16D1H, 16F5H, 16F9H, 171DH, 1721H, 1745H, 1749H, 176DH);
Add8(1771H, 1795H, 1799H, 17BDH, 17C1H, 17E5H, 17E9H, 1811H);
Add8(1839H, 1861H, 1889H, 1985H, 1995H, 19A5H, 19B5H, 19C5H);
Add8(19D5H, 19E5H, 19F5H, 1A05H, 1A15H, 1A25H, 1A55H, 1A65H);
Add8(1A75H, 1A95H, 1AA5H, 1AD5H, 1AE5H, 1AF5H, 1B05H, 1B25H);
Add8(1B35H, 1B45H, 1B55H, 1B65H, 1B75H, 1BB5H, 1BC5H, 1BE5H);
Add8(1C05H, 1C15H, 1C55H, 1C75H, 1CA5H, 1CB5H, 1CE5H, 1D05H);
Add8(1D15H, 1D25H, 1D35H, 1D55H, 1D75H, 1D89H, 08DEH, 08E8H);
Sub(0845H); Sub(087BH); Sub(0916H); Add(0C52H); Add(0C8AH); Add(0D0AH);
 
OutFilePos := UTILS.GetMem(code + data + 8000H);
filebuf := OutFilePos;
UTILS.MemErr(OutFilePos = 0);
 
Write(sys.ADR(bytes), 817H);
Fill(2DDH, 90X);
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
Write(sys.ADR(Code[cur.cmd]), cur.clen);
cur := cur.Next(ASMLINE)
END;
Fill(Align(code, 1000H) - code, 90X);
Write(sys.ADR(bytes[817H]), 55FH);
Write(sys.ADR(Data), data);
Fill(Align(data, 1000H) - data, 0X);
Write(sys.ADR(bytes[817H + 55FH + 55FH]), 0DC5H);
 
F := UTILS.CreateF(FName);
IF F <= 0 THEN
Err(1)
END;
WriteF(F, filebuf, OutFilePos - filebuf);
UTILS.CloseF(F)
END WriteELF;
 
PROCEDURE DelProc*(beg, end: ASMLINE);
BEGIN
WHILE beg # end DO
beg.clen := 0;
beg.tcmd := 0;
beg := beg.Next(ASMLINE)
END;
beg.clen := 0;
beg.tcmd := 0
END DelProc;
 
PROCEDURE FixLabels*(FName: ARRAY OF CHAR; stk, gsize, glob: INTEGER);
VAR size, asize, i, rdatasize, RCount, n, temp, temp2, temp3: INTEGER; cur: ASMLINE; R: RELOC; c: CHAR;
BEGIN
dcount := Align(dcount, 4);
IF dll THEN
LoadAdr := 10000000H;
PackExport(ExecName)
ELSIF con OR gui THEN
LoadAdr := 400000H
ELSIF kos OR obj THEN
LoadAdr := sys.SIZE(KOSHEADER)
ELSIF elf THEN
LoadAdr := 134514420 + 1024;
INC(gsize, 1024)
END;
 
IF dll OR con OR gui THEN
rdatasize := 0DAH + etable.size;
size := 1000H + LoadAdr;
ELSIF kos OR elf OR obj THEN
rdatasize := 0;
size := LoadAdr
END;
 
Optimization;
temp2 := size;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
cur.adr := size;
IF cur.tcmd = LCMD THEN
sys.PUT(cur.varadr, size)
END;
size := size + cur.clen;
cur := cur.Next(ASMLINE)
END;
 
size := temp2;
cur := asmlist.First(ASMLINE);
WHILE cur # NIL DO
cur.adr := size;
IF cur.tcmd = LCMD THEN
sys.PUT(cur.varadr, size)
ELSIF (cur.tcmd = JCMD) & cur.short THEN
sys.GET(cur.varadr, i);
temp3 := i - cur.Next(ASMLINE).adr;
IF (-131 <= temp3) & (temp3 <= 123) THEN
sys.GET(cur(ASMLINE).codeadr - 1, c);
IF c = JMP THEN
sys.PUT(cur(ASMLINE).codeadr - 1, 0EBX)
ELSE (*JE, JNE, JLE, JGE, JG, JL*)
sys.PUT(cur(ASMLINE).codeadr - 2, ORD(c) - 16);
sys.PUT(cur(ASMLINE).codeadr - 1, temp3);
DEC(cur(ASMLINE).codeadr)
END;
cur.clen := 2
END
END;
size := size + cur.clen;
cur := cur.Next(ASMLINE)
END;
 
IF dll OR con OR gui THEN
asize := Align(size, 1000H)
ELSIF kos OR obj THEN
asize := Align(size, 4)
ELSIF elf THEN
asize := 134514420 + 6508 + Align(size - 13 - LoadAdr, 1000H)
END;
 
FOR i := 0 TO Lcount DO
IF Labels[i] < 0 THEN
Labels[i] := -Labels[i] + asize + Align(rdatasize, 1000H)
END
END;
 
temp := dcount;
IF elf THEN
asize := asize + Align(dcount, 1000H) + 64 + 1024;
sys.PUT(sys.ADR(Code[glob + 1]), asize - 1024);
dcount := 0
END;
 
IF dll THEN
asize := asize - LoadAdr + 0DAH;
FOR i := 0 TO etable.namecount - 1 DO
etable.arradr[i] := Labels[etable.arradr[i]] - LoadAdr;
etable.arrnameptr[i] := etable.arrnameptr[i] + asize
END;
etable.arradroffset := etable.arradroffset + asize;
etable.arrnameptroffset := etable.arrnameptroffset + asize;
etable.arrnumoffset := etable.arrnumoffset + asize;
etable.dllnameoffset := etable.dllnameoffset + asize;
asize := asize + LoadAdr - 0DAH
END;
IF dll OR con OR gui THEN
Labels[LoadLibrary] := asize + 4;
Labels[GetProcAddress] := asize;
R.Page := 0;
R.Size := 0;
RCount := 0;
END;
cur := asmlist.First(ASMLINE);
 
FOR i := 0 TO LEN(RtlProc) - 1 DO
RtlProc[i] := Labels[RtlProc[i]]
END;
 
temp3 := asize + Align(rdatasize, 1000H) + dcount;
WHILE cur # NIL DO
CASE cur.tcmd OF
|JCMD:
sys.GET(cur.varadr, i);
sys.PUT(cur.codeadr, i - cur.Next(ASMLINE).adr)
|GCMD:
sys.GET(cur.codeadr, i);
sys.PUT(cur.codeadr, i + temp3)
|OCMD:
sys.MOVE(cur.varadr, cur.codeadr, 4)
ELSE
END;
IF dll & (cur.tcmd IN {GCMD, OCMD}) THEN
n := cur.adr - LoadAdr;
IF ASR(n, 12) = ASR(R.Page, 12) THEN
R.reloc[RCount] := IntToCard16(n MOD 1000H + 3000H);
INC(RCount);
INC(R.Size, 2)
ELSE
IF R.Size # 0 THEN
PutReloc(R)
END;
R.Page := ASR(n, 12) * 1000H;
R.Size := 10;
R.reloc[0] := IntToCard16(n MOD 1000H + 3000H);
RCount := 1
END
END;
cur := cur.Next(ASMLINE)
END;
IF R.Size # 0 THEN
PutReloc(R)
END;
IF dll OR con OR gui THEN
WritePE(FName, stk, size - 1000H - LoadAdr, dcount, rdatasize, gsize)
ELSIF kos OR obj THEN
WriteKOS(FName, Align(stk, 4), size, dcount, gsize, obj)
ELSIF elf THEN
WriteELF(FName, size - LoadAdr, temp, gsize)
END
END FixLabels;
 
PROCEDURE OutStringZ(str: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN
New;
current.clen := LENGTH(str);
FOR i := 0 TO current.clen - 1 DO
Code[ccount] := str[i];
INC(ccount)
END;
Code[ccount] := 0X;
INC(ccount);
INC(current.clen)
END OutStringZ;
 
PROCEDURE Epilog*(gsize: INTEGER; FName: ARRAY OF CHAR; stk: INTEGER);
VAR i, glob: INTEGER;
BEGIN
glob := 0;
gsize := Align(gsize, 4) + 4;
COPY(FName, OutFile);
Labels[RTABLE] := -dcount;
dataint(recarray[0]);
FOR i := 1 TO reccount DO
dataint(recarray[i])
END;
current := start;
IF con OR gui OR dll THEN
PushInt(LoadLibrary);
PushInt(GetProcAddress);
OutCode("5859FF31FF3054")
ELSIF elf THEN
OutCode("6800000000");
glob := current.cmd;
ELSIF kos OR obj THEN
OutByte(54H)
END;
GlobalAdr(0);
PushConst(ASR(gsize, 2));
PushInt(RTABLE);
PushInt(SELFNAME);
CallRTL(_init);
current := asmlist.Last(ASMLINE);
IF dll THEN
OutCode("B801000000C9C20C00")
END;
IF obj THEN
OutCode("B801000000C9C20000")
END;
OutCode("EB05");
Label(ASSRT);
CallRTL(_assrt);
OutCode("EB09");
Label(HALT);
OutCode("6A006A00");
CallRTL(_assrt);
OutCode("6A00");
CallRTL(_halt);
Label(_floor);
OutCode("83EC06D93C2466812424FFF366810C24FFF7D92C2483C402D9FCDB1C2458C3");
IF obj THEN
Label(Exports);
CmdN(szSTART); CmdN(START);
CmdN(szversion); OutInt(stk);
FOR i := 0 TO kosexpcount - 1 DO
CmdN(kosexp[i].NameLabel); CmdN(kosexp[i].Adr)
END;
OutInt(0);
Label(szSTART); OutStringZ("lib_init");
Label(szversion); OutStringZ("version");
FOR i := 0 TO kosexpcount - 1 DO
Label(kosexp[i].NameLabel);
OutStringZ(kosexp[i].Name.Name)
END
END;
FixLabels(FName, stk, gsize, glob)
END Epilog;
 
END X86.