git.zerfleddert.de Git - micropolis/blob

1 /*

2 * tclProc.c --

3 *

4 * This file contains routines that implement Tcl procedures,

5 * including the "proc" and "uplevel" commands.

6 *

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 */

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

21 #include "tclint.h"

23 /*

24 * Forward references to procedures defined later in this file:

25 */

27 static int InterpProc _ANSI_ARGS_((ClientData clientData,

                     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 */

48 /* ARGSUSED */

49 int

 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 {

     register Interp *iPtr = (Interp *) interp;

57 register Proc *procPtr;

58 int result, argCount, i;

59 char **argArray = NULL;

60 Arg *lastArgPtr;

     register Arg *argPtr = NULL;        /* Initialization not needed, but

62 * prevents compiler warning. */

     if (argc != 4) {

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                 " name args body\"", (char *) NULL);

67 return TCL_ERROR;

68 }

     procPtr = (Proc *) ckalloc(sizeof(Proc));

71 procPtr->iPtr = iPtr;

     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);

     strcpy(procPtr->command, argv[3]);

74 procPtr->argPtr = NULL;

76 /*

77 * Break up the argument list into argument specifiers, then process

78 * each argument specifier.

79 */

     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);

82 if (result != TCL_OK) {

83 goto procError;

84 }

85 lastArgPtr = NULL;

     for (i = 0; i < argCount; i++) {

87 int fieldCount, nameLength, valueLength;

88 char **fieldValues;

90 /*

91 * Now divide the specifier up into name and default.

92 */

         result = Tcl_SplitList(interp, argArray[i], &fieldCount,

95 &fieldValues);

96 if (result != TCL_OK) {

97 goto procError;

98 }

         if (fieldCount > 2) {

             ckfree((char *) fieldValues);

101 Tcl_AppendResult(interp,

102 "too many fields in argument specifier \"",

                     argArray[i], "\"", (char *) NULL);

104 result = TCL_ERROR;

105 goto procError;

106 }

         if ((fieldCount == 0) || (*fieldValues[0] == 0)) {

             ckfree((char *) fieldValues);

             Tcl_AppendResult(interp, "procedure \"", argv[1],

                     "\" has argument with no name", (char *) NULL);

111 result = TCL_ERROR;

112 goto procError;

113 }

         nameLength = strlen(fieldValues[0]) + 1;

         if (fieldCount == 2) {

             valueLength = strlen(fieldValues[1]) + 1;

117 } else {

118 valueLength = 0;

119 }

         argPtr = (Arg *) ckalloc((unsigned)

                 (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;

         strcpy(argPtr->name, fieldValues[0]);

         if (fieldCount == 2) {

             argPtr->defValue = argPtr->name + nameLength;

             strcpy(argPtr->defValue, fieldValues[1]);

134 } else {

135 argPtr->defValue = NULL;

136 }

         ckfree((char *) fieldValues);

138 }

139

     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,

141 ProcDeleteProc);

     ckfree((char *) argArray);

143 return TCL_OK;

144

145 procError:

146 ckfree(procPtr->command);

     while (procPtr->argPtr != NULL) {

148 argPtr = procPtr->argPtr;

149 procPtr->argPtr = argPtr->nextPtr;

         ckfree((char *) argPtr);

151 }

     ckfree((char *) procPtr);

153 if (argArray != NULL) {

         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

 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 {

     register Interp *iPtr = (Interp *) interp;

192 int level, result;

193 CallFrame *framePtr;

194

     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;

     if (*string == '#') {

         if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {

207 return -1;

208 }

         if (level < 0) {

210 levelError:

             Tcl_AppendResult(interp, "bad level \"", string, "\"",

212 (char *) NULL);

213 return -1;

214 }

     } else if (isdigit(*string)) {

         if (Tcl_GetInt(interp, string, &level) != TCL_OK) {

217 return -1;

218 }

         level = iPtr->varFramePtr->level - level;

220 } else {

         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

     if (level == 0) {

231 framePtr = NULL;

232 } else {

         for (framePtr = iPtr->varFramePtr; framePtr != NULL;

234 framePtr = framePtr->callerVarPtr) {

             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

 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 {

     register Interp *iPtr = (Interp *) interp;

273 int result;

274 CallFrame *savedVarFramePtr, *framePtr;

275

     if (argc < 2) {

277 uplevelSyntax:

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                 " ?level? command ?command ...?\"", (char *) NULL);

280 return TCL_ERROR;

281 }

282

283 /*

284 * Find the level to use for executing the command.

285 */

286

     result = TclGetFrame(interp, argv[1], &framePtr);

     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

     if (argc == 0) {

306 goto uplevelSyntax;

307 }

     if (argc == 1) {

         result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);

310 } else {

311 char *cmd;

312

         cmd = Tcl_Concat(argc, argv);

         result = Tcl_Eval(interp, cmd, 0, (char **) NULL);

315 ckfree(cmd);

316 }

317 if (result == TCL_ERROR) {

318 char msg[60];

         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

     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);

359 if (hPtr == NULL) {

360 return NULL;

361 }

     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

     if (cmdPtr->proc != InterpProc) {

364 return NULL;

365 }

     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 {

     if (cmdPtr->proc == InterpProc) {

         return (Proc *) cmdPtr->clientData;

393 }

     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

 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 {

     register Proc *procPtr = (Proc *) clientData;

425 register Arg *argPtr;

     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;

     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);

     if (iPtr->varFramePtr != NULL) {

         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

     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;

456 argPtr != NULL;

             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

         if ((argPtr->nextPtr == NULL)

                 && (strcmp(argPtr->name, "args") == 0)) {

             if (argc < 0) {

468 argc = 0;

469 }

             value = Tcl_Merge(argc, args);

             Tcl_SetVar(interp, argPtr->name, value, 0);

472 ckfree(value);

473 argc = 0;

474 break;

         } else if (argc > 0) {

476 value = *args;

         } else if (argPtr->defValue != NULL) {

478 value = argPtr->defValue;

479 } else {

             Tcl_AppendResult(interp, "no value given for parameter \"",

                     argPtr->name, "\" to \"", argv[0], "\"",

482 (char *) NULL);

483 result = TCL_ERROR;

484 goto procDone;

485 }

         Tcl_SetVar(interp, argPtr->name, value, 0);

487 }

     if (argc > 0) {

         Tcl_AppendResult(interp, "called \"", argv[0],

                 "\" 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

     result = Tcl_Eval(interp, procPtr->command, 0, &end);

500 if (result == TCL_RETURN) {

501 result = TCL_OK;

     } else if (result == TCL_ERROR) {

503 char msg[100];

504

505 /*

506 * Record information telling where the error occurred.

507 */

508

         sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],

510 iPtr->errorLine);

511 Tcl_AddErrorInfo(interp, msg);

     } else if (result == TCL_BREAK) {

         iPtr->result = "invoked \"break\" outside of a loop";

514 result = TCL_ERROR;

     } else if (result == TCL_CONTINUE) {

         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;

     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 {

     register Proc *procPtr = (Proc *) clientData;

557 register Arg *argPtr;

558

     ckfree((char *) procPtr->command);

     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {

561 Arg *nextPtr = argPtr->nextPtr;

562

         ckfree((char *) argPtr);

564 argPtr = nextPtr;

565 }

     ckfree((char *) procPtr);

567 }