Subversion Repositories Kolibri OS

Rev

Rev 6613 | Go to most recent revision | Blame | Last modification | View Log | Download | RSS feed

  1. (*
  2.     Copyright 2016, 2017 Anton Krotov
  3.  
  4.     This file is part of Compiler.
  5.  
  6.     Compiler is free software: you can redistribute it and/or modify
  7.     it under the terms of the GNU General Public License as published by
  8.     the Free Software Foundation, either version 3 of the License, or
  9.     (at your option) any later version.
  10.  
  11.     Compiler is distributed in the hope that it will be useful,
  12.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14.     GNU General Public License for more details.
  15.  
  16.     You should have received a copy of the GNU General Public License
  17.     along with Compiler. If not, see <http://www.gnu.org/licenses/>.
  18. *)
  19.  
  20. MODULE DECL;
  21.  
  22. IMPORT SCAN, UTILS, X86, SYSTEM;
  23.  
  24. CONST
  25.  
  26.   lxEOF = 0; lxINT = -1; lxREAL = -2; lxSTRING = -3; lxIDENT = -4; lxHEX = -5; lxCHX = -6; lxLONGREAL = -7;
  27.   lxARRAY = 1; lxBEGIN = 2; lxBY = 3; lxCASE = 4; lxCONST = 5; lxDIV = 6; lxDO = 7; lxELSE = 8;
  28.   lxELSIF = 9; lxEND = 10; lxFALSE = 11; lxFOR = 12; lxIF = 13; lxIMPORT = 14; lxIN = 15; lxIS = 16;
  29.   lxMOD = 17; lxMODULE = 18; lxNIL = 19; lxOF = 20; lxOR = 21; lxPOINTER = 22; lxPROCEDURE = 23;
  30.   lxRECORD = 24; lxREPEAT = 25; lxRETURN = 26; lxTHEN = 27; lxTO = 28; lxTRUE = 29; lxTYPE = 30;
  31.   lxUNTIL = 31; lxVAR = 32; lxWHILE = 33;
  32.  
  33.   lxPlus = 51; lxMinus = 52; lxMult = 53; lxSlash = 54; lxNot = 55; lxAnd = 56; lxComma = 57; lxSemi = 58;
  34.   lxStick = 59; lxLRound = 60; lxLSquare = 61; lxLCurly = 62; lxCaret = 63; lxRRound = 64; lxRSquare = 65;
  35.   lxRCurly = 66; lxDot = 67; lxDbl = 68; lxAssign = 69; lxColon = 70;
  36.   lxEQ = 71; lxNE = 72; lxLT = 73; lxGT = 74; lxLE = 75; lxGE = 76;
  37.  
  38.   lxERR0 = 100; lxERR1 = 101; lxERR2 = 102; lxERR3 = 103; lxERR4 = 104; lxERR5 = 105; lxERR6 = 106;
  39.   lxERR7 = 107; lxERR8 = 108; lxERR9 = 109; lxERR10 = 110; lxERR11 = 111; lxERR20 = 120;
  40.  
  41.   IDMOD = 1; IDCONST = 2; IDTYPE = 3; IDVAR = 4; IDPROC = 5; IDSTPROC = 6; IDGUARD = 7; IDPARAM = 8; IDSYSPROC = 9;
  42.  
  43.   stABS = 1; stODD = 2; stLEN = 3; stLSL = 4; stASR = 5; stROR = 6; stFLOOR = 7; stFLT = 8;
  44.   stORD = 9; stCHR = 10; stLONG = 11; stSHORT = 12; stINC = 13; stDEC = 14; stINCL = 15;
  45.   stEXCL = 16; stCOPY = 17; stNEW = 18; stASSERT = 19; stPACK = 20; stUNPK = 21; stDISPOSE = 22;
  46.   stBITS = 23; stLSR = 24; stLENGTH = 25; stMIN = 26; stMAX = 27;
  47.  
  48.   sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
  49.   sysCODE = 106; sysTYPEID = 107; sysMOVE = 108; sysCOPY = 109;
  50.  
  51.   TINTEGER = 1; TREAL = 2; TLONGREAL = 3; TCHAR = 4; TSET = 5; TBOOLEAN = 6; TVOID = 7; TNIL = 8;
  52.   TCARD16 = 9; TSTRING = 10; TARRAY = 11; TRECORD = 12; TPOINTER = 13; TPROC = 14;
  53.  
  54.   TNUM = {TINTEGER, TREAL, TLONGREAL};
  55.   TFLOAT = {TREAL, TLONGREAL};
  56.   TSTRUCT = {TARRAY, TRECORD};
  57.  
  58.   paramvar* = 1; param* = 2;
  59.  
  60.   defcall = 0; stdcall = 1; cdecl = 2; winapi* = 3;
  61.  
  62.   record = 0; union = 1; noalign = 2;
  63.  
  64.   eVAR = 1; eCONST = 2; eEXP = 3; ePROC = 4; eSTPROC = 5; eSYSPROC = 6;
  65.  
  66.   IOVER* = lxERR5 - lxERR0;
  67.   FOVER* = lxERR7 - lxERR0;
  68.   UNDER* = lxERR9 - lxERR0;
  69.  
  70. TYPE
  71.  
  72.   pTYPE* = POINTER TO RECORD (UTILS.rITEM)
  73.     tType*, Size*, Len*, Number*, Align, Call*, Rec: INTEGER;
  74.     Base*: pTYPE;
  75.     Fields*: UTILS.LIST
  76.   END;
  77.  
  78.   IDENT* = POINTER TO rIDENT;
  79.  
  80.   UNIT* = POINTER TO RECORD (UTILS.rITEM)
  81.     Name: SCAN.NODE;
  82.     File: UTILS.STRING;
  83.     Idents: UTILS.LIST;
  84.     Import: UTILS.LIST;
  85.     IdentBegin: IDENT;
  86.     scanner: SCAN.SCANNER;
  87.     Level*: INTEGER;
  88.     Closed, typedecl, Std, sys: BOOLEAN
  89.   END;
  90.  
  91.   rIDENT* = RECORD (UTILS.rITEM)
  92.     Name*: SCAN.NODE;
  93.     T*: pTYPE;
  94.     Unit*: UNIT;
  95.     Parent*: IDENT;
  96.     Proc*: UTILS.ITEM;
  97.     Value*: LONGREAL;
  98.     coord*: SCAN.TCoord;
  99.     Number*, iType*, StProc*, VarSize, ParamSize*,
  100.     LocalSize*, Offset*, VarKind*, Level*, ParamCount*: INTEGER;
  101.     Export: BOOLEAN
  102.   END;
  103.  
  104.   PTRBASE = POINTER TO RECORD (UTILS.rITEM)
  105.     Name: SCAN.NODE;
  106.     coord: SCAN.TCoord;
  107.     Ptr: pTYPE
  108.   END;
  109.  
  110.   STRITEM = POINTER TO RECORD (UTILS.rITEM)
  111.     Str: UTILS.STRING
  112.   END;
  113.  
  114.   FIELD* = POINTER TO RECORD (UTILS.rITEM)
  115.     Name: SCAN.NODE;
  116.     T*: pTYPE;
  117.     Offset*: INTEGER;
  118.     ByRef*, Export*: BOOLEAN;
  119.     Unit*: UNIT
  120.   END;
  121.  
  122.   EXPRESSION* = RECORD
  123.     id*: IDENT;
  124.     T*: pTYPE;
  125.     eType*: INTEGER;
  126.     Value*: LONGREAL;
  127.     Read*, vparam*, deref*: BOOLEAN
  128.   END;
  129.  
  130.   opPROC = PROCEDURE;
  131.   expPROC = PROCEDURE (VAR e: EXPRESSION);
  132.   assPROC = PROCEDURE (e: EXPRESSION; T: pTYPE; param: BOOLEAN): BOOLEAN;
  133.  
  134.   stTYPES* = ARRAY 11 OF pTYPE;
  135.  
  136.   Proc* = POINTER TO RECORD (UTILS.rITEM)
  137.     used: BOOLEAN;
  138.     beg, end: X86.ASMLINE;
  139.     Procs*: UTILS.LIST
  140.   END;
  141.  
  142. VAR
  143.  
  144.   sttypes: stTYPES; unit*, sys: UNIT; curBlock*: IDENT;
  145.   Path, Main, Std, ExtMain: UTILS.STRING;
  146.   NamePtrBase: SCAN.NODE; ProgSize*, RecCount, UnitNumber*: INTEGER;
  147.   PtrBases, Strings, types, prog, procs: UTILS.LIST; OpSeq: opPROC; Expr: expPROC;
  148.   AssComp: assPROC; main, sizefunc, winplatf, Const*: BOOLEAN;
  149.   pParseType: PROCEDURE (VAR coord: SCAN.TCoord): pTYPE;
  150.   pReadModule: PROCEDURE (Path, Name, Ext: UTILS.STRING): BOOLEAN;
  151.   Platform: INTEGER; voidtype: pTYPE; zcoord: SCAN.TCoord;
  152.   curproc*: Proc;
  153.  
  154. PROCEDURE SetSizeFunc*;
  155. BEGIN
  156.   sizefunc := TRUE
  157. END SetSizeFunc;
  158.  
  159. PROCEDURE MemErr*(err: BOOLEAN);
  160. BEGIN
  161.   IF err THEN
  162.     UTILS.MemErr(TRUE)
  163.   END
  164. END MemErr;
  165.  
  166. PROCEDURE GetString*(adr: LONGREAL): UTILS.STRCONST;
  167. VAR str: UTILS.STRCONST;
  168. BEGIN
  169.   SYSTEM.PUT(SYSTEM.ADR(str), FLOOR(adr))
  170.   RETURN str
  171. END GetString;
  172.  
  173. PROCEDURE AddString*(str: UTILS.STRING): UTILS.STRCONST;
  174. VAR nov: UTILS.STRCONST;
  175. BEGIN
  176.   nov := UTILS.GetStr(Strings, str);
  177.   IF nov = NIL THEN
  178.     NEW(nov);
  179.     MemErr(nov = NIL);
  180.     nov.Str := str;
  181.     nov.Len := SCAN.count - 1;
  182.     nov.Number := X86.NewLabel();
  183.     UTILS.Push(Strings, nov);
  184.     X86.String(nov.Number, nov.Len, nov.Str)
  185.   END
  186.   RETURN nov
  187. END AddString;
  188.  
  189. PROCEDURE AddMono*(c: CHAR): UTILS.STRCONST;
  190. VAR nov: UTILS.STRCONST; s: UTILS.STRING;
  191. BEGIN
  192.   s[0] := c;
  193.   s[1] := 0X;
  194.   nov := UTILS.GetStr(Strings, s);
  195.   IF nov = NIL THEN
  196.     NEW(nov);
  197.     MemErr(nov = NIL);
  198.     nov.Str := s;
  199.     nov.Len := 1;
  200.     nov.Number := X86.NewLabel();
  201.     UTILS.Push(Strings, nov);
  202.     X86.String(nov.Number, nov.Len, nov.Str)
  203.   END
  204.   RETURN nov
  205. END AddMono;
  206.  
  207. PROCEDURE Coord(VAR coord: SCAN.TCoord);
  208. BEGIN
  209.   coord := SCAN.coord
  210. END Coord;
  211.  
  212. PROCEDURE GetModule(Name: SCAN.NODE): UNIT;
  213. VAR cur, res: UNIT;
  214. BEGIN
  215.   res := NIL;
  216.   cur := prog.First(UNIT);
  217.   WHILE (cur # NIL) & UTILS.streq(cur.Name.Name, Name.Name) DO
  218.     res := cur;
  219.     cur := NIL
  220.   ELSIF cur # NIL DO
  221.     cur := cur.Next(UNIT)
  222.   END
  223.   RETURN res
  224. END GetModule;
  225.  
  226. PROCEDURE Assert*(cond: BOOLEAN; coord: SCAN.TCoord; code: INTEGER);
  227. BEGIN
  228.   IF ~cond THEN
  229.     UTILS.ErrMsgPos(coord.line, coord.col, code);
  230.     UTILS.HALT(1)
  231.   END
  232. END Assert;
  233.  
  234. PROCEDURE Assert2(cond: BOOLEAN; code: INTEGER);
  235. BEGIN
  236.   IF ~cond THEN
  237.     Assert(FALSE, SCAN.coord, code)
  238.   END
  239. END Assert2;
  240.  
  241. PROCEDURE Next*;
  242. VAR coord: SCAN.TCoord;
  243. BEGIN
  244.   SCAN.GetLex;
  245.   IF (SCAN.tLex > lxERR0) & (SCAN.tLex < lxERR20) THEN
  246.     coord.line := SCAN.coord.line;
  247.     coord.col := SCAN.coord.col + SCAN.count;
  248.     Assert(FALSE, coord, SCAN.tLex - lxERR0)
  249.   END;
  250.   Assert2(SCAN.tLex # lxEOF, 27)
  251. END Next;
  252.  
  253. PROCEDURE NextCoord(VAR coord: SCAN.TCoord);
  254. BEGIN
  255.   Next;
  256.   coord := SCAN.coord
  257. END NextCoord;
  258.  
  259. PROCEDURE Check*(key: INTEGER);
  260. VAR code: INTEGER;
  261. BEGIN
  262.   IF SCAN.tLex # key THEN
  263.     CASE key OF
  264.     |lxMODULE:  code := 21
  265.     |lxIDENT:   code := 22
  266.     |lxSemi:    code := 23
  267.     |lxEND:     code := 24
  268.     |lxDot:     code := 25
  269.     |lxEQ:      code := 35
  270.     |lxRRound:  code := 38
  271.     |lxTO:      code := 40
  272.     |lxOF:      code := 41
  273.     |lxRCurly:  code := 51
  274.     |lxLRound:  code := 56
  275.     |lxComma:   code := 61
  276.     |lxTHEN:    code := 98
  277.     |lxRSquare: code := 109
  278.     |lxDO:      code := 118
  279.     |lxUNTIL:   code := 119
  280.     |lxAssign:  code := 120
  281.     |lxRETURN:  code := 124
  282.     |lxColon:   code := 157
  283.     ELSE
  284.     END;
  285.     Assert2(FALSE, code)
  286.   END
  287. END Check;
  288.  
  289. PROCEDURE NextCheck(key: INTEGER);
  290. BEGIN
  291.   Next;
  292.   Check(key)
  293. END NextCheck;
  294.  
  295. PROCEDURE CheckIdent(Name: SCAN.NODE): BOOLEAN;
  296. VAR cur: IDENT;
  297. BEGIN
  298.   cur := unit.Idents.Last(IDENT);
  299.   WHILE (cur.iType # IDGUARD) & (cur.Name # Name) DO
  300.     cur := cur.Prev(IDENT)
  301.   END
  302.   RETURN cur.iType = IDGUARD
  303. END CheckIdent;
  304.  
  305. PROCEDURE Guard;
  306. VAR ident: IDENT;
  307. BEGIN
  308.   NEW(ident);
  309.   MemErr(ident = NIL);
  310.   ident.Name := NIL;
  311.   ident.iType := IDGUARD;
  312.   ident.T := voidtype;
  313.   UTILS.Push(unit.Idents, ident);
  314.   INC(unit.Level)
  315. END Guard;
  316.  
  317. PROCEDURE PushIdent(Name: SCAN.NODE; coord: SCAN.TCoord; iType: INTEGER; T: pTYPE; u: UNIT; Export: BOOLEAN; StProc: INTEGER);
  318. VAR ident: IDENT; i: INTEGER;
  319. BEGIN
  320.   Assert(CheckIdent(Name), coord, 30);
  321.   NEW(ident);
  322.   MemErr(ident = NIL);
  323.   ident.Name := Name;
  324.   ident.coord := coord;
  325.   IF iType IN {IDPROC, IDMOD} THEN
  326.     ident.Number := X86.NewLabel();
  327.     i := X86.NewLabel();
  328.     i := X86.NewLabel();
  329.     i := X86.NewLabel()
  330.   END;
  331.   ident.iType := iType;
  332.   ident.T := T;
  333.   ident.Unit := u;
  334.   ident.Export := Export;
  335.   ident.StProc := StProc;
  336.   ident.Level := unit.Level;
  337.   UTILS.Push(unit.Idents, ident)
  338. END PushIdent;
  339.  
  340. PROCEDURE StTypes;
  341. VAR type: pTYPE; i: INTEGER;
  342. BEGIN
  343.   sttypes[0] := NIL;
  344.   FOR i := TINTEGER TO TSTRING DO
  345.     NEW(type);
  346.     MemErr(type = NIL);
  347.     type.tType := i;
  348.     UTILS.Push(types, type);
  349.     sttypes[i] := type
  350.   END;
  351.   sttypes[TINTEGER].Size := 4;
  352.   sttypes[TREAL].Size := 4;
  353.   sttypes[TLONGREAL].Size := 8;
  354.   sttypes[TBOOLEAN].Size := 1;
  355.   sttypes[TCHAR].Size := 1;
  356.   sttypes[TSET].Size := 4;
  357.   sttypes[TVOID].Size := 0;
  358.   sttypes[TSTRING].Size := 0;
  359.   sttypes[TNIL].Size := 4;
  360.   sttypes[TCARD16].Size := 2;
  361.   FOR i := TINTEGER TO TSTRING DO
  362.     sttypes[i].Align := sttypes[i].Size
  363.   END
  364. END StTypes;
  365.  
  366. PROCEDURE PushStProc(Name: UTILS.STRING; StProc: INTEGER);
  367. BEGIN
  368.   PushIdent(SCAN.AddNode(Name), zcoord, IDSTPROC, voidtype, NIL, FALSE, StProc)
  369. END PushStProc;
  370.  
  371. PROCEDURE PushStType(Name: UTILS.STRING; T: INTEGER);
  372. BEGIN
  373.   PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, FALSE, 0)
  374. END PushStType;
  375.  
  376. PROCEDURE PushSysProc(Name: UTILS.STRING; StProc: INTEGER);
  377. BEGIN
  378.   PushIdent(SCAN.AddNode(Name), zcoord, IDSYSPROC, voidtype, NIL, TRUE, StProc)
  379. END PushSysProc;
  380.  
  381. PROCEDURE PushSysType(Name: UTILS.STRING; T: INTEGER);
  382. BEGIN
  383.   PushIdent(SCAN.AddNode(Name), zcoord, IDTYPE, sttypes[T], NIL, TRUE, 0)
  384. END PushSysType;
  385.  
  386. PROCEDURE StIdent;
  387. BEGIN
  388.   Guard;
  389.   PushStProc("ABS",      stABS);
  390.   PushStProc("ASR",      stASR);
  391.   PushStProc("ASSERT",   stASSERT);
  392.   PushStType("BOOLEAN",  TBOOLEAN);
  393.   PushStType("CHAR",     TCHAR);
  394.   PushStProc("CHR",      stCHR);
  395.   PushStProc("COPY",     stCOPY);
  396.   PushStProc("DEC",      stDEC);
  397.   PushStProc("DISPOSE",  stDISPOSE);
  398.   PushStProc("EXCL",     stEXCL);
  399.   PushStProc("FLOOR",    stFLOOR);
  400.   PushStProc("FLT",      stFLT);
  401.   PushStProc("INC",      stINC);
  402.   PushStProc("INCL",     stINCL);
  403.   PushStType("INTEGER",  TINTEGER);
  404.   PushStProc("LEN",      stLEN);
  405.   PushStProc("LSL",      stLSL);
  406.   PushStProc("LONG",     stLONG);
  407.   PushStType("LONGREAL", TLONGREAL);
  408.   PushStProc("NEW",      stNEW);
  409.   PushStProc("ODD",      stODD);
  410.   PushStProc("ORD",      stORD);
  411.   PushStProc("PACK",     stPACK);
  412.   PushStType("REAL",     TREAL);
  413.   PushStProc("ROR",      stROR);
  414.   PushStType("SET",      TSET);
  415.   PushStProc("SHORT",    stSHORT);
  416.   PushStProc("UNPK",     stUNPK);
  417.   PushStProc("BITS",     stBITS);
  418.   PushStProc("LSR",      stLSR);
  419.   PushStProc("LENGTH",   stLENGTH);
  420.   PushStProc("MIN",      stMIN);
  421.   PushStProc("MAX",      stMAX);
  422.   Guard
  423. END StIdent;
  424.  
  425. PROCEDURE GetQIdent*(Unit: UNIT; Name: SCAN.NODE): IDENT;
  426. VAR cur, res: IDENT;
  427. BEGIN
  428.   res := NIL;
  429.   cur := Unit.IdentBegin.Next(IDENT);
  430.   WHILE (cur # NIL) & (cur.iType # IDGUARD) DO
  431.     IF cur.Name = Name THEN
  432.       IF (Unit # unit) & ~cur.Export THEN
  433.         res := NIL
  434.       ELSE
  435.         res := cur
  436.       END;
  437.       cur := NIL
  438.     ELSE
  439.       cur := cur.Next(IDENT)
  440.     END
  441.   END
  442.   RETURN res
  443. END GetQIdent;
  444.  
  445. PROCEDURE GetIdent*(Name: SCAN.NODE): IDENT;
  446. VAR cur, res: IDENT;
  447. BEGIN
  448.   res := NIL;
  449.   cur := unit.Idents.Last(IDENT);
  450.   WHILE (cur # NIL) & (cur.Name = Name) DO
  451.     res := cur;
  452.     cur := NIL
  453.   ELSIF cur # NIL DO
  454.     cur := cur.Prev(IDENT)
  455.   END
  456.   RETURN res
  457. END GetIdent;
  458.  
  459. PROCEDURE Relation*(Op: INTEGER): BOOLEAN;
  460. VAR Res: BOOLEAN;
  461. BEGIN
  462.   CASE Op OF
  463.   |lxEQ, lxNE, lxLT, lxGT,
  464.    lxLE, lxGE, lxIN, lxIS:
  465.     Res := TRUE
  466.   ELSE
  467.     Res := FALSE
  468.   END
  469.   RETURN Res
  470. END Relation;
  471.  
  472. PROCEDURE Arith(a, b: LONGREAL; T: pTYPE; Op: INTEGER; coord: SCAN.TCoord): LONGREAL;
  473. CONST max = SCAN.maxDBL;
  474. VAR res: LONGREAL;
  475. BEGIN
  476.   CASE Op OF
  477.   |lxPlus: res := a + b
  478.   |lxMinus: res := a - b
  479.   |lxMult: res := a * b
  480.   |lxSlash:
  481.     Assert(b # 0.0D0, coord, 46);
  482.     res := a / b
  483.   |lxDIV:
  484.     Assert(~((a = LONG(FLT(SCAN.minINT))) & (b = -1.0D0)), coord, IOVER);
  485.     res := LONG(FLT(FLOOR(a) DIV FLOOR(b)))
  486.   |lxMOD:
  487.     res := LONG(FLT(FLOOR(a) MOD FLOOR(b)))
  488.   ELSE
  489.   END;
  490.   Assert(~UTILS.IsInf(res), coord, FOVER);
  491.   CASE T.tType OF
  492.   |TINTEGER:  Assert((res <= LONG(FLT(SCAN.maxINT))) & (res >= LONG(FLT(SCAN.minINT))), coord, IOVER)
  493.   |TREAL:     Assert((res <= LONG(SCAN.maxREAL)) & (res >= -LONG(SCAN.maxREAL)), coord, FOVER)
  494.   |TLONGREAL: Assert((res <= max) & (res >= -max), coord, FOVER)
  495.   ELSE
  496.   END;
  497.   IF (res = 0.0D0) & (T.tType IN TFLOAT) OR (ABS(res) < LONG(SCAN.minREAL)) & (T.tType = TREAL) THEN
  498.     CASE Op OF
  499.     |lxPlus:  Assert(a = -b, coord, UNDER)
  500.     |lxMinus: Assert(a = b, coord, UNDER)
  501.     |lxMult:  Assert((a = 0.0D0) OR (b = 0.0D0), coord, UNDER)
  502.     |lxSlash: Assert((a = 0.0D0), coord, UNDER)
  503.     ELSE
  504.     END
  505.   END
  506.   RETURN res
  507. END Arith;
  508.  
  509. PROCEDURE strcmp(a, b: LONGREAL; Op: INTEGER): LONGREAL;
  510. VAR sa, sb: UTILS.STRCONST; Res: LONGREAL;
  511. BEGIN
  512.   sa := GetString(a);
  513.   sb := GetString(b);
  514.   CASE Op OF
  515.   |lxEQ, lxNE: Res := LONG(FLT(ORD(sa.Str = sb.Str)))
  516.   |lxLT, lxGT: Res := LONG(FLT(ORD(sa.Str < sb.Str)))
  517.   |lxLE, lxGE: Res := LONG(FLT(ORD(sa.Str <= sb.Str)))
  518.   ELSE
  519.   END
  520.   RETURN Res
  521. END strcmp;
  522.  
  523. PROCEDURE Calc*(a, b: LONGREAL; Ta, Tb: pTYPE; Op: INTEGER; coord: SCAN.TCoord; VAR Res: LONGREAL; VAR TRes: pTYPE);
  524. VAR c: LONGREAL; ai, bi: INTEGER;
  525. BEGIN
  526.   ai := FLOOR(a);
  527.   bi := FLOOR(b);
  528.   IF Op # lxIN THEN
  529.     Assert(Ta = Tb, coord, 37)
  530.   END;
  531.   CASE Op OF
  532.   |lxPlus, lxMinus, lxMult, lxSlash:
  533.     Assert(~((Op = lxSlash) & (Ta.tType = TINTEGER)), coord, 37);
  534.     IF Ta.tType IN TNUM THEN
  535.       Res := Arith(a, b, Ta, Op, coord)
  536.     ELSIF Ta.tType = TSET THEN
  537.       CASE Op OF
  538.       |lxPlus:  Res := LONG(FLT(ORD(BITS(ai) + BITS(bi))))
  539.       |lxMinus: Res := LONG(FLT(ORD(BITS(ai) - BITS(bi))))
  540.       |lxMult:  Res := LONG(FLT(ORD(BITS(ai) * BITS(bi))))
  541.       |lxSlash: Res := LONG(FLT(ORD(BITS(ai) / BITS(bi))))
  542.       ELSE
  543.       END
  544.     ELSE
  545.       Assert(FALSE, coord, 37)
  546.     END;
  547.     TRes := Ta
  548.   |lxDIV, lxMOD:
  549.     Assert(Ta.tType = TINTEGER, coord, 37);
  550.     Assert(bi # 0, coord, 48);
  551.     TRes := Ta;
  552.     Res := Arith(a, b, Ta, Op, coord)
  553.   |lxAnd:
  554.     Assert(Ta.tType = TBOOLEAN, coord, 37);
  555.     Res := LONG(FLT(ORD((ai # 0) & (bi # 0))))
  556.   |lxOR:
  557.     Assert(Ta.tType = TBOOLEAN, coord, 37);
  558.     Res := LONG(FLT(ORD((ai # 0) OR (bi # 0))))
  559.   |lxEQ, lxNE:
  560.     IF Ta.tType = TSTRING THEN
  561.       Res := strcmp(a, b, Op)
  562.     ELSE
  563.       Res := LONG(FLT(ORD(a = b)))
  564.     END;
  565.     IF Op = lxNE THEN
  566.       Res := LONG(FLT(ORD(Res = 0.0D0)))
  567.     END
  568.   |lxLT, lxGT:
  569.     IF Op = lxGT THEN
  570.       c := a;
  571.       a := b;
  572.       b := c
  573.     END;
  574.     Assert(Ta.tType IN (TNUM + {TSTRING}), coord, 37);
  575.     IF Ta.tType = TSTRING THEN
  576.       Res := strcmp(a, b, Op)
  577.     ELSE
  578.       Res := LONG(FLT(ORD(a < b)))
  579.     END
  580.   |lxLE, lxGE:
  581.     IF Op = lxGE THEN
  582.       c := a;
  583.       a := b;
  584.       b := c
  585.     END;
  586.     Assert(Ta.tType IN (TNUM + {TSTRING, TSET}), coord, 37);
  587.     IF Ta.tType = TSTRING THEN
  588.       Res := strcmp(a, b, Op)
  589.     ELSIF Ta.tType = TSET THEN
  590.       Res := LONG(FLT(ORD(BITS(FLOOR(a)) <= BITS(FLOOR(b)))))
  591.     ELSE
  592.       Res := LONG(FLT(ORD(a <= b)))
  593.     END
  594.   |lxIN:
  595.     Assert((Ta.tType = TINTEGER) & (Tb.tType = TSET), coord, 37);
  596.     Assert(ASR(ai, 5) = 0, coord, 49);
  597.     Res := LONG(FLT(ORD(ai IN BITS(bi))))
  598.   ELSE
  599.   END;
  600.   IF Relation(Op) OR (Op = lxAnd) OR (Op = lxOR) THEN
  601.     TRes := sttypes[TBOOLEAN]
  602.   END
  603. END Calc;
  604.  
  605. PROCEDURE ConstExpr*(VAR Value: LONGREAL; VAR T: pTYPE);
  606. VAR e: EXPRESSION; coord: SCAN.TCoord;
  607. BEGIN
  608.   Const := TRUE;
  609.   Coord(coord);
  610.   sizefunc := FALSE;
  611.   Expr(e);
  612.   Assert(~sizefunc & (e.eType = eCONST), coord, 62);
  613.   Value := e.Value;
  614.   T := e.T;
  615.   Const := FALSE
  616. END ConstExpr;
  617.  
  618. PROCEDURE IdType*(VAR coord: SCAN.TCoord): pTYPE;
  619. VAR id: IDENT; Name: SCAN.NODE; Unit: UNIT; Res: pTYPE;
  620. BEGIN
  621.   Res := NIL;
  622.   Name := SCAN.id;
  623.   id := GetIdent(Name);
  624.   IF id = NIL THEN
  625.     Coord(coord);
  626.     NamePtrBase := Name;
  627.     Next
  628.   ELSE
  629.     IF id.iType = IDTYPE THEN
  630.       Coord(coord);
  631.       Next;
  632.       Res := id.T
  633.     ELSIF id.iType = IDMOD THEN
  634.       Unit := id.Unit;
  635.       NextCheck(lxDot);
  636.       NextCheck(lxIDENT);
  637.       Name := SCAN.id;
  638.       NamePtrBase := Name;
  639.       id := GetQIdent(Unit, Name);
  640.       IF Unit # unit THEN
  641.         Assert2(id # NIL, 42);
  642.         Assert2(id.iType = IDTYPE, 77);
  643.         Coord(coord);
  644.         Next;
  645.         Res := id.T
  646.       ELSE
  647.         IF id = NIL THEN
  648.           Assert2((unit.Level = 3) & unit.typedecl, 42);
  649.           Coord(coord);
  650.           Next;
  651.           Res := NIL
  652.         ELSE
  653.           Assert2(id.iType = IDTYPE, 77);
  654.           Coord(coord);
  655.           Next;
  656.           Res := id.T
  657.         END
  658.       END
  659.     ELSE
  660.       Assert2(FALSE, 77)
  661.     END
  662.   END
  663.   RETURN Res
  664. END IdType;
  665.  
  666. PROCEDURE FieldOffset(Align, RecSize: INTEGER): INTEGER;
  667. BEGIN
  668.   Assert2(RecSize <= SCAN.maxINT - (Align - RecSize MOD Align) MOD Align, 83)
  669.   RETURN RecSize + (Align - RecSize MOD Align) MOD Align
  670. END FieldOffset;
  671.  
  672. PROCEDURE Dim*(T: pTYPE): INTEGER;
  673. VAR n: INTEGER;
  674. BEGIN
  675.   n := 0;
  676.   WHILE (T.tType = TARRAY) & (T.Len = 0) DO
  677.     INC(n);
  678.     T := T.Base
  679.   END
  680.   RETURN n
  681. END Dim;
  682.  
  683. PROCEDURE SetFields(Tr, Tf: pTYPE; Rec: BOOLEAN);
  684. VAR cur: FIELD;
  685. BEGIN
  686.   cur := Tr.Fields.First(FIELD);
  687.   WHILE cur.T # NIL DO
  688.     cur := cur.Next(FIELD)
  689.   END;
  690.   WHILE cur # NIL DO
  691.     cur.T := Tf;
  692.     IF Rec THEN
  693.       IF Tf.Align > Tr.Align THEN
  694.         Tr.Align := Tf.Align
  695.       END;
  696.       IF Tr.Rec = record THEN
  697.         cur.Offset := FieldOffset(Tf.Align, Tr.Size);
  698.         Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
  699.         Tr.Size := cur.Offset + Tf.Size
  700.       ELSIF Tr.Rec = noalign THEN
  701.         cur.Offset := FieldOffset(1, Tr.Size);
  702.         Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
  703.         Tr.Size := cur.Offset + Tf.Size
  704.       ELSIF Tr.Rec = union THEN
  705.         IF Tf.Size > Tr.Size THEN
  706.           Tr.Size := Tf.Size
  707.         END;
  708.         cur.Offset := 0
  709.       END
  710.     ELSE
  711.       Tr.Len := Tr.Len + 4 * (ORD((Tf.tType = TRECORD) & cur.ByRef) + Dim(Tf) + ORD((Tf.tType = TLONGREAL) & ~cur.ByRef) + 1)
  712.     END;
  713.     cur := cur.Next(FIELD)
  714.   END
  715. END SetFields;
  716.  
  717. PROCEDURE GetField*(T: pTYPE; Name: SCAN.NODE): FIELD;
  718. VAR cur, Res: FIELD;
  719. BEGIN
  720.   Res := NIL;
  721.   cur := T.Fields.First(FIELD);
  722.   WHILE (cur # NIL) & (cur.Name = Name) DO
  723.     Res := cur;
  724.     cur := NIL
  725.   ELSIF cur # NIL DO
  726.     cur := cur.Next(FIELD)
  727.   END
  728.   RETURN Res
  729. END GetField;
  730.  
  731. PROCEDURE Unique(T: pTYPE; Name: SCAN.NODE): BOOLEAN;
  732. VAR field: FIELD; res: BOOLEAN;
  733. BEGIN
  734.   res := TRUE;
  735.   WHILE (T # NIL) & res DO
  736.     field := GetField(T, Name);
  737.     IF field # NIL THEN
  738.       IF (field.Unit = unit) OR field.Export THEN
  739.         res := FALSE
  740.       END
  741.     END;
  742.     T := T.Base
  743.   END
  744.   RETURN res
  745. END Unique;
  746.  
  747. PROCEDURE notrecurs(id: BOOLEAN; T: pTYPE): BOOLEAN;
  748.   RETURN ~(id & (unit.Idents.Last(IDENT).iType = IDTYPE) & (unit.Idents.Last(IDENT).T = T) &
  749.           (T.tType IN TSTRUCT))
  750. END notrecurs;
  751.  
  752. PROCEDURE ReadFields(T: pTYPE);
  753. VAR Name: SCAN.NODE; field: FIELD; Tf: pTYPE; coord: SCAN.TCoord; id_T: BOOLEAN;
  754. BEGIN
  755.   WHILE SCAN.tLex = lxIDENT DO
  756.     Name := SCAN.id;
  757.     Assert2(Unique(T, Name), 30);
  758.     NEW(field);
  759.     MemErr(field = NIL);
  760.     UTILS.Push(T.Fields, field);
  761.     field.Name := Name;
  762.     field.T := NIL;
  763.     field.Export := FALSE;
  764.     field.Unit := unit;
  765.     Next;
  766.     IF SCAN.tLex = lxMult THEN
  767.       Assert2(unit.Level = 3, 89);
  768.       field.Export := TRUE;
  769.       Next
  770.     END;
  771.     IF SCAN.tLex = lxComma THEN
  772.       NextCheck(lxIDENT)
  773.     ELSIF SCAN.tLex = lxColon THEN
  774.       NextCoord(coord);
  775.       id_T := SCAN.tLex = lxIDENT;
  776.       Tf:= pParseType(coord);
  777.       Assert(Tf # NIL, coord, 42);
  778.       Assert(notrecurs(id_T, Tf), coord, 96);
  779.       SetFields(T, Tf, TRUE);
  780.       IF SCAN.tLex = lxSemi THEN
  781.         NextCheck(lxIDENT)
  782.       ELSE
  783.         Assert2(SCAN.tLex = lxEND, 86)
  784.       END
  785.     ELSE
  786.       Assert2(FALSE, 85)
  787.     END
  788.   END
  789. END ReadFields;
  790.  
  791. PROCEDURE OpenBase*(T: pTYPE): pTYPE;
  792. BEGIN
  793.   WHILE (T.tType = TARRAY) & (T.Len = 0) DO
  794.     T := T.Base
  795.   END
  796.   RETURN T
  797. END OpenBase;
  798.  
  799. PROCEDURE SetVars(T: pTYPE);
  800. VAR cur: IDENT; n: INTEGER;
  801. BEGIN
  802.   cur := unit.Idents.Last(IDENT);
  803.   WHILE cur.T = NIL DO
  804.     cur := cur.Prev(IDENT)
  805.   END;
  806.   cur := cur.Next(IDENT);
  807.   WHILE cur # NIL DO
  808.     cur.T := T;
  809.     IF(cur.VarKind = paramvar) OR (cur.VarKind = param) & (T.tType IN TSTRUCT) THEN
  810.       n := 4 * (1 + Dim(T) + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
  811.     ELSE
  812.       n := T.Size;
  813.       Assert2(n <= SCAN.maxINT - UTILS.Align(n), 93);
  814.       n := n + UTILS.Align(n)
  815.     END;
  816.     IF cur.Level = 3 THEN
  817.       cur.Offset := ProgSize;
  818.       Assert2(ProgSize <= SCAN.maxINT - n, 93);
  819.       ProgSize := ProgSize + n;
  820.       Assert2(ProgSize <= SCAN.maxINT - UTILS.Align(ProgSize), 93);
  821.       ProgSize := ProgSize + UTILS.Align(ProgSize)
  822.     ELSE
  823.       IF cur.VarKind = 0 THEN
  824.         cur.Offset := curBlock.ParamSize - curBlock.VarSize - n
  825.       ELSE
  826.         cur.Offset := curBlock.VarSize - 8 + 4 * (cur.Level + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
  827.       END
  828.     END;
  829.     Assert2(curBlock.VarSize <= SCAN.maxINT - n, 93);
  830.     curBlock.VarSize := curBlock.VarSize + n;
  831.     Assert2(curBlock.VarSize <= SCAN.maxINT - UTILS.Align(curBlock.VarSize), 93);
  832.     curBlock.VarSize := curBlock.VarSize + UTILS.Align(curBlock.VarSize);
  833.     IF cur.VarKind # 0 THEN
  834.       curBlock.ParamSize := curBlock.VarSize
  835.     END;
  836.     cur := cur.Next(IDENT)
  837.   END
  838. END SetVars;
  839.  
  840. PROCEDURE CreateType(tType, Len, Size, Number: INTEGER; Base: pTYPE; Fields: BOOLEAN; NewType: pTYPE): pTYPE;
  841. VAR nov: pTYPE;
  842. BEGIN
  843.   IF NewType = NIL THEN
  844.     NEW(nov);
  845.     MemErr(nov = NIL)
  846.   ELSE
  847.     nov := NewType
  848.   END;
  849.   UTILS.Push(types, nov);
  850.   nov.tType := tType;
  851.   nov.Len := Len;
  852.   nov.Size := Size;
  853.   nov.Base := Base;
  854.   nov.Fields := NIL;
  855.   nov.Number := Number;
  856.   IF Fields THEN
  857.     nov.Fields := UTILS.CreateList()
  858.   END
  859.   RETURN nov
  860. END CreateType;
  861.  
  862. PROCEDURE FormalType(VAR coord: SCAN.TCoord): pTYPE;
  863. VAR TA: pTYPE;
  864. BEGIN
  865.   IF SCAN.tLex = lxARRAY THEN
  866.     NextCheck(lxOF);
  867.     Next;
  868.     TA := CreateType(TARRAY, 0, 0, 0, FormalType(coord), FALSE, NIL)
  869.   ELSE
  870.     Check(lxIDENT);
  871.     TA := IdType(coord);
  872.     Assert(TA # NIL, coord, 42);
  873.   END
  874.   RETURN TA
  875. END FormalType;
  876.  
  877. PROCEDURE Section(T: pTYPE);
  878. VAR Name: SCAN.NODE; ByRef, cont: BOOLEAN; field: FIELD;
  879.     Tf: pTYPE; fp: IDENT; coord: SCAN.TCoord; proc: BOOLEAN;
  880. BEGIN
  881.   proc := T = NIL;
  882.   IF proc THEN
  883.     T := curBlock.T
  884.   END;
  885.   Assert2((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR), 84);
  886.   ByRef := FALSE;
  887.   IF SCAN.tLex = lxVAR THEN
  888.     ByRef := TRUE;
  889.     NextCheck(lxIDENT)
  890.   END;
  891.   cont := TRUE;
  892.   WHILE cont DO
  893.     Name := SCAN.id;
  894.     Assert2(GetField(T, Name) = NIL, 30);
  895.     NEW(field);
  896.     MemErr(field = NIL);
  897.     UTILS.Push(T.Fields, field);
  898.     field.Name := Name;
  899.     field.T := NIL;
  900.     field.ByRef := ByRef;
  901.     IF proc THEN
  902.       PushIdent(Name, coord, IDVAR, NIL, NIL, FALSE, 0);
  903.       INC(curBlock.ParamCount);
  904.       fp := unit.Idents.Last(IDENT);
  905.       IF ByRef THEN
  906.         fp.VarKind := paramvar
  907.       ELSE
  908.         fp.VarKind := param
  909.       END
  910.     END;
  911.     Next;
  912.     IF SCAN.tLex = lxComma THEN
  913.       NextCheck(lxIDENT)
  914.     ELSIF SCAN.tLex = lxColon THEN
  915.       Next;
  916.       Tf := FormalType(coord);
  917.       Assert(Dim(Tf) <= X86.ADIM, coord, 110);
  918.       SetFields(T, Tf, FALSE);
  919.       IF proc THEN
  920.         SetVars(Tf)
  921.       END;
  922.       cont := FALSE
  923.     ELSE
  924.       Assert2(FALSE, 85)
  925.     END
  926.   END
  927. END Section;
  928.  
  929. PROCEDURE ParamType(T: pTYPE);
  930. VAR break: BOOLEAN;
  931. BEGIN
  932.   IF (SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR) THEN
  933.     break := FALSE;
  934.     REPEAT
  935.       Section(T);
  936.       IF SCAN.tLex = lxSemi THEN
  937.         Next
  938.       ELSE
  939.         break := TRUE
  940.       END
  941.     UNTIL break
  942.   END
  943. END ParamType;
  944.  
  945. PROCEDURE AddPtrBase(Name: SCAN.NODE; coord: SCAN.TCoord; T: pTYPE);
  946. VAR nov: PTRBASE;
  947. BEGIN
  948.   NEW(nov);
  949.   MemErr(nov = NIL);
  950.   nov.Name := Name;
  951.   nov.coord := coord;
  952.   nov.Ptr := T;
  953.   UTILS.Push(PtrBases, nov)
  954. END AddPtrBase;
  955.  
  956. PROCEDURE FormalList(T: pTYPE; VAR Res: pTYPE);
  957. VAR coord: SCAN.TCoord;
  958. BEGIN
  959.   IF SCAN.tLex = lxLRound THEN
  960.     Next;
  961.     ParamType(T);
  962.     Check(lxRRound);
  963.     Next;
  964.     IF SCAN.tLex = lxColon THEN
  965.       NextCheck(lxIDENT);
  966.       Res := IdType(coord);
  967.       Assert(Res # NIL, coord, 42);
  968.       Assert(~(Res.tType IN TSTRUCT), coord, 82)
  969.     END
  970.   END
  971. END FormalList;
  972.  
  973. PROCEDURE CallFlag(VAR Call: INTEGER): BOOLEAN;
  974. VAR res: BOOLEAN;
  975. BEGIN
  976.   res := SCAN.tLex = lxLSquare;
  977.   IF res THEN
  978.     Next;
  979.     IF SCAN.Lex = "cdecl" THEN
  980.       Call := cdecl
  981.     ELSIF SCAN.Lex = "stdcall" THEN
  982.       Call := stdcall
  983.     ELSIF SCAN.Lex = "winapi" THEN
  984.       Assert2(winplatf, 50);
  985.       Call := winapi
  986.     ELSE
  987.       Assert2(FALSE, 44)
  988.     END;
  989.     NextCheck(lxRSquare);
  990.     Next;
  991.   ELSE
  992.     Call := defcall
  993.   END
  994.   RETURN res
  995. END CallFlag;
  996.  
  997. PROCEDURE RecFlag(VAR rec: INTEGER): BOOLEAN;
  998. VAR res: BOOLEAN;
  999. BEGIN
  1000.   res := SCAN.tLex = lxLSquare;
  1001.   IF res THEN
  1002.     Next;
  1003.     IF SCAN.Lex = "union" THEN
  1004.       rec := union
  1005.     ELSIF SCAN.Lex = "noalign" THEN
  1006.       rec := noalign
  1007.     ELSE
  1008.       Assert2(FALSE, 103)
  1009.     END;
  1010.     NextCheck(lxRSquare);
  1011.     Next;
  1012.   ELSE
  1013.     rec := record
  1014.   END
  1015.   RETURN res
  1016. END RecFlag;
  1017.  
  1018. PROCEDURE StructType(Comma: BOOLEAN; NewType: pTYPE): pTYPE;
  1019. VAR v: LONGREAL; T, nov: pTYPE; coord, coord2: SCAN.TCoord; id_T: BOOLEAN;
  1020. BEGIN
  1021.   CASE SCAN.tLex OF
  1022.   |lxARRAY, lxComma:
  1023.     IF SCAN.tLex = lxComma THEN
  1024.       Assert2(Comma, 39)
  1025.     END;
  1026.     NextCoord(coord);
  1027.     ConstExpr(v, T);
  1028.     Assert(T.tType = TINTEGER, coord, 52);
  1029.     Assert(v > 0.0D0, coord, 78);
  1030.     nov := CreateType(TARRAY, FLOOR(v), 0, 0, NIL, FALSE, NewType);
  1031.     IF SCAN.tLex = lxComma THEN
  1032.       nov.Base := StructType(TRUE, NIL)
  1033.     ELSIF SCAN.tLex = lxOF THEN
  1034.       NextCoord(coord);
  1035.       id_T := SCAN.tLex = lxIDENT;
  1036.       nov.Base := pParseType(coord);
  1037.       Assert(nov.Base # NIL, coord, 42);
  1038.       Assert(notrecurs(id_T, nov.Base), coord, 96)
  1039.     ELSE
  1040.       Assert2(FALSE, 79)
  1041.     END;
  1042.     Assert2(nov.Base.Size <= SCAN.maxINT DIV nov.Len, 83);
  1043.     nov.Size := nov.Base.Size * nov.Len;
  1044.     nov.Align := nov.Base.Align
  1045.   |lxRECORD:
  1046.     NextCoord(coord);
  1047.     INC(RecCount);
  1048.     nov := CreateType(TRECORD, 0, 0, RecCount, NIL, TRUE, NewType);
  1049.     nov.Align := 1;
  1050.     IF RecFlag(nov.Rec) THEN
  1051.       Assert(unit.sys, coord, 111)
  1052.     END;
  1053.     Coord(coord);
  1054.     IF SCAN.tLex = lxLRound THEN
  1055.       NextCoord(coord2);
  1056.       Check(lxIDENT);
  1057.       nov.Base := IdType(coord);
  1058.       Assert(nov.Base # NIL, coord, 42);
  1059.       IF (nov.Base.tType = TPOINTER) & (nov.Base.Base.tType = TRECORD) THEN
  1060.           nov.Base := nov.Base.Base
  1061.       END;
  1062.       Assert(nov.Base.tType = TRECORD, coord, 80);
  1063.       Assert(notrecurs(TRUE, nov.Base), coord, 96);
  1064.       nov.Size := nov.Base.Size;
  1065.       nov.Align := nov.Base.Align;
  1066.       Check(lxRRound);
  1067.       Next;
  1068.       Assert(nov.Rec = record, coord, 112);
  1069.       Assert(nov.Base.Rec = record, coord2, 113)
  1070.     END;
  1071.     ReadFields(nov);
  1072.     Check(lxEND);
  1073.     nov.Size := X86.Align(nov.Size, nov.Align);
  1074.     IF nov.Base # NIL THEN
  1075.       X86.AddRec(nov.Base.Number)
  1076.     ELSE
  1077.       X86.AddRec(0)
  1078.     END;
  1079.     Next
  1080.   |lxPOINTER:
  1081.     NextCheck(lxTO);
  1082.     NextCoord(coord);
  1083.     nov := CreateType(TPOINTER, 0, 4, 0, NIL, FALSE, NewType);
  1084.     nov.Align := 4;
  1085.     nov.Base := pParseType(coord);
  1086.     IF nov.Base = NIL THEN
  1087.       Assert(unit.typedecl, coord, 42);
  1088.       AddPtrBase(NamePtrBase, coord, nov)
  1089.     ELSE
  1090.       Assert(nov.Base.tType = TRECORD, coord, 81)
  1091.     END
  1092.   |lxPROCEDURE:
  1093.     NextCoord(coord);
  1094.     nov := CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NewType);
  1095.     IF CallFlag(nov.Call) THEN
  1096.       Assert(unit.sys, coord, 111)
  1097.     END;
  1098.     nov.Align := 4;
  1099.     FormalList(nov, nov.Base)
  1100.   ELSE
  1101.     Assert2(FALSE, 39)
  1102.   END
  1103.   RETURN nov
  1104. END StructType;
  1105.  
  1106. PROCEDURE ParseType(VAR coord: SCAN.TCoord): pTYPE;
  1107. VAR Res: pTYPE;
  1108. BEGIN
  1109.   IF SCAN.tLex = lxIDENT THEN
  1110.     Res := IdType(coord)
  1111.   ELSE
  1112.     Res := StructType(FALSE, NIL)
  1113.   END
  1114.   RETURN Res
  1115. END ParseType;
  1116.  
  1117. PROCEDURE PopBlock;
  1118. VAR cur: IDENT; n: INTEGER;
  1119. BEGIN
  1120.   cur := unit.Idents.Last(IDENT);
  1121.   n := 0;
  1122.   WHILE cur.iType # IDGUARD DO
  1123.     cur := cur.Prev(IDENT);
  1124.     INC(n)
  1125.   END;
  1126.   cur := cur.Prev(IDENT);
  1127.   INC(n);
  1128.   unit.Idents.Count := unit.Idents.Count - n;
  1129.   unit.Idents.Last := cur;
  1130.   cur.Next := NIL;
  1131.   DEC(unit.Level)
  1132. END PopBlock;
  1133.  
  1134. PROCEDURE LinkPtr;
  1135. VAR cur: PTRBASE; id: IDENT;
  1136. BEGIN
  1137.   cur := PtrBases.First(PTRBASE);
  1138.   WHILE cur # NIL DO
  1139.     id := GetIdent(cur.Name);
  1140.     Assert(id # NIL, cur.coord, 42);
  1141.     Assert(id.T.tType = TRECORD, cur.coord, 81);
  1142.     cur.Ptr.Base := id.T;
  1143.     cur := cur.Next(PTRBASE)
  1144.   END;
  1145.   UTILS.Clear(PtrBases)
  1146. END LinkPtr;
  1147.  
  1148. PROCEDURE addproc;
  1149. VAR proc: Proc;
  1150. BEGIN
  1151.   NEW(proc);
  1152.   MemErr(proc = NIL);
  1153.   proc.used := FALSE;
  1154.   proc.Procs := UTILS.CreateList();
  1155.   UTILS.Push(procs, proc);
  1156.   curproc := proc
  1157. END addproc;
  1158.  
  1159. PROCEDURE DeclSeq;
  1160. VAR Value: LONGREAL; T, NewType: pTYPE; Name: SCAN.NODE; coord: SCAN.TCoord; Call: INTEGER;
  1161.     Export, func: BOOLEAN; last, id: IDENT; e: EXPRESSION;
  1162.  
  1163.   PROCEDURE IdentDef;
  1164.   BEGIN
  1165.     Name := SCAN.id;
  1166.     Coord(coord);
  1167.     Next;
  1168.     Export := FALSE;
  1169.     IF SCAN.tLex = lxMult THEN
  1170.       Assert2(unit.Level = 3, 89);
  1171.       Export := TRUE;
  1172.       Next
  1173.     END
  1174.   END IdentDef;
  1175.  
  1176. BEGIN
  1177.   IF SCAN.tLex = lxCONST THEN
  1178.     Next;
  1179.     WHILE SCAN.tLex = lxIDENT DO
  1180.       IdentDef;
  1181.       PushIdent(Name, coord, IDCONST, NIL, NIL, Export, 0);
  1182.       last := unit.Idents.Last(IDENT);
  1183.       Check(lxEQ);
  1184.       Next;
  1185.       ConstExpr(Value, T);
  1186.       Check(lxSemi);
  1187.       last.Value := Value;
  1188.       last.T := T;
  1189.       Next
  1190.     END
  1191.   END;
  1192.   IF SCAN.tLex = lxTYPE THEN
  1193.     UTILS.Clear(PtrBases);
  1194.     unit.typedecl := TRUE;
  1195.     Next;
  1196.     WHILE SCAN.tLex = lxIDENT DO
  1197.       IdentDef;
  1198.       PushIdent(Name, coord, IDTYPE, NIL, NIL, Export, 0);
  1199.       last := unit.Idents.Last(IDENT);
  1200.       Check(lxEQ);
  1201.       Next;
  1202.  
  1203.       IF SCAN.tLex = lxIDENT THEN
  1204.         last.T := ParseType(coord)
  1205.       ELSE
  1206.         NEW(NewType);
  1207.         MemErr(NewType = NIL);
  1208.         last.T := NewType;
  1209.         T := StructType(FALSE, NewType)
  1210.       END;
  1211.  
  1212.       Check(lxSemi);
  1213.       Next
  1214.     END
  1215.   END;
  1216.   LinkPtr;
  1217.   unit.typedecl := FALSE;
  1218.   IF SCAN.tLex = lxVAR THEN
  1219.     Next;
  1220.     WHILE SCAN.tLex = lxIDENT DO
  1221.       IdentDef;
  1222.       PushIdent(Name, coord, IDVAR, NIL, NIL, Export, 0);
  1223.       IF SCAN.tLex = lxComma THEN
  1224.         NextCheck(lxIDENT)
  1225.       ELSIF SCAN.tLex = lxColon THEN
  1226.         NextCoord(coord);
  1227.         T := ParseType(coord);
  1228.         Assert(T # NIL, coord, 42);
  1229.         SetVars(T);
  1230.         Check(lxSemi);
  1231.         Next
  1232.       ELSE
  1233.         Assert2(FALSE, 85)
  1234.       END
  1235.     END
  1236.   END;
  1237.   WHILE SCAN.tLex = lxPROCEDURE DO
  1238.     NextCoord(coord);
  1239.     IF CallFlag(Call) THEN
  1240.       Assert(unit.Level = 3, coord, 45);
  1241.       Assert(unit.sys, coord, 111)
  1242.     END;
  1243.     Check(lxIDENT);
  1244.     IdentDef;
  1245.     PushIdent(Name, coord, IDPROC, CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NIL), NIL, Export, 0);
  1246.     id := unit.Idents.Last(IDENT);
  1247.     addproc;
  1248.     id.Proc := curproc;
  1249.     IF id.Export & main THEN
  1250.       IF Platform IN {1, 6} THEN
  1251.         curproc.used := TRUE;
  1252.         Assert((Name # SCAN._START) & (Name # SCAN._version), coord, 133)
  1253.       END;
  1254.       X86.ProcExport(id.Number, Name, X86.NewLabel())
  1255.     END;
  1256.     id.Parent := curBlock;
  1257.     curBlock := id;
  1258.     Guard;
  1259.     FormalList(NIL, curBlock.T.Base);
  1260.     id.T.Call := Call;
  1261.     Check(lxSemi);
  1262.     Next;
  1263.     DeclSeq;
  1264.     id.LocalSize := id.VarSize - id.ParamSize;
  1265.     X86.Label(X86.NewLabel());
  1266.     curproc.beg := X86.current;
  1267.     X86.ProcBeg(id.Number, id.LocalSize, FALSE);
  1268.     IF SCAN.tLex = lxBEGIN THEN
  1269.       Next;
  1270.       OpSeq
  1271.     END;
  1272.     func := curBlock.T.Base.tType # TVOID;
  1273.     IF func THEN
  1274.       Check(lxRETURN);
  1275.       UTILS.UnitLine(UnitNumber, SCAN.coord.line);
  1276.       NextCoord(coord);
  1277.       Expr(e);
  1278.       Assert(AssComp(e, curBlock.T.Base, FALSE), coord, 125);
  1279.       IF e.eType = eVAR THEN
  1280.         X86.Load(e.T.tType)
  1281.       END
  1282.     ELSE
  1283.       Assert2(SCAN.tLex # lxRETURN, 123)
  1284.     END;
  1285.     Check(lxEND);
  1286.     NextCheck(lxIDENT);
  1287.     Assert2(SCAN.id = Name, 87);
  1288.     NextCheck(lxSemi);
  1289.     Next;
  1290.     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);
  1291.     X86.Label(X86.NewLabel());
  1292.     curproc.end := X86.current;
  1293.     PopBlock;
  1294.     curBlock := curBlock.Parent;
  1295.     curproc := curBlock.Proc(Proc);
  1296.   END
  1297. END DeclSeq;
  1298.  
  1299. PROCEDURE Rtl(u: UNIT);
  1300.  
  1301.   PROCEDURE AddProc(name: UTILS.STRING; num: INTEGER);
  1302.   VAR id: IDENT;
  1303.   BEGIN
  1304.     id := GetQIdent(u, SCAN.AddNode(name));
  1305.     id.Proc(Proc).used := TRUE;
  1306.     IF id = NIL THEN
  1307.       UTILS.ErrMsg(158);
  1308.       UTILS.HALT(1)
  1309.     END;
  1310.     X86.AddRtlProc(num, id.Number)
  1311.   END AddProc;
  1312.  
  1313. BEGIN
  1314.   AddProc("_newrec", X86._newrec);
  1315.   AddProc("_disprec", X86._disprec);
  1316.   AddProc("_rset", X86._rset);
  1317.   AddProc("_inset", X86._inset);
  1318.   AddProc("_saverec", X86._saverec);
  1319.   AddProc("_checktype", X86._checktype);
  1320.   AddProc("_strcmp", X86._strcmp);
  1321.   AddProc("_lstrcmp", X86._lstrcmp);
  1322.   AddProc("_rstrcmp", X86._rstrcmp);
  1323.   AddProc("_savearr", X86._savearr);
  1324.   AddProc("_arrayidx", X86._arrayidx);
  1325.   AddProc("_arrayidx1", X86._arrayidx1);
  1326.   AddProc("_arrayrot", X86._arrayrot);
  1327.   AddProc("_assrt", X86._assrt);
  1328.   AddProc("_strcopy", X86._strcopy);
  1329.   AddProc("_init", X86._init);
  1330.   AddProc("_close", X86._close);
  1331.   AddProc("_halt", X86._halt);
  1332.   AddProc("_length", X86._length);
  1333. END Rtl;
  1334.  
  1335. PROCEDURE ImportList;
  1336. VAR cond: INTEGER; coord, namecoord: SCAN.TCoord;
  1337.     name, alias: SCAN.NODE; u, self: UNIT;
  1338.     FName: UTILS.STRING;
  1339.  
  1340.   PROCEDURE AddUnit(newcond: INTEGER);
  1341.   VAR str: STRITEM;
  1342.   BEGIN
  1343.     u := GetModule(name);
  1344.     IF u = NIL THEN
  1345.       self := unit;
  1346.       SCAN.Backup(unit.scanner);
  1347.       COPY(name.Name, FName);
  1348.       IF ~((~self.Std & pReadModule(Path, FName, UTILS.Ext)) OR pReadModule(Std, FName, UTILS.Ext)) THEN
  1349.         IF FName = "SYSTEM" THEN
  1350.           unit := sys;
  1351.           self.sys := TRUE
  1352.         ELSE
  1353.           Assert(FALSE, namecoord, 32)
  1354.         END
  1355.       END;
  1356.       SCAN.Recover(self.scanner);
  1357.       u := unit;
  1358.       unit := self;
  1359.       UTILS.SetFile(unit.File)
  1360.     ELSE
  1361.       Assert(u.Closed, namecoord, 31)
  1362.     END;
  1363.     PushIdent(alias, coord, IDMOD, voidtype, u, FALSE, 0);
  1364.     NEW(str);
  1365.     MemErr(str = NIL);
  1366.     str.Str := name.Name;
  1367.     UTILS.Push(unit.Import, str);
  1368.     cond := newcond
  1369.   END AddUnit;
  1370.  
  1371. BEGIN
  1372.   cond := 0;
  1373.   WHILE cond # 4 DO
  1374.     Next;
  1375.     CASE cond OF
  1376.     |0: Check(lxIDENT);
  1377.         name := SCAN.id;
  1378.         Coord(coord);
  1379.         Coord(namecoord);
  1380.         alias := name;
  1381.         cond := 1
  1382.     |1: CASE SCAN.tLex OF
  1383.         |lxComma:  AddUnit(0)
  1384.         |lxSemi:   AddUnit(4); Next
  1385.         |lxAssign: cond := 2
  1386.         ELSE
  1387.           Assert2(FALSE, 28)
  1388.         END
  1389.     |2: Check(lxIDENT);
  1390.         name := SCAN.id;
  1391.         Coord(namecoord);
  1392.         cond := 3
  1393.     |3: CASE SCAN.tLex OF
  1394.         |lxComma: AddUnit(0)
  1395.         |lxSemi:  AddUnit(4); Next
  1396.         ELSE
  1397.           Assert2(FALSE, 29)
  1398.         END
  1399.     ELSE
  1400.     END
  1401.   END
  1402. END ImportList;
  1403.  
  1404. PROCEDURE Header(Name: SCAN.NODE);
  1405. BEGIN
  1406.   NEW(unit);
  1407.   MemErr(unit = NIL);
  1408.   unit.Idents := UTILS.CreateList();
  1409.   unit.Level := 0;
  1410.   unit.Name := Name;
  1411.   Guard; Guard;
  1412.   PushIdent(unit.Name, zcoord, IDMOD, voidtype, unit, FALSE, 0);
  1413.   Guard;
  1414.   unit.IdentBegin := unit.Idents.Last(IDENT);
  1415.   unit.Closed := TRUE
  1416. END Header;
  1417.  
  1418. PROCEDURE Pseudo;
  1419. VAR temp: UNIT;
  1420. BEGIN
  1421.   temp := unit;
  1422.   Header(SCAN.AddNode("SYSTEM"));
  1423.   PushSysProc("ADR",     sysADR);
  1424.   PushSysProc("SIZE",    sysSIZE);
  1425.   PushSysProc("TYPEID",  sysTYPEID);
  1426.   PushSysProc("GET",     sysGET);
  1427.   PushSysProc("PUT",     sysPUT);
  1428.   PushSysProc("CODE",    sysCODE);
  1429.   PushSysProc("MOVE",    sysMOVE);
  1430.   PushSysProc("COPY",    sysCOPY);
  1431.   PushSysProc("INF",     sysINF);
  1432.   PushSysType("CARD16",  TCARD16);
  1433.   sys := unit;
  1434.   unit := temp
  1435. END Pseudo;
  1436.  
  1437. PROCEDURE ReadModule(Path, Name1, Ext: UTILS.STRING): BOOLEAN;
  1438. VAR FHandle: INTEGER; name, Name, b: UTILS.STRING; idmod: IDENT; Res, temp: BOOLEAN; coord: SCAN.TCoord;
  1439. BEGIN
  1440.   Res := FALSE;
  1441.   name := Name1;
  1442.   Name := Name1;
  1443.   b := Path;
  1444.   UTILS.concat(b, Name);
  1445.   Name := b;
  1446.   UTILS.concat(Name, Ext);
  1447.  
  1448.   IF SCAN.Open(Name, FHandle) THEN
  1449.     NEW(unit);
  1450.     MemErr(unit = NIL);
  1451.     unit.sys := FALSE;
  1452.     unit.Std := Path = Std;
  1453.     UTILS.Push(prog, unit);
  1454.     unit.Idents := UTILS.CreateList();
  1455.     unit.Import := UTILS.CreateList();
  1456.     NEW(unit.scanner);
  1457.     MemErr(unit.scanner = NIL);
  1458.     unit.Closed := FALSE;
  1459.     unit.Level := 0;
  1460.     unit.typedecl := FALSE;
  1461.     COPY(Name, unit.File);
  1462.     UTILS.SetFile(unit.File);
  1463.     StIdent;
  1464.     NextCheck(lxMODULE);
  1465.     NextCheck(lxIDENT);
  1466.     Assert2(UTILS.streq(SCAN.id.Name, name), 33);
  1467.     unit.Name := SCAN.id;
  1468.     coord := SCAN.coord;
  1469.     PushIdent(unit.Name, coord, IDMOD, voidtype, unit, FALSE, 0);
  1470.     idmod := unit.Idents.Last(IDENT);
  1471.     Guard;
  1472.     NextCheck(lxSemi);
  1473.     Next;
  1474.     IF SCAN.tLex = lxIMPORT THEN
  1475.       temp := main;
  1476.       main := FALSE;
  1477.       ImportList;
  1478.       main := temp
  1479.     END;
  1480.     UTILS.OutString("compiling "); UTILS.OutString(unit.Name.Name); UTILS.Ln;
  1481.     X86.Module(idmod.Name.Name, idmod.Number);
  1482.     UnitNumber := idmod.Number;
  1483.     unit.IdentBegin := unit.Idents.Last(IDENT);
  1484.     curBlock := idmod;
  1485.     DeclSeq;
  1486.     X86.ProcBeg(idmod.Number, 0, TRUE);
  1487.     IF SCAN.tLex = lxBEGIN THEN
  1488.       addproc;
  1489.       curproc.used := TRUE;
  1490.       Next;
  1491.       OpSeq
  1492.     END;
  1493.     Check(lxEND);
  1494.     NextCheck(lxIDENT);
  1495.     Assert2(SCAN.id = unit.Name, 26);
  1496.     NextCheck(lxDot);
  1497.     X86.Leave;
  1498.     unit.Closed := TRUE;
  1499.     UTILS.Clear(unit.Import);
  1500.     Res := TRUE
  1501.   END
  1502.   RETURN Res
  1503. END ReadModule;
  1504.  
  1505. PROCEDURE Program*(StdPath, FilePath, NameFile, ExtFile: UTILS.STRING; windows: BOOLEAN;
  1506.   OpSeqProc: opPROC; ExprProc: expPROC; AssCompProc: assPROC; VAR stypes: stTYPES);
  1507. BEGIN
  1508.   winplatf := windows;
  1509.   Path := FilePath;
  1510.   Main := NameFile;
  1511.   ExtMain := ExtFile;
  1512.   Std := StdPath;
  1513.   OpSeq := OpSeqProc;
  1514.   Expr := ExprProc;
  1515.   AssComp := AssCompProc;
  1516.   prog := UTILS.CreateList();
  1517.   PtrBases := UTILS.CreateList();
  1518.   types := UTILS.CreateList();
  1519.   procs := UTILS.CreateList();
  1520.   StTypes;
  1521.   voidtype := sttypes[TVOID];
  1522.   Strings := UTILS.CreateList();
  1523.   Pseudo;
  1524.   stypes := sttypes
  1525. END Program;
  1526.  
  1527. PROCEDURE delfirstchar(VAR s: UTILS.STRING);
  1528. VAR i: INTEGER;
  1529. BEGIN
  1530.   FOR i := 0 TO LENGTH(s) - 1 DO
  1531.     s[i] := s[i + 1]
  1532.   END
  1533. END delfirstchar;
  1534.  
  1535. PROCEDURE DelProcs;
  1536. VAR cur: Proc;
  1537.  
  1538.   PROCEDURE ProcHandling(proc: Proc);
  1539.   VAR cur: IDENT; p: Proc;
  1540.   BEGIN
  1541.     proc.used := TRUE;
  1542.     cur := proc.Procs.First(IDENT);
  1543.     WHILE cur # NIL DO
  1544.       p := cur.Proc(Proc);
  1545.       IF ~p.used THEN
  1546.         ProcHandling(p)
  1547.       END;
  1548.       cur := cur.Next(IDENT)
  1549.     END;
  1550.   END ProcHandling;
  1551.  
  1552. BEGIN
  1553.   cur := procs.First(Proc);
  1554.   WHILE cur # NIL DO
  1555.     IF cur.used THEN
  1556.       ProcHandling(cur)
  1557.     END;
  1558.     cur := cur.Next(Proc)
  1559.   END;
  1560.   cur := procs.First(Proc);
  1561.   WHILE cur # NIL DO
  1562.     IF ~cur.used THEN
  1563.       X86.DelProc(cur.beg, cur.end)
  1564.     END;
  1565.     cur := cur.Next(Proc)
  1566.   END
  1567. END DelProcs;
  1568.  
  1569. PROCEDURE Compile*(platform, stksize: INTEGER);
  1570. VAR full, path, name, ext, temp, path2: UTILS.STRING;
  1571. BEGIN
  1572.   Platform := platform;
  1573.   main := FALSE;
  1574.   IF ReadModule(Path, "RTL", UTILS.Ext) OR ReadModule(Std, "RTL", UTILS.Ext) THEN
  1575.     Rtl(unit)
  1576.   ELSE
  1577.     UTILS.ErrMsg(65);
  1578.     UTILS.HALT(1)
  1579.   END;
  1580.   main := TRUE;
  1581.   IF ~ReadModule(Path, Main, ExtMain) THEN
  1582.     path2 := Path;
  1583.     UTILS.ParamStr(full, 0);
  1584.     UTILS.Split(full, path, name, ext);
  1585.     IF path[0] # 0X THEN
  1586.       path[LENGTH(path) - 1] := 0X
  1587.     END;
  1588.     IF Path[0] = UTILS.Slash THEN
  1589.       delfirstchar(Path)
  1590.     END;
  1591.     UTILS.concat(path, UTILS.Slash);
  1592.     full := path;
  1593.     UTILS.concat(full, Path);
  1594.     Path := full;
  1595.     IF (UTILS.OS = "WIN") & (Path[0] = UTILS.Slash) THEN
  1596.       delfirstchar(Path)
  1597.     END;
  1598.     IF ~ReadModule(Path, Main, ExtMain) THEN
  1599.       UTILS.ErrMsg(64);
  1600.       UTILS.OutString(path2);
  1601.       UTILS.OutString(Main);
  1602.       UTILS.OutString(ExtMain);
  1603.       UTILS.Ln;
  1604.       UTILS.HALT(1)
  1605.     END
  1606.   END;
  1607.   temp := Path;
  1608.   UTILS.concat(temp, Main);
  1609.   IF platform IN {2, 3} THEN
  1610.     UTILS.concat(temp, ".exe")
  1611.   ELSIF platform = 1 THEN
  1612.     UTILS.concat(temp, ".dll")
  1613.   ELSIF platform = 4 THEN
  1614.     UTILS.concat(temp, ".kex")
  1615.   ELSIF platform = 6 THEN
  1616.     UTILS.concat(temp, ".obj")
  1617.   END;
  1618.   IF platform IN {1, 2, 3, 4} THEN
  1619.     stksize := stksize * 100000H
  1620.   END;
  1621.   DelProcs;
  1622.   X86.Epilog(ProgSize, temp, stksize)
  1623. END Compile;
  1624.  
  1625. BEGIN
  1626.   pParseType := ParseType;
  1627.   pReadModule := ReadModule;
  1628.   zcoord.line := 0;
  1629.   zcoord.col := 0
  1630. END DECL.