kolibrios/programs/develop/oberon07/Source/DECL.ob07

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

      IF SCAN.tLex = lxIDENT THEN
        last.T := ParseType(coord)
      ELSE
        NEW(NewType);
        MemErr(NewType = NIL);
        last.T := NewType;
        T := StructType(FALSE, NewType)
      END;

      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("COPY",    sysCOPY);
  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.