source: HiSusy/trunk/Delphes/Delphes-3.0.9/external/tcl/tclIndexObj.c @ 5

Last change on this file since 5 was 5, checked in by zerwas, 11 years ago

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