Merge branch 'builtin-innocallbackengine' into is-6

Components/ASMInline.pas

@@ -0,0 +1,1332 @@
+unit ASMInline;
+
+interface
+
+{ASM Inliner
+ Nicholas Sherlock
+
+ This is incomplete, I've only implemented enough to support InnoCallback.
+
+ Instructions are stored in a TMemoryStream internally
+
+ Instructions usually accept some combination of Registers, Immediates and
+ Memory References. Memory References can either be of the simple form [EAX]
+ (Where [EAX] is really a Delphi set), or the user can build the address with
+ the TASMInline.addr() function. It'd be nice to have a function which builds
+ the address from a string, too, allowing the more intuitive '[EAX+EBX*4+1000]'
+ style.
+
+ The generation of instruction-relative addresses generates Relocations, using
+ SaveToMemory() automatically rebases using the relocations to make these correct
+ in the final block of memory.
+
+  !!!! Not all special cases have been implemented in WriteRegRef().
+}
+
+uses Sysutils, windows, classes, contnrs;
+
+type
+  TModMode = (mmNaked, mmDeref, mmDisp8, mmDisp32);
+
+  TRegister32 = (EAX, EBX, ECX, EDX, ESP, EBP, ESI, EDI);
+  TRegister32Set = set of TRegister32;
+  TRegister16 = (AX, BX, CX, DX, SP, BP, SI, DI);
+  TRegister16Set = set of TRegister16;
+  TRegister8 = (AH, AL, BH, BL, CH, CL, DH, DL);
+
+  TCLRegister = CL..CL;
+
+  TMemSize = (ms8, ms16, ms32, ms64);
+
+  TMemoryAddress = record
+    size: TMemSize;
+    usebase: boolean;
+    base, index: TRegister32;
+    offset: integer;
+    scale: byte;
+  end;
+
+  EOperandSizeMismatch = class(exception)
+  public
+    constructor create;
+  end;
+
+  TRelocType = (rt32Bit);
+
+  TReloc = class
+  public
+    position: longword;
+    relocType: TRelocType;
+  end;
+
+  TLabelRef = class
+  public
+    labelname: string;
+    position: longword;
+    delta: integer;
+    labelType: TRelocType;
+  end;
+
+  TLabel = class
+  public
+    name: string;
+    position: longword;
+  end;
+
+  TLabelList = class
+  private
+    flabels: TStringList;
+  public
+    constructor create;
+    destructor Destroy; override;
+    function GetLabel(const name: string): TLabel;
+    function AddLabel(const name: string; position: longword): Boolean;
+    procedure Clear;
+  end;
+
+  TASMInline = class
+  private
+    fbuffer: TMemoryStream;
+    frelocs, flabelrefs: TObjectList;
+    flabels: TLabelList;
+    fbase: longword;
+    procedure ResolveLabels;
+
+    procedure AddRelocation(position: longword; relocType: TRelocType);
+    procedure AddLabelRef(position: longword; delta: integer; relocType: TRelocType; const labelname: string);
+
+    function GetReloc(index: integer): TReloc;
+    function RelocCount: integer;
+    property Relocs[index: integer]: TReloc read GetReloc;
+
+    procedure WriteByte(b: byte);
+    procedure WriteWord(w: word);
+    procedure WriteInteger(i: integer);
+    procedure WriteLongWord(l: longword);
+    procedure WriteOpSizeOverride;
+    procedure WriteRegRef(reg: byte; base: TRegister32; deref: boolean; index: TRegister32; Offset: integer; Scale: byte; usebase: boolean); overload;
+    procedure WriteRegRef(mem: TMemoryAddress; reg: TRegister8); overload;
+    procedure WriteRegRef(mem: TMemoryAddress; reg: TRegister16); overload;
+    procedure WriteRegRef(mem: TMemoryAddress; reg: TRegister32); overload;
+    procedure WriteRegRef(mem: TMemoryAddress; opcodeext: byte); overload;
+    procedure WriteRegRef(reg1: TRegister8; opcodeext: byte); overload;
+    procedure WriteRegRef(reg1: TRegister16; opcodeext: byte); overload;
+    procedure WriteRegRef(reg1: TRegister32; opcodeext: byte); overload;
+    procedure WriteRegRef(reg1: TRegister8; reg2: TRegister8); overload;
+    procedure WriteRegRef(reg1: TRegister16; reg2: TRegister16); overload;
+    procedure WriteRegRef(reg1: TRegister32; reg2: TRegister32); overload;
+    procedure WriteRegRef(reg: TRegister32; base: TRegister32; deref: boolean; index: TRegister32 = EAX; Offset: integer = 0; Scale: byte = 0; usebase: boolean = true); overload;
+  public
+    function Size: integer;
+
+    procedure Clear;
+
+    procedure Execute;
+
+    procedure Relocate(base: pointer);
+
+    function SaveAsMemory: pointer;
+    procedure SaveToMemory(target: pointer);
+
+    constructor create;
+    destructor Destroy; override;
+
+    function Addr(base: TRegister32; index: TRegister32; scale: Byte = 1; offset: integer = 0; size: TMemSize = ms32): TMemoryAddress; overload;
+    function Addr(base: TRegister32; size: TMemSize = ms32): TMemoryAddress; overload;
+    function Addr(base: TRegister32; offset: Integer; size: TMemSize = ms32): TMemoryAddress; overload;
+    function Addr(offset: integer; index: TRegister32; scale: Byte = 1; size: TMemSize = ms32): TMemoryAddress; overload;
+    function Addr(offset: Integer; size: TMemSize = ms32): TMemoryAddress; overload;
+
+    //RET
+    procedure Ret; overload;
+    //RET imm8
+    procedure Ret(w: Word); overload;
+
+    //PUSH imm
+    procedure Push(lw: longword); overload;
+    //PUSH reg
+    procedure Push(reg: TRegister16); overload;
+    procedure Push(reg: TRegister32); overload;
+    //PUSH [reg]
+    procedure Push(mem: TRegister32Set); overload;
+    //PUSH mem
+    procedure Push(mem: TMemoryAddress); overload;
+
+    //POP reg
+    procedure Pop(reg: TRegister32);
+
+    procedure doLabel(const name: string);
+
+    //DB imm8
+    procedure db(b: byte);
+    //DW imm16
+    procedure dw(w: word);
+    //DD imm32
+    procedure dd(dw: longword);
+
+    //CALL [reg]
+    procedure Call(reg: TRegister32); overload;
+    //CALL rel32
+    procedure Call(target: pointer); overload;
+
+    //JUMP rel32
+    procedure Jmp(target: pointer); overload;
+    //JUMP label
+    procedure Jmp(const labelname: string); overload;
+
+    //MOV reg, imm
+    procedure Mov(reg: TRegister8; b: byte); overload;
+    procedure Mov(reg: TRegister16; b: word); overload;
+    procedure Mov(reg: TRegister32; b: longword); overload;
+    //MOV reg, reg
+    procedure Mov(reg1: TRegister8; reg2: TRegister8); overload;
+    procedure Mov(reg1: TRegister16; reg2: TRegister16); overload;
+    procedure Mov(reg1: TRegister32; reg2: TRegister32); overload;
+    //MOV reg, [reg] and MOV [reg], reg
+    procedure Mov(reg1: TRegister32; reg2: TRegister32Set); overload;
+    procedure Mov(reg1: TRegister32Set; reg2: TRegister32); overload;
+    //MOV [reg], imm
+    procedure Mov(reg1: TRegister32Set; i: longword); overload;
+    //MOV mem, imm
+    procedure Mov(mem: TMemoryAddress; i: longword); overload;
+    //MOV reg, mem and MOV mem, reg
+    procedure Mov(mem: TMemoryAddress; reg: TRegister32); overload;
+    procedure Mov(mem: TMemoryAddress; reg: TRegister16); overload;
+    procedure Mov(mem: TMemoryAddress; reg: TRegister8); overload;
+    procedure Mov(reg: TRegister32; mem: TMemoryAddress); overload;
+    procedure Mov(reg: TRegister16; mem: TMemoryAddress); overload;
+    procedure Mov(reg: TRegister8; mem: TMemoryAddress); overload;
+
+    procedure Nop;
+
+    //SHL reg, imm
+    procedure doSHL(reg: TRegister8; amount: byte); overload;
+    procedure doSHL(reg: TRegister16; amount: byte); overload;
+    procedure doSHL(reg: TRegister32; amount: byte); overload;
+    //SHL reg, CL
+    procedure doSHL(reg: TRegister8; amount: TCLRegister); overload;
+    procedure doSHL(reg: TRegister16; amount: TCLRegister); overload;
+    procedure doSHL(reg: TRegister32; amount: TCLRegister); overload;
+    //SHL mem, imm and SHL mem, CL
+    procedure doSHL(mem: TMemoryAddress; amount: byte); overload;
+    procedure doSHL(mem: TMemoryAddress; amount: TCLRegister); overload;
+
+    //SAR reg, CL
+    procedure SAR(reg: TRegister8; amount: byte); overload;
+    procedure SAR(reg: TRegister16; amount: byte); overload;
+    procedure SAR(reg: TRegister32; amount: byte); overload;
+    //SAR reg, imm
+    procedure SAR(reg: TRegister8; amount: TCLRegister); overload;
+    procedure SAR(reg: TRegister16; amount: TCLRegister); overload;
+    procedure SAR(reg: TRegister32; amount: TCLRegister); overload;
+    //SAR mem, imm and SHR mem, CL
+    procedure SAR(mem: TMemoryAddress; amount: byte); overload;
+    procedure SAR(mem: TMemoryAddress; amount: TCLRegister); overload;
+
+    //SHR reg, imm
+    procedure doSHR(reg: TRegister8; amount: byte); overload;
+    procedure doSHR(reg: TRegister16; amount: byte); overload;
+    procedure doSHR(reg: TRegister32; amount: byte); overload;
+    //SHR reg, CL
+    procedure doSHR(reg: TRegister8; amount: TCLRegister); overload;
+    procedure doSHR(reg: TRegister16; amount: TCLRegister); overload;
+    procedure doSHR(reg: TRegister32; amount: TCLRegister); overload;
+    //SHR mem, imm and SHR mem, CL
+    procedure doSHR(mem: TMemoryAddress; amount: byte); overload;
+    procedure doSHR(mem: TMemoryAddress; amount: TCLRegister); overload;
+
+    //NOT reg
+    procedure doNot(reg: TRegister8); overload;
+    procedure doNot(reg: TRegister32); overload;
+    procedure doNot(reg: TRegister16); overload;
+    //NOT mem
+    procedure doNot(mem: TMemoryAddress); overload;
+  end;
+
+implementation
+
+constructor TLabelList.create;
+begin
+  flabels := TStringList.create;
+  flabels.Sorted := true;
+end;
+
+destructor TLabelList.destroy;
+begin
+  clear;
+  flabels.free;
+end;
+
+function TLabelList.GetLabel(const name: string): TLabel;
+var i: integer;
+begin
+  i := flabels.IndexOf(name);
+  if i = -1 then
+    result := nil else
+    result := TLabel(flabels.objects[i]);
+end;
+
+function TLabelList.AddLabel(const name: string; position: longword): Boolean;
+var alabel: TLabel;
+begin
+  result := flabels.indexof(name) = -1;
+  if result then begin //success
+    alabel := TLabel.create;
+    alabel.name := name;
+    alabel.position := position;
+    flabels.AddObject(name, alabel);
+  end;
+end;
+
+procedure TLabelList.Clear;
+var t1: integer;
+begin
+  for t1 := 0 to flabels.count - 1 do
+    flabels.Objects[t1].free;
+  flabels.Clear;
+end;
+
+constructor EOperandSizeMismatch.create;
+begin
+  inherited create('Operand size mismatch');
+end;
+
+{Throw an exception if test<>match. Poor man's assert().
+ Could overload to add other sorts of tests}
+
+procedure require(test: TMemSize; match: TMemSize);
+begin
+  if test <> match then
+    raise EOperandSizeMismatch.create;
+end;
+
+{Check that the set has exactly one member. If it has one member, return that
+ member, otherwise throw an exception}
+
+function SingleMember(regset: TRegister32Set): TRegister32;
+var r: TRegister32;
+  found: boolean;
+begin
+  found := false;
+  result:=EAX;
+  for r := low(r) to high(r) do
+    if r in regset then
+      if found then //there is more than one member in this set
+        raise exception.create('Invalid register operand') else
+      begin
+        found := true;
+        result := r;
+      end;
+  if not found then begin
+    raise exception.create('Invalid register operand');
+    end;
+end;
+
+function regnum(reg: TRegister16): byte; overload;
+begin
+  case reg of
+    AX: result := 0;
+    BX: result := 3;
+    CX: result := 1;
+    DX: result := 2;
+  else raise exception.create('Unknown register...');
+  end;
+end;
+
+function regnum(reg: TRegister32): byte; overload;
+begin
+  case reg of
+    EAX: result := 0;
+    EBX: result := 3;
+    ECX: result := 1;
+    EDX: result := 2;
+    ESP: result := 4;
+    EBP: result := 5;
+    ESI: result := 6;
+    EDI: result := 7;
+  else raise exception.create('Unknown register...');
+  end;
+end;
+
+function regnum(reg: TRegister8): byte; overload;
+begin
+  case reg of
+    AL: result := 0;
+    BL: result := 3;
+    CL: result := 1;
+    DL: result := 2;
+    AH: result := 4;
+    BH: result := 7;
+    CH: result := 5;
+    DH: result := 6;
+  else raise exception.create('Unknown register...');
+  end;
+end;
+
+function ModModeNum(m: TModMode): byte;
+begin
+  case m of
+    mmDeref: result := 0;
+    mmDisp8: result := 1;
+    mmDisp32: result := 2;
+    mmNaked: result := 3;
+  else raise exception.create('Invalid mod mode: ' + inttostr(ord(m)));
+  end;
+end;
+
+function EncodeSIB(scale, index, base: byte): byte;
+begin
+  result := base or (index shl 3) or (scale shl 6);
+end;
+
+function EncodeModRM(aMod, aReg, aRM: byte): byte; overload;
+begin
+  result := (aMod shl 6) or (areg shl 3) or aRM;
+end;
+
+function EncodeModRM(aregister: TRegister32; reg: Byte): byte; overload;
+begin
+  result := EncodeModRM(3, reg, regnum(aregister));
+end;
+
+function EncodeModRM(aregister: TRegister16; reg: Byte): byte; overload;
+begin
+  result := EncodeModRM(3, reg, regnum(aregister));
+end;
+
+function EncodeModRM(aregister: TRegister8; reg: Byte): byte; overload;
+begin
+  result := EncodeModRM(3, reg, regnum(aregister));
+end;
+
+procedure TASMInline.Execute;
+var codeBuf: pointer;
+begin
+  codeBuf := SaveAsMemory;
+  try
+    tprocedure(codeBuf);
+  finally
+    FreeMem(codeBuf);
+  end;
+end;
+
+{$IFOPT R+}
+{$DEFINE RESTORER}
+{$R-}
+{$ENDIF}
+{$IFOPT Q+}
+{$DEFINE RESTOREQ}
+{$Q-}
+{$ENDIF}
+
+{Resolve any unresolved references to label names into actual relative or
+ absolute addresses}
+
+procedure TASMInline.ResolveLabels;
+var t1: integer;
+  labelref: TLabelRef;
+  alabel: TLabel;
+  lw: Longword;
+begin
+  for t1 := 0 to flabelrefs.count - 1 do begin
+    labelref := TLabelRef(flabelrefs[t1]);
+    alabel := flabels.GetLabel(labelref.labelname);
+    if alabel = nil then
+      raise Exception.create('Unknown label ''' + labelref.labelname + '''');
+
+    fbuffer.seek(labelref.position, soFromBeginning);
+    lw := alabel.position + labelref.delta;
+    writelongword(lw);
+
+//    AddRelocation(labelref.position,labelref.labelType);
+  end;
+
+  flabelrefs.Clear; //we have resolved all these now
+end;
+
+procedure TASMInline.Relocate(base: pointer);
+var oldpos, diff, orig: integer;
+  i: integer;
+  reloc: TReloc;
+begin
+  oldpos := fbuffer.Position;
+  try
+
+    diff := -(longword(base) - fbase);
+
+    for i := 0 to RelocCount - 1 do begin
+      reloc := Relocs[i];
+      case reloc.relocType of
+        rt32Bit: begin
+            fbuffer.Seek(reloc.position, soFromBeginning);
+            fbuffer.Read(orig, sizeof(orig));
+            fbuffer.seek(-sizeof(orig), soFromCurrent);
+            orig := LongWord(orig + diff);
+            fbuffer.write(orig, sizeof(orig));
+          end;
+      end;
+    end;
+    fbase := longword(base);
+  finally
+    fbuffer.position := oldpos;
+  end;
+end;
+{$IFDEF RESTORER}
+{$R+}
+{$ENDIF}
+{$IFDEF RESTOREQ}
+ {Q+}
+{$ENDIF}
+
+function TASMInline.GetReloc(index: integer): TReloc;
+begin
+  result := TReloc(frelocs[index]);
+end;
+
+function TASMInline.RelocCount: integer;
+begin
+  result := frelocs.Count;
+end;
+
+procedure TASMInline.AddLabelRef(position: longword; delta: integer; relocType: TRelocType; const labelname: string);
+var labelref: TLabelRef;
+begin
+  labelref := TLabelRef.create;
+
+  labelref.labelname := labelname;
+  labelref.position := position;
+  labelref.delta := delta;
+  labelref.labelType := relocType;
+
+  fLabelRefs.add(labelref);
+end;
+
+procedure TASMInline.AddRelocation(position: longword; relocType: TRelocType);
+var reloc: TReloc;
+begin
+  reloc := TReloc.Create;
+  reloc.position := position;
+  reloc.relocType := relocType;
+  frelocs.add(reloc);
+end;
+
+procedure TASMInline.Clear;
+begin
+  fbuffer.Clear;
+  frelocs.Clear;
+end;
+
+function TASMInline.SaveAsMemory: pointer;
+var buf: pointer;
+  oldprotect: Cardinal;
+begin
+  GetMem(buf, size);
+  VirtualProtect(buf, Size, PAGE_EXECUTE_READWRITE, oldprotect);
+  SaveToMemory(buf);
+  result := buf;
+end;
+
+procedure TASMInline.SaveToMemory(target: pointer);
+begin
+  ResolveLabels;
+  Relocate(target);
+  Move(fbuffer.memory^, target^, size);
+end;
+
+function TASMInline.Addr(base: TRegister32; size: TMemSize = ms32): TMemoryAddress;
+begin
+  result.base := base;
+  result.usebase := true;
+  result.size := size;
+  result.offset := 0;
+  result.scale := 0; //don't use index
+end;
+
+function TASMInline.Addr(offset: integer; index: TRegister32; scale: Byte = 1; size: TMemSize = ms32): TMemoryAddress;
+begin
+  result.offset := offset;
+  result.index := index;
+  result.scale := scale;
+  result.size := size;
+  result.usebase := false;
+end;
+
+function TASMInline.Addr(base: TRegister32; offset: Integer; size: TMemSize = ms32): TMemoryAddress;
+begin
+  result.base := base;
+  result.scale := 0; //don't use Index
+  result.offset := offset;
+  result.size := size;
+  result.usebase := true;
+end;
+
+function TASMInline.Addr(offset: Integer; size: TMemSize = ms32): TMemoryAddress;
+begin
+  result.offset := offset;
+  result.size := size;
+  result.scale := 0; //dont use Index
+  result.usebase := true;
+end;
+
+function TASMInline.Addr(base: TRegister32; index: TRegister32; scale: Byte = 1; offset: integer = 0; size: TMemSize = ms32): TMemoryAddress;
+begin
+  result.base := base;
+  result.index := index;
+  result.offset := offset;
+  result.scale := scale;
+  result.size := size;
+  result.usebase := true;
+end;
+
+function TASMInline.Size: integer;
+begin
+  result := fbuffer.size;
+end;
+
+procedure TASMInline.WriteInteger(i: integer);
+begin
+  fbuffer.write(i, 4);
+end;
+
+procedure TASMInline.writelongword(l: longword);
+begin
+  fbuffer.write(l, 4);
+end;
+
+procedure TASMInline.writeword(w: word);
+begin
+  fbuffer.write(w, 2);
+end;
+
+procedure TASMInline.writebyte(b: byte);
+begin
+  fbuffer.write(b, 1);
+end;
+
+procedure TASMInline.WriteOpSizeOverride;
+begin
+  writebyte($66);
+end;
+
+procedure TASMInline.Ret;
+begin
+  writebyte($C3);
+end;
+
+procedure TASMInline.Ret(w: Word);
+begin
+  if w = 0 then
+    ret() else begin
+    writebyte($C2);
+    writeword(w);
+  end;
+end;
+
+procedure TASMInline.doSHL(mem: TMemoryAddress; amount: byte);
+begin
+  case mem.size of
+    ms16, ms32: begin
+        if mem.size = ms16 then WriteOpSizeOverride();
+
+        if amount = 1 then begin
+          writebyte($D1);
+          WriteRegRef(mem, 4);
+        end else begin
+          writebyte($C1);
+          WriteRegRef(mem, 4);
+          writebyte(amount);
+        end;
+      end;
+    ms8: begin
+        if amount = 1 then begin
+          writebyte($D0);
+          WriteRegRef(mem, 4);
+        end else begin
+          writebyte($C0);
+          WriteRegRef(mem, 4);
+          writebyte(amount);
+        end;
+      end;
+  else raise EOperandSizeMismatch.create();
+  end;
+end;
+
+procedure TASMInline.doSHL(mem: TMemoryAddress; amount: TCLRegister);
+begin
+  case mem.size of
+    ms16, ms32: begin
+        if mem.size = ms16 then
+          WriteOpSizeOverride;
+        writebyte($D3);
+        writeregref(mem, 4);
+      end;
+    ms8: begin
+        writebyte($D2);
+        writeregref(mem, 4);
+      end;
+  else raise EOperandSizeMismatch.create();
+  end;
+end;
+
+procedure TASMInline.doSHL(reg: TRegister8; amount: byte);
+begin
+  if amount = 1 then begin
+    writebyte($D0);
+    WriteRegRef(reg, 4);
+  end else begin
+    writebyte($C0);
+    WriteRegRef(reg, 4);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.doSHL(reg: TRegister8; amount: TCLRegister);
+begin
+  writebyte($D2);
+  writeregref(reg, 4);
+end;
+
+procedure TASMInline.doSHL(reg: TRegister32; amount: byte);
+begin
+  if amount = 1 then begin
+    writebyte($D1);
+    WriteRegRef(reg, 4);
+  end else begin
+    writebyte($C1);
+    WriteRegRef(reg, 4);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.doSHL(reg: TRegister32; amount: TCLRegister);
+begin
+  writebyte($D3);
+  writeregref(reg, 4);
+end;
+
+procedure TASMInline.doSHL(reg: TRegister16; amount: byte);
+begin
+  WriteOpSizeOverride;
+  if amount = 1 then begin
+    writebyte($D1);
+    WriteRegRef(reg, 4);
+  end else begin
+    writebyte($C1);
+    WriteRegRef(reg, 4);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.doSHL(reg: TRegister16; amount: TCLRegister);
+begin
+  WriteOpSizeOverride;
+  writebyte($D3);
+  writeregref(reg, 4);
+end;
+
+procedure TASMInline.doSHR(mem: TMemoryAddress; amount: byte);
+begin
+  case mem.size of
+    ms16, ms32: begin
+        if mem.size = ms16 then
+          WriteOpSizeOverride;
+
+        if amount = 1 then begin
+          writebyte($D1);
+          WriteRegRef(mem, 5);
+        end else begin
+          writebyte($C1);
+          WriteRegRef(mem, 5);
+          writebyte(amount);
+        end;
+      end;
+    ms8: begin
+        if amount = 1 then begin
+          writebyte($D0);
+          WriteRegRef(mem, 5);
+        end else begin
+          writebyte($C0);
+          WriteRegRef(mem, 5);
+          writebyte(amount);
+        end;
+      end;
+  else raise EOperandSizeMismatch.create();
+  end;
+end;
+
+procedure TASMInline.doSHR(mem: TMemoryAddress; amount: TCLRegister);
+begin
+  case mem.size of
+    ms32: begin
+        writebyte($D3);
+        WriteRegRef(mem, 5);
+      end;
+    ms16: begin
+        WriteOpSizeOverride;
+        writebyte($D3);
+        WriteRegRef(mem, 5);
+      end;
+    ms8: begin
+        writebyte($D2);
+        writeregref(mem, 5);
+      end;
+  end;
+end;
+
+procedure TASMInline.doSHR(reg: TRegister8; amount: byte);
+begin
+  if amount = 1 then begin
+    writebyte($D0);
+    WriteRegRef(reg, 5);
+  end else begin
+    writebyte($C0);
+    WriteRegRef(reg, 5);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.doSHR(reg: TRegister8; amount: TCLRegister);
+begin
+  writebyte($D2);
+  writeregref(reg, 5);
+end;
+
+procedure TASMInline.doSHR(reg: TRegister32; amount: byte);
+begin
+  if amount = 1 then begin
+    writebyte($D1);
+    WriteRegRef(reg, 5);
+  end else begin
+    writebyte($C1);
+    WriteRegRef(reg, 5);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.doSHR(reg: TRegister32; amount: TCLRegister);
+begin
+  writebyte($D3);
+  writeregref(reg, 5);
+end;
+
+procedure TASMInline.doSHR(reg: TRegister16; amount: byte);
+begin
+  WriteOpSizeOverride;
+  if amount = 1 then begin
+    writebyte($D1);
+    WriteRegRef(reg, 5);
+  end else begin
+    writebyte($C1);
+    WriteRegRef(reg, 5);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.doSHR(reg: TRegister16; amount: TCLRegister);
+begin
+  WriteOpSizeOverride;
+  writebyte($D3);
+  writeregref(reg, 5);
+end;
+
+procedure TASMInline.SAR(reg: TRegister8; amount: byte);
+begin
+  if amount = 1 then begin
+    writebyte($D0);
+    WriteRegRef(reg, 7);
+  end else begin
+    writebyte($C0);
+    WriteRegRef(reg, 7);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.SAR(reg: TRegister8; amount: TCLRegister);
+begin
+  writebyte($D2);
+  writeregref(reg, 7);
+end;
+
+procedure TASMInline.SAR(mem: TMemoryAddress; amount: byte);
+begin
+  case mem.size of
+    ms32, ms16: begin
+        if mem.size = ms16 then WriteOpSizeOverride;
+
+        if amount = 1 then begin
+          writebyte($D1);
+          WriteRegRef(mem, 7);
+        end else begin
+          writebyte($C1);
+          WriteRegRef(mem, 7);
+          writebyte(amount);
+        end;
+      end;
+    ms8: begin
+        if amount = 1 then begin
+          writebyte($D0);
+          WriteRegRef(mem, 7);
+        end else begin
+          writebyte($C0);
+          WriteRegRef(mem, 7);
+          writebyte(amount);
+        end;
+      end;
+  else raise EOperandSizeMismatch.create();
+  end;
+end;
+
+procedure TASMInline.SAR(mem: TMemoryAddress; amount: TCLRegister);
+begin
+  case mem.size of
+    ms16, ms32: begin
+        if mem.size = ms16 then
+          WriteOpSizeOverride;
+        writebyte($D3);
+        writeregref(mem, 7);
+      end;
+    ms8: begin
+        writebyte($D2);
+        writeregref(mem, 7);
+      end;
+  else raise EOperandSizeMismatch.create();
+  end;
+end;
+
+procedure TASMInline.SAR(reg: TRegister32; amount: byte);
+begin
+  if amount = 1 then begin
+    writebyte($D1);
+    WriteRegRef(reg, 7);
+  end else begin
+    writebyte($C1);
+    WriteRegRef(reg, 7);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.SAR(reg: TRegister32; amount: TCLRegister);
+begin
+  writebyte($D3);
+  writeregref(reg, 7);
+end;
+
+procedure TASMInline.SAR(reg: TRegister16; amount: byte);
+begin
+  WriteOpSizeOverride;
+  if amount = 1 then begin
+    writebyte($D1);
+    WriteRegRef(reg, 7);
+  end else begin
+    writebyte($C1);
+    WriteRegRef(reg, 7);
+    writebyte(amount);
+  end;
+end;
+
+procedure TASMInline.SAR(reg: TRegister16; amount: TCLRegister);
+begin
+  WriteOpSizeOverride;
+  writebyte($D3);
+  writeregref(reg, 7);
+end;
+
+procedure TASMInline.doNot(mem: TMemoryAddress);
+begin
+  case mem.size of
+    ms32, ms16: begin
+        if mem.size = ms16 then
+          WriteOpSizeOverride;
+        Writebyte($F7);
+        WriteRegRef(mem, 2);
+      end;
+    ms8: begin
+        writebyte($F6);
+        WriteRegRef(mem, 2);
+      end;
+  else raise EOperandSizeMismatch.create;
+  end;
+end;
+
+procedure TASMInline.doNot(reg: TRegister32);
+begin
+  Writebyte($F7);
+  WriteRegRef(reg, 2);
+end;
+
+procedure TASMInline.doNot(reg: TRegister8);
+begin
+  writebyte($F6);
+  WriteRegRef(reg, 2);
+end;
+
+procedure TASMInline.doNot(reg: TRegister16);
+begin
+  WriteOpSizeOverride;
+  writebyte($F7);
+  WriteRegRef(reg, 2);
+end;
+
+procedure TASMInline.Pop(reg: TRegister32);
+begin
+  writebyte($58 + regnum(reg));
+end;
+
+procedure TASMInline.Jmp(const labelname: string);
+begin
+  WriteByte($E9);
+  AddLabelRef(fbuffer.position, -(fbuffer.position + 4), rt32bit, labelname);
+  WriteLongword(0); //dummy space for the label target
+end;
+
+procedure TASMInline.Jmp(target: pointer);
+begin
+  writebyte($E9);
+  AddRelocation(fbuffer.position, rt32bit);
+  WriteInteger(integer(target) - (integer(fBase) + fbuffer.Position + 4));
+end;
+
+procedure TASMInline.doLabel(const name: string);
+begin
+  if not flabels.AddLabel(name, fbuffer.Position) then
+    raise exception.create('Duplicate label identifier ''' + name + '''');
+end;
+
+procedure TASMInline.db(b: byte);
+begin
+  WriteByte(b);
+end;
+
+procedure TASMInline.dw(w: word);
+begin
+  WriteWord(w);
+end;
+
+procedure TASMInline.dd(dw: longword);
+begin
+  WriteLongWord(dw);
+end;
+
+procedure TASMInline.Call(target: pointer);
+begin
+  writebyte($E8);
+  AddRelocation(fbuffer.position, rt32Bit);
+  WriteInteger(integer(target) - (integer(fBase) + fbuffer.Position + 4));
+end;
+
+procedure TASMInline.Call(reg: TRegister32);
+begin
+  writebyte($FF);
+  WriteRegRef(reg, 2);
+end;
+
+procedure TASMInline.Push(mem: TRegister32Set);
+begin
+  push(addr(SingleMember(mem)));
+end;
+
+procedure TASMInline.Push(mem: TMemoryAddress);
+begin
+  writebyte($FF);
+  WriteRegRef(mem, 6);
+end;
+
+procedure TASMInline.Push(lw: longword);
+begin
+  {bytes get sign extended. Only push as byte if it won't end up being
+  interpreted as negative..}
+  if lw < 128 then begin
+    writebyte($6A);
+    writebyte(lw and $FF);
+  end else begin //write a longword
+    writebyte($68);
+    writelongword(lw);
+  end;
+end;
+
+procedure TASMInline.Push(reg: TRegister16);
+begin
+  WriteOpSizeOverride;
+  writebyte($50 + regnum(reg));
+end;
+
+procedure TASMInline.Push(reg: TRegister32);
+begin
+  writebyte($50 + regnum(reg));
+end;
+
+procedure TASMInline.WriteRegRef(reg1: TRegister8; opcodeext: byte);
+begin
+  writebyte(EncodeModRM(3, opcodeext, regnum(reg1)));
+end;
+
+procedure TASMInline.WriteRegRef(reg1: TRegister16; opcodeext: byte);
+begin
+  writebyte(EncodeModRM(3, opcodeext, regnum(reg1)));
+end;
+
+procedure TASMInline.WriteRegRef(reg1: TRegister32; opcodeext: byte);
+begin
+  writebyte(EncodeModRM(3, opcodeext, regnum(reg1)));
+end;
+
+procedure TASMInline.WriteRegRef(reg1: TRegister32; reg2: TRegister32);
+begin
+  writebyte(EncodeModRM(ModModeNum(mmNaked), regnum(reg2), regnum(reg1)));
+end;
+
+procedure TASMInline.WriteRegRef(reg1: TRegister16; reg2: TRegister16);
+begin
+  WriteByte(EncodeModRM(ModModeNum(mmNaked), regnum(reg2), regnum(reg1)));
+end;
+
+procedure TASMInline.WriteRegRef(reg1: TRegister8; reg2: TRegister8);
+begin
+  WriteByte(EncodeModRM(ModModeNum(mmNaked), regnum(reg2), regnum(reg1)));
+end;
+
+procedure TASMInline.WriteRegRef(mem: TMemoryAddress; opcodeext: byte);
+begin
+  writeregref(opcodeext, mem.base, true, mem.index, mem.offset, mem.scale, mem.usebase);
+end;
+
+procedure TASMInline.WriteRegRef(mem: TMemoryAddress; reg: TRegister8);
+begin
+  writeregref(regnum(reg), mem.base, true, mem.index, mem.offset, mem.scale, mem.usebase);
+end;
+
+procedure TASMInline.WriteRegRef(mem: TMemoryAddress; reg: TRegister16);
+begin
+  writeregref(regnum(reg), mem.base, true, mem.index, mem.offset, mem.scale, mem.usebase);
+end;
+
+procedure TASMInline.WriteRegRef(mem: TMemoryAddress; reg: TRegister32);
+begin
+  writeregref(reg, mem.base, true, mem.index, mem.offset, mem.scale, mem.usebase);
+end;
+
+//Write the MODR/M and SIB byte for the given register or memory reference
+
+procedure TASMInline.WriteRegRef(reg: TRegister32; base: TRegister32; deref: boolean; index: TRegister32 = EAX; Offset: integer = 0; Scale: byte = 0; usebase: boolean = true);
+begin
+  WriteRegRef(regnum(reg), base, deref, index, Offset, scale, usebase);
+end;
+
+procedure TASMInline.WriteRegRef(reg: byte; base: TRegister32; deref: boolean; index: TRegister32; Offset: integer; Scale: byte; usebase: boolean);
+type TOffSize = (osNone, os8, os32);
+var mode: TModMode;
+  offsize: TOffSize;
+  useSIB: boolean;
+  areg, arm: Byte;
+begin
+  if not deref then begin
+    mode := mmNaked;
+    offsize := osNone;
+  end else
+    if usebase = false then begin
+      offsize := os32;
+      mode := mmDeref;
+      base := EBP; //the "no base" value
+    end else
+      if Offset = 0 then begin
+        mode := mmDeref;
+        offsize := osNone;
+      end else
+        if (offset >= -128) and (offset < 128) then begin //signed byte
+          mode := mmDisp8;
+          offsize := os8;
+        end else begin
+          mode := mmDisp32;
+          offsize := os32;
+        end;
+
+  if (mode <> mmnaked) then begin
+    usesib := (Scale > 0) or (base = ESP);
+  end else usesib := false;
+
+  if useSIB then begin //calculate scale, easiest just to use a case statement..
+    case scale of
+      0: begin //dont want an index value
+          index := ESP; //"none" value
+        end;
+      1: scale := 0;
+      2: scale := 1;
+      4: scale := 2;
+      8: scale := 3;
+    else raise exception.create('Invalid scale, valid values are 1,2,4,8.');
+    end;
+  end;
+
+  if (not useSIB) and (mode = mmDeref) and (base = EBP) then begin
+  //not available, use [EBP+0] instead
+    mode := mmDisp8;
+    offsize := os8;
+    Offset := 0;
+  end;
+
+  arm := regnum(base);
+  areg := reg;
+
+  if usesib then
+    WriteByte(EncodeModRM(ModModeNum(mode), areg, 4)) else
+    WriteByte(EncodeModRM(ModModeNum(mode), areg, arm));
+
+  if usesib then begin
+    WriteByte(EncodeSIB(Scale, regnum(index), regnum(base)));
+  end;
+
+    //Do we have to append an offset?
+  case offsize of
+    os8: WriteByte(byte(offset)); //ignore sign..
+    os32: writelongword(longword(offset));
+  end;
+end;
+
+procedure TASMInline.Nop;
+begin
+  WriteByte($90);
+end;
+
+procedure TASMInline.Mov(reg1: TRegister32Set; i: longword);
+begin
+  mov(addr(singlemember(reg1)), i);
+end;
+
+procedure TASMInline.Mov(mem: TMemoryAddress; i: longword);
+begin
+  case mem.size of
+    ms8: begin
+        if i > high(byte) then
+          raise EOperandSizeMismatch.create;
+        writebyte($C6);
+        WriteRegRef(mem, 0);
+        writebyte(i);
+      end;
+    ms16: begin
+        if i > high(word) then
+          raise EOperandSizeMismatch.create;
+        WriteOpSizeOverride();
+        writebyte($C7);
+        WriteRegRef(mem, 0);
+        writeword(i);
+      end;
+    ms32: begin
+        writebyte($C7);
+        WriteRegRef(mem, 0);
+        writelongword(i);
+      end;
+  else raise EOperandSizeMismatch.create;
+  end;
+end;
+
+procedure TASMInline.Mov(mem: TMemoryAddress; reg: TRegister32);
+begin
+  require(mem.size, ms32);
+  WriteByte($89);
+  WriteRegRef(mem, reg);
+end;
+
+procedure TASMInline.Mov(mem: TMemoryAddress; reg: TRegister16);
+begin
+  require(mem.size, ms16);
+  WriteOpSizeOverride;
+  WriteByte($89);
+  WriteRegRef(mem, reg);
+end;
+
+procedure TASMInline.Mov(mem: TMemoryAddress; reg: TRegister8);
+begin
+  require(mem.size, ms8);
+  WriteByte($88);
+  WriteRegRef(mem, reg);
+end;
+
+procedure TASMInline.Mov(reg: TRegister32; mem: TMemoryAddress);
+begin
+  require(mem.size, ms32);
+  WriteByte($8B);
+  WriteRegRef(mem, reg);
+end;
+
+procedure TASMInline.Mov(reg: TRegister16; mem: TMemoryAddress);
+begin
+  require(mem.size, ms16);
+  WriteOpSizeOverride;
+  WriteByte($8B);
+  WriteRegRef(mem, reg);
+end;
+
+procedure TASMInline.Mov(reg: TRegister8; mem: TMemoryAddress);
+begin
+  require(mem.size, ms8);
+  WriteByte($8A);
+  WriteRegRef(mem, reg);
+end;
+
+procedure TASMInline.Mov(reg1: TRegister32Set; reg2: TRegister32);
+begin
+  Mov(addr(singlemember(reg1)), reg2);
+end;
+
+procedure TASMInline.Mov(reg1: TRegister32; reg2: TRegister32Set);
+begin
+  mov(reg1, addr(singlemember(reg2)));
+end;
+
+procedure TASMInline.Mov(reg1: TRegister8; reg2: TRegister8);
+begin
+  WriteByte($88);
+  WriteRegRef(reg1, reg2);
+end;
+
+procedure TASMInline.Mov(reg1: TRegister16; reg2: TRegister16);
+begin
+  WriteOpSizeOverride;
+  writebyte($89);
+  WriteRegRef(reg1, reg2);
+end;
+
+procedure TASMInline.Mov(reg1: TRegister32; reg2: TRegister32);
+begin
+  writebyte($89);
+  WriteRegRef(reg1, reg2);
+end;
+
+procedure TASMInline.Mov(reg: TRegister8; b: byte);
+begin
+  writebyte($B0 + regnum(reg));
+  writebyte(b);
+end;
+
+procedure TASMInline.Mov(reg: TRegister16; b: word);
+begin
+  WriteOpSizeOverride;
+  writebyte($B8 + regnum(reg));
+  writeword(b);
+end;
+
+procedure TASMInline.Mov(reg: TRegister32; b: longword);
+begin
+  writebyte($B8 + regnum(reg));
+  writelongword(b);
+end;
+
+constructor TASMInline.create;
+begin
+  fbuffer := tmemorystream.create;
+  frelocs := tobjectlist.create;
+  flabels := TLabelList.create;
+  flabelrefs := TObjectlist.create;
+end;
+
+destructor TASMInline.destroy;
+begin
+  fbuffer.free;
+  frelocs.free;
+  flabels.free;
+  flabelrefs.free;
+  inherited;
+end;
+
+end.
+

Components/UniPs

@@ -1 +1 @@
-Subproject commit 7f3720701fc9467123e940c2f719543652b82109
+Subproject commit e4f2e63a477f83009f6f9bab15b02c854599dc02

Examples/CodeDll.iss

@@ -1,11 +1,12 @@
 ; -- CodeDll.iss --
 ;
-; This script shows how to call DLL functions at runtime from a [Code] section.
+; This script shows how to call functions in external DLLs (like Windows API functions)
+; at runtime and how to perform direct callbacks from these functions to functions
+; in the script.
 
 [Setup]
 AppName=My Program
 AppVersion=1.5
-DisableWelcomePage=no
 DefaultDirName={autopf}\My Program
 DisableProgramGroupPage=yes
 UninstallDisplayIcon={app}\MyProg.exe
@@ -23,26 +24,18 @@ Source: "MyDll.dll"; DestDir: "{app}"
 const
   MB_ICONINFORMATION = $40;
 
-//importing an ANSI Windows API function
-function MessageBox(hWnd: Integer; lpText, lpCaption: AnsiString; uType: Cardinal): Integer;
-external 'MessageBoxA@user32.dll stdcall';
+// Importing a Unicode Windows API function
+function MessageBox(hWnd: Integer; lpText, lpCaption: String; uType: Cardinal): Integer;
+external 'MessageBoxW@user32.dll stdcall';
 
-//importing a Windows API function, automatically choosing ANSI or Unicode (requires ISPP)
-//function MessageBox(hWnd: Integer; lpText, lpCaption: String; uType: Cardinal): Integer;
-//#ifdef UNICODE
-//external '[email protected] stdcall';
-//#else
-//external '[email protected] stdcall';
-//#endif
-
-//importing an ANSI custom DLL function, first for Setup, then for uninstall
+// Importing an ANSI custom DLL function, first for Setup, then for uninstall
 procedure MyDllFuncSetup(hWnd: Integer; lpText, lpCaption: AnsiString; uType: Cardinal);
 external 'MyDllFunc@files:MyDll.dll stdcall setuponly';
 
 procedure MyDllFuncUninstall(hWnd: Integer; lpText, lpCaption: AnsiString; uType: Cardinal);
 external 'MyDllFunc@{app}\MyDll.dll stdcall uninstallonly';
 
-//importing an ANSI function for a DLL which might not exist at runtime
+// Importing an ANSI function for a DLL which might not exist at runtime
 procedure DelayLoadedFunc(hWnd: Integer; lpText, lpCaption: AnsiString; uType: Cardinal);
 external '[email protected] stdcall delayload';
 
@@ -50,7 +43,7 @@ function NextButtonClick(CurPage: Integer): Boolean;
 var
   hWnd: Integer;
 begin
-  if CurPage = wpWelcome then begin
+  if CurPage = wpSelectDir then begin
     hWnd := StrToInt(ExpandConstant('{wizardhwnd}'));
 
     MessageBox(hWnd, 'Hello from Windows API function', 'MessageBoxA', MB_OK or MB_ICONINFORMATION);
@@ -58,10 +51,10 @@ begin
     MyDllFuncSetup(hWnd, 'Hello from custom DLL function', 'MyDllFunc', MB_OK or MB_ICONINFORMATION);
 
     try
-      //if this DLL does not exist (it shouldn't), an exception will be raised
+      // If this DLL does not exist (it shouldn't), an exception will be raised
       DelayLoadedFunc(hWnd, 'Hello from delay loaded function', 'DllFunc', MB_OK or MB_ICONINFORMATION);
     except
-      //handle missing dll here
+      // <Handle missing dll here>
     end;
   end;
   Result := True;
@@ -70,8 +63,7 @@ end;
 procedure CurUninstallStepChanged(CurUninstallStep: TUninstallStep);
 begin
   // Call our function just before the actual uninstall process begins
-  if CurUninstallStep = usUninstall then
-  begin
+  if CurUninstallStep = usUninstall then begin
     MyDllFuncUninstall(0, 'Hello from custom DLL function', 'MyDllFunc', MB_OK or MB_ICONINFORMATION);
     
     // Now that we're finished with it, unload MyDll.dll from memory.
@@ -79,3 +71,23 @@ begin
     UnloadDLL(ExpandConstant('{app}\MyDll.dll'));
   end;
 end;
+
+// The following shows how to use callbacks
+
+function SetTimer(hWnd, nIDEvent, uElapse, lpTimerFunc: Longword): Longword;
+external '[email protected] stdcall';
+
+var
+  TimerCount: Integer;
+
+procedure MyTimerProc(Arg1, Arg2, Arg3, Arg4: Longword);
+begin
+  Inc(TimerCount);
+  WizardForm.BeveledLabel.Caption := ' Timer! ' + IntToStr(TimerCount);
+  WizardForm.BeveledLabel.Visible := True;
+end;
+
+procedure InitializeWizard;
+begin
+  SetTimer(0, 0, 1000, CreateCallback(@MyTimerProc));
+end;

ISHelp/isetup.xml

@@ -3615,6 +3615,10 @@ Keep the default set of selected tasks, but deselect the "desktopicon" task:<br/
 
 <li>Evgeny Karpov of RemObjects Software: Initial work on Unicode support.</li>
 
+<li>DRON: Code for the improved image stretching (5.6.0).</li>
+
+<li>Sherlock Software: Most of the code for the <tt>CreateCallback</tt> support function (6.0).</li>
+
 </ul>
 
 </body>

ISHelp/isxfunc.xml

@@ -728,6 +728,28 @@ end;</pre></example>
       </function>
     </subcategory>
     <subcategory>
+      <function>
+        <name>CreateCallback</name>
+        <prototype>function CreateCallback(Method: AnyMethod): Longword;</prototype>
+        <description><p>Allows you to perform direct callbacks from functions in external DLLs (like Windows API functions) to functions in your script.</p></description>
+        <example><pre>function SetTimer(hWnd, nIDEvent, uElapse, lpTimerFunc: Longword): Longword;
+external '[email protected] stdcall';
+
+var
+  TimerCount: Integer;
+
+procedure MyTimerProc(Arg1, Arg2, Arg3, Arg4: Longword);
+begin
+  Inc(TimerCount);
+  WizardForm.BeveledLabel.Caption := ' Timer! ' + IntToStr(TimerCount);
+  WizardForm.BeveledLabel.Visible := True;
+end;
+
+procedure InitializeWizard;
+begin
+  SetTimer(0, 0, 1000, CreateCallback(@MyTimerProc));
+end;</pre></example>
+      </function>
       <function>
         <name>UnloadDLL</name>
         <prototype>procedure UnloadDLL(Filename: String);</prototype>

Projects/ScriptFunc.pas

@@ -308,7 +308,7 @@ const
   );
 
   { Other }
-  OtherTable: array [0..27] of AnsiString =
+  OtherTable: array [0..28] of AnsiString =
   (
     'procedure BringToFrontAndRestore;',
     'function WizardDirValue: String;',
@@ -337,7 +337,8 @@ const
     'function SaveStringsToFile(const FileName: String; const S: TArrayOfString; const Append: Boolean): Boolean;',
     'function SaveStringsToUTF8File(const FileName: String; const S: TArrayOfString; const Append: Boolean): Boolean;',
     'function EnableFsRedirection(const Enable: Boolean): Boolean;',
-    'function UninstallProgressForm: TUninstallProgressForm;'
+    'function UninstallProgressForm: TUninstallProgressForm;',
+    'function CreateCallback(Method: AnyMethod): Longword;'
   );
 
 implementation

Projects/ScriptFunc_R.pas

@@ -27,7 +27,7 @@ uses
   Struct, ScriptDlg, Main, PathFunc, CmnFunc, CmnFunc2, FileClass, RedirFunc,
   Install, InstFunc, InstFnc2, Msgs, MsgIDs, NewDisk, BrowseFunc, Wizard, VerInfo,
   SetupTypes, Int64Em, MD5, SHA1, Logging, SetupForm, RegDLL, Helper,
-  SpawnClient, UninstProgressForm;
+  SpawnClient, UninstProgressForm, ASMInline;
 
 var
   ScaleBaseUnitsInitialized: Boolean;
@@ -1543,6 +1543,9 @@ begin
 end;
 
 { Other }
+var
+  ASMInliners: array of Pointer;
+
 function OtherProc(Caller: TPSExec; Proc: TPSExternalProcRec; Global, Stack: TPSStack): Boolean;
 
   function GetExceptionMessage: String;
@@ -1686,6 +1689,74 @@ function OtherProc(Caller: TPSExec; Proc: TPSExternalProcRec; Global, Stack: TPS
       Result := False;
     end;
   end;
+  
+  function CreateCallback(P: PPSVariantProcPtr): LongWord;
+  var
+    ProcRec: TPSInternalProcRec;
+    Method: TMethod;
+    Inliner: TASMInline;
+    ParamCount, SwapFirst, SwapLast: Integer;
+    S: tbtstring;
+  begin
+    { Calculate parameter count of our proc, will will need this later. }
+    ProcRec := Caller.GetProcNo(P.ProcNo) as TPSInternalProcRec;
+    S := ProcRec.ExportDecl;
+    GRFW(S);
+    ParamCount := 0;
+    while S <> '' do begin
+      Inc(ParamCount);
+      GRFW(S);
+    end;
+
+    { Turn our proc into a callable TMethod - its Code will point to
+      ROPS' MyAllMethodsHandler and its Data to a record identifying our proc.
+      When called, MyAllMethodsHandler will use the record to call our proc. }
+    Method := MkMethod(Caller, P.ProcNo);
+
+    { Wrap our TMethod with a dynamically generated stdcall callback which will
+      do two things:
+      -Remember the Data pointer which MyAllMethodsHandler needs.
+      -Handle the calling convention mismatch.
+
+      Based on InnoCallback by Sherlock Software, see
+      http://www.sherlocksoftware.org/page.php?id=54 and
+      https://github.com/thenickdude/InnoCallback. }
+    Inliner := TASMInline.create;
+
+    try
+      Inliner.Pop(EAX); //get the retptr off the stack
+
+      SwapFirst := 2;
+      SwapLast := ParamCount-1;
+
+      //Reverse the order of parameters from param3 onwards in the stack
+      while SwapLast > SwapFirst do begin
+        Inliner.Mov(ECX, Inliner.Addr(ESP, SwapFirst * 4)); //load the first item of the pair
+        Inliner.Mov(EDX, Inliner.Addr(ESP, SwapLast * 4)); //load the last item of the pair
+        Inliner.Mov(Inliner.Addr(ESP, SwapFirst * 4), EDX);
+        Inliner.Mov(Inliner.Addr(ESP, SwapLast * 4), ECX);
+        Inc(SwapFirst);
+        Dec(SwapLast);
+      end;
+
+      if ParamCount >= 1 then
+        Inliner.Pop(EDX); //load param1
+      if ParamCount >= 2 then
+        Inliner.Pop(ECX); //load param2
+
+      Inliner.Push(EAX); //put the retptr back onto the stack
+
+      Inliner.Mov(EAX, LongWord(Method.Data)); //Load the self ptr
+
+      Inliner.Jmp(Method.Code); //jump to the wrapped proc
+
+      SetLength(ASMInliners, Length(ASMInliners) + 1);
+      ASMInliners[High(ASMInliners)] := Inliner.SaveAsMemory;
+      Result := LongWord(ASMInliners[High(ASMInliners)]);
+    finally
+      Inliner.Free;
+    end;
+  end;
 
 var
   PStart: Cardinal;
@@ -1815,6 +1886,8 @@ begin
     end;
   end else if Proc.Name = 'UNINSTALLPROGRESSFORM' then begin
     Stack.SetClass(PStart, GetUninstallProgressForm);
+  end else if Proc.Name = 'CREATECALLBACK' then begin
+   Stack.SetInt(PStart, CreateCallback(Stack.Items[PStart-1]));
   end else
     Result := False;
 end;
@@ -1881,4 +1954,16 @@ begin
   ScriptInterpreter.RegisterDelphiFunction(@_GetWindowsVersionEx, 'GetWindowsVersionEx', cdRegister); 
 end;
 
+procedure FreeASMInliners;
+var
+  I: Integer;
+begin
+  for I := 0 to High(ASMInliners) do
+    FreeMem(ASMInliners[I]);
+  SetLength(ASMInliners, 0);
+end;
+
+initialization
+finalization
+  FreeASMInliners;
 end.

whatsnew.htm

@@ -95,6 +95,7 @@ For conditions of distribution and use, see <a href="http://www.jrsoftware.org/f
   <ul>
     <li>Using event attributes it is now possible to have multiple implementations of the same event function in your script. This is especially useful in included scripts implementing an event function to avoid conflicts with the main script. See the help file for more information and the <i>CodeExample1.iss</i> example script for an example.</li>
     <li>Added new <tt>TaskDialogMsgBox</tt> and <tt>SuppressibleTaskDialogMsgBox</tt> support functions which display a task dialog if supported by the system and a regular message box otherwise (<a href="https://i.imgur.com/hU4RQP2.png">example</a>). See the help file for more information and the <i>CodeClasses.iss</i> example script for an example.</li>
+    <li>Added new <tt>CreateCallback</tt> support function which allows you to perform direct callbacks from functions in external DLLs (like Windows API functions) to functions in your script. See the help file and the <i>CodeDll.iss</i> example script for an example.</li>
     <li>[Setup] section directives <tt>ChangesAssociations</tt> and <tt>ChangesEnvironment</tt> may now be set to a boolean expression, which may contain calls to check functions.</li>
     <li>Added new special-purpose <i>HelpTextNote</i> message that can be used to specify one or more lines of text that are added to the list of parameters in the summary shown when passing /HELP on the command line. This message defaults to an empty string so make sure to provide a non-empty default for all languages from your main script if you want to use it.</li>
     <li>Added new <tt>SameStr</tt> and <tt>SameText</tt> support functions.</li>
@@ -118,7 +119,7 @@ For conditions of distribution and use, see <a href="http://www.jrsoftware.org/f
   <li>Minor tweaks.</li>
 </ul>
 
-<p>Contributions via <a href="https://github.com/jrsoftware/issrc" target="_blank">GitHub</a>: Thanks to jogo-, Martin Prikryl, dscharrer, Kleuter, Gavin Lambert, Stef&aacute;n &Ouml;rvar Sigmundsson, DRON, and Kevin Puetz for their contributions.</p>
+<p>Contributions via <a href="https://github.com/jrsoftware/issrc" target="_blank">GitHub</a>: Thanks to jogo-, Martin Prikryl, dscharrer, Kleuter, Gavin Lambert, Stef&aacute;n &Ouml;rvar Sigmundsson, DRON, Kevin Puetz, and Sherlock Software for their contributions.</p>
 
 <p>Some messages have been added in this version:<!-- (<a href="https://github.com/jrsoftware/issrc/commit/b0cd1a0177b818e36734026c67dc24f01ad6a0d0">View differences in Default.isl</a>).--></p>
 <ul>