Sordie.co.uk

libsassy/libSassy.VirtualMachine.pas

Raw

{(
 )) libSassy.VirtualMachine
((    Virtual machine
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.VirtualMachine;

interface

uses
  WinApi.Windows,

  libSassy.Interfaces,
  libSassy.Maths,
  libSassy.Arrays,
  libSassy.Strings,
  libSassy.Integers,
  libSassy.Variant,
  libSassy.Errors;

type
  TVirtualMachine = class;

  TVMOperationProc = reference to procedure(VM: TVirtualMachine);

  TVMOperation = record
    Proc:     TVMOperationProc;
    Instr:    String;
    Priority: Integer;
    Token:    String;
  end;

{$REGION 'TVMOperationManager'}
  TVMOperationManager = class(TInterface)
  private
    class var fDefault: TVMOperationManager;

    procedure OpParamCheck(v: TVariant; Valid: array of TVariantType; VM: TVirtualMachine; Instr: String);
  public
    Operations: array[TTag] of TVMOperation;

    class constructor Create;
    class destructor  Destroy;

    class function Default: TVMOperationManager;

    function Assemble(const Code: TStrings): TVirtualMachine;
    function Disassemble(VM: TVirtualMachine): TStrings;

    function CompileExpression(const Expression: String): TStrings;
    function BuildExpression  (const Expression: String): TVirtualMachine;

    constructor Create;
    destructor  Destroy; override;

    procedure Clear;
    procedure AddStdOps;

    procedure AddOp(Code: TTag; Proc: TVMOperationProc; Instr: String; Priority: Integer = 100; Token: String = '');

    procedure DoOp(Code: TTag; VM: TVirtualMachine); inline;

    procedure StdOpInvalid(VM: TVirtualMachine); virtual;

    procedure StdOpNOp(VM: TVirtualMachine); virtual;

    procedure StdOpHalt(VM: TVirtualMachine); virtual;

    procedure StdOpAdd(VM: TVirtualMachine); virtual;
    procedure StdOpSub(VM: TVirtualMachine); virtual;
    procedure StdOpDiv(VM: TVirtualMachine); virtual;
    procedure StdOpMul(VM: TVirtualMachine); virtual;
    procedure StdOpMod(VM: TVirtualMachine); virtual;
    procedure StdOpPow(VM: TVirtualMachine); virtual;

    procedure StdOpNeg(VM: TVirtualMachine); virtual;
    procedure StdOpNot(VM: TVirtualMachine); virtual;
    procedure StdOpAbs(VM: TVirtualMachine); virtual;

    procedure StdOpBitwiseAnd(VM: TVirtualMachine); virtual;
    procedure StdOpBitwiseOr (VM: TVirtualMachine); virtual;
    procedure StdOpBitwiseXor(VM: TVirtualMachine); virtual;

    procedure StdOpLogicalAnd(VM: TVirtualMachine); virtual;
    procedure StdOpLogicalOr (VM: TVirtualMachine); virtual;
    procedure StdOpLogicalXor(VM: TVirtualMachine); virtual;

    procedure StdOpEq (VM: TVirtualMachine); virtual;
    procedure StdOpNEq(VM: TVirtualMachine); virtual;
    procedure StdOpGT (VM: TVirtualMachine); virtual;
    procedure StdOpGTE(VM: TVirtualMachine); virtual;
    procedure StdOpLT (VM: TVirtualMachine); virtual;
    procedure StdOpLTE(VM: TVirtualMachine); virtual;

    procedure StdOpJmp (VM: TVirtualMachine); virtual;
    procedure StdOpCJmp(VM: TVirtualMachine); virtual;

    procedure StdOpIf(VM: TVirtualMachine); virtual;

    procedure StdOpRead (VM: TVirtualMachine); virtual;
    procedure StdOpWrite(VM: TVirtualMachine); virtual;

    procedure StdOpDupe(VM: TVirtualMachine); virtual;
    procedure StdOpDrop(VM: TVirtualMachine); virtual;

    procedure StdOpCall  (VM: TVirtualMachine); virtual;
    procedure StdOpReturn(VM: TVirtualMachine); virtual;

    procedure StdOpShl(VM: TVirtualMachine); virtual;
    procedure StdOpShr(VM: TVirtualMachine); virtual;
  end;
{$ENDREGION}

{$REGION 'IVMInvokable'}
  IVMInvokable = interface ['{BD57EAF3-1C79-48E3-9B8F-E615C8A610B6}']
    function Invoke(const Ident: String; Params: TVariant.TVariants): TVariant;
  end;
{$ENDREGION}

{$REGION 'TVMVariables'}
  TVMVariables = class(TDictionary<TVariant>, IVMInvokable)
    function Invoke(const Ident: String; Params: TVariant.TVariants): TVariant;
  end;
{$ENDREGION}

{$REGION 'TVirtualMachine'}
  TVirtualMachine = class(TInterface, IVMInvokable)
  private
    fOperationManager: TVMOperationManager;

    fThrottle: Cardinal;

    fStack: TVariant.TVariants;
    fCode:  TVariant.TVariants;
    fCall:  TIntegers;

    fRunning: Boolean;

    fIPtr: Integer;

    fNamespace: IVMInvokable;
  public
    constructor Create;
    destructor  Destroy; override;

    function Run(const Start: Integer = 0): TVariant;
    function Tick: Boolean;
    procedure Resume;

    function Invoke(const Ident: String; Params: TVariant.TVariants): TVariant; virtual;

    property Running: Boolean read fRunning;

    property InstructionPointer: Integer read fIPtr write fIPtr;

    property Throttle: Cardinal read fThrottle write fThrottle;

    property Stack: TVariant.TVariants read fStack;
    property Code:  TVariant.TVariants read fCode;

    property Namespace: IVMInvokable read fNamespace write fNamespace;

    property OperationManager: TVMOperationManager read fOperationManager write fOperationManager;
  end;
{$ENDREGION}

  EVMInvalidOperation  = class(TException);
  EVMInvalidParameter  = class(TException);
  EVMInvalidCodeRange  = class(TException);
  EVMReturnBeforeCall  = class(TException);
  EVMCompilerError     = class(TException);
  EVMUnknownIdentifier = class(TException);

{$REGION 'OpCodes'}
const
  OpNOp:  TTag = 0;
  OpHalt: TTag = 1;

  OpAdd: TTag = 10;
  OpSub: TTag = 11;
  OpDiv: TTag = 12;
  OpMul: TTag = 13;
  OpMod: TTag = 14;
  OpPow: TTag = 15;

  OpNeg: TTag = 20;
  OpNot: TTag = 21;
  OpAbs: TTag = 22;

  OpBitwiseAnd: TTag = 30;
  OpBitwiseOr:  TTag = 31;
  OpBitwiseXor: TTag = 32;

  OpLogicalAnd: TTag = 35;
  OpLogicalOr:  TTag = 36;
  OpLogicalXor: TTag = 37;

  OpEq:  TTag = 40;
  OpNEq: TTag = 41;
  OpGT:  TTag = 42;
  OpGTE: TTag = 43;
  OpLT:  TTag = 44;
  OpLTE: TTag = 45;

  OpJmp:  TTag = 50;
  OpCJmp: TTag = 51;

  OpIf: TTag = 55;

  OpRead:  TTag = 60;
  OpWrite: TTag = 61;

  OpDupe: TTag = 70;
  OpDrop: TTag = 71;

  OpCall:   TTag = 80;
  OpReturn: TTag = 81;

  OpShl: TTag = 90;
  OpShr: TTag = 91;
{$ENDREGION}

implementation

{$REGION 'TVMOperationManager'}
class constructor TVMOperationManager.Create;
begin
  fDefault := nil;
end;

class destructor TVMOperationManager.Destroy;
begin
  if fDefault <> nil then
    fDefault.Free;

  fDefault := nil;
end;

class function TVMOperationManager.Default;
begin
  if fDefault = nil then
  begin
    fDefault := TVMOperationManager.Create;
    fDefault.AddStdOps;
  end;

  Result := fDefault;
end;

function TVMOperationManager.Assemble;
var
  s, n: String;
  v:    Boolean;
  Op:   TTag;
begin
  Result := TVirtualMachine.Create;
  Result.OperationManager := Self;

  for s in Code do
  begin
    if s.Empty then continue;

    if (s.FirstChar = '"') and (s.LastChar = '"') then
      Result.Code.Add(copy(s, 2, length(s) - 2))
    else if String.NumberChars.Contains(s.FirstChar) then
    begin
      if s.Contains('.') then
        Result.Code.Add(Extended(s.AsFloat))
      else
        Result.Code.Add(Integer(s.AsInteger));
    end
    else
    begin
      v := False;

      for Op := low(TTag) to high(TTag) do
        if (s = Operations[Op].Instr) {or (s = Operations[Op].Token)} then
        begin
          Result.Code.Add(Op);
          v := True;
          break;
        end;

      if not v then
      begin
        if s.FirstChar = '#' then
        begin
          n := s.Copy(2, s.Length);
          Result.Code.Add(n.Split(':'));

          with Result.Code.Items[Result.Code.Count - 1] do
          begin
            Kind := vtPointer;

            if n.Empty then
              fInteger := 0
            else
              fInteger := n.AsInteger;
          end;
        end
        else
          EVMCompilerError.RaiseException('Unknown instruction "' + s + '"');
      end
    end;
  end;
end;

function TVMOperationManager.Disassemble;
var
  v: TVariant;
begin
  Result := TStrings.Create;

  for v in VM.fCode do
  begin
    case v.Kind of
      vtString:  Result.Add('"' + v.fString + '"');
      vtTag:     Result.Add(Operations[v.fTag].Instr);
      vtPointer: Result.Add(v.fString + '(' + String.Int(v.fInteger) + ')');
    else
      Result.Add(v);
    end;
  end;
end;

function TVMOperationManager.CompileExpression;
const
  UnaryChars    = '+-';
  BracketChars  = '()';
var
  Operators: String;
  i, j:      Integer;
  Expr:      String;
  Token:     String;
  Unary:     Boolean;
  Stack:     TStrings;
  Prior:     Integer;
  Params:    TIntegers;

  function GetPriority(s: String): Integer;
  var
    Op: TTag;
  begin
    if s.Empty or (s = '(') then exit(0);

    for Op := low(TTag) to high(TTag) do
      if (s = String(Operations[Op].Instr)) or (s = String(Operations[Op].Token)) then
        exit(Operations[Op].Priority);

    Result := High(TTag) + 1;
  end;

  function GetInstr(s: String): String;
  var
    Op: TTag;
  begin
    for Op := low(TTag) to high(TTag) do
      if (s = String(Operations[Op].Instr)) or (s = String(Operations[Op].Token)) then
        exit(Operations[Op].Instr);

    Result := s;
  end;
begin
  Operators := '';
  for i := low(TTag) to high(TTag) do
    Operators := Operators + Operations[i].Token;

  Result := TStrings.Create;
  Stack  := TStrings.Create;

  Expr  := Expression;
  Unary := True;

  Params := TIntegers.Create;

  try
    repeat
      Token := Expr.SplitToken(True);

      if Token.Empty then break;

      if String.NumberChars.Contains(Token.FirstChar) then
      begin
        Unary := False;
        Result.Push(Token);
      end
      else if Token.FirstChar = '"' then
      begin
        Unary := False;
        Result.Push(Token);
      end
      else if String.Ident1Chars.Contains(Token.FirstChar) then
      begin
        Stack.Push('#' + Token);
        Unary := False;
      end
      else if Unary and UnaryChars.Contains(Token.FirstChar) then
      begin
        if Token = '-' then
          Stack.Push('neg');
      end
      else if Unary and (Token = '!') then
        Stack.Push('not')
      else if Token = ',' then
      begin
        Params.Top := Params.Top + 1;

        while (Stack.Count > 0) and (Stack.Last <> '(') do
          Result.Push(Stack.Pop);

        if Stack.Count = 0 then
          EVMCompilerError.RaiseException('Expected (');

        Unary := True;
      end
      else if Token = '(' then
      begin
        Params.Add(1);
        Stack.Push(Token);
        Unary := True;
      end
      else if Token = ')' then
      begin
        while (Stack.Count > 0) and (Stack.Last <> '(') do
          Result.Push(Stack.Pop);

        if Stack.Count = 0 then
          EVMCompilerError.RaiseException('Unxpected )');

        Stack.Pop;

        j := Params.Pop;
        if Unary then j := j - 1;

        for i := Stack.Count - 1 downto 0 do
          if Stack[i].FirstChar = '#' then
          begin
            Stack[i] := Stack[i].Split(':') + ':' + String.Int(j);

            break;
          end;

        Unary := False;
      end
      else if Operators.Contains(Token.FirstChar) then
      begin
        Prior := GetPriority(Token);

        while (Stack.Count > 0) and (Prior <= GetPriority(Stack.Last)) do
          Result.Push(Stack.Pop);

        Stack.Push(GetInstr(Token));

        Unary := True;
      end
      else
        EVMCompilerError.RaiseException('Unknown operator "' + Token + '"');
    until Expr.Empty;

    while Stack.Count > 0 do
    begin
      if BracketChars.Contains(Stack.Last.FirstChar) then
        EVMCompilerError.RaiseException('Bracket mismatch');

      Result.Push(Stack.Pop);
    end;
  finally
    Stack.Free;
    Params.Free;
  end;
end;

function TVMOperationManager.BuildExpression;
var
  Code: TStrings;
begin
  Code := CompileExpression(Expression);
  try
    Result := Assemble(Code);
  finally
    Code.Free;
  end;
end;

constructor TVMOperationManager.Create;
begin
  inherited;
  Clear;
end;

destructor TVMOperationManager.Destroy;
begin
  Clear;
  inherited;
end;

procedure TVMOperationManager.Clear;
var
  i: Integer;
begin
  for i := low(TTag) to high(TTag) do
    AddOp(i, StdOpInvalid, '');
end;

procedure TVMOperationManager.AddStdOps;
begin
  AddOp(OpNOp,  StdOpNOp,  'nop');
  AddOp(OpHalt, StdOpHalt, 'halt');

  AddOp(OpAdd, StdOpAdd, 'add', 11, '+');
  AddOp(OpSub, StdOpSub, 'sub', 11, '-');
  AddOp(OpDiv, StdOpDiv, 'div', 12, '/');
  AddOp(OpMul, StdOpMul, 'mul', 12, '*');
  AddOp(OpMod, StdOpMod, 'mod', 12, '%');
  AddOp(OpPow, StdOpPow, 'pow', 13);

  AddOp(OpNeg, StdOpNeg, 'neg', 14);
  AddOp(OpNot, StdOpNot, 'not', 14, '!');
  AddOp(OpAbs, StdOpAbs, 'abs');

  AddOp(OpBitwiseAnd, StdOpBitwiseAnd, 'band', 7, '&');
  AddOp(OpBitwiseOr,  StdOpBitwiseOr,  'bor',  5, '|');
  AddOp(OpBitwiseXor, StdOpBitwiseXor, 'bxor', 6, '^');

  AddOp(OpLogicalAnd, StdOpLogicalAnd, 'and', 4, '&&');
  AddOp(OpLogicalOr,  StdOpLogicalOr,  'or',  3, '||');
  AddOp(OpLogicalXor, StdOpLogicalXor, 'xor', 3, '^^');

  AddOp(OpEq,  StdOpEq,  'eq',  8, '==');
  AddOp(OpNEq, StdOpNEq, 'neq', 8, '!=');
  AddOp(OpGT,  StdOpGT,  'gt',  9, '>');
  AddOp(OpGTE, StdOpGTE, 'gte', 9, '>=');
  AddOp(OpLT,  StdOpLT,  'lt',  9, '<');
  AddOp(OpLTE, StdOpLTE, 'lte', 9, '<=');

  AddOp(OpJmp,  StdOpJmp,  'jmp');
  AddOp(OpCJmp, StdOpCJmp, 'cjmp');

  AddOp(OpIf, StdOpIf, 'iff', 2, '?');

  AddOp(OpRead,  StdOpRead,  'read');
  AddOp(OpWrite, StdOpWrite, 'write');

  AddOp(OpDupe, StdOpDupe, 'dupe');
  AddOp(OpDrop, StdOpDrop, 'drop');

  AddOp(OpCall,   StdOpCall,   'call');
  AddOp(OpReturn, StdOpReturn, 'ret');

  AddOp(OpShl, StdOpShl, 'shl', 10, '<<');
  AddOp(OpShr, StdOpShr, 'shr', 10, '>>');
end;

procedure TVMOperationManager.AddOp;
begin
  Operations[Code].Proc     := Proc;
  Operations[Code].Instr    := Instr;
  Operations[Code].Priority := Priority;
  Operations[Code].Token    := Token;
end;

procedure TVMOperationManager.DoOp;
begin
  Operations[Code].Proc(VM);
end;

procedure TVMOperationManager.StdOpInvalid;
begin
  EVMInvalidOperation.RaiseException('Invalid VM Operation at ' + String.Int(VM.InstructionPointer));
end;

procedure TVMOperationManager.StdOpNOp;
begin
  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpHalt;
begin
  inc(VM.fIPtr);
  VM.fRunning := False;
end;

procedure TVMOperationManager.OpParamCheck;
begin
  if not v.Valid(Valid) then
    EVMInvalidParameter.RaiseException('Invalid parameter at ' + String.Int(VM.fIPtr) + ' (' + Instr + ')');
end;

procedure TVMOperationManager.StdOpAdd;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'add a');
  OpParamCheck(b, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'add b');

  case a.Kind of
    vtInteger: a.fInteger := a.fInteger + Integer(b);
    vtFloat:   a.fFloat   := a.fFloat   + Extended(b);
    vtBoolean: a.fBoolean := a.fBoolean or (Boolean(b));
    vtString:  a.fString  := a.fString + String(b);
  end;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpSub;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat, vtBoolean], VM, 'sub a');
  OpParamCheck(b, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'sub b');

  case a.Kind of
    vtInteger: a.fInteger := a.fInteger - Integer(b);
    vtFloat:   a.fFloat   := a.fFloat   - Extended(b);
    vtBoolean: a.fBoolean := a.fBoolean xor (Boolean(b));
  end;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpDiv;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat], VM, 'div a');
  OpParamCheck(b, [vtInteger, vtFloat, vtString], VM, 'div b');

  case a.Kind of
    vtInteger: a.fInteger := a.fInteger div Integer(b);
    vtFloat:   a.fFloat   := a.fFloat   /   Extended(b);
  end;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpMul;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat], VM, 'mul a');
  OpParamCheck(b, [vtInteger, vtFloat, vtString], VM, 'mul b');

  case a.Kind of
    vtInteger: a.fInteger := a.fInteger * Integer(b);
    vtFloat:   a.fFloat   := a.fFloat   * Extended(b);
  end;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpMod;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger], VM, 'mod a');
  OpParamCheck(b, [vtInteger, vtFloat, vtString], VM, 'mod b');

  case a.Kind of
    vtInteger: a.fInteger := a.fInteger mod Integer(b);
  end;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpPow;
var
  a, b: TVariant;
  r:    Extended;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat, vtString], VM, 'pow a');
  OpParamCheck(b, [vtInteger, vtFloat, vtString], VM, 'pow b');

  r := Power(Extended(a), Extended(b));

  if frac(r) = 0 then
    a := Integer(trunc(r))
  else
    a := r;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpNeg;
var
  a: TVariant;
begin
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat, vtBoolean], VM, 'neg');

  case a.Kind of
    vtInteger: a.fInteger := -a.fInteger;
    vtFloat:   a.fFloat   := -a.fFloat;
    vtBoolean: a.fBoolean := not a.fBoolean;
  end;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpNot;
var
  a: TVariant;
begin
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtBoolean], VM, 'not');

  case a.Kind of
    vtInteger: a.fInteger := not a.fInteger;
    vtBoolean: a.fBoolean := not a.fBoolean;
  end;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpAbs;
var
  a: TVariant;
begin
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat], VM, 'abs');

  case a.Kind of
    vtInteger: a.fInteger := abs(a.fInteger);
    vtFloat:   a.fFloat   := abs(a.fFloat);
  end;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpBitwiseAnd;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger], VM, 'band a');
  OpParamCheck(b, [vtInteger], VM, 'band b');

  a.fInteger := a.fInteger and b.fInteger;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpBitwiseOr;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger], VM, 'bor a');
  OpParamCheck(b, [vtInteger], VM, 'bor b');

  a.fInteger := a.fInteger or b.fInteger;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpBitwiseXor;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger], VM, 'bxor a');
  OpParamCheck(b, [vtInteger], VM, 'bxor b');

  a.fInteger := a.fInteger xor b.fInteger;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpLogicalAnd;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtBoolean], VM, 'and a');
  OpParamCheck(b, [vtBoolean], VM, 'and b');

  a.fBoolean := a.fBoolean and b.fBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpLogicalOr;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtBoolean], VM, 'or a');
  OpParamCheck(b, [vtBoolean], VM, 'or b');

  a.fBoolean := a.fBoolean or b.fBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpLogicalXor;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtBoolean], VM, 'xor a');
  OpParamCheck(b, [vtBoolean], VM, 'xor b');

  a.fBoolean := a.fBoolean xor b.fBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpEq;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'eq a');
  OpParamCheck(b, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'eq b');

  case a.Kind of
    vtInteger: a.fBoolean := a.fInteger = Integer(b);
    vtFloat:   a.fBoolean := a.fFloat   = Extended(b);
    vtBoolean: a.fBoolean := a.fBoolean = Boolean(b);
    vtString:  a.fBoolean := a.fString  = String(b);
  end;

  a.fString := '';
  a.Kind    := vtBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpNEq;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'neq a');
  OpParamCheck(b, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'neq b');

  case a.Kind of
    vtInteger: a.fBoolean := a.fInteger <> Integer(b);
    vtFloat:   a.fBoolean := a.fFloat   <> Extended(b);
    vtBoolean: a.fBoolean := a.fBoolean <> Boolean(b);
    vtString:  a.fBoolean := a.fString  <> String(b);
  end;

  a.fString := '';
  a.Kind    := vtBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpGT;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat], VM, 'gt a');
  OpParamCheck(b, [vtInteger, vtFloat], VM, 'gt b');

  case a.Kind of
    vtInteger: a.fBoolean := a.fInteger > Integer(b);
    vtFloat:   a.fBoolean := a.fFloat   > Extended(b);
  end;

  a.Kind := vtBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpGTE;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat], VM, 'gte a');
  OpParamCheck(b, [vtInteger, vtFloat], VM, 'gte b');

  case a.Kind of
    vtInteger: a.fBoolean := a.fInteger >= Integer(b);
    vtFloat:   a.fBoolean := a.fFloat   >= Extended(b);
  end;

  a.Kind := vtBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpLT;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat], VM, 'lt a');
  OpParamCheck(b, [vtInteger, vtFloat], VM, 'lt b');

  case a.Kind of
    vtInteger: a.fBoolean := a.fInteger < Integer(b);
    vtFloat:   a.fBoolean := a.fFloat   < Extended(b);
  end;

  a.Kind := vtBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpLTE;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat], VM, 'lte a');
  OpParamCheck(b, [vtInteger, vtFloat], VM, 'lte b');

  case a.Kind of
    vtInteger: a.fBoolean := a.fInteger <= Integer(b);
    vtFloat:   a.fBoolean := a.fFloat   <= Extended(b);
  end;

  a.Kind := vtBoolean;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpJmp;
var
  a: TVariant;
begin
  a := VM.Stack.Pop;
  OpParamCheck(a, [vtInteger], VM, 'jmp');
  VM.fIPtr := a.fInteger;
end;

procedure TVMOperationManager.StdOpCJmp;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger], VM, 'cjmp a');
  OpParamCheck(b, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'cjmp b');

  if Boolean(b) then
    VM.fIPtr := a.fInteger
  else
    inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpIf;
var
  a, b, c: TVariant;
begin
  c := VM.Stack.Pop;
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'iff a');
  OpParamCheck(b, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'iff b');
  OpParamCheck(c, [vtInteger, vtFloat, vtBoolean, vtString], VM, 'iff c');

  if Boolean(c) then
    VM.fStack.Push(a)
  else
    VM.fStack.Push(b);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpRead;
var
  a: TVariant;
  i: Integer;
begin
  a := VM.Stack.Pop;
  OpParamCheck(a, [vtInteger], VM, 'read');
  i := Integer(a);

  if i < 0 then i := VM.Code.Count + i;

  if (i < 0) or (i > (VM.Code.Count - 1)) then
    EVMInvalidCodeRange.RaiseException('Read out of bounds at ' + String.Int(VM.fIPtr) + ': ' + String.Int(i));

  VM.Stack.Push(VM.Code[i]);
  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpWrite;
var
  a, b: TVariant;
  i: Integer;
begin
  a := VM.Stack.Pop;
  b := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger], VM, 'write');
  i := Integer(a);

  if i < 0 then i := VM.Code.Count + i;

  if (i < 0) or (i > (VM.Code.Count - 1)) then
    EVMInvalidCodeRange.RaiseException('Write out of bounds at ' + String.Int(VM.fIPtr) + ': ' + String.Int(i));

  VM.Code[i] := b;
  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpDupe;
begin
  VM.Stack.Push(VM.Stack.Last);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpDrop;
begin
  VM.Stack.Pop;

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpCall;
var
  a: TVariant;
  i: Integer;
begin
  a := VM.Stack.Pop;
  OpParamCheck(a, [vtInteger], VM, 'call');
  i := Integer(a);

  if i < 0 then i := VM.Code.Count + i;

  if (i < 0) or (i > (VM.Code.Count - 1)) then
    EVMInvalidCodeRange.RaiseException('Call out of bounds at ' + String.Int(VM.fIPtr) + ': ' + String.Int(i));

  VM.fCall.Push(VM.fIPtr + 1);
  VM.fIPtr := i;
end;

procedure TVMOperationManager.StdOpReturn;
begin
  if VM.fCall.Empty then
    EVMReturnBeforeCall.RaiseException('Return before call at ' + String.Int(VM.fIPtr));

  VM.fIPtr := VM.fCall.Pop;
end;

procedure TVMOperationManager.StdOpShl;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger], VM, 'shl a');
  OpParamCheck(b, [vtInteger], VM, 'shl b');

  a.fInteger := a.fInteger shl b.fInteger;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;

procedure TVMOperationManager.StdOpShr;
var
  a, b: TVariant;
begin
  b := VM.Stack.Pop;
  a := VM.Stack.Pop;

  OpParamCheck(a, [vtInteger], VM, 'shr a');
  OpParamCheck(b, [vtInteger], VM, 'shr b');

  a.fInteger := a.fInteger shl b.fInteger;

  VM.Stack.Push(a);

  inc(VM.fIPtr);
end;
{$ENDREGION}

{$REGION 'TVMVariables'}
function TVMVariables.Invoke(const Ident: String; Params: TVariant.TVariants): TVariant;
var
  i:     Integer;
  Name:  String;
  Child: String;
  Intf:  IVMInvokable;
begin
  Child := Ident;
  Name  := Child.Split('.');

  i := Find(Name);
  if i = -1 then
    EVMUnknownIdentifier.RaiseException('Unknown identifier "' + Name + '"');

  Result := Items[i].Value;

  case Result.Kind of
    vtMethod: Result := Result.fMethod(Params);
    vtObject:
      try
        Result.fObject.GetInterface(IVMInvokable, Intf);
        Intf._AddRef;
        Result := Intf.Invoke(Child, Params);
      except
        EVMUnknownIdentifier.RaiseException('Invalid identifier "' + Name + '->' + Child + '"');
      end;
  end;
end;
{$ENDREGION}

{$REGION 'TVirtualMachine'}
constructor TVirtualMachine.Create;
begin
  inherited;

  fOperationManager := TVMOperationManager.Default;

  fStack := TVariant.TVariants.Create;
  fCode  := TVariant.TVariants.Create;
  fCall  := TIntegers.Create;

  fNamespace := nil;

  fThrottle := 0;
  fRunning  := False;
end;

destructor TVirtualMachine.Destroy;
begin
  fRunning  := False;

  fStack.Free;
  fCode.Free;
  fCall.Free;

  inherited;
end;

function TVirtualMachine.Run;
begin
  fStack.Clear;
  fCall.Clear;
  fIPtr := Start;
  Resume;
  Result := fStack.Last;
end;

function TVirtualMachine.Tick;
var
  i:      Integer;
  Params: TVariant.TVariants;
begin
  if (fIPtr < 0) or (fIPtr > fCode.Count) then
    EVMInvalidCodeRange.RaiseException('Instruction pointer out of bounds: ' + String.Int(fIPtr) + '-' + String.Int(fCode.Count));

  case fCode[fIPtr].Kind of
    vtTag: fOperationManager.DoOp(fCode[fIPtr].fTag, Self);
    vtPointer:
    begin
      Params := TVariant.TVariants.Create;

      try
        for i := 1 to fCode[fIPtr].fInteger do
          Params.ADd(fStack.Pop, 0);

        fStack.Push(Invoke(fCode[fIPtr].fString, Params));
      finally
        Params.Free;
      end;

      inc(fIPtr);
    end;
  else
    fStack.Push(fCode[fIPtr]);
    inc(fIPtr);
  end;

  Result := fIPtr <= (fCode.Count - 1);
end;

procedure TVirtualMachine.Resume;
begin
  fRunning := True;

  try
    while Tick do
    begin
      if not fRunning then break;
      if fThrottle > 0 then Sleep(fThrottle);
    end;
  finally
    fRunning := False;
  end;
end;

function TVirtualMachine.Invoke;
begin
  if fNamespace <> nil then
    try
      Result := fNamespace.Invoke(Ident, Params)
    except on E: TException do
      Writeln(E.Message);
    end
  else
    EVMUnknownIdentifier.RaiseException('Unknown identifier "' + Ident + '" at ' + String.Int(fIPtr));
end;
{$ENDREGION}

end.