]> cvs.zerfleddert.de Git - micropolis/blob - src/tcl/tclcmdah.c
projects / micropolis / blob
? search:


d1bf65fc868ca9322c4254141ff07ab6f46422bd
[micropolis] / src / tcl / tclcmdah.c
1 /*
2 * tclCmdAH.c --
3 *
4 * This file contains the top-level command routines for most of
5 * the Tcl built-in commands whose names begin with the letters
6 * A to H.
7 *
8 * Copyright 1987-1991 Regents of the University of California
9 * Permission to use, copy, modify, and distribute this
10 * software and its documentation for any purpose and without
11 * fee is hereby granted, provided that the above copyright
12 * notice appear in all copies. The University of California
13 * makes no representations about the suitability of this
14 * software for any purpose. It is provided "as is" without
15 * express or implied warranty.
16 */
17
18 #ifndef lint
19 static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.76 92/07/06 09:49:41 ouster Exp $ SPRITE (Berkeley)";
20 #endif
21
22 #include "tclint.h"
23
24 \f
25 /*
26 *----------------------------------------------------------------------
27 *
28 * Tcl_BreakCmd --
29 *
30 * This procedure is invoked to process the "break" Tcl command.
31 * See the user documentation for details on what it does.
32 *
33 * Results:
34 * A standard Tcl result.
35 *
36 * Side effects:
37 * See the user documentation.
38 *
39 *----------------------------------------------------------------------
40 */
41
42 /* ARGSUSED */
43 int
44 Tcl_BreakCmd(dummy, interp, argc, argv)
45 ClientData dummy; /* Not used. */
46 Tcl_Interp *interp; /* Current interpreter. */
47 int argc; /* Number of arguments. */
48 char **argv; /* Argument strings. */
49 {
50 if (argc != 1) {
51 Tcl_AppendResult(interp, "wrong # args: should be \"",
52 argv[0], "\"", (char *) NULL);
53 return TCL_ERROR;
54 }
55 return TCL_BREAK;
56 }
57 \f
58 /*
59 *----------------------------------------------------------------------
60 *
61 * Tcl_CaseCmd --
62 *
63 * This procedure is invoked to process the "case" Tcl command.
64 * See the user documentation for details on what it does.
65 *
66 * Results:
67 * A standard Tcl result.
68 *
69 * Side effects:
70 * See the user documentation.
71 *
72 *----------------------------------------------------------------------
73 */
74
75 /* ARGSUSED */
76 int
77 Tcl_CaseCmd(dummy, interp, argc, argv)
78 ClientData dummy; /* Not used. */
79 Tcl_Interp *interp; /* Current interpreter. */
80 int argc; /* Number of arguments. */
81 char **argv; /* Argument strings. */
82 {
83 int i, result;
84 int body;
85 char *string;
86 int caseArgc, splitArgs;
87 char **caseArgv;
88
89 if (argc < 3) {
90 Tcl_AppendResult(interp, "wrong # args: should be \"",
91 argv[0], " string ?in? patList body ... ?default body?\"",
92 (char *) NULL);
93 return TCL_ERROR;
94 }
95 string = argv[1];
96 body = -1;
97 if (strcmp(argv[2], "in") == 0) {
98 i = 3;
99 } else {
100 i = 2;
101 }
102 caseArgc = argc - i;
103 caseArgv = argv + i;
104
105 /*
106 * If all of the pattern/command pairs are lumped into a single
107 * argument, split them out again.
108 */
109
110 splitArgs = 0;
111 if (caseArgc == 1) {
112 result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
113 if (result != TCL_OK) {
114 return result;
115 }
116 splitArgs = 1;
117 }
118
119 for (i = 0; i < caseArgc; i += 2) {
120 int patArgc, j;
121 char **patArgv;
122 register char *p;
123
124 if (i == (caseArgc-1)) {
125 interp->result = "extra case pattern with no body";
126 result = TCL_ERROR;
127 goto cleanup;
128 }
129
130 /*
131 * Check for special case of single pattern (no list) with
132 * no backslash sequences.
133 */
134
135 for (p = caseArgv[i]; *p != 0; p++) {
136 if (isspace(*p) || (*p == '\\')) {
137 break;
138 }
139 }
140 if (*p == 0) {
141 if ((*caseArgv[i] == 'd')
142 && (strcmp(caseArgv[i], "default") == 0)) {
143 body = i+1;
144 }
145 if (Tcl_StringMatch(string, caseArgv[i])) {
146 body = i+1;
147 goto match;
148 }
149 continue;
150 }
151
152 /*
153 * Break up pattern lists, then check each of the patterns
154 * in the list.
155 */
156
157 result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
158 if (result != TCL_OK) {
159 goto cleanup;
160 }
161 for (j = 0; j < patArgc; j++) {
162 if (Tcl_StringMatch(string, patArgv[j])) {
163 body = i+1;
164 break;
165 }
166 }
167 ckfree((char *) patArgv);
168 if (j < patArgc) {
169 break;
170 }
171 }
172
173 match:
174 if (body != -1) {
175 result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL);
176 if (result == TCL_ERROR) {
177 char msg[100];
178 sprintf(msg, "\n (\"%.50s\" arm line %d)", caseArgv[body-1],
179 interp->errorLine);
180 Tcl_AddErrorInfo(interp, msg);
181 }
182 goto cleanup;
183 }
184
185 /*
186 * Nothing matched: return nothing.
187 */
188
189 result = TCL_OK;
190
191 cleanup:
192 if (splitArgs) {
193 ckfree((char *) caseArgv);
194 }
195 return result;
196 }
197 \f
198 /*
199 *----------------------------------------------------------------------
200 *
201 * Tcl_CatchCmd --
202 *
203 * This procedure is invoked to process the "catch" Tcl command.
204 * See the user documentation for details on what it does.
205 *
206 * Results:
207 * A standard Tcl result.
208 *
209 * Side effects:
210 * See the user documentation.
211 *
212 *----------------------------------------------------------------------
213 */
214
215 /* ARGSUSED */
216 int
217 Tcl_CatchCmd(dummy, interp, argc, argv)
218 ClientData dummy; /* Not used. */
219 Tcl_Interp *interp; /* Current interpreter. */
220 int argc; /* Number of arguments. */
221 char **argv; /* Argument strings. */
222 {
223 int result;
224
225 if ((argc != 2) && (argc != 3)) {
226 Tcl_AppendResult(interp, "wrong # args: should be \"",
227 argv[0], " command ?varName?\"", (char *) NULL);
228 return TCL_ERROR;
229 }
230 result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
231 if (argc == 3) {
232 if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
233 Tcl_SetResult(interp, "couldn't save command result in variable",
234 TCL_STATIC);
235 return TCL_ERROR;
236 }
237 }
238 Tcl_ResetResult(interp);
239 sprintf(interp->result, "%d", result);
240 return TCL_OK;
241 }
242 \f
243 /*
244 *----------------------------------------------------------------------
245 *
246 * Tcl_ConcatCmd --
247 *
248 * This procedure is invoked to process the "concat" Tcl command.
249 * See the user documentation for details on what it does.
250 *
251 * Results:
252 * A standard Tcl result.
253 *
254 * Side effects:
255 * See the user documentation.
256 *
257 *----------------------------------------------------------------------
258 */
259
260 /* ARGSUSED */
261 int
262 Tcl_ConcatCmd(dummy, interp, argc, argv)
263 ClientData dummy; /* Not used. */
264 Tcl_Interp *interp; /* Current interpreter. */
265 int argc; /* Number of arguments. */
266 char **argv; /* Argument strings. */
267 {
268 if (argc == 1) {
269 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
270 " arg ?arg ...?\"", (char *) NULL);
271 return TCL_ERROR;
272 }
273
274 interp->result = Tcl_Concat(argc-1, argv+1);
275 interp->freeProc = (Tcl_FreeProc *) free;
276 return TCL_OK;
277 }
278 \f
279 /*
280 *----------------------------------------------------------------------
281 *
282 * Tcl_ContinueCmd --
283 *
284 * This procedure is invoked to process the "continue" Tcl command.
285 * See the user documentation for details on what it does.
286 *
287 * Results:
288 * A standard Tcl result.
289 *
290 * Side effects:
291 * See the user documentation.
292 *
293 *----------------------------------------------------------------------
294 */
295
296 /* ARGSUSED */
297 int
298 Tcl_ContinueCmd(dummy, interp, argc, argv)
299 ClientData dummy; /* Not used. */
300 Tcl_Interp *interp; /* Current interpreter. */
301 int argc; /* Number of arguments. */
302 char **argv; /* Argument strings. */
303 {
304 if (argc != 1) {
305 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
306 "\"", (char *) NULL);
307 return TCL_ERROR;
308 }
309 return TCL_CONTINUE;
310 }
311 \f
312 /*
313 *----------------------------------------------------------------------
314 *
315 * Tcl_ErrorCmd --
316 *
317 * This procedure is invoked to process the "error" Tcl command.
318 * See the user documentation for details on what it does.
319 *
320 * Results:
321 * A standard Tcl result.
322 *
323 * Side effects:
324 * See the user documentation.
325 *
326 *----------------------------------------------------------------------
327 */
328
329 /* ARGSUSED */
330 int
331 Tcl_ErrorCmd(dummy, interp, argc, argv)
332 ClientData dummy; /* Not used. */
333 Tcl_Interp *interp; /* Current interpreter. */
334 int argc; /* Number of arguments. */
335 char **argv; /* Argument strings. */
336 {
337 Interp *iPtr = (Interp *) interp;
338
339 if ((argc < 2) || (argc > 4)) {
340 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
341 " message ?errorInfo? ?errorCode?\"", (char *) NULL);
342 return TCL_ERROR;
343 }
344 if ((argc >= 3) && (argv[2][0] != 0)) {
345 Tcl_AddErrorInfo(interp, argv[2]);
346 iPtr->flags |= ERR_ALREADY_LOGGED;
347 }
348 if (argc == 4) {
349 Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
350 TCL_GLOBAL_ONLY);
351 iPtr->flags |= ERROR_CODE_SET;
352 }
353 Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
354 return TCL_ERROR;
355 }
356 \f
357 /*
358 *----------------------------------------------------------------------
359 *
360 * Tcl_EvalCmd --
361 *
362 * This procedure is invoked to process the "eval" Tcl command.
363 * See the user documentation for details on what it does.
364 *
365 * Results:
366 * A standard Tcl result.
367 *
368 * Side effects:
369 * See the user documentation.
370 *
371 *----------------------------------------------------------------------
372 */
373
374 /* ARGSUSED */
375 int
376 Tcl_EvalCmd(dummy, interp, argc, argv)
377 ClientData dummy; /* Not used. */
378 Tcl_Interp *interp; /* Current interpreter. */
379 int argc; /* Number of arguments. */
380 char **argv; /* Argument strings. */
381 {
382 int result;
383 char *cmd;
384
385 if (argc < 2) {
386 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
387 " arg ?arg ...?\"", (char *) NULL);
388 return TCL_ERROR;
389 }
390 if (argc == 2) {
391 result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
392 } else {
393
394 /*
395 * More than one argument: concatenate them together with spaces
396 * between, then evaluate the result.
397 */
398
399 cmd = Tcl_Concat(argc-1, argv+1);
400 result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
401 ckfree(cmd);
402 }
403 if (result == TCL_ERROR) {
404 char msg[60];
405 sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
406 Tcl_AddErrorInfo(interp, msg);
407 }
408 return result;
409 }
410 \f
411 /*
412 *----------------------------------------------------------------------
413 *
414 * Tcl_ExprCmd --
415 *
416 * This procedure is invoked to process the "expr" Tcl command.
417 * See the user documentation for details on what it does.
418 *
419 * Results:
420 * A standard Tcl result.
421 *
422 * Side effects:
423 * See the user documentation.
424 *
425 *----------------------------------------------------------------------
426 */
427
428 /* ARGSUSED */
429 int
430 Tcl_ExprCmd(dummy, interp, argc, argv)
431 ClientData dummy; /* Not used. */
432 Tcl_Interp *interp; /* Current interpreter. */
433 int argc; /* Number of arguments. */
434 char **argv; /* Argument strings. */
435 {
436 if (argc != 2) {
437 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
438 " expression\"", (char *) NULL);
439 return TCL_ERROR;
440 }
441
442 return Tcl_ExprString(interp, argv[1]);
443 }
444 \f
445 /*
446 *----------------------------------------------------------------------
447 *
448 * Tcl_ForCmd --
449 *
450 * This procedure is invoked to process the "for" Tcl command.
451 * See the user documentation for details on what it does.
452 *
453 * Results:
454 * A standard Tcl result.
455 *
456 * Side effects:
457 * See the user documentation.
458 *
459 *----------------------------------------------------------------------
460 */
461
462 /* ARGSUSED */
463 int
464 Tcl_ForCmd(dummy, interp, argc, argv)
465 ClientData dummy; /* Not used. */
466 Tcl_Interp *interp; /* Current interpreter. */
467 int argc; /* Number of arguments. */
468 char **argv; /* Argument strings. */
469 {
470 int result, value;
471
472 if (argc != 5) {
473 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
474 " start test next command\"", (char *) NULL);
475 return TCL_ERROR;
476 }
477
478 result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
479 if (result != TCL_OK) {
480 if (result == TCL_ERROR) {
481 Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
482 }
483 return result;
484 }
485 while (1) {
486 result = Tcl_ExprBoolean(interp, argv[2], &value);
487 if (result != TCL_OK) {
488 return result;
489 }
490 if (!value) {
491 break;
492 }
493 result = Tcl_Eval(interp, argv[4], 0, (char **) NULL);
494 if (result == TCL_CONTINUE) {
495 result = TCL_OK;
496 } else if (result != TCL_OK) {
497 if (result == TCL_ERROR) {
498 char msg[60];
499 sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
500 Tcl_AddErrorInfo(interp, msg);
501 }
502 break;
503 }
504 result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
505 if (result == TCL_BREAK) {
506 break;
507 } else if (result != TCL_OK) {
508 if (result == TCL_ERROR) {
509 Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
510 }
511 return result;
512 }
513 }
514 if (result == TCL_BREAK) {
515 result = TCL_OK;
516 }
517 if (result == TCL_OK) {
518 Tcl_ResetResult(interp);
519 }
520 return result;
521 }
522 \f
523 /*
524 *----------------------------------------------------------------------
525 *
526 * Tcl_ForeachCmd --
527 *
528 * This procedure is invoked to process the "foreach" Tcl command.
529 * See the user documentation for details on what it does.
530 *
531 * Results:
532 * A standard Tcl result.
533 *
534 * Side effects:
535 * See the user documentation.
536 *
537 *----------------------------------------------------------------------
538 */
539
540 /* ARGSUSED */
541 int
542 Tcl_ForeachCmd(dummy, interp, argc, argv)
543 ClientData dummy; /* Not used. */
544 Tcl_Interp *interp; /* Current interpreter. */
545 int argc; /* Number of arguments. */
546 char **argv; /* Argument strings. */
547 {
548 int listArgc, i, result;
549 char **listArgv;
550
551 if (argc != 4) {
552 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
553 " varName list command\"", (char *) NULL);
554 return TCL_ERROR;
555 }
556
557 /*
558 * Break the list up into elements, and execute the command once
559 * for each value of the element.
560 */
561
562 result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
563 if (result != TCL_OK) {
564 return result;
565 }
566 for (i = 0; i < listArgc; i++) {
567 if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
568 Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
569 result = TCL_ERROR;
570 break;
571 }
572
573 result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
574 if (result != TCL_OK) {
575 if (result == TCL_CONTINUE) {
576 result = TCL_OK;
577 } else if (result == TCL_BREAK) {
578 result = TCL_OK;
579 break;
580 } else if (result == TCL_ERROR) {
581 char msg[100];
582 sprintf(msg, "\n (\"foreach\" body line %d)",
583 interp->errorLine);
584 Tcl_AddErrorInfo(interp, msg);
585 break;
586 } else {
587 break;
588 }
589 }
590 }
591 ckfree((char *) listArgv);
592 if (result == TCL_OK) {
593 Tcl_ResetResult(interp);
594 }
595 return result;
596 }
597 \f
598 /*
599 *----------------------------------------------------------------------
600 *
601 * Tcl_FormatCmd --
602 *
603 * This procedure is invoked to process the "format" Tcl command.
604 * See the user documentation for details on what it does.
605 *
606 * Results:
607 * A standard Tcl result.
608 *
609 * Side effects:
610 * See the user documentation.
611 *
612 *----------------------------------------------------------------------
613 */
614
615 /* ARGSUSED */
616 int
617 Tcl_FormatCmd(dummy, interp, argc, argv)
618 ClientData dummy; /* Not used. */
619 Tcl_Interp *interp; /* Current interpreter. */
620 int argc; /* Number of arguments. */
621 char **argv; /* Argument strings. */
622 {
623 register char *format; /* Used to read characters from the format
624 * string. */
625 char newFormat[40]; /* A new format specifier is generated here. */
626 int width; /* Field width from field specifier, or 0 if
627 * no width given. */
628 int precision; /* Field precision from field specifier, or 0
629 * if no precision given. */
630 int size; /* Number of bytes needed for result of
631 * conversion, based on type of conversion
632 * ("e", "s", etc.) and width from above. */
633 char *oneWordValue = NULL; /* Used to hold value to pass to sprintf, if
634 * it's a one-word value. */
635 double twoWordValue; /* Used to hold value to pass to sprintf if
636 * it's a two-word value. */
637 int useTwoWords; /* 0 means use oneWordValue, 1 means use
638 * twoWordValue. */
639 char *dst = interp->result; /* Where result is stored. Starts off at
640 * interp->resultSpace, but may get dynamically
641 * re-allocated if this isn't enough. */
642 int dstSize = 0; /* Number of non-null characters currently
643 * stored at dst. */
644 int dstSpace = TCL_RESULT_SIZE;
645 /* Total amount of storage space available
646 * in dst (not including null terminator. */
647 int noPercent; /* Special case for speed: indicates there's
648 * no field specifier, just a string to copy. */
649 char **curArg; /* Remainder of argv array. */
650 int useShort; /* Value to be printed is short (half word). */
651
652 /*
653 * This procedure is a bit nasty. The goal is to use sprintf to
654 * do most of the dirty work. There are several problems:
655 * 1. this procedure can't trust its arguments.
656 * 2. we must be able to provide a large enough result area to hold
657 * whatever's generated. This is hard to estimate.
658 * 2. there's no way to move the arguments from argv to the call
659 * to sprintf in a reasonable way. This is particularly nasty
660 * because some of the arguments may be two-word values (doubles).
661 * So, what happens here is to scan the format string one % group
662 * at a time, making many individual calls to sprintf.
663 */
664
665 if (argc < 2) {
666 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
667 " formatString ?arg arg ...?\"", (char *) NULL);
668 return TCL_ERROR;
669 }
670 curArg = argv+2;
671 argc -= 2;
672 for (format = argv[1]; *format != 0; ) {
673 register char *newPtr = newFormat;
674
675 width = precision = useTwoWords = noPercent = useShort = 0;
676
677 /*
678 * Get rid of any characters before the next field specifier.
679 * Collapse backslash sequences found along the way.
680 */
681
682 if (*format != '%') {
683 register char *p;
684 int bsSize;
685
686 oneWordValue = p = format;
687 while ((*format != '%') && (*format != 0)) {
688 if (*format == '\\') {
689 *p = Tcl_Backslash(format, &bsSize);
690 if (*p != 0) {
691 p++;
692 }
693 format += bsSize;
694 } else {
695 *p = *format;
696 p++;
697 format++;
698 }
699 }
700 size = p - oneWordValue;
701 noPercent = 1;
702 goto doField;
703 }
704
705 if (format[1] == '%') {
706 oneWordValue = format;
707 size = 1;
708 noPercent = 1;
709 format += 2;
710 goto doField;
711 }
712
713 /*
714 * Parse off a field specifier, compute how many characters
715 * will be needed to store the result, and substitute for
716 * "*" size specifiers.
717 */
718
719 *newPtr = '%';
720 newPtr++;
721 format++;
722 while ((*format == '-') || (*format == '#')) {
723 *newPtr = *format;
724 newPtr++;
725 format++;
726 }
727 if (*format == '0') {
728 *newPtr = '0';
729 newPtr++;
730 format++;
731 }
732 if (isdigit(*format)) {
733 width = atoi(format);
734 do {
735 format++;
736 } while (isdigit(*format));
737 } else if (*format == '*') {
738 if (argc <= 0) {
739 goto notEnoughArgs;
740 }
741 if (Tcl_GetInt(interp, *curArg, &width) != TCL_OK) {
742 goto fmtError;
743 }
744 argc--;
745 curArg++;
746 format++;
747 }
748 if (width != 0) {
749 sprintf(newPtr, "%d", width);
750 while (*newPtr != 0) {
751 newPtr++;
752 }
753 }
754 if (*format == '.') {
755 *newPtr = '.';
756 newPtr++;
757 format++;
758 }
759 if (isdigit(*format)) {
760 precision = atoi(format);
761 do {
762 format++;
763 } while (isdigit(*format));
764 } else if (*format == '*') {
765 if (argc <= 0) {
766 goto notEnoughArgs;
767 }
768 if (Tcl_GetInt(interp, *curArg, &precision) != TCL_OK) {
769 goto fmtError;
770 }
771 argc--;
772 curArg++;
773 format++;
774 }
775 if (precision != 0) {
776 sprintf(newPtr, "%d", precision);
777 while (*newPtr != 0) {
778 newPtr++;
779 }
780 }
781 if (*format == 'l') {
782 format++;
783 } else if (*format == 'h') {
784 useShort = 1;
785 *newPtr = 'h';
786 newPtr++;
787 format++;
788 }
789 *newPtr = *format;
790 newPtr++;
791 *newPtr = 0;
792 if (argc <= 0) {
793 goto notEnoughArgs;
794 }
795 switch (*format) {
796 case 'D':
797 case 'O':
798 case 'U':
799 if (!useShort) {
800 newPtr++;
801 } else {
802 useShort = 0;
803 }
804 newPtr[-1] = tolower(*format);
805 newPtr[-2] = 'l';
806 *newPtr = 0;
807 case 'd':
808 case 'o':
809 case 'u':
810 case 'x':
811 case 'X':
812 if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
813 != TCL_OK) {
814 goto fmtError;
815 }
816 size = 40;
817 break;
818 case 's':
819 oneWordValue = *curArg;
820 size = strlen(*curArg);
821 break;
822 case 'c':
823 if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
824 != TCL_OK) {
825 goto fmtError;
826 }
827 size = 1;
828 break;
829 case 'F':
830 newPtr[-1] = tolower(newPtr[-1]);
831 case 'e':
832 case 'E':
833 case 'f':
834 case 'g':
835 case 'G':
836 if (Tcl_GetDouble(interp, *curArg, &twoWordValue) != TCL_OK) {
837 goto fmtError;
838 }
839 useTwoWords = 1;
840 size = 320;
841 if (precision > 10) {
842 size += precision;
843 }
844 break;
845 case 0:
846 interp->result =
847 "format string ended in middle of field specifier";
848 goto fmtError;
849 default:
850 sprintf(interp->result, "bad field specifier \"%c\"", *format);
851 goto fmtError;
852 }
853 argc--;
854 curArg++;
855 format++;
856
857 /*
858 * Make sure that there's enough space to hold the formatted
859 * result, then format it.
860 */
861
862 doField:
863 if (width > size) {
864 size = width;
865 }
866 if ((dstSize + size) > dstSpace) {
867 char *newDst;
868 int newSpace;
869
870 newSpace = 2*(dstSize + size);
871 newDst = (char *) ckalloc((unsigned) newSpace+1);
872 if (dstSize != 0) {
873 memcpy((VOID *) newDst, (VOID *) dst, dstSize);
874 }
875 if (dstSpace != TCL_RESULT_SIZE) {
876 ckfree(dst);
877 }
878 dst = newDst;
879 dstSpace = newSpace;
880 }
881 if (noPercent) {
882 memcpy((VOID *) (dst+dstSize), (VOID *) oneWordValue, size);
883 dstSize += size;
884 dst[dstSize] = 0;
885 } else {
886 if (useTwoWords) {
887 sprintf(dst+dstSize, newFormat, twoWordValue);
888 } else if (useShort) {
889 int tmp = (int)oneWordValue;
890 sprintf(dst+dstSize, newFormat, (short)tmp);
891 } else {
892 sprintf(dst+dstSize, newFormat, oneWordValue);
893 }
894 dstSize += strlen(dst+dstSize);
895 }
896 }
897
898 interp->result = dst;
899 if (dstSpace != TCL_RESULT_SIZE) {
900 interp->freeProc = (Tcl_FreeProc *) free;
901 } else {
902 interp->freeProc = 0;
903 }
904 return TCL_OK;
905
906 notEnoughArgs:
907 interp->result = "not enough arguments for all format specifiers";
908 fmtError:
909 if (dstSpace != TCL_RESULT_SIZE) {
910 ckfree(dst);
911 }
912 return TCL_ERROR;
913 }
Micropolis
Impressum, Datenschutz