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

Subversion Repositories or1k

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
/*
2 
 * tclTestObj.c --
3 
 *
4 
 *      This file contains C command procedures for the additional Tcl
5 
 *      commands that are used for testing implementations of the Tcl object
6 
 *      types. These commands are not normally included in Tcl
7 
 *      applications; they're only used for testing.
8 
 *
9 
 * Copyright (c) 1995, 1996 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: tclTestObj.c,v 1.1.1.1 2002-01-16 10:25:29 markom Exp $
15 
 */
16 
 
17 
#include "tclInt.h"
18 
 
19 
/*
20 
 * An array of Tcl_Obj pointers used in the commands that operate on or get
21 
 * the values of Tcl object-valued variables. varPtr[i] is the i-th
22 
 * variable's Tcl_Obj *.
23 
 */
24 
 
25 
#define NUMBER_OF_OBJECT_VARS 20
26 
static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
27 
 
28 
/*
29 
 * Forward declarations for procedures defined later in this file:
30 
 */
31 
 
32 
static int              CheckIfVarUnset _ANSI_ARGS_((Tcl_Interp *interp,
33 
                            int varIndex));
34 
static int              GetVariableIndex _ANSI_ARGS_((Tcl_Interp *interp,
35 
                            char *string, int *indexPtr));
36 
static void             SetVarToObj _ANSI_ARGS_((int varIndex,
37 
                            Tcl_Obj *objPtr));
38 
int                     TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
39 
static int              TestbooleanobjCmd _ANSI_ARGS_((ClientData dummy,
40 
                            Tcl_Interp *interp, int objc,
41 
                            Tcl_Obj *CONST objv[]));
42 
static int              TestconvertobjCmd _ANSI_ARGS_((ClientData dummy,
43 
                            Tcl_Interp *interp, int objc,
44 
                            Tcl_Obj *CONST objv[]));
45 
static int              TestdoubleobjCmd _ANSI_ARGS_((ClientData dummy,
46 
                            Tcl_Interp *interp, int objc,
47 
                            Tcl_Obj *CONST objv[]));
48 
static int              TestindexobjCmd _ANSI_ARGS_((ClientData dummy,
49 
                            Tcl_Interp *interp, int objc,
50 
                            Tcl_Obj *CONST objv[]));
51 
static int              TestintobjCmd _ANSI_ARGS_((ClientData dummy,
52 
                            Tcl_Interp *interp, int objc,
53 
                            Tcl_Obj *CONST objv[]));
54 
static int              TestobjCmd _ANSI_ARGS_((ClientData dummy,
55 
                            Tcl_Interp *interp, int objc,
56 
                            Tcl_Obj *CONST objv[]));
57 
static int              TeststringobjCmd _ANSI_ARGS_((ClientData dummy,
58 
                            Tcl_Interp *interp, int objc,
59 
                            Tcl_Obj *CONST objv[]));
60 
 
61 
/*
62 
 *----------------------------------------------------------------------
63 
 *
64 
 * TclObjTest_Init --
65 
 *
66 
 *      This procedure creates additional commands that are used to test the
67 
 *      Tcl object support.
68 
 *
69 
 * Results:
70 
 *      Returns a standard Tcl completion code, and leaves an error
71 
 *      message in interp->result if an error occurs.
72 
 *
73 
 * Side effects:
74 
 *      Creates and registers several new testing commands.
75 
 *
76 
 *----------------------------------------------------------------------
77 
 */
78 
 
79 
int
80 
TclObjTest_Init(interp)
81 
    Tcl_Interp *interp;
82 
{
83 
    register int i;
84 
 
85 
    for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
86 
        varPtr[i] = NULL;
87 
    }
88 
 
89 
    Tcl_CreateObjCommand(interp, "testbooleanobj", TestbooleanobjCmd,
90 
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
91 
    Tcl_CreateObjCommand(interp, "testconvertobj", TestconvertobjCmd,
92 
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
93 
    Tcl_CreateObjCommand(interp, "testdoubleobj", TestdoubleobjCmd,
94 
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
95 
    Tcl_CreateObjCommand(interp, "testintobj", TestintobjCmd,
96 
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
97 
    Tcl_CreateObjCommand(interp, "testindexobj", TestindexobjCmd,
98 
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
99 
    Tcl_CreateObjCommand(interp, "testobj", TestobjCmd,
100 
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
101 
    Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd,
102 
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
103 
    return TCL_OK;
104 
}
105 
 
106 
/*
107 
 *----------------------------------------------------------------------
108 
 *
109 
 * TestbooleanobjCmd --
110 
 *
111 
 *      This procedure implements the "testbooleanobj" command.  It is used
112 
 *      to test the boolean Tcl object type implementation.
113 
 *
114 
 * Results:
115 
 *      A standard Tcl object result.
116 
 *
117 
 * Side effects:
118 
 *      Creates and frees boolean objects, and also converts objects to
119 
 *      have boolean type.
120 
 *
121 
 *----------------------------------------------------------------------
122 
 */
123 
 
124 
static int
125 
TestbooleanobjCmd(clientData, interp, objc, objv)
126 
    ClientData clientData;      /* Not used. */
127 
    Tcl_Interp *interp;         /* Current interpreter. */
128 
    int objc;                   /* Number of arguments. */
129 
    Tcl_Obj *CONST objv[];      /* Argument objects. */
130 
{
131 
    int varIndex, boolValue, length;
132 
    char *index, *subCmd;
133 
 
134 
    if (objc < 3) {
135 
        wrongNumArgs:
136 
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
137 
        return TCL_ERROR;
138 
    }
139 
 
140 
    /*
141 
     * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
142 
     */
143 
 
144 
    index = Tcl_GetStringFromObj(objv[2], &length);
145 
    if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
146 
        return TCL_ERROR;
147 
    }
148 
 
149 
    subCmd = Tcl_GetStringFromObj(objv[1], &length);
150 
    if (strcmp(subCmd, "set") == 0) {
151 
        if (objc != 4) {
152 
            goto wrongNumArgs;
153 
        }
154 
        if (Tcl_GetBooleanFromObj(interp, objv[3], &boolValue) != TCL_OK) {
155 
            return TCL_ERROR;
156 
        }
157 
 
158 
        /*
159 
         * If the object currently bound to the variable with index varIndex
160 
         * has ref count 1 (i.e. the object is unshared) we can modify that
161 
         * object directly. Otherwise, if RC>1 (i.e. the object is shared),
162 
         * we must create a new object to modify/set and decrement the old
163 
         * formerly-shared object's ref count. This is "copy on write".
164 
         */
165 
 
166 
        if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
167 
            Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
168 
        } else {
169 
            SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
170 
        }
171 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
172 
    } else if (strcmp(subCmd, "get") == 0) {
173 
        if (objc != 3) {
174 
            goto wrongNumArgs;
175 
        }
176 
        if (CheckIfVarUnset(interp, varIndex)) {
177 
            return TCL_ERROR;
178 
        }
179 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
180 
    } else if (strcmp(subCmd, "not") == 0) {
181 
        if (objc != 3) {
182 
            goto wrongNumArgs;
183 
        }
184 
        if (CheckIfVarUnset(interp, varIndex)) {
185 
            return TCL_ERROR;
186 
        }
187 
        if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
188 
                                  &boolValue) != TCL_OK) {
189 
            return TCL_ERROR;
190 
        }
191 
        if (!Tcl_IsShared(varPtr[varIndex])) {
192 
            Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
193 
        } else {
194 
            SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
195 
        }
196 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
197 
    } else {
198 
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
199 
                "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
200 
                "\": must be set, get, or not", (char *) NULL);
201 
        return TCL_ERROR;
202 
    }
203 
    return TCL_OK;
204 
}
205 
 
206 
/*
207 
 *----------------------------------------------------------------------
208 
 *
209 
 * TestconvertobjCmd --
210 
 *
211 
 *      This procedure implements the "testconvertobj" command. It is used
212 
 *      to test converting objects to new types.
213 
 *
214 
 * Results:
215 
 *      A standard Tcl object result.
216 
 *
217 
 * Side effects:
218 
 *      Converts objects to new types.
219 
 *
220 
 *----------------------------------------------------------------------
221 
 */
222 
 
223 
static int
224 
TestconvertobjCmd(clientData, interp, objc, objv)
225 
    ClientData clientData;      /* Not used. */
226 
    Tcl_Interp *interp;         /* Current interpreter. */
227 
    int objc;                   /* Number of arguments. */
228 
    Tcl_Obj *CONST objv[];      /* Argument objects. */
229 
{
230 
    int length;
231 
    char *subCmd;
232 
    char buf[20];
233 
 
234 
    if (objc < 3) {
235 
        wrongNumArgs:
236 
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
237 
        return TCL_ERROR;
238 
    }
239 
 
240 
    /*
241 
     * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
242 
     */
243 
 
244 
    subCmd = Tcl_GetStringFromObj(objv[1], &length);
245 
    if (strcmp(subCmd, "double") == 0) {
246 
        double d;
247 
 
248 
        if (objc != 3) {
249 
            goto wrongNumArgs;
250 
        }
251 
        if (Tcl_GetDoubleFromObj(interp, objv[2], &d) != TCL_OK) {
252 
            return TCL_ERROR;
253 
        }
254 
        sprintf(buf, "%f", d);
255 
        Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
256 
    } else {
257 
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
258 
                "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
259 
                "\": must be double", (char *) NULL);
260 
        return TCL_ERROR;
261 
    }
262 
    return TCL_OK;
263 
}
264 
 
265 
/*
266 
 *----------------------------------------------------------------------
267 
 *
268 
 * TestdoubleobjCmd --
269 
 *
270 
 *      This procedure implements the "testdoubleobj" command.  It is used
271 
 *      to test the double-precision floating point Tcl object type
272 
 *      implementation.
273 
 *
274 
 * Results:
275 
 *      A standard Tcl object result.
276 
 *
277 
 * Side effects:
278 
 *      Creates and frees double objects, and also converts objects to
279 
 *      have double type.
280 
 *
281 
 *----------------------------------------------------------------------
282 
 */
283 
 
284 
static int
285 
TestdoubleobjCmd(clientData, interp, objc, objv)
286 
    ClientData clientData;      /* Not used. */
287 
    Tcl_Interp *interp;         /* Current interpreter. */
288 
    int objc;                   /* Number of arguments. */
289 
    Tcl_Obj *CONST objv[];      /* Argument objects. */
290 
{
291 
    int varIndex, length;
292 
    double doubleValue;
293 
    char *index, *subCmd, *string;
294 
 
295 
    if (objc < 3) {
296 
        wrongNumArgs:
297 
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
298 
        return TCL_ERROR;
299 
    }
300 
 
301 
    /*
302 
     * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
303 
     */
304 
 
305 
    index = Tcl_GetStringFromObj(objv[2], &length);
306 
    if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
307 
        return TCL_ERROR;
308 
    }
309 
 
310 
    subCmd = Tcl_GetStringFromObj(objv[1], &length);
311 
    if (strcmp(subCmd, "set") == 0) {
312 
        if (objc != 4) {
313 
            goto wrongNumArgs;
314 
        }
315 
        string = Tcl_GetStringFromObj(objv[3], &length);
316 
        if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
317 
            return TCL_ERROR;
318 
        }
319 
 
320 
        /*
321 
         * If the object currently bound to the variable with index varIndex
322 
         * has ref count 1 (i.e. the object is unshared) we can modify that
323 
         * object directly. Otherwise, if RC>1 (i.e. the object is shared),
324 
         * we must create a new object to modify/set and decrement the old
325 
         * formerly-shared object's ref count. This is "copy on write".
326 
         */
327 
 
328 
        if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
329 
            Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
330 
        } else {
331 
            SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
332 
        }
333 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
334 
    } else if (strcmp(subCmd, "get") == 0) {
335 
        if (objc != 3) {
336 
            goto wrongNumArgs;
337 
        }
338 
        if (CheckIfVarUnset(interp, varIndex)) {
339 
            return TCL_ERROR;
340 
        }
341 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
342 
    } else if (strcmp(subCmd, "mult10") == 0) {
343 
        if (objc != 3) {
344 
            goto wrongNumArgs;
345 
        }
346 
        if (CheckIfVarUnset(interp, varIndex)) {
347 
            return TCL_ERROR;
348 
        }
349 
        if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
350 
                                 &doubleValue) != TCL_OK) {
351 
            return TCL_ERROR;
352 
        }
353 
        if (!Tcl_IsShared(varPtr[varIndex])) {
354 
            Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue * 10.0));
355 
        } else {
356 
            SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue * 10.0) ));
357 
        }
358 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
359 
    } else if (strcmp(subCmd, "div10") == 0) {
360 
        if (objc != 3) {
361 
            goto wrongNumArgs;
362 
        }
363 
        if (CheckIfVarUnset(interp, varIndex)) {
364 
            return TCL_ERROR;
365 
        }
366 
        if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
367 
                                 &doubleValue) != TCL_OK) {
368 
            return TCL_ERROR;
369 
        }
370 
        if (!Tcl_IsShared(varPtr[varIndex])) {
371 
            Tcl_SetDoubleObj(varPtr[varIndex], (doubleValue / 10.0));
372 
        } else {
373 
            SetVarToObj(varIndex, Tcl_NewDoubleObj( (doubleValue / 10.0) ));
374 
        }
375 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
376 
    } else {
377 
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
378 
                "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
379 
                "\": must be set, get, mult10, or div10", (char *) NULL);
380 
        return TCL_ERROR;
381 
    }
382 
    return TCL_OK;
383 
}
384 
 
385 
/*
386 
 *----------------------------------------------------------------------
387 
 *
388 
 * TestindexobjCmd --
389 
 *
390 
 *      This procedure implements the "testindexobj" command. It is used to
391 
 *      test the index Tcl object type implementation.
392 
 *
393 
 * Results:
394 
 *      A standard Tcl object result.
395 
 *
396 
 * Side effects:
397 
 *      Creates and frees int objects, and also converts objects to
398 
 *      have int type.
399 
 *
400 
 *----------------------------------------------------------------------
401 
 */
402 
 
403 
static int
404 
TestindexobjCmd(clientData, interp, objc, objv)
405 
    ClientData clientData;      /* Not used. */
406 
    Tcl_Interp *interp;         /* Current interpreter. */
407 
    int objc;                   /* Number of arguments. */
408 
    Tcl_Obj *CONST objv[];      /* Argument objects. */
409 
{
410 
    int allowAbbrev, index, index2, setError, i, dummy, result;
411 
    char **argv;
412 
    static char *tablePtr[] = {"a", "b", "check", (char *) NULL};
413 
 
414 
    if ((objc == 3) && (strcmp(Tcl_GetStringFromObj(objv[1], &dummy),
415 
            "check") == 0)) {
416 
        /*
417 
         * This code checks to be sure that the results of
418 
         * Tcl_GetIndexFromObj are properly cached in the object and
419 
         * returned on subsequent lookups.
420 
         */
421 
 
422 
        Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,
423 
                "token", 0, &index);
424 
        if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
425 
            return TCL_ERROR;
426 
        }
427 
        objv[1]->internalRep.twoPtrValue.ptr2 = (VOID *) index2;
428 
        result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],
429 
                tablePtr, "token", 0, &index);
430 
        if (result == TCL_OK) {
431 
            Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
432 
        }
433 
        return result;
434 
    }
435 
 
436 
    if (objc < 5) {
437 
        Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
438 
        return TCL_ERROR;
439 
    }
440 
 
441 
    if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
442 
        return TCL_ERROR;
443 
    }
444 
    if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
445 
        return TCL_ERROR;
446 
    }
447 
    argv = (char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
448 
    for (i = 4; i < objc; i++) {
449 
        argv[i-4] = Tcl_GetStringFromObj(objv[i], &dummy);
450 
    }
451 
    argv[objc-4] = NULL;
452 
    result = Tcl_GetIndexFromObj(setError ? interp : NULL, objv[3],
453 
            argv, "token", allowAbbrev ? 0 : TCL_EXACT, &index);
454 
    ckfree((char *) argv);
455 
    if (result == TCL_OK) {
456 
        Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
457 
    }
458 
    return result;
459 
}
460 
 
461 
/*
462 
 *----------------------------------------------------------------------
463 
 *
464 
 * TestintobjCmd --
465 
 *
466 
 *      This procedure implements the "testintobj" command. It is used to
467 
 *      test the int Tcl object type implementation.
468 
 *
469 
 * Results:
470 
 *      A standard Tcl object result.
471 
 *
472 
 * Side effects:
473 
 *      Creates and frees int objects, and also converts objects to
474 
 *      have int type.
475 
 *
476 
 *----------------------------------------------------------------------
477 
 */
478 
 
479 
static int
480 
TestintobjCmd(clientData, interp, objc, objv)
481 
    ClientData clientData;      /* Not used. */
482 
    Tcl_Interp *interp;         /* Current interpreter. */
483 
    int objc;                   /* Number of arguments. */
484 
    Tcl_Obj *CONST objv[];      /* Argument objects. */
485 
{
486 
    int intValue, varIndex, length, i;
487 
    long longValue;
488 
    char *index, *subCmd, *string;
489 
 
490 
    if (objc < 3) {
491 
        wrongNumArgs:
492 
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
493 
        return TCL_ERROR;
494 
    }
495 
 
496 
    /*
497 
     * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
498 
     */
499 
 
500 
    index = Tcl_GetStringFromObj(objv[2], &length);
501 
    if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
502 
        return TCL_ERROR;
503 
    }
504 
 
505 
    subCmd = Tcl_GetStringFromObj(objv[1], &length);
506 
    if (strcmp(subCmd, "set") == 0) {
507 
        if (objc != 4) {
508 
            goto wrongNumArgs;
509 
        }
510 
        string = Tcl_GetStringFromObj(objv[3], &length);
511 
        if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
512 
            return TCL_ERROR;
513 
        }
514 
        intValue = i;
515 
 
516 
        /*
517 
         * If the object currently bound to the variable with index varIndex
518 
         * has ref count 1 (i.e. the object is unshared) we can modify that
519 
         * object directly. Otherwise, if RC>1 (i.e. the object is shared),
520 
         * we must create a new object to modify/set and decrement the old
521 
         * formerly-shared object's ref count. This is "copy on write".
522 
         */
523 
 
524 
        if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
525 
            Tcl_SetIntObj(varPtr[varIndex], intValue);
526 
        } else {
527 
            SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
528 
        }
529 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
530 
    } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
531 
        if (objc != 4) {
532 
            goto wrongNumArgs;
533 
        }
534 
        string = Tcl_GetStringFromObj(objv[3], &length);
535 
        if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
536 
            return TCL_ERROR;
537 
        }
538 
        intValue = i;
539 
        if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
540 
            Tcl_SetIntObj(varPtr[varIndex], intValue);
541 
        } else {
542 
            SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
543 
        }
544 
    } else if (strcmp(subCmd, "setlong") == 0) {
545 
        if (objc != 4) {
546 
            goto wrongNumArgs;
547 
        }
548 
        string = Tcl_GetStringFromObj(objv[3], &length);
549 
        if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
550 
            return TCL_ERROR;
551 
        }
552 
        intValue = i;
553 
        if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
554 
            Tcl_SetLongObj(varPtr[varIndex], intValue);
555 
        } else {
556 
            SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
557 
        }
558 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
559 
    } else if (strcmp(subCmd, "setmaxlong") == 0) {
560 
        long maxLong = LONG_MAX;
561 
        if (objc != 3) {
562 
            goto wrongNumArgs;
563 
        }
564 
        if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
565 
            Tcl_SetLongObj(varPtr[varIndex], maxLong);
566 
        } else {
567 
            SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
568 
        }
569 
    } else if (strcmp(subCmd, "ismaxlong") == 0) {
570 
        if (objc != 3) {
571 
            goto wrongNumArgs;
572 
        }
573 
        if (CheckIfVarUnset(interp, varIndex)) {
574 
            return TCL_ERROR;
575 
        }
576 
        if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
577 
            return TCL_ERROR;
578 
        }
579 
        Tcl_AppendToObj(Tcl_GetObjResult(interp),
580 
                ((longValue == LONG_MAX)? "1" : "0"), -1);
581 
    } else if (strcmp(subCmd, "get") == 0) {
582 
        if (objc != 3) {
583 
            goto wrongNumArgs;
584 
        }
585 
        if (CheckIfVarUnset(interp, varIndex)) {
586 
            return TCL_ERROR;
587 
        }
588 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
589 
    } else if (strcmp(subCmd, "inttoobigtest") == 0) {
590 
        /*
591 
         * If long ints have more bits than ints on this platform, verify
592 
         * that Tcl_GetIntFromObj returns an error if the long int held
593 
         * in an integer object's internal representation is too large
594 
         * to fit in an int.
595 
         */
596 
 
597 
        long maxLong = LONG_MAX;
598 
 
599 
        if (objc != 3) {
600 
            goto wrongNumArgs;
601 
        }
602 
        if (INT_MAX == LONG_MAX) { /* int is same size as long int */
603 
            Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
604 
        } else {
605 
            if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
606 
                Tcl_SetLongObj(varPtr[varIndex], maxLong);
607 
            } else {
608 
                SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
609 
            }
610 
            if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
611 
                Tcl_ResetResult(interp);
612 
                Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
613 
                return TCL_OK;
614 
            }
615 
            Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
616 
        }
617 
    } else if (strcmp(subCmd, "mult10") == 0) {
618 
        if (objc != 3) {
619 
            goto wrongNumArgs;
620 
        }
621 
        if (CheckIfVarUnset(interp, varIndex)) {
622 
            return TCL_ERROR;
623 
        }
624 
        if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
625 
                              &intValue) != TCL_OK) {
626 
            return TCL_ERROR;
627 
        }
628 
        if (!Tcl_IsShared(varPtr[varIndex])) {
629 
            Tcl_SetIntObj(varPtr[varIndex], (intValue * 10));
630 
        } else {
631 
            SetVarToObj(varIndex, Tcl_NewIntObj( (intValue * 10) ));
632 
        }
633 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
634 
    } else if (strcmp(subCmd, "div10") == 0) {
635 
        if (objc != 3) {
636 
            goto wrongNumArgs;
637 
        }
638 
        if (CheckIfVarUnset(interp, varIndex)) {
639 
            return TCL_ERROR;
640 
        }
641 
        if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
642 
                              &intValue) != TCL_OK) {
643 
            return TCL_ERROR;
644 
        }
645 
        if (!Tcl_IsShared(varPtr[varIndex])) {
646 
            Tcl_SetIntObj(varPtr[varIndex], (intValue / 10));
647 
        } else {
648 
            SetVarToObj(varIndex, Tcl_NewIntObj( (intValue / 10) ));
649 
        }
650 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
651 
    } else {
652 
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
653 
                "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
654 
                "\": must be set, get, mult10, or div10", (char *) NULL);
655 
        return TCL_ERROR;
656 
    }
657 
    return TCL_OK;
658 
}
659 
 
660 
/*
661 
 *----------------------------------------------------------------------
662 
 *
663 
 * TestobjCmd --
664 
 *
665 
 *      This procedure implements the "testobj" command. It is used to test
666 
 *      the type-independent portions of the Tcl object type implementation.
667 
 *
668 
 * Results:
669 
 *      A standard Tcl object result.
670 
 *
671 
 * Side effects:
672 
 *      Creates and frees objects.
673 
 *
674 
 *----------------------------------------------------------------------
675 
 */
676 
 
677 
static int
678 
TestobjCmd(clientData, interp, objc, objv)
679 
    ClientData clientData;      /* Not used. */
680 
    Tcl_Interp *interp;         /* Current interpreter. */
681 
    int objc;                   /* Number of arguments. */
682 
    Tcl_Obj *CONST objv[];      /* Argument objects. */
683 
{
684 
    int varIndex, destIndex, i;
685 
    char *index, *subCmd, *string;
686 
    Tcl_ObjType *targetType;
687 
    char buf[20];
688 
    int length;
689 
 
690 
    if (objc < 2) {
691 
        wrongNumArgs:
692 
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
693 
        return TCL_ERROR;
694 
    }
695 
 
696 
    /*
697 
     * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
698 
     */
699 
 
700 
    subCmd = Tcl_GetStringFromObj(objv[1], &length);
701 
    if (strcmp(subCmd, "assign") == 0) {
702 
        if (objc != 4) {
703 
            goto wrongNumArgs;
704 
        }
705 
        index = Tcl_GetStringFromObj(objv[2], &length);
706 
        if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
707 
            return TCL_ERROR;
708 
        }
709 
        if (CheckIfVarUnset(interp, varIndex)) {
710 
            return TCL_ERROR;
711 
        }
712 
        string = Tcl_GetStringFromObj(objv[3], &length);
713 
        if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
714 
            return TCL_ERROR;
715 
        }
716 
        SetVarToObj(destIndex, varPtr[varIndex]);
717 
        Tcl_SetObjResult(interp, varPtr[destIndex]);
718 
     } else if (strcmp(subCmd, "convert") == 0) {
719 
        char *typeName;
720 
        if (objc != 4) {
721 
            goto wrongNumArgs;
722 
        }
723 
        index = Tcl_GetStringFromObj(objv[2], &length);
724 
        if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
725 
            return TCL_ERROR;
726 
        }
727 
        if (CheckIfVarUnset(interp, varIndex)) {
728 
            return TCL_ERROR;
729 
        }
730 
        typeName = Tcl_GetStringFromObj(objv[3], &length);
731 
        if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
732 
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
733 
                    "no type ", typeName, " found", (char *) NULL);
734 
            return TCL_ERROR;
735 
        }
736 
        if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
737 
            != TCL_OK) {
738 
            return TCL_ERROR;
739 
        }
740 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
741 
    } else if (strcmp(subCmd, "duplicate") == 0) {
742 
        if (objc != 4) {
743 
            goto wrongNumArgs;
744 
        }
745 
        index = Tcl_GetStringFromObj(objv[2], &length);
746 
        if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
747 
            return TCL_ERROR;
748 
        }
749 
        if (CheckIfVarUnset(interp, varIndex)) {
750 
            return TCL_ERROR;
751 
        }
752 
        string = Tcl_GetStringFromObj(objv[3], &length);
753 
        if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
754 
            return TCL_ERROR;
755 
        }
756 
        SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
757 
        Tcl_SetObjResult(interp, varPtr[destIndex]);
758 
    } else if (strcmp(subCmd, "freeallvars") == 0) {
759 
        if (objc != 2) {
760 
            goto wrongNumArgs;
761 
        }
762 
        for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
763 
            if (varPtr[i] != NULL) {
764 
                Tcl_DecrRefCount(varPtr[i]);
765 
                varPtr[i] = NULL;
766 
            }
767 
        }
768 
    } else if (strcmp(subCmd, "newobj") == 0) {
769 
        if (objc != 3) {
770 
            goto wrongNumArgs;
771 
        }
772 
        index = Tcl_GetStringFromObj(objv[2], &length);
773 
        if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
774 
            return TCL_ERROR;
775 
        }
776 
        SetVarToObj(varIndex, Tcl_NewObj());
777 
        Tcl_SetObjResult(interp, varPtr[varIndex]);
778 
    } else if (strcmp(subCmd, "refcount") == 0) {
779 
        if (objc != 3) {
780 
            goto wrongNumArgs;
781 
        }
782 
        index = Tcl_GetStringFromObj(objv[2], &length);
783 
        if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
784 
            return TCL_ERROR;
785 
        }
786 
        if (CheckIfVarUnset(interp, varIndex)) {
787 
            return TCL_ERROR;
788 
        }
789 
        sprintf(buf, "%d", varPtr[varIndex]->refCount);
790 
        Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
791 
    } else if (strcmp(subCmd, "type") == 0) {
792 
        if (objc != 3) {
793 
            goto wrongNumArgs;
794 
        }
795 
        index = Tcl_GetStringFromObj(objv[2], &length);
796 
        if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
797 
            return TCL_ERROR;
798 
        }
799 
        if (CheckIfVarUnset(interp, varIndex)) {
800 
            return TCL_ERROR;
801 
        }
802 
        if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
803 
            Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
804 
        } else {
805 
            Tcl_AppendToObj(Tcl_GetObjResult(interp),
806 
                    varPtr[varIndex]->typePtr->name, -1);
807 
        }
808 
    } else if (strcmp(subCmd, "types") == 0) {
809 
        if (objc != 2) {
810 
            goto wrongNumArgs;
811 
        }
812 
        if (Tcl_AppendAllObjTypes(interp, Tcl_GetObjResult(interp)) != TCL_OK) {
813 
            return TCL_ERROR;
814 
        }
815 
    } else {
816 
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
817 
                "bad option \"",
818 
                Tcl_GetStringFromObj(objv[1], (int *) NULL),
819 
                "\": must be assign, convert, duplicate, freeallvars, ",
820 
                "newobj, objcount, refcount, type, or types",
821 
                (char *) NULL);
822 
        return TCL_ERROR;
823 
    }
824 
    return TCL_OK;
825 
}
826 
 
827 
/*
828 
 *----------------------------------------------------------------------
829 
 *
830 
 * TeststringobjCmd --
831 
 *
832 
 *      This procedure implements the "teststringobj" command. It is used to
833 
 *      test the string Tcl object type implementation.
834 
 *
835 
 * Results:
836 
 *      A standard Tcl object result.
837 
 *
838 
 * Side effects:
839 
 *      Creates and frees string objects, and also converts objects to
840 
 *      have string type.
841 
 *
842 
 *----------------------------------------------------------------------
843 
 */
844 
 
845 
static int
846 
TeststringobjCmd(clientData, interp, objc, objv)
847 
    ClientData clientData;      /* Not used. */
848 
    Tcl_Interp *interp;         /* Current interpreter. */
849 
    int objc;                   /* Number of arguments. */
850 
    Tcl_Obj *CONST objv[];      /* Argument objects. */
851 
{
852 
    int varIndex, option, i, length;
853 
#define MAX_STRINGS 12
854 
    char *index, *string, *strings[MAX_STRINGS+1];
855 
    static char *options[] = {
856 
        "append", "appendstrings", "get", "length", "length2",
857 
        "set", "set2", "setlength", (char *) NULL
858 
    };
859 
 
860 
    if (objc < 3) {
861 
        wrongNumArgs:
862 
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
863 
        return TCL_ERROR;
864 
    }
865 
 
866 
    index = Tcl_GetStringFromObj(objv[2], (int *) NULL);
867 
    if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
868 
        return TCL_ERROR;
869 
    }
870 
 
871 
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
872 
            != TCL_OK) {
873 
        return TCL_ERROR;
874 
    }
875 
    switch (option) {
876 
        case 0:                          /* append */
877 
            if (objc != 5) {
878 
                goto wrongNumArgs;
879 
            }
880 
            if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
881 
                return TCL_ERROR;
882 
            }
883 
            if (varPtr[varIndex] == NULL) {
884 
                SetVarToObj(varIndex, Tcl_NewObj());
885 
            }
886 
 
887 
            /*
888 
             * If the object bound to variable "varIndex" is shared, we must
889 
             * "copy on write" and append to a copy of the object.
890 
             */
891 
 
892 
            if (Tcl_IsShared(varPtr[varIndex])) {
893 
                SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
894 
            }
895 
            string = Tcl_GetStringFromObj(objv[3], (int *) NULL);
896 
            Tcl_AppendToObj(varPtr[varIndex], string, length);
897 
            Tcl_SetObjResult(interp, varPtr[varIndex]);
898 
            break;
899 
        case 1:                         /* appendstrings */
900 
            if (objc > (MAX_STRINGS+3)) {
901 
                goto wrongNumArgs;
902 
            }
903 
            if (varPtr[varIndex] == NULL) {
904 
                SetVarToObj(varIndex, Tcl_NewObj());
905 
            }
906 
 
907 
            /*
908 
             * If the object bound to variable "varIndex" is shared, we must
909 
             * "copy on write" and append to a copy of the object.
910 
             */
911 
 
912 
            if (Tcl_IsShared(varPtr[varIndex])) {
913 
                SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
914 
            }
915 
            for (i = 3;  i < objc;  i++) {
916 
                strings[i-3] = Tcl_GetStringFromObj(objv[i], (int *) NULL);
917 
            }
918 
#if PURIFY
919 
            for (int cou = objc - 3; cou < MAX_STRINGS; cou++)
920 
            {
921 
                strings[cou] = NULL;
922 
            }
923 
#else
924 
            strings[objc-3] = NULL;
925 
#endif /* PURIFY */
926 
 
927 
            Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
928 
                    strings[2], strings[3], strings[4], strings[5],
929 
                    strings[6], strings[7], strings[8], strings[9],
930 
                    strings[10], strings[11]);
931 
            Tcl_SetObjResult(interp, varPtr[varIndex]);
932 
            break;
933 
        case 2:                         /* get */
934 
            if (objc != 3) {
935 
                goto wrongNumArgs;
936 
            }
937 
            if (CheckIfVarUnset(interp, varIndex)) {
938 
                return TCL_ERROR;
939 
            }
940 
            Tcl_SetObjResult(interp, varPtr[varIndex]);
941 
            break;
942 
        case 3:                         /* length */
943 
            if (objc != 3) {
944 
                goto wrongNumArgs;
945 
            }
946 
            Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
947 
                    ? varPtr[varIndex]->length : -1);
948 
            break;
949 
        case 4:                         /* length2 */
950 
            if (objc != 3) {
951 
                goto wrongNumArgs;
952 
            }
953 
            Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
954 
                    ? (int) varPtr[varIndex]->internalRep.longValue : -1);
955 
            break;
956 
        case 5:                         /* set */
957 
            if (objc != 4) {
958 
                goto wrongNumArgs;
959 
            }
960 
 
961 
            /*
962 
             * If the object currently bound to the variable with index
963 
             * varIndex has ref count 1 (i.e. the object is unshared) we
964 
             * can modify that object directly. Otherwise, if RC>1 (i.e.
965 
             * the object is shared), we must create a new object to
966 
             * modify/set and decrement the old formerly-shared object's
967 
             * ref count. This is "copy on write".
968 
             */
969 
 
970 
            string = Tcl_GetStringFromObj(objv[3], &length);
971 
            if ((varPtr[varIndex] != NULL)
972 
                    && !Tcl_IsShared(varPtr[varIndex])) {
973 
                Tcl_SetStringObj(varPtr[varIndex], string, length);
974 
            } else {
975 
                SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
976 
            }
977 
            Tcl_SetObjResult(interp, varPtr[varIndex]);
978 
            break;
979 
        case 6:                         /* set2 */
980 
            if (objc != 4) {
981 
                goto wrongNumArgs;
982 
            }
983 
            SetVarToObj(varIndex, objv[3]);
984 
            break;
985 
        case 7:                         /* setlength */
986 
            if (objc != 4) {
987 
                goto wrongNumArgs;
988 
            }
989 
            if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
990 
                return TCL_ERROR;
991 
            }
992 
            if (varPtr[varIndex] != NULL) {
993 
                Tcl_SetObjLength(varPtr[varIndex], length);
994 
            }
995 
            break;
996 
    }
997 
 
998 
    return TCL_OK;
999 
}
1000 
 
1001 
/*
1002 
 *----------------------------------------------------------------------
1003 
 *
1004 
 * SetVarToObj --
1005 
 *
1006 
 *      Utility routine to assign a Tcl_Obj* to a test variable. The
1007 
 *      Tcl_Obj* can be NULL.
1008 
 *
1009 
 * Results:
1010 
 *      None.
1011 
 *
1012 
 * Side effects:
1013 
 *      This routine handles ref counting details for assignment:
1014 
 *      i.e. the old value's ref count must be decremented (if not NULL) and
1015 
 *      the new one incremented (also if not NULL).
1016 
 *
1017 
 *----------------------------------------------------------------------
1018 
 */
1019 
 
1020 
static void
1021 
SetVarToObj(varIndex, objPtr)
1022 
    int varIndex;               /* Designates the assignment variable. */
1023 
    Tcl_Obj *objPtr;            /* Points to object to assign to var. */
1024 
{
1025 
    if (varPtr[varIndex] != NULL) {
1026 
        Tcl_DecrRefCount(varPtr[varIndex]);
1027 
    }
1028 
    varPtr[varIndex] = objPtr;
1029 
    if (objPtr != NULL) {
1030 
        Tcl_IncrRefCount(objPtr);
1031 
    }
1032 
}
1033 
 
1034 
/*
1035 
 *----------------------------------------------------------------------
1036 
 *
1037 
 * GetVariableIndex --
1038 
 *
1039 
 *      Utility routine to get a test variable index from the command line.
1040 
 *
1041 
 * Results:
1042 
 *      A standard Tcl object result.
1043 
 *
1044 
 * Side effects:
1045 
 *      None.
1046 
 *
1047 
 *----------------------------------------------------------------------
1048 
 */
1049 
 
1050 
static int
1051 
GetVariableIndex(interp, string, indexPtr)
1052 
    Tcl_Interp *interp;         /* Interpreter for error reporting. */
1053 
    char *string;               /* String containing a variable index
1054 
                                 * specified as a nonnegative number less
1055 
                                 * than NUMBER_OF_OBJECT_VARS. */
1056 
    int *indexPtr;              /* Place to store converted result. */
1057 
{
1058 
    int index;
1059 
 
1060 
    if (Tcl_GetInt(interp, string, &index) != TCL_OK) {
1061 
        return TCL_ERROR;
1062 
    }
1063 
    if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) {
1064 
        Tcl_ResetResult(interp);
1065 
        Tcl_AppendToObj(Tcl_GetObjResult(interp), "bad variable index", -1);
1066 
        return TCL_ERROR;
1067 
    }
1068 
 
1069 
    *indexPtr = index;
1070 
    return TCL_OK;
1071 
}
1072 
 
1073 
/*
1074 
 *----------------------------------------------------------------------
1075 
 *
1076 
 * CheckIfVarUnset --
1077 
 *
1078 
 *      Utility procedure that checks whether a test variable is readable:
1079 
 *      i.e., that varPtr[varIndex] is non-NULL.
1080 
 *
1081 
 * Results:
1082 
 *      1 if the test variable is unset (NULL); 0 otherwise.
1083 
 *
1084 
 * Side effects:
1085 
 *      Sets the interpreter result to an error message if the variable is
1086 
 *      unset (NULL).
1087 
 *
1088 
 *----------------------------------------------------------------------
1089 
 */
1090 
 
1091 
static int
1092 
CheckIfVarUnset(interp, varIndex)
1093 
    Tcl_Interp *interp;         /* Interpreter for error reporting. */
1094 
    int varIndex;               /* Index of the test variable to check. */
1095 
{
1096 
    if (varPtr[varIndex] == NULL) {
1097 
        char buf[100];
1098 
 
1099 
        sprintf(buf, "variable %d is unset (NULL)", varIndex);
1100 
        Tcl_ResetResult(interp);
1101 
        Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
1102 
        return 1;
1103 
    }
1104 
    return 0;
1105 
}

powered by: WebSVN 2.1.0

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