git.zerfleddert.de Git - micropolis/blob - src/tcl/tclproc.c

   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 \f
  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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 }