OS/2 Shareware BBS: 10 Tools/10-Tools.zip/sa104os2.zip/SATHR104.ZIP/SATHER/COMPILER/PARSE.SA

Text File | 1995-02-13 | 82KB | 2,322 lines

-- Copyright (C) International Computer Science Institute, 1994.  COPYRIGHT  --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in    --
-- the file "Doc/License" of the Sather distribution.  The license is also   --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA.  --
--------> Please email comments to "[e-mail]". <----------

-- parse.sa: 1.0 version of parser for 1.0 Sather compiler.
-------------------------------------------------------------------
class PARSE is
   -- Test the parser out.

   main(arg: ARRAY{STR}) is
      if arg.size < 2 then #OUT + "Usage: " + arg[0] + " [-pSather] <files>\n" end;
      #OUT + "Sather/pSather 1.0 parser - 9 Aug 94\n";
      pSather: BOOL; i: INT;
      if (arg.size > 1) and (arg[1] = "-pSather") then pSather := true; i := 2
      else pSather := false; i := 1
      end;
      p ::= PROG::create;
      loop while!(i < arg.size);
         parser ::= PARSER::create(p, arg[i], pSather);
         if ~void(parser) then
            #OUT + "In file " + arg[i] + ":\n";
            tcd: TR_CLASS_DEF := parser.source_file;
            #OUT + "\n";
            loop until!(void(tcd));
               #OUT + ' ' + tcd.name.str + '\n';
               tcd := tcd.next
            end
         end;
         #OUT + "\n\n";
         i := i+1
      end
   end

end; -- PARSE

-------------------------------------------------------------------
class LEX_CONST is
   const
   -- Sather tokens
      eof_tok, null_tok, ident_tok, type_name_tok, and_tok, assert_tok,
      attr_tok, break_tok, case_tok, class_tok, const_tok, else_tok,
      elsif_tok, end_tok, exception_tok, external_tok, false_tok, if_tok,
      include_tok, initial_tok, is_tok, ITER_tok, loop_tok, new_tok, or_tok,
      post_tok, pre_tok, private_tok, protect_tok, quit_tok, raise_tok,
      readonly_tok, result_tok, return_tok, ROUT_tok, SAME_tok, self_tok,
      shared_tok, then_tok, true_tok, type_tok, typecase_tok, until_tok,
      value_tok, void_tok, when_tok, while_tok, yield_tok, lint_tok, lflt_tok,
      lstr_tok, lchar_tok, lparen_tok, rparen_tok, lbracket_tok, rbracket_tok,
      lbrace_tok, rbrace_tok, comma_tok, dot_tok, semi_tok, colon_tok, under_tok,
      plus_tok, minus_tok, times_tok, quotient_tok, is_lt_tok, is_gt_tok, sharp_tok,
      bang_tok, iter_bang_tok, pow_tok, mod_tok, vbar_tok, is_neq_tok, is_leq_tok,
      is_geq_tok, assign_tok, dcolon_tok, transform_tok, is_eq_tok, not_tok,

   -- pSather tokens
      fork_tok, lock_tok, unlock_tok, try_tok, cobegin_tok, with_tok, at_tok,
      here_tok, where_tok, near_tok, far_tok, spread_tok, dist_tok,
      do_tok, as_tok
end; -- LEX_CONST

-------------------------------------------------------------------
value class TOKEN is
   include LEX_CONST;

   attr val: INT;

   create (val: INT): TOKEN is
      t: TOKEN; t := t.val(val); return t
   end;

   is_eq (y: INT): BOOL is return val = y end;
   is_eq (y: TOKEN): BOOL is return val = y.val end;
   is_neq (y: INT): BOOL is return val /= y end;
   is_neq (y: TOKEN): BOOL is return val /= y.val end;

   str: STR is
   -- A string version of the token.
      res: STR;
      case val
   -- Sather tokens
      when eof_tok then res := "end of file"
      when null_tok then res := "null character"
      when ident_tok then res := "an identifier"
      when type_name_tok then res := "an abstract type name"
      when and_tok then res := "'and'"
      when assert_tok then res := "'assert'"
      when attr_tok then res := "'attr'"
      when break_tok then res := "'break'"
      when case_tok then res := "'case'"
      when class_tok then res := "'class'"
      when const_tok then res := "'const'"
      when else_tok then res := "'else'"
      when elsif_tok then res := "'elsif'"
      when end_tok then res := "'end'"
      when exception_tok then res := "'exception'"
      when external_tok then res := "'external'"
      when false_tok then res := "'false'"
      when if_tok then res := "'if'"
      when include_tok then res := "'include'"
      when initial_tok then res := "'initial'"
      when is_tok then res := "'is'"
      when ITER_tok then res := "'ITER'"
      when loop_tok then res := "'loop'"
      when new_tok then res := "'new'"
      when or_tok then res := "'or'"
      when post_tok then res := "'post'"
      when pre_tok then res := "'pre'"
      when private_tok then res := "'private'"
      when protect_tok then res := "'protect'"
      when quit_tok then res := "'quit'"
      when raise_tok then res := "'raise'"
      when readonly_tok then res := "'readonly'"
      when return_tok then res := "'return'"
      when ROUT_tok then res := "'ROUT'"
      when SAME_tok then res := "'SAME'"
      when self_tok then res := "'self'"
      when shared_tok then res := "'shared'"
      when then_tok then res := "'then'"
      when true_tok then res := "true"
      when type_tok then res := "type"
      when typecase_tok then res := "'typecase'"
      when value_tok then res := "'value'"
      when void_tok then res := "'void'"
      when when_tok then res := "'when'"
      when while_tok then res := "'while!'"
      when yield_tok then res := "'yield'"
      when lint_tok then res := "an integer literal"
      when lflt_tok then res := "a floating point literal"
      when lstr_tok then res := "a string literal"
      when lchar_tok then res := "a character literal"
      when lparen_tok then res := "a left parenthesis '('"
      when rparen_tok then res := "a right parenthesis ')'"
      when lbracket_tok then res := "a left bracket '['"
      when rbracket_tok then res := "a right bracket ']'"
      when lbrace_tok then res := "a left brace '{'"
      when rbrace_tok then res := "a right brace '}'"
      when comma_tok then res := "a comma ','"
      when dot_tok then res := "a dot '.'"
      when semi_tok then res := "a semicolon ';'"
      when colon_tok then res := "a colon ':'"
      when under_tok then res := "an underscore '_'"
      when plus_tok then res := "a plus '+'"
      when minus_tok then res := "a minus '-'"
      when times_tok then res := "an asterisk '*'"
      when quotient_tok then res := "a slash '/'"
      when is_lt_tok then res := "a less than '<'"
      when is_gt_tok then res := "a greater than '>'"
      when sharp_tok then res := "a sharp '#'"
      when bang_tok, iter_bang_tok then res := "an exclamation mark '!'"
      when pow_tok then res := "a carat '^'"
      when mod_tok then res := "a percent '%'"
      when vbar_tok then res := "a vertical bar '|'"
      when is_neq_tok then res := "a not equals '/='"
      when is_leq_tok then res := "a less than or equals '<='"
      when is_geq_tok then res := "a greater than or equals '>='"
      when assign_tok then res := "an assign operator ' := '"
      when transform_tok then res := "a transform '->'"
      when is_eq_tok then res := "a equals '='"
      when not_tok then res := "a not '~'"

   -- pSather tokens
      when fork_tok then res := "a fork ':-'"
      when lock_tok then res := "'lock'"
      when unlock_tok then res := "'unlock'"
      when try_tok then res := "'try'"
      when cobegin_tok then res := "'cobegin'"
      when with_tok then res := "'with'"
      when at_tok then res := "a at '@'"
      when here_tok then res := "'here'"
      when where_tok then res := "'where'"
      when near_tok then res := "'near'"
      when far_tok then res := "'far'"
      when spread_tok then res := "'spread'"
      when dist_tok then res := "'dist'"
      when do_tok then res := "'do'"
      when as_tok then res := "'as'"

      else res := "unknown token"
      end;
      return res
   end;

end; -- TOKEN

----------------------------------------------------------------------

value class SFILE_ID is
-- A character position in a Sather source file. Used for generating error messages.
-- Maintains a shared list of already processed files, and provides the routines for
-- reading a file. Non-reentrant.

   const eof_char: CHAR := '\0'; -- returned at end of file

   private attr loc: INT;
   private const B: INT := 1024; -- maximal line length
   private const sentinel: INT := 2147483647;
   private shared files: FLIST{STR}; -- list of registered file names
   private shared lines: FLIST{INT}; -- list of accumulated lines (0 for first file)

   private shared source: FSTR; -- the current source file as a FSTR
   private shared pos: INT; -- the current position in source line
   private shared column: INT; -- the current column
   private shared line_pos: INT; -- the position of the first character in the line
   private shared newline: BOOL; -- next character starts a new line
   private shared line: INT := 0; -- current accumulated line number


   create (loc: INT): SFILE_ID is
      r: SFILE_ID; r := r.loc(loc); return r
   end;

   is_eq (y: SFILE_ID): BOOL is return loc = y.loc end;
   is_neq (y: SFILE_ID): BOOL is return loc /= y.loc end;

   no_location: SFILE_ID is return #SFILE_ID(-1) end;

   open_file (p: PROG, name: STR): BOOL is
      file: FILE := file.open_for_read(name);
      if ~file.error then source := file.fstr; file.close
      else source := void
      end;
      if ~void(source) then
         if void(files) then
            files := FLIST{STR}::create(64);
            lines := FLIST{INT}::create(64);
         end;
         files := files.push(name);
         lines := lines.push(sentinel);
         pos := 0; column:=1; newline := true;
         return true
--    else                                                                      -- NLP
      end;                                                                      -- NLP
         p.set_eloc(no_location);
         p.err("couldn't read file: " + name);
         return false
--    end                                                                       -- NLP
   end;

   close_file is
      if ~void(source) then lines[lines.size-1] := line; source := void end
   end;

   next: CHAR is
      if pos < source.size then
         if newline then
         line := line+1;
         line_pos := pos;
         newline := false;
         column := 1;
     end;
         ch: CHAR := source[pos];
     pos := pos+1;
     case ch
     when '\t' then column:=column+8-(column-1).mod(8);
         when eof_char then ch := ' ' -- eof_char only at the end of the file
         when '\n' then newline := true;
     else newline:=false; column:=column+1;
         end;
         return ch
--    else return eof_char                                                      -- NLP
      end; return eof_char;                                                     -- NLP
--    end                                                                       -- NLP
   end;

   source_loc: SFILE_ID is
      if ~void(source) then
         c: INT := (column-2).min(SFILE_ID::B-1).max(1);
         return #SFILE_ID(line*SFILE_ID::B + c)
--    else return no_location                                                   -- NLP
      end; return no_location;                                                  -- NLP
--    end                                                                       -- NLP
   end;

   ---------------------------------
   -- The following routines operate on self
   ---------------------------------

   private index: INT is
   -- List index referred to encoded in loc
      if ~void(lines) then
         i: INT := 0;
         l: INT := loc/SFILE_ID::B;
         p: INT := -1;
         loop while!(i < lines.size);
            if (p < l) and (l <= lines[i]) then break! end;
            p := lines[i]; i := i+1
         end;
         return i
      else #OUT + "compiler error in SFILE_ID::index: no files\n";
--       return 0                                                               -- NLP
      end; return 0;                                                            -- NLP
--    end                                                                       -- NLP
   end;

   file_in: STR is
   -- File name encoded in loc
      return files[index]
   end;

   line_num_in: INT is
   -- Line number encoded in loc
      i: INT := index;
      if i > 0 then return loc/SFILE_ID::B - lines[i-1]
--    else return loc/SFILE_ID::B                                               -- NLP
      end; return loc/SFILE_ID::B;                                              -- NLP
--    end                                                                       -- NLP
   end;

   col_num_in: INT is
   -- Column position encoded in loc
      return loc.mod(SFILE_ID::B)
   end;

   str: STR is
   -- Name of the file into which loc is pointing
      if loc = -1 then return "at unknown location"
--    else return file_in + ':' + line_num_in + ':' + col_num_in                -- NLP
      end; return file_in + ':' + line_num_in + ':' + col_num_in;               -- NLP
--    end                                                                       -- NLP
   end;

end; -- SFILE_ID

-------------------------------------------------------------------

class SCANNER is
   -- Scanner for Sather 1.0.  Strategy: a big case statement.
   -- Whitespace and comments are passed in tight loops.  Keywords
   -- are distinguished from identifiers by switching on the first
   -- character, followed by verification on the following characters
   -- ordered by expected keyword frequency.

   include LEX_CONST; -- consts for tokens

-- Scan a string for Sather 1.0 tokens

   attr lex_value:IDENT; -- ident token value
   attr char_value:CHAR; -- character token value
   attr num_value:RAT; -- numerical value
   attr value_type: INT; -- one of the five floating_point types (see TR_FLT_LIT_EXPR)
                                     -- TR_FLT_LIT_EXPR::flt and TR_FLT_LIT_EXPR::flti also used for
                                     -- integers

   attr prog: PROG;
   attr next: CHAR;
   attr buf: FSTR;
   attr backed_up: BOOL;
   attr last_char: CHAR;
   attr pSather: BOOL;

   create (p: PROG, file: STR, pSather: BOOL): SCANNER is
   -- initialize scanner, read f
      res: SCANNER;
      if SFILE_ID::open_file(p, file) then
         res := new;
         res.prog := p;
         res.next := SFILE_ID::next;
         res.buf := #FSTR(256);
         res.backed_up := false;
         res.pSather := pSather
      else res := void
      end;
      return res
   end;

   close_file is
      SFILE_ID::close_file
   end;

   fetch is
      if backed_up then
         c: CHAR := next;
         next := last_char;
         last_char := c;
         backed_up := false
      else
         last_char := next;
         next := SFILE_ID::next
      end
   end;

   backup is
   -- Backup one character at most.
   --
      c: CHAR := next;
      next := last_char;
      last_char := c;
      backed_up := true end;

   error (msg:STR) is
   -- where errors during scanning go
   --
      prog.set_eloc(SFILE_ID::source_loc);
      prog.err(msg) end;

   character: CHAR is
   -- value of something preceeded by a backslash
   --
      res: CHAR;
      fetch;
      case next
      when '0','1','2','3','4','5','6','7' then -- octal character
         v: INT := 0; d: INT;
         loop d := next.hex_digit_value;
            while!((0 <= d) and (d < 8));
            v := v*8 + d;
            fetch
         end;
         res := v.char
      when 'a' then res := '\a'; fetch
      when 'b' then res := '\b'; fetch
      when 'f' then res := '\f'; fetch
      when 'n' then res := '\n'; fetch
      when 'r' then res := '\r'; fetch
      when 't' then res := '\t'; fetch
      when 'v' then res := '\v'; fetch
      when '\\' then res := '\\'; fetch
      when '\'' then res := '\''; fetch
      when '"' then res := '\"'; fetch
      else res := next; fetch
      end;
      return res
   end;

   identifier: TOKEN is
   -- Find out if ident or keyword.
   --
      buf.clear;
      loop c::=next;
      while!(c.is_alphanum or (c = '_'));
          buf := buf + c;
      fetch;
      end;
      res ::= ident_tok;
      case buf[0]
      when 'a' then
         case buf
         when "attr" then res := attr_tok
         when "and" then res := and_tok
         when "assert" then res := assert_tok
     when "as" then if pSather then res := as_tok end
         else end
      when 'b' then
         if (buf = "break") and (next = '!') then fetch; res := break_tok end
      when 'c' then
         case buf
         when "case" then res := case_tok
         when "class" then res := class_tok
         when "const" then res := const_tok
         when "cobegin" then
            if pSather then res := cobegin_tok end
         else end
      when 'd' then
     if pSather then
         case buf
         when "dist" then res := dist_tok
         when "do" then res := do_tok
         else end
     end
      when 'e' then
         case buf
         when "end" then res := end_tok
         when "elsif" then res := elsif_tok
         when "else" then res := else_tok
         when "exception" then res := exception_tok
         when "external" then res := external_tok
        else end
      when 'f' then
         case buf
         when "false" then res := false_tok
         when "far" then
            if pSather then res := far_tok end
         else end
      when 'h' then
         if (buf = "here") and pSather then res := here_tok end
      when 'i' then
         case buf
         when "is" then res := is_tok
         when "if" then res := if_tok
         when "initial" then res := initial_tok
         when "include" then res := include_tok
        else end
      when 'I' then
         if buf = "ITER" then res := ITER_tok end
      when 'l' then
         case buf
         when "loop" then res := loop_tok
         when "lock" then
            if pSather then res := lock_tok end
         else end
      when 'n' then
         case buf
         when "new" then res := new_tok
         when "near" then
            if pSather then res := near_tok end
         else end
      when 'o' then
         if buf = "or" then res := or_tok end
      when 'p' then
         case buf
         when "pre" then res := pre_tok
         when "post" then res := post_tok
         when "private" then res := private_tok
         when "protect" then res := protect_tok
        else end
      when 'q' then
         if buf = "quit" then res := quit_tok end
      when 'r' then
         case buf
         when "return" then res := return_tok
         when "result" then res := result_tok
         when "readonly" then res := readonly_tok
         when "raise" then res := raise_tok
        else end
      when 'R' then
         if buf = "ROUT" then res := ROUT_tok end
      when 's' then
         case buf
         when "self" then res := self_tok
         when "shared" then res := shared_tok
     when "spread" then if pSather then res := spread_tok end
         else end
      when 'S' then
         if buf = "SAME" then res := SAME_tok end
      when 't' then
         case buf
         when "then" then res := then_tok
         when "true" then res := true_tok
         when "type" then res := type_tok
         when "typecase" then res := typecase_tok
         when "try" then
            if pSather then res := try_tok end
         else end
      when 'u' then
         case buf
         when "until" then
            if next = '!' then fetch; res := until_tok end
         when "unlock" then
            if pSather then res := unlock_tok end
         else end
      when 'v' then
         case buf
         when "void" then res := void_tok
         when "value" then res := value_tok
         else end
      when 'w' then
         case buf
         when "when" then res := when_tok
         when "while" then
            if next = '!' then fetch; res := while_tok end
         when "where" then
            if pSather then res := where_tok end
         when "with" then
            if pSather then res := with_tok end
         else end
      when 'y' then
         if buf = "yield" then res := yield_tok end
      else end;
      if res = ident_tok then add_buf_to_sym_table end;
      return #TOKEN(res)
   end;

   add_buf_to_sym_table is
   -- make sure in sym table, and set lex_value to id.
   --
      lex_value := prog.ident_for(buf.str)
   end;

   int_literal (base: INT): INTI is
      b ::= #INTI(base); x ::= #INTI(0);
      loop d ::= next.hex_digit_value;
         if next = '_' then fetch
         elsif (0 <= d) and (d < base) then fetch; x := x*b + #INTI(d)
         else break!
         end
      end;
      return x
   end;

   number: TOKEN is
      res: INT := lint_tok; d ::= 10;
      if next = '0' then fetch; -- check for special base
         if next = 'b' then fetch; d := 2
         elsif next = 'o' then fetch; d := 8
         elsif next = 'x' then fetch; d := 16 end
      end;
      m ::= int_literal(d); e ::= #INTI(0);
      if (next = '.') and (d = 10) then fetch;
         d := next.digit_value;
         if d >= 0 then -- floating point number
            ec ::= 0; ten ::= #INTI(10);
            loop
               if next = '_' then fetch
               elsif d >= 0 then fetch; m := m*ten + #INTI(d); ec := ec-1
               else break!
               end;
               d := next.digit_value
            end;
            e := #INTI(ec);
            if next = 'e' then fetch;
               neg ::= false;
               if next = '-' then fetch; neg := true end;
               d := next.digit_value;
               if d >= 0 then
                  if neg then e := e - int_literal(10)
                  else e := e + int_literal(10)
                  end
               else error("malformed floating point literal: e must be followed by - or a decimal digit")
               end
            end;
            res := lflt_tok
         else backup -- integer with a dot call
         end
      end;
      if e.is_neg then num_value := #RAT(m, #INTI(10) ^ (-e.int))
      else num_value := #RAT(m * #INTI(10) ^ e.int)
      end;
      value_type := TR_FLT_LIT_EXPR::flt; -- ordinary case
      if next = 'i' then fetch; value_type := TR_FLT_LIT_EXPR::flti
      elsif res = lflt_tok then
         if next = 'd' then fetch;
            if next = 'x' then fetch; value_type := TR_FLT_LIT_EXPR::fltdx
            else value_type := TR_FLT_LIT_EXPR::fltd
            end
         elsif next = 'x' then fetch; value_type := TR_FLT_LIT_EXPR::fltx
         end
      end;
      return #TOKEN(res)
   end;

   skip_whitespace is
      loop while!(next.is_space); fetch end
   end;

   comment is
      n ::= 1;
      loop
         while!((next /= SFILE_ID::eof_char) and (n > 0));
         if next = '(' then fetch;
            if next = '*' then fetch; n := n+1 end
         elsif next = '*' then fetch;
            if next = ')' then fetch; n := n-1 end
         else fetch
         end
      end
   end;

   is_class_name (s: STR): BOOL is
   -- s is a legal identifier
   --
      loop if s.elt!.is_lower then return false end end;
      return true
   end;

   token: TOKEN is
   -- next Sather token; eof_tok if at end.
   --
      whitespace ::= false;
      res: INT := null_tok;
      loop
         case next
         when SFILE_ID::eof_char then res := eof_tok
         when '\n', ' ', '\t', '\b', '\r', '\v' then
            whitespace := true; skip_whitespace
         when 'a','b','c','d','e','f','g','h','i','j','k','l','m',
            'n','o','p','q','r','s','t','u','v','w','x','y','z',
            'A','B','C','D','E','F','G','H','I','J','K','L','M',
            'N','O','P','Q','R','S','T','U','V','W','X','Y','Z' then
            res := identifier.val
         when '(' then fetch;
            if next = '*' then fetch; comment
            else res := lparen_tok end
         when ')' then fetch; res := rparen_tok
         when '[' then fetch; res := lbracket_tok
         when ']' then fetch; res := rbracket_tok
         when '{' then fetch; res := lbrace_tok
         when '}' then fetch; res := rbrace_tok
         when ',' then fetch; res := comma_tok
         when '.' then fetch; res := dot_tok
         when ';' then fetch; res := semi_tok
         when '$' then fetch;
            if next.is_upper then
               res := identifier.val;
               if (res = ident_tok) and is_class_name(lex_value.str) then
                  lex_value := prog.ident_for("$" + lex_value.str);
                  res := type_name_tok
               end
            end;
            if res /= type_name_tok then
               error("'$' without type name")
            end
         when '+' then fetch; res := plus_tok
         when '-' then fetch;
            if next = '-' then -- skip comment
               loop fetch;
                  until!((next = '\n') or (next = SFILE_ID::eof_char)) end;
               if next = '\n' then fetch
               else res := eof_tok end
            elsif next = '>' then fetch; res := transform_tok
            else res := minus_tok
            end
         when '*' then fetch; res := times_tok
         when '#' then fetch; res := sharp_tok
         when '^' then fetch; res := pow_tok
         when '%' then fetch; res := mod_tok
         when '|' then fetch; res := vbar_tok
         when '!' then fetch;
            if whitespace then res := bang_tok
            else res := iter_bang_tok end
         when '_' then fetch; res := under_tok
         when '=' then fetch; res := is_eq_tok
         when ':' then -- one of :,  := , ::, :  :=, :-
            fetch;
            if next = ':' then fetch;
               if next = '=' then        -- special case for " ::= "
                  res := colon_tok;
                  backup
               else res := dcolon_tok end;
            elsif next = '=' then fetch; res := assign_tok
            elsif (next = '-') and pSather then res := fork_tok
            else res := colon_tok end
         when '/' then -- one of /, /=
            fetch;
            if next = '=' then fetch; res := is_neq_tok
            else res := quotient_tok end
         when '<' then -- one of <, <=
            fetch;
            if next = '=' then fetch; res := is_leq_tok
            else res := is_lt_tok end
         when '>' then -- one of >, >=
            fetch;
            if next = '=' then fetch; res := is_geq_tok
            else res := is_gt_tok end
         when '~' then fetch; res := not_tok
         -- everything left is some kind of literal
         when '\'' then -- a CHAR literal
            fetch;
            if next = '\\' then -- something funny, have to decode
               char_value := character
            else char_value := next; fetch
            end;
            if next /= '\'' then error("malformed character literal") end;
            fetch; res := lchar_tok
         when '"' then -- a STR literal
            fetch;
            buf.clear;
            loop -- collect adjacent strings
               loop until!(next = '"' or next = '\n');
                  if next = '\\' then buf := buf + character;
                  else buf := buf + next; fetch
                  end
               end;
               if next = '\n' then
                  error("unterminated STR literal");
                  break! end;
               fetch; skip_whitespace;
               if next /= '"' then break! end;
               fetch -- go past next " mark
            end; -- outer loop
            add_buf_to_sym_table;
            res := lstr_tok
         when '0','1','2','3','4','5','6','7','8','9' then res := number.val
         when '@' then
            if pSather then fetch; res := at_tok
            else error("unknown character: '" + next + '\''); fetch
            end;
         else error("unknown character: '" + next + '\''); fetch
         end;
         while!(res = null_tok)
      end;
      return #TOKEN(res)
   end

end; -- SCAN

----------------------------------------------------------------------
class PARSER is
   include LEX_CONST;

   attr prog: PROG;
   attr scanner: SCANNER;
   attr next: TOKEN;
   attr entered: FLIST{STR}; -- stack of grammatical procedure calls

   create (p: PROG, file: STR, pSather: BOOL): PARSER is
      res: PARSER;
      s ::= SCANNER::create(p, file, pSather);
      if ~void(s) then
         res := new;
         res.prog := p;
         res.scanner := s;
         res.next := res.scanner.token;
         res.entered := FLIST{STR}::create(64)
      else res := void
      end;
      return res
   end;

   close_file is
      scanner.close_file
   end;

   source_loc: SFILE_ID is
      return SFILE_ID::source_loc
   end;

   error (msg: STR) is
      -- where errors during parsing go
      prog.set_eloc(source_loc);
      prog.err(msg + " (in " + entered.top + ')')
   end;

   exp_error (msg: STR) is
      error(msg + " expected, but found " + next.str)
   end;

   fetch is
      next := scanner.token
   end;

   match (t: INT) is
      if next /= t then exp_error(#TOKEN(t).str) end;
      fetch
   end;

   check (t: INT): BOOL is
      if next = t then fetch; return true
--    else return false                                                         -- NLP
      end; return false;                                                        -- NLP
--    end                                                                       -- NLP
   end;

   enter (s: STR) is
   -- announce beginning of syntactic structure (for nice errors)
   --
      entered := entered.push(s)
   end;

   exit is
   -- exit from syntactic structure
   --
      s ::= entered.pop
   end;

   ident: IDENT is
      return scanner.lex_value
   end;

   append_bang (arg: IDENT): IDENT is
      -- make new version with trailing bang
      return prog.ident_for(arg.str + "!")
   end;

   is_type_or_class_start (t: TOKEN): BOOL is
      case t.val
      when type_tok, spread_tok, value_tok, external_tok, class_tok then
      return true
--    else return false                                                         -- NLP
      else; end; return false;                                                  -- NLP
--    end                                                                       -- NLP
   end;

   source_file: TR_CLASS_DEF is
   -- source_file =>
   -- [abstract_type_def | class] {';' [abstract_type_def | class]}
   --
      res: TR_CLASS_DEF;
      enter("source file");
      loop
         if is_type_or_class_start(next) then
            if next = type_tok then
           if void(res) then res:=abstract_type_def
           else res.append(abstract_type_def) end;
        else
           if void(res) then res:=class_def
           else res.append(class_def) end end end;
     if check(semi_tok) then -- ok
     elsif is_type_or_class_start(next) then exp_error("semicolon")
         else
            if next /= eof_tok then exp_error("end of file") end;
            break! end end;
      close_file;
      exit; return res
   end;

   abstract_type_def: TR_CLASS_DEF is
   -- abstract_type_def =>
   -- 'type' abstract_type_name
   -- ['{' param_dec {',' param_dec}'}']
   -- ['<' type_spec_list] ['>' type_spec_list]
   -- 'is' [abstract_signature] {';' [abstract_signature]} 'end'
   --
      enter("abstract type definition");
      res ::= #TR_CLASS_DEF; res.source := source_loc; res.kind := res.abs;
      match(type_tok);
      if check(type_name_tok) then --ok
      else exp_error("abstract type name");
         if next = ident_tok then fetch end
      end;
      res.name := ident;
      if check(lbrace_tok) then
         loop until!(next /= ident_tok);
        if void(res.params) then res.params:=param_dec
        else res.params.append(param_dec) end;
            if ~check(comma_tok) then break! end end;
         match(rbrace_tok) end;
      if check(is_lt_tok) then res.under := type_spec_list end;
      if check(is_gt_tok) then res.over := type_spec_list end;
      match(is_tok);
      res.body := abstract_signature_list;
      match(end_tok);
      exit;
      return res
   end;

   abstract_signature_list: $TR_CLASS_ELT is
   -- abstract_signature_list =>
   -- [abstract_signature] {';' [abstract_signature]}
   --
      res: $TR_CLASS_ELT;
      enter("list of abstract signatures");
      loop
         if (next = ident_tok) or (next = bang_tok) or
            (next = iter_bang_tok) then
            if void(res) then res := abstract_signature
            else res.append(abstract_signature) end
         end;
         if check(semi_tok) then -- ok
         elsif next = ident_tok then exp_error("semicolon")
         else break!
         end
      end;
      if next /= end_tok then
         exp_error("semicolon");
         loop while!((next /= end_tok) and (next /= eof_tok)); fetch end
      end;
      exit;
      return res
   end;

   abstract_signature: TR_ROUT_DEF is
   -- abstract_signature =>
   -- (ident | iter_name)
   -- ['(' abstract_argument {',' abstract_argument} ')']
   -- [':' type_spec]
   --
      enter("abstract signature");
      res ::= #TR_ROUT_DEF; res.source := source_loc; res.is_abstract := true;
      res.name := rout_or_iter_name;
      if check(lparen_tok) then
         enter("abstract arguments");
         loop
        if void(res.args_dec) then
           res.args_dec:=abstract_argument(res.name.is_iter);
        else res.args_dec.append(
           abstract_argument(res.name.is_iter)) end;
            while!(check(comma_tok)) end;
         match(rparen_tok);
         exit end;
      if check(colon_tok) then
         enter("return type specification");
         res.ret_dec := type_spec;
         exit end;
      exit;
      return res
   end;

   abstract_argument (is_iter: BOOL): TR_ARG_DEC is
   -- arg_dec => [ident {',' ident} ':'] type_spec ['!']
   --
      res: TR_ARG_DEC;
      enter("abstract argument");
      loop
         newa ::= #TR_ARG_DEC; newa.source := source_loc;
         match(ident_tok);
         newa.name := ident;
         if void(res) then res := newa
         else res.append(newa)
         end;
         while!(check(comma_tok))
      end;
      match(colon_tok);
      tp:TR_TYPE_SPEC := type_spec;
      hot:BOOL := check(bang_tok) or check(iter_bang_tok);
      if hot and ~is_iter then
         error("hot arguments not allowed in routine declarations")
      end;
      p: TR_ARG_DEC := res;
      loop until!(void(p)); p.tp := tp; p.is_hot := hot; p := p.next end;
      exit;
      return res
   end;

   class_def: TR_CLASS_DEF is
   -- class =>
   --        ['spread' | 'value' | 'external'] 'class' uppercase_ident
   --        ['{' param_dec {',' param_dec}'}']
   --        ['<' type_spec_list]
   --        'is' class_elt_list 'end'
   --
      enter("class");
      res ::= #TR_CLASS_DEF; res.source := source_loc;
      case next.val
      when spread_tok then fetch; res.kind := res.spr
      when value_tok then fetch; res.kind := res.val
      when external_tok then fetch; res.kind := res.ext
      else res.kind := res.ref end;
      match(class_tok);
      if check(ident_tok) then
         if ~is_class_name(ident) then
            exp_error("class name")
         end
      else exp_error("concrete class name");
         if next = type_name_tok then fetch end
      end;
      res.name := ident;
      if check(lbrace_tok) then
         loop until!(next /= ident_tok);
        if void(res.params) then res.params:=param_dec
        else res.params.append(param_dec) end;
            if ~check(comma_tok) then break! end end;
         match(rbrace_tok) end;
      if check(is_lt_tok) then res.under := type_spec_list end;
      match(is_tok);
      res.body := class_elt_list;
      match(end_tok);
      exit;
      return res
   end;

   is_class_name (x: IDENT): BOOL is
      return SCANNER::is_class_name(x.str)
   end;

   param_dec: TR_PARAM_DEC is
   -- param_dec => uppercase_ident ['<' type_spec]
   --
      enter("parameter declaration");
      res ::= #TR_PARAM_DEC; res.source := source_loc;
      match(ident_tok); res.name := ident;
      if ~is_class_name(res.name) then
         exp_error("class name") end;
      if check(is_lt_tok) then res.type_constraint := type_spec end;
      exit;
      return res
   end;

   is_class_elt_start (t: TOKEN): BOOL is
      case t.val
      when private_tok, readonly_tok, const_tok, shared_tok,
         attr_tok, include_tok, ident_tok, bang_tok, iter_bang_tok
      then return true
--    else return false                                                         -- NLP
      else; end; return false;                                                  -- NLP
--    end                                                                       -- NLP
   end;

   class_elt_list: $TR_CLASS_ELT is
   -- class_elt_list => [class_elt] {';' [class_elt]}
   --
      res: $TR_CLASS_ELT;
      enter("list of class elements");
      loop
         if is_class_elt_start(next) then
            if void(res) then res := class_elt
            else res.append(class_elt) end end;
         if check(semi_tok) then -- ok
         elsif is_class_elt_start(next) then exp_error("semicolon")
         else break! end end;
      if next /= end_tok then
      exp_error("semicolon");
      loop while!((next /= end_tok) and (next /= eof_tok)); fetch end end;
      exit;
      return res
   end;

   class_elt: $TR_CLASS_ELT is
   -- class_elt => include_clause | const_def | shared_def | attr_def |
   --    rout_def | iter_def
   --
      res: $TR_CLASS_ELT;
      enter("class element");
      mode ::= #TOKEN(null_tok);
      if (next = private_tok) or (next = readonly_tok) then mode := next; fetch end;
      case next.val
      when include_tok then res := include_clause(mode)
      when const_tok then res := const_def(mode)
      when shared_tok then res := shared_def(mode)
      when attr_tok then res := attr_def(mode)
      else res := rout_def(mode)
      end;
      exit;
      return res
   end;

   include_clause (mode: TOKEN): $TR_CLASS_ELT is
   -- include_clause => 'include' type_spec [feat_mod {',' feat_mod}]
   -- feat_mod => ident '->' [['private' | 'readonly'] ident]
   --
   -- 'private' already seen and stripped if present.
   --
      res: $TR_CLASS_ELT;
      enter("include clause");
      if mode = readonly_tok then
         error("readonly not allowed for includes") end;
      match(include_tok);
      incl ::= #TR_INCLUDE_CLAUSE; incl.source := source_loc;
      incl.is_private := mode = private_tok;
      incl.tp := type_spec;
      res := incl;
      if (next = ident_tok) or (next = bang_tok) or (next = iter_bang_tok) then
         loop
            newm ::= #TR_FEAT_MOD; newm.source := source_loc;
            newm.name := rout_or_iter_name;
            match(transform_tok);
            case next.val
            when private_tok then fetch;
               newm.is_private := true;
               newm.new_name := rout_or_iter_name
            when readonly_tok then fetch;
               newm.is_readonly := true;
               newm.new_name := rout_or_iter_name
            when ident_tok, bang_tok, iter_bang_tok then
               newm.new_name := rout_or_iter_name
            else end;
            if ~void(newm.new_name) then
               if newm.name.is_iter /= newm.new_name.is_iter then
                  error("routine can't become an iter or vice versa")
               end
            end;
        if void(incl.mods) then incl.mods:=newm
        else incl.mods.append(newm) end;
            while!(check(comma_tok))
         end
      end;
      exit;
      return res
   end;

   const_def (mode: TOKEN): $TR_CLASS_ELT is
   -- const_def =>
   --        ['private'] 'const' ident
   --        (':' type_spec ' := ' expr | [' := ' expr][',' ident_list])
   --
   -- private_tok already seen and stripped if present.
   --
      res: $TR_CLASS_ELT;
      enter("const definition");
      if mode = readonly_tok then
         error("readonly not allowed for constants") end;
      match(const_tok);
      con ::= #TR_CONST_DEF; con.source := source_loc;
      con.is_private := mode = private_tok;
      res := con;
      match(ident_tok);
      con.name := ident;
      if check(colon_tok) then
         con.tp := type_spec; match(assign_tok); con.init := expr
      else
         if check(assign_tok) then con.init := expr
         else zero ::= #TR_INT_LIT_EXPR; zero.source := source_loc; zero.val := #INTI(0);
            con.init := zero
         end;
         counter: INT := 1;
         loop while!(check(comma_tok));
            -- new constant
            newc ::= #TR_CONST_DEF; newc.source := source_loc;
            newc.is_private := mode = private_tok;
            match(ident_tok);
            newc.name := ident;
               -- new value
            arg ::= #TR_INT_LIT_EXPR; arg.source := source_loc; arg.val := #INTI(counter);
            ex ::= #TR_CALL_EXPR; ex.source := source_loc;
            ex.ob := con.init;
            ex.name := prog.ident_builtin.plus_ident;
            ex.args := arg;
            newc.init := ex;
        if void(res) then res:=newc
        else res.append(newc) end;
            counter := counter+1
         end
      end;
      exit;
      return res
   end;

   shared_def (mode: TOKEN): $TR_CLASS_ELT is
   -- shared_def =>
   --        'shared' (ident ':' type_spec ':=' expr |
   --        ident_list ':' type_spec)
   --
   -- private or readonly already stripped if present.
   --
      res: $TR_CLASS_ELT;
      enter("shared definition");
      match(shared_tok);
      loop
         newid ::= #TR_SHARED_DEF; newid.source := source_loc;
         newid.is_private := mode = private_tok;
         newid.is_readonly := mode = readonly_tok;
         match(ident_tok);
         newid.name := ident;
         if void(res) then res := newid
         else res.append(newid)
         end;
         while!(check(comma_tok)) end;
      match(colon_tok);
      tp: TR_TYPE_SPEC := type_spec;
      p: $TR_CLASS_ELT := res;
      loop until!(void(p));
         typecase p when TR_SHARED_DEF then p.tp := tp end;
         p := p.next
      end;
      if check(assign_tok) then
         typecase res when TR_SHARED_DEF then res.init := expr end;
         if ~void(res.next) then
            error("only single shareds may be initialized") end end;
      exit;
      return res
   end;

   attr_def (mode: TOKEN): $TR_CLASS_ELT is
   -- attr_def =>  'attr' ident_list ':' type_spec
   --
   -- private or readonly already stripped if present.
   --
      res: $TR_CLASS_ELT;
      enter("attribute definition");
      match(attr_tok);
      loop
         newid ::= #TR_ATTR_DEF; newid.source := source_loc;
         newid.is_private := mode = private_tok;
         newid.is_readonly := mode = readonly_tok;
         match(ident_tok);
         newid.name := ident;
         if void(res) then res := newid
         else res.append(newid)
         end;
         while!(check(comma_tok)) end;
      match(colon_tok);
      tp:TR_TYPE_SPEC := type_spec;
      p: $TR_CLASS_ELT := res;
      loop until!(void(p));
         typecase p when TR_ATTR_DEF then p.tp := tp end;
         p := p.next
      end;
      exit;
      return res
   end;

   type_spec: TR_TYPE_SPEC is
   -- type_spec =>
   --        class_name ['{' type_spec_list '}'] |
   --        ('ROUT' | 'ITER') ['{' type_spec ['!']
   --                {',' type_spec ['!']} '}'] [':' type_spec] |
   --        'SAME'
   --
      enter("type specification");
      res ::= #TR_TYPE_SPEC; res.source := source_loc;
      if check(SAME_tok) then res.kind := TR_TYPE_SPEC::same
      elsif (next = type_name_tok) or (next = ident_tok) then
         if (next = ident_tok) and ~is_class_name(ident) then
            error("class name must be all upper_case") end;
         res.kind := TR_TYPE_SPEC::ord;
         res.name := ident; fetch;
         if check(lbrace_tok) then
            res.params := type_spec_list;
            match(rbrace_tok) end
      else
         if check(ROUT_tok) then res.kind := TR_TYPE_SPEC::rt
         elsif check(ITER_tok) then res.kind := TR_TYPE_SPEC::it
         else exp_error("type specifier") end;
         if check(lbrace_tok) then
            loop
               tp:TR_TYPE_SPEC := type_spec;
               if check(bang_tok) or check(iter_bang_tok) then
                  if res.kind = TR_TYPE_SPEC::it then tp.is_hot := true
                  else error("no hot arguments in bound routine") end end;
           if void(res.params) then res.params:=tp
           else res.params.append(tp) end;
               while!(check(comma_tok)) end;
            match(rbrace_tok) end;
         if check(colon_tok) then res.ret := type_spec end end;
      exit;
      return res
   end;

   type_spec_list: TR_TYPE_SPEC is
   -- type_spec_list => type_spec {',' type_spec}
   --
      enter("list of type specifications");
      res ::= type_spec;
      loop while!(next = comma_tok);
         fetch; res.append(type_spec)
      end;
      exit;
      return res
   end;

   rout_or_iter_name: IDENT is
   -- rout_or_iter_name => ident | [ident] '!'
   --
      res: IDENT;
      if next = ident_tok then res := ident; fetch;
         if next = iter_bang_tok then fetch;
            res := append_bang(res)
         elsif next = bang_tok then fetch;
            res := append_bang(res); error("not a correct iter_name")
         end
      elsif (next = bang_tok) or (next = iter_bang_tok) then fetch;
         res := prog.ident_for("!")
      else exp_error("routine or iter name"); res := prog.ident_for("a")
      end;
      return res
   end;

   rout_def (mode: TOKEN): TR_ROUT_DEF is
   -- rout_def =>
   --        (ident | iter_name) ['(' arg_dec {',' arg_dec} ')']
   --        [':' type_spec]
   --        ['pre' expr] ['post' expr]
   --        ['is' stmt_list 'end']
   --
   -- private already stripped if present.
   --
      res: TR_ROUT_DEF;
      enter("routine or iter definition");
      if mode = readonly_tok then
         error("readonly not allowed for routines or iters") end;
      res := #TR_ROUT_DEF; res.source := source_loc;
      res.name := rout_or_iter_name;
      res.is_private := mode = private_tok;
      if check(lparen_tok) then
         enter("arguments");
         loop
        if void(res.args_dec) then
           res.args_dec:=arg_dec(res.name.is_iter)
        else res.args_dec.append(arg_dec(res.name.is_iter)) end;
            while!(check(comma_tok)) end;
         match(rparen_tok);
         exit end;
      if check(colon_tok) then
         enter("return type specification");
         res.ret_dec := type_spec;
         exit end;
      if check(pre_tok) then
         enter("precondition declaration");
         res.pre_e := expr;
         exit end;
      if check(post_tok) then
         enter("postcondition declaration");
         res.post_e := expr;
         exit end;
      if check(is_tok) then
         enter("routine/iter body");
         res.stmts := stmt_list; res.is_abstract := false;
         match(end_tok);
         exit
      else res.is_abstract:=true end;
      exit;
      return res
   end;

   arg_dec (is_iter: BOOL): TR_ARG_DEC is
   -- arg_dec => ident {',' ident} ':' type_spec ['!']
   --
      res: TR_ARG_DEC;
      enter("routine/iter argument declaration");
      loop
         newa ::= #TR_ARG_DEC; newa.source := source_loc;
         match(ident_tok);
         newa.name := ident;
     if void(res) then res:=newa
     else res.append(newa) end;
         while!(check(comma_tok)) end;
      match(colon_tok);
      tp:TR_TYPE_SPEC := type_spec;
      hot:BOOL := check(bang_tok) or check(iter_bang_tok);
      if hot and ~is_iter then
         error("hot arguments not allowed in routine declarations") end;
      p:TR_ARG_DEC := res;
      loop until!(void(p)); p.tp := tp; p.is_hot := hot; p := p.next end;
      exit;
      return res
   end;

   ident_of (x: $TR_EXPR): IDENT is
   -- make sure x consists of an ident only
   --
      typecase x when TR_CALL_EXPR then
          if void(x.ob) and ~void(x.name) and void(x.args) then return x.name end
      else end;
      error("identifier only expected");
      return void
   end;

   break_stmt:TR_EXPR_STMT is
      res ::= #TR_EXPR_STMT; res.source := source_loc; res.e := #TR_BREAK_EXPR;
      return res
   end;

   make_if_stmt (test: $TR_EXPR, then_part, else_part: $TR_STMT): TR_IF_STMT is
      res ::= #TR_IF_STMT; res.source := source_loc; res.test := test;
      res.then_part := then_part;
      res.else_part := else_part;
      return res
   end;

   stmt: $TR_STMT is
   -- stmt =>
   -- dec_stmt | assign_stmt | expr_stmt |
   -- if_stmt | loop_stmt | return_stmt | yield_stmt | quit_stmt |
   -- case_stmt | typecase_stmt | assert_stmt | protect_stmt | raise_stmt
   -- while!_expr | until!_expr | break!_expr |
   -- cobegin_stmt | lock_stmt | unlock_stmt | try_stmt | with_near_stmt |
   -- fork_stmt | dist_stmt
   --
   -- (while!_expr's and until!_expr's are transformed into aquivalent
   -- if statements and break!'s)
   --
      res: $TR_STMT;
      enter("statement");
      was_at: SFILE_ID := source_loc;
      case next.val
      when if_tok then fetch; res := if_stmt
      when loop_tok then res := loop_stmt
      when return_tok then res := return_stmt
      when yield_tok then res := yield_stmt
      when quit_tok then fetch; res := #TR_QUIT_STMT; res.source := source_loc;
      when case_tok then res := case_stmt
      when typecase_tok then res := typecase_stmt
      when assert_tok then res := assert_stmt
      when protect_tok then res := protect_stmt
      when raise_tok then res := raise_stmt
      when cobegin_tok then res := cobegin_stmt
      when lock_tok then res := lock_stmt
      when unlock_tok then res := unlock_stmt
      when try_tok then res := try_stmt
      when with_tok then res := with_near_stmt
      when dist_tok then res := dist_stmt
      when fork_tok then
         enter("fork statement (without LHS)");
         fetch;
         r ::= #TR_FORK_STMT; r.source := source_loc;
         r.lhs := void; r.rhs := expr; res := r;
         exit
      when while_tok then
         enter("while! expression");
         fetch; match(lparen_tok);
         res := make_if_stmt(expr, void, break_stmt);
         match(rparen_tok);
         exit
      when until_tok then
         enter("until! expression");
         fetch; match(lparen_tok);
         res := make_if_stmt(expr, break_stmt, void);
         match(rparen_tok);
         exit
      when break_tok then
         fetch; res := break_stmt
      else
         -- must be one of:dec_stmt, assign_stmt, fork_stmt (with lhs) or expr_stmt:
         --
         -- dec_stmt => ident_list ':' type_spec
         -- assign_stmt => (expr | ident ':' [type_spec]) ' := ' expr
         -- expr_stmt => expr
         --
         -- none of these can be easily distinguished; all may start
         -- with identifiers.  However, all look like they start
         -- with expr's, so do that and then patch up.
         x: $TR_EXPR := expr;
         if check(colon_tok) then -- ident ':'
            tp: TR_TYPE_SPEC;
            if next /= assign_tok then tp := type_spec end;
            if check(assign_tok) then -- ident ':' [type_spec] ' := '
               enter("assignment with declaration");
               r ::= #TR_ASSIGN_STMT; r.source := source_loc;
               r.name := ident_of(x); r.tp := tp; r.rhs := expr; res := r;
               exit
            else -- ident ':' type_spec
               enter("single variable declaration");
               sdecl_res ::= #TR_DEC_STMT; sdecl_res.source := source_loc;
               sdecl_res.name := ident_of(x);
               sdecl_res.tp := tp;
               res := sdecl_res;
               exit
            end
         elsif check(assign_tok) then -- expr ':='
            enter("assignment");
            r ::= #TR_ASSIGN_STMT; r.source := source_loc;
            r.lhs_expr := x; r.rhs := expr; res := r;
            exit
         elsif check(fork_tok) then -- expr ':-'
            enter("fork statement (with LHS)");
            r ::= #TR_FORK_STMT; r.source := source_loc;
            r.lhs := x; r.rhs := expr; res := r;
            exit
         elsif next = comma_tok then -- ident ','
            enter("declaration");
            decl_res ::= #TR_DEC_STMT; decl_res.source := source_loc;
            decl_res.name := ident_of(x);
            res := decl_res;
            loop while!(check(comma_tok));
               newdec ::= #TR_DEC_STMT;
               newdec.source := source_loc;
               match(ident_tok);
               newdec.name := ident;
               if void(res) then res := newdec
               else res.append(newdec) end
            end;
            match(colon_tok);
            tp2: TR_TYPE_SPEC := type_spec;
            p: $TR_STMT := decl_res;
            loop until!(void(p));
               typecase p when TR_DEC_STMT then p.tp := tp2 end;
               p := p.next
            end;
            exit
         else -- expr
            r ::= #TR_EXPR_STMT; r.source := source_loc;
            r.e := x; res := r
         end
      end;
      res.source := was_at;
      exit;
      return res
   end;

   is_expr_start (t:TOKEN):BOOL is
      case t.val
      when self_tok, ident_tok, bang_tok, iter_bang_tok, SAME_tok, void_tok,
         minus_tok, not_tok, new_tok, sharp_tok, vbar_tok, exception_tok,
         initial_tok, result_tok, while_tok, until_tok, break_tok,
         true_tok, false_tok, lchar_tok, lstr_tok, lint_tok, lflt_tok,
         lparen_tok, lbracket_tok,
      -- pSather tokens
         here_tok, where_tok, near_tok, far_tok
      then return true
--    else return false                                                         -- NLP
      else; end; return false;                                                  -- NLP
--    end                                                                       -- NLP
   end;

   is_stmt_start (t:TOKEN):BOOL is
      case t.val
      when ident_tok, if_tok, loop_tok, yield_tok, quit_tok, return_tok,
         case_tok, typecase_tok, assert_tok, protect_tok, raise_tok,
         while_tok, until_tok, break_tok,
      -- pSather tokens
         fork_tok, lock_tok, unlock_tok, try_tok, cobegin_tok, with_tok,
     dist_tok
      then return true
--    else return is_expr_start(t)                                              -- NLP
      else; end; return is_expr_start(t);                                       -- NLP
--    end                                                                       -- NLP
   end;

   stmt_list: $TR_STMT is
   -- stmt_list => [stmt] {';' [stmt]}
   --
      res: $TR_STMT;
      enter("list of statements");
      loop
         if is_stmt_start(next) then
            if void(res) then res := stmt
            else res.append(stmt) end end;
         if check(semi_tok) then -- ok
         elsif is_stmt_start(next) then exp_error("semicolon")
         else break! end end;
      exit;
      return res
   end;

   if_stmt: TR_IF_STMT is
   -- if_stmt =>
   --        'if' expr 'then' stmt_list {'elsif' expr 'then' stmt_list}
   --        ['else' stmt_list] 'end'
   --
   -- if_tok already fetched
   --
      enter("if statement");
      res ::= #TR_IF_STMT; res.source := source_loc;
      res.test := expr; match(then_tok); res.then_part := stmt_list;
      if check(elsif_tok) then res.else_part := if_stmt
      else
         if check(else_tok) then res.else_part := stmt_list end;
         match(end_tok) end;
      exit;
      return res
   end;

   loop_stmt: TR_LOOP_STMT is
   -- loop_stmt => 'loop' stmt_list 'end'
   --
      enter("loop statement");
      match(loop_tok);
      res ::= #TR_LOOP_STMT; res.source := source_loc;
      res.body := stmt_list;
      match(end_tok);
      exit;
      return res
   end;

   case_stmt: TR_CASE_STMT is
   -- case_stmt =>
   --        'case' expr
   --        {'when' expr {',' expr} ' then' stmt_list}
   --        ['else' stmt_list] 'end'
   --
      enter("case statement");
      match(case_tok);
      res ::= #TR_CASE_STMT; res.source := source_loc;
      res.test := expr;
      loop while!(check(when_tok));
         first, this:TR_CASE_WHEN;
         first := void;
         loop
            this := #TR_CASE_WHEN; this.source := source_loc;
            if void(first) then first := this end;
            this.val := expr;
        if void(res.when_part) then res.when_part:=this
        else res.when_part.append(this) end;
            while!(check(comma_tok)) end;
         match(then_tok);
         st: $TR_STMT := stmt_list; this := first;
         loop until!(void(this)); this.then_part := st;
            this := this.next end end;
      if check(else_tok) then
         res.else_part := stmt_list; res.no_else := false
      else res.no_else := true end;
      match(end_tok);
      exit;
      return res
   end;

   typecase_stmt: TR_TYPECASE_STMT is
   -- typecase_stmt =>
   --        'typecase' ident
   --        {'when' type_spec 'then' stmt_list}
   --        ['else' stmt_list] 'end'
   --
      enter("typecase statement");
      match(typecase_tok);
      res ::= #TR_TYPECASE_STMT; res.source := source_loc;
      match(ident_tok);
      res.name := ident;
      loop while!(check(when_tok));
         this ::= #TR_TYPECASE_WHEN; this.source := source_loc;
         this.tp := type_spec;
         match(then_tok);
         this.then_part := stmt_list;
     if void(res.when_part) then res.when_part:=this
     else res.when_part.append(this) end end;
      if check(else_tok) then
         res.else_part := stmt_list; res.no_else := false
      else res.no_else := true end;
      match(end_tok);
      exit;
      return res
   end;

   return_stmt: TR_RETURN_STMT is
   -- return_stmt => 'return' [expr]
   --
      enter("return statement");
      res ::= #TR_RETURN_STMT; res.source := source_loc;
      match(return_tok);
      if is_expr_start(next) then res.val := expr end;
      exit;
      return res
   end;

   yield_stmt: TR_YIELD_STMT is
   -- return_stmt => 'yield' [expr]
   --
      enter("yield statement");
      res ::= #TR_YIELD_STMT; res.source := source_loc;
      match(yield_tok);
      if is_expr_start(next) then res.val := expr end;
      exit;
      return res
   end;

   assert_stmt: TR_ASSERT_STMT is
   -- assert_stmt => 'assert' expr 'end'
   --
      enter("assert statement");
      res ::= #TR_ASSERT_STMT; res.source := source_loc;
      match(assert_tok);
      res.test := expr;
      exit;
      return res
   end;

   raise_stmt: TR_RAISE_STMT is
   -- raise_stmr => 'raise' expr
   --
      enter("raise statement");
      res ::= #TR_RAISE_STMT; res.source := source_loc;
      match(raise_tok);
      res.val := expr;
      exit;
      return res
   end;

   protect_stmt: TR_PROTECT_STMT is
   -- protect_stmt =>
   --        'protect' stmt_list
   --        {'when' type_spec_list 'then' stmt_list}
   --        ['else' stmt_list] 'end'
   --
      enter("protect statement");
      match(protect_tok);
      res ::= #TR_PROTECT_STMT; res.source := source_loc;
      res.stmts := stmt_list;
      loop while!(check(when_tok));
         first, this:TR_PROTECT_WHEN;
         first := void;
         loop
            this := #TR_PROTECT_WHEN; this.source := source_loc;
            if void(first) then first := this end;
            this.tp := type_spec;
        if void(res.when_part) then res.when_part:=this
        else res.when_part.append(this) end;
            while!(check(comma_tok)) end;
         match(then_tok);
         st: $TR_STMT := stmt_list; this := first;
         loop until!(void(this)); this.then_part := st;
            this := this.next end end;
      if check(else_tok) then
         res.else_part := stmt_list; res.no_else := false
      else res.no_else := true end;
      match(end_tok);
      exit;
      return res
   end;

   cobegin_stmt: TR_COBEGIN_STMT is
   -- cobegin_stmt => 'cobegin' stmt_list 'end'
   -- (pSather construct)
   --
      enter("cobegin statement");
      match(cobegin_tok);
      res ::= #TR_COBEGIN_STMT; res.source := source_loc;
      res.stmts := stmt_list;
      match(end_tok);
      exit;
      return res
   end;

   lock_stmt: TR_LOCK_STMT is
   -- lock_stmt => 'lock' expr {',' expr} 'then' stmt_list 'end'
   -- (pSather construct)
   --
      enter("lock statement");
      res ::= #TR_LOCK_STMT; res.source := source_loc;
      match(lock_tok); res.e_list := expr_list(false);
      match(then_tok); res.then_part := stmt_list;
      match(end_tok);
      exit;
      return res
   end;

   unlock_stmt: TR_UNLOCK_STMT is
   -- unlock_stmt => 'unlock' expr
   -- (pSather construct)
   --
      enter("unlock statement");
      res ::= #TR_UNLOCK_STMT; res.source := source_loc;
      match(unlock_tok); res.e := expr;
      exit;
      return res
   end;

   try_stmt: TR_TRY_STMT is
   -- try_stmt =>
   --   'try'  expr {',' expr} 'then' stmt_list
   --   ['else' stmt_list] 'end'
   -- (pSather construct)
   --
      enter("try statement");
      res ::= #TR_TRY_STMT; res.source := source_loc;
      match(try_tok); res.e_list := expr_list(false);
      match(then_tok); res.then_part := stmt_list;
      if check(else_tok) then res.else_part := stmt_list end;
      match(end_tok);
      exit;
      return res
   end;

   ident_list: TR_IDENT_LIST is
   -- ident_list => ident {',' ident}
   --
      enter("identifier list");
      res, id: TR_IDENT_LIST;
      loop
         if next = ident_tok then
            id := #TR_IDENT_LIST; id.name := ident;
         else exp_error("identifier")
         end;
         fetch;
         if void(res) then res := id
         else res.append(id)
         end;
         while!(check(comma_tok))
      end;
      exit;
      return res
   end;

   with_near_stmt: TR_WITH_NEAR_STMT is
   -- with_near_stmt =>
   --   'with'  ident_list 'near' stmt_list
   --   ['else' stmt_list] 'end'
   -- (pSather construct)
   --
      enter("with_near statement");
      res ::= #TR_WITH_NEAR_STMT; res.source := source_loc;
      match(with_tok); res.idents := ident_list;
      match(near_tok); res.near_part := stmt_list;
      if check(else_tok) then res.else_part := stmt_list end;
      match(end_tok);
      exit;
      return res
   end;

   dist_stmt: TR_DIST_STMT is
   -- dist_stmt =>
   --    'dist' [expr 'as' ident] {',' expr 'as' ident} 'do' stmt_list 'end'
       enter("dist statement");
       res ::= #TR_DIST_STMT; res.source := source_loc;
       match(dist_tok);
       if ~check(do_tok) then
       res.exprs:=res.exprs.push(expr);
       match(as_tok);
       match(ident_tok);
       res.ids:=res.ids.push(ident);
       loop until!(check(do_tok));
           match(comma_tok);
           res.exprs:=res.exprs.push(expr);
           match(as_tok);
           match(ident_tok);
           res.ids:=res.ids.push(ident);
       end;
       end;
       res.stmts:=stmt_list;
       match(end_tok);
       return res;
   end;

   expr: $TR_EXPR is
   -- expr => expr7 {'@' expr 7}
   --
      enter("expression (prec = 8)");
      res ::= expr7;
      loop while!(next = at_tok);
         fetch;
         h ::= #TR_AT_EXPR; h.source := source_loc;
         h.e := res; h.at := expr7; res := h
      end;
      exit;
      return res
   end;

   expr7: $TR_EXPR is
   -- expr7 => expr6 {('and' | 'or') expr6}
   --
      enter("expression (prec = 7)");
      res ::= expr6;
      loop
         if check(and_tok) then
            a ::= #TR_AND_EXPR; a.source := source_loc;
            a.e1 := res; a.e2 := expr6; res := a
         elsif check(or_tok) then
            o ::= #TR_OR_EXPR; o.source := source_loc;
            o.e1 := res; o.e2 := expr6; res := o
         else break! end end;
      exit;
      return res
   end;

   expr6: $TR_EXPR is
   -- expr6 => expr5 {('=' | '/=' | '<' | '<=' | '>=' | '>') expr5}
   --
      enter("expression (prec = 6)");
      res ::= expr5;
      loop
         name: IDENT;
         if check(is_eq_tok) then name := prog.ident_builtin.is_eq_ident
         elsif check(is_neq_tok) then name := prog.ident_builtin.is_neq_ident
         elsif check(is_lt_tok) then name := prog.ident_builtin.is_lt_ident
         elsif check(is_leq_tok) then name := prog.ident_builtin.is_leq_ident
         elsif check(is_geq_tok) then name := prog.ident_builtin.is_geq_ident
         elsif check(is_gt_tok) then name := prog.ident_builtin.is_gt_ident
         else break!
         end;
         c ::= #TR_CALL_EXPR; c.source := source_loc; c.name := name;
         c.ob := res; c.args := expr5; res := c
      end;
      exit;
      return res
   end;

   expr5: $TR_EXPR is
   -- expr5 => expr4 {('+' | '-') expr4}
   --
      enter("expression (prec = 5)");
      res ::= expr4;
      loop
         name:IDENT;
         if check(plus_tok) then name := prog.ident_builtin.plus_ident
         elsif check(minus_tok) then name := prog.ident_builtin.minus_ident
         else break! end;
         c ::= #TR_CALL_EXPR; c.source := source_loc; c.name := name;
         c.ob := res; c.args := expr4; res := c end;
      exit;
      return res
   end;

   expr4: $TR_EXPR is
   -- expr4 => expr3 {('*' | '/' | '%') expr3}
   --
      enter("expression (prec = 4)");
      res ::= expr3;
      loop
         name:IDENT;
         if check(times_tok) then name := prog.ident_builtin.times_ident
         elsif check(quotient_tok) then name := prog.ident_builtin.div_ident
         elsif check(mod_tok) then name := prog.ident_builtin.mod_ident
         else break! end;
         c ::= #TR_CALL_EXPR; c.source := source_loc; c.name := name;
         c.ob := res; c.args := expr3; res := c end;
      exit;
      return res
   end;

   expr3: $TR_EXPR is
   -- expr3 => '-' expr3 | '~' expr3 | exp2.
   --
   -- in case of literals and '-' do the negation directly to prevent
   -- overflow in case of minint (e.g. -5 gets translated into 5.negate)
   --
      x: $TR_EXPR; c: TR_CALL_EXPR;
      res: $TR_EXPR;
      enter("expression (prec = 3)");
      if next = minus_tok then fetch; x := expr3;
         typecase x
         when TR_INT_LIT_EXPR then
            i ::= #TR_INT_LIT_EXPR; i.source := source_loc;
            i.val := -x.val; res := i
         when TR_FLT_LIT_EXPR then
            f ::= #TR_FLT_LIT_EXPR; f.source := source_loc;
            f.val := -x.val; f.tp := x.tp; res := f
         else
            c := #TR_CALL_EXPR; c.source := source_loc;
            c.name := prog.ident_builtin.negate_ident;
            c.ob := x; res := c
         end
      elsif next = not_tok then fetch; x := expr3;
         c := #TR_CALL_EXPR; c.source := source_loc;
         c.name := prog.ident_builtin.not_ident;
         c.ob := x; res := c
      else res := expr2
      end;
      exit;
      return res
   end;

   expr2: $TR_EXPR is
   -- expr2 => exp1 ['^' exp2]
   --
      enter("expression (prec = 2)");
      res ::= expr1(false);
      if check(pow_tok) then
         c ::= #TR_CALL_EXPR; c.source := source_loc;
         c.name := prog.ident_builtin.pow_ident;
         c.ob := res; c.args := expr2; res := c end;
      exit;
      return res
   end;

   expr_list (underscore_args:BOOL): $TR_EXPR is
   -- expr_list => bound_arg {',' bound_arg}
   -- bound_arg => expr | '_' [':' type_spec]
   --
      res: $TR_EXPR;
      if underscore_args then enter("list of bound arguments")
      else enter("list of expressions")        end;
      loop x: $TR_EXPR;
         if check(under_tok) then
            u ::= #TR_UNDERSCORE_ARG; u.source := source_loc;
            u.source := source_loc; x := u;
            if check(colon_tok) then u.tp := type_spec end;
            if ~underscore_args then
               error("no underscore arguments allowed") end
         else x := expr end;
         if void(res) then res := x
         else res.append(x) end;
         while!(check(comma_tok)) end;
      exit;
      return res
   end;

   call_expr (ob: $TR_EXPR, tp: TR_TYPE_SPEC, underscore_args: BOOL): TR_CALL_EXPR is
   -- call_expr => (ident | [ident] '!') ['(' expr_list ')']
   --
      res: TR_CALL_EXPR;
      enter("call expressions");
      res := #TR_CALL_EXPR; res.source := source_loc; res.ob := ob; res.tp := tp;
      res.name := rout_or_iter_name;
      if check(lparen_tok) then res.args := expr_list(underscore_args); match(rparen_tok) end;
      exit;
      return res
   end;

   type_of (x: $TR_EXPR): TR_TYPE_SPEC is
   -- make sure x could be a type_spec
   --
      typecase x when TR_CALL_EXPR then
         if void(x.ob) then
            if void(x.tp) then
               if is_class_name(x.name) then
                  tp ::= #TR_TYPE_SPEC; tp.source := x.source;
                  tp.kind := TR_TYPE_SPEC::ord;
                  tp.is_hot := false;
                  tp.name := x.name;
                  tp.params := void;
                  tp.ret := void;
                  return tp
               end
            else return x.tp
            end
         end
      else end;
      error("type specifier expected");
      return void
   end;

   expr1 (underscore_args:BOOL): $TR_EXPR is
   -- expr1 =>
   --        (expr0 '.' call_expr | type_spec '::' call_expr |
   --               call_expr | expr0 '[' expr_list ']')
   --        {"." call_expr | '[' expr_list ']'}
   --
   -- (expr0 accepts type_specs for local_exprs)
   --
      enter("expression (prec = 1)");
      res ::= expr0;
      c:TR_CALL_EXPR;
      if check(dot_tok) then -- expr0 '.'
         res := call_expr(res, void, underscore_args)
      elsif check(dcolon_tok) then -- type_spec '::'
         res := call_expr(void, type_of(res), underscore_args)
      elsif check(iter_bang_tok) then -- part of call_expr: ident '!'
         c := #TR_CALL_EXPR; c.source := source_loc;
         c.name := append_bang(ident_of(res));
         if check(lparen_tok) then c.args := expr_list(underscore_args);
            match(rparen_tok) end;
         res := c
      elsif check(lparen_tok) then -- part of call_expr: ident '('
         c := #TR_CALL_EXPR; c.source := source_loc;
         c.name := ident_of(res);
         c.args := expr_list(underscore_args); match(rparen_tok);
         res := c
      elsif check(lbracket_tok) then -- part of call_expr: expr0 '['
         c := #TR_CALL_EXPR; c.source := source_loc;
         c.ob := res; c.args := expr_list(false); c.is_array := true;
         match(rbracket_tok);
         res := c
      end;
      loop
         if check(dot_tok) then
            res := call_expr(res, void, underscore_args)
         elsif check(lbracket_tok) then
            c := #TR_CALL_EXPR; c.source := source_loc;
            c.ob := res; c.args := expr_list(false); c.is_array := true;
            match(rbracket_tok);
            res := c
         else break! end end;
      exit;
      return res
   end;

   expr0: $TR_EXPR is
   -- expr0 =>
   --      self_expr | local_expr | void_expr | new_expr |
   --      create_expr | array_expr | bound_create_expr |
   --      except_expr | initial_expr | result_expr | while!_expr |
   --      until!_expr | break!_expr | bool_lit_expr | char_lit_expr |
   --      str_lit_expr | int_lit_expr | flt_lit_expr | '(' expr ')' |
   --      '[' expr_list ']' |
   --      here_expr | where_expr | near_expr | far_expr
   --
   -- local_expr accepts also type_spec, filtered out here or in expr1
   --
      enter("expression (prec = 0)");
      res: $TR_EXPR;
      case next.val
      when self_tok then
         fetch; res := #TR_SELF_EXPR; res.source := source_loc
      when ident_tok then
         call_exp ::= #TR_CALL_EXPR; call_exp.source := source_loc;
         if is_class_name(ident) then call_exp.tp := type_spec;
        -- DPS changed from this
            --if (call_exp.tp.kind = TR_TYPE_SPEC::ord) and void(call_exp.tp.params) then -- maybe ordinary call
            --   call_exp.name := call_exp.tp.name;
            --   call_exp.tp := void
            --end
            if (call_exp.tp.kind = TR_TYPE_SPEC::ord) then
        if void(call_exp.tp.params) then -- ordinary call
            call_exp.name := call_exp.tp.name;
            call_exp.tp := void;
        elsif next/=dcolon_tok then
              error("This typespec neither preceeds '::' nor follows '#'");
        end
            end
         else call_exp.name := ident; fetch end;
         res := call_exp
      when bang_tok then
         r ::= #TR_CALL_EXPR; r.source := source_loc;
         r.name := prog.ident_for("!"); fetch;
         res := r
      when iter_bang_tok then
         r ::= #TR_CALL_EXPR; r.source := source_loc;
         r.name := prog.ident_for("!"); fetch;
         res := r
      when SAME_tok then
         r ::= #TR_CALL_EXPR; r.source := source_loc;
         r.tp := type_spec;
         res := r
      when void_tok then
         enter("void expressions");
         fetch;
         if next = lparen_tok then fetch;
            vtest ::= #TR_IS_VOID_EXPR; vtest.source := source_loc;
            vtest.arg := expr; res := vtest;
            match(rparen_tok)
         else res := #TR_VOID_EXPR; res.source := source_loc
         end;
         exit
      when new_tok then
         enter("new expression");
         fetch;
         new_ex ::= #TR_NEW_EXPR; new_ex.source := source_loc;
         res := new_ex;
         if check(lparen_tok) then
            new_ex.arg := expr;
            match(rparen_tok) end;
         exit
      when sharp_tok then fetch;
         if (next = ROUT_tok) or (next = ITER_tok) then
            res := bound_create_expr
         else res := create_expr end
      when vbar_tok then
         enter("array expression");
         fetch;
         arr_ex ::= #TR_ARRAY_EXPR; arr_ex.source := source_loc;
         res := arr_ex;
         arr_ex.elts := expr_list(false);
         match(vbar_tok);
         exit
      when exception_tok then
         fetch; res := #TR_EXCEPT_EXPR; res.source := source_loc;
      when initial_tok then
         enter("initial expression");
         fetch; match(lparen_tok);
         init_ex ::= #TR_INITIAL_EXPR; init_ex.source := source_loc;
         res := init_ex;
         init_ex.e := expr;
         match(rparen_tok);
         exit
      when result_tok then
         fetch; res := #TR_RESULT_EXPR; res.source := source_loc;
      when while_tok then
         enter("while! expression");
         fetch; match(lparen_tok); res := expr; match(rparen_tok);
         error("while! expression must stand alone");
         exit
      when until_tok then
         enter("until! expression");
         fetch; match(lparen_tok); res := expr; match(rparen_tok);
         error("until! expression must stand alone");
         exit
      when break_tok then
         fetch; res := #TR_BOOL_LIT_EXPR; res.source := source_loc;
         error("break! expression must stand alone")
      when true_tok then
         r ::= #TR_BOOL_LIT_EXPR; r.source := source_loc;
         r.val := next = true_tok; res := r; fetch
      when false_tok then
         r ::= #TR_BOOL_LIT_EXPR; r.source := source_loc;
         r.val := next = true_tok; res := r; fetch
      when lchar_tok then
         c ::= #TR_CHAR_LIT_EXPR; c.source := source_loc;
         c.val := scanner.char_value.int;
         res := c; fetch
      when lstr_tok then
         s ::= #TR_STR_LIT_EXPR; s.source := source_loc;
         s.s := ident.str; res := s; fetch
      when lint_tok then
         assert scanner.num_value.is_int;
         i ::=  #TR_INT_LIT_EXPR; i.source := source_loc;
         i.val := scanner.num_value.floor;
         i.is_inti := (scanner.value_type = TR_FLT_LIT_EXPR::flti);
         res := i;
         fetch
      when lflt_tok then
         f ::= #TR_FLT_LIT_EXPR; f.source := source_loc;
         f.val := scanner.num_value;
         f.tp := scanner.value_type;
         res := f; fetch
      when lparen_tok then
         fetch; res := expr; match(rparen_tok)
      when lbracket_tok then
         fetch; a ::= #TR_CALL_EXPR; a.source := source_loc;
         a.args := expr_list(false); a.is_array := true; res := a;
         match(rbracket_tok)
      when here_tok then
         fetch; res := #TR_HERE_EXPR; res.source := source_loc
      when where_tok then
         enter("where expression");
         r ::= #TR_WHERE_EXPR; r.source := source_loc; res := r;
         fetch; match(lparen_tok); r.e := expr; match(rparen_tok);
         exit
      when near_tok then
         enter("near expression");
         r ::= #TR_NEAR_EXPR; r.source := source_loc; res := r;
         fetch; match(lparen_tok); r.e := expr; match(rparen_tok);
         exit
      when far_tok then
         enter("far expression");
         r ::= #TR_FAR_EXPR; r.source := source_loc; res := r;
         fetch; match(lparen_tok); r.e := expr; match(rparen_tok);
         exit
      else exp_error("expression"); res := #TR_VOID_EXPR; res.source := source_loc end;
      exit;
      return res
   end;

   check_underscores (call:TR_CALL_EXPR, is_iter:BOOL) is
      if call.name.is_iter /= is_iter then
         if is_iter then error("bound routine must be an iter")
         else error("bound routine must not be an iter") end end;
      if call.is_array then
         error("only call expressions allowed") end;
      ob: $TR_EXPR := call.ob;
      loop until!(void(ob));
         this: $TR_EXPR := ob;
         typecase this when TR_CALL_EXPR then
            ob := this.ob;
            arg: $TR_EXPR := this.args;
            loop until!(void(arg));
               typecase arg when TR_UNDERSCORE_ARG then
                  error("illegal underscore arguments");
                  return
               else end;
               arg := arg.next
            end
         else
            typecase ob when TR_UNDERSCORE_ARG then
               if ~SYS::ob_eq(ob, call.ob) then
                  error("illegal underscore arguments")
               end
            else end;
            return
         end
      end
   end;

   bound_create_expr: TR_BOUND_CREATE_EXPR is
   -- bound_create_expr =>
   --        '#' ('ROUT' | 'ITER') '('
   --        ('_' [':' type_spec] '.' call_expr | expr1)
   --        [':' type_spec] ')'
   --
   -- '#' already seen and stripped away
   -- next is one of ROUT_tok,  ITER_tok (guaranteed)
   --
      enter("bound create expression");
      res ::= #TR_BOUND_CREATE_EXPR; res.source := source_loc;
      res.is_iter := next = ITER_tok; fetch;
      match(lparen_tok);
      if check(under_tok) then
         u ::= #TR_UNDERSCORE_ARG; u.source := source_loc;
         if check(colon_tok) then u.tp := type_spec end;
         match(dot_tok);
         res.call := call_expr(u, void, true)
      else -- hack: should be improved
         x ::= expr1(true);
         typecase x when TR_CALL_EXPR then res.call := x end
      end;
      check_underscores(res.call, res.is_iter);
      if check(colon_tok) then res.ret := type_spec end;
      match(rparen_tok);
      exit;
      return res
   end;

   create_expr: TR_CREATE_EXPR is
   -- create_expr => '#' [type_spec] ['(' expr_list ')']
   --
   -- '#' already seen and stripped away
   --
      enter("create expression");
      res ::= #TR_CREATE_EXPR; res.source := source_loc;
      if (next = ident_tok) or (next = SAME_tok) then res.tp := type_spec
      elsif next = type_name_tok then res.tp := type_spec;
         error("no abstract types allowed")
      end;
      if check(lparen_tok) then
         res.elts := expr_list(false); match(rparen_tok) end;
      exit;
      return res
   end

end -- PARSER

-------------------------------------------------------------------