Newsgroups: comp.sources.unix From: voodoo@hitl.washington.edu (Geoffery Coco) Subject: v26i193: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part10/16 Sender: unix-sources-moderator@vix.com Approved: paul@vix.com Submitted-By: voodoo@hitl.washington.edu (Geoffery Coco) Posting-Number: Volume 26, Issue 193 Archive-Name: veos-2.0/part10 #! /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 'src/kernel_current/shell/xv_native.c' <<'END_OF_FILE' X/**************************************************************************************** X * * X * file: xv_native.c * X * * X * the xlisp wrappers for the VEOS native prims. * X * * X * creation: December, 1991 * X * * X * * X * by Geoffrey P. Coco at the HITLab, Seattle. * X * * X ****************************************************************************************/ X X X X/**************************************************************************************** X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X X X/**************************************************************************************** X Preliminaries X ****************************************************************************************/ X X#include X#include "xlisp.h" X X/* VEOS definitions: */ X#include "kernel.h" X X#define DEFINE_NATIVE_GLOBS X#include "xv_native.h" X#undef DEFINE_NATIVE_GLOBS X X/****************************************************************************************/ X XTVeosErr Native_MessageToLSpace(); Xvoid Native_ShowMatchArgs(); Xvoid Native_ShowSite(); XTVeosErr Native_XCopySiteMatches(); XTVeosErr Native_XRemoveSiteMatches(); XTVeosErr Native_XInsertEltAtSite(); Xvoid Native_NextMsg(); XTVeosErr Native_DoThrow(); X X/****************************************************************************************/ X X X X/**************************************************************************************** X Veos Primitive Wrappers X ****************************************************************************************/ X X X/****************************************************************************************/ XLVAL Native_Init() X{ X LVAL pXReturn; X int iPort; X TVeosErr iErr; X X xlsave1(pXReturn); X X if (!moreargs()) X iPort = TALK_BOGUS_FD; X else X iPort = getfixnum(xlgafixnum()); X X xllastarg(); X X X /** invoke veos kernel inialization **/ X X iErr = Kernel_Init(iPort, Native_MessageToLSpace); X if (iErr == VEOS_SUCCESS) { X X X /** create a lisp based inspace for messages **/ X X s_InSpace = xlenter("VEOS_INSPACE"); X setvalue(s_InSpace, NIL); X NATIVE_INSPACE = &getvalue(s_InSpace); X X X /** create keyword symbols for nancy prims **/ X X k_TestTime = xlenter(":TEST-TIME"); /* use with copy only */ X k_Freq = xlenter(":FREQ"); /* use with copy, put or get */ X X X /** setup invariant matcher settings in global param blocks **/ X X Native_InitMatcherPBs(); X X X /** make a uid return value to signify success **/ X X X Uid2XVect(&IDENT_ADDR, &pXReturn); X } X X X xlpop(); X X X return(pXReturn); X X } /* Native_Init */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XLVAL Native_Close() X{ X if (!KERNEL_INIT) X Native_TrapErr(NATIVE_NOKERNEL, nil); X X xllastarg(); X X Kernel_Shutdown(); X X return(true); X X } /* Native_Close */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XLVAL Native_Task() X{ X#ifndef OPTIMAL X if (!KERNEL_INIT) X Native_TrapErr(NATIVE_NOKERNEL, nil); X X xllastarg(); X#endif X X /** talk will call our message handler and stuff the inspace **/ X X Kernel_SystemTask(); X X X return(true); X X } /* Native_Task */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XLVAL Native_Put() X{ X TVeosErr iErr; X TTimeStamp tNow; X X#ifndef OPTIMAL X if (!KERNEL_INIT) X Native_TrapErr(NATIVE_NOKERNEL, nil); X#endif X X X X /** get mandatory data argument **/ X X native_putPB.pXReplaceElt = xlgetarg(); X X X X /** get pattern from xlisp args **/ X X iErr = Native_GetPatternArg(&native_putPB.pPatGr, NANCY_ReplaceMatch); X if (iErr != VEOS_SUCCESS) X Native_TrapErr(iErr, nil); X X X /** get optional frequency argument **/ X X NATIVE_FREQ_ARG(native_putPB.iFreqFlag); X X X /** set the data time-stamp **/ X X GET_TIME(tNow); X native_putPB.pStampTime = &tNow; X X X /** dispatch the matcher **/ X X xlsave1(native_putPB.pXResult); X X Native_XMandR(&native_putPB); X X xlpop(); X X X X /** clean up **/ X X Nancy_DisposeGrouple(native_putPB.pPatGr); X X X X return (native_putPB.pXResult); X X } /* Native_Put */ X/****************************************************************************************/ X X X/****************************************************************************************/ XLVAL Native_Get() X{ X TVeosErr iErr; X X#ifndef OPTIMAL X if (!KERNEL_INIT) X Native_TrapErr(NATIVE_NOKERNEL, nil); X#endif X X /** get pattern from xlisp args **/ X X iErr = Native_GetPatternArg(&native_getPB.pPatGr, NANCY_RemoveMatch); X if (iErr != VEOS_SUCCESS) X Native_TrapErr(iErr, nil); X X X /** get optional frequency argument **/ X X NATIVE_FREQ_ARG(native_getPB.iFreqFlag); X X X /** dispatch the matcher **/ X X xlsave1(native_getPB.pXResult); X X Native_XMandR(&native_getPB); X X xlpop(); X X X /** clean up **/ X X Nancy_DisposeGrouple(native_getPB.pPatGr); X X X X return (native_getPB.pXResult); X X } /* Native_Get */ X/****************************************************************************************/ X X X/****************************************************************************************/ XLVAL Native_Copy() X{ X TVeosErr iErr; X TTimeStamp tTest; X X#ifndef OPTIMAL X if (!KERNEL_INIT) X Native_TrapErr(NATIVE_NOKERNEL, nil); X#endif X X X X /** get pattern from xlisp args **/ X X iErr = Native_GetPatternArg(&native_copyPB.pPatGr, NANCY_CopyMatch); X if (iErr != VEOS_SUCCESS) X Native_TrapErr(iErr, nil); X X X /** look for optional time-stamp-test **/ X X NATIVE_TIME_ARG(native_copyPB.pTestTime, tTest); X X X /** get optional frequency argument **/ X X NATIVE_FREQ_ARG(native_copyPB.iFreqFlag); X X X /** dispatch the matcher **/ X X xlsave1(native_copyPB.pXResult); X X Native_XMandR(&native_copyPB); X X xlpop(); X X X /** clean up **/ X X Nancy_DisposeGrouple(native_copyPB.pPatGr); X X X X return (native_copyPB.pXResult); X X } /* Native_Copy */ X/****************************************************************************************/ X X X/****************************************************************************************/ XLVAL Native_Throw() X{ X LVAL pXData, pXDests; X TVeosErr iErr; X X#ifndef OPTIMAL X if (!KERNEL_INIT) X Native_TrapErr(NATIVE_NOKERNEL, nil); X#endif X X /** get dests argument **/ X X pXDests = xlgalist(); X X X /** get data argument **/ X X pXData = xlgetarg(); X X#ifndef OPTIMAL X xllastarg(); X#endif X X iErr = Native_DoThrow(pXDests, pXData); X X return(iErr == VEOS_SUCCESS ? true : NIL); X X } /* Native_Throw */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XLVAL Native_Catch() X{ X LVAL pSave; X TPElt pElt; X X#ifndef OPTIMAL X if (!KERNEL_INIT) X Native_TrapErr(NATIVE_NOKERNEL, nil); X X xllastarg(); X#endif X X Native_NextMsg(&pSave); X X return (pSave); X X } /* Native_Catch */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XLVAL Native_MinTime() X{ X TF2L fTrans; X X /* guaranteed to be earlier than any system time */ X X fTrans.u.l = NANCY_MINTIME; X X return(cvflonum(fTrans.u.f)); X X } /* Native_MinTime */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XLVAL Native_NoSignals() X{ X SIG_ENABLE = FALSE; X X return(true); X X } /* Native_NoSignals */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XLVAL Native_Bugs() X{ X LVAL pXModule; X char *sName; X X pXModule = xlgastring(); X sName = (char *) getstring(pXModule); X X if (strcmp(sName, "talk") == 0) X TALK_BUGS = TALK_BUGS ? FALSE : TRUE; X X else if (strcmp(sName, "nancy") == 0) X NANCY_BUGS = NANCY_BUGS ? FALSE : TRUE; X X else if (strcmp(sName, "shell") == 0) X SHELL_BUGS = SHELL_BUGS ? FALSE : TRUE; X X return(true); X X } /* Native_Bugs */ X/****************************************************************************************/ X Xextern int iEvals; X X/****************************************************************************************/ XLVAL Native_Zoot() X{ X static int iAlreadySeen = 0; X int iSinceLast; X X iSinceLast = iEvals - iAlreadySeen; X iAlreadySeen = iEvals; X X return(cvfixnum(iSinceLast)); X X } /* Native_Zoot */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X The Beuractratic Linkage Between Veos and XLISP X ****************************************************************************************/ X X X/****************************************************************************************/ XTVeosErr Shell_LoadNativePrims() X{ X#define VEOS_NATIVE_LOAD X#include "xv_native_prims.h" X#undef VEOS_NATIVE_LOAD X X return(VEOS_SUCCESS); X } X/****************************************************************************************/ X X X/****************************************************************************************/ XTVeosErr Shell_BailOut(sErr) X char *sErr; X{ X X xlfatal(sErr); X X /** not reached **/ X X return(VEOS_SUCCESS); X X } /* Shell_BailOut */ X/****************************************************************************************/ X X X X/**************************************************************************************** X The Sticky Goo Just Beneath the Wrappers X ****************************************************************************************/ X X X/****************************************************************************************/ XTVeosErr Native_InitMatcherPBs() X{ X /** vget settings **/ X X native_getPB.pSrcGr = WORK_SPACE; X native_getPB.iDestroyFlag = NANCY_RemoveMatch; X native_getPB.pXReplaceElt = nil; X native_getPB.pStampTime = nil; X native_getPB.pTestTime = nil; X X /** vcopy settings **/ X X native_copyPB.pSrcGr = WORK_SPACE; X native_copyPB.iDestroyFlag = NANCY_CopyMatch; X native_copyPB.pXReplaceElt = nil; X native_copyPB.pStampTime = nil; X X /** vput settings **/ X X native_putPB.pSrcGr = WORK_SPACE; X native_putPB.iDestroyFlag = NANCY_ReplaceMatch; X native_putPB.pTestTime = nil; X X X return(VEOS_SUCCESS); X X } /* Native_InitMatcherPBs */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Native_DoThrow(pXDests, pXData) X LVAL pXData, pXDests; X{ X TPUidNode pDests; X TVeosErr iErr; X TMsgRec msgOut; X X X /** convert host/port vectors to talk uids **/ X X iErr = Native_XVectsToUids(pXDests, &pDests); X if (iErr != VEOS_SUCCESS) { X Native_TrapErr(iErr, pXDests); X } X X /** convert data element to flat network format **/ X X iErr = Native_XEltToMsgRec(pXData, &msgOut); X if (iErr != VEOS_SUCCESS) { X Native_DisposeUids(pDests); X Native_TrapErr(iErr, pXData); X } X X /** pass the flat message to veos kernel **/ X X iErr = Talk_SpeakToMany(pDests, &msgOut); X X X Native_DisposeUids(pDests); X X return(iErr); X X } /* Native_DoThrow */ X/****************************************************************************************/ X X X X/****************************************************************************************/ Xvoid Native_NextMsg(hMsg) X LVAL *hMsg; X{ X *hMsg = NIL; X X if (!null(*NATIVE_INSPACE)) { X X /** get the oldest message **/ X X *hMsg = car(*NATIVE_INSPACE); X X /** remove this msg from list immediately. X ** first cons cell in this list will thus be garbage collected. X ** pass back the new msg. X **/ X X *NATIVE_INSPACE = cdr(*NATIVE_INSPACE); X } X } X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Native_XMandR(pMandRPB) X TPXMandRRec pMandRPB; X{ X TVeosErr iErr; X TMatchRec matchSpec; X TPReplaceRec pSite, pSave; X X X /** Initialize the match record. X ** This record get passed through the entire match process. X ** The matcher uses to record sites for removal and insertion. X ** If the matcher returns success, X ** we then perform any destructive operations on the gspace. X **/ X X matchSpec.pPatGr = pMandRPB->pPatGr; X matchSpec.pSrcGr = pMandRPB->pSrcGr; X matchSpec.iDestroyFlag = pMandRPB->iDestroyFlag; X matchSpec.iFreqFlag = pMandRPB->iFreqFlag; X matchSpec.pReplaceList = nil; X matchSpec.pTouchList = nil; X X#ifndef OPTIMAL X if (NANCY_BUGS) X Native_ShowMatchArgs(pMandRPB); X#endif X X /************************************/ X X iErr = Nancy_MatchGrouple(&matchSpec); X X /************************************/ X X#ifndef OPTIMAL X if (NANCY_BUGS) X fprintf(stderr, "nancy %s: match %s.\n", X WHOAMI, iErr == VEOS_SUCCESS ? "succeeded" : "failed"); X#endif X X /** Perform any destructive operations on the gspace. X ** These occur in on a per-site basis. X ** A site is: X ** an enclosing grouple, X ** a set of element intervals, X ** an element index at which to insert. X ** Sites are generated by the matcher during matching. X **/ X X /** perform destructive element retrieval X **/ X X switch (pMandRPB->iDestroyFlag) { X X case NANCY_CopyMatch: X for (pSite = matchSpec.pReplaceList; X pSite && iErr == VEOS_SUCCESS; X pSite = pSite->pNext) { X#ifndef OPTIMAL X if (NANCY_BUGS) X Native_ShowSite(pSite); X#endif X iErr = Native_XCopySiteMatches(pSite, pMandRPB->pTestTime, X &pMandRPB->pXResult); X } X break; X X case NANCY_RemoveMatch: X for (pSite = matchSpec.pReplaceList; X pSite && iErr == VEOS_SUCCESS; X pSite = pSite->pNext) { X X#ifndef OPTIMAL X if (NANCY_BUGS) X Native_ShowSite(pSite); X#endif X iErr = Native_XRemoveSiteMatches(pSite, pMandRPB->pTestTime, X &pMandRPB->pXResult); X } X break; X X case NANCY_ReplaceMatch: X for (pSite = matchSpec.pReplaceList; X pSite && iErr == VEOS_SUCCESS; X pSite = pSite->pNext) { X X#ifndef OPTIMAL X if (NANCY_BUGS) X Native_ShowSite(pSite); X#endif X iErr = Native_XRemoveSiteMatches(pSite, pMandRPB->pTestTime, X &pMandRPB->pXResult); X if (iErr == VEOS_SUCCESS) X iErr = Native_XInsertEltAtSite(pMandRPB->pXReplaceElt, X pMandRPB->pStampTime, pSite); X } X break; X X case NANCY_GimmeMatch: X iErr = NANCY_NotSupported; X break; X X } /* switch */ X X X /** perform destructive element time stamping X **/ X X if (pMandRPB->pStampTime) { X X for (pSite = matchSpec.pTouchList; X pSite && iErr == VEOS_SUCCESS; X pSite = pSite->pNext) { X#ifndef OPTIMAL X if (NANCY_BUGS) X Native_ShowSite(pSite); X#endif X Native_TouchSiteMatches(pSite, *pMandRPB->pStampTime); X X } X } X X /** free all matcher memory (stays within veos kernel) **/ X X pSite = matchSpec.pReplaceList; X while (pSite) { X pSave = pSite; X pSite = pSite->pNext; X Shell_ReturnBlock(pSave, sizeof(TReplaceRec), "replace-bp"); X } X X pSite = matchSpec.pTouchList; X while (pSite) { X pSave = pSite; X pSite = pSite->pNext; X Shell_ReturnBlock(pSave, sizeof(TReplaceRec), "replace-bp"); X } X X X if (iErr == VEOS_SUCCESS) { X X /** check for successful insert (give caller appropriate feeback) **/ X X if (pMandRPB->iDestroyFlag == NANCY_ReplaceMatch && X pMandRPB->pXResult == NIL) X X pMandRPB->pXResult = true; X } X X#ifndef OPTIMAL X else { X if (NANCY_BUGS) X Nancy_TrapErr(iErr); X } X#endif X X return(iErr); X X } /* Native_MatchAndReplace */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Native_XCopySiteMatches(pSite, pTestTime, hXResult) X TPReplaceRec pSite; X TPTimeStamp pTestTime; X LVAL *hXResult; X{ X int iZone, iToKill, iElt, iLeft, iRight; X LVAL pXElt; X TPElt pVElt; X TVeosErr iErr; X X xlsave1(pXElt); X X /** convert outgoing data into supplanted language format. X ** lisp is the current control language X **/ X X if (pTestTime == nil) { X X for (iZone = pSite->iZones - 1; iZone >= 0; iZone --) { X iLeft = pSite->pWipeList[iZone].iLeft; X iRight = pSite->pWipeList[iZone].iRight; X iToKill = iRight - iLeft + 1; X X#ifndef OPTIMAL X if (NANCY_BUGS) { X fprintf(stderr, "nancy %s: left: %d right: %d\n", X WHOAMI, iLeft, iRight); X } X#endif X for (iElt = iRight, pVElt = &pSite->pEnviron->pEltList[iRight]; X iElt >= iLeft; X iElt--, pVElt --) { X X if (Native_VEltToXElt(pVElt, &pXElt) == VEOS_SUCCESS) X X /** assume caller protected *hXResult **/ X *hXResult = cons(pXElt, *hXResult); X } X } X } X else { X X for (iZone = pSite->iZones - 1; iZone >= 0; iZone --) { X iLeft = pSite->pWipeList[iZone].iLeft; X iRight = pSite->pWipeList[iZone].iRight; X iToKill = iRight - iLeft + 1; X X#ifndef OPTIMAL X if (NANCY_BUGS) { X fprintf(stderr, "nancy %s: left: %d right: %d\n", X WHOAMI, iLeft, iRight); X } X#endif X X for (iElt = iRight, pVElt = &pSite->pEnviron->pEltList[iRight]; X iElt >= iLeft; X iElt--, pVElt--) { X X iErr = Native_NewVEltToXElt(pVElt, &pXElt, *pTestTime); X if (iErr == VEOS_SUCCESS) { X X /** assume caller protected *hXResult **/ X *hXResult = cons(pXElt, *hXResult); X } X /* X else if (iErr == NATIVE_STALE) X iErr = VEOS_SUCCESS; X */ X } X } X } X X xlpop(); X X return(VEOS_SUCCESS); X X } /* Native_XCopySiteMatches */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Native_XRemoveSiteMatches(pSite, pTestTime, hXResult) X TPReplaceRec pSite; X TPTimeStamp pTestTime; X LVAL *hXResult; X{ X int iZone, iToKill, iElt, iLeft, iRight; X LVAL pXElt; X TPElt pVElt; X X xlsave1(pXElt); X X for (iZone = pSite->iZones - 1; iZone >= 0; iZone --) { X iLeft = pSite->pWipeList[iZone].iLeft; X iRight = pSite->pWipeList[iZone].iRight; X iToKill = iRight - iLeft + 1; X X /** convert outgoing data into supplanted language format. X ** that format is xlisp, and in reverse order X **/ X X for (iElt = iRight, pVElt = &pSite->pEnviron->pEltList[iRight]; X iElt >= iLeft; X iElt--, pVElt--) { X X if (Native_VEltToXElt(pVElt, &pXElt) == VEOS_SUCCESS) X X /** assume caller has protected *hXResult **/ X X *hXResult = cons(pXElt, *hXResult); X } X X Nancy_DeleteElementsInGrouple(pSite->pEnviron, X iLeft, X iToKill); X } X X xlpop(); X X return(VEOS_SUCCESS); X X } /* Native_XRemoveSiteMatches */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Native_XInsertEltAtSite(pXReplaceElt, pStampTime, pSite) X LVAL pXReplaceElt; X TPTimeStamp pStampTime; X TPReplaceRec pSite; X{ X TElt localElt; X TVeosErr iErr = VEOS_SUCCESS; X X if (pSite->iInsertElt >= 0) { X X localElt = NIL_ELT; X X if (pStampTime) X iErr = Native_XEltToNewVElt(pXReplaceElt, &localElt, *pStampTime); X else X iErr = Native_XEltToVElt(pXReplaceElt, &localElt); X X if (iErr == VEOS_SUCCESS) { X X Nancy_NewElementsInGrouple(pSite->pEnviron, pSite->iInsertElt, 1, X GR_unspecified, 0); X pSite->pEnviron->pEltList[pSite->iInsertElt] = localElt; X } X } X X return(iErr); X X } /* Native_XInsertEltAtSite */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Native_TouchSiteMatches(pSite, time) X TPReplaceRec pSite; X TTimeStamp time; X{ X int iZone, iElt, iLeft, iRight; X TPElt pVElt; X X for (iZone = pSite->iZones - 1; iZone >= 0; iZone --) { X X iLeft = pSite->pWipeList[iZone].iLeft; X iRight = pSite->pWipeList[iZone].iRight; X X /** simply update time stamp of given elements **/ X X for (iElt = iRight, pVElt = &pSite->pEnviron->pEltList[iRight]; X iElt >= iLeft; X iElt--, pVElt--) X X pVElt->tLastMod = time; X } X X return(VEOS_SUCCESS); X X } /* Native_TouchSiteMatches */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Native_MessageToLSpace(pMsgRec) X TPMsgRec pMsgRec; X{ X TVeosErr iErr; X LVAL pXElt, *hFinger; X int iLen; X char *pBuf; X X X xlsave1(pXElt); X X /** return data to grouple form **/ X X pBuf = pMsgRec->sMessage; X iLen = 0; X iErr = Native_MessageToXElt(pBuf, &pXElt, &iLen); X X#ifndef OPTIMAL X if (TALK_BUGS) { X fprintf(stderr, "listen %s: results of message conversion, native: %d\n", X WHOAMI, iErr); X } X#endif X X if (iErr == VEOS_SUCCESS) { X X#ifndef OPTIMAL X if (TALK_BUGS) { X fprintf(stderr, "listen %s: element in message:\n", WHOAMI); X X errprint(pXElt); X } X#endif X X /** append message to native inspace list **/ X X hFinger = NATIVE_INSPACE; X while (!null(*hFinger)) X hFinger = &cdr(*hFinger); X X *hFinger = cons(pXElt, NIL); X } X X xlpop(); X X return(iErr); X X } /* Native_MessageToLSpace */ X/****************************************************************************************/ X X X X/****************************************************************************************/ Xvoid Native_ShowMatchArgs(pMandRPB) X TPXMandRRec pMandRPB; X{ X fprintf(stderr, "nancy %s: MandR arguments.\n", WHOAMI); X X fprintf(stderr, "nancy %s: source:\n", WHOAMI); X Nancy_GroupleToStream(pMandRPB->pSrcGr, stderr); X X fprintf(stderr, "nancy %s: pattern:\n", WHOAMI); X Nancy_GroupleToStream(pMandRPB->pPatGr, stderr); X X fprintf(stderr, "nancy %s: destroyFlag: %s\n", WHOAMI, X pMandRPB->iDestroyFlag == NANCY_RemoveMatch ? "remove" : X pMandRPB->iDestroyFlag == NANCY_CopyMatch ? "copy" : X pMandRPB->iDestroyFlag == NANCY_ReplaceMatch ? "replace" : "unknown"); X X fprintf(stderr, "nancy %s: freqFlag: %s\n", WHOAMI, X pMandRPB->iFreqFlag == NANCY_MatchOne ? "one" : "all"); X X fprintf(stderr, "nancy %s: replace elt:\n", WHOAMI); X errprint(pMandRPB->pXReplaceElt); X X fprintf(stderr, "nancy %s: stamp-time: ", WHOAMI); X if (pMandRPB->pStampTime) X PRINT_TIME(*pMandRPB->pStampTime, stderr); X else X fprintf(stderr, "nil"); X fprintf(stderr, "\n"); X X fprintf(stderr, "nancy %s: test-time: ", WHOAMI); X if (pMandRPB->pTestTime) X PRINT_TIME(*pMandRPB->pTestTime, stderr); X else X fprintf(stderr, "nil"); X fprintf(stderr, "\n"); X X } X/****************************************************************************************/ X X X X/****************************************************************************************/ Xvoid Native_ShowSite(pSite) X TPReplaceRec pSite; X{ X fprintf(stderr, "nancy %s: site grouple:\n", WHOAMI); X Nancy_GroupleToStream(pSite->pEnviron, stderr); X fprintf(stderr, "nancy %s: site zones: %d\n", WHOAMI, pSite->iZones); X fprintf(stderr, "nancy %s: site insert elt: %d\n", WHOAMI, pSite->iInsertElt); X } X/****************************************************************************************/ X X X END_OF_FILE if test 24300 -ne `wc -c <'src/kernel_current/shell/xv_native.c'`; then echo shar: \"'src/kernel_current/shell/xv_native.c'\" unpacked with wrong size! fi # end of 'src/kernel_current/shell/xv_native.c' fi if test -f 'src/xlisp/xcore/c/xleval.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xleval.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xleval.c'\" \(21287 characters\) sed "s/^X//" >'src/xlisp/xcore/c/xleval.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xleval.c X* RCS: $Header: xleval.c,v 1.3 89/11/25 05:21:43 mayer Exp $ X* Description: xlisp evaluator X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:21:14 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 mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ Xstatic char rcs_identity[] = "@(#)$Header: xleval.c,v 1.3 89/11/25 05:21:43 mayer Exp $"; X X#include "xlisp.h" X X/* macro to check for lambda list keywords */ X#define iskey(s) ((s) == lk_optional \ X || (s) == lk_rest \ X || (s) == lk_key \ X || (s) == lk_aux \ X || (s) == lk_allow_other_keys) X X/* macros to handle tracing */ X#define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);} X#define trexit(sym,val) {if (sym) doexit(sym,val);} X X/* external variables */ Xextern LVAL xlenv,xlfenv,xldenv,xlvalue,true; Xextern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys; Xextern LVAL s_evalhook,s_applyhook,s_tracelist; Xextern LVAL s_lambda,s_macro; Xextern LVAL s_unbound; Xextern int xlsample; Xextern char buf[]; X X/* forward declarations */ XFORWARD LVAL xlxeval(); XFORWARD LVAL evalhook(); XFORWARD LVAL evform(); XFORWARD LVAL evfun(); X Xint iEvals = 0; /* Voodoo */ X X/* xleval - evaluate an xlisp expression (checking for *evalhook*) */ XLVAL xleval(expr) X LVAL expr; X{ X /* check for control codes */ X if (--xlsample <= 0) { X xlsample = SAMPLE; X oscheck(); X } X X iEvals ++; /* Voodoo */ X X /* check for *evalhook* */ X if (getvalue(s_evalhook)) X return (evalhook(expr)); X X /* check for nil */ X if (null(expr)) X return (NIL); X X /* dispatch on the node type */ X switch (ntype(expr)) { X case CONS: X return (evform(expr)); X case SYMBOL: X return (xlgetvalue(expr)); X default: X return (expr); X } X} X X#ifdef CURRENTLY_UNUSED X/* xlevalenv - evaluate an expression in a specified environment */ XLVAL xlevalenv(expr,env,fenv) X LVAL expr,env,fenv; X{ X LVAL oldenv,oldfenv,val; X X /* protect some pointers */ X xlstkcheck(2); X xlsave(oldenv); X xlsave(oldfenv); X X /* establish the new environment */ X oldenv = xlenv; X oldfenv = xlfenv; X xlenv = env; X xlfenv = fenv; X X /* evaluate the expression */ X val = xleval(expr); X X /* restore the environment */ X xlenv = oldenv; X xlfenv = oldfenv; X X /* restore the stack */ X xlpopn(2); X X /* return the result value */ X return (val); X} X#endif X X/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */ XLVAL xlxeval(expr) X LVAL expr; X{ X /* check for nil */ X if (null(expr)) X return (NIL); X X /* dispatch on node type */ X switch (ntype(expr)) { X case CONS: X return (evform(expr)); X case SYMBOL: X return (xlgetvalue(expr)); X default: X return (expr); X } X} X X/* xlapply - apply a function to arguments (already on the stack) */ XLVAL xlapply(argc) X int argc; X{ X LVAL *oldargv,fun,val; X int oldargc; X X /* get the function */ X fun = xlfp[1]; X X /* get the functional value of symbols */ X if (symbolp(fun)) { X while ((val = getfunction(fun)) == s_unbound) X xlfunbound(fun); X fun = xlfp[1] = val; X } X X /* check for nil */ X if (null(fun)) X xlerror("bad function",fun); X X /* dispatch on node type */ X switch (ntype(fun)) { X case SUBR: X oldargc = xlargc; X oldargv = xlargv; X xlargc = argc; X xlargv = xlfp + 3; X val = (*getsubr(fun))(); X xlargc = oldargc; X xlargv = oldargv; X break; X case CONS: X if (!consp(cdr(fun))) X xlerror("bad function",fun); X if (car(fun) == s_lambda) X fun = xlclose(NIL, X s_lambda, X car(cdr(fun)), X cdr(cdr(fun)), X xlenv,xlfenv); X else X xlerror("bad function",fun); X /**** fall through into the next case ****/ X case CLOSURE: X if (gettype(fun) != s_lambda) X xlerror("bad function",fun); X val = evfun(fun,argc,xlfp+3); X break; X default: X xlerror("bad function",fun); X } X X /* remove the call frame */ X xlsp = xlfp; X xlfp = xlfp - (int)getfixnum(*xlfp); X X /* return the function value */ X return (val); X} X X/* evform - evaluate a form */ XLOCAL LVAL evform(form) X LVAL form; X{ X LVAL fun,args,val,type; X LVAL tracing=NIL; X LVAL *argv; X int argc; X X /* protect some pointers */ X xlstkcheck(2); X xlsave(fun); X xlsave(args); X X /* get the function and the argument list */ X fun = car(form); X args = cdr(form); X X /* get the functional value of symbols */ X if (symbolp(fun)) { X if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist))) X tracing = fun; X fun = xlgetfunction(fun); X } X X /* check for nil */ X if (null(fun)) X xlerror("bad function",NIL); X X /* dispatch on node type */ X switch (ntype(fun)) { X case SUBR: X argv = xlargv; X argc = xlargc; X xlargc = evpushargs(fun,args); X xlargv = xlfp + 3; X trenter(tracing,xlargc,xlargv); X val = (*getsubr(fun))(); X trexit(tracing,val); X xlsp = xlfp; X xlfp = xlfp - (int)getfixnum(*xlfp); X xlargv = argv; X xlargc = argc; X break; X case FSUBR: X argv = xlargv; X argc = xlargc; X xlargc = pushargs(fun,args); X xlargv = xlfp + 3; X val = (*getsubr(fun))(); X xlsp = xlfp; X xlfp = xlfp - (int)getfixnum(*xlfp); X xlargv = argv; X xlargc = argc; X break; X case CONS: X if (!consp(cdr(fun))) X xlerror("bad function",fun); X if ((type = car(fun)) == s_lambda) X fun = xlclose(NIL, X s_lambda, X car(cdr(fun)), X cdr(cdr(fun)), X xlenv,xlfenv); X else X xlerror("bad function",fun); X /**** fall through into the next case ****/ X case CLOSURE: X if (gettype(fun) == s_lambda) { X argc = evpushargs(fun,args); X argv = xlfp + 3; X trenter(tracing,argc,argv); X val = evfun(fun,argc,argv); X trexit(tracing,val); X xlsp = xlfp; X xlfp = xlfp - (int)getfixnum(*xlfp); X } X else { X macroexpand(fun,args,&fun); X val = xleval(fun); X } X break; X default: X xlerror("bad function",fun); X } X X /* restore the stack */ X xlpopn(2); X X /* return the result value */ X return (val); X} X X/* xlexpandmacros - expand macros in a form */ XLVAL xlexpandmacros(form) X LVAL form; X{ X LVAL fun,args; X X /* protect some pointers */ X xlstkcheck(3); X xlprotect(form); X xlsave(fun); X xlsave(args); X X /* expand until the form isn't a macro call */ X while (consp(form)) { X fun = car(form); /* get the macro name */ X args = cdr(form); /* get the arguments */ X if (!symbolp(fun) || !fboundp(fun)) X break; X fun = xlgetfunction(fun); /* get the expansion function */ X if (!macroexpand(fun,args,&form)) X break; X } X X /* restore the stack and return the expansion */ X xlpopn(3); X return (form); X} X X/* macroexpand - expand a macro call */ Xint macroexpand(fun,args,pval) X LVAL fun,args,*pval; X{ X LVAL *argv; X int argc; X X /* make sure it's really a macro call */ X if (!closurep(fun) || gettype(fun) != s_macro) X return (FALSE); X X /* call the expansion function */ X argc = pushargs(fun,args); X argv = xlfp + 3; X *pval = evfun(fun,argc,argv); X xlsp = xlfp; X xlfp = xlfp - (int)getfixnum(*xlfp); X return (TRUE); X} X X/* evalhook - call the evalhook function */ XLOCAL LVAL evalhook(expr) X LVAL expr; X{ X LVAL *newfp,olddenv,val; X X /* create the new call frame */ X newfp = xlsp; X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp))); X pusharg(getvalue(s_evalhook)); X pusharg(cvfixnum((FIXTYPE)2)); X pusharg(expr); X pusharg(cons(xlenv,xlfenv)); X xlfp = newfp; X X /* rebind the hook functions to nil */ X olddenv = xldenv; X xldbind(s_evalhook,NIL); X xldbind(s_applyhook,NIL); X X /* call the hook function */ X val = xlapply(2); X X /* unbind the symbols */ X xlunbind(olddenv); X X /* return the value */ X return (val); X} X X/* evpushargs - evaluate and push a list of arguments */ XLOCAL int evpushargs(fun,args) X LVAL fun,args; X{ X LVAL *newfp; X int argc; X X /* protect the argument list */ X xlprot1(args); X X /* build a new argument stack frame */ X newfp = xlsp; X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp))); X pusharg(fun); X pusharg(NIL); /* will be argc */ X X /* evaluate and push each argument */ X for (argc = 0; consp(args); args = cdr(args), ++argc) X pusharg(xleval(car(args))); X X /* establish the new stack frame */ X newfp[2] = cvfixnum((FIXTYPE)argc); X xlfp = newfp; X X /* restore the stack */ X xlpop(); X X /* return the number of arguments */ X return (argc); X} X X/* pushargs - push a list of arguments */ Xint pushargs(fun,args) X LVAL fun,args; X{ X LVAL *newfp; X int argc; X X /* build a new argument stack frame */ X newfp = xlsp; X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp))); X pusharg(fun); X pusharg(NIL); /* will be argc */ X X /* push each argument */ X for (argc = 0; consp(args); args = cdr(args), ++argc) X pusharg(car(args)); X X /* establish the new stack frame */ X newfp[2] = cvfixnum((FIXTYPE)argc); X xlfp = newfp; X X /* return the number of arguments */ X return (argc); X} X X/* makearglist - make a list of the remaining arguments */ XLVAL makearglist(argc,argv) X int argc; LVAL *argv; X{ X LVAL list,this,last; X xlsave1(list); X for (last = NIL; --argc >= 0; last = this) { X this = cons(*argv++,NIL); X if (last) rplacd(last,this); X else list = this; X } X xlpop(); X return (list); X} X X/* evfun - evaluate a function */ XLOCAL LVAL evfun(fun,argc,argv) X LVAL fun; int argc; LVAL *argv; X{ X LVAL oldenv,oldfenv,cptr,name,val; X CONTEXT cntxt; X X /* protect some pointers */ X xlstkcheck(3); X xlsave(oldenv); X xlsave(oldfenv); X xlsave(cptr); X X /* create a new environment frame */ X oldenv = xlenv; X oldfenv = xlfenv; X xlenv = xlframe(xlgetenv(fun)); X xlfenv = getfenv(fun); X X /* bind the formal parameters */ X xlabind(fun,argc,argv); X X /* setup the implicit block */ X if (name = getname(fun)) X xlbegin(&cntxt,CF_RETURN,name); X X /* execute the block */ X if (name && xlsetjmp(cntxt.c_jmpbuf)) X val = xlvalue; X else X for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr)) X val = xleval(car(cptr)); X X /* finish the block context */ X if (name) X xlend(&cntxt); X X /* restore the environment */ X xlenv = oldenv; X xlfenv = oldfenv; X X /* restore the stack */ X xlpopn(3); X X /* return the result value */ X return (val); X} X X/* xlclose - create a function closure */ XLVAL xlclose(name,type,fargs,body,env,fenv) X LVAL name,type,fargs,body,env,fenv; X{ X LVAL closure,key,arg,def,svar,new,last; X char keyname[STRMAX+2]; X X /* protect some pointers */ X xlsave1(closure); X X /* create the closure object */ X closure = newclosure(name,type,env,fenv); X setlambda(closure,fargs); X setbody(closure,body); X X /* handle each required argument */ X last = NIL; X while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) { X X /* make sure the argument is a symbol */ X if (!symbolp(arg)) X badarglist(); X X /* create a new argument list entry */ X new = cons(arg,NIL); X X /* link it into the required argument list */ X if (last) X rplacd(last,new); X else X setargs(closure,new); X last = new; X X /* move the formal argument list pointer ahead */ X fargs = cdr(fargs); X } X X /* check for the '&optional' keyword */ X if (consp(fargs) && car(fargs) == lk_optional) { X fargs = cdr(fargs); X X /* handle each optional argument */ X last = NIL; X while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) { X X /* get the default expression and specified-p variable */ X def = svar = NIL; X if (consp(arg)) { X if (def = cdr(arg)) X if (consp(def)) { X if (svar = cdr(def)) X if (consp(svar)) { X svar = car(svar); X if (!symbolp(svar)) X badarglist(); X } X else X badarglist(); X def = car(def); X } X else X badarglist(); X arg = car(arg); X } X X /* make sure the argument is a symbol */ X if (!symbolp(arg)) X badarglist(); X X /* create a fully expanded optional expression */ X new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL); X X /* link it into the optional argument list */ X if (last) X rplacd(last,new); X else X setoargs(closure,new); X last = new; X X /* move the formal argument list pointer ahead */ X fargs = cdr(fargs); X } X } X X /* check for the '&rest' keyword */ X if (consp(fargs) && car(fargs) == lk_rest) { X fargs = cdr(fargs); X X /* get the &rest argument */ X if (consp(fargs) && (arg = car(fargs)) && !iskey(arg) && symbolp(arg)) X setrest(closure,arg); X else X badarglist(); X X /* move the formal argument list pointer ahead */ X fargs = cdr(fargs); X } X X /* check for the '&key' keyword */ X if (consp(fargs) && car(fargs) == lk_key) { X fargs = cdr(fargs); X X /* handle each key argument */ X last = NIL; X while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) { X X /* get the default expression and specified-p variable */ X def = svar = NIL; X if (consp(arg)) { X if (def = cdr(arg)) X if (consp(def)) { X if (svar = cdr(def)) X if (consp(svar)) { X svar = car(svar); X if (!symbolp(svar)) X badarglist(); X } X else X badarglist(); X def = car(def); X } X else X badarglist(); X arg = car(arg); X } X X /* get the keyword and the variable */ X if (consp(arg)) { X key = car(arg); X if (!symbolp(key)) X badarglist(); X if (arg = cdr(arg)) X if (consp(arg)) X arg = car(arg); X else X badarglist(); X } X else if (symbolp(arg)) { X strcpy(keyname,":"); X strcat(keyname,getstring(getpname(arg))); X key = xlenter(keyname); X } X X /* make sure the argument is a symbol */ X if (!symbolp(arg)) X badarglist(); X X /* create a fully expanded key expression */ X new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL); X X /* link it into the optional argument list */ X if (last) X rplacd(last,new); X else X setkargs(closure,new); X last = new; X X /* move the formal argument list pointer ahead */ X fargs = cdr(fargs); X } X } X X /* check for the '&allow-other-keys' keyword */ X if (consp(fargs) && car(fargs) == lk_allow_other_keys) X fargs = cdr(fargs); /* this is the default anyway */ X X /* check for the '&aux' keyword */ X if (consp(fargs) && car(fargs) == lk_aux) { X fargs = cdr(fargs); X X /* handle each aux argument */ X last = NIL; X while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) { X X /* get the initial value */ X def = NIL; X if (consp(arg)) { X if (def = cdr(arg)) X if (consp(def)) X def = car(def); X else X badarglist(); X arg = car(arg); X } X X /* make sure the argument is a symbol */ X if (!symbolp(arg)) X badarglist(); X X /* create a fully expanded aux expression */ X new = cons(cons(arg,cons(def,NIL)),NIL); X X /* link it into the aux argument list */ X if (last) X rplacd(last,new); X else X setaargs(closure,new); X last = new; X X /* move the formal argument list pointer ahead */ X fargs = cdr(fargs); X } X } X X /* make sure this is the end of the formal argument list */ X if (fargs) X badarglist(); X X /* restore the stack */ X xlpop(); X X /* return the new closure */ X return (closure); X} X X/* xlabind - bind the arguments for a function */ Xxlabind(fun,argc,argv) X LVAL fun; int argc; LVAL *argv; X{ X LVAL *kargv,fargs,key,arg,def,svar,p; X int rargc,kargc; X X /* protect some pointers */ X xlsave1(def); X X /* bind each required argument */ X for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) { X X /* make sure there is an actual argument */ X if (--argc < 0) X xlfail("too few arguments"); X X /* bind the formal variable to the argument value */ X xlbind(car(fargs),*argv++); X } X X /* bind each optional argument */ X for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) { X X /* get argument, default and specified-p variable */ X p = car(fargs); X arg = car(p); p = cdr(p); X def = car(p); p = cdr(p); X svar = car(p); X X /* bind the formal variable to the argument value */ X if (--argc >= 0) { X xlbind(arg,*argv++); X if (svar) xlbind(svar,true); X } X X /* bind the formal variable to the default value */ X else { X if (def) def = xleval(def); X xlbind(arg,def); X if (svar) xlbind(svar,NIL); X } X } X X /* save the count of the &rest of the argument list */ X rargc = argc; X X /* handle '&rest' argument */ X if (arg = getrest(fun)) { X def = makearglist(argc,argv); X xlbind(arg,def); X argc = 0; X } X X /* handle '&key' arguments */ X if (fargs = getkargs(fun)) { X for (; fargs; fargs = cdr(fargs)) { X X /* get keyword, argument, default and specified-p variable */ X p = car(fargs); X key = car(p); p = cdr(p); X arg = car(p); p = cdr(p); X def = car(p); p = cdr(p); X svar = car(p); X X /* look for the keyword in the actual argument list */ X for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2) X if (*kargv == key) X break; X X /* bind the formal variable to the argument value */ X if (kargc >= 0) { X xlbind(arg,*++kargv); X if (svar) xlbind(svar,true); X } X X /* bind the formal variable to the default value */ X else { X if (def) def = xleval(def); X xlbind(arg,def); X if (svar) xlbind(svar,NIL); X } X } X argc = 0; X } X X /* check for the '&aux' keyword */ X for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) { X X /* get argument and default */ X p = car(fargs); X arg = car(p); p = cdr(p); X def = car(p); X X /* bind the auxiliary variable to the initial value */ X if (def) def = xleval(def); X xlbind(arg,def); X } X X /* make sure there aren't too many arguments */ X if (argc > 0) X xlfail("too many arguments"); X X /* restore the stack */ X xlpop(); X} X X/* doenter - print trace information on function entry */ XLOCAL doenter(sym,argc,argv) X LVAL sym; int argc; LVAL *argv; X{ X extern int xltrcindent; X int i; X X /* indent to the current trace level */ X for (i = 0; i < xltrcindent; ++i) X trcputstr(" "); X ++xltrcindent; X X /* display the function call */ X sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym))); X trcputstr(buf); X while (--argc >= 0) { X trcprin1(*argv++); X if (argc) trcputstr(" "); X } X trcputstr(")\n"); X} X X/* doexit - print trace information for function/macro exit */ XLOCAL doexit(sym,val) X LVAL sym,val; X{ X extern int xltrcindent; X int i; X X /* indent to the current trace level */ X --xltrcindent; X for (i = 0; i < xltrcindent; ++i) X trcputstr(" "); X X /* display the function value */ X sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym))); X trcputstr(buf); X trcprin1(val); X trcputstr("\n"); X} X X/* member - is 'x' a member of 'list'? */ XLOCAL int member(x,list) X LVAL x,list; X{ X for (; consp(list); list = cdr(list)) X if (x == car(list)) X return (TRUE); X return (FALSE); X} X X/* xlunbound - signal an unbound variable error */ Xxlunbound(sym) X LVAL sym; X{ X xlcerror("try evaluating symbol again","unbound variable",sym); X} X X/* xlfunbound - signal an unbound function error */ Xxlfunbound(sym) X LVAL sym; X{ X xlcerror("try evaluating symbol again","unbound function",sym); X} X X/* xlstkoverflow - signal a stack overflow error */ Xxlstkoverflow() X{ X xlabort("evaluation stack overflow"); X} X X/* xlargstkoverflow - signal an argument stack overflow error */ Xxlargstkoverflow() X{ X xlabort("argument stack overflow"); X} X X/* badarglist - report a bad argument list error */ XLOCAL badarglist() X{ X xlfail("bad formal argument list"); X} END_OF_FILE if test 21287 -ne `wc -c <'src/xlisp/xcore/c/xleval.c'`; then echo shar: \"'src/xlisp/xcore/c/xleval.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xleval.c' fi if test -f 'src/xlisp/xcore/c/xlftab.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlftab.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlftab.c'\" \(22885 characters\) sed "s/^X//" >'src/xlisp/xcore/c/xlftab.c' <<'END_OF_FILE' X/* xlftab.c - xlisp function table */ X/* Copyright (c) 1985, by David Michael Betz */ X X#include "xlisp.h" X X/* external functions */ Xextern LVAL X rmhash(),rmquote(),rmdquote(),rmbquote(),rmcomma(), X clnew(),clisnew(),clanswer(), X obisnew(),obclass(),obshow(), X rmlpar(),rmrpar(),rmsemi(), X xeval(),xapply(),xfuncall(),xquote(),xfunction(),xbquote(), X xlambda(),xset(),xsetq(),xsetf(),xdefun(),xdefmacro(), X xgensym(),xmakesymbol(),xintern(), X xsymname(),xsymvalue(),xsymplist(), X xget(),xputprop(),xremprop(), X xhash(),xmkarray(),xaref(), X xcar(),xcdr(), X xcaar(),xcadr(),xcdar(),xcddr(), X xcaaar(),xcaadr(),xcadar(),xcaddr(), X xcdaar(),xcdadr(),xcddar(),xcdddr(), X xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(), X xcadaar(),xcadadr(),xcaddar(),xcadddr(), X xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(), X xcddaar(),xcddadr(),xcdddar(),xcddddr(), X xcons(),xlist(),xappend(),xreverse(),xlast(),xnth(),xnthcdr(), X xmember(),xassoc(),xsubst(),xsublis(),xlength(),xsort(), X xremove(),xremif(),xremifnot(), X xmapc(),xmapcar(),xmapl(),xmaplist(), X xrplca(),xrplcd(),xnconc(), X xdelete(),xdelif(),xdelifnot(), X xatom(),xsymbolp(),xnumberp(),xboundp(),xnull(),xlistp(),xendp(),xconsp(), X xeq(),xeql(),xequal(), X xcond(),xcase(),xand(),xor(),xlet(),xletstar(),xif(), X xprog(),xprogstar(),xprog1(),xprog2(),xprogn(),xgo(),xreturn(), X xcatch(),xthrow(), X xerror(),xcerror(),xbreak(), X xcleanup(),xtoplevel(),xcontinue(),xerrset(), X xbaktrace(),xevalhook(), X xdo(),xdostar(),xdolist(),xdotimes(), X xminusp(),xzerop(),xplusp(),xevenp(),xoddp(), X xfix(),xfloat(), X xgcd(),xadd(),xsub(),xmul(),xdiv(),xrem(),xmin(),xmax(),xabs(), X xadd1(),xsub1(),xlogand(),xlogior(),xlogxor(),xlognot(), X xsin(),xcos(),xtan(),xexpt(),xexp(),xsqrt(),xrand(), X xlss(),xleq(),xequ(),xneq(),xgeq(),xgtr(), X xstrcat(),xsubseq(),xstring(),xchar(), X xread(),xprint(),xprin1(),xprinc(),xterpri(), X xflatsize(),xflatc(), X xopen(),xclose(),xrdchar(),xpkchar(),xwrchar(),xreadline(), X xload(),xtranscript(), X xtype(),xexit(),xpeek(),xpoke(),xaddrs(), X xvector(),xblock(),xrtnfrom(),xtagbody(), X xpsetq(),xflet(),xlabels(),xmacrolet(),xunwindprotect(),xpp(), X xstrlss(),xstrleq(),xstreql(),xstrneq(),xstrgeq(),xstrgtr(), X xstrilss(),xstrileq(),xstrieql(),xstrineq(),xstrigeq(),xstrigtr(), X xupcase(),xdowncase(),xnupcase(),xndowncase(), X xtrim(),xlefttrim(),xrighttrim(), X xuppercasep(),xlowercasep(),xbothcasep(),xdigitp(),xalphanumericp(), X xcharcode(),xcodechar(),xchupcase(),xchdowncase(),xdigitchar(), X xchrlss(),xchrleq(),xchreql(),xchrneq(),xchrgeq(),xchrgtr(), X xchrilss(),xchrileq(),xchrieql(),xchrineq(),xchrigeq(),xchrigtr(), X xintegerp(),xfloatp(),xstringp(),xarrayp(),xstreamp(),xobjectp(), X xwhen(),xunless(),xloop(), X xsymfunction(),xfboundp(),xsend(),xsendsuper(), X xprogv(),xrdbyte(),xwrbyte(),xformat(), X xcharp(),xcharint(),xintchar(), X xmkstrinput(),xmkstroutput(),xgetstroutput(),xgetlstoutput(), X xgetlambda(),xmacroexpand(),x1macroexpand(), X xtrace(),xuntrace(), X xdefstruct(),xmkstruct(),xcpystruct(),xstrref(),xstrset(),xstrtypep(), X xasin(),xacos(),xatan(), X Prim_POPEN(), Prim_PCLOSE(), Prim_SYSTEM(), /* NPM */ X Prim_FSCANF_FIXNUM(), Prim_FSCANF_STRING(), Prim_FSCANF_FLONUM(), /* NPM */ X Prim_COPY_ARRAY(), Prim_ARRAY_INSERT_POS(), Prim_ARRAY_DELETE_POS(); /* NPM */ X Xextern LVAL xosenvget(); /* JSP */ Xextern void xlinclude_hybrid_prims(); /* Voodoo */ X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLFTAB_C_GLOBALS X#include "../../xmodules.h" X#undef MODULE_XLFTAB_C_GLOBALS X X/* functions specific to xldmem.c */ XLVAL xgc(),xexpand(),xalloc(),xmem(); X#ifdef SAVERESTORE XLVAL xsave(),xrestore(); X#endif X X/* include system dependent definitions */ X#include "osdefs.h" X X/* SUBR/FSUBR indicator */ X#define S SUBR X#define F FSUBR X X/* forward declarations */ XLVAL xnotimp(); X X/* the function table */ XFUNDEF *funtab; X X/* and its associated parts */ /* Voodoo */ X#define xlisp_prim_max 500 Xint iPrimCount; X X X/* xlfinit - setup xlisp function table */ /* Voodoo */ Xvoid xlfinit() X{ X int iIndex; X X if (funtab = (FUNDEF *) malloc(xlisp_prim_max * sizeof(FUNDEF))) { X X iPrimCount = 0; X X /* load xlisp native prims, updates iPrimCount global */ X xlinclude_native_prims(); X X /* load user's hybrid prims, updates iPrimCount global */ X xlinclude_hybrid_prims(); X X /* reserve a slot for sentinel */ X funtab[iPrimCount].fd_name = 0; X funtab[iPrimCount].fd_type = 0; X funtab[iPrimCount].fd_subr = 0; X iPrimCount ++; X X /* allocate permanent global funtable of exact size */ X funtab = (FUNDEF *) realloc(funtab, iPrimCount * sizeof(FUNDEF)); X } X X } /* xlfinit */ X X X X/* xldefine_prim - enter xlisp prim into xlisp function table */ Xvoid xldefine_prim(sName, iType, pFun) /* Voodoo */ X char *sName; X int iType; X LVAL (*pFun)(); X{ X funtab[iPrimCount].fd_name = sName; X funtab[iPrimCount].fd_type = iType; X funtab[iPrimCount].fd_subr = pFun; X iPrimCount ++; X } X X X X/* xnotimp - function table entries that are currently not implemented */ XLOCAL LVAL xnotimp() X{ X xlfail("function not implemented"); X} X X/* funtab_offset - find given fn in funtab. */ /* JSP */ X/* (Obviates need for hacks like FT_CLNEW.) */ /* JSP */ XLOCAL int funtab_index = 0; /* For O(1) lookup time on ordered requests. */ Xfuntab_offset(fn) /* JSP */ XLVAL (*fn)(); /* JSP */ X{ /* JSP */ X int wrapCount = 0; /* JSP */ X while (wrapCount < 2) { /* JSP */ X LVAL (*e)() = funtab[ funtab_index ].fd_subr; /* JSP */ X if (e == fn) return funtab_index; /* JSP */ X if (e) ++funtab_index; /* JSP */ X else {++wrapCount; funtab_index = 0;} /* JSP */ X } /* JSP */ X xlfatal("funtab_offset: internal error"); /* JSP */ X} /* JSP */ X X X X Xxlinclude_native_prims() X{ X /* read macro functions */ X X Xxldefine_prim(NULL, S, rmhash ); /* 0 */ Xxldefine_prim(NULL, S, rmquote ); /* 1 */ Xxldefine_prim(NULL, S, rmdquote ); /* 2 */ Xxldefine_prim(NULL, S, rmbquote ); /* 3 */ Xxldefine_prim(NULL, S, rmcomma ); /* 4 */ Xxldefine_prim(NULL, S, rmlpar ); /* 5 */ Xxldefine_prim(NULL, S, rmrpar ); /* 6 */ Xxldefine_prim(NULL, S, rmsemi ); /* 7 */ Xxldefine_prim(NULL, S, xnotimp ); /* 8 */ X#ifdef ORIGINAL Xxldefine_prim(NULL, S, xnotimp ); /* 9 */ X#else X /* BUGGO,need to put envget somewhere else. */ Xxldefine_prim("GETENV", S, xosenvget ); /* 9 */ X#endif X X /* methods */ Xxldefine_prim(NULL, S, clnew ); /* 10 */ Xxldefine_prim(NULL, S, clisnew ); /* 11 */ Xxldefine_prim(NULL, S, clanswer ); /* 12 */ Xxldefine_prim(NULL, S, obisnew ); /* 13 */ Xxldefine_prim(NULL, S, obclass ); /* 14 */ Xxldefine_prim(NULL, S, obshow ); /* 15 */ Xxldefine_prim(NULL, S, xnotimp ); /* 16 */ Xxldefine_prim(NULL, S, xnotimp ); /* 17 */ Xxldefine_prim(NULL, S, xnotimp ); /* 18 */ Xxldefine_prim(NULL, S, xnotimp ); /* 19 */ X X /* evaluator functions */ Xxldefine_prim("EVAL", S, xeval ); /* 20 */ Xxldefine_prim("APPLY", S, xapply ); /* 21 */ Xxldefine_prim("FUNCALL", S, xfuncall ); /* 22 */ Xxldefine_prim("QUOTE", F, xquote ); /* 23 */ Xxldefine_prim("FUNCTION", F, xfunction ); /* 24 */ Xxldefine_prim("BACKQUOTE", F, xbquote ); /* 25 */ Xxldefine_prim("LAMBDA", F, xlambda ); /* 26 */ X X /* symbol functions */ Xxldefine_prim("SET", S, xset ); /* 27 */ Xxldefine_prim("SETQ", F, xsetq ); /* 28 */ Xxldefine_prim("SETF", F, xsetf ); /* 29 */ Xxldefine_prim("DEFUN", F, xdefun ); /* 30 */ Xxldefine_prim("DEFMACRO", F, xdefmacro ); /* 31 */ Xxldefine_prim("GENSYM", S, xgensym ); /* 32 */ Xxldefine_prim("MAKE-SYMBOL", S, xmakesymbol ); /* 33 */ Xxldefine_prim("INTERN", S, xintern ); /* 34 */ Xxldefine_prim("SYMBOL-NAME", S, xsymname ); /* 35 */ Xxldefine_prim("SYMBOL-VALUE", S, xsymvalue ); /* 36 */ Xxldefine_prim("SYMBOL-PLIST", S, xsymplist ); /* 37 */ Xxldefine_prim("GET", S, xget ); /* 38 */ Xxldefine_prim("PUTPROP", S, xputprop); /* 39 */ Xxldefine_prim("REMPROP", S, xremprop ); /* 40 */ Xxldefine_prim("HASH", S, xhash ); /* 41 */ X X /* array functions */ Xxldefine_prim("MAKE-ARRAY", S, xmkarray ); /* 42 */ Xxldefine_prim("AREF", S, xaref ); /* 43 */ X X /* list functions */ Xxldefine_prim("CAR", S, xcar ); /* 44 */ Xxldefine_prim("CDR", S, xcdr ); /* 45 */ X Xxldefine_prim("CAAR", S, xcaar ); /* 46 */ Xxldefine_prim("CADR", S, xcadr ); /* 47 */ Xxldefine_prim("CDAR", S, xcdar ); /* 48 */ Xxldefine_prim("CDDR", S, xcddr ); /* 49 */ X Xxldefine_prim("CAAAR", S, xcaaar ); /* 50 */ Xxldefine_prim("CAADR", S, xcaadr ); /* 51 */ Xxldefine_prim("CADAR", S, xcadar ); /* 52 */ Xxldefine_prim("CADDR", S, xcaddr ); /* 53 */ Xxldefine_prim("CDAAR", S, xcdaar ); /* 54 */ Xxldefine_prim("CDADR", S, xcdadr ); /* 55 */ Xxldefine_prim("CDDAR", S, xcddar ); /* 56 */ Xxldefine_prim("CDDDR", S, xcdddr ); /* 57 */ X Xxldefine_prim("CAAAAR", S, xcaaaar ); /* 58 */ Xxldefine_prim("CAAADR", S, xcaaadr ); /* 59 */ Xxldefine_prim("CAADAR", S, xcaadar ); /* 60 */ Xxldefine_prim("CAADDR", S, xcaaddr ); /* 61 */ Xxldefine_prim("CADAAR", S, xcadaar ); /* 62 */ Xxldefine_prim("CADADR", S, xcadadr ); /* 63 */ Xxldefine_prim("CADDAR", S, xcaddar ); /* 64 */ Xxldefine_prim("CADDDR", S, xcadddr ); /* 65 */ Xxldefine_prim("CDAAAR", S, xcdaaar ); /* 66 */ Xxldefine_prim("CDAADR", S, xcdaadr ); /* 67 */ Xxldefine_prim("CDADAR", S, xcdadar ); /* 68 */ Xxldefine_prim("CDADDR", S, xcdaddr ); /* 69 */ Xxldefine_prim("CDDAAR", S, xcddaar ); /* 70 */ Xxldefine_prim("CDDADR", S, xcddadr ); /* 71 */ Xxldefine_prim("CDDDAR", S, xcdddar ); /* 72 */ Xxldefine_prim("CDDDDR", S, xcddddr ); /* 73 */ X Xxldefine_prim("CONS", S, xcons ); /* 74 */ Xxldefine_prim("LIST", S, xlist ); /* 75 */ Xxldefine_prim("APPEND", S, xappend ); /* 76 */ Xxldefine_prim("REVERSE", S, xreverse ); /* 77 */ Xxldefine_prim("LAST", S, xlast ); /* 78 */ Xxldefine_prim("NTH", S, xnth ); /* 79 */ Xxldefine_prim("NTHCDR", S, xnthcdr ); /* 80 */ Xxldefine_prim("MEMBER", S, xmember ); /* 81 */ Xxldefine_prim("ASSOC", S, xassoc ); /* 82 */ Xxldefine_prim("SUBST", S, xsubst ); /* 83 */ Xxldefine_prim("SUBLIS", S, xsublis ); /* 84 */ Xxldefine_prim("REMOVE", S, xremove ); /* 85 */ Xxldefine_prim("LENGTH", S, xlength ); /* 86 */ Xxldefine_prim("MAPC", S, xmapc ); /* 87 */ Xxldefine_prim("MAPCAR", S, xmapcar ); /* 88 */ Xxldefine_prim("MAPL", S, xmapl ); /* 89 */ Xxldefine_prim("MAPLIST", S, xmaplist ); /* 90 */ X X /* destructive list functions */ Xxldefine_prim("RPLACA", S, xrplca ); /* 91 */ Xxldefine_prim("RPLACD", S, xrplcd ); /* 92 */ Xxldefine_prim("NCONC", S, xnconc ); /* 93 */ Xxldefine_prim("DELETE", S, xdelete ); /* 94 */ X X /* predicate functions */ Xxldefine_prim("ATOM", S, xatom ); /* 95 */ Xxldefine_prim("SYMBOLP", S, xsymbolp ); /* 96 */ Xxldefine_prim("NUMBERP", S, xnumberp ); /* 97 */ Xxldefine_prim("BOUNDP", S, xboundp ); /* 98 */ Xxldefine_prim("NULL", S, xnull ); /* 99 */ Xxldefine_prim("LISTP", S, xlistp ); /* 100 */ Xxldefine_prim("CONSP", S, xconsp ); /* 101 */ Xxldefine_prim("MINUSP", S, xminusp ); /* 102 */ Xxldefine_prim("ZEROP", S, xzerop ); /* 103 */ Xxldefine_prim("PLUSP", S, xplusp ); /* 104 */ Xxldefine_prim("EVENP", S, xevenp ); /* 105 */ Xxldefine_prim("ODDP", S, xoddp ); /* 106 */ Xxldefine_prim("EQ", S, xeq ); /* 107 */ Xxldefine_prim("EQL", S, xeql ); /* 108 */ Xxldefine_prim("EQUAL", S, xequal ); /* 109 */ X X /* special forms */ Xxldefine_prim("COND", F, xcond ); /* 110 */ Xxldefine_prim("CASE", F, xcase ); /* 111 */ Xxldefine_prim("AND", F, xand ); /* 112 */ Xxldefine_prim("OR", F, xor ); /* 113 */ Xxldefine_prim("LET", F, xlet ); /* 114 */ Xxldefine_prim("LET*", F, xletstar ); /* 115 */ Xxldefine_prim("IF", F, xif ); /* 116 */ Xxldefine_prim("PROG", F, xprog ); /* 117 */ Xxldefine_prim("PROG*", F, xprogstar ); /* 118 */ Xxldefine_prim("PROG1", F, xprog1 ); /* 119 */ Xxldefine_prim("PROG2", F, xprog2 ); /* 120 */ Xxldefine_prim("PROGN", F, xprogn ); /* 121 */ Xxldefine_prim("GO", F, xgo ); /* 122 */ Xxldefine_prim("RETURN", F, xreturn ); /* 123 */ Xxldefine_prim("DO", F, xdo ); /* 124 */ Xxldefine_prim("DO*", F, xdostar ); /* 125 */ Xxldefine_prim("DOLIST", F, xdolist ); /* 126 */ Xxldefine_prim("DOTIMES", F, xdotimes ); /* 127 */ Xxldefine_prim("CATCH", F, xcatch ); /* 128 */ Xxldefine_prim("THROW", F, xthrow ); /* 129 */ X X /* debugging and error handling functions */ Xxldefine_prim("ERROR", S, xerror ); /* 130 */ Xxldefine_prim("CERROR", S, xcerror ); /* 131 */ Xxldefine_prim("BREAK", S, xbreak ); /* 132 */ Xxldefine_prim("CLEAN-UP", S, xcleanup ); /* 133 */ Xxldefine_prim("TOP-LEVEL", S, xtoplevel ); /* 134 */ Xxldefine_prim("CONTINUE", S, xcontinue ); /* 135 */ Xxldefine_prim("ERRSET", F, xerrset ); /* 136 */ Xxldefine_prim("BAKTRACE", S, xbaktrace ); /* 137 */ Xxldefine_prim("EVALHOOK", S, xevalhook ); /* 138 */ X X /* arithmetic functions */ Xxldefine_prim("TRUNCATE", S, xfix ); /* 139 */ Xxldefine_prim("FLOAT", S, xfloat ); /* 140 */ Xxldefine_prim("+", S, xadd ); /* 141 */ Xxldefine_prim("-", S, xsub ); /* 142 */ Xxldefine_prim("*", S, xmul ); /* 143 */ Xxldefine_prim("/", S, xdiv ); /* 144 */ Xxldefine_prim("1+", S, xadd1 ); /* 145 */ Xxldefine_prim("1-", S, xsub1 ); /* 146 */ Xxldefine_prim("REM", S, xrem ); /* 147 */ Xxldefine_prim("MIN", S, xmin ); /* 148 */ Xxldefine_prim("MAX", S, xmax ); /* 149 */ Xxldefine_prim("ABS", S, xabs ); /* 150 */ Xxldefine_prim("SIN", S, xsin ); /* 151 */ Xxldefine_prim("COS", S, xcos ); /* 152 */ Xxldefine_prim("TAN", S, xtan ); /* 153 */ Xxldefine_prim("EXPT", S, xexpt ); /* 154 */ Xxldefine_prim("EXP", S, xexp ); /* 155 */ Xxldefine_prim("SQRT", S, xsqrt ); /* 156 */ Xxldefine_prim("RANDOM", S, xrand ); /* 157 */ X X /* bitwise logical functions */ Xxldefine_prim("LOGAND", S, xlogand ); /* 158 */ Xxldefine_prim("LOGIOR", S, xlogior ); /* 159 */ Xxldefine_prim("LOGXOR", S, xlogxor ); /* 160 */ Xxldefine_prim("LOGNOT", S, xlognot ); /* 161 */ X X /* numeric comparison functions */ Xxldefine_prim("<", S, xlss ); /* 162 */ Xxldefine_prim("<=", S, xleq ); /* 163 */ Xxldefine_prim("=", S, xequ ); /* 164 */ Xxldefine_prim("/=", S, xneq ); /* 165 */ Xxldefine_prim(">=", S, xgeq ); /* 166 */ Xxldefine_prim(">", S, xgtr ); /* 167 */ X X /* string functions */ Xxldefine_prim("STRCAT", S, xstrcat ); /* 168 */ Xxldefine_prim("SUBSEQ", S, xsubseq ); /* 169 */ Xxldefine_prim("STRING", S, xstring ); /* 170 */ Xxldefine_prim("CHAR", S, xchar ); /* 171 */ X X /* I/O functions */ Xxldefine_prim("READ", S, xread ); /* 172 */ Xxldefine_prim("PRINT", S, xprint ); /* 173 */ Xxldefine_prim("PRIN1", S, xprin1 ); /* 174 */ Xxldefine_prim("PRINC", S, xprinc ); /* 175 */ Xxldefine_prim("TERPRI", S, xterpri ); /* 176 */ Xxldefine_prim("FLATSIZE", S, xflatsize ); /* 177 */ Xxldefine_prim("FLATC", S, xflatc ); /* 178 */ X X /* file I/O functions */ Xxldefine_prim("OPEN", S, xopen ); /* 179 */ Xxldefine_prim("FORMAT", S, xformat ); /* 180 */ Xxldefine_prim("CLOSE", S, xclose ); /* 181 */ Xxldefine_prim("READ-CHAR", S, xrdchar ); /* 182 */ Xxldefine_prim("PEEK-CHAR", S, xpkchar ); /* 183 */ Xxldefine_prim("WRITE-CHAR", S, xwrchar ); /* 184 */ Xxldefine_prim("READ-LINE", S, xreadline ); /* 185 */ X X /* system functions */ Xxldefine_prim("LOAD", S, xload ); /* 186 */ Xxldefine_prim("DRIBBLE", S, xtranscript ); /* 187 */ X X /* functions specific to xldmem.c */ Xxldefine_prim("GC", S, xgc ); /* 188 */ Xxldefine_prim("EXPAND", S, xexpand ); /* 189 */ Xxldefine_prim("ALLOC", S, xalloc ); /* 190 */ Xxldefine_prim("ROOM", S, xmem ); /* 191 */ X#ifdef SAVERESTORE Xxldefine_prim("SAVE", S, xsave ); /* 192 */ Xxldefine_prim("RESTORE", S, xrestore ); /* 193 */ X#else Xxldefine_prim(NULL, S, xnotimp ); /* 192 */ Xxldefine_prim(NULL, S, xnotimp ); /* 193 */ X#endif X /* end of functions specific to xldmem.c */ X Xxldefine_prim("TYPE-OF", S, xtype ); /* 194 */ Xxldefine_prim("EXIT", S, xexit ); /* 195 */ Xxldefine_prim("PEEK", S, xpeek ); /* 196 */ Xxldefine_prim("POKE", S, xpoke ); /* 197 */ Xxldefine_prim("ADDRESS-OF", S, xaddrs ); /* 198 */ X X /* new functions and special forms */ Xxldefine_prim("VECTOR", S, xvector ); /* 199 */ Xxldefine_prim("BLOCK", F, xblock ); /* 200 */ Xxldefine_prim("RETURN-FROM", F, xrtnfrom ); /* 201 */ Xxldefine_prim("TAGBODY", F, xtagbody ); /* 202 */ Xxldefine_prim("PSETQ", F, xpsetq ); /* 203 */ Xxldefine_prim("FLET", F, xflet ); /* 204 */ Xxldefine_prim("LABELS", F, xlabels ); /* 205 */ Xxldefine_prim("MACROLET", F, xmacrolet ); /* 206 */ Xxldefine_prim("UNWIND-PROTECT", F, xunwindprotect ); /* 207 */ Xxldefine_prim("PPRINT", S, xpp ); /* 208 */ Xxldefine_prim("STRING<", S, xstrlss ); /* 209 */ Xxldefine_prim("STRING<=", S, xstrleq ); /* 210 */ Xxldefine_prim("STRING=", S, xstreql ); /* 211 */ Xxldefine_prim("STRING/=", S, xstrneq ); /* 212 */ Xxldefine_prim("STRING>=", S, xstrgeq ); /* 213 */ Xxldefine_prim("STRING>", S, xstrgtr ); /* 214 */ Xxldefine_prim("STRING-LESSP", S, xstrilss ); /* 215 */ Xxldefine_prim("STRING-NOT-GREATERP", S, xstrileq ); /* 216 */ Xxldefine_prim("STRING-EQUAL", S, xstrieql ); /* 217 */ Xxldefine_prim("STRING-NOT-EQUAL", S, xstrineq ); /* 218 */ Xxldefine_prim("STRING-NOT-LESSP", S, xstrigeq ); /* 219 */ Xxldefine_prim("STRING-GREATERP", S, xstrigtr ); /* 220 */ Xxldefine_prim("INTEGERP", S, xintegerp ); /* 221 */ Xxldefine_prim("FLOATP", S, xfloatp ); /* 222 */ Xxldefine_prim("STRINGP", S, xstringp ); /* 223 */ Xxldefine_prim("ARRAYP", S, xarrayp ); /* 224 */ Xxldefine_prim("STREAMP", S, xstreamp ); /* 225 */ Xxldefine_prim("OBJECTP", S, xobjectp ); /* 226 */ Xxldefine_prim("STRING-UPCASE", S, xupcase ); /* 227 */ Xxldefine_prim("STRING-DOWNCASE", S, xdowncase ); /* 228 */ Xxldefine_prim("NSTRING-UPCASE", S, xnupcase ); /* 229 */ Xxldefine_prim("NSTRING-DOWNCASE", S, xndowncase ); /* 230 */ Xxldefine_prim("STRING-TRIM", S, xtrim ); /* 231 */ Xxldefine_prim("STRING-LEFT-TRIM", S, xlefttrim ); /* 232 */ Xxldefine_prim("STRING-RIGHT-TRIM", S, xrighttrim ); /* 233 */ Xxldefine_prim("WHEN", F, xwhen ); /* 234 */ Xxldefine_prim("UNLESS", F, xunless ); /* 235 */ Xxldefine_prim("LOOP", F, xloop ); /* 236 */ Xxldefine_prim("SYMBOL-FUNCTION", S, xsymfunction ); /* 237 */ Xxldefine_prim("FBOUNDP", S, xfboundp ); /* 238 */ Xxldefine_prim("SEND", S, xsend ); /* 239 */ Xxldefine_prim("SEND-SUPER", S, xsendsuper ); /* 240 */ Xxldefine_prim("PROGV", F, xprogv ); /* 241 */ Xxldefine_prim("CHARACTERP", S, xcharp ); /* 242 */ Xxldefine_prim("CHAR-INT", S, xcharint ); /* 243 */ Xxldefine_prim("INT-CHAR", S, xintchar ); /* 244 */ Xxldefine_prim("READ-BYTE", S, xrdbyte ); /* 245 */ Xxldefine_prim("WRITE-BYTE", S, xwrbyte ); /* 246 */ Xxldefine_prim("MAKE-STRING-INPUT-STREAM", S, xmkstrinput ); /* 247 */ Xxldefine_prim("MAKE-STRING-OUTPUT-STREAM", S, xmkstroutput ); /* 248 */ Xxldefine_prim("GET-OUTPUT-STREAM-STRING", S, xgetstroutput ); /* 249 */ Xxldefine_prim("GET-OUTPUT-STREAM-LIST", S, xgetlstoutput ); /* 250 */ Xxldefine_prim("GCD", S, xgcd ); /* 251 */ Xxldefine_prim("GET-LAMBDA-EXPRESSION", S, xgetlambda ); /* 252 */ Xxldefine_prim("MACROEXPAND", S, xmacroexpand ); /* 253 */ Xxldefine_prim("MACROEXPAND-1", S, x1macroexpand ); /* 254 */ Xxldefine_prim("CHAR<", S, xchrlss ); /* 255 */ Xxldefine_prim("CHAR<=", S, xchrleq ); /* 256 */ Xxldefine_prim("CHAR=", S, xchreql ); /* 257 */ Xxldefine_prim("CHAR/=", S, xchrneq ); /* 258 */ Xxldefine_prim("CHAR>=", S, xchrgeq ); /* 259 */ Xxldefine_prim("CHAR>", S, xchrgtr ); /* 260 */ Xxldefine_prim("CHAR-LESSP", S, xchrilss ); /* 261 */ Xxldefine_prim("CHAR-NOT-GREATERP", S, xchrileq ); /* 262 */ Xxldefine_prim("CHAR-EQUAL", S, xchrieql ); /* 263 */ Xxldefine_prim("CHAR-NOT-EQUAL", S, xchrineq ); /* 264 */ Xxldefine_prim("CHAR-NOT-LESSP", S, xchrigeq ); /* 265 */ Xxldefine_prim("CHAR-GREATERP", S, xchrigtr ); /* 266 */ Xxldefine_prim("UPPER-CASE-P", S, xuppercasep ); /* 267 */ Xxldefine_prim("LOWER-CASE-P", S, xlowercasep ); /* 268 */ Xxldefine_prim("BOTH-CASE-P", S, xbothcasep ); /* 269 */ Xxldefine_prim("DIGIT-CHAR-P", S, xdigitp ); /* 270 */ Xxldefine_prim("ALPHANUMERICP", S, xalphanumericp ); /* 271 */ Xxldefine_prim("CHAR-UPCASE", S, xchupcase ); /* 272 */ Xxldefine_prim("CHAR-DOWNCASE", S, xchdowncase ); /* 273 */ Xxldefine_prim("DIGIT-CHAR", S, xdigitchar ); /* 274 */ Xxldefine_prim("CHAR-CODE", S, xcharcode ); /* 275 */ Xxldefine_prim("CODE-CHAR", S, xcodechar ); /* 276 */ Xxldefine_prim("ENDP", S, xendp ); /* 277 */ Xxldefine_prim("REMOVE-IF", S, xremif ); /* 278 */ Xxldefine_prim("REMOVE-IF-NOT", S, xremifnot ); /* 279 */ Xxldefine_prim("DELETE-IF", S, xdelif ); /* 280 */ Xxldefine_prim("DELETE-IF-NOT", S, xdelifnot ); /* 281 */ Xxldefine_prim("TRACE", F, xtrace ); /* 282 */ Xxldefine_prim("UNTRACE", F, xuntrace ); /* 283 */ Xxldefine_prim("SORT", S, xsort ); /* 284 */ Xxldefine_prim("DEFSTRUCT", F, xdefstruct ); /* 285 */ Xxldefine_prim("%STRUCT-TYPE-P", S, xstrtypep ); /* 286 */ Xxldefine_prim("%MAKE-STRUCT", S, xmkstruct ); /* 287 */ Xxldefine_prim("%COPY-STRUCT", S, xcpystruct ); /* 288 */ Xxldefine_prim("%STRUCT-REF", S, xstrref ); /* 289 */ Xxldefine_prim("%STRUCT-SET", S, xstrset ); /* 290 */ Xxldefine_prim("ASIN", S, xasin ); /* 291 */ Xxldefine_prim("ACOS", S, xacos ); /* 292 */ Xxldefine_prim("ATAN", S, xatan ); /* 293 */ X X /* extra table entries */ Xxldefine_prim("SYSTEM", S, Prim_SYSTEM ); /* 294 NPM */ Xxldefine_prim("POPEN", S, Prim_POPEN ); /* 295 NPM */ Xxldefine_prim("PCLOSE", S, Prim_PCLOSE ); /* 296 NPM */ Xxldefine_prim("FSCANF-FIXNUM", S, Prim_FSCANF_FIXNUM ); /* 297 NPM */ Xxldefine_prim("FSCANF-STRING", S, Prim_FSCANF_STRING ); /* 298 NPM */ Xxldefine_prim("FSCANF-FLONUM", S, Prim_FSCANF_FLONUM ); /* 299 NPM */ Xxldefine_prim("COPY-ARRAY", S, Prim_COPY_ARRAY ); /* 300 NPM */ Xxldefine_prim("ARRAY-INSERT-POS", S, Prim_ARRAY_INSERT_POS); /* 301 NPM */ Xxldefine_prim("ARRAY-DELETE-POS", S, Prim_ARRAY_DELETE_POS); /* 302 NPM */ X X /* include system dependant function pointers */ X#include "osptrs.h" X X/* Include hybrid-class funtab entries: */ /* JSP a la Voodoo */ X#define MODULE_XLFTAB_C_FUNTAB_S X#include "../../xmodules.h" X#undef MODULE_XLFTAB_C_FUNTAB_S X X/* Include hybrid-class funtab entries: */ /* JSP a la Voodoo */ X#define MODULE_XLFTAB_C_FUNTAB_F X#include "../../xmodules.h" X#undef MODULE_XLFTAB_C_FUNTAB_F X X} END_OF_FILE if test 22885 -ne `wc -c <'src/xlisp/xcore/c/xlftab.c'`; then echo shar: \"'src/xlisp/xcore/c/xlftab.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlftab.c' fi echo shar: End of archive 10 \(of 16\). cp /dev/null ark10isdone 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