Subversion Repositories Kolibri OS

Rev

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

  1. (*
  2.     Copyright 2016 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;
  47.  
  48.   sysADR = 101; sysSIZE = 102; sysINF = 103; sysGET = 104; sysPUT = 105;
  49.   sysCODE = 106; sysTYPEID = 107; sysMOVE = 108;
  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.   Guard
  421. END StIdent;
  422.  
  423. PROCEDURE GetQIdent*(Unit: UNIT; Name: SCAN.NODE): IDENT;
  424. VAR cur, res: IDENT;
  425. BEGIN
  426.   res := NIL;
  427.   cur := Unit.IdentBegin.Next(IDENT);
  428.   WHILE (cur # NIL) & (cur.iType # IDGUARD) DO
  429.     IF cur.Name = Name THEN
  430.       IF (Unit # unit) & ~cur.Export THEN
  431.         res := NIL
  432.       ELSE
  433.         res := cur
  434.       END;
  435.       cur := NIL
  436.     ELSE
  437.       cur := cur.Next(IDENT)
  438.     END
  439.   END
  440.   RETURN res
  441. END GetQIdent;
  442.  
  443. PROCEDURE GetIdent*(Name: SCAN.NODE): IDENT;
  444. VAR cur, res: IDENT;
  445. BEGIN
  446.   res := NIL;
  447.   cur := unit.Idents.Last(IDENT);
  448.   WHILE (cur # NIL) & (cur.Name = Name) DO
  449.     res := cur;
  450.     cur := NIL
  451.   ELSIF cur # NIL DO
  452.     cur := cur.Prev(IDENT)
  453.   END
  454.   RETURN res
  455. END GetIdent;
  456.  
  457. PROCEDURE Relation*(Op: INTEGER): BOOLEAN;
  458. VAR Res: BOOLEAN;
  459. BEGIN
  460.   CASE Op OF
  461.   |lxEQ, lxNE, lxLT, lxGT,
  462.    lxLE, lxGE, lxIN, lxIS:
  463.     Res := TRUE
  464.   ELSE
  465.     Res := FALSE
  466.   END
  467.   RETURN Res
  468. END Relation;
  469.  
  470. PROCEDURE Arith(a, b: LONGREAL; T: pTYPE; Op: INTEGER; coord: SCAN.TCoord): LONGREAL;
  471. CONST max = SCAN.maxDBL;
  472. VAR res: LONGREAL;
  473. BEGIN
  474.   CASE Op OF
  475.   |lxPlus: res := a + b
  476.   |lxMinus: res := a - b
  477.   |lxMult: res := a * b
  478.   |lxSlash:
  479.     Assert(b # 0.0D0, coord, 46);
  480.     res := a / b
  481.   |lxDIV:
  482.     Assert(~((a = LONG(FLT(SCAN.minINT))) & (b = -1.0D0)), coord, IOVER);
  483.     res := LONG(FLT(FLOOR(a) DIV FLOOR(b)))
  484.   |lxMOD:
  485.     res := LONG(FLT(FLOOR(a) MOD FLOOR(b)))
  486.   ELSE
  487.   END;
  488.   Assert(~UTILS.IsInf(res), coord, FOVER);
  489.   CASE T.tType OF
  490.   |TINTEGER:  Assert((res <= LONG(FLT(SCAN.maxINT))) & (res >= LONG(FLT(SCAN.minINT))), coord, IOVER)
  491.   |TREAL:     Assert((res <= LONG(SCAN.maxREAL)) & (res >= -LONG(SCAN.maxREAL)), coord, FOVER)
  492.   |TLONGREAL: Assert((res <= max) & (res >= -max), coord, FOVER)
  493.   ELSE
  494.   END;
  495.   IF (res = 0.0D0) & (T.tType IN TFLOAT) OR (ABS(res) < LONG(SCAN.minREAL)) & (T.tType = TREAL) THEN
  496.     CASE Op OF
  497.     |lxPlus:  Assert(a = -b, coord, UNDER)
  498.     |lxMinus: Assert(a = b, coord, UNDER)
  499.     |lxMult:  Assert((a = 0.0D0) OR (b = 0.0D0), coord, UNDER)
  500.     |lxSlash: Assert((a = 0.0D0), coord, UNDER)
  501.     ELSE
  502.     END
  503.   END
  504.   RETURN res
  505. END Arith;
  506.  
  507. PROCEDURE strcmp(a, b: LONGREAL; Op: INTEGER): LONGREAL;
  508. VAR sa, sb: UTILS.STRCONST; Res: LONGREAL;
  509. BEGIN
  510.   sa := GetString(a);
  511.   sb := GetString(b);
  512.   CASE Op OF
  513.   |lxEQ, lxNE: Res := LONG(FLT(ORD(sa.Str = sb.Str)))
  514.   |lxLT, lxGT: Res := LONG(FLT(ORD(sa.Str < sb.Str)))
  515.   |lxLE, lxGE: Res := LONG(FLT(ORD(sa.Str <= sb.Str)))
  516.   ELSE
  517.   END
  518.   RETURN Res
  519. END strcmp;
  520.  
  521. PROCEDURE Calc*(a, b: LONGREAL; Ta, Tb: pTYPE; Op: INTEGER; coord: SCAN.TCoord; VAR Res: LONGREAL; VAR TRes: pTYPE);
  522. VAR c: LONGREAL; ai, bi: INTEGER;
  523. BEGIN
  524.   ai := FLOOR(a);
  525.   bi := FLOOR(b);
  526.   IF Op # lxIN THEN
  527.     Assert(Ta = Tb, coord, 37)
  528.   END;
  529.   CASE Op OF
  530.   |lxPlus, lxMinus, lxMult, lxSlash:
  531.     Assert(~((Op = lxSlash) & (Ta.tType = TINTEGER)), coord, 37);
  532.     IF Ta.tType IN TNUM THEN
  533.       Res := Arith(a, b, Ta, Op, coord)
  534.     ELSIF Ta.tType = TSET THEN
  535.       CASE Op OF
  536.       |lxPlus:  Res := LONG(FLT(ORD(BITS(ai) + BITS(bi))))
  537.       |lxMinus: Res := LONG(FLT(ORD(BITS(ai) - BITS(bi))))
  538.       |lxMult:  Res := LONG(FLT(ORD(BITS(ai) * BITS(bi))))
  539.       |lxSlash: Res := LONG(FLT(ORD(BITS(ai) / BITS(bi))))
  540.       ELSE
  541.       END
  542.     ELSE
  543.       Assert(FALSE, coord, 37)
  544.     END;
  545.     TRes := Ta
  546.   |lxDIV, lxMOD:
  547.     Assert(Ta.tType = TINTEGER, coord, 37);
  548.     Assert(bi # 0, coord, 48);
  549.     TRes := Ta;
  550.     Res := Arith(a, b, Ta, Op, coord)
  551.   |lxAnd:
  552.     Assert(Ta.tType = TBOOLEAN, coord, 37);
  553.     Res := LONG(FLT(ORD((ai # 0) & (bi # 0))))
  554.   |lxOR:
  555.     Assert(Ta.tType = TBOOLEAN, coord, 37);
  556.     Res := LONG(FLT(ORD((ai # 0) OR (bi # 0))))
  557.   |lxEQ, lxNE:
  558.     IF Ta.tType = TSTRING THEN
  559.       Res := strcmp(a, b, Op)
  560.     ELSE
  561.       Res := LONG(FLT(ORD(a = b)))
  562.     END;
  563.     IF Op = lxNE THEN
  564.       Res := LONG(FLT(ORD(Res = 0.0D0)))
  565.     END
  566.   |lxLT, lxGT:
  567.     IF Op = lxGT THEN
  568.       c := a;
  569.       a := b;
  570.       b := c
  571.     END;
  572.     Assert(Ta.tType IN (TNUM + {TSTRING}), coord, 37);
  573.     IF Ta.tType = TSTRING THEN
  574.       Res := strcmp(a, b, Op)
  575.     ELSE
  576.       Res := LONG(FLT(ORD(a < b)))
  577.     END
  578.   |lxLE, lxGE:
  579.     IF Op = lxGE THEN
  580.       c := a;
  581.       a := b;
  582.       b := c
  583.     END;
  584.     Assert(Ta.tType IN (TNUM + {TSTRING, TSET}), coord, 37);
  585.     IF Ta.tType = TSTRING THEN
  586.       Res := strcmp(a, b, Op)
  587.     ELSIF Ta.tType = TSET THEN
  588.       Res := LONG(FLT(ORD(BITS(FLOOR(a)) <= BITS(FLOOR(b)))))
  589.     ELSE
  590.       Res := LONG(FLT(ORD(a <= b)))
  591.     END
  592.   |lxIN:
  593.     Assert((Ta.tType = TINTEGER) & (Tb.tType = TSET), coord, 37);
  594.     Assert(ASR(ai, 5) = 0, coord, 49);
  595.     Res := LONG(FLT(ORD(ai IN BITS(bi))))
  596.   ELSE
  597.   END;
  598.   IF Relation(Op) OR (Op = lxAnd) OR (Op = lxOR) THEN
  599.     TRes := sttypes[TBOOLEAN]
  600.   END
  601. END Calc;
  602.  
  603. PROCEDURE ConstExpr*(VAR Value: LONGREAL; VAR T: pTYPE);
  604. VAR e: EXPRESSION; coord: SCAN.TCoord;
  605. BEGIN
  606.   Const := TRUE;
  607.   Coord(coord);
  608.   sizefunc := FALSE;
  609.   Expr(e);
  610.   Assert(~sizefunc & (e.eType = eCONST), coord, 62);
  611.   Value := e.Value;
  612.   T := e.T;
  613.   Const := FALSE
  614. END ConstExpr;
  615.  
  616. PROCEDURE IdType*(VAR coord: SCAN.TCoord): pTYPE;
  617. VAR id: IDENT; Name: SCAN.NODE; Unit: UNIT; Res: pTYPE;
  618. BEGIN
  619.   Res := NIL;
  620.   Name := SCAN.id;
  621.   id := GetIdent(Name);
  622.   IF id = NIL THEN
  623.     Coord(coord);
  624.     NamePtrBase := Name;
  625.     Next
  626.   ELSE
  627.     IF id.iType = IDTYPE THEN
  628.       Coord(coord);
  629.       Next;
  630.       Res := id.T
  631.     ELSIF id.iType = IDMOD THEN
  632.       Unit := id.Unit;
  633.       NextCheck(lxDot);
  634.       NextCheck(lxIDENT);
  635.       Name := SCAN.id;
  636.       NamePtrBase := Name;
  637.       id := GetQIdent(Unit, Name);
  638.       IF Unit # unit THEN
  639.         Assert2(id # NIL, 42);
  640.         Assert2(id.iType = IDTYPE, 77);
  641.         Coord(coord);
  642.         Next;
  643.         Res := id.T
  644.       ELSE
  645.         IF id = NIL THEN
  646.           Assert2((unit.Level = 3) & unit.typedecl, 42);
  647.           Coord(coord);
  648.           Next;
  649.           Res := NIL
  650.         ELSE
  651.           Assert2(id.iType = IDTYPE, 77);
  652.           Coord(coord);
  653.           Next;
  654.           Res := id.T
  655.         END
  656.       END
  657.     ELSE
  658.       Assert2(FALSE, 77)
  659.     END
  660.   END
  661.   RETURN Res
  662. END IdType;
  663.  
  664. PROCEDURE FieldOffset(Align, RecSize: INTEGER): INTEGER;
  665. BEGIN
  666.   Assert2(RecSize <= SCAN.maxINT - (Align - RecSize MOD Align) MOD Align, 83)
  667.   RETURN RecSize + (Align - RecSize MOD Align) MOD Align
  668. END FieldOffset;
  669.  
  670. PROCEDURE Dim*(T: pTYPE): INTEGER;
  671. VAR n: INTEGER;
  672. BEGIN
  673.   n := 0;
  674.   WHILE (T.tType = TARRAY) & (T.Len = 0) DO
  675.     INC(n);
  676.     T := T.Base
  677.   END
  678.   RETURN n
  679. END Dim;
  680.  
  681. PROCEDURE SetFields(Tr, Tf: pTYPE; Rec: BOOLEAN);
  682. VAR cur: FIELD;
  683. BEGIN
  684.   cur := Tr.Fields.First(FIELD);
  685.   WHILE cur.T # NIL DO
  686.     cur := cur.Next(FIELD)
  687.   END;
  688.   WHILE cur # NIL DO
  689.     cur.T := Tf;
  690.     IF Rec THEN
  691.       IF Tf.Align > Tr.Align THEN
  692.         Tr.Align := Tf.Align
  693.       END;
  694.       IF Tr.Rec = record THEN
  695.         cur.Offset := FieldOffset(Tf.Align, Tr.Size);
  696.         Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
  697.         Tr.Size := cur.Offset + Tf.Size
  698.       ELSIF Tr.Rec = noalign THEN
  699.         cur.Offset := FieldOffset(1, Tr.Size);
  700.         Assert2(cur.Offset <= SCAN.maxINT - Tf.Size, 83);
  701.         Tr.Size := cur.Offset + Tf.Size
  702.       ELSIF Tr.Rec = union THEN
  703.         IF Tf.Size > Tr.Size THEN
  704.           Tr.Size := Tf.Size
  705.         END;
  706.         cur.Offset := 0
  707.       END
  708.     ELSE
  709.       Tr.Len := Tr.Len + 4 * (ORD((Tf.tType = TRECORD) & cur.ByRef) + Dim(Tf) + ORD((Tf.tType = TLONGREAL) & ~cur.ByRef) + 1)
  710.     END;
  711.     cur := cur.Next(FIELD)
  712.   END
  713. END SetFields;
  714.  
  715. PROCEDURE GetField*(T: pTYPE; Name: SCAN.NODE): FIELD;
  716. VAR cur, Res: FIELD;
  717. BEGIN
  718.   Res := NIL;
  719.   cur := T.Fields.First(FIELD);
  720.   WHILE (cur # NIL) & (cur.Name = Name) DO
  721.     Res := cur;
  722.     cur := NIL
  723.   ELSIF cur # NIL DO
  724.     cur := cur.Next(FIELD)
  725.   END
  726.   RETURN Res
  727. END GetField;
  728.  
  729. PROCEDURE Unique(T: pTYPE; Name: SCAN.NODE): BOOLEAN;
  730. VAR field: FIELD; res: BOOLEAN;
  731. BEGIN
  732.   res := TRUE;
  733.   WHILE (T # NIL) & res DO
  734.     field := GetField(T, Name);
  735.     IF field # NIL THEN
  736.       IF (field.Unit = unit) OR field.Export THEN
  737.         res := FALSE
  738.       END
  739.     END;
  740.     T := T.Base
  741.   END
  742.   RETURN res
  743. END Unique;
  744.  
  745. PROCEDURE notrecurs(id: BOOLEAN; T: pTYPE): BOOLEAN;
  746.   RETURN ~(id & (unit.Idents.Last(IDENT).iType = IDTYPE) & (unit.Idents.Last(IDENT).T = T) &
  747.           (T.tType IN TSTRUCT))
  748. END notrecurs;
  749.  
  750. PROCEDURE ReadFields(T: pTYPE);
  751. VAR Name: SCAN.NODE; field: FIELD; Tf: pTYPE; coord: SCAN.TCoord; id_T: BOOLEAN;
  752. BEGIN
  753.   WHILE SCAN.tLex = lxIDENT DO
  754.     Name := SCAN.id;
  755.     Assert2(Unique(T, Name), 30);
  756.     NEW(field);
  757.     MemErr(field = NIL);
  758.     UTILS.Push(T.Fields, field);
  759.     field.Name := Name;
  760.     field.T := NIL;
  761.     field.Export := FALSE;
  762.     field.Unit := unit;
  763.     Next;
  764.     IF SCAN.tLex = lxMult THEN
  765.       Assert2(unit.Level = 3, 89);
  766.       field.Export := TRUE;
  767.       Next
  768.     END;
  769.     IF SCAN.tLex = lxComma THEN
  770.       NextCheck(lxIDENT)
  771.     ELSIF SCAN.tLex = lxColon THEN
  772.       NextCoord(coord);
  773.       id_T := SCAN.tLex = lxIDENT;
  774.       Tf:= pParseType(coord);
  775.       Assert(Tf # NIL, coord, 42);
  776.       Assert(notrecurs(id_T, Tf), coord, 96);
  777.       SetFields(T, Tf, TRUE);
  778.       IF SCAN.tLex = lxSemi THEN
  779.         NextCheck(lxIDENT)
  780.       ELSE
  781.         Assert2(SCAN.tLex = lxEND, 86)
  782.       END
  783.     ELSE
  784.       Assert2(FALSE, 85)
  785.     END
  786.   END
  787. END ReadFields;
  788.  
  789. PROCEDURE OpenBase*(T: pTYPE): pTYPE;
  790. BEGIN
  791.   WHILE (T.tType = TARRAY) & (T.Len = 0) DO
  792.     T := T.Base
  793.   END
  794.   RETURN T
  795. END OpenBase;
  796.  
  797. PROCEDURE SetVars(T: pTYPE);
  798. VAR cur: IDENT; n: INTEGER;
  799. BEGIN
  800.   cur := unit.Idents.Last(IDENT);
  801.   WHILE cur.T = NIL DO
  802.     cur := cur.Prev(IDENT)
  803.   END;
  804.   cur := cur.Next(IDENT);
  805.   WHILE cur # NIL DO
  806.     cur.T := T;
  807.     IF(cur.VarKind = paramvar) OR (cur.VarKind = param) & (T.tType IN TSTRUCT) THEN
  808.       n := 4 * (1 + Dim(T) + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
  809.     ELSE
  810.       n := T.Size;
  811.       Assert2(n <= SCAN.maxINT - UTILS.Align(n), 93);
  812.       n := n + UTILS.Align(n)
  813.     END;
  814.     IF cur.Level = 3 THEN
  815.       cur.Offset := ProgSize;
  816.       Assert2(ProgSize <= SCAN.maxINT - n, 93);
  817.       ProgSize := ProgSize + n;
  818.       Assert2(ProgSize <= SCAN.maxINT - UTILS.Align(ProgSize), 93);
  819.       ProgSize := ProgSize + UTILS.Align(ProgSize)
  820.     ELSE
  821.       IF cur.VarKind = 0 THEN
  822.         cur.Offset := curBlock.ParamSize - curBlock.VarSize - n
  823.       ELSE
  824.         cur.Offset := curBlock.VarSize - 8 + 4 * (cur.Level + ORD((cur.VarKind = paramvar) & (T.tType = TRECORD)))
  825.       END
  826.     END;
  827.     Assert2(curBlock.VarSize <= SCAN.maxINT - n, 93);
  828.     curBlock.VarSize := curBlock.VarSize + n;
  829.     Assert2(curBlock.VarSize <= SCAN.maxINT - UTILS.Align(curBlock.VarSize), 93);
  830.     curBlock.VarSize := curBlock.VarSize + UTILS.Align(curBlock.VarSize);
  831.     IF cur.VarKind # 0 THEN
  832.       curBlock.ParamSize := curBlock.VarSize
  833.     END;
  834.     cur := cur.Next(IDENT)
  835.   END
  836. END SetVars;
  837.  
  838. PROCEDURE CreateType(tType, Len, Size, Number: INTEGER; Base: pTYPE; Fields: BOOLEAN; NewType: pTYPE): pTYPE;
  839. VAR nov: pTYPE;
  840. BEGIN
  841.   IF NewType = NIL THEN
  842.     NEW(nov);
  843.     MemErr(nov = NIL)
  844.   ELSE
  845.     nov := NewType
  846.   END;
  847.   UTILS.Push(types, nov);
  848.   nov.tType := tType;
  849.   nov.Len := Len;
  850.   nov.Size := Size;
  851.   nov.Base := Base;
  852.   nov.Fields := NIL;
  853.   nov.Number := Number;
  854.   IF Fields THEN
  855.     nov.Fields := UTILS.CreateList()
  856.   END
  857.   RETURN nov
  858. END CreateType;
  859.  
  860. PROCEDURE FormalType(VAR coord: SCAN.TCoord): pTYPE;
  861. VAR TA: pTYPE;
  862. BEGIN
  863.   IF SCAN.tLex = lxARRAY THEN
  864.     NextCheck(lxOF);
  865.     Next;
  866.     TA := CreateType(TARRAY, 0, 0, 0, FormalType(coord), FALSE, NIL)
  867.   ELSE
  868.     Check(lxIDENT);
  869.     TA := IdType(coord);
  870.     Assert(TA # NIL, coord, 42);
  871.   END
  872.   RETURN TA
  873. END FormalType;
  874.  
  875. PROCEDURE Section(T: pTYPE);
  876. VAR Name: SCAN.NODE; ByRef, cont: BOOLEAN; field: FIELD;
  877.     Tf: pTYPE; fp: IDENT; coord: SCAN.TCoord; proc: BOOLEAN;
  878. BEGIN
  879.   proc := T = NIL;
  880.   IF proc THEN
  881.     T := curBlock.T
  882.   END;
  883.   Assert2((SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR), 84);
  884.   ByRef := FALSE;
  885.   IF SCAN.tLex = lxVAR THEN
  886.     ByRef := TRUE;
  887.     NextCheck(lxIDENT)
  888.   END;
  889.   cont := TRUE;
  890.   WHILE cont DO
  891.     Name := SCAN.id;
  892.     Assert2(GetField(T, Name) = NIL, 30);
  893.     NEW(field);
  894.     MemErr(field = NIL);
  895.     UTILS.Push(T.Fields, field);
  896.     field.Name := Name;
  897.     field.T := NIL;
  898.     field.ByRef := ByRef;
  899.     IF proc THEN
  900.       PushIdent(Name, coord, IDVAR, NIL, NIL, FALSE, 0);
  901.       INC(curBlock.ParamCount);
  902.       fp := unit.Idents.Last(IDENT);
  903.       IF ByRef THEN
  904.         fp.VarKind := paramvar
  905.       ELSE
  906.         fp.VarKind := param
  907.       END
  908.     END;
  909.     Next;
  910.     IF SCAN.tLex = lxComma THEN
  911.       NextCheck(lxIDENT)
  912.     ELSIF SCAN.tLex = lxColon THEN
  913.       Next;
  914.       Tf := FormalType(coord);
  915.       Assert(Dim(Tf) <= X86.ADIM, coord, 110);
  916.       SetFields(T, Tf, FALSE);
  917.       IF proc THEN
  918.         SetVars(Tf)
  919.       END;
  920.       cont := FALSE
  921.     ELSE
  922.       Assert2(FALSE, 85)
  923.     END
  924.   END
  925. END Section;
  926.  
  927. PROCEDURE ParamType(T: pTYPE);
  928. VAR break: BOOLEAN;
  929. BEGIN
  930.   IF (SCAN.tLex = lxIDENT) OR (SCAN.tLex = lxVAR) THEN
  931.     break := FALSE;
  932.     REPEAT
  933.       Section(T);
  934.       IF SCAN.tLex = lxSemi THEN
  935.         Next
  936.       ELSE
  937.         break := TRUE
  938.       END
  939.     UNTIL break
  940.   END
  941. END ParamType;
  942.  
  943. PROCEDURE AddPtrBase(Name: SCAN.NODE; coord: SCAN.TCoord; T: pTYPE);
  944. VAR nov: PTRBASE;
  945. BEGIN
  946.   NEW(nov);
  947.   MemErr(nov = NIL);
  948.   nov.Name := Name;
  949.   nov.coord := coord;
  950.   nov.Ptr := T;
  951.   UTILS.Push(PtrBases, nov)
  952. END AddPtrBase;
  953.  
  954. PROCEDURE FormalList(T: pTYPE; VAR Res: pTYPE);
  955. VAR coord: SCAN.TCoord;
  956. BEGIN
  957.   IF SCAN.tLex = lxLRound THEN
  958.     Next;
  959.     ParamType(T);
  960.     Check(lxRRound);
  961.     Next;
  962.     IF SCAN.tLex = lxColon THEN
  963.       NextCheck(lxIDENT);
  964.       Res := IdType(coord);
  965.       Assert(Res # NIL, coord, 42);
  966.       Assert(~(Res.tType IN TSTRUCT), coord, 82)
  967.     END
  968.   END
  969. END FormalList;
  970.  
  971. PROCEDURE CallFlag(VAR Call: INTEGER): BOOLEAN;
  972. VAR res: BOOLEAN;
  973. BEGIN
  974.   res := SCAN.tLex = lxLSquare;
  975.   IF res THEN
  976.     Next;
  977.     IF SCAN.Lex = "cdecl" THEN
  978.       Call := cdecl
  979.     ELSIF SCAN.Lex = "stdcall" THEN
  980.       Call := stdcall
  981.     ELSIF SCAN.Lex = "winapi" THEN
  982.       Assert2(winplatf, 50);
  983.       Call := winapi
  984.     ELSE
  985.       Assert2(FALSE, 44)
  986.     END;
  987.     NextCheck(lxRSquare);
  988.     Next;
  989.   ELSE
  990.     Call := defcall
  991.   END
  992.   RETURN res
  993. END CallFlag;
  994.  
  995. PROCEDURE RecFlag(VAR rec: INTEGER): BOOLEAN;
  996. VAR res: BOOLEAN;
  997. BEGIN
  998.   res := SCAN.tLex = lxLSquare;
  999.   IF res THEN
  1000.     Next;
  1001.     IF SCAN.Lex = "union" THEN
  1002.       rec := union
  1003.     ELSIF SCAN.Lex = "noalign" THEN
  1004.       rec := noalign
  1005.     ELSE
  1006.       Assert2(FALSE, 103)
  1007.     END;
  1008.     NextCheck(lxRSquare);
  1009.     Next;
  1010.   ELSE
  1011.     rec := record
  1012.   END
  1013.   RETURN res
  1014. END RecFlag;
  1015.  
  1016. PROCEDURE StructType(Comma: BOOLEAN; NewType: pTYPE): pTYPE;
  1017. VAR v: LONGREAL; T, nov: pTYPE; coord, coord2: SCAN.TCoord; id_T: BOOLEAN;
  1018. BEGIN
  1019.   CASE SCAN.tLex OF
  1020.   |lxARRAY, lxComma:
  1021.     IF SCAN.tLex = lxComma THEN
  1022.       Assert2(Comma, 39)
  1023.     END;
  1024.     NextCoord(coord);
  1025.     ConstExpr(v, T);
  1026.     Assert(T.tType = TINTEGER, coord, 52);
  1027.     Assert(v > 0.0D0, coord, 78);
  1028.     nov := CreateType(TARRAY, FLOOR(v), 0, 0, NIL, FALSE, NewType);
  1029.     IF SCAN.tLex = lxComma THEN
  1030.       nov.Base := StructType(TRUE, NIL)
  1031.     ELSIF SCAN.tLex = lxOF THEN
  1032.       NextCoord(coord);
  1033.       id_T := SCAN.tLex = lxIDENT;
  1034.       nov.Base := pParseType(coord);
  1035.       Assert(nov.Base # NIL, coord, 42);
  1036.       Assert(notrecurs(id_T, nov.Base), coord, 96)
  1037.     ELSE
  1038.       Assert2(FALSE, 79)
  1039.     END;
  1040.     Assert2(nov.Base.Size <= SCAN.maxINT DIV nov.Len, 83);
  1041.     nov.Size := nov.Base.Size * nov.Len;
  1042.     nov.Align := nov.Base.Align
  1043.   |lxRECORD:
  1044.     NextCoord(coord);
  1045.     INC(RecCount);
  1046.     nov := CreateType(TRECORD, 0, 0, RecCount, NIL, TRUE, NewType);
  1047.     nov.Align := 1;
  1048.     IF RecFlag(nov.Rec) THEN
  1049.       Assert(unit.sys, coord, 111)
  1050.     END;
  1051.     Coord(coord);
  1052.     IF SCAN.tLex = lxLRound THEN
  1053.       NextCoord(coord2);
  1054.       Check(lxIDENT);
  1055.       nov.Base := IdType(coord);
  1056.       Assert(nov.Base # NIL, coord, 42);
  1057.       Assert(nov.Base.tType = TRECORD, coord, 80);
  1058.       Assert(notrecurs(TRUE, nov.Base), coord, 96);
  1059.       nov.Size := nov.Base.Size;
  1060.       nov.Align := nov.Base.Align;
  1061.       Check(lxRRound);
  1062.       Next;
  1063.       Assert(nov.Rec = record, coord, 112);
  1064.       Assert(nov.Base.Rec = record, coord2, 113)
  1065.     END;
  1066.     ReadFields(nov);
  1067.     Check(lxEND);
  1068.     nov.Size := X86.Align(nov.Size, nov.Align);
  1069.     IF nov.Base # NIL THEN
  1070.       X86.AddRec(nov.Base.Number)
  1071.     ELSE
  1072.       X86.AddRec(0)
  1073.     END;
  1074.     Next
  1075.   |lxPOINTER:
  1076.     NextCheck(lxTO);
  1077.     NextCoord(coord);
  1078.     nov := CreateType(TPOINTER, 0, 4, 0, NIL, FALSE, NewType);
  1079.     nov.Align := 4;
  1080.     nov.Base := pParseType(coord);
  1081.     IF nov.Base = NIL THEN
  1082.       Assert(unit.typedecl, coord, 42);
  1083.       AddPtrBase(NamePtrBase, coord, nov)
  1084.     ELSE
  1085.       Assert(nov.Base.tType = TRECORD, coord, 81)
  1086.     END
  1087.   |lxPROCEDURE:
  1088.     NextCoord(coord);
  1089.     nov := CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NewType);
  1090.     IF CallFlag(nov.Call) THEN
  1091.       Assert(unit.sys, coord, 111)
  1092.     END;
  1093.     nov.Align := 4;
  1094.     FormalList(nov, nov.Base)
  1095.   ELSE
  1096.     Assert2(FALSE, 39)
  1097.   END
  1098.   RETURN nov
  1099. END StructType;
  1100.  
  1101. PROCEDURE ParseType(VAR coord: SCAN.TCoord): pTYPE;
  1102. VAR Res: pTYPE;
  1103. BEGIN
  1104.   IF SCAN.tLex = lxIDENT THEN
  1105.     Res := IdType(coord)
  1106.   ELSE
  1107.     Res := StructType(FALSE, NIL)
  1108.   END
  1109.   RETURN Res
  1110. END ParseType;
  1111.  
  1112. PROCEDURE PopBlock;
  1113. VAR cur: IDENT; n: INTEGER;
  1114. BEGIN
  1115.   cur := unit.Idents.Last(IDENT);
  1116.   n := 0;
  1117.   WHILE cur.iType # IDGUARD DO
  1118.     cur := cur.Prev(IDENT);
  1119.     INC(n)
  1120.   END;
  1121.   cur := cur.Prev(IDENT);
  1122.   INC(n);
  1123.   unit.Idents.Count := unit.Idents.Count - n;
  1124.   unit.Idents.Last := cur;
  1125.   cur.Next := NIL;
  1126.   DEC(unit.Level)
  1127. END PopBlock;
  1128.  
  1129. PROCEDURE LinkPtr;
  1130. VAR cur: PTRBASE; id: IDENT;
  1131. BEGIN
  1132.   cur := PtrBases.First(PTRBASE);
  1133.   WHILE cur # NIL DO
  1134.     id := GetIdent(cur.Name);
  1135.     Assert(id # NIL, cur.coord, 42);
  1136.     Assert(id.T.tType = TRECORD, cur.coord, 81);
  1137.     cur.Ptr.Base := id.T;
  1138.     cur := cur.Next(PTRBASE)
  1139.   END;
  1140.   UTILS.Clear(PtrBases)
  1141. END LinkPtr;
  1142.  
  1143. PROCEDURE addproc;
  1144. VAR proc: Proc;
  1145. BEGIN
  1146.   NEW(proc);
  1147.   MemErr(proc = NIL);
  1148.   proc.used := FALSE;
  1149.   proc.Procs := UTILS.CreateList();
  1150.   UTILS.Push(procs, proc);
  1151.   curproc := proc
  1152. END addproc;
  1153.  
  1154. PROCEDURE DeclSeq;
  1155. VAR Value: LONGREAL; T, NewType: pTYPE; Name: SCAN.NODE; coord: SCAN.TCoord; Call: INTEGER;
  1156.     Export, func: BOOLEAN; last, id: IDENT; e: EXPRESSION;
  1157.  
  1158.   PROCEDURE IdentDef;
  1159.   BEGIN
  1160.     Name := SCAN.id;
  1161.     Coord(coord);
  1162.     Next;
  1163.     Export := FALSE;
  1164.     IF SCAN.tLex = lxMult THEN
  1165.       Assert2(unit.Level = 3, 89);
  1166.       Export := TRUE;
  1167.       Next
  1168.     END
  1169.   END IdentDef;
  1170.  
  1171. BEGIN
  1172.   IF SCAN.tLex = lxCONST THEN
  1173.     Next;
  1174.     WHILE SCAN.tLex = lxIDENT DO
  1175.       IdentDef;
  1176.       PushIdent(Name, coord, IDCONST, NIL, NIL, Export, 0);
  1177.       last := unit.Idents.Last(IDENT);
  1178.       Check(lxEQ);
  1179.       Next;
  1180.       ConstExpr(Value, T);
  1181.       Check(lxSemi);
  1182.       last.Value := Value;
  1183.       last.T := T;
  1184.       Next
  1185.     END
  1186.   END;
  1187.   IF SCAN.tLex = lxTYPE THEN
  1188.     UTILS.Clear(PtrBases);
  1189.     unit.typedecl := TRUE;
  1190.     Next;
  1191.     WHILE SCAN.tLex = lxIDENT DO
  1192.       IdentDef;
  1193.       PushIdent(Name, coord, IDTYPE, NIL, NIL, Export, 0);
  1194.       last := unit.Idents.Last(IDENT);
  1195.       Check(lxEQ);
  1196.       Next;
  1197.       NEW(NewType);
  1198.       MemErr(NewType = NIL);
  1199.       last.T := NewType;
  1200.       T := StructType(FALSE, NewType);
  1201.       Check(lxSemi);
  1202.       Next
  1203.     END
  1204.   END;
  1205.   LinkPtr;
  1206.   unit.typedecl := FALSE;
  1207.   IF SCAN.tLex = lxVAR THEN
  1208.     Next;
  1209.     WHILE SCAN.tLex = lxIDENT DO
  1210.       IdentDef;
  1211.       PushIdent(Name, coord, IDVAR, NIL, NIL, Export, 0);
  1212.       IF SCAN.tLex = lxComma THEN
  1213.         NextCheck(lxIDENT)
  1214.       ELSIF SCAN.tLex = lxColon THEN
  1215.         NextCoord(coord);
  1216.         T := ParseType(coord);
  1217.         Assert(T # NIL, coord, 42);
  1218.         SetVars(T);
  1219.         Check(lxSemi);
  1220.         Next
  1221.       ELSE
  1222.         Assert2(FALSE, 85)
  1223.       END
  1224.     END
  1225.   END;
  1226.   WHILE SCAN.tLex = lxPROCEDURE DO
  1227.     NextCoord(coord);
  1228.     IF CallFlag(Call) THEN
  1229.       Assert(unit.Level = 3, coord, 45);
  1230.       Assert(unit.sys, coord, 111)
  1231.     END;
  1232.     Check(lxIDENT);
  1233.     IdentDef;
  1234.     PushIdent(Name, coord, IDPROC, CreateType(TPROC, 0, 4, 0, voidtype, TRUE, NIL), NIL, Export, 0);
  1235.     id := unit.Idents.Last(IDENT);
  1236.     addproc;
  1237.     id.Proc := curproc;
  1238.     IF id.Export & main THEN
  1239.       IF Platform IN {1, 6} THEN
  1240.         curproc.used := TRUE;
  1241.         Assert((Name # SCAN._START) & (Name # SCAN._version), coord, 133)
  1242.       END;
  1243.       X86.ProcExport(id.Number, Name, X86.NewLabel())
  1244.     END;
  1245.     id.Parent := curBlock;
  1246.     curBlock := id;
  1247.     Guard;
  1248.     FormalList(NIL, curBlock.T.Base);
  1249.     id.T.Call := Call;
  1250.     Check(lxSemi);
  1251.     Next;
  1252.     DeclSeq;
  1253.     id.LocalSize := id.VarSize - id.ParamSize;
  1254.     X86.Label(X86.NewLabel());
  1255.     curproc.beg := X86.current;
  1256.     X86.ProcBeg(id.Number, id.LocalSize, FALSE);
  1257.     IF SCAN.tLex = lxBEGIN THEN
  1258.       Next;
  1259.       OpSeq
  1260.     END;
  1261.     func := curBlock.T.Base.tType # TVOID;
  1262.     IF func THEN
  1263.       Check(lxRETURN);
  1264.       UTILS.UnitLine(UnitNumber, SCAN.coord.line);
  1265.       NextCoord(coord);
  1266.       Expr(e);
  1267.       Assert(AssComp(e, curBlock.T.Base, FALSE), coord, 125);
  1268.       IF e.eType = eVAR THEN
  1269.         X86.Load(e.T.tType)
  1270.       END
  1271.     ELSE
  1272.       Assert2(SCAN.tLex # lxRETURN, 123)
  1273.     END;
  1274.     Check(lxEND);
  1275.     NextCheck(lxIDENT);
  1276.     Assert2(SCAN.id = Name, 87);
  1277.     NextCheck(lxSemi);
  1278.     Next;
  1279.     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);
  1280.     X86.Label(X86.NewLabel());
  1281.     curproc.end := X86.current;
  1282.     PopBlock;
  1283.     curBlock := curBlock.Parent;
  1284.     curproc := curBlock.Proc(Proc);
  1285.   END
  1286. END DeclSeq;
  1287.  
  1288. PROCEDURE Rtl(u: UNIT);
  1289.  
  1290.   PROCEDURE AddProc(name: UTILS.STRING; num: INTEGER);
  1291.   VAR id: IDENT;
  1292.   BEGIN
  1293.     id := GetQIdent(u, SCAN.AddNode(name));
  1294.     id.Proc(Proc).used := TRUE;
  1295.     IF id = NIL THEN
  1296.       UTILS.ErrMsg(158);
  1297.       UTILS.HALT(1)
  1298.     END;
  1299.     X86.AddRtlProc(num, id.Number)
  1300.   END AddProc;
  1301.  
  1302. BEGIN
  1303.   AddProc("_newrec", X86._newrec);
  1304.   AddProc("_disprec", X86._disprec);
  1305.   AddProc("_rset", X86._rset);
  1306.   AddProc("_inset", X86._inset);
  1307.   AddProc("_saverec", X86._saverec);
  1308.   AddProc("_checktype", X86._checktype);
  1309.   AddProc("_strcmp", X86._strcmp);
  1310.   AddProc("_lstrcmp", X86._lstrcmp);
  1311.   AddProc("_rstrcmp", X86._rstrcmp);
  1312.   AddProc("_savearr", X86._savearr);
  1313.   AddProc("_arrayidx", X86._arrayidx);
  1314.   AddProc("_arrayidx1", X86._arrayidx1);
  1315.   AddProc("_arrayrot", X86._arrayrot);
  1316.   AddProc("_assrt", X86._assrt);
  1317.   AddProc("_strcopy", X86._strcopy);
  1318.   AddProc("_init", X86._init);
  1319.   AddProc("_close", X86._close);
  1320.   AddProc("_halt", X86._halt);
  1321.   AddProc("_length", X86._length);
  1322. END Rtl;
  1323.  
  1324. PROCEDURE ImportList;
  1325. VAR cond: INTEGER; coord, namecoord: SCAN.TCoord;
  1326.     name, alias: SCAN.NODE; u, self: UNIT;
  1327.     FName: UTILS.STRING;
  1328.  
  1329.   PROCEDURE AddUnit(newcond: INTEGER);
  1330.   VAR str: STRITEM;
  1331.   BEGIN
  1332.     u := GetModule(name);
  1333.     IF u = NIL THEN
  1334.       self := unit;
  1335.       SCAN.Backup(unit.scanner);
  1336.       COPY(name.Name, FName);
  1337.       IF ~((~self.Std & pReadModule(Path, FName, UTILS.Ext)) OR pReadModule(Std, FName, UTILS.Ext)) THEN
  1338.         IF FName = "SYSTEM" THEN
  1339.           unit := sys;
  1340.           self.sys := TRUE
  1341.         ELSE
  1342.           Assert(FALSE, namecoord, 32)
  1343.         END
  1344.       END;
  1345.       SCAN.Recover(self.scanner);
  1346.       u := unit;
  1347.       unit := self;
  1348.       UTILS.SetFile(unit.File)
  1349.     ELSE
  1350.       Assert(u.Closed, namecoord, 31)
  1351.     END;
  1352.     PushIdent(alias, coord, IDMOD, voidtype, u, FALSE, 0);
  1353.     NEW(str);
  1354.     MemErr(str = NIL);
  1355.     str.Str := name.Name;
  1356.     UTILS.Push(unit.Import, str);
  1357.     cond := newcond
  1358.   END AddUnit;
  1359.  
  1360. BEGIN
  1361.   cond := 0;
  1362.   WHILE cond # 4 DO
  1363.     Next;
  1364.     CASE cond OF
  1365.     |0: Check(lxIDENT);
  1366.         name := SCAN.id;
  1367.         Coord(coord);
  1368.         Coord(namecoord);
  1369.         alias := name;
  1370.         cond := 1
  1371.     |1: CASE SCAN.tLex OF
  1372.         |lxComma:  AddUnit(0)
  1373.         |lxSemi:   AddUnit(4); Next
  1374.         |lxAssign: cond := 2
  1375.         ELSE
  1376.           Assert2(FALSE, 28)
  1377.         END
  1378.     |2: Check(lxIDENT);
  1379.         name := SCAN.id;
  1380.         Coord(namecoord);
  1381.         cond := 3
  1382.     |3: CASE SCAN.tLex OF
  1383.         |lxComma: AddUnit(0)
  1384.         |lxSemi:  AddUnit(4); Next
  1385.         ELSE
  1386.           Assert2(FALSE, 29)
  1387.         END
  1388.     ELSE
  1389.     END
  1390.   END
  1391. END ImportList;
  1392.  
  1393. PROCEDURE Header(Name: SCAN.NODE);
  1394. BEGIN
  1395.   NEW(unit);
  1396.   MemErr(unit = NIL);
  1397.   unit.Idents := UTILS.CreateList();
  1398.   unit.Level := 0;
  1399.   unit.Name := Name;
  1400.   Guard; Guard;
  1401.   PushIdent(unit.Name, zcoord, IDMOD, voidtype, unit, FALSE, 0);
  1402.   Guard;
  1403.   unit.IdentBegin := unit.Idents.Last(IDENT);
  1404.   unit.Closed := TRUE
  1405. END Header;
  1406.  
  1407. PROCEDURE Pseudo;
  1408. VAR temp: UNIT;
  1409. BEGIN
  1410.   temp := unit;
  1411.   Header(SCAN.AddNode("SYSTEM"));
  1412.   PushSysProc("ADR",     sysADR);
  1413.   PushSysProc("SIZE",    sysSIZE);
  1414.   PushSysProc("TYPEID",  sysTYPEID);
  1415.   PushSysProc("GET",     sysGET);
  1416.   PushSysProc("PUT",     sysPUT);
  1417.   PushSysProc("CODE",    sysCODE);
  1418.   PushSysProc("MOVE",    sysMOVE);
  1419.   PushSysProc("INF",     sysINF);
  1420.   PushSysType("CARD16",  TCARD16);
  1421.   sys := unit;
  1422.   unit := temp
  1423. END Pseudo;
  1424.  
  1425. PROCEDURE ReadModule(Path, Name1, Ext: UTILS.STRING): BOOLEAN;
  1426. VAR FHandle: INTEGER; name, Name, b: UTILS.STRING; idmod: IDENT; Res, temp: BOOLEAN; coord: SCAN.TCoord;
  1427. BEGIN
  1428.   Res := FALSE;
  1429.   name := Name1;
  1430.   Name := Name1;
  1431.   b := Path;
  1432.   UTILS.concat(b, Name);
  1433.   Name := b;
  1434.   UTILS.concat(Name, Ext);
  1435.  
  1436.   IF SCAN.Open(Name, FHandle) THEN
  1437.     NEW(unit);
  1438.     MemErr(unit = NIL);
  1439.     unit.sys := FALSE;
  1440.     unit.Std := Path = Std;
  1441.     UTILS.Push(prog, unit);
  1442.     unit.Idents := UTILS.CreateList();
  1443.     unit.Import := UTILS.CreateList();
  1444.     NEW(unit.scanner);
  1445.     MemErr(unit.scanner = NIL);
  1446.     unit.Closed := FALSE;
  1447.     unit.Level := 0;
  1448.     unit.typedecl := FALSE;
  1449.     COPY(Name, unit.File);
  1450.     UTILS.SetFile(unit.File);
  1451.     StIdent;
  1452.     NextCheck(lxMODULE);
  1453.     NextCheck(lxIDENT);
  1454.     Assert2(UTILS.streq(SCAN.id.Name, name), 33);
  1455.     unit.Name := SCAN.id;
  1456.     coord := SCAN.coord;
  1457.     PushIdent(unit.Name, coord, IDMOD, voidtype, unit, FALSE, 0);
  1458.     idmod := unit.Idents.Last(IDENT);
  1459.     Guard;
  1460.     NextCheck(lxSemi);
  1461.     Next;
  1462.     IF SCAN.tLex = lxIMPORT THEN
  1463.       temp := main;
  1464.       main := FALSE;
  1465.       ImportList;
  1466.       main := temp
  1467.     END;
  1468.     UTILS.OutString("compiling "); UTILS.OutString(unit.Name.Name); UTILS.Ln;
  1469.     X86.Module(idmod.Name.Name, idmod.Number);
  1470.     UnitNumber := idmod.Number;
  1471.     unit.IdentBegin := unit.Idents.Last(IDENT);
  1472.     curBlock := idmod;
  1473.     DeclSeq;
  1474.     X86.ProcBeg(idmod.Number, 0, TRUE);
  1475.     IF SCAN.tLex = lxBEGIN THEN
  1476.       addproc;
  1477.       curproc.used := TRUE;
  1478.       Next;
  1479.       OpSeq
  1480.     END;
  1481.     Check(lxEND);
  1482.     NextCheck(lxIDENT);
  1483.     Assert2(SCAN.id = unit.Name, 26);
  1484.     NextCheck(lxDot);
  1485.     X86.Leave;
  1486.     unit.Closed := TRUE;
  1487.     UTILS.Clear(unit.Import);
  1488.     Res := TRUE
  1489.   END
  1490.   RETURN Res
  1491. END ReadModule;
  1492.  
  1493. PROCEDURE Program*(StdPath, FilePath, NameFile, ExtFile: UTILS.STRING; windows: BOOLEAN;
  1494.   OpSeqProc: opPROC; ExprProc: expPROC; AssCompProc: assPROC; VAR stypes: stTYPES);
  1495. BEGIN
  1496.   winplatf := windows;
  1497.   Path := FilePath;
  1498.   Main := NameFile;
  1499.   ExtMain := ExtFile;
  1500.   Std := StdPath;
  1501.   OpSeq := OpSeqProc;
  1502.   Expr := ExprProc;
  1503.   AssComp := AssCompProc;
  1504.   prog := UTILS.CreateList();
  1505.   PtrBases := UTILS.CreateList();
  1506.   types := UTILS.CreateList();
  1507.   procs := UTILS.CreateList();
  1508.   StTypes;
  1509.   voidtype := sttypes[TVOID];
  1510.   Strings := UTILS.CreateList();
  1511.   Pseudo;
  1512.   stypes := sttypes
  1513. END Program;
  1514.  
  1515. PROCEDURE delfirstchar(VAR s: UTILS.STRING);
  1516. VAR i: INTEGER;
  1517. BEGIN
  1518.   FOR i := 0 TO LENGTH(s) - 1 DO
  1519.     s[i] := s[i + 1]
  1520.   END
  1521. END delfirstchar;
  1522.  
  1523. PROCEDURE DelProcs;
  1524. VAR cur: Proc;
  1525.  
  1526.   PROCEDURE ProcHandling(proc: Proc);
  1527.   VAR cur: IDENT; p: Proc;
  1528.   BEGIN
  1529.     proc.used := TRUE;
  1530.     cur := proc.Procs.First(IDENT);
  1531.     WHILE cur # NIL DO
  1532.       p := cur.Proc(Proc);
  1533.       IF ~p.used THEN
  1534.         ProcHandling(p)
  1535.       END;
  1536.       cur := cur.Next(IDENT)
  1537.     END;
  1538.   END ProcHandling;
  1539.  
  1540. BEGIN
  1541.   cur := procs.First(Proc);
  1542.   WHILE cur # NIL DO
  1543.     IF cur.used THEN
  1544.       ProcHandling(cur)
  1545.     END;
  1546.     cur := cur.Next(Proc)
  1547.   END;
  1548.   cur := procs.First(Proc);
  1549.   WHILE cur # NIL DO
  1550.     IF ~cur.used THEN
  1551.       X86.DelProc(cur.beg, cur.end)
  1552.     END;
  1553.     cur := cur.Next(Proc)
  1554.   END
  1555. END DelProcs;
  1556.  
  1557. PROCEDURE Compile*(platform, stksize: INTEGER);
  1558. VAR full, path, name, ext, temp, path2: UTILS.STRING;
  1559. BEGIN
  1560.   Platform := platform;
  1561.   main := FALSE;
  1562.   IF ReadModule(Path, "RTL", UTILS.Ext) OR ReadModule(Std, "RTL", UTILS.Ext) THEN
  1563.     Rtl(unit)
  1564.   ELSE
  1565.     UTILS.ErrMsg(65);
  1566.     UTILS.HALT(1)
  1567.   END;
  1568.   main := TRUE;
  1569.   IF ~ReadModule(Path, Main, ExtMain) THEN
  1570.     path2 := Path;
  1571.     UTILS.ParamStr(full, 0);
  1572.     UTILS.Split(full, path, name, ext);
  1573.     IF path[0] # 0X THEN
  1574.       path[LENGTH(path) - 1] := 0X
  1575.     END;
  1576.     IF Path[0] = UTILS.Slash THEN
  1577.       delfirstchar(Path)
  1578.     END;
  1579.     UTILS.concat(path, UTILS.Slash);
  1580.     full := path;
  1581.     UTILS.concat(full, Path);
  1582.     Path := full;
  1583.     IF (UTILS.OS = "WIN") & (Path[0] = UTILS.Slash) THEN
  1584.       delfirstchar(Path)
  1585.     END;
  1586.     IF ~ReadModule(Path, Main, ExtMain) THEN
  1587.       UTILS.ErrMsg(64);
  1588.       UTILS.OutString(path2);
  1589.       UTILS.OutString(Main);
  1590.       UTILS.OutString(ExtMain);
  1591.       UTILS.Ln;
  1592.       UTILS.HALT(1)
  1593.     END
  1594.   END;
  1595.   temp := Path;
  1596.   UTILS.concat(temp, Main);
  1597.   IF platform IN {2, 3} THEN
  1598.     UTILS.concat(temp, ".exe")
  1599.   ELSIF platform = 1 THEN
  1600.     UTILS.concat(temp, ".dll")
  1601.   ELSIF platform = 4 THEN
  1602.     UTILS.concat(temp, ".kex")
  1603.   ELSIF platform = 6 THEN
  1604.     UTILS.concat(temp, ".obj")
  1605.   END;
  1606.   IF platform IN {1, 2, 3, 4} THEN
  1607.     stksize := stksize * 100000H
  1608.   END;
  1609.   DelProcs;
  1610.   X86.Epilog(ProgSize, temp, stksize)
  1611. END Compile;
  1612.  
  1613. BEGIN
  1614.   pParseType := ParseType;
  1615.   pReadModule := ReadModule;
  1616.   zcoord.line := 0;
  1617.   zcoord.col := 0
  1618. END DECL.