Subversion Repositories Kolibri OS

(*

    Copyright 2016, 2017 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 .

*)

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; stMIN = 26; stMAX = 27;

  sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;

  sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCOPY = 109;

  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);

  PushStProc("MIN",      stMIN);

  PushStProc("MAX",      stMAX);

  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);

      IF (nov.Base.tType = TPOINTER) & (nov.Base.Base.tType = TRECORD) THEN

          nov.Base := nov.Base.Base

      END;

      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);