Return to tclproc.c CVS log

Up to [Micropolis - Activity] / micropolis / src / tcl

Annotation of micropolis/src/tcl/tclproc.c, revision 1.1

1.1     ! root        1: /* 
        !             2:  * tclProc.c --
        !             3:  *
        !             4:  *     This file contains routines that implement Tcl procedures,
        !             5:  *     including the "proc" and "uplevel" commands.
        !             6:  *
        !             7:  * Copyright 1987-1991 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.59 91/09/30 16:59:54 ouster Exp $ SPRITE (Berkeley)";
        !            19: #endif
        !            20: 
        !            21: #include "tclint.h"
        !            22: 
        !            23: /*
        !            24:  * Forward references to procedures defined later in this file:
        !            25:  */
        !            26: 
        !            27: static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
        !            28:                    Tcl_Interp *interp, int argc, char **argv));
        !            29: static  void   ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
        !            30: 
        !            31: /*
        !            32:  *----------------------------------------------------------------------
        !            33:  *
        !            34:  * Tcl_ProcCmd --
        !            35:  *
        !            36:  *     This procedure is invoked to process the "proc" Tcl command.
        !            37:  *     See the user documentation for details on what it does.
        !            38:  *
        !            39:  * Results:
        !            40:  *     A standard Tcl result value.
        !            41:  *
        !            42:  * Side effects:
        !            43:  *     A new procedure gets created.
        !            44:  *
        !            45:  *----------------------------------------------------------------------
        !            46:  */
        !            47: 
        !            48:        /* ARGSUSED */
        !            49: int
        !            50: Tcl_ProcCmd(dummy, interp, argc, argv)
        !            51:     ClientData dummy;                  /* Not used. */
        !            52:     Tcl_Interp *interp;                        /* Current interpreter. */
        !            53:     int argc;                          /* Number of arguments. */
        !            54:     char **argv;                       /* Argument strings. */
        !            55: {
        !            56:     register Interp *iPtr = (Interp *) interp;
        !            57:     register Proc *procPtr;
        !            58:     int result, argCount, i;
        !            59:     char **argArray = NULL;
        !            60:     Arg *lastArgPtr;
        !            61:     register Arg *argPtr = NULL;       /* Initialization not needed, but
        !            62:                                         * prevents compiler warning. */
        !            63: 
        !            64:     if (argc != 4) {
        !            65:        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
        !            66:                " name args body\"", (char *) NULL);
        !            67:        return TCL_ERROR;
        !            68:     }
        !            69: 
        !            70:     procPtr = (Proc *) ckalloc(sizeof(Proc));
        !            71:     procPtr->iPtr = iPtr;
        !            72:     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
        !            73:     strcpy(procPtr->command, argv[3]);
        !            74:     procPtr->argPtr = NULL;
        !            75: 
        !            76:     /*
        !            77:      * Break up the argument list into argument specifiers, then process
        !            78:      * each argument specifier.
        !            79:      */
        !            80: 
        !            81:     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
        !            82:     if (result != TCL_OK) {
        !            83:        goto procError;
        !            84:     }
        !            85:     lastArgPtr = NULL;
        !            86:     for (i = 0; i < argCount; i++) {
        !            87:        int fieldCount, nameLength, valueLength;
        !            88:        char **fieldValues;
        !            89: 
        !            90:        /*
        !            91:         * Now divide the specifier up into name and default.
        !            92:         */
        !            93: 
        !            94:        result = Tcl_SplitList(interp, argArray[i], &fieldCount,
        !            95:                &fieldValues);
        !            96:        if (result != TCL_OK) {
        !            97:            goto procError;
        !            98:        }
        !            99:        if (fieldCount > 2) {
        !           100:            ckfree((char *) fieldValues);
        !           101:            Tcl_AppendResult(interp,
        !           102:                    "too many fields in argument specifier \"",
        !           103:                    argArray[i], "\"", (char *) NULL);
        !           104:            result = TCL_ERROR;
        !           105:            goto procError;
        !           106:        }
        !           107:        if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
        !           108:            ckfree((char *) fieldValues);
        !           109:            Tcl_AppendResult(interp, "procedure \"", argv[1],
        !           110:                    "\" has argument with no name", (char *) NULL);
        !           111:            result = TCL_ERROR;
        !           112:            goto procError;
        !           113:        }
        !           114:        nameLength = strlen(fieldValues[0]) + 1;
        !           115:        if (fieldCount == 2) {
        !           116:            valueLength = strlen(fieldValues[1]) + 1;
        !           117:        } else {
        !           118:            valueLength = 0;
        !           119:        }
        !           120:        argPtr = (Arg *) ckalloc((unsigned)
        !           121:                (sizeof(Arg) - sizeof(argPtr->name) + nameLength
        !           122:                + valueLength));
        !           123:        if (lastArgPtr == NULL) {
        !           124:            procPtr->argPtr = argPtr;
        !           125:        } else {
        !           126:            lastArgPtr->nextPtr = argPtr;
        !           127:        }
        !           128:        lastArgPtr = argPtr;
        !           129:        argPtr->nextPtr = NULL;
        !           130:        strcpy(argPtr->name, fieldValues[0]);
        !           131:        if (fieldCount == 2) {
        !           132:            argPtr->defValue = argPtr->name + nameLength;
        !           133:            strcpy(argPtr->defValue, fieldValues[1]);
        !           134:        } else {
        !           135:            argPtr->defValue = NULL;
        !           136:        }
        !           137:        ckfree((char *) fieldValues);
        !           138:     }
        !           139: 
        !           140:     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
        !           141:            ProcDeleteProc);
        !           142:     ckfree((char *) argArray);
        !           143:     return TCL_OK;
        !           144: 
        !           145:     procError:
        !           146:     ckfree(procPtr->command);
        !           147:     while (procPtr->argPtr != NULL) {
        !           148:        argPtr = procPtr->argPtr;
        !           149:        procPtr->argPtr = argPtr->nextPtr;
        !           150:        ckfree((char *) argPtr);
        !           151:     }
        !           152:     ckfree((char *) procPtr);
        !           153:     if (argArray != NULL) {
        !           154:        ckfree((char *) argArray);
        !           155:     }
        !           156:     return result;
        !           157: }
        !           158: 
        !           159: /*
        !           160:  *----------------------------------------------------------------------
        !           161:  *
        !           162:  * TclGetFrame --
        !           163:  *
        !           164:  *     Given a description of a procedure frame, such as the first
        !           165:  *     argument to an "uplevel" or "upvar" command, locate the
        !           166:  *     call frame for the appropriate level of procedure.
        !           167:  *
        !           168:  * Results:
        !           169:  *     The return value is -1 if an error occurred in finding the
        !           170:  *     frame (in this case an error message is left in interp->result).
        !           171:  *     1 is returned if string was either a number or a number preceded
        !           172:  *     by "#" and it specified a valid frame.  0 is returned if string
        !           173:  *     isn't one of the two things above (in this case, the lookup
        !           174:  *     acts as if string were "1").  The variable pointed to by
        !           175:  *     framePtrPtr is filled in with the address of the desired frame
        !           176:  *     (unless an error occurs, in which case it isn't modified).
        !           177:  *
        !           178:  * Side effects:
        !           179:  *     None.
        !           180:  *
        !           181:  *----------------------------------------------------------------------
        !           182:  */
        !           183: 
        !           184: int
        !           185: TclGetFrame(interp, string, framePtrPtr)
        !           186:     Tcl_Interp *interp;                /* Interpreter in which to find frame. */
        !           187:     char *string;              /* String describing frame. */
        !           188:     CallFrame **framePtrPtr;   /* Store pointer to frame here (or NULL
        !           189:                                 * if global frame indicated). */
        !           190: {
        !           191:     register Interp *iPtr = (Interp *) interp;
        !           192:     int level, result;
        !           193:     CallFrame *framePtr;
        !           194: 
        !           195:     if (iPtr->varFramePtr == NULL) {
        !           196:        iPtr->result = "already at top level";
        !           197:        return -1;
        !           198:     }
        !           199: 
        !           200:     /*
        !           201:      * Parse string to figure out which level number to go to.
        !           202:      */
        !           203: 
        !           204:     result = 1;
        !           205:     if (*string == '#') {
        !           206:        if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
        !           207:            return -1;
        !           208:        }
        !           209:        if (level < 0) {
        !           210:            levelError:
        !           211:            Tcl_AppendResult(interp, "bad level \"", string, "\"",
        !           212:                    (char *) NULL);
        !           213:            return -1;
        !           214:        }
        !           215:     } else if (isdigit(*string)) {
        !           216:        if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
        !           217:            return -1;
        !           218:        }
        !           219:        level = iPtr->varFramePtr->level - level;
        !           220:     } else {
        !           221:        level = iPtr->varFramePtr->level - 1;
        !           222:        result = 0;
        !           223:     }
        !           224: 
        !           225:     /*
        !           226:      * Figure out which frame to use, and modify the interpreter so
        !           227:      * its variables come from that frame.
        !           228:      */
        !           229: 
        !           230:     if (level == 0) {
        !           231:        framePtr = NULL;
        !           232:     } else {
        !           233:        for (framePtr = iPtr->varFramePtr; framePtr != NULL;
        !           234:                framePtr = framePtr->callerVarPtr) {
        !           235:            if (framePtr->level == level) {
        !           236:                break;
        !           237:            }
        !           238:        }
        !           239:        if (framePtr == NULL) {
        !           240:            goto levelError;
        !           241:        }
        !           242:     }
        !           243:     *framePtrPtr = framePtr;
        !           244:     return result;
        !           245: }
        !           246: 
        !           247: /*
        !           248:  *----------------------------------------------------------------------
        !           249:  *
        !           250:  * Tcl_UplevelCmd --
        !           251:  *
        !           252:  *     This procedure is invoked to process the "uplevel" Tcl command.
        !           253:  *     See the user documentation for details on what it does.
        !           254:  *
        !           255:  * Results:
        !           256:  *     A standard Tcl result value.
        !           257:  *
        !           258:  * Side effects:
        !           259:  *     See the user documentation.
        !           260:  *
        !           261:  *----------------------------------------------------------------------
        !           262:  */
        !           263: 
        !           264:        /* ARGSUSED */
        !           265: int
        !           266: Tcl_UplevelCmd(dummy, interp, argc, argv)
        !           267:     ClientData dummy;                  /* Not used. */
        !           268:     Tcl_Interp *interp;                        /* Current interpreter. */
        !           269:     int argc;                          /* Number of arguments. */
        !           270:     char **argv;                       /* Argument strings. */
        !           271: {
        !           272:     register Interp *iPtr = (Interp *) interp;
        !           273:     int result;
        !           274:     CallFrame *savedVarFramePtr, *framePtr;
        !           275: 
        !           276:     if (argc < 2) {
        !           277:        uplevelSyntax:
        !           278:        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
        !           279:                " ?level? command ?command ...?\"", (char *) NULL);
        !           280:        return TCL_ERROR;
        !           281:     }
        !           282: 
        !           283:     /*
        !           284:      * Find the level to use for executing the command.
        !           285:      */
        !           286: 
        !           287:     result = TclGetFrame(interp, argv[1], &framePtr);
        !           288:     if (result == -1) {
        !           289:        return TCL_ERROR;
        !           290:     }
        !           291:     argc -= (result+1);
        !           292:     argv += (result+1);
        !           293: 
        !           294:     /*
        !           295:      * Modify the interpreter state to execute in the given frame.
        !           296:      */
        !           297: 
        !           298:     savedVarFramePtr = iPtr->varFramePtr;
        !           299:     iPtr->varFramePtr = framePtr;
        !           300: 
        !           301:     /*
        !           302:      * Execute the residual arguments as a command.
        !           303:      */
        !           304: 
        !           305:     if (argc == 0) {
        !           306:        goto uplevelSyntax;
        !           307:     }
        !           308:     if (argc == 1) {
        !           309:        result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);
        !           310:     } else {
        !           311:        char *cmd;
        !           312: 
        !           313:        cmd = Tcl_Concat(argc, argv);
        !           314:        result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
        !           315:        ckfree(cmd);
        !           316:     }
        !           317:     if (result == TCL_ERROR) {
        !           318:        char msg[60];
        !           319:        sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
        !           320:        Tcl_AddErrorInfo(interp, msg);
        !           321:     }
        !           322: 
        !           323:     /*
        !           324:      * Restore the variable frame, and return.
        !           325:      */
        !           326: 
        !           327:     iPtr->varFramePtr = savedVarFramePtr;
        !           328:     return result;
        !           329: }
        !           330: 
        !           331: /*
        !           332:  *----------------------------------------------------------------------
        !           333:  *
        !           334:  * TclFindProc --
        !           335:  *
        !           336:  *     Given the name of a procedure, return a pointer to the
        !           337:  *     record describing the procedure.
        !           338:  *
        !           339:  * Results:
        !           340:  *     NULL is returned if the name doesn't correspond to any
        !           341:  *     procedure.  Otherwise the return value is a pointer to
        !           342:  *     the procedure's record.
        !           343:  *
        !           344:  * Side effects:
        !           345:  *     None.
        !           346:  *
        !           347:  *----------------------------------------------------------------------
        !           348:  */
        !           349: 
        !           350: Proc *
        !           351: TclFindProc(iPtr, procName)
        !           352:     Interp *iPtr;              /* Interpreter in which to look. */
        !           353:     char *procName;            /* Name of desired procedure. */
        !           354: {
        !           355:     Tcl_HashEntry *hPtr;
        !           356:     Command *cmdPtr;
        !           357: 
        !           358:     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
        !           359:     if (hPtr == NULL) {
        !           360:        return NULL;
        !           361:     }
        !           362:     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
        !           363:     if (cmdPtr->proc != InterpProc) {
        !           364:        return NULL;
        !           365:     }
        !           366:     return (Proc *) cmdPtr->clientData;
        !           367: }
        !           368: 
        !           369: /*
        !           370:  *----------------------------------------------------------------------
        !           371:  *
        !           372:  * TclIsProc --
        !           373:  *
        !           374:  *     Tells whether a command is a Tcl procedure or not.
        !           375:  *
        !           376:  * Results:
        !           377:  *     If the given command is actuall a Tcl procedure, the
        !           378:  *     return value is the address of the record describing
        !           379:  *     the procedure.  Otherwise the return value is 0.
        !           380:  *
        !           381:  * Side effects:
        !           382:  *     None.
        !           383:  *
        !           384:  *----------------------------------------------------------------------
        !           385:  */
        !           386: 
        !           387: Proc *
        !           388: TclIsProc(cmdPtr)
        !           389:     Command *cmdPtr;           /* Command to test. */
        !           390: {
        !           391:     if (cmdPtr->proc == InterpProc) {
        !           392:        return (Proc *) cmdPtr->clientData;
        !           393:     }
        !           394:     return (Proc *) 0;
        !           395: }
        !           396: 
        !           397: /*
        !           398:  *----------------------------------------------------------------------
        !           399:  *
        !           400:  * InterpProc --
        !           401:  *
        !           402:  *     When a Tcl procedure gets invoked, this routine gets invoked
        !           403:  *     to interpret the procedure.
        !           404:  *
        !           405:  * Results:
        !           406:  *     A standard Tcl result value, usually TCL_OK.
        !           407:  *
        !           408:  * Side effects:
        !           409:  *     Depends on the commands in the procedure.
        !           410:  *
        !           411:  *----------------------------------------------------------------------
        !           412:  */
        !           413: 
        !           414: static int
        !           415: InterpProc(clientData, interp, argc, argv)
        !           416:     ClientData clientData;     /* Record describing procedure to be
        !           417:                                 * interpreted. */
        !           418:     Tcl_Interp *interp;                /* Interpreter in which procedure was
        !           419:                                 * invoked. */
        !           420:     int argc;                  /* Count of number of arguments to this
        !           421:                                 * procedure. */
        !           422:     char **argv;               /* Argument values. */
        !           423: {
        !           424:     register Proc *procPtr = (Proc *) clientData;
        !           425:     register Arg *argPtr;
        !           426:     register Interp *iPtr = (Interp *) interp;
        !           427:     char **args;
        !           428:     CallFrame frame;
        !           429:     char *value, *end;
        !           430:     int result;
        !           431: 
        !           432:     /*
        !           433:      * Set up a call frame for the new procedure invocation.
        !           434:      */
        !           435: 
        !           436:     iPtr = procPtr->iPtr;
        !           437:     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
        !           438:     if (iPtr->varFramePtr != NULL) {
        !           439:        frame.level = iPtr->varFramePtr->level + 1;
        !           440:     } else {
        !           441:        frame.level = 1;
        !           442:     }
        !           443:     frame.argc = argc;
        !           444:     frame.argv = argv;
        !           445:     frame.callerPtr = iPtr->framePtr;
        !           446:     frame.callerVarPtr = iPtr->varFramePtr;
        !           447:     iPtr->framePtr = &frame;
        !           448:     iPtr->varFramePtr = &frame;
        !           449: 
        !           450:     /*
        !           451:      * Match the actual arguments against the procedure's formal
        !           452:      * parameters to compute local variables.
        !           453:      */
        !           454: 
        !           455:     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
        !           456:            argPtr != NULL;
        !           457:            argPtr = argPtr->nextPtr, args++, argc--) {
        !           458: 
        !           459:        /*
        !           460:         * Handle the special case of the last formal being "args".  When
        !           461:         * it occurs, assign it a list consisting of all the remaining
        !           462:         * actual arguments.
        !           463:         */
        !           464: 
        !           465:        if ((argPtr->nextPtr == NULL)
        !           466:                && (strcmp(argPtr->name, "args") == 0)) {
        !           467:            if (argc < 0) {
        !           468:                argc = 0;
        !           469:            }
        !           470:            value = Tcl_Merge(argc, args);
        !           471:            Tcl_SetVar(interp, argPtr->name, value, 0);
        !           472:            ckfree(value);
        !           473:            argc = 0;
        !           474:            break;
        !           475:        } else if (argc > 0) {
        !           476:            value = *args;
        !           477:        } else if (argPtr->defValue != NULL) {
        !           478:            value = argPtr->defValue;
        !           479:        } else {
        !           480:            Tcl_AppendResult(interp, "no value given for parameter \"",
        !           481:                    argPtr->name, "\" to \"", argv[0], "\"",
        !           482:                    (char *) NULL);
        !           483:            result = TCL_ERROR;
        !           484:            goto procDone;
        !           485:        }
        !           486:        Tcl_SetVar(interp, argPtr->name, value, 0);
        !           487:     }
        !           488:     if (argc > 0) {
        !           489:        Tcl_AppendResult(interp, "called \"", argv[0],
        !           490:                "\" with too many arguments", (char *) NULL);
        !           491:        result = TCL_ERROR;
        !           492:        goto procDone;
        !           493:     }
        !           494: 
        !           495:     /*
        !           496:      * Invoke the commands in the procedure's body.
        !           497:      */
        !           498: 
        !           499:     result = Tcl_Eval(interp, procPtr->command, 0, &end);
        !           500:     if (result == TCL_RETURN) {
        !           501:        result = TCL_OK;
        !           502:     } else if (result == TCL_ERROR) {
        !           503:        char msg[100];
        !           504: 
        !           505:        /*
        !           506:         * Record information telling where the error occurred.
        !           507:         */
        !           508: 
        !           509:        sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
        !           510:                iPtr->errorLine);
        !           511:        Tcl_AddErrorInfo(interp, msg);
        !           512:     } else if (result == TCL_BREAK) {
        !           513:        iPtr->result = "invoked \"break\" outside of a loop";
        !           514:        result = TCL_ERROR;
        !           515:     } else if (result == TCL_CONTINUE) {
        !           516:        iPtr->result = "invoked \"continue\" outside of a loop";
        !           517:        result = TCL_ERROR;
        !           518:     }
        !           519: 
        !           520:     /*
        !           521:      * Delete the call frame for this procedure invocation (it's
        !           522:      * important to remove the call frame from the interpreter
        !           523:      * before deleting it, so that traces invoked during the
        !           524:      * deletion don't see the partially-deleted frame).
        !           525:      */
        !           526: 
        !           527:     procDone:
        !           528:     iPtr->framePtr = frame.callerPtr;
        !           529:     iPtr->varFramePtr = frame.callerVarPtr;
        !           530:     TclDeleteVars(iPtr, &frame.varTable);
        !           531:     return result;
        !           532: }
        !           533: 
        !           534: /*
        !           535:  *----------------------------------------------------------------------
        !           536:  *
        !           537:  * ProcDeleteProc --
        !           538:  *
        !           539:  *     This procedure is invoked just before a command procedure is
        !           540:  *     removed from an interpreter.  Its job is to release all the
        !           541:  *     resources allocated to the procedure.
        !           542:  *
        !           543:  * Results:
        !           544:  *     None.
        !           545:  *
        !           546:  * Side effects:
        !           547:  *     Memory gets freed.
        !           548:  *
        !           549:  *----------------------------------------------------------------------
        !           550:  */
        !           551: 
        !           552: static void
        !           553: ProcDeleteProc(clientData)
        !           554:     ClientData clientData;             /* Procedure to be deleted. */
        !           555: {
        !           556:     register Proc *procPtr = (Proc *) clientData;
        !           557:     register Arg *argPtr;
        !           558: 
        !           559:     ckfree((char *) procPtr->command);
        !           560:     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
        !           561:        Arg *nextPtr = argPtr->nextPtr;
        !           562: 
        !           563:        ckfree((char *) argPtr);
        !           564:        argPtr = nextPtr;
        !           565:     }
        !           566:     ckfree((char *) procPtr);
        !           567: }

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