/* msstuff.c - ms-dos specific routines */
#include <stdlib.h>
#include <signal.h>
#include "xlisp.h"
#include "xmath.h"
#include "version.h"
#define LBSIZE 200
/* set the size for the overlay buffer */
unsigned _ovrbuffer = 0x1800;
/* external variables */
extern LVAL s_unbound,true;
extern FILEP tfp;
extern int errno;
/* make sure we get a large stack */
int _stklen = 32766;
/* local variables */
static char lbuf[LBSIZE];
static int lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;
static long rseed = 1L;
static void errcatch(int);
/* osinit - initialize */
osinit(banner)
char *banner;
{
printf("%s\n",banner);
printf("XLISP-STAT Release %d.%d.%d%s.\n",
XLS_MAJOR_RELEASE, XLS_MINOR_RELEASE, XLS_SUBMINOR_RELEASE,
XLS_RELEASE_STATUS);
printf("Copyright (c) 1989-1999, by Luke Tierney.\n");
printf("Trimmed-down DOS Version");
if (! _OvrInitEms(0, 0, 0))
printf(" -- using extenden memory for swapping.\n");
else if (! _OvrInitExt(0L, 0L))
printf(" -- using expanded memory for swapping.\n");
else
printf(" -- no extra memory for swapping.\n");
printf("Initialization may take a moment.\n\n");
lposition = 0;
lindex = 0;
lcount = 0;
signal(SIGABRT, errcatch);
signal(SIGFPE, errcatch);
signal(SIGILL, errcatch);
signal(SIGSEGV, errcatch);
}
/* osfinish - clean up before returning to the operating system */
osfinish()
{
}
/* oserror - print an error message */
xoserror(msg)
char *msg;
{
printf("error: %s\n",msg);
}
# ifdef XLISP_ONLY
/* osrand - return a random number between 0 and n-1 */
int osrand(n)
int n;
{
long k1;
/* make sure we don't get stuck at zero */
if (rseed == 0L) rseed = 1L;
/* algorithm taken from Dr. Dobbs Journal, November 1985, page 91 */
k1 = rseed / 127773L;
if ((rseed = 16807L * (rseed - k1 * 127773L) - k1 * 2836L) < 0L)
rseed += 2147483647L;
/* return a random number between 0 and n-1 */
return ((int)(rseed % (long)n));
}
#endif /* XLISP_ONLY */
/* osaopen - open an ascii file */
FILE *osaopen(name,mode)
char *name,*mode;
{
return (fopen(name,mode));
}
/* osbopen - open a binary file */
FILE *osbopen(name,mode)
char *name,*mode;
{
char bmode[10];
strcpy(bmode,mode); strcat(bmode,"b");
return (fopen(name,bmode));
}
/* osclose - close a file */
int osclose(fp)
FILE *fp;
{
return (fclose(fp));
}
/* osagetc - get a character from an ascii file */
int osagetc(fp)
FILE *fp;
{
return (getc(fp));
}
/* osaputc - put a character to an ascii file */
int osaputc(ch,fp)
int ch; FILE *fp;
{
return (putc(ch,fp));
}
/* osbgetc - get a character from a binary file */
int osbgetc(fp)
FILE *fp;
{
return (getc(fp));
}
/* osbputc - put a character to a binary file */
int osbputc(ch,fp)
int ch; FILE *fp;
{
return (putc(ch,fp));
}
/* ostgetc - get a character from the terminal */
int ostgetc()
{
int ch;
/* check for a buffered character */
if (lcount--)
return (lbuf[lindex++]);
/* get an input line */
for (lcount = 0; ; )
switch (ch = xgetc()) {
case '\r':
lbuf[lcount++] = '\n';
xputc('\r'); xputc('\n'); lposition = 0;
if (tfp!=CLOSED) OSWRITE(lbuf,1,lcount,tfp);
lindex = 0; lcount--;
return (lbuf[lindex++]);
case '\010':
case '\177':
if (lcount) {
lcount--;
while (lposition > lpos[lcount]) {
xputc('\010'); xputc(' '); xputc('\010');
lposition--;
}
}
break;
case '\032':
xflush();
return (EOF);
default:
if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
lbuf[lcount] = ch;
lpos[lcount] = lposition;
if (ch == '\t')
do {
xputc(' ');
} while (++lposition & 7);
else {
xputc(ch); lposition++;
}
lcount++;
}
else {
xflush();
switch (ch) {
case '\003': xlsigint(); /* control-c */
case '\007': xlcleanup(); /* control-g */
case '\020': xlcontinue(); /* control-p */
case '\032': return (EOF); /* control-z */
default: return (ch);
}
}
}
}
/* ostputc - put a character to the terminal */
ostputc(ch)
int ch;
{
/* check for control characters */
oscheck();
/* output the character */
if (ch == '\n') {
xputc('\r'); xputc('\n');
lposition = 0;
}
else {
xputc(ch);
lposition++;
}
/* output the character to the transcript file */
if (tfp != CLOSED)
OSPUTC(ch,tfp);
}
/* osflush - flush the terminal input buffer */
osflush()
{
lindex = lcount = 0;
}
/* oscheck - check for control characters during execution */
oscheck()
{
int ch;
if (ch = xcheck())
switch (ch) {
case '\002': /* control-b */
xflush();
xlbreak("BREAK",s_unbound);
break;
case '\003': /* control-c */
xflush();
xlsigint();
break;
case '\024': /* control-t */
xinfo();
break;
}
}
ossymbols()
{
statsymbols();
}
osfinit()
{
statfinit();
}
/* xinfo - show information on control-t */
static xinfo()
{
extern int nfree,gccalls;
extern long total;
char buf[80];
sprintf(buf,"\n[ Free: %d, GC calls: %d, Total: %ld ]",
nfree,gccalls,total);
errputstr(buf);
}
/* xflush - flush the input line buffer and start a new line */
static xflush()
{
osflush();
ostputc('\n');
}
/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
return (bdos(7) & 0xFF);
}
/* xputc - put a character to the terminal */
static xputc(ch)
int ch;
{
bdos(6,ch);
}
/* xcheck - check for a character */
static int xcheck()
{
return (bdos(6,0xFF));
}
/* xsystem - execute a system command */
LVAL xsystem()
{
char *cmd="COMMAND";
if (moreargs())
cmd = (char *)getstring(xlgastring());
xllastarg();
return (system(cmd) == 0 ? true : cvfixnum((FIXTYPE)errno));
}
/* xgetkey - get a key from the keyboard */
LVAL xgetkey()
{
xllastarg();
return (cvfixnum((FIXTYPE)xgetc()));
}
#ifdef max
#undef max
#endif
max(x, y)
int x, y;
{
return((x > y) ? x : y);
}
#ifdef min
#undef min
#endif
min(x, y)
int x, y;
{
return((x < y) ? x : y);
}
SysBeep(n)
int n;
{
n = n / 10;
do {
printf("\007");
} while (n-- > 0);
fflush(stdout);
}
#undef getenv
char *getdosenv(char *s)
{
return(getenv(s));
}
static void errcatch(int sig)
{
signal(sig, errcatch);
switch(sig) {
case SIGABRT: xlfail("Abnormal termination signal -- time to bail out");
case SIGFPE: xlfail("Floating point exception.");
case SIGILL: xlfail("Illegal instruction -- time to bail out");
case SIGSEGV: xlfail("Segment violation -- time to bail out");
default: xexit();
}
}
int cdecl matherr(struct exception *e) { return(1); }
int renamebackup(name) char *name; { return(TRUE); }
/* xgetwd - builtin function GET-WORKING-DIRECTORY */
LVAL xgetwd()
{
xllastarg();
if (! getcwd(buf, FNAMEMAX))
return NIL;
else
return cvstring(buf);
}
/* xsetwd - builtin function SET-WORKING-DIRECTORY */
LVAL xsetwd()
{
char *dir = getstring(xlgastring());
xllastarg();
if (chdir(dir))
return NIL;
else
return s_true;
}
syntax highlighted by Code2HTML, v. 0.9.1