{******************************************************************************
*                                                                             *
*                            TINY PASCAL BASIC                                *
*                                                                             *
*                            1980 S. A. MOORE                                 *
*                                                                             *
* Implements a small basic in Pascal. An example of how small a program can   *
* be to implement a simple language.                                          *
* Variables are allowed, using the letters "a" thru "z". Integers are denoted *
* by the letters alone. Strings are denoted by "a$" form.                     *
* The following statements are implemented:                                   *
*                                                                             *
*    input <variable>   Reads the contents of the variable from the user.     *
*                       If the variable is integer, a line is read from the   *
*                       user, then any spaces on the line skipped, then a     *
*                       number read.                                          *
*                       If the variable is string, the entire line is         *
*                       assigned to it, including any spaces.                 *
*                                                                             *
*    print <expr> [,<expr].. [;] Prints the expression. The expression can be *
*                       integer or string. If a trailing ";" exists, the next *
*                       print will resume on the same line. Any number of     *
*                       items may appear to be printed on the same line,      *
*                       separated by ",".                                     *
*                                                                             *
*    goto <integer>     Control resumes at the line specified by the integer. *
*                       Note that no "calculated gotos" are allowed.          *
*                                                                             *
*    if <expr> then <statement>  The expression must be a integer. If the     *
*                       condition is 0, control resumes on the next line.     *
*                       if the condition is not 0, the statement after "then" *
*                       is executed (as well as the rest of the line).        *
*                                                                             *
*    rem <line>         The entire rest of the line is ignored.               *
*                                                                             *
*    stop               Terminates program execution. The values of variables *
*                       are not cleared.                                      *
*                                                                             *
*    run                All variables are cleared, with integers becoming 0,  *
*                       and strings becoming empty. Then control passes to    *
*                       the first statement in the program.                   *
*                                                                             *
*    list [<start>[,<end>]]  Lists all program lines between the given lines. *
*                       The default if no lines are given is the starting     *
*                       and ending lines of the entire program.               *
*                                                                             *
*    new                Clears the entire program and stops execution.        *  
*                                                                             *
*    [let] <var> = <expr>  Assigns the value of the expression to the         *
*                       variable. The variable must be the same type (string  *
*                       or integer) as the expression. The "let" keyword is   *
*                       optional.                                             *
*                                                                             *
*    bye                Exits basic for the operating system.                 *
*                                                                             *
* Expressions can contain the following operators:                            *
*                                                                             *
*    <, >, =, <>, <=, >=          Comparision.                                *
*    +, -, *, /, mod              Basic math.                                 *
*    left$(<str>, <expr>)         The leftmost characters of the string.      *
*    right$(<str>, <expr>)        The rightmost characters of the string.     *
*    mid$(<str>, <start>, <len>)  The middle characters of the string.        *
*    str$(<expr>)                 The string form of the integer expression.  *
*    val(<str>)                   The integer equivalent of the string.       *
*    chr(<str>)                   The ascii value of the first character.     *
*                                                                             *
* The internal form of the program is keyword compressed for effiency, which  *
* both allows for a smaller internal program, and simplifies the decoding of  *
* keywords.                                                                   *
*                                                                             *
*                                                                             *
* Notes:                                                                      *
*                                                                             *
* 1. If the program store were of the same form as basic strings, routines    *
* that handle both in common could be used (example: getting a number from    *
* the string).                                                                *
*                                                                             *
******************************************************************************}

program basics(input, output);

label   88, 77, 99;
 
const   maxlin = 9999; { maximum line number }
        maxpgm = 100;  { maximum line store }
        maxstk = 10;   { maximum temp count }
        maxkey = 29;   { maximum key store }
 
        { key codes }
 
        cinput =  1; cprint =  2; cgoto  =  3; cif    =  4;
        crem   =  5; cstop  =  6; crun   =  7; clist  =  8; 
        cnew   =  9; clet   = 10; cbye   = 11; clequ  = 12;
        cgequ  = 13; cequ   = 14; cnequ  = 15; cltn   = 16;
        cgtn   = 17; cadd   = 18; csub   = 19; cmult  = 20;
        cdiv   = 21; cmod   = 22; cleft  = 23; cright = 24;
        cmid   = 25; cthen  = 26; cstr   = 27; cval   = 28;
        cchr   = 29;
 
type    string10   = packed array [1..10] of char;   { key }
        string80   = packed array [1..80] of char;   { general string }
        bstring80  = record
                       len : integer;
                       str : string80
                    end;
        vartyp     = (tint, tstr); { variable type }
        { error codes }
        errcod     = (eitp, estate, eexmi, eeque, estyp, epbful, eiovf, evare,
                      elabnf, einte, econv, elntl, ewtyp, erpe, eexc, emqu, 
                      eifact, elintl, estrovf, eedlexp, elpe, ecmaexp, estre,
                      estrinx);
 
var     prgm:  array [0..maxpgm] of string80; { program store }
        strs:  array ['a'..'z'] of bstring80;  { string store }
        ints:  array ['a'..'z'] of integer;   { integer store }
        keywd: array [cinput..cchr] of string10; { keywords }
        temp:  array [1..maxstk] of record
                                        typ  : vartyp;
                                        int  : integer;
                                        bstr : bstring80
                                     end;
        prgmc,           { program counter (0 = input line) }
        top,             { current temps top }
        linec: integer;  { character position }

{ print key compressed line }
 
procedure prtlin(var str : string80);
 
var i, j: integer;
 
procedure prtkey(var str : string10);
 
var i, j: integer;
 
begin { prtkey }

   j := 10;
   while (str[j] = ' ') and (j > 0) do j := j - 1;
   j := j + 1;
   i := 1;
   while i < j do begin write(str[i]); i := i + 1 end

end; { prtkey }
 
begin { prtlin }

   j := 80;
   while (str[j] = ' ') and (j > 0) do j := j - 1;
   j := j + 1;
   i := 1;
   while i < j do begin

      if ord(str[i]) < ord(' ') then prtkey(keywd[ord(str[i])])
      else write(str[i]);
      i := i + 1

   end;
   writeln

end; { prtlin }

{ print error }
 
procedure prterr(err : errcod);
 
begin

   if prgmc <> 0 then prtlin(prgm[prgmc]);
   write('*** ');
   case err of
 
      eitp:     writeln('Interpreter error');
      estate:   writeln('Statement expected');
      eexmi:    writeln('Expression must be integer');
      eeque:    writeln('"=" expected');
      estyp:    writeln('Operands not of same type');
      epbful:   writeln('Program buffer full');
      eiovf:    writeln('Input overflow');
      evare:    writeln('Variable expected');
      elabnf:   writeln('Statement label not found');
      einte:    writeln('Integer expected');
      econv:    writeln('Conversion error');
      elntl:    writeln('Line number too large');
      ewtyp:    writeln('Operand(s) of wrong type');
      erpe:     writeln('")" expected');
      eexc:     writeln('Expression too complex');
      emqu:     writeln('Missing quote');
      eifact:   writeln('Invalid factor');
      elintl:   writeln('Line number too large');
      estrovf:  writeln('String overflow');
      eedlexp:  writeln('End of line expected');
      elpe:     writeln('"(" expected');
      ecmaexp:  writeln('"," expected');
      estre:    writeln('String expected');
      estrinx:  writeln('String indexing error')
 
   end;
   goto 88 { loop to ready }

end;

{ check character }
 
function chkchr : char;
 
var c: char;
 
begin

   if linec <= 80 then c := prgm[prgmc][linec]
   else c := ' ';
   chkchr := c

end;

{ check end of line }

function chkend: boolean;

begin

   chkend := linec > 80 { past end of line }

end;
 
{ get character }
 
function getchr: char;
 
begin

   getchr := chkchr;
   if not chkend then linec := linec + 1

end;
 
{ check next character }
 
function chknxt(c : char) : boolean;
 
begin

   chknxt := c = chkchr;
   if c = chkchr then c := getchr

end;
 
{ skip spaces }
 
procedure skpspc;
 
var c: char;
 
begin

   while (chkchr = ' ') and not chkend do c := getchr;

end;

{ check end of statement }

function chksend: boolean;

begin

   skpspc; { skip spaces }
   chksend := chkend or (chkchr = ':') { check eoln or ':' }

end;

{ check null string }
 
function null(var str : string80) : boolean;
 
var i: integer;
    f: boolean;
 
begin

   f := true;
   for i := 1 to 80 do if str[i] <> ' ' then f := false;
   null := f

end;
 
{ check digit }
 
function digit(c : char) : boolean;
 
begin

   digit := (ord(c) >= ord('0')) and (ord(c) <= ord('9'))

end;
 
{ convert to lower case }
 
function lcase(c : char) : char;
 
begin

   if (ord(c) >= ord('A')) and (ord(c) <= ord('Z')) then
      c := chr(ord(c) - ord('A') + ord('a'));
   lcase := c

end;
 
{ check alphabetical }
 
function alpha(c : char) : boolean;
 
begin

   alpha := (ord(lcase(c)) >= ord('a')) and
      (ord(c) <= ord('z'))

end;

{ parse leading integer }
 
function lint(var str : string80) : integer;
 
var i, v: integer;
    b:    boolean;
 
begin

   v := 0;
   i := 1;
   while (i < 80) and (str[i] = ' ') do i := i + 1;
   repeat

      if digit(str[i]) then begin

         v := v*10 + (ord(str[i]) - ord('0'));
         if i <> 80 then begin

            i := i + 1;
            b := false

         end else b := true

      end else b := true

   until b;
   lint := v

end;

{ search label }
 
function schlab(lab : integer):integer;
 
var i: integer;
 
begin

   i := 1;
   while (lab <> lint(prgm[i])) and (i <= maxpgm) do i := i + 1;
   if lab <> lint(prgm[i]) then prterr(elabnf);
   schlab := i

end;
 
{ input string }
 
procedure inpstr(var str : string80);
 
var i: integer;
 
begin

   for i := 1 to 80 do str[i] := ' ';
   i := 1;
   while (i <= 80) and not eoln do begin

      read(str[i]);
      i := i + 1

   end;
   readln;
   if (i > 80) then prterr(eiovf)

end;
 
{ parse variable reference }
 
function getvar : char;
 
begin

   if not alpha(chkchr) then prterr(evare);
   getvar := lcase(getchr)

end;

{ enter line to store }
 
procedure enter(var str : string80);
 
var line, i, j, k: integer;
    f:             boolean;
 
begin

   line := lint(str);
   if line > maxlin then prterr(elintl); { input line number to large }
   i := 1;
   f := false;
   repeat

      if null(prgm[i]) then f := true
      else if lint(prgm[i]) < line then begin

         i := i + 1;
         if i > maxpgm then f := true

      end else f := true

   until f;
   if i > maxpgm then prterr(epbful);
   if null(prgm[i]) then prgm[i] := str
   else if lint(prgm[i]) = line then begin

      j := 1;
      while (str[j] = ' ') and (j < 80) do j := j + 1;
      while digit(str[j]) and (j < 80) do j := j + 1;
      while (str[j] = ' ') and (j < 80) do j := j + 1;
      if j = 80 then begin

         for k := i to maxpgm - 1 do prgm[k] := prgm[k + 1];
         for j := 1 to 80 do prgm[maxpgm][j] := ' '

      end else prgm[i] := str

   end else if not null(prgm[maxpgm]) then prterr(epbful)
   else begin

      for k := maxpgm downto i + 1 do prgm[k] := prgm[k - 1];
      prgm[i] := str

   end

end;

{ compress keys }
 
procedure keycom(var str : string80);
 
var ts:        string80;
    k, i1, i2: integer;
    f:         boolean;
    c:         char;
 
function matstr(var stra: string80; var i: integer;
                 var strb: string10): boolean;
 
var i1, i2: integer;
    f:      boolean;
 
begin { matstr }

   i1 := i;
   i2 := 1;
   repeat

      if strb[i2] = ' ' then f := false
      else if lcase(stra[i1]) = lcase(strb[i2]) then begin

         f := true;
         i1 := i1 + 1;
         i2 := i2 + 1

      end
      else f := false

   until not f or (i1 > 80) or (i2 > 10);
   if i2 > 10 then begin f := true; i := i1 end
   else if strb[i2] = ' ' then begin f := true; i := i1 end
   else f := false;
   matstr := f

end; { matstr }
{}
begin { keycom }

   for i2 := 1 to 80 do ts[i2] := ' ';
   i1 := 1;
   i2 := 1;
   repeat

      if str[i1] = '"' then begin

         ts[i2] := '"';
         i1 := i1 + 1;
         i2 := i2 + 1;
         c := ' ';
         while (i1 <= 80) and (c <> '"') do begin

            c := str[i1];
            ts[i2] := str[i1];
            i1 := i1 + 1;
            i2 := i2 + 1

         end

      end else if str[i1] = ' ' then begin

         ts[i2] := str[i1];
         i1 := i1 + 1;
         i2 := i2 + 1

      end else begin

         k := 1;
         f := false;
         while (k <= maxkey) and not f do
         begin

            f := matstr(str, i1, keywd[k]);
            k := k + 1

         end;
         if f then ts[i2] := chr(k - 1)
         else begin ts[i2] := str[i1]; i1 := i1 + 1 end;
         i2 := i2 + 1

      end

   until i1 > 80;
   for i1 := 1 to 80 do str[i1] := ts[i1]
{ this diagnostic prints the resulting tolken sequence }
{;for i1 := 1 to 80 do write(ord(str[i1]), ' ');}

end; { keycom }

{ get integer }
 
function getint: integer;
 
var v: integer;
 
begin

   v := 0;
   skpspc;
   if not digit(chkchr) then prterr(einte);
   repeat v := v*10 + (ord(getchr) - ord('0'))
   until not digit(chkchr);
   getint := v

end;
 
{ get integer from string }
 
function getval(var str: string80): integer;
 
var i: integer;
 
begin

   i := 1;
   while (i <= 80) and (str[i] = ' ') do i := i + 1;
   if not digit(str[i]) then prterr(einte);
   getval := lint(str);
   while (i < 80) and digit(str[i]) do i := i + 1;
   while (i < 80) and (str[i] = ' ') do i := i + 1;
   if i <> 80 then prterr(econv)

end;

{ get integer from basic string }
 
function getbval(var str: bstring80): integer;
 
var i, v: integer;
 
begin

   i := 1;
   while (i <= str.len) and (str.str[i] = ' ') do i := i + 1; { skip spaces }
   if not digit(str.str[i]) then prterr(einte); { number not present }
   v := 0; { clear result }
   while (i <= str.len) and digit(str.str[i]) do begin { parse digit }

      v := v*10+ord(str.str[i])-ord('0'); { scale, convert and add in digit }
      i := i+1 { next character }

   end;
   while (i <= str.len) and (str.str[i] = ' ') do i := i + 1;
   if i <= str.len then prterr(econv);
   getbval := v { return result }

end;

{ place integer to string }

procedure putbval(var str: bstring80; v: integer);

var p: integer; { power holder }
    i: integer; { string index }

begin

   str.len := 0; { clear result string }
   p := 10000; { set maximum power }
   i := 1; { set 1st character }
   if v < 0 then begin { negative }

      str.str[i] := '-'; { place minus sign }
      i := i + 1; { next character }
      v := -v { negate number }

   end;
   while p <> 0 do begin { fit powers }

      str.str[i] := chr(v div p+ord('0')); { place digit }
      if str.str[1] = '-' then begin { negative }

         if (str.str[2] <> '0') or (p = 1) then i := i + 1; { next digit }

      end else { positive }
         if (str.str[1] <> '0') or (p = 1) then i := i + 1; { next digit }
      v := v mod p; { remove from value }
      p := p div 10 { find next power }

   end;
   str.len := i-1 { set length of string }

end;

{ print basic string }
 
procedure prtbstr(var bstr: bstring80);
 
var i: integer;
 
begin

   for i := 1 to bstr.len do write(bstr.str[i]);

end;
 
{ input basic string }
 
procedure inpbstr(var bstr: bstring80);
 
var i: integer;
 
begin

   for i := 1 to 80 do bstr.str[i] := ' ';
   i := 1;
   while (i < 80) and not eoln do begin

      read(bstr.str[i]);
      i := i + 1

   end;
   if (i > 80) and not eoln then prterr(eiovf);
   readln;
   bstr.len := i

end;
 
{ concatenate basic strings }
 
procedure cat(var bstra, bstrb: bstring80);
 
var i: integer; { index for string }

begin 

   if (bstra.len + bstrb.len) > 80 then prterr(estrovf); { string overflow }
   { copy source after destination }
   for i := 1 to bstrb.len do bstra.str[bstra.len+i] := bstrb.str[i];
   bstra.len := bstra.len + bstrb.len { set new length }

end;

{ check stack items equal }
 
function chkequ : boolean;
 
begin

   if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint) then 
      prterr(ewtyp);
   chkequ := temp[top - 1].int = temp[top].int

end;
 
{ check stack items less than }
 
function chkltn: boolean;
 
begin

   if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint)
      then prterr(ewtyp);
   chkltn := temp[top - 1].int < temp[top].int

end;
 
{ check stack items greater than }
 
function chkgtn: boolean;
 
begin

   if (temp[top].typ <> tint) or (temp[top - 1].typ <> tint)
      then prterr(ewtyp);
   chkgtn := temp[top - 1].int > temp[top].int

end;
 
{ set tos true }
 
procedure settrue;
 
begin

   temp[top].typ := tint;
   temp[top].int := 1

end;
 
{ set tos false }
 
procedure setfalse;
 
begin

   temp[top].typ := tint;
   temp[top].int := 0

end;

{ clear program store }
 
procedure clear;
 
var x, y: integer;
    c:    char;
 
begin

   for x := 1 to maxpgm do
      for y := 1 to 80 do prgm[x][y] := ' ';
   for c := 'a' to 'z' do strs[c].len := 0;
   for c := 'a' to 'z' do ints[c] := 0;
   prgmc := 0;
   linec := 1;
   top := 1

end;
 
{ clear variable store }
 
procedure clrvar;
 
var c: char;
 
begin

   for c := 'a' to 'z' do strs[c].len := 0;
   for c := 'a' to 'z' do ints[c] := 0;
   prgmc := 0;
   linec := 1;
   top := 1

end;

{ execute string }
 
procedure exec;
 
label 1; { exit procedure }
 
var c: char;
 
{ execute statement }
 
procedure stat;
 
var x, y: integer;
    c:    char;
    s:    string80;
    b:    boolean;
 
{ parse expression }
 
procedure expr;
 
{ parse simple expression }
 
procedure sexpr;
 
{ parse term }
 
procedure term;
 
{ parse factor }
 
procedure factor;
 
var i: integer;
    c: char;

begin { factor }

   skpspc;
   c := chkchr; { save starting character }
   if chknxt('(') then begin

      expr;
      if not chknxt(')') then prterr(erpe)

   end else if chknxt(chr(cadd)) then begin

      factor;
      if temp[top].typ <> tint then prterr(ewtyp)

   end else if chknxt(chr(csub)) then begin

      factor;
      if temp[top].typ <> tint then prterr(ewtyp);
      temp[top].int := - temp[top].int

   end else if chknxt('"') then begin

      top := top + 1;
      if top > maxstk then prterr(eexc);
      temp[top].typ := tstr;
      i := 1;
      while (i <= 80) and (chkchr <> '"') do begin

         temp[top].bstr.str[i] := getchr;
         i := i + 1

      end;
      if not chknxt('"') then prterr(emqu);
      temp[top].bstr.len := i - 1

   end else if digit(chkchr) then begin

      top := top + 1;
      if top > maxstk then prterr(eexc);
      temp[top].typ := tint;
      temp[top].int := getint

   end else if alpha(chkchr) then begin

      top := top + 1;
      if top > maxstk then prterr(eexc);
      c := getvar;
      if chknxt('$') then begin

         temp[top].typ := tstr;
         temp[top].bstr := strs[c]

      end else begin

         temp[top].typ := tint;
         temp[top].int := ints[c]

      end

   end else if chknxt(chr(cleft)) or chknxt(chr(cright)) or 
               chknxt(chr(cmid)) then begin

      { left$, right$ }
      skpspc; { skip spaces }
      if not chknxt('(') then prterr(elpe); { '(' expected }
      expr; { parse expression }
      if temp[top].typ <> tstr then prterr(estre); { string expected }
      skpspc; { skip spaces }
      if not chknxt(',') then prterr(ecmaexp); { ',' expected }
      expr; { parse expression }
      if temp[top].typ <> tint then prterr(einte); { integer expected }
      skpspc; { skip spaces }
      if c <> chr(cmid) then begin { left$ or right$ }

         if not chknxt(')') then prterr(erpe); { ')' expected }
         if temp[top].int > temp[top-1].bstr.len then prterr(estrinx);
         if c = chr(cright) then { right$ }
            for i := 1 to temp[top].int do { move string left }
               temp[top-1].bstr.str[i] := 
                  temp[top-1].bstr.str[i+temp[top-1].bstr.len-temp[top].int];
         temp[top-1].bstr.len := temp[top].int; { set new length left }
         top := top-1 { clean stack }

      end else begin { mid$ }

         if not chknxt(',') then prterr(ecmaexp); { ',' expected }
         expr; { parse end expression }
         if temp[top].typ <> tint then prterr(einte); { integer expected }
         skpspc; { skip spaces }
         if not chknxt(')') then prterr(erpe); { ')' expected }
         { check requested length > string length }
         if temp[top].int+temp[top-1].int-1 > temp[top-2].bstr.len then 
            prterr(estrinx);
         for i := 1 to temp[top].int do { move string left }
            temp[top-2].bstr.str[i] := temp[top-2].bstr.str[i+temp[top-1].int-1];
         temp[top-2].bstr.len := temp[top].int; { set new length left }
         top := top-2 { clean stack }

      end
    
   end else if chknxt(chr(cchr)) then begin { chr }

      if not chknxt('(') then prterr(elpe); { '(' expected }
      expr; { parse expression }
      if temp[top].typ <> tstr then prterr(estre); { string expected }
      skpspc; { skip spaces }
      if not chknxt(')') then prterr(erpe); { ')' expected }
      if temp[top].bstr.len < 1 then prterr(estrinx); { check valid }
      c := temp[top].bstr.str[1]; { get the 1st character }
      temp[top].typ := tint; { change to integer }
      temp[top].int := ord(c) { place result }

   end else if chknxt(chr(cval)) then begin { val }

      if not chknxt('(') then prterr(elpe); { '(' expected }
      expr; { parse expression }
      if temp[top].typ <> tstr then prterr(estre); { string expected }
      skpspc; { skip spaces }
      if not chknxt(')') then prterr(erpe); { ')' expected }
      i := getbval(temp[top].bstr); { get string value }
      temp[top].typ := tint; { change to integer }
      temp[top].int := i { place result }

   end else if chknxt(chr(cstr)) then begin { str$ }

      if not chknxt('(') then prterr(elpe); { '(' expected }
      expr; { parse expression }
      if temp[top].typ <> tint then prterr(einte); { integer expected }
      skpspc; { skip spaces }
      if not chknxt(')') then prterr(erpe); { ')' expected }
      i := temp[top].int; { get value }
      temp[top].typ := tstr; { change to string }
      putbval(temp[top].bstr, i) { place value in ascii }

   end else prterr(eifact)

end; { factor }

begin { term }

   factor;
   skpspc;
   while ord(chkchr) in [cmult, cdiv, cmod] do begin

      case ord(getchr) of { tolken }

         cmult: begin { * }
   
            factor;
            if (temp[top].typ <> tint) or
               (temp[top - 1].typ <> tint) then prterr(ewtyp);
            temp[top - 1].int := temp[top - 1].int * temp[top].int;
            top := top - 1

         end;
   
         cdiv: begin { / }
   
            factor;
            if (temp[top].typ <> tint) or
               (temp[top - 1].typ <> tint) then prterr(ewtyp);
            temp[top - 1].int := temp[top - 1].int div temp[top].int;
            top := top - 1

         end;
   
         cmod: begin { mod }
   
            factor;
            if (temp[top].typ <> tint) or
               (temp[top - 1].typ <> tint) then prterr(ewtyp);
            temp[top - 1].int := temp[top - 1].int mod
               temp[top].int;
            top := top - 1

         end

      end;
      skpspc { skip spaces }

   end

end; { term }

begin { sexpr }

   term;
   skpspc;
   while ord(chkchr) in [cadd, csub] do begin

      case ord(getchr) of { tolken }

         cadd: begin

            term;
            if temp[top].typ = tstr then begin
   
               if temp[top - 1].typ <> tstr then prterr(estyp);
               cat(temp[top - 1].bstr, temp[top].bstr);
               top := top - 1
   
            end else begin
   
               if temp[top - 1].typ <> tint then prterr(estyp);
               temp[top - 1].int :=
                  temp[top - 1].int + temp[top].int;
               top := top - 1;
   
            end

         end;
   
         csub: begin { - }
   
            term;
            if (temp[top].typ <> tint) or
               (temp[top - 1].typ <> tint) then prterr(ewtyp);
            temp[top - 1].int := temp[top - 1].int - temp[top].int;
            top := top - 1
   
         end

      end;
      skpspc { skip spaces }

   end

end; { sexpr }

begin { expr }

   sexpr; { parse simple expression }
   skpspc; { skip spaces }
   while ord(chkchr) in [cequ, cnequ, cltn, cgtn, clequ, cgequ] do begin

      case ord(getchr) of { tolken }

         cequ: begin
   
            sexpr;
            if chkequ then begin top := top - 1; settrue end
            else begin top := top - 1; setfalse end
   
         end;
   
         cnequ: begin
   
            sexpr;
            if chkequ then begin top := top - 1; setfalse end
            else begin top := top - 1; settrue end
   
         end;
   
         cltn: begin
   
            sexpr;
            if chkltn then begin top := top - 1; settrue end
            else begin top := top - 1; setfalse end
   
         end;
   
         cgtn: begin
   
            sexpr;
            if chkgtn then begin top := top - 1; settrue end
            else begin top := top - 1; setfalse end
   
         end;
   
         clequ: begin
   
            sexpr;
            if chkgtn then begin top := top - 1; setfalse end
            else begin top := top - 1; settrue end
   
         end;

         cgequ: begin
   
            sexpr;
            if chkltn then begin top := top - 1; setfalse end
            else begin top := top - 1; settrue end
   
         end

     end;
     skpspc { skip spaces }

   end

end; { expr }

{ process "let" function }

procedure let;

begin

   skpspc;
   c := getvar;
   if chknxt('$') then begin

      skpspc;
      if not chknxt(chr(cequ)) then
         prterr(eeque);
      expr;
      if temp[top].typ <> tstr then
         prterr(estyp);
      strs[c] := temp[top].bstr;
      top := top - 1

   end else begin

      skpspc;
      if not chknxt(chr(cequ)) then
         prterr(eeque);
      expr;
      if temp[top].typ <> tint then
         prterr(estyp);
      ints[c] := temp[top].int;
      top := top - 1

   end

end;

begin { stat }

   skpspc;
   if ord(chkchr) < ord(' ') then begin

      if ord(chkchr) > cbye then prterr(estate);
      case ord(getchr) of { statement }
 
         cinput:  begin

                     skpspc;
                     c := getvar;
                     if chknxt('$') then inpbstr(strs[c])
                     else begin

                        inpstr(s);
                        ints[c] := getval(s)

                     end

                   end;
 
         cprint:   begin

                      repeat { list items }

                         expr;
                         if temp[top].typ = tstr then prtbstr(temp[top].bstr)
                         else write(temp[top].int);
                         top := top - 1;
                         skpspc
                      
                      until not chknxt(','); { until not ',' }
                      if not chknxt(';') then writeln

                    end;
 
         cgoto:     begin

                       prgmc := schlab(getint);
                       goto 1

                    end;
 
         cif:       begin

                       expr;
                       if temp[top].typ <> tint then
                          prterr(eexmi);
                       if temp[top].int = 0 then begin

                          top := top - 1;
                          { go next line }
                          if prgmc > 0 then prgmc := prgmc + 1;
                          goto 1

                       end;
                       top := top - 1;
                       b := chknxt(chr(cthen));
                       stat

                    end;
 
         crem:      begin

                       if prgmc > 0 then prgmc := prgmc + 1; { go next line }
                       goto 1 { exit line executive }

                    end;
 
         cstop:     goto 88;
 
         crun:      begin clrvar; prgmc := 1; goto 1 end;
 
         clist:     begin

                       x := 1; { set default list swath }
                       y := maxpgm;
                       if not chksend then begin { list swath is specified }

                          x := schlab(getint);
                          skpspc;
                          { check if end line is specified }
                          if chknxt(',') then y := schlab(getint)

                       end;
                       for x := x to y do { print specified lines }
                          if not null(prgm[x]) then { line exists in buffer }
                             prtlin(prgm[x]) { print }

                    end;
 
         cnew:      begin clear; goto 88 end;
 
         clet:      let;
 
         cbye:      goto 99
 
      end

   end else let { default let }

end; { stat }

begin { exec }

   linec := 1;
   while digit(chkchr) do c := getchr; { skip label }
   repeat stat until getchr <> ':';
   skpspc;
   if not chkend then prterr(eedlexp); { should be at line end }
   if prgmc > 0 then prgmc := prgmc + 1;
   1:

end; { exec }

begin { executive }

   clear;
   { initalize keys }
   keywd[cinput] := 'input     '; keywd[cprint] := 'print     ';
   keywd[cgoto]  := 'goto      '; keywd[cif]    := 'if        ';
   keywd[crem]   := 'rem       '; keywd[cstop]  := 'stop      ';
   keywd[crun]   := 'run       '; keywd[clist]  := 'list      ';
   keywd[cnew]   := 'new       '; keywd[clet]   := 'let       ';
   keywd[cbye]   := 'bye       '; keywd[clequ]  := '<=        ';
   keywd[cgequ]  := '>=        '; keywd[cequ]   := '=         ';
   keywd[cnequ]  := '<>        '; keywd[cltn]   := '<         ';
   keywd[cgtn]   := '>         '; keywd[cadd]   := '+         ';
   keywd[csub]   := '-         '; keywd[cmult]  := '*         ';
   keywd[cdiv]   := '/         '; keywd[cmod]   := 'mod       ';
   keywd[cleft]  := 'left$     '; keywd[cright] := 'right$    ';
   keywd[cmid]   := 'mid$      '; keywd[cthen]  := 'then      ';
   keywd[cstr]   := 'str$      '; keywd[cval]   := 'val       ';
   keywd[cchr]   := 'chr       ';
   writeln;
   writeln('Tiny basic interpreter vs. 0.1 Copyright (C) 1994 S. A. Moore');
   writeln;
   88: while true do begin

      writeln('Ready');
   77: prgmc := 0;
      linec := 1;
      top := 0;
      { get user lines until non-blank }
      repeat inpstr(prgm[0]) until not null(prgm[0]);
      keycom(prgm[0]);
      if lint(prgm[0]) > 0 then begin

         enter(prgm[0]);
         goto 77

      end else repeat

         exec;
         if (prgmc > maxpgm) then prgmc := 0
         else if null(prgm[prgmc]) then prgmc := 0

      until prgmc = 0

   end;
   99: writeln

end.