]> cvs.zerfleddert.de Git - micropolis/blame_incremental - src/tcl/tclcmdil.c
projects / micropolis / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
fix fire coverage overlay by iterating over the whole map
[micropolis] / src / tcl / tclcmdil.c
... / ...
CommitLineData
1/*
2 * tclCmdIL.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 * I through L. It contains only commands in the generic core
7 * (i.e. those that don't depend much upon UNIX facilities).
8 *
9 * Copyright 1987-1991 Regents of the University of California
10 * Permission to use, copy, modify, and distribute this
11 * software and its documentation for any purpose and without
12 * fee is hereby granted, provided that the above copyright
13 * notice appear in all copies. The University of California
14 * makes no representations about the suitability of this
15 * software for any purpose. It is provided "as is" without
16 * express or implied warranty.
17 */
18
19#ifndef lint
20static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.84 91/12/06 10:42:36 ouster Exp $ SPRITE (Berkeley)";
21#endif
22
23#include "tclint.h"
24
25/*
26 * Global absolute file name:
27 */
28
29char *TCL_Library = TCL_LIBRARY;
30
31/*
32 * Forward declarations for procedures defined in this file:
33 */
34
35static int SortCompareProc _ANSI_ARGS_((CONST VOID *first,
36 CONST VOID *second));
37\f
38/*
39 *----------------------------------------------------------------------
40 *
41 * Tcl_IfCmd --
42 *
43 * This procedure is invoked to process the "if" Tcl command.
44 * See the user documentation for details on what it does.
45 *
46 * Results:
47 * A standard Tcl result.
48 *
49 * Side effects:
50 * See the user documentation.
51 *
52 *----------------------------------------------------------------------
53 */
54
55 /* ARGSUSED */
56int
57Tcl_IfCmd(dummy, interp, argc, argv)
58 ClientData dummy; /* Not used. */
59 Tcl_Interp *interp; /* Current interpreter. */
60 int argc; /* Number of arguments. */
61 char **argv; /* Argument strings. */
62{
63 char *condition, *ifPart, *elsePart, *cmd, *name;
64 char *clause;
65 int result, value;
66
67 name = argv[0];
68 if (argc < 3) {
69 ifSyntax:
70 Tcl_AppendResult(interp, "wrong # args: should be \"", name,
71 " bool ?then? command ?else? ?command?\"", (char *) NULL);
72 return TCL_ERROR;
73 }
74 condition = argv[1];
75 argc -= 2;
76 argv += 2;
77 if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
78 argc--;
79 argv++;
80 }
81 if (argc < 1) {
82 goto ifSyntax;
83 }
84 ifPart = *argv;
85 argv++;
86 argc--;
87 if (argc == 0) {
88 elsePart = "";
89 } else {
90 if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
91 argc--;
92 argv++;
93 }
94 if (argc != 1) {
95 goto ifSyntax;
96 }
97 elsePart = *argv;
98 }
99
100 cmd = ifPart;
101 clause = "\"then\" clause";
102 result = Tcl_ExprBoolean(interp, condition, &value);
103 if (result != TCL_OK) {
104 if (result == TCL_ERROR) {
105 char msg[60];
106 sprintf(msg, "\n (\"if\" test line %d)", interp->errorLine);
107 Tcl_AddErrorInfo(interp, msg);
108 }
109 return result;
110 }
111 if (value == 0) {
112 cmd = elsePart;
113 clause = "\"else\" clause";
114 }
115 if (*cmd == 0) {
116 return TCL_OK;
117 }
118 result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
119 if (result == TCL_ERROR) {
120 char msg[60];
121 sprintf(msg, "\n (%s line %d)", clause, interp->errorLine);
122 Tcl_AddErrorInfo(interp, msg);
123 }
124 return result;
125}
126\f
127/*
128 *----------------------------------------------------------------------
129 *
130 * Tcl_IncrCmd --
131 *
132 * This procedure is invoked to process the "incr" Tcl command.
133 * See the user documentation for details on what it does.
134 *
135 * Results:
136 * A standard Tcl result.
137 *
138 * Side effects:
139 * See the user documentation.
140 *
141 *----------------------------------------------------------------------
142 */
143
144 /* ARGSUSED */
145int
146Tcl_IncrCmd(dummy, interp, argc, argv)
147 ClientData dummy; /* Not used. */
148 Tcl_Interp *interp; /* Current interpreter. */
149 int argc; /* Number of arguments. */
150 char **argv; /* Argument strings. */
151{
152 int value;
153 char *oldString, *result;
154 char newString[30];
155
156 if ((argc != 2) && (argc != 3)) {
157 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
158 " varName ?increment?\"", (char *) NULL);
159 return TCL_ERROR;
160 }
161
162 oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
163 if (oldString == NULL) {
164 return TCL_ERROR;
165 }
166 if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
167 Tcl_AddErrorInfo(interp,
168 "\n (reading value of variable to increment)");
169 return TCL_ERROR;
170 }
171 if (argc == 2) {
172 value += 1;
173 } else {
174 int increment;
175
176 if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
177 Tcl_AddErrorInfo(interp,
178 "\n (reading increment)");
179 return TCL_ERROR;
180 }
181 value += increment;
182 }
183 sprintf(newString, "%d", value);
184 result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
185 if (result == NULL) {
186 return TCL_ERROR;
187 }
188 interp->result = result;
189 return TCL_OK;
190}
191\f
192/*
193 *----------------------------------------------------------------------
194 *
195 * Tcl_InfoCmd --
196 *
197 * This procedure is invoked to process the "info" Tcl command.
198 * See the user documentation for details on what it does.
199 *
200 * Results:
201 * A standard Tcl result.
202 *
203 * Side effects:
204 * See the user documentation.
205 *
206 *----------------------------------------------------------------------
207 */
208
209 /* ARGSUSED */
210int
211Tcl_InfoCmd(dummy, interp, argc, argv)
212 ClientData dummy; /* Not used. */
213 Tcl_Interp *interp; /* Current interpreter. */
214 int argc; /* Number of arguments. */
215 char **argv; /* Argument strings. */
216{
217 register Interp *iPtr = (Interp *) interp;
218 int length;
219 char c;
220 Arg *argPtr;
221 Proc *procPtr;
222 Var *varPtr;
223 Command *cmdPtr;
224 Tcl_HashEntry *hPtr;
225 Tcl_HashSearch search;
226
227 if (argc < 2) {
228 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
229 " option ?arg arg ...?\"", (char *) NULL);
230 return TCL_ERROR;
231 }
232 c = argv[1][0];
233 length = strlen(argv[1]);
234 if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
235 if (argc != 3) {
236 Tcl_AppendResult(interp, "wrong # args: should be \"",
237 argv[0], " args procname\"", (char *) NULL);
238 return TCL_ERROR;
239 }
240 procPtr = TclFindProc(iPtr, argv[2]);
241 if (procPtr == NULL) {
242 infoNoSuchProc:
243 Tcl_AppendResult(interp, "\"", argv[2],
244 "\" isn't a procedure", (char *) NULL);
245 return TCL_ERROR;
246 }
247 for (argPtr = procPtr->argPtr; argPtr != NULL;
248 argPtr = argPtr->nextPtr) {
249 Tcl_AppendElement(interp, argPtr->name, 0);
250 }
251 return TCL_OK;
252 } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
253 if (argc != 3) {
254 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
255 " body procname\"", (char *) NULL);
256 return TCL_ERROR;
257 }
258 procPtr = TclFindProc(iPtr, argv[2]);
259 if (procPtr == NULL) {
260 goto infoNoSuchProc;
261 }
262 iPtr->result = procPtr->command;
263 return TCL_OK;
264 } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
265 && (length >= 2)) {
266 if (argc != 2) {
267 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
268 " cmdcount\"", (char *) NULL);
269 return TCL_ERROR;
270 }
271 sprintf(iPtr->result, "%d", iPtr->cmdCount);
272 return TCL_OK;
273 } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
274 && (length >= 2)){
275 if (argc > 3) {
276 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
277 " commands [pattern]\"", (char *) NULL);
278 return TCL_ERROR;
279 }
280 for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
281 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
282 char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
283 if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
284 continue;
285 }
286 Tcl_AppendElement(interp, name, 0);
287 }
288 return TCL_OK;
289 } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
290 if (argc != 5) {
291 Tcl_AppendResult(interp, "wrong # args: should be \"",
292 argv[0], " default procname arg varname\"",
293 (char *) NULL);
294 return TCL_ERROR;
295 }
296 procPtr = TclFindProc(iPtr, argv[2]);
297 if (procPtr == NULL) {
298 goto infoNoSuchProc;
299 }
300 for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
301 if (argPtr == NULL) {
302 Tcl_AppendResult(interp, "procedure \"", argv[2],
303 "\" doesn't have an argument \"", argv[3],
304 "\"", (char *) NULL);
305 return TCL_ERROR;
306 }
307 if (strcmp(argv[3], argPtr->name) == 0) {
308 if (argPtr->defValue != NULL) {
309 if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
310 argPtr->defValue, 0) == NULL) {
311 defStoreError:
312 Tcl_AppendResult(interp,
313 "couldn't store default value in variable \"",
314 argv[4], "\"", (char *) NULL);
315 return TCL_ERROR;
316 }
317 iPtr->result = "1";
318 } else {
319 if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
320 == NULL) {
321 goto defStoreError;
322 }
323 iPtr->result = "0";
324 }
325 return TCL_OK;
326 }
327 }
328 } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
329 char *p;
330 if (argc != 3) {
331 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
332 " exists varName\"", (char *) NULL);
333 return TCL_ERROR;
334 }
335 p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
336
337 /*
338 * The code below handles the special case where the name is for
339 * an array: Tcl_GetVar will reject this since you can't read
340 * an array variable without an index.
341 */
342
343 if (p == NULL) {
344 Tcl_HashEntry *hPtr;
345 Var *varPtr;
346
347 if (strchr(argv[2], '(') != NULL) {
348 noVar:
349 iPtr->result = "0";
350 return TCL_OK;
351 }
352 if (iPtr->varFramePtr == NULL) {
353 hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
354 } else {
355 hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
356 }
357 if (hPtr == NULL) {
358 goto noVar;
359 }
360 varPtr = (Var *) Tcl_GetHashValue(hPtr);
361 if (varPtr->flags & VAR_UPVAR) {
362 varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
363 }
364 if (!(varPtr->flags & VAR_ARRAY)) {
365 goto noVar;
366 }
367 }
368 iPtr->result = "1";
369 return TCL_OK;
370 } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
371 char *name;
372
373 if (argc > 3) {
374 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
375 " globals [pattern]\"", (char *) NULL);
376 return TCL_ERROR;
377 }
378 for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
379 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
380 varPtr = (Var *) Tcl_GetHashValue(hPtr);
381 if (varPtr->flags & VAR_UNDEFINED) {
382 continue;
383 }
384 name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
385 if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
386 continue;
387 }
388 Tcl_AppendElement(interp, name, 0);
389 }
390 return TCL_OK;
391 } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
392 && (length >= 2)) {
393 if (argc == 2) {
394 if (iPtr->varFramePtr == NULL) {
395 iPtr->result = "0";
396 } else {
397 sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
398 }
399 return TCL_OK;
400 } else if (argc == 3) {
401 int level;
402 CallFrame *framePtr;
403
404 if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
405 return TCL_ERROR;
406 }
407 if (level <= 0) {
408 if (iPtr->varFramePtr == NULL) {
409 levelError:
410 Tcl_AppendResult(interp, "bad level \"", argv[2],
411 "\"", (char *) NULL);
412 return TCL_ERROR;
413 }
414 level += iPtr->varFramePtr->level;
415 }
416 for (framePtr = iPtr->varFramePtr; framePtr != NULL;
417 framePtr = framePtr->callerVarPtr) {
418 if (framePtr->level == level) {
419 break;
420 }
421 }
422 if (framePtr == NULL) {
423 goto levelError;
424 }
425 iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
426 iPtr->freeProc = (Tcl_FreeProc *) free;
427 return TCL_OK;
428 }
429 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
430 " level [number]\"", (char *) NULL);
431 return TCL_ERROR;
432 } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
433 && (length >= 2)) {
434 if (argc != 2) {
435 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
436 " library\"", (char *) NULL);
437 return TCL_ERROR;
438 }
439#ifdef TCL_LIBRARY
440 interp->result = TCL_Library;
441 return TCL_OK;
442#else
443 interp->result = "there is no Tcl library at this installation";
444 return TCL_ERROR;
445#endif
446 } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
447 && (length >= 2)) {
448 char *name;
449
450 if (argc > 3) {
451 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
452 " locals [pattern]\"", (char *) NULL);
453 return TCL_ERROR;
454 }
455 if (iPtr->varFramePtr == NULL) {
456 return TCL_OK;
457 }
458 for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
459 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
460 varPtr = (Var *) Tcl_GetHashValue(hPtr);
461 if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
462 continue;
463 }
464 name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
465 if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
466 continue;
467 }
468 Tcl_AppendElement(interp, name, 0);
469 }
470 return TCL_OK;
471 } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
472 if (argc > 3) {
473 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
474 " procs [pattern]\"", (char *) NULL);
475 return TCL_ERROR;
476 }
477 for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
478 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
479 char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
480
481 cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
482 if (!TclIsProc(cmdPtr)) {
483 continue;
484 }
485 if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
486 continue;
487 }
488 Tcl_AppendElement(interp, name, 0);
489 }
490 return TCL_OK;
491 } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
492 if (argc != 2) {
493 Tcl_AppendResult(interp, "wrong # args: should be \"",
494 argv[0], " script\"", (char *) NULL);
495 return TCL_ERROR;
496 }
497 if (iPtr->scriptFile != NULL) {
498 interp->result = iPtr->scriptFile;
499 }
500 return TCL_OK;
501 } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
502 if (argc != 2) {
503 Tcl_AppendResult(interp, "wrong # args: should be \"",
504 argv[0], " tclversion\"", (char *) NULL);
505 return TCL_ERROR;
506 }
507
508 /*
509 * Note: TCL_VERSION below is expected to be set with a "-D"
510 * switch in the Makefile.
511 */
512
513 strcpy(iPtr->result, TCL_VERSION);
514 return TCL_OK;
515 } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
516 Tcl_HashTable *tablePtr;
517 char *name;
518
519 if (argc > 3) {
520 Tcl_AppendResult(interp, "wrong # args: should be \"",
521 argv[0], " vars [pattern]\"", (char *) NULL);
522 return TCL_ERROR;
523 }
524 if (iPtr->varFramePtr == NULL) {
525 tablePtr = &iPtr->globalTable;
526 } else {
527 tablePtr = &iPtr->varFramePtr->varTable;
528 }
529 for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
530 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
531 varPtr = (Var *) Tcl_GetHashValue(hPtr);
532 if (varPtr->flags & VAR_UNDEFINED) {
533 continue;
534 }
535 name = Tcl_GetHashKey(tablePtr, hPtr);
536 if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
537 continue;
538 }
539 Tcl_AppendElement(interp, name, 0);
540 }
541 return TCL_OK;
542 } else {
543 Tcl_AppendResult(interp, "bad option \"", argv[1],
544 "\": should be args, body, commands, cmdcount, default, ",
545 "exists, globals, level, library, locals, procs, ",
546 "script, tclversion, or vars",
547 (char *) NULL);
548 return TCL_ERROR;
549 }
550}
551\f
552/*
553 *----------------------------------------------------------------------
554 *
555 * Tcl_JoinCmd --
556 *
557 * This procedure is invoked to process the "join" Tcl command.
558 * See the user documentation for details on what it does.
559 *
560 * Results:
561 * A standard Tcl result.
562 *
563 * Side effects:
564 * See the user documentation.
565 *
566 *----------------------------------------------------------------------
567 */
568
569 /* ARGSUSED */
570int
571Tcl_JoinCmd(dummy, interp, argc, argv)
572 ClientData dummy; /* Not used. */
573 Tcl_Interp *interp; /* Current interpreter. */
574 int argc; /* Number of arguments. */
575 char **argv; /* Argument strings. */
576{
577 char *joinString;
578 char **listArgv;
579 int listArgc, i;
580
581 if (argc == 2) {
582 joinString = " ";
583 } else if (argc == 3) {
584 joinString = argv[2];
585 } else {
586 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
587 " list ?joinString?\"", (char *) NULL);
588 return TCL_ERROR;
589 }
590
591 if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
592 return TCL_ERROR;
593 }
594 for (i = 0; i < listArgc; i++) {
595 if (i == 0) {
596 Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
597 } else {
598 Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
599 }
600 }
601 ckfree((char *) listArgv);
602 return TCL_OK;
603}
604\f
605/*
606 *----------------------------------------------------------------------
607 *
608 * Tcl_LindexCmd --
609 *
610 * This procedure is invoked to process the "lindex" Tcl command.
611 * See the user documentation for details on what it does.
612 *
613 * Results:
614 * A standard Tcl result.
615 *
616 * Side effects:
617 * See the user documentation.
618 *
619 *----------------------------------------------------------------------
620 */
621
622 /* ARGSUSED */
623int
624Tcl_LindexCmd(dummy, interp, argc, argv)
625 ClientData dummy; /* Not used. */
626 Tcl_Interp *interp; /* Current interpreter. */
627 int argc; /* Number of arguments. */
628 char **argv; /* Argument strings. */
629{
630 char *p, *element;
631 int index, size, parenthesized, result;
632
633 if (argc != 3) {
634 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
635 " list index\"", (char *) NULL);
636 return TCL_ERROR;
637 }
638 if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
639 return TCL_ERROR;
640 }
641 if (index < 0) {
642 return TCL_OK;
643 }
644 for (p = argv[1] ; index >= 0; index--) {
645 result = TclFindElement(interp, p, &element, &p, &size,
646 &parenthesized);
647 if (result != TCL_OK) {
648 return result;
649 }
650 }
651 if (size == 0) {
652 return TCL_OK;
653 }
654 if (size >= TCL_RESULT_SIZE) {
655 interp->result = (char *) ckalloc((unsigned) size+1);
656 interp->freeProc = (Tcl_FreeProc *) free;
657 }
658 if (parenthesized) {
659 memcpy((VOID *) interp->result, (VOID *) element, size);
660 interp->result[size] = 0;
661 } else {
662 TclCopyAndCollapse(size, element, interp->result);
663 }
664 return TCL_OK;
665}
666\f
667/*
668 *----------------------------------------------------------------------
669 *
670 * Tcl_LinsertCmd --
671 *
672 * This procedure is invoked to process the "linsert" Tcl command.
673 * See the user documentation for details on what it does.
674 *
675 * Results:
676 * A standard Tcl result.
677 *
678 * Side effects:
679 * See the user documentation.
680 *
681 *----------------------------------------------------------------------
682 */
683
684 /* ARGSUSED */
685int
686Tcl_LinsertCmd(dummy, interp, argc, argv)
687 ClientData dummy; /* Not used. */
688 Tcl_Interp *interp; /* Current interpreter. */
689 int argc; /* Number of arguments. */
690 char **argv; /* Argument strings. */
691{
692 char *p, *element, savedChar;
693 int i, index, count, result, size;
694
695 if (argc < 4) {
696 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
697 " list index element ?element ...?\"", (char *) NULL);
698 return TCL_ERROR;
699 }
700 if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
701 return TCL_ERROR;
702 }
703
704 /*
705 * Skip over the first "index" elements of the list, then add
706 * all of those elements to the result.
707 */
708
709 size = 0;
710 element = argv[1];
711 for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
712 result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
713 if (result != TCL_OK) {
714 return result;
715 }
716 }
717 if (*p == 0) {
718 Tcl_AppendResult(interp, argv[1], (char *) NULL);
719 } else {
720 char *end;
721
722 end = element+size;
723 if (element != argv[1]) {
724 while ((*end != 0) && !isspace(*end)) {
725 end++;
726 }
727 }
728 savedChar = *end;
729 *end = 0;
730 Tcl_AppendResult(interp, argv[1], (char *) NULL);
731 *end = savedChar;
732 }
733
734 /*
735 * Add the new list elements.
736 */
737
738 for (i = 3; i < argc; i++) {
739 Tcl_AppendElement(interp, argv[i], 0);
740 }
741
742 /*
743 * Append the remainder of the original list.
744 */
745
746 if (*p != 0) {
747 Tcl_AppendResult(interp, " ", p, (char *) NULL);
748 }
749 return TCL_OK;
750}
751\f
752/*
753 *----------------------------------------------------------------------
754 *
755 * Tcl_ListCmd --
756 *
757 * This procedure is invoked to process the "list" Tcl command.
758 * See the user documentation for details on what it does.
759 *
760 * Results:
761 * A standard Tcl result.
762 *
763 * Side effects:
764 * See the user documentation.
765 *
766 *----------------------------------------------------------------------
767 */
768
769 /* ARGSUSED */
770int
771Tcl_ListCmd(dummy, interp, argc, argv)
772 ClientData dummy; /* Not used. */
773 Tcl_Interp *interp; /* Current interpreter. */
774 int argc; /* Number of arguments. */
775 char **argv; /* Argument strings. */
776{
777 if (argc < 2) {
778 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
779 " arg ?arg ...?\"", (char *) NULL);
780 return TCL_ERROR;
781 }
782 interp->result = Tcl_Merge(argc-1, argv+1);
783 interp->freeProc = (Tcl_FreeProc *) free;
784 return TCL_OK;
785}
786\f
787/*
788 *----------------------------------------------------------------------
789 *
790 * Tcl_LlengthCmd --
791 *
792 * This procedure is invoked to process the "llength" Tcl command.
793 * See the user documentation for details on what it does.
794 *
795 * Results:
796 * A standard Tcl result.
797 *
798 * Side effects:
799 * See the user documentation.
800 *
801 *----------------------------------------------------------------------
802 */
803
804 /* ARGSUSED */
805int
806Tcl_LlengthCmd(dummy, interp, argc, argv)
807 ClientData dummy; /* Not used. */
808 Tcl_Interp *interp; /* Current interpreter. */
809 int argc; /* Number of arguments. */
810 char **argv; /* Argument strings. */
811{
812 int count, result;
813 char *element, *p;
814
815 if (argc != 2) {
816 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
817 " list\"", (char *) NULL);
818 return TCL_ERROR;
819 }
820 for (count = 0, p = argv[1]; *p != 0 ; count++) {
821 result = TclFindElement(interp, p, &element, &p, (int *) NULL,
822 (int *) NULL);
823 if (result != TCL_OK) {
824 return result;
825 }
826 if (*element == 0) {
827 break;
828 }
829 }
830 sprintf(interp->result, "%d", count);
831 return TCL_OK;
832}
833\f
834/*
835 *----------------------------------------------------------------------
836 *
837 * Tcl_LrangeCmd --
838 *
839 * This procedure is invoked to process the "lrange" Tcl command.
840 * See the user documentation for details on what it does.
841 *
842 * Results:
843 * A standard Tcl result.
844 *
845 * Side effects:
846 * See the user documentation.
847 *
848 *----------------------------------------------------------------------
849 */
850
851 /* ARGSUSED */
852int
853Tcl_LrangeCmd(notUsed, interp, argc, argv)
854 ClientData notUsed; /* Not used. */
855 Tcl_Interp *interp; /* Current interpreter. */
856 int argc; /* Number of arguments. */
857 char **argv; /* Argument strings. */
858{
859 int first, last, result;
860 char *begin, *end, c, *dummy;
861 int count;
862
863 if (argc != 4) {
864 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
865 " list first last\"", (char *) NULL);
866 return TCL_ERROR;
867 }
868 if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
869 return TCL_ERROR;
870 }
871 if (first < 0) {
872 first = 0;
873 }
874 if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
875 last = 1000000;
876 } else {
877 if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
878 Tcl_ResetResult(interp);
879 Tcl_AppendResult(interp,
880 "expected integer or \"end\" but got \"",
881 argv[3], "\"", (char *) NULL);
882 return TCL_ERROR;
883 }
884 }
885 if (first > last) {
886 return TCL_OK;
887 }
888
889 /*
890 * Extract a range of fields.
891 */
892
893 for (count = 0, begin = argv[1]; count < first; count++) {
894 result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
895 (int *) NULL);
896 if (result != TCL_OK) {
897 return result;
898 }
899 if (*begin == 0) {
900 break;
901 }
902 }
903 for (count = first, end = begin; (count <= last) && (*end != 0);
904 count++) {
905 result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
906 (int *) NULL);
907 if (result != TCL_OK) {
908 return result;
909 }
910 }
911
912 /*
913 * Chop off trailing spaces.
914 */
915
916 while (isspace(end[-1])) {
917 end--;
918 }
919 c = *end;
920 *end = 0;
921 Tcl_SetResult(interp, begin, TCL_VOLATILE);
922 *end = c;
923 return TCL_OK;
924}
925\f
926/*
927 *----------------------------------------------------------------------
928 *
929 * Tcl_LreplaceCmd --
930 *
931 * This procedure is invoked to process the "lreplace" Tcl command.
932 * See the user documentation for details on what it does.
933 *
934 * Results:
935 * A standard Tcl result.
936 *
937 * Side effects:
938 * See the user documentation.
939 *
940 *----------------------------------------------------------------------
941 */
942
943 /* ARGSUSED */
944int
945Tcl_LreplaceCmd(notUsed, interp, argc, argv)
946 ClientData notUsed; /* Not used. */
947 Tcl_Interp *interp; /* Current interpreter. */
948 int argc; /* Number of arguments. */
949 char **argv; /* Argument strings. */
950{
951 char *p1, *p2, *element, savedChar, *dummy;
952 int i, first, last, count, result, size;
953
954 if (argc < 4) {
955 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
956 " list first last ?element element ...?\"", (char *) NULL);
957 return TCL_ERROR;
958 }
959 if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
960 return TCL_ERROR;
961 }
962 if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
963 return TCL_ERROR;
964 }
965 if (first < 0) {
966 first = 0;
967 }
968 if (last < 0) {
969 last = 0;
970 }
971 if (first > last) {
972 Tcl_AppendResult(interp, "first index must not be greater than second",
973 (char *) NULL);
974 return TCL_ERROR;
975 }
976
977 /*
978 * Skip over the elements of the list before "first".
979 */
980
981 size = 0;
982 element = argv[1];
983 for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
984 result = TclFindElement(interp, p1, &element, &p1, &size,
985 (int *) NULL);
986 if (result != TCL_OK) {
987 return result;
988 }
989 }
990 if (*p1 == 0) {
991 Tcl_AppendResult(interp, "list doesn't contain element ",
992 argv[2], (char *) NULL);
993 return TCL_ERROR;
994 }
995
996 /*
997 * Skip over the elements of the list up through "last".
998 */
999
1000 for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
1001 result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
1002 (int *) NULL);
1003 if (result != TCL_OK) {
1004 return result;
1005 }
1006 }
1007
1008 /*
1009 * Add the elements before "first" to the result. Be sure to
1010 * include quote or brace characters that might terminate the
1011 * last of these elements.
1012 */
1013
1014 p1 = element+size;
1015 if (element != argv[1]) {
1016 while ((*p1 != 0) && !isspace(*p1)) {
1017 p1++;
1018 }
1019 }
1020 savedChar = *p1;
1021 *p1 = 0;
1022 Tcl_AppendResult(interp, argv[1], (char *) NULL);
1023 *p1 = savedChar;
1024
1025 /*
1026 * Add the new list elements.
1027 */
1028
1029 for (i = 4; i < argc; i++) {
1030 Tcl_AppendElement(interp, argv[i], 0);
1031 }
1032
1033 /*
1034 * Append the remainder of the original list.
1035 */
1036
1037 if (*p2 != 0) {
1038 if (*interp->result == 0) {
1039 Tcl_SetResult(interp, p2, TCL_VOLATILE);
1040 } else {
1041 Tcl_AppendResult(interp, " ", p2, (char *) NULL);
1042 }
1043 }
1044 return TCL_OK;
1045}
1046\f
1047/*
1048 *----------------------------------------------------------------------
1049 *
1050 * Tcl_LsearchCmd --
1051 *
1052 * This procedure is invoked to process the "lsearch" Tcl command.
1053 * See the user documentation for details on what it does.
1054 *
1055 * Results:
1056 * A standard Tcl result.
1057 *
1058 * Side effects:
1059 * See the user documentation.
1060 *
1061 *----------------------------------------------------------------------
1062 */
1063
1064 /* ARGSUSED */
1065int
1066Tcl_LsearchCmd(notUsed, interp, argc, argv)
1067 ClientData notUsed; /* Not used. */
1068 Tcl_Interp *interp; /* Current interpreter. */
1069 int argc; /* Number of arguments. */
1070 char **argv; /* Argument strings. */
1071{
1072 int listArgc;
1073 char **listArgv;
1074 int i, match;
1075
1076 if (argc != 3) {
1077 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1078 " list pattern\"", (char *) NULL);
1079 return TCL_ERROR;
1080 }
1081 if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
1082 return TCL_ERROR;
1083 }
1084 match = -1;
1085 for (i = 0; i < listArgc; i++) {
1086 if (Tcl_StringMatch(listArgv[i], argv[2])) {
1087 match = i;
1088 break;
1089 }
1090 }
1091 sprintf(interp->result, "%d", match);
1092 ckfree((char *) listArgv);
1093 return TCL_OK;
1094}
1095\f
1096/*
1097 *----------------------------------------------------------------------
1098 *
1099 * Tcl_LsortCmd --
1100 *
1101 * This procedure is invoked to process the "lsort" Tcl command.
1102 * See the user documentation for details on what it does.
1103 *
1104 * Results:
1105 * A standard Tcl result.
1106 *
1107 * Side effects:
1108 * See the user documentation.
1109 *
1110 *----------------------------------------------------------------------
1111 */
1112
1113 /* ARGSUSED */
1114int
1115Tcl_LsortCmd(notUsed, interp, argc, argv)
1116 ClientData notUsed; /* Not used. */
1117 Tcl_Interp *interp; /* Current interpreter. */
1118 int argc; /* Number of arguments. */
1119 char **argv; /* Argument strings. */
1120{
1121 int listArgc;
1122 char **listArgv;
1123
1124 if (argc != 2) {
1125 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1126 " list\"", (char *) NULL);
1127 return TCL_ERROR;
1128 }
1129 if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
1130 return TCL_ERROR;
1131 }
1132 qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
1133 interp->result = Tcl_Merge(listArgc, listArgv);
1134 interp->freeProc = (Tcl_FreeProc *) free;
1135 ckfree((char *) listArgv);
1136 return TCL_OK;
1137}
1138
1139/*
1140 * The procedure below is called back by qsort to determine
1141 * the proper ordering between two elements.
1142 */
1143
1144static int
1145SortCompareProc(first, second)
1146 CONST VOID *first, *second; /* Elements to be compared. */
1147{
1148 return strcmp(*((char **) first), *((char **) second));
1149}
Micropolis
Impressum, Datenschutz