home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / compcomp / tpyacc / src / yaccsem.pas < prev    next >
Pascal/Delphi Source File  |  1992-05-12  |  15KB  |  571 lines

  1.  
  2. unit YaccSem;
  3.  
  4. (* 2-17-91 AG
  5.    5-13-92 AG (bug fix in add_rule_action) *)
  6.  
  7. (* Copyright (c) 1990,91 by Albert Graef, Schillerstr. 18,
  8.    6509 Schornsheim/Germany
  9.    All rights reserved *)
  10.  
  11. interface
  12.  
  13. (* Semantic routines for the Yacc parser. *)
  14.  
  15. var
  16.  
  17. act_prec : Integer;
  18.   (* active precedence level in token and precedence declarations (0 in
  19.      %token declaration) *)
  20. act_type : Integer;
  21.   (* active type tag in token, precedence and type declarations *)
  22.  
  23. procedure yyerror ( msg : String );
  24.   (* YaccLib.yyerror redefined to ignore 'syntax error' message; the parser
  25.      does its own error handling *)
  26.  
  27. function sym ( k : Integer ) : Integer;
  28.   (* returns internal symbol number for the symbol k; if k is yet undefined,
  29.      a new nonterminal or literal symbol is created, according to the
  30.      appearance of symbol k (nonterminal if an ordinary identifier, literal
  31.      otherwise) *)
  32.  
  33. function ntsym ( k : Integer ) : Integer;
  34.   (* like sym, but requires symbol k to be a nonterminal symbol; if it
  35.      is already defined a literal, an error message is issued, and a dummy
  36.      nonterminal symbol returned *)
  37.  
  38. function litsym ( k : Integer; n : Integer ) : Integer;
  39.   (* same for literal symbols; if n>0 it denotes the literal number to be
  40.      assigned to the symbol; when a new literal identifier is defined, a
  41.      corresponding constant definition is also written to the definition
  42.      file *)
  43.  
  44. procedure next_section;
  45.   (* find next section mark (%%) in code template *)
  46.  
  47. procedure definitions;
  48.   (* if necessary, write out definition of the semantic value type YYSType *)
  49.  
  50. procedure copy_code;
  51.   (* copy Turbo Pascal code section ( %{ ... %} ) to output file *)
  52.  
  53. procedure copy_action;
  54.   (* copy an action to the output file *)
  55.  
  56. procedure copy_single_action;
  57.   (* like copy_action, but action must be single statement terminated
  58.      with `;' *)
  59.  
  60. procedure copy_rest_of_file;
  61.   (* copies the rest of the source file to the output file *)
  62.  
  63. procedure start_rule ( sym : Integer );
  64.   (* start a new rule with lhs nonterminal symbol sym *)
  65.  
  66. procedure start_body;
  67.   (* start a new rule body (rhs) *)
  68.  
  69. procedure end_body;
  70.   (* end a rule body *)
  71.  
  72. procedure add_symbol ( sym : Integer );
  73.   (* add the denoted symbol to the current rule body *)
  74.  
  75. procedure add_action;
  76.   (* add an action to the current rule body *)
  77.  
  78. procedure add_rule_prec ( sym : Integer );
  79.   (* add the precedence of terminal symbol sym to the current rule *)
  80.  
  81. procedure generate_parser;
  82.   (* generate the parse table *)
  83.  
  84. implementation
  85.  
  86. uses YaccBase, YaccTables, YaccClosure, YaccLR0, YaccLookaheads,
  87.   YaccParseTable, YaccMsgs;
  88.  
  89. procedure yyerror ( msg : String );
  90.   begin
  91.     if msg='syntax error' then
  92.       (* ignore *)
  93.     else
  94.       fatal(msg)
  95.   end(*yyerror*);
  96.  
  97. function act_char : char;
  98.   begin
  99.     if cno>length(line) then
  100.       if eof(yyin) then
  101.         act_char := #0
  102.       else
  103.         act_char := nl
  104.     else
  105.       act_char := line[cno]
  106.   end(*act_char*);
  107.  
  108. function lookahead_char : char;
  109.   begin
  110.     if succ(cno)>length(line) then
  111.       if eof(yyin) then
  112.         lookahead_char := #0
  113.       else
  114.         lookahead_char := nl
  115.     else
  116.       lookahead_char := line[succ(cno)]
  117.   end(*lookahead_char*);
  118.  
  119. procedure next_char;
  120.   begin
  121.     if cno>length(line) then
  122.       if eof(yyin) then
  123.         { nop }
  124.       else
  125.         begin
  126.           readln(yyin, line);
  127.           inc(lno); cno := 1
  128.         end
  129.     else
  130.       inc(cno)
  131.   end(*next_char*);
  132.  
  133. var
  134.  
  135. (* Current rule: *)
  136.  
  137. act_rule      : RuleRec;
  138.  
  139. (* Actions: *)
  140.  
  141. n_act : Integer;
  142. p_act : Boolean;
  143.  
  144. function sym ( k : Integer ) : Integer;
  145.   var s : Integer;
  146.   begin
  147.     if is_def_key(k, s) then
  148.       sym := s
  149.     else if sym_table^[k].pname^[1]='''' then
  150.       begin
  151.         s := new_lit;
  152.         def_key(k, s);
  153.         sym := s;
  154.       end
  155.     else
  156.       begin
  157.         s := new_nt;
  158.         def_key(k, s);
  159.         sym := s;
  160.       end
  161.   end(*sym*);
  162.  
  163. function ntsym ( k : Integer ) : Integer;
  164.   var s : Integer;
  165.   begin
  166.     if is_def_key(k, s) then
  167.       if s<0 then
  168.         ntsym := s
  169.       else
  170.         begin
  171.           error(nonterm_expected);
  172.           ntsym := -1;
  173.         end
  174.     else if sym_table^[k].pname^[1]='''' then
  175.       begin
  176.         error(nonterm_expected);
  177.         ntsym := -1;
  178.       end
  179.     else
  180.       begin
  181.         s := new_nt;
  182.         def_key(k, s);
  183.         ntsym := s;
  184.       end
  185.   end(*ntsym*);
  186.  
  187. function litsym ( k : Integer; n : Integer ) : Integer;
  188.   var s : Integer;
  189.   begin
  190.     if is_def_key(k, s) then
  191.       if s>=0 then
  192.         begin
  193.           if n>0 then error(double_tokennum_def);
  194.           litsym := s;
  195.         end
  196.       else
  197.         begin
  198.           error(literal_expected);
  199.           litsym := 1;
  200.         end
  201.     else if sym_table^[k].pname^[1]='''' then
  202.       begin
  203.         if n>0 then
  204.           begin
  205.             add_lit(n);
  206.             s := n;
  207.           end
  208.         else
  209.           s := new_lit;
  210.         def_key(k, s);
  211.         litsym := s;
  212.       end
  213.     else
  214.       begin
  215.         if n>0 then
  216.           begin
  217.             add_lit(n);
  218.             s := n;
  219.           end
  220.         else
  221.           s := new_lit;
  222.         def_key(k, s);
  223.         writeln(yyout, 'const ', pname(s), ' = ', s, ';');
  224.         litsym := s;
  225.       end
  226.   end(*litsym*);
  227.  
  228. procedure next_section;
  229.   var line : String;
  230.   begin
  231.     while not eof(yycod) do
  232.       begin
  233.         readln(yycod, line);
  234.         if line='%%' then exit;
  235.         writeln(yyout, line);
  236.       end;
  237.   end(*next_section*);
  238.  
  239. procedure definitions;
  240.   var line : String; i : Integer;
  241.   begin
  242.     if n_types>0 then
  243.       begin
  244.         writeln(yyout);
  245.         writeln(yyout, 'type YYSType = record case Integer of');
  246.         for i := 1 to n_types do
  247.           writeln(yyout, ' ':15, i:3, ' : ( ',
  248.                          'yy', sym_table^[type_table^[i]].pname^, ' : ',
  249.                          sym_table^[type_table^[i]].pname^, ' );');
  250.         writeln(yyout, ' ':15, 'end(*YYSType*);');
  251.       end;
  252.   end(*definitions*);
  253.  
  254. procedure copy_code;
  255.   var str_state : Boolean;
  256.   begin
  257.     str_state := false;
  258.     while act_char<>#0 do
  259.       if act_char=nl then
  260.         begin
  261.           writeln(yyout);
  262.           next_char;
  263.         end
  264.       else if act_char='''' then
  265.         begin
  266.           write(yyout, '''');
  267.           str_state := not str_state;
  268.           next_char;
  269.         end
  270.       else if not str_state and (act_char='%') and (lookahead_char='}') then
  271.         exit
  272.       else
  273.         begin
  274.           write(yyout, act_char);
  275.           next_char;
  276.         end;
  277.   end(*copy_code*);
  278.  
  279. procedure scan_val;
  280.   (* process a $ value in an action
  281.      (not very pretty, but it does its job) *)
  282.   var tag, numstr : String; i, code : Integer;
  283.   begin
  284.     tokleng := 0;
  285.     next_char;
  286.     if act_char='<' then
  287.       begin
  288.         (* process type tag: *)
  289.         next_char;
  290.         tag := '';
  291.         while (act_char<>nl) and (act_char<>#0) and (act_char<>'>') do
  292.           begin
  293.             tag := tag+act_char;
  294.             next_char;
  295.           end;
  296.         if act_char='>' then
  297.           begin
  298.             if not search_type(tag) then
  299.               begin
  300.                 tokleng := length(tag);
  301.                 error(unknown_identifier);
  302.               end;
  303.             next_char;
  304.           end
  305.         else
  306.           error(syntax_error);
  307.       end
  308.     else
  309.       tag := '';
  310.     tokleng := 0;
  311.     if act_char='$' then
  312.       begin
  313.         (* left-hand side value: *)
  314.         write(yyout, 'yyval');
  315.         (* check for value type: *)
  316.         if (tag='') and (n_types>0) then with act_rule do
  317.           if sym_type^[lhs_sym]>0 then
  318.             tag := sym_table^[sym_type^[lhs_sym]].pname^
  319.           else
  320.             begin
  321.               tokleng := 1;
  322.               error(type_error);
  323.             end;
  324.         if tag<>'' then write(yyout, '.yy', tag);
  325.         next_char;
  326.       end
  327.     else
  328.       begin
  329.         (* right-hand side value: *)
  330.         if act_char='-' then
  331.           begin
  332.             numstr := '-';
  333.             next_char;
  334.           end
  335.         else
  336.           numstr := '';
  337.         while ('0'<=act_char) and (act_char<='9') do
  338.           begin
  339.             numstr := numstr+act_char;
  340.             next_char;
  341.           end;
  342.         if numstr<>'' then
  343.           begin
  344.             val(numstr, i, code);
  345.             if code=0 then
  346.               if i<=act_rule.rhs_len then
  347.                 begin
  348.                   write(yyout, 'yyv[yysp-', act_rule.rhs_len-i, ']');
  349.                   (* check for value type: *)
  350.                   if (tag='') and (n_types>0) then with act_rule do
  351.                     if i<=0 then
  352.                       begin
  353.                         tokleng := length(numstr)+1;
  354.                         error(type_error);
  355.                       end
  356.                     else if sym_type^[rhs_sym[i]]>0 then
  357.                       tag := sym_table^[sym_type^[rhs_sym[i]]].pname^
  358.                     else
  359.                       begin
  360.                         tokleng := length(numstr)+1;
  361.                         error(type_error);
  362.                       end;
  363.                   if tag<>'' then write(yyout, '.yy', tag);
  364.                 end
  365.               else
  366.                 begin
  367.                   tokleng := length(numstr);
  368.                   error(range_error);
  369.                 end
  370.             else
  371.               error(syntax_error)
  372.           end
  373.         else
  374.           error(syntax_error)
  375.       end
  376.   end(*scan_val*);
  377.  
  378. procedure copy_action;
  379.   var str_state : Boolean;
  380.   begin
  381.     str_state := false;
  382.     while act_char=' ' do next_char;
  383.     write(yyout, ' ':9);
  384.     while act_char<>#0 do
  385.       if act_char=nl then
  386.         begin
  387.           writeln(yyout);
  388.           next_char;
  389.           while act_char=' ' do next_char;
  390.           write(yyout, ' ':9);
  391.         end
  392.       else if act_char='''' then
  393.         begin
  394.           write(yyout, '''');
  395.           str_state := not str_state;
  396.           next_char;
  397.         end
  398.       else if not str_state and (act_char='}') then
  399.         begin
  400.           writeln(yyout);
  401.           exit;
  402.         end
  403.       else if not str_state and (act_char='$') then
  404.         scan_val
  405.       else
  406.         begin
  407.           write(yyout, act_char);
  408.           next_char;
  409.         end;
  410.   end(*copy_action*);
  411.  
  412. procedure copy_single_action;
  413.   var str_state : Boolean;
  414.   begin
  415.     str_state := false;
  416.     while act_char=' ' do next_char;
  417.     write(yyout, ' ':9);
  418.     while act_char<>#0 do
  419.       if act_char=nl then
  420.         begin
  421.           writeln(yyout);
  422.           next_char;
  423.           while act_char=' ' do next_char;
  424.           write(yyout, ' ':9);
  425.         end
  426.       else if act_char='''' then
  427.         begin
  428.           write(yyout, '''');
  429.           str_state := not str_state;
  430.           next_char;
  431.         end
  432.       else if not str_state and (act_char=';') then
  433.         begin
  434.           writeln(yyout, ';');
  435.           exit;
  436.         end
  437.       else if not str_state and (act_char='$') then
  438.         scan_val
  439.       else
  440.         begin
  441.           write(yyout, act_char);
  442.           next_char;
  443.         end;
  444.   end(*copy_single_action*);
  445.  
  446. procedure copy_rest_of_file;
  447.   begin
  448.     while act_char<>#0 do
  449.       if act_char=nl then
  450.         begin
  451.           writeln(yyout);
  452.           next_char;
  453.         end
  454.       else
  455.         begin
  456.           write(yyout, act_char);
  457.           next_char;
  458.         end;
  459.   end(*copy_rest_of_file*);
  460.  
  461. procedure start_rule ( sym : Integer );
  462.   begin
  463.     if n_rules=0 then
  464.       begin
  465.         (* fix start nonterminal of the grammar: *)
  466.         if startnt=0 then startnt := sym;
  467.         (* add augmented start production: *)
  468.         with act_rule do
  469.           begin
  470.             lhs_sym := -1;
  471.             rhs_len := 2;
  472.             rhs_sym[1] := startnt;
  473.             rhs_sym[2] := 0; (* end marker *)
  474.           end;
  475.         add_rule(newRuleRec(act_rule));
  476.       end;
  477.     act_rule.lhs_sym := sym;
  478.   end(*start_rule*);
  479.  
  480. procedure start_body;
  481.   begin
  482.     act_rule.rhs_len := 0;
  483.     p_act := false;
  484.     writeln(yyout, n_rules:4, ' : begin');
  485.   end(*start_body*);
  486.  
  487. procedure end_body;
  488.   var i : Integer;
  489.   begin
  490.     if not p_act and (act_rule.rhs_len>0) then
  491.       (* add default action: *)
  492.       writeln(yyout, ' ':9, 'yyval := yyv[yysp-',
  493.                             act_rule.rhs_len-1, '];');
  494.     add_rule(newRuleRec(act_rule));
  495.     writeln(yyout, ' ':7, 'end;');
  496.   end(*end_body*);
  497.  
  498. procedure add_rule_action;
  499.   (* process an action inside a rule *)
  500.   var k : Integer; r : RuleRec;
  501.   begin
  502.     writeln(yyout, ' ':7, 'end;');
  503.     inc(n_act);
  504.     k := get_key('$$'+intStr(n_act));
  505.     with r do
  506.       begin
  507.         lhs_sym := new_nt;
  508.         def_key(k, lhs_sym);
  509.         rhs_len := 0;
  510.       end;
  511.     with act_rule do
  512.       begin
  513.         inc(rhs_len);
  514.         if rhs_len>max_rule_len then fatal(rule_table_overflow);
  515.         rhs_sym[rhs_len] := r.lhs_sym;
  516.       end;
  517.     add_rule(newRuleRec(r));
  518.     rule_prec^[n_rules+1] := rule_prec^[n_rules];
  519.     rule_prec^[n_rules] := 0;
  520.     writeln(yyout, n_rules:4, ' : begin');
  521.   end(*add_rule_action*);
  522.  
  523. procedure add_symbol ( sym : Integer );
  524.   begin
  525.     if p_act then add_rule_action;
  526.     p_act := false;
  527.     with act_rule do
  528.       begin
  529.         inc(rhs_len);
  530.         if rhs_len>max_rule_len then fatal(rule_table_overflow);
  531.         rhs_sym[rhs_len] := sym;
  532.         if sym>=0 then rule_prec^[n_rules+1] := sym_prec^[sym]
  533.       end
  534.   end(*add_symbol*);
  535.  
  536. procedure add_action;
  537.   begin
  538.     if p_act then add_rule_action;
  539.     p_act := true;
  540.   end(*add_action*);
  541.  
  542. procedure add_rule_prec ( sym : Integer );
  543.   begin
  544.     rule_prec^[n_rules+1] := sym_prec^[sym];
  545.   end(*add_rule_prec*);
  546.  
  547. procedure generate_parser;
  548.   begin
  549.     if startnt=0 then error(empty_grammar);
  550.     if errors=0 then
  551.       begin
  552.         write('sort ... ');
  553.         sort_rules; rule_offsets;
  554.         write('closures ... ');
  555.         closures;
  556.         write('first sets ... ');
  557.         first_sets;
  558.         write('LR0 set ... ');
  559.         LR0Set;
  560.         write('lookaheads ... ');
  561.         lookaheads;
  562.         writeln;
  563.         write('code generation ... ');
  564.         parse_table;
  565.       end;
  566.   end(*generate_parser*);
  567.  
  568. begin
  569.   n_act := 0;
  570. end(*YaccSem*).
  571.