开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 游戏 > 游戏引擎 > 查看源码
OComp.pas
资源名称：CAST2SDK.rar　[点击查看]
上传用户：yj_qiu
上传日期：2022-08-08
资源大小：23636k
文件大小：69k
源码类别：

游戏引擎

开发平台：

Delphi

OComp.pas：源码内容
  1. (*
  2.  Oberon compiler unit
  3.  (C) 2004-2007 George "Mirage" Bakhtadze. <a href="http://www.casteng.com">www.casteng.com</a> <br>
  4.  The source code may be used under either MPL 1.1 or LGPL 2.1 license. See included license.txt file <br>
  5.  The unit contains compiler main class
  6. *)
  7. {$DEFINE DEBUG}
  8. unit OComp;
  10. interface
  12. uses SysUtils,
  13. {$IFDEF DEBUG} Classes, {$ENDIF}
  14.   OTypes, OScan, ORun, Dialogs;
  16. const
  17.   ConstMask  = 0 shl 24; VarMask = 1 shl 24; ProcMask = 2 shl 24;
  18.   ArrayMask = 4 shl 24; COArrayMask = 8 shl 24; ResWordMask = 16 shl 24; 
  19.   AllMask = 127 shl 24;
  21. type
  22.   TCompiledModule = record
  23.   end;
  25.   TTokenSet = set of TToken;
  27.   TCompiler = class
  28.     Scaner: TScaner;
  29.     Error: Boolean;
  30.     CError: TCompilationError;
  31.     CurNamespace, Namespace: PNamespace;       // Current and global namespaces
  32.     LastExpConstant: Boolean;
  33.     LoopCount: Integer;
  34. // Run-time data
  35.     Data: TRTData;
  36.     ExternalVars: array of record
  37.       VarAddress: Pointer;
  38.       VarName, VarType: string;
  39.     end;
  40.     constructor Create(AScaner: TScaner);
  41.     destructor Destroy; override;
  42.     procedure Reset;
  43.     function Compile: Integer;
  45.     function ImportExternalVar(AName, AType: string; Address: Pointer): Boolean;
  46.     function GetExternalVarIndex(AName: string): Integer;
  48.     function AddType(AName: TName): PType;
  49.     procedure ClearType(AType: PType); virtual;
  51.     function NewNamespace(AName: TName): PNamespace;
  52.     procedure AddNamespace(AName: TName); virtual;
  53.     procedure ClearNamespace(NS: PNamespace); virtual;
  55.     function AllocateData(const DataSize, Value: Integer): Integer;
  56.     function AllocateStack(const DataSize: Integer): Integer;
  58.     function AddIdent(AKind: Int32; AName: TName; AType, AValue: Integer): Integer; overload;
  59.     function AddIdentS(AKind: Int32; AName: TName; AType: Integer; AValue: Single): Integer; overload;
  60.     function CheckIdent(AName: TName; NS: PNamespace; SearchToRoot: Boolean; var IdentKind: Integer): Int32;
  62.     function SpecifyArray(TypeID: Integer; var Offset: Integer; var RuntimeOffs: Boolean): Integer;
  63.     function SpecifyRecord(TypeID: Integer; var Offset: Integer; var RuntimeOffs: Boolean): Integer;
  64.     function SpecifyVariable(AName: TName; TypeID: Integer; var Offset: Integer; var RuntimeOffs: Boolean): Integer;
  66.     function CompileBlock(ReturnType: Integer): Integer;
  67.     function ComputeExpression(StartPIN: Integer): Integer;
  68.     function SetNValue(PINIndex: Integer; Buffer: string; SetType: Boolean): Integer;
  69.     function SetSValue(PINIndex: Integer; Buffer: string): Integer;
  70.     function isNumeric(AType: Integer): Boolean;
  71.     function isInteger(AType: Integer): Boolean;
  72.     function isReal(AType: Integer): Boolean;
  73.   private
  74.     LocalVM: TOberonVM;
  75.     TotalNamesSpaces: Integer;
  76.     procedure AddOperation(LastOp, OldType: Integer; var Res: Integer);
  77.     function ControlTypes(var Operation: Integer; Type1, Type2: Integer): Integer;
  78.     procedure SynError(ASource: string; AErrorNum: Integer; AErrorData: Integer);
  79.     function CheckEnd(Buf: string): Integer;
  80.     function CheckOperator(Buf: string): Integer;
  81.     function GetOp1: Integer;
  82.     function Exp1: Integer;
  83.     function Exp2: Integer;
  84.     function SimplifyExpression(Loc: Integer): Integer;
  85.     function Expression: Integer;
  86.     function ConstantExpression(var ExpResult: Integer): Integer;
  87.     function GetOperator(Buf: string): Integer;
  88.     procedure ParseAssign(IdentID, IdentOffset: Integer);
  89.     procedure ParseLoop(ReturnType: Integer);
  90.     procedure ParseWhile(ReturnType: Integer);
  91.     procedure ParseRepeat(ReturnType: Integer);
  92.     procedure ParseFor(ReturnType: Integer);
  93.     procedure ParseIf(ReturnType: Integer);
  94.     procedure ParseCall(const ProcID: Integer);
  95.     procedure SetVarLocation(var AVar: TIdent; ALocation: Integer);
  96.     function ParseVarSection: Integer;
  97.     function ParseVar: Integer;
  98.     procedure ParseConst;
  99.     procedure ParseProc;
  100.     function ParseTypeDef(TypeName: TName; AlwaysNew: Boolean): Integer;
  101.     procedure ParseType;
  102.     function GetDeclaration(Buf: string): Integer;
  103. //    function GetTypeKind(TID: Integer): Integer;
  104.     function GetType(Buf: string): Integer;
  105.     function GetTypeSize(const TID: Integer): Integer;
  106.     function GetConst(const Index: Integer): Integer;
  107.     function Operators(ReturnType: Integer): Integer;
  108.     function Declarations: Integer;
  109.   end;
  111. implementation
  113. function TCompiler.SetNValue(PINIndex: Integer; Buffer: string; SetType: Boolean): Integer;            // ToFix: Check values range
  114. var i: Integer; Temp: Extended; DecPos: Int32;
  116. function HexStrToInt: Integer;
  117. var i: Integer;
  118. begin
  119.   Result := 0;
  120.   for i := 1 to Length(Buffer)-1 do begin
  121.     if Buffer[i] in ['0'..'9'] then
  122.      Result := (Result shl 4) or (Ord(Buffer[i]) - Ord('0')) else
  123.       if UpCase(Buffer[i]) in ['A'..'F'] then begin
  124.         if i = 1 then SynError('HexStrToStr', eInvalidNumber, 0) else
  125.         Result := (Result shl 4) or (Ord(UpCase(Buffer[i])) - Ord('A') + 10)
  126.       end else SynError('HexStrToStr', eInvalidNumber, 0);
  127.   end;
  128.   if UpCase(Buffer[Length(Buffer)]) <> 'H' then SynError('HexStrToStr', eInvalidNumber, 0);
  129. end;
  131. begin
  132.   Result := -1;
  133.   DecPos := Pos('.', Buffer);
  134.   if DecPos = 0 then begin
  135.     Data.PIN[PINIndex+1] := StrToIntDef(Buffer, 0);
  136.     for i := 1 to Length(Buffer) do if not (UpCase(Buffer[i]) in ['0'..'9']) then begin
  137.       Data.PIN[PINIndex+1] := HexStrToInt;                     // Number in hex format
  138.       Break;
  139.     end;
  140.     if Error then Exit;
  141.     if SetType then Data.PIN[PINIndex] := GetVTypeInt(Data.PIN[PINIndex+1]);
  142.   end else begin
  143.     if Pos('.', Copy(Buffer, DecPos+1, Length(Buffer))) > 0 then begin
  144.       SynError('SetNValue', eInvalidNumber, 0);
  145.       Exit;
  146.     end;
  147.     for i := 1 to Length(Buffer) do if not (UpCase(Buffer[i]) in ['0'..'9', 'D', 'E', '.', '-', '+']) then begin
  148.       SynError('SetNValue', eInvalidNumber, 0);
  149.       Exit;
  150.     end;
  151.     Buffer[DecPos] := ',';
  152.     DecPos := Length(Buffer)-DecPos;
  153.     case DecPos of
  154.       1..7: Data.PIN[PINIndex] := dtSingle;                         // ToFix: Wrong type checking
  155.       8..15: Data.PIN[PINIndex] := dtDouble;
  156.       else Data.PIN[PINIndex] := dtReal;
  157.     end;
  158.     Temp := StrToFloat(Buffer);
  159.     Single((@Data.PIN[PINIndex+1])^) := Temp;
  160.   end;
  161.   Result := Data.PIN[PINIndex];
  162. end;
  164. function TCompiler.SetSValue(PINIndex: Integer; Buffer: string): Integer;
  165. var Len: Nat16;
  166. begin
  167.   Result := -1;
  168.   Data.PIN[PINIndex+1] := Data.DataLength;
  169.   Data.PIN[PINIndex] := dtString;
  170.   Len := Length(Buffer);
  171.   Move(Len, Pointer(Int32(Data.Data)+Data.DataLength)^, 2);
  172.   if Len > 0 then Move(Buffer[1], Pointer(Int32(Data.Data)+Data.DataLength+2)^, Len);
  173.   Inc(Data.DataLength, Len+2);
  174.   Result := Data.PIN[PINIndex];
  175. end;
  177. function TCompiler.AddType(AName: TName): PType;
  178. begin
  179.   Assert(CurNamespace <> nil, 'AddType: Current namespace is nil');
  180.   New(Result);
  181.   Inc(Data.TotalTypes); SetLength(Data.Types, Data.TotalTypes);
  182.   Data.Types[Data.TotalTypes-1] := Result;
  184.   Inc(CurNamespace.TotalTypes); SetLength(CurNamespace.Types, CurNamespace.TotalTypes);
  185.   CurNamespace.Types[CurNamespace.TotalTypes-1] := Data.TotalTypes-1;
  187.   Result.Name := AName;
  188.   Result.ID := Data.TotalTypes-1;
  189.   Result.Kind := 0;
  190.   Result.Namespace := nil;
  191.   Result.Size := SizeOf(TStackItem);
  192. end;
  194. function TCompiler.NewNamespace(AName: TName): PNamespace;
  195. begin
  196.   New(Result);
  197.   Result.Name := AName;
  198.   Result.TotalConstants := 0; SetLength(Result.Constants, 0);
  199.   Result.TotalVariables := 0; SetLength(Result.Variables, 0);
  200.   Result.TotalProcedures := 0; SetLength(Result.Procedures, 0);
  201.   Result.TotalTypes := 0; SetLength(Result.Types, 0);
  202.   Result.Parent := nil;
  203.   Result.Kind := nskModule;
  204.   Result.StackLength := 0;
  205.   Result.ParamCount := 0; Result.ID := 0;
  206.   Result.UID := TotalNamesSpaces;
  207.   Inc(TotalNamesSpaces);
  208. end;
  210. procedure TCompiler.AddNamespace(AName: TName);
  211. var NewNS: PNamespace;
  212. begin
  213.   NewNS := NewNamespace(AName);
  214.   if CurNamespace = nil then Namespace := NewNS else begin
  215.     Inc(CurNamespace.TotalProcedures); SetLength(CurNamespace.Procedures, CurNamespace.TotalProcedures);
  216.     CurNamespace.Procedures[CurNamespace.TotalProcedures-1] := NewNS;
  217.   end;
  218.   NewNS.Parent := CurNamespace;
  219.   CurNamespace := NewNS;
  220. end;
  222. procedure TCompiler.ClearType(AType: PType);
  223. begin
  224.   if AType.Namespace <> nil then ClearNamespace(AType.Namespace);
  225. end;
  227. procedure TCompiler.ClearNamespace(NS: PNamespace);
  228. var i: Integer;
  229. begin
  230.   NS.TotalConstants := 0; SetLength(NS.Constants, 0);
  231.   NS.TotalVariables := 0; SetLength(NS.Variables, 0);
  232.   NS.TotalTypes := 0; SetLength(NS.Types, 0);
  233.   for i := 0 to NS.TotalProcedures-1 do begin
  234.     ClearNamespace(NS.Procedures[i]);
  235.     Dispose(NS.Procedures[i]);
  236.   end;
  237.   NS.TotalProcedures := 0; SetLength(NS.Procedures, 0);
  238. end;
  240. function TCompiler.AddIdent(AKind: Int32; AName: TName; AType, AValue: Integer): Integer;
  241. // Adds constant, variable or procedure identifier
  242. // In case of variable doesn't allocate data
  243. // Returns index of the new identifier
  244. var Offset, IdentKind: Integer;
  245. begin
  246.   Result := -1;
  247.   case AKind of
  248.     ikConstant: begin
  249.       Inc(Data.TotalConstants); SetLength(Data.Constants, Data.TotalConstants);
  250.       with Data.Constants[Data.TotalConstants-1] do begin
  251.         Name := AName; TypeID := AType; Namespace := CurNamespace;
  252.         Index := AllocateData(GetTypeSize(AType), AValue);
  253.         Location := ilGlobal;
  254.       end;
  255.       Inc(CurNamespace.TotalConstants); SetLength(CurNamespace.Constants, CurNamespace.TotalConstants);
  256.       CurNamespace.Constants[CurNamespace.TotalConstants-1] := Data.TotalConstants-1;
  257.       Result := Data.TotalConstants-1;
  258.     end;
  259.     ikVariable: begin
  260.       Offset := CheckIdent(AName, Namespace, False, IdentKind);
  261.       if (CurNamespace <> NameSpace) or (Offset = -1) then begin
  262.         Inc(Data.TotalVariables); SetLength(Data.Variables, Data.TotalVariables);
  263.         with Data.Variables[Data.TotalVariables-1] do begin
  264.           Name := AName; TypeID := AType; Namespace := CurNamespace;
  265. //          if Data.Types[AType].Kind <> tkRecord then begin
  266. //          end;
  267.         end;
  268.         Inc(CurNamespace.TotalVariables); SetLength(CurNamespace.Variables, CurNamespace.TotalVariables);
  269.         CurNamespace.Variables[CurNamespace.TotalVariables-1] := Data.TotalVariables-1;
  270.         Result := Data.TotalVariables-1;
  271.       end else Result := Offset and not AllMask;
  272.     end;
  273.     ikProcedure: begin
  274.       Inc(Data.TotalProcedures); SetLength(Data.Procedures, Data.TotalProcedures);
  275.       with Data.Procedures[Data.TotalProcedures-1] do begin
  276.         Name := AName; TypeID := AType; Namespace := CurNamespace;
  277.         Index := AllocateData(4, AValue);
  278.         Location := ilGlobal;
  279.       end;
  280. //      Inc(CurNamespace.TotalProcedures); SetLength(CurNamespace.Procedures, CurNamespace.TotalProcedures);
  281. //      CurNamespace.Procedures[CurNamespace.TotalProcedures-1].Value := TotalProcedures-1;
  282.       Result := Data.TotalProcedures-1
  283.     end;
  284.     ikType:;{ begin
  285.       Inc(Data.TotalTypes); SetLength(Data.Types, Data.TotalTypes);
  286.       with Data.Types[Data.TotalTypes-1] do begin
  287.         Name := AName; Value := AValue; TypeID := AType; Namespace := CurNamespace;
  288.       end;
  289.     end;}
  290.     else Assert(False, 'Invalid identifier kind');
  291.   end;
  292. end;
  294. function TCompiler.AddIdentS(AKind: Int32; AName: TName; AType: Integer; AValue: Single): Integer;
  295. begin
  296.   Result := AddIdent(AKind, AName, AType, Integer((@AValue)^));
  297. end;
  299. procedure TCompiler.SynError(ASource: string; AErrorNum: Integer; AErrorData: Integer);
  300. begin
  301.   if Error then Exit;
  302.   with CError do begin
  303.     Source := ASource;
  304.     Line := Scaner.CurLine;
  305.     Position := Scaner.SourcePos;
  306.     Number := AErrorNum;
  307.     Data := AErrorData;
  308.   end;
  309.   Error := True;
  310. end;
  312. function TCompiler.CheckEnd(Buf: string): Integer;
  313. var i: Integer;
  314. begin
  315.   Result := -1;
  316.   for i := 0 to TotalEndTokens-1 do if Buf = EndTokenStr[i] then begin
  317.     Result := i;
  318.     Break;
  319.   end;
  320. end;
  322. function TCompiler.CheckOperator(Buf: string): Integer;
  323. var i: Integer;
  324. begin
  325.   Result := -1;
  326.   for i := 0 to TotalOperators-1 do if Buf = OperatorStr[i] then begin
  327.     Result := i;
  328.     Break;
  329.   end;
  330. end;
  332. function TCompiler.SpecifyArray(TypeID: Integer; var Offset: Integer; var RuntimeOffs: Boolean): Integer;
  333. // Parses "["Exp"]"
  334. var i, ExpStartPIN: Integer; ch: Char;
  335. begin
  336. //  Assert(Data.Types[TID].ID = TID, 'CheckIdent.SpecifyArray: Type ID mismatch');
  338.   Scaner.SkipDelims;
  339.   Scaner.ReadChar(ch);
  340.   if ch <> '[' then begin Result := TypeID; Scaner.ReturnChar(ch); Exit; end;
  342.   ExpStartPIN := Data.PINItems;
  343.   LastExpConstant := True;
  344.   if not isInteger(Exp1) then begin
  345.     SynError('SpecifyArray', eIntExpExpected, 0);
  346.     Exit;
  347.   end;
  348.   if Error then Exit;
  350.   if LastExpConstant then begin
  351.     Offset := Offset + ComputeExpression(ExpStartPIN) * GetTypeSize(Data.Types[TypeID].ID);
  352.     Data.PINItems := ExpStartPIN;
  353.   end else begin
  354.     Inc(Data.PINItems, 3); SetLength(Data.PIN, Data.PINItems);
  355.     Data.PIN[Data.PINItems-3] := dtInt;
  356.     Data.PIN[Data.PINItems-2] := GetTypeSize(Data.Types[TypeID].ID);
  357.     Data.PIN[Data.PINItems-1] := aoMulII;                              // Multiply expression by element size
  358.     if RuntimeOffs then begin
  359.       Inc(Data.PINItems, 1); SetLength(Data.PIN, Data.PINItems);
  360.       Data.PIN[Data.PINItems-1] := aoAddII;                              // Add base variable address
  361.     end;
  362.     RuntimeOffs := True;
  363.   end;
  365.   Scaner.SkipDelims;
  366.   Scaner.ReadChar(ch);
  367.   if ch <> ']' then begin
  368.     SynError('SpecifyArray', eRightBracketExpected, 0);
  369.     Exit;
  370.   end;
  372.   case Data.Types[Data.Types[TypeID].ID].Kind of
  373.     tkCommon: Result := Data.Types[TypeID].ID;
  374.     tkRecord: Result := SpecifyRecord(Data.Types[TypeID].ID, Offset, RuntimeOffs);
  375.     tkArray: Result := SpecifyArray(Data.Types[TypeID].ID, Offset, RuntimeOffs);
  376.   end;
  377. end;
  379. function TCompiler.SpecifyRecord(TypeID: Integer; var Offset: Integer; var RuntimeOffs: Boolean): Integer;
  380. // Parses "."ident
  381. // Returns field index
  382. var ch: Char; FieldIndex, TempIdentKind: Integer;
  383. begin
  384.   Scaner.SkipDelims;
  385.   Scaner.ReadChar(ch);
  386.   if ch <> '.' then begin Result := TypeID; Scaner.ReturnChar(ch); Exit; end;
  387.   Scaner.SkipDelims;
  388.   Scaner.ReadChar(ch);
  389.   Scaner.GetIdent(ch);
  390.   if Scaner.Buf = '' then SynError('SpecifyRecord', eVariableExpected, 0) else
  392.   FieldIndex := CheckIdent(Scaner.Buf, Data.Types[TypeID].Namespace, False, TempIdentKind);
  393.   if FieldIndex = -1 then begin                                       // Not found
  394.     SynError('SpecifyRecord', eUndeclaredIdentifier, 0); Exit;
  395.   end;
  396.   if (TempIdentKind and ResWordMask > 0) then begin                     // Found, but is reserved word
  397.     SynError('SpecifyRecord', eUnexpectedResWord, 0); Exit;
  398.   end;
  400.   Offset := Offset + Data.Variables[FieldIndex].Index;
  402.   case Data.Types[Data.Variables[FieldIndex].TypeID].Kind of
  403.     tkCommon: Result := Data.Variables[FieldIndex].TypeID;
  404.     tkRecord: Result := SpecifyRecord(Data.Variables[FieldIndex].TypeID, Offset, RuntimeOffs);
  405.     tkArray: Result := SpecifyArray(Data.Variables[FieldIndex].TypeID, Offset, RuntimeOffs);
  406.   end;
  407. end;
  409. function TCompiler.SpecifyVariable(AName: TName; TypeID: Integer; var Offset: Integer; var RuntimeOffs: Boolean): Integer;
  410. // Calculates offset of specified field in record or array element of specified type
  411. // Returns type ID of the element specified
  412. // In offset returns offset of specified element
  413. // In IdentKind returns identifier kind (constant offset or run-time calculated offset)
  414. // Adds to PIN code to calculate runtime calculating offset
  415. begin
  416.   Result := TypeID;
  418.   RuntimeOffs := False;
  420.   case Data.Types[TypeID].Kind of
  421.     tkRecord: Result := SpecifyRecord(TypeID, Offset, RuntimeOffs);
  422.     tkArray: Result := SpecifyArray(TypeID, Offset, RuntimeOffs);
  423.   end;
  425.   if RuntimeOffs then begin
  426.       Inc(Data.PINItems, 3); SetLength(Data.PIN, Data.PINItems);
  427.       Data.PIN[Data.PINItems-3] := dtInt;
  428.       Data.PIN[Data.PINItems-2] := Offset;
  429.       Data.PIN[Data.PINItems-1] := aoAddII;                              // Add base variable address
  430.     end;
  432. {  if Result and ArrayMask > 0 then begin
  433.     Inc(Data.PINItems, 3); SetLength(Data.PIN, Data.PINItems);
  434.     Data.PIN[Data.PINItems-3] := dtInt;
  435.     Data.PIN[Data.PINItems-2] := Offset;
  436.     Data.PIN[Data.PINItems-1] := aoAddII;                              // Add base variable address
  437.   end;}
  439. end;
  441. function TCompiler.CheckIdent(AName: TName; NS: PNamespace; SearchToRoot: Boolean; var IdentKind: Integer): Int32;
  442. // Searches identifier by name specified
  443. // in current namespace and above namespaces if SearchToRoot is true.
  444. // Returns index in Constants, Variables etc array
  445. // In IdentKind returns kind of identifier (reserved word, constant, variable or procedure)
  446. var i: Integer; ch: Char;
  447. begin
  448.   Result := -1;
  450.   for i := 0 to TotalReservedWords-1 do if AName = ReservedWord[i] then begin
  451.     Result := i; IdentKind := ResWordMask; Exit;
  452.   end;
  454.   while NS <> nil do begin
  455.     for i := 0 to NS.TotalConstants-1 do if Data.Constants[NS.Constants[i]].Name = AName then begin
  456.       Result := NS.Constants[i]; IdentKind := ConstMask; Exit;
  457.     end;
  458.     for i := 0 to NS.TotalVariables-1 do if Data.Variables[NS.Variables[i]].Name = AName then begin
  459.       Result := NS.Variables[i]; IdentKind := VarMask; Exit;
  460.     end;
  461.     for i := 0 to NS.TotalProcedures-1 do if NS.Procedures[i].Name = AName then begin
  462.       Result := NS.Procedures[i].ID; IdentKind := ProcMask; Exit;
  463.     end;
  464.     if SearchToRoot then NS := NS.Parent else NS := nil;
  465.   end;
  466. end;
  468. procedure TCompiler.AddOperation(LastOp, OldType: Integer; var Res: Integer);
  469. begin
  470.   if LastOp <> aoNull then begin
  471.     Res := ControlTypes(LastOp, OldType, Res);
  472.     Inc(Data.PINItems, 1); SetLength(Data.PIN, Data.PINItems);
  473.     Data.PIN[Data.PINItems-1] := LastOp;
  474.   end;
  475. end;
  477. function TCompiler.GetOp1: Integer;
  478. var i: Integer;
  479. begin
  480.   Result := -1;
  481.   for i := 0 to TotalOperations1-1 do if Scaner.Buf = Op1Str[i] then begin
  482.     Result := Op1ID[i]; Break;
  483.   end;
  484. end;
  486. function TCompiler.Exp1: Integer;
  487. var ch: Char; LastOp, OldType: Integer;
  488. begin
  489. // Exp1 = ['-' | '+'] Exp2 { ['-' | '+', 'OR'] Exp2}
  490. // Result - expression type
  491.   Result := -1; OldType := -1;
  492.   LastOp := aoNull;
  493. {  Scaner.SkipDelims;
  494.   Scaner.ReadChar(ch);
  495.   if ch = '-' then NegOp := oNeg else if ch <> '+' then Scaner.ReturnChar(ch);}
  497.   Result := Exp2;                                               //
  499.   Scaner.SkipDelims;
  500.   while not Error and Scaner.ReadChar(ch) and (ch <> ';') do begin
  501.     Scaner.Buf := ch;
  503.     if Scaner.isAlpha(ch) then Scaner.GetIdent(ch);
  505.     if (ch = ',') or (ch = ')') or (ch = '}') or (ch = ']') or Scaner.isRelation(ch) or
  506.        (CheckEnd(Scaner.Buf) <> -1) or (CheckOperator(Scaner.Buf) <> -1) or (Scaner.Buf = RelationStr[6]) or (Scaner.Buf = RelationStr[7])  then begin
  507.       Scaner.ReturnBuf(Scaner.Buf); Break;
  508.     end;
  510.     LastOp := GetOp1;
  511.     if LastOp = -1 then begin
  512.       SynError('Exp1', eOperationExpected, 0);
  513.       Break;
  514.     end;
  515.     OldType := Result; Result := Exp2;
  516.     if Error then Break;
  517.     AddOperation(LastOp, OldType, Result);
  518.   end;
  519.   if ch = ';' then Scaner.ReturnBuf(ch);
  520. end;
  522. function TCompiler.Exp2: Integer;
  523. var ch: Char; LastOp, IdentIndex, IdentKind: Int32; OldType: Integer;
  525. function GetOp2: Integer;
  526. var i: Integer;
  527. begin
  528.   Result := -1;
  529.   for i := 0 to TotalOperations2-1 do if Scaner.Buf = Op2Str[i] then begin
  530.     Result := Op2ID[i]; Break;
  531.   end;
  532. end;
  534. function ParseSetConstructor: Integer;
  535. var TotalElements: Integer; ch: Char;
  536. // Set = "{" [El {, El}] "}"
  537. // El = Exp [..Exp]
  538. begin
  539.   Result := -1;
  540.   TotalElements := 0;
  541. // First element if exists
  542.   Scaner.SkipDelims; Scaner.ReadChar(ch);
  543.   Scaner.ReturnChar(ch);
  544.   if ch <> '}' then
  545.    if isInteger(Exp1) then Inc(TotalElements) else
  546.     SynError('ParseSetConstructor', eIncompatibleTypes, 0);
  547. // Rest of elements
  548.   while Scaner.ReadChar(ch) and (ch = ',') and not Error do begin
  549.     if not isInteger(Exp1) then begin SynError('ParseSetConstructor', eIncompatibleTypes, 0); Break; end;
  550.     Inc(TotalElements);
  551.     Scaner.SkipDelims;
  552.   end;
  553.   if Error then Exit;
  554.   Inc(Data.PINItems); SetLength(Data.PIN, Data.PINItems);
  555.   Data.PIN[Data.PINItems-1] := dtSet + TotalElements shl 16;
  556.   Result := dtSet;
  557. end;
  559. function ParseStdFunction: Integer;
  560. // STDPROC
  561. var i, Op, ExpType: Integer;
  562. begin
  563. {  Result := StandardFunctions[IdentIndex].ResultType;
  564.   Op := oAssign;
  565.   ExpType := Expression;
  566.   if Error then Exit;
  567.   if ControlTypes(Op, dtReal, ExpType) = -1 then Exit;
  568.   Inc(Data.PINItems, 1); SetLength(Data.PIN, Data.PINItems);
  569.   Data.PIN[Data.PINItems-1] := StandardFunctions[IdentIndex].OperationID;}
  570. end;
  572. function ParseMultiplier: Integer;
  573. var InvOp, NegOp, VarOfs, VarLoc: Integer; RTOffs: Boolean;
  574. // Mult = ~Mult | Const | Ident | (Expression)
  575. // Result - multiplier's type
  577. begin
  578.   Result := -1;
  579.   Scaner.SkipDelims; Scaner.ReadChar(ch);
  580.   if ch = '-' then begin
  581.     NegOp := oNeg;
  582.     Result := ControlTypes(NegOp, ParseMultiplier, 0);
  583.     if Result = -1 then Exit;
  584.     Inc(Data.PINItems); SetLength(Data.PIN, Data.PINItems);
  585.     Data.PIN[Data.PINItems-1] := NegOp;
  586.   end else if ch='~' then begin
  587.     InvOp := oInv;
  588.     Result := ControlTypes(InvOp, ParseMultiplier, 0);
  589.     if Result = -1 then Exit;
  590.     Inc(Data.PINItems); SetLength(Data.PIN, Data.PINItems);
  591.     Data.PIN[Data.PINItems-1] := InvOp;
  592.     Exit;
  593.   end else if Scaner.isNumber(ch) then begin
  594.     Scaner.GetNumber(ch);
  595.     Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  596. //    OldType := Result;
  597.     Result := SetNValue(Data.PINItems-2, Scaner.Buf, True);
  598. //    AddOperation(LastOp, OldType, Result);
  599.     Exit;
  600.   end else if Scaner.isAlpha(ch) then begin
  601.     Scaner.GetIdent(ch);
  602. //    if CheckOp1 then begin Scaner.ReturnBuf(Scaner.Buf); Break; end;
  603.     IdentIndex := CheckIdent(Scaner.Buf, CurNamespace, True, IdentKind);
  604.     if IdentIndex >= 0 then begin
  605.       case IdentKind of
  606.         VarMask: begin                                // Variable
  608.           if (IdentKind and VarMask <> 0) then begin                                // Variable
  609.             VarOfs := Data.Variables[IdentIndex].Index;
  610.             Result := SpecifyVariable(Scaner.Buf, Data.Variables[IdentIndex].TypeID, VarOfs, RTOffs);
  611.             VarLoc := Data.Variables[IdentIndex].Location;
  613.             if RTOffs then begin
  614.               Inc(Data.PINItems);
  615. //              if VarLoc = ilExternal then Inc(Data.PINItems);
  616.               SetLength(Data.PIN, Data.PINItems);
  617.               case VarLoc of
  618.                 ilStack: Data.PIN[Data.PINItems-1] := dtStackVariableByOfs;
  619.                 ilGlobal: Data.PIN[Data.PINItems-1] := dtVariableByOfs;
  620.                 ilExternal: Data.PIN[Data.PINItems-1] := dtExtVariableByOfs;
  621.               end;
  622. //              if VarLoc = ilExternal then Data.PIN[Data.PINItems-1] := VarOfs;
  623.             end else begin
  624.               Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  625.               case VarLoc of
  626.                 ilStack: Data.PIN[Data.PINItems-2] := dtStackVariable;
  627.                 ilGlobal: Data.PIN[Data.PINItems-2] := dtVariable;
  628.                 ilExternal: Data.PIN[Data.PINItems-2] := dtExtVariable;
  629.               end;
  630.               Data.PIN[Data.PINItems-1] := VarOfs;
  631.             end;
  632.             LastExpConstant := False;
  633.           end else begin
  634.             SynError('ParseAssign', eCannotAssign, 0); Exit;
  635.           end;
  637.           LastExpConstant := False;
  638.         end;
  639.         ConstMask: begin                              // Constant
  640.           Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  641.           Data.PIN[Data.PINItems-2] := Data.Constants[IdentIndex].TypeID;
  642.           Data.PIN[Data.PINItems-1] := GetConst(IdentIndex);
  643.           Result := Data.Constants[IdentIndex].TypeID;
  644.         end;
  645.         ProcMask: begin                               // Procedure-function
  646.           if Data.Procedures[IdentIndex].TypeID = -1 then begin
  647.             SynError('ParseMultiplier', eMustBeFunction, 0);
  648.             Exit;
  649.           end;
  650.           ParseCall(IdentIndex);
  651.           Result := Data.Procedures[IdentIndex].TypeID;
  652.           LastExpConstant := False;                       // ToFix: Take in account compile-time computable functions
  653.         end;
  654.         ResWordMask: begin
  655.           SynError('ParseMultiplier', eUnexpectedResWord, 0); Exit;
  656.         end;
  657.         else begin
  658.           MessageDlg('Unknown identifier type', mtError, [mbOK], 0);
  659.           SynError('ParseMultiplier', eUndeclaredIdentifier, 0); Exit;
  660.         end;
  661.       end;
  662.     end else begin SynError('ParseMultiplier', eUndeclaredIdentifier, 0); Exit; end;
  663.   end else if (ch='''') or (ch='"') then begin
  664.     Scaner.GetString(ch);
  665.     Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  666. //    OldType := Result;
  667.     Result := SetSValue(Data.PINItems-2, Scaner.Buf);
  668. //    AddOperation(LastOp, OldType, Result);
  669.   end else if (ch='{') then Result := ParseSetConstructor else if (ch='(') then begin
  670.     Result := Expression;
  671.     Scaner.SkipDelims; Scaner.ReadChar(ch);
  672.     if ch <> ')' then SynError('ParseMultiplier', eRightParenthesisExpected, 0);
  673.   end;
  674. end;
  676. begin
  677. // Exp2 =  Mult { "*" | "/" | DIV | MOD | "&"  Mult }
  678.   Result := -1; OldType := -1;
  679.   LastOp := aoNull;
  680.   Result := ParseMultiplier;
  681.   if Result = -1 then Exit;
  682.   Scaner.SkipDelims;
  683.   while not Error and Scaner.ReadChar(ch) do begin
  684.     if (ch = ';') or (ch = ',') or (ch = ')') or (ch = '}') or (ch = ']') or Scaner.isRelation(ch) then begin Scaner.ReturnChar(ch); Break; end;
  685.     if Scaner.isOperation(ch) then Scaner.GetOperation(ch) else
  686.      if Scaner.isAlpha(ch) then Scaner.GetIdent(ch);
  687.     if (GetOp1 <> -1) or (CheckEnd(Scaner.Buf) <> -1) or (Scaner.Buf = RelationStr[6]) or (Scaner.Buf = RelationStr[7]) then begin
  688.       Scaner.ReturnBuf(Scaner.Buf);
  689.       Break;
  690.     end;
  691.     LastOp := GetOp2;
  692.     if LastOp = -1 then begin
  693.       SynError('Exp2', eOperationExpected, 0);
  694.     end else begin
  695.       OldType := Result;
  696.       Result := ParseMultiplier;
  697.       AddOperation(LastOp, OldType, Result);
  698.       Scaner.SkipDelims;
  699.     end;
  700.   end;
  701. end;
  703. function TCompiler.SimplifyExpression(Loc: Integer): Integer;
  704. var IP, i1, i2: Integer; r1, r2: Single;
  705. type TStackItem = Integer;
  706. const StackCapacityStep = 32;
  707. var
  708.   Stack: array of TStackItem;
  709.   TotalStack, StackCapacity: Integer;
  711. procedure Push(Item: TStackItem);
  712. begin
  713.   Inc(TotalStack);
  714.   if TotalStack > StackCapacity then begin
  715.     Inc(StackCapacity, StackCapacityStep); SetLength(Stack, StackCapacity);
  716.   end;
  717.   Stack[TotalStack-1] := Item;
  718. end;
  720. procedure PushS(Item: Single); 
  721. begin
  722.   Inc(TotalStack);
  723.   if TotalStack > StackCapacity then begin
  724.     Inc(StackCapacity, StackCapacityStep); SetLength(Stack, StackCapacity);
  725.   end;
  726.   Stack[TotalStack-1] := TStackItem((@Item)^);
  727. end;
  729. function Pop: TStackItem;
  730. begin
  731.   if TotalStack = 0 then Exit;
  732.   Result := Stack[TotalStack-1];
  733.   Dec(TotalStack);
  734. end;
  736. function PopS: Single;
  737. begin
  738.   if TotalStack = 0 then Exit;
  739.   Result := Single((@Stack[TotalStack-1])^);
  740.   Dec(TotalStack);
  741. end;
  743. // 2, 3, * 7, x, * 8 * + x, 2 * 3 * x * + 2, 4, * 1, 2, x, * + * + ( 2*3+7*x*8+x*2*3*x+2*4*(1+2*x) )
  744. // x, 2, 4, * x, 2, x * + * + ( x+2*4*(x+2*x) )
  745. begin
  746. end;
  748. function TCompiler.Expression: Integer;
  749. var i: Integer; ch: Char; LastOp, OldType: Integer;
  750. begin
  751. // Exp1 [rel Exp1]
  752.   LastExpConstant := True;
  753.   Result := -1; OldType := -1;
  754.   LastOp := aoNull;
  755.   Scaner.SkipDelims;
  756.   Result := Exp1;
  757.   if (Result = -1) then begin
  758.     if not Error then SynError('Expression', eUnexpectedExpEnd, Ord(ch));
  759.     Exit;
  760.   end;
  762.   Scaner.SkipDelims;
  763.   if not Scaner.ReadChar(ch) then Exit;
  764.   if Scaner.isRelation(ch) then Scaner.GetRelation(ch) else if Scaner.isAlpha(ch) then Scaner.GetIdent(ch) else begin
  765.     Scaner.ReturnChar(ch); Exit;
  766.   end;
  767.   for i := 0 to TotalRelations-1 do if Scaner.Buf = RelationStr[i] then begin
  768.     LastOp := RelationID[i];
  769.     Break;
  770.   end;
  771.   if LastOp = aoNull then begin Scaner.ReturnBuf(Scaner.Buf); Exit; end;
  773.   Scaner.SkipDelims;
  774.   OldType := Result;
  775.   Result := Exp1;
  776.   if (Result = -1) and not Error then begin SynError('Expression', eUnexpectedExpEnd, Ord(ch)); Exit; end;
  777.   AddOperation(LastOp, OldType, Result);
  778. end;
  780. function TCompiler.ConstantExpression(var ExpResult: Integer): Integer;
  781. // Parses expression, compute it and return result in ExpResult
  782. // Returns type of expression
  783. var i, ExpStartPIN: Integer;
  784. begin
  785.   ExpStartPIN := Data.PINItems;
  786.   Result := Expression;
  787.   if Error then Exit;
  788.   if not LastExpConstant then SynError('ConstantExpression', eConstExpExpected, 0);
  789.   ExpResult := ComputeExpression(ExpStartPIN);
  790.   Data.PINItems := ExpStartPIN;
  791. end;
  793. constructor TCompiler.Create(AScaner: TScaner);
  794. begin
  795.   Scaner := AScaner;
  796.   Data   := TRTData.Create;
  797.   Reset;
  798. end;
  800. procedure TCompiler.Reset;
  801. var i: Integer;
  802. begin
  803.   Data.EntryPIN := -1;
  804.   CError.Number := 0;
  805.   Scaner.Create(Scaner.Source);
  806. //  Constants := nil; Variables := nil; Procedures := nil;
  807.   Data.TotalConstants := 0; Data.TotalVariables := 0; Data.TotalProcedures := 0;
  808.   for i := 0 to Data.TotalTypes-1 do begin
  809.     ClearType(Data.Types[i]);
  810.     Dispose(Data.Types[i]);
  811.   end;
  812.   Data.TotalTypes := 0;
  813. //  Data.PIN := nil;
  814.   Data.PINItems := 0;
  815. //  if Assigned(Data) then FreeMem(Data);
  816. //  Data.DataLength := 0;
  817.   if Namespace <> nil then begin
  818.     ClearNamespace(Namespace);
  819.     Dispose(Namespace);
  820.   end;
  821.   Namespace := nil;
  822.   CurNamespace := nil;
  823.   TotalNamesSpaces := 0;
  825.   Data.DataLength := 0; SetLength(Data.Data, Data.DataLength);
  826.   Data.BaseData := nil;
  828.   ExternalVars := nil; Data.TotalExternalVariables := 0; 
  829. end;
  831. function TCompiler.GetOperator(Buf: string): Integer;
  832. var i: Integer;
  833. begin
  834.   Result := -1;
  835.   for i := 0 to TotalOperators-1 do if Buf = OperatorStr[i] then begin
  836.     Result := i; Exit;
  837.   end;
  838. end;
  840. procedure TCompiler.ParseAssign(IdentID, IdentOffset: Integer);
  841. var Op: Integer; ch: Char; AssignType, ExpType, IdentKind, VarLoc: Integer; RTOffs: Boolean;
  842. begin
  843.   IdentKind := VarMask;
  844.   if IdentID = -1 then begin
  845.     Scaner.SkipDelims;
  846.     Scaner.ReadChar(ch);
  847.     if Scaner.isAlpha(ch) then Scaner.GetIdent(ch) else begin SynError('ParseAssign', eVariableExpected, 0); Exit; end;
  848.     IdentID := CheckIdent(Scaner.Buf, CurNamespace, True, IdentKind);
  849.     if IdentID = -1 then begin SynError('ParseAssign', eUndeclaredIdentifier, 0); Exit; end;
  850.   end;
  852.   if (IdentKind and VarMask > 0) then begin                                // Variable
  853.     IdentOffset := Data.Variables[IdentID].Index;
  854.     AssignType := SpecifyVariable(Scaner.Buf, Data.Variables[IdentID].TypeID, IdentOffset, RTOffs);
  855.     VarLoc := Data.Variables[IdentID].Location;
  856.     if RTOffs then begin
  857. {      Inc(Data.PINItems);
  858.       if VarLoc = ilExternal then Inc(Data.PINItems);
  859.       SetLength(Data.PIN, Data.PINItems);
  860.       case VarLoc of
  861.         ilStack: Data.PIN[Data.PINItems-1] := dtStackVariableByOfs;
  862.         ilGlobal: Data.PIN[Data.PINItems-1] := dtVariableByOfs;
  863.         ilExternal: Data.PIN[Data.PINItems-2] := dtExtVariableByOfs;
  864.       end;
  865.       if VarLoc = ilExternal then Data.PIN[Data.PINItems-1] := VarOfs;}
  866.     end else begin
  867.       if (IdentID and ArrayMask = 0) then begin
  868.         Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  869.         Data.PIN[Data.PINItems-2] := dtVariableRef;
  870.         Data.PIN[Data.PINItems-1] := IdentOffset;
  871.       end;
  872.     end;
  873.     LastExpConstant := False;
  874.   end else begin
  875.     SynError('ParseAssign', eCannotAssign, 0); Exit;
  876.   end;
  878.   Scaner.SkipDelims;
  879.   Scaner.ReadChar(ch);
  880.   Scaner.GetOperator(ch);
  881.   if Scaner.Buf <> ':=' then begin
  882.     SynError('ParseAssign', eAssignationExpected, 0);
  883.     Exit;
  884.   end;
  885.   Op := oAssign;
  886.   ExpType := ControlTypes(Op, AssignType, Expression);
  887.   if Exptype = -1 then Exit;
  889.   if Data.Variables[IdentID and not AllMask].Location = ilStack then case Op of
  890.     aoAssign1, aoAssign2, aoAssign4: Op := aoStackAssign4;
  891.     aoAssignSize: Op := aoStackAssignSize;
  892.     aoAssign4RI: Op := aoStackAssign4RI;
  893.   end else if Data.Variables[IdentID and not AllMask].Location = ilExternal then case Op of
  894.     aoAssign1, aoAssign2, aoAssign4: Op := aoExtAssign4;
  895.     aoAssignSize: Op := aoExtAssignSize;
  896.     aoAssign4RI: Op := aoExtAssign4RI;
  897.   end;
  899.   Inc(Data.PINItems, 1); SetLength(Data.PIN, Data.PINItems);
  900.   Data.PIN[Data.PINItems-1] := Op;
  901. end;
  903. procedure TCompiler.ParseLoop(ReturnType: Integer);
  904. var ch: Char; BegIP, ExitPIN: Integer;
  905. begin
  906. // LOOP ops; END;
  907.   Inc(LoopCount);
  908.   Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  909.   Data.PIN[Data.PINItems-2] := dtInt; ExitPIN := Data.PINItems-1;
  911.   BegIP := Data.PINItems-1;
  913.   Operators(ReturnType);
  915.   if Error then Exit;
  916.   Scaner.SkipDelims;
  917.   Scaner.ReadChar(ch);
  918.   Scaner.GetIdent(ch);
  919.   if Scaner.Buf <> EndTokenStr[etEnd] then begin
  920.     SynError('OpLoop', eEndExpected, 0); Exit;
  921.   end;
  923.   Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  924.   Data.PIN[Data.PINItems-2] := aoGoto; Data.PIN[Data.PINItems-1] := BegIP;
  925.   if ExitPIN <> -1 then Data.PIN[ExitPIN] := Data.PINItems-1;
  926.   Dec(LoopCount);
  927. end;
  929. procedure TCompiler.ParseWhile(ReturnType: Integer);
  930. var ch: Char; BegIP, JumpPIN, ExitPIN: Integer;
  931. begin
  932. // WHILE Expr DO Ops; END
  933.   Inc(LoopCount);
  934.   Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  935.   Data.PIN[Data.PINItems-2] := dtInt; ExitPIN := Data.PINItems-1;
  937.   BegIP := Data.PINItems-1;
  939.   Scaner.SkipDelims;
  940.   if Expression <> dtBoolean then begin
  941.     SynError('OpWhile', eBooleanExpExpected, 0); Exit;
  942.   end;
  944.   Scaner.SkipDelims;
  945.   Scaner.ReadChar(ch);
  946.   Scaner.GetIdent(ch);
  947.   if Scaner.Buf <> EndTokenStr[etDo] then begin
  948.     SynError('OpWhile', eDoExpected, 0); Exit;
  949.   end;
  951.   Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  952.   Data.PIN[Data.PINItems-2] := aoJumpIfZero; JumpPIN := Data.PINItems-1;
  954.   if Operators(ReturnType) = -1 then begin
  955.   end;
  956.   if Error then Exit;
  958.   Scaner.SkipDelims;
  959.   Scaner.ReadChar(ch);
  960.   Scaner.GetIdent(ch);
  961.   if Scaner.Buf <> EndTokenStr[etEnd] then begin
  962.     SynError('OpWhile', eEndExpected, 0); Exit;
  963.   end;
  965.   Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  966.   Data.PIN[Data.PINItems-2] := aoGoto; Data.PIN[Data.PINItems-1] := BegIP;
  967.   Data.PIN[JumpPin] := Data.PINItems-1;
  968.   if ExitPIN <> -1 then Data.PIN[ExitPIN] := Data.PINItems-1;
  969.   Dec(LoopCount);
  970. end;
  972. procedure TCompiler.ParseRepeat(ReturnType: Integer);
  973. var ch: Char; BegIP, ExitPIN: Integer;
  974. begin
  975. // REPEAT ops; UNTIL Expr;
  976.   ExitPIN := -1;
  977.   BegIP := Data.PINItems-1;
  978.   if Operators(ReturnType) = -1 then begin
  979.     Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  980.     Data.PIN[Data.PINItems-2] := aoGoto; ExitPIN := Data.PINItems-1;
  981.   end;
  982.   if Error then Exit;
  984.   Scaner.SkipDelims;
  985.   Scaner.ReadChar(ch);
  986.   Scaner.GetIdent(ch);
  987.   if Scaner.Buf <> EndTokenStr[etUntil] then begin
  988.     SynError('OpRepeat', eUntilExpected, 0); Exit;
  989.   end;
  990.   Scaner.SkipDelims;
  991.   if Expression <> dtBoolean then begin
  992.     SynError('OpRepeat', eBooleanExpExpected, 0); Exit;
  993.   end;
  995.   Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  996.   Data.PIN[Data.PINItems-2] := aoJumpIfZero; Data.PIN[Data.PINItems-1] := BegIP;
  997.   if ExitPIN <> -1 then Data.PIN[ExitPIN] := Data.PINItems-1;
  998. end;
  1000. procedure TCompiler.ParseFor(ReturnType: Integer);
  1001. var ch: Char; BegIP, JumpPIN, ExitPIN, VarRef, VarOfs, IdentKind: Integer;
  1002. begin
  1003. // FOR Ident := Expr TO Expr [BY ConstExpr] DO Ops END
  1004.   ExitPIN := -1;
  1006.   Scaner.SkipDelims;
  1007.   Scaner.ReadChar(ch);
  1008.   if Scaner.isAlpha(ch) then Scaner.GetIdent(ch) else begin SynError('OpFor', eVariableExpected, 0); Exit; end;
  1009.   VarOfs := 0;
  1010.   VarRef := CheckIdent(Scaner.Buf, CurNamespace, True, IdentKind);
  1011.   if VarRef = -1 then begin SynError('OpAssign', eUndeclaredIdentifier, 0); Exit; end;
  1012.   if (IdentKind and VarMask = 0) then begin SynError('OpAssign', eCannotAssign, 0); Exit; end;
  1013.   ParseAssign(VarRef, VarOfs);
  1014.   Scaner.SkipDelims;
  1015.   Scaner.ReadChar(ch);
  1016.   Scaner.GetIdent(ch);
  1017.   if Scaner.Buf <> EndTokenStr[etTo] then begin
  1018.     SynError('OpFor', eToExpected, 0); Exit;
  1019.   end;
  1021.   BegIP := Data.PINItems-1;
  1023.   Expression;
  1024.   Scaner.SkipDelims;
  1025.   Scaner.ReadChar(ch);
  1026.   Scaner.GetIdent(ch);
  1027.   if Scaner.Buf <> EndTokenStr[etDo] then begin
  1028.     SynError('OpFor', eDoExpected, 0); Exit;
  1029.   end;
  1031.   Inc(Data.PINItems, 5); SetLength(Data.PIN, Data.PINItems);
  1032.   Data.PIN[Data.PINItems-5] := dtVariable; Data.PIN[Data.PINItems-4] := Data.Variables[VarRef].Index;
  1033.   Data.PIN[Data.PINItems-3] := arGreaterEqualII;  
  1034.   Data.PIN[Data.PINItems-2] := aoJumpIfZero; JumpPIN := Data.PINItems-1;
  1036.   if Operators(ReturnType) = -1 then begin
  1037.     Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  1038.     Data.PIN[Data.PINItems-2] := aoGoto; ExitPIN := Data.PINItems-1;
  1039.   end;
  1040.   if Error then Exit;
  1042.   Scaner.SkipDelims;
  1043.   Scaner.ReadChar(ch);
  1044.   if ch = ';' then begin
  1045.     while ch = ';' do Scaner.ReadChar(ch);
  1046.     Scaner.SkipDelims;
  1047.     Scaner.ReadChar(ch);
  1048.   end;
  1049.   Scaner.GetIdent(ch);
  1050.   if Scaner.Buf <> EndTokenStr[etEnd] then begin
  1051.     SynError('OpFor', eEndExpected, 0); Exit;
  1052.   end;
  1054.   Inc(Data.PINItems, 10); SetLength(Data.PIN, Data.PINItems);                         //ToFix: BY support
  1056.   Data.PIN[Data.PINItems-10] := dtVariableRef; Data.PIN[Data.PINItems-9] := Data.Variables[VarRef].Index;
  1057.   Data.PIN[Data.PINItems-8] := dtVariable; Data.PIN[Data.PINItems-7] := Data.Variables[VarRef].Index;
  1058.   Data.PIN[Data.PINItems-6] := dtInt; Data.PIN[Data.PINItems-5] := 1;
  1059.   Data.PIN[Data.PINItems-4] := aoAddII; Data.PIN[Data.PINItems-3] := aoAssign4;
  1061.   Data.PIN[Data.PINItems-2] := aoGoto; Data.PIN[Data.PINItems-1] := BegIP;
  1062.   Data.PIN[JumpPin] := Data.PINItems-1;
  1063.   if ExitPIN <> -1 then Data.PIN[ExitPIN] := Data.PINItems-1;
  1064. end;
  1066. procedure TCompiler.ParseIf(ReturnType: Integer);
  1067. var i, JumpPIN: Integer; ch: Char; ExitPINs: array of Integer; TotalExitPINs: Integer;
  1069. procedure ProcessIf;
  1070. begin
  1071.   if JumpPIN <> -1 then begin
  1072.     Inc(TotalExitPINs); SetLength(ExitPINs, TotalExitPINs);
  1073.     Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  1074.     Data.PIN[Data.PINItems-2] := aoGoto; ExitPINs[TotalExitPINs-1] := Data.PINItems-1;
  1075.   end;
  1077.   Scaner.SkipDelims;
  1078.   if Expression <> dtBoolean then begin
  1079.     SynError('ProcessIf', eBooleanExpExpected, 0); Exit;
  1080.   end;
  1082.   Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  1083.   Data.PIN[Data.PINItems-2] := aoJumpIfZero; JumpPIN := Data.PINItems-1;
  1085.   Scaner.SkipDelims;
  1086.   Scaner.ReadChar(ch);
  1087.   Scaner.GetIdent(ch);
  1088.   if Scaner.Buf <> EndTokenStr[etThen] then begin
  1089.     SynError('ProcessIf', eThenExpected, 0); Exit;
  1090.   end;
  1092.   if Operators(ReturnType) = -1 then SynError('ProcessIf', eUnexpectedBreak, 0);
  1093.   if Error then Exit;
  1095. {  Inc(TotalExitPINs); SetLength(ExitPINs, TotalExitPINs);
  1096.   Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  1097.   Data.PIN[Data.PINItems-2] := aoGoto; ExitPINs[TotalExitPINs-1] := Data.PINItems-1;}
  1099.   Data.PIN[JumpPIN] := Data.PINItems+1;
  1101.   Scaner.SkipDelims;
  1102.   Scaner.ReadChar(ch);
  1103.   Scaner.GetIdent(ch);
  1104.   if Scaner.Buf = EndTokenStr[etElseIf] then ProcessIf;
  1105. end;
  1107. begin
  1108. // IF expr THEN ops {ELSEIF expr THEN ops }[ELSE os ]END
  1109.   TotalExitPINs := 0; JumpPIN := -1;
  1110.   ProcessIf;
  1111.   if Error then Exit;
  1112.   if Scaner.Buf = EndTokenStr[etElse] then begin
  1113.     Inc(TotalExitPINs); SetLength(ExitPINs, TotalExitPINs);
  1114.     Inc(Data.PINItems, 2); SetLength(Data.PIN, Data.PINItems);
  1115.     Data.PIN[Data.PINItems-2] := aoGoto; ExitPINs[TotalExitPINs-1] := Data.PINItems-1;
  1116.     if Operators(ReturnType) = -1 then SynError('ParseIf', eUnexpectedBreak, 0);
  1117.     if not Error then begin
  1118.       Scaner.SkipDelims;
  1119.       Scaner.ReadChar(ch);
  1120.       Scaner.GetIdent(ch);
  1121.       if Scaner.Buf = EndTokenStr[etElseIf] then ProcessIf;
  1122. //      Inc(TotalExitPINs);
  1123.     end;
  1124.   end else Dec(Data.PIN[JumpPIN], 2);
  1125.   if not Error and (Scaner.Buf <> EndTokenStr[etEnd]) then SynError('ParseIf', eEndExpected, 0);
  1126.   if TotalExitPINs >= 1 then for i := 0 to TotalExitPINs-1 do Data.PIN[ExitPINs[i]] := Data.PINItems-1;
  1127.   SetLength(ExitPins, 0);
  1128. end;
  1130. procedure TCompiler.ParseCall(const ProcID: Integer);
  1131. var LastParameter: Boolean; CurPar, Op, ExpType: Integer; ch: Char;
  1132. begin
  1133. // Procname [([Arg] {, Arg} )];
  1134.   Scaner.SkipDelims; Scaner.ReadChar(ch);
  1135.   CurPar := 0;
  1136.   if ch = '(' then begin
  1137.     Scaner.SkipDelims; Scaner.ReadChar(ch);
  1138.     if ch <> ')' then begin
  1139.       Scaner.ReturnChar(ch);
  1140.       repeat
  1141.         if CurPar >= Data.Procedures[ProcID].Namespace.ParamCount then begin
  1142.           SynError('ParseCall', eTooManyParameters, 0);
  1143.           Exit;
  1144.         end;
  1145.         LastParameter := True;
  1147.         Op := oAssign;
  1148.         ExpType := Expression;
  1149.         if Error then Exit;
  1150.         if ControlTypes(Op, Data.Variables[Data.Procedures[ProcID].Namespace.Variables[Curpar]].TypeID, ExpType) = -1 then Exit;
  1151.         Scaner.SkipDelims; Scaner.ReadChar(ch);
  1152.         if ch = ',' then begin
  1153.           LastParameter := False;
  1154. //          Scaner.SkipDelims; Scaner.ReadChar(ch);
  1155.         end else if ch <> ')' then begin
  1156.           SynError('ParseCall', eRightParenthesisExpected, 0);
  1157.           Exit;
  1158.         end;
  1159.         Inc(CurPar);
  1160.       until LastParameter or Scaner.EOS;
  1161.     end;
  1162.   end else Scaner.ReturnChar(ch);                        // ToFix: return procedure reference in this case
  1164.   if CurPar <> Data.Procedures[ProcID].Namespace.ParamCount then begin
  1165.     SynError('ParseCall', eNotEnoughParameters, 0);
  1166.     Exit;
  1167.   end;
  1169.   if ProcID < TotalStandardProcedures then begin
  1170.     Inc(Data.PINItems, 1); SetLength(Data.PIN, Data.PINItems);
  1171.     Data.PIN[Data.PINItems-1] := Data.Procedures[ProcID].CommandID;
  1172.   end else begin
  1173.     Inc(Data.PINItems, 3); SetLength(Data.PIN, Data.PINItems);
  1174.     Data.PIN[Data.PINItems-3] := dtInt; Data.PIN[Data.PINItems-2] := Data.Procedures[ProcID].Index;
  1175.     Data.PIN[Data.PINItems-1] := aoCall;
  1176.   end;
  1177. end;
  1179. function TCompiler.Operators(ReturnType: Integer): Integer;
  1180. var i, Op, Operation, IdentID, IdentOfs, ExpType, ReturnOp, IdentKind: Integer; ch: Char;
  1181. begin
  1182.   Result := 0;
  1183.   Scaner.SkipDelims;
  1184.   while (not Error) and Scaner.ReadChar(ch) do begin
  1185.     if ch = ';' then begin Scaner.SkipDelims; Continue; end;
  1186.     if Scaner.isAlpha(ch) then begin
  1187.       Scaner.GetIdent(ch);
  1188.       Op := GetOperator(Scaner.Buf);
  1189.       if Op >= 0 then begin
  1190.         case Op of
  1191.           1: ParseLoop(ReturnType);
  1192.           2: ParseWhile(ReturnType);
  1193.           3: ParseRepeat(ReturnType);
  1194.           4: ParseFor(ReturnType);
  1195.           5: ParseIf(ReturnType);
  1196.           6: if LoopCount > 0 then begin                       // Exit operator
  1197.             Inc(Data.PINItems); SetLength(Data.PIN, Data.PINItems);
  1198.             Data.PIN[Data.PINItems-1] := aoExit;
  1199.           end else SynError('Operators', eUnexpectedBreak, 0);
  1200.           7: if ReturnType = rtModule then SynError('Operators', eUnexpectedReturn, 0) else begin
  1201.             Scaner.SkipDelims;
  1202.             if ReturnType <> rtProcedure then begin
  1203.               Operation := oAssign;
  1204.               ExpType := Expression;
  1205.               if Error then Exit;
  1206.               if ControlTypes(Operation, ReturnType, ExpType) = -1 then Exit;
  1207.               ReturnOp := aoReturnF;
  1208.             end else ReturnOp := aoReturnP;
  1209.             Inc(Data.PINItems, 3); SetLength(Data.PIN, Data.PINItems);
  1210.             Data.PIN[Data.PINItems-3] := ReturnOp;
  1211.             Data.PIN[Data.PINItems-2] := CurNamespace.ParamCount;          // Number of parameters
  1212.             Data.PIN[Data.PINItems-1] := CurNamespace.StackLength div 4;   // Size of all local data
  1213.           end;
  1214.         end;
  1215.       end else if CheckEnd(Scaner.Buf) <> -1 then begin
  1216.         Scaner.ReturnBuf(Scaner.Buf);
  1217.         Break;
  1218.       end else begin
  1219.         IdentID := CheckIdent(Scaner.Buf, CurNamespace, True, IdentKind);
  1220.         if (IdentID <> -1) then begin
  1221.           if (IdentKind and ProcMask > 0) then begin
  1222.             if Data.Procedures[IdentID and not AllMask].TypeID <> -1 then begin
  1223.               SynError('Operators', eMustBeProcedure, 0);
  1224.               Exit;
  1225.             end;
  1226.             ParseCall(IdentID);
  1227.           end else if (IdentKind and ResWordMask > 0) then begin
  1228.             SynError('Operators', eUnexpectedResWord, 0); Exit;
  1229.           end else if (IdentKind and VarMask > 0) then ParseAssign(IdentID, IdentOfs);
  1230.         end else begin
  1231.           SynError('Operators', eUndeclaredIdentifier, 0); Exit;
  1232.         end;
  1233.       end;
  1234.     end else begin Scaner.ReturnChar(ch); ParseAssign(-1, 0); end;               // ?
  1235.     Scaner.SkipDelims;
  1236.   end;
  1237. end;
  1239. function TCompiler.GetDeclaration(Buf: string): Integer;
  1240. var i: Integer;
  1241. begin
  1242.   Result := -1;
  1243.   for i := 0 to TotalDeclarations-1 do if Buf = DeclarationStr[i] then begin
  1244.     Result := i; Exit;
  1245.   end;
  1246. end;
  1248. {function TCompiler.GetTypeKind(TID: Integer): Integer;
  1249. begin
  1250.   Result := -1;
  1251.   if TID = -1 then Exit;
  1252.   if TID < TotalSTDTypes then Result := TypeKind[TID] else begin
  1253.     case Data.Types[TID].Kind of
  1254.       tkCommon: Result := GetTypeKind(Data.Types[TID].ID);
  1255.       tkArray: Result := dtArray;
  1256.       tkRecord: Result := dtRecord;
  1257.       tkPointer: Result := dtPointer;
  1258.       tkProcedure: Result := dtProcedure;
  1259.     end;
  1260.   end;
  1261. end;}
  1263. function TCompiler.GetType(Buf: string): Integer;
  1264. var i: Integer;
  1265. begin
  1266.   Result := -1;
  1267.   for i := 0 to Data.TotalTypes-1 do if Buf = Data.Types[i].Name then begin
  1268.     Result := i; Exit;
  1269.   end;
  1270. end;
  1272. function TCompiler.ParseTypeDef(TypeName: TName; AlwaysNew: Boolean): Integer;
  1273. // Returns type ID of existing or just created type
  1274. // TypeDef = Ident | ARRAY [n] OF Type | RECORD ... END | POINTER TO TYPE | ProcDef
  1275. var ch: Char; OldNS, NS: PNamespace; T: PType;
  1277.   function ParseArray: Integer;
  1278.   // Parses ARRAY [Len {, Len}] OF Type
  1279.   var
  1280.     Dims: array of Integer; TotalDims: Integer; ch: Char; TID: Integer;
  1281.     T: PType;
  1282.   begin
  1283.     T := AddType(TypeName);
  1284.     Result := Data.TotalTypes-1;
  1286.     TotalDims := 1; SetLength(Dims, TotalDims);
  1287.     if not isInteger(ConstantExpression(Dims[TotalDims-1])) then SynError('ParseArray', eIntExpExpected, 0);
  1288.     if Dims[TotalDims-1] < 0 then SynError('ParseArray', ePositiveIntExpExpected, 0);
  1289.     if Error then Exit;
  1290.     Scaner.SkipDelims;
  1291.     Scaner.ReadChar(ch);
  1292.     Scaner.GetIdent(ch);
  1293.     if Scaner.Buf <> 'OF' then begin
  1294.       SynError('ParseArray', eOfExpected, 0);
  1295.       Exit;
  1296.     end;
  1297.     TID := ParseTypeDef('$internal$', False);
  1298.     if TID = -1 then begin SynError('ParseArray', eUnknownType, TID); Exit; end;
  1300.     T.Kind := tkArray;
  1301.     T.Dimension := Dims[TotalDims-1];
  1302.     T.Size := T.Dimension * Data.Types[TID].Size;
  1303.     T.ID := TID;
  1304.   end;
  1306.   function ParseRecord: Integer;
  1307.   // Returns size of record
  1308.   // Parses: RECORD ["(" Base type ")"] Fields {";" [Fields]} END
  1309.   var ch: Char;
  1310.   begin
  1311.     T := AddType(TypeName);
  1312.     Result := Data.TotalTypes-1;
  1313.     NS := NewNamespace(TypeName);
  1314.     T.Namespace := NS;
  1315.     T.Kind := tkRecord;
  1316.     NS.Kind := nskRecord;
  1317.     if CurNamespace.Kind = nskRecord then NS.Parent := CurNamespace;
  1318.     OldNS := CurNamespace;
  1319.     CurNamespace := NS;
  1321.     T.Size := ParseVar;
  1322.     Scaner.SkipDelims;
  1323.     Scaner.ReadChar(ch);
  1324.     while (ch = ';') or Scaner.isDelim(ch) do Scaner.ReadChar(ch);
  1325.     Scaner.GetIdent(ch);
  1326.     if Scaner.Buf <> 'END' then SynError('ParseRecord', eEndExpected, 0);
  1328.     CurNamespace := OldNS;
  1329.   end;
  1331.   function ParsePointer: Integer;
  1332.   var ch: Char;
  1333.   // TO <array or record type>
  1334.   begin
  1335.     Scaner.SkipDelims;
  1336.     Scaner.ReadChar(ch);
  1337.     Scaner.GetIdent(ch);
  1338.   //  if Scaner.Buf
  1339.   end;
  1341.   function ParseProcType: Integer;
  1342.   begin
  1343.   end;
  1345. begin
  1346.   Scaner.SkipDelims;
  1347.   Scaner.ReadChar(ch);
  1348.   Scaner.GetIdent(ch);
  1349.   Result := GetType(Scaner.Buf);
  1350.   if Result <> -1 then begin
  1351.     if AlwaysNew then begin
  1352.       T := AddType(TypeName);
  1353.       T.Kind := tkCommon;
  1354.       T.ID := Result;
  1355.     end;
  1356.   end else if Scaner.Buf = 'ARRAY' then begin
  1357.     Result := ParseArray;
  1358.   end else if Scaner.Buf = 'RECORD' then begin
  1359.     Result := ParseRecord;
  1360.   end else if Scaner.Buf = 'POINTER' then ParsePointer
  1361.    else if Scaner.Buf = 'PROCEDURE' then ParseProcType
  1362.     else SynError('ParseTypeDef', eUnknownType, 0);
  1363. end;
  1365. procedure TCompiler.ParseType;
  1366. // TYPE {Ident = TypeDef}
  1367. // TypeDef = Ident | ARRAY [n] OF Type | RECORD ... END | POINTER TO TYPE | ProcDef
  1368. var
  1369.   TypeEnd: Boolean; ch: Char;
  1370.   i, Ident, IdentOfs, TID, IdentKind: Integer; TypeName: TName;
  1371. begin
  1372.   repeat
  1373.     TypeEnd := True;
  1375.     Scaner.SkipDelims;
  1376.     Scaner.ReadChar(ch);
  1377.     Scaner.GetIdent(ch);
  1378.     IdentOfs := 0;
  1379.     Ident := CheckIdent(Scaner.Buf, CurNamespace, False, IdentKind);
  1380.     if Ident <> -1 then begin
  1381.       SynError('ParseType', eIdentRedeclared, Ident);
  1382.       Break;
  1383.     end;
  1384.     TypeName := Scaner.Buf;
  1386.     Scaner.SkipDelims;
  1387.     Scaner.ReadChar(ch);
  1389.     if (ch <> '=') then SynError('ParseType', eEqualExpected, 0) else begin
  1390.       TID := ParseTypeDef(TypeName, True);
  1391.     end;
  1393.     AddIdent(ikType, TypeName, TID, 0);
  1395.     if Error then Exit;
  1397.     Scaner.SkipDelims;
  1398.     Scaner.ReadChar(ch);
  1399.     if ch <> ';' then SynError('ParseType', eSemicolonExpected, 0);
  1400.     while ch = ';' do Scaner.ReadChar(ch);
  1401.     Scaner.ReturnChar(ch);
  1403.     if not Error then begin
  1404.       Scaner.SkipDelims;
  1405.       Scaner.ReadChar(ch);
  1406.       if Scaner.isAlpha(ch) then begin
  1407.         Scaner.GetIdent(ch);
  1408.         if (Scaner.Buf <> 'BEGIN') and (Scaner.Buf <> 'END') and (GetDeclaration(Scaner.Buf) = -1) then TypeEnd := False;
  1409.         Scaner.ReturnBuf(Scaner.Buf);
  1410.       end else SynError('ParseType', eUnexpectedSimbol, Ord(ch));
  1411.     end;
  1412.   until TypeEnd or Scaner.EOS or Error;
  1413. end;
  1415. function TCompiler.ParseVarSection: Integer;
  1416. // Parses variable section and returns size of all declared variables
  1417. // ident1, ident2, ... : Type;
  1418. var ch: Char; ListEnd: Boolean;
  1419. var i, j, Ident, IdentOfs, OldTotalVars, NSOldTotalVars, VarCount, TID, IdentKind: Integer;
  1420. begin
  1421.   Result := 0;
  1422.   OldTotalVars := Data.TotalVariables;
  1423.   NSOldTotalVars := CurNamespace.TotalVariables;
  1424.   VarCount := 0;
  1425.   repeat
  1426.     ListEnd := True;
  1427.     Scaner.SkipDelims;
  1428.     Scaner.ReadChar(ch);
  1429.     Scaner.GetIdent(ch);
  1430.     IdentOfs := 0;
  1431.     Ident := CheckIdent(Scaner.Buf, CurNamespace, False, IdentKind);
  1432.     if Ident <> -1 then begin
  1433.       SynError('ParseVarSection', eIdentRedeclared, Ident);
  1434.       Break;
  1435.     end;
  1437.     AddIdent(ikVariable, Scaner.Buf, 0, 0);
  1439.     Scaner.SkipDelims;
  1440.     Scaner.ReadChar(ch);
  1441.     if ch = ',' then ListEnd := False;
  1442.     Inc(VarCount);
  1443.   until ListEnd or Scaner.EOS or Error;
  1445.   if not Error and (ch <> ':') then SynError('ParseVarSection', eColonExpected, 0);
  1446.   if not Error then begin
  1447.     TID := ParseTypeDef('$internal$', False);
  1448.     if TID = -1 then begin SynError('ParseVarSection', eUnknownType, TID); Exit; end;
  1449.   end;
  1451.   if Error then begin
  1452.     Data.TotalVariables := OldTotalVars;
  1453.     CurNamespace.TotalVariables := NSOldTotalVars;
  1454.     SetLength(Data.Variables, Data.TotalVariables);
  1455.     Exit;
  1456.   end;
  1458.   for i := OldTotalVars to OldTotalVars+VarCount-1 do begin
  1459.     Inc(Result, GetTypeSize(TID));
  1460.     if (CurNamespace.Kind = nskModule) or (CurNamespace.Kind = nskRecord) then begin
  1461.       if GetExternalVarIndex(Data.Variables[i].Name) <> -1 then
  1462.        Data.Variables[i].Index := AllocateData(0, 0) else begin
  1463.          Data.Variables[i].Index := AllocateData(GetTypeSize(TID), 0);
  1464.          SetVarLocation(Data.Variables[i], ilGlobal);
  1465.        end;
  1466.     end else begin
  1467.       Data.Variables[i].Index := AllocateStack(GetTypeSize(TID));
  1468.       SetVarLocation(Data.Variables[i], ilStack);
  1469.     end;
  1470.     Data.Variables[i].TypeID := TID;
  1471.   end;
  1472. end;
  1474. function TCompiler.ParseVar: Integer;
  1475. // Parses: {ident { , ident}: Type ;}
  1476. // Returns size of all declared variables
  1477. var VarEnd: Boolean; ch: Char;
  1478. begin
  1479.   Result := 0;
  1480.   repeat
  1481.     VarEnd := True;
  1483.     Inc(Result, ParseVarSection);
  1485.     if Error then Exit;
  1487.     Scaner.SkipDelims;
  1488.     Scaner.ReadChar(ch);
  1489.     if ch <> ';' then SynError('ParseVar', eSemicolonExpected, 0);
  1490.     while ch = ';' do Scaner.ReadChar(ch);
  1491.     Scaner.ReturnChar(ch);
  1493.     if not Error then begin
  1494.       Scaner.SkipDelims;
  1495.       Scaner.ReadChar(ch);
  1496.       if Scaner.isAlpha(ch) then begin
  1497.         Scaner.GetIdent(ch);
  1498.         if (Scaner.Buf <> 'BEGIN') and (Scaner.Buf <> 'END') and (GetDeclaration(Scaner.Buf) = -1) then VarEnd := False;
  1499.         Scaner.ReturnBuf(Scaner.Buf);
  1500.       end else SynError('ParseVar', eUnexpectedSimbol, Ord(ch));
  1501.     end;
  1502.   until VarEnd or Scaner.EOS or Error;
  1503. end;
  1505. procedure TCompiler.ParseConst;
  1506. var
  1507.   ConstEnd: Boolean; ch: Char;
  1508.   i, Ident, IdentOfs, TID, ExpStartPIN, ExpResult, IdentKind: Integer; ConstName: TName;
  1509. begin
  1510. // CONST {ident = Expression}
  1511.   repeat
  1512.     ConstEnd := True;
  1514.     Scaner.SkipDelims;
  1515.     Scaner.ReadChar(ch);
  1516.     Scaner.GetIdent(ch);
  1517.     IdentOfs := 0;
  1518.     Ident := CheckIdent(Scaner.Buf, CurNamespace, False, IdentKind);
  1519.     if Ident <> -1 then begin
  1520.       SynError('ParseConst', eIdentRedeclared, Ident);
  1521.       Break;
  1522.     end;
  1523.     ConstName := Scaner.Buf;
  1525.     Scaner.SkipDelims;
  1526.     Scaner.ReadChar(ch);
  1528.     if (ch = '=') then TID := ConstantExpression(ExpResult) else SynError('ParseConst', eEqualExpected, 0);
  1530.     if Error then Exit;
  1532.     AddIdent(ikConstant, ConstName, TID, ExpResult);
  1534.     Scaner.SkipDelims;
  1535.     Scaner.ReadChar(ch);
  1536.     if ch <> ';' then SynError('ParseConst', eSemicolonExpected, 0);
  1537.     while ch = ';' do Scaner.ReadChar(ch);
  1538.     Scaner.ReturnChar(ch);
  1540.     if not Error then begin
  1541.       Scaner.SkipDelims;
  1542.       Scaner.ReadChar(ch);
  1543.       if Scaner.isAlpha(ch) then begin
  1544.         Scaner.GetIdent(ch);
  1545.         if (Scaner.Buf <> 'BEGIN') and (Scaner.Buf <> 'END') and (GetDeclaration(Scaner.Buf) = -1) then ConstEnd := False;
  1546.         Scaner.ReturnBuf(Scaner.Buf);
  1547.       end else SynError('ParseConst', eUnexpectedSimbol, Ord(ch));
  1548.     end;
  1549.   until ConstEnd or Scaner.EOS or Error;
  1550. end;
  1552. procedure TCompiler.ParseProc;
  1553. var ch: Char; Ident, IdentOfs, FuncType, IdentKind: Integer; ProcName: string[128];
  1554. // PROCEDURE ident [ "(" [[var] Vars {";" [var] Vars}] ")" [":" Type] ] ";"
  1555. // Declarations BEGIN ops END ident
  1557. function ParseFormalPars: Integer;
  1558. // "(" [[var] Vars {";" [var] Vars}] ")" [":" Type]
  1559. var LastParameter: Boolean;
  1560. begin
  1561.   Result := rtProcedure;
  1562.   Scaner.SkipDelims; Scaner.ReadChar(ch);
  1563.   if ch = '(' then begin
  1564.     Scaner.SkipDelims; Scaner.ReadChar(ch);
  1565.     if ch <> ')' then repeat
  1566.       LastParameter := True;
  1567.       if not Scaner.isAlpha(ch) then begin
  1568.         SynError('ParseFormalPars', eUnexpectedSimbol, 0);
  1569.         Exit;
  1570.       end;
  1571.       Scaner.GetIdent(ch);
  1572.       if Scaner.Buf = 'VAR' then  else Scaner.ReturnBuf(Scaner.Buf);
  1573.       ParseVarSection;
  1574.       Scaner.SkipDelims; Scaner.ReadChar(ch);
  1575.       if ch = ';' then begin
  1576.         LastParameter := False;
  1577.         Scaner.SkipDelims; Scaner.ReadChar(ch);
  1578.       end;
  1579.     until LastParameter;
  1580.   end else Scaner.ReturnChar(ch);
  1581.   Scaner.SkipDelims; Scaner.ReadChar(ch);
  1582.   if ch = ':' then begin
  1583.     Result := ParseTypeDef('$internal$', False);
  1584.     if Result = -1 then SynError('ParseFormalPars', eUnknownType, Result);
  1585.   end else Scaner.ReturnChar(ch);
  1586. end;
  1588. begin
  1589. // Procedure header
  1590.   Scaner.SkipDelims;
  1591.   Scaner.ReadChar(ch);
  1592.   Scaner.GetIdent(ch);
  1593.   IdentOfs := 0;
  1594.   Ident := CheckIdent(Scaner.Buf, CurNamespace, False, IdentKind);
  1595.   if Ident <> -1 then begin
  1596.     SynError('ParseProc', eIdentRedeclared, Ident);
  1597.     Exit;
  1598.   end;
  1599.   ProcName := Scaner.Buf;
  1600.   AddNameSpace(ProcName);
  1601.   CurNamespace.Kind := nskProcedure;
  1603.   CurNamespace.Parent.Procedures[CurNamespace.Parent.TotalProcedures-1].ID := Data.TotalProcedures;
  1605.   AddIdent(ikProcedure, ProcName, 0, Data.PINItems);                   // Procedure identifier
  1607.   FuncType := ParseFormalPars;                                    // Procedure result type
  1608.   Data.Procedures[Data.TotalProcedures-1].TypeID := FuncType;
  1609.   CurNamespace.ParamCount := CurNamespace.TotalVariables;              // Parameters count
  1610.   if Error then Exit;
  1611.   Scaner.SkipDelims; Scaner.ReadChar(ch);
  1612.   if ch <> ';' then begin SynError('ParseProc', eSemicolonExpected, 0); Exit; end;
  1613. // Procedure body
  1614.   Inc(CurNamespace.StackLength, 2*SizeOf(TStackItem));
  1615.   CompileBlock(FuncType); if Error then Exit;
  1617.   if (FuncType = rtProcedure) and (Data.PINItems >= 3) and (Data.PIN[Data.PINItems-3] <> aoReturnP) then begin
  1618.     Inc(Data.PINItems, 3); SetLength(Data.PIN, Data.PINItems);
  1619.     Data.PIN[Data.PINItems-3] := aoReturnP;
  1620.     Data.PIN[Data.PINItems-2] := CurNamespace.ParamCount;           // Number of parameters
  1621.     Data.PIN[Data.PINItems-1] := CurNamespace.StackLength div 4;    // Length of all local data
  1622.   end else
  1623.    if (Data.PINItems >= 3) and (Data.PIN[Data.PINItems-3] <> aoReturnF) and (FuncType <> -1) then Synerror('ParseProc', eReturnExpected, 0);
  1625.   Scaner.SkipDelims; Scaner.ReadChar(ch); Scaner.GetIdent(ch);
  1626.   if Scaner.Buf <> ProcName then SynError('ParseProc', eProcNameMismatch, 0);
  1628. //  Inc(CurNamespace.Parent.StackLength, CurNamespace.StackLength);
  1629.   CurNamespace := CurNamespace.Parent;
  1630. end;
  1632. function TCompiler.Declarations: Integer;
  1633. var i, D: Integer; ch: Char;
  1634. begin
  1635. // { CONST {吾