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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 44 - (hide annotations) (download)
Fri Oct 14 02:09:58 2016 UTC (7 years, 11 months ago) by dashley
File MIME type: text/plain
File size: 30210 byte(s)
Rename for reorganization.
1 dashley 25 /* $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