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

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

type
 check_type_t   = (write_calls,       write_keywords,        write_actions_s,   write_actions_c,
                   write_structure,   write_reference_error, write_convergence);

 parse_handle_t = pointer;
 check_set_t    = set of check_type_t;
 family_name_t  = string (32);

procedure read_bnf      (var ph        : parse_handle_t;    {the new generated handle}
                         src_bnf       : path_name_t;       {Backus Nauer Syntax definitions}
                         check_set     : check_set_t;       {used for diagnostics diagnostic only}
                         var err       : boolean);          {somthing was wrong}

procedure translate_bnf (ph            : parse_handle_t;    {handle give from read_bnf}
                         family_name   : family_name_t;     {family Name}
                         dsn_unit      : path_name_t;       {name of pascal unit, BNF Interpreter}
                         dsn_main      : path_name_t;       {name of pascal main program}
                         offs          : integer);          {}

procedure close_parser  (ph            : parse_handle_t);                                       


(* ------- Action Commands -------------------------------------------------------------------------------------
  Command                              Channel
  Syntax     Function                  Operands    Comments
  --------------------------------------------------------------------------------------------------------------

                                                   SELECTING A CHANNEL 
                                                   -------------------------------------------------------------
   ^A        select channel A                      typically source and destination operand
  ^^B        select channel B                      typically source operand
 ^^^C        select channel C                      typically 3rd operand (condition tests etc.)

                                                   WRITING TO CHANNEL AND FILE
                                                  -------------------------------------------------------------
 'text'      ^A := ^A + 'text'         ^A          append text
  `s`        ^A := ^A + symbol         ^A          append last symbol                             (app_symbol)
  `S`        ^A := ^A + dic(symbol)    ^A          append last symbols dictionary number          (obj_add_ord)
  `v`        ^A := ^A + value          ^A          append last value  (text, Integer, real)       (app_value)
  `c`        ^A := nil                 ^A          clear channel                                  (obj_delete)
  `n`        ^A := ^A + newline        ^A          append newline                                 (obj_add_chr)
  `'`        ^A := ^A + apostr         ^A          append apostr                                  (obj_add_chr)
  `"`        ^A := ^A + quote          ^A          append quote                                   (obj_add_chr)
  ` `        ^A := ^A + blank          ^A          append blank                                   (obj_add_chr)
  `w`      file := file + ^A           ^A          append channel A to file (write ^A to file)    (out_channel)
  `T`      file := file + symbol table             Writes the symbol table                        (obj_add_dic)
  `=`        ^A := ^^B                 ^A ^^B      assign copy of channel B to A  equ. to `c+`    (obj_assign)
  `+`        ^A := ^A + ^^B            ^A ^^B      append copy of channel B to A                  (obj_add_obj)
  `i`        ^A := ^A + ptr (^^B)      ^A ^^B      append reference of channel B to A             (obj_add_obj_inc)
  `m`        ^A := ^A + ^^B; ^^B:=nil  ^A ^^B      append channel B to A by moving                (obj_move_obj)
  `M`        ^A := ^A + (^^M, ^^^P)    ^A ^^M ^^^P append Macro                                   (obj_add_dic_mac)
                                                   Name=symbol,  P=formal parameter,  M=macro   

                                                   LOOP
                                                   ------------------------------------------------------------- 
  `{..b..}`  loop control with break               begin looping, break the loop, end the loop    (break)
   
                                                   DIAGNOSTCS & ERROR 
                                                   ------------------------------------------------------------- 
  `d`        write diagnostc                       write diagnostc line to terminal and continue parsing
  `q`        soft error exit to caller             soft input data error, stop parsing and return to calling program
  `e`        abort                                 hard input data error, stop parsing and abort the parser

                                                   TEST (a and b are any sequences of legal statements)
                                                   Examples: [sa], [s:b], [sa:b], [sabc:xyz]
                                                   ------------------------------------------------------------- 
  `[sa:b]`   if symbol then a else b          ^^^C test if last symbol exists in channel C
  `[ca:b]`   if C=nil  then a else b          ^^^C test if channel C is empty

  `[ta:b]`   if v=text then a else b               test if last value is of type Text
  `[ia:b]`   if v=int  then a else b               test if last value is of type Integer
  `[ra:b]`   if v=real then a else b               test if last value is of type Real
                                                   
                                                   CONDITIONAL ACTIONS if successful continue executing a else b
                                                   -------------------------------------------------------------
  `[oa:b]`   ^A := ^A + ord (s,P)      ^A     ^^^P conditional append ord (symbol in C) to A  (formal parameter)
  `[Ma:b]`   ^A := ^A + exp (s(M),P)   ^A ^^M ^^^P conditional macro expansion P=actual paramlist, M=Macro skeletton  

-------- Action Commands -------------- END ------------------------------------------------------------------*)
{!R! page; exit;}
{--------open questions  -------------------------------------------------------------------------------------
debug control line, column & file_name info from scanner, introduce appl_end ??
abort controllable: abort with diagnostic or soft return to user program (interactive applications)
empty case zB.   ( '' | A | B )   ---> otherwise legen //case mit 2 varianten  mit if then else ??? ist das gut?
scanner should convert various integer formats to standard decimal format, leading zeros suppresed
   16xA   --> 10     2x10  -->  2   0004   -->  4     000   -->  0
(dynamic syntax for number formats???)
case sensitivity in dictionary  and scanner to be solved (by switch?)
priority of keywords: example next,   conditional actions : if symbol exists then else
control diagnostics and control compile versions through bnf file ??, error concept to be clarified 
if the use count of call=0 then prevent declaration of procedure's , also action calls
predeclatation  =  'string' 122 'abc xyz' 12;  hunting a sequence problem
For \w: line length control and recursion control; Automatic constans for parameter:  call (CH1 'immediate' CH2)
New Actions: \= assign ^A:=^^B; \+ add ^A:=^A+^^B; Conditional Actions: \?sabc: xyz if symbol in ^^^CH then to abc

check if really used and prevent declaring routines:  app_data, out_channel, app_symbol, app_value
^^C `i` not working Channel C=nil
rule for giving names must be redesigned (why first entry of bnf must be 'program'?)
parse complains about non existing Channel if using [t...] [i...] [r...], no Channel is neede!
diagnostic `d` points to the next token (no chance to repair??), but generated code should be reduced

if binary mode ---> keine tabelle der key woerter generieren
---------- offene Fragen --END ----------------------------------------------------------------------------}
{--------- PARSE INTERFACE END ----------------------------------------------------------------------------}
{!R! page; exit;}


IMPLEMENTATION {-------------------------------------------------------------------------------------------}
const
  apostr        = chr (39); 

type
  rec_t         = (case_begin, case_split, loop_split, option_split, call, call_entry,
                   appl_symbol, appl_value, appl_keyword, appl_action_s, appl_action_c,
                   appl_chn0, appl_chn1, appl_chn2, appl_channel);
  rec_str_t     = string (20);

  record_p_t    = ^record_t;
  record_t      = record
                    next     : record_p_t;                     {pointer to next object in sequence}
                    gp_index : dic_indx;                       {general purpose index to dictionary}
                    tag      : rec_t;
                     case rec_t of
                      case_begin, case_split, loop_split, option_split,
                      call         : (split     : record_p_t;  {case header, case, loop split: 0..infinite}
                                      tok0, tok1: set_handle_t;{variable length set of potential tokens}
                                      actual_par: record_p_t;  {actual parameteter (valid only for calls)}
                                      tf        : boolean);    {token found        (valid only for calls)}
                      call_entry   : (entry_p   : record_p_t;  {named header of callable bnf structure}
                                      formal_par,              {formal parameter list}
                                      local_var : record_p_t;  {local variable list (channels)}
                                      use_cnt   : Integer;     {use count of substitution}
                                      d_chn0    : dic_indx;    {default channel 0}
                                      d_chn1    : dic_indx;    {default channel 1}
                                      d_chn2    : dic_indx);   {default channel 2}
                      appl_symbol,                             {application symbol expected}
                      appl_value,                              {application value: Integer, Real, Text...}
                      appl_keyword,                            {application keywords: begin end ;  => ...etc} 
                      appl_action_s,                           {chain of data string application actions)} 
                      appl_action_c,                           {chain of commands application actions)} 
                      appl_chn0, appl_chn1, appl_chn2,         {std, aux, test}
                      appl_channel              : ();          {application channel list}
                     end;

  parser_cb_p_t = ^parser_cb_t;
  parser_cb_t   = record
                   scan_handle              : scan_handle_t;   {link to the scanner}
                   dic_handle_calls         : dic_handle_t;    {symbols for syntax substitutions within bnf}  
                   dic_handle_keywords      : dic_handle_t;    {application keywords: <begin> <;> }  
                   dic_handle_strings       : dic_handle_t;    {application actions, strings} 
                   dic_handle_actions       : dic_handle_t;    {application actions, commands} 
                   root_entry               : record_p_t;      {root pointer to chain of callable bnf structures}
                   first_entry              : record_p_t;      {first entry to bnf structure}
                   global_channels          : record_p_t;      {list of global channels (CH1, CH2, ...}
                   gd_chn0, gd_chn1, gd_chn2: dic_indx;        {global default channels (^CH0 ^^CH1 ^^^CH2)}

                   token_min, token_empty, token_max_keyword, token_finish, token_symbol, token_value,
                   token_max                : dic_indx;
                   structure_blanks         : Integer;         {formatting the output}  
                   write_line_numbers       : boolean;         {formatting the output}
                   output_binary            : boolean;         {select binary output, default is ASCII}      
                   used_app_data, used_out_channel, used_app_symbol, used_app_value : boolean;

                   pgm_name,     {'pascal_parser'}  pgm_version,  {'0.0'}           pgm_del_beg,  {' ' and tab etc}
                   pgm_sym_beg,  {'A..Za..z'}       pgm_sym_cont, {'A..Za..z_0..9'} pgm_num_beg,  {'0123456789'}
                   pgm_equ_char, {'AaBb....'}       pgm_comments, {'{ . (*  #'}     pgm_include,  {'%include ;'}
                   pgm_txt_del,  {'" "'}            pgm_options   {'v123L'} : dic_sym;      

                   error_count              : integer;        {indicates any error in bnf structure}
                  end;


var
  dummy    : boolean;  {discard useless boolean function return values}
  dummy_ch : char;     {discard useless character function return values}

procedure wr_dic  (dh: dic_handle_t);  var index: dic_indx;
begin for index:= 1 to dic_last_indx (dh) do writeln (index:4, ' ', dic_symbol (dh, index)) end;

function non_zero_ch (local, global: dic_indx): dic_indx;
begin if local<>0 then non_zero_ch:= local else non_zero_ch:= global end;  

function str_tag (t: rec_t): rec_str_t;
begin
 case t of
  case_begin   :str_tag:='case_begin';   case_split   :str_tag:='case_split';   loop_split  :str_tag:='loop_split';
  option_split :str_tag:='option_split'; call         :str_tag:='call';         call_entry  :str_tag:='call_entry';
  appl_symbol  :str_tag:='appl_symbol';  appl_value   :str_tag:='appl_value';   appl_keyword:str_tag:='appl_keyword';
  appl_action_s:str_tag:='appl_action_s';appl_action_c:str_tag:='appl_action_c';appl_chn0   :str_tag:='appl_chn0';
  appl_chn1    :str_tag:='appl_chn1';    appl_chn2    :str_tag:='appl_chn2';    appl_channel:str_tag:='appl_channel';
  otherwise     str_tag:='?' end
end;

{!R! page; exit;}

procedure read_bnf (var ph: parse_handle_t; src_bnf: path_name_t; check_set: check_set_t; var err: boolean);
const 
  sym_begin         = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  symbol_cont       = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789';
  max_iterations    = 30;
     
type                 (*         symbol      value      =   [    ]    {    }    ((  ))  |    .    ;      (     )  *) 
  parser_keywords_t = (illegal, bnf_symbol, bnf_value, eq, eka, ekz, gka, gkz, ka, kz, bar, pnt, semik, par0, par1,
                                                             (*  ^    ^^   ^^^ *)
                                                              chn0, chn1, chn2);
var  parser_cb_p    : parser_cb_p_t;
     token          : token_t;      {last returned token from scanner}
     result         : dic_indx;     {last returned result from scanner}
     call_entry_p   : record_p_t;   {pointer to call, first used for building then for checking bnf structure}
     init_token_cnt,
     change_cnt,                    {change count, token prediction for substitutions}
     empty_lo_cnt,                  {empty loop and option token prediction}
     empty_case_cnt,                {multiple empty token in case list, one empty case allowd}
     dupl_case_cnt  : integer;      {duplicate token in case list}
     i              : Integer;      {general purpose index}
     verbose        : boolean;      {if true talk about any error}
     error_flag     : boolean;      {Error flag is redundant, it is true if error_count is <>0}

 procedure diagnostic (err: err_str_t);
 begin write (StdErr, 'Error: ', err, chr(7)); write_diagn (parser_cb_p^.scan_handle); abort ('') end;

 procedure inc_error; begin error_flag:= true; with parser_cb_p^ do error_count:= error_count + 1 end;

 procedure finish_unexpected (result: Integer);                 {never returning routine}
 begin {finish_unexpected}
   case result of
     ord (end_of_input)   : diagnostic ('EOF not expected');
     ord (illegal_char)   : diagnostic ('Illegal Character');
     ord (not_terminated) : diagnostic ('Oject not terminated'); {String or comment line not terminated}
     otherwise              diagnostic ('Fatal result')          {test remove this line if the program is stable}
     end;
 end;  {finish_unexpected}

 function new_obj (object_type: rec_t): record_p_t;
 var p: record_p_t;
 begin {new_obj}
   case object_type of
     case_begin, case_split, loop_split, option_split,
     call         : begin
                      new (p, case_begin);
                      with p^ do begin split   := nil; tok0:= nil; tok1:= nil; actual_par:= nil; tf:= true end
                    end;
     call_entry   : begin
                      new (p, call_entry);
                      with p^ do
                        begin
                          entry_p := nil; formal_par:= nil; local_var:= nil; use_cnt :=0;
                          d_chn0:=0; d_chn1:=0;  d_chn2:=0
                        end
                    end;
     appl_symbol  : new (p, appl_symbol);  appl_value  : new (p, appl_value);
     appl_keyword : new (p, appl_keyword);
     appl_action_s: new (p, appl_action_s);
     appl_action_c: new (p, appl_action_c);
     appl_chn0    : new (p, appl_chn0);
     appl_chn1    : new (p, appl_chn1);
     appl_chn2    : new (p, appl_chn2);
     appl_channel : new (p, appl_channel)
     otherwise abort ('Fatal program error in new_object')  {test remove this line after module works stable}
     end;
   with p^ do begin next:= nil; gp_index:= 0; tag:= object_type end;
   new_obj := p
 end;  {new_obj}

 function find_call_entry_p (index: dic_indx; must_be_new: boolean): record_p_t;
 var p: record_p_t; 
 begin {find_call_entry_p}           {returns nil if not found and auto_generate=false}
  with parser_cb_p^ do
    begin
      p := root_entry;
      while (p<>nil) and then (p^.gp_index<>index) do p:= p^.next;
      if p=nil
        then
          begin
             p:= new_obj (call_entry);
             with p^ do begin tag:= call_entry; gp_index:= index; next:= root_entry end;
             if root_entry=nil then first_entry:= p; {remember first's line subtitution} 
             root_entry:= p
          end
        else if must_be_new and (p^.entry_p<>nil) then diagnostic ('Duplicate substitution name');
      find_call_entry_p:= p
    end
 end;  {find_call_entry_p}                {!R! page; exit;} 

 function parameter_exists (parameter_list: record_p_t): boolean;
 var p: record_p_t;
 begin
   p:= parameter_list;
   while p<>nil do with p^ do begin if result=gp_index then break; p:= next end;
   parameter_exists:= p<>nil
 end;

 function parameter_undeclared (c1, c2, c3: record_p_t): boolean;
 begin parameter_undeclared:= not (parameter_exists (c1) or parameter_exists (c2) or parameter_exists (c3)) end;

 procedure get_default_channels (var c0, c1, c2: dic_indx; list0, list1: record_p_t); 
    procedure get_d_chn (var d_chn: dic_indx);
    begin
      with parser_cb_p^ do
        begin
          if next_token (scan_handle, result) = symbol
             then begin if d_chn<>0 then diagnostic ('Default channel redefined'); d_chn:= result end
             else diagnostic ('Channel expected after ^ or ^^');
          if parameter_undeclared (list0, list1, global_channels) then diagnostic ('Channel not declared')
        end
    end;
 begin   {get_default_channels}
   while (token=keyword) and ((result=ord (chn0)) or (result= ord (chn1)) or (result= ord (chn2)))  do 
     begin
       case result of
         ord (chn0) : get_d_chn (c0);
         ord (chn1) : get_d_chn (c1);
         ord (chn2) : get_d_chn (c2);
         otherwise end;
       token:= next_token (parser_cb_p^.scan_handle, result);
     end
 end;    {get_default_channels}

 procedure get_parameter_list
    (var parameter_list : record_p_t;   {new list of channels read from input}
     parameter_list_1   : record_p_t;   {existing list to be checked, if must_be_unique is true}
     must_be_unique     : boolean);
 var p, p1: record_p_t;                 {first par or delimiter already in token & result} 
 begin
  p:= nil;
  while token=symbol do
   begin
    if must_be_unique
      then if parameter_exists (p) or parameter_exists (parameter_list_1)
              then diagnostic ('duplicate channel')
              else
      else with call_entry_p^, parser_cb_p^ do
           if parameter_undeclared (formal_par, local_var, global_channels)
              then diagnostic ('Channel not declared')
              else begin end;
    new (p1, appl_channel);
    with p1^ do begin next:= p; gp_index:= result; tag:= appl_channel end;
    p:= p1;
    token:= next_token (parser_cb_p^.scan_handle, result); 
   end;
  if token<>keyword then diagnostic ('parameter list error'); {list always ends with: ) or =}
  {reverse the order of parameters here, if necessary}
  parameter_list:= p
 end;

 function set_definition (s: dic_sym; var v: dic_sym): boolean;
 begin
   with parser_cb_p^ do if dic_symbol (dic_handle_calls, result) <> s then set_definition:= false else
     begin
       token:= next_token (scan_handle, result);
       if (token <> value) (* or (value_type (dic_handle_strings) <> text2_const) *)
                                                                       then diagnostic ('String expected');
       if v<>''                                                        then diagnostic ('duplicate definition');
       v:= dic_symbol (dic_handle_strings, result);
       token:= next_token (scan_handle, result);
       if (token <> keyword) or (result <> ord (semik))                then diagnostic ('; expected');
       set_definition:= true
     end
 end;                                {!R! page; exit;} 

 function expression (var pfirst: record_p_t): parser_keywords_t;
 var p0, p1,                     {currently build expression}
     case_list,                  {used if case expression (|) is detected}
     append0       : record_p_t; {object chain to be appended by append_object}
     stop_repeat   : boolean;    {switch to stop the repeat loop}

   procedure append_object;
   begin
     if append0=nil then diagnostic ('cant append nil obj') else if p0=nil then p0:=append0 else p1^.next:=append0;
     p1:= append0
   end;

   procedure append_new_obj (object_type: rec_t); begin append0:= new_obj (object_type); append_object end;

   procedure append_case;   var tmp: record_p_t;
   begin
     if p0=nil then diagnostic ('empty case expr');
     tmp:= new_obj (case_split);
     with tmp^ do begin next:= case_list; split:= p0 end;
     case_list:= tmp
   end;

   procedure append_chn (chn: rec_t);
   begin
     with call_entry_p^, parser_cb_p^ do 
       begin 
         append_new_obj (chn);
         if next_token (scan_handle, result) <> symbol                    then diagnostic ('Channel expected');
         if parameter_undeclared (formal_par, local_var, global_channels) then diagnostic ('Channel not declared');
         append0^.gp_index:= result
       end
   end;                              {!R! page; exit;} 
         
 begin {expression}
   p0          := nil;
   p1          := nil;   {test may be redundant}
   case_list   := nil;   {if <> nil case expression is active}
   stop_repeat := false;
   with parser_cb_p^ do
     repeat
       token := next_token (scan_handle, result); 
       case token of
         finish : begin expression:= illegal; stop_repeat:= true; finish_unexpected (result) end;
         symbol : begin {result = ord number of symbol string: 1..2**16-1 (in dictionary)}
                    append_new_obj (call);
                    with append0^ do
                     begin split:= find_call_entry_p (result, false); with split^ do begin use_cnt:= use_cnt+1 end end;
                  end;
         value  : begin
                    case value_type (scan_handle) of                  
                      text1_const :  append_new_obj (appl_keyword);
                      text2_const :  append_new_obj (appl_action_s);
                      text3_const :  append_new_obj (appl_action_c);
                      otherwise diagnostic ('Fatal value_type') end;
                    append0^.gp_index := result;
                  end;
         keyword: case result of      {result = ord number of keyword string 1..2**16-1 (built in dic)}
                   ord (illegal)   : diagnostic ('Fatal illegal keyword');
                   ord (bnf_symbol): append_new_obj (appl_symbol);
                   ord (bnf_value) : append_new_obj (appl_value);
                   ord (ka)        : begin
                                       if expression (append0) <> kz then diagnostic (') expected');
                                       append_object;               {p1 points to last object}
                                       while append0<>nil do begin p1:= append0; append0:= append0^.next end
                                     end;
                   ord (eka)       : begin
                                       append0:= new_obj (option_split); append_object;  
                                       if expression (append0^.split) <> ekz then diagnostic ('] expected'); 
                                     end;
                   ord (gka)       : begin
                                       append0:= new_obj (loop_split);   append_object;
                                       if expression (append0^.split) <> gkz then diagnostic ('} expected');
                                     end;
                   ord (bar)       : begin append_case; p0:= nil; p1:= nil        end;
                   ord (kz)        : begin stop_repeat:= true; expression:= kz    end;
                   ord (ekz)       : begin stop_repeat:= true; expression:= ekz   end;
                   ord (gkz)       : begin stop_repeat:= true; expression:= gkz   end;
                   ord (pnt)       : begin stop_repeat:= true; expression:= pnt   end;
                   ord (semik)     : begin stop_repeat:= true; expression:= semik end;
                   ord (eq)        : begin stop_repeat:= true; expression:= eq    end;
                   ord (par0)      : if append0=nil
                                       then diagnostic ('parameter not valid here')
                                       else with append0^ do if tag<>call
                                         then diagnostic ('parameter valid only after substitution name')
                                         else
                                          begin
                                           token:= next_token (scan_handle, result);
                                           get_parameter_list (actual_par, nil, false);
                                           if result <> ord (par1) then diagnostic (') expected')
                                          end;
                   ord (par1)      : diagnostic (') valid only after parameter list');
                   ord (chn0)      : append_chn (appl_chn0);
                   ord (chn1)      : append_chn (appl_chn1);
                   ord (chn2)      : append_chn (appl_chn2);
                   otherwise abort ('Fatal result in expression') {test remove this line if program is stable}
                   end;
         otherwise abort ('Fatal token in expression')            {test remove this line if program is stable}
         end
       until stop_repeat;
   if case_list<>nil then begin append_case; p0:= new_obj (case_begin); p0^.split:= case_list end;
   if p0=nil then diagnostic ('empty expression');
   pfirst:= p0
 end;  {expression}           {!R! page; exit;}
 (*-----------------------------------------------------------------------------------------------*) 
 procedure find_token_all (bnf_list: record_p_t; var sot: set_handle_t; var token_found: boolean); 
 var p: record_p_t; token: set_handle_t;
 begin {find_token_all}
  p:= bnf_list;
  token:=nil;
  while p<>nil do with p^ do
   begin
     token_found:= false;
     case tag of
       case_begin, case_split, loop_split,
       option_split  : begin
                         find_token_all (split, token, dummy);
                         set_union (sot, token, sot); if tag=case_begin then begin token_found:= true; break end
                       end;
       call          : begin set_union  (sot, tok0, sot); token_found:= tf; if tf then break end;
       call_entry    : abort ('call_entry found in find_token');
       appl_symbol   : begin set_add_element (sot, parser_cb_p^.token_symbol); token_found:= true; break end;
       appl_value    : begin set_add_element (sot, parser_cb_p^.token_value);  token_found:= true; break end;
       appl_keyword  : begin set_add_element (sot, gp_index);                  token_found:= true; break end;
       appl_action_s, appl_action_c, appl_chn0, appl_chn1, appl_chn2, appl_channel  : ;
       otherwise abort ('Fatal tag ' + str_tag (tag) + ' in find_token_all') {test remove if program ok}
       end;
     p:= next
   end
 end;  {find_token_all}

 procedure init_token (ptr_to_obj: record_p_t);
 var p, p1: record_p_t; token0, token1, acc, t: set_handle_t; ec: Integer;
 begin {init_token}
  p:= ptr_to_obj;
  token0:=nil; token1:=nil; acc:= nil; t:= nil;
  while p<>nil do with p^ do 
   begin
     set_make_empty (token0); set_make_empty (token1);
     case tag of
       case_begin  : begin
                      init_token       (split);
                      p1:= split; set_make_empty (acc); ec:= 0;
                      while p1<>nil do with p1^ do
                        begin
                          if set_empty (tok1) then begin ec:= ec+1; if ec>1 then empty_case_cnt:=empty_case_cnt +1 end;
                          set_intersection (tok1, acc, t);
                          if not set_empty (t) then
                             begin
                               dupl_case_cnt:= dupl_case_cnt +1;
                               if verbose then begin set_write (t, parser_cb_p^.dic_handle_keywords); writeln end
                             end;
                          set_union    (acc, tok1, acc);
                          p1:= next
                        end
                     end;
       case_split  : begin
                      find_token_all   (split,  token1, tf);     {look only for contents of individual case}
                      if not set_equal (token1, tok1)            then change_cnt:= change_cnt + 1;
                      set_assign       (token1, tok1); 
                      init_token       (split);
                     end;
       loop_split,
       option_split: begin
                      find_token_all   (split,  token1, tf);     {look for bnf elements in loops and options}
                      if not set_equal (token1, tok1)            then change_cnt:= change_cnt + 1;
                      set_assign       (token1, tok1);
                      if set_empty     (tok1)                    then empty_lo_cnt := empty_lo_cnt  + 1; 

                      find_token_all   (next,   token0, tf);     {look for linear following bnf elements} 
                      set_exclusion    (token0, token1, token0); {exclude elements from linear sequence}
                      if not set_equal (token0, tok0)            then change_cnt:= change_cnt + 1;  
                      set_assign       (token0, tok0); 

                      init_token       (split);   
                     end;
       call        : begin
                      find_token_all   (split^.entry_p, token0, tf);
                      if not set_equal (token0, tok0)            then change_cnt:= change_cnt + 1; 
                      set_assign       (token0, tok0);
                     end;
       call_entry  : abort ('call_entry found in init_token'); 
       appl_symbol, appl_value, appl_keyword, appl_action_s, appl_action_c,
       appl_chn0, appl_chn1, appl_chn2, appl_channel : ;
       otherwise abort ('Fatal tag ' + str_tag (tag) + ' in init_token')               {test rm this line if pgm ok}
       end;
     p:= next
   end
 end;  {init_token}           {!R! page; exit;}

 procedure init_token_global;   var p: record_p_t;
 begin {init_token_global}
 with parser_cb_p^ do   
   begin  
     change_cnt:=0; empty_lo_cnt:=0; empty_case_cnt:= 0; dupl_case_cnt:= 0;
     p:= root_entry; while p<>nil do with p^ do
       begin
         if verbose then begin write ('Name: '); write (dic_symbol (dic_handle_calls, gp_index)); writeln end;
         init_token (entry_p);
         p:= next
       end;
   end
 end;  {init_token_global}   

 procedure wr_set_of_token (sh: set_handle_t; dh: dic_handle_t); 
 begin
   with parser_cb_p^ do
     begin
       if set_element_of (sh, token_value)  then write (' value');
       if set_element_of (sh, token_symbol) then write (' symbol')
     end;
   set_write (sh, dh)
 end;

 procedure write_ccb (ccb: record_p_t; any_case: boolean);
 begin
   with ccb^ do
     begin
       if any_case or ((entry_p=nil) or ((use_cnt=0) and (next<>nil))) then
         begin
           write ('Substitution: ', gp_index:2, ', use_cnt: ', use_cnt:2, ', Name: ',
                   dic_symbol (parser_cb_p^.dic_handle_calls, gp_index));
           if entry_p=nil                 then begin write (' never declared');               err:= true end;
           if (use_cnt=0) and (next<>nil) then begin write (' declared but never refereced'); err:= true end;
           writeln
         end
     end
 end;

 procedure write_expr (expr_p: record_p_t; blanks: Integer);
 const offs=2;
 var p: record_p_t;
 begin
   p:= expr_p;
   while p<>nil do with parser_cb_p^, p^ do
    begin
      write (' ':blanks, str_tag (tag):16, ' '); 
      case tag of
        case_begin    : begin writeln; write_expr (split, blanks+2) end;
        case_split, loop_split,
        option_split  : begin
                          if tag<>case_split then write (' TOK0->  '); wr_set_of_token (tok0, dic_handle_keywords);
                          write (' TOK1-v  '); wr_set_of_token (tok1, dic_handle_keywords);
                          if set_empty (tok1) then write ('ERROR: not any token exists'); 
                          writeln;
                          write_expr (split, blanks+offs)
                        end;
        call_entry    : begin writeln; abort ('Fatal error: call_entry found in expression') end;
        call          : if split<>nil
                          then
                            begin
                              write (dic_symbol (dic_handle_calls, split^.gp_index)); 
                              write (' TOK0-> '); wr_set_of_token (tok0, dic_handle_keywords);
                              writeln
                            end
                          else writeln (' ERROR: unknown substitution');
        appl_symbol,
        appl_value    : writeln;
        appl_keyword  : writeln (dic_symbol (dic_handle_keywords, gp_index));
        appl_action_s :{writeln (dic_symbol (dic_handle_strings,  gp_index)) };    {test}
        appl_action_c :{writeln (dic_symbol (dic_handle_actions,  gp_index)) };    {test}
        appl_chn0, appl_chn1, appl_chn2,
        appl_channel  : ;
        otherwise       writeln; abort ('Fatal tag in ' + str_tag (tag) + ' write_expr') end;
      p:= next
    end
 end;

 function bnf_name: dic_sym;
 begin bnf_name:= dic_symbol (parser_cb_p^.dic_handle_calls, call_entry_p^.gp_index) end;       {!R! page; exit;}

 procedure check_parameter_count (bnf_list: record_p_t; chn0, chn1, chn2: dic_indx);
 var p, p1: record_p_t; c0, c1, c2: dic_indx;

   procedure test_action_c;
   var i: Integer; s: dic_sym;

     procedure wr_error (txt: family_name_t);
     begin
       inc_error;
       writeln ('Error: ', txt, ', in Substitution: ', bnf_name);
       writeln ('`', s, '`');
       writeln (' ':i, '^');
       abort ('First action check failed') 
     end;

     procedure chk_chn (index: dic_indx); begin if index=0 then wr_error ('Channel undefined') end; 

     function cond_cmnd: boolean;
     begin
       cond_cmnd:= true;
       case s [i] of
         's', 'c'      :                                   chk_chn (c2);     {check existance of ^^^C}
         't', 'i', 'r' : ;                                                   {no checks needed }
         'o'           : begin chk_chn (c0);               chk_chn (c2) end; {check ^A and ^^B}
         'M'           : begin chk_chn (c0); chk_chn (c1); chk_chn (c2) end; {check ^A, ^^B and ^^^C} 
         otherwise cond_cmnd:= false end;
     end;

     function wr_stmt: char;
     var cont_loop: boolean;
     begin
       wr_stmt:= chr (1); {illegal return code}
       cont_loop:= true;
       while cont_loop and (i<=length (s)) do
         begin
           case s [i] of
            's'                : begin chk_chn (c0); parser_cb_p^.used_app_symbol := true end;     {check dst}
            'v'                : begin chk_chn (c0); parser_cb_p^.used_app_value  := true end;     {check dst}
            'w'                : begin chk_chn (c0); parser_cb_p^.used_out_channel:= true end;     {check dst}
            'S', 'c', 'n', apostr,
            '"', ' ', 'T'      : chk_chn (c0);                                        {check dst}
            'i', '=', '+', 'm' : begin chk_chn (c0); chk_chn (c1) end;                {check dst and src} 
            'M'                : begin chk_chn (c0); chk_chn (c1); chk_chn (c1) end;  {check all 3 channels} 
            'b', 'd', 'e', 'q' : ;                                                    {no channels needed}
            '[' : begin
                    i:= i+1;      if (i+3) > length (s) then wr_error ('illegal [..]');
                    if not cond_cmnd then wr_error ('Condition expected after [');
                    i:= i+1;
                    if s [i] = ':'
                      then begin i:= i+1; if wr_stmt <> ']' then wr_error ('] expected') end
                      else case wr_stmt of
                            ':' : if wr_stmt <> ']'     then wr_error ('] expected');
                            ']' : ;
                            otherwise wr_error (': or ] expexted') end;
                    i:=i-1
                  end;
            ':' : begin cont_loop:= false; wr_stmt:= ':'     end;
            ']' : begin cont_loop:= false; wr_stmt:= ']'     end;
            '{' : begin
                    i:= i+1;
                    if cond_cmnd then i:= i+1;
                    if wr_stmt <> '}' then wr_error ('} expected');
                    i:= i-1
                  end;
            '}' : begin cont_loop:= false; wr_stmt:= '}'     end;
            otherwise wr_error ('Illegal action command') end;
           i:= i+1
         end
     end;
   begin {test_action_c}
     if dic_indx2sym (parser_cb_p^.dic_handle_actions, p^.gp_index, s)
       then begin i:= 1; dummy_ch:= wr_stmt; if (i-1) <> length (s) then wr_error ('Nesting error 0') end
       else abort ('Fatal index in test_action_c')
   end;  {test_action_c}

  function members  (sh: set_handle_t): dic_indx; {gives the number of active members in the set}
  var i, n: dic_indx;
  begin
    n:=0;
    with parser_cb_p^ do for i:= token_min to token_max do if set_element_of (sh, i) then n:= n+1;
    members:= n
  end;

  function channels (chn_list: record_p_t): Integer;  {gives the number of channel in parameter list}
  var p: record_p_t; i: Integer;
  begin i:= 0; p:= chn_list; while p<>nil do with p^ do begin i:= i+1; p:= next end; channels:= i end;
{!R! page; exit;}
 begin {check_parameter_count}
  p:= bnf_list;  c0:= chn0; c1:= chn1; c2:= chn2;
  while p<>nil do with parser_cb_p^, p^ do   
   begin
     case tag of
      case_begin    : check_parameter_count (split, c0, c1, c2);
      case_split    : check_parameter_count (split, c0, c1, c2);
      loop_split    : begin
                       if members (tok1) = 0 then abort ('loop_split: empty');
                       check_parameter_count (split, c0, c1, c2)
                      end;
      option_split  : begin
                       if members (tok1) = 0 then abort ('option_split: empty'); 
                       check_parameter_count (split, c0, c1, c2)
                      end;
      call          : begin
                       if split=nil then abort ('Procedure undeclared');
                       if channels (actual_par) <> channels (split^.formal_par) then
                         begin
                           writeln ('Wrong Parameter count when referencing ',
                                    dic_symbol (dic_handle_calls, split^.gp_index), ' from ', bnf_name);
                           inc_error
                         end
                      end;
      call_entry    : abort ('call_entry found in check_parameter_count');
      appl_symbol   : ;
      appl_value    : ;
      appl_keyword  : ;
      appl_action_s : if c0=0 then abort ('Missing Channel (^C)') else used_app_data:= true;
      appl_action_c : test_action_c;
      appl_chn0     : c0:= gp_index;
      appl_chn1     : c1:= gp_index;
      appl_chn2     : c2:= gp_index;
      appl_channel  : ;
      otherwise abort ('Fatal tag ' + str_tag (tag) + ' in check_parameter_count') {test, rm if pgm ok}
      end;
      p:= next
   end
 end;  {check_parameter_count}    {!R! page; exit;}  

(*---- read_bnf -------------------------------------------------------------------------------------------*)
begin {read_bnf}
 err:= false;
 new (parser_cb_p); ph:= parser_cb_p;
 with parser_cb_p^ do 
  begin
   error_count:= 0; error_flag:= false; structure_blanks:=1; write_line_numbers:= false; verbose:= false;
   output_binary:= false; {select the default ASCII output}     
   used_app_data  := false; used_out_channel:= false; used_app_symbol := false; used_app_value := false;
   open_scan_new(scan_handle);
   dic_new     (dic_handle_calls, true); def_scan_dic (scan_handle, dic_handle_calls,    [symbol_const]);
   dic_new     (dic_handle_keywords, true);def_scan_dic (scan_handle, dic_handle_keywords, [text1_const]);
   dic_new     (dic_handle_strings, true); def_scan_dic (scan_handle, dic_handle_strings,  [text2_const]); {strings}
   dic_new     (dic_handle_actions, true); def_scan_dic (scan_handle, dic_handle_actions,  [text3_const]); {cmnds}

                {       delimiter_begin  sym_begin  symbol_cont  num_beg  equ_char}
   def_alphabet (scan_handle, ' ',       sym_begin, symbol_cont, '',      '');

   def_quoting  (scan_handle, '/*',       '*/',       comment_const);     {parser  comment}
   def_quoting  (scan_handle, '(*',       '*)',       comment_const);     {parser  comment}
   def_quoting  (scan_handle, '#',        '',         comment_const);     {parser  comment}
   def_quoting  (scan_handle, '%include', ';',        include_const);     {parser  includes a file}
   def_quoting  (scan_handle, '<',        '>',        text1_const);       {extract application keywords}
   def_quoting  (scan_handle, '<.',       '.>',       text1_const);       {extract application keywords, alternative}
   def_quoting  (scan_handle, apostr, apostr,         text2_const);       {extract application actions strings} 
   def_quoting  (scan_handle, '"',        '"',        text2_const);       {extract application actions,  alternative}
   def_quoting  (scan_handle, '`',        '`',        text3_const);       {extract application actions commands}

   def_keyword  (scan_handle, 'symbol value = [ ] { } (( )) | . ; ( ) ^ ^^ ^^^'); {parser  keywords}
   def_file     (scan_handle, src_bnf);                              {end of opening scanner and parser}

   root_entry:= nil;   first_entry  := nil;
   pgm_name     := ''; pgm_version  := ''; 
   pgm_del_beg  := ''; pgm_sym_beg  := ''; pgm_sym_cont := ''; pgm_num_beg := '';
   pgm_equ_char := ''; pgm_comments := ''; pgm_include  := ''; pgm_txt_del := ''; pgm_options := '';

   {------------------- get definitions from the bnf file --------------------------------------------}
   repeat
     token:= next_token (scan_handle, result); 
     if token<>symbol                                               then diagnostic ('Symbol expected');
     if dic_symbol (dic_handle_calls, result) = 'bnf_syntax'        then break;     {and read now the syntax}

     if set_definition ('name',            pgm_name    ) then continue;
     if set_definition ('version',         pgm_version ) then continue;
     if set_definition ('delimiter',       pgm_del_beg ) then continue;
     if set_definition ('symbol_begin',    pgm_sym_beg ) then continue;
     if set_definition ('symbol_continue', pgm_sym_cont) then continue;
     if set_definition ('number_begin',    pgm_num_beg ) then continue;
     if set_definition ('translate',       pgm_equ_char) then continue;
     if set_definition ('comment',         pgm_comments) then continue;
     if set_definition ('include',         pgm_include ) then continue;
     if set_definition ('text',            pgm_txt_del ) then continue;
     if set_definition ('options',         pgm_options ) then continue;
     inc_error;
     diagnostic ('Predefinition or bnf_syntax expected');
     until false; 
   {------------------- set default values if not delivered by the bnf file itself -------------------}  
   if pgm_name     = '' then pgm_name     := 'unknown'; 
   if pgm_version  = '' then pgm_version  := '0.0'; 
   if pgm_del_beg  = '' then pgm_del_beg  := ' '; 
   if pgm_sym_beg  = '' then pgm_sym_beg  := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
   if pgm_sym_cont = '' then pgm_sym_cont := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789';
   if pgm_num_beg  = '' then pgm_num_beg  := '0123456789';
(* if pgm_equ_char = '' then pgm_equ_char := 'aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ'; *)
   if pgm_comments = '' then pgm_comments := '{ } (* *)';
(* if pgm_include  = '' then pgm_include  := '%include ;';  {bnf file MUST decide this: include OR translate} *)
   if pgm_txt_del  = '' then pgm_txt_del  :=  ' " " ' + apostr + ' ' + apostr; {APOLLO append removed}

   for i:=1 to length (pgm_options) do case pgm_options [i] of
      '0'..'4' : structure_blanks   := ord (pgm_options [i]) - ord ('0');
      'L'      : write_line_numbers := true;
      'v'      : verbose            := true;
      'b'      : output_binary      := true;
      otherwise abort ('Illegal Option ' + pgm_options [i]) end;

   dic_reset (dic_handle_calls);
   dic_reset (dic_handle_strings);       {!R! page; exit;}

   {------------------- get global and actual default channels, if any -------------------------------}
   token:= next_token (scan_handle, result);
   get_parameter_list (global_channels, nil, true);
   get_default_channels (gd_chn0, gd_chn1, gd_chn2, nil, nil);
   if result <> ord (semik)                                       then diagnostic ('^, ^^ or ; expected');     

   {----------------- get now the bnf expressions ----------------------------------------------------}
   repeat
     token:= next_token (scan_handle, result);
     if token = finish then if result=ord (end_of_input) then break else finish_unexpected (result);
     if token <> symbol                                           then diagnostic ('Name or EOF expected');
     call_entry_p := find_call_entry_p (result, true); {must be a new one}

     {----------------- get parameter channels,if any ------------------------------------------------} 
     token:= next_token (scan_handle, result);           
     if (token=keyword) and (result = ord (par0)) then
        begin {list starts with ( }
          token:= next_token (scan_handle, result); 
          get_parameter_list (call_entry_p^.formal_par, nil, true);
          if result <> ord (par1)                                 then diagnostic (') expected');      
          token:= next_token (scan_handle, result);
        end;
     {----------------- get local channels, if any ---------------------------------------------------} 
     with call_entry_p^ do
        begin
          get_parameter_list (local_var, formal_par, true);
          get_default_channels (d_chn0, d_chn1, d_chn2, local_var, formal_par);
        end;

     {----------------- get bnf expression -----------------------------------------------------------}
     if (token<>keyword) or (result <> ord (eq))                  then diagnostic ('^, ^^ or = expected');
     if expression (call_entry_p^.entry_p) <> semik               then diagnostic ('; expected');
     until false;

   token_min            := 0;
   token_empty          := 0;
   token_max_keyword    := dic_last_indx (dic_handle_keywords);
   token_finish         := 1 + token_max_keyword + ord (finish);
   token_symbol         := 1 + token_max_keyword + ord (symbol);
   token_value          := 1 + token_max_keyword + ord (value);
   token_max            := 1 + token_max_keyword + ord (keyword);

   {------------------------- initialize tokens -------------------------------------------------------------}
   init_token_cnt:= 0;
   repeat 
     init_token_global;
     if write_convergence in check_set then writeln
        ('Change=', change_cnt:3, '  empty_lo=', empty_lo_cnt:2, '  empty_case=', empty_case_cnt:2,
         '  dupl_case=',  dupl_case_cnt:2); {test}
     init_token_cnt:= init_token_cnt+1;
     until ((change_cnt=0) and (empty_lo_cnt=0) and (empty_case_cnt=0)) or (init_token_cnt >= max_iterations);
   scan_close (scan_handle);
   if init_token_cnt >= max_iterations then
       begin inc_error; writeln ('BNF is faulty, Iteration Count: ', init_token_cnt:1) end;

   {------------------------- Last consistency checks: Channels, unreachable options, loops etc -------------}
   call_entry_p:= root_entry; 
   while call_entry_p<>nil do with call_entry_p^ do
     begin
       if tag<>call_entry then abort ('Fatal: call_entry expected');             {test ??? }
       check_parameter_count (entry_p, non_zero_ch (d_chn0, gd_chn0),
                                       non_zero_ch (d_chn1, gd_chn1),
                                       non_zero_ch (d_chn2, gd_chn2));
       call_entry_p:= next 
     end;

   {------------------------- Write diagnostic info depending on switches set in check_set ------------------}
   if write_calls     in check_set then begin writeln ('dic_handle_calls');   wr_dic (dic_handle_calls)   end; 
   if write_keywords  in check_set then begin writeln ('dic_handle_keywords');wr_dic (dic_handle_keywords)end;
   if write_actions_s in check_set then begin writeln ('dic_handle_strings'); wr_dic (dic_handle_strings) end;
   if write_actions_c in check_set then begin writeln ('dic_handle_actions'); wr_dic (dic_handle_actions) end;
   if write_structure in check_set then 
     begin 
       call_entry_p:= root_entry; 
       while call_entry_p<>nil do with call_entry_p^ do
          begin write_ccb (call_entry_p, true); write_expr (entry_p, 1); call_entry_p:= next end 
     end;
   if write_reference_error in check_set then
     begin 
       call_entry_p:= root_entry;
       while call_entry_p<>nil do with call_entry_p^ do
          begin write_ccb (call_entry_p, false); call_entry_p:= next end
     end;

   if error_flag then begin writeln ('Error Count: ', error_count:1); abort ('BNF file not successfully parsed') end;
  end 
end; {read_bnf}               {!R! page; exit;}
{-----------------------TRANSLATE ---------------------------------------------------------------------------}
procedure translate_bnf (ph            : parse_handle_t; 
                         family_name   : family_name_t;
                         dsn_unit      : path_name_t;
                         dsn_main      : path_name_t;
                         offs          : integer);

const                              {solving potential name conflicts between predfined names and BNF names}
  bnf_leader     = 'bnf_';         {begin all BNF-defined proc    names, never to be used by any pre-defined names}
  chn_leader     = 'chn_';         {begin all BNF-defined channel names, never to be used by any pre-defined names}

type
  base_name_t    = string (20);
var
  parser_cb_p    : parser_cb_p_t;  {handle for pnf structure}
  line           : Integer;        {out commented header for sorting the output lines}
  blanks         : Integer;        {formatting blanks for readability of output code, pascal style}
  f              : text;           {unit/module file variable}
{ bnf_name       : base_name_t; }  {main entry substitution name of bnf}  {test}
  base_name      : base_name_t;    {base name: family_name + '_' + bnf_name} 

  procedure wh;
     begin
       if parser_cb_p^.write_line_numbers then write (f, '{', line:6, '} ');
       if blanks > 0 then write (f, ' ':blanks);
       line:=line+1
     end;
  procedure r;           begin blanks:= blanks + parser_cb_p^.structure_blanks end;
  procedure l;           begin blanks:= blanks - parser_cb_p^.structure_blanks end;
  procedure wh_ln;       begin wh; writeln (f) end;
  procedure wh_begin_ln; begin r; wh; writeln (f, 'begin'); r end;
  procedure wh_end_ln;   begin l; wh; writeln (f, 'end');   l end;
  procedure wh_ends_ln;  begin l; wh; writeln (f, 'end;');  l end;

  procedure write_set_numbers (sh: set_handle_t);  {writes active members: 1,9,20... }
  var i: dic_indx; empty: boolean;
  begin
    empty:= true;
    with parser_cb_p^ do for i:= token_min to token_max do if set_element_of (sh, i) then
       begin if empty then write (f, i:1) else write (f, ',', i:1); empty:= false end;
    if empty then write (f, '0')
  end;

  function members  (sh: set_handle_t): dic_indx; {gives the number of active members in the set}
  var i, n: dic_indx;
  begin
    n:=0;
    with parser_cb_p^ do for i:= token_min to token_max do if set_element_of (sh, i) then n:= n+1;
    members:= n
  end;

  function procedure_name (index: dic_indx): dic_sym;
  begin procedure_name:= bnf_leader + dic_symbol (parser_cb_p^.dic_handle_calls, index) end;

  function ch_name (index: dic_indx): dic_sym;
  begin
    if index=0 then abort ('Undefined Channel Name');
    ch_name:= chn_leader + dic_symbol (parser_cb_p^.dic_handle_calls, index)
  end;

  procedure write_channel_list (channel_list: record_p_t);  var p: record_p_t; 
  begin
    p:= channel_list; 
    while p<>nil do with p^, parser_cb_p^ do 
      begin 
        write (f, ch_name (gp_index)); 
        p:= next; 
        if p<>nil then write (f, ', ')  {do not append komma after last channel name}
      end 
  end;

  procedure write_procedure_head (p: record_p_t); 
  begin
    with p^ do
      begin
        wh; write (f, 'PROCEDURE ', procedure_name (gp_index));
        if formal_par<>nil then
          begin
            write (f, ' (VAR ');
            write_channel_list (formal_par);
            write   (f, ': obj_handle_t)')
          end
      end
  end;
  
  procedure write_err_free_test; begin writeln (f, 'if err_free then'); wh_begin_ln end; {!R! page; exit;}  
  procedure write_instructions (bnf_list: record_p_t; chn0, chn1, chn2: dic_indx);
  var p, p1: record_p_t; c0, c1, c2: dic_indx;

   procedure write_action_c;
   var i: Integer; s: dic_sym;
     procedure wr_cond_ln (if_then_else: boolean);
     begin
       if if_then_else 
         then begin wh; write (f, 'if '); if s [i+1]=':' then write (f, 'not ') end 
         else begin wh; write (f, 'while ') end;
       case s [i] of
         's' : write (f, 'obj_sym_exists (', ch_name (c2), ', index_sym)'); 
         'c' : write (f, '(', ch_name (c2), '=nil)');
         't' : write (f, '(term_val_type=text1_const)');   {test ??? text2_const, text3_const, text4_const}
         'i' : write (f, '(term_val_type=Integer_const)');
         'r' : write (f, '(term_val_type=real_const)');
         'o' : write (f, 'obj_add_cond_ord (', ch_name (c0), ', ', ch_name (c2), ', index_sym)'); 
         'M' : write (f, 'obj_expand_macro (', ch_name (c0), ', ', ch_name (c2), ', ', ch_name (c1), ', index_sym)'); 
         otherwise if if_then_else
             then begin writeln ('Condition: ', s [i]); abort ('Illegal contition') end
             else begin write (f, 'true'); i:=i-1 end end;
       if not if_then_else then begin writeln (f, ' do'); i:= i+1 end
     end;

     function wr_stmt: char;
     var cont_loop: boolean;
     begin
       wr_stmt  := chr(1); {illegal return code}
       cont_loop:= true;
       while cont_loop and (i<=length (s)) do
         begin
           case s [i] of
            's' : begin wh; writeln (f, 'app_symbol (',      ch_name (c0), ');') end;
            'S' : begin wh; writeln (f, 'obj_add_ord (',     ch_name (c0), ', index_sym);') end;
            'v' : begin wh; writeln (f, 'app_value (',       ch_name (c0), ');') end;
            'c' : begin wh; writeln (f, 'obj_delete (',      ch_name (c0), ');') end;
            'n' : begin wh; writeln (f, 'obj_add_chr (',     ch_name (c0), ', newline);') end; 
         apostr : begin wh; writeln (f, 'obj_add_chr (',     ch_name (c0), ', apostr);') end; 
            '"' : begin wh; writeln (f, 'obj_add_chr (',     ch_name (c0), ', ', apostr, '"', apostr, ');') end; 
            ' ' : begin wh; writeln (f, 'obj_add_chr (',     ch_name (c0), ', ', apostr, ' ', apostr, ');') end; 
            'w' : begin wh; writeln (f, 'out_channel (',     ch_name (c0), ');') end;
            'T' : begin wh; writeln (f, 'obj_add_dic (',     ch_name (c0), ', appl_handle^.wpar.dic_handle_symbol);') end;
            'i' : begin wh; writeln (f, 'obj_inc_obj (',     ch_name (c0), ', ', ch_name (c1), ');') end; 
            '=' : begin wh; writeln (f, 'obj_assign (',      ch_name (c0), ', ', ch_name (c1), ');') end; 
            '+' : begin wh; writeln (f, 'obj_add_obj (',     ch_name (c0), ', ', ch_name (c1), ');') end; 
            'm' : begin wh; writeln (f, 'obj_mov_obj (',     ch_name (c0), ', ', ch_name (c1), ');') end;   
            'M' : begin wh; writeln (f, 'obj_add_dic_mac (', ch_name (c0), ', ', ch_name (c1), ', ', ch_name (c2), ', index_sym);') end;
            'b' : begin wh; writeln (f, 'break;') end;
            'd' : begin wh; writeln (f, 'write (', apostr, 'BNF diagnostic', apostr, '); dic_diagnostic (appl_handle^.scan_handle);') end;
            'e' : begin wh; writeln (f, 'abort (', apostr, 'BNF abort', apostr, ');') end; 
            'q' : begin wh; writeln (f, 'err_free:= false;') end;
            '[' : begin
                    i:= i+1;
                    wr_cond_ln (true);
                    writeln (f);
                    i:= i+1;
                    if s [i] = ':'
                      then
                        begin 
                          i:= i+1;
                          r; wh; writeln (f, 'then'); 
                          wh_begin_ln; 
                          if wr_stmt <> ']' then abort ('] expected');
                          wh_ends_ln;
                          l
                        end 
                      else
                        begin
                          r; wh; writeln (f, 'then');
                          wh_begin_ln;
                          case wr_stmt of
                            ':' : begin
                                    wh_end_ln; 
                                    wh; writeln (f, 'else'); wh_begin_ln;
                                    if wr_stmt <> ']' then abort ('] expected');
                                    wh_ends_ln; l 
                                  end;
                            ']' : begin wh_ends_ln; l end;
                            otherwise abort (': or ] expexted') end;
                        end;
                    i:=i-1
                  end;

            ':' : begin cont_loop:= false; wr_stmt:= ':'     end;
            ']' : begin cont_loop:= false; wr_stmt:= ']'     end;
            '{' : begin
                    i:= i+1;
                    wr_cond_ln (false);
                    wh_begin_ln;
                    if wr_stmt <> '}' then abort ('} expected');
                    wh_ends_ln;
                    i:= i-1
                  end;
            '}' : begin cont_loop:= false; wr_stmt:= '}'     end;
            otherwise abort ('illegal action command') end;
           i:= i+1
         end
     end;

   begin {write_action_c}
     if dic_indx2sym (parser_cb_p^.dic_handle_actions, p^.gp_index, s)
       then begin i:= 1; dummy_ch:= wr_stmt;  {test->} if (i-1) <> length (s) then abort ('nesting error 1') end
       else abort ('Fatal index in write_action_c')
   end;  {write_action_c}

  begin {write_instructions}
   p:= bnf_list;  c0:= chn0; c1:= chn1; c2:= chn2;
   while p<>nil do with parser_cb_p^, p^ do   
    begin
      case tag of
       case_begin    : begin
                        wh; writeln (f, 'case term of'); r; 
                        write_instructions (split, c0, c1, c2);
                        p1:= split;
                        while (p1<>nil) and then not set_empty (p1^.tok1) do p1:= p1^.next;  {surch empty case_split}
                        if p1<>nil
                          then
                            begin
                              wh; writeln (f, 'otherwise '); r; r; 
                              write_instructions (p1^.split, c0, c1, c2);
                              wh_ends_ln;
                            end                             {0: test unclear what to tell}
                          else begin wh; writeln (f, 'otherwise write_error ([0]) end;') end;
                        l;
                       end;
       case_split    : if not set_empty (tok1) then   {do not write empty cases, they are written after otherwise}
                         begin
                          wh; write_set_numbers (tok1); writeln (f, ':'); 
                          wh_begin_ln; write_instructions (split, c0, c1, c2); wh_ends_ln
                         end;
       loop_split    : begin
                        wh; write (f, 'while term');
                        case members (tok1) of
                          0: abort ('loop_split: empty');
                          1: begin  write (f, '=');     write_set_numbers (tok1); writeln (f, ' do')    end; 
                          otherwise write (f, ' in ['); write_set_numbers (tok1); writeln (f, '] do')   end;
                        wh_begin_ln; write_instructions (split, c0, c1, c2); wh_ends_ln
                       end;
       option_split  : begin
                        wh; write (f, 'if term');
                        case members (tok1) of 
                          0: abort ('option_split: empty'); 
                          1: begin  write (f, '=');     write_set_numbers (tok1); writeln (f, ' then')  end;  
                          otherwise write (f, ' in ['); write_set_numbers (tok1); writeln (f, '] then') end; 
                        wh_begin_ln; write_instructions (split, c0, c1, c2); wh_ends_ln
                       end;
       call          : begin
                        wh; write (f, procedure_name (split^.gp_index));
                        if actual_par<>nil then
                           begin write (f, ' ('); write_channel_list (actual_par); write (f, ')') end;
                        writeln (f, ';')
                       end;
       call_entry    : ;
       appl_symbol   : begin wh; writeln (f, 'ack_keyword (token_symbol);')     end;
       appl_value    : begin wh; writeln (f, 'ack_keyword (token_value);')      end;
       appl_keyword  : begin wh; writeln (f, 'ack_keyword (', gp_index:1, ');') end;
       appl_action_s : if gp_index<>0 then
                        begin wh; if output_binary 
                            then writeln (f, 'app_kw   (', ch_name (c0), ', ', DIC_SYMBOL (dic_handle_strings, gp_index), ');')
                            else writeln (f, 'app_data (', ch_name (c0), ', ', gp_index:1, ');')
                        end;
       appl_action_c : write_action_c;
       appl_chn0     : c0:= gp_index;
       appl_chn1     : c1:= gp_index;
       appl_chn2     : c2:= gp_index;
       appl_channel  : ;
       otherwise abort ('Fatal tag ' + str_tag (tag) + ' in write_instructions') {test, rm if pgm ok}
       end;
       p:= next
    end
  end;  {write_instructions}    {!R! page; exit;}  

  procedure write_ch_init (channel_list: record_p_t);     var p: record_p_t;
  begin
    p:= channel_list;
    while p<>nil do with p^ do begin wh; writeln (f, ch_name (gp_index), ':= nil;'); p:= next end
  end;

  procedure write_ch_dispose (channel_list: record_p_t);  var p: record_p_t;
  begin
    p:= channel_list;
    while p<>nil do with p^ do begin wh; writeln (f, 'obj_delete (', ch_name (gp_index), ');'); p:= next end
  end;

  procedure write_quoting (s: dic_sym; vt: value_t);
  var i: Integer; vts: dic_sym;
  procedure next_str;  begin while (i<=length (s)) and (s [i] =' ') do i:=i+1 end;   
  procedure write_str;
   begin
    while (i<=length (s)) and (s [i]<>' ') do
       begin write (f, s [i]); if s [i]=apostr then write (f, apostr); i:=i+1 end;
    next_str {step to next word if any}         {test error: if ' not correctly handled}
   end;  
  begin
    i:=1;
    next_str;
    case vt of
      comment_const : vts:='comment_const';
      include_const : vts:='include_const';
      text1_const   : vts:='text1_const';
      text2_const   : vts:='text2_const';
      text3_const   : vts:='text3_const';
      otherwise abort ('write_quoting: illegal vt') end;
    while i<=length (s) do
      begin
        wh;
        write   (f, 'def_quoting (scan_handle, ',  apostr); write_str;
        write   (f, apostr, ', ', apostr); write_str;
        writeln (f, apostr, ', ', vts, ');');
      end
  end;

(*
  procedure write_keyw (dh: dic_handle_t);          {problem?? wegen := INDEX_TO_STRING () faellt weg}
  const                                                {geloest mit dic_indx2sym, perfomance schlecht}
     max_words = 10;
  var 
    words : Integer;
    index : dic_indx; 
    s     : dic_sym;  
  begin 
    index:=1; 
    while dic_indx2sym (dh, index, s) do
      begin
        words:= 1;
        wh; write (f, 'def_keyword (scan_handle, ', apostr);
        while dic_indx2sym (dh, index, s) and (words <= max_words) do
                begin if words<>1 then write (f, ' '); write (f, s); index:= index+1; words:= words+1 end;
        writeln (f, apostr, ');')
      end 
  end; 
*)

  procedure write_keyw (dh: dic_handle_t);          {problem?? wegen := INDEX_TO_STRING () faellt weg}
  const                                                {geloest mit dic_indx2sym, perfomance schlecht}
     max_words = 10;
  var 
    words, i : Integer;
    index    : dic_indx; 
    s        : dic_sym;  
  begin 
    index:=1; 
    while dic_indx2sym (dh, index, s) do
      begin
        words:= 1;
        wh; write (f, 'def_keyword (scan_handle, ', apostr);
        while dic_indx2sym (dh, index, s) and (words <= max_words) do
           begin
             if words<>1 then write (f, ' ');       {duplicate single apostrophes}
             for i:=1 to length (s) do begin write (f, s[i]); if s[i]=apostr then write (f, apostr) end; {procedure?}
             index:= index+1;
             words:= words+1
           end;
        writeln (f, apostr, ');')
      end 
  end; 

  procedure write_actions_s_const (dh: dic_handle_t);
  var
    index : dic_indx;
  begin
    for index:=1 to dic_last_indx (dh) do
      begin
        wh; writeln (f, 'add_data {', index:3, '}  (', apostr, dic_symbol (dh, index), apostr, ');')
      end
  end;                        {!R! page; exit;}  

  procedure write_proc_decl_open;
  begin
    wh; writeln (f);
    wh; writeln (f,  'procedure ',  base_name, '_open');
    wh; writeln (f,  '                (var handle    : ', base_name, '_handle_t;');
    wh; writeln (f,  '                 dic_file      : path_name_t);');
  end;

  procedure write_proc_decl_use;
  begin
    wh; writeln (f);
    wh; writeln (f,  'procedure ', base_name, '_use');
    wh; writeln (f,  '                (handle        : ',  base_name, '_handle_t;');
    wh; writeln (f,  '                 in_path_name,');
    wh; writeln (f,  '                 out_path_name : path_name_t;');
    wh; writeln (f,  '                 var error_code: Integer);');
  end;

  procedure write_proc_decl_close;
  begin
    wh; writeln (f);
    wh; writeln (f,  'procedure ', base_name, '_close');
    wh; writeln (f,  '                (handle        : ', base_name, '_handle_t);');
  end;

  procedure write_unit;
  var p: record_p_t; {universal, to be used only in local context}
  begin
    with parser_cb_p^ do
     begin
      {-- UNIT declarations ------------------------------------------------------------------}  
      wh; writeln (f,  'UNIT ',  base_name, '_unit;');
      wh; writeln (f,  'INTERFACE');
      wh; writeln (f,  'USES base, object, dictionary, scanner;');
      wh; writeln (f,  'type ', base_name, '_handle_t  = pointer;');
      write_proc_decl_open;
      write_proc_decl_use;
      write_proc_decl_close;
      wh; writeln (f);
      wh_ln;

      {-- INTERFACE part ---------------------------------------------------------------------}
      wh; writeln (f, 'IMPLEMENTATION');
      {-- GLOBAL const -----------------------------------------------------------------------} 
      wh; writeln (f, 'const');  r;
      wh; writeln (f, 'apostr            = chr (39);');
      wh; writeln (f, 'newline           = chr (10);');
      wh; writeln (f, 'token_min         =', token_min        :3, ';');
      wh; writeln (f, 'token_empty       =', token_empty      :3, ';');
      wh; writeln (f, 'token_max_keyword =', token_max_keyword:3, ';');
      wh; writeln (f, 'token_finish      =', token_finish     :3, ';');
      wh; writeln (f, 'token_symbol      =', token_symbol     :3, ';'); 
      wh; writeln (f, 'token_value       =', token_value      :3, ';'); 
      wh; writeln (f, 'token_max         =', token_max        :3, ';');                l;
      wh_ln; 

      {-- GLOBAL type for token set ----------------------------------------------------------}
if output_binary then begin
      wh; writeln (f, '%include ', apostr, pgm_name, '.keyword.include',    apostr, ';'); wh_ln end;
      wh; writeln (f, 'type');  r;
      wh; writeln (f, 'token_range_t     = ', token_min:1, '..', token_max:1, ';');   {problem: firstof/lastof don't work}
      wh; writeln (f, 'token_set_t       = set of token_range_t;');
      wh_ln; 

      {-- GLOBAL type for handle -------------------------------------------------------------}   
      wh; writeln (f, 'appl_handle_p_t   = ^appl_handle_t;'); 
      wh; writeln (f, 'appl_handle_t     = record'); 
      wh; writeln (f, '                      scan_handle  : scan_handle_t;');  
      wh; writeln (f, '                      wpar         : obj_param_t;');  
      wh; writeln (f, '                      dictionary   : path_name_t;');  
      wh; writeln (f, '                    end;'); 
      wh_ln; 

      l;
      {-- PROCEDURE open & interface ---------------------------------------------------------} 
      write_proc_decl_open;
      wh; writeln (f, 'var appl_handle: appl_handle_p_t;');
if not output_binary then begin
      wh; writeln (f, 'procedure add_data (s: dic_sym); var index: dic_indx; dummy: boolean;'); r;
      wh; writeln (f, 'begin dummy:= dic_sym2indx (appl_handle^.wpar.dic_handle_data, s, index, create) end;') end;
      l;
      wh_begin_ln;  
      wh; writeln (f, 'new (appl_handle);'); 
      wh; writeln (f, 'handle:= appl_handle;');  
      wh; writeln (f, 'with appl_handle^ do');  
      wh_begin_ln;     
      wh; writeln (f, 'open_scan_new (scan_handle);');
      wh; writeln (f, 'dictionary:= dic_file;');
      wh; write   (f, 'dic_new (wpar.dic_handle_symbol, true); ');
          writeln (f, 'def_scan_dic (scan_handle, wpar.dic_handle_symbol,[symbol_const]);');
      wh; write   (f, 'dic_new (wpar.dic_handle_value, true);  ');  
          writeln (f, 'def_scan_dic (scan_handle, wpar.dic_handle_value, [Integer_const,real_const,text1_const]);');
      wh; writeln (f, 'if length (dictionary) <> 0 then DIC_READ (wpar.dic_handle_symbol, dictionary);'); 
if not output_binary then begin
      wh; writeln (f, 'dic_new (wpar.dic_handle_data, true);'); write_actions_s_const (dic_handle_strings) end;
      wh_ln;
      wh; writeln (f, 'def_alphabet'); r; r; r;
      wh; writeln (f, '(scan_handle,');
      wh; writeln (f, ' ', apostr, pgm_del_beg,      apostr,   ',');
      wh; writeln (f, ' ', apostr, pgm_sym_beg,      apostr,   ',');
      wh; writeln (f, ' ', apostr, pgm_sym_cont,     apostr,   ',');
      wh; writeln (f, ' ', apostr, pgm_num_beg,      apostr,   ',');
      wh; writeln (f, ' ', apostr, pgm_equ_char,     apostr,   ');'); l; l; l;
      write_quoting (pgm_comments,       comment_const);
      write_quoting (pgm_include,        include_const);
      write_quoting (pgm_txt_del,        text1_const);        {test ' fails}
      write_keyw    (dic_handle_keywords);
      wh; writeln (f, 'with wpar do');
      wh_begin_ln;   
      wh; writeln (f, 'max_line_length := 110;');        {test could be delivered by bnf or caller ??}
      wh; writeln (f, 'output_buffer   := '''';');       {test could be delivered by bnf or caller ??}
      wh; writeln (f, 'leader          := apostr;');     {test could be delivered by bnf or caller ??}
      wh; writeln (f, 'trailler        := apostr;');     {test could be delivered by bnf or caller ??}
      wh_end_ln;
      wh_end_ln;
      wh_ends_ln;
      wh_ln; 

      {-- PROCEDURE close & interface --------------------------------------------------------}
      write_proc_decl_close;
      wh; writeln (f, 'var appl_handle: appl_handle_p_t;');
      wh_begin_ln;    
      wh; writeln (f, 'appl_handle:= handle;'); 
      wh; writeln (f, 'with appl_handle^ do'); 
      wh_begin_ln;  
      wh; writeln (f, 'if length (dictionary) <> 0 then DIC_WRITE (wpar.dic_handle_symbol, dictionary);');
      wh; writeln (f, 'scan_close (scan_handle);'); 
      wh; writeln (f, 'dic_dispose      (wpar.dic_handle_symbol);'); 
      wh; writeln (f, 'dic_dispose      (wpar.dic_handle_value);');
      if not output_binary then begin
      wh; writeln (f, 'dic_dispose      (wpar.dic_handle_data);') end;  
      wh_ends_ln;
      wh; writeln (f, 'dispose (appl_handle);');
      wh; writeln (f, 'obj_release_pool;');
      wh_ends_ln;  
      wh_ln; 

      {-- PROCEDURE use & interface ----------------------------------------------------------}
      write_proc_decl_use;
      wh; writeln (f, 'var');
      r;
      wh; writeln (f, 'appl_handle   : appl_handle_p_t;');
      wh; writeln (f, 'term          : dic_indx;');
      wh; writeln (f, 'index_fin     : dic_indx;');
      wh; writeln (f, 'index_fin1    : dic_indx;');
      wh; writeln (f, 'index_sym     : dic_indx;');
      wh; writeln (f, 'index_sym1    : dic_indx;');
      wh; writeln (f, 'index_val     : dic_indx;');
      wh; writeln (f, 'index_val1    : dic_indx;');
      wh; writeln (f, 'term_val_type : value_t;');
      wh; writeln (f, 'term_val_type1: value_t;');
      wh; writeln (f, 'last_token    : token_t;');
      wh; writeln (f, 'err_free      : boolean;');  
      wh_ln;  
      if global_channels<>nil then 
              begin
                wh; write_channel_list (global_channels); 
                writeln (f, ': obj_handle_t; {global channels}');
                wh_ln; 
              end;
      {--------------- local to use: place for more global variables comming from BNF --------}
      l;

      {--------------- local to use: write_error ----------------------------------------------} 
      wh; writeln (f, 'procedure write_error (ts: token_set_t);'); 
      wh; writeln (f, 'var tr: token_range_t;');
      wh_begin_ln;    
      wh; writeln (f, 'write (StdErr, ', apostr, 'Error: ', apostr, ');');
      wh; writeln (f, 'if token_symbol in ts then write (StdErr, ', apostr, 'Symbol', apostr, ') else');
      wh; writeln (f, 'if token_finish in ts then write (StdErr, ', apostr, 'EOF',    apostr, ') else');  {werkt nicht richtig}
      wh; writeln (f, 'if token_value  in ts then write (StdErr, ', apostr, 'value',  apostr, ')');
      wh; writeln (f, '  else for tr:=0 to token_max do if tr in ts then write (StdErr, tr:1,', apostr, ' ', apostr, ');');
      wh; writeln (f, 'write (StdErr, ', apostr, ' expected', apostr, ');');
      wh; writeln (f, 'write_diagn (appl_handle^.scan_handle);');
  {   wh; writeln (f, 'dic_diagnostic (appl_handle^.scan_handle);');     }
      wh; writeln (f, 'abort (', apostr, '', apostr, ');');
      wh; writeln (f, 'err_free:= false;');
      wh_ends_ln;   
      wh_ln; 

      {--------------- local to use: write channel ----------------------------------------}
      if used_out_channel then
      begin
        wh; writeln (f, 'procedure out_channel (var channel: obj_handle_t);');
        wh; writeln (f, 'begin if err_free then obj_write (channel, appl_handle^.wpar) end;');
        wh_ln;
      end;
      {--------------- local to use: append last symbol to channel -------------------------}
      if used_app_symbol then
      begin
        wh; writeln (f, 'procedure app_symbol (var channel: obj_handle_t);');
        wh; writeln (f, 'begin if err_free then obj_add_dic_sym (channel, index_sym) end;');
        wh_ln;
      end;

      {--------------- local to use: write last value ----------------------------------------}
      if used_app_value then
      begin
        wh; writeln (f, 'procedure app_value (var channel: obj_handle_t);');
        wh_begin_ln;  
        wh; write_err_free_test; 
        wh; writeln (f, 'with appl_handle^ do case term_val_type of');                              r;
        wh; writeln (f, 'not_value, comment_const, include_const, keyword_const, symbol_const :;');
        wh; writeln (f, 'Integer_const : obj_add_dic_int  (channel, index_val);');
        wh; writeln (f, 'real_const    : obj_add_dic_real (channel, index_val);');
        wh; writeln (f, 'text1_const, text2_const, text3_const, text4_const');
        wh; writeln (f, '              : obj_add_dic_txt  (channel, index_val);');
        wh; writeln (f, 'otherwise abort (', apostr, 'Fatal Data Type', apostr, ') end;');  l;
        wh_end_ln;
        wh_ends_ln;
        wh_ln;
      end;

      {--------------- local to use: append data to channel -----------------------------}
      if used_app_data then if output_binary
        then
          begin
            wh; writeln (f, 'procedure app_kw (var chn: obj_handle_t; kw: keyw_t);');
            wh; writeln (f, 'begin if err_free then obj_add_kw (chn, ord (kw)) end;');
            wh_ln
          end
        else
          begin
            wh; writeln (f, 'procedure app_data (var chn: obj_handle_t; index: dic_indx);');
            wh; writeln (f, 'begin if err_free then obj_add_dic_dat (chn, index) end;');
            wh_ln
          end;

      {--------------- local to use: check KEYWORD and read next token -----------------------}
      wh; writeln (f, 'procedure ack_keyword (kw: dic_indx);');
      wh_begin_ln;
      wh; write_err_free_test;
      wh; writeln (f, 'if term=kw');                r;
      wh; writeln (f, 'then with appl_handle^ do');
      wh_begin_ln;
 
      wh; writeln (f, 'index_fin     := index_fin1;');
      wh; writeln (f, 'index_sym     := index_sym1;');
      wh; writeln (f, 'index_val     := index_val1;');
      wh; writeln (f, 'term_val_type := term_val_type1;');

      wh; writeln (f, 'last_token:= next_token (scan_handle, term);');
      wh; writeln (f, 'case last_token of');                                               r;
      wh; writeln (f, 'finish : begin index_fin1:= term; term:=token_finish end;');
      wh; writeln (f, 'symbol : begin index_sym1:= term; term:=token_symbol end;');
      wh; write   (f, 'value  : begin index_val1:= term; term:=token_value;');
          writeln (f, ' term_val_type1:= value_type (scan_handle) end;');
      wh; writeln (f, 'keyword: ;');
      wh; writeln (f, 'otherwise abort (', apostr, 'Fatal token', apostr, ') end;');  l;
      wh_end_ln;
      wh; writeln (f, 'else write_error ([kw])');   l;
      wh_end_ln;
      wh_ends_ln;
      wh_ln;

      {--------------- write procedure forward declarations ----------------------------------}
      p:= root_entry;
      while p<>nil do
        begin
          write_procedure_head (p);
          writeln (f, '; forward;');
          p:= p^.next
        end;

      {--------------- local to use: BNF SYNTAX converting to procedures ---------------------}
      wh_ln;
      p:= root_entry;
      while p<>nil do with p^ do
        begin
          write_procedure_head (p);
          writeln (f, ';');
          if local_var<>nil then
            begin
              wh; write (f, 'var ');
              write_channel_list (local_var);
              writeln (f, ': obj_handle_t;')
            end;
          wh; writeln (f, 'begin');
          wh; write_err_free_test;
          write_ch_init      (local_var);
          write_instructions (entry_p, non_zero_ch (d_chn0, gd_chn0),
                                       non_zero_ch (d_chn1, gd_chn1),
                                       non_zero_ch (d_chn2, gd_chn2));
          write_ch_dispose   (local_var);
          wh_end_ln;
          wh; writeln (f, 'end;');
          wh_ln;
          p:= next
        end;

      {---------------- PROGRAM BODY ---------------------------------------------------------}
      l;
      wh_begin_ln;
      wh; writeln (f, 'err_free      := true;');  {test: error handling must be yet 'designed'}
      wh; writeln (f, 'appl_handle   := handle;');  

      wh; writeln (f, 'index_fin1    := 9999;'); 
      wh; writeln (f, 'index_sym1    := 0;'); 
      wh; writeln (f, 'index_val1    := 0;'); 
      wh; writeln (f, 'term_val_type1:= not_value;');  

      wh; writeln (f, 'with appl_handle^ do');  
      wh_begin_ln; 
      wh; writeln (f, 'def_file (scan_handle, in_path_name);            {giving the input file}');
      wh; writeln (f, 'last_token:= next_token (scan_handle, term); {read the first token of input file}');
      wh; writeln (f, 'case last_token of');                                               r;
      wh; writeln (f, 'finish : begin index_fin1:= term; term:=token_finish end;');
      wh; writeln (f, 'symbol : begin index_sym1:= term; term:=token_symbol end;');
      wh; write   (f, 'value  : begin index_val1:= term; term:=token_value;');
          writeln (f, ' term_val_type1:= value_type (scan_handle) end;');
      wh; writeln (f, 'keyword: ;');
      wh; writeln (f, 'otherwise abort (', apostr, 'Fatal token', apostr, ') end;');  l;

      wh; writeln (f, 'index_fin     := index_fin1;');
      wh; writeln (f, 'index_sym     := index_sym1;');
      wh; writeln (f, 'index_val     := index_val1;');
      wh; writeln (f, 'term_val_type := term_val_type1;');

      wh; writeln (f, 'with wpar do'); 
      wh_begin_ln;  
      if output_binary 
        then 
          begin {open binary output}  
            wh; writeln (f, '{OPEN binary output}');
            wh; writeln (f, 'out_bin:= true;');
            wh; writeln (f, 'lib_open_write (lib_handle, out_path_name);'); 
          end 
        else
          begin {open ASCII output}
            wh; writeln (f, 'out_bin:= false;');
            wh; writeln (f, 'assign (f, out_path_name);');
            wh; writeln (f, 'rewrite (f);');
          end; 
      wh_end_ln; 
      wh_ends_ln; 

      {---------------- calling the root entry of SYNTAX (first line of BNF file -------------} 
          write_ch_init (global_channels);  
      wh; writeln       (f, bnf_leader, dic_symbol (dic_handle_calls, first_entry^.gp_index),';');
      wh; writeln       (f, 'if (last_token<>finish) or (index_fin1<>ord (end_of_input)) then write_error ([ord(finish)]);');
          write_ch_dispose (global_channels);
      wh; writeln (f, 'with appl_handle^.wpar do ');
      wh_begin_ln; 
      if output_binary 
        then 
          begin {close binary output} 
            wh; writeln (f, '{CLOSE binary output}');
            wh; writeln (f, 'lib_close (lib_handle);');
          end
        else
          begin {close ASCII output}
            wh; writeln (f, 'if length (output_buffer)<>0 then writeln (f, output_buffer);');
            wh; writeln (f, 'output_buffer :='''';');
            wh; writeln (f, 'close (f);')
          end;
      wh_ends_ln;
      wh; writeln (f, 'error_code:= ord (not err_free);');
      wh_ends_ln;
      wh; writeln (f, '  {here we could do some initializing actions at start}');
      wh; writeln (f, 'END.')
     end;
  end;                  {!R! page; exit;}  

  procedure write_main;
  begin
    with parser_cb_p^ do
     begin
      {-- MAIN declarations ------------------------------------------------------------------}  
      wh; writeln (f,  'PROGRAM ',  base_name, '_main (input, output);');
      wh; writeln (f,  'USES base, ', base_name, '_unit;');
      wh; writeln (f,  'var h           : ', base_name, '_handle_t;');
      wh; writeln (f,  '    ac, err     : integer;');
      wh; writeln (f,  '    a, src, dst_unit: path_name_t;');
      wh; writeln (f);

      wh; writeln (f,  'procedure write_help (s : err_str_t);');
      wh_begin_ln;
      wh; write   (f,  'writeln (StdErr, ',  apostr, 'Usage : ',    apostr);
          writeln (f,  ' + ParamStr (0) + ', apostr, '[src [dst_unit [dest_main]]]', apostr,')');
      wh_ends_ln;
      l;
      wh; writeln (f);
      wh_begin_ln;       {' --> ', apostr, '                ''  -->  ', apostr, apostr, ' }
      wh; writeln (f, 'src:= ', apostr, apostr, '; dst_unit:= ', apostr, apostr, ';');
      wh; writeln (f, 'for ac:=1 to ParamCount do');
      wh_begin_ln;
      wh; writeln (f, 'a:= ParamStr (ac);');
      wh; writeln (f, 'if src = ', apostr, apostr, ' then src:= a');
      wh; writeln (f, '   else if dst_unit=', apostr, apostr, ' then dst_unit:=a');
      wh; writeln (f, '   else write_help (', apostr, 'Too many parameters', apostr, ')');
      wh_ends_ln;

      wh; writeln (f, base_name, '_open  (h, ', apostr, apostr, ');');
      wh; writeln (f, base_name, '_use   (h, src, dst_unit, err);');
      wh; writeln (f, base_name, '_close (h)');
      l;
      wh; writeln (f, 'end.')
     end
  end;

begin    {translate_appl}
  parser_cb_p:= ph;
  base_name := family_name + parser_cb_p^.pgm_name;
  line:= 1; blanks:=0;
  if offs >= 0 then parser_cb_p^.structure_blanks:= offs;               {pos value overwrites the value from bnf}
  assign     (f, dsn_unit); rewrite (f);  write_unit; close (f);        {write the unit}
  if dsn_main <> '' then                                                {and if needed a sutable main program}
    begin
      line:= 1; blanks:=0;
      assign (f, dsn_main); rewrite (f);  write_main; close (f)
    end
end;     {translate_appl}

(* ----------------------- CLOSE bnf structure ------------------------------------------------------------- *) 
procedure close_parser   (ph : parse_handle_t);
 var
   parser_cb_p  : parser_cb_p_t;
   p            : record_p_t;

 procedure dispose_expr (obj: record_p_t);
 var p, pr: record_p_t;
 begin
  p:= obj;
  while p<>nil do with p^ do
   begin
     pr :=p; p:= next;
     case tag of
      case_begin, case_split, loop_split, option_split
                    : begin
                        set_make_empty (tok0);
                        set_make_empty (tok1);
                        dispose_expr (split);
                        dispose (pr, option_split);
                      end;
      call_entry    : abort ('Fatal call dispose');
      call          : begin
                        dispose_expr (actual_par);
                        dispose      (pr, call);
                      end;
      appl_symbol   : dispose (pr, appl_symbol);
      appl_value    : dispose (pr, appl_value);
      appl_keyword  : dispose (pr, appl_keyword);
      appl_action_s : dispose (pr, appl_action_s);
      appl_action_c : dispose (pr, appl_action_c);
      appl_chn0     : dispose (pr, appl_chn0);
      appl_chn1     : dispose (pr, appl_chn1);
      appl_chn2     : dispose (pr, appl_chn2);
      appl_channel  : dispose (pr, appl_channel);
      otherwise abort ('Fatal dispose')  {test remove this line if program is stable}
      end
   end
 end;

begin  {close_parser}
 parser_cb_p:= ph;
 with parser_cb_p^ do   
   begin
     dic_dispose (dic_handle_calls);
     dic_dispose (dic_handle_keywords); 
     dic_dispose (dic_handle_strings);
     dic_dispose (dic_handle_actions);
     dispose_expr (global_channels);
     p:=root_entry;                      {dispose bnf structure now}
     while p<>nil do with p^ do 
       begin
         dispose_expr (entry_p); 
         dispose_expr (formal_par);      {macht crash, Segmentation fault}
         dispose_expr (local_var);
         root_entry:= p;
         p:= next ;
         dispose (root_entry, call_entry);
       end
   end; 
 dispose (parser_cb_p);
end;   {close_parser}
(* ----------------------- CLOSE bnf structure -------- END ------------------------------------------------ *)

END.
