Fork me on GitHub

source: git/external/tcl/tclIndexObj.c

Last change on this file was d7d2da3, checked in by pavel <pavel@…>, 12 years ago

move branches/ModularDelphes to trunk
  • Property mode set to 100644
File size: 9.1 KB
Line 
1/*
2 * tclIndexObj.c --
3 *
4 * This file implements objects of type "index". This object type
5 * is used to lookup a keyword in a table of valid values and cache
6 * the index of the matching entry.
7 *
8 * Copyright (c) 1997 Sun Microsystems, Inc.
9 *
10 * See the file "license.terms" for information on usage and redistribution
11 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id: tclIndexObj.c,v 1.1 2008-06-04 13:58:07 demin Exp $
14 */
15
16#include "tclInt.h"
17
18/*
19 * Prototypes for procedures defined later in this file:
20 */
21
22static void DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
23 Tcl_Obj *copyPtr));
24static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
25 Tcl_Obj *objPtr));
26static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr));
27
28/*
29 * The structure below defines the index Tcl object type by means of
30 * procedures that can be invoked by generic object code.
31 */
32
33Tcl_ObjType tclIndexType = {
34 "index", /* name */
35 (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
36 DupIndexInternalRep, /* dupIntRepProc */
37 UpdateStringOfIndex, /* updateStringProc */
38 SetIndexFromAny /* setFromAnyProc */
39};
40
41
42/*
43 *----------------------------------------------------------------------
44 *
45 * Tcl_GetIndexFromObj --
46 *
47 * This procedure looks up an object's value in a table of strings
48 * and returns the index of the matching string, if any.
49 *
50 * Results:
51
52 * If the value of objPtr is identical to or a unique abbreviation
53 * for one of the entries in objPtr, then the return value is
54 * TCL_OK and the index of the matching entry is stored at
55 * *indexPtr. If there isn't a proper match, then TCL_ERROR is
56 * returned and an error message is left in interp's result (unless
57 * interp is NULL). The msg argument is used in the error
58 * message; for example, if msg has the value "option" then the
59 * error message will say something flag 'bad option "foo": must be
60 * ...'
61 *
62 * Side effects:
63 * The result of the lookup is cached as the internal rep of
64 * objPtr, so that repeated lookups can be done quickly.
65 *
66 *----------------------------------------------------------------------
67 */
68
69int
70Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
71 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
72 Tcl_Obj *objPtr; /* Object containing the string to lookup. */
73 char **tablePtr; /* Array of strings to compare against the
74 * value of objPtr; last entry must be NULL
75 * and there must not be duplicate entries. */
76 char *msg; /* Identifying word to use in error messages. */
77 int flags; /* 0 or TCL_EXACT */
78 int *indexPtr; /* Place to store resulting integer index. */
79{
80 int index, length, i, numAbbrev;
81 char *key, *p1, *p2, **entryPtr;
82 Tcl_Obj *resultPtr;
83
84 /*
85 * See if there is a valid cached result from a previous lookup.
86 */
87
88 if ((objPtr->typePtr == &tclIndexType)
89 && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
90 *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
91 return TCL_OK;
92 }
93
94 /*
95 * Lookup the value of the object in the table. Accept unique
96 * abbreviations unless TCL_EXACT is set in flags.
97 */
98
99 key = Tcl_GetStringFromObj(objPtr, &length);
100 index = -1;
101 numAbbrev = 0;
102 for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) {
103 for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
104 if (*p1 == 0) {
105 index = i;
106 goto done;
107 }
108 }
109 if (*p1 == 0) {
110 /*
111 * The value is an abbreviation for this entry. Continue
112 * checking other entries to make sure it's unique. If we
113 * get more than one unique abbreviation, keep searching to
114 * see if there is an exact match, but remember the number
115 * of unique abbreviations and don't allow either.
116 */
117
118 numAbbrev++;
119 index = i;
120 }
121 }
122 if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
123 goto error;
124 }
125
126 done:
127 if ((objPtr->typePtr != NULL)
128 && (objPtr->typePtr->freeIntRepProc != NULL)) {
129 objPtr->typePtr->freeIntRepProc(objPtr);
130 }
131 objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
132 objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
133 objPtr->typePtr = &tclIndexType;
134 *indexPtr = index;
135 return TCL_OK;
136
137 error:
138 if (interp != NULL) {
139 resultPtr = Tcl_GetObjResult(interp);
140 Tcl_AppendStringsToObj(resultPtr,
141 (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
142 key, "\": must be ", *tablePtr, (char *) NULL);
143 for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) {
144 if (entryPtr[1] == NULL) {
145 Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr,
146 (char *) NULL);
147 } else {
148 Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
149 (char *) NULL);
150 }
151 }
152 }
153 return TCL_ERROR;
154}
155
156
157/*
158 *----------------------------------------------------------------------
159 *
160 * DupIndexInternalRep --
161 *
162 * Copy the internal representation of an index Tcl_Obj from one
163 * object to another.
164 *
165 * Results:
166 * None.
167 *
168 * Side effects:
169 * "copyPtr"s internal rep is set to same value as "srcPtr"s
170 * internal rep.
171 *
172 *----------------------------------------------------------------------
173 */
174
175static void
176DupIndexInternalRep(srcPtr, copyPtr)
177 register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
178 register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
179{
180 copyPtr->internalRep.twoPtrValue.ptr1
181 = srcPtr->internalRep.twoPtrValue.ptr1;
182 copyPtr->internalRep.twoPtrValue.ptr2
183 = srcPtr->internalRep.twoPtrValue.ptr2;
184 copyPtr->typePtr = &tclIndexType;
185}
186
187
188/*
189 *----------------------------------------------------------------------
190 *
191 * SetIndexFromAny --
192 *
193 * This procedure is called to convert a Tcl object to index
194 * internal form. However, this doesn't make sense (need to have a
195 * table of keywords in order to do the conversion) so the
196 * procedure always generates an error.
197 *
198 * Results:
199 * The return value is always TCL_ERROR, and an error message is
200 * left in interp's result if interp isn't NULL.
201 *
202 * Side effects:
203 * None.
204 *
205 *----------------------------------------------------------------------
206 */
207
208static int
209SetIndexFromAny(interp, objPtr)
210 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
211 register Tcl_Obj *objPtr; /* The object to convert. */
212{
213 Tcl_AppendToObj(Tcl_GetObjResult(interp),
214 "can't convert value to index except via Tcl_GetIndexFromObj API",
215 -1);
216 return TCL_ERROR;
217}
218
219
220/*
221 *----------------------------------------------------------------------
222 *
223 * UpdateStringOfIndex --
224 *
225 * This procedure is called to update the string representation for
226 * an index object. It should never be called, because we never
227 * invalidate the string representation for an index object.
228 *
229 * Results:
230 * None.
231 *
232 * Side effects:
233 * A panic is added
234 *
235 *----------------------------------------------------------------------
236 */
237
238static void
239UpdateStringOfIndex(objPtr)
240 register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
241{
242 panic("UpdateStringOfIndex should never be invoked");
243}
244
245
246/*
247 *----------------------------------------------------------------------
248 *
249 * Tcl_WrongNumArgs --
250 *
251 * This procedure generates a "wrong # args" error message in an
252 * interpreter. It is used as a utility function by many command
253 * procedures.
254 *
255 * Results:
256 * None.
257 *
258 * Side effects:
259 * An error message is generated in interp's result object to
260 * indicate that a command was invoked with the wrong number of
261 * arguments. The message has the form
262 * wrong # args: should be "foo bar additional stuff"
263 * where "foo" and "bar" are the initial objects in objv (objc
264 * determines how many of these are printed) and "additional stuff"
265 * is the contents of the message argument.
266 *
267 *----------------------------------------------------------------------
268 */
269
270void
271Tcl_WrongNumArgs(interp, objc, objv, message)
272 Tcl_Interp *interp; /* Current interpreter. */
273 int objc; /* Number of arguments to print
274 * from objv. */
275 Tcl_Obj *CONST objv[]; /* Initial argument objects, which
276 * should be included in the error
277 * message. */
278 char *message; /* Error message to print after the
279 * leading objects in objv. The
280 * message may be NULL. */
281{
282 Tcl_Obj *objPtr;
283 char **tablePtr;
284 int i;
285
286 objPtr = Tcl_GetObjResult(interp);
287 Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
288 for (i = 0; i < objc; i++) {
289 /*
290 * If the object is an index type use the index table which allows
291 * for the correct error message even if the subcommand was
292 * abbreviated. Otherwise, just use the string rep.
293 */
294
295 if (objv[i]->typePtr == &tclIndexType) {
296 tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
297 Tcl_AppendStringsToObj(objPtr,
298 tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
299 (char *) NULL);
300 } else {
301 Tcl_AppendStringsToObj(objPtr,
302 Tcl_GetStringFromObj(objv[i], (int *) NULL),
303 (char *) NULL);
304 }
305 if (i < (objc - 1)) {
306 Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
307 }
308 }
309 if (message) {
310 Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
311 }
312 Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
313}
Note: See TracBrowser for help on using the repository browser.