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

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

游戏引擎

开发平台：

Delphi

ORun.pas：源码内容
  1. (*
  2.  Oberon virtual machine 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 VM class
  6. *)
  7. {$DEFINE DEBUG}
  8. unit ORun;
  10. interface
  12. uses
  13.   SysUtils,
  14. {$IFDEF DEBUG} Dialogs, Classes, {$ENDIF}
  15.   OTypes, OScan, OBasics;
  17. {$IFDEF DEBUG} var Debug: string; DItems: TStringList; {$ENDIF}
  19. type
  20.   TBinModuleSign = array[0..3] of Char;
  22.   TStackItem = Integer;
  24.   TOberonVM = class
  25.     Data: TRTData;
  26.     TotalStack, StackCapacity, StackCapacityStep, StackBase: Integer;
  27.     Stack: array of TStackItem;                                  // Stack
  28. //    Comp: TCompiler;
  29. // Implementation specific
  30.     MaxSet: Integer;
  31.     El2Set: array of Longword;                                   // For set optimisation
  32.     constructor Create;
  33.     destructor Destroy; override;
  34. {$IFDEF DEBUG}
  35.     function ItemToStr(Index: Integer): string;   // Converts PIN item to string in debug purposes
  36.     function GetVar(const Location, Offset, Index: Integer): Integer;
  37. {$ENDIF}
  38.     function Save(const Stream: TDStream): Integer;
  39.     function Load(const Stream: TDStream): Integer;
  40.     function SetExtVarAddr(const VarIndex: Integer; const Addr: Pointer): Boolean;
  41.     procedure Run;
  42.     function Compute: TStackItem;
  43.   private
  44.     procedure ExpandStack(const Amount: Integer);
  45.     procedure Push(Item: TStackItem);
  46.     procedure PushS(Item: Single);
  47.     function Pop: TStackItem;
  48.     function PopS: Single;
  49.     procedure RunTimeError(ErrorNumber: Integer);
  51.     function AddII(Value1, Value2: Integer): Integer;
  52.     function AddRR(Value1, Value2: Single): Single;
  53.     function AddIR(Value1: Integer; Value2: Single): Single;
  54.     function AddRI(Value1: Single; Value2: Integer): Single;
  55.     function AddSS(Value1, Value2: Integer): Integer;
  56.     function AddStrStr(Value1, Value2: Integer): Integer;
  57.     function SubII(Value1, Value2: Integer): Integer;
  58.     function SubRR(Value1, Value2: Single): Single;
  59.     function SubIR(Value1: Integer; Value2: Single): Single;
  60.     function SubRI(Value1: Single; Value2: Integer): Single;
  61.     function SubSS(Value1, Value2: Integer): Integer;
  62.     function MulII(Value1, Value2: Integer): Integer;
  63.     function MulRR(Value1, Value2: Single): Single;
  64.     function MulIR(Value1: Integer; Value2: Single): Single;
  65.     function MulRI(Value1: Single; Value2: Integer): Single;
  66.     function MulSS(Value1, Value2: Integer): Integer;
  67.     function DivII(Value1, Value2: Integer): Single;
  68.     function DivRR(Value1, Value2: Single): Single;
  69.     function DivIR(Value1: Integer; Value2: Single): Single;
  70.     function DivRI(Value1: Single; Value2: Integer): Single;
  71.     function DivSS(Value1, Value2: Integer): Integer;
  72.     function OrII(Value1, Value2: Integer): Integer;
  73.     function AndII(Value1, Value2: Integer): Integer;
  74.     function IDivII(Value1, Value2: Integer): Integer;
  75.     function ModII(Value1, Value2: Integer): Integer;
  76.     function NegI(Value1: Integer): Integer;
  77.     function NegR(Value1: Single): Single;
  78.     function NegS(Value1: Integer): Integer;
  79.     function InvI(Value1: Integer): Integer;
  80.     function InvB(Value1: Integer): Integer;
  81.     function Equal(Value1, Value2: Integer): Integer;
  82.     function EqualRI(Value1: Single; Value2: Integer): Integer;
  83.     function GreaterII(Value1, Value2: Integer): Integer;
  84.     function GreaterIR(Value1: Integer; Value2: Single): Integer;
  85.     function GreaterRI(Value1: Single; Value2: Integer): Integer;
  86.     function GreaterRR(Value1, Value2: Single): Integer;
  87.     function LessII(Value1, Value2: Integer): Integer;
  88.     function LessIR(Value1: Integer; Value2: Single): Integer;
  89.     function LessRI(Value1: Single; Value2: Integer): Integer;
  90.     function LessRR(Value1, Value2: Single): Integer;
  91.     function GreaterEqualII(Value1, Value2: Integer): Integer;
  92.     function GreaterEqualIR(Value1: Integer; Value2: Single): Integer;
  93.     function GreaterEqualRI(Value1: Single; Value2: Integer): Integer;
  94.     function GreaterEqualRR(Value1, Value2: Single): Integer;
  95.     function LessEqualII(Value1, Value2: Integer): Integer;
  96.     function LessEqualIR(Value1: Integer; Value2: Single): Integer;
  97.     function LessEqualRI(Value1: Single; Value2: Integer): Integer;
  98.     function LessEqualRR(Value1, Value2: Single): Integer;
  99.     function NotEqual(Value1, Value2: Integer): Integer;
  100.     function NotEqualRI(Value1: Single; Value2: Integer): Integer;
  101.     function GreaterEqual(Value1, Value2: Integer): Integer;
  102.     function LessEqual(Value1, Value2: Integer): Integer;
  103.     function TestIn(Value1, Value2: Integer): Integer;
  104.     procedure DoAssign4(Value1, Value2: Integer);
  105.     procedure DoStackAssign4(Value1, Value2: Integer);
  106.     procedure DoGoto(var IP: Integer);
  107.     procedure DoZeroJump(Value1: Integer; var IP: Integer);
  108.     procedure DoCall(const Dest: Integer; var IP: Integer);
  109.     procedure DoReturn(var IP: Integer);
  110.     procedure DoExit(const Dest: Integer; var IP: Integer);
  111.     function ConstructSet(const TotalElements: Integer): Integer;
  112. // For scripting support
  113.     procedure DoExtAssign4(Value1, Value2: Integer);
  114.   end;
  116. const
  117.  BinModuleSign: TBinModuleSign = ('O', '2', 'B', 'M');
  119. implementation
  121. {$IFDEF DEBUG}
  122. function TOberonVM.ItemToStr(Index: Integer): string;
  123. var j: Integer; Len: Nat16; First: Boolean;
  125.   function GetVarName(NS: PNamespace; Ofs: Integer): string;
  126.   var i, ind, Bound: Integer;
  127.   begin
  128.     Result := 'Unknown';
  129.     for i := 0 to NS.TotalVariables-1 do begin
  130.       Bound := Data.Variables[NS.Variables[i]].Index + Data.Types[Data.Variables[NS.Variables[i]].TypeID].Size;
  131.       if Bound > Ofs then begin
  132.         ind := i;
  133.   {    if Data.Variables[NS.Variables[i]].Index >= Ofs then begin
  134.         if (Data.Variables[NS.Variables[i]].Index > Ofs) then begin
  135.           ind := i-1;
  136.           if ind < 0 then Exit;
  137.         end else ind := i;}
  138.         if Data.Types[Data.Variables[NS.Variables[ind]].TypeID].Kind = tkRecord then
  139.          Result := Data.Variables[NS.Variables[ind]].Name+'.'+GetVarName(Data.Types[Data.Variables[NS.Variables[ind]].TypeID].Namespace,
  140.                               Ofs-Data.Variables[NS.Variables[ind]].Index) else
  141.           Result := Data.Variables[NS.Variables[ind]].Name;
  142.         Exit;
  143.       end;
  144.     end;
  145.   {  ind := NS.TotalVariables-1;
  146.     Result := Data.Variables[NS.Variables[ind]].Name+'.'+GetVarName(Data.Types[Data.Variables[NS.Variables[ind]].TypeID].Namespace,
  147.                               Ofs-Data.Variables[NS.Variables[ind]].Index);}
  148.   end;
  150.   function GetGlobalVarName(Ofs: Integer): string;
  151.   begin
  152.     Result := GetVarName(Data.Namespace, Ofs);
  153.   end;
  155. begin
  156. //  Result := '';
  157.   case Data.PIN[Index] and $FFFF of
  158.     dtBoolean: if Boolean((@Data.PIN[Index+1])^) then Result := 'True' else Result := 'False';
  159.     dtChar: Result := Char((@Data.PIN[Index+1])^);
  160.     dtInt8, dtInt16, dtInt32, dtInt, dtNat8, dtNat16, dtNat32, dtNat: Result := IntToStr(Data.PIN[Index+1])+',';
  161.     dtSingle, dtDouble, dtReal: Result := FloatToStr(Single((@Data.PIN[Index+1])^));
  162.     dtString: begin
  163.       Move(Pointer(Int32(Data.Data)+Data.PIN[Index+1])^, Len, 2);
  164.       SetLength(Result, Len);
  165.       if Len > 0 then Move(Pointer(Int32(Data.Data)+Data.PIN[Index+1]+2)^, Result[1], Len);
  166.     end;
  167.     dtSet: Result := 'SET of ' + IntToStr(Longword(Data.PIN[Index] shr 16)) + ' elements';
  168.     aoNull: Result := ' Null ';
  169.     aoAddII: Result := ' +(ii) ';
  170.     aoAddIR: Result := ' +(ir) ';
  171.     aoAddRI: Result := ' +(ri) ';
  172.     aoAddRR: Result := ' +(rr) ';
  173.     aoAddSS: Result := ' +(ss) ';
  174.     aoSubII: Result := ' -(ii) ';
  175.     aoSubIR: Result := ' -(ir) ';
  176.     aoSubRI: Result := ' -(ri) ';
  177.     aoSubRR: Result := ' -(rr) ';
  178.     aoSubSS: Result := ' -(ss) ';
  179.     aoMulII: Result := ' *(ii) ';
  180.     aoMulIR: Result := ' *(ir) ';
  181.     aoMulRI: Result := ' *(ri) ';
  182.     aoMulRR: Result := ' *(rr) ';
  183.     aoMulSS: Result := ' *(ss) ';
  184.     aoDivII: Result := ' /(ii) ';
  185.     aoDivIR: Result := ' /(ir) ';
  186.     aoDivRI: Result := ' /(ri) ';
  187.     aoDivRR: Result := ' /(rr) ';
  188.     aoDivSS: Result := ' /(ss) ';
  189.     aoOrII: Result := ' OR(ii) ';
  190.     aoOrBB: Result := ' OR(bb) ';
  191.     aoAndII: Result := ' &(ii) ';
  192.     aoAndBB: Result := ' &(bb) ';
  193.     aoIDivII: Result := ' DIV(ii) ';
  194.     aoModII: Result := ' MOD(ii) ';
  195.     aoNegI: Result := ' Neg(i) ';
  196.     aoNegR: Result := ' Neg(r) ';
  197.     aoNegS: Result := ' Neg(s) ';
  198.     aoInvI: Result := ' ~(i) ';
  199.     aoInvB: Result := ' ~(b) ';
  200.     arEqualII: Result := ' =(ii) ';
  201.     arEqualIR: Result := ' =(ir) ';
  202.     arEqualRI: Result := ' =(ri) ';
  203.     arEqualRR: Result := ' =(rr) ';
  204.     arGreaterII: Result := ' >(ii) ';
  205.     arGreaterIR: Result := ' >(ir) ';
  206.     arGreaterRI: Result := ' >(ri) ';
  207.     arGreaterRR: Result := ' >(rr) ';
  208.     arLessII: Result := ' <(ii) ';
  209.     arLessIR: Result := ' <(ir) ';
  210.     arLessRI: Result := ' <(ri) ';
  211.     arLessRR: Result := ' <(rr) ';
  212.     arGreaterEqualII: Result := ' >=(ii) ';
  213.     arGreaterEqualIR: Result := ' >=(ir) ';
  214.     arGreaterEqualRI: Result := ' >=(ri) ';
  215.     arGreaterEqualRR: Result := ' >=(rr) ';
  216.     arLessEqualII: Result := ' <=(ii) ';
  217.     arLessEqualIR: Result := ' <=(ir) ';
  218.     arLessEqualRI: Result := ' <=(ri) ';
  219.     arLessEqualRR: Result := ' <=(rr) ';
  220.     arNotEqualII: Result := ' #(ii) ';
  221.     arNotEqualIR: Result := ' #(ir) ';
  222.     arNotEqualRI: Result := ' #(ri) ';
  223.     arNotEqualRR: Result := ' #(rr) ';
  224.     aoAssign1: Result := ' :=[1b] ';
  225.     aoAssign2: Result := ' :=[2b] ';
  226.     aoAssign4: Result := ' :=[4b] ';
  227.     aoAssign4RI: Result := ' :=[r4b] ';
  228.     aoAssignSize: Result := ' :=[?b] ';
  229.     aoStackAssign4: Result := ' [s]:= ';
  230.     aoStackAssign4RI: Result := ' [s]:=[r] ';
  231.     aoStackAssignSize: Result := ' [s]:=[?b] ';
  232.     aoGoto: Result := ' Goto ';
  233.     aoJumpIfZero: Result := ' JumpIfZero ';
  234.     aoCall: Result := ' Call ';
  235.     aoReturnF: Result := ' Function return ';
  236.     aoReturnP: Result := ' Procedure return ';
  237.     dtVariable, dtVariableRef: Result := GetGlobalVarName(Data.PIN[Index+1]) + ' [' + IntToStr(Data.PIN[Index+1]) + ']';
  238.     dtVariableByOfs: Result := 'ARR: '+GetGlobalVarName(Data.PIN[Index+1]) + ' [' + IntToStr(Data.PIN[Index+1]) + ']';
  239.     dtStackVariable: Result := 'Local variable';//Data.Variables[Data.PIN[Index+1]].Name+'[s],';
  240.     dtStackVariableByOfs: Result := 'Local array';//Data.Variables[Data.PIN[Index+1]].Name+'[s],';
  241.     aoSetStackBase: Result := 'Set stack base (- ' + IntToStr(Data.PIN[Index+1])+' parameters)';
  242.     aoExpandStack: Result := 'Expand stack by ' + IntToStr(Data.PIN[Index+1]);
  243.   end;
  244. end;
  246. function TOberonVM.GetVar(const Location, Offset, Index: Integer): Integer;
  247. begin
  248.   case Data.Types[Data.Variables[Index].TypeID].Size of
  249.     1: Result := Data.BaseData[Data.Variables[Index].Index+Offset + Integer(Data.Data)];
  250.     2: Result := Word((@Data.BaseData[Data.Variables[Index].Index+Offset + Integer(Data.Data)])^);
  251.     4: case Location of
  252.       ilGlobal: Result := Int32((@Data.BaseData[Data.Variables[Index].Index+Offset + Integer(Data.Data)])^);
  253.       ilExternal: Result := Int32((@Data.BaseData[Data.Variables[Index].Index+Offset])^);
  254.     end;
  255.   end;
  256. end;
  257. {$ENDIF}
  259. procedure TOberonVM.ExpandStack(const Amount: Integer);
  260. begin
  261.   Inc(TotalStack, Amount);
  262.   if TotalStack > StackCapacity then begin
  263.     Inc(StackCapacity, StackCapacityStep); SetLength(Stack, StackCapacity);
  264.   end;
  265. end;
  267. procedure TOberonVM.Push(Item: TStackItem);
  268. begin
  269.   ExpandStack(1);
  270.   Stack[TotalStack-1] := Item;
  271. end;
  273. procedure TOberonVM.PushS(Item: Single);
  274. begin
  275.   ExpandStack(1);
  276.   Stack[TotalStack-1] := TStackItem((@Item)^);
  277. end;
  279. function TOberonVM.Pop: TStackItem;
  280. begin
  281.   if TotalStack = 0 then begin
  282.     RunTimeError(rteStackEmpty); Exit; 
  283.   end;
  284.   Result := Stack[TotalStack-1];
  285.   Dec(TotalStack);
  286. end;
  288. function TOberonVM.PopS: Single;
  289. begin
  290.   if TotalStack = 0 then Exit;
  291.   Result := Single((@Stack[TotalStack-1])^);
  292.   Dec(TotalStack);
  293. end;
  295. function TOberonVM.Save(const Stream: TDStream): Integer;
  296. const InvalidUID: Integer = -1;
  298.   function SaveNamespace(NS: PNamespace): Integer;
  299.   var i: Integer;
  300.   begin
  301.     Result :=  feCannotWrite;
  302.     if Stream.Write(NS.Name, SizeOf(NS.Name)) <> feOK then Exit;
  303.     if Stream.Write(NS.UID, SizeOf(NS.UID)) <> feOK then Exit;
  304.     if Stream.Write(NS.Kind, SizeOf(NS.Kind)) <> feOK then Exit;
  305.     if Stream.Write(NS.ParamCount, SizeOf(NS.ParamCount)) <> feOK then Exit;
  306.     if Stream.Write(NS.ID, SizeOf(NS.ID)) <> feOK then Exit;
  307.     if Stream.Write(NS.StackLength, SizeOf(NS.StackLength)) <> feOK then Exit;
  308.     if Stream.Write(NS.TotalConstants, SizeOf(NS.TotalConstants)) <> feOK then Exit;
  309.     if NS.TotalConstants > 0 then if Stream.Write(NS.Constants[0], SizeOf(Longword)*NS.TotalConstants) <> feOK then Exit;
  310.     if Stream.Write(NS.TotalVariables, SizeOf(NS.TotalVariables)) <> feOK then Exit;
  311.     if NS.TotalVariables > 0 then if Stream.Write(NS.Variables[0], SizeOf(Longword)*NS.TotalVariables) <> feOK then Exit;
  312.     if Stream.Write(NS.TotalTypes, SizeOf(NS.TotalTypes)) <> feOK then Exit;
  313.     if NS.TotalTypes > 0 then if Stream.Write(NS.Types[0], SizeOf(Longword)*NS.TotalTypes) <> feOK then Exit;
  314.     if Stream.Write(NS.TotalProcedures, SizeOf(NS.TotalProcedures)) <> feOK then Exit;
  315.     for i := 0 to NS.TotalProcedures-1 do if SaveNamespace(NS.Procedures[i]) <> feOK then Exit;
  316.     if NS.Parent <> nil then begin
  317.       if Stream.Write(NS.Parent.ID, SizeOf(NS.Parent.ID)) <> feOK then Exit;
  318.     end else begin
  319.       if Stream.Write(InvalidUID, SizeOf(InvalidUID)) <> feOK then Exit;
  320.     end;
  321.     Result := feOK;
  322.   end;
  324. var i, Ind: Integer;
  325. begin
  326.   Result := feCannotWrite;
  327.   if Stream.Write(BinModuleSign, SizeOf(TBinModuleSign)) <> feOK then Exit;
  328.   if Stream.Write(Data.EntryPIN, SizeOf(Data.EntryPIN)) <> feOK then Exit;
  329.   if Stream.Write(Data.PINItems, SizeOf(Data.PINItems)) <> feOK then Exit;
  330.   if Stream.Write(Data.PIN[0], SizeOf(TPINItem)*Data.PINItems) <> feOK then Exit;
  331.   if Stream.Write(Data.TotalExternalVariables, SizeOf(Data.TotalExternalVariables)) <> feOK then Exit;
  332.   if Stream.Write(Data.ExternalVarsOfs, SizeOf(Data.ExternalVarsOfs)) <> feOK then Exit;
  334.   if SaveNamespace(Data.Namespace) <> feOK then Exit;
  336.   if Stream.Write(Data.BaseData, SizeOf(Data.BaseData)) <> feOK then Exit;
  337.   if Stream.Write(Data.DataLength, SizeOf(Data.DataLength)) <> feOK then Exit;
  338.   if Data.DataLength > 0 then
  339.    if Stream.Write(Data.Data[0], Data.DataLength * SizeOf(Data.Data[0])) <> feOK then Exit;
  341.   if Stream.Write(Data.TotalTypes, SizeOf(Data.TotalTypes)) <> feOK then Exit;
  342.   for i := 0 to Data.TotalTypes-1 do begin
  343.     if Stream.Write(Data.Types[i]^, SizeOf(Data.Types[i]^)-SizeOf(Data.Types[i].Namespace)) <> feOK then Exit;
  344.     if Data.Types[i].Namespace <> nil then begin
  345.       if Stream.Write(Data.Types[i].Namespace.UID, SizeOf(Data.Types[i].Namespace.UID)) <> feOK then Exit;
  346.       if SaveNamespace(Data.Types[i].Namespace) <> feOK then Exit;
  347.     end else begin
  348.       if Stream.Write(InvalidUID, SizeOf(InvalidUID)) <> feOK then Exit;
  349.     end;
  350.   end;
  352.   if Stream.Write(Data.TotalProcedures, SizeOf(Data.TotalProcedures)) <> feOK then Exit;
  353.   for i := 0 to Data.TotalProcedures-1 do begin
  354.     if Stream.Write(Data.Procedures[i], SizeOf(Data.Procedures[i])-SizeOf(Data.Procedures[i].Namespace)) <> feOK then Exit;
  355.     if Stream.Write(Data.Procedures[i].Namespace.UID, SizeOf(Data.Procedures[i].Namespace.UID)) <> feOK then Exit;
  356.   end;
  358.   if Stream.Write(Data.TotalVariables, SizeOf(Data.TotalVariables)) <> feOK then Exit;
  359.   for i := 0 to Data.TotalVariables-1 do begin
  360.     if Stream.Write(Data.Variables[i], SizeOf(Data.Variables[i])-SizeOf(Data.Variables[i].Namespace){-SizeOf(Data.Variables[i].Index)}) <> feOK then Exit;
  361. {    if (Data.Variables[i].Location = ilGlobal) and (Data.Variables[i].Namespace.Parent = nil) then
  362.      Ind := Data.Variables[i].Index - Integer(Data.Data) else
  363.       Ind := Data.Variables[i].Index;
  364.     if Stream.Write(Ind, SizeOf(Ind)) <> feOK then Exit;}
  365.     if Stream.Write(Data.Variables[i].Namespace.UID, SizeOf(Data.Variables[i].Namespace.UID)) <> feOK then Exit;
  366.   end;
  368.   if Stream.Write(Data.TotalConstants, SizeOf(Data.TotalConstants)) <> feOK then Exit;
  369.   for i := 0 to Data.TotalConstants-1 do begin
  370.     if Stream.Write(Data.Constants[i], SizeOf(Data.Constants[i])-SizeOf(Data.Constants[i].Namespace){-SizeOf(Data.Constants[i].Index)}) <> feOK then Exit;
  371. //    Ind := Data.Constants[i].Index - Integer(Data.Data);
  372. //    if Stream.Write(Ind, SizeOf(Ind)) <> feOK then Exit;
  373.     if Stream.Write(Data.Constants[i].Namespace.UID, SizeOf(Data.Constants[i].Namespace.UID)) <> feOK then Exit;
  374.   end;
  376.   Result := feOK;
  377. end;
  379. function TOberonVM.Load(const Stream: TDStream): Integer;
  381. function GetNamespace(ID: Integer): PNamespace;
  383. function SearchID(FirstNS: PNamespace; ID: Integer): PNamespace;
  384. var i: Integer;
  385. begin
  386.   Result := nil;
  387.   if (ID < 0) or (FirstNS = nil) then Exit;
  388.   if FirstNS.UID = ID then begin
  389.     Result := FirstNS; Exit;
  390.   end;
  391.   for i := 0 to FirstNS.TotalProcedures-1 do begin
  392.     Result := SearchID(FirstNS.Procedures[i], ID);
  393.     if Result <> nil then Exit;
  394.   end;
  395. end;
  397. var i: Integer;
  398. begin
  399.   for i := 0 to Data.TotalTypes-1 do begin
  400.     Result := SearchID(Data.Types[i].Namespace, ID);
  401.     if Result <> nil then Exit;
  402.   end;
  403.   Result := SearchID(Data.Namespace, ID);
  404. end;
  406. function LoadNamespace(var NS: PNamespace): Integer;
  407. var i, ID: Integer;
  408. begin
  409.   Result :=  feCannotRead;
  410. {  UID: Integer;
  411.   Name: TName;
  412.   Kind: Int32;                     // Procedure or record
  413.   ParamCount: Int32;
  414.   ID: Int32;                       // Index in Data.Procedures
  415.   StackLength: Int32;              // Length of variables declared local and in child namespaces
  416.   TotalConstants, TotalVariables, TotalProcedures, TotalTypes: Int32;
  417.   Constants, Variables, Types: array of Longword;
  418.   Procedures: array of PNameSpace;
  419.   Parent: PNamespace;}
  420.   New(NS);
  421.   if Stream.Read(NS.Name, SizeOf(NS.Name)) <> feOK then Exit;
  422.   if Stream.Read(NS.UID, SizeOf(NS.UID)) <> feOK then Exit;
  423.   if Stream.Read(NS.Kind, SizeOf(NS.Kind)) <> feOK then Exit;
  424.   if Stream.Read(NS.ParamCount, SizeOf(NS.ParamCount)) <> feOK then Exit;
  425.   if Stream.Read(NS.ID, SizeOf(NS.ID)) <> feOK then Exit;
  426.   if Stream.Read(NS.StackLength, SizeOf(NS.StackLength)) <> feOK then Exit;
  428.   if Stream.Read(NS.TotalConstants, SizeOf(NS.TotalConstants)) <> feOK then Exit;
  429.   SetLength(NS.Constants, NS.TotalConstants);
  430.   if NS.TotalConstants > 0 then
  431.    if Stream.Read(NS.Constants[0], SizeOf(Longword)*NS.TotalConstants) <> feOK then Exit;
  433.   if Stream.Read(NS.TotalVariables, SizeOf(NS.TotalVariables)) <> feOK then Exit;
  434.   SetLength(NS.Variables, NS.TotalVariables);
  435.   if NS.TotalVariables > 0 then
  436.    if Stream.Read(NS.Variables[0], SizeOf(Longword)*NS.TotalVariables) <> feOK then Exit;
  438.   if Stream.Read(NS.TotalTypes, SizeOf(NS.TotalTypes)) <> feOK then Exit;
  439.   SetLength(NS.Types, NS.TotalTypes);
  440.   if NS.TotalTypes > 0 then
  441.    if Stream.Read(NS.Types[0], SizeOf(Longword)*NS.TotalTypes) <> feOK then Exit;
  443.   if Stream.Read(NS.TotalProcedures, SizeOf(NS.TotalProcedures)) <> feOK then Exit;
  444.   SetLength(NS.Procedures, NS.TotalProcedures);
  445.   for i := 0 to NS.TotalProcedures-1 do NS.Procedures[i] := nil;
  446.   for i := 0 to NS.TotalProcedures-1 do if LoadNamespace(NS.Procedures[i]) <> feOK then Exit;
  447.   if Stream.Read(ID, SizeOf(ID)) <> feOK then Exit;
  448.   NS.Parent := GetNamespace(ID);
  449.   Result := feOK;
  450. end;
  452. var i, ID, Ind: Integer; Sign: TBinModuleSign;
  453. begin
  454.   Result := feCannotRead;
  456. {$IFDEF DEBUG}
  457.   DItems.Clear;
  458. {$ENDIF}
  459.   StackCapacity := 256; SetLength(Stack, StackCapacity);
  461.   if Stream.Read(Sign, SizeOf(TBinModuleSign)) <> feOK then Exit;
  462.   if Sign <> BinModuleSign then begin
  463.     Result := feInvalidFileFormat; Exit;
  464.   end;
  466.   if Stream.Read(Data.EntryPIN, SizeOf(Data.EntryPIN)) <> feOK then Exit;
  467.   if Stream.Read(Data.PINItems, SizeOf(Data.PINItems)) <> feOK then Exit;
  468.   SetLength(Data.PIN, Data.PINItems);
  469.   if Data.PINItems > 0 then
  470.    if Stream.Read(Data.PIN[0], SizeOf(TPINItem)*Data.PINItems) <> feOK then Exit;
  471.   if Stream.Read(Data.TotalExternalVariables, SizeOf(Data.TotalExternalVariables)) <> feOK then Exit;
  472.   if Stream.Read(Data.ExternalVarsOfs, SizeOf(Data.ExternalVarsOfs)) <> feOK then Exit;
  474.   if LoadNamespace(Data.Namespace) <> feOK then Exit;
  476.   if Stream.Read(Data.BaseData, SizeOf(Data.BaseData)) <> feOK then Exit;
  478.   if Stream.Read(Data.DataLength, SizeOf(Data.DataLength)) <> feOK then Exit;
  479.   SetLength(Data.Data, Data.DataLength);
  480.   if Data.DataLength > 0 then
  481.    if Stream.Read(Data.Data[0], Data.DataLength * SizeOf(Data.Data[0])) <> feOK then Exit;
  483.   if Stream.Read(Data.TotalTypes, SizeOf(Data.TotalTypes)) <> feOK then Exit;
  484.   SetLength(Data.Types, Data.TotalTypes);
  485.   for i := 0 to Data.TotalTypes-1 do begin
  486.     New(Data.Types[i]);
  487.     Data.Types[i].Namespace := nil;
  488.   end;
  489.   for i := 0 to Data.TotalTypes-1 do begin
  490.     if Stream.Read(Data.Types[i]^, SizeOf(Data.Types[i]^)-SizeOf(Data.Types[i].Namespace)) <> feOK then Exit;
  491.     if Stream.Read(ID, SizeOf(ID)) <> feOK then Exit;
  492.     if ID <> -1 then LoadNamespace(Data.Types[i].Namespace);
  493.   end;
  495.   if Stream.Read(Data.TotalProcedures, SizeOf(Data.TotalProcedures)) <> feOK then Exit;
  496.   SetLength(Data.Procedures, Data.TotalProcedures);
  497.   for i := 0 to Data.TotalProcedures-1 do begin
  498.     if Stream.Read(Data.Procedures[i], SizeOf(Data.Procedures[i])-SizeOf(Data.Procedures[i].Namespace)) <> feOK then Exit;
  499.     if Stream.Read(ID, SizeOf(ID)) <> feOK then Exit;
  500.     Data.Procedures[i].Namespace := GetNamespace(ID);
  501.   end;
  503.   if Stream.Read(Data.TotalVariables, SizeOf(Data.TotalVariables)) <> feOK then Exit;
  504.   SetLength(Data.Variables, Data.TotalVariables);
  505.   for i := 0 to Data.TotalVariables-1 do begin
  506.     if Stream.Read(Data.Variables[i], SizeOf(Data.Variables[i])-SizeOf(Data.Variables[i].Namespace){-SizeOf(Data.Variables[i].Index)}) <> feOK then Exit;
  507. //    if Stream.Read(Ind, SizeOf(Ind)) <> feOK then Exit;
  508. //    Data.Variables[i].Index := Ind;
  509.     if Stream.Read(ID, SizeOf(ID)) <> feOK then Exit;
  510.     Data.Variables[i].Namespace := GetNamespace(ID);
  511.   end;
  513.   if Stream.Read(Data.TotalConstants, SizeOf(Data.TotalConstants)) <> feOK then Exit;
  514.   SetLength(Data.Constants, Data.TotalConstants);
  515.   for i := 0 to Data.TotalConstants-1 do begin
  516.     if Stream.Read(Data.Constants[i], SizeOf(Data.Constants[i])-SizeOf(Data.Constants[i].Namespace)) <> feOK then Exit;
  517. //    if Stream.Read(Ind, SizeOf(Ind)) <> feOK then Exit;
  518. //    Data.Constants[i].Index := Ind + Integer(Data.Data);
  519.     if Stream.Read(ID, SizeOf(ID)) <> feOK then Exit;
  520.     Data.Constants[i].Namespace := GetNamespace(ID);
  521.   end;
  523.   Result := feOK;
  524. end;
  526. function TOberonVM.SetExtVarAddr(const VarIndex: Integer; const Addr: Pointer): Boolean;
  527. begin
  528.   Result := False;
  529.   if (VarIndex < 0) or (VarIndex >= Data.TotalExternalVariables) then Exit;
  530.   Data.Variables[Data.ExternalVarsOfs + VarIndex].Index := Integer(Addr);
  531.   Result := True;
  532. end;
  534. {$I ExpComb.inc}
  536. procedure TOberonVM.Run;
  537. var IP, i1, i2: Integer; r1, r2: Single;
  538. begin
  539.   StackBase := 0; TotalStack := 0;
  540.   IP := Data.EntryPIN;
  541.   while IP < Data.PINItems do begin
  542.     case Data.PIN[IP] and $FF of
  543.       dtBoolean..dtString, dtVariableRef: begin Inc(IP); Push(Data.PIN[IP]); end;
  544.       dtSet: Push(ConstructSet(Data.PIN[IP] shr 16));
  545.       dtVariable: begin
  546.         Inc(IP); Push(TStackItem((@Data.BaseData[Integer(Data.Data) + Data.PIN[IP]])^));
  547.       end;
  548.       dtVariableByOfs: begin
  549.         Push(TStackItem((@Data.BaseData[Integer(Data.Data) + Pop])^));
  550.       end;
  551.       dtStackVariable: begin
  552.         Inc(IP); Push(TStackItem((@Stack[StackBase+Data.PIN[IP]])^));
  553.       end;
  554.       dtStackVariableByOfs: begin
  555.         Push(TStackItem((@Stack[StackBase+Pop])^));
  556.       end;
  557.       dtExtVariable: begin
  558.         Inc(IP); Push(TStackItem( (@Data.BaseData[Data.PIN[IP]])^));
  559. //        Inc(IP); Push(TStackItem( (@Data.BaseData[Data.Variables[Data.PIN[IP]].Index])^));
  560.       end;
  561.       dtExtVariableByOfs: begin
  562.         Push(TStackItem((@Data.BaseData[Pop])^));
  563. //        Inc(IP); Push(TStackItem( (@Data.BaseData[Data.PIN[IP] + Pop])^));
  564.       end;
  565.       aoAddII: begin i2 := Pop; i1 := Pop; Push(AddII(i1, i2)); end;
  566.       aoAddIR: begin r2 := PopS; i1 := Pop; PushS(AddIR(i1, r2)); end;
  567.       aoAddRI: begin i2 := Pop; r1 := PopS; PushS(AddRI(r1, i2)); end;
  568.       aoAddRR: begin r2 := PopS; r1 := PopS; PushS(AddRR(r1, r2)); end;
  569.       aoAddSS: begin i2 := Pop; i1 := Pop; Push(AddSS(i1, i2)); end;
  570.       aoSubII: begin i2 := Pop; i1 := Pop; Push(SubII(i1, i2)); end;
  571.       aoSubIR: begin r2 := PopS; i1 := Pop; PushS(SubIR(i1, r2)); end;
  572.       aoSubRI: begin i2 := Pop; r1 := PopS; PushS(SubRI(r1, i2)); end;
  573.       aoSubRR: begin r2 := PopS; r1 := PopS; PushS(SubRR(r1, r2)); end;
  574.       aoSubSS: begin i2 := Pop; i1 := Pop; Push(SubSS(i1, i2)); end;
  575.       aoMulII: begin i2 := Pop; i1 := Pop; Push(MulII(i1, i2)); end;
  576.       aoMulIR: begin r2 := PopS; i1 := Pop; PushS(MulIR(i1, r2)); end;
  577.       aoMulRI: begin i2 := Pop; r1 := PopS; PushS(MulRI(r1, i2)); end;
  578.       aoMulRR: begin r2 := PopS; r1 := PopS; PushS(MulRR(r1, r2)); end;
  579.       aoMulSS: begin i2 := Pop; i1 := Pop; Push(MulSS(i1, i2)); end;
  580.       aoDivII: begin i2 := Pop; i1 := Pop; PushS(DivII(i1, i2)); end;
  581.       aoDivIR: begin r2 := PopS; i1 := Pop; PushS(DivIR(i1, r2)); end;
  582.       aoDivRI: begin i2 := Pop; r1 := PopS; PushS(DivRI(r1, i2)); end;
  583.       aoDivRR: begin r2 := PopS; r1 := PopS; PushS(DivRR(r1, r2)); end;
  584.       aoDivSS: begin i2 := Pop; i1 := Pop; Push(DivSS(i1, i2)); end;
  585.       aoOrII, aoOrBB: Push(OrII(Pop, Pop));
  586.       aoAndII, aoAndBB: Push(AndII(Pop, Pop));
  587.       aoIDivII: Push(IDivII(Pop, Pop));
  588.       aoModII: Push(ModII(Pop, Pop));
  589.       aoNegI: Push(NegI(Pop));
  590.       aoNegR: PushS(NegR(PopS));
  591.       aoNegS: Push(NegS(Pop));
  592.       aoInvI: Push(InvI(Pop));
  593.       aoInvB: Push(InvB(Pop));
  594.       arEqualII, arEqualRR: begin i2 := Pop; i1 := Pop; Push(Equal(i1, i2)); end;
  595.       arEqualIR: begin r1 := PopS; i2 := Pop; Push(EqualRI(r1, i2)); end;
  596.       arEqualRI: begin i1 := Pop; r2 := PopS; Push(EqualRI(r2, i1)); end;
  597.       arGreaterII: begin i2 := Pop; i1 := Pop; Push(GreaterII(i1, i2)); end;
  598.       arGreaterIR: begin r2 := PopS; i1 := Pop; Push(GreaterIR(i1, r2)); end;
  599.       arGreaterRI: begin i2 := Pop; r1 := PopS; Push(GreaterRI(r1, i2)); end;
  600.       arGreaterRR: begin r2 := PopS; r1 := PopS; Push(GreaterRR(r1, r2)); end;
  601.       arLessII: begin i2 := Pop; i1 := Pop; Push(LessII(i1, i2)); end;
  602.       arLessIR: begin r2 := PopS; i1 := Pop; Push(LessIR(i1, r2)); end;
  603.       arLessRI: begin i2 := Pop; r1 := PopS; Push(LessRI(r1, i2)); end;
  604.       arLessRR: begin r2 := PopS; r1 := PopS; Push(LessRR(r1, r2)); end;
  605.       arGreaterEqualII: begin i2 := Pop; i1 := Pop; Push(GreaterEqualII(i1, i2)); end;
  606.       arGreaterEqualIR: begin r2 := PopS; i1 := Pop; Push(GreaterEqualIR(i1, r2)); end;
  607.       arGreaterEqualRI: begin i2 := Pop; r1 := PopS; Push(GreaterEqualRI(r1, i2)); end;
  608.       arGreaterEqualRR: begin r2 := PopS; r1 := PopS; Push(GreaterEqualRR(r1, r2)); end;
  609.       arLessEqualII: begin i2 := Pop; i1 := Pop; Push(LessEqualII(i1, i2)); end;
  610.       arLessEqualIR: begin r2 := PopS; i1 := Pop; Push(LessEqualIR(i1, r2)); end;
  611.       arLessEqualRI: begin i2 := Pop; r1 := PopS; Push(LessEqualRI(r1, i2)); end;
  612.       arLessEqualRR: begin r2 := PopS; r1 := PopS; Push(LessEqualRR(r1, r2)); end;
  613.       arNotEqualII, arNotEqualRR: begin i2 := Pop; i1 := Pop; Push(NotEqual(i1, i2)); end;
  614.       arNotEqualIR: begin i2 := Pop; i1 := Pop; Push(NotEqualRI(i1, i2)); end;
  615.       arNotEqualRI: begin i2 := Pop; i1 := Pop; Push(NotEqualRI(i2, i1)); end;
  616.       arIn: begin i2 := Pop; i1 := Pop; Push(TestIn(i1, i2)); end;
  618.       aoAssign1: ;//begin i2 := Pop; i1 := Pop; DoAssign4(i1, i2); end;
  619.       aoAssign2: ;
  620.       aoAssign4: begin i2 := Pop; i1 := Pop; DoAssign4(i1, i2); end;
  621.       aoAssign4RI: begin r2 := Pop; i1 := Pop; DoAssign4(i1, Integer((@r2)^)); end;
  622.       aoAssignSize: ;
  623.       aoStackAssign4: begin i2 := Pop; i1 := Pop; DoStackAssign4(i1, i2); end;
  624.       aoStackAssign4RI: begin r2 := Pop; i1 := Pop; DoStackAssign4(i1, Integer((@r2)^)); end;
  625.       aoStackAssignSize: ;
  626.       aoExtAssign4: begin i2 := Pop; i1 := Pop; DoExtAssign4(i1, i2); end;
  627.       aoExtAssign4RI: begin r2 := Pop; i1 := Pop; DoExtAssign4(i1, Integer((@r2)^)); end;
  629.       aoGoto: DoGoto(IP);
  630.       aoJumpIfZero: DoZeroJump(Pop, IP);
  631.       aoCall: begin DoCall(Pop, IP); Dec(IP); end;
  632.       aoReturnF: begin
  633.         i1 := Pop; DoReturn(IP); Push(i1);             // function only
  634.       end;
  635.       aoReturnP: DoReturn(IP);                         // procedure only
  636.       aoExit: begin DoExit(Pop, IP); end;
  637.       aoSetStackBase: begin Inc(IP); Push(StackBase); StackBase := TotalStack-Data.PIN[IP]-2; end;
  638.       aoExpandStack: begin Inc(IP); ExpandStack(Data.PIN[IP]); end;
  639. {        eoAdd, eoSub: Push(AddItems(Pop, Pop, Data.PIN[i].Value = eoSub));
  640.       eoOr: Push(OrItems(Pop, Pop));
  641.       eoAnd: Push(AndItems(Pop, Pop));
  642.       eoMul: Push(MulItems(Pop, Pop));
  643.       eoDiv: Push(DivItems(Pop, Pop));
  644.       eoIDiv: Push(IDivItems(Pop, Pop));
  645.       eoMod: Push(ModItems(Pop, Pop));
  646.       rEqual, rNotEqual: Push(TestEqual(Pop, Pop, Data.PIN[i].Value = rNotEqual));
  647.       rGreater, rLessEqual: Push(TestGreater(Pop, Pop, Data.PIN[i].Value = rLessEqual));
  648.       rLess, rGreaterEqual: Push(TestLess(Pop, Pop, Data.PIN[i].Value = rGreaterEqual));}
  649. // Standard functions
  650.       sfSin: Pushs(Sin(PopS));
  651.       sfCos: Pushs(Cos(PopS));
  652.       sfTan: begin r1 := PopS; PushS(Sin(r1)/Cos(r1)); end;
  653.       sfArcTan: PushS(ArcTan(PopS));
  654.       sfSqrt: PushS(Sqrt(PopS));
  655.       sfInvSqrt: PushS(InvSqrt(PopS));
  656.       sfRnd: PushS(Random);
  657.       sfEntier: Push(Round(PopS));
  658.       sfLn: Pushs(Ln(PopS));
  659.       sfBlend: begin
  660.         r1 := PopS; i1 := Pop; i2 := Pop;
  661.         Push(Integer(BlendColor(Cardinal(i2), Cardinal(i1), r1)));
  662.       end;
  663.     end;
  664.     Inc(IP);
  665.   end;
  666. end;
  668. function TOberonVM.Compute: TStackItem;
  669. begin
  670.   Run;
  671.   Result := Pop;
  672. end;
  674. constructor TOberonVM.Create;
  675. var i: Integer;
  676. begin
  677. {$IFDEF DEBUG}
  678.   DItems := TStringList.Create;
  679. {$ENDIF}
  680.   Data  := TRTData.Create;
  681.   StackCapacityStep := 256; StackCapacity := 256; SetLength(Stack, StackCapacity);
  682.   MaxSet := 31;
  683.   SetLength(El2Set, MaxSet);
  684.   for i := 0 to MaxSet-1 do El2Set[i] := 1 shl i;
  685.   Data.Namespace := nil;
  686. end;
  688. destructor TOberonVM.Destroy;
  689. begin
  690.   StackCapacity := 0; SetLength(Stack, StackCapacity);
  691.   SetLength(El2Set, 0);
  692. end;
  694. end.