UNIT scanner; {-*-Mode: fundamental-mode}

INTERFACE {----------------------------------------------------------------------------------------------}
uses base, gpc, dictionary;

type
 scan_handle_t= pointer;

                {token  := next_token (result)}
 token_t      = (finish,              {result = ord (finish_t)}
                 symbol,              {result = ord number of symbol string: 1..2**16-1 (in dictionary)  }
                 value,               {result = ord number of value  string: 1..2**16-1 (in dictionary)  }
                 keyword);            {result = ord number of keyword string 1..2**16-1 (in built-in-dic)}

 finish_t     = (end_of_input, illegal_char, not_terminated);
                {in case of next_token returns finish, reason given in result}

 value_t      = (not_value, comment_const, include_const, keyword_const, symbol_const,
                 integer_const, real_const,
                 text1_const, text2_const, text3_const, text4_const);
                 {in case of next_token returns value, value_type returns the last type of value}

                 {carefully increase enumerated defs due to lack of APOLLO lastof(type)}

 set_of_value_t = set of value_t;

{-------- OPEN THE SCANNER and CUSTOMAZITION ------------------------------------------------------------}
procedure open_scan_new  (var sh     : scan_handle_t);  {create a new scanner object}

procedure def_scan_dic   (sh         : scan_handle_t;   {define dictionaries for various address spaces}
                          dic_handle : dic_handle_t;    {dictionaries must be opened by user}
                          sov        : set_of_value_t); {set of data types using the same dictionary}

procedure def_alphabet   (sh         : scan_handle_t;
                          delimiter_begin,              {' ', chr(9), .. }
                          sym_begin,                    {'ABCabc........'}
                          symbol_cont,                  {'ABCabc0123....'}
                          num_beg,                      {'0123..........'}
                          equ_char   : dic_sym);        {'AaBb..........' will be outphased}

procedure def_quoting    (sh         : scan_handle_t;   {Example:        }
                          str1, str2 : dic_sym;         {def_quoting (sh, '(*', '*)', comment_const); }
                          value_type : value_t);        {def_quoting (sh, '"',  '"',  text1_const);   }

procedure def_keyword_dic(sh         : scan_handle_t;   {predefine keywords, all read from a dictinary}
                          dic_handle : dic_handle_t);

procedure def_keyword    (sh         : scan_handle_t;   {predefine individual keywords, example:}
                          s          : dic_sym);        {def_keyword (sh, 'while'); }

{-------- USING THE SCANNER -----------------------------------------------------------------------------}
procedure def_string     (sh         : scan_handle_t;   {give the scanner a string to be scanned}
                          strg       : dic_sym);

procedure def_file       (sh         : scan_handle_t;   {give the scanner a file to be scanned}
                          path_name  : path_name_t);

function  next_token     (sh         : scan_handle_t;   {scan string/file and get the next token}
                          var result : dic_indx):  token_t;   

function  value_type     (sh         : scan_handle_t): value_t; {value type of last found token}


procedure write_diagn    (sh         : scan_handle_t);  {writes 2 lines to StdErr: last token info}

procedure scan_close     (sh         : scan_handle_t);  {opened dictionaries remain open}
{-------- SCANNER INTERFACE -------------------------- END ----------------------------------------------}

{ Under Discussion:
    sym_begin    ---> symbol_begin
    sym_begin    ---> symber_begin
    all function/procedures begin with scan_

    scan_instead (sh, '<<', '>>', scan_handle);
!R! page; exit;}

IMPLEMENTATION {-----------------------------------------------------------------------------------------}
const
 hash_tab_max    = 16#FF;                    {must be 2**n - 1, used as mask}
 max_sym_len     = 16#1F;                    {should be 2**n, do not change this}

type
 sym_id_t        = ShortInt;                 {symbol identifier type}
 sym_tab_index_t = ShortInt;
 int_str_t       = string (80);              {string of an ShortInt value should fit in, replace?, test}

 cntl_p_t        = ^cntl_blk_t;
 cntl_blk_t      = record
                     next         : cntl_p_t;
                     symid        : sym_id_t;
                     hc, len      : ShortInt;
                     case ShortInt of
                           0 : (A04 : array [1.. 4] of char); 1 : (A08 : array [1.. 8] of char);
                           2 : (A12 : array [1..12] of char); 3 : (A16 : array [1..16] of char);
                           4 : (A20 : array [1..20] of char); 5 : (A24 : array [1..24] of char);
                           6 : (A28 : array [1..28] of char); 7 : (A32 : array [1..32] of char);
                   end;

 trailler_p_t    = ^trailler_t;
 trailler_t      = record
                     tr_p         : trailler_p_t;
                     tr_ch        : char
                   end;

 interp_cntl_p_t = ^interp_cntl_t;
 interp_cntl_t   = record
                     next, down   : interp_cntl_p_t;
                     char_val     : char;
                     terminal     : boolean;
                     id_or_ptr    : value_t;
                     case boolean of
                       false : (id         : sym_id_t);
                       true  : (trailler_p : trailler_p_t);
                    end;

 ch_strt_t       = (ill_strt_char, eol_at_strt, del_strt, sym_strt, num_strt_continue, interp_strt);
  
 file_stack_p_t  = ^file_stack_t;
 file_stack_t    = record
                     dsn_next     : file_stack_p_t;
                     dsn          : dic_sym;
                     f_sav        : text;
                     x0, y0       : ShortInt; 
                     s            : dic_sym 
                   end;

 scan_cb_p_t     = ^scan_cb_t ;
 scan_cb_t       = record
                     root         : interp_cntl_p_t; {root pointer to high priority symbols like => <= or (* }
                     file_stack   : file_stack_p_t;  {pointer to stack of included  files}
                     next_u_symid : sym_id_t;        {next free user symbol identifier}
                     u_dic        : array [value_t] of dic_handle_t;    {pointer to dictionary for user symbols}
                     ending_p     : trailler_p_t;    {nil or pointer to chain of trailling delimiter characters}
                     obj, leng,                      {actual pointers to s}
                     x0, y0       : ShortInt;
                     s            : dic_sym;
                     sym_n        : sym_id_t;
                     data_type    : value_t;         {data type of last detected token}

                     hash_tab     : array [0..hash_tab_max]  of cntl_p_t;  {pointers to predefined keywords}
                     fast_root    : array [#0 .. #255] of interp_cntl_p_t; {fast acces to first root level}
                     alt_ch       : array [#0 .. #255] of char;
                     ch_strt      : array [#0 .. #255] of ch_strt_t;
                     sy_cont      : array [#0 .. #255] of boolean;         {true: legal symbol continue char}
                   end;
{!R! page; exit;}
procedure open_scan_new  (var sh: scan_handle_t);
var  scan_handle: scan_cb_p_t; vt: value_t; i: ShortInt; ch: char; 
begin
 new (scan_handle); sh:= scan_handle;
 with scan_handle^ do 
   begin
     ending_p:= nil;
     s:= ''; x0:= 1; y0:= 1;
     if s [1] <> chr(0) then abort ('Open_scanner, no C delimiter');  {test}
     obj := 1; leng := 0;
     for i:= 0 to hash_tab_max do hash_tab [i] := nil;
     next_u_symid     := 0;
     sym_n            := 1;
     for ch:= chr(0) to chr(255) do
       begin
         alt_ch      [ch] := ch;
         ch_strt     [ch] := ill_strt_char;
         sy_cont     [ch] := false;
         fast_root   [ch] := nil
       end;
     ch_strt [chr(0)] := eol_at_strt;
     root             := nil;
     file_stack       := nil;
     for vt:= not_value  to text4_const do u_dic [vt]:= nil
   end
end;

procedure def_scan_dic   (sh: scan_handle_t; dic_handle :dic_handle_t; sov: set_of_value_t);
const illegal_value_type = [not_value, comment_const, include_const, keyword_const];
var scan_handle: scan_cb_p_t; vt: value_t; 
begin
 scan_handle:= sh;
 with scan_handle^ do if sov * illegal_value_type = []
    then for vt:= not_value to text4_const do
        if vt in sov then if u_dic [vt]=nil then u_dic [vt]:= dic_handle else abort ('Dupl dic def')
                     else {ignore}
    else abort ('def_scan_dic: illegal_values')
end;

{-------- char_defining ---------------------------------------------------------------------------------}
procedure def_alphabet   (sh: scan_handle_t; delimiter_begin, sym_begin, symbol_cont, num_beg, equ_char:dic_sym);
var  scan_handle: scan_cb_p_t; i: ShortInt; ch, ch1, ch2: char; 
begin
 scan_handle:= sh;  
 with scan_handle^ do  
   begin
     for i:= 1 to length (delimiter_begin) do {delimiter starter: typical ' ' and TAB}
       begin
         ch:= delimiter_begin [i];
         if ch_strt [ch] <> ill_strt_char     then abort ('Scanner: Redefinition of delimiter start char: ' + ch);
         ch_strt [ch]:= del_strt
       end;

     for i:= 1 to length (sym_begin) do       {symbol start char: typical A..Z, a..z}
       begin
         ch:= sym_begin [i]; 
         if ch_strt [ch] <> ill_strt_char     then abort ('Scanner: Redefinition of symbol start char: ' + ch);  
         if ch <= ' '                         then abort ('Scanner: Illegal symbol start char');
         ch_strt [ch]:= sym_strt
       end;

     for i:= 1 to length (symbol_cont) do     {symbol continue char: typical A..Z, a..z, 0..9, $}
       begin
         ch:= symbol_cont [i];
         if ch_strt [ch] = del_strt           then abort ('Scanner: symbol continue=delimiter ' + ch);  
         if sy_cont [ch]                      then abort ('Scanner: Redefinition of symbol continue char:' + ch);
         sy_cont [ch]:= true;
       end;

     for i:= 1 to length (num_beg) do         {number starter and continue char}
       begin
         ch:= num_beg [i];
         if ch_strt [ch] <> ill_strt_char     then abort ('Scanner: Redefinition of number start char: ' + ch); 
         ch_strt [ch]:= num_strt_continue;
       end;

     i:= 1;
     while true do
       begin
         while (i<length (equ_char)) and (equ_char [i]=' ') do i:= i+1; if i>=length (equ_char) then break;
         ch1:= equ_char [i]; i:= i+1; ch2:= equ_char [i];
         if ch2<>' '  then begin  alt_ch [ch1]:= ch2; alt_ch [ch2]:= ch1; i:= i+1 end
                      else abort ('equ characters must be pairwise')
       end
   end
end;
{------ character definition --------------------- char_defining -- END ---------------------------------}
{!R! page; exit;}
{------ predefine punctuation and symbols -------- pre_defining -----------------------------------------}
function insert_interp (sh: scan_cb_p_t; str: dic_sym): interp_cntl_p_t; 
var ch: char; i, j, len: ShortInt; p, p1: interp_cntl_p_t;
begin
with sh^ do
  begin 
    len:= length (str); {length of str must be > 0, check before calling this function}
    ch:=  str [1]; 

    if not ((ch_strt [ch] = ill_strt_char) or (ch_strt [ch] = interp_strt))  then 
           abort ('Insert_interp: illegal first char in punctuation string'); 
    ch_strt [ch]:= interp_strt;

    p:= fast_root [ch];
    if p=nil
      then
        begin
          new (p, true); fast_root[ch]:= p; p^.next:= root; root:= p;
          with p^ do begin char_val:= ch; terminal:= false end;
          for i:= 2 to len do
             begin
               new (p1, true);
               with p1^ do begin next:= nil; char_val:= str [i]; terminal:= false end;
               p^.down:= p1;
               p:= p1
             end;
          with p^ do begin down:= nil; terminal:= true end
        end
      else
        begin
          for i:= 2 to len do
             begin
               ch:= str [i];
               p1:= p^.down;
               while (p1<>nil) do begin if ch=p1^.char_val then break; p1:= p1^.next end;
               if p1=nil then
                   begin
                     new (p1, true);
                     p1^.next:= p^.down;
                     p^.down:= p1;
                     with p1^ do begin char_val:= ch; terminal:= false end;
                     for j:= i+1 to len do
                        begin
                           new (p, true);
                           with p^ do begin next:= nil; char_val:= str [j]; terminal:= false end;
                           p1^.down:= p;
                           p1:= p
                        end;
                     with p1^ do begin down:= nil; terminal:= true end;
                     insert_interp:= p1;
                     exit
                   end;
               p:=p1
             end;
          if p^.terminal then begin writeln (StdErr, str); abort ('Duplicate punctuation definition') end;
          p^.terminal:= true
        end;
    insert_interp:= p
  end
end;

procedure def_quoting    (sh: scan_handle_t; str1, str2 : dic_sym; value_type: value_t);
const allowed_value_type= [comment_const, include_const, text1_const, text2_const, text3_const, text4_const];
var  scan_handle: scan_cb_p_t; p: interp_cntl_p_t; p1, p2: trailler_p_t; i: ShortInt;
begin
 scan_handle:= sh; 
 with scan_handle^ do if value_type in allowed_value_type
   then
     begin
       if length (str1) < 1               then abort ('Def_quoting: illegal str1');
       {comments  automatically end at end of line if str2 is a null string;
        data strings must be terminated with matching delimiter in the same line}
       if (length (str2) < 1) and then (value_type <> comment_const) then abort ('Limitpair: illegal str2');
       p:= insert_interp (scan_handle, str1);
       p1:= nil;
       for i:= length (str2) downto 1  do {create trailling char string in reverse order}
           begin new (p2); with p2^ do begin tr_p:= p1; tr_ch:= str2 [i] end; p1:= p2 end;
       with p^ do begin id_or_ptr:= value_type; trailler_p:= p1 end
     end
   else abort ('Def_quoting: illegal value_type');
end;

procedure def_keyword_dic (sh : scan_handle_t; dic_handle : dic_handle_t);
var i: ShortInt;
begin for i:= 1 to dic_last_indx (dic_handle) do def_keyword (sh, dic_symbol (dic_handle, i)) end;  {!R! page; exit;}

function str_of_next_word (s: int_str_t; var index: integer; var ok: boolean): dic_sym; { test ---> inline }
var b: integer; {symbol begins}
begin
  while (index<=length (s)) and (s [index]= ' ') do index:= index+1; {step to first non blank char in s}
  b:= index;
  if index<=length (s)
    then
      begin
        while (index<=length (s)) and (s [index]<>' ') do index:= index + 1;
        str_of_next_word := substr (s, b, index-b);
        ok:= true
      end
    else ok:= false
end;

procedure def_keyword    (sh: scan_handle_t; s        : dic_sym);
var scan_handle: scan_cb_p_t; p: interp_cntl_p_t; temp: cntl_p_t; i, hashcode: ShortInt; ch: char; 
    src: integer; kwstr: dic_sym;
    function next_word_of_str: boolean; var ok: boolean;              {used only once, --> inline}
    begin
      kwstr:= str_of_next_word (s, src, ok); next_word_of_str:= ok
    end;
begin
  src         := 1;
  scan_handle := sh;
  with scan_handle^ do while next_word_of_str { (s, kwstr, src) } do  {next_word_of_str changed}
    begin
      ch:=  kwstr [1];
      if (ch_strt [ch] = ill_strt_char) or (ch_strt [ch] = interp_strt)
        then
          begin  {punctuation}
            p:= insert_interp (scan_handle, kwstr);
            with p^ do begin id_or_ptr:= keyword_const; id:= sym_n end;
          end
        else
          begin  {keyword}
            hashcode:= length (kwstr);
            for i:= 1 to length (kwstr) do
                begin ch:= kwstr [i]; hashcode:= hashcode + max (ord (ch), ord (alt_ch [ch])) end;
            case  length (kwstr) shr 2 of
              0 : begin new (temp, 0); with temp^ do for i:= 1 to length (kwstr) do a04 [i]:= kwstr [i] end;
              1 : begin new (temp, 1); with temp^ do for i:= 1 to length (kwstr) do a08 [i]:= kwstr [i] end;
              2 : begin new (temp, 2); with temp^ do for i:= 1 to length (kwstr) do a12 [i]:= kwstr [i] end;
              3 : begin new (temp, 3); with temp^ do for i:= 1 to length (kwstr) do a16 [i]:= kwstr [i] end;
              4 : begin new (temp, 4); with temp^ do for i:= 1 to length (kwstr) do a20 [i]:= kwstr [i] end;
              5 : begin new (temp, 5); with temp^ do for i:= 1 to length (kwstr) do a24 [i]:= kwstr [i] end;
              6 : begin new (temp, 6); with temp^ do for i:= 1 to length (kwstr) do a28 [i]:= kwstr [i] end;
              7 : begin new (temp, 7); with temp^ do for i:= 1 to length (kwstr) do a32 [i]:= kwstr [i] end
              end;
            with temp^ do begin symid:= sym_n; len:= length (kwstr); hc:= hashcode end;
            i:= hashcode and hash_tab_max;
            temp^.next:= hash_tab [i]; hash_tab [i]:= temp;
          end;
      sym_n:= sym_n + 1;
  end
end;  {------ predefine punctuation and symbols -------- pre_defining --- END ---------------------------}

{------------ preparing the input -----------------------------------------------------------------------}
procedure def_string     (sh: scan_handle_t; strg        : dic_sym);
var scan_handle: scan_cb_p_t; 
begin scan_handle:= sh;  with scan_handle^ do begin s:= strg; x0:= 1; y0:= 1; leng:=0  end end;

procedure def_file       (sh: scan_handle_t; path_name : path_name_t);
var scan_handle: scan_cb_p_t; p: file_stack_p_t;
begin
 scan_handle:= sh; 
 with scan_handle^ do 
   begin 
     if ending_p<>nil then
       begin
         write (StdErr, 'Comment not closed before insert new file'); {begin ..; ending_p:=nil end;}
         write_diagn (scan_handle);
         abort ('')
       end;
     if file_stack<>nil then begin file_stack^.s:= s; file_stack^.x0:= x0; file_stack^.y0:=y0 end;
     new (p);
     with p^ do
       begin
         dsn_next := file_stack;                                      {link to list}
         dsn      := path_name;                                       {remember the path name}
         assign (f_sav, dsn);                                         {open and (APOLLO: check)}
         reset  (f_sav);                                              {init for read}
       end;
     readln (p^.f_sav, s);                                            {and get first line}
     x0:= 1; y0:= 1; leng:=0;
     file_stack:= p;
   end
end;
{------ preparing the input ---------------------- END -----------------------------------!R! page; exit;}
{------ scanning ----------------------------------------------------------------------------------------}
function  next_token     (sh: scan_handle_t; var result     : dic_indx)    : token_t;
 var   scan_handle          : scan_cb_p_t; 
       p0, p1, p2           : interp_cntl_p_t;
       e0, e1               : trailler_p_t;
       temp                 : cntl_p_t;
       x1, x2, i, hashcode  : ShortInt;
       ch, ech              : char;
       sy                   : dic_sym;             dummy: boolean;
 label before_comment, after_comment;

function next_line: boolean;
var p: file_stack_p_t;
begin
with scan_handle^ do 
  begin 
    if file_stack=nil
      then begin leng:= 0; next_line:= false end
      else if eof (file_stack^.f_sav)
             then 
               begin {pop file stack}
                 close (file_stack^.f_sav);
                 if ending_p<>nil then
                   begin
                     write ('Comment not closed before EOF'); {begin .. ending_p:=nil end;}
                     write_diagn (scan_handle);
                     abort ('')
                   end;
                 p:= file_stack;
                 file_stack:= file_stack^.dsn_next; dispose (p);
                 if file_stack<>nil
                      then begin x0:= file_stack^.x0; y0:= file_stack^.y0; s:= file_stack^.s; next_line:= true end
                      else begin leng:= 0; next_line:= false end
               end
             else 
               begin
                 readln (file_stack^.f_sav, s); {scanner accesses 1 byte beyond length (s)}
                 s:= s + ' ';                   {simulate a delimiter, def_alphabet should deliver this. test test}
                 x0:=1; y0:= y0+1; leng:= 0;
                 next_line:= true
               end
  end 
end;

function keyword_present: boolean;
var ptr: cntl_p_t; i: ShortInt; found : boolean;
begin
with scan_handle^ do
  begin
   hashcode:= 0;
   repeat hashcode:= hashcode + max (ord(ch), ord (alt_ch[ch])); x0:= x0+1; ch:= s [x0]
      until (not sy_cont [ch]) or (x0 > length (s));
   leng:= x0 - obj; hashcode:= hashcode + leng;
   ptr:= hash_tab [hashcode and hash_tab_max];
   while ptr<>nil do
     begin
       with ptr^ do if (hc=hashcode) and then (len=leng) then
         begin
          found:= true;                    {this should be optimized}
          for i:= obj to x0-1 do if (s [i] <> a32 [i-obj+1]) and (alt_ch [s [i]] <> a32 [i-obj+1])
             then begin found:= false; break end;
          if found then begin result:= symid; keyword_present:= true; exit end
         end; 
       ptr:= ptr^.next
     end;
   keyword_present:= false
  end
end;

begin  {next_token}
 scan_handle:= sh; 
 with scan_handle^ do 
   begin 
   before_comment:
    if ending_p<>nil then {consume pending comment}
       begin
         e0:= ending_p; ech:= e0^.tr_ch; {ending_p points to expected ending sequence}
         repeat
            while (s [x0]<>char(0)) and (s [x0]<>ech) do x0:= x0+1; {find comment end}
            if x0>length (s) then  {comment again}
               begin obj:=1; if next_line then goto before_comment
                                          else begin next_token:= finish; result:= ord (end_of_input); exit end end;
            e1:= e0; x1:= x0;  {try to find remaining ending character  sequence}
            while e1<>nil do begin if s [x1]<>e1^.tr_ch then break; x1:= x1+1; e1:= e1^.tr_p end;
            x0:=x0 + 1;
            until e1=nil;
         x0:=x1; ending_p:= nil {end of comment found, x0 points to first non comment char or to eol=chr(0)}
       end;
   after_comment:
    while (x0 <= length (s)) and (ch_strt [s [x0]] = del_strt) do x0:= x0 + 1; {adjust x0 after last delimite}
    if x0 <= length (s) then ch:= s [x0] else ch:= #0;                         {obj points to first non delimiter}
    obj:= x0; data_type:= not_value;
    case ch_strt [ch] of
{=>} ill_strt_char: begin next_token:= finish; result:= ord (illegal_char); leng:=1; x0:= x0+1 end;
{=>} eol_at_strt  : if next_line then goto after_comment else begin next_token:=finish;result:= ord(end_of_input) end;
{=>} sym_strt     :                       {x0=obj both pointing now to first character of a symbol}
       if keyword_present              {add as a new user symbol}
         then begin  data_type  := keyword_const; next_token := keyword            end
         else begin  data_type  := symbol_const;  next_token := symbol;  result:=0 end;
{=>} num_strt_continue :  {x0=obj both pointing now to first digit of a number}
       begin
         repeat x0:= x0+1 until ch_strt [s [x0]]<>num_strt_continue;
         if (s [x0]='.') and then (ch_strt [s [x0+1]]=num_strt_continue)
           then
             begin
               x0:=x0+2;
               while ch_strt [s [x0]]=num_strt_continue do x0:= x0+1;
               {1.2E+13 format could be analysed here}
               data_type:= real_const
             end
           else data_type:= integer_const;      {remove trailing zeros here, 16#12ABC (hex, octal etc)}
         leng        := x0-obj;                 {necessary for object}
         next_token  := value;                  {may be overwritten by dic_sym2indx}
         result      := 0;                       
       end;
{=>} interp_strt  :       {x0=obj both pointing now to first character of punctuation string}
       begin
         p0:=fast_root [ch]; x2:= x0; p2:= p0;
         repeat
            if p0^.terminal then begin x2:= x0; p2:= p0 end;  {x2 and p2 correspond with last valid terminal char}
            x0:= x0+1; ch:= s [x0]; p1:= p0^.down;
            while p1<>nil do begin if p1^.char_val=ch then begin p0:= p1; break end; p1:= p1^.next end
            until p1=nil;
         x0:= x2+1; p0:= p2;
         if p0^.terminal
           then with p0^ do if id_or_ptr=keyword_const                    {simple punctuation}
              then begin next_token:= keyword; result:= id; data_type:= keyword_const; leng:= x0-obj end
              else                                                        {comment or enclosed data, string ..}
                begin
                   obj:= x0; e0:= trailler_p;
                   if e0=nil then if id_or_ptr=comment_const
                      then if next_line
                             then goto after_comment
                             else begin next_token:= finish; result:= ord (end_of_input); exit end {comment to eol}
                      else abort ('Scan fatal error: data without termination'); {test}
                   ech:= e0^.tr_ch;
                   repeat
                      while (s [x0]<>char(0)) and (s [x0]<>ech) do x0:= x0+1;
                      if x0>length (s) then if id_or_ptr=comment_const
                        then
                          begin
                            ending_p:= e0;
                            if next_line
                               then goto before_comment
                               else
                                 begin
                                   next_token:= finish; result:= ord (end_of_input);
                                   data_type:= not_value; exit
                                 end
                          end   {comment pending, non closed comment detected by next_line}
                        else
                          begin
                            next_token:= finish; result:= ord (not_terminated); leng:= x0-obj;
                            exit  {termination string not complete}
                          end;
                      e1:= e0; x1:= x0;  {try to find ending character  sequence}
                      while e1<>nil do begin if s [x1]<>e1^.tr_ch then break; x1:= x1+1; e1:= e1^.tr_p end;
                      x0:=x0 + 1;
                      until e1=nil;
                   leng:= x0-obj-1; x0:=x1;
                   if id_or_ptr=comment_const then goto after_comment;
                   if p0^.id_or_ptr=include_const then
                      begin def_file (scan_handle, trim (substr (s, obj, leng))); goto after_comment end;
                   next_token:= value; data_type:= p0^.id_or_ptr
                end
           else begin next_token:= finish; result:= ord (illegal_char); data_type:= not_value;leng:= 1;x0:=obj+1 end
       end;
     otherwise abort ('Fatal otherwise in scanner: next_token') end;     {test}
   if u_dic [data_type]<>nil then dummy:= dic_sym2indx (u_dic [data_type], substr (s, obj, leng), result, create);
  end
end;   {next_token}
{------ scanning ------------------------- END ---------------------------------------------------} {!R! page; exit;}
{------ INQUIERY ---------------------------------------------------------------------------------}
function  value_type  (sh: scan_handle_t): value_t;
var  scan_handle: scan_cb_p_t; begin scan_handle:= sh; value_type:= scan_handle^.data_type end;

{------ DIAGNOSTIC TOOLS -------------------------------------------------------------------------}
procedure write_diagn    (sh: scan_handle_t);  {will be called with an terminated write ('error message')}
var scan_handle: scan_cb_p_t; i: ShortInt;
begin
 scan_handle:= sh; 
 with scan_handle^ do
   begin 
     if file_stack<>nil then writeln (StdErr, ' in line ', y0:1, ' of file ', file_stack^.dsn)
                        else writeln (StdErr);
     if (length (s) <> 0) and (leng > 0) then
       begin
         writeln (StdErr, s);
         for i:= 1 to obj-1 do write (StdErr, ' '); for i:= 1 to leng do write (StdErr, '^');
         writeln (StdErr)
       end
   end
end;

{---------- CLOSE --------------------------------------------------------------------------------}
procedure scan_close (sh: scan_handle_t); {release dynamic allocated data  structure}
var scan_handle: scan_cb_p_t; p: file_stack_p_t; i: ShortInt; p0, p1: cntl_p_t;

procedure dispose_root (p: interp_cntl_p_t);
 var p0, p1: interp_cntl_p_t; e0, e1: trailler_p_t;
begin
  p0:= p;
  while p0<>nil do with p0^ do
   begin
      dispose_root (down);
      if terminal and then (id_or_ptr<>keyword_const) then
          begin
            e0:= trailler_p;
            while e0<>nil do begin e1:= e0; e0:=e0^.tr_p; dispose (e1) end
          end;
      p1:= p0; p0:= p0^.next;
      dispose (p1)
   end
end;

begin {scan_close}
 scan_handle:= sh;
 with scan_handle^ do
   begin
     while file_stack<>nil do
       begin p:= file_stack; file_stack:= file_stack^.dsn_next; close (p^.f_sav); dispose (p) end;
     for i:= 0 to hash_tab_max do
       begin
         p0:= hash_tab [i];
         while p0 <> nil do
           begin
             p1:= p0; p0:= p0^.next;
             case p1^.len shr 2 of
              0 : dispose (p1, 0); 1 : dispose (p1, 1); 2 : dispose (p1, 2); 3 : dispose (p1, 3);
              4 : dispose (p1, 4); 5 : dispose (p1, 5); 6 : dispose (p1, 6); 7 : dispose (p1, 7) end
           end
       end;
     dispose_root (root)
   end;
 dispose (scan_handle)
end;  {scan_close}


{----- SCANNER ----------------------------------- END ------------------------------------}

END.