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

Contents of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclresult.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 98 - (show annotations) (download)
Sun Dec 18 00:57:31 2016 UTC (7 years, 3 months ago) by dashley
File MIME type: text/plain
File size: 28826 byte(s)
Reorganization.
1 /* $Header$ */
2 /*
3 * tclResult.c --
4 *
5 * This file contains code to manage the interpreter result.
6 *
7 * Copyright (c) 1997 by Sun Microsystems, Inc.
8 *
9 * See the file "license.terms" for information on usage and redistribution
10 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 *
12 * RCS: @(#) $Id: tclresult.c,v 1.1.1.1 2001/06/13 04:45:53 dtashley Exp $
13 */
14
15 #include "tclInt.h"
16
17 /*
18 * Function prototypes for local procedures in this file:
19 */
20
21 static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
22 static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
23 int newSpace));
24
25
26 /*
27 *----------------------------------------------------------------------
28 *
29 * Tcl_SaveResult --
30 *
31 * Takes a snapshot of the current result state of the interpreter.
32 * The snapshot can be restored at any point by
33 * Tcl_RestoreResult. Note that this routine does not
34 * preserve the errorCode, errorInfo, or flags fields so it
35 * should not be used if an error is in progress.
36 *
37 * Once a snapshot is saved, it must be restored by calling
38 * Tcl_RestoreResult, or discarded by calling
39 * Tcl_DiscardResult.
40 *
41 * Results:
42 * None.
43 *
44 * Side effects:
45 * Resets the interpreter result.
46 *
47 *----------------------------------------------------------------------
48 */
49
50 void
51 Tcl_SaveResult(interp, statePtr)
52 Tcl_Interp *interp; /* Interpreter to save. */
53 Tcl_SavedResult *statePtr; /* Pointer to state structure. */
54 {
55 Interp *iPtr = (Interp *) interp;
56
57 /*
58 * Move the result object into the save state. Note that we don't need
59 * to change its refcount because we're moving it, not adding a new
60 * reference. Put an empty object into the interpreter.
61 */
62
63 statePtr->objResultPtr = iPtr->objResultPtr;
64 iPtr->objResultPtr = Tcl_NewObj();
65 Tcl_IncrRefCount(iPtr->objResultPtr);
66
67 /*
68 * Save the string result.
69 */
70
71 statePtr->freeProc = iPtr->freeProc;
72 if (iPtr->result == iPtr->resultSpace) {
73 /*
74 * Copy the static string data out of the interp buffer.
75 */
76
77 statePtr->result = statePtr->resultSpace;
78 strcpy(statePtr->result, iPtr->result);
79 statePtr->appendResult = NULL;
80 } else if (iPtr->result == iPtr->appendResult) {
81 /*
82 * Move the append buffer out of the interp.
83 */
84
85 statePtr->appendResult = iPtr->appendResult;
86 statePtr->appendAvl = iPtr->appendAvl;
87 statePtr->appendUsed = iPtr->appendUsed;
88 statePtr->result = statePtr->appendResult;
89 iPtr->appendResult = NULL;
90 iPtr->appendAvl = 0;
91 iPtr->appendUsed = 0;
92 } else {
93 /*
94 * Move the dynamic or static string out of the interpreter.
95 */
96
97 statePtr->result = iPtr->result;
98 statePtr->appendResult = NULL;
99 }
100
101 iPtr->result = iPtr->resultSpace;
102 iPtr->resultSpace[0] = 0;
103 iPtr->freeProc = 0;
104 }
105
106 /*
107 *----------------------------------------------------------------------
108 *
109 * Tcl_RestoreResult --
110 *
111 * Restores the state of the interpreter to a snapshot taken
112 * by Tcl_SaveResult. After this call, the token for
113 * the interpreter state is no longer valid.
114 *
115 * Results:
116 * None.
117 *
118 * Side effects:
119 * Restores the interpreter result.
120 *
121 *----------------------------------------------------------------------
122 */
123
124 void
125 Tcl_RestoreResult(interp, statePtr)
126 Tcl_Interp* interp; /* Interpreter being restored. */
127 Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
128 {
129 Interp *iPtr = (Interp *) interp;
130
131 Tcl_ResetResult(interp);
132
133 /*
134 * Restore the string result.
135 */
136
137 iPtr->freeProc = statePtr->freeProc;
138 if (statePtr->result == statePtr->resultSpace) {
139 /*
140 * Copy the static string data into the interp buffer.
141 */
142
143 iPtr->result = iPtr->resultSpace;
144 strcpy(iPtr->result, statePtr->result);
145 } else if (statePtr->result == statePtr->appendResult) {
146 /*
147 * Move the append buffer back into the interp.
148 */
149
150 if (iPtr->appendResult != NULL) {
151 ckfree((char *)iPtr->appendResult);
152 }
153
154 iPtr->appendResult = statePtr->appendResult;
155 iPtr->appendAvl = statePtr->appendAvl;
156 iPtr->appendUsed = statePtr->appendUsed;
157 iPtr->result = iPtr->appendResult;
158 } else {
159 /*
160 * Move the dynamic or static string back into the interpreter.
161 */
162
163 iPtr->result = statePtr->result;
164 }
165
166 /*
167 * Restore the object result.
168 */
169
170 Tcl_DecrRefCount(iPtr->objResultPtr);
171 iPtr->objResultPtr = statePtr->objResultPtr;
172 }
173
174 /*
175 *----------------------------------------------------------------------
176 *
177 * Tcl_DiscardResult --
178 *
179 * Frees the memory associated with an interpreter snapshot
180 * taken by Tcl_SaveResult. If the snapshot is not
181 * restored, this procedure must be called to discard it,
182 * or the memory will be lost.
183 *
184 * Results:
185 * None.
186 *
187 * Side effects:
188 * None.
189 *
190 *----------------------------------------------------------------------
191 */
192
193 void
194 Tcl_DiscardResult(statePtr)
195 Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
196 {
197 TclDecrRefCount(statePtr->objResultPtr);
198
199 if (statePtr->result == statePtr->appendResult) {
200 ckfree(statePtr->appendResult);
201 } else if (statePtr->freeProc) {
202 if ((statePtr->freeProc == TCL_DYNAMIC)
203 || (statePtr->freeProc == (Tcl_FreeProc *) free)) {
204 ckfree(statePtr->result);
205 } else {
206 (*statePtr->freeProc)(statePtr->result);
207 }
208 }
209 }
210
211 /*
212 *----------------------------------------------------------------------
213 *
214 * Tcl_SetResult --
215 *
216 * Arrange for "string" to be the Tcl return value.
217 *
218 * Results:
219 * None.
220 *
221 * Side effects:
222 * interp->result is left pointing either to "string" (if "copy" is 0)
223 * or to a copy of string. Also, the object result is reset.
224 *
225 *----------------------------------------------------------------------
226 */
227
228 void
229 Tcl_SetResult(interp, string, freeProc)
230 Tcl_Interp *interp; /* Interpreter with which to associate the
231 * return value. */
232 register char *string; /* Value to be returned. If NULL, the
233 * result is set to an empty string. */
234 Tcl_FreeProc *freeProc; /* Gives information about the string:
235 * TCL_STATIC, TCL_VOLATILE, or the address
236 * of a Tcl_FreeProc such as free. */
237 {
238 Interp *iPtr = (Interp *) interp;
239 int length;
240 register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
241 char *oldResult = iPtr->result;
242
243 if (string == NULL) {
244 iPtr->resultSpace[0] = 0;
245 iPtr->result = iPtr->resultSpace;
246 iPtr->freeProc = 0;
247 } else if (freeProc == TCL_VOLATILE) {
248 length = strlen(string);
249 if (length > TCL_RESULT_SIZE) {
250 iPtr->result = (char *) ckalloc((unsigned) length+1);
251 iPtr->freeProc = TCL_DYNAMIC;
252 } else {
253 iPtr->result = iPtr->resultSpace;
254 iPtr->freeProc = 0;
255 }
256 strcpy(iPtr->result, string);
257 } else {
258 iPtr->result = string;
259 iPtr->freeProc = freeProc;
260 }
261
262 /*
263 * If the old result was dynamically-allocated, free it up. Do it
264 * here, rather than at the beginning, in case the new result value
265 * was part of the old result value.
266 */
267
268 if (oldFreeProc != 0) {
269 if ((oldFreeProc == TCL_DYNAMIC)
270 || (oldFreeProc == (Tcl_FreeProc *) free)) {
271 ckfree(oldResult);
272 } else {
273 (*oldFreeProc)(oldResult);
274 }
275 }
276
277 /*
278 * Reset the object result since we just set the string result.
279 */
280
281 ResetObjResult(iPtr);
282 }
283
284 /*
285 *----------------------------------------------------------------------
286 *
287 * Tcl_GetStringResult --
288 *
289 * Returns an interpreter's result value as a string.
290 *
291 * Results:
292 * The interpreter's result as a string.
293 *
294 * Side effects:
295 * If the string result is empty, the object result is moved to the
296 * string result, then the object result is reset.
297 *
298 *----------------------------------------------------------------------
299 */
300
301 char *
302 Tcl_GetStringResult(interp)
303 register Tcl_Interp *interp; /* Interpreter whose result to return. */
304 {
305 /*
306 * If the string result is empty, move the object result to the
307 * string result, then reset the object result.
308 */
309
310 if (*(interp->result) == 0) {
311 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
312 TCL_VOLATILE);
313 }
314 return interp->result;
315 }
316
317 /*
318 *----------------------------------------------------------------------
319 *
320 * Tcl_SetObjResult --
321 *
322 * Arrange for objPtr to be an interpreter's result value.
323 *
324 * Results:
325 * None.
326 *
327 * Side effects:
328 * interp->objResultPtr is left pointing to the object referenced
329 * by objPtr. The object's reference count is incremented since
330 * there is now a new reference to it. The reference count for any
331 * old objResultPtr value is decremented. Also, the string result
332 * is reset.
333 *
334 *----------------------------------------------------------------------
335 */
336
337 void
338 Tcl_SetObjResult(interp, objPtr)
339 Tcl_Interp *interp; /* Interpreter with which to associate the
340 * return object value. */
341 register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
342 * obj result is made an empty string
343 * object. */
344 {
345 register Interp *iPtr = (Interp *) interp;
346 register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
347
348 iPtr->objResultPtr = objPtr;
349 Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
350
351 /*
352 * We wait until the end to release the old object result, in case
353 * we are setting the result to itself.
354 */
355
356 TclDecrRefCount(oldObjResult);
357
358 /*
359 * Reset the string result since we just set the result object.
360 */
361
362 if (iPtr->freeProc != NULL) {
363 if ((iPtr->freeProc == TCL_DYNAMIC)
364 || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
365 ckfree(iPtr->result);
366 } else {
367 (*iPtr->freeProc)(iPtr->result);
368 }
369 iPtr->freeProc = 0;
370 }
371 iPtr->result = iPtr->resultSpace;
372 iPtr->resultSpace[0] = 0;
373 }
374
375 /*
376 *----------------------------------------------------------------------
377 *
378 * Tcl_GetObjResult --
379 *
380 * Returns an interpreter's result value as a Tcl object. The object's
381 * reference count is not modified; the caller must do that if it
382 * needs to hold on to a long-term reference to it.
383 *
384 * Results:
385 * The interpreter's result as an object.
386 *
387 * Side effects:
388 * If the interpreter has a non-empty string result, the result object
389 * is either empty or stale because some procedure set interp->result
390 * directly. If so, the string result is moved to the result object
391 * then the string result is reset.
392 *
393 *----------------------------------------------------------------------
394 */
395
396 Tcl_Obj *
397 Tcl_GetObjResult(interp)
398 Tcl_Interp *interp; /* Interpreter whose result to return. */
399 {
400 register Interp *iPtr = (Interp *) interp;
401 Tcl_Obj *objResultPtr;
402 int length;
403
404 /*
405 * If the string result is non-empty, move the string result to the
406 * object result, then reset the string result.
407 */
408
409 if (*(iPtr->result) != 0) {
410 ResetObjResult(iPtr);
411
412 objResultPtr = iPtr->objResultPtr;
413 length = strlen(iPtr->result);
414 TclInitStringRep(objResultPtr, iPtr->result, length);
415
416 if (iPtr->freeProc != NULL) {
417 if ((iPtr->freeProc == TCL_DYNAMIC)
418 || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
419 ckfree(iPtr->result);
420 } else {
421 (*iPtr->freeProc)(iPtr->result);
422 }
423 iPtr->freeProc = 0;
424 }
425 iPtr->result = iPtr->resultSpace;
426 iPtr->resultSpace[0] = 0;
427 }
428 return iPtr->objResultPtr;
429 }
430
431 /*
432 *----------------------------------------------------------------------
433 *
434 * Tcl_AppendResultVA --
435 *
436 * Append a variable number of strings onto the interpreter's string
437 * result.
438 *
439 * Results:
440 * None.
441 *
442 * Side effects:
443 * The result of the interpreter given by the first argument is
444 * extended by the strings in the va_list (up to a terminating NULL
445 * argument).
446 *
447 * If the string result is empty, the object result is moved to the
448 * string result, then the object result is reset.
449 *
450 *----------------------------------------------------------------------
451 */
452
453 void
454 Tcl_AppendResultVA (interp, argList)
455 Tcl_Interp *interp; /* Interpreter with which to associate the
456 * return value. */
457 va_list argList; /* Variable argument list. */
458 {
459 #define STATIC_LIST_SIZE 16
460 Interp *iPtr = (Interp *) interp;
461 char *string, *static_list[STATIC_LIST_SIZE];
462 char **args = static_list;
463 int nargs_space = STATIC_LIST_SIZE;
464 int nargs, newSpace, i;
465
466 /*
467 * If the string result is empty, move the object result to the
468 * string result, then reset the object result.
469 */
470
471 if (*(iPtr->result) == 0) {
472 Tcl_SetResult((Tcl_Interp *) iPtr,
473 TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)),
474 TCL_VOLATILE);
475 }
476
477 /*
478 * Scan through all the arguments to see how much space is needed
479 * and save pointers to the arguments in the args array,
480 * reallocating as necessary.
481 */
482
483 nargs = 0;
484 newSpace = 0;
485 while (1) {
486 string = va_arg(argList, char *);
487 if (string == NULL) {
488 break;
489 }
490 if (nargs >= nargs_space) {
491 /*
492 * Expand the args buffer
493 */
494 nargs_space += STATIC_LIST_SIZE;
495 if (args == static_list) {
496 args = (void *)ckalloc(nargs_space * sizeof(char *));
497 for (i = 0; i < nargs; ++i) {
498 args[i] = static_list[i];
499 }
500 } else {
501 args = (void *)ckrealloc((void *)args,
502 nargs_space * sizeof(char *));
503 }
504 }
505 newSpace += strlen(string);
506 args[nargs++] = string;
507 }
508
509 /*
510 * If the append buffer isn't already setup and large enough to hold
511 * the new data, set it up.
512 */
513
514 if ((iPtr->result != iPtr->appendResult)
515 || (iPtr->appendResult[iPtr->appendUsed] != 0)
516 || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
517 SetupAppendBuffer(iPtr, newSpace);
518 }
519
520 /*
521 * Now go through all the argument strings again, copying them into the
522 * buffer.
523 */
524
525 for (i = 0; i < nargs; ++i) {
526 string = args[i];
527 strcpy(iPtr->appendResult + iPtr->appendUsed, string);
528 iPtr->appendUsed += strlen(string);
529 }
530
531 /*
532 * If we had to allocate a buffer from the heap,
533 * free it now.
534 */
535
536 if (args != static_list) {
537 ckfree((void *)args);
538 }
539 #undef STATIC_LIST_SIZE
540 }
541
542 /*
543 *----------------------------------------------------------------------
544 *
545 * Tcl_AppendResult --
546 *
547 * Append a variable number of strings onto the interpreter's string
548 * result.
549 *
550 * Results:
551 * None.
552 *
553 * Side effects:
554 * The result of the interpreter given by the first argument is
555 * extended by the strings given by the second and following arguments
556 * (up to a terminating NULL argument).
557 *
558 * If the string result is empty, the object result is moved to the
559 * string result, then the object result is reset.
560 *
561 *----------------------------------------------------------------------
562 */
563
564 void
565 Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
566 {
567 Tcl_Interp *interp;
568 va_list argList;
569
570 interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
571 Tcl_AppendResultVA(interp, argList);
572 va_end(argList);
573 }
574
575 /*
576 *----------------------------------------------------------------------
577 *
578 * Tcl_AppendElement --
579 *
580 * Convert a string to a valid Tcl list element and append it to the
581 * result (which is ostensibly a list).
582 *
583 * Results:
584 * None.
585 *
586 * Side effects:
587 * The result in the interpreter given by the first argument is
588 * extended with a list element converted from string. A separator
589 * space is added before the converted list element unless the current
590 * result is empty, contains the single character "{", or ends in " {".
591 *
592 * If the string result is empty, the object result is moved to the
593 * string result, then the object result is reset.
594 *
595 *----------------------------------------------------------------------
596 */
597
598 void
599 Tcl_AppendElement(interp, string)
600 Tcl_Interp *interp; /* Interpreter whose result is to be
601 * extended. */
602 CONST char *string; /* String to convert to list element and
603 * add to result. */
604 {
605 Interp *iPtr = (Interp *) interp;
606 char *dst;
607 int size;
608 int flags;
609
610 /*
611 * If the string result is empty, move the object result to the
612 * string result, then reset the object result.
613 */
614
615 if (*(iPtr->result) == 0) {
616 Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
617 TCL_VOLATILE);
618 }
619
620 /*
621 * See how much space is needed, and grow the append buffer if
622 * needed to accommodate the list element.
623 */
624
625 size = Tcl_ScanElement(string, &flags) + 1;
626 if ((iPtr->result != iPtr->appendResult)
627 || (iPtr->appendResult[iPtr->appendUsed] != 0)
628 || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
629 SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
630 }
631
632 /*
633 * Convert the string into a list element and copy it to the
634 * buffer that's forming, with a space separator if needed.
635 */
636
637 dst = iPtr->appendResult + iPtr->appendUsed;
638 if (TclNeedSpace(iPtr->appendResult, dst)) {
639 iPtr->appendUsed++;
640 *dst = ' ';
641 dst++;
642 }
643 iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
644 }
645
646 /*
647 *----------------------------------------------------------------------
648 *
649 * SetupAppendBuffer --
650 *
651 * This procedure makes sure that there is an append buffer properly
652 * initialized, if necessary, from the interpreter's result, and
653 * that it has at least enough room to accommodate newSpace new
654 * bytes of information.
655 *
656 * Results:
657 * None.
658 *
659 * Side effects:
660 * None.
661 *
662 *----------------------------------------------------------------------
663 */
664
665 static void
666 SetupAppendBuffer(iPtr, newSpace)
667 Interp *iPtr; /* Interpreter whose result is being set up. */
668 int newSpace; /* Make sure that at least this many bytes
669 * of new information may be added. */
670 {
671 int totalSpace;
672
673 /*
674 * Make the append buffer larger, if that's necessary, then copy the
675 * result into the append buffer and make the append buffer the official
676 * Tcl result.
677 */
678
679 if (iPtr->result != iPtr->appendResult) {
680 /*
681 * If an oversized buffer was used recently, then free it up
682 * so we go back to a smaller buffer. This avoids tying up
683 * memory forever after a large operation.
684 */
685
686 if (iPtr->appendAvl > 500) {
687 ckfree(iPtr->appendResult);
688 iPtr->appendResult = NULL;
689 iPtr->appendAvl = 0;
690 }
691 iPtr->appendUsed = strlen(iPtr->result);
692 } else if (iPtr->result[iPtr->appendUsed] != 0) {
693 /*
694 * Most likely someone has modified a result created by
695 * Tcl_AppendResult et al. so that it has a different size.
696 * Just recompute the size.
697 */
698
699 iPtr->appendUsed = strlen(iPtr->result);
700 }
701
702 totalSpace = newSpace + iPtr->appendUsed;
703 if (totalSpace >= iPtr->appendAvl) {
704 char *new;
705
706 if (totalSpace < 100) {
707 totalSpace = 200;
708 } else {
709 totalSpace *= 2;
710 }
711 new = (char *) ckalloc((unsigned) totalSpace);
712 strcpy(new, iPtr->result);
713 if (iPtr->appendResult != NULL) {
714 ckfree(iPtr->appendResult);
715 }
716 iPtr->appendResult = new;
717 iPtr->appendAvl = totalSpace;
718 } else if (iPtr->result != iPtr->appendResult) {
719 strcpy(iPtr->appendResult, iPtr->result);
720 }
721
722 Tcl_FreeResult((Tcl_Interp *) iPtr);
723 iPtr->result = iPtr->appendResult;
724 }
725
726 /*
727 *----------------------------------------------------------------------
728 *
729 * Tcl_FreeResult --
730 *
731 * This procedure frees up the memory associated with an interpreter's
732 * string result. It also resets the interpreter's result object.
733 * Tcl_FreeResult is most commonly used when a procedure is about to
734 * replace one result value with another.
735 *
736 * Results:
737 * None.
738 *
739 * Side effects:
740 * Frees the memory associated with interp's string result and sets
741 * interp->freeProc to zero, but does not change interp->result or
742 * clear error state. Resets interp's result object to an unshared
743 * empty object.
744 *
745 *----------------------------------------------------------------------
746 */
747
748 void
749 Tcl_FreeResult(interp)
750 register Tcl_Interp *interp; /* Interpreter for which to free result. */
751 {
752 register Interp *iPtr = (Interp *) interp;
753
754 if (iPtr->freeProc != NULL) {
755 if ((iPtr->freeProc == TCL_DYNAMIC)
756 || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
757 ckfree(iPtr->result);
758 } else {
759 (*iPtr->freeProc)(iPtr->result);
760 }
761 iPtr->freeProc = 0;
762 }
763
764 ResetObjResult(iPtr);
765 }
766
767 /*
768 *----------------------------------------------------------------------
769 *
770 * Tcl_ResetResult --
771 *
772 * This procedure resets both the interpreter's string and object
773 * results.
774 *
775 * Results:
776 * None.
777 *
778 * Side effects:
779 * It resets the result object to an unshared empty object. It
780 * then restores the interpreter's string result area to its default
781 * initialized state, freeing up any memory that may have been
782 * allocated. It also clears any error information for the interpreter.
783 *
784 *----------------------------------------------------------------------
785 */
786
787 void
788 Tcl_ResetResult(interp)
789 register Tcl_Interp *interp; /* Interpreter for which to clear result. */
790 {
791 register Interp *iPtr = (Interp *) interp;
792
793 ResetObjResult(iPtr);
794 if (iPtr->freeProc != NULL) {
795 if ((iPtr->freeProc == TCL_DYNAMIC)
796 || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
797 ckfree(iPtr->result);
798 } else {
799 (*iPtr->freeProc)(iPtr->result);
800 }
801 iPtr->freeProc = 0;
802 }
803 iPtr->result = iPtr->resultSpace;
804 iPtr->resultSpace[0] = 0;
805 iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
806 }
807
808 /*
809 *----------------------------------------------------------------------
810 *
811 * ResetObjResult --
812 *
813 * Procedure used to reset an interpreter's Tcl result object.
814 *
815 * Results:
816 * None.
817 *
818 * Side effects:
819 * Resets the interpreter's result object to an unshared empty string
820 * object with ref count one. It does not clear any error information
821 * in the interpreter.
822 *
823 *----------------------------------------------------------------------
824 */
825
826 static void
827 ResetObjResult(iPtr)
828 register Interp *iPtr; /* Points to the interpreter whose result
829 * object should be reset. */
830 {
831 register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
832
833 if (Tcl_IsShared(objResultPtr)) {
834 TclDecrRefCount(objResultPtr);
835 TclNewObj(objResultPtr);
836 Tcl_IncrRefCount(objResultPtr);
837 iPtr->objResultPtr = objResultPtr;
838 } else {
839 if ((objResultPtr->bytes != NULL)
840 && (objResultPtr->bytes != tclEmptyStringRep)) {
841 ckfree((char *) objResultPtr->bytes);
842 }
843 objResultPtr->bytes = tclEmptyStringRep;
844 objResultPtr->length = 0;
845 if ((objResultPtr->typePtr != NULL)
846 && (objResultPtr->typePtr->freeIntRepProc != NULL)) {
847 objResultPtr->typePtr->freeIntRepProc(objResultPtr);
848 }
849 objResultPtr->typePtr = (Tcl_ObjType *) NULL;
850 }
851 }
852
853 /*
854 *----------------------------------------------------------------------
855 *
856 * Tcl_SetErrorCodeVA --
857 *
858 * This procedure is called to record machine-readable information
859 * about an error that is about to be returned.
860 *
861 * Results:
862 * None.
863 *
864 * Side effects:
865 * The errorCode global variable is modified to hold all of the
866 * arguments to this procedure, in a list form with each argument
867 * becoming one element of the list. A flag is set internally
868 * to remember that errorCode has been set, so the variable doesn't
869 * get set automatically when the error is returned.
870 *
871 *----------------------------------------------------------------------
872 */
873
874 void
875 Tcl_SetErrorCodeVA (interp, argList)
876 Tcl_Interp *interp; /* Interpreter in which to access the errorCode
877 * variable. */
878 va_list argList; /* Variable argument list. */
879 {
880 char *string;
881 int flags;
882 Interp *iPtr = (Interp *) interp;
883
884 /*
885 * Scan through the arguments one at a time, appending them to
886 * $errorCode as list elements.
887 */
888
889 flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
890 while (1) {
891 string = va_arg(argList, char *);
892 if (string == NULL) {
893 break;
894 }
895 (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
896 (char *) NULL, string, flags);
897 flags |= TCL_APPEND_VALUE;
898 }
899 iPtr->flags |= ERROR_CODE_SET;
900 }
901
902 /*
903 *----------------------------------------------------------------------
904 *
905 * Tcl_SetErrorCode --
906 *
907 * This procedure is called to record machine-readable information
908 * about an error that is about to be returned.
909 *
910 * Results:
911 * None.
912 *
913 * Side effects:
914 * The errorCode global variable is modified to hold all of the
915 * arguments to this procedure, in a list form with each argument
916 * becoming one element of the list. A flag is set internally
917 * to remember that errorCode has been set, so the variable doesn't
918 * get set automatically when the error is returned.
919 *
920 *----------------------------------------------------------------------
921 */
922 /* VARARGS2 */
923 void
924 Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
925 {
926 Tcl_Interp *interp;
927 va_list argList;
928
929 /*
930 * Scan through the arguments one at a time, appending them to
931 * $errorCode as list elements.
932 */
933
934 interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
935 Tcl_SetErrorCodeVA(interp, argList);
936 va_end(argList);
937 }
938
939 /*
940 *----------------------------------------------------------------------
941 *
942 * Tcl_SetObjErrorCode --
943 *
944 * This procedure is called to record machine-readable information
945 * about an error that is about to be returned. The caller should
946 * build a list object up and pass it to this routine.
947 *
948 * Results:
949 * None.
950 *
951 * Side effects:
952 * The errorCode global variable is modified to be the new value.
953 * A flag is set internally to remember that errorCode has been
954 * set, so the variable doesn't get set automatically when the
955 * error is returned.
956 *
957 *----------------------------------------------------------------------
958 */
959
960 void
961 Tcl_SetObjErrorCode(interp, errorObjPtr)
962 Tcl_Interp *interp;
963 Tcl_Obj *errorObjPtr;
964 {
965 Interp *iPtr;
966
967 iPtr = (Interp *) interp;
968 Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY);
969 iPtr->flags |= ERROR_CODE_SET;
970 }
971
972 /*
973 *-------------------------------------------------------------------------
974 *
975 * TclTransferResult --
976 *
977 * Copy the result (and error information) from one interp to
978 * another. Used when one interp has caused another interp to
979 * evaluate a script and then wants to transfer the results back
980 * to itself.
981 *
982 * This routine copies the string reps of the result and error
983 * information. It does not simply increment the refcounts of the
984 * result and error information objects themselves.
985 * It is not legal to exchange objects between interps, because an
986 * object may be kept alive by one interp, but have an internal rep
987 * that is only valid while some other interp is alive.
988 *
989 * Results:
990 * The target interp's result is set to a copy of the source interp's
991 * result. The source's error information "$errorInfo" may be
992 * appended to the target's error information and the source's error
993 * code "$errorCode" may be stored in the target's error code.
994 *
995 * Side effects:
996 * None.
997 *
998 *-------------------------------------------------------------------------
999 */
1000
1001 void
1002 TclTransferResult(sourceInterp, result, targetInterp)
1003 Tcl_Interp *sourceInterp; /* Interp whose result and error information
1004 * should be moved to the target interp.
1005 * After moving result, this interp's result
1006 * is reset. */
1007 int result; /* TCL_OK if just the result should be copied,
1008 * TCL_ERROR if both the result and error
1009 * information should be copied. */
1010 Tcl_Interp *targetInterp; /* Interp where result and error information
1011 * should be stored. If source and target
1012 * are the same, nothing is done. */
1013 {
1014 Interp *iPtr;
1015 Tcl_Obj *objPtr;
1016
1017 if (sourceInterp == targetInterp) {
1018 return;
1019 }
1020
1021 if (result == TCL_ERROR) {
1022 /*
1023 * An error occurred, so transfer error information from the source
1024 * interpreter to the target interpreter. Setting the flags tells
1025 * the target interp that it has inherited a partial traceback
1026 * chain, not just a simple error message.
1027 */
1028
1029 iPtr = (Interp *) sourceInterp;
1030 if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
1031 Tcl_AddErrorInfo(sourceInterp, "");
1032 }
1033 iPtr->flags &= ~(ERR_ALREADY_LOGGED);
1034
1035 Tcl_ResetResult(targetInterp);
1036
1037 objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
1038 TCL_GLOBAL_ONLY);
1039 Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
1040 TCL_GLOBAL_ONLY);
1041
1042 objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
1043 TCL_GLOBAL_ONLY);
1044 Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr,
1045 TCL_GLOBAL_ONLY);
1046
1047 ((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET);
1048 }
1049
1050 ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
1051 Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
1052 Tcl_ResetResult(sourceInterp);
1053 }
1054
1055 /* End of tclresult.c */

Properties

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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25