{$ 990, WIDELIST, MAP }
{$ NO WARNINGS, NO ASSERTS, NO 72COL, GLOBALOPT }

program FOCAL;
{***********************************************************************
*
* FOCAL - FOCAL main procedure
*
* A FOCAL language interpreter
*
* Dave Pitts
*
*  FOCAL is language developed by Digital Equipment and is implemented
*  here in Pascal.
*  TO learn FOCAL syntax refer to DEC Programming Languages Handbook
*
***********************************************************************}

const

   EOL		= '|';			{ End of line - vert. bar }
   LINE_LEN	= 80;			{ Source line length }
   PLEN		= 132;			{ Print buffer length }
   PBEG		= 3;			{ Print buffer start }
   LOG_LUN      = 0;
   PROG_LUN     = 10;
   PRINT_LUN    = 11;

type

   BYTE		= 0..255;
   TWOCHAR	= packed array [1..2] of char;
   SLINE	= packed array [1..LINE_LEN] of char;
   STRING	= packed array [0..LINE_LEN] of char;
   TOKTYP	= integer;
   TOKVAL	= real;

   SYM_NODE_PTR	= ^SYM_NODE;
   SYM_NODE	= packed record		{ Symbol node }
      SYM_PTR	: SYM_NODE_PTR;
      SYMBOL	: TWOCHAR;
      INDEX	: integer;
      CVALU	: TOKVAL
      end;
 
   LINE_NODE_PTR	= ^LINE_NODE;
   LINE_NODE	= packed record		{ Line node }
      LINE_PTR	: LINE_NODE_PTR;
      LIN_TXT	: SLINE;
      case BYTE of
      1 : ( GRP_STP	: packed array [1..4] of char);
      2 : ( GRP_NUM,
            STP_NUM	: TWOCHAR )
      end;
 
   PC_STK_PTR	= ^PC_STK;
   PC_STK	= packed record		{ PC stack element }
      PTR	: PC_STK_PTR;
      FLAGS	: SET of ( DO_FLG, FOR_FLG );
      INDEX	: integer;
      OLD_PC	: LINE_NODE_PTR
      end;
 
   FOR_STK_PTR	= ^FOR_STK;
   FOR_STK	= packed record		{ FOR loop stack element }
      PTR	: FOR_STK_PTR;
      INDEX	: TWOCHAR;
      INC	: TOKVAL;
      LIMIT	: TOKVAL
      end;
 
   DO_STK_PTR	= ^DO_STK;
   DO_STK	= packed record		{ DO stack element }
      PTR	: DO_STK_PTR;
      GRP	: TWOCHAR;
      FLG	: boolean
      end;

   EVT_BLK	= packed record		{ Get event SVC block }
      OP	: BYTE;
      STAT	: BYTE;
      EVT	: BYTE;
      LUNO	: BYTE
      end;

   IO_BLK	= packed record		{ I/O SVC block }
      OP	: BYTE;
      STAT	: BYTE;
      SUBOP	: BYTE;
      LUNO	: BYTE;
      FLAGS	: integer;
      ADDR	: integer;
      LRL	: integer;
      CHC	: integer
      end;

   EVT_REC	= packed record		{ CTRL-C event record }
      FLAG	: integer;
      STAT	: integer
      end;
 
   TIME_BLK	= packed record		{ ITIME block }
      HOUR	: 0..24;
      MINUTE	: 0..59;
      SECOND	: 0..59
      end;

var

   BUFFER,				{ Pointer to buffer }
   LINE_ANCHOR	: LINE_NODE_PTR;	{ Text lines anchor }
   SYM_ANCHOR	: SYM_NODE_PTR;		{ Symbol table anchor }
   PC_TOP	: PC_STK_PTR;		{ Top of the PC stack }
   FOR_TOP	: FOR_STK_PTR;		{ Top of the FOR loop stack }
   DO_TOP	: DO_STK_PTR;		{ Top of the DO routine stack }
   PC		: LINE_NODE_PTR;	{ The PC }
 
   ERR_FLG,				{ Parse error flag }
   RUN_MODE,				{ Program running mode 'GO' }
   DO_MODE,				{ Program in subroutine 'DO' }
   PRINT_OPEN,
   QUIT_FLAG	: boolean;		{ Terminate FOCAL or program }
 
   TBUF		: SLINE;
   PBUF		: packed array [1..PLEN] of char; { PRINT LINE }
   GET_EVT	: EVT_REC;
 
   PNDX,				{ Index into print buffer }
   WIDTH,				{ Print field width }
   DIGITS,				{ Print field significance }
   SEED,				{ Random number seed }
   PRT_LUN,				{ Print LUN }
   J,					{ Temporary }
   I		: integer;		{ Index into executing line }

   READ_IO_BLK	: IO_BLK;
   WRITE_IO_BLK	: IO_BLK;

   SECNDS	: real;			{ Time of day seconds }

   PROGFILE	: text;
   PRINTFILE	: text;
 
procedure HEAP$TERM (
	var	O	: boolean;
		N	: boolean);			       external;

procedure ASK;							forward;
procedure CLEANER;						forward;
procedure CONTINUE;						forward;
procedure DOCMD;						forward;
procedure ERASE;						forward;
procedure ERROR	( 
		ERR_CODE	: integer;
		ERR_STAT	: integer );			forward;
procedure EXECLINE;						forward;
procedure EXPRESSION (
	var	VAL		: TOKVAL );			forward;
procedure FINDLINE (
	var	P		: LINE_NODE_PTR );		forward;
procedure FORCMD;						forward;
procedure GETGRP (
	var	GRP		: TWOCHAR );			forward;
procedure GETSTP (
	var	STP		: TWOCHAR );			forward;
procedure GOCMD;						forward;
procedure GOTOIT;						forward;
procedure GETSYM (
	var	SYM		: TWOCHAR;
	var	NDX		: integer );			forward;
procedure IFCMD;						forward;
procedure INSERTLINE;						forward;
procedure LIBRARY;						forward;
procedure MODIFY;						forward;
procedure NEXTFIELD;						forward;
procedure PARSE (
	var	EXPR		: packed array [1..?] of char;
		NDX		: integer;
	var	IVAL		: TOKVAL );			forward;
procedure PCPOP;						forward;
procedure PCPUSH;						forward;
procedure QUIT;							forward;
procedure RETURN;						forward;
procedure SETCMD;						forward;
procedure SYMBOLTABLE (
		SYM		: TWOCHAR;
	var	VAL		: TOKVAL;
		NDX	   	: integer;
		FLG		: boolean );			forward;
procedure TYPECMD;						forward;
procedure WRITECMD;						forward;
{$PAGE}

{--------------------------------------------------------------------}

function GETSECNDS (
	var	ORG	: real ) : real;
{***********************************************************************
*
* Get seconds.
*
***********************************************************************}

var
   NOW	: TIME_BLK;

procedure ITIME (var TIME : TIME_BLK); external;

begin
   ITIME (NOW);
   GETSECNDS := float (NOW.HOUR, 6) * 3600.0 +
                float (NOW.MINUTE, 6) * 60.0 +
                float (NOW.SECOND, 6) + ORG
end; { GETSECNDS }

{$PAGE}
function GETRANDOM (
	var	SEED	: integer ) : real;
{***********************************************************************
*
* Get random number.
*
***********************************************************************}
var
   I : integer;

begin
   I := SEED * 259;
   if I < 0 then
      I := I * 65535 + 1;
   SEED := I;
   GETRANDOM := abs (float(I, 6) * 1.525879e-05)
end; { GETRANDOM }

{$PAGE}
procedure CHECKTERM (
	var	EVENT	: EVT_REC );
{***********************************************************************
*
* Check for terminal interrupt.
*
***********************************************************************}
var

  EVT_REC : EVT_BLK;

procedure SVC$ (var SCB : EVT_BLK); external;

begin
   EVENT.STAT := 0;
   EVENT.FLAG := 0;

   EVT_REC.OP := #39;
   EVT_REC.STAT := 0;
   EVT_REC.EVT := 0;
   EVT_REC.LUNO := 0;
   SVC$ (EVT_REC);
   if (EVT_REC.STAT = 0) and (EVT_REC.EVT = #98) then begin
      EVENT.STAT := 1;
      EVENT.FLAG := 1
      end
end; { CHEKTERM }

{$PAGE}
procedure GETLINE (
		LUN	: integer;
	var	UBUF	: SLINE;
	var	LEN	: integer );
{***********************************************************************
*
* Get a line from the terminal.
*
***********************************************************************}

procedure SVC$ (var SCB : IO_BLK); external;

begin
   with READ_IO_BLK do begin
      OP := 0;
      STAT := 0;
      SUBOP := #09;
      LUNO := LUN;
      FLAGS := 0;
      ADDR := location (UBUF);
      LRL := LINE_LEN;
      CHC := LINE_LEN
      end;

   SVC$ (READ_IO_BLK);

   LEN := READ_IO_BLK.CHC + 1;
   UBUF[LEN] := EOL

end; { GETLINE }

{$PAGE}
procedure PUTLINE (
		LUN     : integer;
		UBUF	: packed array [1..?] of char;
		LEN	: integer );
{***********************************************************************
*
* Put a line out to file.
*
***********************************************************************}

procedure SVC$ (var SCB : IO_BLK); external;

begin
   with WRITE_IO_BLK do begin
      OP := 0;
      STAT := 0;
      SUBOP := #0B;
      LUNO := LUN;
      FLAGS := 0;
      ADDR := location (UBUF);
      LRL := LEN;
      CHC := LEN
      end;

   SVC$ (WRITE_IO_BLK)

end; { PUTLINE }

{$PAGE}
procedure OPENFILE (
	var	FILENM	: packed array [1..?] of char;
	var	FIL	: text;
		LUN	: integer;
	var	STAT	: integer;
		FLAG	: integer );
{***********************************************************************
*
* Open a file.
*
***********************************************************************}
var
   OV  : boolean;
   I,J	: integer;
   LBUF	: STRING;

procedure SET$ACNM (var F: text; var S : STRING); external;

begin
   for J := 1 to LINE_LEN do
      LBUF[J] := ' ';
   J := 0;
L1: for I := 1 to LINE_LEN do begin
      if FILENM[I] = EOL then
         escape L1;
      LBUF[I] := FILENM[I];
      J := J + 1;
      end;
   LBUF[0] := chr(J);

   IOTERM (FIL, OV, false);
   SETLUNO (FIL, LUN);
   SET$ACNM(FIL, LBUF);
   I := STATUS(FIL);
   if I <> 0 then begin
      STAT := I;
      escape OPENFILE
      end;

   if STAT = 0 then
      RESET(FIL)
   else
      REWRITE(FIL);

   I := STATUS(FIL);
   if I <> 0 then
      STAT := I
   else
      STAT := 0
end; { OPENFILE }

{$PAGE}
procedure CLOSEFILE (
	var	FIL	: text;
		STAT	: integer );
{***********************************************************************
*
* Close a file.
*
***********************************************************************}

begin
   CLOSE ( FIL )
end; { CLOSEFILE }

{$PAGE}
procedure READCODE (
	var	BUFF	: packed array [1..?] of char;
	var	FIL	: text;
	var	STAT	: integer );
{***********************************************************************
*
* Read a record from a FOCAL code file.
*
***********************************************************************}
var
   I	: integer;
   LBUF	: SLINE;

begin
   if EOF(FIL) then begin
      STAT := -1;
      escape READCODE 
      end;
   READLN (FIL, LBUF);
   for I := 1 to LINE_LEN do
      BUFF[I] := LBUF[I];
   I := LINE_LEN;
   while (I > 1) and (BUFF[I] <> ' ') do
      I := I - 1;
   BUFF[I] := EOL;
   STAT := 0
end; { READCODE }

{$PAGE}
procedure WRITCODE (
	var	BUFF	: packed array [1..?] of char;
	var	FIL	: text;
	var	STAT	: integer );
{***********************************************************************
*
* Write a record to a FOCAL code file.
*
***********************************************************************}
var
   J,I	: integer;
   LBUF	: SLINE;

begin
   I := 1;
   while BUFF[I] <> EOL do begin
      LBUF[I] := BUFF[I];
      I := I + 1
      end;
   for J := I to LINE_LEN do
      LBUF[I] := ' ';
   WRITELN (FIL, LBUF);
   STAT := 0 
end; { WRITCODE }

{$PAGE}
procedure CLEARSCREEN;
{***********************************************************************
*
* Clear the screen.
*
***********************************************************************}
var
   BUFF	: packed array [1..4] of char;

begin
   BUFF[1] := chr ( 27 );
   BUFF[2] := '[';
   BUFF[3] := '2';
   BUFF[4] := 'J';
   PUTLINE ( LOG_LUN, BUFF, 4 )
end; { CLEARSCREEN }

{$PAGE}
procedure CLEARLINE;
{***********************************************************************
*
* Clear a line.
*
***********************************************************************}
var
   BUFF	: packed array [1..4] of char;

begin
   BUFF[1] := chr ( 27 );
   BUFF[2] := '[';
   BUFF[3] := '2';
   BUFF[4] := 'K';
   PUTLINE ( LOG_LUN, BUFF, 4 )
end; { CLEARLINE }

{$PAGE}
procedure SCREENPOSITION (
		ROW	: TWOCHAR;
		COL	: TWOCHAR );
{***********************************************************************
*
* Position the cursor on the screen.
*
***********************************************************************}
var
   BUFF	: packed array [1..10] of char;

begin
   BUFF[1] := chr ( 27 );
   BUFF[2] := '[';
   BUFF[3] := ROW[1];
   BUFF[4] := ROW[2];
   BUFF[5] := chr ( 59 );
   BUFF[6] := COL[1];
   BUFF[7] := COL[2];
   BUFF[8] := 'H';
   PUTLINE ( LOG_LUN, BUFF, 8 )
end; { SCREENPOSITION }
{--------------------------------------------------------------------}
{$PAGE}

procedure ASK;
{***********************************************************************
*
* ASK - Ask for user input
*
* Procedure ASK processes the ASK command. The forms recognized are
* as follows:
*	A(SK) <VAR>		 ASK for a variable
*	A(SK) "PROMPT",<VAR>	 ASK for a variable w/prompting
*
***********************************************************************}
var
   PROMPT	: SLINE;
   ROW,
   COL,
   SYM		: TWOCHAR;
   VAL		: TOKVAL;
   NDX,
   J		: integer;
   CH		: char;

begin
   NEXTFIELD;				{ Position to the next field }
   J := 3;
   PROMPT[1] := chr ( 13 );
   PROMPT[2] := chr ( 10 );
   repeat
      CH := PC^.LIN_TXT[I];		{ Check for symbol }
      if CH in ['a'..'e','g'..'z','A'..'E','G'..'Z'] then begin
         GETSYM(SYM,NDX);
         if PC^.LIN_TXT[I] in ['(','[','<','{'] then begin
            EXPRESSION(VAL);		{ Get subscript }
            NDX := round ( VAL )
            end;
         PROMPT[J] := ':';
         PUTLINE ( LOG_LUN, PROMPT, J );{ Prompt for input }
         TBUF[1] := EOL;
         GETLINE ( LOG_LUN, TBUF, J );	{ Read input }
         J := 1;
         if TBUF[1] <> EOL then
            PARSE ( TBUF, J, VAL )
         else
            VAL := 0.0;
         J := 3;
         PROMPT[1] := chr ( 13 );
         PROMPT[2] := chr ( 10 );
         SYMBOLTABLE ( SYM, VAL, NDX, false ) { Save in symbol table }
         end
      else if CH = '!' then begin	{ Check for new line }
         I := I + 1;
         PUTLINE ( LOG_LUN, PBUF, 2 )
         end
      else if CH = '"' then begin	{ Check for prompt }
         I := I + 1;
         while (PC^.LIN_TXT[I] <> '"') and 
               (PC^.LIN_TXT[I] <> EOL) do begin
            PROMPT[J] := PC^.LIN_TXT[I];
            J := J + 1;
            I := I + 1
            end;
         if PC^.LIN_TXT[I] = EOL then
            ERROR ( 6, 0 )
         else
            I := I + 1
         end
      else if CH = '@' then begin
         J := 1;
         I := I + 1;
         ROW := '01';
         COL := '01';
         CH := PC^.LIN_TXT[I];
         if (CH = 'e') or (CH = 'E') then begin
            I := I + 1;
            CLEARSCREEN
            end;
         if PC^.LIN_TXT[I] in ['0'..'9'] then begin
            GETGRP ( ROW );
            if PC^.LIN_TXT[I] = '.' then begin
               I := I + 1;
               GETGRP ( COL )
               end;
            SCREENPOSITION ( ROW, COL )            
            end;
         CH := PC^.LIN_TXT[I];
         if (CH = 'c') or (CH = 'C') then begin
            I := I + 1;
            CLEARLINE
            end
         end
      else if (CH = 'f') or (CH = 'F') then { Error if function  }
         ERROR ( 5, 0 )
      else I := I + 1;
   until (PC^.LIN_TXT[I] = ';') or (PC^.LIN_TXT[I] = EOL) or ERR_FLG
end; { ASK }
{$PAGE}

procedure CLEANER;
{***********************************************************************
*
* CLEANER - Clean up after error
*
* This procedure cleans up after an error.
*
***********************************************************************}
var
   P	: DO_STK_PTR;
   Q	: FOR_STK_PTR;
   J	: integer;

begin
   if RUN_MODE then with PC^ do begin	{ Write line number }
      TBUF[1] := ' ';
      TBUF[2] := '@';
      TBUF[3] := ' ';
      TBUF[4] := GRP_NUM[1];
      TBUF[5] := GRP_NUM[2];
      TBUF[6] := '.';
      TBUF[7] := STP_NUM[1];
      TBUF[8] := STP_NUM[2];
      PUTLINE (LOG_LUN, TBUF, 8)
      end;
   while PC_TOP <> nil do PCPOP;	{ Purge PC stack }
   while DO_TOP <> nil do begin		{ Purge DO stack }
      P := DO_TOP;
      DO_TOP := P^.PTR;
      dispose ( P )
      end;
   while FOR_TOP <> nil do begin	{ Purge for stack }
      Q := FOR_TOP;
      FOR_TOP := Q^.PTR;
      dispose ( Q )
      end;
   RUN_MODE := false;
   DO_MODE := false;
   PUTLINE ( LOG_LUN, PBUF, 2 )		{ Print error message }
end; { CLEANER }
{$PAGE}

procedure CONTINUE;
{***********************************************************************
*
* CONTINUE - CONTINUE/COMMENT
*
* Procedure CONTINUE processes the CONTINUE/COMMENT command.
*
***********************************************************************}
begin
   while (PC^.LIN_TXT[I] <> ';') and (PC^.LIN_TXT[I] <> EOL) do 
      I := I + 1
end; { CONTINUE }
{$PAGE}

procedure DOCMD;
{***********************************************************************
*
* DOCMD - DO subroutine command
*
* Procedure DOCMD process the DO command. The syntax is:
*	 D(O) <GRP>[.<STP>]
*
***********************************************************************}
var
   FOUND	: boolean;
   P		: DO_STK_PTR;
   L		: LINE_NODE_PTR;
   SYM		: TWOCHAR;

begin
   NEXTFIELD;				{ Position to group field }
   new ( P );
   GETGRP ( SYM );			{ Get group from buffer }
   P^.GRP := SYM;
   P^.FLG := true;
   L := LINE_ANCHOR;			{ Find group in line list }
   FOUND := false;
   while (L <> nil) and not FOUND do
      if L^.GRP_NUM = SYM then
         FOUND := true
      else
         L := L^.LINE_PTR;
   if L <> nil then begin
      if PC^.LIN_TXT[I] = '.' then begin { Check for step }
         I := I + 1;
         P^.FLG := false;
         GETSTP ( SYM );		{ Get step }
         if not ERR_FLG then begin
            FOUND := false;
            while (L <> nil) and not FOUND do
               if (P^.GRP = L^.GRP_NUM) and
                  (SYM = L^.STP_NUM) then
                  FOUND := true
               else
                  L := L^.LINE_PTR;
            if L = nil then begin
               ERROR ( 2, 2 );		{ Bad line number }
               dispose ( P )
               end
            end
         end;
      NEXTFIELD;
      if not ERR_FLG then begin
         PCPUSH;			{ Push where we are }
         PC_TOP^.FLAGS := [ DO_FLG ];
         PC := L;
         I := 1;
         P^.PTR := DO_TOP;		{ Set up DO stack }
         DO_TOP := P;
         DO_MODE := true;
         end
      end
   else begin
      ERROR ( 2, 2 );			{ Bad group }
      dispose ( P )
      end
end; { DO_CMD }
{$PAGE}

procedure ERASE;
{***********************************************************************
*
* ERASE - Erase lines and symbols
*
* Procedure ERASE deletes the symbol table and program lines.
*
***********************************************************************}
var
   FOUND	: boolean;
   P,
   P1		: SYM_NODE_PTR;
   Q,
   Q1		: LINE_NODE_PTR;
   CH		: char;
   K		: integer;
   GRP,
   STP		: TWOCHAR;

begin
   NEXTFIELD;
   K := 2;
   CH := PC^.LIN_TXT[I];
   if (CH = EOL) or (CH = ';') then
      K := 0				{ Erase symbol table }
   else if (CH = 'a') or (CH = 'A') then begin
      NEXTFIELD;			{ Erase program and symbols }
      K := 0;
      Q := LINE_ANCHOR;
      LINE_ANCHOR := nil;
      while Q <> nil do begin
         Q1 := Q^.LINE_PTR;
         dispose ( Q );
         Q := Q1
         end
      end
   else if CH in ['0'..'9'] then begin
      K := 2;				{ Erase specified lines }
      GETGRP ( GRP );
      Q := LINE_ANCHOR;
      Q1 := LINE_ANCHOR;
      FOUND := false;
      while (Q <> nil) and not FOUND do
         if Q^.GRP_NUM = GRP then
            FOUND := true
         else begin
            Q1 := Q;
            Q := Q^.LINE_PTR
            end;
      if Q <> nil then begin
         if PC^.LIN_TXT[I] = '.' then begin
            I := I + 1;
            GETSTP ( STP );
            FOUND := false;
            if not ERR_FLG then
               while (Q <> nil) and not FOUND do
                  if (Q^.GRP_NUM = GRP) and (Q^.STP_NUM = STP) then
                     FOUND := true
                  else begin
                     Q1	:= Q;
                     Q := Q^.LINE_PTR
                     end;
            if Q <> nil then
               if Q <> LINE_ANCHOR then begin
                  Q1^.LINE_PTR := Q^.LINE_PTR;
                  dispose ( Q )
                  end
               else begin
                  LINE_ANCHOR := Q^.LINE_PTR;
                  dispose ( Q )
                  end
            end
         else begin
            FOUND := false;
            if Q <> LINE_ANCHOR then 
               while (Q <> nil) and not FOUND do
                  if Q^.GRP_NUM = GRP then begin
                     Q1^.LINE_PTR := Q^.LINE_PTR;
                     dispose ( Q );
                     Q := Q1^.LINE_PTR
                     end
                  else FOUND := true
            else while (Q <> nil) and not FOUND do
                  if Q^.GRP_NUM = GRP then begin
                     LINE_ANCHOR := Q^.LINE_PTR;
                     dispose ( Q );
                     Q := LINE_ANCHOR
                     end
                  else
                     FOUND := true
            end
         end
      end
   else ERROR ( 2, 0 );
   if K = 0 then begin
      P := SYM_ANCHOR;			{ Erase symbols }
      SYM_ANCHOR := nil;
      while P <> nil do begin
         P1 := P^.SYM_PTR;
         dispose(P);
         P := P1
         end
      end
end; { ERASE }
{$PAGE}

procedure ERROR {(
		ERR_CODE	: integer;
		ERR_STAT	: integer )};
{***********************************************************************
*
* ERROR - General error processor
*
* Procedure ERROR genertates error messages from a passed error code
*
***********************************************************************}
var
   J	: integer;

begin
   ERR_FLG := true;
   if PNDX > PBEG then begin		{ Print pending text }
      PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
      PNDX := PBEG
      end;
   PUTLINE ( LOG_LUN, PBUF, 2 );
   case ERR_CODE of
   0: PUTLINE ( LOG_LUN, 'STOP', 4 );
   1: PUTLINE ( LOG_LUN, 'BAD CMD', 7 );
   2: begin
         PUTLINE ( LOG_LUN, 'BAD LINE NUM', 12 );
         case ERR_STAT of
         1: PUTLINE ( LOG_LUN, ' IN GOTO', 8 );
         2: PUTLINE ( LOG_LUN, ' IN DO', 6 );
         otherwise ;
         end
      end;
   3: PUTLINE ( LOG_LUN, 'BAD VAR', 7 );
   4: PUTLINE ( LOG_LUN, 'BAD EXPR', 8 );
   5: PUTLINE ( LOG_LUN, 'BAD FUNC USAGE', 14 );
   6: PUTLINE ( LOG_LUN, 'BAD TEXT STRING', 15 );
   7: PUTLINE ( LOG_LUN, 'BAD NUM', 7 );
   8: case ERR_STAT of
      0: PUTLINE ( LOG_LUN, 'LINE BUFFER FULL', 16 );
      3: PUTLINE ( LOG_LUN, 'SYMBOL TABLE FULL', 17 );
      otherwise PUTLINE ( LOG_LUN, 'STACK OVERFLOW', 14 )
      end;
   10: case ERR_STAT of
      0: PUTLINE ( LOG_LUN, 'MISSING "=" IN FOR/SET', 22 );
      1: PUTLINE ( LOG_LUN, 'BAD EXPR IN IF', 14 );
      2,8,23,24:
         PUTLINE ( LOG_LUN, 'MISSING "-","(",NUM,VAR OR FUNC', 31 );
      3: PUTLINE ( LOG_LUN, 'MISSING "+" OR "-"', 18 );
      5,16,17,18,19,21:
         PUTLINE ( LOG_LUN, 'MISSING "(",NUM,VAR OR FUNC', 27 );
      14: PUTLINE ( LOG_LUN, 'MISSING "("', 11 );
      22,31,32:
         PUTLINE (LOG_LUN,'MISSING ")","-" OR "+"', 22);
      otherwise begin
         PUTLINE (LOG_LUN,'SYNTAX ERROR=', 13);
         encode (TBUF, 1, J ,ERR_STAT:3);
	 PUTLINE (LOG_LUN, TBUF, 3)
	 end
      end;
   11: case ERR_STAT of
      4,9: PUTLINE ( LOG_LUN, 'BAD EXPONENT SIGN', 17 );
      7: PUTLINE ( LOG_LUN, 'BAD FRACTION', 12 );
      8: PUTLINE ( LOG_LUN, 'EXPONENT OVERFLOW', 17 );
      otherwise begin
         PUTLINE (LOG_LUN,'SCAN ERROR=', 11);
         encode (TBUF, 1, J ,ERR_STAT:3);
	 PUTLINE (LOG_LUN, TBUF, 3)
	 end
      end;
   12: case ERR_STAT of
      1: PUTLINE ( LOG_LUN, 'DIVIDE BY 0', 11 );
      2: PUTLINE ( LOG_LUN, 'NEGATIVE SQRT', 13 );
      3: PUTLINE ( LOG_LUN, 'NEGATIVE OR ZERO LOG', 20 );
      4: PUTLINE ( LOG_LUN, 'BAD TAB VAL', 11 );
      otherwise begin
         PUTLINE (LOG_LUN,'INTERP ERROR=', 13);
         encode (TBUF, 1, J ,ERR_STAT:3);
	 PUTLINE (LOG_LUN, TBUF, 3)
	 end
      end;
   13: PUTLINE ( LOG_LUN, 'NO MATCH FOUND', 14 );
   15: begin
       PUTLINE ( LOG_LUN, 'FILE I/O ERROR=>', 16);
       encode (TBUF, 1, J, ERR_STAT:2 HEX);
       PUTLINE (LOG_LUN, TBUF, 2)
       end;
   16: PUTLINE ( LOG_LUN, 'BAD LIBRARY CMD', 15 );
   otherwise PUTLINE ( LOG_LUN, 'UNDEFINED ERR', 13 )
   end;
   CLEANER				{ Clean up }
end; { ERROR }
{$PAGE}

procedure EXECLINE;
{***********************************************************************
*
* EXECLINE - Execute line
*
* Procedure EXECLINE processes source/command lines pointed to by
* the PC.
*
***********************************************************************}

var
   Q		: DO_STK_PTR;
   Q1		: FOR_STK_PTR;
   P		: LINE_NODE_PTR;
   CH		: char;
   VAL		: TOKVAL;
   SYM		: TWOCHAR;
   DOIT,
   NEXT		: boolean;

begin
   repeat
LOOP:
      repeat
         I := I + 1;
         CH := PC^.LIN_TXT[I];
         if CH in ['a'..'z'] then
            CH := chr( ord(CH) - (ord('a') - ord('A')) );
         if CH in ['0'..'9'] then begin		{ Text line - indirect }
            INSERTLINE;
            escape LOOP
            end
         else case CH of
            'A' : ASK;
         {  'B' : AVAILABLE }
            'C' : CONTINUE;
            'D' : DOCMD;
            'E'	: ERASE;
            'F'	: FORCMD;
            'G'	: GOCMD;
         {  'H' : AVAILABLE }
            'I'	: IFCMD;
         {  'J' : AVAILABLE }
         {  'K' : AVAILABLE }
            'L'	: LIBRARY;
            'M' : MODIFY;
         {  'N' : AVAILABLE }
         {  'O' : AVAILABLE }
         {  'P' : AVAILABLE }
            'Q' : QUIT;
            'R'	: RETURN;
            'S'	: SETCMD;
            'T'	: TYPECMD;
         {  'U' : AVAILABLE }
         {  'V' : AVAILABLE }
            'W'	: WRITECMD;
         {  'X' : AVAILABLE }
         {  'Y' : AVAILABLE }
         {  'Z' : AVAILABLE }
            ' ',EOL,';'
                : ;
            otherwise ERROR ( 1, 0 )
            end;
         CHECKTERM ( GET_EVT );		{ Check for user abort }
         if GET_EVT.STAT <> 0 then
            ERROR ( 0, 0 );
      until (PC^.LIN_TXT[I] = EOL) or ERR_FLG;
      NEXT := true;
      if PC_TOP <> nil then		{ Check for loop in progress }
         if FOR_FLG in PC_TOP^.FLAGS then begin
            SYM := FOR_TOP^.INDEX;
            SYMBOLTABLE ( SYM, VAL, 0, true );
            VAL := VAL + FOR_TOP^.INC;
            SYMBOLTABLE ( SYM, VAL, 0, false );
            if VAL <= FOR_TOP^.LIMIT then begin
               NEXT := false;
               PC := PC_TOP^.OLD_PC;
               I := PC_TOP^.INDEX
               end
            else begin
               PCPOP;
               Q1 := FOR_TOP;
               FOR_TOP := Q1^.PTR;
               dispose ( Q1 );
               escape EXECLINE
               end
            end
         else begin			{ Not a loop must be DO }
            P := PC^.LINE_PTR;
            DOIT := false;
            if P = nil then DOIT := true;
            if P <> nil then
               if P^.GRP_NUM <> DO_TOP^.GRP then
                  DOIT := true;
            if not DO_TOP^.FLG then
               DOIT := true;
            if DOIT then begin
               PC := PC_TOP^.OLD_PC;
               I := PC_TOP^.INDEX - 1;
               NEXT := false;
               PCPOP;
               Q := DO_TOP;
               DO_TOP := Q^.PTR;
               dispose ( Q );
               if DO_TOP = nil then
                  DO_MODE := false
               end
            end;
         if (RUN_MODE or DO_MODE) and NEXT then begin
            P := PC^.LINE_PTR;		{ Point PC to next line }
            if P <> nil then begin
               PC := P;
               I := 0
               end
            else RUN_MODE := false
            end
   until not RUN_MODE and (PC_TOP = nil);
end; { EXECUTELINE }
{$PAGE}

procedure EXPRESSION {(
	var	VAL	: TOKVAL )};
{***********************************************************************
*
* EXPRESSION - Scan out expression
*
* Procedure EXPERSSION scans out expressions and calls the parser to
* reduce the expression to a value.
*
***********************************************************************}
var
   J	: integer;

begin
   J := 1;
   while not( PC^.LIN_TXT[I] in [',', EOL, ';', '=', '"', '%', '!' ] )
   do begin
      if PC^.LIN_TXT[I] <> ' ' then begin
         TBUF[J] := PC^.LIN_TXT[I];
         J := J + 1
         end;
      I := I + 1
      end;
   TBUF[J] := EOL;
   TBUF[J+1] := EOL;
   PARSE ( TBUF, 1, VAL )
end; { EXPRESSION }
{$PAGE}

procedure FINDLINE {(
	var	P	: LINE_NODE_PTR )};
{***********************************************************************
*
* FINDLINE - Find line
*
* Procedure FINDLINE returns the address OF the line addressed by the
* line number in the buffer.
*
***********************************************************************}
var
   FOUND	: boolean;
   STP,
   GRP		: TWOCHAR;
   L		: LINE_NODE_PTR;

begin
   P := nil;
   GETGRP ( GRP );			{ Get line group }
   if PC^.LIN_TXT[I] = '.' then begin
      I := I + 1;
      GETSTP ( STP );			{ Get line step }
      P := LINE_ANCHOR;
      if RUN_MODE then begin		{ See if going forward }
         L := PC;
         if (L^.GRP_NUM <= GRP) and ((L^.GRP_NUM = GRP) and 
            (L^.STP_NUM <= STP)) then
            P := L
         end;
      FOUND := false;
      while (P <> nil) and not FOUND do
         if (P^.GRP_NUM = GRP) and (P^.STP_NUM = STP) then 
            FOUND := true
         else
            P := P^.LINE_PTR
      end
end; { FINDLINE }
{$PAGE}

procedure FORCMD;
{***********************************************************************
*
* FORCMD - FOR loop command
*
* Procedure FORCMD process the FOR statement. Syntax is:
*   F(OR) <NDX>=<EXPR>,<EXPR>[,<EXPR>];<STMT>
*
***********************************************************************}
var
   P	: FOR_STK_PTR;
   J	: integer;
   V1,
   VAL	: TOKVAL;
   TMP	: TWOCHAR;

begin
   NEXTFIELD;				{ Skip to index variable }
   new ( P );
   GETSYM ( TMP, J );			{ Get index symbol }
   P^.INDEX :=	TMP;
   if PC^.LIN_TXT[I] = ' ' then
      NEXTFIELD;
   if PC^.LIN_TXT[I] = '=' then begin
      I := I + 1;			{ Get start expression }
      EXPRESSION ( VAL );
      V1 := VAL;
      SYMBOLTABLE ( TMP, VAL, J, false );
      I := I + 1;			{ Get increment }
      EXPRESSION ( VAL );
      P^.INC := VAL;
      if PC^.LIN_TXT[I] in [';',EOL]	{ If EOL then this }
      then begin
         P^.LIMIT := P^.INC;		{ limit and inc is 1 }
         P^.INC := 1.0
         end
      else begin
         I := I + 1;			{ Get limit }
         EXPRESSION ( VAL );
         P^.LIMIT := VAL
         end;
      if (not ERR_FLG) and (P^.LIMIT >= V1) then begin
         P^.PTR := FOR_TOP;		{ Set up FOR stack }
         FOR_TOP := P;
         PCPUSH;			{ Set up PC stack }
         PC_TOP^.FLAGS := [ FOR_FLG ];
         EXECLINE			{ Execute loop }
         end
      else begin
         dispose ( P );
         while PC^.LIN_TXT[I] <> EOL do
            I := I + 1
         end
      end
   else begin
      ERROR ( 10, 0 );			{ Bad loop expression }
      dispose ( P )
      end
end; { FOR_CMD }
{$PAGE}

procedure GETGRP {(
	var	GRP	: TWOCHAR )};
{***********************************************************************
*
* GETGRP - Get line group
*
* Procedure GETGRP gets the group number, 1 or 2 digits, from the
* buffer indexed by I and returns the value.
*
***********************************************************************}
var
   CH	: char;

begin
   GRP := '00';
   CH := PC^.LIN_TXT[I];
   I := I + 1;
   if CH in ['0'..'9'] then
      if PC^.LIN_TXT[I] in ['0'..'9'] then begin
         GRP[1] := CH;
         GRP[2] := PC^.LIN_TXT[I];
         I := I + 1
         end
      else 
         GRP[2] := CH
   else
      ERROR ( 2, 0 )
end; { GET_GRP }
{$PAGE}

procedure GETSTP {(
	var	STP	: TWOCHAR )};
{***********************************************************************
*
* GETSTP - Get line step
*
* Procedure GETSTP get the step number, 1 or 2 digits, from the
* buffer indexed by I and returns the value.
*
***********************************************************************}
var
   CH	: char;

begin
   STP := '00';
   CH := PC^.LIN_TXT[I];
   I := I + 1;
   if CH in ['0'..'9'] then
      if PC^.LIN_TXT[I] in ['0'..'9'] then begin
         STP[1] := CH;
         STP[2] := PC^.LIN_TXT[I];
         I := I + 1
         end
      else 
         STP[1] := CH
   else
      ERROR ( 2, 0 )
end; { GET_STP }
{$PAGE}

procedure GETSYM {(
	var	SYM	: TWOCHAR;
	var	NDX	: integer )};
{***********************************************************************
*
* GETSYM - Get symbol
*
* Procedure GETSYM gets the symbol from the buffer.
*
***********************************************************************}
var
   CH	: char;
   J	: integer;

begin
   SYM := '  ';
   NDX := 0;
   J := 1;
   repeat
      CH := PC^.LIN_TXT[I];
      if CH in ['a'..'z'] then
         CH := chr( ord(CH) - ( ord('a') - ord('A') ));
      if J <= 2 then
         SYM[J] := CH;
      I := I + 1;
      J := J + 1
   until not(PC^.LIN_TXT[I] in ['A'..'Z','0'..'9','a'..'z'])
end; { GET_SYM }
{$PAGE}

procedure GOCMD;
{***********************************************************************
*
* GOCMD - GO TO command
*
* Procedure GOCMD process the GO/GOTO statements. The syntax is:
*   G(O(TO)) (<LN>) If the line number is absent then go to lowest
*		    numbered line.
*
***********************************************************************}
begin
   NEXTFIELD;
   if LINE_ANCHOR <> nil then
      GOTOIT
end; { GO }
{$PAGE}

procedure GOTOIT;
{***********************************************************************
*
* GOTOIT - GOTO line
*
* Procedure GOTOIT set the PC to the line number in the buffer.
*
***********************************************************************}
var
   P	: LINE_NODE_PTR;

begin
   if not ( PC^.LIN_TXT[I] in [';',EOL] ) then begin
      FINDLINE ( P );
      if P <> nil then begin		{ Set PC to target line }
         PC := P;
         RUN_MODE := true
         end
      else
         ERROR ( 2, 1 )
      end
   else begin				{ No line number use anchor }
      PC := LINE_ANCHOR;
      if PC <> nil then
         RUN_MODE := true
      end;
   I := 1
end; { GOTOIT }
{$PAGE}

procedure IFCMD;
{***********************************************************************
*
* IFCMD - IF command
*
* Procedure IFCMD process the IF command. Syntax:
*   I(F) (<EXPR>) <LN>[,<LN>[,<LN>]];
*
***********************************************************************}
var
   K,
   J	: integer;
   VAL	: TOKVAL;

begin
   NEXTFIELD;				{ Position to expression }
   if PC^.LIN_TXT[I] = '(' then begin	{ Scan out expression }
      J := 1;
      while not( PC^.LIN_TXT[I] in [',',EOL,';']) do begin
         TBUF[J] := PC^.LIN_TXT[I];
         J := J + 1;
         I := I + 1
         end;
      repeat
         J := J - 1;
         I := I - 1
      until TBUF[J-1] = ')';
      TBUF[J] := EOL;
      TBUF[J+1] := EOL;
      PARSE ( TBUF, 1, VAL );		{ Get value of expression }
      J := 0;
      if VAL = 0.0 then
         J := 1;
      if VAL > 0.0 then
         J := 2;
      K := 0;
      while K < J do begin		{ Go to target line number }
         while not( PC^.LIN_TXT[I] in [',',';',EOL] ) do 
            I := I + 1;
         if PC^.LIN_TXT[I] = ',' then
            I := I + 1;
         K := K + 1
         end;
      while PC^.LIN_TXT[I] = ' ' do
         I := I + 1;
      if not( PC^.LIN_TXT[I] in [';',EOL] ) then
         GOTOIT
      end
   else
      ERROR ( 10, 1 )
end; { IFCMD }
{$PAGE}

procedure INSERTLINE;
{***********************************************************************
*
* INSERTLINE - Insert text line
*
* Procedure INSERTLINE takes a source line and links it into the line
* buffer in GROUP/STEP order. If the line currently exists its text is
* replaced with the new text.
*
***********************************************************************}
var
   FOUND	: boolean;
   J		: integer;
   P,
   NEXT,
   BACK		: LINE_NODE_PTR;
   CH		: char;
   T		: TWOCHAR;

begin
   new ( P );
   if P = nil then
      ERROR ( 8, 0 )
   else begin
      P^.LINE_PTR := nil;
      GETGRP ( T );			{ Get line group number }
      P^.GRP_NUM := T;
      if not ERR_FLG then
         if PC^.LIN_TXT[I] = '.' then begin
            I := I + 1;
            GETSTP ( T );		{ Get line step number }
            P^.STP_NUM := T;
            if not ERR_FLG then begin
               for J := I to LINE_LEN do
                  P^.LIN_TXT[J-I+1] := PC^.LIN_TXT[J];
               BACK := LINE_ANCHOR;
               NEXT := LINE_ANCHOR;
               if LINE_ANCHOR = nil then
                  LINE_ANCHOR := P
               else begin		{ Search for place to insert }
                  FOUND := false;
                  while (NEXT <> nil) and not FOUND do
                     if NEXT^.GRP_STP < P^.GRP_STP then begin
                        BACK := NEXT;
                        NEXT := NEXT^.LINE_PTR
                        end
                     else
                        FOUND := true;
                     if NEXT = nil then	{ Link at end of list }
                        BACK^.LINE_PTR := P
                     else if NEXT^.GRP_STP <> P^.GRP_STP then
                        if NEXT = LINE_ANCHOR then begin
                           LINE_ANCHOR := P;{ Link in at top of list }
                           P^.LINE_PTR := NEXT
                           end
                        else begin	{ Link into middle }
                           BACK^.LINE_PTR := P;
                           P^.LINE_PTR := NEXT
                           end
                     else begin		{ Replace old with new }
                        I := 1;
                        while P^.LIN_TXT[I] <> ' ' do
                           I := I + 1;
                        if P^.LIN_TXT[I] <> EOL then
                           for I := 1 to LINE_LEN do
                              NEXT^.LIN_TXT[I] := P^.LIN_TXT[I]
                        else begin	{ NULL INPUT, DELETE }
                           BACK^.LINE_PTR := NEXT^.LINE_PTR;
                           dispose ( NEXT )
                           end;
                        dispose ( P )
                        end
                  end
               end
            else
               dispose ( P )
         end
      else begin
         ERROR ( 2, 0 );
         dispose ( P )
         end
   else
      dispose ( P )
   end
end; { INSERT_LINE }
{$PAGE}

procedure LIBRARY;
{***********************************************************************
*
* LIBRARY - Provide library services
*
* Procedure LIBRARY processes the librarian function. Syntax is:
*   L(IBRARY) S(AVE) <PATHNAME>	  Saves program in FILE
*   L(IBRARY) C(ALL) <PATHNAME>	  Reads program from file
*   L(IBRARY) P(RINT) <PATHNAME>  Sends TYPE/WRITE output to file
*
***********************************************************************}
const
   EOF	= 1;
   NOEOF= 0;
   REW	= 1;
   NOREW= 0;

var
   CH	: char;
   L,K,
   J	: integer;
   SPC,
   P	: LINE_NODE_PTR;

begin
   NEXTFIELD;				{ Position to function }
   CH := PC^.LIN_TXT[I];		{ Get function (C,S,P) }
   NEXTFIELD;
   J := 1;				{ Scan off pathname }
   while not(PC^.LIN_TXT[I] in [';',' ',EOL]) do begin
      TBUF[J] := PC^.LIN_TXT[I];
      if TBUF[J] in ['a'..'z'] then
	 TBUF[J] := chr( ord(TBUF[J]) - (ord('a') - ord('A')) );
      I := I + 1;
      J := J + 1
      end;
   TBUF[J] := EOL;
   if (CH = 's') or (CH = 'S') then begin { Save program }
      J := 1;
      OPENFILE ( TBUF, PROGFILE, PROG_LUN, J, REW );
      if J = 0 then begin
         P := LINE_ANCHOR;
         L := 0;
         while (P <> nil) and (L = 0) do begin
            with P^ do begin
               TBUF[1] := GRP_NUM[1];
               TBUF[2] := GRP_NUM[2];
               TBUF[3] := '.';
               TBUF[4] := STP_NUM[1];
               TBUF[5] := STP_NUM[2];
               for J := 6 to LINE_LEN do 
                  TBUF[J] := LIN_TXT[J-5]
               end;
            WRITCODE ( TBUF, PROGFILE, L );
            P := P^.LINE_PTR
            end;
         if L > 0 then
            ERROR ( 15, L );
         CLOSEFILE ( PROGFILE, EOF )
         end
      else begin
	 CLOSEFILE ( PROGFILE, NOEOF );
	 ERROR ( 15, J ) 
	 end
      end
   else if (CH = 'c') or (CH = 'C') then begin { Call (load) program }
      J := 0;
      OPENFILE ( TBUF, PROGFILE, PROG_LUN, J, REW );
      if J = 0 then begin
         SPC := PC;
         K := I;
         new ( PC );
         repeat
            READCODE ( TBUF, PROGFILE, L );
            if L = 0 then begin
               for I := 1 to LINE_LEN do
                  PC^.LIN_TXT[I] := TBUF[I];
               I := 1;
               INSERTLINE
	       end;
         until (L <> 0) or ERR_FLG;
         if L > 0 then
            ERROR ( 15, L );
         I := K;
         dispose ( PC );
         PC := SPC;
         CLOSEFILE ( PROGFILE, NOEOF )
         end
      else begin
	 CLOSEFILE ( PROGFILE, NOEOF );
	 ERROR ( 15, J ) 
	 end
      end
   else if (CH = 'p') or (CH = 'P') then begin { Print to new file }
      if PNDX > PBEG then PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
      if PRINT_OPEN then
	 CLOSEFILE ( PRINTFILE, EOF );
      if (J = 3) and (TBUF[1] = 'M') and (TBUF[2] = 'E') then begin
	 PRINT_OPEN := false;
	 PRT_LUN := LOG_LUN;
         end
      else begin
         J := 1;
         OPENFILE ( TBUF, PRINTFILE, PRINT_LUN, J, NOREW );
         if J = 0 then begin
	    PRT_LUN := PRINT_LUN;
	    PRINT_OPEN := true
	    end
         else begin
	    CLOSEFILE ( PRINTFILE, NOEOF );
	    ERROR ( 15, J ) 
	    end
         end
      end
   else
      ERROR ( 16, 0 )
end; { LIBRARY }
{$PAGE}

procedure MODIFY;
{***********************************************************************
*
* MODIFY - Modify source line
*
* Procedure MODIFY fixes up source lines and has the following
* syntax:
*	M(ODIFY) GG.SS /OLD/NEW/
*
***********************************************************************}
var
   DELIM	: char;
   FOUND,
   DONE		: boolean;
   J, K, DISP,
   START_POS,
   MATCH_POS,
   NEW_LEN,
   OLD_LEN,
   END_POS	: integer;
   L		: LINE_NODE_PTR;

begin
   NEXTFIELD;
   FINDLINE ( L );
   if L <> nil then begin
      NEXTFIELD;
      if PC^.LIN_TXT[I] <> EOL then begin
         DELIM := PC^.LIN_TXT[I];
         I := I + 1;
         START_POS := I;
         J := 1;
         DONE := false;
         while not DONE do begin
            K := START_POS;
            while (L^.LIN_TXT[J] <> PC^.LIN_TXT[K]) and
                  (J < LINE_LEN) do
               J := J + 1;
            MATCH_POS := J;
            if J < LINE_LEN then begin
               FOUND := false;
               repeat
                  if L^.LIN_TXT[J] = PC^.LIN_TXT[K] then begin
                     J := J + 1;
                     K := K + 1
                     end
                  else if PC^.LIN_TXT[K] = DELIM then
                     FOUND := true
                  else
                     J := LINE_LEN
               until FOUND or (J >= LINE_LEN);
               if FOUND then begin
                  K := K + 1;
                  I := K;
                  while (PC^.LIN_TXT[K] <> DELIM) and
                        (PC^.LIN_TXT[K] <> EOL) do
                     K := K + 1;
                  NEW_LEN := K - I;
                  OLD_LEN := J - MATCH_POS;
                  if OLD_LEN > NEW_LEN then begin
                     DISP := OLD_LEN - NEW_LEN;
                     with L^ do for K := J to LINE_LEN do 
                        LIN_TXT[K-DISP] := LIN_TXT[K]
                     end
                  else if OLD_LEN < NEW_LEN then begin
                     DISP := NEW_LEN - OLD_LEN;
                     with L^ do for K := LINE_LEN downto J+DISP do
                        LIN_TXT[K] := LIN_TXT[K-DISP]
                     end;
                  for J := 1 to NEW_LEN do begin
                     L^.LIN_TXT[MATCH_POS] := PC^.LIN_TXT[I];
                     MATCH_POS := MATCH_POS + 1;
                     I := I + 1
                     end;
                  DONE := true
                  end
               else
                  J := MATCH_POS + 1
               end
            else begin
               DONE := true;
               ERROR ( 13, 0 )
               end
            end { while }
         end
      end
   else
      ERROR ( 2, 0 )
end; { MODIFY }
{$PAGE}

procedure NEXTFIELD;
{***********************************************************************
*
* NEXTFIELD - Skip to next field
*
* Procedure NEXTFIELD moves the pointer forward in the buffer
* to the next non_blank field, end of command (;), or end of line.
*
***********************************************************************}
begin
   while not(PC^.LIN_TXT[I] in [' ',EOL,';']) do
      I := I + 1;
   if not(PC^.LIN_TXT[I] in [EOL,';']) then
      repeat
         I := I + 1
      until PC^.LIN_TXT[I] <> ' '
end; { NEXTFIELD }
{$PAGE}

procedure PARSE {(
	var	EXPR	: packed array [1..?] of char;
		NDX	: integer;
	var	IVAL	: TOKVAL )};
{***********************************************************************
*
* PARSE - SLR(1) parser
*
* This routine interprets the parse tables TO perform the SLR(1)
* Parsing actions. Based on Aho and Ullman's parser in "Principles
* of Compiler Design".
*
***********************************************************************}

type
   PSTATE	= 0..255;
   TTYPE	= 0..#7F;
   REDCN	= PSTATE;
   ACTN		= ( SHIFT, REDUCE );

   SELEMENT_P	= ^SELEMENT;
   SELEMENT	= record
      STATE	: PSTATE;
      CVALU	: TOKVAL;
      LINK	: SELEMENT_P
      end;
 
   PARSE_ACTION	= packed record
      SR	: PSTATE;
      A		: ACTN;
      T		: TTYPE
      end;
   ACTION_LIST	= array [1..2] of PARSE_ACTION;
 
   NEXT_STATE	= packed record
      NEXT	: PSTATE;
      CRNT	: PSTATE
      end;
   GOTO_LIST	= array [1..2] of NEXT_STATE;

var
   I,J		: integer;
   C_S,
   CURRENT_STATE: PSTATE;
   TOKEN	: TOKTYP;
   CVALU	: TOKVAL;

   STACK	: SELEMENT_P;

common
   PRSTBL	: array [1..2] of record
      ACT	: ^ACTION_LIST;
      end;

   GOTTBL	: array [1..2] of record
      GO	: ^GOTO_LIST;
      HANDLE	: integer
      end;

access PRSTBL, GOTTBL;
 
procedure PUSH (
		S	: PSTATE;
		V	: TOKVAL );				forward;
procedure POP (
		H	: integer );				forward;
function POWER (
		BASE	: TOKVAL;
		EXPT	: TOKVAL ) : TOKVAL;			forward;
function TOP : PSTATE;						forward;
procedure SCAN (
	var	EXPR	: packed array [1..?] of char;
	var	NDX	: integer;
	var	TOKEN	: TOKTYP;
	var	CVALU	: TOKVAL );				forward;
{$PAGE}

procedure INTRP (
		R	: PSTATE;
	var 	IVALUE	: TOKVAL );
{***********************************************************************
*
* INTRP - Interpret syntactical reduction
*
* This routine adds the semantic interpretation to the recognition of
* syntactical reductions.
*
***********************************************************************}
var
   T		: packed record
      case BYTE of
      1:( SYM1	: packed array [1..4] of char);
      2:( SYM	: TWOCHAR;
          SYML	: TWOCHAR );
      3:( SYMR	: TOKVAL )
      end;
   K		: integer ;

function STKVAL (
		DEPTH	: integer ) : TOKVAL;
{***********************************************************************
*
* STKVAL - Get stack value
*
* This routine returns the value of a stack element given its position.
*
***********************************************************************}
var
   STEMP	: SELEMENT_P;
   I		: integer;
  
begin
   STEMP := STACK;			{ Find stack element }
   for I := 2 to DEPTH do
      with STEMP^ do
         STEMP := LINK;
   with STEMP^ do			{ Get value }
      STKVAL := CVALU
end; { STKVAL }
{$PAGE}

{***********************************************************************
*
* Interpret main body
*
***********************************************************************}
begin
   IVALUE := 0.0;
   with T do
      case R of
      1,11:
         IVALUE := STKVAL(2);
      3: IVALUE := - STKVAL(1);
      4: IVALUE := STKVAL(3) + STKVAL(1);
      5: IVALUE := STKVAL(3) - STKVAL(1);
      7: IVALUE := STKVAL(3) * STKVAL(1);
      8: if STKVAL(1) = 0.0 then
            ERROR ( 12, 1 )
         else
            IVALUE := STKVAL(3) / STKVAL(1);
     10: if STKVAL(3) = 0.0 then
            IVALUE := 0.0
         else
            IVALUE := POWER ( STKVAL(3), STKVAL(1) );
     15: begin
            SYMR := STKVAL(1);
            K := 0;
            SYMBOLTABLE ( SYM, IVALUE, K, true )
            end;
     17: begin
            SYMR := STKVAL(4);
            K := round ( STKVAL(2) );
            SYMBOLTABLE ( SYM, IVALUE, K, true )
            end;
     18: begin
            SYMR := STKVAL(4);
            if SYM = 'SQ' then begin	{ FSQT }
               if STKVAL(2) < 0.0 then
                  ERROR ( 12, 2 )
               else
                  IVALUE := sqrt ( STKVAL(2) );
               end
            else if SYM = 'AB' then	{ FABS }
               IVALUE := abs (STKVAL(2))
            else if SYM = 'SG' then	{ FSGN }
               if STKVAL(2) >= 0.0 then
                  IVALUE := 1.0
               else
                  IVALUE := -1.0
            else if SYM = 'IT' then	{ FITR }
               IVALUE := trunc ( STKVAL(2) )
            else if SYM = 'RA' then	{ FRAN }
               IVALUE := GETRANDOM ( SEED )
            else if SYM = 'EX' then	{ FEXP }
               IVALUE := exp ( STKVAL(2) )
            else if SYM = 'SI' then	{ FSIN }
               IVALUE := sin ( STKVAL(2) )
            else if SYM = 'CO' then	{ FCOS }
               IVALUE := cos (STKVAL(2))
            else if SYM = 'AT' then	{ FATN }
               IVALUE := arctan ( STKVAL(2) )
            else if SYM = 'LO' then	{ FLOG }
               if STKVAL(2) <= 0.0 then
                  ERROR ( 12, 3 )
               else
                  IVALUE := ln ( STKVAL(2) )
            else
               ERROR ( 5, 0 )
            end
      otherwise
         IVALUE := STKVAL(1)
      end
end; { INTRP }
{$PAGE}

procedure POP {(
		H	: integer )};
{***********************************************************************
*
* POP - Pop parser stack
*
* This routine pops parse states and token values from the parse stack
* when a reduction is recognized.
*
***********************************************************************}

var
   STEMP	: SELEMENT_P;
   I		: integer;

begin
   for I := 1 to H do
      if STACK = nil then
         escape POP
      else with STACK^ do begin
         STEMP := LINK;
         dispose ( STACK );
         { if STEMP = nil then
            escape POP}
         STACK := STEMP
         end;
end; { POP }
{$PAGE}

function POWER {(
		BASE	: TOKVAL;
		EXPT	: TOKVAL ) : TOKVAL };
{***********************************************************************
*
* POWER - Raise a number to a power.
*
* This function takes a base to a power.
*
***********************************************************************}
var
   TEMP	: TOKVAL;

begin
   TEMP := exp ( EXPT * ln ( abs ( BASE ) ) );
   if BASE < 0.0 then
      if odd(trunc( EXPT )) then
         TEMP := - TEMP;
   POWER := TEMP
end; { POWER }
{$PAGE}

procedure PUSH {(
		S	: PSTATE;
		V	: TOKVAL )};
{***********************************************************************
*
* PUSH - Push parser stack
*
* This routine pushes a parse state and token value onto the parse
* stack.
*
***********************************************************************}
var
   STEMP	: SELEMENT_P;
 
begin
   new ( STEMP );
   if STEMP = nil then
      ERROR ( 8, 1 )
   else begin
      with STEMP^ do begin
         STATE := S;
         CVALU := V;
         LINK  := STACK
         end;
      STACK := STEMP
      end
end; { PUSH }
{$PAGE}

procedure SCAN {(
	var	EXPR	: packed array [1..?] of char;
	var	NDX	: integer;
	var	TOKEN	: TOKTYP;
	var	CVALU	: TOKVAL )};
{***********************************************************************
*
* SCAN - Lexical scanner
*
* This routine is a table driven scanner used to lexically analyze
* source input. Scan is called whenever the parser needs the next
* token in the input stream. The scanner is implemented as a finite
* state machine.
*
***********************************************************************}

const
   NTOK		= 15;			{ NUMERIC TOKEN }
   STOK		= 17;			{ SYMBOLIC TOKEN }
   FTOK		= 19;			{ FUNCTION }
   DIGTYP	= 5;			{ DIGIT TYPE }
   MINUS	= 12;			{ MINUS TYPE }
   AZERO	= '0';			{ ASCII ZERO }
   MAX_EXP	= 75.0;			{ MAXIMUM EXPONENT }

type
   STATE	= 0..63;
   TCHAR	= 0..31;
   ACTION	= SET of ( ERR, BACK, MOVE, EAT, BUILD );

   TRANSITIONS	= array [1..2] of packed record
      A		: ACTION;
      N		: STATE;
      C		: TCHAR
      end;


var
   SELECT,
   CURRENT_STATE: STATE;		{ Scanner current state }
   SEXP, SFRC, 
   DIGNUM,
   EXPSGN	: TOKVAL;
   SDX,
   J,K,I	: integer;
   LACHAR	: char;			{ Look ahead character }
   LATRAN	: TCHAR;		{ Translated look ahead char }
 
   T		: packed record
      case BYTE of
      1:( SYM1	: packed array [1..4] of char);
      2:( SYM	: TWOCHAR;
          SYML	: TWOCHAR );
      3:( SYMR	: TOKVAL )
      end;

COMMON
   SCNTBL	: array [1..2] of record
      ARCS	: ^TRANSITIONS;
      end;

   CHRTBL	: packed array [char] of char;
 
ACCESS SCNTBL, CHRTBL;

begin
   CVALU := 0.0;			{ Initialization }
   SEXP := 0.0;
   SFRC := 0.1;
   EXPSGN := 1.0;

   SDX := 1;
   T.SYM := '  ';
   CURRENT_STATE := 1;			{ Initialize current state }
 
   repeat
      LACHAR := EXPR[NDX];		{ Get current input char }
      if LACHAR in ['a'..'z'] then
         LACHAR := chr ( ord ( LACHAR ) -( ord ( 'a' ) - ord ( 'A' )));
      LATRAN := CHRTBL[LACHAR]::TCHAR;
      DIGNUM := 0.0;
      if LATRAN = DIGTYP then		{ Convert to real number }
         for I := 1 to ord(LACHAR) - ord(AZERO) do 
            DIGNUM := DIGNUM + 1.0;
		
{ Find state transition given current state and input character }

      with SCNTBL[CURRENT_STATE] do begin
L1:      for I := 1 to 20 do with ARCS^[I] do begin
            if (C = LATRAN) or (C = 31) then begin 
					{ State transition found }
	 { PERFORM THE SCAN ACTION for THIS TRANSITION }
               if ERR in A then begin	{ Error, terminate scan	}
                  ERROR ( 11, CURRENT_STATE );
                  escape SCAN
                  end;
               if BACK in A then	{ BACK up in input stream }
                  NDX := NDX - 1;
               if EAT in A then		{ EAT (ignore) character }
                  NDX := NDX + 1;
               if BUILD in A then begin	{ Token found process it }
                  if N = 0 then
                     SELECT := CURRENT_STATE
                  else
                     SELECT := N;
                  case SELECT of
                  1: begin		{ Operator found }
                        if LACHAR in ['[','<','{'] then
                           LACHAR := '('
                        else if LACHAR in [']','>','}'] then
                           LACHAR := ')';
                        TOKEN := ord ( LACHAR )
                        end;
                  2: with T do begin	{ Symbol found }
                        TOKEN := STOK;
                        if SDX <= 2 then 
                           SYM[SDX] := LACHAR;
                        SDX := SDX + 1;
                        CVALU := SYMR
                        end;
                  3: begin		{ Number found }
                        CVALU := CVALU * 10.0 + DIGNUM;
                        TOKEN := NTOK
                        end;
                  4: ;
                  5: begin		{ Exponent found }
                        SEXP := SEXP * 10.0 + DIGNUM;
                        TOKEN := NTOK
                        end;
                  6: with T do begin	{ Function found }
                        TOKEN := FTOK;
                        if SDX <= 2 then
                           SYM[SDX] := LACHAR;
                        SDX := SDX + 1;
                        CVALU := SYMR
                        end;
                  7: begin		{ Fractional part }
                        CVALU := CVALU + (SFRC * DIGNUM);
                        SFRC := SFRC / 10.0;
                        TOKEN := NTOK
                        end;
                  8: if CVALU <> 0.0 then begin
                        if SEXP < MAX_EXP then
                           CVALU := CVALU * POWER (10.0,(SEXP * EXPSGN))
                        else
                           ERROR ( 11, 8 )
                        end;
                  9: if LATRAN = MINUS then 
                        EXPSGN := -1.0;
                     end
                  end;
               CURRENT_STATE := N;	{ Go to new scan state }
               escape L1
               end
	    end
          end;
   until CURRENT_STATE = 0;
end; { SCAN }
{$PAGE}

function TOP {: PSTATE};
{***********************************************************************
*
* TOP - Get current parse state
*
* This routine return the parse state from the top element of the
* parse stack.
*
***********************************************************************}
begin
   with STACK^ do TOP := STATE
end; { TOP }
{$PAGE}

{***********************************************************************
*
* SLR(1) Parser main procedure
*
***********************************************************************}
begin
   CURRENT_STATE := 1;
   STACK := nil;
   PUSH ( CURRENT_STATE, 0 );
   SCAN ( EXPR, NDX, TOKEN, CVALU );	{ Get look ahead input token }
 
   repeat begin
   { Get action entry for current state, look ahead token }
      with PRSTBL[CURRENT_STATE] do begin
L1:      for I := 1 to 100 do with ACT^[I] do begin
            if (T = #7F) or (T = TOKEN::TTYPE) then begin
            { State action found - do ERROR, SHIFT or REDUCE action }
               if (SR = 255) or ERR_FLG then begin
                  if not ERR_FLG then
                     ERROR ( 10, CURRENT_STATE+1 );
                  POP ( 1000 );
                  escape PARSE
                  end;
               if A = SHIFT then begin
                  PUSH ( SR, CVALU );
                  SCAN ( EXPR, NDX, TOKEN, CVALU )
                  end
               else with GOTTBL[SR] do begin
                  INTRP ( SR, IVAL );
                  POP ( HANDLE );
                  C_S := TOP;
                  { Use GOTO tables to get next state }
L2:               for J := 1 to 20 do with GO^[J] do begin
                     if (CRNT = C_S) or (CRNT = 255) then begin
                        PUSH ( NEXT, IVAL );
                        escape L2
                        end
		     end
                  end;
               escape L1
               end
            end;
         end;
      end;
      CURRENT_STATE := TOP
   until CURRENT_STATE = 0;		{ Until input is accepted }
   POP ( 50 )				{ Purge stack }
end; { PARSE }
{$PAGE}

procedure PCPOP;
{***********************************************************************
*
* PCPOP - Pops the PC context
*
* This routine pops the context from the PC stack.
*
***********************************************************************}
var
   P	: PC_STK_PTR;

begin
   P := PC_TOP;
   PC_TOP := P^.PTR;
   dispose ( P )
end; { PCPOP }
{$PAGE}

procedure PCPUSH;
{***********************************************************************
*
* PCPUSH - Push PC context
*
* This routine pushes the program context on the PC stack.
*
***********************************************************************}
var
   P	: PC_STK_PTR;

begin
   new ( P );
   if P = nil then
      ERROR ( 8, 2 )
   else begin
      with P^ do begin
         INDEX := I;
         OLD_PC := PC;
         PTR := PC_TOP
         end;
      PC_TOP := P
      end
end; { PCPUSH }
{$PAGE}

procedure QUIT;
{***********************************************************************
*
* QUIT - QUIT command
*
* This routine processes the QUIT command.
*
***********************************************************************}
var
   P	: DO_STK_PTR;
   Q	: FOR_STK_PTR;

begin
   NEXTFIELD;
   if not (RUN_MODE or DO_MODE) then
      QUIT_FLAG := true;
   RUN_MODE :=	false;
   DO_MODE := false;
   while PC_TOP <> nil do
      PCPOP;
   while DO_TOP <> nil do begin
      P := DO_TOP;
      DO_TOP := P^.PTR;
      dispose ( P )
      end;
   while FOR_TOP <> nil do begin
      Q := FOR_TOP;
      FOR_TOP := Q^.PTR;
      dispose ( Q )
      end
end; { QUIT }
{$PAGE}

procedure RETURN;
{***********************************************************************
*
* RETURN - RETURN command
*
* This routine processes the RETURN command.
*
***********************************************************************}
var
   P	: DO_STK_PTR;
   Q	: FOR_STK_PTR;

begin
   NEXTFIELD;
   if DO_TOP <> nil then begin
      while not ( DO_FLG in PC_TOP^.FLAGS ) do begin
         PCPOP;
         Q := FOR_TOP;
         FOR_TOP := Q^.PTR;
         dispose ( Q )
         end;
      PC := PC_TOP^.OLD_PC;
      I  := PC_TOP^.INDEX;
      PCPOP;
      P := DO_TOP;
      DO_TOP := P^.PTR;
      dispose ( P );
      if DO_TOP = nil then
         DO_MODE := false
      end
end; { RETURN }
{$PAGE}

procedure SETCMD;
{***********************************************************************
*
* SETCMD - SET command
*
* This routine processes the SET command. Syntax:
*   S(ET) <VAR>	= <EXPR>
*
***********************************************************************}
var
   SYM	: TWOCHAR;
   NDX	: integer;
   VAL	: TOKVAL;

begin
   NEXTFIELD;
   GETSYM ( SYM, NDX );
   if PC^.LIN_TXT[I] = ' ' then
      NEXTFIELD;
   if PC^.LIN_TXT[I] in ['(','<','[','{'] then begin
      EXPRESSION ( VAL );
      NDX := round ( VAL )
      end;
   if not ERR_FLG then begin
      if PC^.LIN_TXT[I] = ' ' then
         NEXTFIELD;
      if PC^.LIN_TXT[I] = '=' then begin
         I := I + 1;
         EXPRESSION ( VAL );
         if not ERR_FLG then
            SYMBOLTABLE ( SYM, VAL, NDX, false )
         end
      else
         ERROR ( 10, 0 )
      end
end; { SETCMD }
{$PAGE}

procedure SYMBOLTABLE {(
		SYM	: TWOCHAR;
	var	VAL	: TOKVAL; 
		NDX	: integer;
		FLG	: boolean )};
{***********************************************************************
*
* SYMBOLTABLE - Process symbol table
*
* This routine stores and/or retrieves data from the symbol table.
* If the symbol is not found it is created with an initial value of
* zero.
*
***********************************************************************}
var
   FOUND	: boolean;
   P,
   NEXT		: SYM_NODE_PTR;

begin
   new ( P );
   if P = nil then
      ERROR ( 8, 3 )
   else begin
      with P^ do begin
         SYM_PTR := nil;		{ Initialize new node }
         SYMBOL := SYM;
         INDEX := NDX;
         CVALU := VAL
         end;
      NEXT := SYM_ANCHOR;
      if SYM_ANCHOR = nil then		{ If list empty add at head }
         SYM_ANCHOR := P
      else begin
         FOUND := false;
         while (NEXT <> nil) and not FOUND do
         if (NEXT^.SYMBOL = SYM) and (NEXT^.INDEX = NDX) then
            FOUND := true
         else
            NEXT := NEXT^.SYM_PTR;
         if NEXT = nil then begin	{ Symbol not found }
            P^.SYM_PTR := SYM_ANCHOR;	{ Link new sym at head }
            SYM_ANCHOR := P
            end
         else begin
            dispose ( P );		{ Symbol is found }
            if FLG then			{ If FLAG is true }
               VAL := NEXT^.CVALU	{ Return current value }
            else
               NEXT^.CVALU := VAL
            end
         end
      end
end; { SYMBOLTABLE }
{$PAGE}

procedure TYPECMD;
{***********************************************************************
*
* TYPECMD - TYPE command
*
* This procedure processes the TYPE command. The recognized forms are
* as follows:
*	T(YPE) <VAR>	    TYPE a variable
*	T(YPE) <EXPR>	    TYPE an expression
*	T(YPE) "TEXT"	    TYPE a text string
*
***********************************************************************}

var
   CH	: char;
   ROW,
   COL,
   TMP	: TWOCHAR;
   K,J	: integer;
   P	: SYM_NODE_PTR;
   VAL	: TOKVAL;

procedure FMTNUM (
		VAL	: TOKVAL );
{***********************************************************************
*
* FMTNUM - Format numbers
*
* This routine format numbers for printing in either floating or fixed
* format.
*
***********************************************************************}
var
   L    : integer;
   IVAL : longint;

begin
   PBUF[PNDX] := '='; PNDX := PNDX + 1;
   L := PNDX;
   if DIGITS = 0 and WIDTH > 1 then begin
      IVAL := trunc (VAL);
      encode (PBUF, L, J, IVAL:WIDTH);
      J := WIDTH
      end
   else if WIDTH > 1 then begin
      encode (PBUF, L, J, VAL:WIDTH:DIGITS);
      J := WIDTH
      end;
   if (PBUF[PNDX] = '*') or (WIDTH <= 1) then begin
      encode (PBUF, PNDX, J, VAL);
      J := 0
      end;
   PNDX := PNDX + J;
end; { FMTNUM }
{$PAGE}

{***********************************************************************
*
* Main TYPECMD procedure
*
***********************************************************************}
begin
   NEXTFIELD;
   repeat
      if PNDX >= PLEN then begin	{ Buffer overflow print line }
         PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
         PNDX := PBEG
         end;
      CH := PC^.LIN_TXT[I];
      I := I + 1;
      if CH = '"' then begin		{ Start of text string }
         while (PC^.LIN_TXT[I] <> '"') and
               (PC^.LIN_TXT[I] <> EOL) do begin
            PBUF[PNDX] :=  PC^.LIN_TXT[I];
            PNDX := PNDX + 1;
            I := I + 1
            end;
         if PC^.LIN_TXT[I] <> '"' then
            ERROR ( 6, 0 )
         else
            I := I + 1
         end
      else if CH = '!' then begin	{ Carriage return/line feed }
         PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
         PNDX := PBEG
         end
      else if CH = '##' then begin	{ Carriage return }
         PBUF[2] := chr ( 0 );
         PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
         PBUF[2] := chr ( 10 );
         PNDX := PBEG
         end
      else if CH= '&' then begin	{ Top of form }
         PBUF[PNDX] := chr(12);
         PUTLINE ( PRT_LUN, PBUF, PNDX );
         PNDX := PBEG
         end
      else if CH= '$' then begin	{ Print symbol table }
         if PNDX > PBEG then
            PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
         P := SYM_ANCHOR;
         while P <> nil do begin
            CHECKTERM ( GET_EVT );
            if GET_EVT.STAT <> 0 then
               escape TYPECMD;
            with P^ do begin
               PBUF[PBEG] := SYMBOL[1];
               PBUF[PBEG+1] := SYMBOL[2];
               PBUF[PBEG+2] := '(';
	       PNDX := PBEG + 3;
	       encode ( PBUF, PNDX, J, INDEX:2 );
	       PBUF[PNDX] := ')';
	       PNDX := PNDX + 1;
               FMTNUM ( CVALU );
               end;
	    PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
            P := P^.SYM_PTR
            end;
         PNDX := PBEG
         end
      else if CH = '%' then begin	{ Change numeric format	}
         WIDTH := 1;
         DIGITS := 0;
         if PC^.LIN_TXT[I] in ['0'..'9'] then begin
            GETGRP ( TMP );
            decode ( TMP, 1, J, WIDTH );
            if WIDTH = 0 then WIDTH := 1;
            if PC^.LIN_TXT[I] = '.' then begin
               I := I + 1;
               GETGRP ( TMP );
               decode ( TMP, 1, J, DIGITS );
               end
            end
         end
      else if CH = ':' then begin	{ Tab }
         EXPRESSION ( VAL );
         K := trunc ( VAL ) + PBEG;
         if K > PNDX then
            for J := PNDX to K do begin
               PBUF[J] := ' ';
               end;
         PNDX := K
         end
      else if CH = '@' then begin	{ Position on screen }
         ROW := '01';
         COL := '01';
         CH := PC^.LIN_TXT[I];
         if (CH = 'e') or (CH = 'E') then begin
            I := I + 1;
            CLEARSCREEN
            end;
         if PC^.LIN_TXT[I] in ['0'..'9'] then begin
            GETGRP ( ROW );
            if PC^.LIN_TXT[I] = '.' then begin
               I := I + 1;
               GETGRP ( COL )
               end;
            SCREENPOSITION ( ROW, COL )            
            end;
         CH := PC^.LIN_TXT[I];
         if (CH = 'c') or (CH = 'C') then begin
            I := I + 1;
            CLEARLINE
            end
         end
      else if (CH = ' ') or (CH = ',') then
         CH := CH
      else begin			{ Print value of expression }
         I := I - 1;
         EXPRESSION ( VAL );
         if not ERR_FLG then
            FMTNUM ( VAL )
         end
   until (PC^.LIN_TXT[I] = ';') or (PC^.LIN_TXT[I] = EOL) or ERR_FLG;
end; { TYPECMD	}
{$PAGE}

procedure WRITECMD;
{***********************************************************************
*
* WRITECMD - Write lines command
*
* This procedure processes the WRITE command. The recognized forms are
* as follows:
*      W(RITE) [A(LL)]	    WRITE out entire buffer
*      W(RITE) GRP	    WRITE out a group of lines
*      W(RITE) GRP.STP	    WRITE out a single line
*
***********************************************************************}

var
   FOUND	: boolean;
   P,
   BACK		: LINE_NODE_PTR;
   CH		: char;
   STP,
   GRP		: TWOCHAR;
   J		: integer;

procedure WRITEIT;
{***********************************************************************
*
* WRITEIT - Write a text line
*
* Format and write a source text line.
*
***********************************************************************}
begin
   with P^ do begin
      PBUF[PBEG]   := GRP_NUM[1];
      PBUF[PBEG+1] := GRP_NUM[2];
      PBUF[PBEG+2] := '.';
      PBUF[PBEG+3] := STP_NUM[1];
      PBUF[PBEG+4] := STP_NUM[2];
      J := 1;
      while LIN_TXT[J] <> EOL do begin
         PBUF[PBEG+4+J] := LIN_TXT[J];
         J := J + 1
         end;
      PUTLINE ( PRT_LUN, PBUF, PBEG+3+J )
      end
end; { WRITEIT }
{$PAGE}

{***********************************************************************
*
* Main WRITECMD procedure
*
***********************************************************************}
begin
   NEXTFIELD;
   if PNDX > PBEG then PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
   CH := PC^.LIN_TXT[I];
   if (CH = 'a') or (CH = 'A') or (CH = EOL) or (CH = ';') then begin
      NEXTFIELD;
      P := LINE_ANCHOR;			{ List entire program }
      BACK := LINE_ANCHOR;
      while P <> nil do begin
         CHECKTERM ( GET_EVT );
         if GET_EVT.STAT <> 0 then
            escape WRITECMD;
         WRITEIT;
         BACK := P;
         P := P^.LINE_PTR;
         if P <> nil then
            if BACK^.GRP_NUM <> P^.GRP_NUM then
               PUTLINE ( PRT_LUN, PBUF, 2 )
         end
      end
   else if CH in ['0'..'9'] then begin
      GETGRP ( GRP );
      P	:= LINE_ANCHOR;
      FOUND := false;
      while (P <> nil) and not FOUND do
         if P^.GRP_NUM = GRP then
            FOUND := true
         else
            P := P^.LINE_PTR;
      if P <> nil then begin
         if PC^.LIN_TXT[I] = '.' then begin
            I := I + 1;			{ List one line }
            GETSTP ( STP );
            if not ERR_FLG then begin
               FOUND := false;
               while (P <> nil) and not FOUND do
                  if ( P^.GRP_NUM = GRP) and ( P^.STP_NUM = STP) then
                     FOUND := true
                  else
                     P := P^.LINE_PTR
               end;
            if P <> nil then
               WRITEIT
            end
         else begin
            FOUND := false;
            while (P <> nil) and not FOUND do
               if P^.GRP_NUM = GRP then begin
                  WRITEIT;		{ List a group of lines	}
                  CHECKTERM ( GET_EVT );
                  if GET_EVT.STAT <> 0 then
                     escape WRITECMD;
                  P := P^.LINE_PTR
                  end
               else
                  FOUND := true
            end
         end
      end
   else ;
   PNDX := PBEG
end; { WRITECMD }
{$PAGE}

{**********************************************************************
*								      *
* Main driver							      *
*								      *
**********************************************************************}
begin

   HEAP$TERM (QUIT_FLAG, false );

   PBUF[1] := chr ( 13 );		{ Set carriage control }
   PBUF[2] := chr ( 10 );
   PNDX := PBEG;			{ Index into print buffer }
   PRT_LUN := LOG_LUN;

   WIDTH := 10;				{ Set default width }
   DIGITS := 4;				{ Set default significance }

   SECNDS := 0.0;
   SECNDS := GETSECNDS ( SECNDS );	{ What time is it ? }
   SEED := trunc ( SECNDS );		{ Seed random number gener. }

   LINE_ANCHOR := nil;			{ Set list pointers to nil }
   SYM_ANCHOR := nil;
   PC_TOP := nil;
   FOR_TOP := nil;
   DO_TOP := nil;

   QUIT_FLAG := false;			{ Set initial flags }
   RUN_MODE := false;
   DO_MODE := false;
   PRINT_OPEN := false;

   with GET_EVT do begin		{ Initialize event block }
      STAT := 0;
      FLAG := 0
      end;

   new ( BUFFER );			{ Allocate keyboard buffer }

   repeat
      PC := BUFFER;			{ Point PC to input buff }
      ERR_FLG := false;			{ No errors }
      if PNDX > PBEG then 		{ Print pending text }
         PUTLINE ( PRT_LUN, PBUF, PNDX-1 );
      PNDX := PBEG;
      PBUF[PBEG] := '*';
      PUTLINE ( LOG_LUN, PBUF, 3 );	{ Prompt user for input }
      GETLINE ( LOG_LUN, TBUF, J );	{ Read input }
      for I := 1 to J do
         PC^.LIN_TXT[I] := TBUF[I];
      I := 0;
      EXECLINE				{ Go process input }
   until QUIT_FLAG = true

end. { FOCAL }