/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclindexobj.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclindexobj.c

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25