Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume25/tcl/part12

Text File | 1991-11-14 | 48.6 KB | 1,910 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i080:  tcl - tool command language, version 6.1, Part12/33
Message-ID: <[e-mail]>
X-Md4-Signature: 7efc03ec6a8d962867173d087f5155e2
Date: Thu, 14 Nov 1991 20:30:28 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 25, Issue 80
Archive-name: tcl/part12
Environment: UNIX

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 12 (of 33)."
# Contents:  tcl6.1/tclCkalloc.c tcl6.1/tclProc.c tcl6.1/tclUnixStr.c
# Wrapped by karl@one on Tue Nov 12 19:44:20 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclCkalloc.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclCkalloc.c'\"
else
echo shar: Extracting \"'tcl6.1/tclCkalloc.c'\" \(15293 characters\)
sed "s/^X//" >'tcl6.1/tclCkalloc.c' <<'END_OF_FILE'
X/*
X * tclCkalloc.c --
X *    Interface to malloc and free that provides support for debugging problems
X *    involving overwritten, double freeing memory and loss of memory.
X *
X * Copyright 1991 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies.  The University of California
X * makes no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without
X * express or implied warranty.
X *
X * This code contributed by Karl Lehenbauer and Mark Diekhans
X *
X */
X
X#include "tclInt.h"
X#include "tclUnix.h"
X
X#define FALSE    0
X#define TRUE    1
X
X#ifdef TCL_MEM_DEBUG
X
X#define GUARD_SIZE 8
X
Xstruct mem_header {
X        long               length;
X        char              *file;
X        int                line;
X        struct mem_header *flink;
X        struct mem_header *blink;
X        unsigned char      low_guard[GUARD_SIZE];
X        char               body[1];
X};
X
Xstatic struct mem_header *allocHead = NULL;  /* List of allocated structures */
X
X#define GUARD_VALUE  0341
X
X/* static char high_guard[] = {0x89, 0xab, 0xcd, 0xef}; */
X
Xstatic int total_mallocs = 0;
Xstatic int total_frees = 0;
Xstatic int current_bytes_malloced = 0;
Xstatic int maximum_bytes_malloced = 0;
Xstatic int current_malloc_packets = 0;
Xstatic int maximum_malloc_packets = 0;
Xstatic int break_on_malloc = 0;
Xstatic int trace_on_at_malloc = 0;
Xstatic int  alloc_tracing = FALSE;
Xstatic int  init_malloced_bodies = FALSE;
X#ifdef MEM_VALIDATE
X    static int  validate_memory = TRUE;
X#else
X    static int  validate_memory = FALSE;
X#endif
X
X
X/*
X *----------------------------------------------------------------------
X *
X * dump_memory_info --
X *     Display the global memory management statistics.
X *
X *----------------------------------------------------------------------
X */
Xstatic void
Xdump_memory_info(outFile)
X    FILE *outFile;
X{
X        fprintf(outFile,"total mallocs             %10d\n",
X                total_mallocs);
X        fprintf(outFile,"total frees               %10d\n",
X                total_frees);
X        fprintf(outFile,"current packets allocated %10d\n",
X                current_malloc_packets);
X        fprintf(outFile,"current bytes allocated   %10d\n",
X                current_bytes_malloced);
X        fprintf(outFile,"maximum packets allocated %10d\n",
X                maximum_malloc_packets);
X        fprintf(outFile,"maximum bytes allocated   %10d\n",
X                maximum_bytes_malloced);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * ValidateMemory --
X *     Procedure to validate allocted memory guard zones.
X *
X *----------------------------------------------------------------------
X */
Xstatic void
XValidateMemory (memHeaderP, file, line, nukeGuards)
X    struct mem_header *memHeaderP;
X    char              *file;
X    int                line;
X    int                nukeGuards;
X{
X    unsigned char *hiPtr;
X    int   idx;
X    int   guard_failed = FALSE;
X
X    for (idx = 0; idx < GUARD_SIZE; idx++)
X        if (*(memHeaderP->low_guard + idx) != GUARD_VALUE) {
X            guard_failed = TRUE;
X            fflush (stdout);
X            fprintf(stderr, "low guard byte %d is 0x%x\n", idx,
X                    *(memHeaderP->low_guard + idx) & 0xff);
X        }
X
X    if (guard_failed) {
X        dump_memory_info (stderr);
X        fprintf (stderr, "low guard failed at %lx, %s %d\n",
X                 memHeaderP->body, file, line);
X        fflush (stderr);  /* In case name pointer is bad. */
X        fprintf (stderr, "Allocated at (%s %d)\n", memHeaderP->file,
X                 memHeaderP->line);
X        panic ("Memory validation failure");
X    }
X
X    hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
X    for (idx = 0; idx < GUARD_SIZE; idx++)
X        if (*(hiPtr + idx) != GUARD_VALUE) {
X            guard_failed = TRUE;
X            fflush (stdout);
X            fprintf(stderr, "hi guard byte %d is 0x%x\n", idx,
X                    *(hiPtr+idx) & 0xff);
X        }
X
X    if (guard_failed) {
X        dump_memory_info (stderr);
X        fprintf (stderr, "high guard failed at %lx, %s %d\n",
X                 memHeaderP->body, file, line);
X        fflush (stderr);  /* In case name pointer is bad. */
X        fprintf (stderr, "Allocated at (%s %d)\n", memHeaderP->file,
X                 memHeaderP->line);
X        panic ("Memory validation failure");
X    }
X
X    if (nukeGuards) {
X        memset ((char *) memHeaderP->low_guard, 0, GUARD_SIZE);
X        memset ((char *) hiPtr, 0, GUARD_SIZE);
X    }
X
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ValidateAllMemory --
X *     Validates guard regions for all allocated memory.
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_ValidateAllMemory (file, line)
X    char  *file;
X    int    line;
X{
X    struct mem_header *memScanP;
X
X    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink)
X        ValidateMemory (memScanP, file, line, FALSE);
X
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DumpActiveMemory --
X *     Displays all allocated memory to stderr.
X *
X * Results:
X *     Return TCL_ERROR if an error accessing the file occures, `errno'
X *     will have the file error number left in it.
X *----------------------------------------------------------------------
X */
Xint
XTcl_DumpActiveMemory (fileName)
X    char *fileName;
X{
X    FILE              *fileP;
X    struct mem_header *memScanP;
X    char              *address;
X
X    fileP = fopen (fileName, "w");
X    if (fileP == NULL)
X        return TCL_ERROR;
X
X    for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
X        address = &memScanP->body [0];
X        fprintf (fileP, "%8lx - %8lx  %7d @ %s %d\n", address,
X                 address + memScanP->length - 1, memScanP->length,
X                 memScanP->file, memScanP->line);
X    }
X    fclose (fileP);
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DbCkalloc - debugging ckalloc
X *
X *        Allocate the requested amount of space plus some extra for
X *        guard bands at both ends of the request, plus a size, panicing
X *        if there isn't enough space, then write in the guard bands
X *        and return the address of the space in the middle that the
X *        user asked for.
X *
X *        The second and third arguments are file and line, these contain
X *        the filename and line number corresponding to the caller.
X *        These are sent by the ckalloc macro; it uses the preprocessor
X *        autodefines __FILE__ and __LINE__.
X *
X *----------------------------------------------------------------------
X */
Xchar *
XTcl_DbCkalloc(size, file, line)
X    unsigned int size;
X    char        *file;
X    int          line;
X{
X    struct mem_header *result;
X
X    if (validate_memory)
X        Tcl_ValidateAllMemory (file, line);
X
X    result = (struct mem_header *)malloc((unsigned)size +
X                              sizeof(struct mem_header) + GUARD_SIZE);
X    if (result == NULL) {
X        fflush(stdout);
X        dump_memory_info(stderr);
X        panic("unable to alloc %d bytes, %s line %d", size, file,
X              line);
X    }
X
X    /*
X     * Fill in guard zones and size.  Link into allocated list.
X     */
X    result->length = size;
X    result->file = file;
X    result->line = line;
X    memset ((char *) result->low_guard, GUARD_VALUE, GUARD_SIZE);
X    memset (result->body + size, GUARD_VALUE, GUARD_SIZE);
X    result->flink = allocHead;
X    result->blink = NULL;
X    if (allocHead != NULL)
X        allocHead->blink = result;
X    allocHead = result;
X
X    total_mallocs++;
X    if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
X        (void) fflush(stdout);
X        fprintf(stderr, "reached malloc trace enable point (%d)\n",
X                total_mallocs);
X        fflush(stderr);
X        alloc_tracing = TRUE;
X        trace_on_at_malloc = 0;
X    }
X
X    if (alloc_tracing)
X        fprintf(stderr,"ckalloc %lx %d %s %d\n", result->body, size,
X                file, line);
X
X    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
X        break_on_malloc = 0;
X        (void) fflush(stdout);
X        fprintf(stderr,"reached malloc break limit (%d)\n",
X                total_mallocs);
X        fprintf(stderr, "program will now enter C debugger\n");
X        (void) fflush(stderr);
X        kill (getpid(), SIGINT);
X    }
X
X    current_malloc_packets++;
X    if (current_malloc_packets > maximum_malloc_packets)
X        maximum_malloc_packets = current_malloc_packets;
X    current_bytes_malloced += size;
X    if (current_bytes_malloced > maximum_bytes_malloced)
X        maximum_bytes_malloced = current_bytes_malloced;
X
X    if (init_malloced_bodies)
X        memset (result->body, 0xff, (int) size);
X
X    return result->body;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DbCkfree - debugging ckfree
X *
X *        Verify that the low and high guards are intact, and if so
X *        then free the buffer else panic.
X *
X *        The guards are erased after being checked to catch duplicate
X *        frees.
X *
X *        The second and third arguments are file and line, these contain
X *        the filename and line number corresponding to the caller.
X *        These are sent by the ckfree macro; it uses the preprocessor
X *        autodefines __FILE__ and __LINE__.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_DbCkfree(ptr, file, line)
X    char *  ptr;
X    char     *file;
X    int       line;
X{
X    struct mem_header *memp = 0;  /* Must be zero for size calc */
X
X    /*
X     * Since header ptr is zero, body offset will be size
X     */
X    memp = (struct mem_header *)(((char *) ptr) - (int)memp->body);
X
X    if (alloc_tracing)
X        fprintf(stderr, "ckfree %lx %ld %s %d\n", memp->body,
X                memp->length, file, line);
X
X    if (validate_memory)
X        Tcl_ValidateAllMemory (file, line);
X
X    ValidateMemory (memp, file, line, TRUE);
X
X    total_frees++;
X    current_malloc_packets--;
X    current_bytes_malloced -= memp->length;
X
X    /*
X     * Delink from allocated list
X     */
X    if (memp->flink != NULL)
X        memp->flink->blink = memp->blink;
X    if (memp->blink != NULL)
X        memp->blink->flink = memp->flink;
X    if (allocHead == memp)
X        allocHead = memp->flink;
X    free((char *) memp);
X    return 0;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * MemoryCmd --
X *     Implements the TCL memory command:
X *       memory info
X *       memory display
X *       break_on_malloc count
X *       trace_on_at_malloc count
X *       trace on|off
X *       validate on|off
X *
X * Results:
X *     Standard TCL results.
X *
X *----------------------------------------------------------------------
X */
X    /* ARGSUSED */
Xstatic int
XMemoryCmd (clientData, interp, argc, argv)
X    char       *clientData;
X    Tcl_Interp *interp;
X    int         argc;
X    char      **argv;
X{
X    char *fileName;
X
X    if (argc < 2) {
X    Tcl_AppendResult(interp, "wrong # args:  should be \"",
X        argv[0], " option [args..]\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    if (strcmp(argv[1],"trace") == 0) {
X        if (argc != 3)
X            goto bad_suboption;
X        alloc_tracing = (strcmp(argv[2],"on") == 0);
X        return TCL_OK;
X    }
X    if (strcmp(argv[1],"init") == 0) {
X        if (argc != 3)
X            goto bad_suboption;
X        init_malloced_bodies = (strcmp(argv[2],"on") == 0);
X        return TCL_OK;
X    }
X    if (strcmp(argv[1],"validate") == 0) {
X        if (argc != 3)
X             goto bad_suboption;
X        validate_memory = (strcmp(argv[2],"on") == 0);
X        return TCL_OK;
X    }
X    if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
X        if (argc != 3)
X            goto argError;
X        if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK)
X                return TCL_ERROR;
X         return TCL_OK;
X    }
X    if (strcmp(argv[1],"break_on_malloc") == 0) {
X        if (argc != 3)
X            goto argError;
X        if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK)
X                return TCL_ERROR;
X        return TCL_OK;
X    }
X
X    if (strcmp(argv[1],"info") == 0) {
X        dump_memory_info(stdout);
X        return TCL_OK;
X    }
X    if (strcmp(argv[1],"active") == 0) {
X        if (argc != 3) {
X        Tcl_AppendResult(interp, "wrong # args:  should be \"",
X            argv[0], " active file", (char *) NULL);
X        return TCL_ERROR;
X    }
X        fileName = argv [2];
X        if (fileName [0] == '~')
X            if ((fileName = Tcl_TildeSubst (interp, fileName)) == NULL)
X                return TCL_ERROR;
X        if (Tcl_DumpActiveMemory (fileName) != TCL_OK) {
X        Tcl_AppendResult(interp, "error accessing ", argv[2],
X            (char *) NULL);
X        return TCL_ERROR;
X    }
X    return TCL_OK;
X    }
X    Tcl_AppendResult(interp, "bad option \"", argv[1],
X        "\":  should be info, init, active, break_on_malloc, ",
X        "trace_on_at_malloc, trace, or validate", (char *) NULL);
X    return TCL_ERROR;
X
XargError:
X    Tcl_AppendResult(interp, "wrong # args:  should be \"", argv[0],
X        " ", argv[1], "count\"", (char *) NULL);
X    return TCL_ERROR;
X
Xbad_suboption:
X    Tcl_AppendResult(interp, "wrong # args:  should be \"", argv[0],
X        " ", argv[1], " on|off\"", (char *) NULL);
X    return TCL_ERROR;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_InitMemory --
X *     Initialize the memory command.
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_InitMemory(interp)
X    Tcl_Interp *interp;
X{
XTcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData)NULL,
X                  (void (*)())NULL);
X}
X
X#else
X
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_Ckalloc --
X *     Interface to malloc when TCL_MEM_DEBUG is disabled.  It does check
X *     that memory was actually allocated.
X *
X *----------------------------------------------------------------------
X */
XVOID *
XTcl_Ckalloc (size)
X    unsigned int size;
X{
X        char *result;
X
X        result = malloc(size);
X        if (result == NULL)
X                panic("unable to alloc %d bytes", size);
X        return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TckCkfree --
X *     Interface to free when TCL_MEM_DEBUG is disabled.  Done here rather
X *     in the macro to keep some modules from being compiled with
X *     TCL_MEM_DEBUG enabled and some with it disabled.
X *
X *----------------------------------------------------------------------
X */
Xvoid
XTcl_Ckfree (ptr)
X    VOID *ptr;
X{
X        free (ptr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_InitMemory --
X *     Dummy initialization for memory command, which is only available
X *     if TCL_MEM_DEBUG is on.
X *
X *----------------------------------------------------------------------
X */
X    /* ARGSUSED */
Xvoid
XTcl_InitMemory(interp)
X    Tcl_Interp *interp;
X{
X}
X
X#endif
X
END_OF_FILE
if test 15293 -ne `wc -c <'tcl6.1/tclCkalloc.c'`; then
    echo shar: \"'tcl6.1/tclCkalloc.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclCkalloc.c'
fi
if test -f 'tcl6.1/tclProc.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclProc.c'\"
else
echo shar: Extracting \"'tcl6.1/tclProc.c'\" \(14709 characters\)
sed "s/^X//" >'tcl6.1/tclProc.c' <<'END_OF_FILE'
X/*
X * tclProc.c --
X *
X *    This file contains routines that implement Tcl procedures,
X *    including the "proc" and "uplevel" commands.
X *
X * Copyright 1987-1991 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies.  The University of California
X * makes no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without
X * express or implied warranty.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclProc.c,v 1.59 91/09/30 16:59:54 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * Forward references to procedures defined later in this file:
X */
X
Xstatic  int    InterpProc _ANSI_ARGS_((ClientData clientData,
X            Tcl_Interp *interp, int argc, char **argv));
Xstatic  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ProcCmd --
X *
X *    This procedure is invoked to process the "proc" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    A new procedure gets created.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ProcCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    register Interp *iPtr = (Interp *) interp;
X    register Proc *procPtr;
X    int result, argCount, i;
X    char **argArray = NULL;
X    Arg *lastArgPtr;
X    register Arg *argPtr = NULL;    /* Initialization not needed, but
X                     * prevents compiler warning. */
X
X    if (argc != 4) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " name args body\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    procPtr = (Proc *) ckalloc(sizeof(Proc));
X    procPtr->iPtr = iPtr;
X    procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
X    strcpy(procPtr->command, argv[3]);
X    procPtr->argPtr = NULL;
X
X    /*
X     * Break up the argument list into argument specifiers, then process
X     * each argument specifier.
X     */
X
X    result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
X    if (result != TCL_OK) {
X    goto procError;
X    }
X    lastArgPtr = NULL;
X    for (i = 0; i < argCount; i++) {
X    int fieldCount, nameLength, valueLength;
X    char **fieldValues;
X
X    /*
X     * Now divide the specifier up into name and default.
X     */
X
X    result = Tcl_SplitList(interp, argArray[i], &fieldCount,
X        &fieldValues);
X    if (result != TCL_OK) {
X        goto procError;
X    }
X    if (fieldCount > 2) {
X        ckfree((char *) fieldValues);
X        Tcl_AppendResult(interp,
X            "too many fields in argument specifier \"",
X            argArray[i], "\"", (char *) NULL);
X        result = TCL_ERROR;
X        goto procError;
X    }
X    if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
X        ckfree((char *) fieldValues);
X        Tcl_AppendResult(interp, "procedure \"", argv[1],
X            "\" has argument with no name", (char *) NULL);
X        result = TCL_ERROR;
X        goto procError;
X    }
X    nameLength = strlen(fieldValues[0]) + 1;
X    if (fieldCount == 2) {
X        valueLength = strlen(fieldValues[1]) + 1;
X    } else {
X        valueLength = 0;
X    }
X    argPtr = (Arg *) ckalloc((unsigned)
X        (sizeof(Arg) - sizeof(argPtr->name) + nameLength
X        + valueLength));
X    if (lastArgPtr == NULL) {
X        procPtr->argPtr = argPtr;
X    } else {
X        lastArgPtr->nextPtr = argPtr;
X    }
X    lastArgPtr = argPtr;
X    argPtr->nextPtr = NULL;
X    strcpy(argPtr->name, fieldValues[0]);
X    if (fieldCount == 2) {
X        argPtr->defValue = argPtr->name + nameLength;
X        strcpy(argPtr->defValue, fieldValues[1]);
X    } else {
X        argPtr->defValue = NULL;
X    }
X    ckfree((char *) fieldValues);
X    }
X
X    Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
X        ProcDeleteProc);
X    ckfree((char *) argArray);
X    return TCL_OK;
X
X    procError:
X    ckfree(procPtr->command);
X    while (procPtr->argPtr != NULL) {
X    argPtr = procPtr->argPtr;
X    procPtr->argPtr = argPtr->nextPtr;
X    ckfree((char *) argPtr);
X    }
X    ckfree((char *) procPtr);
X    if (argArray != NULL) {
X    ckfree((char *) argArray);
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclGetFrame --
X *
X *    Given a description of a procedure frame, such as the first
X *    argument to an "uplevel" or "upvar" command, locate the
X *    call frame for the appropriate level of procedure.
X *
X * Results:
X *    The return value is -1 if an error occurred in finding the
X *    frame (in this case an error message is left in interp->result).
X *    1 is returned if string was either a number or a number preceded
X *    by "#" and it specified a valid frame.  0 is returned if string
X *    isn't one of the two things above (in this case, the lookup
X *    acts as if string were "1").  The variable pointed to by
X *    framePtrPtr is filled in with the address of the desired frame
X *    (unless an error occurs, in which case it isn't modified).
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTclGetFrame(interp, string, framePtrPtr)
X    Tcl_Interp *interp;        /* Interpreter in which to find frame. */
X    char *string;        /* String describing frame. */
X    CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
X                 * if global frame indicated). */
X{
X    register Interp *iPtr = (Interp *) interp;
X    int level, result;
X    CallFrame *framePtr;
X
X    if (iPtr->varFramePtr == NULL) {
X    iPtr->result = "already at top level";
X    return -1;
X    }
X
X    /*
X     * Parse string to figure out which level number to go to.
X     */
X
X    result = 1;
X    if (*string == '#') {
X    if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
X        return -1;
X    }
X    if (level < 0) {
X        levelError:
X        Tcl_AppendResult(interp, "bad level \"", string, "\"",
X            (char *) NULL);
X        return -1;
X    }
X    } else if (isdigit(*string)) {
X    if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
X        return -1;
X    }
X    level = iPtr->varFramePtr->level - level;
X    } else {
X    level = iPtr->varFramePtr->level - 1;
X    result = 0;
X    }
X
X    /*
X     * Figure out which frame to use, and modify the interpreter so
X     * its variables come from that frame.
X     */
X
X    if (level == 0) {
X    framePtr = NULL;
X    } else {
X    for (framePtr = iPtr->varFramePtr; framePtr != NULL;
X        framePtr = framePtr->callerVarPtr) {
X        if (framePtr->level == level) {
X        break;
X        }
X    }
X    if (framePtr == NULL) {
X        goto levelError;
X    }
X    }
X    *framePtrPtr = framePtr;
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UplevelCmd --
X *
X *    This procedure is invoked to process the "uplevel" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_UplevelCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    register Interp *iPtr = (Interp *) interp;
X    int result;
X    CallFrame *savedVarFramePtr, *framePtr;
X
X    if (argc < 2) {
X    uplevelSyntax:
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " ?level? command ?command ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    /*
X     * Find the level to use for executing the command.
X     */
X
X    result = TclGetFrame(interp, argv[1], &framePtr);
X    if (result == -1) {
X    return TCL_ERROR;
X    }
X    argc -= (result+1);
X    argv += (result+1);
X
X    /*
X     * Modify the interpreter state to execute in the given frame.
X     */
X
X    savedVarFramePtr = iPtr->varFramePtr;
X    iPtr->varFramePtr = framePtr;
X
X    /*
X     * Execute the residual arguments as a command.
X     */
X
X    if (argc == 0) {
X    goto uplevelSyntax;
X    }
X    if (argc == 1) {
X    result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);
X    } else {
X    char *cmd;
X
X    cmd = Tcl_Concat(argc, argv);
X    result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
X    ckfree(cmd);
X    }
X    if (result == TCL_ERROR) {
X    char msg[60];
X    sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
X    Tcl_AddErrorInfo(interp, msg);
X    }
X
X    /*
X     * Restore the variable frame, and return.
X     */
X
X    iPtr->varFramePtr = savedVarFramePtr;
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclFindProc --
X *
X *    Given the name of a procedure, return a pointer to the
X *    record describing the procedure.
X *
X * Results:
X *    NULL is returned if the name doesn't correspond to any
X *    procedure.  Otherwise the return value is a pointer to
X *    the procedure's record.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
XProc *
XTclFindProc(iPtr, procName)
X    Interp *iPtr;        /* Interpreter in which to look. */
X    char *procName;        /* Name of desired procedure. */
X{
X    Tcl_HashEntry *hPtr;
X    Command *cmdPtr;
X
X    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
X    if (hPtr == NULL) {
X    return NULL;
X    }
X    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
X    if (cmdPtr->proc != InterpProc) {
X    return NULL;
X    }
X    return (Proc *) cmdPtr->clientData;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclIsProc --
X *
X *    Tells whether a command is a Tcl procedure or not.
X *
X * Results:
X *    If the given command is actuall a Tcl procedure, the
X *    return value is the address of the record describing
X *    the procedure.  Otherwise the return value is 0.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
XProc *
XTclIsProc(cmdPtr)
X    Command *cmdPtr;        /* Command to test. */
X{
X    if (cmdPtr->proc == InterpProc) {
X    return (Proc *) cmdPtr->clientData;
X    }
X    return (Proc *) 0;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * InterpProc --
X *
X *    When a Tcl procedure gets invoked, this routine gets invoked
X *    to interpret the procedure.
X *
X * Results:
X *    A standard Tcl result value, usually TCL_OK.
X *
X * Side effects:
X *    Depends on the commands in the procedure.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic int
XInterpProc(clientData, interp, argc, argv)
X    ClientData clientData;    /* Record describing procedure to be
X                 * interpreted. */
X    Tcl_Interp *interp;        /* Interpreter in which procedure was
X                 * invoked. */
X    int argc;            /* Count of number of arguments to this
X                 * procedure. */
X    char **argv;        /* Argument values. */
X{
X    register Proc *procPtr = (Proc *) clientData;
X    register Arg *argPtr;
X    register Interp *iPtr = (Interp *) interp;
X    char **args;
X    CallFrame frame;
X    char *value, *end;
X    int result;
X
X    /*
X     * Set up a call frame for the new procedure invocation.
X     */
X
X    iPtr = procPtr->iPtr;
X    Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
X    if (iPtr->varFramePtr != NULL) {
X    frame.level = iPtr->varFramePtr->level + 1;
X    } else {
X    frame.level = 1;
X    }
X    frame.argc = argc;
X    frame.argv = argv;
X    frame.callerPtr = iPtr->framePtr;
X    frame.callerVarPtr = iPtr->varFramePtr;
X    iPtr->framePtr = &frame;
X    iPtr->varFramePtr = &frame;
X
X    /*
X     * Match the actual arguments against the procedure's formal
X     * parameters to compute local variables.
X     */
X
X    for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
X        argPtr != NULL;
X        argPtr = argPtr->nextPtr, args++, argc--) {
X
X    /*
X     * Handle the special case of the last formal being "args".  When
X     * it occurs, assign it a list consisting of all the remaining
X     * actual arguments.
X     */
X
X    if ((argPtr->nextPtr == NULL)
X        && (strcmp(argPtr->name, "args") == 0)) {
X        if (argc < 0) {
X        argc = 0;
X        }
X        value = Tcl_Merge(argc, args);
X        Tcl_SetVar(interp, argPtr->name, value, 0);
X        ckfree(value);
X        argc = 0;
X        break;
X    } else if (argc > 0) {
X        value = *args;
X    } else if (argPtr->defValue != NULL) {
X        value = argPtr->defValue;
X    } else {
X        Tcl_AppendResult(interp, "no value given for parameter \"",
X            argPtr->name, "\" to \"", argv[0], "\"",
X            (char *) NULL);
X        result = TCL_ERROR;
X        goto procDone;
X    }
X    Tcl_SetVar(interp, argPtr->name, value, 0);
X    }
X    if (argc > 0) {
X    Tcl_AppendResult(interp, "called \"", argv[0],
X        "\" with too many arguments", (char *) NULL);
X    result = TCL_ERROR;
X    goto procDone;
X    }
X
X    /*
X     * Invoke the commands in the procedure's body.
X     */
X
X    result = Tcl_Eval(interp, procPtr->command, 0, &end);
X    if (result == TCL_RETURN) {
X    result = TCL_OK;
X    } else if (result == TCL_ERROR) {
X    char msg[100];
X
X    /*
X     * Record information telling where the error occurred.
X     */
X
X    sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
X        iPtr->errorLine);
X    Tcl_AddErrorInfo(interp, msg);
X    } else if (result == TCL_BREAK) {
X    iPtr->result = "invoked \"break\" outside of a loop";
X    result = TCL_ERROR;
X    } else if (result == TCL_CONTINUE) {
X    iPtr->result = "invoked \"continue\" outside of a loop";
X    result = TCL_ERROR;
X    }
X
X    /*
X     * Delete the call frame for this procedure invocation (it's
X     * important to remove the call frame from the interpreter
X     * before deleting it, so that traces invoked during the
X     * deletion don't see the partially-deleted frame).
X     */
X
X    procDone:
X    iPtr->framePtr = frame.callerPtr;
X    iPtr->varFramePtr = frame.callerVarPtr;
X    TclDeleteVars(iPtr, &frame.varTable);
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * ProcDeleteProc --
X *
X *    This procedure is invoked just before a command procedure is
X *    removed from an interpreter.  Its job is to release all the
X *    resources allocated to the procedure.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    Memory gets freed.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic void
XProcDeleteProc(clientData)
X    ClientData clientData;        /* Procedure to be deleted. */
X{
X    register Proc *procPtr = (Proc *) clientData;
X    register Arg *argPtr;
X
X    ckfree((char *) procPtr->command);
X    for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
X    Arg *nextPtr = argPtr->nextPtr;
X
X    ckfree((char *) argPtr);
X    argPtr = nextPtr;
X    }
X    ckfree((char *) procPtr);
X}
END_OF_FILE
if test 14709 -ne `wc -c <'tcl6.1/tclProc.c'`; then
    echo shar: \"'tcl6.1/tclProc.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclProc.c'
fi
if test -f 'tcl6.1/tclUnixStr.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclUnixStr.c'\"
else
echo shar: Extracting \"'tcl6.1/tclUnixStr.c'\" \(14884 characters\)
sed "s/^X//" >'tcl6.1/tclUnixStr.c' <<'END_OF_FILE'
X/*
X * tclUnixStr.c --
X *
X *    This file contains procedures that generate strings
X *    corresponding to various UNIX-related codes, such
X *    as errno and signals.
X *
X * Copyright 1991 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that this copyright
X * notice appears in all copies.  The University of California
X * makes no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without
X * express or implied warranty.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclUnixStr.c,v 1.6 91/09/30 09:07:57 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include "tclInt.h"
X#include "tclUnix.h"
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ErrnoId --
X *
X *    Return a textual identifier for the current errno value.
X *
X * Results:
X *    This procedure returns a machine-readable textual identifier
X *    that corresponds to the current errno value (e.g. "EPERM").
X *    The identifier is the same as the #define name in errno.h.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_ErrnoId()
X{
X    switch (errno) {
X#ifdef E2BIG
X    case E2BIG: return "E2BIG";
X#endif
X#ifdef EACCES
X    case EACCES: return "EACCES";
X#endif
X#ifdef EADDRINUSE
X    case EADDRINUSE: return "EADDRINUSE";
X#endif
X#ifdef EADDRNOTAVAIL
X    case EADDRNOTAVAIL: return "EADDRNOTAVAIL";
X#endif
X#ifdef EADV
X    case EADV: return "EADV";
X#endif
X#ifdef EAFNOSUPPORT
X    case EAFNOSUPPORT: return "EAFNOSUPPORT";
X#endif
X#ifdef EAGAIN
X    case EAGAIN: return "EAGAIN";
X#endif
X#ifdef EALIGN
X    case EALIGN: return "EALIGN";
X#endif
X#ifdef EALREADY
X    case EALREADY: return "EALREADY";
X#endif
X#ifdef EBADE
X    case EBADE: return "EBADE";
X#endif
X#ifdef EBADF
X    case EBADF: return "EBADF";
X#endif
X#ifdef EBADFD
X    case EBADFD: return "EBADFD";
X#endif
X#ifdef EBADMSG
X    case EBADMSG: return "EBADMSG";
X#endif
X#ifdef EBADR
X    case EBADR: return "EBADR";
X#endif
X#ifdef EBADRPC
X    case EBADRPC: return "EBADRPC";
X#endif
X#ifdef EBADRQC
X    case EBADRQC: return "EBADRQC";
X#endif
X#ifdef EBADSLT
X    case EBADSLT: return "EBADSLT";
X#endif
X#ifdef EBFONT
X    case EBFONT: return "EBFONT";
X#endif
X#ifdef EBUSY
X    case EBUSY: return "EBUSY";
X#endif
X#ifdef ECHILD
X    case ECHILD: return "ECHILD";
X#endif
X#ifdef ECHRNG
X    case ECHRNG: return "ECHRNG";
X#endif
X#ifdef ECOMM
X    case ECOMM: return "ECOMM";
X#endif
X#ifdef ECONNABORTED
X    case ECONNABORTED: return "ECONNABORTED";
X#endif
X#ifdef ECONNREFUSED
X    case ECONNREFUSED: return "ECONNREFUSED";
X#endif
X#ifdef ECONNRESET
X    case ECONNRESET: return "ECONNRESET";
X#endif
X#ifdef EDEADLK
X#ifndef EWOULDBLOCK
X    case EDEADLK: return "EDEADLK";
X#else
X#if EWOULDBLOCK != EDEADLK
X    case EDEADLK: return "EDEADLK";
X#endif /* EWOULDBLOCK != EDEADLK */
X#endif /* EWOULDBLOCK */
X#endif /* EDEADLK */
X#ifdef EDEADLOCK
X    case EDEADLOCK: return "EDEADLOCK";
X#endif
X#ifdef EDESTADDRREQ
X    case EDESTADDRREQ: return "EDESTADDRREQ";
X#endif
X#ifdef EDIRTY
X    case EDIRTY: return "EDIRTY";
X#endif
X#ifdef EDOM
X    case EDOM: return "EDOM";
X#endif
X#ifdef EDOTDOT
X    case EDOTDOT: return "EDOTDOT";
X#endif
X#ifdef EDQUOT
X    case EDQUOT: return "EDQUOT";
X#endif
X#ifdef EDUPPKG
X    case EDUPPKG: return "EDUPPKG";
X#endif
X#ifdef EEXIST
X    case EEXIST: return "EEXIST";
X#endif
X#ifdef EFAULT
X    case EFAULT: return "EFAULT";
X#endif
X#ifdef EFBIG
X    case EFBIG: return "EFBIG";
X#endif
X#ifdef EHOSTDOWN
X    case EHOSTDOWN: return "EHOSTDOWN";
X#endif
X#ifdef EHOSTUNREACH
X    case EHOSTUNREACH: return "EHOSTUNREACH";
X#endif
X#ifdef EIDRM
X    case EIDRM: return "EIDRM";
X#endif
X#ifdef EINIT
X    case EINIT: return "EINIT";
X#endif
X#ifdef EINPROGRESS
X    case EINPROGRESS: return "EINPROGRESS";
X#endif
X#ifdef EINTR
X    case EINTR: return "EINTR";
X#endif
X#ifdef EINVAL
X    case EINVAL: return "EINVAL";
X#endif
X#ifdef EIO
X    case EIO: return "EIO";
X#endif
X#ifdef EISCONN
X    case EISCONN: return "EISCONN";
X#endif
X#ifdef EISDIR
X    case EISDIR: return "EISDIR";
X#endif
X#ifdef EISNAME
X    case EISNAM: return "EISNAM";
X#endif
X#ifdef ELBIN
X    case ELBIN: return "ELBIN";
X#endif
X#ifdef EL2HLT
X    case EL2HLT: return "EL2HLT";
X#endif
X#ifdef EL2NSYNC
X    case EL2NSYNC: return "EL2NSYNC";
X#endif
X#ifdef EL3HLT
X    case EL3HLT: return "EL3HLT";
X#endif
X#ifdef EL3RST
X    case EL3RST: return "EL3RST";
X#endif
X#ifdef ELIBACC
X    case ELIBACC: return "ELIBACC";
X#endif
X#ifdef ELIBBAD
X    case ELIBBAD: return "ELIBBAD";
X#endif
X#ifdef ELIBEXEC
X    case ELIBEXEC: return "ELIBEXEC";
X#endif
X#ifdef ELIBMAX
X    case ELIBMAX: return "ELIBMAX";
X#endif
X#ifdef ELIBSCN
X    case ELIBSCN: return "ELIBSCN";
X#endif
X#ifdef ELNRNG
X    case ELNRNG: return "ELNRNG";
X#endif
X#ifdef ELOOP
X    case ELOOP: return "ELOOP";
X#endif
X#ifdef EMFILE
X    case EMFILE: return "EMFILE";
X#endif
X#ifdef EMLINK
X    case EMLINK: return "EMLINK";
X#endif
X#ifdef EMSGSIZE
X    case EMSGSIZE: return "EMSGSIZE";
X#endif
X#ifdef EMULTIHOP
X    case EMULTIHOP: return "EMULTIHOP";
X#endif
X#ifdef ENAMETOOLONG
X    case ENAMETOOLONG: return "ENAMETOOLONG";
X#endif
X#ifdef ENAVAIL
X    case ENAVAIL: return "ENAVAIL";
X#endif
X#ifdef ENET
X    case ENET: return "ENET";
X#endif
X#ifdef ENETDOWN
X    case ENETDOWN: return "ENETDOWN";
X#endif
X#ifdef ENETRESET
X    case ENETRESET: return "ENETRESET";
X#endif
X#ifdef ENETUNREACH
X    case ENETUNREACH: return "ENETUNREACH";
X#endif
X#ifdef ENFILE
X    case ENFILE: return "ENFILE";
X#endif
X#ifdef ENOANO
X    case ENOANO: return "ENOANO";
X#endif
X#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
X    case ENOBUFS: return "ENOBUFS";
X#endif
X#ifdef ENOCSI
X    case ENOCSI: return "ENOCSI";
X#endif
X#ifdef ENODATA
X    case ENODATA: return "ENODATA";
X#endif
X#ifdef ENODEV
X    case ENODEV: return "ENODEV";
X#endif
X#ifdef ENOENT
X    case ENOENT: return "ENOENT";
X#endif
X#ifdef ENOEXEC
X    case ENOEXEC: return "ENOEXEC";
X#endif
X#ifdef ENOLCK
X    case ENOLCK: return "ENOLCK";
X#endif
X#ifdef ENOLINK
X    case ENOLINK: return "ENOLINK";
X#endif
X#ifdef ENOMEM
X    case ENOMEM: return "ENOMEM";
X#endif
X#ifdef ENOMSG
X    case ENOMSG: return "ENOMSG";
X#endif
X#ifdef ENONET
X    case ENONET: return "ENONET";
X#endif
X#ifdef ENOPKG
X    case ENOPKG: return "ENOPKG";
X#endif
X#ifdef ENOPROTOOPT
X    case ENOPROTOOPT: return "ENOPROTOOPT";
X#endif
X#ifdef ENOSPC
X    case ENOSPC: return "ENOSPC";
X#endif
X#ifdef ENOSR
X    case ENOSR: return "ENOSR";
X#endif
X#ifdef ENOSTR
X    case ENOSTR: return "ENOSTR";
X#endif
X#ifdef ENOSYM
X    case ENOSYM: return "ENOSYM";
X#endif
X#ifdef ENOSYS
X    case ENOSYS: return "ENOSYS";
X#endif
X#ifdef ENOTBLK
X    case ENOTBLK: return "ENOTBLK";
X#endif
X#ifdef ENOTCONN
X    case ENOTCONN: return "ENOTCONN";
X#endif
X#ifdef ENOTDIR
X    case ENOTDIR: return "ENOTDIR";
X#endif
X#ifdef ENOTEMPTY
X    case ENOTEMPTY: return "ENOTEMPTY";
X#endif
X#ifdef ENOTNAM
X    case ENOTNAM: return "ENOTNAM";
X#endif
X#ifdef ENOTSOCK
X    case ENOTSOCK: return "ENOTSOCK";
X#endif
X#ifdef ENOTTY
X    case ENOTTY: return "ENOTTY";
X#endif
X#ifdef ENOTUNIQ
X    case ENOTUNIQ: return "ENOTUNIQ";
X#endif
X#ifdef ENXIO
X    case ENXIO: return "ENXIO";
X#endif
X#ifdef EOPNOTSUPP
X    case EOPNOTSUPP: return "EOPNOTSUPP";
X#endif
X#ifdef EPERM
X    case EPERM: return "EPERM";
X#endif
X#ifdef EPFNOSUPPORT
X    case EPFNOSUPPORT: return "EPFNOSUPPORT";
X#endif
X#ifdef EPIPE
X    case EPIPE: return "EPIPE";
X#endif
X#ifdef EPROCLIM
X    case EPROCLIM: return "EPROCLIM";
X#endif
X#ifdef EPROCUNAVAIL
X    case EPROCUNAVAIL: return "EPROCUNAVAIL";
X#endif
X#ifdef EPROGMISMATCH
X    case EPROGMISMATCH: return "EPROGMISMATCH";
X#endif
X#ifdef EPROGUNAVAIL
X    case EPROGUNAVAIL: return "EPROGUNAVAIL";
X#endif
X#ifdef EPROTO
X    case EPROTO: return "EPROTO";
X#endif
X#ifdef EPROTONOSUPPORT
X    case EPROTONOSUPPORT: return "EPROTONOSUPPORT";
X#endif
X#ifdef EPROTOTYPE
X    case EPROTOTYPE: return "EPROTOTYPE";
X#endif
X#ifdef ERANGE
X    case ERANGE: return "ERANGE";
X#endif
X#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))
X    case EREFUSED: return "EREFUSED";
X#endif
X#ifdef EREMCHG
X    case EREMCHG: return "EREMCHG";
X#endif
X#ifdef EREMDEV
X    case EREMDEV: return "EREMDEV";
X#endif
X#ifdef EREMOTE
X    case EREMOTE: return "EREMOTE";
X#endif
X#ifdef EREMOTEIO
X    case EREMOTEIO: return "EREMOTEIO";
X#endif
X#ifdef EREMOTERELEASE
X    case EREMOTERELEASE: return "EREMOTERELEASE";
X#endif
X#ifdef EROFS
X    case EROFS: return "EROFS";
X#endif
X#ifdef ERPCMISMATCH
X    case ERPCMISMATCH: return "ERPCMISMATCH";
X#endif
X#ifdef ERREMOTE
X    case ERREMOTE: return "ERREMOTE";
X#endif
X#ifdef ESHUTDOWN
X    case ESHUTDOWN: return "ESHUTDOWN";
X#endif
X#ifdef ESOCKTNOSUPPORT
X    case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT";
X#endif
X#ifdef ESPIPE
X    case ESPIPE: return "ESPIPE";
X#endif
X#ifdef ESRCH
X    case ESRCH: return "ESRCH";
X#endif
X#ifdef ESRMNT
X    case ESRMNT: return "ESRMNT";
X#endif
X#ifdef ESTALE
X    case ESTALE: return "ESTALE";
X#endif
X#ifdef ESUCCESS
X    case ESUCCESS: return "ESUCCESS";
X#endif
X#ifdef ETIME
X    case ETIME: return "ETIME";
X#endif
X#ifdef ETIMEDOUT
X    case ETIMEDOUT: return "ETIMEDOUT";
X#endif
X#ifdef ETOOMANYREFS
X    case ETOOMANYREFS: return "ETOOMANYREFS";
X#endif
X#ifdef ETXTBSY
X    case ETXTBSY: return "ETXTBSY";
X#endif
X#ifdef EUCLEAN
X    case EUCLEAN: return "EUCLEAN";
X#endif
X#ifdef EUNATCH
X    case EUNATCH: return "EUNATCH";
X#endif
X#ifdef EUSERS
X    case EUSERS: return "EUSERS";
X#endif
X#ifdef EVERSION
X    case EVERSION: return "EVERSION";
X#endif
X#ifdef EWOULDBLOCK
X    case EWOULDBLOCK: return "EWOULDBLOCK";
X#endif
X#ifdef EXDEV
X    case EXDEV: return "EXDEV";
X#endif
X#ifdef EXFULL
X    case EXFULL: return "EXFULL";
X#endif
X    }
X    return "unknown error";
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SignalId --
X *
X *    Return a textual identifier for a signal number.
X *
X * Results:
X *    This procedure returns a machine-readable textual identifier
X *    that corresponds to sig.  The identifier is the same as the
X *    #define name in signal.h.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_SignalId(sig)
X    int sig;            /* Number of signal. */
X{
X    switch (sig) {
X#ifndef SIGIOT
X#ifdef SIGABRT
X    case SIGABRT: return "SIGABRT";
X#endif
X#endif /* SIGIOT */
X#ifdef SIGALRM
X    case SIGALRM: return "SIGALRM";
X#endif
X#ifdef SIGBUS
X    case SIGBUS: return "SIGBUS";
X#endif
X#ifdef SIGCHLD
X    case SIGCHLD: return "SIGCHLD";
X#endif
X#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
X    case SIGCLD: return "SIGCLD";
X#endif
X#ifdef SIGCONT
X    case SIGCONT: return "SIGCONT";
X#endif
X#ifdef SIGEMT
X    case SIGEMT: return "SIGEMT";
X#endif
X#ifdef SIGFPE
X    case SIGFPE: return "SIGFPE";
X#endif
X#ifdef SIGHUP
X    case SIGHUP: return "SIGHUP";
X#endif
X#ifdef SIGILL
X    case SIGILL: return "SIGILL";
X#endif
X#ifdef SIGINT
X    case SIGINT: return "SIGINT";
X#endif
X#ifdef SIGIO
X    case SIGIO: return "SIGIO";
X#endif
X#ifdef SIGIOT
X    case SIGIOT: return "SIGIOT";
X#endif
X#ifdef SIGKILL
X    case SIGKILL: return "SIGKILL";
X#endif
X#ifdef SIGLOST
X    case SIGLOST: return "SIGLOST";
X#endif
X#ifdef SIGPIPE
X    case SIGPIPE: return "SIGPIPE";
X#endif
X#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
X    case SIGPOLL: return "SIGPOLL";
X#endif
X#ifdef SIGPROF
X    case SIGPROF: return "SIGPROF";
X#endif
X#ifdef SIGPWR
X    case SIGPWR: return "SIGPWR";
X#endif
X#ifdef SIGQUIT
X    case SIGQUIT: return "SIGQUIT";
X#endif
X#ifdef SIGSEGV
X    case SIGSEGV: return "SIGSEGV";
X#endif
X#ifdef SIGSTOP
X    case SIGSTOP: return "SIGSTOP";
X#endif
X#ifdef SIGSYS
X    case SIGSYS: return "SIGSYS";
X#endif
X#ifdef SIGTERM
X    case SIGTERM: return "SIGTERM";
X#endif
X#ifdef SIGTRAP
X    case SIGTRAP: return "SIGTRAP";
X#endif
X#ifdef SIGTSTP
X    case SIGTSTP: return "SIGTSTP";
X#endif
X#ifdef SIGTTIN
X    case SIGTTIN: return "SIGTTIN";
X#endif
X#ifdef SIGTTOU
X    case SIGTTOU: return "SIGTTOU";
X#endif
X#ifdef SIGURG
X    case SIGURG: return "SIGURG";
X#endif
X#ifdef SIGUSR1
X    case SIGUSR1: return "SIGUSR1";
X#endif
X#ifdef SIGUSR2
X    case SIGUSR2: return "SIGUSR2";
X#endif
X#ifdef SIGVTALRM
X    case SIGVTALRM: return "SIGVTALRM";
X#endif
X#ifdef SIGWINCH
X    case SIGWINCH: return "SIGWINCH";
X#endif
X#ifdef SIGXCPU
X    case SIGXCPU: return "SIGXCPU";
X#endif
X#ifdef SIGXFSZ
X    case SIGXFSZ: return "SIGXFSZ";
X#endif
X    }
X    return "unknown signal";
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SignalMsg --
X *
X *    Return a human-readable message describing a signal.
X *
X * Results:
X *    This procedure returns a string describing sig that should
X *    make sense to a human.  It may not be easy for a machine
X *    to parse.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_SignalMsg(sig)
X    int sig;            /* Number of signal. */
X{
X    switch (sig) {
X#ifndef SIGIOT
X#ifdef SIGABRT
X    case SIGABRT: return "SIGABRT";
X#endif
X#endif /* SIGIOT */
X#ifdef SIGALRM
X    case SIGALRM: return "alarm clock";
X#endif
X#ifdef SIGBUS
X    case SIGBUS: return "bus error";
X#endif
X#ifdef SIGCHLD
X    case SIGCHLD: return "child status changed";
X#endif
X#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
X    case SIGCLD: return "child status changed";
X#endif
X#ifdef SIGCONT
X    case SIGCONT: return "continue after stop";
X#endif
X#ifdef SIGEMT
X    case SIGEMT: return "EMT instruction";
X#endif
X#ifdef SIGFPE
X    case SIGFPE: return "floating-point exception";
X#endif
X#ifdef SIGHUP
X    case SIGHUP: return "hangup";
X#endif
X#ifdef SIGILL
X    case SIGILL: return "illegal instruction";
X#endif
X#ifdef SIGINT
X    case SIGINT: return "interrupt";
X#endif
X#ifdef SIGIO
X    case SIGIO: return "input/output possible on file";
X#endif
X#ifdef SIGIOT
X    case SIGIOT: return "IOT instruction";
X#endif
X#ifdef SIGKILL
X    case SIGKILL: return "kill signal";
X#endif
X#ifdef SIGLOST
X    case SIGLOST: return "resource lost";
X#endif
X#ifdef SIGPIPE
X    case SIGPIPE: return "write on pipe with no readers";
X#endif
X#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
X    case SIGPOLL: return "input/output possible on file";
X#endif
X#ifdef SIGPROF
X    case SIGPROF: return "profiling alarm";
X#endif
X#ifdef SIGPWR
X    case SIGPWR: return "power-fail restart";
X#endif
X#ifdef SIGQUIT
X    case SIGQUIT: return "quit signal";
X#endif
X#ifdef SIGSEGV
X    case SIGSEGV: return "segmentation violation";
X#endif
X#ifdef SIGSTOP
X    case SIGSTOP: return "stop";
X#endif
X#ifdef SIGSYS
X    case SIGSYS: return "bad argument to system call";
X#endif
X#ifdef SIGTERM
X    case SIGTERM: return "software termination signal";
X#endif
X#ifdef SIGTRAP
X    case SIGTRAP: return "trace trap";
X#endif
X#ifdef SIGTSTP
X    case SIGTSTP: return "stop signal from tty";
X#endif
X#ifdef SIGTTIN
X    case SIGTTIN: return "background tty read";
X#endif
X#ifdef SIGTTOU
X    case SIGTTOU: return "background tty write";
X#endif
X#ifdef SIGURG
X    case SIGURG: return "urgent I/O condition";
X#endif
X#ifdef SIGUSR1
X    case SIGUSR1: return "user-defined signal 1";
X#endif
X#ifdef SIGUSR2
X    case SIGUSR2: return "user-defined signal 2";
X#endif
X#ifdef SIGVTALRM
X    case SIGVTALRM: return "virtual time alarm";
X#endif
X#ifdef SIGWINCH
X    case SIGWINCH: return "window changed";
X#endif
X#ifdef SIGXCPU
X    case SIGXCPU: return "exceeded CPU time limit";
X#endif
X#ifdef SIGXFSZ
X    case SIGXFSZ: return "exceeded file size limit";
X#endif
X    }
X    return "unknown signal";
X}
END_OF_FILE
if test 14884 -ne `wc -c <'tcl6.1/tclUnixStr.c'`; then
    echo shar: \"'tcl6.1/tclUnixStr.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclUnixStr.c'
fi
echo shar: End of archive 12 \(of 33\).
cp /dev/null ark12isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 33 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].