Генератор
Проектов

Проект algol60

Проект algol60 представляет синтксический анализатор алоголоподобного языка.

Цель проекта - не разработка транслятора, а демонстрация методов разработки. Изначально Алгол-60 был выбран в силу того, что в нем нет сложных типов кроме логических значений, чисел и массивов. В процессе работы обнаружилось, что синтаксис чрезвычайно архаичен и непривычен. Синтаксис реализован практически по памяти с минимальным подглядывание в официальное модифицированное сообщение.

В проекте реализована утилита algol60, которой при запуске нужно задать параметром файл с текстом программы на Алголе-60. На выходе формируется файл с исходным именем и суффиксом ".txt". В выходном файле по построенной по результатам разбора модели проекта формируется текст этой же программы. Это не копирование, это именно формирование текста по результату разбора.

В пакете alg описнаы типы и документ-очередь, в которой строится модель программы. Рассмотрим основные компоненты модели.

Запись prc представляет процедуру. Сингулярный набор alg_prc хранит список процедур программы в порядке их описания.

Запись var представляет переменную (параметр процедуры или описанную в блоке).

Запись typ представляет тип переменной. Компонента typtype записи определяет тип переменной.

Запись dim представляет размерность массива. Набор typ_dim - список размерностей массива.

Запись opr представляет оператор программы. Компонента oprtype - тип оператора. Набор opr_opr задает вложенность операторов, составные операторы типа блока, условного оператра, цикла составляются из других операторов.

Запись exp представляет выражение. Компонента exptype - тип выражения. Набор exp_exp задает иерархическую структуру выражения.

Набор opr_exp - перечень выражений в составе оператора.

Запись elm предстявляет элемент списка цикла - своеобразная и давно позабытая синтаксическая констркукция.

Запись stk предстявляет элемент синтаксического стека. Сингулярный набор alg_stk - собственно стек - перечень элементов. Набор stk_var - перечень переменных в элементе стека. Синтаксический стек используется в процессе синтаксического анализа для хранения перечня доступных в текущем контексте переменных.

При начале обработки процедуры заводится элемент стека и к нему присоединяются все параметры процедуры по мере их чтения. По окончании обработки процедуры данный элемент стека удаляется.

При начале обработки блока оператров begin...end также создается элемент стека, и к нему присоеднияются все описанные в этом блоке переменные. По окончании обработки блока данный элемент стека удаляется.

В процессе синтаксического анализа выражений для каждого встретившегося идентификатора разыскивается первое вхождение переменной с таким именем в синтаксическом стеке. Если поиск успешен - идентификатор обозначает соответствующую переменную в зоне видимости. Если переменная не найдена, это что-то другое, например процедура, которая ищется по набору alg_prc.

В пакете syntax реализован алгоритм синтаксического разбора методом рекурсивного спуска. Для разбора используется системный пакет лексического разбора flex. В процессе разбора на ходу строится модель программы, т.е. создаются записи для процедур, операторов, выражений, переменных, типов и т.п. Эти записи связываются друг с другом посредством включения в наборы. По мере построения модели ее содержимое используется для проверки корректности анализируемой программы, выходящей за пределы возможностей контекстно-свободной грамматики. Так при обнаружении идентификатора по частично построенной модели ищется объект, который он представляет (переменная, процедура), проверяется дублирование однотипных объектов и соответствие типов выражений.

В пакете listing производится построение выходного файла, синтаксически эквивалентного входной программе.

Файл algol60.gen:

project algol60
  /version="01.001"
  /firm="УСТ"
  /http="http://www.ustech.ru"
  /email="managers@ustech.ru"

dirbin test

dirdbg test1

package alg

package syntax

package listing

utility algol60

Файл alg.package:

package alg

type t_name : char7[50];
type t_buf : char7[300];
type t_elmtype : enum
( EXP,
  STEP,
  WHILE
);
type t_exptype : enum
( IVAL,
  RVAL,
  VAR,
  INDEX,
  FUNC,
  PAREN,
  POW,
  MUL,
  DIV,
  MOD,
  ADD,
  SUB,
  EQ,
  NE,
  GE,
  GT,
  LE,
  LT,
  NOT,
  AND,
  OR,
  AUTO_I_TO_R
);
type t_oprtype : enum
( BLOCK,
  IF,
  FOR,
  CALL,
  ASSIGN,
  PRINT
);
type t_typtype : enum
( VOID,
  REAL,
  INTEGER,
  BOOLEAN,
  REAL_ARR,
  INTEGER_ARR,
  BOOLEAN_ARR
);
type alg : dqueue
(
  record dim;
  record elm
  ( t_elmtype elmtype
  );
  record exp
  ( t_exptype exptype,
    t_typtype typtype,
    int line,
    int ival,
    double dval
  );
  record opr
  ( t_oprtype oprtype,
    int line
  );
  record prc
  ( t_name name,
    t_typtype typtype
  );
  record stk;
    /oper=(del)
  record typ
  ( t_typtype typtype
  );
  record var
  ( t_name name,
    bool value
  );
  record vlu
  ( t_name name
  );
  set alg_prc member prc;
  set alg_stk member stk;/oper=(mem,next)
  set dim_exp owner dim member exp;/oper=(mem)
  set elm_exp owner elm member exp;/oper=(mem,next)
  set exp_exp owner exp member exp;/oper=(mem,next)
  set fun_exp owner prc member exp;/oper=(own)
  set opr_elm owner opr member elm;/oper=(mem,next)
  set opr_exp owner opr member exp;/oper=(mem,next)
  set opr_opr owner opr member opr;/oper=(mem,next)
  set opr_prc owner opr member prc;/oper=(own)
  set opr_typ owner opr member typ;/oper=(mem,next)
  set opr_var owner opr member var;
  set prc_opr owner prc member opr;/oper=(own)
  set prc_typ owner prc member typ;/oper=(mem,next)
  set prc_var owner prc member var;
  set prc_vlu owner prc member vlu;
  set ret_fun owner var member prc;/used
  set stk_var owner stk member var;/oper=(dis,mem)
  set typ_dim owner typ member dim;/oper=(mem,next,cnt)
  set typ_var owner typ member var;/oper=(mem,next,own)
  set var_exp owner var member exp;/oper=(own)
  set var_opr owner var member opr;/oper=(own)
  find find_alg_prc set alg_prc(name);/oper=(first)
  find find_opr_var set opr_var(name);/oper=(first)
  find find_prc_var set prc_var(name);/oper=(first)
  find find_prc_vlu set prc_vlu(name);/oper=(first)
  find find_stk_var set stk_var(name);/oper=(first)
);

Файл syntax.package:

package syntax

procdecl syn(alg.alg xalg,string8 n_file);

implementation

procspec syn_exp(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp);
procspec syn_opr(flex.t_lex xlex,alg.alg xalg,out alg.opr xopr);

proc syn_push(alg.alg xalg)
{ var
    alg.stk xstk;

  alg.stk_cre(xalg,xstk);
  alg.alg_stk_ins(xalg,xstk,0);
}

proc syn_push_var(alg.alg xalg,alg.var xvar)
{ var
    alg.stk xstk;

  alg.alg_stk_mem(xalg,0,xstk);
  if ( isnull(xstk) )
    error "syn_push_var: internal error - empty stack";

  alg.stk_var_ins(xstk,xvar,-1);
}

proc syn_find_var(alg.alg xalg,alg.t_name varname,out alg.var xvar)
{ var
    alg.stk xstk;

  null(xvar);
  alg.alg_stk_mem(xalg,0,xstk);

  while ( isnotnull(xstk) )
  { alg.find_stk_var_first(xstk,varname,xvar);
    if ( isnotnull(xvar) )
      break;

    alg.alg_stk_next(xstk);
  }
}

proc syn_pop(alg.alg xalg)
{ var
    alg.stk xstk;

  alg.alg_stk_mem(xalg,0,xstk);

  for ( ; ; )
  { var
      alg.var xvar;

    alg.stk_var_mem(xstk,0,xvar);
    if ( isnull(xvar) )
      break;

    alg.stk_var_dis(xvar);
  }

  alg.stk_del(xstk);
}

proc syn_simple_type(flex.t_lex xlex,out alg.t_typtype typtype)
{ typtype := alg.t_typtype.VOID;
  if ( flex.sample(xlex,"real") )
    typtype := alg.t_typtype.REAL;
  else if ( flex.sample(xlex,"integer") )
    typtype := alg.t_typtype.INTEGER;
  else if ( flex.sample(xlex,"boolean") )
    typtype := alg.t_typtype.BOOLEAN;
  else
    flex.message(xlex,"no type declaration found");
}

func syn_type:bool(flex.t_lex xlex,out alg.t_typtype typtype)
{ typtype := alg.t_typtype.VOID;
  if ( flex.sample(xlex,"real") )
  { if ( flex.sample(xlex,"array") )
      typtype := alg.t_typtype.REAL_ARR;
    else
      typtype := alg.t_typtype.REAL;
  }
  else if ( flex.sample(xlex,"integer") )
  { if ( flex.sample(xlex,"array") )
      typtype := alg.t_typtype.INTEGER_ARR;
    else
      typtype := alg.t_typtype.INTEGER;
  }
  else if ( flex.sample(xlex,"boolean") )
  { if ( flex.sample(xlex,"array") )
      typtype := alg.t_typtype.BOOLEAN_ARR;
    else
      typtype := alg.t_typtype.BOOLEAN;
  }
  else
    return false;

  return true;
}

proc syn_dim(flex.t_lex xlex,alg.typ xtyp)
{ switch ( xtyp.typtype )
  { case alg.t_typtype.REAL_ARR,INTEGER_ARR,BOOLEAN_ARR:
    { var
        alg.exp xexp;

      flex.sample_err(xlex,"[");

      for ( ; ; )
      { var
          alg.dim xdim;

        alg.dim_cre(xtyp.xdoc,xdim);
        alg.typ_dim_ins(xtyp,xdim,-1);
        call syn_exp(xlex,xtyp.xdoc,xexp); //! check type int
        alg.dim_exp_ins(xdim,xexp,-1);
        flex.sample_err(xlex,":");
        call syn_exp(xlex,xtyp.xdoc,xexp); //! check type int
        alg.dim_exp_ins(xdim,xexp,-1);
        if ( not flex.sample(xlex,",") )
          break;
      }

      flex.sample_err(xlex,"]");
    }
  }
}

proc syn_spec(flex.t_lex xlex,alg.prc xprc)
{ if ( flex.sample(xlex,"value") )
  { for ( ; ; )
    { var
        alg.var xvar,
        alg.vlu xvlu,
        alg.t_name varname;

      flex.ident_err(xlex,varname);
      alg.find_prc_var_first(xprc,varname,xvar);
      if ( isnull(xvar) )
        flex.message(xlex,"parameter not found");

      alg.find_prc_vlu_first(xprc,varname,xvlu);
      if ( isnotnull(xvlu) )
        flex.message(xlex,"duplicate value spec");

      alg.vlu_cre(xprc.xdoc,xvlu);
      xvlu.name := varname;
      alg.prc_vlu_ins(xprc,xvlu,-1);
      xvar.value := true;
      if ( not flex.sample(xlex,",") )
        break;
    }

    flex.sample_err(xlex,";");
  }

  for ( ; ; )
  { var
      alg.typ xtyp,
      alg.t_typtype typtype;

    if ( not syn_type(xlex,typtype) )
      break;

    alg.typ_cre(xprc.xdoc,xtyp);
    xtyp.typtype := typtype;
    alg.prc_typ_ins(xprc,xtyp,-1);

    for ( ; ; )
    { var
        alg.var xvar,
        alg.typ xtyp1,
        alg.t_name varname;

      flex.ident_err(xlex,varname);
      alg.find_prc_var_first(xprc,varname,xvar);
      if ( isnull(xvar) )
        flex.message(xlex,"parameter not found");

      alg.typ_var_own(xvar,xtyp1);
      if ( isnotnull(xtyp1) )
        flex.message(xlex,"parameter already specified");

      alg.typ_var_ins(xtyp,xvar,-1);
      if ( not flex.sample(xlex,",") )
        break;
    }

    call syn_dim(xlex,xtyp);
    flex.sample_err(xlex,";");
  }

  { var
      alg.var xvar;

    alg.prc_var_mem(xprc,0,xvar);

    while ( isnotnull(xvar) )
    { var
        alg.typ xtyp;

      alg.typ_var_own(xvar,xtyp);
      if ( isnull(xtyp) )
      { var
          alg.t_buf txt;

        flex.message(xlex,string(txt,"parameter ",xvar.name," not specified"));
      }

      alg.prc_var_next(xvar);
    }
  }
}

proc syn_auto_convert(flex.t_lex xlex,alg.t_typtype typtype,inout alg.exp xexp)
{ switch ( typtype )
  { case REAL:
    { switch ( xexp.typtype )
      { case REAL:
          ;
        case INTEGER:
        { var
            alg.exp xexp1 := xexp;

          alg.exp_cre(xexp1.xdoc,xexp);
          xexp.exptype := alg.t_exptype.AUTO_I_TO_R;
          xexp.typtype := typtype;
          xexp.line := flex.line_numb(xlex);
          alg.exp_exp_ins(xexp,xexp1,-1);
        }
        default:
        { var
            alg.t_buf txt;

          flex.message(xlex,string(txt,"formal ",typtype," /actual ",xexp.typtype," parameters type mismatch"));
        }
      }
    }
    default:
    { if ( typtype <> xexp.typtype )
      { var
          alg.t_buf txt;

        flex.message(xlex,string(txt,"formal ",typtype," /actual ",xexp.typtype," parameters type mismatch"));
      }
    }
  }
}

proc syn_actual_par(flex.t_lex xlex,alg.prc xprc1,alg.opr xopr,alg.exp xexp)
{ var
    alg.var xvar;

  flex.sample_err(xlex,"(");
  alg.prc_var_mem(xprc1,0,xvar);

  while ( isnotnull(xvar) )
  { var
      alg.typ xtyp,
      alg.exp xexp1;

    alg.typ_var_own(xvar,xtyp);
    call syn_exp(xlex,xprc1.xdoc,xexp1);
    if ( xvar.value )
      call syn_auto_convert(xlex,xtyp.typtype,xexp1);
    else
    { switch ( xexp1.exptype )
      { case VAR,INDEX:
          ;
        default:
          flex.message(xlex,"formal nonvalue parameter must be var or var with indices");
      }

      if ( xtyp.typtype <> xexp1.typtype )
        flex.message(xlex,"formal/actual parameter type mismatch");
    }

    switch ( xtyp.typtype )
    { case REAL_ARR,INTEGER_ARR:
      { var
          alg.var xvar1,
          alg.typ xtyp1,
          int cnt,
          int cnt1;

        alg.var_exp_own(xexp1,xvar1);
        alg.typ_var_own(xvar1,xtyp1);
        alg.typ_dim_cnt(xtyp,cnt);
        alg.typ_dim_cnt(xtyp1,cnt1);
        if ( cnt <> cnt1 )
          flex.message(xlex,"formal/actual parameter dimensions mismatch");
      }
    }

    if ( isnotnull(xopr) )
      alg.opr_exp_ins(xopr,xexp1,-1);

    if ( isnotnull(xexp) )
      alg.exp_exp_ins(xexp,xexp1,-1);

    alg.prc_var_next(xvar);
    if ( isnotnull(xvar) )
      flex.sample_err(xlex,",");
  }

  flex.sample_err(xlex,")");
}

proc syn_exp_indices(flex.t_lex xlex,alg.alg xalg,alg.typ xtyp,alg.var xvar,out alg.exp xexp)
{ var
    alg.dim xdim,
    alg.t_typtype typtype;

  switch ( xtyp.typtype )
  { case REAL_ARR:
      typtype := alg.t_typtype.REAL;
    case INTEGER_ARR:
      typtype := alg.t_typtype.INTEGER;
    case BOOLEAN_ARR:
      typtype := alg.t_typtype.BOOLEAN;
    default:
      flex.message(xlex,"var isnot an array");
  }

  alg.exp_cre(xalg,xexp);
  xexp.exptype := alg.t_exptype.INDEX;
  xexp.typtype := typtype;
  xexp.line := flex.line_numb(xlex);
  alg.var_exp_ins(xvar,xexp,-1);
  alg.typ_dim_mem(xtyp,0,xdim);

  while ( isnotnull(xdim) )
  { var
      alg.exp xexp1;

    call syn_exp(xlex,xalg,xexp1);
    if ( xexp1.typtype <> alg.t_typtype.INTEGER )
      flex.message(xlex,"index is not of integer type");

    alg.exp_exp_ins(xexp,xexp1,-1);
    alg.typ_dim_next(xdim);
    if ( isnotnull(xdim) )
      flex.sample_err(xlex,",");
  }

  flex.sample_err(xlex,"]");
}

proc syn_exp_fact(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ var
    alg.t_name anyname,
    int line,
    int ival,
    double dval;

  null(xexp);
  line := flex.line_numb(xlex);
  if ( flex.sample(xlex,"(") )
  { var
      alg.exp xexp1;

    alg.exp_cre(xalg,xexp);
    xexp.exptype := alg.t_exptype.PAREN;
    call syn_exp(xlex,xalg,xexp1);
    xexp.typtype := xexp1.typtype;
    alg.exp_exp_ins(xexp,xexp1,-1);
    flex.sample_err(xlex,")");
  }
  else if ( flex.numb_i(xlex,NOSIGN,ival) )
  { alg.exp_cre(xalg,xexp);
    xexp.exptype := alg.t_exptype.IVAL;
    xexp.typtype := alg.t_typtype.INTEGER;
    xexp.ival := ival;
  }
  else if ( flex.double_prec(xlex,NOSIGN,FRAC,NOEXPON,dval,ival) )
  { alg.exp_cre(xalg,xexp);
    xexp.exptype := alg.t_exptype.RVAL;
    xexp.typtype := alg.t_typtype.REAL;
    xexp.dval := dval;
    xexp.ival := ival;
  }
  else if ( flex.ident(xlex,anyname) )
  { var
      alg.var xvar;

    call syn_find_var(xalg,anyname,xvar);
    if ( isnotnull(xvar) )
    { var
        alg.typ xtyp;

      alg.typ_var_own(xvar,xtyp);
      if ( flex.sample(xlex,"[") )
        call syn_exp_indices(xlex,xalg,xtyp,xvar,xexp);
      else
      { alg.exp_cre(xalg,xexp);
        xexp.exptype := alg.t_exptype.VAR;
        xexp.typtype := xtyp.typtype;
        alg.var_exp_ins(xvar,xexp,-1);
      }
    }
    else
    { var
        alg.opr xoprnull,
        alg.prc xprc1;

      alg.find_alg_prc_first(xalg,anyname,xprc1);
      if ( isnotnull(xprc1) )
      { if ( xprc1.typtype = alg.t_typtype.VOID )
          flex.message(xlex,"procedure is not a function");

        alg.exp_cre(xalg,xexp);
        xexp.exptype := alg.t_exptype.FUNC;
        xexp.typtype := xprc1.typtype;
        alg.fun_exp_ins(xprc1,xexp,-1);
        call syn_actual_par(xlex,xprc1,xoprnull,xexp);
      }
      else
        flex.message(xlex,"unrecognized identifier");
    }
  }
  else
    flex.message(xlex,"syntax error");

  xexp.line := line;
}

proc check_numeric_type(flex.t_lex xlex,alg.t_typtype typtype)
{ switch ( typtype )
  { case REAL,INTEGER:
      ;
    default:
      flex.message(xlex,"nonnumeric type");
  }
}

proc check_numeric_types(flex.t_lex xlex,alg.t_typtype typtype1,alg.t_typtype typtype2,out alg.t_typtype typtype)
{ typtype := alg.t_typtype.VOID;

  switch ( typtype1 )
  { case REAL:
    { switch ( typtype2 )
      { case REAL,INTEGER:
          typtype := alg.t_typtype.REAL;
        default:
          flex.message(xlex,"nonnumeric type of second exp");
      }
    }
    case INTEGER:
    { switch ( typtype2 )
      { case REAL:
          typtype := alg.t_typtype.REAL;
        case INTEGER:
          typtype := alg.t_typtype.INTEGER;
        default:
          flex.message(xlex,"nonnumeric type of second exp");
      }
    }
    default:
      flex.message(xlex,"nonnumeric type of first exp");
  }
}

proc check_boolean_type(flex.t_lex xlex,alg.t_typtype typtype)
{ if ( typtype <> alg.t_typtype.BOOLEAN )
    flex.message(xlex,"nonboolean type");
}

proc syn_exp_pow(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ var
    int line := flex.line_numb(xlex);

  call syn_exp_fact(xlex,xalg,xexp);

  while ( flex.sample(xlex,"^") )
  { var
      alg.exp xexp1 := xexp,
      alg.exp xexp2;

    call syn_exp_fact(xlex,xalg,xexp2);
    alg.exp_cre(xalg,xexp);
    xexp.exptype := alg.t_exptype.POW;
    xexp.line := line;
    call check_numeric_types(xlex,xexp1.typtype,xexp2.typtype,xexp.typtype);
    alg.exp_exp_ins(xexp,xexp1,-1);
    alg.exp_exp_ins(xexp,xexp2,-1);
  }
}

proc syn_exp_mul(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ var
    int line := flex.line_numb(xlex);

  call syn_exp_pow(xlex,xalg,xexp);

  for ( ; ; )
  { var
      alg.exp xexp1 := xexp,
      alg.exp xexp2,
      alg.t_exptype exptype;

    if ( flex.sample(xlex,"*") )
      exptype := alg.t_exptype.MUL;
    else if ( flex.sample(xlex,"/") )
      exptype := alg.t_exptype.DIV;
    else if ( flex.sample(xlex,"%") )
      exptype := alg.t_exptype.MOD;
    else
      break;

    call syn_exp_pow(xlex,xalg,xexp2);
    alg.exp_cre(xalg,xexp);
    xexp.exptype := exptype;
    xexp.line := line;
    call check_numeric_types(xlex,xexp1.typtype,xexp2.typtype,xexp.typtype);
    if ( exptype = alg.t_exptype.MOD and xexp.typtype <> alg.t_typtype.INTEGER )
      flex.message(xlex,"noninteher type");

    alg.exp_exp_ins(xexp,xexp1,-1);
    alg.exp_exp_ins(xexp,xexp2,-1);
  }
}

proc syn_exp_add(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ var
    int line := flex.line_numb(xlex);

  call syn_exp_mul(xlex,xalg,xexp);

  for ( ; ; )
  { var
      alg.exp xexp1 := xexp,
      alg.exp xexp2,
      alg.t_exptype exptype;

    if ( flex.sample(xlex,"+") )
      exptype := alg.t_exptype.ADD;
    else if ( flex.sample(xlex,"-") )
      exptype := alg.t_exptype.SUB;
    else
      break;

    call syn_exp_mul(xlex,xalg,xexp2);
    alg.exp_cre(xalg,xexp);
    xexp.line := line;
    xexp.exptype := exptype;
    call check_numeric_types(xlex,xexp1.typtype,xexp2.typtype,xexp.typtype);
    alg.exp_exp_ins(xexp,xexp1,-1);
    alg.exp_exp_ins(xexp,xexp2,-1);
  }
}

proc syn_exp_cmp(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ var
    alg.t_exptype exptype,
    int line := flex.line_numb(xlex);

  call syn_exp_add(xlex,xalg,xexp);
  if ( flex.sample(xlex,"=") )
    exptype := alg.t_exptype.EQ;
  else if ( flex.sample(xlex,"<>") )
    exptype := alg.t_exptype.NE;
  else if ( flex.sample(xlex,">=") )
    exptype := alg.t_exptype.GE;
  else if ( flex.sample(xlex,">") )
    exptype := alg.t_exptype.GT;
  else if ( flex.sample(xlex,"<=") )
    exptype := alg.t_exptype.LE;
  else if ( flex.sample(xlex,"<") )
    exptype := alg.t_exptype.LT;
  else
    return;

  var
    alg.exp xexp1 := xexp,
    alg.exp xexp2,
    alg.t_typtype typtype0;

  call syn_exp_add(xlex,xalg,xexp2);
  alg.exp_cre(xalg,xexp);
  xexp.exptype := exptype;
  xexp.line := line;
  call check_numeric_types(xlex,xexp1.typtype,xexp2.typtype,typtype0);
  xexp.typtype := alg.t_typtype.BOOLEAN;
  alg.exp_exp_ins(xexp,xexp1,-1);
  alg.exp_exp_ins(xexp,xexp2,-1);
}

proc syn_exp_not(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ var
    int line := flex.line_numb(xlex);

  if ( flex.sample(xlex,"~") )
  { var
      alg.exp xexp1;

    call syn_exp_cmp(xlex,xalg,xexp1);
    call check_boolean_type(xlex,xexp1.typtype);
    alg.exp_cre(xalg,xexp);
    xexp.exptype := alg.t_exptype.NOT;
    xexp.typtype := alg.t_typtype.BOOLEAN;
    xexp.line := line;
    alg.exp_exp_ins(xexp,xexp1,-1);
  }
  else
    call syn_exp_cmp(xlex,xalg,xexp);
}

proc syn_exp_and(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ var
    int line := flex.line_numb(xlex);

  call syn_exp_not(xlex,xalg,xexp);

  while ( flex.sample(xlex,"&") )
  { var
      alg.exp xexp1 := xexp,
      alg.exp xexp2;

    call syn_exp_not(xlex,xalg,xexp2);
    call check_boolean_type(xlex,xexp1.typtype);
    call check_boolean_type(xlex,xexp2.typtype);
    alg.exp_cre(xalg,xexp);
    xexp.exptype := alg.t_exptype.AND;
    xexp.typtype := alg.t_typtype.BOOLEAN;
    xexp.line := line;
    alg.exp_exp_ins(xexp,xexp1,-1);
    alg.exp_exp_ins(xexp,xexp2,-1);
  }
}

proc syn_exp_or(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ var
    int line := flex.line_numb(xlex);

  call syn_exp_and(xlex,xalg,xexp);

  while ( flex.sample(xlex,"|") )
  { var
      alg.exp xexp1 := xexp,
      alg.exp xexp2;

    call syn_exp_and(xlex,xalg,xexp2);
    call check_boolean_type(xlex,xexp1.typtype);
    call check_boolean_type(xlex,xexp2.typtype);
    alg.exp_cre(xalg,xexp);
    xexp.exptype := alg.t_exptype.OR;
    xexp.typtype := alg.t_typtype.BOOLEAN;
    xexp.line := line;
    alg.exp_exp_ins(xexp,xexp1,-1);
    alg.exp_exp_ins(xexp,xexp2,-1);
  }
}

proc syn_exp(flex.t_lex xlex,alg.alg xalg,out alg.exp xexp)
{ call syn_exp_or(xlex,xalg,xexp);
}

proc syn_opr_block(flex.t_lex xlex,alg.alg xalg,out alg.opr xopr)
{ alg.opr_cre(xalg,xopr);
  xopr.oprtype := alg.t_oprtype.BLOCK;
  call syn_push(xalg);
  if ( not flex.sample(xlex,"end") )
  { var
      bool decl := true;

    for ( ; ; )
    { var
        alg.opr xopr1,
        alg.t_typtype typtype;

      if ( decl and syn_type(xlex,typtype) )
      { var
          alg.typ xtyp;

        alg.typ_cre(xalg,xtyp);
        xtyp.typtype := typtype;
        alg.opr_typ_ins(xopr,xtyp,-1);

        for ( ; ; )
        { var
            alg.var xvar,
            alg.t_name varname;

          flex.ident_err(xlex,varname);
          alg.find_opr_var_first(xopr,varname,xvar);
          if ( isnotnull(xvar) )
            flex.message(xlex,"duplicate var");

          alg.var_cre(xalg,xvar);
          xvar.name := varname;
          alg.typ_var_ins(xtyp,xvar,-1);
          alg.opr_var_ins(xopr,xvar,-1);
          call syn_push_var(xalg,xvar);
          if ( not flex.sample(xlex,",") )
            break;
        }

        call syn_dim(xlex,xtyp);
      }
      else
      { decl := false;
        call syn_opr(xlex,xalg,xopr1);
        alg.opr_opr_ins(xopr,xopr1,-1);
      }

      if ( not flex.sample(xlex,";") )
        break;
    }

    flex.sample_err(xlex,"end");
  }

  call syn_pop(xalg);
}

proc syn_opr_if(flex.t_lex xlex,alg.alg xalg,out alg.opr xopr)
{ alg.opr_cre(xalg,xopr);
  xopr.oprtype := alg.t_oprtype.IF;

  for ( ; ; )
  { var
      alg.exp xexp,
      alg.opr xopr1;

    call syn_exp(xlex,xalg,xexp);
    call check_boolean_type(xlex,xexp.typtype);
    alg.opr_exp_ins(xopr,xexp,-1);
    flex.sample_err(xlex,"then");
    call syn_opr(xlex,xalg,xopr1);
    alg.opr_opr_ins(xopr,xopr1,-1);
    if ( not flex.sample(xlex,"else") )
      break;

    if ( not flex.sample(xlex,"if") )
    { call syn_opr(xlex,xalg,xopr1);
      alg.opr_opr_ins(xopr,xopr1,-1);
      break;
    }
  }
}

proc syn_opr_for(flex.t_lex xlex,alg.alg xalg,out alg.opr xopr)
{ var
    alg.var xvar,
    alg.typ xtyp,
    alg.opr xopr1,
    alg.t_name varname;

  alg.opr_cre(xalg,xopr);
  xopr.oprtype := alg.t_oprtype.FOR;
  flex.ident_err(xlex,varname);
  call syn_find_var(xalg,varname,xvar);
  if ( isnull(xvar) )
    flex.message(xlex,"var not found");

  alg.typ_var_own(xvar,xtyp);

  switch ( xtyp.typtype )
  { case alg.t_typtype.REAL,INTEGER:
      ;
    default:
      flex.message(xlex,"index is not of integer type");
  }

  alg.var_opr_ins(xvar,xopr,-1);
  flex.sample_err(xlex,":=");

  for ( ; ; )
  { var
      alg.elm xelm,
      alg.exp xexp;

    alg.elm_cre(xalg,xelm);
    alg.opr_elm_ins(xopr,xelm,-1);
    call syn_exp(xlex,xalg,xexp);
    call check_numeric_type(xlex,xexp.typtype);
    alg.elm_exp_ins(xelm,xexp,-1);
    if ( flex.sample(xlex,"step") )
    { xelm.elmtype := alg.t_elmtype.STEP;
      call syn_exp(xlex,xalg,xexp);
      call syn_auto_convert(xlex,xtyp.typtype,xexp);
      alg.elm_exp_ins(xelm,xexp,-1);
      flex.sample_err(xlex,"until");
      call syn_exp(xlex,xalg,xexp);
      call syn_auto_convert(xlex,xtyp.typtype,xexp);
      alg.elm_exp_ins(xelm,xexp,-1);
    }
    else if ( flex.sample(xlex,"while") )
    { xelm.elmtype := alg.t_elmtype.WHILE;
      call syn_exp(xlex,xalg,xexp);
      call check_boolean_type(xlex,xexp.typtype);
      alg.elm_exp_ins(xelm,xexp,-1);
    }
    else
      xelm.elmtype := alg.t_elmtype.EXP;

    if ( not flex.sample(xlex,",") )
      break;
  }

  flex.sample_err(xlex,"do");
  call syn_opr(xlex,xalg,xopr1);
  alg.opr_opr_ins(xopr,xopr1,-1);
}

proc syn_opr_print(flex.t_lex xlex,alg.alg xalg,out alg.opr xopr)
{ alg.opr_cre(xalg,xopr);
  xopr.oprtype := alg.t_oprtype.PRINT;
  flex.sample_err(xlex,"(");

  for ( ; ; )
  { var
      alg.exp xexp;

    call syn_exp(xlex,xalg,xexp);
    alg.opr_exp_ins(xopr,xexp,-1);
    if ( not flex.sample(xlex,",") )
      break;
  }

  flex.sample_err(xlex,")");
}

proc syn_opr(flex.t_lex xlex,alg.alg xalg,out alg.opr xopr)
{ var
    alg.t_name anyname,
    int line := flex.line_numb(xlex);

  null(xopr);
  if ( flex.sample(xlex,"begin") )
    call syn_opr_block(xlex,xalg,xopr);
  else if ( flex.sample(xlex,"if") )
    call syn_opr_if(xlex,xalg,xopr);
  else if ( flex.sample(xlex,"for") )
    call syn_opr_for(xlex,xalg,xopr);
  else if ( flex.sample(xlex,"print") )
    call syn_opr_print(xlex,xalg,xopr);
  else if ( flex.ident_check(xlex,anyname) )
  { var
      alg.var xvar;

    call syn_find_var(xalg,anyname,xvar);
    if ( isnotnull(xvar) )
    { var
        alg.exp xexp1,
        alg.exp xexp2;

      call syn_exp(xlex,xalg,xexp1);

      switch ( xexp1.exptype )
      { case VAR,INDEX:
          ;
        default:
          flex.message(xlex,"expr is not lvalue");
      }

      flex.sample_err(xlex,":=");
      call syn_exp(xlex,xalg,xexp2);
      call syn_auto_convert(xlex,xexp1.typtype,xexp2);
      alg.opr_cre(xalg,xopr);
      xopr.oprtype := alg.t_oprtype.ASSIGN;
      alg.opr_exp_ins(xopr,xexp1,-1);
      alg.opr_exp_ins(xopr,xexp2,-1);
    }
    else
    { var
        alg.prc xprc1;

      alg.find_alg_prc_first(xalg,anyname,xprc1);
      if ( isnotnull(xprc1) )
      { var
          alg.exp xexpnull;

        if ( xprc1.typtype <> alg.t_typtype.VOID )
          flex.message(xlex,"procedure is a function");

        flex.ident_err(xlex,anyname);
        alg.opr_cre(xalg,xopr);
        xopr.oprtype := alg.t_oprtype.CALL;
        alg.prc_opr_ins(xprc1,xopr,-1);
        call syn_actual_par(xlex,xprc1,xopr,xexpnull);
      }
      else
        flex.message(xlex,"unrecognized identifier");
    }
  }
  else
    flex.message(xlex,"syntax error");

  xopr.line := line;
}

proc syn_proc(flex.t_lex xlex,alg.alg xalg)
{ var
    alg.prc xprc,
    alg.opr xopr,
    alg.t_name prcname,
    alg.t_typtype typtype;

  if ( flex.sample(xlex,"procedure") )
    ;
  else
  { call syn_simple_type(xlex,typtype);
    flex.sample_err(xlex,"procedure");
  }

  flex.ident_err(xlex,prcname);
  alg.find_alg_prc_first(xalg,prcname,xprc);
  if ( isnotnull(xprc) )
    flex.message(xlex,"duplicate procedure");

  alg.prc_cre(xalg,xprc);
  xprc.name := prcname;
  xprc.typtype := typtype;
  alg.alg_prc_ins(xalg,xprc,-1);
  call syn_push(xalg);
  if ( typtype <> alg.t_typtype.VOID )
  { var
      alg.var xvar,
      alg.typ xtyp;

    alg.typ_cre(xalg,xtyp);
    xtyp.typtype := typtype;
    alg.var_cre(xalg,xvar);
    xvar.name := prcname;
    alg.typ_var_ins(xtyp,xvar,-1);
    alg.ret_fun_ins(xvar,xprc,-1);
    call syn_push_var(xalg,xvar);
  }

  flex.sample_err(xlex,"(");
  if ( not flex.sample(xlex,")") )
  { for ( ; ; )
    { var
        alg.var xvar,
        alg.t_name parname;

      flex.ident_err(xlex,parname);
      alg.find_prc_var_first(xprc,parname,xvar);
      if ( isnotnull(xvar) )
        flex.message(xlex,"duplicate parameter");

      alg.var_cre(xprc.xdoc,xvar);
      xvar.name := parname;
      alg.prc_var_ins(xprc,xvar,-1);
      call syn_push_var(xalg,xvar);
      if ( not flex.sample(xlex,",") )
        break;
    }

    flex.sample_err(xlex,")");
  }

  call syn_spec(xlex,xprc);
  call syn_opr(xlex,xalg,xopr);
  alg.opr_prc_ins(xopr,xprc,-1);
  call syn_pop(xalg);
}

procdecl syn(alg.alg xalg,string8 n_file)
{ varobj
    flex.t_lex xlex;

  flex.fopen(xlex,n_file);

  while ( not flex.eof(xlex) )
  { call syn_proc(xlex,xalg);
  }

  { var
      alg.prc xprc,
      alg.var xvar;

    alg.alg_prc_mem(xalg,-1,xprc);
    if ( isnull(xprc) )
      flex.message(xlex,"no proc found");

    alg.prc_var_mem(xprc,0,xvar);
    if ( isnotnull(xvar) )
      flex.message(xlex,"last procedure has nonempty parameter list");
  }

  flex.eof_err(xlex);
}

Файл listing.package:

package listing

procdecl listing(alg.alg xalg,string8 n_file);

implementation

procspec list_exp(gio.t_file ofile,alg.exp xexp);

proc list_level(gio.t_file ofile,int level)
{ var
    int lev;

  for ( lev := 0; lev < level; lev += 1 )
    gio.fwrite_c(ofile,"  ");
}

proc typ_name(gio.t_file ofile,alg.t_typtype typtype)
{ switch ( typtype )
  { case REAL:
      gio.fwrite_c(ofile,"real");
    case INTEGER:
      gio.fwrite_c(ofile,"integer");
    case BOOLEAN:
      gio.fwrite_c(ofile,"boolean");
    case REAL_ARR:
      gio.fwrite_c(ofile,"real array");
    case INTEGER_ARR:
      gio.fwrite_c(ofile,"integer array");
    case BOOLEAN_ARR:
      gio.fwrite_c(ofile,"boolean array");
  }
}

proc list_prc_header(gio.t_file ofile,alg.prc xprc)
{ var
    alg.var xvar;

  if ( xprc.typtype <> alg.t_typtype.VOID )
  { call typ_name(ofile,xprc.typtype);
    gio.fwrite_c(ofile," ");
  }

  gio.fwrite_c(ofile,"procedure ");
  gio.fwrite_c(ofile,xprc.name);
  gio.fwrite_c(ofile,"(");
  alg.prc_var_mem(xprc,0,xvar);

  while ( isnotnull(xvar) )
  { gio.fwrite_c(ofile,xvar.name);
    alg.prc_var_next(xvar);
    if ( isnotnull(xvar) )
      gio.fwrite_c(ofile,",");
  }

  gio.fwrite_c(ofile,")\n");
}

proc list_typ(gio.t_file ofile,alg.typ xtyp)
{ var
    alg.var xvar;

  gio.fwrite_c(ofile,"  ");
  call typ_name(ofile,xtyp.typtype);
  gio.fwrite_c(ofile," ");
  alg.typ_var_mem(xtyp,0,xvar);

  while ( isnotnull(xvar) )
  { gio.fwrite_c(ofile,xvar.name);
    alg.typ_var_next(xvar);
    if ( isnotnull(xvar) )
      gio.fwrite_c(ofile,",");
  }

  switch ( xtyp.typtype )
  { case alg.t_typtype.REAL_ARR,INTEGER_ARR,BOOLEAN_ARR:
    { var
        alg.dim xdim;

      gio.fwrite_c(ofile,"[");
      alg.typ_dim_mem(xtyp,0,xdim);

      while ( isnotnull(xdim) )
      { var
          alg.exp xexp1,
          alg.exp xexp2;

        alg.dim_exp_mem(xdim,0,xexp1);
        alg.dim_exp_mem(xdim,1,xexp2);
        call list_exp(ofile,xexp1);
        gio.fwrite_c(ofile,":");
        call list_exp(ofile,xexp2);
        alg.typ_dim_next(xdim);
        if ( isnotnull(xdim) )
          gio.fwrite_c(ofile,",");
      }

      gio.fwrite_c(ofile,"]");
    }
  }
}

proc list_prc_spec(gio.t_file ofile,alg.prc xprc)
{ var
    alg.vlu xvlu,
    alg.typ xtyp;

  alg.prc_vlu_mem(xprc,0,xvlu);
  if ( isnotnull(xvlu) )
  { gio.fwrite_c(ofile,"  value ");

    while ( isnotnull(xvlu) )
    { gio.fwrite_c(ofile,xvlu.name);
      alg.prc_vlu_next(xvlu);
      if ( isnotnull(xvlu) )
        gio.fwrite_c(ofile,",");
    }

    gio.fwrite_c(ofile,";\n");
  }

  alg.prc_typ_mem(xprc,0,xtyp);

  while ( isnotnull(xtyp) )
  { call list_typ(ofile,xtyp);
    gio.fwrite_c(ofile,";\n");
    alg.prc_typ_next(xtyp);
  }
}

proc list_exp_ival(gio.t_file ofile,alg.exp xexp)
{ var
    alg.t_buf txt;

  gio.fwrite_c(ofile,string(txt,xexp.ival));
}

proc list_exp_dval(gio.t_file ofile,alg.exp xexp)
{ var
    alg.t_buf buf,
    alg.t_buf form;

  form := "%";
  form += xexp.ival+1;
  form += ".";
  form += xexp.ival;
  form += "lf";
  gstring.from_double(xexp.dval,form,buf);
  gio.fwrite_c(ofile,buf);
}

proc list_exp_var(gio.t_file ofile,alg.exp xexp)
{ var
    alg.var xvar;

  alg.var_exp_own(xexp,xvar);
  gio.fwrite_c(ofile,xvar.name);
}

proc list_exp_index(gio.t_file ofile,alg.exp xexp)
{ var
    alg.var xvar,
    alg.exp xexp1;

  alg.var_exp_own(xexp,xvar);
  gio.fwrite_c(ofile,xvar.name);
  gio.fwrite_c(ofile,"[");
  alg.exp_exp_mem(xexp,0,xexp1);

  while ( isnotnull(xexp1) )
  { call list_exp(ofile,xexp1);
    alg.exp_exp_next(xexp1);
    if ( isnotnull(xexp1) )
      gio.fwrite_c(ofile,",");
  }

  gio.fwrite_c(ofile,"]");
}

proc list_exp_func(gio.t_file ofile,alg.exp xexp)
{ var
    alg.prc xprc,
    alg.exp xexp1;

  alg.fun_exp_own(xexp,xprc);
  gio.fwrite_c(ofile,xprc.name);
  gio.fwrite_c(ofile,"(");
  alg.exp_exp_mem(xexp,0,xexp1);

  while ( isnotnull(xexp1) )
  { call list_exp(ofile,xexp1);
    alg.exp_exp_next(xexp1);
    if ( isnotnull(xexp1) )
      gio.fwrite_c(ofile,",");
  }

  gio.fwrite_c(ofile,")");
}

proc list_exp_paren(gio.t_file ofile,alg.exp xexp)
{ var
    alg.exp xexp1;

  alg.exp_exp_mem(xexp,0,xexp1);
  gio.fwrite_c(ofile,"(");
  call list_exp(ofile,xexp1);
  gio.fwrite_c(ofile,")");
}

proc list_exp_oper(gio.t_file ofile,alg.exp xexp,string7 oper)
{ var
    alg.exp xexp1,
    alg.exp xexp2;

  alg.exp_exp_mem(xexp,0,xexp1);
  alg.exp_exp_mem(xexp,1,xexp2);
  call list_exp(ofile,xexp1);
  gio.fwrite_c(ofile,oper);
  call list_exp(ofile,xexp2);
}

proc list_exp_not(gio.t_file ofile,alg.exp xexp)
{ var
    alg.exp xexp1;

  alg.exp_exp_mem(xexp,0,xexp1);
  gio.fwrite_c(ofile,"~");
  call list_exp(ofile,xexp1);
}

proc list_exp_auto_i_to_r(gio.t_file ofile,alg.exp xexp)
{ var
    alg.exp xexp1;

  alg.exp_exp_mem(xexp,0,xexp1);
  call list_exp(ofile,xexp1);
}

proc list_exp(gio.t_file ofile,alg.exp xexp)
{ switchall ( xexp.exptype )
  { case IVAL:
      call list_exp_ival(ofile,xexp);
    case RVAL:
      call list_exp_dval(ofile,xexp);
    case VAR:
      call list_exp_var(ofile,xexp);
    case INDEX:
      call list_exp_index(ofile,xexp);
    case FUNC:
      call list_exp_func(ofile,xexp);
    case PAREN:
      call list_exp_paren(ofile,xexp);
    case POW:
      call list_exp_oper(ofile,xexp,"^");
    case MUL:
      call list_exp_oper(ofile,xexp,"*");
    case DIV:
      call list_exp_oper(ofile,xexp,"/");
    case MOD:
      call list_exp_oper(ofile,xexp,"%");
    case ADD:
      call list_exp_oper(ofile,xexp,"+");
    case SUB:
      call list_exp_oper(ofile,xexp,"-");
    case EQ:
      call list_exp_oper(ofile,xexp," = ");
    case NE:
      call list_exp_oper(ofile,xexp," <> ");
    case GE:
      call list_exp_oper(ofile,xexp," >= ");
    case GT:
      call list_exp_oper(ofile,xexp," > ");
    case LE:
      call list_exp_oper(ofile,xexp," <= ");
    case LT:
      call list_exp_oper(ofile,xexp," < ");
    case NOT:
      call list_exp_not(ofile,xexp);
    case AND:
      call list_exp_oper(ofile,xexp," & ");
    case OR:
      call list_exp_oper(ofile,xexp," | ");
    case AUTO_I_TO_R:
      call list_exp_auto_i_to_r(ofile,xexp);
  }
}

procspec list_opr(gio.t_file ofile,alg.opr xopr,int level);

proc list_block(gio.t_file ofile,alg.opr xopr,int level)
{ switch ( xopr.oprtype )
  { case BLOCK:
      call list_opr(ofile,xopr,level);
    default:
    { gio.fwrite_c(ofile,"  ");
      call list_opr(ofile,xopr,level+1);
    }
  }
}

proc list_opr_block(gio.t_file ofile,alg.opr xopr,int level)
{ var
    alg.opr xopr1,
    alg.typ xtyp;

  gio.fwrite_c(ofile,"begin\n");
  alg.opr_typ_mem(xopr,0,xtyp);

  while ( isnotnull(xtyp) )
  { call list_level(ofile,level);
    call list_typ(ofile,xtyp);
    alg.opr_typ_next(xtyp);
    gio.fwrite_c(ofile,";\n");
  }

  alg.opr_opr_mem(xopr,0,xopr1);

  while ( isnotnull(xopr1) )
  { call list_level(ofile,level+1);
    call list_opr(ofile,xopr1,level+1);
    alg.opr_opr_next(xopr1);
    if ( isnotnull(xopr1) )
      gio.fwrite_c(ofile,";");

    gio.fwrite_c(ofile,"\n");
  }

  call list_level(ofile,level);
  gio.fwrite_c(ofile,"end");
}

proc list_opr_if(gio.t_file ofile,alg.opr xopr,int level)
{ var
    alg.exp xexp,
    alg.opr xopr1;

  alg.opr_exp_mem(xopr,0,xexp);
  alg.opr_opr_mem(xopr,0,xopr1);
  gio.fwrite_c(ofile,"if ");

  for ( ; ; )
  { call list_exp(ofile,xexp);
    gio.fwrite_c(ofile," then\n");
    call list_level(ofile,level);
    call list_block(ofile,xopr1,level);
    alg.opr_exp_next(xexp);
    alg.opr_opr_next(xopr1);
    if ( isnull(xexp) )
      break;

    call gio.fwrite_c(ofile,"\n");
    call list_level(ofile,level);
    call gio.fwrite_c(ofile,"else if ");
  }

  if ( isnotnull(xopr1) )
  { gio.fwrite_c(ofile,"\n");
    call list_level(ofile,level);
    gio.fwrite_c(ofile,"else\n");
    call list_level(ofile,level);
    call list_block(ofile,xopr1,level);
  }
}

proc list_opr_for(gio.t_file ofile,alg.opr xopr,int level)
{ var
    alg.var xvar,
    alg.elm xelm,
    alg.opr xopr1;

  gio.fwrite_c(ofile,"for ");
  alg.var_opr_own(xopr,xvar);
  gio.fwrite_c(ofile,xvar.name);
  gio.fwrite_c(ofile," := ");
  alg.opr_elm_mem(xopr,0,xelm);

  while ( isnotnull(xelm) )
  { var
      alg.exp xexp;

    alg.elm_exp_mem(xelm,0,xexp);

    switchall ( xelm.elmtype )
    { case EXP:
        call list_exp(ofile,xexp);
      case STEP:
      { call list_exp(ofile,xexp);
        gio.fwrite_c(ofile," step ");
        alg.elm_exp_next(xexp);
        call list_exp(ofile,xexp);
        gio.fwrite_c(ofile," until ");
        alg.elm_exp_next(xexp);
        call list_exp(ofile,xexp);
      }
      case WHILE:
      { call list_exp(ofile,xexp);
        gio.fwrite_c(ofile," while ");
        alg.elm_exp_next(xexp);
        call list_exp(ofile,xexp);
      }
    }

    alg.opr_elm_next(xelm);
    if ( isnotnull(xelm) )
      gio.fwrite_c(ofile,",");
  }

  gio.fwrite_c(ofile," do\n");
  alg.opr_opr_mem(xopr,0,xopr1);
  call list_level(ofile,level);
  call list_block(ofile,xopr1,level);
}

proc list_opr_call(gio.t_file ofile,alg.opr xopr)
{ var
    alg.prc xprc,
    alg.exp xexp;

  alg.prc_opr_own(xopr,xprc);
  gio.fwrite_c(ofile,xprc.name);
  gio.fwrite_c(ofile,"(");
  alg.opr_exp_mem(xopr,0,xexp);

  while ( isnotnull(xexp) )
  { call list_exp(ofile,xexp);
    alg.opr_exp_next(xexp);
    if ( isnotnull(xexp) )
      gio.fwrite_c(ofile,",");
  }

  gio.fwrite_c(ofile,")");
}

proc list_opr_print(gio.t_file ofile,alg.opr xopr)
{ var
    alg.exp xexp;

  gio.fwrite_c(ofile,"print(");
  alg.opr_exp_mem(xopr,0,xexp);

  while ( isnotnull(xexp) )
  { call list_exp(ofile,xexp);
    alg.opr_exp_next(xexp);
    if ( isnotnull(xexp) )
      gio.fwrite_c(ofile,",");
  }

  gio.fwrite_c(ofile,")");
}

proc list_opr_assign(gio.t_file ofile,alg.opr xopr)
{ var
    alg.exp xexp1,
    alg.exp xexp2;

  alg.opr_exp_mem(xopr,0,xexp1);
  alg.opr_exp_mem(xopr,1,xexp2);
  call list_exp(ofile,xexp1);
  gio.fwrite_c(ofile," := ");
  call list_exp(ofile,xexp2);
}

proc list_opr(gio.t_file ofile,alg.opr xopr,int level)
{ switchall ( xopr.oprtype )
  { case BLOCK:
      call list_opr_block(ofile,xopr,level);
    case IF:
      call list_opr_if(ofile,xopr,level);
    case FOR:
      call list_opr_for(ofile,xopr,level);
    case CALL:
      call list_opr_call(ofile,xopr);
    case ASSIGN:
      call list_opr_assign(ofile,xopr);
    case PRINT:
      call list_opr_print(ofile,xopr);
  }
}

proc list_prc(gio.t_file ofile,alg.prc xprc)
{ var
    alg.opr xopr;

  gio.fwrite_c(ofile,"\n");
  call list_prc_header(ofile,xprc);
  call list_prc_spec(ofile,xprc);
  alg.opr_prc_own(xprc,xopr);
  call list_opr(ofile,xopr,0);
  gio.fwrite_c(ofile,"\n");
}

procdecl listing(alg.alg xalg,string8 n_file)
{ varobj
    gio.t_file ofile;

  var
    alg.prc xprc,
    gsystem.t_filename8 n_list := n_file;

  n_list += ".txt";
  gio.fopen(n_list,"w",ofile);
  alg.alg_prc_mem(xalg,0,xprc);

  while ( isnotnull(xprc) )
  { call list_prc(ofile,xprc);
    alg.alg_prc_next(xprc);
  }

  gio.fclose(ofile);
}

Файл algol60.utility:

utility algol60:"ALGOL60"

main
{ varobj
    alg.alg xalg;

  if ( utl.argc(xutl.yutl) <> 2 )
    error U"Не задан файл";

  var
    gsystem.t_filename8 n_file := utl.argv8(xutl.yutl,1);

  call syntax.syn(xalg,n_file);
  call listing.listing(xalg,n_file);
}
Скачать проект algol60