Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP Path: utzoo!watmath!clyde!rutgers!lll-lcc!styx!ames!ucbcad!ucbvax!decvax!decwrl!cookie.dec.com!wecker From: wecker@cookie.dec.com.UUCP Newsgroups: comp.sys.amiga Subject: uEMACS (V1.0 DBW 870220) my own version Part 3/4 Message-ID: <8188@decwrl.DEC.COM> Date: Fri, 20-Feb-87 20:29:12 EST Article-I.D.: decwrl.8188 Posted: Fri Feb 20 20:29:12 1987 Date-Received: Sat, 21-Feb-87 16:35:45 EST Sender: daemon@decwrl.DEC.COM Organization: Digital Equipment Corporation Lines: 2987 # This is a shell archive. # Remove everything above and including the cut line. # Then run the rest of the file through sh. #----cut here-----cut here-----cut here-----cut here----# #!/bin/sh # shar: Shell Archiver # Run the following text with /bin/sh to create: # fileio.c # line.c # lisp.c # lock.c # main.c # random.c # This archive created: Fri Feb 20 17:44:33 1987 echo shar: extracting fileio.c sed 's/^XX//' << \SHAR_EOF > fileio.c XX/* XX * The routines in this file read and write ASCII files from the disk. All of XX * the knowledge about files are here. A better message writing scheme should XX * be used. XX */ XX#include XX#include "estruct.h" XX#include "edef.h" XX XXFILE *ffp; /* File pointer, all functions. */ XX XX/* XX * Open a file for reading. XX */ XXffropen(fn) XXchar *fn; XX { XX if ((ffp=fopen(fn, "r")) == NULL) return (FIOFNF); XX return (FIOSUC); XX } XX XX/* XX * Open a file for writing. Return TRUE if all is well, and FALSE on error XX * (cannot create). XX */ XXffwopen(fn) XXchar *fn; XX { XX#if VMS XX register int fd; XX XX if ((fd=creat(fn, 0666, "rfm=var", "rat=cr")) < 0 || (ffp=fdopen(fd, "w")) == NULL) { XX#else XX if ((ffp=fopen(fn, "w")) == NULL) { XX#endif XX mlwrite("Cannot open file for writing"); XX return (FIOERR); XX } XX return (FIOSUC); XX } XX XX /* XX * Close a file. Should look at the status in all systems. XX */ XX ffclose() XX { XX#if ULTRIX XX if (fclose(ffp) != FALSE) { XX mlwrite("Error closing file"); XX return(FIOERR); XX } XX return(FIOSUC); XX#else XX fclose(ffp); XX return (FIOSUC); XX#endif XX } XX XX /* XX * Write a line to the already opened file. The "buf" points to the buffer, XX * and the "nbuf" is its length, less the free newline. Return the status. XX * Check only at the newline. XX */ XX ffputline(buf, nbuf) XX char buf[]; XX { XX register int i; XX XX for (i = 0; i < nbuf; ++i) fputc(buf[i]&0xFF, ffp); XX XX fputc('\n', ffp); XX XX if (ferror(ffp)) { XX mlwrite("Write I/O error"); XX return (FIOERR); XX } XX XX return (FIOSUC); XX } XX XX /* XX * Read a line from a file, and store the bytes in the supplied buffer. The XX * "nbuf" is the length of the buffer. Complain about long lines and lines XX * at the end of the file that don't have a newline present. Check for I/O XX * errors too. Return status. XX */ XX ffgetline(buf, nbuf) XX register char buf[]; XX { XX register int c; XX register int i; XX XX i = 0; XX XX while ((c = fgetc(ffp)) != EOF && c != '\n') { XX if (i >= nbuf-2) { XX buf[nbuf - 2] = c; /* store last char read */ XX buf[nbuf - 1] = 0; /* and terminate it */ XX mlwrite("File has long line"); XX return (FIOLNG); XX } XX buf[i++] = c; XX } XX XX if (c == EOF) { XX if (ferror(ffp)) { XX mlwrite("File read error"); XX return (FIOERR); XX } XX XX if (i != 0) { XX mlwrite("File has funny line at EOF"); XX return (FIOERR); XX } XX return (FIOEOF); XX } XX XX buf[i] = 0; XX return (FIOSUC); XX } XX SHAR_EOF if test 2446 -ne "`wc -c fileio.c`" then echo shar: error transmitting fileio.c '(should have been 2446 characters)' fi echo shar: extracting line.c sed 's/^XX//' << \SHAR_EOF > line.c XX/* XX * The functions in this file are a general set of line management utilities. XX * They are the only routines that touch the text. They also touch the buffer XX * and window structures, to make sure that the necessary updating gets done. XX * There are routines in this file that handle the kill buffer too. It isn't XX * here for any good reason. XX * XX * Note that this code only updates the dot and mark values in the window list. XX * Since all the code acts on the current window, the buffer that we are XX * editing must be being displayed, which means that "b_nwnd" is non zero, XX * which means that the dot and mark values in the buffer headers are nonsense. XX */ XX XX#include XX#include "estruct.h" XX#include "edef.h" XX XX#define NBLOCK 16 /* Line block chunk size */ XX#define KBLOCK 1024 /* Kill buffer block size */ XX XXchar *kbufp = NULL; /* Kill buffer data */ XXunsigned kused = 0; /* # of bytes used in KB */ XXunsigned ksize = 0; /* # of bytes allocated in KB */ XX XX/* XX * This routine allocates a block of memory large enough to hold a LINE XX * containing "used" characters. The block is always rounded up a bit. Return XX * a pointer to the new block, or NULL if there isn't any memory left. Print a XX * message in the message line if no space. XX */ XXLINE * XXlalloc(used) XXregister int used; XX { XX register LINE *lp; XX register int size; XX char *malloc(); XX XX size = (used+NBLOCK-1) & ~(NBLOCK-1); XX if (size == 0) /* Assume that an empty */ XX size = NBLOCK; /* line is for type-in. */ XX if ((lp = (LINE *) malloc(sizeof(LINE)+size)) == NULL) { XX mlwrite("Cannot allocate %d bytes", size); XX return (NULL); XX } XX lp->l_size = size; XX lp->l_used = used; XX return (lp); XX } XX XX/* XX * Delete line "lp". Fix all of the links that might point at it (they are XX * moved to offset 0 of the next line. Unlink the line from whatever buffer it XX * might be in. Release the memory. The buffers are updated too; the magic XX * conditions described in the above comments don't hold here. XX */ XXlfree(lp) XXregister LINE *lp; XX { XX register BUFFER *bp; XX register WINDOW *wp; XX XX wp = wheadp; XX while (wp != NULL) { XX if (wp->w_linep == lp) wp->w_linep = lp->l_fp; XX if (wp->w_dotp == lp) { XX wp->w_dotp = lp->l_fp; XX wp->w_doto = 0; XX } XX if (wp->w_markp == lp) { XX wp->w_markp = lp->l_fp; XX wp->w_marko = 0; XX } XX wp = wp->w_wndp; XX } XX bp = bheadp; XX while (bp != NULL) { XX if (bp->b_nwnd == 0) { XX if (bp->b_dotp == lp) { XX bp->b_dotp = lp->l_fp; XX bp->b_doto = 0; XX } XX if (bp->b_markp == lp) { XX bp->b_markp = lp->l_fp; XX bp->b_marko = 0; XX } XX } XX bp = bp->b_bufp; XX } XX lp->l_bp->l_fp = lp->l_fp; XX lp->l_fp->l_bp = lp->l_bp; XX free((char *) lp); XX } XX XX/* XX * This routine gets called when a character is changed in place in the current XX * buffer. It updates all of the required flags in the buffer and window XX * system. The flag used is passed as an argument; if the buffer is being XX * displayed in more than 1 window we change EDIT t HARD. Set MODE if the XX * mode line needs to be updated (the "*" has to be set). XX */ XXlchange(flag) XXregister int flag; XX { XX register WINDOW *wp; XX XX if (curbp->b_nwnd != 1) /* Ensure hard. */ XX flag = WFHARD; XX if ((curbp->b_flag&BFCHG) == 0) { /* First change, so */ XX flag |= WFMODE; /* update mode lines. */ XX curbp->b_flag |= BFCHG; XX } XX wp = wheadp; XX while (wp != NULL) { XX if (wp->w_bufp == curbp) wp->w_flag |= flag; XX wp = wp->w_wndp; XX } XX } XX XX/* XX * Insert "n" copies of the character "c" at the current location of dot. In XX * the easy case all that happens is the text is stored in the line. In the XX * hard case, the line has to be reallocated. When the window list is updated, XX * take special care; I screwed it up once. You always update dot in the XX * current window. You update mark, and a dot in another window, if it is XX * greater than the place where you did the insert. Return TRUE if all is XX * well, and FALSE on errors. XX */ XXlinsert(n, c) XX { XX register char *cp1; XX register char *cp2; XX register LINE *lp1; XX register LINE *lp2; XX register LINE *lp3; XX register int doto; XX register int i; XX register WINDOW *wp; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX lchange(WFEDIT); XX lp1 = curwp->w_dotp; /* Current line */ XX if (lp1 == curbp->b_linep) { /* At the end: special */ XX if (curwp->w_doto != 0) { XX mlwrite("bug: linsert"); XX return (FALSE); XX } XX if ((lp2=lalloc(n)) == NULL) /* Allocate new line */ XX return (FALSE); XX lp3 = lp1->l_bp; /* Previous line */ XX lp3->l_fp = lp2; /* Link in */ XX lp2->l_fp = lp1; XX lp1->l_bp = lp2; XX lp2->l_bp = lp3; XX for (i=0; il_text[i] = c; XX curwp->w_dotp = lp2; XX curwp->w_doto = n; XX return (TRUE); XX } XX doto = curwp->w_doto; /* Save for later. */ XX if (lp1->l_used+n > lp1->l_size) { /* Hard: reallocate */ XX if ((lp2=lalloc(lp1->l_used+n)) == NULL) XX return (FALSE); XX cp1 = &lp1->l_text[0]; XX cp2 = &lp2->l_text[0]; XX while (cp1 != &lp1->l_text[doto]) *cp2++ = *cp1++; XX cp2 += n; XX while (cp1 != &lp1->l_text[lp1->l_used]) *cp2++ = *cp1++; XX lp1->l_bp->l_fp = lp2; XX lp2->l_fp = lp1->l_fp; XX lp1->l_fp->l_bp = lp2; XX lp2->l_bp = lp1->l_bp; XX free((char *) lp1); XX } XX else { /* Easy: in place */ XX lp2 = lp1; /* Pretend new line */ XX lp2->l_used += n; XX cp2 = &lp1->l_text[lp1->l_used]; XX cp1 = cp2-n; XX while (cp1 != &lp1->l_text[doto]) *--cp2 = *--cp1; XX } XX for (i=0; il_text[doto+i] = c; XX wp = wheadp; /* Update windows */ XX while (wp != NULL) { XX if (wp->w_linep == lp1) wp->w_linep = lp2; XX if (wp->w_dotp == lp1) { XX wp->w_dotp = lp2; XX if (wp==curwp || wp->w_doto>doto) wp->w_doto += n; XX } XX if (wp->w_markp == lp1) { XX wp->w_markp = lp2; XX if (wp->w_marko > doto) wp->w_marko += n; XX } XX wp = wp->w_wndp; XX } XX return (TRUE); XX } XX XX/* XX * Insert a newline into the buffer at the current location of dot in the XX * current window. The funny ass-backwards way it does things is not a botch; XX * it just makes the last line in the file not a special case. Return TRUE if XX * everything works out and FALSE on error (memory allocation failure). The XX * update of dot and mark is a bit easier then in the above case, because the XX * split forces more updating. XX */ XXlnewline() XX { XX register char *cp1; XX register char *cp2; XX register LINE *lp1; XX register LINE *lp2; XX register int doto; XX register WINDOW *wp; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX lchange(WFHARD); XX lp1 = curwp->w_dotp; /* Get the address and */ XX doto = curwp->w_doto; /* offset of "." */ XX if ((lp2=lalloc(doto)) == NULL) /* New first half line */ XX return (FALSE); XX cp1 = &lp1->l_text[0]; /* Shuffle text around */ XX cp2 = &lp2->l_text[0]; XX while (cp1 != &lp1->l_text[doto]) *cp2++ = *cp1++; XX cp2 = &lp1->l_text[0]; XX while (cp1 != &lp1->l_text[lp1->l_used]) *cp2++ = *cp1++; XX lp1->l_used -= doto; XX lp2->l_bp = lp1->l_bp; XX lp1->l_bp = lp2; XX lp2->l_bp->l_fp = lp2; XX lp2->l_fp = lp1; XX wp = wheadp; /* Windows */ XX while (wp != NULL) { XX if (wp->w_linep == lp1) wp->w_linep = lp2; XX if (wp->w_dotp == lp1) { XX if (wp->w_doto < doto) wp->w_dotp = lp2; XX else XX wp->w_doto -= doto; XX } XX if (wp->w_markp == lp1) { XX if (wp->w_marko < doto) wp->w_markp = lp2; XX else XX wp->w_marko -= doto; XX } XX wp = wp->w_wndp; XX } XX return (TRUE); XX } XX XX/* XX * This function deletes "n" bytes, starting at dot. It understands how do deal XX * with end of lines, etc. It returns TRUE if all of the characters were XX * deleted, and FALSE if they were not (because dot ran into the end of the XX * buffer. The "kflag" is TRUE if the text should be put in the kill buffer. XX */ XXldelete(n, kflag) XX { XX register char *cp1; XX register char *cp2; XX register LINE *dotp; XX register int doto; XX register int chunk; XX register WINDOW *wp; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX while (n != 0) { XX dotp = curwp->w_dotp; XX doto = curwp->w_doto; XX if (dotp == curbp->b_linep) /* Hit end of buffer. */ XX return (FALSE); XX chunk = dotp->l_used-doto; /* Size of chunk. */ XX if (chunk > n) chunk = n; XX if (chunk == 0) { /* End of line, merge. */ XX lchange(WFHARD); XX if (ldelnewline() == FALSE || (kflag!=FALSE && kinsert('\n')==FALSE)) XX return (FALSE); XX --n; XX continue; XX } XX lchange(WFEDIT); XX cp1 = &dotp->l_text[doto]; /* Scrunch text. */ XX cp2 = cp1 + chunk; XX if (kflag != FALSE) { /* Kill? */ XX while (cp1 != cp2) { XX if (kinsert(*cp1) == FALSE) return (FALSE); XX ++cp1; XX } XX cp1 = &dotp->l_text[doto]; XX } XX while (cp2 != &dotp->l_text[dotp->l_used]) *cp1++ = *cp2++; XX dotp->l_used -= chunk; XX wp = wheadp; /* Fix windows */ XX while (wp != NULL) { XX if (wp->w_dotp==dotp && wp->w_doto>=doto) { XX wp->w_doto -= chunk; XX if (wp->w_doto < doto) wp->w_doto = doto; XX } XX if (wp->w_markp==dotp && wp->w_marko>=doto) { XX wp->w_marko -= chunk; XX if (wp->w_marko < doto) wp->w_marko = doto; XX } XX wp = wp->w_wndp; XX } XX n -= chunk; XX } XX return (TRUE); XX } XX XX/* XX * Delete a newline. Join the current line with the next line. If the next line XX * is the magic header line always return TRUE; merging the last line with the XX * header line can be thought of as always being a successful operation, even XX * if nothing is done, and this makes the kill buffer work "right". Easy cases XX * can be done by shuffling data around. Hard cases require that lines be moved XX * about in memory. Return FALSE on error and TRUE if all looks ok. Called by XX * "ldelete" only. XX */ XXldelnewline() XX { XX register char *cp1; XX register char *cp2; XX register LINE *lp1; XX register LINE *lp2; XX register LINE *lp3; XX register WINDOW *wp; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX lp1 = curwp->w_dotp; XX lp2 = lp1->l_fp; XX if (lp2 == curbp->b_linep) { /* At the buffer end. */ XX if (lp1->l_used == 0) /* Blank line. */ XX lfree(lp1); XX return (TRUE); XX } XX if (lp2->l_used <= lp1->l_size-lp1->l_used) { XX cp1 = &lp1->l_text[lp1->l_used]; XX cp2 = &lp2->l_text[0]; XX while (cp2 != &lp2->l_text[lp2->l_used]) *cp1++ = *cp2++; XX wp = wheadp; XX while (wp != NULL) { XX if (wp->w_linep == lp2) wp->w_linep = lp1; XX if (wp->w_dotp == lp2) { XX wp->w_dotp = lp1; XX wp->w_doto += lp1->l_used; XX } XX if (wp->w_markp == lp2) { XX wp->w_markp = lp1; XX wp->w_marko += lp1->l_used; XX } XX wp = wp->w_wndp; XX } XX lp1->l_used += lp2->l_used; XX lp1->l_fp = lp2->l_fp; XX lp2->l_fp->l_bp = lp1; XX free((char *) lp2); XX return (TRUE); XX } XX if ((lp3=lalloc(lp1->l_used+lp2->l_used)) == NULL) return (FALSE); XX cp1 = &lp1->l_text[0]; XX cp2 = &lp3->l_text[0]; XX while (cp1 != &lp1->l_text[lp1->l_used]) *cp2++ = *cp1++; XX cp1 = &lp2->l_text[0]; XX while (cp1 != &lp2->l_text[lp2->l_used]) *cp2++ = *cp1++; XX lp1->l_bp->l_fp = lp3; XX lp3->l_fp = lp2->l_fp; XX lp2->l_fp->l_bp = lp3; XX lp3->l_bp = lp1->l_bp; XX wp = wheadp; XX while (wp != NULL) { XX if (wp->w_linep==lp1 || wp->w_linep==lp2) wp->w_linep = lp3; XX if (wp->w_dotp == lp1) wp->w_dotp = lp3; XX else if (wp->w_dotp == lp2) { XX wp->w_dotp = lp3; XX wp->w_doto += lp1->l_used; XX } XX if (wp->w_markp == lp1) wp->w_markp = lp3; XX else if (wp->w_markp == lp2) { XX wp->w_markp = lp3; XX wp->w_marko += lp1->l_used; XX } XX wp = wp->w_wndp; XX } XX free((char *) lp1); XX free((char *) lp2); XX return (TRUE); XX } XX XX/* XX * Delete all of the text saved in the kill buffer. Called by commands when a XX * new kill context is being created. The kill buffer array is released, just XX * in case the buffer has grown to immense size. No errors. XX */ XXkdelete() XX { XX if (kbufp != NULL) { XX free((char *) kbufp); XX kbufp = NULL; XX kused = 0; XX ksize = 0; XX } XX } XX XX/* XX * Insert a character to the kill buffer, enlarging the buffer if there isn't XX * any room. Always grow the buffer in chunks, on the assumption that if you XX * put something in the kill buffer you are going to put more stuff there too XX * later. Return TRUE if all is well, and FALSE on errors. XX */ XX XXkinsert(c) XX { XX register char *nbufp; XX char *realloc(); XX char *malloc(); XX XX if (kused == ksize) { XX if (ksize == 0) /* first time through? */ XX nbufp = malloc(KBLOCK); /* alloc the first block */ XX else /* or re allocate a bigger block */ XX nbufp = realloc(kbufp, ksize+KBLOCK); XX XX if (nbufp == NULL) /* abort if it fails */ XX return(FALSE); XX kbufp = nbufp; /* point our global at it */ XX ksize += KBLOCK; /* and adjust the size */ XX } XX kbufp[kused++] = c; XX return (TRUE); XX } XX XX/* XX * This function gets characters from the kill buffer. If the character index XX * "n" is off the end, it returns "-1". This lets the caller just scan along XX * until it gets a "-1" back. XX */ XXkremove(n) XX { XX if (n >= kused) return (-1); XX else XX return (kbufp[n] & 0xFF); XX } XX XX XX#if LATTICE | AZTEC XX/* we need to have the following functions to manage memory that XXdon't exist under Lattice */ XX XX XXchar *realloc(ptr, size) /* re-allocate a memory chunk to a XXdifferent size, copying what can XXby copied */ XX XXchar *ptr; /* pointer to the original block */ XXunsigned size; /* # of bytes needed in new block */ XX XX { XX char *newptr; /* pointer to new block */ XX unsigned csize; /* size of area to copy from old buffer to new */ XX char *malloc(); XX XX newptr = malloc(size); /* get the new block */ XX if (newptr == NULL) /* if malloc fails....*/ XX return(NULL); XX XX csize = ksize; /******THIS IS A CHEAT SINCE WE CAN NOT GET XX AT THE SIZE OF THE MALLOCED BLOCK!! XX DO NOT USE THIS FUNCTION GENERICALLY!!!*/ XX if (csize > size) /* we need to copy some stuff from */ XX csize = size; /* the old buffer to the new */ XX XX movmem(ptr, newptr, csize); /* copy the availible bytes */ XX free(ptr); /* dump the old buffer */ XX return(newptr); /* and return the new */ XX } XX#endif XX XX SHAR_EOF if test 14691 -ne "`wc -c line.c`" then echo shar: error transmitting line.c '(should have been 14691 characters)' fi echo shar: extracting lisp.c sed 's/^XX//' << \SHAR_EOF > lisp.c XX/************************************************************************** XX * XX * Micro LISP functions for micro EMACS XX * XX * V1.0 DBW 870204 Dave Wecker XX * XX *************************************************************************/ XX XX XX#include XX#include XX XX#include "estruct.h" XX#include "edef.h" XX#include "epath.h" XX XXextern short doflashing; XXextern char *malloc(); XX XXjmp_buf env[10]; /* environments for setjmp/longjmp */ XXstatic envnum = -1; XX#define PROGN_RETURN 1 XX#define PROGN_GO 2 XX XX/* node definitions */ XX#define NIL 0 XX#define CONS 1 XX#define INTEGER 2 XX#define STRING 3 XX#define SUBR 4 XX#define SYMBOL 5 XX XX#if AMIGA XX#define MAXNODE 500 XX#else XX#define MAXNODE 5000 XX#endif XX XXtypedef struct node { XX char type; XX struct node *car; XX struct node *cdr; XX } NODE; XX XXtypedef int INTRTN(); XX XXextern NODE *fncmatch(); /* match a function name with an address */ XX XX#if AMIGA XXstatic NODE TNODE = { INTEGER, 1L, 0L }; XXstatic NODE FNODE = { INTEGER, 0L, 0L }; XX#else XXstatic NODE TNODE = { INTEGER, (NODE *)1L, (NODE *)0L }; XXstatic NODE FNODE = { INTEGER, (NODE *)0L, (NODE *)0L }; XX#endif XX XXstatic NODE *syms[26]; /* symbols A-Z */ XXstatic NODE *retval; /* global return value for procedures */ XXstatic NODE *gblpar[20]; /* global parameters for emacs routines */ XXstatic NODE **nodes = NULL; /* nodes available to the system */ XXstatic int maxnode = -1; /* current maximum node index */ XXstatic int gblidx = 0; /* current parameter index */ XXstatic int gblnum = 0; /* maximum parameter count */ XXstatic int pushback = -1; XXstatic LINE *c_endp; /* compile end line pointer */ XXstatic LINE *c_dotp; /* current compile line */ XXstatic short c_doto; /* current compile offset */ XXstatic INTRTN *lstfnc = NULL; /* last function executed */ XX XX/************************** support routines ***************************/ XX XXDEBUG_dump(n) XXNODE *n; XX { XX long l; XX char c; XX XX if (n == NULL) { XX printf("NIL"); XX fflush(stderr); XX return; XX } XX switch (n->type) { XX case INTEGER: XX printf("%ld ",(long)n->car); XX break; XX XX case STRING: XX printf("\042%s\042 ",(char *)n->car); XX break; XX XX case SYMBOL: XX l = (long)n->car + 97L; XX c = l; XX printf("%c ",c); XX break; XX XX case SUBR: XX printf("#%lx ",(long)n->car); XX break; XX XX case CONS: XX printf("("); XX DEBUG_dump(n->car); XX printf(". "); XX DEBUG_dump(n->cdr); XX printf(")"); XX break; XX } XX fflush(stderr); XX } XX XXNODE * XXnewtnode(typ,len) XXint typ,len; XX { XX if (nodes == NULL) nodes = (NODE **)malloc(MAXNODE * sizeof(NODE *)); XX if (++maxnode >= MAXNODE) { XX mlwrite("!!!!! RAN OUT OF LISP NODES !!!!!"); XX maxnode = MAXNODE-1; XX } XX nodes[maxnode] = (NODE *)malloc(sizeof(NODE)); XX nodes[maxnode]->type = typ; XX if (typ == STRING) nodes[maxnode]->car = (NODE *)malloc(len+1); XX else nodes[maxnode]->car = NULL; XX nodes[maxnode]->cdr = NULL; XX return(nodes[maxnode]); XX } XX XXrettnode() XX { XX int i; XX XX for (i = 0; i <= maxnode; i++) { XX if (nodes[i] != NULL) { XX if (nodes[i]->type == STRING && nodes[i]->car != NULL) XX free((char *)nodes[i]->car); XX free((char *)nodes[i]); XX nodes[i] = NULL; XX } XX } XX if (nodes != NULL) free((char *)nodes); XX nodes = NULL; XX maxnode = -1; XX for (i = 0; i < 26; i++) syms[i] = NULL; XX } XX XXNODE * XXnewnode(typ,len) XXint typ,len; XX { XX NODE *n; XX XX n = (NODE *)malloc(sizeof(NODE)); XX n->type = typ; XX if (typ == STRING) n->car = (NODE *)malloc(len+1); XX else n->car = NULL; XX n->cdr = NULL; XX return(n); XX } XX XXretnode(n) XXNODE *n; XX { XX NODE *nnew; XX XX while (n != NULL) { XX switch (n->type) { XX case CONS: XX retnode(n->car); XX nnew = n->cdr; XX free((char *)n); XX n = nnew; XX break; XX XX case STRING: XX if (n->car != NULL) free((char *)n->car); XX XX default: XX free((char *)n); XX return; XX } XX } XX } XX XX/************************ compilation of LISP code **********************/ XXchar XXlisp_readchr(instr) XXint instr; XX { XX char c; XX XX if (pushback != -1) { XX c = (char)pushback; XX if (pushback != 0) pushback = -1; XX return(c); XX } XX XX /* compress out comments */ XX c = ';'; XX while (c == ';') { XX /* do we need to terminate this line */ XX if (c_doto == llength(c_dotp)) { XX c_doto++; XX if (instr) c = '\n'; XX else c = ' '; XX return(c); XX } XX /* are we past the end of line */ XX while (c_doto >= llength(c_dotp)) { XX c_dotp = c_dotp->l_fp; XX c_doto = 0; XX if (c_dotp == c_endp) { XX pushback = 0; XX return('\000'); XX } XX } XX c = lgetc(c_dotp,c_doto++); XX if (instr) return(c); XX XX /* all white becomes a space */ XX if (c == '\n' || c == '\r' || c == '\t' || c == '\014') c = ' '; XX XX /* skip comments */ XX if (c == ';') c_doto = llength(c_dotp) + 1; XX else return(c); XX } XX } XX XXNODE * XXlisp_sexpr() XX { XX char c,d,str[256]; XX long sign,intval; XX int i; XX NODE *val,*cur,*nxt; XX XX c = ' '; XX while (c == ' ') c = lisp_readchr(0); XX XX if (c == '\000' || c == ')') return(NULL); XX XX /* see if we have a list to put together */ XX if (c == '(') { XX val = cur = NULL; XX while ((nxt = lisp_sexpr()) != NULL) { XX if (cur == NULL) { XX cur = newnode(CONS,0); XX val = cur; XX } XX else { XX cur->cdr = newnode(CONS,0); XX cur = cur->cdr; XX } XX cur->car = nxt; XX } XX return(val); XX } XX XX /* see if we have an integer to gather */ XX if ((c >= '0' && c <= '9') || c == '-') { XX sign = 1L; XX intval = 0L; XX if (c == '-') { XX c = lisp_readchr(0); XX if (c == '\000') return(NULL); XX XX /* no, it's really the subtraction operator */ XX if (c == ' ') { XX str[0] = '-'; XX str[1] = '\000'; XX val = newnode(SUBR,0); XX val->car = fncmatch(str); XX if (val->car == NULL) { XX mlwrite("Unknown function: %s",str); XX longjmp(env[0],1); XX } XX return(val); XX } XX sign = -1L; XX } XX while (c >= '0' && c <= '9') { XX intval = (10L * intval) + (long)(c - '0'); XX c = lisp_readchr(0); XX if (c == '\000') return(NULL); XX } XX if (c != ' ') pushback = c; XX intval *= sign; XX val = newnode(INTEGER,0); XX val->car = (NODE *)intval; XX return(val); XX } XX XX /* maybe it's a string */ XX if (c == '"') { XX i = 0; XX for (c = lisp_readchr(1); c != '"'; c = lisp_readchr(1)) { XX if (c == '\000') return(NULL); XX if (c != '\\') str[i++] = c; XX else { XX c = lisp_readchr(1); XX if (c == '\000') return(NULL); XX switch(c) { XX case 'n': c = '\n'; break; XX case 'r': c = '\r'; break; XX case 't': c = '\t'; break; XX case 'e': c = '\033'; break; XX default: XX if (c >= '0' && c <= '7') { XX c = (c - '0') * 64; XX d = lisp_readchr(1); XX if (d == '\000') return(NULL); XX if (d < '0' || d > '7') { XX c /= 64; XX pushback = d; XX break; XX } XX c += (d - '0') * 8; XX d = lisp_readchr(1); XX if (d == '\000') return(NULL); XX if (d < '0' || d > '7') { XX c /= 8; XX pushback = d; XX break; XX } XX c += d - '0'; XX } XX } XX str[i++] = c; XX } XX if (i > 255) i = 255; XX } XX str[i] = '\000'; XX val = newnode(STRING,strlen(str)); XX strcpy((char *)val->car,(char *)str); XX return(val); XX } XX XX /* possibly a symbol */ XX str[0] = c; XX c = lisp_readchr(0); XX if (c == '\000') return(NULL); XX if (str[0] >= 'a' && str[0] <= 'z' && (c == ' ' || c == ')')) { XX val = newnode(SYMBOL,0); XX val->car = (NODE *)(str[0] - 'a'); XX if (c != ' ') pushback = c; XX return(val); XX } XX XX /* must be a subr */ XX i = 1; XX while (c != ' ' && c != ')') { XX str[i++] = c; XX c = lisp_readchr(0); XX if (c == '\000') return(NULL); XX if (i > 255) i = 255; XX } XX if (c != ' ') pushback = c; XX str[i] = '\000'; XX val = newnode(SUBR,0); XX val->car = fncmatch(str); XX if (val->car == NULL) { XX mlwrite("Unknown function: %s",str); XX longjmp(env[0],1); XX } XX return(val); XX } XX XXNODE * XXcompilebuf(bp) XXBUFFER *bp; XX { XX int i; XX WINDOW *wp; XX NODE *head,*val,*cur,*prv; XX XX mlwrite("Compiling buffer"); XX XX /* Now walk through the buffer (compiling s-expers) */ XX c_endp = bp->b_linep; XX c_dotp = bp->b_linep->l_fp; XX c_doto = 0; XX pushback = -1; XX head = NULL; XX while ((val=lisp_sexpr()) != NULL) { XX cur = newnode(CONS,0); XX cur->car = val; XX cur->cdr = NULL; XX if (head == NULL) head = cur; XX else prv->cdr = cur; XX prv = cur; XX } XX if (head == NULL) { XX mlwrite("Compile of buffer failed!"); XX return(NULL); XX } XX else mlerase(); XX return(head); XX } XX XX/************************ execution of compiled code *********************/ XX XX/* dobuf: execute the contents of the buffer pointed to by the passed bp. */ XX XXdobuf(f,n,bp) XXint f,n; XXBUFFER *bp; XX { XX NODE *head; XX int oldcle,status; XX XX /* first make sure that the buffer is compiled */ XX if (setjmp(env[0])) return(FALSE); XX head = compilebuf(bp); XX XX /* now execute the compiled code (as a progn) */ XX if (f == FALSE) n = 1; XX while (n-- > 0) { XX envnum = -1; XX status = l_progn(head); XX rettnode(); XX if (status != TRUE) break; XX } XX retnode(head); XX return(status); XX } XX XXl_progn(head) XXNODE *head; XX { XX NODE *curr,*scr; XX int jmp,oldcle,curenv; XX XX curr = head; XX oldcle = clexec; XX curenv = ++envnum; XX if (envnum > 9) { XX mlwrite("Too many PROGN nestings"); XX return(FALSE); XX } XX XX /* set up for non-local goto's */ XX if ((jmp = setjmp(env[curenv])) != 0) { XX clexec = oldcle; XX if (jmp == PROGN_RETURN) { XX envnum--; XX return(TRUE); XX } XX curr = head; XX while (curr != NULL) { XX if (curr->type != CONS) { XX envnum--; XX return(FALSE); XX } XX if (curr->car->type == INTEGER && retval->type == INTEGER && XX (long)(curr->car->car) == (long)(retval->car)) break; XX if (curr->car->type == STRING && retval->type == STRING && XX strcmp((char *)(curr->car->car),(char *)(retval->car)) XX == 0) break; XX curr = curr->cdr; XX } XX XX /* try finding the label at a higher level */ XX if (curr == NULL) longjmp(env[--envnum],PROGN_GO); XX } XX XX /* actual progn loop */ XX while (curr != NULL) { XX if (l_eval(curr->car) == FALSE) { XX envnum--; XX return(FALSE); XX } XX curr = curr->cdr; XX } XX envnum--; XX return(TRUE); XX } XX XXl_setq(expr) XXNODE *expr; XX { XX long i; XX char str[256],istr[20]; XX NODE *sym; XX XX if (expr == NULL || expr->type != CONS) return(FALSE); XX sym = expr->car; XX expr = expr->cdr; XX if (sym == NULL || sym->type != SYMBOL) return(FALSE); XX i = (long)sym->car; XX str[0] = '\000'; XX XX /* now concatenate parameters */ XX while (expr != NULL && expr->type == CONS) { XX if (l_eval(expr->car) == FALSE) return(FALSE); XX if (retval->type == STRING) strcat(str,(char *)retval->car); XX else if (retval->type == INTEGER) { XX sprintf(istr,"%ld",(long)retval->car); XX strcat(str,istr); XX } XX expr = expr->cdr; XX } XX retval = newtnode(STRING,strlen(str)); XX strcpy((char *)retval->car,str); XX XX syms[i] = retval; XX return(TRUE); XX } XX XXl_if(expr) XXNODE *expr; XX { XX NODE *thn,*els; XX int tst,status; XX XX if (expr == NULL || expr->type != CONS) return(FALSE); XX tst = 0; XX if (l_eval(expr->car) != FALSE) XX if ((retval->type == INTEGER && (long)retval->car != 0L) || XX (retval->type == STRING && *((char *)retval->car) != '\000')) XX tst = 1; XX XX thn = expr->cdr; XX if (thn != NULL) els = thn->cdr; XX else els = NULL; XX XX if (tst) status = l_eval(thn->car); XX else if (els != NULL) status = l_eval(els->car); XX else { XX retval = &TNODE; XX status = TRUE; XX } XX return(status); XX } XX XXl_eval(expr) XXNODE *expr; XX { XX long i; XX int p,q,status,oldcle,f,n; XX NODE *func,*par[20]; XX INTRTN *fnc; XX XX if (expr == NULL) return(FALSE); XX switch (expr->type) { XX case INTEGER: XX case STRING: XX case SUBR: XX retval = expr; XX return(TRUE); XX XX case SYMBOL: XX i = (long)expr->car; XX retval = syms[i]; XX return(TRUE); XX XX case CONS: XX if (l_eval(expr->car) == FALSE) return(FALSE); XX func = retval; XX if (func != NULL && func->type == INTEGER) { XX f = TRUE; XX i = (long)func->car; XX n = i; XX expr = expr->cdr; XX if (l_eval(expr->car) == FALSE) return(FALSE); XX func = retval; XX } XX else { XX f = FALSE; XX n = 1; XX } XX if (func == NULL || func->type != SUBR) return(FALSE); XX fnc = (INTRTN *)(func->car); XX expr = expr->cdr; XX XX /* take care of fsubr's in-line */ XX if (*fnc == l_progn || *fnc == l_setq || *fnc == l_if) { XX status = TRUE; XX while (n-- > 0) { XX gblidx = 0; XX status = (*fnc)(expr); XX if (status != TRUE) return(status); XX } XX return(status); XX } XX XX p = 0; XX while (expr != NULL) { XX if (l_eval(expr->car) == FALSE) return(FALSE); XX par[p++] = retval; XX expr = expr->cdr; XX } XX for (q = 0; q < p; q++) gblpar[q] = par[q]; XX gblidx = 0; XX gblnum = p; XX lstfnc = fnc; XX oldcle = clexec; XX clexec = TRUE; XX retval = NULL; XX status = (*fnc)(f,n); XX clexec = oldcle; XX if (retval == NULL) { XX if (status) retval = &TNODE; XX else retval = &FNODE; XX status = TRUE; XX } XX return(status); XX } XX } XX XXnxtarg(tok) XXchar *tok; XX { XX NODE *cur; XX NBIND *ffp; XX XX if (gblidx >= gblnum) { XX ffp = &names[0]; XX while (ffp->n_func != NULL && ffp->n_func != lstfnc) ++ffp; XX if (ffp->n_func != NULL) mlwrite("Missing param for: %s",ffp->n_name); XX else mlwrite("Missing paramater for function"); XX longjmp(env[0],1); XX } XX else cur = gblpar[gblidx++]; XX if (cur == NULL) { XX *tok = '\000'; XX return(TRUE); XX } XX if (cur->type == STRING) { XX strcpy(tok,(char *)cur->car); XX return(TRUE); XX } XX if (cur->type == INTEGER) { XX sprintf(tok,"%ld",(long)cur->car); XX return(TRUE); XX } XX *tok = '\000'; XX return(TRUE); XX } XX XXl_go(f,n) XXint f,n; XX { XX if (gblpar[0] == NULL) return(FALSE); XX retval = gblpar[0]; XX longjmp(env[envnum],PROGN_GO); XX } XX XXl_return(f,n) XXint f,n; XX { XX retval = gblpar[0]; XX longjmp(env[envnum],PROGN_RETURN); XX } XX XXl_yank_str(f,n) XXint f,n; XX { XX char str[256]; XX int i,c; XX XX for (i=0; i < 255 && (c=kremove(i)) >= 0; i++) str[i] = (char)c; XX str[i] = '\000'; XX retval = newtnode(STRING,i); XX strcpy((char *)retval->car,str); XX return(TRUE); XX } XX XXl_ask(f,n) XXint f,n; XX { XX char c,str[256],inp[256]; XX int oldcle; XX XX gblidx = 0; XX if (gblidx >= gblnum) strcpy(str,"Ask> "); XX else nxtarg(str); XX if (gblidx >= gblnum) inp[0] = '\000'; XX else nxtarg(inp); XX while (inp[0] != '\000') { XX strcat(str,inp); XX if (gblidx >= gblnum) inp[0] = '\000'; XX else nxtarg(inp); XX } XX oldcle = clexec; XX clexec = FALSE; XX update(); XX if (batchmode) { XX printf(str); XX if (gets(inp) == NULL) inp[0] = '\000'; XX } XX else mlreply(str,inp,255); XX clexec = oldcle; XX retval = newtnode(STRING,strlen(inp)); XX strcpy((char *)retval->car,inp); XX return(TRUE); XX } XX XXlong XXmake_num(n) XXNODE *n; XX { XX long i; XX XX if (n == NULL) return(0L); XX if (n->type == INTEGER) return((long)n->car); XX if (n->type == STRING) { XX if (sscanf((char *)n->car," %ld",&i) != 1) return(0L); XX return(i); XX } XX return(0L); XX } XX XXmath_compute(op) XXchar op; XX { XX long p1,p2; XX XX p1 = make_num(gblpar[0]); XX p2 = make_num(gblpar[1]); XX switch(op) { XX case '=': retval = (p1==p2) ? &TNODE : &FNODE; return(TRUE); XX case '#': retval = (p1!=p2) ? &TNODE : &FNODE; return(TRUE); XX case '>': retval = (p1>p2) ? &TNODE : &FNODE; return(TRUE); XX case ']': retval = (p1>=p2) ? &TNODE : &FNODE; return(TRUE); XX case '<': retval = (p1car = (NODE *)(p1 + p2); return(TRUE); XX case '-': retval->car = (NODE *)(p1 - p2); return(TRUE); XX case '*': retval->car = (NODE *)(p1 * p2); return(TRUE); XX case '/': retval->car = (NODE *)(p1 / ((p2!=0)?p2:1L)); return(TRUE); XX case '%': retval->car = (NODE *)(p1 % p2); return(TRUE); XX case '&': retval->car = (NODE *)(p1 & p2); return(TRUE); XX case '|': retval->car = (NODE *)(p1 | p2); return(TRUE); XX } XX return(FALSE); XX } XX XXl_add(f,n) { return(math_compute('+')); } XXl_sub(f,n) { return(math_compute('-')); } XXl_mul(f,n) { return(math_compute('*')); } XXl_div(f,n) { return(math_compute('/')); } XXl_mod(f,n) { return(math_compute('%')); } XXl_bitand(f,n) { return(math_compute('&')); } XXl_bitor(f,n) { return(math_compute('|')); } XXl_eql(f,n) { return(math_compute('=')); } XXl_neq(f,n) { return(math_compute('#')); } XXl_gt(f,n) { return(math_compute('>')); } XXl_ge(f,n) { return(math_compute(']')); } XXl_lt(f,n) { return(math_compute('<')); } XXl_le(f,n) { return(math_compute('[')); } XXl_not(f,n) { return(math_compute('n')); } XXl_and(f,n) { return(math_compute('a')); } XXl_or(f,n) { return(math_compute('o')); } XX XXl_eq(f,n) XXint f,n; XX { XX retval = &FNODE; XX if (gblpar[0] == NULL && gblpar[1] == NULL) retval = &TNODE; XX else if (gblpar[0] != NULL && gblpar[1] != NULL && XX gblpar[0]->type == gblpar[1]->type) { XX if (gblpar[0]->type == INTEGER && XX (long)gblpar[0]->car == (long)gblpar[1]->car) retval = &TNODE; XX else if (gblpar[0]->type == STRING && XX strcmp((char *)gblpar[0]->car,(char *)gblpar[1]->car) == 0) XX retval = &TNODE; XX } XX return(TRUE); XX } XX XXl_curchr(f,n) XXint f,n; XX { XX long i; XX XX if (curwp->w_doto >= llength(curwp->w_dotp)) i = (long)'\n'; XX else i = (long)lgetc(curwp->w_dotp,curwp->w_doto); XX retval = newtnode(INTEGER,0); XX retval->car = (NODE *)i; XX return(TRUE); XX } XX XXl_curlin(f,n) XXint f,n; XX { XX long i; XX LINE *clp; XX XX clp = lforw(curbp->b_linep); XX i = 0L; XX while (clp != curwp->w_dotp) { XX clp = lforw(clp); XX i++; XX } XX retval = newtnode(INTEGER,0); XX retval->car = (NODE *)i; XX return(TRUE); XX } XX XXl_curcol(f,n) XXint f,n; XX { XX long i; XX XX i = (long)getccol(FALSE); XX retval = newtnode(INTEGER,0); XX retval->car = (NODE *)i; XX return(TRUE); XX } XX XXl_curbuf(f,n) XXint f,n; XX { XX XX retval = newtnode(STRING,strlen(curbp->b_bname)); XX strcpy((char *)retval->car,curbp->b_bname); XX return(TRUE); XX } XX XXl_princ(f,n) XXint f,n; XX { XX char str[256]; XX int i; XX XX if (f == FALSE) n = 1; XX while (n-- > 0) { XX gblidx = 0; XX if (gblidx >= gblnum) str[0] = '\000'; XX else nxtarg(str); XX while (str[0] != '\000') { XX for (i=0; str[i] != '\000'; i++) { XX if (str[i] == '\n') lnewline(FALSE,1); XX else linsert(1,str[i]); XX } XX if (gblidx >= gblnum) str[0] = '\000'; XX else nxtarg(str); XX } XX } XX return(TRUE); XX } XX XX XX/* execute a command line to be typed in */ XXexeccmd(f,n) XXint f,n; XX { XX mlwrite("Not implemented yet"); XX } XX XX/* execute the contents of a named buffer */ XXexecbuf(f,n) XXint f,n; XX { XX register BUFFER *bp; /* ptr to buffer to execute */ XX register int status; /* status return */ XX char bufn[NBUFN]; /* name of buffer to execute */ XX XX /* find out what buffer the user wants to execute */ XX if ((status = mlreply("Execute buffer: ", bufn, NBUFN)) != TRUE) return(status); XX XX /* find the pointer to that buffer */ XX if ((bp=bfind(bufn, TRUE, 0)) == NULL) return(FALSE); XX XX /* and now execute it as asked */ XX if ((status = dobuf(f,n,bp)) != TRUE) return(status); XX return(TRUE); XX } XX XXexecfile(f, n) /* execute a series of commands in a file */ XXint f, n; /* default flag and numeric arg to pass on to file */ XX { XX register int status; /* return status of name query */ XX char *fname[NSTRING]; /* name of file to execute */ XX XX if ((status = mlreply("File to execute: ", fname, NSTRING -1)) != TRUE) return(status); XX XX /* otherwise, execute it */ XX if ((status=dofile(f,n,fname)) != TRUE) return(status); XX XX return(TRUE); XX } XX XX/* dofile: yank a file into a buffer and execute it XX if there are no errors, delete the buffer on exit */ XX XXdofile(f,n,fname) XXint f,n; XXchar *fname; /* file name to execute */ XX { XX register BUFFER *bp; /* buffer to place file to exeute */ XX register BUFFER *cb; /* temp to hold current buf while we read */ XX register int status; /* results of various calls */ XX char bname[NBUFN]; /* name of buffer */ XX XX makename(bname, fname); /* derive the name of the buffer */ XX if ((bp = bfind(bname, TRUE, 0)) == NULL) /* get the needed buffer */ XX return(FALSE); XX XX bp->b_mode = MDVIEW; /* mark the buffer as read only */ XX cb = curbp; /* save the old buffer */ XX curbp = bp; /* make this one current */ XX /* and try to read in the file to execute */ XX if ((status = readin(fname, FALSE)) != TRUE) { XX curbp = cb; /* restore the current buffer */ XX return(status); XX } XX XX /* go execute it! */ XX curbp = cb; /* restore the current buffer */ XX if ((status = dobuf(f,n,bp)) != TRUE) return(status); XX XX /* if not displayed, remove the now unneeded buffer and exit */ XX if (bp->b_nwnd == 0) zotbuf(bp); XX return(TRUE); XX } XX XX/* execute the startup file */ XX XXstartup() XX { XX register int status; /* status of I/O operations */ XX register int i; /* index into help file names */ XX char fname[NSTRING]; /* buffer to construct file name in */ XX XX char *homedir; /* pointer to your home directory */ XX char *getenv(); XX XX#if ULTRIX | AMIGA XX /* are we on a slow terminal */ XX if (getenv("SLOWTERM") != NULL) slowterm = TRUE; XX XX /* get the HOME from the environment */ XX if ((homedir = getenv("HOME")) != NULL) { XX /* build the file name */ XX strcpy(fname, homedir); XX strcat(fname, "/"); XX strcat(fname, pathname[0]); XX XX /* and test it */ XX status = ffropen(fname); XX if (status == FIOSUC) { XX ffclose(); XX return(dofile(FALSE,1,fname)); XX } XX } XX#endif XX#if VMS XX /* are we on a slow terminal */ XX if (getenv("EMACSVAR_SLOWTERM") != NULL) slowterm = TRUE; XX XX /* get the HOME from the environment */ XX if ((homedir = getenv("SYS$LOGIN")) != NULL) { XX /* build the file name */ XX strcpy(fname, homedir); XX strcat(fname, pathname[0]); XX XX /* and test it */ XX status = ffropen(fname); XX if (status == FIOSUC) { XX ffclose(); XX return(dofile(FALSE,1,fname)); XX } XX } XX#endif XX XX /* search through the list of startup files */ XX for (i=2; i < NPNAMES; i++) { XX strcpy(fname, pathname[i]); XX strcat(fname, pathname[0]); XX status = ffropen(fname); XX if (status == FIOSUC) break; XX } XX XX /* if it isn't around, don't sweat it */ XX if (status == FIOFNF) return(TRUE); XX XX ffclose(); /* close the file to prepare for to read it in */ XX XX return(dofile(FALSE,1,fname)); XX } XX SHAR_EOF if test 22291 -ne "`wc -c lisp.c`" then echo shar: error transmitting lisp.c '(should have been 22291 characters)' fi echo shar: extracting lock.c sed 's/^XX//' << \SHAR_EOF > lock.c XX/* LOCK: File locking command routines for MicroEMACS XX */ XX XX#include XX#include "estruct.h" XX#include "edef.h" XX XX#if FILOCK XX#if ULTRIX XX XXchar *lname[NLOCKS]; /* names of all locked files */ XXint numlocks; /* # of current locks active */ XX XX/* lockchk: check a file for locking and add it to the list */ XX XXlockchk(fname) XX XXchar *fname; /* file to check for a lock */ XX XX { XX register int i; /* loop indexes */ XX register int status; /* return status */ XX char *undolock(); XX XX /* check to see if that file is already locked here */ XX if (numlocks > 0) for (i=0; i < numlocks; ++i) XX if (strcmp(fname, lname[i]) == 0) return(TRUE); XX XX /* if we have a full locking table, bitch and leave */ XX if (numlocks == NLOCKS) { XX mlwrite("LOCK ERROR: Lock table full"); XX return(ABORT); XX } XX XX /* next, try to lock it */ XX status = lock(fname); XX if (status == ABORT) /* file is locked, no override */ XX return(ABORT); XX if (status == FALSE) /* locked, overriden, dont add to table */ XX return(TRUE); XX XX /* we have now locked it, add it to our table */ XX lname[++numlocks - 1] = (char *)malloc(strlen(fname) + 1); XX if (lname[numlocks - 1] == NULL) { /* malloc failure */ XX undolock(fname); /* free the lock */ XX mlwrite("Cannot lock, out of memory"); XX --numlocks; XX return(ABORT); XX } XX XX /* everthing is cool, add it to the table */ XX strcpy(lname[numlocks-1], fname); XX return(TRUE); XX } XX XX/* lockrel: release all the file locks so others may edit */ XX XXlockrel() XX XX { XX register int i; /* loop index */ XX XX if (numlocks > 0) for (i=0; i < numlocks; ++i) { XX unlock(lname[i]); XX free(lname[i]); XX } XX numlocks = 0; XX } XX XX/* lock: Check and lock a file from access by others XXreturns TRUE = files was not locked and now is XXFALSE = file was locked and overridden XXABORT = file was locked, abort command XX */ XX XXlock(fname) XX XXchar *fname; /* file name to lock */ XX XX { XX register char *locker; /* lock error message */ XX register int status; /* return status */ XX char msg[NSTRING]; /* message string */ XX char *dolock(); XX XX /* attempt to lock the file */ XX locker = dolock(fname); XX if (locker == NULL) /* we win */ XX return(TRUE); XX XX /* file failed...abort */ XX if (strncmp(locker, "LOCK", 4) == 0) { XX mlwrite(locker); XX return(ABORT); XX } XX XX /* someone else has it....override? */ XX strcpy(msg, "File in use by "); XX strcat(msg, locker); XX strcat(msg, ", overide?"); XX status = mlyesno(msg); /* ask them */ XX if (status == TRUE) return(FALSE); XX else XX return(ABORT); XX } XX XX/* unlock: Unlock a file XXthis only warns the user if it fails XX */ XX XXunlock(fname) XX XXchar *fname; /* file to unlock */ XX XX { XX register char *locker; /* undolock return string */ XX char *undolock(); XX XX /* unclock and return */ XX locker = undolock(fname); XX if (locker == NULL) return(TRUE); XX XX /* report the error and come back */ XX mlwrite(locker); XX return(FALSE); XX } XX#endif XX#else XXlckhello() /* dummy function */ XX { XX } XX#endif XX SHAR_EOF if test 3010 -ne "`wc -c lock.c`" then echo shar: error transmitting lock.c '(should have been 3010 characters)' fi echo shar: extracting main.c sed 's/^XX//' << \SHAR_EOF > main.c XX/* XX* This program is in public domain; written by Dave G. Conroy. XX* This file contains the main driving routine, and some keyboard processing XX* code, for the MicroEMACS screen editor. XX* XX* REVISION HISTORY: XX* XX* 1.0 Steve Wilhite, 30-Nov-85 XX* 2.0 George Jones, 12-Dec-85 XX* 3.0 Daniel Lawrence, 29-Dec-85 XX* xxx Dave Wecker 29-June-86 XX*/ XX XX#include XX XX/* make global definitions not external */ XX XX#define maindef XX XX#include "estruct.h" XX#include "efunc.h" XX#include "edef.h" XX#include "ebind.h" XX XX#if VMS XX#include XX#define GOOD (SS$_NORMAL) XX#endif XX XX#ifndef GOOD XX#define GOOD 0 XX#endif XX XX#if ULTRIX XX#define IOCPARM_MASK 0x7f /* parameters must be < 128 bytes */ XX#define IOC_OUT 0x40000000 /* copy out parameters */ XX#define _IOR(x,y,t) (IOC_OUT|((sizeof(t)&IOCPARM_MASK)<<16)|('x'<<8)|y) XX#define FIONREAD _IOR(f, 127, int) /* get # bytes to read */ XX#endif XX XX#if AMIGA XXextern short int Enable_Abort; XX#endif XX XXshort doflashing = TRUE; XX XXmain(argc, argv) XXchar *argv[]; XX { XX register int c; XX register int f; XX int n; XX register int mflag; XX register BUFFER *bp; XX register int ffile; /* first file flag */ XX register int carg; /* current arg to scan */ XX int basec; /* c stripped of meta character */ XX int viewflag; /* are we starting in view mode? */ XX char bname[NBUFN]; /* buffer name of file to read */ XX char *bfile; /* batch file name */ XX int s; XX WINDOW *wp; XX XX /* initialize the editor and process the startup file */ XX XX#if AMIGA XX Enable_Abort = 0; XX#endif XX XX /* pre scan the command line for the batchmode switch */ XX for (carg = 1; carg < argc; ++carg) XX if (argv[carg][0] == '-' && (argv[carg][1]|' ') == 'b') { XX batchmode = TRUE; XX break; XX } XX XX strcpy(bname, "main"); /* default buffer name */ XX vtinit(); /* Displays. */ XX edinit(bname); /* Buffers, windows. */ XX startup(); /* execute .emacsrc if there */ XX viewflag = FALSE; XX ffile = TRUE; /* no file to edit yet */ XX update(); /* let the user know we are here */ XX XX /* scan through the command line and get the files to edit */ XX for (carg = 1; carg < argc; ++carg) { XX /* if its a switch, process it */ XX if (argv[carg][0] == '-') { XX switch (argv[carg][1]|' ') { XX case 'v': /* -v for View File */ XX viewflag = TRUE; XX break; XX XX case 'e': /* -e for Edit file */ XX viewflag = FALSE; XX break; XX XX case 'b': /* -b for batch mode */ XX if (++carg >= argc) exit(1); XX bfile = argv[carg]; XX break; XX XX default: /* unknown switch */ XX /* ignore this for now */ XX break; XX } XX } XX else { /* process a file name */ XX /* set up a buffer for this file */ XX makename(bname, argv[carg]); XX XX /* if this is the first file, read it in */ XX if (ffile) { XX bp = curbp; XX makename(bname, argv[carg]); XX strcpy(bp->b_bname, bname); XX strcpy(bp->b_fname, argv[carg]); XX readin(argv[carg], (viewflag==FALSE)); XX bp->b_dotp = bp->b_linep; XX bp->b_doto = 0; XX ffile = FALSE; XX } XX else { XX /* visit the file */ XX if ((wp = wpopup()) != NULL) { XX curwp = wp; XX curbp = wp->w_bufp; XX } XX if (getfile(argv[carg],FALSE)) { XX wp = wheadp; XX while (wp != NULL) { XX wp->w_flag |= WFMODE; XX wp = wp->w_wndp; XX } XX } XX bp = curbp; XX } XX XX /* set the view mode appropriatly */ XX if (viewflag) bp->b_mode |= MDVIEW; XX } XX } XX XX /* setup to process commands */ XX lastflag = 0; /* Fake last flags. */ XX XX /* if in batch mode... do the batch file and get out */ XX if (batchmode) { XX dofile(FALSE,1,bfile); XX quit(TRUE,1); XX } XX XX update(); XX XX while (TRUE) { /* do top level forever */ XX XX#if ULTRIX XX /* sit in a subprocess wait loop */ XX if (procbuf != NULL) readsubproc(); XX#endif XX /* do the real top level processing */ XX dotoplevel(); XX } XX } XX XXdotoplevel() { XX register int c,basec,f,mflag; XX int n; XX XXloop: XX update(); XX XX#if ULTRIX XX ioctl(0,FIONREAD,&n); XX if (n < 1 && procbuf != NULL) return; XX#endif XX XX c = getkey(); XX if (mpresf != FALSE) { XX mlerase(); XX update(); XX#if CLRMSG XX if (c == ' ') /* ITS EMACS does this */ XX goto loop; XX#endif XX } XX f = FALSE; XX n = 1; XX XX /* do META-# processing if needed */ XX XX basec = c & ~META; /* strip meta char off if there */ XX if ((c & META) && ((basec >= '0' && basec <= '9') || basec == '-')) { XX f = TRUE; /* there is a # arg */ XX n = 0; /* start with a zero default */ XX mflag = 1; /* current minus flag */ XX c = basec; /* strip the META */ XX while ((c >= '0' && c <= '9') || (c == '-')) { XX if (c == '-') { XX /* already hit a minus or digit? */ XX if ((mflag == -1) || (n != 0)) break; XX mflag = -1; XX } XX else { XX n = n * 10 + (c - '0'); XX } XX if ((n == 0) && (mflag == -1)) /* lonely - */ XX mlwrite("Arg:"); XX else XX mlwrite("Arg: %d",n * mflag); XX XX c = getkey(); /* get the next key */ XX } XX n = n * mflag; /* figure in the sign */ XX } XX XX /* do ^U repeat argument processing */ XX XX if (c == (CTRL|'U')) { /* ^U, start argument */ XX f = TRUE; XX n = 4; /* with argument of 4 */ XX mflag = 0; /* that can be discarded. */ XX mlwrite("Arg: 4"); XX while ((c=getkey()) >='0' && c<='9' || c==(CTRL|'U') || c=='-'){ XX if (c == (CTRL|'U')) n = n*4; XX /* XX * If dash, and start of argument string, set arg. XX * to -1. Otherwise, insert it. XX */ XX else if (c == '-') { XX if (mflag) break; XX n = 0; XX mflag = -1; XX } XX /* XX * If first digit entered, replace previous argument XX * with digit and set sign. Otherwise, append to arg. XX */ XX else { XX if (!mflag) { XX n = 0; XX mflag = 1; XX } XX n = 10*n + c - '0'; XX } XX mlwrite("Arg: %d", (mflag >=0) ? n : (n ? -n : -1)); XX } XX /* XX * Make arguments preceded by a minus sign negative and change XX * the special argument "^U -" to an effective "^U -1". XX */ XX if (mflag == -1) { XX if (n == 0) n++; XX n = -n; XX } XX } XX if (c == (CTRL|'X')) { /* ^X is a prefix */ XX c = getkey(); XX if ((c & 0x77) >='a' && (c & 0x77) <= 'z') c -= 0x20; XX c |= CTLX; XX } XX XX if (kbdmip != NULL) { /* Save macro strokes. */ XX if (c!=(CTLX|')') && kbdmip>&kbdm[NKBDM-6]) { XX ctrlg(FALSE, 0); XX goto loop; XX } XX if (f != FALSE) { XX *kbdmip++ = (CTRL|'U'); XX *kbdmip++ = n; XX } XX *kbdmip++ = c; XX } XX execute(c, f, n); /* Do it. */ XX goto loop; XX } XX XX/* XX* Initialize all of the buffers and windows. The buffer name is passed down XX* as an argument, because the main routine may have been told to read in a XX* file by default, and we want the buffer name to be right. XX*/ XXedinit(bname) XXchar bname[]; XX { XX register BUFFER *bp; XX register WINDOW *wp; XX char *malloc(); XX XX bp = bfind(bname, TRUE, 0); /* First buffer */ XX blistp = bfind("[List]", TRUE, BFTEMP); /* Buffer list buffer */ XX wp = (WINDOW *) malloc(sizeof(WINDOW)); /* First window */ XX if (bp==NULL || wp==NULL || blistp==NULL) exit(1); XX curbp = bp; /* Make this current */ XX wheadp = wp; XX curwp = wp; XX wp->w_wndp = NULL; /* Initialize window */ XX wp->w_bufp = bp; XX bp->b_nwnd = 1; /* Displayed. */ XX wp->w_linep = bp->b_linep; XX wp->w_dotp = bp->b_linep; XX wp->w_doto = 0; XX wp->w_markp = NULL; XX wp->w_marko = 0; XX wp->w_toprow = 0; XX wp->w_ntrows = term.t_nrow-1; /* "-1" for mode line. */ XX wp->w_force = 0; XX wp->w_flag = WFMODE|WFHARD; /* Full. */ XX } XX XX/* XX* This is the general command execution routine. It handles the fake binding XX* of all the keys to "self-insert". It also clears out the "thisflag" word, XX* and arranges to move it to the "lastflag", so that the next command can XX* look at it. Return the status of command. XX*/ XXexecute(c, f, n) XX { XX register KEYTAB *ktp; XX register int status; XX XX ktp = &keytab[0]; /* Look in key table. */ XX while (ktp->k_fp != NULL) { XX if (ktp->k_code == c) { XX thisflag = 0; XX status = (*ktp->k_fp)(f, n); XX lastflag = thisflag; XX return (status); XX } XX ++ktp; XX } XX XX /* XX * If a space was typed, fill column is defined, the argument is non- XX * negative, wrap mode is enabled, and we are now past fill column, XX * and we are not read-only, perform word wrap. XX */ XX if (c == ' ' && (curwp->w_bufp->b_mode & MDWRAP) && fillcol > 0 && n >= 0 && getccol(FALSE) > fillcol && XX (curwp->w_bufp->b_mode & MDVIEW) == FALSE) XX wrapword(); XX XX if ((c>=0x20 && c<=0x7E) /* Self inserting. */ XX || (c>=0xA0 && c<=0xFE)) { XX if (n <= 0) { /* Fenceposts. */ XX lastflag = 0; XX return (n<0 ? FALSE : TRUE); XX } XX thisflag = 0; /* For the future. */ XX status = linsert(n, c); XX c &= 0x7f; XX if (status && doflashing && XX (c == ')' || c == ']' || c == '}' || c == '>')) flash(c); XX lastflag = thisflag; XX return (status); XX } XXmlwrite("\007[Key not bound]"); /* complain */ XXlastflag = 0; /* Fake last flags. */ XXreturn (FALSE); XX} XX XX/* XX* Read in a key. XX* Do the standard keyboard preprocessing. Convert the keys to the internal XX* character set. XX*/ XXgetkey() XX { XX register int c; XX XX c = (*term.t_getchar)(); XX if (c == METACH || c == 0x9B) { /* Apply M- prefix */ XX if (c == METACH) c = getctl(); XX else c = '['; /* kludge for the AMIGA CSI*/ XX XX if (c == '[' || c == 'O') { XX c = (*term.t_getchar)() & 0x7F; XX if (c == 'P') { XX c = (*term.t_getchar)(); XX if (c != METACH && c != 0x9B) return (META | (c&0x7f)); XX if (c == METACH) c = getctl(); /* kludge for AMIGA CSI */ XX else c = '['; XX XX if (c == '[' || c == 'O') { XX c = (*term.t_getchar)() & 0x7F; XX if (c != ']') return (GOLD | c); XX c = getctl(); XX if (c == '<') return (0x7f); XX return (GOLD | CTRL | c); XX } XX return (GOLD | META | c); XX } XX if (c != ']') return (SPEC | c); XX c = getctl(); XX if (c == '<') return (0x7F); XX return (CTRL | c); XX } XX return (META | c); XX } XX if (c>=0x00 && c<=0x1F) /* C0 control -> C- */ XX c = CTRL | (c+'@'); XX return (c); XX } XX XX/* XX* Get a key. XX* Apply control modifications to the read key. XX*/ XXgetctl() XX { XX register int c; XX XX c = (*term.t_getchar)(); XX if (c>='a' && c<='z') /* Force to upper */ XX c -= 0x20; XX if (c>=0x00 && c<=0x1F) /* C0 control -> C- */ XX c = CTRL | (c+'@'); XX return (c); XX } XX XX/* XX* Fancy quit command, as implemented by Norm. If the any buffer has XX* changed do a write on that buffer and exit emacs, otherwise simply exit. XX*/ XXquickexit(f, n) XX { XX register BUFFER *bp; /* scanning pointer to buffers */ XX XX bp = bheadp; XX while (bp != NULL) { XX if ((bp->b_flag&BFCHG) != 0 /* Changed. */ XX && (bp->b_flag&BFTEMP) == 0) { /* Real. */ XX curbp = bp; /* make that buffer cur */ XX mlwrite("[Saving %s]",bp->b_fname); XX filesave(f, n); XX } XX bp = bp->b_bufp; /* on to the next buffer */ XX } XX quit(f, n); /* conditionally quit */ XX } XX XX/* XX* Quit command. If an argument, always quit. Otherwise confirm if a buffer XX* has been changed and not written out. Normally bound to "C-X C-C". XX*/ XXquit(f, n) XX { XX register int s; XX XX if (f != FALSE /* Argument forces it. */ XX || anycb() == FALSE /* All buffers clean. */ XX /* User says it's OK. */ XX || (s=mlyesno("Modified buffers exist. Leave anyway")) == TRUE) { XX#if FILOCK XX lockrel(); XX#endif XX vttidy(); XX exit(GOOD); XX } XX mlwrite(""); XX return (s); XX } XX XX/* XX* Begin a keyboard macro. XX* Error if not at the top level in keyboard processing. Set up variables and XX* return. XX*/ XXctlxlp(f, n) XX { XX if (kbdmip!=NULL || kbdmop!=NULL) { XX mlwrite("Not now"); XX return (FALSE); XX } XX mlwrite("[Start macro]"); XX kbdmip = &kbdm[0]; XX return (TRUE); XX } XX XX/* XX* End keyboard macro. Check for the same limit conditions as the above XX* routine. Set up the variables and return to the caller. XX*/ XXctlxrp(f, n) XX { XX if (kbdmip == NULL) { XX mlwrite("Not now"); XX return (FALSE); XX } XX mlwrite("[End macro]"); XX kbdmip = NULL; XX return (TRUE); XX } XX XX/* XX* Execute a macro. XX* The command argument is the number of times to loop. Quit as soon as a XX* command gets an error. Return TRUE if all ok, else FALSE. XX*/ XXctlxe(f, n) XX { XX register int c; XX register int af; XX register int an; XX register int s; XX XX if (kbdmip!=NULL || kbdmop!=NULL) { XX mlwrite("Not now"); XX return (FALSE); XX } XX if (n <= 0) return (TRUE); XX do { XX kbdmop = &kbdm[0]; XX doflashing = FALSE; XX do { XX af = FALSE; XX an = 1; XX if ((c = *kbdmop++) == (CTRL|'U')) { XX af = TRUE; XX an = *kbdmop++; XX c = *kbdmop++; XX } XX s = TRUE; XX } XX while (c!=(CTLX|')') && (s=execute(c, af, an))==TRUE); XX doflashing = TRUE; XX kbdmop = NULL; XX } XX while (s==TRUE && --n); XX return (s); XX } XX XX/* XX* Abort. XX* Beep the beeper. Kill off any keyboard macro, etc., that is in progress. XX* Sometimes called as a routine, to do general aborting of stuff. XX*/ XXctrlg(f, n) XX { XX (*term.t_beep)(); XX if (kbdmip != NULL) { XX kbdm[0] = (CTLX|')'); XX kbdmip = NULL; XX } XX mlwrite("[Aborted]"); XX return (ABORT); XX } XX XX/* tell the user that this command is illegal while we are in XX VIEW (read-only) mode */ XX XXrdonly() XX XX { XX (*term.t_beep)(); XX mlwrite("[Key illegal in VIEW mode]"); XX return(FALSE); XX } SHAR_EOF if test 13526 -ne "`wc -c main.c`" then echo shar: error transmitting main.c '(should have been 13526 characters)' fi echo shar: extracting random.c sed 's/^XX//' << \SHAR_EOF > random.c XX/* XX * This file contains the command processing functions for a number of random XX * commands. There is no functional grouping here, for sure. XX */ XX XX#include XX#include "estruct.h" XX#include "edef.h" XX XXint tabsize; /* Tab size (0: use real tabs) */ XX XX/* XX * Set fill column to n. XX XX */ XXsetfillcol(f, n) XX { XX fillcol = n; XX mlwrite("[Fill column is %d]",n); XX return(TRUE); XX } XX XX/* XX * Display the current position of the cursor, in origin 1 X-Y coordinates, XX * the character that is under the cursor (in octal), and the fraction of the XX * text that is before the cursor. The displayed column is not the current XX * column, but the column that would be used on an infinite width display. XX * Normally this is bound to "C-X =". XX */ XXshowcpos(f, n) XX { XX register LINE *clp; XX register long nch; XX register int cbo; XX register long nbc; XX register int cac; XX register int ratio; XX register int col; XX register int i; XX register int c; XX XX clp = lforw(curbp->b_linep); /* Grovel the data. */ XX cbo = 0; XX nch = 0; XX for (;;) { XX if (clp==curwp->w_dotp && cbo==curwp->w_doto) { XX nbc = nch; XX if (cbo == llength(clp)) cac = '\n'; XX else XX cac = lgetc(clp, cbo); XX } XX if (cbo == llength(clp)) { XX if (clp == curbp->b_linep) break; XX clp = lforw(clp); XX cbo = 0; XX } XX else XX ++cbo; XX ++nch; XX } XX col = getccol(FALSE); /* Get real column. */ XX ratio = 0; /* Ratio before dot. */ XX if (nch != 0) ratio = (100L*nbc) / nch; XX mlwrite("X=%d Y=%d CH=0x%x .=%D (%d%% of %D)", XX col+1, currow+1, cac, nbc, ratio, nch); XX return (TRUE); XX } XX XX/* XX * Return current column. Stop at first non-blank given TRUE argument. XX */ XXgetccol(bflg) XXint bflg; XX { XX register int c, i, col; XX col = 0; XX for (i=0; iw_doto; ++i) { XX c = lgetc(curwp->w_dotp, i); XX if (c!=' ' && c!='\t' && bflg) break; XX if (c == '\t') col |= 0x07; XX else if (c<0x20 || c==0x7F) ++col; XX ++col; XX } XX return(col); XX } XX XX/* XX * Twiddle the two characters on either side of dot. If dot is at the end of XX * the line twiddle the two characters before it. Return with an error if dot XX * is at the beginning of line; it seems to be a bit pointless to make this XX * work. This fixes up a very common typo with a single stroke. Normally bound XX * to "C-T". This always works within a line, so "WFEDIT" is good enough. XX */ XXtwiddle(f, n) XX { XX register LINE *dotp; XX register int doto; XX register int cl; XX register int cr; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX dotp = curwp->w_dotp; XX doto = curwp->w_doto; XX if (doto==llength(dotp) && --doto<0) return (FALSE); XX cr = lgetc(dotp, doto); XX if (--doto < 0) return (FALSE); XX cl = lgetc(dotp, doto); XX lputc(dotp, doto+0, cr); XX lputc(dotp, doto+1, cl); XX lchange(WFEDIT); XX return (TRUE); XX } XX XX/* XX * Quote the next character, and insert it into the buffer. All the characters XX * are taken literally, with the exception of the newline, which always has XX * its line splitting meaning. The character is always read, even if it is XX * inserted 0 times, for regularity. Bound to "C-Q" XX */ XXquote(f, n) XX { XX register int s; XX register int c; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX c = getkey(); XX if (c & CTRL) c -= (CTRL|'@'); XX c &= 0x7F; XX XX if (n < 0) return (FALSE); XX if (n == 0) return (TRUE); XX if (c == '\n') { XX do { XX s = lnewline(); XX } XX while (s==TRUE && --n); XX return (s); XX } XX return (linsert(n, c)); XX } XX XX/* XX * Set tab size if given non-default argument (n <> 1). Otherwise, insert a XX * tab into file. If given argument, n, of zero, change to true tabs. XX * If n > 1, simulate tab stop every n-characters using spaces. This has to be XX * done in this slightly funny way because the tab (in ASCII) has been turned XX * into "C-I" (in 10 bit code) already. Bound to "C-I". XX */ XXtab(f, n) XX { XX register int curcol,newcol,nxttab; XX XX if (n < 0) return (FALSE); XX if (n == 0 || n > 1) { XX tabsize = n; XX return(TRUE); XX } XX if (! tabsize) return(linsert(1, '\t')); XX XX /* try to compress out spaces whenever possible */ XX curcol = getccol(FALSE); XX newcol = curcol + (tabsize - (curcol % tabsize)); XX while (curwp->w_doto > 0 && curwp->w_dotp->l_text[curwp->w_doto-1] == ' ') XX backdel(FALSE,1); XX XX curcol = getccol(FALSE); XX nxttab = 8 - (curcol % 8); XX while (nxttab+curcol <= newcol) { XX if (linsert(1,'\t') == FALSE) return(FALSE); XX curcol += nxttab; XX nxttab = 8; XX } XX if (newcol > curcol) return(linsert(newcol-curcol,' ')); XX return(TRUE); XX } XX XX/* XX * Open up some blank space. The basic plan is to insert a bunch of newlines, XX * and then back up over them. Everything is done by the subcommand XX * procerssors. They even handle the looping. Normally this is bound to "C-O". XX */ XXopenline(f, n) XX { XX register int i; XX register int s; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX if (n < 0) return (FALSE); XX if (n == 0) return (TRUE); XX i = n; /* Insert newlines. */ XX do { XX s = lnewline(); XX } XX while (s==TRUE && --i); XX if (s == TRUE) /* Then back up overtop */ XX s = backchar(f, n); /* of them all. */ XX return (s); XX } XX XX/* XX * Insert a newline. Bound to "C-M". If we are in CMODE, do automatic XX * indentation as specified. XX */ XXnewline(f, n) XX { XX register LINE *lp; XX register int s; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX if (n < 0) return (FALSE); XX XX /* if we are in C mode and this is a default */ XX if (n == 1 && (curbp->b_mode & MDCMOD) && curwp->w_dotp != curbp->b_linep) XX return(cinsert()); XX XX /* if we are in MODULA mode and this is a default */ XX if (n == 1 && (curbp->b_mode & MDMMOD) && curwp->w_dotp != curbp->b_linep) XX return(minsert()); XX XX /* if we are in LISP mode and this is a default */ XX if (n == 1 && (curbp->b_mode & MDLISP) && curwp->w_dotp != curbp->b_linep) XX return(lispinsert()); XX XX#if ULTRIX XX /* if we are in a sub shell then send the line */ XX if (curbp == procbuf) return(pinsert()); XX#endif XX XX /* insert some lines */ XX while (n--) { XX if ((s=lnewline()) != TRUE) return (s); XX } XX return (TRUE); XX } XX XXcinsert() /* insert a newline and indentation for C */ XX { XX register char *cptr; /* string pointer into text to copy */ XX register int tptr; /* index to scan into line */ XX register int i,j; XX int gotleft,gotright; XX XX /* grab a pointer to text to copy indentation from */ XX cptr = &curwp->w_dotp->l_text[0]; XX tptr = curwp->w_doto - 1; XX gotleft = gotright = 0; XX for (i = 0; i<=tptr; i++) { XX if (*cptr == '{') ++gotleft; XX if (*cptr++ == '}') ++gotright; XX } XX if (gotright > gotleft) return(fixblockend(gotleft,gotright)); XX XX XX /* save the indent of the previous line */ XX i = getccol(TRUE); j = getccol(FALSE); XX XX if (gotleft > gotright && i == j-1) { XX backdel(FALSE,1); /* get rid of curly on blank line */ XX tab(FALSE,1); /* indent it correctly */ XX linsert(1,'{'); /* put it back in */ XX } XX else if (i == j) { XX backdel(FALSE,tptr+1); /* get rid of spaces on blank lines */ XX } XX XX /* put in the newline */ XX if (lnewline() == FALSE) return(FALSE); XX XX /* and the saved indentation */ XX while (getccol(TRUE) < i) tab(FALSE, 1); XX XX /* add tabs for brace nesting on the previous line */ XX while (gotleft-- > gotright) tab(FALSE,1); XX XX return(TRUE); XX } XX XXfixblockend(gotleft,gotright) /* fix up a close brace in CMODE/MMODE/LISP */ XX { XX register int i; XX register int target; /* column brace should go after */ XX XX XX /* calc where we will go back to */ XX target = getccol(TRUE); XX while (gotright-- > gotleft) { XX i = target % (tabsize == 0 ? 8 : tabsize); XX if (i == 0) i = (tabsize == 0 ? 8 : tabsize); XX target -= i; XX } XX XX /* end the line and indent */ XX if (lnewline() == FALSE) return(FALSE); XX if (target <= 0) return(TRUE); XX XX while (getccol(TRUE) < target) tab(FALSE, 1); XX XX return(TRUE); XX XX } XX XXminsert() /* insert a newline and indentation for MODULA */ XX { XX register char *cptr; /* string pointer into text to copy */ XX register int tptr; /* index to scan into line */ XX register int i,j,doto; XX int gotleft,gotright; XX char scrbuf[20]; /* scratch buffer for comparisons */ XX XX /* grab a pointer to text to copy indentation from */ XX cptr = &curwp->w_dotp->l_text[0]; XX tptr = curwp->w_doto - 1; XX gotleft = gotright = 0; XX XX /* compress out leading white space */ XX for (doto = 0; doto<=tptr && (*cptr == ' ' || *cptr == '\t'); doto++) XX cptr++; XX XX /* upcase the test string */ XX strncpy(scrbuf,cptr,6); XX for (i = 0; i<6 ; i++) XX if (scrbuf[i]>=0x61 && scrbuf[i]<=0x7A) scrbuf[i] -= 0x20; XX XX if (strncmp(scrbuf,"IF",2) == 0 || XX strncmp(scrbuf,"FOR",3) == 0 || XX strncmp(scrbuf,"CASE",4) == 0 || XX strncmp(scrbuf,"LOOP",4) == 0 || XX strncmp(scrbuf,"WITH",4) == 0 || XX strncmp(scrbuf,"WHILE",5) == 0 || XX strncmp(scrbuf,"BEGIN",5) == 0 || XX strncmp(scrbuf,"REPEAT",6) == 0 || XX strncmp(scrbuf,"RECORD",6) == 0) ++gotleft; XX else if (strncmp(scrbuf,"ELSE",4) == 0 || XX strncmp(scrbuf,"ELSIF",5) == 0) { XX ++gotleft; XX ++gotright; XX } XX else if (strncmp(scrbuf,"END",3) == 0 || XX strncmp(scrbuf,"UNTIL",5) == 0) ++gotright; XX XX /* just ended a block */ XX if (gotright > gotleft) return(fixblockend(gotleft,gotright)); XX XX XX /* save the indent of the previous line */ XX i = getccol(TRUE); j = getccol(FALSE); XX XX /* get rid of spaces on blank lines */ XX if (i == j) backdel(FALSE,tptr+1); XX XX /* adjust current line */ XX else if (gotleft > 0 && gotleft == gotright) { XX curwp->w_doto = doto; XX while(getccol(TRUE) > i-4 && curwp->w_doto > 0) backdel(FALSE,1); XX while(getccol(TRUE) < i-4) tab(FALSE,1); XX curwp->w_doto = llength(curwp->w_dotp); XX } XX XX /* put in the newline */ XX if (lnewline() == FALSE) return(FALSE); XX XX /* and the saved indentation */ XX while (getccol(TRUE) < i) tab(FALSE, 1); XX XX /* add tabs for block nesting on the previous line */ XX while (gotleft-- > gotright) tab(FALSE,1); XX XX return(TRUE); XX } XX XXlispinsert() /* insert a newline and indentation for LISP */ XX { XX register char *cptr; /* string pointer into text to copy */ XX register int tptr; /* index to scan into line */ XX register int i,j; XX int gotleft,gotright; XX XX /* grab a pointer to text to copy indentation from */ XX cptr = &curwp->w_dotp->l_text[0]; XX tptr = curwp->w_doto - 1; XX gotleft = gotright = 0; XX for (i = 0; i<=tptr; i++) { XX if (*cptr == '(') ++gotleft; XX if (*cptr++ == ')') ++gotright; XX } XX if (gotright > gotleft) return(fixblockend(gotleft,gotright)); XX XX /* save the indent of the previous line */ XX i = getccol(TRUE); j = getccol(FALSE); XX XX if (i == j) { XX backdel(FALSE,tptr+1); /* get rid of spaces on blank lines */ XX } XX XX /* put in the newline */ XX if (lnewline() == FALSE) return(FALSE); XX XX /* and the saved indentation */ XX while (getccol(TRUE) < i) tab(FALSE, 1); XX XX /* add tabs for paren nesting on the previous line */ XX while (gotleft-- > gotright) tab(FALSE,1); XX XX return(TRUE); XX } XX XX/* XX* Delete blank lines around dot. What this command does depends if dot is XX* sitting on a blank line. If dot is sitting on a blank line, this command XX* deletes all the blank lines above and below the current line. If it is XX* sitting on a non blank line then it deletes all of the blank lines after XX* the line. Normally this command is bound to "C-X C-O". Any argument is XX* ignored. XX*/ XXdeblank(f, n) XX { XX register LINE *lp1; XX register LINE *lp2; XX register int nld; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX lp1 = curwp->w_dotp; XX while (llength(lp1)==0 && (lp2=lback(lp1))!=curbp->b_linep) lp1 = lp2; XX lp2 = lp1; XX nld = 0; XX while ((lp2=lforw(lp2))!=curbp->b_linep && llength(lp2)==0) ++nld; XX if (nld == 0) return (TRUE); XX curwp->w_dotp = lforw(lp1); XX curwp->w_doto = 0; XX return (ldelete(nld)); XX } XX XX/* XX* Insert a newline, then enough tabs and spaces to duplicate the indentation XX* of the previous line. Assumes tabs are every eight characters. Quite simple. XX* Figure out the indentation of the current line. Insert a newline by calling XX* the standard routine. Insert the indentation by inserting the right number XX* of tabs and spaces. Return TRUE if all ok. Return FALSE if one of the XX* subcomands failed. Normally bound to "C-J". XX*/ XXindent(f, n) XX { XX register int nicol; XX register int c; XX register int i; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX if (n < 0) return (FALSE); XX while (n--) { XX nicol = 0; XX for (i=0; iw_dotp); ++i) { XX c = lgetc(curwp->w_dotp, i); XX if (c!=' ' && c!='\t') break; XX if (c == '\t') nicol |= 0x07; XX ++nicol; XX } XX if (lnewline() == FALSE || ((i=nicol/8)!=0 && linsert(i, '\t')==FALSE) XX || ((i=nicol%8)!=0 && linsert(i, ' ')==FALSE)) XX return (FALSE); XX } XX return (TRUE); XX } XX XX/* XX* Delete forward. This is real easy, because the basic delete routine does XX* all of the work. Watches for negative arguments, and does the right thing. XX* If any argument is present, it kills rather than deletes, to prevent loss XX* of text if typed with a big argument. Normally bound to "C-D". XX*/ XXforwdel(f, n) XX { XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX if (n < 0) return (backdel(f, -n)); XX if (f != FALSE) { /* Really a kill. */ XX if ((lastflag&CFKILL) == 0) XX kdelete(); XX thisflag |= CFKILL; XX } XX return (ldelete(n, f)); XX } XX XX/* XX* Delete backwards. This is quite easy too, because it's all done with other XX* functions. Just move the cursor back, and delete forwards. Like delete XX* forward, this actually does a kill if presented with an argument. Bound to XX* both "RUBOUT" and "C-H". XX*/ XXbackdel(f, n) XX { XX register int s; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX if (n < 0) return (forwdel(f, -n)); XX if (f != FALSE) { /* Really a kill. */ XX if ((lastflag&CFKILL) == 0) XX kdelete(); XX thisflag |= CFKILL; XX } XX if ((s=backchar(f, n)) == TRUE) s = ldelete(n, f); XX return (s); XX } XX XX/* XX* Kill text. If called without an argument, it kills from dot to the end of XX* the line, unless it is at the end of the line, when it kills the newline. XX* If called with an argument of 0, it kills from the start of the line to dot. XX* If called with a positive argument, it kills from dot forward over that XX* number of newlines. If called with a negative argument it kills backwards XX* that number of newlines. Normally bound to "C-K". XX*/ XXkilltext(f, n) XX { XX register int chunk; XX register LINE *nextp; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX XX return(rdonly()); /* we are in read only mode */ XX if ((lastflag&CFKILL) == 0) /* Clear kill buffer if */ XX kdelete(); /* last wasn't a kill. */ XX thisflag |= CFKILL; XX if (f == FALSE) { XX chunk = llength(curwp->w_dotp)-curwp->w_doto; XX if (chunk == 0) chunk = 1; XX } XX else if (n == 0) { XX chunk = curwp->w_doto; XX curwp->w_doto = 0; XX } XX else if (n > 0) { XX chunk = llength(curwp->w_dotp)-curwp->w_doto+1; XX nextp = lforw(curwp->w_dotp); XX while (--n) { XX if (nextp == curbp->b_linep) return (FALSE); XX chunk += llength(nextp)+1; XX nextp = lforw(nextp); XX } XX } XX else { XX mlwrite("neg kill"); XX return (FALSE); XX } XX return (ldelete(chunk, TRUE)); XX } XX XX/* XX* Yank text back from the kill buffer. This is really easy. All of the work XX* is done by the standard insert routines. All you do is run the loop, and XX* check for errors. Bound to "C-Y". XX*/ XXyank(f, n) XX { XX register int c; XX register int i; XX extern int kused; XX XX if (curbp->b_mode&MDVIEW) /* don't allow this command if */ XX return(rdonly()); /* we are in read only mode */ XX if (n < 0) return (FALSE); XX while (n--) { XX i = 0; XX while ((c=kremove(i)) >= 0) { XX if (c == '\n') { XX if (lnewline(FALSE, 1) == FALSE) return (FALSE); XX } XX else { XX if (linsert(1, c) == FALSE) return (FALSE); XX } XX ++i; XX } XX } XX return (TRUE); XX } XX XX XXadjustmode(f,n) /* change the editor mode status */ XX { XX register char *scan; /* scanning pointer to convert prompt */ XX register int i; /* loop index */ XX char cbuf[NPAT]; /* buffer to recieve mode name into */ XX char prompt[80]; /* string to prompt user with */ XX XX strcpy(prompt,"Change mode ("); XX strcat(prompt,modename[0]); XX for (i=1; i < NUMMODES; i++) { XX strcat(prompt,","); XX strcat(prompt,modename[i]); XX } XX strcat(prompt,"): "); XX XX /* prompt the user and get an answer */ XX XX mlreply(prompt, cbuf, NPAT - 1); XX XX /* make it uppercase */ XX XX scan = cbuf; XX while (*scan != 0) { XX if (*scan >= 'a' && *scan <= 'z') *scan = *scan - 32; XX scan++; XX } XX XX /* test it against the modes we know (first letter only) */ XX XX for (i=0; i < NUMMODES; i++) { XX if (cbuf[0] == modename[i][0]) { XX /* finding a match, we process it */ XX if ((curwp->w_bufp->b_mode & (1 << i)) == 0) { XX curwp->w_bufp->b_mode |= (1 << i); XX if ((1 << i) == MDCMOD) { XX tab(FALSE,4); XX curwp->w_bufp->b_mode &= ~(MDMMOD|MDLISP); XX } XX if ((1 << i) == MDMMOD) { XX tab(FALSE,4); XX curwp->w_bufp->b_mode &= ~(MDCMOD|MDLISP); XX } XX if ((1 << i) == MDLISP) { XX tab(FALSE,2); XX curwp->w_bufp->b_mode &= ~(MDCMOD|MDMMOD); XX } XX } XX else { XX curwp->w_bufp->b_mode &= ~(1 << i); XX if (((1 << i) == MDCMOD) || XX ((1 << i) == MDMMOD) || XX ((1 << i) == MDLISP)) tab(FALSE,0); XX } XX /* display new mode line */ XX upmode(); XX mlerase(); /* erase the junk */ XX return(TRUE); XX } XX } XX XX mlwrite("No such mode!"); XX return(FALSE); XX } XX SHAR_EOF if test 18178 -ne "`wc -c random.c`" then echo shar: error transmitting random.c '(should have been 18178 characters)' fi # End of shell archive exit 0