/*
 * Pilot for CP/M 
 *
 *	Len Edmondson
 *
 *	Morrow Designs
 *	    1982
 */

#include <stdio.h>

#define	CPMSYS	YES	/* we're running under CPM */

/*
 * CP/M version numbers
 */

#define CPM22	(0x22)
#define CPMPLUS (0x31)


/*
 * CP/M system call numbers
 */

#define C_VERSION 12
#define C_BIOS 50


#define CURDRIVE	25	/* CP/M system call number */
#define SUBBIT		(1 << 7)
#define RUNPILOT "\ra:pilot\r"


#define NEWLINE	'\n'
#define RETURN		'\r'
#define FACTOR	2000		/* for a 1 second delay */
#define CPUTC	2
#define LIST	5
#define CGETC  1
#define CREADY 11
#define SUB	"A:$$$.SUB"
#define STATE	"A:XSTATEX.PIL"
#define STATES	"XSTATEX PIL"
#define BINARY 1
#define ABSOLUTE 0
#define STACKSIZE (BUFSIZE / 2)
#define RECSIZE 128
#define SUBSIZE 128
#define BLANK	' '
#define ESC	033
#define RUB	0177
#define CTLX	24		/* control x char */
#define CTLZ	26

#define TYPE		0
#define TNR		1
#define PR		2
#define ACCEPT		3
#define INMAX		4
#define MATCH		5
#define MATCHC		6
#define JUMP		7
#define USE		8
#define RET		9
#define EXIT		10
#define BELL		11
#define COMPUTE	12
#define ALERT		13
#define REMARK		14
#define RESET		15
#define DEFINE		16
#define ESCAPE		17
#define WAIT		18
#define SAVE		19
#define HOLD		20
#define COMPILE	21
#define CLRS		22
#define CURSOR		23
#define LINEFEED	24
#define LOAD		25
#define CALL		26
#define CHAIN		27
#define CPM		28
#define OUT		29
#define INSTALL	30
#define EXIST		32
#define EI		33
#define DI		34
#define ERASTR		35
#define CASE		36


/*
 * Note: this stuff is for the Morrow Decision
 * only.
 * The program should properly automatically determine
 * whether or not the specific qualities of the Morrow
 * Micro Decision's BIOS are present.
 * values for "code" in the xlt structure
 *
 * The object of such system specific stuff
 * is to speed up the chaining process.
 */


#define MEMSUB		0xfd	/* In- memory submit buffer */
#define TRANTAB	0xfe	/* This is the char translate tab. */
#define ENDTAB		0xff	/* This is the end of the table */

/*
 * Micro Decision BIOS label addresses
 */

#define RAMDATY	0x42

/*
 * structure for CPMPLUS BDOS function 50: Direct bios call
 *
 * From CP/M+ Programmer's manual, page 3-72
 */

struct bios
	{
	char func;
	char a;
	int bc;
	int de;
	int hl;
	};


struct xlt
	{
	unsigned char code;
	unsigned int length;
	};



struct label
	{
	char *name;
	long location;
	};

struct string
	{
	char	*name,
		*data;
	};

struct number
	{
	char	*name;
	int	value;
	};

#define FIRST		17	/* search for first */
#define NEXT		18	/* search for next */
#define SETDMA		26	/* set dma address */

struct fcb
	{
	UTINY	dr,
		
		name [8],
		type [3],

		ex,

		s1,
		s2;

	UTINY	rc,

		dn [4];


	UCOUNT	inumber;
	UCOUNT	device;
	UTINY	ro;			/* read only */
	TINY	fd;			/* file descriptor */

	UCOUNT	nrec;			/* no. of recs in the file */
	UCOUNT	nexts;			/* no. of extents */
	UCOUNT	currec;			/* current record number */
					/* currec of 0 indicates uncertainty */

	UTINY	cr,		/* filled in by the user */
			/* current record to read or write in a sequential 
				file operation */
			/* normally set to zero by the user */

		rand  [3];
	};

struct inst
	{
	char	type,
		*token;
	};

char	*logo = "Pilot - L. W. Edmondson - Morrow Designs - 1982",
	escenable = YES,
	*esclabel = NULL,
	*scriptname = NULL,
	yflag = YES,
	*readstring (),
	ibuf [BUFSIZE] = {0};	/* input buffer */

int	nlabels = 0,		/* no. of labels in the table */
	length = 0,		/* length of the current line */
	nnumbers = 0,
	nstrings = 0;

unsigned 
	inmax = 80;

long	*sp = NULL,
	pc = 0,
	stack [STACKSIZE] = {0},
	atol (),
	looklabel ();

FILE	*fd = NULL;

struct label *label = NULL;

struct number *number = NULL;

struct string *string = NULL;

struct inst inst [] 
	=
	{
	TYPE,		"T",
	TYPE,		"",
	TNR,		"TNR",
	PR,		"PR",
	ACCEPT,	        "A",
	INMAX,		"INMAX",
	MATCH,		"M",
	MATCHC,		"MC",
	JUMP,		"J",
	USE,		"U",
	RET,		"E"
	EXIT,		"END",
	COMPUTE,	"C",
	REMARK,		"R",
	ALERT,		"BELL",
	ERASTR,		"ERASTR",
	DEFINE,		"DEF",
	ESCAPE,		"ESC",
	WAIT,		"WAIT",
	SAVE,		"SAVE",
	HOLD,		"HOLD",
	COMPILE,	"COMPILE",
	CLRS		"CLRS",
	CURSOR,		"CUR",
	LINEFEED,	"LF",
	LOAD,		"LOAD",
	CALL,		"CALL",
	CHAIN,		"CH",
	CPM,		"CPM",
	OUT,		"OUT",
	INSTALL,	"INSTALL",
	EXIST,		"EXIST",
	EI,		"EI",
	DI,		"DI",
	CASE,		"CASE",
	NULL,		NULL,
	};


ring ()
	{
	}

main (ac, av)
	char **av;
	{
	if (ac <= 1)	/* no args */
		{
		if (!restorestate ())
			{
			exit (NO);
			}
		}
	else
		{
		plogo ();
		newscript (av[1]);
		}

	pilot ();

	return YES;
	}

pilot (a)
	register char *a;
	{
	char buf [BUFSIZE];

	for (;;)
		{
		fgets (buf, BUFSIZE, fd);

		if (feof (fd))
			break;

		clean (buf);

		length = lenstr (buf);
		pc += length;

		doline (buf);
		}
	}

doline (a)
	register char *a;
	{
	char word [BUFSIZE];
	static char *p, *t, cond, *z, *n;

/*
 * skip  initial blank space
 */

	p = skipbl (a);

	if (*p == '*')		/* label */
		{

/*
 * skip over label
 */

		p = skipword (p + 1);

/*
 * skip white space following label
 */

		p = skipbl (p);
		}


/*
 * now p should be pointing to the instruction
 */


/*
 * look for a colon (and also a left paren)
 */

	n = NULL;

	for (t = a; *t && *t != ':'; t++)
		{
		if (*t == '(' && !n)
			n = t + 1;

		if (*t == ')' && n)
			*t = NULL;
		}

	if (!*t)
		{
		return;	/* no colon */
		}

	t++;

/*
 * now t should be pointing to the text following the colon
 * now n should be either null or pointing to the numeric condition
 */


/*
 * check for a condition (Y or N)
 * find the last letter before the colon and a parenthesis
 * This will be the condition character
 */

	cond = NULL;


	for (z = p; *z && *z != ':' && *z != '('; z++)
		if (isalpha (*z))
			cond = *z;


/*
 * now z is pointing at the last character
 * of the instruction
 */

	cond = toupper (cond);

/*
 * test for inhibiting conditions
 */


	if (cond == 'Y' && !yflag)
		{
		return;
		}

	if (cond == 'N' && yflag)
		{
		return;
		}

	if (n && readnumber (n) <= 0)
		{
		return;
		}

	for (z = p; isalpha (*z); z++)	/* find end of command */
		;

	if (z == p)
		return;		/* no command */

	z--;

/*
 * now z is pointing to the last char of the command
 */

	*z = toupper (*z);	/* change to upper case */

	if (*z != 'Y' && *z != 'N')
		z++;

	*z = NULL;	/* null terminate the command */

	switch (lookup (p))
		{
		case CASE:
			{
			if (n)
				docase (readnumber (n), t);

			break;
			}

		case HOLD:
			{
			static char c;
	
			c = NULL;

			cgets (&c, 1, 0);

			c = toupper (c);

			if (c == 'R')
				jump (t);

			break;
			}

		case ACCEPT:	/* accept input data */
			{
			cgets (ibuf, inmax, 0);
			getword (t, word);

			if (*word == '$')
				setstring (word, ibuf);

			else if (*word == '#')
				setnumber (word, atoi (ibuf));

			break;
			}

		case WAIT:	/* wait only so long for input data */
			{
			static char *z;
			static delay;


			delay = 6;

			z = t;

			for (;;)
				{
				z = getword (z, word);

				if (!*word)
					break;

				if (numeric (word))
					{
					delay = atoi (word);

					if (delay)
						break;
					}
				}

			cgets (ibuf, inmax, delay);

			getword (t, word);
		
			if (*word == '$')
				setstring (word, ibuf);

			else if (*word == '#')
				setnumber (word, atoi (ibuf));

			break;
			}



		case ALERT:
			{
			cputc (7);
			break;
			}

		case USE:	/* Use command */
			{
			if (sp == stack + STACKSIZE - 1)
				{
				put ("Stack overflow\n");
				exit (NO);
				}

			*sp++ = pc;	/* save the pc */
			}

	/* fall into ... */

		case JUMP:	/* jump */
			{
			jump (t);
			break;
			}

		case CLRS:
			{
			cputc (26);
			break;
			}

		case COMPUTE:
			{
			compute (t);
			break;
			}

		case CURSOR:
			{
			docursor (t);
			break;
			}

		case DEFINE:		/* define */
				/*   D:   $variable string */
			{
			static char *z;

			z = getword (t, word);	/* string variable name */

			if (*z)		/* skip one space */
				z++;

			shorten (z);

			expand (z);

			setstring (word, z);

			break;
			}

		case DI:
			{
			escenable = NO;
			break;
			}

		case EI:
			{
			escenable = YES;
			break;
			}

		case ESCAPE:
			{
			free (esclabel);
			escenable = YES;

			getword (t, word);

			if (empty (word))
				esclabel = NULL;
			else
				esclabel = save (word);


			break;
			}

		case RESET: /* reset all numeric variables to zero */
			{
			reset ();
			break;
			}

		case ERASTR:
			{
			erastr (); /* erase all string variables */
			break;
			}

		case EXIT:
			{
			exit (YES);
			}
/*
 * file existence test
 */


		case EXIST:
			{
			expand (t);

			t = skipbl (t);


/*
 * now t should be pointing to the condition char
 */

			getblack (t, word);

			yflag = fexists (word);

			break;
			}

		case INMAX:
			{
			if (empty (t))
				inmax = 80;	/* def. value */
			else
				inmax = eval (t);

			break;
			}

		case LINEFEED:
			{
			static n;

			n = eval (t);

			while (n--)
				put ("\n");

			break;
			}

		case MATCH:	/* match */
			{
			match (t, ',');
			break;
			}

		case MATCHC:	/* match */
			{
			match (t, '^');
			break;
			}

		case CPM:
			{
			shorten (t);
			expand (t);
			docpm (t);
			break;
			}

		case CHAIN:	/* new script */
			{
			expand (t);

			getword (t, word);

			if (*word)	/* if theres a file name */
				newscript (word);

			break;
			}

		case RET:	/* return from subroutine */
			{
			if (sp == stack)
				{
				exit (YES);
				}
			else
				{
				pc = *--sp;

				fseek (fd, pc, ABSOLUTE);
				}

			break;
			}

		case SAVE:	/* save */
			{
			getword (t, word);

			setstring (word, ibuf);

			break;
			}

		case TNR:
			{
			shorten (t);
			}

		/* fall into ... */

		case TYPE:	/* type */
			{
			expand (t);
			put (t);
			break;
			}

		case PR:
			{
			expand (t);
			lists (t);
			break;
			}

		case REMARK:
			{
			break;
			}

		default:
			{
			lower (p);
			put (p);
			put (": Unrecognized instruction\n");
			exit (NO);
			}
		}
	}

	char *
skipbl (a)
	register char *a;
	{
	while (*a == BLANK || *a == '\t' || *a == NEWLINE)
		a++;

	return a;
	}

	char *
skipword (a)
	register char *a;
	{
	a = skipbl (a);

	while (isblack (*a))
		a++;

	return a;
	}

/*
 * send a string to the console
 */

put (a)
	register char *a;
	{
	for (; *a; a++)
		{
		static char c;

		c = *a;

		if (c == '{')
			{
			cputc (BLANK);
			cputc (ESC);
			cputc ('(');
			}

		else if (c == '}')
			{
			cputc (BLANK);
			cputc (ESC);
			cputc (')');
			}

		else if (c == NEWLINE)
			{
			cputc ('\r');
			cputc (NEWLINE);
			}

	else if (c == '^' && a[1] == '^' && ishex (a[2]) && ishex (a[3]))
			{
			c = a[4];
			a[4] = NULL;
			cputc (htoi (a + 2));
			a[4] = c;
			a += 3;
			}

		else
			{
			cputc (c);
			}
		}
	}

/*
 * send a single character to the CP/M console
 */

cputc (a)
	{
	cpm (CPUTC, a);
	}

	char *
getword (a, b)
	register char *a, *b;
	{
	a = skipbl (a);		/* skip leading blank space */

	if (*a == '@' || *a == '$' || *a == '*' || *a == '#')	/* string variable */
		{
		*b++ = *a++;	/* copy first char */

		goto word;
		}

	else if (isdigit (*a))
		{
		while (isdigit (*a))
			*b++ = *a++;
		}

	else if (isalpha (*a) || *a == '_') /* alphanumeric */
		{
		word:

		while (isalpha (*a) || isdigit (*a) || *a == '_')
			*b++ = *a++;
		}

	else if (*a)
		{
		*b++ = *a++;
		}

	*b = NULL;
	return a;
	}

newlabel (a, b)
	register char *a;
	long b;
	{
	struct label *l;

	if (*a == '*')
		a++;

	nlabels++;

	label = realloc (label, nlabels * sizeof *label);

	l = label + nlabels - 1;

	l->name = save (a);
	l->location = b;
	}

clearlabels ()
	{
	static i;

	for (i = 0; i < nlabels; i++)
		{
		free (label[i].name);
		}

	nlabels = 0;
	}


findlabels ()
	{
	char buf [BUFSIZE], word [BUFSIZE];
	static char *p;
	long l;

	clearlabels ();		/* get rid of old labels */

	l = 0;		/* file offset */

	rewind (fd);

	for (;; l += lenstr (buf))
		{
		fgets (buf, BUFSIZE, fd);	/* read a line */

		if (feof (fd))			/* end of file ? */
			break;

		p = skipbl (buf);		/* skip initial space */

		if (*p != '*')
			continue;		/* no label here */

		getword (p, word);		/* snag the label */

		if (*word)
			newlabel (word, l);
		}

	rewind (fd);
	}

newscript (a)
	register char *a;
	{
	char buf [BUFSIZE], x;

	if (!element ('.', a))
		{
		cpystr (buf, a, ".pil", NULL); /* postfix .pil */
		a = buf;
		}

/*
 * close the old file if any
 */

	if (fd) 
		fclose (fd);

/*
 * try to open the new file
 */

	x = open (a, READ, BINARY);

	if (x < 0)
		{
		perror (a);
		exit (NO);
		}

	fd = fdopen (x, "read");

	free (scriptname);
	scriptname = save (a);
	
	sp = stack;	/* reset the stack */

	pc = 0;		/* reset the pc */

	free (esclabel);	/* reset the escape label */
	esclabel = NULL;

	findlabel ();	/* remake the label list */
	}

	long
looklabel (a)
	register char *a;
	{
	static struct label *l;

	if (*a == '*')
		a++;		/* bypass the leading asterisk */

	if (!*a)	
		{
		put ("Missing label\n");
		exit (NO);
		}

	for (l = label; l < & label [nlabels]; l++)
		if (ulcmp (a, l->name))
			return l->location;

	put (a);
	put (": Label not found\n");
	exit (NO);
	}

/*
 * set the string variable "a" to have value "b"
 */

setstring (a, b)
	register char *a, *b;
	{
	static char *p;
	static struct string *s;

	if (*a == '$')
		a++;		/* skip over string variable pref. */

	if (*a == '(')
		{
		a++;

		p = a + lenstr (a) - 1;

		if (*p == ')')
			*p = NULL;
		}

	if (!*a)		/* no variable name */
		return;

	for (s = string; s < &string [nstrings]; s++)
		{
		if (ulcmp (a, s->name))
			{
			free (s->data);
			s->data = save (b);
			return;
			}
		}

/*
 * wasn't there, expand the string table
 */

	nstrings++;

	string = realloc (string, nstrings * sizeof *string);

	s = string + nstrings - 1;

	s->name = save (a);
	s->data = save (b);
	}

/*
 * set the numeric variable "a" to have value "b"
 */

setnumber (a, b)
	register char *a;
	int b;
	{
	static struct number *n;

	if (*a == '#')
		a = skipbl (a + 1);	/* skip over string variable pref. */

	if (!*a)		/* no variable name */
		return;

	for (n = number; n < &number [nnumbers]; n++)
		{
		if (ulcmp (a, n->name))
			{
			n->value = b;
			return;
			}
		}

/*
 * wasn't there, expand the string table
 */

	nnumbers++;

	number = realloc (number, nnumbers * sizeof *number);

	n = number + nnumbers - 1;

	n->name = save (a);
	n->value = b;
	}

/*
 * return the value of a string variable
 */

	char *
readstring (a)
	register char *a;
	{
	static char *p;
	static struct string *s;

	if (*a == '$')
		a++;

	if (*a == '(')
		{
		a++;

		p = a + lenstr (a) - 1;

		if (*p == ')')
			*p = NULL;
		}

	for (s = string; s < &string [nstrings]; s++)
		if (ulcmp (a, s->name))
			return s->data;

	return a;	/* not defined yet */
	}

/*
 * return the value of a string variable
 */

readnumber (a)
	register char *a;
	{
	static char *p;
	static struct number *n;

	if (*a == '#')
		a++;

	for (n = number; n < &number [nnumbers]; n++)
		if (ulcmp (a, n->name))
			return n->value;

	return NULL;	/* not defined yet */
	}

/*
 * string comparison ignoring case
 */

ulcmp (a, b)
	register char *a, *b;
	{
	static char x, y;

	for (;; a++, b++)
		{
		x = *a; 
		y = *b;

		x = tolower (x);
		y = tolower (y);

		if (x != y)
			return NO;

		if (!x)
			return YES;
		}
	}

empty (a)
	register char *a;
	{
	for (; *a; a++)
		if (!iswhite (*a))
			return NO;

	return YES;
	}

/*
 * is `a' a substring of `b'?
 */

substring (a, b)
	register char *a, *b;
	{
	static char *p, *q;

	if (!*a)
		return NO;

	for (; *b; b++)
		{
		for (p = a, q = b;; p++, q++)
			{
			static char x, y;

			if (!*p)
				{
				return YES;
				}

			x = *p;
			y = *q;

			x = tolower (x);
			y = tolower (y);

			if (x != y)	
				break;
			}
		}

	return NO;
	}

	char *
save (a)
	char *a;
	{
	char *b;




	b = alloc (lenstr (a) + 1);

	cpystr (b, a, NULL);

	return b;
	}

expand (a)
	register char *a;
	{
	char buf [BUFSIZE], word [BUFSIZE];
	static char *p, *q, *per;

/*
 * scan for interesting characters
 */

	for (p = a; *p; p++)
		if (*p == '$' || *p == '#' || *p == '`')
			break;

	if (*p == NULL)
		return;		/* found no interesting characters */

	p = buf;

	q = a;

	per = NULL;

	for (;;)
		{
		if (*q == NULL)
			{
			break;		/* all done */
			}

/*
 * we've encountered a string variable
 */

		else if (*q == '$')
			{
			if (q[1] == '$')
				{
				*p++ = '$';
				q += 2;
				}

			else
				{
				q = getword (q, word);
				p = cpystr (p, readstring (word), NULL);
				}
			}

		else if (*q == '#')
			{
			if (q[1] == '#')
				{
				*p++ = '#';
				q += 2;
				}

			else
				{
				q = getword (q, word);
				p = cpystr (p, itoa (readnumber (word)), NULL);
				}
			}

		else if (*q == '`')	/* suffix elimination */
			{
			if (q[1] == '`')
				{
				*p++ = '`';
				q += 2;
				}

			else
				{
				if (per)
					p = per;

				q++;		/* skip the grave */
				per = NULL;
				}
			}

		else if (*q == '.')	/* mark the spot of a period */
			{
			per = q;
			*p++ = *q++;	/* copy it too */
			}

		else
			{
			*p++ = *q++;
			}
		}
		
	*p = NULL;

	cpystr (a, buf, NULL);		/* replace original string */
	}

numeric (a)
	register char *a;
	{
	if (!*a)
		return NO;


	for (; *a; a++)
		if (!isdigit (*a))
			return NO;

	return YES;
	}

	char *
itoa (a)
	{
	static char buf [16];

	buf [itob (buf, a, -10)] = NULL;
	return buf;
	}

perror (a)
	{
	put (a);
	put (": can't access\n");
	}

lookup (a)
	char *a;
	{
	struct inst *i;

	for (i = inst; i->token; i++)
		if (ulcmp (a, i->token))
			return i->type;

	return -1;
	}

/*
 * file exists if its openable
 */

fexists (a)
	{
	char f;


#ifdef CPMSYS
	char firstbuf [RECSIZE];
	struct fcb fcb;

	global (a, &fcb);

	cpm (SETDMA, firstbuf);
	f = cpm (FIRST, &fcb);

	return 0 <= f && f <= 3;

#else
	f = open (a, READ, BINARY);

	if (f < 0)
		{
		return NO;
		}

	else
		{
		close (f);
		return YES;
		}
#endif
	}

docpm (a)
	char *a;
	{


/*
 * try the in-memory submit first
 * If that fails, use the disk submit
 */

	if (!memsub (a))
		disksub (a);

	savestate ();

	exit (YES);
	}

/*
 * build a submit file 
 * and then exit
 */

disksub (a)
	char *a;
	{
	static char *b;

	if (empty (a))
		return;

	subline ("a:pilot");

/*
 * move b to the end of the string
 */

	b = a + lenstr (a);

	for (;;)
		{
/*
 * now back b up to the beginning of the last command
 * in the line
 */
 
		while (a <= b && *b != ';' && *b != '|')
			b--;

		subline (b + 1);

		if (a > b)
			break;	/* we've hit the beginning of the line */

		*b-- = NULL;	/* punch out the semicolon and back up */
		}
	}

subline (a)
	{
	static char f = -1;
	char buf [RECSIZE];

	if (f < 0)
		{
		f = create (SUB, WRITE, BINARY);

		if (f < 0)
			{
			perror (SUB);
			exit (NO);
			}
		}

	*buf = lenstr (a);
	cpybuf (buf + 1, a, RECSIZE - 1);
	write (f, buf, RECSIZE);
	}

compute (a)
	register char *a;
	{
	char word [BUFSIZE], product [BUFSIZE], flag;
	static int sum, term;

	a = getword (a, product);

	flag = '+';
	sum = 0;

	for (;;)
		{
		a = getword (a, word);

		if (!*word)
			{
			break;
			}

		else if (cmpstr (word, "="))
			{
			continue;
			}

		else if (cmpstr (word, "+"))
			{
			flag = '+';
			continue;
			}

		else if (cmpstr (word, "-"))
			{
			flag = '-';
			continue;
			}

		else if (numeric (word))
			{
			term = atoi (word);
			}

		else if (*word == '$')	/* string variable */
			{
			term = atoi (readstring (word));
			}

		else if (*word == '@')
			{
			term = * (char *) atoi (word + 1);
			}

		else 		/* numeric variable */
			{
			term = readnumber (word);
			}

		if (flag == '+')
			sum += term;
		else
			sum -= term;
		}

	setnumber (product, sum);
	}

erastr (a)
	{
	static struct string *s;

	for (s = string; s < &string [nstrings]; s++)
		{
		free (s->name);
		free (s->data);
		}

	nstrings = 0;
	}

docursor (a)
	register char *a;
	{
	static char column, row;

	column = eval (a);

	while (*a && *a != ',')
		a++;

	if (*a)
		a++;		/* skip over the comma */

	row = eval (a);

/*
 * generate a cursor addressing sequence for ADM3a terminal
 */

	cputc (ESC);
	cputc ('=');

	column += ' ';
	row += ' ';

	cputc (row);
	cputc (column);
	}

/*
 * do an output instr.
 */

doout (a)
	register char *a;
	{
	static char addr, data;

	data = htoi (a);

	while (*a && *a != ',')
		a++;

	if (*a)
		a++;

	addr = htoi (a);

	out (addr, data);
	}

/*
 * hex representation
 */

htoi (a)
	register char *a;
	{
	static b;

	btoi (a, lenstr (a), &b, 16);
	return b;
	}

eval (a)
	register char *a;
	{
	char buf [BUFSIZE];

	getword (a, buf);

	a = buf;

	if (isdigit (*a))
		return atoi (a);

	else
		return readnumber (a);
	}

/*
 * get a string from cpm
 * a is the address
 * b is the max number of chars
 * d is the delay flag
 */

cgets (a, b, d)
	register char *a;
	register unsigned b;
	{
	static char *p, timed, c;
	long t;

	if (d)
		{
		timed = YES;

		t = d;

		t *= FACTOR;
		}
	else
		{
		timed = NO;	/* don't watch the clock */
		}

	p = a;

	for (;;)
		{
		if (!cready ()) /* no char ready yet */
			{
			if (timed)
				{
				if (!t)
					{
					cpybuf (a, "TIMEOUT", b);
					return;
					}
				else
					{
					t--;	/* decrement timing counter */
					}
				}

			continue;
			}

		timed = NO;	/* stop the clock */

		c = cgetc ();

		if (c == ESC)
			{
			p = a;
			doesc ();
			break;
			}

		else if (c == CTLX)
			{
			p = a;
			cputc ('\r');
			cputc (NEWLINE);
			}

		else if (c == '\b' || c == RUB)
			{
			if (p != a)
				p--;

			continue;
			}

		else if (c == NEWLINE || c == '\r')
			{
			cputc (NEWLINE);
			break;
			}

		*p++ = c;
			
		if (p - a >= b)	/* full count */
			{
			break;
			}
		}

	*p = NULL;
	}

cgetc ()
	{
	return cpm (CGETC);
	}

cready ()
	{
	return cpm (CREADY);
	}

jump (t)
	char *t;
	{
	char word [BUFSIZE];



	getword (t, word);	/* pull the first word out of the input */



	pc = looklabel (word);	/* get its address */

	fseek (fd, pc, ABSOLUTE);
	}

doesc ()
	{
	if (!escenable)
		return;

	if (!esclabel)
		exit (NO);

	jump (esclabel);
	}

/* 
 * reset all numeric variables to zero
 */

reset ()
	{
	static struct number *n;

	for (n = number; n < &number [nnumbers]; n++)
		n->value = 0;
	}

lists (a)
	register char *a;
	{
	for (; *a; a++)
		listc (*a);
	}

listc (a)
	{
	cpm (LIST, a);
	}

match (t, b)
	register char *t, b;
	{
	char *patterns[BUFSIZE];
	static char **pat, *z;

	yflag = NO;	/* clear the test flag */

	pat = patterns;

/*
 * expand any string variables
 */

	expand (t);

/*
 * make a table of pointers to the patterns
 */

	shorten (t);

	for (z = t; *z;)
		{
		*pat++ = z;	/* save this spot */

		while (*z && *z != b)
			z++;	/* skip over field */

		if (*z == NULL)
			break;

		else if (*z == b)
			*z++ = NULL;	/* punch it out */

		}


	*pat = NULL;	/* null terminate the list of pats. */

/*
 * scan the list of patterns
 */

	for (pat = patterns; *pat; pat++)
		if (omatch (*pat, ibuf))
			yflag = YES;
	}

/*
 * Match a single pattern
 * a is the pattern
 * b is the text
 */

omatch (a, b)
	register char *a, *b;
	{
	char text [BUFSIZE];

	cpystr (text, " ", b, " ", NULL);

	b = text;

	single (a);
	single (b);

/* 
 * match pattern of all spaces
 * should match only missing inputs
 */


	if (empty (a))
		return empty (b);

	return substring (a, b);
	}

/*
 * reduce white space to a single space char
 */

single (a)
	char *a;
	{
	static char *from, *to;

	from = a;
	to = a;

	while (*from)
		{
		if (from [0] == BLANK && from [1] == BLANK)
			from++;

		else
			*to++ = *from++;
		}

	*to = NULL;
	}

ishex (a)
	{
	return element (a, "0123456789abcdefABCDEF");
	}

/*
 * the case statement
 *
 *	CASE(A) : label1, label2, label3, ...
 *
 *
 *	if a is 1, jump to label1
 */

docase (a, b)
	int a;
	register char *b;
	{
	static char *p;

	if (a <= 0)	
		return;	 /* numberic var. out of range */
			
/*
 * found the Nth label in the list
 */

	p = b;
	a--;		/* switch to zero origin */

	while (a)
		{
/*
 * skip one label
 */

		while (*p && *p != ',')
			p++;	/* find next comma */

		if (*p)
			p++;	/* skip comma */
		else
			break;	/* ran into the end */

		a--;
		}
	
	if (a)
		return;	/* var. out of range - too few labels */

	for (; *b; b++)
		if (*b == ',')
			*b = NULL;

	jump (p);
	}

/*
 * this is a valid char for a string variable
 */

isstring (a)
	char a;
	{
	return isalpha (a) || a == '-';
	}

/*
 * this is a valid char for a string variable
 */

isnumber (a)
	char a;
	{
	return isalpha (a) || a == '_';
	}

clean (a)
	register char *a;
	{
	for (; *a; a++)
		{
		*a &= 0177;

		if (*a == CTLZ)
			*a = NULL;
		}
	}

shorten (a)
	register char *a;
	{
	for (; *a; a++)
		{
		if (*a == NEWLINE || *a == RETURN)
			{
			*a = NULL;
			break;
			}
		}
	}

savestate ()
	{
	static struct string *s;
	static struct number *n;
	static struct label *l;
	static long *st;
	static FILE *f;
	static int cuser;

	cuser = user(0xff);
	user (0);
	f = fopen (STATE, "write");

	if (f == NULL)
		{
		user (cuser);
		perror (STATE);
		return;
		}

/*
 * string variables
 */

	for (s = string; s < &string[nstrings]; s++)
		{
		fputs ("$",     f);
		fputs (s->name, f);
		fputs (" ",     f);
		fputs (s->data, f);
		fputs ("\n",    f);
		}

	for (n = number; n < &number[nnumbers]; n++)
		{
		fputs ("#",             f);
		fputs (n->name,         f);
		fputs (" ",             f);
		fputs (itoa (n->value), f);
		fputs ("\n",            f);
		}

/*
 * the labels
 */

	for (l = label; l < &label[nlabels]; l++)
		{
		fputs ("*",                f);
		fputs (l->name,            f);
		fputs (" ",                f);
		fputs (ltoa (l->location), f);
		fputs ("\n",               f);
		}

/*
 * the stack 
 */

	fputs ("^", f);

	for (st = stack; st < sp; st++)
		{
		fputs (ltoa (*st), f);
		fputs (" ",        f);
		}

	fputs ("\n", f);

/*
 * the  pc
 */

	fputs (".",       f);
	fputs (ltoa (pc), f);
	fputs ("\n",      f);

/*
 * the escape label
 */

	if (esclabel)
		{
		fputs (":",      f);
		fputs (esclabel, f);
		fputs ("\n",     f);
		}

/*
 * the flag
 */

	if (yflag)
		fputs ("+\n", f);
	else
		fputs ("-\n", f);

/*
 * the script name
 */

	fputs (">",        f);
	fputs (scriptname, f);
	fputs ("\n",       f);

	fclose (f);
	sysfile ();
	user (cuser);
	}

restorestate ()
	{
	static char *t, x;
	static FILE *f;
	char buf [BUFSIZE], word [BUFSIZE];
	static int cuser;

	f = fopen (STATE, "read");

	if (f == NULL)
		return NO;

	for (;;)
		{
		fgets (buf, BUFSIZE, f);

		if (feof (f))
			break;

		shorten (buf);

		t = buf;

		switch (*t)
			{
			case '*':	/* label */
				{
				t = getword (t, word);
				newlabel (word, atol (t));
				break;
				}

			case '$':
				{
				t = getword (t, word);
				setstring (word, t + 1);
				break;
				}

			case '#':
				{
				t = getword (t, word);
				setnumber (word, atoi (t));
				break;
				}

			case '.':	/* pc */
				{
				pc = atol (t + 1);
				break;
				}

			case '>':	/* scriptname */
				{
				free (scriptname);
				scriptname = save (t + 1);
				break;
				}

			case ':':
				{
				esclabel = save (t + 1);
				break;
				}

			case '+':
				{
				yflag = YES;
				break;
				}
			
			case '-':
				{
				yflag = NO;
				break;
				}

			case '^':	/* stack */
				{
				t++;
				sp = stack;

				for (;;)
					{
					t = getword (t, word);

					if (!*word)
						break;

					*sp++ = atol (word);
					}

				break;
				}
			}
		}

	if (!scriptname)
		return NO;

	x = open (scriptname, READ, BINARY);

	if (x < 0)
		{
		perror (scriptname);
		return NO;
		}

	if (fd)
		fclose (fd);

	fd = fdopen (x, "read");

	if (fd == NULL)
		return NO;

	fseek (fd, pc, ABSOLUTE);
	fclose (f);
	cuser = user(0xff);
	user (0);
	remove (STATE);
	user (cuser);

	return YES;
	}

/*
 * convert long to ascii decimal representation
 */

	char *
ltoa (a)
	long a;
	{
	static char buf [20];

	buf [ltob (buf, a, 10)] = NULL;
	return buf;
	}

plogo ()
	{
	put ("Micro-Decision Pilot Rev. 5.1\nCopyright 1984 Morrow Designs, Inc.\n\n");
	}

getblack (a, b)
	register char *a, *b;
	{
	a = skipbl (a);

	while (isblack (*a))
		*b++ = *a++;

	*b = NULL;
	return a;
	}

/*
 * memsub - Morrow Designs BIOS special
 *		time saving all in memory submit
 */

memsub (a)
	char *a;
	{
	static char *p, tran, n;
	static unsigned space, need, *i;
	static struct xlt *x, *new, *t;
	char md11;

# define INJECTIMS 0xb

	if (cpm (C_VERSION) >= CPMPLUS)
		{
		char buf [SUBSIZE];
		struct bios b;

/*		cpystr (buf + 1, a, RUNPILOT, NULL);
*/
		*buf = lenstr (a) + lenstr (RUNPILOT);
		memlayin (a, buf+1);

		b.func = 0;
		b.a = INJECTIMS;
		b.de = buf;


		cpm (C_BIOS, &b);

		return YES;
		}

/*
 * find the address of the memory translation tables (if any)
 */


	i = 1;		/* address of primary BIOS jump */

	i = *i - 3 + 0x46	/* address of table pointer */
	  + ((cpm (C_VERSION) > CPM22) ? 0x30 : 0);

	t = *i;		/* address of table */


	if (t < i)
		return NO;	/* table must be further up in memory */


	x = t;		/* x will walk the table */

	if (x->code != 0)
		return NO;

/*
 * tran is a verification flag.
 * we should encounter a structure marked
 * as the character translation tables.
 * If we don't, then this probably isn't
 * a Morrow Designs environment
 */

	tran = NO;

	for (n = 20; n; n--)	/* at most 20 steps */
		{
		if (x->code == TRANTAB)
			{
			tran = YES;	/* just note the presence */
			}

		if (x->code == ENDTAB)
			{
			break;		/* found what we were looking for */
			}

		x = (char *) x + x->length + sizeof *x;
		
		if (x < t)	/* out of range */
			{	
			return NO;	/* not a Morrow BIOS */
			}
		}


	if (!n)
		{
		return NO;
		}


	if (tran == NO)	/* failed to encounter a char tran tab. */
		{
		return NO;	
		}

	space = x->length;

	new = (char *) x + x->length + sizeof *x;

/*
 * if there's already an in memory submit buffer
 * present, add in the space it's holding
 * otherwise, make space for a new structure.
 * use all available space.
 */

	if (new->code == MEMSUB)	
		{
		space += new->length;
		}

	else			/* old BIOS version */
		{
		return NO;
		}

	need = lenstr (a) + lenstr (RUNPILOT);

	if (space < need)
		{
		return NO;		/* won't fit in memory */
		}


/*
 * allow for what we're going to use up
 */

	space -= need;

	x->length = space;

	new = (char *) x + sizeof *x + space;

/*
 * build the new structure
 */

	new->code = MEMSUB;
	new->length = need;

	memlayin (a, (char *) new + sizeof *new);


	i = 1;

	i = *i - 3 + 0x42;


	if (* (( * (char **) 1) - 3 + 0x3f) >= 0x40)
		p = *i + 18;
	else
		p = *i + 11;

	*p |= SUBBIT;

	return YES;
	}


memlayin (a, b)
	register char *a, *b;
	{

	for (; *a; a++, b++)
		{
		if (*a == ';')
			*b = '\r';

		else if (*a == '|')
			*b = '\r' | (1 << 7);

		else 
			*b = *a;
		}

	cpybuf (b, RUNPILOT, lenstr (RUNPILOT));
	}

lower (a)
	register char *a;
	{
	for (; *a; a++)
		*a = tolower (*a);
	}


/*
 * transform a string like A:*.*
 * into an appropriate fcb for use with "search/next"
 */

global (a, b)
	TEXT *a;
	FAST struct fcb *b;
	{
	INTERN UTINY i;

	raise (a);

	if (isalpha (*a) && a[1] == ':')
		{
		b->dr = *a - 'A' + 1;
		a += 2;
		}
	else
		{
		b->dr = 0;	/* current drive */
		}

	b->ex = 0;		/* first extent only */

	if (!*a)
		{
		fill (b->name, 11, '?');
		return;
		}

/*
 * start off with all spaces
 */

	fill (b->name, 11, ' ');

/*
 * fill in b->name
 */
	for (i = 0; i < 8; i++)
		{
		if (*a == '*')
			{
			fill (&b->name [i], 8 - i, '?');
			a++;
			break;
			}

		if (*a == '.')
			{
			a++;
			break;
			}

		if (!*a)
			return;

		b->name[i] = toupper (*a);
		a++;
		}

	if (*a == '.')
		a++;

	for (i = 0; i < 3; i++)
		{
		if (!*a)
			return;

		if (*a == '*')
			{
			fill (&b->type[i], 3 - i, '?');
			return;
			}

		b->type[i] = toupper (*a);
		a++;
		}
	}

raise (a)
	char *a;
	{
	for (; *a; a++)
		*a = toupper (*a);
	}

#ifdef CPMSYS

stat ()
	{
	return -1;
	}

#endif

# define USERFUN 32 /* Function Call for BDOS */

user (a)
	int a;
	{
	int b;

	b = cpm(USERFUN, a);
	return b;
	}

# define SETSYS 0x1e

sysfile ()
	{
	int i;
	struct fcb f;
	unsigned char *a = STATES;

	for (i = 0; f.name[i] = a[i]; i++)
		;
	f.type[1] = (f.type[1] | 0x80);
	f.dr = 0;

	cpm (SETSYS, &f);

	}