Usenet 1994 January

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume26 / veos-2.0 / part04 < prev next >

Wrap

Text File | 1993-04-25 | 87.0 KB | 3,138 lines

Newsgroups: comp.sources.unix From: voodoo@hitl.washington.edu (Geoffery Coco) Subject: v26i187: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part04/16 Sender: unix-sources-moderator@vix.com Approved: paul@vix.com Submitted-By: voodoo@hitl.washington.edu (Geoffery Coco) Posting-Number: Volume 26, Issue 187 Archive-Name: veos-2.0/part04 #! /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 4 (of 16)." # Contents: kernel_private/src/fern/fx.lsp # kernel_private/src/include/kernel.h # kernel_private/src/shell/shell.c src/kernel_current/fern/fx.lsp # src/kernel_current/include/kernel.h # src/kernel_current/shell/shell.c src/xlisp/xcore/c/xlinit.c # src/xlisp/xcore/c/xlprin.c # Wrapped by vixie@efficacy.home.vix.com on Sun Apr 25 23:10:34 1993 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'kernel_private/src/fern/fx.lsp' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kernel_private/src/fern/fx.lsp'\" else echo shar: Extracting \"'kernel_private/src/fern/fx.lsp'\" $9543 characters$ sed "s/^X//" >'kernel_private/src/fern/fx.lsp' <<'END_OF_FILE' X;;----------------------------------------------------------- X;; file: fx.lsp X;; X;; FERN is the Fractal Entity Relativity Node. X;; This file is the trans compenent of the Fern System. X;; X;; creation: March 28, 1992 X;; X;; by Geoffrey P. Coco at the HITLab, Seattle X;;----------------------------------------------------------- X X;;----------------------------------------------------------- X;; Copyright (C) 1992 Geoffrey P. Coco, X;; Human Interface Technology Lab, Seattle X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X#| X XThe FX component of the Fern System is concerned with normal Xcommunications between space and entity. X XA primary purpose of the Fern System is to transparently Xmaintain the distributed world database. These functions Xprovide the inter-entity transport mechanism for the Fern XSystem and they compose the FX component of the Fern System. X X|# X;;----------------------------------------------------------- X X X X;;=========================================================== X;; X;; FX PUBLIC FUNCTIONS X;; X;;=========================================================== X X X;;----------------------------------------------------------- X;; Entity Level Binding Entry Pts X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X X;; instigate a space/entity relationship between your entity X;; and the given entity. sp-uid becomes a space of yours. X;; any entity/space token loop begins here. X X(defun fx-enter (sp-uid) X (cond ((fe-copy.ext.sps.ent sp-uid)) X (t X (cond (fern-debug X (printf "fx-enter... new space: " (uid2str sp-uid)))) X X ;; add new space to external partition X (fe-put.ext.sps.ent (list sp-uid ())) X X ;; add delta time-stamp to hash table X (fbase-put-hash fern-ent-htab sp-uid (vmintime)) X X ;; pass first boundary update (i.e. the token) to space X (vthrow (list sp-uid) X `(fx-sp-enter ,self (quote ,(fx-ent-exude sp-uid)))) X t))) X X;;----------------------------------------------------------- X X;; instagate the exit procedure. X;; terminate a space/entity relationship between your entity X;; and the given entity. the token will travel one more time X;; around. X X(defun fx-exit (sp-uid) X X X (cond ((fe-copy.ext.sps.ent sp-uid) X X (cond (fern-debug X (printf "fx-exit... space: " (uid2str sp-uid)))) X X ;; remove space from space list. X (fe-get.ext.sps.ent sp-uid) X X ;; remove this entry from timestamp hash table X (fbase-get-hash fern-ent-htab sp-uid) X X ;; assume that entity has the token. X ;; NOTE: this is not a safe assumption. X ;; In other words, it is only safe to call X ;; fx-exit from within a react proc. X X ;; token now passes one more time through it's loop X ;; to the space (fx-sp-exit, fx-sp-unperceive) X ;; then, ending at (fx-ent-unperceive) X (vthrow (list sp-uid) X `(fx-sp-exit ,self)) X ))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; X;; FX PRIVATE FUNCTIONS X;; X;;=========================================================== X X X;;----------------------------------------------------------- X X(defun fx-init () X (setq fern-sp-htab (fbase-new-htab)) X (setq fern-ent-htab (fbase-new-htab)) X ) X X;;----------------------------------------------------------- X X X X;;----------------------------------------------------------- X;; Space Level Binding Entry Pts X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X X;; accept a space/entity relationship between from another X;; entity. setup initial data structures, pass included X;; entity->space token into token loop. X X(defun fx-sp-enter (ent-uid vbf) X (progn X (cond (fern-debug X (printf "fx-sp-enter... new entity: " (uid2str ent-uid)))) X X ;; the entering entity has already checked for duplicates. X ;; add new entity to sublings partition, X ;; overiding a possible previous deletion. X (fe-put.int.subs.ent (list ent-uid nil)) X X ;; add new entity with delta time-stamp to fern hash table X (fbase-put-hash fern-sp-htab ent-uid (vmintime)) X X ;; pass included token to normal space entry point X (fx-sp-perceive ent-uid vbf) X )) X X;;----------------------------------------------------------- X X;; accept a termination request of space/entity relationship X;; from another entity. takedown data structures, pass included X;; entity->space token into final token loop. X X(defun fx-sp-exit (ent-uid) X (progn X (cond (fern-debug X (printf "fx-sp-exit... retiring entity: " (uid2str ent-uid)))) X X ;; remove entity timestamp hash table X (fbase-get-hash fern-sp-htab ent-uid) X X ;; remove entity from sublings partition.. X ;; and thus from the externals of all other entities in this space. X (fe-get.int.subs.ent ent-uid) X X ;; eliminate perceptual references to this entity X (fx-sp-unperceive ent-uid) X )) X X;;----------------------------------------------------------- X X X X;;----------------------------------------------------------- X;; Space Token Normal Operation X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X X(defun fx-ent-perceive (which-sp bndry-list) X (progn X (cond (fern-debug X (printf "fx-ent-perceive ... from space: " (uid2str which-sp)) X (printf "the goods:") X (pprint bndry-list))) X X ;;; X ;;; update external siblings partition of local grouplespace X ;;; X X (dolist (ent bndry-list) X X (cond X ((equal (car ent) self)) X ((consp (cadr ent)) X (dolist (ob (cadr ent)) X X (cond X ((consp (cadr ob)) X (dolist (attr (cadr ob)) X X (fe-put.ext.sibs.ent.ob.attr (car ent) (car ob) attr))) X X ((fe-put.ext.sibs.ent.ob (car ent) ob))))) X X ((fe-put.ext.sibs.ent ent)))) X X ;; dispatch reactive behaviors X (do-procs react-procs) X X ;; repost to space all instant changes X ;; this is the bottom of the entity-space token loop X (vthrow (list which-sp) X `(fx-sp-perceive ,self (quote ,(fx-ent-exude which-sp)))) X X (gc) X )) X X;;----------------------------------------------------------- X X(defun fx-ent-exude (sp-uid) X X ;; generate a vbf structure to match space protocol. X ;; a vbf structure is (uid virt-bndry fltr). X X ;; as of 5/1/92, filters are omitted and X ;; the uid is passed as a separate argument. X X (let* ((ts 0.0) vbf) X X (fbase-hash fern-ent-htab sp-uid ts) X (setq vbf (fe-copy.bndry.vrt :test-time ts)) X X ;; replace time stamp for this space X (fbase-put-hash fern-ent-htab sp-uid ts) X X (cond (fern-debug X (printf "fx-ent-exude ... to space: " (uid2str sp-uid)) X (printf "the goods:") X (pprint vbf))) X X ;; return the entity->space token to caller X vbf)) X X;;----------------------------------------------------------- X X X X;;----------------------------------------------------------- X X(defun fx-sp-perceive (uid vbf) X (progn X ;; top of the entity-space token loop. X X (cond (fern-debug X (printf "fx-sp-perceive ... from entity: " (uid2str uid)) X (printf "the goods:") X (pprint vbf))) X X ;;; X ;;; update internal sublings partition of grouplepsace X ;;; X X (cond X ((listp vbf) X (dolist (ob vbf) X X (cond X ((consp (cadr ob)) X (dolist (attr (cadr ob)) X X (fe-put.int.subs.ent.ob.attr uid (car ob) attr))) X X ((fe-put.int.subs.ent.ob uid ob))))) X X ((fe-put.int.subs.ent (list uid vbf)))) X X X ;;; X ;;; space takes no reactive action... X ;;; X (cond (fern-debug X (printf "\nthe world:") X (pprint (fe-copy.int.subs)) X (printf ""))) X X ;; repost to entity all world activity X (vthrow (list uid) X `(fx-ent-perceive ,self (quote ,(fx-sp-exude uid)))) X )) X X;;----------------------------------------------------------- X X(defun fx-sp-exude (uid) X (progn X ;; generate message to match entity protocol: X ;; list of sibling entities X X (let* ((ts 0.0) sibs) X X (fbase-hash fern-sp-htab uid ts) X (setq sibs (fe-copy.int.subs :test-time ts)) X X ;; reset this entity's time-stamp X (fbase-put-hash fern-sp-htab uid ts) X X (cond (fern-debug X (printf "fx-sp-exude ... to entity: " (uid2str uid)) X (printf "the goods:") X (pprint sibs))) X X ;; return the space->entity token to caller X sibs))) X X;;----------------------------------------------------------- X X X X X X;;----------------------------------------------------------- X;; Token Loop Unbinding X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X X;; end of line for space/entity token. X X(defun fx-ent-unperceive (which-sp ent-list) X (progn X (cond (fern-debug X (printf "fx-ent-UNperceive ... from space: " (uid2str which-sp)))) X X ;; update external perception partition of local grouplespace X ;; so that all that entities from that space are removed. X (mapcar 'fe-get.ext.sibs.ent ent-list) X )) X X;;----------------------------------------------------------- X X(defun fx-sp-unperceive (uid) X (progn X (cond (fern-debug X (printf "fx-sp-UNperceive ... from entity: " (uid2str uid)))) X X ;; rid subling of any perceptions of this space X (vthrow (list uid) X `(fx-ent-unperceive ,self (quote ,(fe-copy.int.subs.uids)))) X )) X X;;----------------------------------------------------------- X X END_OF_FILE if test 9543 -ne `wc -c <'kernel_private/src/fern/fx.lsp'`; then echo shar: \"'kernel_private/src/fern/fx.lsp'\" unpacked with wrong size! fi # end of 'kernel_private/src/fern/fx.lsp' fi if test -f 'kernel_private/src/include/kernel.h' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kernel_private/src/include/kernel.h'\" else echo shar: Extracting \"'kernel_private/src/include/kernel.h'\" $9869 characters$ sed "s/^X//" >'kernel_private/src/include/kernel.h' <<'END_OF_FILE' X/**************************************************************************************** X * file: kernel.h * X * * X * May 18, 1991: the kernel's private defines, and structures. * X * * X * by Geoffrey P. Coco at the HITLab, Seattle. * X * * X ****************************************************************************************/ X X X/**************************************************************************************** X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X X#include "world.h" X X#ifdef _SG_ X#include <ulocks.h> X#endif X X#ifdef MAIN_MODULE X#define EXTERN X#else X#define EXTERN extern X#endif X X/**************************************************************************************** X Talk Module X ****************************************************************************************/ X X X#define TALK_CREATE -11 /* socket() error */ X#define TALK_HOST -12 /* gethostbyname() error */ X#define TALK_PROTOCOL -13 /* getprotobyname() error */ X#define TALK_SERVICE -14 /* getservbyname() error */ X X#define TALK_CONNECT -15 /* connect() error */ X#define TALK_BIND -16 /* bind(): bind to an address */ X#define TALK_NAME -17 /* getsockname(): can't name socket */ X#define TALK_LISTEN -18 /* listen() error */ X#define TALK_FLAGS -23 /* ioctl error **/ X#define TALK_SELECT -19 /* select() error */ X#define TALK_SELECT_TIMEOUT -20 /* select() time out; nonfatal error */ X#define TALK_NOCONN -21 /* FD_ISSET() failed, try again */ X#define TALK_ACCEPT -22 /* accept(): can't accept selection */ X#define TALK_CLOSE -90 /* close() error */ X#define TALK_CONN_CLOSED -30 X X#define TALK_SPEAK_BLOCKED -252 X#define TALK_LISTEN_BLOCKED -253 X X#define TALK_DEFAULT_PROTOCOL "tcp" /* standard for messages */ X#define TALK_DEFAULT_HOST "localhost" /* standard loop-back */ X X#define TALK_SELECT_TIME 0 /* quick check for incoming conns */ X#define TALK_QUEUE_SIZE 5 /* size of listening queue */ X#define TALK_MAX_BUFFER 8192 X#define TALK_MAX_SPEAK_FAIL 20 X X#define TALK_AGRESSIVE -25 /* forcefully take listen port */ X#define TALK_PASSIVE -24 /* leave used ports alone */ X X#define TALK_MIN_PORT 5500 X#define TALK_MAX_PORT 20000 X X#define TALK_SOCK_CONN 1 X#define TALK_SHMEM_CONN 2 X X#define SHMEM_SHARED_BUF_SIZE 0xFFFF X#define SHMEM_RW_BUF_SIZE 0x0FFF X X#define SHMEM_FULL -272 X#define SHMEM_INIT_ERR -270 X#define SHMEM_ARENA_FILE "/tmp/veos_shmem_arena" X X#define UID_COMPARE(uid1, uid2) ((uid1)->iPort == (uid2)->iPort && \ X (uid1)->lHost == (uid2)->lHost) X X/**************************************************************************************** X Entity Addressing X ****************************************************************************************/ X Xtypedef struct { X u_long lHost; X int iPort; X } TUid, X *TPUid, X **THUid; X Xtypedef struct uidnode { X TUid addr; X struct uidnode *pNext; X } TUidNode, X *TPUidNode, X **THUidNode; X X/**************************************************************************************** X Shared Memory X ****************************************************************************************/ X X#ifdef _SG_ Xtypedef usptr_t *TPShMem; Xtypedef usema_t *TPSemaphor; X#else Xtypedef char *TPShMem; Xtypedef char *TPSemaphor; X#endif X Xtypedef struct memrec { X int iPort; X TPSemaphor pSem; X char pBuffer[SHMEM_RW_BUF_SIZE]; X char *pAvail, *pEnd; X struct memrec *pNext; X X } TSharedRec, X *TPSharedRec, X **THSharedRec; X X Xtypedef struct { X TPSemaphor pChainSem; X TPSharedRec pChannelChain; X X } TShDomainRec, X *TPShDomainRec, X **THShDomainRec; X X/**************************************************************************************** X Talk Message Queueing X ****************************************************************************************/ X Xtypedef struct listennode { X X int iSocketFD; X struct listennode *pLink; X X } TListenNode, X *TPListenNode, X **THListenNode; X Xtypedef struct { X char *sMessage; X int iLen; X X } TMsgRec, X *TPMsgRec, X **THMsgRec; X Xtypedef struct messageq { X X char *sMessage; X int iMsgLen; X struct messageq *pLink; X X } TMessageNode, X *TPMessageNode, X **THMessageNode; X Xtypedef struct speaknode { X X TUid destRec; X int iConnType; X int iSocketFD; X TPMessageNode pMessageQ; X struct speaknode *pLink; X X } TSpeakNode, X *TPSpeakNode, X **THSpeakNode; X X/**************************************************************************************** X Hostname Hash Table Entries X ****************************************************************************************/ X Xtypedef struct hostnode { X char *sHostName; X u_long lHost; X struct hostnode *pNext; X X } THostNode, X *TPHostNode, X **THHostNode; X X/**************************************************************************************** X Talk Globals X ****************************************************************************************/ X XEXTERN int talk_iListenFD; XEXTERN char *talk_pTransBuffer; XEXTERN TUid talk_selfRec; X XEXTERN fd_set talk_InetSocket_OpenWriteSockets; XEXTERN fd_set talk_InetSocket_OpenReadSockets; X XEXTERN TPHostNode talk_pHostHash[26]; XEXTERN TPSpeakNode talk_pOutConns; XEXTERN TPListenNode talk_pInConns; X XEXTERN boolean talk_bTalkDebugging; XEXTERN boolean talk_bOutDirty; XEXTERN long talk_lTasks; X XEXTERN TPShDomainRec talk_pPublicDomain; XEXTERN TPShMem talk_pTheArena; XEXTERN TPSharedRec talk_pListenChannel; XEXTERN TVeosErr (*talk_pIncomingMsgFun) (); X X/** quick access to talk globals **/ X X#define SPEAK_SET talk_pOutConns X#define LISTEN_SOCKETFD talk_iListenFD X#define LISTEN_SET talk_pInConns X#define TASKS talk_lTasks X#define TALK_BUFFER talk_pTransBuffer X#define TALK_BUGS talk_bTalkDebugging X#define SPEAK_DIRTY talk_bOutDirty X#define OPEN_READ_SOCKETS talk_InetSocket_OpenReadSockets X#define OPEN_WRITE_SOCKETS talk_InetSocket_OpenWriteSockets X#define IDENT_ADDR talk_selfRec X X#define SHMEM_DOMAIN talk_pPublicDomain X#define SHMEM_ARENA talk_pTheArena X#define SHMEM_CHANNEL talk_pListenChannel X X#define TALK_MSG_FUNC talk_pIncomingMsgFun X#define SOCK_HOSTS talk_pHostHash X X/**************************************************************************************** X Nancy Module X ****************************************************************************************/ X Xtypedef struct { X int iLeft, iRight; X X } TInterval, X *TPInterval; X Xtypedef struct repnode { X TPGrouple pEnviron; X TInterval pWipeList[10]; X int iZones; X int iInsertElt; X struct repnode *pNext; X X } TReplaceRec, X *TPReplaceRec, X **THReplaceRec; X Xtypedef struct { X TPGrouple pPatGr, pSrcGr; X int iDestroyFlag, iFreqFlag; X TPReplaceRec pReplaceList; X TPReplaceRec pTouchList; X X } TMatchRec, X *TPMatchRec, X **THMatchRec; X X/****************************************************************************************/ X X#define VEOS_GROUPLE_BUF_SIZE 1024 X#define NANCY_EltListInc 8 X#define NANCY_AllocHashMax 30 X X/****************************************************************************************/ X X#define ELTS_TO_ALLOCATE(iElts) \ X ((((iElts - 1) / NANCY_EltListInc) + 1) * NANCY_EltListInc) X X#define ELTS_ALLOCATED(elts) ((elts < NANCY_AllocHashMax) ? \ X ALLOC_ELTS[elts] : ELTS_TO_ALLOCATE(elts)) X X#define BLOCKS_ALLOCATED(iBlocks, iSegSize) \ X ((((iBlocks - 1) / iSegSize) + 1) * iSegSize) X X#define GET_TIME(time) (time) = ++NANCY_TIME X#define PRINT_TIME(time, stream) fprintf(stream, "(ts: %d) ", time) X X/****************************************************************************************/ X X X/** nancy global declarations **/ X XEXTERN FILE *nancy_pStreamGlob; XEXTERN int nancy_iLineCount; XEXTERN TPGrouple nancy_pInSpace, nancy_pWorkSpace; XEXTERN TElt nancy_eltNil; XEXTERN char *nancy_pAllPurposeBuf; XEXTERN int nancy_pAllocElts[NANCY_AllocHashMax]; XEXTERN int nancy_pTypeSizes[30]; XEXTERN boolean nancy_bNancyDebugging; XEXTERN TTimeStamp nancy_lTime; XEXTERN TTimeStamp nancy_lMinTime; X X X/** quick access to nancy globals **/ X X#define WORK_SPACE nancy_pWorkSpace X#define GR_INSPACE nancy_pInSpace X X#define LINE_COUNT nancy_iLineCount X#define GR_STREAM nancy_pStreamGlob X#define NANCY_BUF nancy_pAllPurposeBuf X#define TYPE_SIZES nancy_pTypeSizes X#define ALLOC_ELTS nancy_pAllocElts X#define NANCY_BUGS nancy_bNancyDebugging X#define NIL_ELT nancy_eltNil X#define NANCY_TIME nancy_lTime X#define NANCY_MINTIME nancy_lMinTime X X/**************************************************************************************** X Shell Module X ****************************************************************************************/ X X#define SHELL_CHAIN_HASH_MAX 65 X X/****************************************************************************************/ X XEXTERN long shell_lTrapFlags; XEXTERN boolean shell_bShellDebugging; XEXTERN char *shell_pChains[SHELL_CHAIN_HASH_MAX]; XEXTERN int shell_pBlocks[SHELL_CHAIN_HASH_MAX]; X X#ifdef MAIN_MODULE Xboolean shell_bSignals = TRUE; Xboolean shell_bKernelSetup = FALSE; X#else Xextern boolean shell_bSignals; Xextern boolean shell_bKernelSetup; X#endif X X X/** quick access to shell globals **/ X X#define TRAP_FLAGS shell_lTrapFlags X#define MEM_CHAINS shell_pChains X#define BLOCKS_OUT shell_pBlocks X#define SIG_ENABLE shell_bSignals X#define SHELL_BUGS shell_bShellDebugging X#define KERNEL_INIT shell_bKernelSetup X X/****************************************************************************************/ X X X END_OF_FILE if test 9869 -ne `wc -c <'kernel_private/src/include/kernel.h'`; then echo shar: \"'kernel_private/src/include/kernel.h'\" unpacked with wrong size! fi # end of 'kernel_private/src/include/kernel.h' fi if test -f 'kernel_private/src/shell/shell.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kernel_private/src/shell/shell.c'\" else echo shar: Extracting \"'kernel_private/src/shell/shell.c'\" $10711 characters$ sed "s/^X//" >'kernel_private/src/shell/shell.c' <<'END_OF_FILE' X/**************************************************************************************** X * * X * file: shell.c * X * * X * September 7, 1990: Wow, that's old. * X * * X * by Geoffrey P. Coco at the HITLab, Seattle. * X * * X ****************************************************************************************/ X X X/**************************************************************************************** X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X X X/**************************************************************************************** X * include the papa include file */ X X#include <signal.h> X X#define MAIN_MODULE X#include "kernel.h" X X/****************************************************************************************/ X X X/**************************************************************************************** X * Kernel_Init */ X XTVeosErr Kernel_Init(iPort, pMessFun) X int iPort; X TVeosErr (*pMessFun) (); X{ X TVeosErr iErr = VEOS_FAILURE; X X if (KERNEL_INIT) { X fprintf(stderr, "veos kernel already initialized...\n"); X fprintf(stderr, "no action was taken.\n"); X } X else { X /** initialize often-used globals with defualt values **/ X X iErr = Shell_InitCaches(); X if (iErr == VEOS_SUCCESS) { X X X /** perform one-time nancy initialization **/ X X iErr = Nancy_Init(); X if (iErr == VEOS_SUCCESS) { X X X /** initialize inter-entity communication handler **/ X /** this puts an ear to the network **/ X X iErr = Talk_HelloTalk(iPort, pMessFun); X if (iErr == VEOS_SUCCESS) { X X X /** provide for graceful exit **/ X X Shell_SetupErrorTraps(); X X X /** print gratuitous credits **/ X X Shell_StartUpMessage(); X X KERNEL_INIT = TRUE; X } X } X } X X if (iErr != VEOS_SUCCESS) X fprintf(stderr, "shell %s: kernel initialization failed, error: %d\n", X WHOAMI, iErr); X } X X return(iErr); X X } /* Kernel_Init */ X/****************************************************************************************/ X X X X/**************************************************************************************** X * Kernel_Shutdown */ X XTVeosErr Kernel_Shutdown() X{ X TVeosErr iSuccess = VEOS_FAILURE; X X if (KERNEL_INIT) { X X /** cleanup network loose ends **/ X X iSuccess = Talk_ByeTalk(); X X X /** dispose all memory **/ X X fprintf(stderr, "\n"); X X X KERNEL_INIT = FALSE; X } X X X return(iSuccess); X X } /* Kernel_Shutdown */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X * Kernel_SystemTask */ X XTVeosErr Kernel_SystemTask() X{ X /** inspect every open connection for queued outgoing messages **/ X X if (SPEAK_DIRTY) X Talk_DispatchQedSpeakMessages(); X X X /** accept new entity connections **/ X/* X if (++TASKS % 10 == 0) X*/ X Talk_EstNewListenConnections(); X X X /** check each open listen connection for incoming messages **/ X X Talk_GatherListenMessages(); X X X return(VEOS_SUCCESS); X X } /* Kernel_SystemTask */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_NewBlock(iSize, hBlock, sDebug) X int iSize; X char * *hBlock; X char *sDebug; X{ X char * *pBlock; X TVeosErr iSuccess; X X if (iSize >= SHELL_CHAIN_HASH_MAX) { X X NEWPTR(pBlock, char **, iSize); X#ifndef OPTIMAL X if (SHELL_BUGS) X fprintf(stderr, "shell %s: %s >> size: %d, regular\n", X WHOAMI, sDebug ? sDebug : "", iSize); X#endif X } X X else { X if (pBlock = (char **) MEM_CHAINS[iSize]) { X X BLOCKS_OUT[iSize] ++; X X /** remove nearest block in chain **/ X X MEM_CHAINS[iSize] = *pBlock; X *pBlock = nil; X#ifndef OPTIMAL X if (SHELL_BUGS) X fprintf(stderr, "shell %s: %s >> size: %d, recycle, blocks out: %d\n", X WHOAMI, sDebug ? sDebug : "", iSize, BLOCKS_OUT[iSize]); X#endif X } X X else { X BLOCKS_OUT[iSize] ++; X NEWPTR(pBlock, char **, iSize); X#ifndef OPTIMAL X if (SHELL_BUGS) X fprintf(stderr, "shell %s: %s >> size: %d, new, blocks out: %d\n", X WHOAMI, sDebug ? sDebug : "", iSize, BLOCKS_OUT[iSize]); X#endif X } X } X X if (*hBlock = (char *) pBlock) X iSuccess = VEOS_SUCCESS; X else X iSuccess = VEOS_FAILURE; X X X return(iSuccess); X X } /* Shell_NewBlock */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Shell_ReturnBlock(pBlock, iSize, sDebug) X char * *pBlock; X int iSize; X char *sDebug; X{ X int iSuccess; X X iSuccess = VEOS_SUCCESS; X X if (iSize >= SHELL_CHAIN_HASH_MAX) { X X DUMP(pBlock); X#ifndef OPTIMAL X if (SHELL_BUGS) X fprintf(stderr, "shell %s: %s << size: %d, regular\n", X WHOAMI, sDebug ? sDebug : "", iSize); X#endif X } X X else { X BLOCKS_OUT[iSize] --; X X *pBlock = MEM_CHAINS[iSize]; X X MEM_CHAINS[iSize] = (char *) pBlock; X#ifndef OPTIMAL X if (SHELL_BUGS) { X fprintf(stderr, "shell %s: %s << size: %d, blocks out: %d\n", X WHOAMI, sDebug ? sDebug : "", iSize, BLOCKS_OUT[iSize]); X } X#endif X } X X return(iSuccess); X X } /* Shell_ReturnBlock */ X/****************************************************************************************/ X X X X/**************************************************************************************** X * local functions * X ****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_InitCaches() X{ X TVeosErr iSuccess; X int iChain; X str63 sHostName; X X iSuccess = VEOS_FAILURE; X X X /** chain list is as long as largest possible block size **/ X X for (iChain = 0; iChain < SHELL_CHAIN_HASH_MAX; iChain ++) { X MEM_CHAINS[iChain] = nil; X BLOCKS_OUT[iChain] = 0; X } X X X /** publicly accessible globals **/ X X if (gethostname(sHostName, sizeof(sHostName)) != -1) X iSuccess = Sock_StrHost2IP(sHostName, &IDENT_ADDR.lHost); X X IDENT_ADDR.iPort = TALK_BOGUS_FD; X X Shell_UpdateUid(); X X X TERMINATE = FALSE; X X X /** kernel debugging flags **/ X X TALK_BUGS = FALSE; X SHELL_BUGS = FALSE; X NANCY_BUGS = FALSE; X X X /** other kernel globals **/ X X TRAP_FLAGS = 0; X TASKS = 0; X X iSuccess = VEOS_SUCCESS; X X X return(iSuccess); X X } /* Shell_InitCaches */ X/****************************************************************************************/ X X X X/****************************************************************************************/ Xvoid Shell_TrapErr(iSignal, iCode, context, pAddr) X int iSignal, iCode; X struct sigcontext *context; X char *pAddr; X{ X str255 sErr; X str63 sSignal; X static boolean bGone = FALSE; X X /** interupt was already trapped once with no service **/ X X if (TRAP_FLAGS & 0x00000001 << iSignal) { X Shell_Signal2String(iSignal, sSignal); X sprintf(sErr, "fatal signal: %s, entity: %s\n", sSignal, WHOAMI); X X if (bGone) X exit(0); X X else { X bGone = TRUE; X Shell_BailOut(sErr); X } X } X else { X#ifndef OPTIMAL X if (SHELL_BUGS) { X Shell_Signal2String(iSignal, sSignal); X fprintf(stderr, "shell %s: interrupt occurred: %s.\n", WHOAMI, sSignal); X } X#endif X TRAP_FLAGS |= 0x00000001 << iSignal; X } X X } /* Shell_TrapErr */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_Signal2String(iSignal, sSignal) X int iSignal; X char *sSignal; X{ X switch (iSignal) { X X case SIGBUS: X strcpy(sSignal, "bus error"); X break; X X case SIGKILL: X strcpy(sSignal, "forceful kill"); X break; X X case SIGQUIT: X strcpy(sSignal, "user quit request"); X break; X X case SIGSEGV: X strcpy(sSignal, "segmentation fault"); X break; X X case SIGINT: X strcpy(sSignal, "keyboard interrupt"); X break; X X case SIGPIPE: X strcpy(sSignal, "broken pipe"); X break; X X default: X strcpy(sSignal, "unknown signal"); X break; X } X X return(VEOS_SUCCESS); X X } /* Shell_Signal2String */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_SetupErrorTraps() X{ X if (SIG_ENABLE) { X signal(SIGINT, Shell_TrapErr); X signal(SIGQUIT, Shell_TrapErr); X signal(SIGBUS, Shell_TrapErr); X signal(SIGSEGV, Shell_TrapErr); X signal(SIGPIPE, Shell_TrapErr); X } X X } /* Shell_SetupErrorTraps */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_StartUpMessage() X{ X fprintf(stderr, "\n\n\n"); X fprintf(stderr, "----------------------------------------------------\n"); X fprintf(stderr, " VEOS 2.0 by Geoffrey Coco \n"); X fprintf(stderr, " Copyright (C) 1992, Human Interface Technology Lab \n"); X fprintf(stderr, "----------------------------------------------------\n\n\n\n"); X X return(VEOS_SUCCESS); X X } /* Shell_StartUpMessage */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Shell_UpdateUid() X{ X TVeosErr iSuccess; X str63 sHostName; X X /** update WHOAMI C variable **/ X X iSuccess = Sock_IP2StrHost(IDENT_ADDR.lHost, sHostName); X if (iSuccess == VEOS_SUCCESS) X X sprintf(WHOAMI, "%s_%d", sHostName, IDENT_ADDR.iPort); X X X return(iSuccess); X X } /* Shell_UpdateUid */ X/****************************************************************************************/ X X X X#ifdef _DEC_ X/****************************************************************************************/ Xchar *strdup(sSrc) X char *sSrc; X{ X char *sReturn; X X sReturn = nil; X X if (sSrc) { X if (NEWPTR(sReturn, char *, strlen(sSrc) + 1)) X strcpy(sReturn, sSrc); X } X X return(sReturn); X X } /* strdup */ X/****************************************************************************************/ X#endif X X X END_OF_FILE if test 10711 -ne `wc -c <'kernel_private/src/shell/shell.c'`; then echo shar: \"'kernel_private/src/shell/shell.c'\" unpacked with wrong size! fi # end of 'kernel_private/src/shell/shell.c' fi if test -f 'src/kernel_current/fern/fx.lsp' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/kernel_current/fern/fx.lsp'\" else echo shar: Extracting \"'src/kernel_current/fern/fx.lsp'\" $9543 characters$ sed "s/^X//" >'src/kernel_current/fern/fx.lsp' <<'END_OF_FILE' X;;----------------------------------------------------------- X;; file: fx.lsp X;; X;; FERN is the Fractal Entity Relativity Node. X;; This file is the trans compenent of the Fern System. X;; X;; creation: March 28, 1992 X;; X;; by Geoffrey P. Coco at the HITLab, Seattle X;;----------------------------------------------------------- X X;;----------------------------------------------------------- X;; Copyright (C) 1992 Geoffrey P. Coco, X;; Human Interface Technology Lab, Seattle X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X#| X XThe FX component of the Fern System is concerned with normal Xcommunications between space and entity. X XA primary purpose of the Fern System is to transparently Xmaintain the distributed world database. These functions Xprovide the inter-entity transport mechanism for the Fern XSystem and they compose the FX component of the Fern System. X X|# X;;----------------------------------------------------------- X X X X;;=========================================================== X;; X;; FX PUBLIC FUNCTIONS X;; X;;=========================================================== X X X;;----------------------------------------------------------- X;; Entity Level Binding Entry Pts X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X X;; instigate a space/entity relationship between your entity X;; and the given entity. sp-uid becomes a space of yours. X;; any entity/space token loop begins here. X X(defun fx-enter (sp-uid) X (cond ((fe-copy.ext.sps.ent sp-uid)) X (t X (cond (fern-debug X (printf "fx-enter... new space: " (uid2str sp-uid)))) X X ;; add new space to external partition X (fe-put.ext.sps.ent (list sp-uid ())) X X ;; add delta time-stamp to hash table X (fbase-put-hash fern-ent-htab sp-uid (vmintime)) X X ;; pass first boundary update (i.e. the token) to space X (vthrow (list sp-uid) X `(fx-sp-enter ,self (quote ,(fx-ent-exude sp-uid)))) X t))) X X;;----------------------------------------------------------- X X;; instagate the exit procedure. X;; terminate a space/entity relationship between your entity X;; and the given entity. the token will travel one more time X;; around. X X(defun fx-exit (sp-uid) X X X (cond ((fe-copy.ext.sps.ent sp-uid) X X (cond (fern-debug X (printf "fx-exit... space: " (uid2str sp-uid)))) X X ;; remove space from space list. X (fe-get.ext.sps.ent sp-uid) X X ;; remove this entry from timestamp hash table X (fbase-get-hash fern-ent-htab sp-uid) X X ;; assume that entity has the token. X ;; NOTE: this is not a safe assumption. X ;; In other words, it is only safe to call X ;; fx-exit from within a react proc. X X ;; token now passes one more time through it's loop X ;; to the space (fx-sp-exit, fx-sp-unperceive) X ;; then, ending at (fx-ent-unperceive) X (vthrow (list sp-uid) X `(fx-sp-exit ,self)) X ))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; X;; FX PRIVATE FUNCTIONS X;; X;;=========================================================== X X X;;----------------------------------------------------------- X X(defun fx-init () X (setq fern-sp-htab (fbase-new-htab)) X (setq fern-ent-htab (fbase-new-htab)) X ) X X;;----------------------------------------------------------- X X X X;;----------------------------------------------------------- X;; Space Level Binding Entry Pts X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X X;; accept a space/entity relationship between from another X;; entity. setup initial data structures, pass included X;; entity->space token into token loop. X X(defun fx-sp-enter (ent-uid vbf) X (progn X (cond (fern-debug X (printf "fx-sp-enter... new entity: " (uid2str ent-uid)))) X X ;; the entering entity has already checked for duplicates. X ;; add new entity to sublings partition, X ;; overiding a possible previous deletion. X (fe-put.int.subs.ent (list ent-uid nil)) X X ;; add new entity with delta time-stamp to fern hash table X (fbase-put-hash fern-sp-htab ent-uid (vmintime)) X X ;; pass included token to normal space entry point X (fx-sp-perceive ent-uid vbf) X )) X X;;----------------------------------------------------------- X X;; accept a termination request of space/entity relationship X;; from another entity. takedown data structures, pass included X;; entity->space token into final token loop. X X(defun fx-sp-exit (ent-uid) X (progn X (cond (fern-debug X (printf "fx-sp-exit... retiring entity: " (uid2str ent-uid)))) X X ;; remove entity timestamp hash table X (fbase-get-hash fern-sp-htab ent-uid) X X ;; remove entity from sublings partition.. X ;; and thus from the externals of all other entities in this space. X (fe-get.int.subs.ent ent-uid) X X ;; eliminate perceptual references to this entity X (fx-sp-unperceive ent-uid) X )) X X;;----------------------------------------------------------- X X X X;;----------------------------------------------------------- X;; Space Token Normal Operation X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X X(defun fx-ent-perceive (which-sp bndry-list) X (progn X (cond (fern-debug X (printf "fx-ent-perceive ... from space: " (uid2str which-sp)) X (printf "the goods:") X (pprint bndry-list))) X X ;;; X ;;; update external siblings partition of local grouplespace X ;;; X X (dolist (ent bndry-list) X X (cond X ((equal (car ent) self)) X ((consp (cadr ent)) X (dolist (ob (cadr ent)) X X (cond X ((consp (cadr ob)) X (dolist (attr (cadr ob)) X X (fe-put.ext.sibs.ent.ob.attr (car ent) (car ob) attr))) X X ((fe-put.ext.sibs.ent.ob (car ent) ob))))) X X ((fe-put.ext.sibs.ent ent)))) X X ;; dispatch reactive behaviors X (do-procs react-procs) X X ;; repost to space all instant changes X ;; this is the bottom of the entity-space token loop X (vthrow (list which-sp) X `(fx-sp-perceive ,self (quote ,(fx-ent-exude which-sp)))) X X (gc) X )) X X;;----------------------------------------------------------- X X(defun fx-ent-exude (sp-uid) X X ;; generate a vbf structure to match space protocol. X ;; a vbf structure is (uid virt-bndry fltr). X X ;; as of 5/1/92, filters are omitted and X ;; the uid is passed as a separate argument. X X (let* ((ts 0.0) vbf) X X (fbase-hash fern-ent-htab sp-uid ts) X (setq vbf (fe-copy.bndry.vrt :test-time ts)) X X ;; replace time stamp for this space X (fbase-put-hash fern-ent-htab sp-uid ts) X X (cond (fern-debug X (printf "fx-ent-exude ... to space: " (uid2str sp-uid)) X (printf "the goods:") X (pprint vbf))) X X ;; return the entity->space token to caller X vbf)) X X;;----------------------------------------------------------- X X X X;;----------------------------------------------------------- X X(defun fx-sp-perceive (uid vbf) X (progn X ;; top of the entity-space token loop. X X (cond (fern-debug X (printf "fx-sp-perceive ... from entity: " (uid2str uid)) X (printf "the goods:") X (pprint vbf))) X X ;;; X ;;; update internal sublings partition of grouplepsace X ;;; X X (cond X ((listp vbf) X (dolist (ob vbf) X X (cond X ((consp (cadr ob)) X (dolist (attr (cadr ob)) X X (fe-put.int.subs.ent.ob.attr uid (car ob) attr))) X X ((fe-put.int.subs.ent.ob uid ob))))) X X ((fe-put.int.subs.ent (list uid vbf)))) X X X ;;; X ;;; space takes no reactive action... X ;;; X (cond (fern-debug X (printf "\nthe world:") X (pprint (fe-copy.int.subs)) X (printf ""))) X X ;; repost to entity all world activity X (vthrow (list uid) X `(fx-ent-perceive ,self (quote ,(fx-sp-exude uid)))) X )) X X;;----------------------------------------------------------- X X(defun fx-sp-exude (uid) X (progn X ;; generate message to match entity protocol: X ;; list of sibling entities X X (let* ((ts 0.0) sibs) X X (fbase-hash fern-sp-htab uid ts) X (setq sibs (fe-copy.int.subs :test-time ts)) X X ;; reset this entity's time-stamp X (fbase-put-hash fern-sp-htab uid ts) X X (cond (fern-debug X (printf "fx-sp-exude ... to entity: " (uid2str uid)) X (printf "the goods:") X (pprint sibs))) X X ;; return the space->entity token to caller X sibs))) X X;;----------------------------------------------------------- X X X X X X;;----------------------------------------------------------- X;; Token Loop Unbinding X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X X;; end of line for space/entity token. X X(defun fx-ent-unperceive (which-sp ent-list) X (progn X (cond (fern-debug X (printf "fx-ent-UNperceive ... from space: " (uid2str which-sp)))) X X ;; update external perception partition of local grouplespace X ;; so that all that entities from that space are removed. X (mapcar 'fe-get.ext.sibs.ent ent-list) X )) X X;;----------------------------------------------------------- X X(defun fx-sp-unperceive (uid) X (progn X (cond (fern-debug X (printf "fx-sp-UNperceive ... from entity: " (uid2str uid)))) X X ;; rid subling of any perceptions of this space X (vthrow (list uid) X `(fx-ent-unperceive ,self (quote ,(fe-copy.int.subs.uids)))) X )) X X;;----------------------------------------------------------- X X END_OF_FILE if test 9543 -ne `wc -c <'src/kernel_current/fern/fx.lsp'`; then echo shar: \"'src/kernel_current/fern/fx.lsp'\" unpacked with wrong size! fi # end of 'src/kernel_current/fern/fx.lsp' fi if test -f 'src/kernel_current/include/kernel.h' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/kernel_current/include/kernel.h'\" else echo shar: Extracting \"'src/kernel_current/include/kernel.h'\" $9869 characters$ sed "s/^X//" >'src/kernel_current/include/kernel.h' <<'END_OF_FILE' X/**************************************************************************************** X * file: kernel.h * X * * X * May 18, 1991: the kernel's private defines, and structures. * X * * X * by Geoffrey P. Coco at the HITLab, Seattle. * X * * X ****************************************************************************************/ X X X/**************************************************************************************** X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X X#include "world.h" X X#ifdef _SG_ X#include <ulocks.h> X#endif X X#ifdef MAIN_MODULE X#define EXTERN X#else X#define EXTERN extern X#endif X X/**************************************************************************************** X Talk Module X ****************************************************************************************/ X X X#define TALK_CREATE -11 /* socket() error */ X#define TALK_HOST -12 /* gethostbyname() error */ X#define TALK_PROTOCOL -13 /* getprotobyname() error */ X#define TALK_SERVICE -14 /* getservbyname() error */ X X#define TALK_CONNECT -15 /* connect() error */ X#define TALK_BIND -16 /* bind(): bind to an address */ X#define TALK_NAME -17 /* getsockname(): can't name socket */ X#define TALK_LISTEN -18 /* listen() error */ X#define TALK_FLAGS -23 /* ioctl error **/ X#define TALK_SELECT -19 /* select() error */ X#define TALK_SELECT_TIMEOUT -20 /* select() time out; nonfatal error */ X#define TALK_NOCONN -21 /* FD_ISSET() failed, try again */ X#define TALK_ACCEPT -22 /* accept(): can't accept selection */ X#define TALK_CLOSE -90 /* close() error */ X#define TALK_CONN_CLOSED -30 X X#define TALK_SPEAK_BLOCKED -252 X#define TALK_LISTEN_BLOCKED -253 X X#define TALK_DEFAULT_PROTOCOL "tcp" /* standard for messages */ X#define TALK_DEFAULT_HOST "localhost" /* standard loop-back */ X X#define TALK_SELECT_TIME 0 /* quick check for incoming conns */ X#define TALK_QUEUE_SIZE 5 /* size of listening queue */ X#define TALK_MAX_BUFFER 8192 X#define TALK_MAX_SPEAK_FAIL 20 X X#define TALK_AGRESSIVE -25 /* forcefully take listen port */ X#define TALK_PASSIVE -24 /* leave used ports alone */ X X#define TALK_MIN_PORT 5500 X#define TALK_MAX_PORT 20000 X X#define TALK_SOCK_CONN 1 X#define TALK_SHMEM_CONN 2 X X#define SHMEM_SHARED_BUF_SIZE 0xFFFF X#define SHMEM_RW_BUF_SIZE 0x0FFF X X#define SHMEM_FULL -272 X#define SHMEM_INIT_ERR -270 X#define SHMEM_ARENA_FILE "/tmp/veos_shmem_arena" X X#define UID_COMPARE(uid1, uid2) ((uid1)->iPort == (uid2)->iPort && \ X (uid1)->lHost == (uid2)->lHost) X X/**************************************************************************************** X Entity Addressing X ****************************************************************************************/ X Xtypedef struct { X u_long lHost; X int iPort; X } TUid, X *TPUid, X **THUid; X Xtypedef struct uidnode { X TUid addr; X struct uidnode *pNext; X } TUidNode, X *TPUidNode, X **THUidNode; X X/**************************************************************************************** X Shared Memory X ****************************************************************************************/ X X#ifdef _SG_ Xtypedef usptr_t *TPShMem; Xtypedef usema_t *TPSemaphor; X#else Xtypedef char *TPShMem; Xtypedef char *TPSemaphor; X#endif X Xtypedef struct memrec { X int iPort; X TPSemaphor pSem; X char pBuffer[SHMEM_RW_BUF_SIZE]; X char *pAvail, *pEnd; X struct memrec *pNext; X X } TSharedRec, X *TPSharedRec, X **THSharedRec; X X Xtypedef struct { X TPSemaphor pChainSem; X TPSharedRec pChannelChain; X X } TShDomainRec, X *TPShDomainRec, X **THShDomainRec; X X/**************************************************************************************** X Talk Message Queueing X ****************************************************************************************/ X Xtypedef struct listennode { X X int iSocketFD; X struct listennode *pLink; X X } TListenNode, X *TPListenNode, X **THListenNode; X Xtypedef struct { X char *sMessage; X int iLen; X X } TMsgRec, X *TPMsgRec, X **THMsgRec; X Xtypedef struct messageq { X X char *sMessage; X int iMsgLen; X struct messageq *pLink; X X } TMessageNode, X *TPMessageNode, X **THMessageNode; X Xtypedef struct speaknode { X X TUid destRec; X int iConnType; X int iSocketFD; X TPMessageNode pMessageQ; X struct speaknode *pLink; X X } TSpeakNode, X *TPSpeakNode, X **THSpeakNode; X X/**************************************************************************************** X Hostname Hash Table Entries X ****************************************************************************************/ X Xtypedef struct hostnode { X char *sHostName; X u_long lHost; X struct hostnode *pNext; X X } THostNode, X *TPHostNode, X **THHostNode; X X/**************************************************************************************** X Talk Globals X ****************************************************************************************/ X XEXTERN int talk_iListenFD; XEXTERN char *talk_pTransBuffer; XEXTERN TUid talk_selfRec; X XEXTERN fd_set talk_InetSocket_OpenWriteSockets; XEXTERN fd_set talk_InetSocket_OpenReadSockets; X XEXTERN TPHostNode talk_pHostHash[26]; XEXTERN TPSpeakNode talk_pOutConns; XEXTERN TPListenNode talk_pInConns; X XEXTERN boolean talk_bTalkDebugging; XEXTERN boolean talk_bOutDirty; XEXTERN long talk_lTasks; X XEXTERN TPShDomainRec talk_pPublicDomain; XEXTERN TPShMem talk_pTheArena; XEXTERN TPSharedRec talk_pListenChannel; XEXTERN TVeosErr (*talk_pIncomingMsgFun) (); X X/** quick access to talk globals **/ X X#define SPEAK_SET talk_pOutConns X#define LISTEN_SOCKETFD talk_iListenFD X#define LISTEN_SET talk_pInConns X#define TASKS talk_lTasks X#define TALK_BUFFER talk_pTransBuffer X#define TALK_BUGS talk_bTalkDebugging X#define SPEAK_DIRTY talk_bOutDirty X#define OPEN_READ_SOCKETS talk_InetSocket_OpenReadSockets X#define OPEN_WRITE_SOCKETS talk_InetSocket_OpenWriteSockets X#define IDENT_ADDR talk_selfRec X X#define SHMEM_DOMAIN talk_pPublicDomain X#define SHMEM_ARENA talk_pTheArena X#define SHMEM_CHANNEL talk_pListenChannel X X#define TALK_MSG_FUNC talk_pIncomingMsgFun X#define SOCK_HOSTS talk_pHostHash X X/**************************************************************************************** X Nancy Module X ****************************************************************************************/ X Xtypedef struct { X int iLeft, iRight; X X } TInterval, X *TPInterval; X Xtypedef struct repnode { X TPGrouple pEnviron; X TInterval pWipeList[10]; X int iZones; X int iInsertElt; X struct repnode *pNext; X X } TReplaceRec, X *TPReplaceRec, X **THReplaceRec; X Xtypedef struct { X TPGrouple pPatGr, pSrcGr; X int iDestroyFlag, iFreqFlag; X TPReplaceRec pReplaceList; X TPReplaceRec pTouchList; X X } TMatchRec, X *TPMatchRec, X **THMatchRec; X X/****************************************************************************************/ X X#define VEOS_GROUPLE_BUF_SIZE 1024 X#define NANCY_EltListInc 8 X#define NANCY_AllocHashMax 30 X X/****************************************************************************************/ X X#define ELTS_TO_ALLOCATE(iElts) \ X ((((iElts - 1) / NANCY_EltListInc) + 1) * NANCY_EltListInc) X X#define ELTS_ALLOCATED(elts) ((elts < NANCY_AllocHashMax) ? \ X ALLOC_ELTS[elts] : ELTS_TO_ALLOCATE(elts)) X X#define BLOCKS_ALLOCATED(iBlocks, iSegSize) \ X ((((iBlocks - 1) / iSegSize) + 1) * iSegSize) X X#define GET_TIME(time) (time) = ++NANCY_TIME X#define PRINT_TIME(time, stream) fprintf(stream, "(ts: %d) ", time) X X/****************************************************************************************/ X X X/** nancy global declarations **/ X XEXTERN FILE *nancy_pStreamGlob; XEXTERN int nancy_iLineCount; XEXTERN TPGrouple nancy_pInSpace, nancy_pWorkSpace; XEXTERN TElt nancy_eltNil; XEXTERN char *nancy_pAllPurposeBuf; XEXTERN int nancy_pAllocElts[NANCY_AllocHashMax]; XEXTERN int nancy_pTypeSizes[30]; XEXTERN boolean nancy_bNancyDebugging; XEXTERN TTimeStamp nancy_lTime; XEXTERN TTimeStamp nancy_lMinTime; X X X/** quick access to nancy globals **/ X X#define WORK_SPACE nancy_pWorkSpace X#define GR_INSPACE nancy_pInSpace X X#define LINE_COUNT nancy_iLineCount X#define GR_STREAM nancy_pStreamGlob X#define NANCY_BUF nancy_pAllPurposeBuf X#define TYPE_SIZES nancy_pTypeSizes X#define ALLOC_ELTS nancy_pAllocElts X#define NANCY_BUGS nancy_bNancyDebugging X#define NIL_ELT nancy_eltNil X#define NANCY_TIME nancy_lTime X#define NANCY_MINTIME nancy_lMinTime X X/**************************************************************************************** X Shell Module X ****************************************************************************************/ X X#define SHELL_CHAIN_HASH_MAX 65 X X/****************************************************************************************/ X XEXTERN long shell_lTrapFlags; XEXTERN boolean shell_bShellDebugging; XEXTERN char *shell_pChains[SHELL_CHAIN_HASH_MAX]; XEXTERN int shell_pBlocks[SHELL_CHAIN_HASH_MAX]; X X#ifdef MAIN_MODULE Xboolean shell_bSignals = TRUE; Xboolean shell_bKernelSetup = FALSE; X#else Xextern boolean shell_bSignals; Xextern boolean shell_bKernelSetup; X#endif X X X/** quick access to shell globals **/ X X#define TRAP_FLAGS shell_lTrapFlags X#define MEM_CHAINS shell_pChains X#define BLOCKS_OUT shell_pBlocks X#define SIG_ENABLE shell_bSignals X#define SHELL_BUGS shell_bShellDebugging X#define KERNEL_INIT shell_bKernelSetup X X/****************************************************************************************/ X X X END_OF_FILE if test 9869 -ne `wc -c <'src/kernel_current/include/kernel.h'`; then echo shar: \"'src/kernel_current/include/kernel.h'\" unpacked with wrong size! fi # end of 'src/kernel_current/include/kernel.h' fi if test -f 'src/kernel_current/shell/shell.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/kernel_current/shell/shell.c'\" else echo shar: Extracting \"'src/kernel_current/shell/shell.c'\" $10711 characters$ sed "s/^X//" >'src/kernel_current/shell/shell.c' <<'END_OF_FILE' X/**************************************************************************************** X * * X * file: shell.c * X * * X * September 7, 1990: Wow, that's old. * X * * X * by Geoffrey P. Coco at the HITLab, Seattle. * X * * X ****************************************************************************************/ X X X/**************************************************************************************** X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X X X/**************************************************************************************** X * include the papa include file */ X X#include <signal.h> X X#define MAIN_MODULE X#include "kernel.h" X X/****************************************************************************************/ X X X/**************************************************************************************** X * Kernel_Init */ X XTVeosErr Kernel_Init(iPort, pMessFun) X int iPort; X TVeosErr (*pMessFun) (); X{ X TVeosErr iErr = VEOS_FAILURE; X X if (KERNEL_INIT) { X fprintf(stderr, "veos kernel already initialized...\n"); X fprintf(stderr, "no action was taken.\n"); X } X else { X /** initialize often-used globals with defualt values **/ X X iErr = Shell_InitCaches(); X if (iErr == VEOS_SUCCESS) { X X X /** perform one-time nancy initialization **/ X X iErr = Nancy_Init(); X if (iErr == VEOS_SUCCESS) { X X X /** initialize inter-entity communication handler **/ X /** this puts an ear to the network **/ X X iErr = Talk_HelloTalk(iPort, pMessFun); X if (iErr == VEOS_SUCCESS) { X X X /** provide for graceful exit **/ X X Shell_SetupErrorTraps(); X X X /** print gratuitous credits **/ X X Shell_StartUpMessage(); X X KERNEL_INIT = TRUE; X } X } X } X X if (iErr != VEOS_SUCCESS) X fprintf(stderr, "shell %s: kernel initialization failed, error: %d\n", X WHOAMI, iErr); X } X X return(iErr); X X } /* Kernel_Init */ X/****************************************************************************************/ X X X X/**************************************************************************************** X * Kernel_Shutdown */ X XTVeosErr Kernel_Shutdown() X{ X TVeosErr iSuccess = VEOS_FAILURE; X X if (KERNEL_INIT) { X X /** cleanup network loose ends **/ X X iSuccess = Talk_ByeTalk(); X X X /** dispose all memory **/ X X fprintf(stderr, "\n"); X X X KERNEL_INIT = FALSE; X } X X X return(iSuccess); X X } /* Kernel_Shutdown */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X * Kernel_SystemTask */ X XTVeosErr Kernel_SystemTask() X{ X /** inspect every open connection for queued outgoing messages **/ X X if (SPEAK_DIRTY) X Talk_DispatchQedSpeakMessages(); X X X /** accept new entity connections **/ X/* X if (++TASKS % 10 == 0) X*/ X Talk_EstNewListenConnections(); X X X /** check each open listen connection for incoming messages **/ X X Talk_GatherListenMessages(); X X X return(VEOS_SUCCESS); X X } /* Kernel_SystemTask */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_NewBlock(iSize, hBlock, sDebug) X int iSize; X char * *hBlock; X char *sDebug; X{ X char * *pBlock; X TVeosErr iSuccess; X X if (iSize >= SHELL_CHAIN_HASH_MAX) { X X NEWPTR(pBlock, char **, iSize); X#ifndef OPTIMAL X if (SHELL_BUGS) X fprintf(stderr, "shell %s: %s >> size: %d, regular\n", X WHOAMI, sDebug ? sDebug : "", iSize); X#endif X } X X else { X if (pBlock = (char **) MEM_CHAINS[iSize]) { X X BLOCKS_OUT[iSize] ++; X X /** remove nearest block in chain **/ X X MEM_CHAINS[iSize] = *pBlock; X *pBlock = nil; X#ifndef OPTIMAL X if (SHELL_BUGS) X fprintf(stderr, "shell %s: %s >> size: %d, recycle, blocks out: %d\n", X WHOAMI, sDebug ? sDebug : "", iSize, BLOCKS_OUT[iSize]); X#endif X } X X else { X BLOCKS_OUT[iSize] ++; X NEWPTR(pBlock, char **, iSize); X#ifndef OPTIMAL X if (SHELL_BUGS) X fprintf(stderr, "shell %s: %s >> size: %d, new, blocks out: %d\n", X WHOAMI, sDebug ? sDebug : "", iSize, BLOCKS_OUT[iSize]); X#endif X } X } X X if (*hBlock = (char *) pBlock) X iSuccess = VEOS_SUCCESS; X else X iSuccess = VEOS_FAILURE; X X X return(iSuccess); X X } /* Shell_NewBlock */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Shell_ReturnBlock(pBlock, iSize, sDebug) X char * *pBlock; X int iSize; X char *sDebug; X{ X int iSuccess; X X iSuccess = VEOS_SUCCESS; X X if (iSize >= SHELL_CHAIN_HASH_MAX) { X X DUMP(pBlock); X#ifndef OPTIMAL X if (SHELL_BUGS) X fprintf(stderr, "shell %s: %s << size: %d, regular\n", X WHOAMI, sDebug ? sDebug : "", iSize); X#endif X } X X else { X BLOCKS_OUT[iSize] --; X X *pBlock = MEM_CHAINS[iSize]; X X MEM_CHAINS[iSize] = (char *) pBlock; X#ifndef OPTIMAL X if (SHELL_BUGS) { X fprintf(stderr, "shell %s: %s << size: %d, blocks out: %d\n", X WHOAMI, sDebug ? sDebug : "", iSize, BLOCKS_OUT[iSize]); X } X#endif X } X X return(iSuccess); X X } /* Shell_ReturnBlock */ X/****************************************************************************************/ X X X X/**************************************************************************************** X * local functions * X ****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_InitCaches() X{ X TVeosErr iSuccess; X int iChain; X str63 sHostName; X X iSuccess = VEOS_FAILURE; X X X /** chain list is as long as largest possible block size **/ X X for (iChain = 0; iChain < SHELL_CHAIN_HASH_MAX; iChain ++) { X MEM_CHAINS[iChain] = nil; X BLOCKS_OUT[iChain] = 0; X } X X X /** publicly accessible globals **/ X X if (gethostname(sHostName, sizeof(sHostName)) != -1) X iSuccess = Sock_StrHost2IP(sHostName, &IDENT_ADDR.lHost); X X IDENT_ADDR.iPort = TALK_BOGUS_FD; X X Shell_UpdateUid(); X X X TERMINATE = FALSE; X X X /** kernel debugging flags **/ X X TALK_BUGS = FALSE; X SHELL_BUGS = FALSE; X NANCY_BUGS = FALSE; X X X /** other kernel globals **/ X X TRAP_FLAGS = 0; X TASKS = 0; X X iSuccess = VEOS_SUCCESS; X X X return(iSuccess); X X } /* Shell_InitCaches */ X/****************************************************************************************/ X X X X/****************************************************************************************/ Xvoid Shell_TrapErr(iSignal, iCode, context, pAddr) X int iSignal, iCode; X struct sigcontext *context; X char *pAddr; X{ X str255 sErr; X str63 sSignal; X static boolean bGone = FALSE; X X /** interupt was already trapped once with no service **/ X X if (TRAP_FLAGS & 0x00000001 << iSignal) { X Shell_Signal2String(iSignal, sSignal); X sprintf(sErr, "fatal signal: %s, entity: %s\n", sSignal, WHOAMI); X X if (bGone) X exit(0); X X else { X bGone = TRUE; X Shell_BailOut(sErr); X } X } X else { X#ifndef OPTIMAL X if (SHELL_BUGS) { X Shell_Signal2String(iSignal, sSignal); X fprintf(stderr, "shell %s: interrupt occurred: %s.\n", WHOAMI, sSignal); X } X#endif X TRAP_FLAGS |= 0x00000001 << iSignal; X } X X } /* Shell_TrapErr */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_Signal2String(iSignal, sSignal) X int iSignal; X char *sSignal; X{ X switch (iSignal) { X X case SIGBUS: X strcpy(sSignal, "bus error"); X break; X X case SIGKILL: X strcpy(sSignal, "forceful kill"); X break; X X case SIGQUIT: X strcpy(sSignal, "user quit request"); X break; X X case SIGSEGV: X strcpy(sSignal, "segmentation fault"); X break; X X case SIGINT: X strcpy(sSignal, "keyboard interrupt"); X break; X X case SIGPIPE: X strcpy(sSignal, "broken pipe"); X break; X X default: X strcpy(sSignal, "unknown signal"); X break; X } X X return(VEOS_SUCCESS); X X } /* Shell_Signal2String */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_SetupErrorTraps() X{ X if (SIG_ENABLE) { X signal(SIGINT, Shell_TrapErr); X signal(SIGQUIT, Shell_TrapErr); X signal(SIGBUS, Shell_TrapErr); X signal(SIGSEGV, Shell_TrapErr); X signal(SIGPIPE, Shell_TrapErr); X } X X } /* Shell_SetupErrorTraps */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Shell_StartUpMessage() X{ X fprintf(stderr, "\n\n\n"); X fprintf(stderr, "----------------------------------------------------\n"); X fprintf(stderr, " VEOS 2.0 by Geoffrey Coco \n"); X fprintf(stderr, " Copyright (C) 1992, Human Interface Technology Lab \n"); X fprintf(stderr, "----------------------------------------------------\n\n\n\n"); X X return(VEOS_SUCCESS); X X } /* Shell_StartUpMessage */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Shell_UpdateUid() X{ X TVeosErr iSuccess; X str63 sHostName; X X /** update WHOAMI C variable **/ X X iSuccess = Sock_IP2StrHost(IDENT_ADDR.lHost, sHostName); X if (iSuccess == VEOS_SUCCESS) X X sprintf(WHOAMI, "%s_%d", sHostName, IDENT_ADDR.iPort); X X X return(iSuccess); X X } /* Shell_UpdateUid */ X/****************************************************************************************/ X X X X#ifdef _DEC_ X/****************************************************************************************/ Xchar *strdup(sSrc) X char *sSrc; X{ X char *sReturn; X X sReturn = nil; X X if (sSrc) { X if (NEWPTR(sReturn, char *, strlen(sSrc) + 1)) X strcpy(sReturn, sSrc); X } X X return(sReturn); X X } /* strdup */ X/****************************************************************************************/ X#endif X X X END_OF_FILE if test 10711 -ne `wc -c <'src/kernel_current/shell/shell.c'`; then echo shar: \"'src/kernel_current/shell/shell.c'\" unpacked with wrong size! fi # end of 'src/kernel_current/shell/shell.c' fi if test -f 'src/xlisp/xcore/c/xlinit.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlinit.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlinit.c'\" $10643 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlinit.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xlinit.c X* RCS: $Header: xlinit.c,v 1.3 89/11/25 05:31:53 mayer Exp $ X* Description: xlisp initialization module X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:31:30 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: xlinit.c,v 1.3 89/11/25 05:31:53 mayer Exp $"; X X#include "xlisp.h" X X/* external variables */ Xextern LVAL true,s_dot,s_unbound; Xextern LVAL s_quote,s_function,s_bquote,s_comma,s_comat; Xextern LVAL s_lambda,s_macro; Xextern LVAL s_send;/*91Jun15jsp*/ Xextern LVAL s_stdin,s_stdout,s_stderr,s_debugio,s_traceout; Xextern LVAL s_evalhook,s_applyhook,s_tracelist; Xextern LVAL s_tracenable,s_tlimit,s_breakenable; Xextern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get,s_eql; Xextern LVAL s_svalue,s_sfunction,s_splist; Xextern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro; Xextern LVAL k_sescape,k_mescape; Xextern LVAL s_ifmt,s_ffmt,s_printcase; Xextern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus; Xextern LVAL k_test,k_tnot; Xextern LVAL k_direction,k_input,k_output; Xextern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end; Xextern LVAL k_verbose,k_print,k_count,k_key,k_upcase,k_downcase; Xextern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys; Xextern LVAL a_subr,a_fsubr,a_cons,a_symbol; Xextern LVAL a_fixnum,a_flonum,a_string,a_stream,a_object; Xextern LVAL a_vector,a_closure,a_char,a_ustream; Xextern LVAL s_gcflag,s_gchook; Xextern FUNDEF *funtab; X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLINIT_C_GLOBALS X#include "../../xmodules.h" X#undef MODULE_XLINIT_C_GLOBALS X X/* xlinit - xlisp initialization routine */ Xxlinit() X{ X /* initialize xlisp (must be in this order) */ X xlfinit(); /* initialize the function table */ /* Voodoo */ X xlminit(); /* initialize xldmem.c */ X xldinit(); /* initialize xldbug.c */ X X /* finish initializing */ X#ifdef SAVERESTORE X if (!xlirestore("xlisp.wks")) X#endif X initwks(); X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLINIT_C_XLINIT X#include "../../xmodules.h" X#undef MODULE_XLINIT_C_XLINIT X} X X/* initwks - build an initial workspace */ XLOCAL initwks() X{ X FUNDEF *p; X int i; X X xlsinit(); /* initialize xlsym.c */ X X /* To prevent obscure gc() crashes during initialization, it is */ X /* important to establish s_gcflag and s_gchook early, and to set */ X /* them to NIL immediately. This is Tom Almy's improvement on my */ X /* earlier kludge: (91Jan18jsp) */ X s_gcflag = xlenter("*GC-FLAG*"); setvalue(s_gcflag,NIL); X s_gchook = xlenter("*GC-HOOK*"); setvalue(s_gchook,NIL); X X xlsymbols();/* enter all symbols used by the interpreter */ X xlrinit(); /* initialize xlread.c */ X xloinit(); /* initialize xlobj.c */ X X /* setup defaults */ X setvalue(s_evalhook,NIL); /* no evalhook function */ X setvalue(s_applyhook,NIL); /* no applyhook function */ X setvalue(s_tracelist,NIL); /* no functions being traced */ X setvalue(s_tracenable,NIL); /* traceback disabled */ X setvalue(s_tlimit,NIL); /* trace limit infinite */ X setvalue(s_breakenable,NIL); /* don't enter break loop on errors */ X setvalue(s_ifmt,cvstring(IFMT)); /* integer print format */ X setvalue(s_ffmt,cvstring("%g")); /* float print format */ X setvalue(s_printcase,k_upcase); /* upper case output of symbols */ X X /* install the built-in functions and special forms */ X for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p) X if (p->fd_name) X xlsubr(p->fd_name,p->fd_type,p->fd_subr,i); X X /* add some synonyms */ X setfunction(xlenter("NOT"),getfunction(xlenter("NULL"))); X setfunction(xlenter("FIRST"),getfunction(xlenter("CAR"))); X setfunction(xlenter("SECOND"),getfunction(xlenter("CADR"))); X setfunction(xlenter("THIRD"),getfunction(xlenter("CADDR"))); X setfunction(xlenter("FOURTH"),getfunction(xlenter("CADDDR"))); X setfunction(xlenter("REST"),getfunction(xlenter("CDR"))); X} X X/* xlsymbols - enter all of the symbols used by the interpreter */ Xxlsymbols() X{ X LVAL sym; X X /* enter the unbound variable indicator (must be first) */ X s_unbound = xlenter("*UNBOUND*"); X setvalue(s_unbound,s_unbound); X X /* enter the 't' symbol */ X true = xlenter("T"); X setvalue(true,true); X X /* enter some important symbols */ X s_dot = xlenter("."); X s_quote = xlenter("QUOTE"); X s_function = xlenter("FUNCTION"); X s_bquote = xlenter("BACKQUOTE"); X s_comma = xlenter("COMMA"); X s_comat = xlenter("COMMA-AT"); X s_lambda = xlenter("LAMBDA"); X s_send = xlenter("SEND"); /*91Jun15jsp*/ X s_macro = xlenter("MACRO"); X s_eql = xlenter("EQL"); X s_ifmt = xlenter("*INTEGER-FORMAT*"); X s_ffmt = xlenter("*FLOAT-FORMAT*"); X X /* symbols set by the read-eval-print loop */ X s_1plus = xlenter("+"); X s_2plus = xlenter("++"); X s_3plus = xlenter("+++"); X s_1star = xlenter("*"); X s_2star = xlenter("**"); X s_3star = xlenter("***"); X s_minus = xlenter("-"); X X /* enter setf place specifiers */ X s_setf = xlenter("*SETF*"); X s_car = xlenter("CAR"); X s_cdr = xlenter("CDR"); X s_nth = xlenter("NTH"); X s_aref = xlenter("AREF"); X s_get = xlenter("GET"); X s_svalue = xlenter("SYMBOL-VALUE"); X s_sfunction = xlenter("SYMBOL-FUNCTION"); X s_splist = xlenter("SYMBOL-PLIST"); X X /* enter the readtable variable and keywords */ X s_rtable = xlenter("*READTABLE*"); X k_wspace = xlenter(":WHITE-SPACE"); X k_const = xlenter(":CONSTITUENT"); X k_nmacro = xlenter(":NMACRO"); X k_tmacro = xlenter(":TMACRO"); X k_sescape = xlenter(":SESCAPE"); X k_mescape = xlenter(":MESCAPE"); X X /* enter parameter list keywords */ X k_test = xlenter(":TEST"); X k_tnot = xlenter(":TEST-NOT"); X X /* "open" keywords */ X k_direction = xlenter(":DIRECTION"); X k_input = xlenter(":INPUT"); X k_output = xlenter(":OUTPUT"); X X /* enter *print-case* symbol and keywords */ X s_printcase = xlenter("*PRINT-CASE*"); X k_upcase = xlenter(":UPCASE"); X k_downcase = xlenter(":DOWNCASE"); X X /* other keywords */ X k_start = xlenter(":START"); X k_end = xlenter(":END"); X k_1start = xlenter(":START1"); X k_1end = xlenter(":END1"); X k_2start = xlenter(":START2"); X k_2end = xlenter(":END2"); X k_verbose = xlenter(":VERBOSE"); X k_print = xlenter(":PRINT"); X k_count = xlenter(":COUNT"); X k_key = xlenter(":KEY"); X X /* enter lambda list keywords */ X lk_optional = xlenter("&OPTIONAL"); X lk_rest = xlenter("&REST"); X lk_key = xlenter("&KEY"); X lk_aux = xlenter("&AUX"); X lk_allow_other_keys = xlenter("&ALLOW-OTHER-KEYS"); X X /* enter *standard-input*, *standard-output* and *error-output* */ X s_stdin = xlenter("*STANDARD-INPUT*"); X setvalue(s_stdin,cvfile(stdin)); X s_stdout = xlenter("*STANDARD-OUTPUT*"); X setvalue(s_stdout,cvfile(stdout)); X s_stderr = xlenter("*ERROR-OUTPUT*"); X setvalue(s_stderr,cvfile(stderr)); X X /* enter *debug-io* and *trace-output* */ X s_debugio = xlenter("*DEBUG-IO*"); X setvalue(s_debugio,getvalue(s_stderr)); X s_traceout = xlenter("*TRACE-OUTPUT*"); X setvalue(s_traceout,getvalue(s_stderr)); X X /* enter the eval and apply hook variables */ X s_evalhook = xlenter("*EVALHOOK*"); X s_applyhook = xlenter("*APPLYHOOK*"); X X /* enter the symbol pointing to the list of functions being traced */ X s_tracelist = xlenter("*TRACELIST*"); X X /* enter the error traceback and the error break enable flags */ X s_tracenable = xlenter("*TRACENABLE*"); X s_tlimit = xlenter("*TRACELIMIT*"); X s_breakenable = xlenter("*BREAKENABLE*"); X X /* Enter a symbol to control printing of garbage collection messages. */ X s_gcflag = xlenter("*GC-FLAG*"); X s_gchook = xlenter("*GC-HOOK*"); X X /* enter a copyright notice into the oblist */ X#ifdef PROVIDE_sWINTERP X sym = xlenter("**Copyright-1989-by-David-Betz-and-Niels-Mayer**"); X#else X sym = xlenter("**Copyright-1989-by-David-Betz**"); X#endif X setvalue(sym,true); X X /* enter type names */ X a_subr = xlenter("SUBR"); X a_fsubr = xlenter("FSUBR"); X a_cons = xlenter("CONS"); X a_symbol = xlenter("SYMBOL"); X a_fixnum = xlenter("FIXNUM"); X a_flonum = xlenter("FLONUM"); X a_string = xlenter("STRING"); X a_object = xlenter("OBJECT"); X a_stream = xlenter("FILE-STREAM"); X a_vector = xlenter("ARRAY"); X a_closure = xlenter("CLOSURE"); X a_char = xlenter("CHARACTER"); X a_ustream = xlenter("UNNAMED-STREAM"); X X /* add the object-oriented programming symbols and os specific stuff */ X obsymbols(); /* object-oriented programming symbols */ X ossymbols(); /* os specific symbols */ X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLINIT_C_XLSYMBOLS X#include "../../xmodules.h" X#undef MODULE_XLINIT_C_XLSYMBOLS X} X END_OF_FILE if test 10643 -ne `wc -c <'src/xlisp/xcore/c/xlinit.c'`; then echo shar: \"'src/xlisp/xcore/c/xlinit.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlinit.c' fi if test -f 'src/xlisp/xcore/c/xlprin.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlprin.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlprin.c'\" $9502 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlprin.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xlprint.c X* RCS: $Header: xlprin.c,v 1.5 89/11/25 05:42:42 mayer Exp $ X* Description: xlisp print routine X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:42:35 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: xlprin.c,v 1.5 89/11/25 05:42:42 mayer Exp $"; X X X#include "xlisp.h" X X/* external variables */ Xextern LVAL tentry(); Xextern LVAL s_printcase,k_downcase,k_const,k_nmacro; Xextern LVAL s_ifmt,s_ffmt; Xextern FUNDEF *funtab; Xextern char buf[]; X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLPRIN_C_GLOBALS X#include "../../xmodules.h" X#undef MODULE_XLPRIN_C_GLOBALS X X/* xlprint - print an xlisp value */ Xxlprint(fptr,vptr,flag) X LVAL fptr,vptr; int flag; X{ X LVAL nptr,next; X int n,i; X X /* print nil */ X if (vptr == NIL) { X putsymbol(fptr,"NIL",flag); X return; X } X X /* check value type */ X switch (ntype(vptr)) { X case SUBR: X putsubr(fptr,"Subr",vptr); X break; X case FSUBR: X putsubr(fptr,"FSubr",vptr); X break; X case CONS: X xlputc(fptr,'('); X for (nptr = vptr; nptr != NIL; nptr = next) { X xlprint(fptr,car(nptr),flag); X if (next = cdr(nptr)) X if (consp(next)) X xlputc(fptr,' '); X else { X xlputstr(fptr," . "); X xlprint(fptr,next,flag); X break; X } X } X xlputc(fptr,')'); X break; X case SYMBOL: X putsymbol(fptr,getstring(getpname(vptr)),flag); X break; X case FIXNUM: X putfixnum(fptr,getfixnum(vptr)); X break; X case FLONUM: X putflonum(fptr,getflonum(vptr)); X break; X case CHAR: X putchcode(fptr,getchcode(vptr),flag); X break; X case STRING: X if (flag) X putqstring(fptr,vptr); X else X putstring(fptr,vptr); X break; X case STREAM: X putatm(fptr,"File-Stream",vptr); X break; X case USTREAM: X putatm(fptr,"Unnamed-Stream",vptr); X break; X case OBJECT: X putatm(fptr,"Object",vptr); X break; X case VECTOR: X xlputc(fptr,'#'); xlputc(fptr,'('); X for (i = 0, n = getsz(vptr) - 1; i <= n; ++i) { X xlprint(fptr,getelement(vptr,i),flag); X if (i != n) xlputc(fptr,' '); X } X xlputc(fptr,')'); X break; X case STRUCT: X xlprstruct(fptr,vptr,flag); X break; X case CLOSURE: X putclosure(fptr,vptr); X break; X case FREE: X putatm(fptr,"Free",vptr); X break; X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLPRIN_C_XLPRINT X#include "../../xmodules.h" X#undef MODULE_XLPRIN_C_XLPRINT X X default: X putatm(fptr,"Foo",vptr); X break; X } X} X X/* xlterpri - terminate the current print line */ Xxlterpri(fptr) X LVAL fptr; X{ X xlputc(fptr,'\n'); X} X X/* xlputstr - output a string */ Xxlputstr(fptr,str) X LVAL fptr; char *str; X{ X while (*str) X xlputc(fptr,*str++); X} X X/* putsymbol - output a symbol */ XLOCAL putsymbol(fptr,str,escflag) X LVAL fptr; char *str; int escflag; X{ X int downcase,ch; X LVAL type; X char *p; X X /* check for printing without escapes */ X if (!escflag) { X xlputstr(fptr,str); X return; X } X X /* check to see if symbol needs escape characters */ X if (tentry(*str) == k_const) { X for (p = str; *p; ++p) X if (islower(*p) X || ((type = tentry(*p)) != k_const X && (!consp(type) || car(type) != k_nmacro))) { X xlputc(fptr,'|'); X while (*str) { X if (*str == '\\' || *str == '|') X xlputc(fptr,'\\'); X xlputc(fptr,*str++); X } X xlputc(fptr,'|'); X return; X } X } X X /* get the case translation flag */ X downcase = (getvalue(s_printcase) == k_downcase); X X /* check for the first character being '#' */ X if (*str == '#' || *str == '.' || isnumber(str,NULL)) X xlputc(fptr,'\\'); X X /* output each character */ X while ((ch = *str++) != '\0') { X /* don't escape colon until we add support for packages */ X if (ch == '\\' || ch == '|' /* || ch == ':' */) X xlputc(fptr,'\\'); X xlputc(fptr,(downcase && isupper(ch) ? tolower(ch) : ch)); X } X} X X/* putstring - output a string */ XLOCAL putstring(fptr,str) X LVAL fptr,str; X{ X unsigned char *p; X int ch; X X /* output each character */ X for (p = getstring(str); (ch = *p) != '\0'; ++p) X xlputc(fptr,ch); X} X X/* putqstring - output a quoted string */ XLOCAL putqstring(fptr,str) X LVAL fptr,str; X{ X unsigned char *p; X int ch; X X /* get the string pointer */ X p = getstring(str); X X /* output the initial quote */ X xlputc(fptr,'"'); X X /* output each character in the string */ X for (p = getstring(str); (ch = *p) != '\0'; ++p) X X /* check for a control character */ X if (ch < 040 || ch == '\\' || ch > 0176) { X xlputc(fptr,'\\'); X switch (ch) { X case '\011': X xlputc(fptr,'t'); X break; X case '\012': X xlputc(fptr,'n'); X break; X case '\014': X xlputc(fptr,'f'); X break; X case '\015': X xlputc(fptr,'r'); X break; X case '\\': X xlputc(fptr,'\\'); X break; X default: X putoct(fptr,ch); X break; X } X } X X /* output a normal character */ X else X xlputc(fptr,ch); X X /* output the terminating quote */ X xlputc(fptr,'"'); X} X X/* putatm - output an atom */ XLOCAL putatm(fptr,tag,val) X LVAL fptr; char *tag; LVAL val; X{ X sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf); X sprintf(buf,AFMT,val); xlputstr(fptr,buf); X xlputc(fptr,'>'); X} X X/* putsubr - output a subr/fsubr */ XLOCAL putsubr(fptr,tag,val) X LVAL fptr; char *tag; LVAL val; X{ X sprintf(buf,"#<%s-%s: #",tag,funtab[getoffset(val)].fd_name); X xlputstr(fptr,buf); X sprintf(buf,AFMT,val); xlputstr(fptr,buf); X xlputc(fptr,'>'); X} X X/* putclosure - output a closure */ XLOCAL putclosure(fptr,val) X LVAL fptr,val; X{ X LVAL name; X if (name = getname(val)) X sprintf(buf,"#<Closure-%s: #",getstring(getpname(name))); X else X strcpy(buf,"#<Closure: #"); X xlputstr(fptr,buf); X sprintf(buf,AFMT,val); xlputstr(fptr,buf); X xlputc(fptr,'>'); X/* X xlputstr(fptr,"\nName: "); xlprint(fptr,getname(val),TRUE); X xlputstr(fptr,"\nType: "); xlprint(fptr,gettype(val),TRUE); X xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE); X xlputstr(fptr,"\nArgs: "); xlprint(fptr,getargs(val),TRUE); X xlputstr(fptr,"\nOargs: "); xlprint(fptr,getoargs(val),TRUE); X xlputstr(fptr,"\nRest: "); xlprint(fptr,getrest(val),TRUE); X xlputstr(fptr,"\nKargs: "); xlprint(fptr,getkargs(val),TRUE); X xlputstr(fptr,"\nAargs: "); xlprint(fptr,getaargs(val),TRUE); X xlputstr(fptr,"\nBody: "); xlprint(fptr,getbody(val),TRUE); X xlputstr(fptr,"\nEnv: "); xlprint(fptr,xlgetenv(val),TRUE); X xlputstr(fptr,"\nFenv: "); xlprint(fptr,getfenv(val),TRUE); X*/ X} X X/* putfixnum - output a fixnum */ XLOCAL putfixnum(fptr,n) X LVAL fptr; FIXTYPE n; X{ X unsigned char *fmt; X LVAL val; X fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? getstring(val) X : (unsigned char *)IFMT); X sprintf(buf,(char *)fmt,n); X xlputstr(fptr,buf); X} X X/* putflonum - output a flonum */ XLOCAL putflonum(fptr,n) X LVAL fptr; FLOTYPE n; X{ X unsigned char *fmt; X LVAL val; X fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? getstring(val) X : (unsigned char *)"%g"); X sprintf(buf,(char *)fmt,n); X xlputstr(fptr,buf); X} X X/* putchcode - output a character */ XLOCAL putchcode(fptr,ch,escflag) X LVAL fptr; int ch,escflag; X{ X if (escflag) { X switch (ch) { X case '\n': X xlputstr(fptr,"#\\Newline"); X break; X case ' ': X xlputstr(fptr,"#\\Space"); X break; X default: X sprintf(buf,"#\\%c",ch); X xlputstr(fptr,buf); X break; X } X } X else X xlputc(fptr,ch); X} X X/* putoct - output an octal byte value */ XLOCAL putoct(fptr,n) X LVAL fptr; int n; X{ X sprintf(buf,"%03o",n); X xlputstr(fptr,buf); X} END_OF_FILE if test 9502 -ne `wc -c <'src/xlisp/xcore/c/xlprin.c'`; then echo shar: \"'src/xlisp/xcore/c/xlprin.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlprin.c' fi echo shar: End of archive 4 $of 16$. cp /dev/null ark4isdone 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