C++ Tcl_ListObjGetElements函数代码示例

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

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