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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25