/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. |