Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume26/veos-2.0/part12

Text File | 1993-04-25 | 65.3 KB | 2,913 lines

Newsgroups: comp.sources.unix
From: [e-mail] (Geoffery Coco)
Subject: v26i195: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part12/16
Sender: [e-mail]
Approved: [e-mail]

Submitted-By: [e-mail] (Geoffery Coco)
Posting-Number: Volume 26, Issue 195
Archive-Name: veos-2.0/part12

#! /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 16)."
# Contents:  src/kernel_current/nancy/nancy_fundamental.c
#   src/xlisp/xcore/c/xlcont.c
# Wrapped by [e-mail] on Sun Apr 25 23:10:44 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/kernel_current/nancy/nancy_fundamental.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/kernel_current/nancy/nancy_fundamental.c'\"
else
echo shar: Extracting \"'src/kernel_current/nancy/nancy_fundamental.c'\" \(31245 characters\)
sed "s/^X//" >'src/kernel_current/nancy/nancy_fundamental.c' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: nancy.c                                    *
X *                                            *
X * August 21, 1990: the world(s)' interface to grouples.                       *
X *                                            *
X * by Geoffrey P. Coco at the HITLab, Seattle.                          *
X *                                            *
X ****************************************************************************************/
X
X/****************************************************************************************
X * Copyright (C) 1992  Geoffrey P. Coco, Human Interface Technology Lab, Seattle    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X *                          includes galore                    */
X
X#include "kernel.h"
X#include <string.h>
X#include <malloc.h>
X#include <varargs.h>
X
X/****************************************************************************************/
X
X
X/****************************************************************************************
X *                     forward function declarations                */
X
X
X/* nancy setup and preprocessing */
X
XTVeosErr Nancy_Init();
X
X
X/* fundamental grouple data structure utils */
X
XTVeosErr Nancy_NewGrouple();
XTVeosErr Nancy_DisposeGrouple();
XTVeosErr Nancy_CopyGrouple();
XTVeosErr Nancy_CreateElement();
XTVeosErr Nancy_DisposeElement();
XTVeosErr Nancy_CopyElement();
XTVeosErr Nancy_NewElementsInGrouple();
XTVeosErr Nancy_DeleteElementsInGrouple();
X
X
X/* related public nancy utils */
X
XTVeosErr Nancy_GroupleToStream();
XTVeosErr Nancy_ElementToStream();
XTVeosErr Nancy_GroupleToStreamWithLevel();
XTVeosErr Nancy_ElementToStreamWithLevel();
X
XTVeosErr Nancy_EmptyGrouple();
XTVeosErr Nancy_InsertEltList();
XTVeosErr Nancy_CopyEltList();
XTVeosErr Nancy_ConcatGrouple();
X
XTVeosErr Nancy_GetFileSize();
XTVeosErr Nancy_FileToGrouple();
XTVeosErr Nancy_TrapErr();
X
X
X/* private nancy utils */
X
XTVeosErr Nancy_ResizeEltList();
XTVeosErr Nancy_SetupTypeSizes();
X
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X *                setup and preprocessing                    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_Init                                    */
X
XTVeosErr Nancy_Init()
X{
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_MEM_ERR;
X    LINE_COUNT = 0;
X    NANCY_MINTIME = 0;
X    NANCY_TIME = 1;
X
X    /** setup runtime hash table for element sizes **/
X
X    iSuccess = Nancy_SetupFastMem();
X    if (iSuccess == VEOS_SUCCESS) {
X
X    /** StreamToElement assumes global buffer **/
X
X    if (NEWPTR(NANCY_BUF, char *, VEOS_GROUPLE_BUF_SIZE)) {
X
X        NIL_ELT.iType = GR_unspecified;
X        NIL_ELT.u.pU = nil;
X        NIL_ELT.tLastMod = 0x7FFFFFFF;
X        NIL_ELT.iFlags = 0;
X
X        iSuccess = Nancy_NewGrouple(&GR_INSPACE);
X        if (iSuccess == VEOS_SUCCESS) {
X
X        iSuccess = Nancy_NewGrouple(&WORK_SPACE);
X        }
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_Init */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *             fundamental nancy data structure utils                *
X ****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_NewGrouple                                    */
X
XTVeosErr Nancy_NewGrouple(hDestGrouple)
X    THGrouple        hDestGrouple;
X{
X    TVeosErr        iSuccess;
X    TPGrouple        pNewGrouple;
X
X
X    iSuccess = VEOS_FAILURE;                       /* pessimism */
X
X
X    if (hDestGrouple) {                    /* sanity check */
X
X    iSuccess = VEOS_MEM_ERR;            /* more pessimism */
X
X    *hDestGrouple = (TPGrouple) nil;
X
X
X
X    /** allocate the grouple structure itself **/
X
X    iSuccess = Shell_NewBlock(TYPE_SIZES[GR_grouple], &pNewGrouple,
X                  "grouple");
X
X    if (iSuccess == VEOS_SUCCESS) {
X        pNewGrouple->pEltList = nil;
X        pNewGrouple->iElts = 0;
X        pNewGrouple->iFlags = 0;
X
X        *hDestGrouple = pNewGrouple;
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_NewGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_DisposeGrouple                                    */
X
XTVeosErr Nancy_DisposeGrouple(pDeadGrouple)
X    TPGrouple        pDeadGrouple;
X{
X    TVeosErr        iSuccess;
X    int            iEltIndex;
X    TPElt        pEltList;
X
X    iSuccess = VEOS_SUCCESS;            /* what could go wrong? */
X
X    if (pDeadGrouple) {                /* sanity check */
X
X
X    /** clear all elements from grouple **/
X
X    Nancy_DeleteElementsInGrouple(pDeadGrouple, 0, pDeadGrouple->iElts);
X
X
X    /** deallocate element list itself **/
X
X    Nancy_ResizeEltList(pDeadGrouple, 0);
X
X
X    /** deallocate the grouple structure itself **/
X
X    Shell_ReturnBlock(pDeadGrouple, TYPE_SIZES[GR_grouple], "grouple");
X    }
X
X
X    return(iSuccess);
X
X    } /* Nancy_DisposeGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_CopyGrouple                                    */
X
XTVeosErr Nancy_CopyGrouple(pSrcGrouple, pDestGrouple)
X    TPGrouple        pSrcGrouple;
X    TPGrouple        pDestGrouple;
X{
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;                          /* pessimism */
X
X    if (pSrcGrouple && pDestGrouple) {                /* sanity check */
X
X    /** allocate element list enough for all copied elements **/
X
X    iSuccess = Nancy_ResizeEltList(pDestGrouple, pSrcGrouple->iElts);
X    if (iSuccess == VEOS_SUCCESS) {
X
X
X        iSuccess = Nancy_CopyEltList(pSrcGrouple->pEltList,
X                     pDestGrouple->pEltList,
X                     pSrcGrouple->iElts);
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_CopyGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_CreateElement                                    */
X
XTVeosErr Nancy_CreateElement(pDestElt, iType, iSize)
X    TPElt        pDestElt;
X    int            iType, iSize;
X{
X    TVeosErr        iSuccess;
X    str15        sTypeName;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pDestElt) {        /* sane? */
X
X    pDestElt->iType = iType;
X
X    iSuccess = VEOS_MEM_ERR;
X
X    switch (iType) {
X
X    case GR_grouple:
X        iSuccess = Nancy_NewGrouple(&pDestElt->u.pGr);
X        break;
X
X    case GR_vector:
X        iSuccess = Nancy_NewGrouple(&pDestElt->u.pGr);
X        pDestElt->iType = GR_vector;
X        break;
X
X    case GR_string:
X    case GR_prim:
X        if (iSize > 0) {
X        if (NEWPTR(pDestElt->u.pS, char *, iSize))
X            iSuccess = VEOS_SUCCESS;
X        }
X        else {
X        pDestElt->u.pS = nil;
X        iSuccess = VEOS_SUCCESS;
X        }
X        break;
X
X    case GR_float:
X    case GR_int:
X    case GR_these:
X    case GR_theseall:
X    case GR_some:
X    case GR_any:
X    case GR_here:
X        /* nothing to allocate */
X        iSuccess = VEOS_SUCCESS;
X        break;
X
X    case GR_unspecified:
X    default:
X        pDestElt->u.pU = nil;
X        iSuccess = VEOS_SUCCESS;
X        break;
X
X        } /* switch */
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_CreateElement */
X/****************************************************************************************/
X
X
X
X
X
X/****************************************************************************************
X * Nancy_DisposeElement                                    */
X
XTVeosErr Nancy_DisposeElement(pDestElt)
X    TPElt        pDestElt;
X{
X    TVeosErr        iSuccess;
X    str15        sTypeName;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pDestElt) {
X
X    /** recurs to sublist if necessary **/
X    switch (pDestElt->iType) {
X
X    case GR_grouple:
X    case GR_vector:
X        Nancy_DisposeGrouple(pDestElt->u.pGr);
X        break;
X
X    case GR_string:
X        DUMP(pDestElt->u.pS);
X        break;
X
X    case GR_float:
X    case GR_int:
X    case GR_these:
X    case GR_theseall:
X    case GR_some:
X    case GR_any:
X    case GR_here:
X    case GR_unspecified:
X    default:
X        /* nothing allocated */
X        break;
X
X        } /* switch */
X
X    *pDestElt = NIL_ELT;
X
X    iSuccess = VEOS_SUCCESS;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_DisposeElement */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_CopyElement                                    */
X
XTVeosErr Nancy_CopyElement(pSrcElt, pDestElt)
X    TPElt        pSrcElt, pDestElt;
X{
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pSrcElt && pDestElt && pSrcElt->iType == pDestElt->iType) {    /* sane? */
X
X    iSuccess = VEOS_SUCCESS;
X
X    switch (pSrcElt->iType) {
X
X    case GR_grouple:
X    case GR_vector:
X        iSuccess = Nancy_CopyGrouple(pSrcElt->u.pGr,
X                     pDestElt->u.pGr);
X        break;
X
X    case GR_float:
X    case GR_int:
X    case GR_these:
X    case GR_some:
X        pDestElt->u.iVal = pSrcElt->u.iVal;
X        break;
X
X    case GR_theseall:
X    case GR_any:
X    case GR_here:
X        /** no data to copy **/
X        break;
X
X    case GR_string:
X    case GR_prim:
X        if (pDestElt->u.pS)
X        strcpy(pDestElt->u.pS, pSrcElt->u.pS);
X        else
X        pDestElt->u.pS = strdup(pSrcElt->u.pS);
X        break;
X
X    case GR_unspecified:
X        break;
X
X        } /* switch */
X
X    pDestElt->tLastMod = pSrcElt->tLastMod;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_CopyElement */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_NewElementsInGrouple                                */
X
XTVeosErr Nancy_NewElementsInGrouple(pDestGrouple, iInsertElt, iElts, iType, iSize)
X    TPGrouple        pDestGrouple;
X    int            iInsertElt, iElts, iType, iSize;
X{
X    TVeosErr        iSuccess;
X    TPElt        pEltList;
X    int            iIndex, iOldElts, iLimit;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pDestGrouple) {
X
X    iOldElts = pDestGrouple->iElts;        /* ResizeEltList() clobbers this field */
X
X    iSuccess = Nancy_ResizeEltList(pDestGrouple,
X                       iOldElts > iInsertElt ?
X                       (iOldElts + iElts) : (iInsertElt + iElts));
X    if (iSuccess == VEOS_SUCCESS) {
X
X
X
X        /** use stack var for speed **/
X
X        pEltList = pDestGrouple->pEltList;
X
X
X
X        /** all elements which occur after insertion point are shifted down **/
X
X        iIndex = iOldElts + iElts - 1;
X        iLimit = iInsertElt + iElts;
X
X        while (iIndex >= iLimit) {
X
X        pEltList[iIndex] = pEltList[iIndex - iElts];
X
X        iIndex --;
X        }
X
X
X        /** initialize new elements that may have been created by list growth **/
X
X        iIndex = iOldElts;
X        iLimit = iInsertElt + iElts;
X
X        while (iIndex < iLimit) {
X
X        pEltList[iIndex] = NIL_ELT;
X
X        iIndex ++;
X        }
X
X
X        /** attempt to create actual element data block, if requested **/
X
X        iIndex = iInsertElt;
X        iLimit = iInsertElt + iElts;
X        while (iIndex < iLimit && iSuccess == VEOS_SUCCESS) {
X
X        iSuccess = Nancy_CreateElement(&pEltList[iIndex], iType, iSize);
X
X        iIndex ++;
X        }
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_NewElementsInGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_DeleteElementsInGrouple                            */
X
XTVeosErr Nancy_DeleteElementsInGrouple(pGrouple, iStartElt, iElts)
X    TPGrouple        pGrouple;
X    int            iStartElt, iElts;
X{
X    TVeosErr        iSuccess;
X    int            iIndex, iEndElt, iNewElts;
X    TPElt        pEltList;
X
X    iSuccess = VEOS_SUCCESS;
X    iEndElt = iStartElt + iElts;
X
X    if (pGrouple &&
X    iElts > 0) {
X
X    if (pGrouple->iElts >= iEndElt) {        /* sane? */
X
X
X        /** deallocate specific element data **/
X
X        iIndex = iStartElt;
X        while (iIndex < iEndElt) {
X
X        Nancy_DisposeElement(&pGrouple->pEltList[iIndex]);
X
X        iIndex ++;
X        }
X
X
X        iSuccess = Nancy_DownShift(pGrouple, iStartElt, iElts);
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_DeleteElementsInGrouple */
X/****************************************************************************************/
X
X
X/****************************************************************************************
X                     Data Conversion
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_ElementToStream                                */
X
XTVeosErr Nancy_ElementToStream(pElt, pStream)
X    TPElt        pElt;
X    FILE        *pStream;
X{
X    TVeosErr        iSuccess;
X    FILE        *pSave;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pElt && pStream) {                /* sane? */
X
X    pSave = GR_STREAM;
X    GR_STREAM = pStream;
X
X    iSuccess = Nancy_ElementToStreamAux(pElt, 0);
X
X    GR_STREAM = pSave;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_ElementToStream */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_GroupleToStream                                */
X
XTVeosErr Nancy_GroupleToStream(pGrouple, pStream)
X    TPGrouple        pGrouple;
X    FILE        *pStream;
X{
X    TElt        elt;
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pGrouple && pStream) {                /* sane? */
X
X    elt = NIL_ELT;
X    elt.iType = GR_grouple;
X    elt.u.pGr = pGrouple;
X
X    iSuccess = Nancy_ElementToStream(&elt, pStream);
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_GroupleToStream */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_ElementToStreamWithLevel                            */
X
XTVeosErr Nancy_ElementToStreamWithLevel(pElt, pStream, iLevel)
X    TPElt        pElt;
X    FILE        *pStream;
X    int            iLevel;
X{
X    TVeosErr        iSuccess;
X    FILE        *pSave;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pElt && pStream) {                /* sane? */
X
X    pSave = GR_STREAM;
X    GR_STREAM = pStream;
X
X    iSuccess = Nancy_ElementToStreamAux(pElt, iLevel);
X
X    GR_STREAM = pSave;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_ElementToStreamWithLevel */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_GroupleToStreamWithLevel                            */
X
XTVeosErr Nancy_GroupleToStreamWithLevel(pGrouple, pStream, iLevel)
X    TPGrouple        pGrouple;
X    FILE        *pStream;
X    int            iLevel;
X{
X    TElt        elt;
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pGrouple && pStream) {                /* sane? */
X
X    elt = NIL_ELT;
X    elt.iType = GR_grouple;
X    elt.u.pGr = pGrouple;
X
X    iSuccess = Nancy_ElementToStreamWithLevel(&elt, pStream, iLevel);
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_GroupleToStreamWithLevel */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X                   Grouple -> Network Message
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_EltToMessage                                    */
X
XTVeosErr Nancy_EltToMessage(pElt, pBuffer, pLen)
X    TPElt        pElt;
X    char        *pBuffer;
X    int            *pLen;
X{
X    int            iLen, iType;
X
X    if (pElt) {                /* sane? */
X
X    iType = pElt->iType;
X
X    /** first part of message element is element type **/
X    /** assume pBuffer is aligned **/
X
X    *(int *) pBuffer = htonl(iType);
X
X    pBuffer += 4;
X    *pLen += 4;
X
X    switch (iType) {
X
X    case GR_grouple:
X    case GR_vector:
X        iLen = 0;
X        Nancy_GroupleToMessage(pElt->u.pGr, pBuffer, &iLen);
X        break;
X
X    case GR_int:
X    case GR_float:
X        *(long *) pBuffer = htonl(pElt->u.iVal);
X        iLen = 4;
X        break;
X
X    case GR_string:
X    case GR_prim:
X        strcpy(pBuffer, pElt->u.pS);
X        iLen = MEMSIZE(strlen(pElt->u.pS) + 1);
X        break;
X
X    case GR_unspecified:
X    default:
X        iLen = 0;
X        break;
X
X        } /* switch */
X
X    *pLen += iLen;
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_EltToMessage */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_GroupleToMessage                                */
X
XTVeosErr Nancy_GroupleToMessage(pGrouple, pBuffer, pLen)
X    TPGrouple        pGrouple;
X    char        *pBuffer;
X    int            *pLen;
X{
X    int            iEltIndex, iElts, iLen;
X    TPElt        pEltList;
X
X    if (pGrouple) {                /* sane? */
X
X
X    /** use stack vars for speed **/
X
X    iElts = pGrouple->iElts;
X    pEltList = pGrouple->pEltList;
X
X
X
X    /** first code of protocol is number of elements **/
X
X    *(int *) pBuffer = htonl(iElts);    /** assume pBuffer is aligned **/
X
X    pBuffer += 4;
X    *pLen += 4;
X
X
X    for (iEltIndex = 0; iEltIndex < iElts; iEltIndex ++) {
X
X        iLen = 0;
X
X        /** invoke recursive translation **/
X
X        Nancy_EltToMessage(&pEltList[iEltIndex], pBuffer, &iLen);
X
X        pBuffer += iLen;
X        *pLen += iLen;
X        }
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_GroupleToMessage */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X *                related public utils                    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_EmptyGrouple                                    */
X
XTVeosErr Nancy_EmptyGrouple(pGrouple)
X    TPGrouple        pGrouple;
X{
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pGrouple && pGrouple->iElts > 0) {
X
X    iSuccess = Nancy_DeleteElementsInGrouple(pGrouple, 0, pGrouple->iElts);
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_EmptyGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_InsertEltList(pSrcList, iSrcElts, pDestGrouple, iStartElt)
X    TPElt        pSrcList;
X    int            iSrcElts, iStartElt;
X    TPGrouple        pDestGrouple;
X{
X    TVeosErr        iSuccess;
X    int            iSrcIndex;
X    TPElt        pDestList;
X
X
X    iSuccess = VEOS_SUCCESS;
X
X    if (pSrcList && pDestGrouple) {        /* sane? */
X
X    iSuccess = Nancy_NewElementsInGrouple(pDestGrouple,
X                          iStartElt,
X                          iSrcElts,
X                          GR_unspecified, 0);
X    if (iSuccess == VEOS_SUCCESS) {
X
X
X        /** transfer each element from chosen starting locations **/
X
X        pDestList = &pDestGrouple->pEltList[iStartElt];
X        iSrcIndex = 0;
X        while (iSrcIndex < iSrcElts) {
X
X        pDestList[iSrcIndex] = pSrcList[iSrcIndex];
X
X
X        /** set default vals for src elements **/
X        /** in case the caller disposes the src elt list after the call **/
X
X        pSrcList[iSrcIndex++] = NIL_ELT;
X        }
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_InsertEltList */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_CopyEltList(pSrcList, pDestList, iElts)
X    TPElt        pSrcList, pDestList;
X    int            iElts;
X{
X    int            iEltIndex;
X    TVeosErr        iSuccess = VEOS_SUCCESS;
X
X
X    if (pSrcList && pDestList) {        /* sane? */
X
X    /** copy the grouple element list, one elt at a time **/
X
X    iSuccess = VEOS_SUCCESS;
X    iEltIndex = 0;
X    while (iEltIndex < iElts && iSuccess == VEOS_SUCCESS) {
X
X        pDestList[iEltIndex] = pSrcList[iEltIndex];
X
X        if (pSrcList[iEltIndex].iType != GR_unspecified) {
X
X        iSuccess = Nancy_CreateElement(&pDestList[iEltIndex],
X                           pSrcList[iEltIndex].iType, 0);
X        if (iSuccess == VEOS_SUCCESS)
X
X            iSuccess = Nancy_CopyElement(&pSrcList[iEltIndex],
X                         &pDestList[iEltIndex]);
X        }
X
X        iEltIndex ++;
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_CopyEltList */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_ConcatGrouple                                    */
X
XTVeosErr Nancy_ConcatGrouple(pSrcGrouple, pDestGrouple)
X    TPGrouple        pSrcGrouple;
X    TPGrouple        pDestGrouple;
X{
X    TVeosErr        iSuccess;
X    int            iOldElts;
X
X    iSuccess = VEOS_FAILURE;                          /* pessimism */
X
X    if (pSrcGrouple && pDestGrouple) {                /* sanity check */
X
X
X    /** allocate element list enough for all copied elements **/
X
X    iOldElts = pDestGrouple->iElts;
X    iSuccess = Nancy_ResizeEltList(pDestGrouple,
X                       iOldElts + pSrcGrouple->iElts);
X    if (iSuccess == VEOS_SUCCESS) {
X
X
X        iSuccess = Nancy_CopyEltList(pSrcGrouple->pEltList,
X                     &pDestGrouple->pEltList[iOldElts],
X                     pSrcGrouple->iElts);
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_ConcatGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_EltIdentical(pLeftElt, pRightElt)
X    TPElt        pRightElt, pLeftElt;
X{
X    TVeosErr        iSuccess;
X    int            iType;
X    boolean        bSame;
X    char        *pGenericRight, *pGenericLeft, *pMax;
X
X
X    iSuccess = VEOS_FAILURE;
X    bSame = FALSE;
X
X    if (pLeftElt == pRightElt)
X    bSame = TRUE;
X
X    else if (pLeftElt &&
X         pRightElt &&
X         pLeftElt->iType == pRightElt->iType) {
X
X    iType = pLeftElt->iType;
X    switch (iType) {
X
X    case GR_float:
X        if (pLeftElt->u.fVal == pRightElt->u.fVal)
X        bSame = TRUE;
X        break;
X
X    case GR_int:
X        if (pLeftElt->u.iVal == pRightElt->u.iVal)
X        bSame = TRUE;
X        break;
X
X    case GR_string:
X    case GR_prim:
X        if (strcmp(pLeftElt->u.pS, pRightElt->u.pS) == 0)
X        bSame = TRUE;
X        break;
X
X    case GR_unspecified:
X    default:
X        bSame = TRUE;
X        break;
X
X        } /* switch */
X    }
X
X    if (bSame)
X    iSuccess = VEOS_SUCCESS;
X
X    return(iSuccess);
X
X    } /* Nancy_EltIdentical */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_TrapErr                                    */
X
XTVeosErr Nancy_TrapErr(iErr)
X    TVeosErr        iErr;
X{
X    switch(iErr) {
X
X    case NANCY_EndOfGrouple:
X    fprintf(stderr, "nancy %s: end of grouple reached\n", WHOAMI);
X    break;
X
X    case NANCY_MisplacedLeftBracket:
X    fprintf(stderr, "nancy %s: misplaced '[', near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case NANCY_MisplacedRightBracket:
X    fprintf(stderr, "nancy %s: misplaced ']', near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case NANCY_MissingRightBracket:
X    fprintf(stderr, "nancy %s: missing ']', near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case NANCY_BadType:
X    fprintf(stderr, "nancy %s: bad element type, near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case NANCY_NoTypeMatch:
X    fprintf(stderr, "nancy %s: unknown data type, near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case VEOS_EOF:
X    fprintf(stderr, "nancy %s: end of stream reached permaturely, near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case VEOS_MEM_ERR:
X    fprintf(stderr, "nancy %s: memory error\n", WHOAMI);
X    break;
X
X    case VEOS_FAILURE:
X    fprintf(stderr, "nancy %s: bad parameters\n", WHOAMI);
X    break;
X
X    case VEOS_SUCCESS:
X    fprintf(stderr, "nancy %s: success\n", WHOAMI);
X    break;
X
X    case NANCY_NoMatch:
X    fprintf(stderr, "nancy %s: no matches were found\n", WHOAMI);
X    break;
X
X    case NANCY_NotSupported:
X    fprintf(stderr, "nancy %s: that operation not currently supported\n", WHOAMI);
X    break;
X
X    case NANCY_SrcTooShort:
X    fprintf(stderr, "nancy %s: no match - source grouple shorter than pattern\n", WHOAMI);
X    break;
X
X    case NANCY_PatTooShort:
X    fprintf(stderr, "nancy %s: no match - pattern shorter than source grouple\n", WHOAMI);
X    break;
X
X    default:
X    fprintf(stderr, "nancy %s: unknown error: %d\n", WHOAMI, iErr);
X    break;
X
X    } /* switch */
X
X    } /* Nancy_TrapErr */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *                       private routines                    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_ResizeEltList                                    */
X
XTVeosErr Nancy_ResizeEltList(pDestGrouple, iNewElts)
X    TPGrouple        pDestGrouple;
X    int            iNewElts;
X{
X    TVeosErr        iSuccess;
X    TPElt        pEltList;
X    int            iIsLen, iShouldLen;
X
X    iSuccess = VEOS_SUCCESS;
X
X    if (pDestGrouple) {                /* sane? */
X
X
X    /** if element ptr array is too long or too short, alter size **/
X
X    iShouldLen = ELTS_ALLOCATED(iNewElts);
X    iIsLen = ELTS_ALLOCATED(pDestGrouple->iElts);
X
X    if (iShouldLen != iIsLen) {
X
X        iSuccess = VEOS_MEM_ERR;
X        pEltList = nil;
X
X
X        /**---------------------------------------------------**/
X        /** use fast in-house memory scheme for element lists **/
X        /**---------------------------------------------------**/
X
X        if (iShouldLen <= 0) {
X
X        /** want to dispose all elt list memory **/
X
X        if (pDestGrouple->pEltList)
X            Shell_ReturnBlock(pDestGrouple->pEltList,
X                      iIsLen * sizeof(TElt), "elt list");
X        }
X
X        else if (pDestGrouple->pEltList) {
X
X
X        /** want to resize elt list array **/
X
X        iSuccess = Shell_NewBlock(iShouldLen * sizeof(TElt),
X                      &pEltList, "bigger elt list");
X        if (iSuccess == VEOS_SUCCESS) {
X
X            bcopy(pDestGrouple->pEltList,
X              pEltList,
X              (iIsLen < iShouldLen ? iIsLen : iShouldLen) * sizeof(TElt));
X
X            Shell_ReturnBlock(pDestGrouple->pEltList,
X                      iIsLen * sizeof(TElt), "smaller elt list");
X            }
X        }
X
X
X        else {
X        /** want to create elt list for first time **/
X
X        iSuccess = Shell_NewBlock(iShouldLen * sizeof(TElt),
X                      &pEltList, "elt list");
X        }
X
X        /** attach new element array (contains old contents) **/
X
X        if (iSuccess = VEOS_SUCCESS)
X        pDestGrouple->pEltList = pEltList;
X        }
X
X    pDestGrouple->iElts = iNewElts;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_ResizeEltList */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_DownShift(pGrouple, iStartElt, iElts)
X    TPGrouple        pGrouple;
X    int            iStartElt, iElts;
X{
X    TVeosErr        iSuccess;
X    TPElt        pEltList;
X    int            iNewElts, iIndex;
X
X
X    /** use stack vars for speed **/
X
X    pEltList = pGrouple->pEltList;
X    iNewElts = pGrouple->iElts - iElts;
X
X
X
X    iIndex = iStartElt;
X    while (iIndex < iNewElts) {
X
X    pEltList[iIndex] = pEltList[iIndex + iElts];
X
X    iIndex ++;
X    }
X
X    iSuccess = Nancy_ResizeEltList(pGrouple, iNewElts);
X
X    return(iSuccess);
X
X    } /* Nancy_DownShift */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XTVeosErr Nancy_ElementToStreamAux(pElt, iLevel)
X    TPElt        pElt;
X    int            iLevel;
X{
X    TPElt        pEltList;
X    int            iElts, iEltIndex;
X    str63        sHostName;
X
X    if (pElt) {                /* sane? */
X
X    Nancy_StreamTabs(iLevel, GR_STREAM);
X
X    if (TESTFLAG(NANCY_EltMarkMask, pElt->iFlags))
X        fprintf(stderr, "> ");
X
X    PRINT_TIME(pElt->tLastMod, stderr);
X
X
X    switch (pElt->iType) {
X
X    case GR_vector:
X        fprintf(GR_STREAM, "#");
X
X    case GR_grouple:
X        fprintf(GR_STREAM, "[\n");
X
X        pEltList = pElt->u.pGr->pEltList;
X        iElts = pElt->u.pGr->iElts;
X
X        for (iEltIndex = 0; iEltIndex < iElts; iEltIndex ++) {
X
X        /** recurs */
X        Nancy_ElementToStreamAux(&pEltList[iEltIndex], iLevel + 1);
X        }
X
X        Nancy_StreamTabs(iLevel, GR_STREAM);
X        fprintf(GR_STREAM, "]\n");
X        break;
X
X    case GR_here:
X        fprintf(GR_STREAM, "^\n");
X        break;
X
X    case GR_some:
X        fprintf(GR_STREAM, "*%d\n", pElt->u.iVal);
X        break;
X
X    case GR_any:
X        fprintf(GR_STREAM, "**\n");
X        break;
X
X    case GR_these:
X        fprintf(GR_STREAM, "@%d\n", pElt->u.iVal);
X        break;
X
X    case GR_theseall:
X        fprintf(GR_STREAM, "@@\n");
X        break;
X
X    case GR_float:
X        fprintf(GR_STREAM, "%.2f\n", pElt->u.fVal);
X        break;
X
X    case GR_int:
X        fprintf(GR_STREAM, "%d\n", pElt->u.iVal);
X        break;
X
X    case GR_string:
X        fprintf(GR_STREAM, "\"%s\"\n", pElt->u.pS);
X        break;
X
X    case GR_prim:
X        fprintf(GR_STREAM, "'prim' %s\n", pElt->u.pS);
X        break;
X
X    case GR_unspecified:
X        fprintf(GR_STREAM, "()\n");
X        break;
X
X    default:
X        break;
X
X        } /* switch */
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_ElementToStreamAux */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_TypeToString(iType, sName)
X    int        iType;
X    char    *sName;
X{
X    if (sName) {
X
X    switch (iType) {
X
X    case GR_grouple:
X        strcpy(sName, "grouple");
X        break;
X    case GR_vector:
X        strcpy(sName, "vector");
X        break;
X    case GR_float:
X        strcpy(sName, "float");
X        break;
X    case GR_int:
X        strcpy(sName, "int");
X        break;
X    case GR_string:
X        strcpy(sName, "string");
X        break;
X    case GR_prim:
X        strcpy(sName, "prim");
X        break;
X    case GR_unspecified:
X        strcpy(sName, "unspecified");
X        break;
X    case GR_these:
X        strcpy(sName, "these");
X        break;
X    case GR_theseall:
X        strcpy(sName, "theseall");
X        break;
X    case GR_some:
X        strcpy(sName, "some");
X        break;
X    case GR_any:
X        strcpy(sName, "any");
X        break;
X    case GR_here:
X        strcpy(sName, "here");
X        break;
X    case GR_mark:
X        strcpy(sName, "mark");
X        break;
X    case GR_touch:
X        strcpy(sName, "touch");
X        break;
X    default:
X        break;
X
X        } /* switch */
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_TypeToString */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_StreamTabs(iTabs, pStream)
X    int        iTabs;
X    FILE    *pStream;
X{
X    while (iTabs-- > 0)
X    fprintf(pStream, "    ");
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_StreamTabs */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_SetupFastMem()
X{
X    TVeosErr        iSuccess;
X    int            i;
X
X    iSuccess = VEOS_SUCCESS;
X
X    TYPE_SIZES[GR_grouple] = TYPE_SIZES[GR_vector] = sizeof(TGrouple);
X
X    TYPE_SIZES[GR_prim] = TYPE_SIZES[GR_string] = 0;
X
X    TYPE_SIZES[GR_float] = 0;
X    TYPE_SIZES[GR_int] = 0;
X    TYPE_SIZES[GR_these] = 0;
X    TYPE_SIZES[GR_theseall] = 0;
X    TYPE_SIZES[GR_some] = 0;
X    TYPE_SIZES[GR_any] = 0;
X    TYPE_SIZES[GR_here] = 0;
X
X
X    /* the elt list for the empty grouple is nil */
X    ALLOC_ELTS[0] = 0;
X
X    /* optimize for pair-type grouples coming from lisp */
X    ALLOC_ELTS[1] = 2;
X    ALLOC_ELTS[2] = 2;
X
X    for (i = 3; i < NANCY_AllocHashMax; i++)
X    ALLOC_ELTS[i] = ELTS_TO_ALLOCATE(i);
X
X    return(iSuccess);
X
X    } /* Nancy_SetupFastMem */
X/****************************************************************************************/
X
X
X
X
X
END_OF_FILE
if test 31245 -ne `wc -c <'src/kernel_current/nancy/nancy_fundamental.c'`; then
    echo shar: \"'src/kernel_current/nancy/nancy_fundamental.c'\" unpacked with wrong size!
fi
# end of 'src/kernel_current/nancy/nancy_fundamental.c'
fi
if test -f 'src/xlisp/xcore/c/xlcont.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlcont.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlcont.c'\" \(30247 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlcont.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlcont
X* RCS:          $Header: xlcont.c,v 1.4 89/11/25 05:14:27 mayer Exp $
X* Description:  xlisp special forms
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:14:10 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlcont.c,v 1.4 89/11/25 05:14:27 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,xlvalue;
Xextern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
Xextern LVAL s_svalue,s_sfunction,s_splist;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_comma,s_comat;
Xextern LVAL s_unbound;
Xextern LVAL true;
X
X/* external routines */
Xextern LVAL makearglist();
X
X/* forward declarations */
XFORWARD LVAL bquote1();
XFORWARD LVAL let();
XFORWARD LVAL flet();
XFORWARD LVAL prog();
XFORWARD LVAL progx();
XFORWARD LVAL doloop();
XFORWARD LVAL evarg();
XFORWARD LVAL match();
XFORWARD LVAL evmatch();
X
X/* dummy node type for a list */
X#define LIST    -1
X
X/* xquote - special form 'quote' */
XLVAL xquote()
X{
X    LVAL val;
X    val = xlgetarg();
X    xllastarg();
X    return (val);
X}
X
X/* xfunction - special form 'function' */
XLVAL xfunction()
X{
X    LVAL val;
X
X    /* get the argument */
X    val = xlgetarg();
X    xllastarg();
X
X    /* create a closure for lambda expressions */
X    if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
X    val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);
X
X    /* otherwise, get the value of a symbol */
X    else if (symbolp(val))
X    val = xlgetfunction(val);
X
X    /* otherwise, its an error */
X    else
X    xlerror("not a function",val);
X
X    /* return the function */
X    return (val);
X}
X
X/* xbquote - back quote special form */
XLVAL xbquote()
X{
X    LVAL expr;
X
X    /* get the expression */
X    expr = xlgetarg();
X    xllastarg();
X
X    /* fill in the template */
X    return (bquote1(expr));
X}
X
X/* bquote1 - back quote helper function */
XLOCAL LVAL bquote1(expr)
X  LVAL expr;
X{
X    LVAL val,list,last,new;
X
X    /* handle atoms */
X    if (atom(expr))
X    val = expr;
X
X    /* handle (comma <expr>) */
X    else if (car(expr) == s_comma) {
X    if (atom(cdr(expr)))
X        xlfail("bad comma expression");
X    val = xleval(car(cdr(expr)));
X    }
X
X    /* handle ((comma-at <expr>) ... ) */
X    else if (consp(car(expr)) && car(car(expr)) == s_comat) {
X    xlstkcheck(2);
X    xlsave(list);
X    xlsave(val);
X    if (atom(cdr(car(expr))))
X        xlfail("bad comma-at expression");
X    list = xleval(car(cdr(car(expr))));
X    for (last = NIL; consp(list); list = cdr(list)) {
X        new = consa(car(list));
X        if (last)
X        rplacd(last,new);
X        else
X        val = new;
X        last = new;
X    }
X    if (last)
X        rplacd(last,bquote1(cdr(expr)));
X    else
X        val = bquote1(cdr(expr));
X    xlpopn(2);
X    }
X
X    /* handle any other list */
X    else {
X    xlsave1(val);
X    val = consa(NIL);
X    rplaca(val,bquote1(car(expr)));
X    rplacd(val,bquote1(cdr(expr)));
X    xlpop();
X    }
X
X    /* return the result */
X    return (val);
X}
X
X/* xlambda - special form 'lambda' */
XLVAL xlambda()
X{
X    LVAL fargs,body,val;
X
X    /* get the formal argument list and function body */
X    xlsave1(body);
X    fargs = xlgalist();
X    body  = makearglist(xlargc,xlargv);
X
X    /* create a new function definition */
X    val = xlclose(NIL,s_lambda,fargs,body,xlenv,xlfenv);
X
X    /* restore the stack and return the closure */
X    xlpop();
X    return (val);
X}
X
X/* xgetlambda - get the lambda expression associated with a closure */
XLVAL xgetlambda()
X{
X    LVAL closure;
X    closure = xlgaclosure();
X    return (cons(gettype(closure),
X                 cons(getlambda(closure),getbody(closure))));
X}
X
X/* xsetq - special form 'setq' */
XLVAL xsetq()
X{
X    LVAL sym,val;
X
X    /* handle each pair of arguments */
X    for (val = NIL; moreargs(); ) {
X    sym = xlgasymbol();
X    val = xleval(nextarg());
X    xlsetvalue(sym,val);
X    }
X
X    /* return the result value */
X    return (val);
X}
X
X/* xpsetq - special form 'psetq' */
XLVAL xpsetq()
X{
X    LVAL plist,sym,val;
X
X    /* protect some pointers */
X    xlsave1(plist);
X
X    /* handle each pair of arguments */
X    for (val = NIL; moreargs(); ) {
X    sym = xlgasymbol();
X    val = xleval(nextarg());
X    plist = cons(cons(sym,val),plist);
X    }
X
X    /* do parallel sets */
X    for (; plist; plist = cdr(plist))
X    xlsetvalue(car(car(plist)),cdr(car(plist)));
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result value */
X    return (val);
X}
X
X/* xsetf - special form 'setf' */
XLVAL xsetf()
X{
X    LVAL place,value;
X
X    /* protect some pointers */
X    xlsave1(value);
X
X    /* handle each pair of arguments */
X    while (moreargs()) {
X
X    /* get place and value */
X    place = xlgetarg();
X    value = xleval(nextarg());
X
X    /* expand macros in the place form */
X    if (consp(place))
X        place = xlexpandmacros(place);
X
X    /* check the place form */
X    if (symbolp(place))
X        xlsetvalue(place,value);
X    else if (consp(place))
X        placeform(place,value);
X    else
X        xlfail("bad place form");
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the value */
X    return (value);
X}
X
X/* placeform - handle a place form other than a symbol */
X#ifdef PROVIDE_WINTERP
Xplaceform(place,value)        /* needed by w_resources.c:Wres_GetValues_ArgList_To_Lisp */
X#else
XLOCAL placeform(place,value)
X#endif
X  LVAL place,value;
X{
X    LVAL fun,arg1,arg2;
X    int i;
X
X    /* check the function name */
X    if ((fun = match(SYMBOL,&place)) == s_get) {
X    xlstkcheck(2);
X    xlsave(arg1);
X    xlsave(arg2);
X    arg1 = evmatch(SYMBOL,&place);
X    arg2 = evmatch(SYMBOL,&place);
X    if (place) toomany(place);
X    xlputprop(arg1,value,arg2);
X    xlpopn(2);
X    }
X    else if (fun == s_svalue) {
X    arg1 = evmatch(SYMBOL,&place);
X    if (place) toomany(place);
X    setvalue(arg1,value);
X    }
X    else if (fun == s_sfunction) {
X    arg1 = evmatch(SYMBOL,&place);
X    if (place) toomany(place);
X    setfunction(arg1,value);
X    }
X    else if (fun == s_splist) {
X    arg1 = evmatch(SYMBOL,&place);
X    if (place) toomany(place);
X    setplist(arg1,value);
X    }
X    else if (fun == s_car) {
X    arg1 = evmatch(CONS,&place);
X    if (place) toomany(place);
X    rplaca(arg1,value);
X    }
X    else if (fun == s_cdr) {
X    arg1 = evmatch(CONS,&place);
X    if (place) toomany(place);
X    rplacd(arg1,value);
X    }
X    else if (fun == s_nth) {
X    xlsave1(arg1);
X    arg1 = evmatch(FIXNUM,&place);
X    arg2 = evmatch(LIST,&place);
X    if (place) toomany(place);
X    for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
X        arg2 = cdr(arg2);
X    if (consp(arg2))
X        rplaca(arg2,value);
X    xlpop();
X    }
X    else if (fun == s_aref) {
X    xlsave1(arg1);
X    arg1 = evmatch(VECTOR,&place);
X    arg2 = evmatch(FIXNUM,&place); i = (int)getfixnum(arg2);
X    if (place) toomany(place);
X    if (i < 0 || i >= getsz(arg1))
X        xlerror("index out of range",arg2);
X    setelement(arg1,i,value);
X    xlpop();
X    }
X    else if (fun = xlgetprop(fun,s_setf))
X    setffunction(fun,place,value);
X    else
X    xlfail("bad place form");
X}
X
X/* setffunction - call a user defined setf function */
XLOCAL setffunction(fun,place,value)
X  LVAL fun,place,value;
X{
X    LVAL *newfp;
X    int argc;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(NIL);
X
X    /* push the values of all of the place expressions and the new value */
X    for (argc = 1; consp(place); place = cdr(place), ++argc)
X    pusharg(xleval(car(place)));
X    pusharg(value);
X
X    /* insert the argument count and establish the call frame */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X
X    /* apply the function */
X    xlapply(argc);
X}
X
X/* xdefun - special form 'defun' */
XLVAL xdefun()
X{
X    LVAL sym,fargs,arglist;
X
X    /* get the function symbol and formal argument list */
X    xlsave1(arglist);
X    sym = xlgasymbol();
X    fargs = xlgalist();
X    arglist = makearglist(xlargc,xlargv);
X
X    /* make the symbol point to a new function definition */
X    xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));
X
X    /* restore the stack and return the function symbol */
X    xlpop();
X    return (sym);
X}
X
X/* xdefmacro - special form 'defmacro' */
XLVAL xdefmacro()
X{
X    LVAL sym,fargs,arglist;
X
X    /* get the function symbol and formal argument list */
X    xlsave1(arglist);
X    sym = xlgasymbol();
X    fargs = xlgalist();
X    arglist = makearglist(xlargc,xlargv);
X
X    /* make the symbol point to a new function definition */
X    xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));
X
X    /* restore the stack and return the function symbol */
X    xlpop();
X    return (sym);
X}
X
X/* xcond - special form 'cond' */
XLVAL xcond()
X{
X    LVAL list,val;
X
X    /* find a predicate that is true */
X    for (val = NIL; moreargs(); ) {
X
X    /* get the next conditional */
X    list = nextarg();
X
X    /* evaluate the predicate part */
X    if (consp(list) && (val = xleval(car(list)))) {
X
X        /* evaluate each expression */
X        for (list = cdr(list); consp(list); list = cdr(list))
X        val = xleval(car(list));
X
X        /* exit the loop */
X        break;
X    }
X    }
X
X    /* return the value */
X    return (val);
X}
X
X/* xwhen - special form 'when' */
XLVAL xwhen()
X{
X    LVAL val;
X
X    /* check the test expression */
X    if (val = xleval(xlgetarg()))
X    while (moreargs())
X        val = xleval(nextarg());
X
X    /* return the value */
X    return (val);
X}
X
X/* xunless - special form 'unless' */
XLVAL xunless()
X{
X    LVAL val=NIL;
X
X    /* check the test expression */
X    if (xleval(xlgetarg()) == NIL)
X    while (moreargs())
X        val = xleval(nextarg());
X
X    /* return the value */
X    return (val);
X}
X
X/* xcase - special form 'case' */
XLVAL xcase()
X{
X    LVAL key,list,cases,val;
X
X    /* protect some pointers */
X    xlsave1(key);
X
X    /* get the key expression */
X    key = xleval(nextarg());
X
X    /* find a case that matches */
X    for (val = NIL; moreargs(); ) {
X
X    /* get the next case clause */
X    list = nextarg();
X
X    /* make sure this is a valid clause */
X    if (consp(list)) {
X
X        /* compare the key list against the key */
X        if ((cases = car(list)) == true ||
X                (listp(cases) && keypresent(key,cases)) ||
X                eql(key,cases)) {
X
X        /* evaluate each expression */
X        for (list = cdr(list); consp(list); list = cdr(list))
X            val = xleval(car(list));
X
X        /* exit the loop */
X        break;
X        }
X    }
X    else
X        xlerror("bad case clause",list);
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the value */
X    return (val);
X}
X
X/* keypresent - check for the presence of a key in a list */
XLOCAL int keypresent(key,list)
X  LVAL key,list;
X{
X    for (; consp(list); list = cdr(list))
X    if (eql(car(list),key))
X        return (TRUE);
X    return (FALSE);
X}
X
X/* xand - special form 'and' */
XLVAL xand()
X{
X    LVAL val;
X
X    /* evaluate each argument */
X    for (val = true; moreargs(); )
X    if ((val = xleval(nextarg())) == NIL)
X        break;
X
X    /* return the result value */
X    return (val);
X}
X
X/* xor - special form 'or' */
XLVAL xor()
X{
X    LVAL val;
X
X    /* evaluate each argument */
X    for (val = NIL; moreargs(); )
X    if ((val = xleval(nextarg())))
X        break;
X
X    /* return the result value */
X    return (val);
X}
X
X/* xif - special form 'if' */
XLVAL xif()
X{
X    LVAL testexpr,thenexpr,elseexpr;
X
X    /* get the test expression, then clause and else clause */
X    testexpr = xlgetarg();
X    thenexpr = xlgetarg();
X    elseexpr = (moreargs() ? xlgetarg() : NIL);
X    xllastarg();
X
X    /* evaluate the appropriate clause */
X    return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
X}
X
X/* xlet - special form 'let' */
XLVAL xlet()
X{
X    return (let(TRUE));
X}
X
X/* xletstar - special form 'let*' */
XLVAL xletstar()
X{
X    return (let(FALSE));
X}
X
X/* let - common let routine */
XLOCAL LVAL let(pflag)
X  int pflag;
X{
X    LVAL newenv,val;
X
X    /* protect some pointers */
X    xlsave1(newenv);
X
X    /* create a new environment frame */
X    newenv = xlframe(xlenv);
X
X    /* get the list of bindings and bind the symbols */
X    if (!pflag) xlenv = newenv;
X    dobindings(xlgalist(),newenv);
X    if (pflag) xlenv = newenv;
X
X    /* execute the code */
X    for (val = NIL; moreargs(); )
X    val = xleval(nextarg());
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xflet - built-in function 'flet' */
XLVAL xflet()
X{
X    return (flet(s_lambda,TRUE));
X}
X
X/* xlabels - built-in function 'labels' */
XLVAL xlabels()
X{
X    return (flet(s_lambda,FALSE));
X}
X
X/* xmacrolet - built-in function 'macrolet' */
XLVAL xmacrolet()
X{
X    return (flet(s_macro,TRUE));
X}
X
X/* flet - common flet/labels/macrolet routine */
XLOCAL LVAL flet(type,letflag)
X  LVAL type; int letflag;
X{
X    LVAL list,bnd,sym,fargs,val;
X
X    /* create a new environment frame */
X    xlfenv = xlframe(xlfenv);
X
X    /* bind each symbol in the list of bindings */
X    for (list = xlgalist(); consp(list); list = cdr(list)) {
X
X    /* get the next binding */
X    bnd = car(list);
X
X    /* get the symbol and the function definition */
X    sym = match(SYMBOL,&bnd);
X    fargs = match(LIST,&bnd);
X    val = xlclose(sym,type,fargs,bnd,xlenv,(letflag?cdr(xlfenv):xlfenv));
X
X    /* bind the value to the symbol */
X    xlfbind(sym,val);
X    }
X
X    /* execute the code */
X    for (val = NIL; moreargs(); )
X    val = xleval(nextarg());
X
X    /* unbind the arguments */
X    xlfenv = cdr(xlfenv);
X
X    /* return the result */
X    return (val);
X}
X
X/* xprog - special form 'prog' */
XLVAL xprog()
X{
X    return (prog(TRUE));
X}
X
X/* xprogstar - special form 'prog*' */
XLVAL xprogstar()
X{
X    return (prog(FALSE));
X}
X
X/* prog - common prog routine */
XLOCAL LVAL prog(pflag)
X  int pflag;
X{
X    LVAL newenv,val;
X    CONTEXT cntxt;
X
X    /* protect some pointers */
X    xlsave1(newenv);
X
X    /* create a new environment frame */
X    newenv = xlframe(xlenv);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else {
X
X    /* get the list of bindings and bind the symbols */
X    if (!pflag) xlenv = newenv;
X    dobindings(xlgalist(),newenv);
X    if (pflag) xlenv = newenv;
X
X    /* execute the code */
X    tagbody();
X    val = NIL;
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X    }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xgo - special form 'go' */
XLVAL xgo()
X{
X    LVAL label;
X
X    /* get the target label */
X    label = xlgetarg();
X    xllastarg();
X
X    /* transfer to the label */
X    xlgo(label);
X}
X
X/* xreturn - special form 'return' */
XLVAL xreturn()
X{
X    LVAL val;
X
X    /* get the return value */
X    val = (moreargs() ? xleval(nextarg()) : NIL);
X    xllastarg();
X
X    /* return from the inner most block */
X    xlreturn(NIL,val);
X}
X
X/* xrtnfrom - special form 'return-from' */
XLVAL xrtnfrom()
X{
X    LVAL name,val;
X
X    /* get the return value */
X    name = xlgasymbol();
X    val = (moreargs() ? xleval(nextarg()) : NIL);
X    xllastarg();
X
X    /* return from the inner most block */
X    xlreturn(name,val);
X}
X
X/* xprog1 - special form 'prog1' */
XLVAL xprog1()
X{
X    return (progx(1));
X}
X
X/* xprog2 - special form 'prog2' */
XLVAL xprog2()
X{
X    return (progx(2));
X}
X
X/* progx - common progx code */
XLOCAL LVAL progx(n)
X  int n;
X{
X    LVAL val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* evaluate the first n expressions */
X    while (moreargs() && --n >= 0)
X    val = xleval(nextarg());
X
X    /* evaluate each remaining argument */
X    while (moreargs())
X    xleval(nextarg());
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xprogn - special form 'progn' */
XLVAL xprogn()
X{
X    LVAL val;
X
X    /* evaluate each expression */
X    for (val = NIL; moreargs(); )
X    val = xleval(nextarg());
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xprogv - special form 'progv' */
XLVAL xprogv()
X{
X    LVAL olddenv,vars,vals,val;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(vars);
X    xlsave(vals);
X
X    /* get the list of variables and the list of values */
X    vars = xlgalist(); vars = xleval(vars);
X    vals = xlgalist(); vals = xleval(vals);
X
X    /* bind the values to the variables */
X    for (olddenv = xldenv; consp(vars); vars = cdr(vars)) {
X    if (!symbolp(car(vars)))
X        xlerror("expecting a symbol",car(vars));
X    if (consp(vals)) {
X        xldbind(car(vars),car(vals));
X        vals = cdr(vals);
X    }
X    else
X        xldbind(car(vars),s_unbound);
X    }
X
X    /* evaluate each expression */
X    for (val = NIL; moreargs(); )
X    val = xleval(nextarg());
X
X    /* restore the previous environment and the stack */
X    xlunbind(olddenv);
X    xlpopn(2);
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xloop - special form 'loop' */
XLVAL xloop()
X{
X    LVAL *argv,arg,val;
X    CONTEXT cntxt;
X    int argc;
X
X    /* protect some pointers */
X    xlsave1(arg);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else
X    for (argv = xlargv, argc = xlargc; ; xlargv = argv, xlargc = argc)
X        while (moreargs()) {
X        arg = nextarg();
X        if (consp(arg))
X            xleval(arg);
X        }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xdo - special form 'do' */
XLVAL xdo()
X{
X    return (doloop(TRUE));
X}
X
X/* xdostar - special form 'do*' */
XLVAL xdostar()
X{
X    return (doloop(FALSE));
X}
X
X/* doloop - common do routine */
XLOCAL LVAL doloop(pflag)
X  int pflag;
X{
X    LVAL newenv,*argv,blist,clist,test,val;
X    CONTEXT cntxt;
X    int argc;
X
X    /* protect some pointers */
X    xlsave1(newenv);
X
X    /* get the list of bindings, the exit test and the result forms */
X    blist = xlgalist();
X    clist = xlgalist();
X    test = (consp(clist) ? car(clist) : NIL);
X    argv = xlargv;
X    argc = xlargc;
X
X    /* create a new environment frame */
X    newenv = xlframe(xlenv);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else {
X
X    /* bind the symbols */
X    if (!pflag) xlenv = newenv;
X    dobindings(blist,newenv);
X    if (pflag) xlenv = newenv;
X
X    /* execute the loop as long as the test is false */
X    for (val = NIL; xleval(test) == NIL; doupdates(blist,pflag)) {
X        xlargv = argv;
X        xlargc = argc;
X        tagbody();
X    }
X
X    /* evaluate the result expression */
X    if (consp(clist))
X        for (clist = cdr(clist); consp(clist); clist = cdr(clist))
X        val = xleval(car(clist));
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X    }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xdolist - special form 'dolist' */
XLVAL xdolist()
X{
X    LVAL list,*argv,clist,sym,val;
X    CONTEXT cntxt;
X    int argc;
X
X    /* protect some pointers */
X    xlsave1(list);
X
X    /* get the control list (sym list result-expr) */
X    clist = xlgalist();
X    sym = match(SYMBOL,&clist);
X    list = evmatch(LIST,&clist);
X    argv = xlargv;
X    argc = xlargc;
X
X    /* initialize the local environment */
X    xlenv = xlframe(xlenv);
X    xlbind(sym,NIL);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else {
X
X    /* loop through the list */
X    for (val = NIL; consp(list); list = cdr(list)) {
X
X        /* bind the symbol to the next list element */
X        xlsetvalue(sym,car(list));
X
X        /* execute the loop body */
X        xlargv = argv;
X        xlargc = argc;
X        tagbody();
X    }
X
X    /* evaluate the result expression */
X    xlsetvalue(sym,NIL);
X    val = (consp(clist) ? xleval(car(clist)) : NIL);
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X    }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xdotimes - special form 'dotimes' */
XLVAL xdotimes()
X{
X    LVAL *argv,clist,sym,cnt,val;
X    CONTEXT cntxt;
X    int argc,n,i;
X
X    /* get the control list (sym list result-expr) */
X    clist = xlgalist();
X    sym = match(SYMBOL,&clist);
X    cnt = evmatch(FIXNUM,&clist); n = getfixnum(cnt);
X    argv = xlargv;
X    argc = xlargc;
X
X    /* initialize the local environment */
X    xlenv = xlframe(xlenv);
X    xlbind(sym,NIL);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else {
X
X    /* loop through for each value from zero to n-1 */
X    for (val = NIL, i = 0; i < n; ++i) {
X
X        /* bind the symbol to the next list element */
X        xlsetvalue(sym,cvfixnum((FIXTYPE)i));
X
X        /* execute the loop body */
X        xlargv = argv;
X        xlargc = argc;
X        tagbody();
X    }
X
X    /* evaluate the result expression */
X    xlsetvalue(sym,cnt);
X    val = (consp(clist) ? xleval(car(clist)) : NIL);
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X    }
X    xlend(&cntxt);
X
X    /* return the result */
X    return (val);
X}
X
X/* xblock - special form 'block' */
XLVAL xblock()
X{
X    LVAL name,val;
X    CONTEXT cntxt;
X
X    /* get the block name */
X    name = xlgetarg();
X    if (name && !symbolp(name))
X    xlbadtype(name);
X
X    /* execute the block */
X    xlbegin(&cntxt,CF_RETURN,name);
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else
X    for (val = NIL; moreargs(); )
X        val = xleval(nextarg());
X    xlend(&cntxt);
X
X    /* return the value of the last expression */
X    return (val);
X}
X
X/* xtagbody - special form 'tagbody' */
XLVAL xtagbody()
X{
X    tagbody();
X    return (NIL);
X}
X
X/* xcatch - special form 'catch' */
XLVAL xcatch()
X{
X    CONTEXT cntxt;
X    LVAL tag,val;
X
X    /* protect some pointers */
X    xlsave1(tag);
X
X    /* get the tag */
X    tag = xleval(nextarg());
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_THROW,tag);
X
X    /* check for 'throw' */
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X
X    /* otherwise, evaluate the remainder of the arguments */
X    else {
X    for (val = NIL; moreargs(); )
X        val = xleval(nextarg());
X    }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xthrow - special form 'throw' */
XLVAL xthrow()
X{
X    LVAL tag,val;
X
X    /* get the tag and value */
X    tag = xleval(nextarg());
X    val = (moreargs() ? xleval(nextarg()) : NIL);
X    xllastarg();
X
X    /* throw the tag */
X    xlthrow(tag,val);
X}
X
X/* xunwindprotect - special form 'unwind-protect' */
XLVAL xunwindprotect()
X{
X    extern CONTEXT *xltarget;
X    extern int xlmask;
X    CONTEXT cntxt,*target;
X    int mask,sts;
X    LVAL val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* get the expression to protect */
X    val = xlgetarg();
X
X    /* evaluate the protected expression */
X    xlbegin(&cntxt,CF_UNWIND,NIL);
X    if (sts = xlsetjmp(cntxt.c_jmpbuf)) {
X    target = xltarget;
X    mask = xlmask;
X    val = xlvalue;
X    }
X    else
X    val = xleval(val);
X    xlend(&cntxt);
X
X    /* evaluate the cleanup expressions */
X    while (moreargs())
X    xleval(nextarg());
X
X    /* if unwinding, continue unwinding */
X    if (sts)
X    xljump(target,mask,val);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the value of the protected expression */
X    return (val);
X}
X
X/* xerrset - special form 'errset' */
XLVAL xerrset()
X{
X    LVAL expr,flag,val;
X    CONTEXT cntxt;
X
X    /* get the expression and the print flag */
X    expr = xlgetarg();
X    flag = (moreargs() ? xlgetarg() : true);
X    xllastarg();
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_ERROR,flag);
X
X    /* check for error */
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    val = NIL;
X
X    /* otherwise, evaluate the expression */
X    else {
X    expr = xleval(expr);
X    val = consa(expr);
X    }
X    xlend(&cntxt);
X
X    /* return the result */
X    return (val);
X}
X
X/* xtrace - special form 'trace' */
XLVAL xtrace()
X{
X    LVAL sym,fun,this;
X
X    /* loop through all of the arguments */
X    sym = xlenter("*TRACELIST*");
X    while (moreargs()) {
X    fun = xlgasymbol();
X
X    /* check for the function name already being in the list */
X    for (this = getvalue(sym); consp(this); this = cdr(this))
X        if (car(this) == fun)
X        break;
X
X    /* add the function name to the list */
X    if (null(this))
X        setvalue(sym,cons(fun,getvalue(sym)));
X    }
X    return (getvalue(sym));
X}
X
X/* xuntrace - special form 'untrace' */
XLVAL xuntrace()
X{
X    LVAL sym,fun,this,last;
X
X    /* loop through all of the arguments */
X    sym = xlenter("*TRACELIST*");
X    while (moreargs()) {
X    fun = xlgasymbol();
X
X    /* remove the function name from the list */
X    last = NIL;
X    for (this = getvalue(sym); consp(this); this = cdr(this)) {
X        if (car(this) == fun) {
X        if (last)
X            rplacd(last,cdr(this));
X        else
X            setvalue(sym,cdr(this));
X        break;
X        }
X        last = this;
X    }
X    }
X    return (getvalue(sym));
X}
X
X/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
XLOCAL dobindings(list,env)
X  LVAL list,env;
X{
X    LVAL bnd,sym,val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* bind each symbol in the list of bindings */
X    for (; consp(list); list = cdr(list)) {
X
X    /* get the next binding */
X    bnd = car(list);
X
X    /* handle a symbol */
X    if (symbolp(bnd)) {
X        sym = bnd;
X        val = NIL;
X    }
X
X    /* handle a list of the form (symbol expr) */
X    else if (consp(bnd)) {
X        sym = match(SYMBOL,&bnd);
X        val = evarg(&bnd);
X    }
X    else
X        xlfail("bad binding");
X
X    /* bind the value to the symbol */
X    xlpbind(sym,val,env);
X    }
X
X    /* restore the stack */
X    xlpop();
X}
X
X/* doupdates - handle updates for do/do* */
XLOCAL doupdates(list,pflag)
X  LVAL list; int pflag;
X{
X    LVAL plist,bnd,sym,val;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(plist);
X    xlsave(val);
X
X    /* bind each symbol in the list of bindings */
X    for (; consp(list); list = cdr(list)) {
X
X    /* get the next binding */
X    bnd = car(list);
X
X    /* handle a list of the form (symbol expr) */
X    if (consp(bnd)) {
X        sym = match(SYMBOL,&bnd);
X        bnd = cdr(bnd);
X        if (bnd) {
X        val = evarg(&bnd);
X        if (pflag)
X            plist = cons(cons(sym,val),plist);
X        else
X            xlsetvalue(sym,val);
X        }
X    }
X    }
X
X    /* set the values for parallel updates */
X    for (; plist; plist = cdr(plist))
X    xlsetvalue(car(car(plist)),cdr(car(plist)));
X
X    /* restore the stack */
X    xlpopn(2);
X}
X
X/* tagbody - execute code within a block and tagbody */
XLOCAL tagbody()
X{
X    LVAL *argv,arg;
X    CONTEXT cntxt;
X    int argc;
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_GO,NIL);
X    argc = xlargc;
X    argv = xlargv;
X
X    /* check for a 'go' */
X    if (xlsetjmp(cntxt.c_jmpbuf)) {
X    cntxt.c_xlargc = argc;
X    cntxt.c_xlargv = argv;
X    }
X
X    /* execute the body */
X    while (moreargs()) {
X    arg = nextarg();
X    if (consp(arg))
X        xleval(arg);
X    }
X    xlend(&cntxt);
X}
X
X/* match - get an argument and match its type */
XLOCAL LVAL match(type,pargs)
X  int type; LVAL *pargs;
X{
X    LVAL arg;
X
X    /* make sure the argument exists */
X    if (!consp(*pargs))
X    toofew(*pargs);
X
X    /* get the argument value */
X    arg = car(*pargs);
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X
X    /* check its type */
X    if (type == LIST) {
X    if (arg && ntype(arg) != CONS)
X        xlerror("bad argument type",arg);
X    }
X    else {
X    if (arg == NIL || ntype(arg) != type)
X        xlerror("bad argument type",arg);
X    }
X
X    /* return the argument */
X    return (arg);
X}
X
X/* evarg - get the next argument and evaluate it */
XLOCAL LVAL evarg(pargs)
X  LVAL *pargs;
X{
X    LVAL arg;
X
X    /* protect some pointers */
X    xlsave1(arg);
X
X    /* make sure the argument exists */
X    if (!consp(*pargs))
X    toofew(*pargs);
X
X    /* get the argument value */
X    arg = car(*pargs);
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X
X    /* evaluate the argument */
X    arg = xleval(arg);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the argument */
X    return (arg);
X}
X
X/* evmatch - get an evaluated argument and match its type */
XLOCAL LVAL evmatch(type,pargs)
X  int type; LVAL *pargs;
X{
X    LVAL arg;
X
X    /* protect some pointers */
X    xlsave1(arg);
X
X    /* make sure the argument exists */
X    if (!consp(*pargs))
X    toofew(*pargs);
X
X    /* get the argument value */
X    arg = car(*pargs);
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X
X    /* evaluate the argument */
X    arg = xleval(arg);
X
X    /* check its type */
X    if (type == LIST) {
X    if (arg && ntype(arg) != CONS)
X        xlerror("bad argument type",arg);
X    }
X    else {
X    if (arg == NIL || ntype(arg) != type)
X        xlerror("bad argument type",arg);
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the argument */
X    return (arg);
X}
X
X/* toofew - too few arguments */
XLOCAL toofew(args)
X  LVAL args;
X{
X    xlerror("too few arguments",args);
X}
X
X/* toomany - too many arguments */
XLOCAL toomany(args)
X  LVAL args;
X{
X    xlerror("too many arguments",args);
X}
X
END_OF_FILE
if test 30247 -ne `wc -c <'src/xlisp/xcore/c/xlcont.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlcont.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlcont.c'
fi
echo shar: End of archive 12 \(of 16\).
cp /dev/null ark12isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 16 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