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); }