kcw@beach.cis.ufl.edu (Ken Whedbee) (12/10/90)
matthew1@stretch.cs.mun.ca (Matthew J. Newhook) writes: I have several versions of xlisp 2.1, the most recent being the one updated by Tom Almy. I am running it under several versions of Unix (SunOS, System V, BSD 4.3), and they all have the same common problem. They don't show the current level of nesting. ie: if i type >(setq a '(a b c) it should say 1> however, it doesn't, it just shows nothing... also a return at the > prompt should return with another >, that doesn't do the job either: I posted this a month ago. The changes to the src takes care of handling the control keys. The useage of the break loop is defined in init.lsp Ken 12/10/90 I got sick of the control keys not working in the unix-frontend for xlisp. To date, the best unix-front end has been the one provided by Niels Mayer in his winterp distribution, for instance the SYSTEM function worked. However, those control keys still did not work, and I sure like to use CTRL-c when I get dumped into a break loop! What we have here is a hacked version of Niels Mayer unix-front end, I got this working on a Sun SPARC station (BSD derivative), the hooks are there for S5 also. Job control still works in BSD, another common control key is CTRL-t, which shows garbage collection information. I have also included some timing functions that break the time down into CPU and REAL time that a function or program takes. Enjoy !! PS: standard disclaimers apply! #!/bin/sh # This is a shell archive (produced by shar 3.49) # To extract the files from this archive, save it to a file, remove # everything above the "!/bin/sh" line above, and type "sh file_name". # # made 12/10/1990 13:58 UTC by kcw@reef # Source directory /net/bikini/0/kcw/xlisp/src/distrib # # existing files will NOT be overwritten unless -c is specified # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 21763 -rw------- unixstuff.c # 389 -rw------- osdefs.h # 881 -rw------- osptrs.h # 377 -rw------- xlisp.h.add # 1906 -rw------- init.lsp # # ============= unixstuff.c ============== if test -f 'unixstuff.c' -a X"$1" != X"-c"; then echo 'x - skipping unixstuff.c (File already exists)' else echo 'x - extracting unixstuff.c (Text)' sed 's/^X//' << 'SHAR_EOF' > 'unixstuff.c' && /* -*-C-*- ******************************************************************************** * * File: unixstuff.c * Description: UNIX-Specific interfaces for XLISP * Authors: David Michael Betz; Niels Mayer * * Revision: Ken Whedbee kcw@reef.cis.ufl.edu * * 1. Control characters will work now on BSD and S5 * 2. Added Common Lisp timing functions * * WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). * XLISP version 2.1, Copyright (c) 1989, by David Betz. * ******************************************************************************** */ X #include <stdio.h> #include <signal.h> #include <sys/types.h> #include <sys/times.h> X #ifdef BSD #include <sys/ioctl.h> struct sgttyb savetty; struct sgttyb newtty; #define stty(fd,arg) (ioctl(fd, TIOCSETP, arg)) #define gtty(fd,arg) (ioctl(fd, TIOCGETP, arg)) #else #include <termio.h> struct termio savetty; struct termio newtty; #define stty(fd,arg) (ioctl(fd, TCGETA, arg)) #define gtty(fd,arg) (ioctl(fd, TCSETAF, arg)) #endif X #include "xlisp.h" X #define LBSIZE 200 #define HZ 60 X /* -- external variables */ extern FILE *tfp; extern long times(); extern long time_stamp; extern char buf[]; extern LVAL xeval(); X /* -- local variables */ static long rseed = 1L; static char lbuf[LBSIZE]; static int lpos[LBSIZE]; static int lposition; static int lindex; static int lcount; X char *xfgets(); char read_keybd(); X X /* -- osinit - initialize */ /****************************************************************************** X * Prim_POPEN - start a process and open a pipe for read/write X * (code stolen from xlfio.c:xopen()) X * X * syntax: (popen <command line> :direction <direction>) X * <command line> is a string to be sent to the subshell (sh). X * <direction> is either :input (to read from the pipe) or X * :output (to write to the pipe). X * (:input is the default) X * X * Popen returns a stream, or NIL if files or processes couldn't be created. X * The success of the command execution can be checked by examining the X * return value of pclose. X * X * Added to XLISP by Niels Mayer X ******************************************************************************/ LVAL Prim_POPEN() { X extern LVAL k_direction, k_input, k_output; X char *name,*mode; X FILE *fp; X LVAL dir; X X /* get the process name and direction */ X name = (char *) getstring(xlgastring()); X if (!xlgetkeyarg(k_direction, &dir)) X dir = k_input; X X /* get the mode */ X if (dir == k_input) X mode = "r"; X else if (dir == k_output) X mode = "w"; X else X xlerror("bad direction",dir); X X /* try to open the file */ X return ((fp = popen(name,mode)) ? cvfile(fp) : NIL); } X X /****************************************************************************** X * Prim_PCLOSE - close a pipe opened by Prim_POPEN(). X * (code stolen from xlfio.c:xclose()) X * X * syntax: (pclose <stream>) X * <stream> is a stream created by popen. X * returns T if the command executed successfully, otherwise, X * returns the exit status of the opened command. X * X * Added to XLISP by Niels Mayer X ******************************************************************************/ LVAL Prim_PCLOSE() { X extern LVAL true; X LVAL fptr; X int result; X X /* get file pointer */ X fptr = xlgastream(); X xllastarg(); X X /* make sure the file exists */ X if (getfile(fptr) == NULL) X xlfail("file not open"); X X /* close the pipe */ X result = pclose(getfile(fptr)); X X if (result == -1) X xlfail("<stream> has not been opened with popen"); X X setfile(fptr,NULL); X X /* return T if success (exit status 0), else return exit status */ X return (result ? cvfixnum(result) : true); } X X /****************************************************************************** X * Prim_SYSTEM - run a process, sending output (if any) to stdout/stderr X * X * syntax: (system <command line>) X * <command line> is a string to be sent to the subshell (sh). X * X * Returns T if the command executed succesfully, otherwise returns the X * integer shell exit status for the command. X * X * Added to XLISP by Niels Mayer X ******************************************************************************/ LVAL Prim_SYSTEM() { X extern LVAL true; X extern int sys_nerr; X extern char *sys_errlist[]; X extern int errno; X LVAL command; X int result; X char temptext[1024]; X X /* get shell command */ X command = xlgastring(); X xllastarg(); X X /* run the process */ X result = system((char *) getstring(command)); X X if (result == -1) { /* if a system error has occured */ X if (errno < sys_nerr) X (void) sprintf(temptext, "Error in system(3S): %s\n", sys_errlist[errno]); X else X (void) strcpy(temptext, "Error in system(3S): unknown error\n"); X xlfail(temptext); X } X X /* return T if success (exit status 0), else return exit status */ X return (result ? cvfixnum(result) : true); } X X /****************************************************************************** X * (FSCANF-FIXNUM <stream> <scanf-format>) X * This routine calls fscanf(3s) on a <stream> that was previously openend X * via open or popen. It will not work on an USTREAM. X * <scanf-format> is a format string containing a single conversion X * directive that will result in an integer valued conversion. X * %d, %u, %o, %x, %ld, %lu, %lo and %lx style conversions X * are acceptable for this routine. X * WARNING: specifying a <scanf-format> that will result in the conversion X * of a result larger than sizeof(long) will result in corrupted memory and X * core dumps. X * X * This routine will return an FIXNUM if fscanf() returns 1 (i.e. if X * the one expected conversion has succeeded. It will return NIL if the X * conversion wasn't successful, or if EOF was reached. X ******************************************************************************/ LVAL Prim_FSCANF_FIXNUM() { X LVAL lval_stream; X char* fmt; X long result; X X lval_stream = xlgastream(); X if (getfile(lval_stream) == NULL) X xlerror("File not opened.", lval_stream); X fmt = (char *) getstring(xlgastring()); X xllastarg(); X X result = 0L; /* clear it out hibits incase short is written */ X /* if scanf returns result <1 then an error or eof occured. */ X if (fscanf(getfile(lval_stream), fmt, &result) < 1) X return (NIL); X else X return (cvfixnum((FIXTYPE) result)); } X X /****************************************************************************** X * (FSCANF-STRING <stream> <scanf-format>) X * This routine calls fscanf(3s) on a <stream> that was previously openend X * via open or popen. It will not work on an USTREAM. X * <scanf-format> is a format string containing a single conversion X * directive that will result in a string valued conversion. X * %s, %c, and %[...] style conversions are acceptable for X * this routine. X * WARNING: specifying a <scanf-format> that will result in the conversion X * of a result larger than 1024 characters will result in corrupted X * memory and core dumps. X * X * This routine will return a string if fscanf() returns 1 (i.e. if X * the one expected conversion has succeeded. It will return NIL if the X * conversion wasn't successful, or if EOF was reached. X ******************************************************************************/ LVAL Prim_FSCANF_STRING() { X LVAL lval_stream; X char* fmt; X char result[BUFSIZ]; X X X lval_stream = xlgastream(); X if (getfile(lval_stream) == NULL) X xlerror("File not opened.", lval_stream); X fmt = (char *) getstring(xlgastring()); X xllastarg(); X X result[0] = result[1] = '\0'; /* if the conversion is %c, then fscanf X doesn't null terminate the string, X so do it just incase */ X X /* if scanf returns result <1 then an error or eof occured. */ X if (fscanf(getfile(lval_stream), fmt, result) < 1) X return (NIL); X else X return (cvstring(result)); } X X /****************************************************************************** X * (FSCANF-FLONUM <stream> <scanf-format>) X * This routine calls fscanf(3s) on a <stream> that was previously openend X * via open or popen. It will not work on an USTREAM. X * <scanf-format> is a format string containing a single conversion X * directive that will result in an FLONUM valued conversion. X * %e %f or %g are valid conversion specifiers for this routine. X * X * WARNING: specifying a <scanf-format> that will result in the conversion X * of a result larger than sizeof(float) will result in corrupted memory and X * core dumps. X * X * This routine will return a FLONUM if fscanf() returns 1 (i.e. if X * the one expected conversion has succeeded. It will return NIL if the X * conversion wasn't successful, or if EOF was reached. X ******************************************************************************/ LVAL Prim_FSCANF_FLONUM() { X LVAL lval_stream; X char* fmt; X FILE * fp; X float result; X X lval_stream = xlgastream(); X if (getfile(lval_stream) == NULL) X xlerror("File not opened.", lval_stream); X fmt = (char *) getstring(xlgastring()); X xllastarg(); X X /* if scanf returns result <1 then an error or eof occured. */ X if (fscanf(getfile(lval_stream), fmt, &result) < 1) X return (NIL); X else X return (cvflonum((FLOTYPE) result)); } X X /****************************************************************************** X * (copy-array <src> <dest> [<pos>]) --> returns <dest> X * This function copies from array <src> into the preallocated array <dest> X * (allocate with 'make-array'). If the optional arg <pos> is given, then X * elements from <src> will be written into <dest> at index <pos>, otherwise X * <pos> defaults to 0. X * X * This function was added to xlisp by Niels Mayer. X ******************************************************************************/ LVAL Prim_COPY_ARRAY() { X register int size; X register LVAL *src, *dest; X LVAL src_array, dest_array, lval_pos; X X src_array = xlgavector(); /* get <src> */ X dest_array = xlgavector(); /* get <dest> */ X if moreargs() X lval_pos = xlgafixnum(); /* get optional <pos> */ X else X lval_pos = NIL; X xllastarg(); X X src = src_array->n_vdata; X dest = dest_array->n_vdata; X X if (getsize(src_array) < getsize(dest_array)) /* which is shortest? */ X size = getsize(src_array); X else X size = getsize(dest_array); X X if (lval_pos) { X int pos = getfixnum(lval_pos); X int len = getsize(dest_array) - pos; X if ((len <= 0) || (pos < 0)) X xlerror("Array position out of bounds.", lval_pos); X if (len < size) X size = len; X dest = dest + pos; X } X X while (size--) X *dest++ = *src++; X X return (dest_array); } X /****************************************************************************** X * (array-insert-pos <array> <pos> <elt>) --> returns the new <array> X * inserts <elt> at index <pos> in <array>. if <pos> < 0, then <elt> is X * appended to the end of <array>. X * X * This function was added to xlisp by Niels Mayer. X ******************************************************************************/ LVAL Prim_ARRAY_INSERT_POS() { X register int i; X register LVAL *src, *dest; X LVAL src_array, dest_array, elt, lval_position; X int src_size, position; X X src_array = xlgavector(); /* get <array> */ X lval_position = xlgafixnum(); /* get <pos>, a fixnum */ X elt = nextarg(); /* get <elt>, which can be any lisp type */ X xllastarg(); X X src_size = getsize(src_array); X position = getfixnum(lval_position); X if (position >= src_size) X xlerror("Array insertion position out of bounds.", lval_position); X dest_array = newvector(src_size + 1); X X src = src_array->n_vdata; X dest = dest_array->n_vdata; X X if (position < 0) { /* append <elt> to end of array */ X i = src_size; X while (i--) X *dest++ = *src++; X *dest = elt; X } X else { /* insert <elt> at <position> */ X i = position; X while (i--) X *dest++ = *src++; X *dest++ = elt; X i = src_size - position; X while (i--) X *dest++ = *src++; X } X return (dest_array); } X /****************************************************************************** X * (array-delete-pos <array> <pos>) --> returns the new <array> X * deletes the element at index <pos> in <array>. If <pos>==-1, then it X * will delete the last element in the array. X * Note that this function is destructive. It reuses the old <array>'s X * elements. X * X * This function was added to xlisp by Niels Mayer. X ******************************************************************************/ LVAL Prim_ARRAY_DELETE_POS() { X register int i; X register LVAL *src, *dest; X LVAL src_array, dest_array, lval_position; X int src_size, position; X X src_array = xlgavector(); /* get <array> */ X lval_position = xlgafixnum(); /* get <pos>, a fixnum */ X xllastarg(); X X src_size = getsize(src_array); X position = getfixnum(lval_position); X if (position >= src_size) X xlerror("Array insertion position out of bounds.", lval_position); X if ((src_size - 1) > 0) X dest_array = newvector(src_size - 1); X else X return (NIL); X X src = src_array->n_vdata; X dest = dest_array->n_vdata; X X if (position < 0) { /* remove last element of array */ X i = src_size - 1; X while (i--) X *dest++ = *src++; X } X else { /* remove <elt> at <position> */ X i = position; X while (i--) X *dest++ = *src++; X src++; /* don't copy the deleted elt */ X i = src_size - (position + 1); X while (i--) X *dest++ = *src++; X } X return (dest_array); } X X X X /******************************************************************************/ /* -- Written by dbetz for XLISP 2.0 */ X X /* -- osinit - initialize */ osinit(banner) X char *banner; { X printf("%s\n", banner ); X printf("%s\n", "UNIX version"); X init_tty(); X lindex = 0; X lcount = 0; } X /* -- osfinish - clean up before returning to the operating system */ osfinish() { X stty(0, &savetty); } X X /* -- oserror - print an error message */ oserror(msg) X char *msg; X { X printf( "error: %s\n", msg ); } X X /* -- osrand - return a random number between 0 and n-1 */ int osrand(n) X int n; X { X long k1; X X /* -- make sure we don't get stuck at zero */ X if ( rseed == 0L ) rseed = 1L; X X /* -- algorithm taken from Dr Dobbs Journal, Nov. 1985, page 91 */ X k1 = rseed / 127773L; X if ( ( rseed = 16807L * (rseed - k1 * 127773L) -k1 * 2836L) < 0L ) X rseed += 2147483647L; X X /* -- return a random number between 0 and n-1 */ X return( (int) (rseed & (long) n ) ); } X X X /* -- osaopen -- open an ascii file */ FILE *osaopen( name, mode ) char *name, *mode; { X return( fopen( name, mode ) ); } X X X /* -- osbopen -- open a binary file */ FILE *osbopen( name, mode ) char *name, *mode; { X return( fopen( name, mode ) ); } X X /* -- osclose -- close a file */ int osclose( fp ) FILE *fp; { X return( fclose( fp ) ); } X X /* -- osagetc - get a character from an ASCII file */ int osagetc( fp ) FILE *fp; { X return( getc(fp) ); } X /* -- osaputc - put a character to an ASCII file */ int osaputc( ch, fp ) int ch; FILE *fp; { X return( putc( ch, fp ) ); } X X X /* -- osbgetc - get a character from a binary file */ int osbgetc( fp ) FILE *fp; { X return( getc(fp) ); } X /* -- osbputc - put a character to a binary file */ int osbputc( ch, fp ) int ch; FILE *fp; { X return( putc( ch, fp ) ); } X /* -- ostgetc - get a character from the terminal */ int ostgetc() { X X while(--lcount < 0 ) X { X if ( xfgets(lbuf,LBSIZE,stdin) == NULL ) X return( EOF ); X if ( tfp ) X fputs( lbuf, tfp ); X X lcount = strlen( lbuf ); X lindex = 0; X } X X return( lbuf[lindex++] ); } X X /* -- ostputc - put a character to the terminal */ ostputc( ch ) int ch; { X char buf[1]; X X buf[0] = ch; X X /* -- output the character */ /* putchar( ch ); */ X write(1,buf,sizeof(buf)); X X /* -- output the char to the transcript file */ X if ( tfp ) X osaputc( ch, tfp ); } X X X X /* -- osflush - flush the terminal input buffer */ osflush() { X lindex = lcount = 0; } X oscheck() { } X osx_check(ch) char ch; { X switch (ch) { X case '\003': X xltoplevel(); /* control-c */ X case '\007': X xlcleanup(); /* control-g */ X case '\020': X xlcontinue(); /* control-p */ X case '\024': /* control-t */ X xinfo(); X printf("\n "); X } } X X /* -- ossymbols - enter os-specific symbols */ ossymbols() { } X X /* xinfo - show information on control-t */ static xinfo() { X extern int nfree,gccalls; X extern long total; X char buf[80], tymebuf[20]; X int tyme; X X tyme = time(0); X strcpy(tymebuf, ctime(&tyme)); X tymebuf[19] = '\0'; X sprintf(buf,"\n[ %s Free: %d, GC calls: %d, Total: %ld ]", X tymebuf, nfree,gccalls,total); X errputstr(buf); } X /* xflush - flush the input line buffer and start a new line */ static xflush() { X osflush(); X ostputc('\n'); } X X char read_keybd() /* added KCW */ { X int nrd; X char buf[1]; X X nrd = read(0, buf, sizeof(buf)); X buf[nrd] = 0; X X if (buf[0] == 127) { /* perform the BACKSPACE */ X stdputstr("\010"); X stdputstr(" "); X stdputstr("\010"); X } X else X stdputstr(buf); X X return(buf[0]); } X X init_tty() /* added KCW */ { X /* extern sigcatch(); */ X extern onsusp(); X X signal(SIGINT, xltoplevel); X signal(SIGQUIT, SIG_IGN); X if (signal(SIGTSTP, onsusp) == SIG_DFL) { X signal(SIGTSTP, onsusp); X } X if (gtty(0, &savetty) == -1) X { X printf("ioctl failed: not a tty\n"); X exit(); X } #ifdef BSD X newtty = savetty; X newtty.sg_flags |= CBREAK; /* turn off canonical mode */ X /* i.e., turn on cbreak mode */ X newtty.sg_flags &= ~ECHO; /* turn off character echo */ #else X newtty.c_lflag &= ~ICANON; /* SYS 5 */ X newtty.c_lflag &= ~ECHO; X newtty.c_cc[VMIN] = 1; X newtty.c_cc[VTIME] = 1; #endif X /* X * You can't request that it try to give you at least X * 5 characters, nor set the timeout to 10 seconds, X * as you can in the S5 example. If characters come X * in fast enough, though, you may get more than one. X */ X if (stty(0, &newtty) == -1) X { X printf("cannot put tty into cbreak mode\n"); X exit(); X } } X onsusp() /* added KCW */ { X /* ignore SIGTTOU so we dont get stopped if csh grabs the tty */ X signal(SIGTTOU, SIG_IGN); X stty(0, &savetty); X xflush(); X signal(SIGTTOU,SIG_DFL); X X /* send the TSTP signal to suspend our process group */ X signal(SIGTSTP, SIG_DFL); X sigsetmask(0); X kill(0, SIGTSTP); X /* pause for station break */ X X /* we re back */ X signal(SIGTSTP, onsusp); X stty(0, &newtty); } X X X char *xfgets(s, n, iop) /* hacked fgets, KCW */ char *s; register FILE *iop; { X register c; X register char *cs; X X cs = s; X while (--n>0 && (c = read_keybd()) != EOF) { X switch(c) { X case '\002' : /* CTRL-b */ X case '\003' : /* CTRL-c */ X case '\007' : /* CTRL-g */ X case '\020' : /* CTRL-p */ X case '\024' : osx_check(c); /* CTRL-t */ X n++; X break; X X case 127 : n+=2; /* BACKSPACE */ X *cs--; X *cs = ' '; X break; X X default : *cs++ = c; /* character */ X } X if (c=='\n') break; X } X if (c == EOF && cs==s) return(NULL); X *cs++ = '\0'; X return(s); } X /***********************************************************************/ /** **/ /** Time Functions: code from Tom Almy and Luke Tierney further **/ /** hacked by KCW **/ /** **/ /***********************************************************************/ X unsigned long ticks_per_second() { return((unsigned long) HZ); } X unsigned long run_tick_count() /* CPU time */ { X struct tms tm; X X times(&tm); X return((unsigned long) tm.tms_utime + tm.tms_stime ); } X unsigned long real_tick_count() /* real time */ { X return((unsigned long) (60 * (time((unsigned long *) NULL) - time_stamp))); } X X LVAL xstime() { X LVAL result; X unsigned long tm, rtm; X double dtm, rdtm; X X tm = run_tick_count(); X rtm = real_tick_count(); X result = xeval(); X tm = run_tick_count() - tm; X rtm = real_tick_count() - rtm; X dtm = (tm > 0) ? tm : -tm; X rdtm = (rtm > 0) ? rtm : -rtm; X sprintf(buf, "CPU %.2f sec., Real %.2f sec.\n", dtm / ticks_per_second(), X rdtm / ticks_per_second()); X stdputstr(buf); X return(result); } X LVAL xs_get_internal_run_time() { return(cvfixnum((FIXTYPE) run_tick_count())); } X LVAL xs_get_internal_real_time() { return(cvfixnum((FIXTYPE) real_tick_count())); } X X X SHAR_EOF chmod 0600 unixstuff.c || echo 'restore of unixstuff.c failed' Wc_c="`wc -c < 'unixstuff.c'`" test 21763 -eq "$Wc_c" || echo 'unixstuff.c: original size 21763, current size' "$Wc_c" fi # ============= osdefs.h ============== if test -f 'osdefs.h' -a X"$1" != X"-c"; then echo 'x - skipping osdefs.h (File already exists)' else echo 'x - extracting osdefs.h (Text)' sed 's/^X//' << 'SHAR_EOF' > 'osdefs.h' && /* osdefs.h - system specific function declarations */ X X #ifdef UNIX extern LVAL Prim_POPEN(), Prim_PCLOSE(), Prim_SYSTEM(); extern LVAL Prim_FSCANF_FIXNUM(), Prim_FSCANF_STRING(), Prim_FSCANF_FLONUM(); extern LVAL Prim_COPY_ARRAY(), Prim_ARRAY_INSERT_POS(), Prim_ARRAY_DELETE_POS(); extern LVAL xstime(), xsgetenv(), xs_get_internal_run_time(), X xs_get_internal_real_time(); #endif X SHAR_EOF chmod 0600 osdefs.h || echo 'restore of osdefs.h failed' Wc_c="`wc -c < 'osdefs.h'`" test 389 -eq "$Wc_c" || echo 'osdefs.h: original size 389, current size' "$Wc_c" fi # ============= osptrs.h ============== if test -f 'osptrs.h' -a X"$1" != X"-c"; then echo 'x - skipping osptrs.h (File already exists)' else echo 'x - extracting osptrs.h (Text)' sed 's/^X//' << 'SHAR_EOF' > 'osptrs.h' && /* osptrs.h - system specific function pointers */ X X #ifdef UNIX { "SYSTEM", S, Prim_SYSTEM }, { "POPEN", S, Prim_POPEN }, { "PCLOSE", S, Prim_PCLOSE }, { "FSCANF-FIXNUM", S, Prim_FSCANF_FIXNUM }, { "FSCANF-STRING", S, Prim_FSCANF_STRING }, { "FSCANF-FLONUM", S, Prim_FSCANF_FLONUM }, { "COPY-ARRAY", S, Prim_COPY_ARRAY }, { "ARRAY-INSERT-POS", S, Prim_ARRAY_INSERT_POS}, { "ARRAY-DELETE-POS", S, Prim_ARRAY_DELETE_POS}, { "TIME", F, xstime }, { "GET-INTERNAL-RUN-TIME", S, xs_get_internal_run_time }, { "GET-INTERNAL-REAL-TIME", S, xs_get_internal_real_time }, #endif X X SHAR_EOF chmod 0600 osptrs.h || echo 'restore of osptrs.h failed' Wc_c="`wc -c < 'osptrs.h'`" test 881 -eq "$Wc_c" || echo 'osptrs.h: original size 881, current size' "$Wc_c" fi # ============= xlisp.h.add ============== if test -f 'xlisp.h.add' -a X"$1" != X"-c"; then echo 'x - skipping xlisp.h.add (File already exists)' else echo 'x - extracting xlisp.h.add (Text)' sed 's/^X//' << 'SHAR_EOF' > 'xlisp.h.add' && X X X #define UNIX X /* for BSD & SYSV Unix. */ #ifdef UNIX #define BSD #define NNODES 2000 #define AFMT "%lx" #define OFFTYPE long #define SAVERESTORE #define SEEK_SET 0 #define SEEK_CUR 1 #define SEEK_END 2 /* #define memcpy(src,dest,length) bcopy(src,dest,length) */ #endif X SHAR_EOF chmod 0600 xlisp.h.add || echo 'restore of xlisp.h.add failed' Wc_c="`wc -c < 'xlisp.h.add'`" test 377 -eq "$Wc_c" || echo 'xlisp.h.add: original size 377, current size' "$Wc_c" fi # ============= init.lsp ============== if test -f 'init.lsp' -a X"$1" != X"-c"; then echo 'x - skipping init.lsp (File already exists)' else echo 'x - extracting init.lsp (Text)' sed 's/^X//' << 'SHAR_EOF' > 'init.lsp' && ; initialization file for XLISP 2.0 X X ; (mapcan fun list [ list ]...) (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args))) X ; (mapcon fun list [ list ]...) (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args))) X ; (set-macro-character ch fun [ tflag ]) (defun set-macro-character (ch fun &optional tflag) X (setf (aref *readtable* (char-int ch)) X (cons (if tflag :tmacro :nmacro) fun)) X t) X ; (get-macro-character ch) (defun get-macro-character (ch) X (if (consp (aref *readtable* (char-int ch))) X (cdr (aref *readtable* (char-int ch))) X nil)) X ; (savefun fun) - save a function definition to a file (defmacro savefun (fun) X `(let* ((fname (strcat (symbol-name ',fun) ".lsp")) X (fval (get-lambda-expression (symbol-function ',fun))) X (fp (open fname :direction :output))) X (cond (fp (print (cons (if (eq (car fval) 'lambda) X 'defun X 'defmacro) X (cons ',fun (cdr fval))) fp) X (close fp) X fname) X (t nil)))) X ; (debug) - enable debug breaks (defun debug () X (setq *breakenable* t)) X ; (nodebug) - disable debug breaks (defun nodebug () X (setq *breakenable* nil)) X ; initialize to enable breaks but no trace back (setq *breakenable* t) (setq *tracenable* nil) X ; print message when garbage collecting ;(setq *gc-flag* t) X X (defvar *editor* "vi") ; pick your own editor, make sure its in yer path. ; function to call up an editor (defun ed (&optional file) X (if (not (null file)) X (if (not (search ".lsp" file)) X (setq file (strcat file ".lsp")))) X X (let ((ed-command *editor*)) X (if (not (null file)) X (setq ed-command (strcat *editor* " " file))) X (system ed-command)) X X (if (not (null file)) ; load the changed file after we are done. X (load file)) X ) X SHAR_EOF chmod 0600 init.lsp || echo 'restore of init.lsp failed' Wc_c="`wc -c < 'init.lsp'`" test 1906 -eq "$Wc_c" || echo 'init.lsp: original size 1906, current size' "$Wc_c" fi exit 0 -- Ken Whedbee Internet: kcw@beach.cis.ufl.edu University of Florida UUCP: ..!uflorida!beach.cis.ufl.edu!kcw "C Code. C code run. Run, code, run... PLEASE!!!" -- Barbara Toungue