/* This class produces objects that can be used with Windows
  callback functions.  A standard Actor block is used as the
  actual callback function. */!!

inherit(Object, #Callback, #(codeStruct    /* contains generic callback function */
functionBlock /* the callback block */
argsArray     /* defines arg types */
bytesAA       /* args info + argBytes */
hFunction     /* non-bankable handle to a block stub */
aliasSelector  /* for DS to CS aliasing */), 2, nil)!!

now(class(Callback))!!

/* Create a new callback with the passed arguments. */
Def create(self, args, fBlk | aCB)
{ aCB := new(self);
  setArgsArray(aCB, args);
  setFunctionBlock(aCB, fBlk);
  ^aCB;
}!!

now(Callback)!!

/* Return the argsArray ivar. */
Def argsArray(self)
{ ^argsArray;
}!!

/* Return the codeStruct ivar. */
Def codeStruct(self)
{ ^codeStruct;
}!!

/* Free the function. */
Def free(self | ret)
{ ret := hFunction cand
    (Call FreeSelector(aliasSelector) == 0) cand
    (globalUnlock(hFunction) == 0);
  hFunction := aliasSelector := nil;
  ^ret;
}!!

/* Return the functionBlock ivar. */
Def functionBlock(self)
{ ^functionBlock;
}!!

/* Fill the code struct with data.  The first six bytes contain
two move instructions that move the OPs of the function block
and Args Array into bx and cx.  Next is a jump to the callback
procedure, which uses the info in the Args array to take
values off the stack and convert them to args for the block. */
Def initCodeStruct(self | opBlk, opAA, newAA, argBytes)
{ makeByteAA(self);
  opBlk := op(functionBlock);
  opAA := op(bytesAA);
  codeStruct := new(Struct, 64);
  codeStruct[0] := 0xbb90;  /* "nop" | "mov bx,immed" */
  codeStruct[2] := opBlk;
  codeStruct[4] := 0xb990;  /* "nop" | "mov cx,immed" */
  codeStruct[6] := opAA;
  codeStruct[8] := 0xea90;
  putLong(codeStruct, CBFunc, 10);
  codeStruct[14] := 0x00cb;
  codeStruct[16] := 0x9090;
}!!

/* Lock the code struct and return a long pointer to
   the function. */
Def lock(self | addr)
{ initCodeStruct(self);
  if ((hFunction := asGlobalHandle(codeStruct,
    GMEM_NOT_BANKED bitOr GMEM_SHARE bitOr GMEM_FIXED)) = 0) cor
    ((addr := globalLock(hFunction)) = 0) cor
    ((aliasSelector := Call AllocDSToCSAlias(high(addr))) = 0)
  then ^hFunction := aliasSelector := nil;
  endif;
  ^pack(low(addr), aliasSelector);
}!!

/* Produce new array based on contents of argsArray.  First word is the
total number of arg bytes represented by the data in argsArray. */
Def makeByteAA(self | argBytes, idx)
{ if argsArray cand size(argsArray) > 0
  then bytesAA := new(Array, size(argsArray) + 1);
    argBytes := 0;
    do(argsArray,
    {using(aw) argBytes := argBytes + aw + aw + 2;
    });
    bytesAA[0] := argBytes;
    idx := 1;
    do(argsArray,
    {using(aw) bytesAA[idx] := aw;
      idx := idx + 1;
    });
  endif;
}!!

/* Set the argsArray ivar. */
Def setArgsArray(self, aA)
{ ^argsArray := aA;
}!!

/* Initialize the functionBlock ivar with this block. */
Def setFunctionBlock(self, aBlock)
{ ^functionBlock := aBlock;
}!!
