home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / simcode.arc / TOKEN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-12-03  |  5.5 KB  |  212 lines
  1. {$symtab-,$linesize:131,$pagesize:86,$debug-,
  2. $title:'TOKEN.PAS -- Tokenize the script files'}
  3. {    COPYRIGHT @ 1982
  4.     Jim Holtman and Eric Holtman
  5.     35 Dogwood Trail
  6.     Randolph, NJ 07869
  7.     (201) 361-3395
  8. }
  9.  
  10.  module tokens;
  11.  
  12.     var
  13.        i,j : integer;
  14.        buf : lstring(255);
  15.        str : lstring(255);
  16.        lineno [public] : integer;
  17.        charno [public] : integer;
  18.        line_inc : boolean;
  19.        back_stack : lstring(255);
  20.        back_ptr : integer;
  21.        comp_file_name [external] : lstring(20);
  22.        current_line : lstring(255);
  23.        value lineno := 0;
  24.        charno := 0;
  25.        line_inc := false;
  26.        back_ptr := 0;
  27.  
  28.     function getbchar : integer;
  29.  
  30.        begin
  31.       if (back_ptr > 0) then begin
  32.          getbchar := ord(back_stack[back_ptr]);
  33.          back_ptr := back_ptr - 1;
  34.          end
  35.       else getbchar := -1;
  36.       end;
  37.  
  38.     procedure putbchar(ch : char)[public];
  39.  
  40.        begin
  41.       back_ptr := back_ptr + 1;
  42.       back_stack[back_ptr] := ch;
  43.       end;
  44.  
  45.     procedure putbstr(const s : lstring)[public];
  46.  
  47.        var
  48.       i : integer;
  49.  
  50.        begin
  51.       for i := ord(s.len) downto 1 do putbchar(s[i]);
  52.       end;
  53.  
  54.     function getnextchar(var fd : text) : integer;
  55.  
  56.        var
  57.       c : char;
  58.       i : integer;
  59.       s : lstring(255);
  60.  
  61.        begin
  62.       i := getbchar;
  63.       if (i > -1) then begin
  64.          getnextchar := i;
  65.          charno := charno + 1;
  66.          return;
  67.          end;
  68.       if (eof(fd)) then begin
  69.          getnextchar := - 1;
  70.          return;
  71.          end;
  72.       lineno := lineno + 1;
  73.       charno := 0;
  74.       readln(fd, current_line);
  75.       putbchar(' ');
  76.       putbstr(current_line);
  77.       getnextchar := getnextchar(fd);
  78.       end;
  79.  
  80.     procedure print_error(const mess : lstring;
  81.      back : integer) [public];
  82.  
  83.        var
  84.       i,j : integer;
  85.       buf : lstring(255);
  86.       c : char;
  87.  
  88.        begin
  89.       write(lineno:3,': ');
  90.       writeln(current_line);
  91.       write('-----');
  92.       j := 1;
  93.       for i := 1 to charno-1-back do begin
  94.          if (current_line[i] <> chr(9)) then begin
  95.         j := j + 1;
  96.         write('-')   end
  97.          else begin
  98.         repeat
  99.            write('-');
  100.            j := j + 1;
  101.            until (j mod 8) = 1;
  102.         end;
  103.          end;
  104.       writeln('^ ',mess);
  105.       end;
  106.  
  107.     function next_token(var d : lstring;
  108.      var fil : text) : integer [public];
  109.  
  110.        var
  111.       i,j : integer;
  112.       state : integer;
  113.       s : char;
  114.       nc : integer;
  115.       st : integer;
  116.       typ : integer;
  117. {$include:'token.h'}
  118.  
  119.        begin
  120.       i := 0;
  121.       j := 0;
  122.       s := chr(0);
  123.       st := 1;
  124.       typ := 0;
  125.       nc := getnextchar(fil);
  126.       if (nc > -1) then begin
  127.          while ((chr(nc) = ' ') or (chr(nc) = chr(9))) do begin
  128.         nc := getnextchar(fil);
  129.         if (nc = -1) then break;
  130.         end;
  131.          end;
  132.       state := OUT_QUOTE;
  133.       if (nc > -1) then s := chr(nc);
  134.       while true do begin       {writeln('parsing -',s,'-   -',ord(s));]}
  135.          if (eof(fil) and (s = chr(0))) then begin
  136.         next_token := -1;
  137.         d.len := wrd(j);
  138.         return;
  139.         end
  140.          else if ( ((s = ' ') or (s = chr(9))) and (state = OUT_QUOTE)) then
  141.           begin
  142.         d.len := wrd(j);
  143.         if (d = 'if') then next_token := TOK_IF
  144.         else if (d = 'dial') then next_token := TOK_DIAL
  145.         else if (d = 'send') then next_token := TOK_SEND
  146.         else if (d = 'say') then next_token := TOK_SAY
  147.         else if (d = 'goto') then next_token := TOK_GOTO
  148.         else if (d = 'name') then next_token := TOK_NAME
  149.         else if (d = 'else') then next_token := TOK_ELSE
  150.         else if (d = 'quit') then next_token := TOK_QUIT
  151.         else if (d = 'gosub') then next_token := TOK_GOSUB
  152.         else if (d = 'return') then next_token := TOK_RETURN
  153.         else if (d = '{') then next_token := TOK_LBRACK
  154.         else if (d = '}') then next_token := TOK_RBRACK
  155.         else if (d = 'input') then next_token := TOK_INPUT
  156.         else if (d = 'settime') then next_token := TOK_SETTIME
  157.         else if (d = 'openlog') then next_token := TOK_OPENLOG
  158.         else if (d = 'closelog') then next_token := TOK_CLOSELOG
  159.         else if (d = 'toggle_tr') then next_token := TOK_TOGGLE_TR
  160.         else if (d = 'case') then next_token := TOK_CASE
  161.         else if (d = 'caseend') then next_token := TOK_CASEEND
  162.         else if (d = 'otherwise') then next_token := TOK_OTHERWISE
  163.         else if (d[j] = ':') then next_token := TOK_LABEL
  164.         else begin
  165.            writeln;
  166.            print_error('Warning: constants should have quotes',j);
  167.            next_token := TOK_STR;
  168.            writeln;
  169.            end;
  170.         return;
  171.         end
  172.          else if ( (s = '"') and (state = IN_QUOTE) ) then begin
  173.         nc := getnextchar(fil);
  174.         if (nc <> ord(':')) then begin
  175.            next_token := TOK_STR;
  176.            d.len := wrd(j);
  177.            putbchar(chr(nc));
  178.            return;
  179.            end
  180.         else begin
  181.            j := j + 1;
  182.            d[j] := chr(nc);
  183.            d.len := wrd(j);
  184.            next_token := TOK_LABEL;
  185.            return;
  186.            end;
  187.         end
  188.          else if (s = '"') then state := -1 * state
  189.          else if (s = '\') then begin
  190.         st := st + 1;
  191.         j := j + 1;
  192.         nc := getnextchar(fil);
  193.         if (nc = -1) then begin
  194.            next_token := -1;
  195.            d.len := wrd(j);
  196.            return;
  197.            end;
  198.         s := chr(nc);
  199.         d[j] := s;
  200.         end
  201.          else begin
  202.         j := j + 1;
  203.         d[j] := s;
  204.         end;
  205.          st := st + 1;
  206.          nc := getnextchar(fil);
  207.          if (nc > -1) then s := chr(nc)
  208.          else s := chr(0);
  209.          end;
  210.       end;
  211.  end.
  212.