int tcl_pmepot_add(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
int cell_count, atom_count, sub_count, i, j;
Tcl_Obj **cell_list, **atom_list, **sub_list;
float cell[12], *atoms;
double d;
pmepot_data *data;
if ( objc != 4 ) {
Tcl_SetResult(interp,"args: handle {{o...} {a...} {b...} {c...}} {{x y z q}...}",TCL_VOLATILE);
return TCL_ERROR;
}
data = Tcl_GetAssocData(interp, Tcl_GetString(objv[1]), 0);
if ( ! data ) {
Tcl_SetResult(interp,"Pmepot bug: unable to access handle.",TCL_VOLATILE);
return TCL_ERROR;
}
if ( Tcl_ListObjGetElements(interp,objv[2],&cell_count,&cell_list) != TCL_OK ) return TCL_ERROR;
if ( cell_count != 4 ) {
Tcl_SetResult(interp,"cell format: {{ox oy oz} {ax ay az} {bx by bz} {cx cy cz}}",TCL_VOLATILE);
return TCL_ERROR;
}
for ( i=0; i<4; ++i ) {
if ( Tcl_ListObjGetElements(interp,cell_list[i],&sub_count,&sub_list) != TCL_OK ) return TCL_ERROR;
if ( sub_count != 3 ) {
Tcl_SetResult(interp,"cell format: {{ox oy oz} {ax ay az} {bx by bz} {cx cy cz}}",TCL_VOLATILE);
return TCL_ERROR;
}
for ( j=0; j<3; ++j ) {
if ( Tcl_GetDoubleFromObj(interp,sub_list[j],&d) != TCL_OK ) return TCL_ERROR;
cell[3*i+j] = d;
}
}
if ( Tcl_ListObjGetElements(interp,objv[3],&atom_count,&atom_list) != TCL_OK ) return TCL_ERROR;
atoms = malloc(atom_count*4*sizeof(float));
for ( i=0; i<atom_count; ++i ) {
if ( Tcl_ListObjGetElements(interp,atom_list[i],&sub_count,&sub_list) != TCL_OK ) { free(atoms); return TCL_ERROR; }
if ( sub_count != 4 ) {
Tcl_SetResult(interp,"atoms format: {{x y z q}...}",TCL_VOLATILE);
free(atoms); return TCL_ERROR;
}
for ( j=0; j<4; ++j ) {
if ( Tcl_GetDoubleFromObj(interp,sub_list[j],&d) != TCL_OK ) { free(atoms); return TCL_ERROR; }
atoms[4*i+j] = d;
}
}
if ( pmepot_add(data,cell,atom_count,atoms) ) {
Tcl_SetResult(interp,"Pmepot bug: pmepot_add failed.",TCL_VOLATILE);
free(atoms);
return TCL_ERROR;
}
free(atoms);
return TCL_OK;
}
/*
* Tk_StateMapLookup --
*
* A state map is a paired list of StateSpec / value pairs.
* Returns the value corresponding to the first matching state
* specification, or NULL if not found or an error occurs.
*/
Tcl_Obj *Ttk_StateMapLookup(
Tcl_Interp *interp, /* Where to leave error messages; may be NULL */
Ttk_StateMap map, /* State map */
Ttk_State state) /* State to look up */
{
Tcl_Obj **specs;
int nSpecs;
int j, status;
status = Tcl_ListObjGetElements(interp, map, &nSpecs, &specs);
if (status != TCL_OK)
return NULL;
for (j = 0; j < nSpecs; j += 2) {
Ttk_StateSpec spec;
status = Ttk_GetStateSpecFromObj(interp, specs[j], &spec);
if (status != TCL_OK)
return NULL;
if (Ttk_StateMatches(state, &spec))
return specs[j+1];
}
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "No match in state map", NULL);
}
return NULL;
}
int parse_imprlist(NLEnergy *p, Tcl_Interp *interp,
Tcl_Obj *const obj, boolean invert) {
char *imprsel = Array_data(&(p->imprsel));
char *invsel = Array_data(&(p->invsel));
char *sel = (invert ? invsel : imprsel);
const int32 nimprs = Topology_impr_array_length(&(p->topo));
int32 id;
Tcl_Obj **objv;
int objc, n;
if (invert) {
memset(invsel, 0, nimprs);
}
if ((id=parse_impr(p,interp,obj)) >= 0) { /* could be a singleton */
sel[id] = TRUE;
}
else { /* its a list of imprs */
if (TCL_ERROR==Tcl_ListObjGetElements(interp, obj, &objc, &objv)) {
return FAIL;
}
for (n = 0; n < objc; n++) {
if ((id=parse_impr(p,interp,objv[n])) < 0) {
return FAIL;
}
sel[id] = TRUE;
}
}
if (invert) {
for (id = 0; id < nimprs; id++) {
if (FALSE==invsel[id]) imprsel[id] = TRUE;
}
}
return OK;
}
static AP_Obj TclToPrologObj0(Tcl_Interp *interp, Tcl_Obj *tcl_obj, AP_World *w, AP_Obj *vars)
{
AP_Obj prolog_obj;
if (tcl_obj->typePtr == tcl_integer_type) {
prolog_obj = AP_NewNumberFromLong(w, tcl_obj->internalRep.longValue);
} else if (tcl_obj->typePtr == tcl_double_type) {
prolog_obj = AP_NewFloatFromDouble(w, tcl_obj->internalRep.doubleValue);
} else if (tcl_obj->typePtr == tcl_list_type) {
int i, objc;
AP_Obj list;
Tcl_Obj **objv;
Tcl_ListObjGetElements(interp, tcl_obj, &objc, &objv);
for (i = objc-1, list = AP_NullList(w); i >= 0; i--) {
list = AP_NewInitList(w, TclToPrologObj0(interp, objv[i], w, vars), list);
}
prolog_obj = list;
} else {
prolog_obj = AP_NewUIAFromStr(w, Tcl_GetStringFromObj(tcl_obj, NULL));
}
return prolog_obj;
}
/* Ttk_GetTagSetFromObj --
* Extract an array of pointers to Ttk_Tags from a Tcl_Obj.
* objPtr may be NULL, in which case a new empty tag set is returned.
*
* Returns NULL and leaves an error message in interp->result on error.
*
* Non-NULL results must be passed to Ttk_FreeTagSet().
*/
Ttk_TagSet Ttk_GetTagSetFromObj(
Tcl_Interp *interp, Ttk_TagTable tagTable, Tcl_Obj *objPtr)
{
Ttk_TagSet tagset = (Ttk_TagSet)(ckalloc(sizeof *tagset));
Tcl_Obj **objv;
int i, objc;
if (objPtr == NULL) {
tagset->tags = NULL;
tagset->nTags = 0;
return tagset;
}
if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
ckfree((ClientData)tagset);
return NULL;
}
tagset->tags = (Ttk_Tag*)ckalloc((objc+1) * sizeof(Ttk_Tag));
for (i=0; i<objc; ++i) {
tagset->tags[i] = Ttk_GetTagFromObj(tagTable, objv[i]);
}
tagset->tags[i] = NULL;
tagset->nTags = objc;
return tagset;
}
/* Ttk_GetStateMapFromObj --
* Returns a Ttk_StateMap from a Tcl_Obj*.
* Since a Ttk_StateMap is just a specially-formatted Tcl_Obj,
* this basically just checks for errors.
*/
Ttk_StateMap Ttk_GetStateMapFromObj(
Tcl_Interp *interp, /* Where to leave error messages; may be NULL */
Tcl_Obj *mapObj) /* State map */
{
Tcl_Obj **specs;
int nSpecs;
int j, status;
status = Tcl_ListObjGetElements(interp, mapObj, &nSpecs, &specs);
if (status != TCL_OK)
return NULL;
if (nSpecs % 2 != 0) {
if (interp)
Tcl_SetResult(interp,
"State map must have an even number of elements",
TCL_STATIC);
return 0;
}
for (j = 0; j < nSpecs; j += 2) {
Ttk_StateSpec spec;
if (Ttk_GetStateSpecFromObj(interp, specs[j], &spec) != TCL_OK)
return NULL;
}
return mapObj;
}
/*
* Tk_StateMapLookup --
*
* A state map is a paired list of StateSpec / value pairs.
* Returns the value corresponding to the first matching state
* specification, or NULL if not found or an error occurs.
*/
Tcl_Obj *Ttk_StateMapLookup(
Tcl_Interp *interp, /* Where to leave error messages; may be NULL */
Ttk_StateMap map, /* State map */
Ttk_State state) /* State to look up */
{
Tcl_Obj **specs;
int nSpecs;
int j, status;
status = Tcl_ListObjGetElements(interp, map, &nSpecs, &specs);
if (status != TCL_OK)
return NULL;
for (j = 0; j < nSpecs; j += 2) {
Ttk_StateSpec spec;
status = Ttk_GetStateSpecFromObj(interp, specs[j], &spec);
if (status != TCL_OK)
return NULL;
if (Ttk_StateMatches(state, &spec))
return specs[j+1];
}
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("No match in state map", -1));
Tcl_SetErrorCode(interp, "TTK", "STATE", "UNMATCHED", NULL);
}
return NULL;
}
SEXP RTcl_ObjAsCharVector(SEXP args)
{
int count;
Tcl_Obj **elem, *obj;
int ret, i;
SEXP ans;
obj = (Tcl_Obj *) R_ExternalPtrAddr(CADR(args));
if (!obj) error(_("invalid tclObj -- perhaps saved from another session?"));
ret = Tcl_ListObjGetElements(RTcl_interp, obj, &count, &elem);
if (ret != TCL_OK)
return RTcl_StringFromObj(args);
PROTECT(ans = allocVector(STRSXP, count));
for (i = 0 ; i < count ; i++) {
char *s;
Tcl_DString s_ds;
Tcl_DStringInit(&s_ds);
/* FIXME: could use UTF-8 here */
s = Tcl_UtfToExternalDString(NULL,
(Tcl_GetStringFromObj(elem[i], NULL)),
-1, &s_ds);
SET_STRING_ELT(ans, i, mkChar(s));
Tcl_DStringFree(&s_ds);
}
UNPROTECT(1);
return ans;
}
int NLEnergy_add_bondprm(NLEnergy *p, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
ForcePrm *fprm = &(p->fprm);
BondPrm a;
const char *t = NULL;
int n;
double d;
Tcl_Obj **aobjv;
int aobjc;
int32 id;
TEXT("bondprm");
if (objc != 3) return ERROR(ERR_EXPECT);
t = Tcl_GetStringFromObj(objv[0], &n);
if (n >= sizeof(AtomType) || 0==t[0]) return ERROR(ERR_EXPECT);
strcpy(a.atomType[0], t);
t = Tcl_GetStringFromObj(objv[1], &n);
if (n >= sizeof(AtomType) || 0==t[0]) return ERROR(ERR_EXPECT);
strcpy(a.atomType[1], t);
if (TCL_ERROR==Tcl_ListObjGetElements(interp, objv[2], &aobjc, &aobjv)
|| aobjc != 2) return ERROR(ERR_EXPECT);
if (TCL_ERROR==Tcl_GetDoubleFromObj(interp, aobjv[0], &d)
|| d < 0) return ERROR(ERR_EXPECT);
a.k = d * ENERGY_INTERNAL;
if (TCL_ERROR==Tcl_GetDoubleFromObj(interp, aobjv[1], &d)
|| d < 0) return ERROR(ERR_EXPECT);
a.r0 = d;
if ((id=ForcePrm_add_bondprm(fprm, &a)) < OK) {
return (id < FAIL ? ERROR(id) : FAIL);
}
if ((n=Topology_setprm_bond_array(&(p->topo))) < FAIL) return ERROR(n);
return OK;
}
SEXP RTcl_ObjAsIntVector(SEXP args)
{
int count;
Tcl_Obj **elem, *obj;
int ret, i;
int x;
SEXP ans;
obj = (Tcl_Obj *) R_ExternalPtrAddr(CADR(args));
if (!obj) error(_("invalid tclObj -- perhaps saved from another session?"));
/* First try for single value */
ret = Tcl_GetIntFromObj(RTcl_interp, obj, &x);
if (ret == TCL_OK) return ScalarInteger(x);
/* Then try as list */
ret = Tcl_ListObjGetElements(RTcl_interp, obj, &count, &elem);
if (ret != TCL_OK) /* didn't work, return NULL */
return R_NilValue;
ans = allocVector(INTSXP, count);
for (i = 0 ; i < count ; i++){
ret = Tcl_GetIntFromObj(RTcl_interp, elem[i], &x);
if (ret != TCL_OK) x = NA_INTEGER;
INTEGER(ans)[i] = x;
}
return ans;
}
/* Ttk_GetBorderFromObj --
* Same as Ttk_GetPaddingFromObj, except padding is a list of integers
* instead of Tk_Pixel specifications. Does not require a Tk_Window
* parameter.
*
*/
int Ttk_GetBorderFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Ttk_Padding *pad)
{
Tcl_Obj **padv;
int i, padc, pixels[4];
if (TCL_OK != Tcl_ListObjGetElements(interp, objPtr, &padc, &padv)) {
goto error;
}
if (padc > 4) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "Wrong #elements in border spec", NULL);
}
goto error;
}
for (i=0; i < padc; ++i) {
if (Tcl_GetIntFromObj(interp, padv[i], &pixels[i]) != TCL_OK) {
goto error;
}
}
TTKInitPadding(padc, pixels, pad);
return TCL_OK;
error:
pad->left = pad->top = pad->right = pad->bottom = 0;
return TCL_ERROR;
}
SEXP RTcl_ObjAsRawVector(SEXP args)
{
int nb, count, i, j;
Tcl_Obj **elem, *obj;
unsigned char *ret;
SEXP ans, el;
obj = (Tcl_Obj *) R_ExternalPtrAddr(CADR(args));
if (!obj) error(_("invalid tclObj -- perhaps saved from another session?"));
ret = Tcl_GetByteArrayFromObj(obj, &nb);
if (ret) {
ans = allocVector(RAWSXP, nb);
for (j = 0 ; j < nb ; j++) RAW(ans)[j] = ret[j];
return ans;
}
/* Then try as list */
if (Tcl_ListObjGetElements(RTcl_interp, obj, &count, &elem)
!= TCL_OK) return R_NilValue;
PROTECT(ans = allocVector(VECSXP, count));
for (i = 0 ; i < count ; i++) {
el = allocVector(RAWSXP, nb);
SET_VECTOR_ELT(ans, i, el);
ret = Tcl_GetByteArrayFromObj(elem[i], &nb);
for (j = 0 ; j < nb ; j++) RAW(el)[j] = ret[j];
}
UNPROTECT(1);
return ans;
}
/* Ttk_GetStateMapFromObj --
* Returns a Ttk_StateMap from a Tcl_Obj*.
* Since a Ttk_StateMap is just a specially-formatted Tcl_Obj,
* this basically just checks for errors.
*/
Ttk_StateMap Ttk_GetStateMapFromObj(
Tcl_Interp *interp, /* Where to leave error messages; may be NULL */
Tcl_Obj *mapObj) /* State map */
{
Tcl_Obj **specs;
int nSpecs;
int j, status;
status = Tcl_ListObjGetElements(interp, mapObj, &nSpecs, &specs);
if (status != TCL_OK)
return NULL;
if (nSpecs % 2 != 0) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"State map must have an even number of elements", -1));
Tcl_SetErrorCode(interp, "TTK", "VALUE", "STATEMAP", NULL);
}
return 0;
}
for (j = 0; j < nSpecs; j += 2) {
Ttk_StateSpec spec;
if (Ttk_GetStateSpecFromObj(interp, specs[j], &spec) != TCL_OK)
return NULL;
}
return mapObj;
}
int parse_ivector (Tcl_Obj * const obj, std::vector<int> &vec, Tcl_Interp *interp, bool fromDouble)
{
Tcl_Obj **data;
int num;
double d;
if (Tcl_ListObjGetElements(interp, obj, &num, &data) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing arguments", TCL_STATIC);
return -1;
}
vec.resize(num);
if (fromDouble == false) {
for (int i = 0; i < num; i++) {
if (Tcl_GetIntFromObj(interp, data[i], &vec[i]) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing vector element as integer", TCL_STATIC);
return -1;
}
}
} else {
// do a double-to-int conversion first
for (int i = 0; i < num; i++) {
if (Tcl_GetDoubleFromObj(interp, data[i], &d) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing vector element as integer", TCL_STATIC);
return -1;
}
vec[i] = int (d);
}
}
return num;
}
Tk_PathDash *
TkPathDashNew(Tcl_Interp *interp, Tcl_Obj *dashObjPtr)
{
Tk_PathDash *dashPtr;
int objc, i;
double value;
Tcl_Obj **objv;
dashPtr = (Tk_PathDash *) ckalloc(sizeof(Tk_PathDash));
dashPtr->number = 0;
dashPtr->array = NULL;
if (Tcl_ListObjGetElements(interp, dashObjPtr, &objc, (Tcl_Obj ***) &objv) != TCL_OK) {
goto error;
}
dashPtr->number = objc;
dashPtr->array = (float *) ckalloc(objc * sizeof(float));
for (i = 0; i < objc; i++) {
if (Tcl_GetDoubleFromObj(interp, objv[i], &value) != TCL_OK) {
goto error;
}
dashPtr->array[i] = (float) value;
}
return dashPtr;
error:
TkPathDashFree(dashPtr);
return NULL;
}
/* helper function: recurse through lists to get to the data */
static int read_list_list(Tcl_Interp *interp, Tcl_Obj *tdata, int curdim, int ndim,
int *ndat, kiss_fft_cpx *input, int *alldim)
{
int i,num_el;
Tcl_Obj **clist;
if (Tcl_ListObjGetElements(interp, tdata, &num_el, &clist) != TCL_OK) {
return TCL_ERROR;
}
if (num_el != ndat[curdim]) { /* consistency check. all lists must be the same length */
return TCL_ERROR;
}
if (ndim == curdim+1) { /* end of recursion. read numbers and increment counter accordingly */
for (i=0; i<num_el; ++i) {
if (read_list_cpx(interp, clist[i], input + *alldim) != TCL_OK) {
return TCL_ERROR;
}
++(*alldim);
}
} else { /* recurse into next dimension after consistency check. */
if (curdim+1 > ndim) return TCL_ERROR;
for (i=0; i<num_el; ++i) {
if (read_list_list(interp, clist[i], curdim+1, ndim, ndat, input, alldim) != TCL_OK) {
return TCL_ERROR;
}
}
}
return TCL_OK;
}
static int
listObjToParameters (Tcl_Interp *interp, Tcl_Obj *pParameters, Method &method)
{
int paramCount;
if (Tcl_ListObjLength(interp, pParameters, ¶mCount) != TCL_OK) {
return TCL_ERROR;
}
for (int i = 0; i < paramCount; ++i) {
Tcl_Obj *pParameter;
if (Tcl_ListObjIndex(interp, pParameters, i, &pParameter)
!= TCL_OK) {
return TCL_ERROR;
}
int paramObjc;
Tcl_Obj **paramObjv;
if (Tcl_ListObjGetElements(interp, pParameter, ¶mObjc, ¶mObjv)
!= TCL_OK) {
return TCL_ERROR;
}
Parameter parameter(
Tcl_GetStringFromObj(paramObjv[0], 0),
Tcl_GetStringFromObj(paramObjv[1], 0),
Tcl_GetStringFromObj(paramObjv[2], 0));
method.addParameter(parameter);
}
return TCL_OK;
}
int tcl_pmepot_create(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
int dims_count, dims[3], i;
Tcl_Obj **dims_list;
double ewald_factor;
char namebuf[128];
int *countptr;
pmepot_data *data;
if ( objc != 3 ) {
Tcl_SetResult(interp,"args: {na nb nc} ewald_factor",TCL_VOLATILE);
return TCL_ERROR;
}
if ( Tcl_ListObjGetElements(interp,objv[1],&dims_count,&dims_list) != TCL_OK ) return TCL_ERROR;
if ( dims_count != 3 ) {
Tcl_SetResult(interp,"args: {na nb nc} ewald_factor",TCL_VOLATILE);
return TCL_ERROR;
}
for ( i=0; i<3; ++i ) {
if ( Tcl_GetIntFromObj(interp,dims_list[i],&dims[i]) != TCL_OK ) return TCL_ERROR;
if ( dims[i] < 8 ) {
Tcl_SetResult(interp,"each grid dimension must be at least 8",TCL_VOLATILE);
return TCL_ERROR;
}
}
if ( dims[2] % 2 ) {
Tcl_SetResult(interp,"third grid dimension must be even",TCL_VOLATILE);
return TCL_ERROR;
}
if ( Tcl_GetDoubleFromObj(interp,objv[2],&ewald_factor) != TCL_OK ) {
return TCL_ERROR;
}
if ( ewald_factor <= 0. ) {
Tcl_SetResult(interp,"ewald factor must be positive",TCL_VOLATILE);
return TCL_ERROR;
}
countptr = Tcl_GetAssocData(interp, "Pmepot_count", 0);
if ( ! countptr ) {
Tcl_SetResult(interp,"Pmepot bug: Pmepot_count not initialized.",TCL_VOLATILE);
return TCL_ERROR;
}
data = pmepot_create(dims, ewald_factor);
if ( ! data ) {
Tcl_SetResult(interp,"Pmepot bug: pmepot_create failed.",TCL_VOLATILE);
return TCL_ERROR;
}
sprintf(namebuf,"Pmepot_%d",*countptr);
Tcl_SetAssocData(interp,namebuf,pmepot_deleteproc,(ClientData)data);
*countptr += 1;
Tcl_SetResult(interp,namebuf,TCL_VOLATILE);
return TCL_OK;
}
static int LinTransitionSet(
ClientData clientData,
Tcl_Interp *interp, /* Current interp; may be used for errors. */
Tk_Window tkwin, /* Window for which option is being set. */
Tcl_Obj **value, /* Pointer to the pointer to the value object.
* We use a pointer to the pointer because
* we may need to return a value (NULL). */
char *recordPtr, /* Pointer to storage for the widget record. */
int internalOffset, /* Offset within *recordPtr at which the
* internal value is to be stored. */
char *oldInternalPtr, /* Pointer to storage for the old value. */
int flags) /* Flags for the option, set Tk_SetOptions. */
{
char *internalPtr;
int objEmpty = 0;
Tcl_Obj *valuePtr;
double z[4] = {0.0, 0.0, 1.0, 0.0}; /* Defaults according to SVG. */
PathRect *newrc = NULL;
valuePtr = *value;
internalPtr = ComputeSlotAddress(recordPtr, internalOffset);
objEmpty = ObjectIsEmpty(valuePtr);
/*
* Important: the new value for the transition is not yet
* stored into the style! transObj may be NULL!
* The new value is stored in style *after* we return TCL_OK.
*/
if ((flags & TK_OPTION_NULL_OK) && objEmpty) {
valuePtr = NULL;
} else {
int i, len;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, valuePtr, &len, &objv) != TCL_OK) {
return TCL_ERROR;
}
if (len != 4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-lineartransition must have four elements", -1));
return TCL_ERROR;
}
for (i = 0; i < 4; i++) {
if (Tcl_GetDoubleFromObj(interp, objv[i], z+i) != TCL_OK) {
return TCL_ERROR;
}
}
newrc = (PathRect *) ckalloc(sizeof(PathRect));
newrc->x1 = z[0];
newrc->y1 = z[1];
newrc->x2 = z[2];
newrc->y2 = z[3];
}
if (internalPtr != NULL) {
*((PathRect **) oldInternalPtr) = *((PathRect **) internalPtr);
*((PathRect **) internalPtr) = newrc;
}
return TCL_OK;
}
int
GetIndexFromObjList(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
Tcl_Obj *tableObjPtr, /* List of strings to compare against the
* value of objPtr. */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
int objc, result, t;
Tcl_Obj **objv;
const char **tablePtr;
/*
* Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
* of the code there. This is a bit ineffiecient but simpler.
*/
result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
/*
* Build a string table from the list.
*/
tablePtr = ckalloc((objc + 1) * sizeof(char *));
for (t = 0; t < objc; t++) {
if (objv[t] == objPtr) {
/*
* An exact match is always chosen, so we can stop here.
*/
ckfree(tablePtr);
*indexPtr = t;
return TCL_OK;
}
tablePtr[t] = Tcl_GetString(objv[t]);
}
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
sizeof(char *), msg, flags, indexPtr);
/*
* The internal rep must be cleared since tablePtr will go away.
*/
TclFreeIntRep(objPtr);
ckfree(tablePtr);
return result;
}
/*
* setFromAnyProc
*/
static int
FilterregSetFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr /* The object to convert. */
) {
Tcl_Obj *guardObj = NULL, *filterObj;
Filterreg *filterregPtr;
int oc; Tcl_Obj **ov;
if (Tcl_ListObjGetElements(interp, objPtr, &oc, &ov) == TCL_OK) {
if (oc == 1) {
filterObj = ov[0];
/* } else if (oc == 2) {
filterObj = ov[0];
guardObj = ov[1];*/
} else if (oc == 3 && !strcmp(ObjStr(ov[1]), NsfGlobalStrings[NSF_GUARD_OPTION])) {
filterObj = ov[0];
guardObj = ov[2];
} else {
return TCL_ERROR;
}
} else {
return TCL_ERROR;
}
/*
* Conversion was ok.
* Allocate structure ...
*/
filterregPtr = NEW(Filterreg);
filterregPtr->filterObj = filterObj;
filterregPtr->guardObj = guardObj;
/*
* ... and increment refCounts
*/
INCR_REF_COUNT2("filterregPtr->filterObj", filterObj);
if (guardObj != NULL) {INCR_REF_COUNT2("filterregPtr->guardObj", guardObj);}
/*fprintf(stderr, "FilterregSetFromAny alloc filterreg %p class %p guard %p\n",
filterregPtr, filterregPtr->filterObj, filterregPtr->guardObj);*/
/*
* Free the old internal representation and store own structure as internal
* representation.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *)filterregPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &NsfFilterregObjType;
return TCL_OK;
}
/*
* Helper function to interpret color_idx values.
*/
static int tclGd_GetColor(Tcl_Interp * interp, Tcl_Obj * obj, int *color)
{
int nlist, retval = TCL_OK;
Tcl_Obj **theList;
char *firsttag, *secondtag;
/* Assume it's an integer, check other cases on failure. */
if (Tcl_GetIntFromObj(interp, obj, color) == TCL_OK)
return TCL_OK;
else {
Tcl_ResetResult(interp);
if (Tcl_ListObjGetElements(interp, obj, &nlist, &theList) !=
TCL_OK)
return TCL_ERROR;
if (nlist < 1 || nlist > 2)
retval = TCL_ERROR;
else {
firsttag = Tcl_GetString(theList[0]);
switch (firsttag[0]) {
case 'b':
*color = gdBrushed;
if (nlist == 2) {
secondtag = Tcl_GetString(theList[1]);
if (secondtag[0] == 's') {
*color = gdStyledBrushed;
} else {
retval = TCL_ERROR;
}
}
break;
case 's':
*color = gdStyled;
if (nlist == 2) {
secondtag = Tcl_GetString(theList[1]);
if (secondtag[0] == 'b') {
*color = gdStyledBrushed;
} else {
retval = TCL_ERROR;
}
}
break;
case 't':
*color = gdTiled;
break;
default:
retval = TCL_ERROR;
}
}
}
if (retval == TCL_ERROR)
Tcl_SetResult(interp, "Malformed special color value", TCL_STATIC);
return retval;
}
static int StateSpecSetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr)
{
int status;
int objc;
Tcl_Obj **objv;
int i;
unsigned int onbits = 0, offbits = 0;
status = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv);
if (status != TCL_OK)
return status;
for (i = 0; i < objc; ++i) {
const char *stateName = Tcl_GetString(objv[i]);
int on, j;
if (*stateName == '!') {
++stateName;
on = 0;
} else {
on = 1;
}
for (j = 0; stateNames[j] != 0; ++j) {
if (strcmp(stateName, stateNames[j]) == 0)
break;
}
if (stateNames[j] == 0) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Invalid state name %s", stateName));
Tcl_SetErrorCode(interp, "TTK", "VALUE", "STATE", NULL);
}
return TCL_ERROR;
}
if (on) {
onbits |= (1<<j);
} else {
offbits |= (1<<j);
}
}
/* Invalidate old intrep:
*/
if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) {
objPtr->typePtr->freeIntRepProc(objPtr);
}
objPtr->typePtr = &StateSpecObjType;
objPtr->internalRep.longValue = (onbits << 16) | offbits;
return TCL_OK;
}
static int RadTransitionSet(
ClientData clientData,
Tcl_Interp *interp, /* Current interp; may be used for errors. */
Tk_Window tkwin, /* Window for which option is being set. */
Tcl_Obj **value, /* Pointer to the pointer to the value object.
* We use a pointer to the pointer because
* we may need to return a value (NULL). */
char *recordPtr, /* Pointer to storage for the widget record. */
int internalOffset, /* Offset within *recordPtr at which the
internal value is to be stored. */
char *oldInternalPtr, /* Pointer to storage for the old value. */
int flags) /* Flags for the option, set Tk_SetOptions. */
{
char *internalPtr;
int objEmpty = 0;
Tcl_Obj *valuePtr;
double z[5] = {0.5, 0.5, 0.5, 0.5, 0.5};
RadialTransition *newrc = NULL;
valuePtr = *value;
internalPtr = ComputeSlotAddress(recordPtr, internalOffset);
objEmpty = ObjectIsEmpty(valuePtr);
if ((flags & TK_OPTION_NULL_OK) && objEmpty) {
valuePtr = NULL;
} else {
int i, len;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, valuePtr, &len, &objv) != TCL_OK) {
return TCL_ERROR;
}
if ((len == 1) || (len == 4) || (len > 5)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-radialtransition must be a list {cx cy ?r? ?fx fy?}", -1));
return TCL_ERROR;
}
for (i = 0; i < len; i++) {
if (Tcl_GetDoubleFromObj(interp, objv[i], z+i) != TCL_OK) {
return TCL_ERROR;
}
}
newrc = (RadialTransition *) ckalloc(sizeof(RadialTransition));
newrc->centerX = z[0];
newrc->centerY = z[1];
newrc->radius = z[2];
newrc->focalX = z[3];
newrc->focalY = z[4];
}
if (internalPtr != NULL) {
*((RadialTransition **) oldInternalPtr) = *((RadialTransition **) internalPtr);
*((RadialTransition **) internalPtr) = newrc;
}
return TCL_OK;
}
FileSystem::FileSystem(Tcl_Interp* interp,
Tcl_Obj* list)
{
// Set up for iteration
int listLength,
listIndex = 0;
Tcl_Obj** templates;
if (Tcl_ListObjGetElements(interp,
list,
&listLength,
&templates) == TCL_ERROR)
return;
// Iterate through the templates
while (listIndex < listLength)
{
int templateDataLength;
Tcl_Obj** templateData;
Tcl_ListObjGetElements(interp,
templates[listIndex],
&templateDataLength,
&templateData);
if (templateDataLength != 2)
continue;
int nameLength,
sourceLength;
const char* name = Tcl_GetStringFromObj(templateData[0],
&nameLength),
* source = Tcl_GetStringFromObj(templateData[1],
&sourceLength);
this->_map.insert(FileSystemPair(std::string(name),
std::string(source)));
listIndex++;
}
}
static int
map_arg_registers (Tcl_Interp *interp, int objc, Tcl_Obj **objv,
map_func func, map_arg arg)
{
int regnum, numregs;
/* Note that the test for a valid register must include checking the
gdbarch_register_name because gdbarch_num_regs may be allocated for
the union of the register sets within a family of related processors.
In this case, some entries of gdbarch_register_name will change
depending upon the particular processor being debugged. */
numregs = (gdbarch_num_regs (get_current_arch ())
+ gdbarch_num_pseudo_regs (get_current_arch ()));
if (objc == 0) /* No args, just do all the regs */
{
result_ptr->flags |= GDBTK_MAKES_LIST;
for (regnum = 0; regnum < numregs; regnum++)
{
if (gdbarch_register_name (get_current_arch (), regnum) == NULL
|| *(gdbarch_register_name (get_current_arch (), regnum)) == '\0')
continue;
func (regnum, arg);
}
return TCL_OK;
}
if (objc == 1)
if (Tcl_ListObjGetElements (interp, *objv, &objc, &objv ) != TCL_OK)
return TCL_ERROR;
if (objc > 1)
result_ptr->flags |= GDBTK_MAKES_LIST;
/* Else, list of register #s, just do listed regs */
for (; objc > 0; objc--, objv++)
{
if (Tcl_GetIntFromObj (NULL, *objv, ®num) != TCL_OK)
{
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
return TCL_ERROR;
}
if (regnum >= 0 && regnum < numregs)
func (regnum, arg);
else
{
Tcl_SetStringObj (result_ptr->obj_ptr, "bad register number", -1);
return TCL_ERROR;
}
}
return TCL_OK;
}
int32 parse_bond(NLEnergy *p, Tcl_Interp *interp, Tcl_Obj *const obj) {
int32 a0, a1;
Tcl_Obj **objv;
int objc = 0;
if (TCL_ERROR==Tcl_ListObjGetElements(interp, obj, &objc, &objv)
|| objc != 2
|| (a0=atomid_from_obj(p,interp,objv[0])) < 0
|| (a1=atomid_from_obj(p,interp,objv[1])) < 0) {
return FAIL;
}
return Topology_getid_bond(&(p->topo), a0, a1);
}
static void
fillSafeArray (
Tcl_Obj *pList,
SAFEARRAY *psa,
unsigned dim,
long *pIndices,
Tcl_Interp *interp,
bool addRef)
{
HRESULT hr;
// Get index range.
long lowerBound;
hr = SafeArrayGetLBound(psa, dim, &lowerBound);
if (FAILED(hr)) {
_com_issue_error(hr);
}
long upperBound;
hr = SafeArrayGetUBound(psa, dim, &upperBound);
if (FAILED(hr)) {
_com_issue_error(hr);
}
int numElements;
Tcl_Obj **pElements;
if (Tcl_ListObjGetElements(interp, pList, &numElements, &pElements)
!= TCL_OK) {
_com_issue_error(E_INVALIDARG);
}
unsigned dim1 = dim - 1;
if (dim < SafeArrayGetDim(psa)) {
// Create list of list for multi-dimensional array.
for (int i = 0; i < numElements; ++i) {
pIndices[dim1] = i;
fillSafeArray(pElements[i], psa, dim + 1, pIndices, interp, addRef);
}
} else {
for (int i = 0; i < numElements; ++i) {
TclObject element(pElements[i]);
NativeValue elementVar;
element.toNativeValue(&elementVar, Type::variant(), interp, addRef);
pIndices[dim1] = i;
hr = SafeArrayPutElement(psa, pIndices, &elementVar);
if (FAILED(hr)) {
_com_issue_error(hr);
}
}
}
}
static void tvfsExecTcl(
Testvfs *p,
const char *zMethod,
Tcl_Obj *arg1,
Tcl_Obj *arg2,
Tcl_Obj *arg3
){
int rc; /* Return code from Tcl_EvalObj() */
int nArg; /* Elements in eval'd list */
int nScript;
Tcl_Obj ** ap;
assert( p->pScript );
if( !p->apScript ){
int nByte;
int i;
if( TCL_OK!=Tcl_ListObjGetElements(p->interp, p->pScript, &nScript, &ap) ){
Tcl_BackgroundError(p->interp);
Tcl_ResetResult(p->interp);
return;
}
p->nScript = nScript;
nByte = (nScript+TESTVFS_MAX_ARGS)*sizeof(Tcl_Obj *);
p->apScript = (Tcl_Obj **)ckalloc(nByte);
memset(p->apScript, 0, nByte);
for(i=0; i<nScript; i++){
p->apScript[i] = ap[i];
}
}
p->apScript[p->nScript] = Tcl_NewStringObj(zMethod, -1);
p->apScript[p->nScript+1] = arg1;
p->apScript[p->nScript+2] = arg2;
p->apScript[p->nScript+3] = arg3;
for(nArg=p->nScript; p->apScript[nArg]; nArg++){
Tcl_IncrRefCount(p->apScript[nArg]);
}
rc = Tcl_EvalObjv(p->interp, nArg, p->apScript, TCL_EVAL_GLOBAL);
if( rc!=TCL_OK ){
Tcl_BackgroundError(p->interp);
Tcl_ResetResult(p->interp);
}
for(nArg=p->nScript; p->apScript[nArg]; nArg++){
Tcl_DecrRefCount(p->apScript[nArg]);
p->apScript[nArg] = 0;
}
}
int32 parse_impr(NLEnergy *p, Tcl_Interp *interp, Tcl_Obj *const obj) {
int32 a0, a1, a2, a3;
Tcl_Obj **objv;
int objc;
if (TCL_ERROR==Tcl_ListObjGetElements(interp, obj, &objc, &objv)
|| objc != 4
|| (a0=atomid_from_obj(p,interp,objv[0])) < 0
|| (a1=atomid_from_obj(p,interp,objv[1])) < 0
|| (a2=atomid_from_obj(p,interp,objv[2])) < 0
|| (a3=atomid_from_obj(p,interp,objv[3])) < 0) {
return FAIL;
}
return Topology_getid_impr(&(p->topo), a0, a1, a2, a3);
}
