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