Chip 2000 February/Chip_2000-02_cd.bin/zkuste/Delphi/navody/tt/objvm.exe/UNITS/ObjOps.pas

Pascal/Delphi Source File | 1999-05-29 | 14KB | 509 lines

unit ObjOps;

interface
uses ObjOp,
     OpList,OpCodes,SysUtils;
procedure Register(a:TOpList);
implementation
uses
    uExecution,LangValue,VarLangValue;
//ocNop    =-40;
type TNoOp=class(TObjOp)
        procedure Execute(e:IExecution);override;
     end;
procedure TNoOp.Execute;
          begin
            e.IP:=e.IP+SIzeOf(OpCode);
          end;
//Arithmetic operations
type TBinOp=class(TNoOp)
     protected
       function DoOp(a,b:ILangValue):ILangValue;virtual;
     public
       procedure Execute(e:IExecution);override;
     end;
procedure TBinOp.Execute;
          Var a,b:ILangValue;
          begin
            Inherited Execute(e);
            a:=e.Data.Pop;
            b:=e.Data.Pop;
            e.Data.Push(DoOp(a,b));
            a.Free;
            b.Free;
          end;
function  TBinOp.DoOp;
          begin
            Result:=TVarLangValue.Create(nil);
          end;

//ocAdd    =-1;
type TAddOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TAddOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsVariant:=b.AsVariant+a.AsVariant;
         end;
//ocSub    =-2;
type TSubOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TSubOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsVariant:=b.AsVariant-a.AsVariant;
         end;
//ocMul    =-3;
type TMulOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TMulOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsVariant:=a.AsVariant*b.AsVariant;
         end;
//ocDiv    =-4;
type TDivOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TDivOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsVariant:=b.AsVariant/a.AsVariant;
         end;
//ocNegate
type TNegateOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TNegateOp.Execute;
           Var a:ILangValue;
           begin
             inherited Execute(e);
             a:=e.Data.Pop;
             a.AsVariant:=-a.AsVariant;
             e.Data.Push(a);
           end;
//Boolean operations
//ocAnd    =-11;
type TAndOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TAndOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsBoolean:=a.AsBoolean and b.AsBoolean;
         end;
//ocOr     =-12;
type TOrOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TOrOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsBoolean:=a.AsBoolean or b.AsBoolean;
         end;
//ocNot    =-13;
type TNotOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TNotOp.Execute;
           Var a:ILangValue;
           begin
             inherited Execute(e);
             a:=e.Data.Pop;
             a.AsBoolean:=not a.AsBoolean;
             e.Data.Push(a);
           end;

{Comparison ops}
//ocEqu    =-14
type TEquOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TEquOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsBoolean:=a.AsVariant=b.AsVariant;
         end;
//ocNE     =-15
type TNEOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TNEOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsBoolean:=b.AsVariant<>a.AsVariant;
         end;
//ocG      =-16
type TGOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TGOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsBoolean:=b.AsVariant>a.AsVariant;
         end;
//ocL      =-17
type TLOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TLOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsBoolean:=b.AsVariant<a.AsVariant;
         end;
//ocLE     =-18
type TLEOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TLEOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsBoolean:=b.AsVariant<=a.AsVariant;
         end;
//ocGE     =-19
type TGEOp=class(TBinOp)
       function DoOp(a,b:ILangValue):ILangValue;override;
     protected
     end;
function TGEOp.DoOp;
         begin
           Result:=Inherited DoOp(a,b);
           Result.AsBoolean:=b.AsVariant>=a.AsVariant;
         end;
//Value operations
//ocGet    =-21;
type TGetOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TGetOp.Execute;
           Var a,b:ILangValue;

           begin
             inherited Execute(e);
             a:=e.Data.Pop;
             b:=TVarLangValue.Create(nil);
             b.AsInteger:=0;
             e.Data.Push(b);
             a.Exec(e.Data,true);
             a.Free;
           end;
//ocSet    =-22;
type TSetOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TSetOp.Execute;
           Var a,b:ILangValue;
           begin
             inherited Execute(e);
             a:=e.Data.Pop;
             b:=TVarLangValue.Create(nil);
             b.AsInteger:=1;
             e.Data.Push(b);
             a.Exec(e.Data,false);
             a.Free;
           end;

//ocExec   =-23;
type TExecOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TExecOp.Execute;
           Var a,b:ILangValue;
           begin
             inherited Execute(e);
             a:=e.Data.Pop;
             a.Exec(e.Data,false);
             a.Free;
           end;
//ocEval   =-24;
type TEvalOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TEvalOp.Execute;
           Var a,b:ILangValue;
           begin
             Inherited Execute(e);
             a:=e.Data.Pop;
             a.Exec(e.Data,true);
             a.Free;
           end;
//ocGetElem=-25;
type TGetElemOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TGetElemOp.Execute;
           Var a,b,c:ILangValue;
               S:string;
           begin
             inherited Execute(e);
             a:=e.Data.Pop;
             b:=e.Data.Pop;
             s:=a.AsSTring;
             c:=b.Values[a.AsString];
             e.Data.Push(c);
             b.Free;
             a.Free;
             if c=nil then
                Raise Exception.Create('╚Σσφ≥Φ⌠ΦΩα≥ε≡ φσ φαΘΣσφ - '+s);
           end;
//ocRoot   =-26;
type TRootOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TRootOp.Execute;
           begin
             inherited Execute(e);
             e.Data.Push(e.Root.CreateEqu);
           end;
//Constant operations
//ocStr    =-31;
type TStrOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TStrOp.Execute;
           Var a:ILangValue;
           begin
             inherited Execute(e);
             a:=TVarLangValue.Create(nil);
             a.AsString:=e.Code.Str[e.IP];
             e.Data.Push(a);
             e.IP:=e.IP+Length(a.AsString)+1;
           end;
//ocFloat  =-32;
type TFloatOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TFloatOp.Execute;
           Var a:ILangValue;
           begin
             inherited Execute(e);
             a:=TVarLangValue.Create(nil);
             a.AsFloat:=e.Code.Num[e.IP];
             e.Data.Push(a);
             e.IP:=e.IP+SizeOf(Extended);
           end;
//ocInt    =-33;
type TIntOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TIntOp.Execute;
           Var a:ILangValue;
           begin
             inherited Execute(e);
             a:=TVarLangValue.Create(nil);
             a.AsInteger:=e.Code.Int[e.IP];
             e.Data.Push(a);
             e.IP:=e.IP+SizeOf(Integer);
           end;
//ocBool   =-34;
type TBoolOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TBoolOp.Execute;
           Var a:ILangValue;
           begin
             inherited Execute(e);
             a:=TVarLangValue.Create(nil);
             a.AsBoolean:=e.Code.Elements[e.IP]<>0;
             e.Data.Push(a);
             inc(e.IP,SIzeof(Byte));
           end;
//Execution flow operations
//ocHalt   =-41;
type THaltOp=class(TObjOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure THaltOp.Execute;
           begin
             e.IsEnd:=true;
           end;
//ocJZ     =-42;
type TJZOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TJZOp.Execute;
           Var a:ILangValue;
           begin
             Inherited Execute(e);
             a:=e.Data.Pop;
             if a.AsBoolean then
             begin
               e.IP:=e.Code.Int[e.IP];
             end
             else
               e.IP:=e.IP+SizeOf(Integer);
           end;

//ocJNZ    =-43;
type TJNZOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TJNZOp.Execute;
           Var a:ILangValue;
           begin
             Inherited Execute(e);
             a:=e.Data.Pop;
             if not a.AsBoolean then
             begin
               e.IP:=e.Code.Int[e.IP];
             end
             else
               e.IP:=e.IP+SizeOf(Integer);
             a.Free;
           end;
//ocJMP    =-44;
type TJMPOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TJMPOp.Execute;
           begin
             Inherited Execute(e);
             e.IP:=e.Code.Int[e.IP];
           end;
//ocJRZ
type TJRZOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TJRZOp.Execute;
           Var a:ILangValue;
           begin
             Inherited Execute(e);
             a:=e.Return.Pop;
             if not a.AsBoolean then
             begin
               e.IP:=e.Code.Int[e.IP];
             end
             else
               e.IP:=e.IP+SizeOf(Integer);
             e.Return.Push(a);
           end;
//ocDcrR
type TDcrROp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TDcrROp.Execute;
           Var a:ILangValue;
           begin
             Inherited Execute(e);
             a:=e.Return.Pop;
             a.AsInteger:=a.AsInteger-1;
             e.Return.Push(a);
           end;
//ocToR
type TToROp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TToROp.Execute;
           Var a:ILangValue;
           begin
             Inherited Execute(e);
             a:=e.Data.Pop;
             e.Return.Push(a);
           end;
//ocFromR
type TFromROp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TFromROp.Execute;
           Var a:ILangValue;
           begin
             Inherited Execute(e);
             a:=e.Return.Pop;
             e.Data.Push(a);
           end;
//ocRDrop
type TRDropOp=class(TNoOp)
     public
       procedure Execute(e:IExecution);override;
     end;
 procedure TRDropOp.Execute;
           Var a:ILangValue;
           begin
             Inherited Execute(e);
             a:=e.Return.Pop;
             a.Free;
           end;

procedure Register(a:TOpList);
          begin
            WIth a do
            begin
               Register(ocNop,TNoOp);
               //Arithmetic operations
               Register(ocAdd,TAddOp);
               Register(ocSub,TSubOp);
               Register(ocMul,TMulOp);
               Register(ocDiv,TDivOp);
               Register(ocNegate,TNegateOp);
               //Boolean operations
               Register(ocAnd,TAndOp);
               Register(ocOr,TOrOp);
               Register(ocNot,TNotOp);
               Register(ocEqu,TEquOp);
               Register(ocNE,TNEOp);
               Register(ocG,TGOp);
               Register(ocL,TLOp);
               Register(ocLE,TLEOp);
               Register(ocGE,TGEOp);
           //Value operations
               Register(ocGet,TGetOp);
               Register(ocSet,TSetOp);
               Register(ocExec,TExecOp);
               Register(ocEval,TEvalOp);
               Register(ocGetElem,TGetElemOp);
               Register(ocRoot,TRootOp);
               //Constant operations
               Register(ocStr,TStrOp);
               Register(ocFloat,TFloatOp);
               Register(ocInt,TIntOp);
               Register(ocBool,TBoolOp);
               //Execution flow operations
               Register(ocHalt,THaltOp);
               Register(ocJZ,TJZOp);
               Register(ocJMP,TJMPOp);
               Register(ocJNZ,TJNZOp);
               Register(ocJRZ,TJRZOp);
               Register(ocDcrR,TDcrROp);
               Register(ocToR,TToROp);
               {Moves value from return stack to data stack}
               Register(ocFromR,TFromROp);
               {Drops value from reaturn stack}
               Register(ocRDrop,TRDropOp);
            end;
          end;
end.