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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25