HardwareClass.pas

   1 unit HardwareClass;
   2
   3 interface
   4
   5 uses
   6   ConstantsClass, FunctionsClass, PrefixTreeClass, ResourcesClass, TypesClass;
   7
   8 type
   9
  10   TInstruction = class;
  11
  12   { THardwareState }
  13
  14   THardware = class
  15   private
  16     pAddress, pMaxAddress: Integer;
  17     pError: String;
  18     pInstructions, pOperands: TPrefixTree;
  19     pOldState, pState: THardwareState;
  20     pOnOperand, pOnState: TChangeEvent;
  21     function pErrorSet: Boolean; virtual;
  22     function pInstFromName(Name: String; var Care: Boolean): TInstruction; virtual;
  23     function pOperandAt(Input: String; Position: Integer): TOperandType; virtual;
  24     function pOperandToType(Input: String): TOperandType; virtual;
  25     function pParseInstr(var Input: String; InType: Integer): TStrings; virtual;
  26     function pParseOperand(Input: String): TStrings; virtual;
  27     function pTranslateOperands(Input: String): String; virtual;
  28     function pTranslateInput(Input: TStrings; var Tree: TPrefixTree; var Position: Integer): Boolean; virtual;
  29     function pTypeToDesc(Input: TOperandType): TStrings; virtual;
  30     function pTypeToOperands(Input: TOperandType): TStrings; virtual;
  31     function pTStringsToInst(Input: TStrings; Last: Integer): String; virtual;
  32     procedure pAddOperandByRecord(Input: POperandRecord); virtual;
  33     procedure pSetError(Input: String = GLOB_NO_ERROR; Description: String = ''); virtual;
  34     procedure pSetState(Input: THardwareState); virtual;
  35   public
  36     constructor Create; virtual;
  37     function DescriptionsByPrefix(Prefix: String): TStrings; virtual;
  38     function InstructionByName(Name: String): TInstruction; virtual;
  39     function InstructionsByPrefix(Prefix: String): TStrings; virtual;
  40     function OperandAdd(Operand: String): Boolean; virtual;
  41     function OperandRemove(Operand: String): Boolean; virtual;
  42     function ValidateInstruction(Instruction: TInstruction): Boolean; overload; virtual;
  43     function ValidateInstruction(Name: String): Boolean; overload; virtual;
  44     function ValidateOperand(Operand: String): Boolean; virtual;
  45     procedure InitializeState; virtual;
  46     procedure InitializeOperands; virtual;
  47     destructor Destroy; override;
  48     property LastError: String read pError;
  49     property Address: Integer read pAddress write pAddress default 0;
  50     property MaxAddress: Integer read pMaxAddress write pMaxAddress default 0;
  51     property OldState: THardwareState read pOldState write pOldState;
  52     property OnOperand: TChangeEvent read pOnOperand write pOnOperand;
  53     property OnState: TChangeEvent read pOnState write pOnState;
  54     property Operands: TPrefixTree read pOperands;
  55     property State: THardwareState read pState write pSetState;
  56   end;
  57
  58   { TInstruction }
  59
  60   TInstruction = class
  61   private
  62     pHardware: THardware;
  63     pName, pCode, pDescription: String;
  64     pBranch: TBranchType;
  65     pAddr: String;
  66     function pGetCode: String;
  67     procedure pSetCode(Code: String);
  68   public
  69     constructor Create; virtual;
  70     function Execute: Boolean; virtual;
  71     property Hardware: THardware read pHardware write pHardware;
  72     property Name: String read pName write pName;
  73     property Code: String read pGetCode write pSetCode;
  74     property Branch: TBranchType read pBranch write pBranch;
  75     property BranchAddress: String read pAddr write pAddr;
  76     property Description: String read pDescription write pDescription;
  77   end;
  78
  79   { Static Functions }
  80
  81   function CompareStateCondition(Hardware: THardware; Position: Integer): Boolean;
  82   function CompareStateException(Hardware: THardware; Position: Integer): Boolean;
  83   function CompareStateFlag(Hardware: THardware; Position: Integer): Boolean;
  84   function CompareStateMask(Hardware: THardware; Position: Integer): Boolean;
  85   function CompareStatePrecision(Hardware: THardware): Boolean;
  86   function CompareStateRound(Hardware: THardware): Boolean;
  87   function CompareStateStack(Hardware: THardware; Position: Integer): Boolean;
  88   function CompareStateTag(Hardware: THardware; Position: Integer): Boolean;
  89   function GetCondition(State: THardwareState; Position: Integer): Boolean;
  90   function GetException(State: THardwareState; Position: Integer): Boolean;
  91   function GetFlag(State: THardwareState; Position: Integer): Boolean;
  92   function GetMask(State: THardwareState; Position: Integer): Boolean;
  93   function GetPrecision(State: THardwareState): Integer;
  94   function GetRound(State: THardwareState): Integer;
  95   function GetTag(State: THardwareState; Position: Integer): Integer;
  96   procedure SetCondition(var State: THardwareState; Position: Integer; Condition: Boolean);
  97   procedure SetException(var State: THardwareState; Position: Integer; Exception: Boolean);
  98   procedure SetFlag(var State: THardwareState; Position: Integer; Flag: Boolean);
  99   procedure SetMask(var State: THardwareState; Position: Integer; Mask: Boolean);
 100   procedure SetPrecision(var State: THardwareState; Precision: Integer);
 101   procedure SetRound(var State: THardwareState; Round: Integer);
 102   procedure SetTag(var State: THardwareState; Position, Tag: Integer);
 103
 104 implementation
 105
 106 // ************************************************************************** //
 107 // *                     THardwareState implementation                      * //
 108 // ************************************************************************** //
 109
 110   function THardware.pErrorSet: Boolean;
 111   begin
 112     Result := not(pError = GLOB_NO_ERROR);
 113   end;
 114
 115   function THardware.pInstFromName(Name: String; var Care: Boolean
 116     ): TInstruction;
 117   var
 118     i, llength: Integer;
 119     lstrings: TStrings;
 120     lcode: String;
 121     ltree: TPrefixTree;
 122     linst: PInstructionRecord;
 123     loper: POperandRecord;
 124     lcare: Boolean;
 125   begin
 126     lcare := Care;
 127     Care := False;
 128     pSetError;
 129     Result := nil;
 130     lstrings := pParseInstr(Name, INTYPE_INSTRUCTION);
 131     if pErrorSet then Exit;
 132     i := 0;
 133     while pTranslateInput(lstrings, ltree, i) do;
 134     if pErrorSet then Exit;
 135     if lcare then
 136     begin
 137       linst :=  PInstructionrecord(ltree.Data);
 138       Result := TInstruction.Create;
 139       Result.Name := Name;
 140       Result.Code := linst^.Code;
 141       Result.Description := linst^.Description;
 142       Result.Branch := linst^.Branch;
 143       Result.Hardware := Self;
 144       for i := 1 to (Length(lstrings) - 1) do
 145       begin
 146         if IsAddress(lstrings[i]) then
 147         begin
 148           if (Result.Branch = BRANCH_BRANCH) then
 149             Result.BranchAddress := lstrings[i];
 150           Continue;
 151         end;
 152         ltree := pOperands.GetDescendant(lstrings[i]);
 153         loper := POperandRecord(ltree.Data);
 154         lcode := loper^.Code;
 155         llength := Length(Result.Code);
 156         if (llength > 0) and (Length(lcode) > 0) then
 157         begin
 158           lcode[1] := Chr(Ord(lcode[1]) xor Ord(Result.Code[llength]));
 159           Result.Code := RemoveCharacter(Result.Code);
 160         end;
 161         Result.Code := Result.Code + lcode;
 162       end;
 163     end;
 164     Care := True;
 165   end;
 166
 167
 168   function THardware.pOperandAt(Input: String; Position: Integer): TOperandType;
 169   var
 170     i: Integer;
 171   begin
 172     Result := #0;
 173     if not(Position > 0) then Exit;
 174     for i := 1 to Length(Input) do
 175     begin
 176       if (Position = 0) then
 177       begin
 178         Result := Input[i];
 179         Break;
 180       end;
 181       if (Input[i] = FPU_SPACE) then Position := Position - 1;
 182     end;
 183   end;
 184
 185   function THardware.pOperandToType(Input: String): TOperandType;
 186   var
 187     ltree: TPrefixTree;
 188   begin
 189     if IsAddress(Input) then
 190     begin
 191       Result := FPU_OPERAND_ADDR;
 192       Exit;
 193     end;
 194     ltree := pOperands.GetDescendant(Input);
 195     if ValidPrefixTree(ltree) then
 196       Result := POperandRecord(ltree.Data)^.OperandType
 197     else
 198     begin
 199       pSetError(INST_OPER_UNKNOWN, Input);
 200       Result := FPU_OPERAND_ERROR;
 201     end;
 202   end;
 203
 204   function THardware.pParseInstr(var Input: String; InType: Integer): TStrings;
 205   var
 206     lname: String;
 207     lspace: Boolean;
 208     i: Integer;
 209   begin
 210     SetLength(Result, 1);
 211     Result[0] := '';
 212     if (Input = '') then
 213     begin
 214       pSetError(INST_NONE);
 215       Exit;
 216     end;
 217     lspace := (Input[Length(Input)] = ' ');
 218     if not(InType = INTYPE_DESCRIPTION) then
 219       for i := 1 to Length(Input) do
 220         if (Input[i] in CHARS_CONTROL) then
 221         begin
 222           pSetError(INST_CHAR_INVALID, Input[i]);
 223           Exit;
 224         end;
 225     Input := TrimCharacter(Input, ' ');
 226     Input := OmmitEverywhere(Input, '(', ' ');
 227     Input := OmmitEverywhere(Input, ')', ' ');
 228     Input := OmmitEverywhere(Input, ',', ' ');
 229     Input := NeutralizeDoubles(Input, ' ');
 230     Input := UpperCase(Input);
 231     if (Input = '') then
 232     begin
 233       pSetError(INST_NONE);
 234       Exit;
 235     end;
 236     lname := Input;
 237     Result := MergeStringTStrings(
 238                 lname, ParseToStrings(PChar(ParseFirst(lname, ' ')), ','));
 239     if ((Intype = INTYPE_DESCRIPTION) or (InType = INTYPE_PREFIX)) and
 240       (Length(Result) = 1) and lspace then
 241       Result := MergeTStringsString(Result, '');
 242   end;
 243
 244   function THardware.pParseOperand(Input: String): TStrings;
 245   var
 246     i: Integer;
 247   begin
 248     Input := TrimCharacter(Input, ' ');
 249     Input := OmmitEverywhere(Input, OPER_SEP, ' ');
 250     Input := UpperCase(Input);
 251     SetLength(Result, 2);
 252     Result := ParseToStrings(PChar(Input), OPER_SEP);
 253     if not(Length(Result) = 2) then
 254     begin
 255       pSetError(INST_OPER_TYPE_INVALID, Input);
 256       Exit;
 257     end;
 258     for i := 0 to (Length(Result[0]) - 1) do
 259       if (Result[0][i] in CHARS_CONTROL) then
 260       begin
 261         pSetError(INST_CHAR_INVALID, Result[0][i]);
 262         Exit;
 263       end;
 264     if ValidPrefixTree(pOperands.GetDescendant(Result[0])) then
 265     begin
 266       pSetError(INST_OPER_NAME_EXISTS, Result[0]);
 267       Exit;
 268     end;
 269     for i := 0 to (Length(sOperandOrdinals) - 1) do
 270       if (sOperandOrdinals[i].Name = Result[1]) then Exit;
 271     pSetError(INST_OPER_TYPE_UNKNOWN, Result[1]);
 272   end;
 273
 274   function THardware.pTranslateOperands(Input: String): String;
 275   var
 276     i: Integer;
 277     ltype: TOperandType;
 278   begin
 279     Result := ParseBeforeFirst(Input, FPU_SPACE);
 280     i := 1;
 281     ltype := pOperandAt(Input, i);
 282     if not(ltype = #0) then Result := Result + ' ' + pTypeToDesc(ltype)[0];
 283     repeat
 284       i := i + 1;
 285       ltype := pOperandAt(Input, i);
 286       if (ltype = #0) then Break;
 287       Result := Result + ',' + pTypeToDesc(ltype)[0];
 288     until False;
 289   end;
 290
 291   function THardware.pTranslateInput(Input: TStrings; var Tree: TPrefixTree;
 292     var Position: Integer): Boolean;
 293   var
 294     ltype: TOperandType;
 295     ltree: TPrefixTree;
 296   begin
 297     Result := False;
 298     if not(Length(Input) > 0) then Exit;
 299     if (Position < 0) then Exit;
 300     if (Position = 0) then
 301     begin
 302       ltree := pInstructions;
 303       Tree := ltree;
 304     end
 305     else ltree := Tree;
 306     if (Position = Length(Input)) then
 307     begin
 308       if not ValidPrefixTree(ltree) then
 309       begin
 310         pSetError(INST_OPER_NOT_ENOUGH);
 311         Exit;
 312       end;
 313       Position := Position + 1;
 314     end;
 315     if not(Position < Length(Input)) then Exit;
 316     if (ltree = nil) then Exit;
 317     if ValidPrefixTree(ltree) and (Length(ltree.GetAllDescendants) = 1) then
 318     begin
 319       pSetError(INST_OPER_TOO_MANY);
 320       Exit;
 321     end;
 322     if not(Position = 0) then
 323     begin
 324       ltype := pOperandToType(Input[Position]);
 325       if (ltype = FPU_OPERAND_ERROR) then
 326       begin
 327         pSetError(INST_OPER_UNKNOWN, Input[Position]);
 328         Exit;
 329       end;
 330       if (Position = 1) then ltree := ltree.GetDescendant(ltype)
 331       else ltree := ltree.GetDescendant(FPU_SPACE + ltype);
 332       if (ltree = nil) then
 333       begin
 334         pSetError(INST_OPER_INVALID);
 335         Exit;
 336       end;
 337     end
 338     else
 339     begin
 340       ltree := ltree.GetDescendant(Input[0] + FPU_SPACE);
 341       if (ltree = nil) then
 342       begin
 343         pSetError(INST_INST_UNKNOWN, Input[0]);
 344         Exit;
 345       end;
 346       if (Length(Input) = 1) then
 347       begin
 348         ltree := ltree.GetDescendant(FPU_OPERAND_NONE);
 349         if not ValidPrefixTree(ltree) then
 350         begin
 351           pSetError(INST_OPER_NOT_ENOUGH);
 352           Exit;
 353         end;
 354       end;
 355     end;
 356     Position := Position + 1;
 357     Tree := ltree;
 358     Result := True;
 359   end;
 360
 361   function THardware.pTypeToDesc(Input: TOperandType): TStrings;
 362   var
 363     i: Integer;
 364   begin
 365     SetLength(Result, 1);
 366     Result[0] := '<' + sOperandTypes[0].Description + '>';
 367     for i := 1 to (Length(sOperandTypes) - 1) do
 368       if (sOperandTypes[i].OperandType = Input) then
 369       begin
 370         Result[0] := '<' + sOperandTypes[i].Description + '>';
 371         Break;
 372       end;
 373   end;
 374
 375   function THardware.pTypeToOperands(Input: TOperandType): TStrings;
 376   var
 377     i: Integer;
 378     ltrees: TPrefixTrees;
 379     loperand: POperandRecord;
 380   begin
 381     SetLength(Result, 0);
 382     ltrees := pOperands.GetAllDescendants;
 383     for i := 0 to (Length(ltrees) - 1) do
 384     begin
 385       loperand := POperandRecord(ltrees[i].Data);
 386       if (loperand^.OperandType = Input) then
 387         Result := MergeTStringsString(Result, loperand^.Name);
 388     end;
 389     if (Input = FPU_OPERAND_ADDR) then Result := MergeTStringsString(Result,
 390       '<0 - ' + ZeroPaddedInteger(MaxAddress) + '>');
 391     if (Length(Result) = 0) then pSetError(INST_OPER_UNKNOWN);
 392   end;
 393
 394   function THardware.pTStringsToInst(Input: TStrings; Last: Integer): String;
 395   var
 396     i: Integer;
 397   begin
 398     Result := '';
 399     if not(Length(Input) > 0) then Exit;
 400     if not(Last < Length(Input)) then Exit;
 401     Result := Input[0];
 402     if (Last < 0) then Exit;
 403     Result := Result + ' ';
 404     for i := 1 to Last do
 405       if not(Input[i] = '') then
 406         Result := Result + Input[i] + ',';
 407   end;
 408
 409   procedure THardware.pAddOperandByRecord(Input: POperandRecord);
 410   begin
 411     if not(Input^.Default = '') then
 412     with Input^ do
 413     begin
 414       Data := GetMemory(Length(Default));
 415       Move(PChar(Default)[0], Data^, Length(Default));
 416       Code := Code + AddressToString(Data);
 417     end;
 418     pOperands.Add(Input^.Name, Input);
 419   end;
 420
 421   procedure THardware.pSetError(Input, Description: String);
 422   begin
 423     pError := Input;
 424     if not(Description = '') then pError := pError + ': "' + Description + '"';
 425   end;
 426
 427   procedure THardware.pSetState(Input: THardwareState);
 428   begin
 429     pState := Input;
 430     if not(@OnState = nil) then OnState(Self);
 431   end;
 432
 433   constructor THardware.Create;
 434   var
 435     i: Integer;
 436   begin
 437     pSetError;
 438     InitializeState;
 439     pInstructions := TPrefixTree.Create;
 440     for i := 0 to (Length(sInstructions) - 1) do
 441       pInstructions.Add(sInstructions[i].Name, @sInstructions[i]);
 442     InitializeOperands;
 443   end;
 444
 445   function THardware.DescriptionsByPrefix(Prefix: String): TStrings;
 446   var
 447     i, j, lpos: Integer;
 448     linst: PInstructionRecord;
 449     linstructions, lnames, lstrings: TStrings;
 450     lname: String;
 451     ltree: TPrefixTree;
 452     ltrees: TPrefixTrees;
 453   begin
 454     SetLength(Result, 0);
 455     SetLength(lnames, 0);
 456     SetLength(lstrings, 0);
 457     SetLength(ltrees, 0);
 458     linstructions := InstructionsByPrefix(Prefix);
 459     for i := 0 to (Length(linstructions) - 1) do
 460     begin
 461       lstrings := pParseInstr(linstructions[i], INTYPE_DESCRIPTION);
 462       lpos := 0;
 463       while pTranslateInput(lstrings, ltree, lpos) do;
 464       ltrees := ltree.GetAllDescendants;
 465       for j := 0 to (Length(ltrees) - 1) do
 466       begin
 467         lname := PInstructionRecord(ltrees[j].Data)^.Name;
 468         lnames := RemoveExactString(lnames, lname);
 469         lnames := MergeTStringsString(lnames, lname);
 470       end;
 471     end;
 472     for i := 0 to (Length(lnames) - 1) do
 473     begin
 474       linst := PInstructionRecord(pInstructions.GetDescendant(lnames[i]).Data);
 475       lname := pTranslateOperands(linst^.Name) + ' - ' + linst^.Description;
 476       RemoveExactString(Result, lname);
 477       Result := MergeTStringsString(Result, lname);
 478     end;
 479     pSetError;
 480   end;
 481
 482   function THardware.InstructionByName(Name: String): TInstruction;
 483   var
 484     lcare: Boolean;
 485   begin
 486     lcare := True;
 487     Result := pInstFromName(Name, lcare);
 488   end;
 489
 490   function THardware.InstructionsByPrefix(Prefix: String): TStrings;
 491   var
 492     i, j, lpos: Integer;
 493     lstrings, loperands: TStrings;
 494     lprefix, lopers: String;
 495     ltree: TPrefixTree;
 496     ltrees: TPrefixTrees;
 497     linst: PInstructionRecord;
 498   begin
 499     try
 500       SetLength(Result, 0);
 501       SetLength(loperands, 0);
 502       SetLength(ltrees, 0);
 503       lstrings := pParseInstr(Prefix, INTYPE_PREFIX);
 504       if not(lstrings[Length(lstrings)] = '') then
 505         lstrings[Length(lstrings) - 1] := '';
 506       lpos := 0;
 507       while pTranslateInput(lstrings, ltree, lpos) do;
 508       if (lpos = 0) and (Length(lstrings) > 1) then Exit;
 509       ltrees := ltree.GetAllDescendants;
 510       lprefix := pTStringsToInst(lstrings, lpos - 1);
 511       for i := 0 to (Length(ltrees) - 1) do
 512       begin
 513         linst := PInstructionRecord(ltrees[i].Data);
 514         if (lpos = 0) then
 515         begin
 516           if IsPrefixOf(Prefix, linst^.Name) then
 517           begin
 518             lopers := ParseBeforeFirst(linst^.Name, FPU_SPACE) + ' ';
 519             Result := RemoveExactString(Result, lopers);
 520             Result := MergeTStringsString(Result, lopers);
 521           end;
 522         end
 523         else
 524         begin
 525           loperands := pTypeToOperands(pOperandAt(linst^.Name, lpos));
 526           if (Length(loperands) = 0) then
 527             loperands := pTypeToDesc(pOperandAt(linst^.Name, lpos));
 528           loperands := CartesianOfStrings(lprefix, loperands);
 529           for j := 0 to (Length(loperands) - 1) do
 530             if IsPrefixOf(Prefix, loperands[j]) then
 531             begin
 532               if not(pOperandAt(linst^.Name, lpos + 1) = #0) then
 533                 loperands[j] := loperands[j] + ',';
 534               Result := RemoveExactString(Result, loperands[j]);
 535               Result := MergeTStringsString(Result, loperands[j]);
 536           end;
 537         end;
 538       end;
 539     finally
 540       pSetError;
 541     end;
 542   end;
 543
 544   function THardware.OperandAdd(Operand: String): Boolean;
 545   var
 546     i: Integer;
 547     lstrings: TStrings;
 548     lrecord: POperandRecord;
 549   begin
 550     pSetError;
 551     Result := False;
 552     lstrings := pParseOperand(Operand);
 553     if pErrorSet then Exit;
 554     for i := 0 to (Length(sOperandOrdinals) - 1) do
 555       with sOperandOrdinals[i] do
 556       if (Name = lstrings[1]) and not(Default = '') then
 557       begin
 558         New(lrecord);
 559         lrecord^ := sOperandOrdinals[i];
 560         lrecord^.Name := lstrings[0];
 561         pAddOperandByRecord(lrecord);
 562         Result := True;
 563         Break;
 564       end;
 565     if Result and not(@OnOperand = nil) then OnOperand(Self);
 566   end;
 567
 568   function THardware.OperandRemove(Operand: String): Boolean;
 569   var
 570     i: Integer;
 571     ltree: TPrefixTree;
 572   begin
 573     pSetError;
 574     Result := False;
 575     Operand := UpperCase(TrimCharacter(Operand, ' '));
 576     for i := 0 to (Length(Operand) - 1) do
 577       if (Operand[i] in CHARS_CONTROL) then
 578       begin
 579         pSetError(INST_CHAR_INVALID, Operand[i]);
 580         Exit;
 581       end;
 582     ltree := pOperands.GetDescendant(Operand);
 583     if ValidPrefixTree(ltree) then
 584     begin
 585       Dispose(POperandRecord(ltree.Data));
 586       pOperands.Remove(Operand);
 587       Result := True;
 588     end
 589     else
 590       pSetError(INST_OPER_NAME_UNKNOWN, Operand);
 591     if Result and not(@OnOperand = nil) then OnOperand(Self);
 592   end;
 593
 594   function THardware.ValidateInstruction(Instruction: TInstruction): Boolean;
 595   var
 596     linst: TInstruction;
 597   begin
 598     Result := ValidateInstruction(Instruction.Name);
 599     if Result then
 600     begin
 601       linst := InstructionByName(Instruction.Name);
 602       if not(Instruction.Code = linst.Code) then Instruction.Code := linst.Code;
 603       linst.Free;
 604     end;
 605   end;
 606
 607   function THardware.ValidateInstruction(Name: String): Boolean;
 608   var
 609     lcare: Boolean;
 610   begin
 611     lcare := False;
 612     pInstFromName(Name, lcare);
 613     Result := lcare;
 614   end;
 615
 616   function THardware.ValidateOperand(Operand: String): Boolean;
 617   begin
 618     pSetError;
 619     pParseOperand(Operand);
 620     Result := not pErrorSet;
 621   end;
 622
 623   procedure THardware.InitializeState;
 624   var
 625     ldummy: TFPUState;
 626     lstate: THardwareState;
 627     i: Integer;
 628   begin
 629     asm
 630       fnsave [ldummy]
 631       fnsave [lstate.FPUState]
 632       frstor [ldummy]
 633       pushfd
 634       pop dword ptr [lstate.EFlags]
 635     end;
 636     lstate.Reg_EAX := 0;
 637     for i := 0 to 7 do
 638       lstate.FPUState.ST[i] := 0;
 639     State := lstate;
 640     OldState := lstate;
 641   end;
 642
 643   procedure THardware.InitializeOperands;
 644   var
 645     i: Integer;
 646   begin
 647     pOperands.Free;
 648     pOperands := TPrefixTree.Create;
 649     for i := 0 to (Length(sOperands) - 1) do
 650       pAddOperandByRecord(@sOperands[i]);
 651     if not(@OnOperand = nil) then OnOperand(Self);
 652   end;
 653
 654   destructor THardware.Destroy;
 655   begin
 656     pInstructions.Free;
 657     pOperands.Free;
 658   end;
 659
 660 // ************************************************************************** //
 661 // *                     TInstruction implementation                        * //
 662 // ************************************************************************** //
 663
 664   function TInstruction.pGetCode: String;
 665   begin
 666     Result := RemoveCharacter(pCode);
 667   end;
 668
 669   procedure TInstruction.pSetCode(Code: String);
 670   begin
 671     pCode := Code + INST_OPCODE_RET;
 672   end;
 673
 674   constructor TInstruction.Create;
 675   begin
 676     Name := '';
 677     Code := '';
 678     Description := '';
 679     Branch := BRANCH_NORMAL;
 680   end;
 681
 682   function TInstruction.Execute: Boolean;
 683   var
 684     lstate: THardwareState;
 685   begin
 686     if (Branch = BRANCH_UNSUPPORTED) then
 687     begin
 688       Result := False;
 689       LogWrite(INST_INST_UNSUPPORTED, True);
 690       Exit;
 691     end;
 692     lstate := pHardware.State;
 693     asm
 694       push 0
 695       push offset @return
 696       mov eax, Self
 697       push [TInstruction(eax).pCode]
 698       frstor [lstate.FPUState]
 699       push dword ptr [lstate.EFlags]
 700       push dword ptr [lstate.Reg_EAX]
 701       pop eax
 702       popfd
 703       ret
 704       @return:
 705       pushfd
 706       push eax
 707       pop dword ptr [lstate.Reg_EAX]
 708       pop dword ptr [lstate.EFlags]
 709       fnsave [lstate.FPUState]
 710       pop eax
 711       mov Result, al
 712     end;
 713     pHardware.OldState := pHardware.State;
 714     pHardware.State := lstate;
 715   end;
 716
 717 // ************************************************************************** //
 718 // *                     Static Functions implementation                    * //
 719 // ************************************************************************** //
 720
 721   function CompareStateCondition(Hardware: THardware; Position: Integer
 722     ): Boolean;
 723   var
 724     lcondition: Boolean;
 725   begin
 726     lcondition := GetCondition(Hardware.State, Position);
 727     Result := (lcondition = GetCondition(Hardware.pOldState, Position));
 728   end;
 729
 730   function CompareStateException(Hardware: THardware; Position: Integer
 731     ): Boolean;
 732   var
 733     lexception: Boolean;
 734   begin
 735     lexception := GetException(Hardware.State, Position);
 736     Result := (lexception = GetException(Hardware.OldState, Position));
 737   end;
 738
 739   function CompareStateFlag(Hardware: THardware; Position: Integer): Boolean;
 740   begin
 741     with Hardware do
 742       Result := (GetFlag(State, Position) = GetFlag(pOldState, Position));
 743   end;
 744
 745   function CompareStateMask(Hardware: THardware; Position: Integer): Boolean;
 746   var
 747     lexception: Boolean;
 748   begin
 749     lexception := GetMask(Hardware.State, Position);
 750     Result := (lexception = GetMask(Hardware.OldState, Position));
 751   end;
 752
 753   function CompareStatePrecision(Hardware: THardware): Boolean;
 754   var
 755     lprecision: Integer;
 756   begin
 757     lprecision := GetPrecision(Hardware.State);
 758     Result := (lprecision = GetPrecision(Hardware.OldState));
 759   end;
 760
 761   function CompareStateRound(Hardware: THardware): Boolean;
 762   begin
 763     Result := (GetRound(Hardware.State) = GetRound(Hardware.OldState));
 764   end;
 765
 766   function CompareStateStack(Hardware: THardware; Position: Integer): Boolean;
 767   var
 768     lsecond: PChar;
 769   begin
 770     Result := False;
 771     if (Position < 0) or (Position > 7) then Exit;
 772     lsecond := @Hardware.OldState.FPUState.ST[Position];
 773     with Hardware.State.FPUState do
 774       Result := StringCompare(@ST[Position], lsecond, SizeOf(ST[Position]));
 775   end;
 776
 777   function CompareStateTag(Hardware: THardware; Position: Integer): Boolean;
 778   var
 779     ltag: Integer;
 780   begin
 781     ltag := GetTag(Hardware.State, Position);
 782     Result := (ltag = GetTag(Hardware.OldState, Position));
 783   end;
 784
 785   function GetCondition(State: THardwareState; Position: Integer): Boolean;
 786   begin
 787     Result := False;
 788     if (Position < 0) or (Position > 3) then Exit;
 789     if (Position = 3) then Position := 14
 790     else Position := Position + 8;
 791     Result := not((State.FPUState.StatusWord and (1 shl Position)) = 0);
 792   end;
 793
 794   function GetException(State: THardwareState; Position: Integer): Boolean;
 795   begin
 796     Result := False;
 797     if (Position < 0) or (Position > 7) then Exit;
 798     Result := not((State.FPUState.StatusWord and (1 shl Position)) = 0);
 799   end;
 800
 801   function GetFlag(State: THardwareState; Position: Integer): Boolean;
 802   begin
 803     Result := False;
 804     if (Position < 0) or (Position > 2) then Exit;
 805     case Position of
 806       1: Position := 2;
 807       2: Position := 6;
 808     end;
 809     Result := not((State.EFlags and (1 shl Position)) = 0);
 810   end;
 811
 812   function GetMask(State: THardwareState; Position: Integer): Boolean;
 813   begin
 814     Result := False;
 815     if (Position < 0) or (Position > 5) then Exit;
 816     Result := not((State.FPUState.ControlWord and (1 shl Position)) = 0);
 817   end;
 818
 819   function GetPrecision(State: THardwareState): Integer;
 820   begin
 821     Result := (State.FPUState.ControlWord shr 8) and 3;
 822   end;
 823
 824   function GetRound(State: THardwareState): Integer;
 825   begin
 826     Result := (State.FPUState.ControlWord shr 10) and 3;
 827   end;
 828
 829   function GetTag(State: THardwareState; Position: Integer): Integer;
 830   var
 831     ltop: Integer;
 832   begin
 833     Result := -1;
 834     if (Position < 0) or (Position > 7) then Exit;
 835     with State.FPUState do
 836     begin
 837       ltop := (Position + ((StatusWord shr 11) and 7)) mod 8;
 838       Result := (TagWord shr (2 * ltop)) and 3;
 839     end;
 840   end;
 841
 842   procedure SetCondition(var State: THardwareState; Position: Integer;
 843     Condition: Boolean);
 844   begin
 845     if (Position < 0) or (Position > 7) then Exit;
 846     if (Position = 3) then Position := 14
 847     else Position := Position + 8;
 848     with State.FPUState do
 849       if Condition then StatusWord := StatusWord or (1 shl Position)
 850       else StatusWord := StatusWord and not(1 shl Position);
 851   end;
 852
 853   procedure SetException(var State: THardwareState; Position: Integer;
 854     Exception: Boolean);
 855   begin
 856     if (Position < 0) or (Position > 7) then Exit;
 857     with State.FPUState do
 858       if Exception then StatusWord := StatusWord or (1 shl Position)
 859       else StatusWord := StatusWord and not(1 shl Position);
 860   end;
 861
 862   procedure SetFlag(var State: THardwareState; Position: Integer; Flag: Boolean
 863     );
 864   begin
 865     if (Position < 0) or (Position > 2) then Exit;
 866     case Position of
 867       1: Position := 2;
 868       2: Position := 6;
 869     end;
 870     if Flag then State.EFlags := State.EFlags or (1 shl Position)
 871     else State.EFlags := State.EFlags and not(1 shl Position);
 872   end;
 873
 874   procedure SetMask(var State: THardwareState; Position: Integer; Mask: Boolean
 875     );
 876   begin
 877     if (Position < 0) or (Position > 5) then Exit;
 878     with State.FPUState do
 879       if Mask then ControlWord := ControlWord or (1 shl Position)
 880       else ControlWord := ControlWord and not(1 shl Position);
 881   end;
 882
 883   procedure SetPrecision(var State: THardwareState; Precision: Integer);
 884   var
 885     lcw: Word;
 886   begin
 887     if (Precision < 0) or (Precision > 3) then Exit;
 888     with State.FPUState do
 889     begin
 890       lcw := ControlWord and not(3 shl 8);
 891       ControlWord := lcw or (Precision shl 8);
 892     end;
 893   end;
 894
 895   procedure SetRound(var State: THardwareState; Round: Integer);
 896   var
 897     lcw: Word;
 898   begin
 899     if (Round < 0) or (Round > 3) then Exit;
 900     with State.FPUState do
 901     begin
 902       lcw := ControlWord and not(3 shl 10);
 903       ControlWord := lcw or (Round shl 10);
 904     end;
 905   end;
 906
 907   procedure SetTag(var State: THardwareState; Position, Tag: Integer);
 908   var
 909     ltop, ltag: Integer;
 910   begin
 911     if (Position < 0) or (Position > 7) or (Tag < 0) or (Tag > 3) then Exit;
 912     with State.FPUState do
 913     begin
 914       ltop := (Position + ((StatusWord shr 11) and 7)) mod 8;
 915       ltag := TagWord and not(3 shl (2 * ltop));
 916       TagWord := ltag or (Tag shl (2 * ltop));
 917     end;
 918   end;
 919 end.
 920