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     pOnState: TChangeEvent;
  21     function pErrorSet: Boolean; virtual;
  22     function pInstFromName(Name: String; var Care: Boolean): TInstruction; virtual;
  23     function pOperandAt(Input: String; Position: Integer): TOperand; virtual;
  24     function pOperandToType(Input: String): TOperand; virtual;
  25     function pParseInput(var Input: String; InType: Integer): TStrings; virtual;
  26     function pTranslateInput(Input: TStrings; var Tree: TPrefixTree; var Position: Integer): Boolean; virtual;
  27     function pTypeToDesc(Input: TOperand): TStrings; virtual;
  28     function pTypeToOperands(Input: TOperand): TStrings; virtual;
  29     function pTStringsToInst(Input: TStrings; Last: Integer): String; virtual;
  30     procedure pSetError(Input: String = GLOB_NO_ERROR; Description: String = ''); virtual;
  31     procedure pSetState(Input: THardwareState); virtual;
  32   public
  33     constructor Create; virtual;
  34     function InstructionByName(Name: String): TInstruction; virtual;
  35     function InstructionValidate(Name: String): Boolean; virtual;
  36     function InstructionsByPrefix(Prefix: String): TStrings; virtual;
  37     procedure InitializeState; virtual;
  38     destructor Destroy; override;
  39     property LastError: String read pError;
  40     property Address: Integer read pAddress write pAddress default 0;
  41     property MaxAddress: Integer read pMaxAddress write pMaxAddress default 0;
  42     property OldState: THardwareState read pOldState write pOldState;
  43     property OnState: TChangeEvent read pOnState write pOnState;
  44     property State: THardwareState read pState write pSetState;
  45   end;
  46
  47   { TInstruction }
  48
  49   TInstruction = class
  50   private
  51     pHardware: THardware;
  52     pName, pCode, pDescription: String;
  53     pBranch: TBranchType;
  54     pAddr: String;
  55     function pGetCode: String;
  56     procedure pSetCode(Code: String);
  57   public
  58     constructor Create; virtual;
  59     function Execute: Boolean; virtual;
  60     property HardwareState: THardware read pHardware write pHardware;
  61     property Name: String read pName write pName;
  62     property Code: String read pGetCode write pSetCode;
  63     property Branch: TBranchType read pBranch write pBranch;
  64     property BranchAddress: String read pAddr write pAddr;
  65     property Description: String read pDescription write pDescription;
  66   end;
  67
  68   { Static Functions }
  69
  70   function CompareStateException(Hardware: THardware; Position: Integer): Boolean;
  71   function CompareStateMask(Hardware: THardware; Position: Integer): Boolean;
  72   function CompareStateStack(Hardware: THardware; Position: Integer): Boolean;
  73   function CompareStateTag(Hardware: THardware; Position: Integer): Boolean;
  74   function GetException(State: THardwareState; Position: Integer): Boolean;
  75   function GetMask(State: THardwareState; Position: Integer): Boolean;
  76   function GetTag(State: THardwareState; Position: Integer): Integer;
  77
  78   procedure SetException(var State: THardwareState; Position: Integer; Exception: Boolean);
  79   procedure SetMask(var State: THardwareState; Position: Integer; Mask: Boolean);
  80   procedure SetTag(var State: THardwareState; Position, Tag: Integer);
  81
  82 implementation
  83
  84 // ************************************************************************** //
  85 // *                     THardwareState implementation                      * //
  86 // ************************************************************************** //
  87
  88   function THardware.pErrorSet: Boolean;
  89   begin
  90     Result := not(pError = GLOB_NO_ERROR);
  91   end;
  92
  93   function THardware.pInstFromName(Name: String; var Care: Boolean
  94     ): TInstruction;
  95   var
  96     i, llength: Integer;
  97     lstrings: TStrings;
  98     lcode: String;
  99     ltree: TPrefixTree;
 100     linst: PInstructionRecord;
 101     loper: POperandRecord;
 102     lcare: Boolean;
 103   begin
 104     lcare := Care;
 105     Care := False;
 106     pSetError;
 107     Result := nil;
 108     lstrings := pParseInput(Name, INTYPE_INSTRUCTION);
 109     if pErrorSet then Exit;
 110     i := 0;
 111     while pTranslateInput(lstrings, ltree, i) do;
 112     if pErrorSet then Exit;
 113     if lcare then
 114     begin
 115       linst :=  PInstructionrecord(ltree.Data);
 116       Result := TInstruction.Create;
 117       Result.Name := Name;
 118       Result.Code := linst^.Code;
 119       Result.Description := linst^.Description;
 120       Result.Branch := linst^.Branch;
 121       Result.HardwareState := Self;
 122       for i := 1 to (Length(lstrings) - 1) do
 123       begin
 124         if IsAddress(lstrings[i]) then
 125         begin
 126           if (Result.Branch = BRANCH_BRANCH) then
 127             Result.BranchAddress := lstrings[i];
 128           Continue;
 129         end;
 130         ltree := pOperands.GetDescendant(lstrings[i]);
 131         loper := POperandRecord(ltree.Data);
 132         lcode := loper^.Code;
 133         llength := Length(Result.Code);
 134         if (llength > 0) and (Length(lcode) > 0) then
 135         begin
 136           lcode[1] := Chr(Ord(lcode[1]) xor Ord(Result.Code[llength]));
 137           Result.Code := RemoveCharacter(Result.Code);
 138         end;
 139         Result.Code := Result.Code + lcode;
 140       end;
 141     end;
 142     Care := True;
 143   end;
 144
 145
 146   function THardware.pOperandAt(Input: String; Position: Integer): TOperand;
 147   var
 148     i: Integer;
 149   begin
 150     Result := #0;
 151     if not(Position > 0) then Exit;
 152     for i := 1 to Length(Input) do
 153     begin
 154       if (Position = 0) then
 155       begin
 156         Result := Input[i];
 157         Break;
 158       end;
 159       if (Input[i] = FPU_SPACE) then Position := Position - 1;
 160     end;
 161   end;
 162
 163   function THardware.pOperandToType(Input: String): TOperand;
 164   var
 165     ltree: TPrefixTree;
 166   begin
 167     if IsAddress(Input) then
 168     begin
 169       Result := FPU_OPERAND_ADDR;
 170       Exit;
 171     end;
 172     ltree := pOperands.GetDescendant(Input);
 173     if ValidPrefixTree(ltree) then
 174       Result := POperandRecord(ltree.Data)^.OperandType
 175     else
 176     begin
 177       pSetError(INST_OPER_UNKNOWN, Input);
 178       Result := FPU_OPERAND_ERROR;
 179     end;
 180   end;
 181
 182   function THardware.pParseInput(var Input: String; InType: Integer): TStrings;
 183   var
 184     lname: String;
 185     lspace: Boolean;
 186     i: Integer;
 187   begin
 188     SetLength(Result, 1);
 189     Result[0] := '';
 190     if (Input = '') then
 191     begin
 192       pSetError(INST_NONE);
 193       Exit;
 194     end;
 195     lspace := (Input[Length(Input)] = ' ');
 196     for i := 1 to Length(Input) do
 197       if (Input[i] in CHARS_CONTROL) then
 198       begin
 199         pSetError(INST_CHAR_INVALID, Input[i]);
 200         Exit;
 201       end;
 202     Input := TrimCharacter(Input, ' ');
 203     Input := OmmitEverywhere(Input, '(', ' ');
 204     Input := OmmitEverywhere(Input, ')', ' ');
 205     Input := OmmitEverywhere(Input, ',', ' ');
 206     Input := NeutralizeDoubles(Input, ' ');
 207     Input := UpperCase(Input);
 208     if (Input = '') then
 209     begin
 210       pSetError(INST_NONE);
 211       Exit;
 212     end;
 213     lname := Input;
 214     Result := MergeStringTStrings(
 215                 lname, ParseToStrings(PChar(ParseFirst(lname, ' ')), ','));
 216     if (InType = INTYPE_PREFIX) and (Length(Result) = 1) and lspace then
 217       Result := MergeTStringsString(Result, '');
 218   end;
 219
 220   function THardware.pTranslateInput(Input: TStrings; var Tree: TPrefixTree;
 221     var Position: Integer): Boolean;
 222   var
 223     ltype: TOperand;
 224     ltree: TPrefixTree;
 225   begin
 226     Result := False;
 227     if not(Length(Input) > 0) then Exit;
 228     if (Position < 0) then Exit;
 229     if (Position = 0) then
 230     begin
 231       ltree := pInstructions;
 232       Tree := ltree;
 233     end
 234     else ltree := Tree;
 235     if (Position = Length(Input)) then
 236     begin
 237       if not ValidPrefixTree(ltree) then
 238       begin
 239         pSetError(INST_OPER_NOT_ENOUGH);
 240         Exit;
 241       end;
 242       Position := Position + 1;
 243     end;
 244     if not(Position < Length(Input)) then Exit;
 245     if (ltree = nil) then Exit;
 246     if ValidPrefixTree(ltree) and (Length(ltree.GetAllDescendants) = 1) then
 247     begin
 248       pSetError(INST_OPER_TOO_MANY);
 249       Exit;
 250     end;
 251     if not(Position = 0) then
 252     begin
 253       ltype := pOperandToType(Input[Position]);
 254       if (ltype = FPU_OPERAND_ERROR) then
 255       begin
 256         pSetError(INST_OPER_UNKNOWN, Input[Position]);
 257         Exit;
 258       end;
 259       if (Position = 1) then ltree := ltree.GetDescendant(ltype)
 260       else ltree := ltree.GetDescendant(FPU_SPACE + ltype);
 261       if (ltree = nil) then
 262       begin
 263         pSetError(INST_OPER_INVALID);
 264         Exit;
 265       end;
 266     end
 267     else
 268     begin
 269       ltree := ltree.GetDescendant(Input[0] + FPU_SPACE);
 270       if (ltree = nil) then
 271       begin
 272         pSetError(INST_INST_UNKNOWN, Input[0]);
 273         Exit;
 274       end;
 275       if (Length(Input) = 1) then
 276       begin
 277         ltree := ltree.GetDescendant(FPU_OPERAND_NONE);
 278         if not ValidPrefixTree(ltree) then
 279         begin
 280           pSetError(INST_OPER_NOT_ENOUGH);
 281           Exit;
 282         end;
 283       end;
 284     end;
 285     Position := Position + 1;
 286     Tree := ltree;
 287     Result := True;
 288   end;
 289
 290   function THardware.pTypeToDesc(Input: TOperand): TStrings;
 291   var
 292     i: Integer;
 293   begin
 294     SetLength(Result, 1);
 295     Result[0] := sOperandTypes[0].Description;
 296     for i := 1 to (Length(sOperandTypes) - 1) do
 297       if (sOperandTypes[i].OperandType = Input) then
 298       begin
 299         Result[0] := sOperandTypes[i].Description;
 300         Break;
 301       end;
 302   end;
 303
 304   function THardware.pTypeToOperands(Input: TOperand): TStrings;
 305   var
 306     i: Integer;
 307     ltrees: TPrefixTrees;
 308     loperand: POperandRecord;
 309   begin
 310     SetLength(Result, 0);
 311     ltrees := pOperands.GetAllDescendants;
 312     for i := 0 to (Length(ltrees) - 1) do
 313     begin
 314       loperand := POperandRecord(ltrees[i].Data);
 315       if (loperand^.OperandType = Input) then
 316         Result := MergeTStringsString(Result, loperand^.Name);
 317     end;
 318     if (Input = FPU_OPERAND_ADDR) then Result := MergeTStringsString(Result,
 319       '<0 - ' + ZeroPaddedInteger(MaxAddress) + '>');
 320     if (Length(Result) = 0) then pSetError(INST_OPER_UNKNOWN);
 321   end;
 322
 323   function THardware.pTStringsToInst(Input: TStrings; Last: Integer): String;
 324   var
 325     i: Integer;
 326   begin
 327     Result := '';
 328     if not(Length(Input) > 0) then Exit;
 329     if not(Last < Length(Input)) then Exit;
 330     Result := Input[0];
 331     if (Last < 0) then Exit;
 332     Result := Result + ' ';
 333     for i := 1 to Last do
 334       if not(Input[i] = '') then
 335         Result := Result + Input[i] + ',';
 336   end;
 337
 338   procedure THardware.pSetError(Input, Description: String);
 339   begin
 340     pError := Input;
 341     if not(Description = '') then pError := pError + ': "' + Description + '"';
 342   end;
 343
 344   procedure THardware.pSetState(Input: THardwareState);
 345   begin
 346     pState := Input;
 347     if not(@OnState = nil) then OnState(Self);
 348   end;
 349
 350   constructor THardware.Create;
 351   var
 352     i: Integer;
 353   begin
 354     pSetError;
 355     InitializeState;
 356     pInstructions := TPrefixTree.Create;
 357     pOperands := TPrefixTree.Create;
 358     for i := 0 to (Length(sInstructions) - 1) do
 359       pInstructions.Add(sInstructions[i].Name, @sInstructions[i]);
 360     for i := 0 to (Length(sOperands) - 1) do
 361     begin
 362       if not(sOperands[i].Default = '') then
 363       with sOperands[i] do
 364       begin
 365         Data := GetMemory(Length(Default));
 366         Move(PChar(Default)[0], Data^, Length(Default));
 367         Code := Code + AddressToString(Data);
 368       end;
 369       pOperands.Add(sOperands[i].Name, @sOperands[i])
 370     end;
 371   end;
 372
 373   function THardware.InstructionValidate(Name: String): Boolean;
 374   var
 375     lcare: Boolean;
 376   begin
 377     lcare := False;
 378     pInstFromName(Name, lcare);
 379     Result := lcare;
 380   end;
 381
 382   function THardware.InstructionByName(Name: String): TInstruction;
 383   var
 384     lcare: Boolean;
 385   begin
 386     lcare := True;
 387     Result := pInstFromName(Name, lcare);
 388   end;
 389
 390   function THardware.InstructionsByPrefix(Prefix: String): TStrings;
 391   var
 392     i, j, lpos: Integer;
 393     lstrings, loperands: TStrings;
 394     lprefix, lopers: String;
 395     ltree: TPrefixTree;
 396     ltrees: TPrefixTrees;
 397     linst: PInstructionRecord;
 398   begin
 399     try
 400       SetLength(Result, 0);
 401       SetLength(loperands, 0);
 402       SetLength(ltrees, 0);
 403       lstrings := pParseInput(Prefix, INTYPE_PREFIX);
 404       if not(lstrings[Length(lstrings)] = '') then
 405         lstrings[Length(lstrings) - 1] := '';
 406       lpos := 0;
 407       while pTranslateInput(lstrings, ltree, lpos) do;
 408       if (lpos > Length(lstrings)) and (Length(ltree.GetAllDescendants) = 1) then
 409       begin
 410         Result := MergeTStringsString(Result, Prefix);
 411         pSetError;
 412         Exit;
 413       end;
 414       if (lpos = 0) and (Length(lstrings) > 1) then Exit;
 415       ltrees := ltree.GetAllDescendants;
 416       lprefix := pTStringsToInst(lstrings, lpos - 1);
 417       for i := 0 to (Length(ltrees) - 1) do
 418       begin
 419         linst := PInstructionRecord(ltrees[i].Data);
 420         if (lpos = 0) then
 421         begin
 422           if IsPrefixOf(Prefix, linst^.Name) then
 423           begin
 424             lopers := ParseBeforeFirst(linst^.Name, FPU_SPACE) + ' ';
 425             Result := RemoveExactString(Result, lopers);
 426             Result := MergeTStringsString(Result, lopers);
 427           end;
 428         end
 429         else
 430         begin
 431           loperands := pTypeToOperands(pOperandAt(linst^.Name, lpos));
 432           if (Length(loperands) = 0) then
 433             loperands := pTypeToDesc(pOperandAt(linst^.Name, lpos));
 434           loperands := CartesianOfStrings(lprefix, loperands);
 435           for j := 0 to (Length(loperands) - 1) do
 436             if IsPrefixOf(Prefix, loperands[j]) then
 437             begin
 438               if not(pOperandAt(linst^.Name, lpos + 1) = #0) then
 439                 loperands[j] := loperands[j] + ',';
 440               Result := RemoveExactString(Result, loperands[j]);
 441               Result := MergeTStringsString(Result, loperands[j]);
 442           end;
 443         end;
 444       end;
 445     finally
 446       pSetError;
 447     end;
 448   end;
 449
 450   procedure THardware.InitializeState;
 451   var
 452     ldummy: TFPUState;
 453     lstate: THardwareState;
 454     i: Integer;
 455   begin
 456     asm
 457       fnsave [ldummy]
 458       fnsave [lstate.FPUState]
 459       frstor [ldummy]
 460       pushfd
 461       pop dword ptr [lstate.EFlags]
 462     end;
 463     lstate.Reg_EAX := 0;
 464     for i := 0 to 7 do
 465       lstate.FPUState.ST[i] := 0;
 466     State := lstate;
 467     OldState := lstate;
 468   end;
 469
 470   destructor THardware.Destroy;
 471   begin
 472     pInstructions.Free;
 473     pOperands.Free;
 474   end;
 475
 476 // ************************************************************************** //
 477 // *                     TInstruction implementation                        * //
 478 // ************************************************************************** //
 479
 480   function TInstruction.pGetCode: String;
 481   begin
 482     Result := RemoveCharacter(pCode);
 483   end;
 484
 485   procedure TInstruction.pSetCode(Code: String);
 486   begin
 487     pCode := Code + INST_OPCODE_RET;
 488   end;
 489
 490   constructor TInstruction.Create;
 491   begin
 492     Name := '';
 493     Code := '';
 494     Description := '';
 495     Branch := BRANCH_NORMAL;
 496   end;
 497
 498   function TInstruction.Execute: Boolean;
 499   var
 500     lstate: THardwareState;
 501   begin
 502     if (Branch = BRANCH_UNSUPPORTED) then
 503     begin
 504       Result := False;
 505       Exit;
 506     end;
 507     lstate := pHardware.State;
 508     asm
 509       push 0
 510       push offset @return
 511       mov eax, Self
 512       push [TInstruction(eax).pCode]
 513       frstor [lstate.FPUState]
 514       push dword ptr [lstate.EFlags]
 515       push dword ptr [lstate.Reg_EAX]
 516       pop eax
 517       popfd
 518       ret
 519       @return:
 520       pushfd
 521       push eax
 522       pop dword ptr [lstate.Reg_EAX]
 523       pop dword ptr [lstate.EFlags]
 524       fnsave [lstate.FPUState]
 525       pop eax
 526       mov Result, al
 527     end;
 528     pHardware.OldState := pHardware.State;
 529     pHardware.State := lstate;
 530   end;
 531
 532 // ************************************************************************** //
 533 // *                     Static Functions implementation                    * //
 534 // ************************************************************************** //
 535
 536   function CompareStateException(Hardware: THardware; Position: Integer
 537     ): Boolean;
 538   var
 539     lexception: Boolean;
 540   begin
 541     lexception := GetException(Hardware.State, Position);
 542     Result := (lexception = GetException(Hardware.OldState, Position));
 543   end;
 544
 545   function CompareStateMask(Hardware: THardware; Position: Integer): Boolean;
 546   var
 547     lexception: Boolean;
 548   begin
 549     lexception := GetMask(Hardware.State, Position);
 550     Result := (lexception = GetMask(Hardware.OldState, Position));
 551   end;
 552
 553   function CompareStateStack(Hardware: THardware; Position: Integer): Boolean;
 554   var
 555     lsecond: PChar;
 556   begin
 557     Result := False;
 558     if (Position < 0) or (Position > 7) then Exit;
 559     lsecond := @Hardware.OldState.FPUState.ST[Position];
 560     with Hardware.State.FPUState do
 561       Result := StringCompare(@ST[Position], lsecond, SizeOf(ST[Position]));
 562   end;
 563
 564   function CompareStateTag(Hardware: THardware; Position: Integer): Boolean;
 565   var
 566     ltag: Integer;
 567   begin
 568     ltag := GetTag(Hardware.State, Position);
 569     Result := (ltag = GetTag(Hardware.OldState, Position));
 570   end;
 571
 572   function GetException(State: THardwareState; Position: Integer): Boolean;
 573   begin
 574     Result := False;
 575     if (Position < 0) or (Position > 7) then Exit;
 576     Result := not((State.FPUState.StatusWord and (1 shl Position)) = 0);
 577   end;
 578
 579   function GetMask(State: THardwareState; Position: Integer): Boolean;
 580   begin
 581     Result := False;
 582     if (Position < 0) or (Position > 5) then Exit;
 583     Result := not((State.FPUState.ControlWord and (1 shl Position)) = 0);
 584   end;
 585
 586   function GetTag(State: THardwareState; Position: Integer): Integer;
 587   var
 588     ltop: Integer;
 589   begin
 590     Result := -1;
 591     if (Position < 0) or (Position > 7) then Exit;
 592     with State.FPUState do
 593     begin
 594       ltop := (Position + ((StatusWord shr 11) and 7)) mod 8;
 595       Result := (TagWord shr (2 * ltop)) and 3;
 596     end;
 597   end;
 598
 599   procedure SetException(var State: THardwareState; Position: Integer;
 600     Exception: Boolean);
 601   begin
 602     if (Position < 0) or (Position > 7) then Exit;
 603     with State.FPUState do
 604       if Exception then StatusWord := StatusWord or (1 shl Position)
 605       else StatusWord := StatusWord and not(1 shl Position);
 606   end;
 607
 608   procedure SetMask(var State: THardwareState; Position: Integer; Mask: Boolean
 609     );
 610   begin
 611     if (Position < 0) or (Position > 5) then Exit;
 612     with State.FPUState do
 613       if Mask then ControlWord := ControlWord or (1 shl Position)
 614       else ControlWord := ControlWord and not(1 shl Position);
 615   end;
 616
 617   procedure SetTag(var State: THardwareState; Position, Tag: Integer);
 618   var
 619     ltop, ltag: Integer;
 620   begin
 621     if (Position < 0) or (Position > 7) or (Tag < 0) or (Tag > 3) then Exit;
 622     with State.FPUState do
 623     begin
 624       ltop := (Position + ((StatusWord shr 11) and 7)) mod 8;
 625       ltag := TagWord and not(3 shl (2 * ltop));
 626       TagWord := ltag or (Tag shl (2 * ltop));
 627     end;
 628   end;
 629 end.
 630