OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [generic/] [tclIndexObj.c] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
/*
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.1.1 2002-01-16 10:25:27 markom Exp $
14
 */
15
 
16
#include "tclInt.h"
17
 
18
/*
19
 * Prototypes for procedures defined later in this file:
20
 */
21
 
22
static void             DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
23
                            Tcl_Obj *copyPtr));
24
static int              SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
25
                            Tcl_Obj *objPtr));
26
static 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
 
33
Tcl_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
 
68
int
69
Tcl_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
 
173
static void
174
DupIndexInternalRep(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
 
205
static int
206
SetIndexFromAny(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
 
234
static void
235
UpdateStringOfIndex(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
 
265
void
266
Tcl_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
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.