suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

minor reformatting

Browse Source 
svn: r9695
This commit is contained in:
Eli Barzilay 2008-05-06 18:13:11 +00:00
parent 0e550f6f10
commit edf6d53102
3 changed files with 1673 additions and 2098 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

367
src/mysterx/array.cxx
View File

@ -22,16 +22,14 @@
#include "mysterx.h"
Scheme_Object *safeArrayElementToSchemeObject(SAFEARRAY *theArray,
long *allIndices) {
long *allIndices) {
HRESULT hr;
VARTYPE vt;
char errBuff[128];
hr = SafeArrayGetVartype(theArray,&vt);
if (hr != S_OK) {
codedComError("Can't get array type",hr);
}
if (hr != S_OK) codedComError("Can't get array type",hr);
switch(vt) {
@ -136,9 +134,9 @@ Scheme_Object *safeArrayElementToSchemeObject(SAFEARRAY *theArray,
return variantToSchemeObject(&variant);
default :
sprintf(errBuff,
"Can't make Scheme value from array element with type 0x%X",vt);
"Can't make Scheme value from array element with type 0x%X",
vt);
scheme_signal_error(errBuff);
}
@ -146,8 +144,11 @@ Scheme_Object *safeArrayElementToSchemeObject(SAFEARRAY *theArray,
return NULL;
}
Scheme_Object *buildVectorFromArray(SAFEARRAY *theArray,long currDim,
long *allIndices,long *currNdx, long offset) {
Scheme_Object *buildVectorFromArray(SAFEARRAY *theArray,
long currDim,
long *allIndices,
long *currNdx,
long offset) {
Scheme_Object *vec, *v;
long low,high,vecSize;
long i,j;
@ -161,8 +162,8 @@ Scheme_Object *buildVectorFromArray(SAFEARRAY *theArray,long currDim,
if (currDim > 1) {
for (i = 0,j = low; i < vecSize; i++,j++) {
currNdx[offset] = j;
v = buildVectorFromArray(theArray,currDim - 1,
allIndices,currNdx, offset - 1);
v = buildVectorFromArray(theArray, currDim - 1,
allIndices, currNdx, offset - 1);
SCHEME_VEC_ELS(vec)[i] = v;
}
}
@ -183,12 +184,9 @@ Scheme_Object *safeArrayToSchemeVector(SAFEARRAY *theArray) {
Scheme_Object *retval;
numDims = SafeArrayGetDim(theArray);
indices = (long *)scheme_malloc_atomic(numDims * sizeof(long));
retval = buildVectorFromArray(theArray,numDims,
indices,indices, numDims - 1);
indices, indices, numDims - 1);
return retval;
}
@ -208,7 +206,7 @@ int getSchemeVectorDims(Scheme_Object *vec) {
}
void setArrayEltCounts(Scheme_Object *vec,
SAFEARRAYBOUND *rayBounds,long numDims) {
SAFEARRAYBOUND *rayBounds,long numDims) {
Scheme_Object *currObj;
long i;
@ -227,9 +225,7 @@ BOOL isRegularVector(Scheme_Object *vec) {
int len,currLen,zeroLen;
int i;
if (SCHEME_VECTORP(vec) == FALSE) {
return TRUE;
}
if (SCHEME_VECTORP(vec) == FALSE) return TRUE;
len = SCHEME_VEC_SIZE(vec);
elts = SCHEME_VEC_ELS(vec);
@ -239,33 +235,18 @@ BOOL isRegularVector(Scheme_Object *vec) {
elt = elts[0];
zeroIsVec = SCHEME_VECTORP(elt);
if (zeroIsVec) {
zeroLen = SCHEME_VEC_SIZE(elt);
}
if (zeroIsVec) zeroLen = SCHEME_VEC_SIZE(elt);
if (isRegularVector(elt) == FALSE) {
return FALSE;
}
if (isRegularVector(elt) == FALSE) return FALSE;
for (i = 1; i < len; i++) {
elt = elts[i];
isVec = SCHEME_VECTORP(elt);
if (isVec != zeroIsVec) {
return FALSE;
}
if (isVec != zeroIsVec) return FALSE;
if (isVec) {
currLen = SCHEME_VEC_SIZE(elt);
if (currLen != zeroLen) {
return FALSE;
}
if (isRegularVector(elt) == FALSE) {
return FALSE;
}
if (currLen != zeroLen) return FALSE;
if (isRegularVector(elt) == FALSE) return FALSE;
}
}
@ -278,143 +259,62 @@ void* variantDataPointer(VARTYPE vt,VARIANTARG *pVariantArg)
char errBuff[256];
switch (vt) {
case VT_NULL :
return NULL;
case VT_I1 :
return &pVariantArg->cVal;
case VT_I1 | VT_BYREF :
return &pVariantArg->pcVal;
case VT_UI1 :
return &pVariantArg->bVal;
case VT_UI1 | VT_BYREF :
return &pVariantArg->pbVal;
case VT_I2 :
return &(pVariantArg->iVal);
case VT_I2 | VT_BYREF :
return &pVariantArg->piVal;
case VT_UI2 :
return &pVariantArg->uiVal;
case VT_UI2 | VT_BYREF :
return &pVariantArg->puiVal;
case VT_I4 :
return &pVariantArg->lVal;
case VT_I4 | VT_BYREF :
return &pVariantArg->plVal;
case VT_UI4 :
return &pVariantArg->ulVal;
case VT_UI4 | VT_BYREF :
return &pVariantArg->pulVal;
case VT_INT :
return &pVariantArg->intVal;
case VT_INT | VT_BYREF :
return &pVariantArg->pintVal;
case VT_UINT :
return &pVariantArg->uintVal;
case VT_UINT | VT_BYREF :
return &pVariantArg->puintVal;
// VT_USERDEFINED in the typeDesc indicates an ENUM,
// but VT_USERDEFINED is illegal to use in the DISPPARAMS.
// The right thing to do is pass it as an INT. Note that
// we have to bash out the variant tag.
// ** NOTE THAT VT_USERDEFINED | VT_BYREF IS NOT
// ** A REFERENCE TO AN INT
case VT_USERDEFINED:
return &pVariantArg->vt;
case VT_R4 :
return &pVariantArg->fltVal;
case VT_R4 | VT_BYREF :
return &pVariantArg->pfltVal;
case VT_R8 :
return &pVariantArg->dblVal;
case VT_R8 | VT_BYREF :
return &pVariantArg->pdblVal;
case VT_BSTR :
return &pVariantArg->bstrVal;
case VT_BSTR | VT_BYREF :
return &pVariantArg->pbstrVal;
case VT_CY :
return &pVariantArg->cyVal;
case VT_CY | VT_BYREF :
return &pVariantArg->pcyVal;
case VT_DATE :
return &pVariantArg->date;
case VT_DATE | VT_BYREF :
return &pVariantArg->pdate;
case VT_BOOL :
return &pVariantArg->boolVal;
case VT_BOOL | VT_BYREF :
return &pVariantArg->pboolVal;
case VT_ERROR :
return &pVariantArg->scode;
case VT_ERROR | VT_BYREF :
return &pVariantArg->pscode;
case VT_DISPATCH :
return &pVariantArg->pdispVal;
case VT_DISPATCH | VT_BYREF :
return &pVariantArg->ppdispVal;
// VT_USERDEFINED | VT_BYREF indicates that we should pass
// the IUnknown pointer of a COM object.
// VT_USERDEFINED | VT_BYREF is illegal in the DISPPARAMS, so
// we bash it out to VT_UNKNOWN.
case VT_USERDEFINED | VT_BYREF :
return &pVariantArg->punkVal;
case VT_VARIANT | VT_BYREF :
return &pVariantArg->pvarVal;
case VT_UNKNOWN :
return &pVariantArg->punkVal;
case VT_UNKNOWN | VT_BYREF :
return &pVariantArg->ppunkVal;
case VT_VARIANT :
return pVariantArg;
case VT_PTR:
scheme_signal_error ("unable to marshal VT_PTR");
case VT_NULL : return NULL;
case VT_I1 : return &pVariantArg->cVal;
case VT_I1 | VT_BYREF : return &pVariantArg->pcVal;
case VT_UI1 : return &pVariantArg->bVal;
case VT_UI1 | VT_BYREF : return &pVariantArg->pbVal;
case VT_I2 : return &(pVariantArg->iVal);
case VT_I2 | VT_BYREF : return &pVariantArg->piVal;
case VT_UI2 : return &pVariantArg->uiVal;
case VT_UI2 | VT_BYREF : return &pVariantArg->puiVal;
case VT_I4 : return &pVariantArg->lVal;
case VT_I4 | VT_BYREF : return &pVariantArg->plVal;
case VT_UI4 : return &pVariantArg->ulVal;
case VT_UI4 | VT_BYREF : return &pVariantArg->pulVal;
case VT_INT : return &pVariantArg->intVal;
case VT_INT | VT_BYREF : return &pVariantArg->pintVal;
case VT_UINT : return &pVariantArg->uintVal;
case VT_UINT | VT_BYREF : return &pVariantArg->puintVal;
// VT_USERDEFINED in the typeDesc indicates an ENUM, but
// VT_USERDEFINED is illegal to use in the DISPPARAMS. The right
// thing to do is pass it as an INT. Note that we have to bash out
// the variant tag.
// ** NOTE THAT VT_USERDEFINED | VT_BYREF IS NOT
// ** A REFERENCE TO AN INT
case VT_USERDEFINED : return &pVariantArg->vt;
case VT_R4 : return &pVariantArg->fltVal;
case VT_R4 | VT_BYREF : return &pVariantArg->pfltVal;
case VT_R8 : return &pVariantArg->dblVal;
case VT_R8 | VT_BYREF : return &pVariantArg->pdblVal;
case VT_BSTR : return &pVariantArg->bstrVal;
case VT_BSTR | VT_BYREF : return &pVariantArg->pbstrVal;
case VT_CY : return &pVariantArg->cyVal;
case VT_CY | VT_BYREF : return &pVariantArg->pcyVal;
case VT_DATE : return &pVariantArg->date;
case VT_DATE | VT_BYREF : return &pVariantArg->pdate;
case VT_BOOL : return &pVariantArg->boolVal;
case VT_BOOL | VT_BYREF : return &pVariantArg->pboolVal;
case VT_ERROR : return &pVariantArg->scode;
case VT_ERROR | VT_BYREF : return &pVariantArg->pscode;
case VT_DISPATCH : return &pVariantArg->pdispVal;
case VT_DISPATCH | VT_BYREF : return &pVariantArg->ppdispVal;
// VT_USERDEFINED | VT_BYREF indicates that we should pass the
// IUnknown pointer of a COM object.
// VT_USERDEFINED | VT_BYREF is illegal in the DISPPARAMS, so we
// bash it out to VT_UNKNOWN.
case VT_USERDEFINED | VT_BYREF : return &pVariantArg->punkVal;
case VT_VARIANT | VT_BYREF : return &pVariantArg->pvarVal;
case VT_UNKNOWN : return &pVariantArg->punkVal;
case VT_UNKNOWN | VT_BYREF : return &pVariantArg->ppunkVal;
case VT_VARIANT : return pVariantArg;
case VT_PTR :
scheme_signal_error("unable to marshal VT_PTR");
break;
default :
sprintf (errBuff, "Unable to marshal Scheme value into VARIANT: 0x%X",
pVariantArg->vt);
scheme_signal_error (errBuff);
sprintf(errBuff, "Unable to marshal Scheme value into VARIANT: 0x%X",
pVariantArg->vt);
scheme_signal_error(errBuff);
}
// Make the compiler happy
@ -423,59 +323,30 @@ void* variantDataPointer(VARTYPE vt,VARIANTARG *pVariantArg)
VARTYPE schemeValueToCOMType(Scheme_Object* val)
{
if (SCHEME_CHARP (val))
return VT_UI1;
else if (SCHEME_EXACT_INTEGERP (val))
return VT_I4;
if (SCHEME_CHARP(val)) return VT_UI1;
else if (SCHEME_EXACT_INTEGERP(val)) return VT_I4;
#ifdef MZ_USE_SINGLE_FLOATS
else if (SCHEME_FLTP (val))
return VT_R4;
else if (SCHEME_FLTP(val)) return VT_R4;
#endif
else if (SCHEME_DBLP (val))
return VT_R8;
else if (SCHEME_STRSYMP (val))
return VT_BSTR;
else if (MX_CYP (val))
return VT_CY;
else if (MX_DATEP (val))
return VT_DATE;
else if (val == scheme_false)
return VT_BOOL;
else if (val == scheme_true)
return VT_BOOL;
else if (MX_SCODEP (val))
return VT_ERROR;
else if (MX_COM_OBJP (val))
return VT_DISPATCH;
else if (MX_IUNKNOWNP (val))
return VT_UNKNOWN;
else if (SCHEME_VECTORP (val))
getSchemeVectorType(val);
else if (scheme_apply (mx_marshal_raw_scheme_objects, 0, NULL) == scheme_false)
scheme_signal_error ("Unable to inject Scheme value %V into VARIANT", val);
else
return VT_INT;
return VT_VARIANT; // If all else fails.
else if (SCHEME_DBLP(val)) return VT_R8;
else if (SCHEME_STRSYMP(val)) return VT_BSTR;
else if (MX_CYP(val)) return VT_CY;
else if (MX_DATEP(val)) return VT_DATE;
else if (val == scheme_false) return VT_BOOL;
else if (val == scheme_true) return VT_BOOL;
else if (MX_SCODEP(val)) return VT_ERROR;
else if (MX_COM_OBJP(val)) return VT_DISPATCH;
else if (MX_IUNKNOWNP(val)) return VT_UNKNOWN;
else if (SCHEME_VECTORP(val)) getSchemeVectorType(val);
else if (scheme_apply(mx_marshal_raw_scheme_objects, 0, NULL) == scheme_false)
scheme_signal_error("Unable to inject Scheme value %V into VARIANT", val);
else return VT_INT;
return VT_VARIANT; // If all else fails. (Eli: Looks like this is redundant)
}
void doSetArrayElts(Scheme_Object *vec,VARTYPE elementType,SAFEARRAY *theArray,
long *allIndices,long *currNdx, long offset) {
void doSetArrayElts(Scheme_Object *vec, VARTYPE elementType, SAFEARRAY *theArray,
long *allIndices, long *currNdx, long offset) {
VARIANT variant;
Scheme_Object *elt;
int len;
@ -487,46 +358,50 @@ void doSetArrayElts(Scheme_Object *vec,VARTYPE elementType,SAFEARRAY *theArray,
for (i = 0; i < len; i++) {
elt = SCHEME_VEC_ELS(vec)[i];
currNdx[offset] = i;
doSetArrayElts(elt,elementType,theArray,allIndices,currNdx, offset - 1);
doSetArrayElts(elt, elementType, theArray, allIndices,
currNdx, offset - 1);
}
}
else {
} else {
for (i = 0; i < len; i++) {
elt = SCHEME_VEC_ELS(vec)[i];
currNdx[offset] = i;
marshalSchemeValueToVariant(elt,&variant);
// I don't think this will ever happen (at least when calling this function from the scheme side).
// I don't think this will ever happen (at least when calling
// this function from the scheme side).
if (variant.vt != elementType) {
char errBuff[100];
sprintf (errBuff, "Unable to put an element of COM type 0x%x into an array of COM type 0x%x", variant.vt, elementType);
scheme_signal_error (errBuff);
sprintf(errBuff,
"Unable to put an element of COM type 0x%x into an array of COM type 0x%x",
variant.vt, elementType);
scheme_signal_error(errBuff);
}
SafeArrayPutElement(theArray,allIndices,variantDataPointer(elementType,&variant));
SafeArrayPutElement(theArray, allIndices,
variantDataPointer(elementType,&variant));
}
}
}
void setArrayElts(Scheme_Object *vec,VARTYPE elementType,SAFEARRAY *theArray,long numDims) {
void setArrayElts(Scheme_Object *vec, VARTYPE elementType, SAFEARRAY *theArray,
long numDims) {
long indices[MAXARRAYDIMS];
memset(indices,0,sizeof(indices));
doSetArrayElts(vec,elementType,theArray,indices,indices, numDims - 1);
}
// This doesn't work if we have an integer in a double array (or want a double array but have an integer vector).
// But it should work if we have doubles and integers (and return a VT_R8 array). Try to subtype it.
// This doesn't work if we have an integer in a double array (or want
// a double array but have an integer vector). But it should work if
// we have doubles and integers (and return a VT_R8 array). Try to
// subtype it.
VARTYPE getSchemeVectorType(Scheme_Object *vec) {
VARTYPE type;
int i, size = SCHEME_VEC_SIZE(vec);
type = schemeValueToCOMType(SCHEME_VEC_ELS(vec)[0]);
if (VT_VARIANT == type) return type;
for (i = 1; i < size; ++i)
if (type != schemeValueToCOMType(SCHEME_VEC_ELS(vec)[i]))
return VT_VARIANT;
return type;
}
@ -536,36 +411,20 @@ SAFEARRAY *schemeVectorToSafeArray(Scheme_Object *vec, VARTYPE *vt) {
int numDims;
int i;
if (SCHEME_VECTORP(vec) == FALSE) {
if (SCHEME_VECTORP(vec) == FALSE)
scheme_signal_error("Can't convert non-vector to SAFEARRAY");
}
if (isRegularVector(vec) == FALSE) {
if (isRegularVector(vec) == FALSE)
scheme_signal_error("Can't convert irregular vector to SAFEARRAY");
}
numDims = getSchemeVectorDims(vec);
if (numDims > MAXARRAYDIMS) {
if (numDims > MAXARRAYDIMS)
scheme_signal_error("Too many array dimensions");
}
rayBounds = (SAFEARRAYBOUND *)malloc(numDims * sizeof(SAFEARRAYBOUND));
for (i = 0; i < numDims; i++) {
rayBounds[i].lLbound = 0L;
}
for (i = 0; i < numDims; i++) rayBounds[i].lLbound = 0L;
setArrayEltCounts(vec,rayBounds,numDims);
*vt = getSchemeVectorType(vec);
theArray = SafeArrayCreate(*vt,numDims,rayBounds);
setArrayElts(vec,*vt,theArray,numDims);
return theArray;
}
#endif // MYSTERX_3M

3384
src/mysterx/mysterx.cxx
View File

File diff suppressed because it is too large Load Diff

10
src/mysterx/mysterx.h
View File

@ -706,8 +706,8 @@ extern unsigned long browserCount;
else { \
vaPtr->vt = getVarTypeFromElemDesc(&pFuncDesc->lprgelemdescParam[j]); \
if (vaPtr->vt == VT_VARIANT) { \
marshalSchemeValueToVariant(argv[i],vaPtr); \
va = *vaPtr; \
marshalSchemeValueToVariant(argv[i],vaPtr); \
va = *vaPtr; \
pushVariant(va); \
continue; \
} \
@ -740,15 +740,15 @@ extern unsigned long browserCount;
for ( ; j > 0; i--,j--,vaPtr--) { \
VariantInit(vaPtr); \
if (isDefaultParam(pFuncDesc,i)) { \
vaPtr = &(pFuncDesc->lprgelemdescParam[i].paramdesc.pparamdescex->varDefaultValue); \
vaPtr = &(pFuncDesc->lprgelemdescParam[i].paramdesc.pparamdescex->varDefaultValue); \
} \
else if (i == lcidIndex) { \
vaPtr->vt = VT_UI4; \
vaPtr->ulVal = LOCALE_SYSTEM_DEFAULT; \
} \
else { \
vaPtr->vt = VT_ERROR; \
vaPtr->lVal = DISP_E_PARAMNOTFOUND; \
vaPtr->vt = VT_ERROR; \
vaPtr->lVal = DISP_E_PARAMNOTFOUND; \
va = *vaPtr; \
pushVariant(va); \
continue; \