Return to tclProc.c CVS log

Up to [Research Unix] / researchv10dc / cmd / worm / scsi / tcl

Annotation of researchv10dc/cmd/worm/scsi/tcl/tclProc.c, revision 1.1

1.1     ! root        1: /* 
        !             2:  * tclProc.c --
        !             3:  *
        !             4:  *     This file contains routines that implement Tcl procedures and
        !             5:  *     variables.
        !             6:  *
        !             7:  * Copyright 1987 Regents of the University of California
        !             8:  * Permission to use, copy, modify, and distribute this
        !             9:  * software and its documentation for any purpose and without
        !            10:  * fee is hereby granted, provided that the above copyright
        !            11:  * notice appear in all copies.  The University of California
        !            12:  * makes no representations about the suitability of this
        !            13:  * software for any purpose.  It is provided "as is" without
        !            14:  * express or implied warranty.
        !            15:  */
        !            16: 
        !            17: #ifndef lint
        !            18: static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclProc.c,v 1.35 90/03/29 10:55:16 ouster Exp $ SPRITE (Berkeley)";
        !            19: #pragma ref rcsid
        !            20: #endif not lint
        !            21: 
        !            22: #include <stdio.h>
        !            23: #include <stdlib.h>
        !            24: #include <string.h>
        !            25: #include <ctype.h>
        !            26: #include "tclInt.h"
        !            27: 
        !            28: /*
        !            29:  * Forward references to procedures defined later in this file:
        !            30:  */
        !            31: 
        !            32: extern Var *   FindVar();
        !            33: extern int     InterpProc();
        !            34: extern Var *   NewVar();
        !            35: extern void    ProcDeleteProc();
        !            36: 
        !            37: /*
        !            38:  *----------------------------------------------------------------------
        !            39:  *
        !            40:  * Tcl_ProcCmd --
        !            41:  *
        !            42:  *     This procedure is invoked to process the "proc" Tcl command.
        !            43:  *     See the user documentation for details on what it does.
        !            44:  *
        !            45:  * Results:
        !            46:  *     A standard Tcl result value.
        !            47:  *
        !            48:  * Side effects:
        !            49:  *     A new procedure gets created.
        !            50:  *
        !            51:  *----------------------------------------------------------------------
        !            52:  */
        !            53: 
        !            54:        /* ARGSUSED */
        !            55: int
        !            56: Tcl_ProcCmd(dummy, interp, argc, argv)
        !            57:     ClientData dummy;                  /* Not used. */
        !            58:     Tcl_Interp *interp;                        /* Current interpreter. */
        !            59:     int argc;                          /* Number of arguments. */
        !            60:     char **argv;                       /* Argument strings. */
        !            61: {
        !            62: #pragma ref dummy
        !            63:     register Interp *iPtr = (Interp *) interp;
        !            64:     register Proc *procPtr;
        !            65:     int result, argCount, i;
        !            66:     char **argArray;
        !            67: 
        !            68:     if (argc != 4) {
        !            69:        sprintf(iPtr->result,
        !            70:                "wrong # args: should be \"%.50s name args body\"",
        !            71:                argv[0]);
        !            72:        return TCL_ERROR;
        !            73:     }
        !            74: 
        !            75:     procPtr = (Proc *) malloc(sizeof(Proc));
        !            76:     procPtr->iPtr = iPtr;
        !            77:     procPtr->command = (char *) malloc((unsigned) strlen(argv[3]) + 1);
        !            78:     strcpy(procPtr->command, argv[3]);
        !            79:     procPtr->argPtr = NULL;
        !            80:     Tcl_CreateCommand(interp, argv[1], InterpProc,
        !            81:            (ClientData) procPtr, ProcDeleteProc);
        !            82: 
        !            83:     /*
        !            84:      * Break up the argument list into argument specifiers, then process
        !            85:      * each argument specifier.
        !            86:      */
        !            87: 
        !            88:     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
        !            89:     if (result != TCL_OK) {
        !            90:        return result;
        !            91:     }
        !            92:     for (i = 0; i < argCount; i++) {
        !            93:        int fieldCount, nameLength, valueLength;
        !            94:        char **fieldValues;
        !            95:        register Var *argPtr;
        !            96: 
        !            97:        /*
        !            98:         * Now divide the specifier up into name and default.
        !            99:         */
        !           100: 
        !           101:        result = Tcl_SplitList(interp, argArray[i], &fieldCount,
        !           102:                &fieldValues);
        !           103:        if (result != TCL_OK) {
        !           104:            goto procError;
        !           105:        }
        !           106:        if (fieldCount > 2) {
        !           107:            sprintf(iPtr->result,
        !           108:                    "too many fields in argument specifier \"%.50s\"",
        !           109:                    argArray[i]);
        !           110:            result = TCL_ERROR;
        !           111:            goto procError;
        !           112:        }
        !           113:        if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
        !           114:            sprintf(iPtr->result,
        !           115:                    "procedure \"%.50s\" has argument with no name", argv[1]);
        !           116:            result = TCL_ERROR;
        !           117:            goto procError;
        !           118:        }
        !           119:        nameLength = strlen(fieldValues[0]);
        !           120:        if (fieldCount == 2) {
        !           121:            valueLength = strlen(fieldValues[1]);
        !           122:        } else {
        !           123:            valueLength = 0;
        !           124:        }
        !           125:        if (procPtr->argPtr == NULL) {
        !           126:            argPtr = (Var *) malloc(VAR_SIZE(nameLength, valueLength));
        !           127:            procPtr->argPtr = argPtr;
        !           128:        } else {
        !           129:            argPtr->nextPtr = (Var *) malloc(VAR_SIZE(nameLength, valueLength));
        !           130:            argPtr = argPtr->nextPtr;
        !           131:        }
        !           132:        strcpy(argPtr->name, fieldValues[0]);
        !           133:        if (fieldCount == 2) {
        !           134:            argPtr->value = argPtr->name + nameLength + 1;
        !           135:            strcpy(argPtr->value, fieldValues[1]);
        !           136:        } else {
        !           137:            argPtr->value = NULL;
        !           138:        }
        !           139:        argPtr->valueLength = valueLength;
        !           140:        argPtr->flags = 0;
        !           141:        argPtr->nextPtr = NULL;
        !           142:        free((char *) fieldValues);
        !           143:     }
        !           144: 
        !           145:     free((char *) argArray);
        !           146:     return TCL_OK;
        !           147: 
        !           148:     procError:
        !           149:     free((char *) argArray);
        !           150:     return result;
        !           151: }
        !           152: 
        !           153: /*1
        !           154:  *----------------------------------------------------------------------
        !           155:  *
        !           156:  * Tcl_GetVar --
        !           157:  *
        !           158:  *     Return the value of a Tcl variable.
        !           159:  *
        !           160:  * Results:
        !           161:  *     The return value points to the current value of varName.  If
        !           162:  *     the variable is not defined in interp, either as a local or
        !           163:  *     global variable, then a NULL pointer is returned.  Note:  the
        !           164:  *     return value is only valid up until the next call to Tcl_SetVar;
        !           165:  *     if you depend on the value lasting longer than that, then make
        !           166:  *     yourself a private copy.
        !           167:  *
        !           168:  * Side effects:
        !           169:  *     None.
        !           170:  *
        !           171:  *----------------------------------------------------------------------
        !           172:  */
        !           173: 
        !           174: char *
        !           175: Tcl_GetVar(interp, varName, global)
        !           176:     Tcl_Interp *interp;                /* Command interpreter in which varName is
        !           177:                                 * to be looked up. */
        !           178:     char *varName;             /* Name of a variable in interp. */
        !           179:     int global;                        /* If non-zero, use only a global variable */
        !           180: {
        !           181:     Var *varPtr;
        !           182:     Interp *iPtr = (Interp *) interp;
        !           183: 
        !           184:     if (global || (iPtr->varFramePtr == NULL)) {
        !           185:        varPtr = FindVar(&iPtr->globalPtr, varName);
        !           186:     } else {
        !           187:        varPtr = FindVar(&iPtr->varFramePtr->varPtr, varName);
        !           188:     }
        !           189:     if (varPtr == NULL) {
        !           190:        return NULL;
        !           191:     }
        !           192:     if (varPtr->flags & VAR_GLOBAL) {
        !           193:        varPtr = varPtr->globalPtr;
        !           194:     }
        !           195:     if (varPtr->flags & VAR_DOESNT_EXIST) {
        !           196:        return NULL;
        !           197:     }
        !           198:     return varPtr->value;
        !           199: }
        !           200: 
        !           201: /*
        !           202:  *----------------------------------------------------------------------
        !           203:  *
        !           204:  * Tcl_SetVar --
        !           205:  *
        !           206:  *     Change the value of a variable.
        !           207:  *
        !           208:  * Results:
        !           209:  *     None.
        !           210:  *
        !           211:  * Side effects:
        !           212:  *     If varName is defined as a local or global variable in interp,
        !           213:  *     its value is changed to newValue.  If varName isn't currently
        !           214:  *     defined, then a new global variable by that name is created.
        !           215:  *
        !           216:  *----------------------------------------------------------------------
        !           217:  */
        !           218: 
        !           219: void
        !           220: Tcl_SetVar(interp, varName, newValue, global)
        !           221:     Tcl_Interp *interp;                /* Command interpreter in which varName is
        !           222:                                 * to be looked up. */
        !           223:     char *varName;             /* Name of a variable in interp. */
        !           224:     char *newValue;            /* New value for varName. */
        !           225:     int global;                        /* If non-zero, use only a global variable. */
        !           226: {
        !           227:     register Var *varPtr, **varListPtr;
        !           228:     register Interp *iPtr = (Interp *) interp;
        !           229:     int valueLength;
        !           230: 
        !           231:     if (global || (iPtr->varFramePtr == NULL)) {
        !           232:        varListPtr = &iPtr->globalPtr;
        !           233:     } else {
        !           234:        varListPtr = &iPtr->varFramePtr->varPtr;
        !           235:     }
        !           236:     varPtr = FindVar(varListPtr, varName);
        !           237:     if (varPtr == NULL) {
        !           238:        varPtr = NewVar(varName, newValue);
        !           239:        varPtr->nextPtr = *varListPtr;
        !           240:        *varListPtr = varPtr;
        !           241:     } else {
        !           242:        if (varPtr->flags & VAR_GLOBAL) {
        !           243:            varPtr = varPtr->globalPtr;
        !           244:        }
        !           245:        valueLength = strlen(newValue);
        !           246:        if (valueLength > varPtr->valueLength) {
        !           247:            if (varPtr->flags & VAR_DYNAMIC) {
        !           248:                free(varPtr->value);
        !           249:            }
        !           250:            varPtr->value = (char *) malloc((unsigned) valueLength + 1);
        !           251:            varPtr->flags |= VAR_DYNAMIC;
        !           252:            varPtr->valueLength = valueLength;
        !           253:        }
        !           254:        strcpy(varPtr->value, newValue);
        !           255:        varPtr->flags &= ~VAR_DOESNT_EXIST;
        !           256:     }
        !           257: }
        !           258: 
        !           259: /*
        !           260:  *----------------------------------------------------------------------
        !           261:  *
        !           262:  * Tcl_ParseVar --
        !           263:  *
        !           264:  *     Given a string starting with a $ sign, parse off a variable
        !           265:  *     name and return its value.
        !           266:  *
        !           267:  * Results:
        !           268:  *     The return value is the contents of the variable given by
        !           269:  *     the leading characters of string.  If termPtr isn't NULL,
        !           270:  *     *termPtr gets filled in with the address of the character
        !           271:  *     just after the last one in the variable specifier.  If the
        !           272:  *     variable doesn't exist, then the return value is NULL and
        !           273:  *     an error message will be left in interp->result.
        !           274:  *
        !           275:  * Side effects:
        !           276:  *     None.
        !           277:  *
        !           278:  *----------------------------------------------------------------------
        !           279:  */
        !           280: 
        !           281: char *
        !           282: Tcl_ParseVar(interp, string, termPtr)
        !           283:     Tcl_Interp *interp;                        /* Context for looking up variable. */
        !           284:     register char *string;             /* String containing variable name.
        !           285:                                         * First character must be "$". */
        !           286:     char **termPtr;                    /* If non-NULL, points to word to fill
        !           287:                                         * in with character just after last
        !           288:                                         * one in the variable specifier. */
        !           289: 
        !           290: {
        !           291:     char *name, c, *result;
        !           292: 
        !           293:     /*
        !           294:      * There are two cases:
        !           295:      * 1. The $ sign is followed by an open curly brace.  Then the variable
        !           296:      *    name is everything up to the next close curly brace.
        !           297:      * 2. The $ sign is not followed by an open curly brace.  Then the
        !           298:      *    variable name is everything up to the next character that isn't
        !           299:      *    a letter, digit, or underscore.
        !           300:      * 3. The $ sign is followed by something that isn't a letter, digit,
        !           301:      *    or underscore:  in this case, there is no variable name, and "$"
        !           302:      *    is returned.
        !           303:      */
        !           304: 
        !           305:     string++;
        !           306:     if (*string == '{') {
        !           307:        string++;
        !           308:        name = string;
        !           309:        while ((*string != '}') && (*string != 0)) {
        !           310:            string++;
        !           311:        }
        !           312:        if (termPtr != 0) {
        !           313:            if (*string != 0) {
        !           314:                *termPtr = string+1;
        !           315:            } else {
        !           316:                *termPtr = string;
        !           317:            }
        !           318:        }
        !           319:     } else {
        !           320:        name = string;
        !           321:        while (isalnum(*string) || (*string == '_')) {
        !           322:            string++;
        !           323:        }
        !           324:        if (termPtr != 0) {
        !           325:            *termPtr = string;
        !           326:        }
        !           327:        if (string == name) {
        !           328:            return "$";
        !           329:        }
        !           330:     }
        !           331: 
        !           332:     c = *string;
        !           333:     *string = 0;
        !           334:     result = Tcl_GetVar(interp, name, 0);
        !           335:     if (result == NULL) {
        !           336:        Tcl_Return(interp, (char *) NULL, TCL_STATIC);
        !           337:        sprintf(interp->result, "couldn't find variable \"%.50s\"", name);
        !           338:     }
        !           339:     *string = c;
        !           340:     return result;
        !           341: }
        !           342: 
        !           343: /*
        !           344:  *----------------------------------------------------------------------
        !           345:  *
        !           346:  * Tcl_SetCmd --
        !           347:  *
        !           348:  *     This procedure is invoked to process the "set" Tcl command.
        !           349:  *     See the user documentation for details on what it does.
        !           350:  *
        !           351:  * Results:
        !           352:  *     A standard Tcl result value.
        !           353:  *
        !           354:  * Side effects:
        !           355:  *     A variable's value may be changed.
        !           356:  *
        !           357:  *----------------------------------------------------------------------
        !           358:  */
        !           359: 
        !           360:        /* ARGSUSED */
        !           361: int
        !           362: Tcl_SetCmd(dummy, interp, argc, argv)
        !           363:     ClientData dummy;                  /* Not used. */
        !           364:     register Tcl_Interp *interp;       /* Current interpreter. */
        !           365:     int argc;                          /* Number of arguments. */
        !           366:     char **argv;                       /* Argument strings. */
        !           367: {
        !           368: #pragma ref dummy
        !           369:     if (argc == 2) {
        !           370:        char *value;
        !           371: 
        !           372:        value = Tcl_GetVar(interp, argv[1], 0);
        !           373:        if (value == NULL) {
        !           374:            sprintf(interp->result, "couldn't find variable \"%.50s\"",
        !           375:                    argv[1]);
        !           376:            return TCL_ERROR;
        !           377:        }
        !           378:        interp->result = value;
        !           379:        return TCL_OK;
        !           380:     } else if (argc == 3) {
        !           381:        Tcl_SetVar(interp, argv[1], argv[2], 0);
        !           382:        return TCL_OK;
        !           383:     } else {
        !           384:        sprintf(interp->result,
        !           385:                "wrong # args: should be \"%.50s varName [newValue]\"",
        !           386:                argv[0]);
        !           387:        return TCL_ERROR;
        !           388:     }
        !           389: }
        !           390: 
        !           391: /*
        !           392:  *----------------------------------------------------------------------
        !           393:  *
        !           394:  * Tcl_GlobalCmd --
        !           395:  *
        !           396:  *     This procedure is invoked to process the "global" Tcl command.
        !           397:  *     See the user documentation for details on what it does.
        !           398:  *
        !           399:  * Results:
        !           400:  *     A standard Tcl result value.
        !           401:  *
        !           402:  * Side effects:
        !           403:  *     See the user documentation.
        !           404:  *
        !           405:  *----------------------------------------------------------------------
        !           406:  */
        !           407: 
        !           408:        /* ARGSUSED */
        !           409: int
        !           410: Tcl_GlobalCmd(dummy, interp, argc, argv)
        !           411:     ClientData dummy;                  /* Not used. */
        !           412:     Tcl_Interp *interp;                        /* Current interpreter. */
        !           413:     int argc;                          /* Number of arguments. */
        !           414:     char **argv;                       /* Argument strings. */
        !           415: {
        !           416: #pragma ref dummy
        !           417:     register Var *varPtr;
        !           418:     register Interp *iPtr = (Interp *) interp;
        !           419:     Var *gVarPtr;
        !           420: 
        !           421:     if (argc < 2) {
        !           422:        sprintf(iPtr->result,
        !           423:                "too few args:  should be \"%.50s varName varName ...\"",
        !           424:                argv[0]);
        !           425:        return TCL_ERROR;
        !           426:     }
        !           427:     if (iPtr->varFramePtr == NULL) {
        !           428:        return TCL_OK;
        !           429:     }
        !           430: 
        !           431:     for (argc--, argv++; argc > 0; argc--, argv++) {
        !           432:        gVarPtr = FindVar(&iPtr->globalPtr, *argv);
        !           433:        if (gVarPtr == NULL) {
        !           434:            gVarPtr = NewVar(*argv, "");
        !           435:            gVarPtr->nextPtr = iPtr->globalPtr;
        !           436:            iPtr->globalPtr = gVarPtr;
        !           437:            gVarPtr->flags |= VAR_DOESNT_EXIST;
        !           438:        }
        !           439:        varPtr = NewVar(*argv, "");
        !           440:        varPtr->flags |= VAR_GLOBAL;
        !           441:        varPtr->globalPtr = gVarPtr;
        !           442:        varPtr->nextPtr = iPtr->varFramePtr->varPtr;
        !           443:        iPtr->varFramePtr->varPtr = varPtr;
        !           444:     }
        !           445:     return TCL_OK;
        !           446: }
        !           447: 
        !           448: /*
        !           449:  *----------------------------------------------------------------------
        !           450:  *
        !           451:  * Tcl_UplevelCmd --
        !           452:  *
        !           453:  *     This procedure is invoked to process the "uplevel" Tcl command.
        !           454:  *     See the user documentation for details on what it does.
        !           455:  *
        !           456:  * Results:
        !           457:  *     A standard Tcl result value.
        !           458:  *
        !           459:  * Side effects:
        !           460:  *     See the user documentation.
        !           461:  *
        !           462:  *----------------------------------------------------------------------
        !           463:  */
        !           464: 
        !           465:        /* ARGSUSED */
        !           466: int
        !           467: Tcl_UplevelCmd(dummy, interp, argc, argv)
        !           468:     ClientData dummy;                  /* Not used. */
        !           469:     Tcl_Interp *interp;                        /* Current interpreter. */
        !           470:     int argc;                          /* Number of arguments. */
        !           471:     char **argv;                       /* Argument strings. */
        !           472: {
        !           473: #pragma ref dummy
        !           474:     register Interp *iPtr = (Interp *) interp;
        !           475:     int level, result;
        !           476:     char *end, *levelArg;
        !           477:     CallFrame *savedVarFramePtr, *framePtr;
        !           478: 
        !           479:     if (argc < 2) {
        !           480:        uplevelSyntax:
        !           481:        sprintf(iPtr->result,
        !           482:                "too few args:  should be \"%.50s [level] command ...\"",
        !           483:                argv[0]);
        !           484:        return TCL_ERROR;
        !           485:     }
        !           486: 
        !           487:     /*
        !           488:      * Parse arguments to figure out which level to go to, and set
        !           489:      * argv and argc to refer to the command to execute at that level.
        !           490:      */
        !           491: 
        !           492:     levelArg = argv[1];
        !           493:     if (*levelArg == '#') {
        !           494:        level = strtoul(levelArg+1, &end, 10);
        !           495:        if ((end == (levelArg+1)) || (*end != '\0')) {
        !           496:            goto levelError;
        !           497:        }
        !           498:        argc -= 2;
        !           499:        argv += 2;
        !           500:     } else if (isdigit(*levelArg)) {
        !           501:        level = strtoul(levelArg, &end, 10);
        !           502:        if ((end == levelArg) || (*end != '\0')) {
        !           503:            goto levelError;
        !           504:        }
        !           505:        if (iPtr->varFramePtr == NULL) {
        !           506:            goto levelError;
        !           507:        }
        !           508:        level = iPtr->varFramePtr->level - level;
        !           509:        argc -= 2;
        !           510:        argv += 2;
        !           511:     } else {
        !           512:        if (iPtr->varFramePtr == NULL) {
        !           513:            goto levelError;
        !           514:        }
        !           515:        level = iPtr->varFramePtr->level - 1;
        !           516:        argc--;
        !           517:        argv++;
        !           518:     }
        !           519: 
        !           520:     /*
        !           521:      * Figure out which frame to use, and modify the interpreter so
        !           522:      * its variables come from that frame.
        !           523:      */
        !           524: 
        !           525:     savedVarFramePtr = iPtr->varFramePtr;
        !           526:     if (level == 0) {
        !           527:        iPtr->varFramePtr = NULL;
        !           528:     } else {
        !           529:        for (framePtr = savedVarFramePtr; framePtr != NULL;
        !           530:                framePtr = framePtr->callerVarPtr) {
        !           531:            if (framePtr->level == level) {
        !           532:                break;
        !           533:            }
        !           534:        }
        !           535:        if (framePtr == NULL) {
        !           536:            goto levelError;
        !           537:        }
        !           538:        iPtr->varFramePtr = framePtr;
        !           539:     }
        !           540: 
        !           541:     /*
        !           542:      * Execute the residual arguments as a command.
        !           543:      */
        !           544: 
        !           545:     if (argc == 0) {
        !           546:        goto uplevelSyntax;
        !           547:     }
        !           548:     if (argc == 1) {
        !           549:        result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);
        !           550:     } else {
        !           551:        char *cmd;
        !           552: 
        !           553:        cmd = Tcl_Concat(argc, argv);
        !           554:        result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
        !           555:     }
        !           556:     if (result == TCL_ERROR) {
        !           557:        char msg[60];
        !           558:        sprintf(msg, " (\"uplevel\" body line %d)", interp->errorLine);
        !           559:        Tcl_AddErrorInfo(interp, msg);
        !           560:     }
        !           561: 
        !           562:     /*
        !           563:      * Restore the variable frame, and return.
        !           564:      */
        !           565: 
        !           566:     iPtr->varFramePtr = savedVarFramePtr;
        !           567:     return result;
        !           568: 
        !           569:     levelError:
        !           570:     sprintf(iPtr->result, "bad level \"%.50s\"", levelArg);
        !           571:     return TCL_ERROR;
        !           572: }
        !           573: 
        !           574: /*
        !           575:  *----------------------------------------------------------------------
        !           576:  *
        !           577:  * TclFindProc --
        !           578:  *
        !           579:  *     Given the name of a procedure, return a pointer to the
        !           580:  *     record describing the procedure.
        !           581:  *
        !           582:  * Results:
        !           583:  *     NULL is returned if the name doesn't correspond to any
        !           584:  *     procedure.  Otherwise the return value is a pointer to
        !           585:  *     the procedure's record.
        !           586:  *
        !           587:  * Side effects:
        !           588:  *     None.
        !           589:  *
        !           590:  *----------------------------------------------------------------------
        !           591:  */
        !           592: 
        !           593: Proc *
        !           594: TclFindProc(iPtr, procName)
        !           595:     Interp *iPtr;              /* Interpreter in which to look. */
        !           596:     char *procName;            /* Name of desired procedure. */
        !           597: {
        !           598:     Command *cmdPtr;
        !           599: 
        !           600:     cmdPtr = TclFindCmd(iPtr, procName, 0);
        !           601:     if (cmdPtr == NULL) {
        !           602:        return NULL;
        !           603:     }
        !           604:     if (cmdPtr->proc != InterpProc) {
        !           605:        return NULL;
        !           606:     }
        !           607:     return (Proc *) cmdPtr->clientData;
        !           608: }
        !           609: 
        !           610: /*
        !           611:  *----------------------------------------------------------------------
        !           612:  *
        !           613:  * TclIsProc --
        !           614:  *
        !           615:  *     Tells whether a command is a Tcl procedure or not.
        !           616:  *
        !           617:  * Results:
        !           618:  *     If the given command is actuall a Tcl procedure, the
        !           619:  *     return value is the address of the record describing
        !           620:  *     the procedure.  Otherwise the return value is 0.
        !           621:  *
        !           622:  * Side effects:
        !           623:  *     None.
        !           624:  *
        !           625:  *----------------------------------------------------------------------
        !           626:  */
        !           627: 
        !           628: Proc *
        !           629: TclIsProc(cmdPtr)
        !           630:     Command *cmdPtr;           /* Command to test. */
        !           631: {
        !           632:     if (cmdPtr->proc == InterpProc) {
        !           633:        return (Proc *) cmdPtr->clientData;
        !           634:     }
        !           635:     return (Proc *) 0;
        !           636: }
        !           637: 
        !           638: /*
        !           639:  *----------------------------------------------------------------------
        !           640:  *
        !           641:  * TclDeleteVars --
        !           642:  *
        !           643:  *     This procedure is called as part of deleting an interpreter:
        !           644:  *     it recycles all the storage space associated with global
        !           645:  *     variables (the local ones should already have been deleted).
        !           646:  *
        !           647:  * Results:
        !           648:  *     None.
        !           649:  *
        !           650:  * Side effects:
        !           651:  *     Variables are deleted.
        !           652:  *
        !           653:  *----------------------------------------------------------------------
        !           654:  */
        !           655: 
        !           656: void
        !           657: TclDeleteVars(iPtr)
        !           658:     Interp *iPtr;              /* Interpreter to nuke. */
        !           659: {
        !           660:     register Var *varPtr;
        !           661: 
        !           662:     for (varPtr = iPtr->globalPtr; varPtr != NULL; varPtr = varPtr->nextPtr) {
        !           663:        if (varPtr->flags & VAR_DYNAMIC) {
        !           664:            free(varPtr->value);
        !           665:        }
        !           666:        free((char *) varPtr);
        !           667:     }
        !           668: }
        !           669: 
        !           670: /*
        !           671:  *----------------------------------------------------------------------
        !           672:  *
        !           673:  * InterpProc --
        !           674:  *
        !           675:  *     When a Tcl procedure gets invoked, this routine gets invoked
        !           676:  *     to interpret the procedure.
        !           677:  *
        !           678:  * Results:
        !           679:  *     A standard Tcl result value, usually TCL_OK.
        !           680:  *
        !           681:  * Side effects:
        !           682:  *     Depends on the commands in the procedure.
        !           683:  *
        !           684:  *----------------------------------------------------------------------
        !           685:  */
        !           686: 
        !           687: int
        !           688: InterpProc(procPtr, interp, argc, argv)
        !           689:     register Proc *procPtr;    /* Record describing procedure to be
        !           690:                                 * interpreted. */
        !           691:     Tcl_Interp *interp;                /* Interpreter in which procedure was
        !           692:                                 * invoked. */
        !           693:     int argc;                  /* Count of number of arguments to this
        !           694:                                 * procedure. */
        !           695:     char **argv;               /* Argument values. */
        !           696: {
        !           697:     char **args;
        !           698:     register Var *formalPtr, *argPtr;
        !           699:     register Interp *iPtr = (Interp *) interp;
        !           700:     CallFrame frame;
        !           701:     char *value, *end;
        !           702:     int result;
        !           703: 
        !           704:     /*
        !           705:      * Set up a call frame for the new procedure invocation.
        !           706:      */
        !           707: 
        !           708:     iPtr = procPtr->iPtr;
        !           709:     frame.varPtr = NULL;
        !           710:     if (iPtr->varFramePtr != NULL) {
        !           711:        frame.level = iPtr->varFramePtr->level + 1;
        !           712:     } else {
        !           713:        frame.level = 1;
        !           714:     }
        !           715:     frame.argc = argc;
        !           716:     frame.argv = argv;
        !           717:     frame.callerPtr = iPtr->framePtr;
        !           718:     frame.callerVarPtr = iPtr->varFramePtr;
        !           719:     iPtr->framePtr = &frame;
        !           720:     iPtr->varFramePtr = &frame;
        !           721: 
        !           722:     /*
        !           723:      * Match the actual arguments against the procedure's formal
        !           724:      * parameters to compute local variables.
        !           725:      */
        !           726: 
        !           727:     for (formalPtr = procPtr->argPtr, args = argv+1, argc -= 1;
        !           728:            formalPtr != NULL;
        !           729:            formalPtr = formalPtr->nextPtr, args++, argc--) {
        !           730: 
        !           731:        /*
        !           732:         * Handle the special case of the last formal being "args".  When
        !           733:         * it occurs, assign it a list consisting of all the remaining
        !           734:         * actual arguments.
        !           735:         */
        !           736: 
        !           737:        if ((formalPtr->nextPtr == NULL)
        !           738:                && (strcmp(formalPtr->name, "args") == 0)) {
        !           739:            if (argc < 0) {
        !           740:                argc = 0;
        !           741:            }
        !           742:            value = Tcl_Merge(argc, args);
        !           743:            argPtr = NewVar(formalPtr->name, value);
        !           744:            free(value);
        !           745:            argPtr->nextPtr = frame.varPtr;
        !           746:            frame.varPtr = argPtr;
        !           747:            argc = 0;
        !           748:            break;
        !           749:        } else if (argc > 0) {
        !           750:            value = *args;
        !           751:        } else if (formalPtr->value != NULL) {
        !           752:            value = formalPtr->value;
        !           753:        } else {
        !           754:            sprintf(iPtr->result,
        !           755:                    "no value given for parameter \"%s\" to \"%s\"",
        !           756:                    formalPtr->name, argv[0]);
        !           757:            result = TCL_ERROR;
        !           758:            goto procDone;
        !           759:        }
        !           760:        argPtr = NewVar(formalPtr->name, value);
        !           761:        argPtr->nextPtr = frame.varPtr;
        !           762:        frame.varPtr = argPtr;
        !           763:     }
        !           764:     if (argc > 0) {
        !           765:        sprintf(iPtr->result, "called \"%s\" with too many arguments",
        !           766:                argv[0]);
        !           767:        result = TCL_ERROR;
        !           768:        goto procDone;
        !           769:     }
        !           770: 
        !           771:     /*
        !           772:      * Invoke the commands in the procedure's body.
        !           773:      */
        !           774: 
        !           775:     result = Tcl_Eval(interp, procPtr->command, 0, &end);
        !           776:     if (result == TCL_RETURN) {
        !           777:        result = TCL_OK;
        !           778:     } else if (result == TCL_ERROR) {
        !           779:        char msg[100];
        !           780: 
        !           781:        /*
        !           782:         * Record information telling where the error occurred.
        !           783:         */
        !           784: 
        !           785:        sprintf(msg, " (procedure \"%.50s\" line %d)", argv[0],
        !           786:                iPtr->errorLine);
        !           787:        Tcl_AddErrorInfo(interp, msg);
        !           788:     } else if (result == TCL_BREAK) {
        !           789:        iPtr->result = "invoked \"break\" outside of a loop";
        !           790:        result = TCL_ERROR;
        !           791:     } else if (result == TCL_CONTINUE) {
        !           792:        iPtr->result = "invoked \"continue\" outside of a loop";
        !           793:        result = TCL_ERROR;
        !           794:     }
        !           795: 
        !           796:     /*
        !           797:      * Delete the call frame for this procedure invocation.
        !           798:      */
        !           799: 
        !           800:     procDone:
        !           801:     for (argPtr = frame.varPtr; argPtr != NULL; argPtr = argPtr->nextPtr) {
        !           802:        if (argPtr->flags & VAR_DYNAMIC) {
        !           803:            free(argPtr->value);
        !           804:        }
        !           805:        free((char *) argPtr);
        !           806:     }
        !           807:     iPtr->framePtr = frame.callerPtr;
        !           808:     iPtr->varFramePtr = frame.callerVarPtr;
        !           809:     return result;
        !           810: }
        !           811: 
        !           812: /*
        !           813:  *----------------------------------------------------------------------
        !           814:  *
        !           815:  * ProcDeleteProc --
        !           816:  *
        !           817:  *     This procedure is invoked just before a command procedure is
        !           818:  *     removed from an interpreter.  Its job is to release all the
        !           819:  *     resources allocated to the procedure.
        !           820:  *
        !           821:  * Results:
        !           822:  *     None.
        !           823:  *
        !           824:  * Side effects:
        !           825:  *     Memory gets freed.
        !           826:  *
        !           827:  *----------------------------------------------------------------------
        !           828:  */
        !           829: 
        !           830: void
        !           831: ProcDeleteProc(procPtr)
        !           832:     register Proc *procPtr;            /* Procedure to be deleted. */
        !           833: {
        !           834:     register Var *argPtr;
        !           835: 
        !           836:     free((char *) procPtr->command);
        !           837:     for (argPtr = procPtr->argPtr; argPtr != NULL; argPtr = argPtr->nextPtr) {
        !           838:        if (argPtr->flags & VAR_DYNAMIC) {
        !           839:            free(argPtr->value);
        !           840:        }
        !           841:        free((char *) argPtr);
        !           842:     }
        !           843:     free((char *) procPtr);
        !           844: }
        !           845: 
        !           846: /*
        !           847:  *----------------------------------------------------------------------
        !           848:  *
        !           849:  * FindVar --
        !           850:  *
        !           851:  *     Locate the Var structure corresponding to varName, if there
        !           852:  *     is one defined in a given list.
        !           853:  *
        !           854:  * Results:
        !           855:  *     The return value points to the Var structure corresponding to
        !           856:  *     the current value of varName in varListPtr, or NULL if varName
        !           857:  *     isn't currently defined in the list.
        !           858:  *
        !           859:  * Side effects:
        !           860:  *     If the variable is found, it is moved to the front of the list.
        !           861:  *
        !           862:  *----------------------------------------------------------------------
        !           863:  */
        !           864: 
        !           865: Var *
        !           866: FindVar(varListPtr, varName)
        !           867:     Var **varListPtr;          /* Pointer to head of list.  The value pointed
        !           868:                                 * to will be modified to bring the found
        !           869:                                 * variable to the front of the list. */
        !           870:     char *varName;             /* Desired variable. */
        !           871: {
        !           872:     register Var *prev, *cur;
        !           873:     register char c;
        !           874: 
        !           875:     c = *varName;
        !           876: 
        !           877:     /*
        !           878:      * Local variables take precedence over global ones.  Check the
        !           879:      * first character immediately, before wasting time calling strcmp.
        !           880:      */
        !           881: 
        !           882:     for (prev = NULL, cur = *varListPtr; cur != NULL;
        !           883:            prev = cur, cur = cur->nextPtr) {
        !           884:        if ((cur->name[0] == c) && (strcmp(cur->name, varName) == 0)) {
        !           885:            if (prev != NULL) {
        !           886:                prev->nextPtr = cur->nextPtr;
        !           887:                cur->nextPtr = *varListPtr;
        !           888:                *varListPtr = cur;
        !           889:            }
        !           890:            return cur;
        !           891:        }
        !           892:     }
        !           893:     return NULL;
        !           894: }
        !           895: 
        !           896: /*
        !           897:  *----------------------------------------------------------------------
        !           898:  *
        !           899:  * NewVar --
        !           900:  *
        !           901:  *     Create a new variable with the given name and initial value.
        !           902:  *
        !           903:  * Results:
        !           904:  *     The return value is a pointer to the new variable.  The variable
        !           905:  *     will not have been linked into any particular list, and its
        !           906:  *     nextPtr field will be NULL.
        !           907:  *
        !           908:  * Side effects:
        !           909:  *     Storage gets allocated.
        !           910:  *
        !           911:  *----------------------------------------------------------------------
        !           912:  */
        !           913: 
        !           914: Var *
        !           915: NewVar(name, value)
        !           916:     char *name;                        /* Name for variable. */
        !           917:     char *value;               /* Value for variable. */
        !           918: {
        !           919:     register Var *varPtr;
        !           920:     int nameLength, valueLength;
        !           921: 
        !           922:     nameLength = strlen(name);
        !           923:     valueLength = strlen(value);
        !           924:     if (valueLength < 20) {
        !           925:        valueLength = 20;
        !           926:     }
        !           927:     varPtr = (Var *) malloc(VAR_SIZE(nameLength, valueLength));
        !           928:     strcpy(varPtr->name, name);
        !           929:     varPtr->value = varPtr->name + nameLength + 1;
        !           930:     strcpy(varPtr->value, value);
        !           931:     varPtr->valueLength = valueLength;
        !           932:     varPtr->flags = 0;
        !           933:     varPtr->globalPtr = NULL;
        !           934:     varPtr->nextPtr = NULL;
        !           935:     return varPtr;
        !           936: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.