{
*************************************************************************
*                                                                       *
*                                                                       *
*                       *  P A S  *  S Y S T E M                        *
*                                                                       *
*                                                                       *
*                    * * *   C o m p i l e r    * * *                   *
*                                                                       *
*                                                                       *
*              ---  Main Part  of PASCAL COMPILER ---                   *
*                                                                       *
*              ---  Version  3.1-B5 -- 31/07/2019 ---                   *
*                                                                       *
*           by :                                                        *
*                                                                       *
*               P. Wolfers                                              *
*                                          FRANCE.                      *
*                                                                       *
*************************************************************************


/////////////////////////////////////////////////////////////////////////
//                                                                     //
//                                                                     //
//                  Global Public Licence (GPL)                        //
//                                                                     //
//                                                                     //
// This license described in this file overrides all other licenses    //
// that might be specified in other files for this software.           //
//                                                                     //
// This program is free software; you can redistribute it and/or       //
// modify it under the terms of the GNU Lesser General Public          //
// License as published by the Free Software Foundation; either        //
// version 2.1 of the License, or (at your option) any later version.  //
//                                                                     //
// This software is distributed in the hope that it will be useful,    //
// but WITHOUT ANY WARRANTY; without even the implied warranty of      //
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU   //
// Library General Public License for more details.                    //
//                                                                     //
// You should have received a copy of the GNU Lesser General Public    //
// License along with this library (see COPYING.LIB); if not, write to //
// the Free Software Foundation :                                      //
//                      Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  //
//                                                                     //
/////////////////////////////////////////////////////////////////////////


}


{************     CPAS  version    *************}

(*
[inherit(    'lib:cpas_b__src',                { Use Basic Library Definitions }
             'lib:pas_env')]                   { Use Tree Definitions }
*)
module PAS_COMPILER( Input, Output );

{
        *** Modification(s) from major version ***


                  ----

                 NOTHING

                  ----

}

{ *** Include basic compiler environment *** }
%include 'passrc:pcmp_env';


var
  spc_align,                                   { Attributes specified alignement in byte }
  spc_asize:             integer;              { Attributes specified size in byte }

  spc_opearg:            boolean := false;     { Flag for operator get argument in the EXPRESSION manager }



procedure CMP_PASS2( pr: pro_ptr ); forward;



{*****************************************}
{   Procedure to Manage a Dynamic Block   }
{*****************************************}


[global]
procedure CMP_BLOCK( owner: pro_ptr; bproc: boolean; glicd: integer );
{ To Compile a PASCAL Main/Module/Procedure/Function Block }
{ owner    is the pro_rec pointer,
  bproc    to test for procedure or dynamic block,
  glicd    to preset the GEN_LINETRACE procedure in the statelist sequence.
}
const
  mdnam = 'BLOC';

var
  lgr,                                         { LGT pointer for Return managment }
  lgt_last_enode,                              { Last node generated by STATEMENT }
  lgt_end_list,                                { Last statelist generated node }
  loop_lgt: lgt_ptr;                           { Default loop node }

  lab_end_list,                                { Last created label for the current block }
  sav_label,                                   { Save any more external label list }
  fw_ptr,                                      { Forward list head }
  var_lst_end: ide_ptr;                        { Variable list end }
  p_ope, p_ope2: ope_ptr;                      { To scan all local operator definitions }

  attr_kind: var_kind;                         { Set attribute class for procedure/function/variable }
  attr_nam:  nam_ptr;                          { External name for attribute declaration }

  has_intdesc,                                 { Flag to mark a sub-type with a descritor }
  return_flg: boolean;                         { Flag to mark returned value specified }



function  EXPRESSION: lgt_ptr;                                                 { Enable call to use EXPRESSION }
forward;

function FORMAL_PROC_DECL( isfunction: boolean ): ide_ptr;                     { To create an entry descriptor }
forward;

function FORMAL_PROC_PTR( isfunction: boolean ): typ_ptr;                      { To create an entry descriptor }
forward;

function ARGUMENT_LIST( var pr: pro_ptr; isfunct, no_entry: boolean ): boolean;{ To manage an entry argument list }
forward;

function CASE_DEFINITION( mode: symbol; ty: typ_ptr ): lgt_ptr;                { Builder of a case tree procedure reference }
forward;



(*
procedure CHECK_DOUBLE( iv: integer );
var p: gen_ptr;
begin
  if iv >= 0 then WRITELN( ' Check type double ', iv:-4 );
  with typ_std[form_double]^.typ_ide^ do
  begin
    p := ide_gfirst;
    while p <> nil do
      if p^.gen_link = p then
      begin
        WRITELN( ' DOUBLE gen_rec loop on op = ', p^.gen_pcode );
        PASCAL_EXIT;
      end else p := p^.gen_link;
  end
end CHECK_DOUBLE;
*)

{****************************************************************************
 *                                                                          *
 *           Block dependant Internal procedures and functions              *
 *                                                                          *
 ****************************************************************************}



function EXPRESSION_TYPE( it: typ_ptr; exact, no_def, no_check: boolean := false ): lgt_ptr;
{ To Get (and Built LGT Equivalent Tree) of a Specified Type Expression.
}
const
  mdnam = 'EXPT';

var
  vp:               val_ptr;
  lgt1, lgt2:       lgt_ptr;
  ivl:              integer;
  ch:                  char;
  bok:              boolean;

begin
  bok  := false;
  lgt1 := EXPRESSION;                          { Keep target in stack }
  if lgt1 <> nil then
  with lgt1^, it^ do
  if lgt_typ <> it then
  begin { The types are not same }
    if lgt_kind = lgt_const then
    begin
      if (lgt_typ = typ_std[form_nil]) and COMP_TYPE( lgt_typ, it ) then
      begin  lgt_typ := it; bok := true  end
      else
      if COMP_TYPE( lgt_typ, typ_std[form_record], false ) or
         COMP_TYPE( lgt_typ, typ_std[form_char], true ) then   { We have got a string or a char }
      begin { For a cte. expression }
        if (typ_form = form_record) and
           (lgt_typ^.typ_form = form_char) and 
           COMP_TYPE( lgt_typ, it, exact ) then
        begin { We have a character and we want a string }
          if lgt_cte <> nil then ch := CHR( lgt_cte^.val_ival ) else ch := ' ';
          VAL_FREE( lgt_cte );
          VAL_NEW( lgt_cte, typ_std[form_record] );
          lgt_typ := typ_std[form_record];
          with lgt_cte^ do
          begin
            val_kind := form_string;
            val_size := 1;
            NEW( val_str, 1);
            val_str^ := ch
          end;
          bok := true
        end
        else
        if (typ_form = form_array) and         { Cte. char. or Standard string -> to -> array of char }
           (typ_aeltype = typ_std[form_char]) then
        begin { for cte. packed array[...] of char }
          STRING_IN_ARRAY( lgt1, it );
          bok := true
        end
        else
        if typ_parent = lgt_typ then           { A subtype of the string type }
        begin
          STRING_IN_SUBSTRING( lgt1, it );
          bok := true
        end
      end
      else
        if lgt_typ^.typ_parent = it then bok := true
        else
        case typ_form of
          form_lit, form_char, form_int:
            if typ_parent = lgt_typ then
            { The target type is a child of the given type }
            if lgt_cte <> nil then
            with lgt_cte^ do
            begin
              if typ_unsigned then
              begin
                if (typ_umin <= val_uval) and (typ_umax >= val_uval) then
                begin  lgt_typ := it; val_typ := it; bok := true  end
              end
              else
                if (typ_min <= val_ival) and (typ_max >= val_ival) then
                begin  lgt_typ := it; val_typ := it; bok := true  end;

              if not bok then SRC_ERROR( mdnam, 154, e_error ) { Out of range error }
            end;

          form_range:
            if typ_parent = lgt_typ then
            { The target type is a child of the given type }
            if lgt_cte <> nil then
            with lgt_cte^ do
              if lgt_typ^.typ_size <= typ_size then
              begin                            { Verify the agreement with the size }
                lgt_typ := it;
                val_typ := it;
                if cmp_range and not no_check then
                begin                          { Generate dynamic range Check when required }
                  lgt2 := LGT_TYPE_EVAL( typ_low, curr_descr );

                  lgt2^.lgt_nxt := LGT_TYPE_EVAL( typ_high, curr_descr );
                  lgt1^.lgt_nxt := lgt2;
                  lgt1 := LGT_NEW_CODE( pcod_range, lgt1 );
                  lgt1^.lgt_typ := it
                end;
                bok := true
              end;

          form_single, form_double:
            with lgt_cte^ do
            begin                              { Integer to float conversion }
              if lgt_typ <> nil then
                case lgt_typ^.typ_form of
                  form_int: begin  val_rval := val_ival; bok := true  end;
                  form_single, form_double: bok := true;
                otherwise
                end;
              if bok then
              begin
                val_kind := typ_form;
                val_typ  := it;
                lgt_typ  := it
              end
            end;

        otherwise
        end
    end;

(* /// Must be an Error should be suppress any type/range error control ///
    else
      bok := true;
*)

    if not bok then
      if not COMP_TYPE( lgt_typ, it, exact ) then
      begin                                    { Incompatible type or out of range (on type spc.) }
        SRC_ERROR( mdnam, 109, e_severe);
        lgt1^.lgt_typ := it
      end
      else
        if cmp_range and not no_check then
        case typ_form of
          form_lit, form_char, form_int:
            if enm_range then
            begin                              { Generate a range check when required }
              lgt2 := LGT_NEW_ECONST( lgt_typ, typ_min );
              lgt2^.lgt_nxt := LGT_NEW_ECONST( lgt_typ, typ_max );
              lgt1^.lgt_nxt := lgt2;
              lgt1 := LGT_NEW_CODE( pcod_range, lgt1 );
              lgt1^.lgt_typ := it
            end;

          form_range:
            begin
              lgt2 := LGT_TYPE_EVAL( typ_low, curr_descr );
              lgt2^.lgt_nxt := LGT_TYPE_EVAL( typ_high, curr_descr );
              lgt1^.lgt_nxt := lgt2;
              lgt1 := LGT_NEW_CODE( pcod_range, lgt1 );
              lgt1^.lgt_typ := it
            end;

        otherwise
        end
  end;
  if no_def then
    if lgt1^.lgt_kind = lgt_empty then SRC_ERROR( mdnam, 181, e_error );
  EXPRESSION_TYPE := lgt1
end EXPRESSION_TYPE;



function EXP_GENNUM( var ty: typ_ptr ): integer;
{ To get (and build LGT ...) a cte. nummeric expression.
}
const
  mdnam = 'EGCT';

var
  lgt: lgt_ptr;

begin
  lgt := EXPRESSION_TYPE( ty );
  with lgt^ do
  begin
    ty := lgt_typ;
    if lgt_kind = lgt_const then
      EXP_GENNUM := lgt_cte^.val_ival
    else
    begin
      SRC_ERROR( mdnam, 853, e_error );
      EXP_GENNUM := ty^.typ_min
    end
  end;
  LGT_FREE_TREE( lgt )
end EXP_GENNUM;



function ATTR_TYPE( lgt: lgt_ptr; ty: typ_ptr): lgt_ptr;
{ Procedure to refer any particular attribute attached to a specified type or variable.
  Example :
  Any user defined type parameter,
  first and last, successor and predecessor for a ennumerated type,
  assumed precision for a float.
}
const
  mdnam = 'ATTY';

var

  sav_form: typ_forms;
  i1, i2:   integer;
  lgt1:     lgt_ptr;
  ip, iq:   ide_ptr;
  idn:      string( id_maxsize ); 


begin { ATTR_TYPE }
  lgt1 := nil;
  with sy_sym, ty^ do
  begin
    INSYMBOL;                                  { Gobble up " character }
    if sy = identsy then
    begin
      ip := LEVEL_SEARCH( attr_list );
      if ip = nil then SRC_ERROR_S( mdnam, 105, e_severe, sy_ident )
      else
      case ip^.ide_attr of
        attr_addr: { Address of }
          begin
(* ///
            if typ_form <> form_record then    { For any not record object }
              with lgt^ do                     { Force the address of the descriptor }
                lgt_disp := lgt_disp - typ_descr_size;
*)
            if lgt = nil then SRC_ERROR_S( mdnam, 161, e_severe, sy_ident );
            LGT_NEW( lgt1, typ_std[form_nil], lgt_address, lgt );
            lgt := nil
          end;

        attr_size: { Size in bytes }
          if typ_size >= 0 then
            lgt1 := LGT_NEW_ECONST( typ_std[form_int], typ_size )
          else
          begin
            lgt1 := LGT_TYPE_COMPUTE( typ_sizesrv, typ_comp_size, typ_size, lgt );
            if lgt <> nil then
              { To do allow the FREE of the object node when it it used }
              if lgt^.lgt_kind <> lgt_const then lgt := nil
          end;

        attr_arrimin,
        attr_arrimax:
          begin
            if COMP_TYPE( ty, typ_std[form_record], true ) then  ty := ty^.typ_lastfield^.ide_typ; { Standard string }
            case ty^.typ_form of
              form_conf,
              form_array:
                with ty^.typ_indtype^ do
                  if typ_form = form_range then
                  begin
                    if ip^.ide_attr = attr_arrimin then lgt1 := typ_low
                                                   else lgt1 := typ_high;
(*
WRITELN( lst_current^.lst_file, ' EXP_ATTR : ', lgt^.lgt_disp:0, ' base = ', curr_descr^.lgt_disp:0 );
LGT_WRITE_TREE( 4, lgt );
LGT_WRITE_TREE( 4, curr_descr );
*)
                    lgt1 := LGT_TYPE_COMPUTE( nil, lgt1, 1, curr_descr );
                    lgt1^.lgt_typ := typ_parent
                  end
                  else
                  begin
                    if ip^.ide_attr = attr_arrimin then i1 := typ_min
                                                   else i1 := typ_max;
                    lgt1 := LGT_NEW_ECONST( ty^.typ_indtype, i1 )
                  end;
            otherwise
              SRC_ERROR( mdnam, 158, e_severe );
              lgt1 := LGT_NEW_ECONST( typ_std[form_ennum], 1 )
            end
          end;

        attr_first, { Lowest value }
        attr_last:  { Greatest Value }
          if typ_form <= form_int then
            if ip^.ide_attr = attr_first then lgt1 := LGT_NEW_ECONST( ty, typ_min )
                                         else lgt1 := LGT_NEW_ECONST( ty, typ_max )
          else
          if typ_form = form_range then
          begin
            if ip^.ide_attr = attr_first then lgt1 := typ_low
                                         else lgt1 := typ_high;
            lgt1 := LGT_TYPE_COMPUTE( nil, lgt1, 1, curr_descr )
          end;

        attr_pred: { Predecessor }
          if lgt <> nil then
          begin
            lgt^.lgt_nxt := LGT_NEW_ECONST( typ_std[form_int], 1 );
            lgt1 := EXP_GENOP( add_op, lgt ); lgt := nil
          end;

        attr_succ: { Successor }
          if lgt <> nil then
          begin
            lgt^.lgt_nxt := LGT_NEW_ECONST( typ_std[form_int], 1 );
            lgt1 := EXP_GENOP( sub_op, lgt ); lgt := nil
          end;

        attr_image:
          case typ_form of
            form_lit: 
              if lgt = nil then
                { Refer the array directly }
                lgt1 := LGT_LINK( typ_idetab )
              else                             { For an expression we return the corresponding identifier }
              begin                            { We must use the constant table of each cte name }
                LGT_NEW( lgt1, ima_typ^.typ_aeltype, lgt_index,
                                 LGT_LINK( typ_idetab ) );
                lgt1^.lgt_parmlst^.lgt_nxt := lgt;     { link index value }
                lgt^.lgt_nxt :=
                    LGT_NEW_ECONST( int_typ, typ_idetab^.lgt_typ^.typ_el_size )
              end;
            form_set, form_lset:
              if typ_seltype <> nil then
              with typ_seltype^ do
                if lgt = nil then              { legal only for a type - not an expression }
                begin
                  { Refer the array directly }
                  if typ_idetab = nil then
                    lgt1 := LGT_LINK( typ_idetab )
                end;

          otherwise
          end;

        attr_fobjsize:
          begin
            if ty = typ_std[form_file] then i1 := 0 { for Text File } 
            else
              if (typ_form = form_file) and (typ_eltype <> nil) then i1 := typ_eltype^.typ_size        { Wild File }
                                                                else i1 := integer"last;   { Error on file def. }
            lgt1 := LGT_NEW_ECONST( typ_std[form_int], i1 )
          end;

        attr_digits,                           { Number of valide decimal figures of floatting type }
        attr_emax,                             { Largest exponante }
        attr_small,                            { Smallest number > 0 }
        attr_epsilon,                          { Smallest number > 1.0 - 1.0 }
        attr_large,                            { Largest float number }
        attr_mantissa:                         { Number of bits in the mantissa }
          with idn do
          begin
            { Build the identifier name of attribute cte value }
            idn.length := 0;
            case typ_form of
              form_int:
                begin
                  if typ_unsigned then WRITEV( idn, '$unsigned' )
                                  else WRITEV( idn, '$integer' );
                  WRITEV( idn:false, typ_size:1, '$' )
                end;
              form_single: WRITEV( idn, '$single' );
              form_double: WRITEV( idn, '$double' );
            otherwise
            end;
            WRITEV( idn:false, '$attr_' );
            with ip^.ide_name^ do
            WRITEV( idn:false, s:l );
            { Load the identifier string in sy_ident }
            IDE_CREATE_NAME( idn );
            iq := LEX_SEARCH( 0 );
            if iq <> nil then
            with iq^ do
              if ide_class = cla_konst then
              begin
                LGT_NEW( lgt1, ide_typ, lgt_const, nil );
                with lgt1^ do
                begin
                  lgt_cte := ide_value;
                  VAL_NEW( lgt_cte, ide_typ )
                end
              end;
            if lgt1 = nil then
            begin
              lgt1 := LGT_NEW_ECONST( typ_std[form_int], 0 );
              SRC_ERROR_S( mdnam, 164, e_error, ip^.ide_name^ )
            end
          end;

        attr_card:
          if (typ_form = form_set) or (typ_form = form_lset) then
            lgt1 := LGT_NEW_ECONST( int_typ, typ_cardinality );

      otherwise
      end { case };
      INSYMBOL                                 { Gobble up the attribute identifier }
    end
    else
      { Not an Identifier }
      SRC_ERROR( mdnam, 162, e_error )
  end;
  if lgt <> nil then LGT_FREE( lgt );
  if lgt1 <> nil then ATTR_TYPE := lgt1
  else
  begin
    SRC_ERROR( mdnam, 169, e_error );
    ATTR_TYPE := LGT_NEW_ECONST( typ_std[form_int], 1 )
  end
end ATTR_TYPE;



function BUILD_ARG_LIST( pr: pro_ptr ): lgt_ptr;
{ Function to call a not generic entry (including any formal entry - function or procedure).
}
const
  mdnam = 'BARG';

var
  found:               boolean;
  lgt0, lgt1, lgt2:    lgt_ptr;
  pg:                  gen_ptr;
  epr, fpr:            pro_ptr;
  ep, fp:              ide_ptr;

begin { BUILD_ARG_LIST }
  with sy_sym, pr^ do
  begin
    lgt0 := nil;
    fp := pro_parmlst;                                 { Head of formal parameter list }
    if pro_typ <> nil then                             { Function call: skip not simple type result arg. }
      if not pro_typ^.typ_simple then fp := fp^.ide_nxt;
    if fp <> nil then
    begin
      if sy <> lparen then SRC_ERROR( mdnam, 22, e_error)
                      else INSYMBOL                    { Gobble up "(" };
      while fp <> nil do                               { Scan on all parameter definitions }
      begin
        if fp^.ide_class = cla_fentry then
        begin { * Formal Entry ( = procedure or function) }
          found := false;
          fpr := fp^.ide_entry;                        { Get the formal entry definition }
          if sy = identsy then
          begin                                        { Look for specified effective procedure }
            ep := IDE_SEARCH( [cla_varbl,cla_fentry, cla_genwfent, cla_generic] );
            if ep <> ide_udptr[cla_varbl] then
            begin
              { Declared procedure/function or variable }
              with ep^ do

              if ide_class = cla_varbl then            { For effective pointed entry }
              begin
                epr := nil;
                if ide_typ <> nil then
                  with ide_typ^ do                     { Get the effective entry model reference }
                    if typ_form = form_fentry then epr := typ_entry;
                if epr <> nil then
                  { We verify that the parameter list compatibility }
                  if epr^.pro_parmlst <> fpr^.pro_parmlst then   { Not same arg. list }
                    if COMP_PROC_ARG( epr, fpr ) then found := true
                    (* if COMPARE_ENTRY( epr, fpr ) then found := true *)
                                                 else SRC_ERROR_S( mdnam, 120, e_severe, sy_ident )
              end
              else
              if ide_class = cla_fentry then           { For formal entry identifier }
              begin
                epr := ide_entry;                      { Get the effective entry model reference }
                { We verify that the parameter list compatibility }
                if epr^.pro_parmlst <> fpr^.pro_parmlst then   { Not same arg. list }
                  if COMP_PROC_ARG( epr, fpr ) then found := true
                  (* if COMPARE_ENTRY( epr, fpr ) then found := true *)
                                               else SRC_ERROR_S( mdnam, 121, e_severe, sy_ident )
              end
              else
              begin                                    { Generic name is given (cla_genwfent or cla_fentry) }
                pg := COMPARE_PROC_ARGID( ep^.ide_gfirst, ep^.ide_glast, fpr );
                (*
                if pg <> nil then epr := pg^.gen_proc
                             else SRC_ERROR( mdnam, 122, e_severe )
                *)
                pg := ep^.ide_gfirst;
                { We look for a procedure that match with the formal procedure/function parameter list }
                while (pg <> nil) and not found do
                with pg^ do
                begin
                  if not gen_blt then                  { Skip any builtin entry }
                  begin                                { Only the User Procedure can take as effective Procedure. }
                    epr := gen_proc;
                    found := COMP_PROC_ARG( epr, fpr )
                  end;
                  pg := gen_link
                end;
                if not found then SRC_ERROR_S( mdnam, 122, e_severe, sy_ident, fp^.ide_name^ )
              end;
            end;
            INSYMBOL                                   { Gobble up the effective entry name }
          end
          else
          begin                                        { Try default effective entry }
            epr := fp^.ide_defentry;                   { Default entry }
            if epr = nil then SRC_ERROR_S( mdnam, 148, e_severe, fp^.ide_name^ )
            else
              if fpr <> nil then found := COMP_PROC_ARG( epr, fpr )
                            else SRC_ERROR_S( mdnam, 123, e_severe, fp^.ide_name^ )    { Should be never }
          end;
          { Call is possible }
          if found then
          begin
            LGT_NEW( lgt2, epr^.pro_typ, lgt_proref, nil );
            lgt2^.lgt_pro := epr;
            if (epr^.pro_typ <> fpr^.pro_typ) and (fpr^.pro_typ <> nil) then
              if not COMP_TYPE( epr^.pro_typ, fpr^.pro_typ, true ) then
                SRC_ERROR_S( mdnam, 124, e_severe, ep^.ide_name^, fp^.ide_name^ )
          end
        end                                           { Formal function/procedure }
        else
        begin { Generate the parameter}               { Other formal: formal, rformal, wformal, vformal }
          lgt2 := EXPRESSION_TYPE( fp^.ide_typ, fp^.ide_vkind <> var_vformal );
          with lgt2^ do
            if lgt_kind = lgt_empty then              { No provided argument }
              if fp^.ide_inival = nil then
                { No default value specified for a not given eff. parameter }
                SRC_ERROR_S( mdnam, 854, e_severe, fp^.ide_name^ )
              else
              begin                                   { Set the initial value }
                lgt_kind := lgt_const;
                lgt_typ  := fp^.ide_typ;
                lgt_cte  := fp^.ide_inival;
                VAL_NEW( lgt_cte, nil {unused} );
                lgt_lide := nil
              end
        end;

        { We must link the parameter together }
        if lgt0 <> nil then lgt1^.lgt_nxt := lgt2
                       else lgt0 := lgt2;
        lgt1 := lgt2;

        fp := fp^.ide_nxt;                             { Skip to next formal argument }
        if sy = comma then INSYMBOL
      end                                              { While other defined argument(s) };
      if sy = rparen then INSYMBOL
      else SRC_ERROR( mdnam, 23, e_severe );           { Too many effective arguments }
    end                                                { if a parameter list must be present }
  end;
  BUILD_ARG_LIST := lgt0
end BUILD_ARG_LIST;



function CALL_FORMAL_PROC( ip: ide_ptr; bfnc: boolean ): lgt_ptr;
{ Function to call a not generic entry (including any formal entry - function or procedure).
}
const
  mdnam = 'FCAL';

var
  lgt: lgt_ptr;
  pr:  pro_ptr;

begin { CALL_FORMAL_PROC }
  with ip^ do
    { Get the formal procedure definition }
    case ide_class of
      cla_fentry:    { * Formal Entry }
        pr := ip^.ide_entry;

      cla_genwfent:  { * Entry with Formal entry in his argument list }
        pr := ide_gfirst^.gen_proc;

    otherwise        { * Usually due to a previously detected error }
      pr := nil
    end;

  if pr <> nil then
  with sy_sym do
  begin
    lgt := BUILD_ARG_LIST( pr );                       { Get the argument list }
    lgt := LGT_NEW_CALL( pr^.pro_typ, pr, lgt );       { Create a new node }
    CALL_SETTING( lgt )                                { Complete the call }
  end
  else
  begin
    SRC_ERROR( mdnam, 998, e_severe );
    lgt := nil
  end;
  if lgt = nil then
    { Simule a wild variable reference to continue the compilation }
    lgt := LGT_NEW_IDREF( ide_udptr[cla_varbl], nil )
  else
    if (lgt^.lgt_typ = nil) and bfnc then             { Error: Should be a function }
    begin
      SRC_ERROR( mdnam, 73, e_severe );
      lgt^.lgt_typ := typ_std[form_wild]
    end;
  CALL_FORMAL_PROC := lgt
end CALL_FORMAL_PROC;



function CALL_INDIRECT_PROC( lge: lgt_ptr ): lgt_ptr;
{ Indirect call of an entry (function/procedure).
  lge is the reference of entry pointer.
}
var
  lgt: lgt_ptr;
  pr:  pro_ptr;

begin
  lgt := nil;
  if lge <> nil then
  with lge^, lgt_typ^ do                               { The type is necesserly a form_fentry }
  begin
    pr := typ_entry;                                   { Get the entry model descriptor }
    if pr <> nil then
    with pr^ do
    begin
      lge^.lgt_nxt := BUILD_ARG_LIST( pr );            { Build the effective argument list }
      LGT_NEW( lgt, pro_typ, lgt_icall, lge );         { Form the lgt icall sub-tree }
      with lgt^ do
      begin
        if pro_typ <> nil then                         { For a function with complex type result ... }
        begin
          if not pro_typ^.typ_simple then              { ... we set the address return flag }
            lgt_status := lgt_status + [lgt_add]
        end
        else lgt^.lgt_typ := typ_std[form_null];
        lgt_pro := pr                                  { Set the procedure descriptor }
      end
    end;
  end;
  if lgt = nil then                                    { On error ... (a message should be already emitted) }
    lgt := LGT_NEW_ECONST( typ_std[form_wild], 0 );    { ... we return a wild constant }
  CALL_INDIRECT_PROC := lgt
end CALL_INDIRECT_PROC;



function CALL_GENERIC( ip: ide_ptr; bfnc: boolean ): lgt_ptr;
const
  mdnam = 'CALG';

var
  found:            boolean;
  npa, is:          integer;
  p1:               ide_ptr;
  lgt0, lgt1, lgt2: lgt_ptr;

begin
  lgt0 := nil;
  npa := 0;
  with sy_sym do
  begin
    { In first we build the actual parameter list in the stack }
    if sy = lparen then
    begin
      repeat
        INSYMBOL;                              { Gobble up the "(" or "," }
        lgt2 := EXPRESSION;                    { Get an actual }
        { Perform the parameter linking }
        if lgt0 = nil then lgt0 := lgt2 else lgt1^.lgt_nxt := lgt2;
        lgt1 := lgt2;
        npa := npa + 1;
        if (sy <> comma) and (sy <> rparen) then
          SRC_ERROR( mdnam, 24, e_error )
      until sy <> comma;
      INSYMBOL;                                { Gobble the ")" }
    end;
    lgt2 := GENERATE_CALL( ip, lgt0, npa )
  end;
  if lgt2 = nil then
    { Simule a wild variable reference to continue the compilation }
    lgt2 := LGT_NEW_IDREF( ide_udptr[cla_varbl], nil )
  else
    if (lgt2^.lgt_typ = nil) and bfnc then     { Error: Should be a function }
    begin
      SRC_ERROR( mdnam, 73, e_severe );
      lgt2^.lgt_typ := typ_std[form_wild]
    end;
  CALL_GENERIC := lgt2
end CALL_GENERIC;



function OPEN_CALL( ifnc: integer ): lgt_ptr;
{ Call for open (0), reset(1), rewrite(2), append(3).
}
const
  mdnam = 'OPEN';

var

  bpar, buse:            boolean;
  npa, imd, isz:         integer;
  ip:                    ide_ptr;
  ty:                    typ_ptr;
  pg:                    gen_ptr;
  lgt, lgtc, lgth, lgtl: lgt_ptr;

begin
  lgt := nil;
  ip := IDE_SEARCH_FROM_NAMEID( iof_std_open );
  if ip <> nil then
  with sy_sym do
  begin
    if sy = lparen then INSYMBOL
                   else SRC_ERROR( mdnam, 22, e_error );
    { Get the file variable specification }
    lgth := EXPRESSION_TYPE( typ_std[form_wfile] );
    { Get the file componante size }
    ty   := lgth^.lgt_typ^.typ_eltype;
    if lgth^.lgt_typ = typ_std[form_file] then
      isz := 0                                 { Text file }
    else
    begin                                      { Not a text file }
      if ty <> nil then isz := ABS( ty^.typ_size );
      if isz = 0 then isz := 1
    end;
    lgtl := LGT_NEW_ECONST( typ_std[form_int], isz );
    lgth^.lgt_nxt := lgtl;
    npa  := 2;
    { Set the open flag mode }
    case ifnc of
      1: { reset }   imd := 1;
      2: { rewrite } imd := 2;
      3: { append }  imd := 6;
    otherwise
      imd := 0;
    end;
    if imd <> 0 then
    begin
      if sy = comma then
      begin
        INSYMBOL;
        { Get the filename specification ( in standard a string ) }
        lgtc := EXPRESSION;
        lgtl^.lgt_nxt := lgtc;
        lgtl := lgtc;
        npa := npa + 1
      end;      
      lgtc := LGT_NEW_ECONST( typ_std[form_int], imd );
      lgtl^.lgt_nxt := lgtc;
      lgtl := lgtc;
      npa  := npa + 1
    end;
    { Get each user specified parameter }
    while sy_sym.sy = comma do
    begin
      INSYMBOL;
      lgtc := EXPRESSION;
      lgtl^.lgt_nxt := lgtc;
      lgtl := lgtc;
      npa := npa + 1
    end;
    pg := ip^.ide_gfirst;
    { Look for the good i/o procedure }
    GENERIC_SEARCH( ip^.ide_name^, npa, pg, lgth );
    if pg <> nil then with pg^ do
      if gen_proc <> nil then
      begin                                    { Procedure is found => generate a call }
        lgt := LGT_NEW_CALL( gen_proc^.pro_typ, gen_proc, lgth );
        CALL_SETTING( lgt )                    { Complete the call }
      end;

    if sy_sym.sy = rparen then INSYMBOL
                          else SRC_ERROR( mdnam, 23, e_error );
  end;
  OPEN_CALL := lgt
end OPEN_CALL;



function READWRITE_CALL( dfi, psel, pio1, pio2, peoln: ide_ptr ): lgt_ptr;
const
  mdnam = 'RWIO';

var
  bpar, buse, binf: boolean;
  npa:              integer;
  pio:              ide_ptr;
  pg:               gen_ptr;
  lgth, lgtl, lgtf, lgtv, lgtfh, lgtfl, lgtp: lgt_ptr;


begin
  lgth  := nil;
  lgtf  := nil;
  bpar  := false;
  sy_label_flag := false;

  with sy_sym do
  begin
    pio := pio1;                               { Assume text mode }
    if sy = lparen then
    begin                                      { Some parameters are given }
      binf := false;                           { Text mode }
      buse := true;                            { Set flag for parameter already set in lgtv }
      bpar := true;                            { With parameter list }
      INSYMBOL;                                { Gobble up the "(" }
      lgtv := EXPRESSION;
      if dfi = nil then
      begin                                    { For READV or WRITEV }
        lgtf := lgtv;                          { Keep virtual file reference }
        npa := 1;
        if sy = colon then
        begin
          lgtl := lgtf;
          while sy = colon do
          begin
            INSYMBOL;                          { Gobble up the format specification }
            lgtp := EXPRESSION;                { Get an additionel parameter. }
            lgtl^.lgt_nxt := lgtp;
            lgtl := lgtp;
            npa := npa + 1
          end;
        end;
        if sy = rparen then
        { If no object specification list }
        begin  bpar := false; INSYMBOL  end    { Go out of "( ... )" }
        else
          if sy <> comma then SRC_ERROR( mdnam, 29, e_error );
        buse := false
      end
      else
      begin                                    { READ, WRITE, READLN, WRITELN }
        if COMP_TYPE( lgtv^.lgt_typ, typ_std[form_wfile], false ) then
        begin                                  { First parameter is a file for i/o }
          lgtf := lgtv;                        { Keep this file reference }
          { and set the related binary or text mode flag }
          if lgtf^.lgt_typ <> typ_std[form_file] then pio := pio2;     { Binary }
          { If no object specification list }
          if sy = rparen then
          begin  bpar := false; INSYMBOL  end  { Go out of "( ... )" }
          else
            if sy <> comma then SRC_ERROR( mdnam, 29, e_error );

          buse := false                        { Set flag for no parameter is already set in lgtv }
        end
      end
    end
    else
      if dfi = nil then SRC_ERROR( mdnam, 22, e_error );       { READV or WRITEV }

    if  psel <> nil then psel  := IDE_SEARCH_FROM_NAMEID( psel );
    if  pio  <> nil then pio   := IDE_SEARCH_FROM_NAMEID( pio );
    if peoln <> nil then peoln := IDE_SEARCH_FROM_NAMEID( peoln );

    if lgtf = nil then lgtf := LGT_NEW_IDREF( dfi, nil );

    { Generate the file selection as the first statement }
    lgth := EXP_GENOPER( psel^.ide_name^, psel^.ide_gfirst, lgtf );
    lgtl := lgth;

    if bpar then
    begin                                      { Generate all input or output of each object }
      while buse or (sy = comma) do
      begin
        if not buse then
        begin
          INSYMBOL;                            { Gobble up comma }
          lgtv := EXPRESSION
        end
        else buse := false;
        lgtfh := nil;
        npa   := 1;
        while sy = colon do
        begin
          INSYMBOL;                            { Gobble up the format specification }
          lgtp := EXPRESSION;                  { Get a format expr. }
          if lgtfh = nil then lgtfh := lgtp
                         else lgtfl^.lgt_nxt := lgtp;
          lgtfl := lgtp;
          npa := npa + 1
        end;
        lgtv^.lgt_nxt := lgtfh;
        pg := pio^.ide_gfirst;
        { Look for the good i/o procedure }
        GENERIC_SEARCH( pio^.ide_name^, npa, pg, lgtv );
        if pg <> nil then with pg^ do
        begin
          if gen_proc <> nil then
          begin                                { Procedure is found => generate a call }
            lgtfh := LGT_NEW_CALL( gen_proc^.pro_typ, gen_proc, lgtv );
            CALL_SETTING( lgtfh )              { complete the call }
          end;
          lgtl^.lgt_nxt := lgtfh;
          lgtl := lgtfh
        end
      end;
      if sy = rparen then INSYMBOL
                     else SRC_ERROR( mdnam, 23, e_error )
    end;

    { For READLN and WRITELN generate the appropriate EOLN managment }
    if peoln <> nil then
    begin
      pg := peoln^.ide_gfirst;
      { Look for the good eoln procedure }
      GENERIC_SEARCH( peoln^.ide_name^, 0, pg, nil );
      if pg <> nil then with pg^ do
      begin
        if gen_proc <> nil then
        begin                                  { Procedure is found => generate a call }
          lgtfh := LGT_NEW_CALL( gen_proc^.pro_typ, gen_proc, nil );
          CALL_SETTING( lgtfh )                { Complete the call }
        end;
        lgtl^.lgt_nxt := lgtfh;
        lgtl := lgtfh
      end
    end
  end;
  if lgtl <> lgth then
  begin                                        { We must generate a sequence node }
    LGT_NEW( lgth, nil, lgt_ctlflow, lgth );
    lgth^.lgt_stm := stm_sequence
  end;
  sy_label_flag := true;
  READWRITE_CALL := lgth
end READWRITE_CALL;



function USER_STATE_CALL( ip: ide_ptr ): lgt_ptr;
{ User Defined Statement Management.
}
const
  mdnam = 'USTA';

var
  bspc, bcus, bpar:            boolean;
  npa:                         integer;
  psel, psta, pend:            ide_ptr;
  lgth, lgtl, lgtf, lgtp, lgt: lgt_ptr;
  ips:                         sta_ptr;


  function GET_STATE_EFF_LIST: lgt_ptr;
  var
    lgth, lgtl, lgtp: lgt_ptr;

  begin
    lgth := nil;
    lgtl := nil;
    npa  :=   0;
    with sy_sym do
    begin
      sy := colon;                             { Simule a colon to start the source psub-parameter scan }
      while sy = colon do
      begin
        INSYMBOL;                              { Gobble up the separator }
        lgtp := EXPRESSION;                    { Get the effective parameter expression ... }
        if lgtl = nil then lgth := lgtp        { ... and queue it in the parameter list }
                      else lgtl^.lgt_nxt := lgtp;
        lgtl := lgtp;
        npa := npa + 1                         { Update the sub-parameter count }
      end
    end;
    GET_STATE_EFF_LIST := lgth                 { Return the parameter list }
  end GET_STATE_EFF_LIST;


begin { USER_STATE_CALL }
  lgth :=   nil;                               { Init the call list to the empty state }
  lgtl :=   nil;
  lgtf :=   nil;                               { Assume no Context/File expr. specified }
  lgtp :=   nil;
  bpar := false;                               { Assume without parm list }
  bspc := false;                               { Assume default context until shown otherwise }
  bcus := false;                               { Assume User Context/File was not already used }
  sy_label_flag := false;
  ips := ip^.ide_stafirst;                     { Get the list of definitions  to scan }
  with sy_sym do
  begin
    if sy = lparen then                        { We have a parameter(s) list }
    begin                                      { Some parameters are given }
      bpar := true;                            { Flags the parameter list scan }
      lgtp := GET_STATE_EFF_LIST               { Get the first effective parameter - with possible sub-parameters }
    end;
    { Loop to locate the appropriate statement definition }
    while ips <> nil do
    with ips^ do
    begin
      { Stop the Search on first definition without reference type }
    exit if (sta_otyp = nil) or (lgtp = nil);
      { A context type (for a context effective parameter) is Used in this definition }
      bspc := COMP_TYPE( lgtp^.lgt_typ, sta_otyp, false );
    exit if bspc;                              { The specified context is compatible }
      { Stop the Search on first definition with a default reference type parameter }
    exit if sta_dfcntx <> nil;
      ips := sta_nxt                           { Continue to the next definition }
    end;

    if ips = nil then
    begin                                      { We cannot find an Appropriate Statement Definition }
      SRC_ERROR_S( mdnam, 41, e_severe, ip^.ide_name^ );
      SKIP_SYMBOL( rparen );                   { On error Skip all other item(s) in the parameter list ... }
      USER_STATE_CALL := nil                   { ... and return a NIL operator }
    end
    else
    with ips^ do
    begin                                      { We have found an appropriate definition }
      { Get all Actual Statement Generic Entries }
      if sta_select <> nil then psel := IDE_SEARCH_FROM_NAMEID( sta_select )
                           else psel := nil;
      if sta_prstat <> nil then psta := IDE_SEARCH_FROM_NAMEID( sta_prstat )
                           else psta := nil;
      if sta_ndstat <> nil then pend := IDE_SEARCH_FROM_NAMEID( sta_ndstat )
                           else pend := nil;

      { We are ready to scan the complete Parameter list }
      if bpar and (sy = rparen) then
      begin  INSYMBOL; bpar := false  end;     { The parameter list is finished }

      if bspc then
      begin                                    { Keep the Specified Context/File }
        lgtf := lgtp;                          { Set this first Effective Parameter as the current Context/File ... }
        lgt  := lgtf;                          { ... and prepare it for possible selection Call }
        lgtp :=  nil;                          { Flags parameter as used }
        if sy <> comma then SRC_ERROR( mdnam, 29, e_error )
      end
      else
      if sta_dfcntx <> nil then                { We Used a Provided Default Context/File }
      begin
        npa := 1;                              { Set the default parameter count for Context/File selection }
        if sta_dfrs then begin  sta_dfrs := false; lgt := sta_dfcntx  end
                    else lgt := LGT_LINK( sta_dfcntx )
      end
      else
      begin  npa := 0; lgt := nil  end;        { No Context/File was used }

      if psel <> nil then                      { When we are using the select mode, Call the select Entry }
      begin
        lgth := GENERATE_CALL( psel, lgt, npa );
        lgtl := lgth;
        if bspc then bcus := true              { Flag the Context/File parameter as used }
      end;


      if bpar then
      begin                                    { Parameters (not of Context/File) are provided }
        repeat                                 { Loop on all parameters (objects) of the statement }
          { Get the effective parameter (with possible list of sub-parameter) list }
          if lgtp = nil then lgtp := GET_STATE_EFF_LIST;       { It is already taken when context parm. was not given }
          if sta_rcnt then
          begin { For the repeat context mode, we insert the context expression at the begining }
            if bspc then                       { Context/File was provided }
              if bcus then lgt := LGT_LINK( lgtf )
                      else begin  bcus := true; lgt := lgtf  end
            else
              if sta_dfrs then begin  sta_dfrs := false; lgt := sta_dfcntx  end
                          else lgt := LGT_LINK( sta_dfcntx );
            lgt^.lgt_nxt := lgtp;
            lgtp := lgt
          end;
          { Call the Action Statement function }
          lgt := GENERATE_CALL( psta, lgtp, npa );
          { Append the call in the statement list }
          if lgt <> nil then
          begin
            if lgtl = nil then lgth := lgt
                          else lgtl^.lgt_nxt := lgt;
            lgtl := lgt
          end;
          lgtp := nil                          { Parameter is just used }
        until sy <> comma;                     { The statement parameter list must be ended by semicolon }

        if sy <> rparen then
        begin
          SRC_ERROR( mdnam, 34, e_severe );
          SKIP_SYMBOL( semicolon )
        end else INSYMBOL
      end { if bpar then ... };

      if pend <> nil then                      { When a end generic is specified we must call it }
      begin
        if sta_rcnt then                       { When the repeat mode was specified }
        begin                                  { For the repeat context mode, we insert the context expression at the begining }
          npa := 1;
          if bspc then                         { Context/File was provided }
            if bcus then lgtp := LGT_LINK( lgtf )
                    else begin  bcus := true; lgtp := lgtf  end
          else
            if sta_dfrs then begin  sta_dfrs := false; lgtp := sta_dfcntx  end
                        else lgtp := LGT_LINK( sta_dfcntx )
        end
        else
        begin  npa := 0; lgtp := nil  end;
        lgt := GENERATE_CALL( pend, lgtp, npa );
        if lgtl = nil then lgth := lgt
                      else lgtl^.lgt_nxt := lgt;
        lgtl := lgt
      end
    end { with ips^ do };
    { We must goup all execution node to one }
    if lgtl <> lgth then
    begin                                      { We must generate a sequence node }
      LGT_NEW( lgth, nil, lgt_ctlflow, lgth );
      lgth^.lgt_stm := stm_sequence
    end
  end { with sy_sym do };
  sy_label_flag := true;
  USER_STATE_CALL := lgth
end USER_STATE_CALL;



function NEW_CALL( new_fnc: pro_ptr ): lgt_ptr;
{ To generate a dynamic allocation.
}
const
  mdnam = 'NEWC';

var
  iq: ide_ptr;
  newproc: pro_ptr;
  ty, target_ty: typ_ptr;
  target, lgth1, lgth2, lgtl1, lgtl2, lgt1, lgt2, lgt3, lgt4: lgt_ptr;
  ish, jsh: integer;

begin
  lgth1 := nil;
  lgth2 := nil;
  lgt2  := nil;
  ty    := nil;
  with sy_sym do
  begin
    if sy = lparen then INSYMBOL
                   else SRC_ERROR( mdnam, 22, e_error );
    { Get a pointer expression }
    target := EXPRESSION_TYPE( typ_std[form_pointer] );
    if target <> nil then
    with target^ do
      if lgt_out in lgt_status then            { Pointer object with write access }
        target_ty := lgt_typ;                  { Get the related pointer type }
        if target_ty <> nil then
          with target_ty^ do
            if typ_form = form_pointer then ty := typ_eltype
                                       else ty := nil;

    if ty <> nil then                          { Legal pointer of known type }
    with ty^ do
    begin                                      { Ok for a full allocation }
      ish := typ_size;
      if (typ_parmlst <> nil) or typ_hasidsc then      { Management for type with parameter(s) }
      begin                                    { Allocation for a type with formal parameter }
(*
with typ_ide^.ide_name^ do
WRITELN( ' for type id = "', s:l, '" : NEW object with parm = ', typ_parmlst <> nil, ' hasidsc = ', typ_hasidsc );
*)
        if typ_parmlst <> nil then
        begin                                  { When the type is parametrized }
          iq := typ_parmlst;
          while (iq <> nil) do                 { if iq <> nil then parameters exists !!! }
          begin                                { Link each parameter with this expression value }
            if sy = comma then INSYMBOL;       { Gobble the first comma }
            lgt1 := EXPRESSION_TYPE( iq^.ide_typ );
            if lgt1^.lgt_kind = lgt_empty then
            with lgt1^ do                      { Type parameter is not present }
            begin                              { We must use a default value }
              lgt_kind := lgt_const;
              lgt_cte  := iq^.ide_cteval;
              if lgt_cte = nil then
                { Undefined default value for a type parameter }
                SRC_ERROR( mdnam, 126, e_severe );
              VAL_NEW( lgt_cte, nil {unused} );
              lgt_lide := nil;
              lgt_typ := iq^.ide_typ
            end;

            if lgt1^.lgt_kind <> lgt_const then
            begin                              { Parameter is an expression }
              LGT_NEW( lgt4, iq^.ide_typ, lgt_varbl, nil );
              lgt4^.lgt_nxt := lgt1;
              ALL_NEW( lgt4^.lgt_alloc, iq^.ide_typ, nil, var_tmp );
              LGT_NEW( lgt1, iq^.ide_typ, lgt_codep, lgt4 );
              lgt1^.lgt_pcode := pcod_istore;
              { Creates a descriptor list value and set formal link }
              if lgth1 = nil then lgth1 := lgt1
                             else lgtl1^.lgt_nxt := lgt1;
              lgtl1 := lgt1                    { Keep the previous link }
            end
            else lgt4 := lgt1;

            with iq^ do
            begin
              { Set the dynamic link for the type parameter identifier }
              ide_tlink2 := lgt4;
              ide_tkind  := (* tpa_eval; *) tpa_dycte; (* /// *)
              { Prepare the descriptor assignement }
              LGT_NEW( lgt3, ide_typ, lgt_indir, LGT_LINK( target ) );
              lgt3^.lgt_disp := ide_toffset;   { Set tparam offset }
              if lgt4^.lgt_kind = lgt_const then lgt3^.lgt_nxt := lgt4
                                            else lgt3^.lgt_nxt := LGT_LINK( lgt4 );
              LGT_NEW( lgt4, ide_typ, lgt_codep, lgt3 );
              lgt4^.lgt_pcode := pcod_istore;
              if lgth2 = nil then lgth2 := lgt4
                             else lgtl2^.lgt_nxt := lgt4;
              lgtl2 := lgt4
            end;


            if (sy <> comma) and (sy <> rparen) then
              SRC_ERROR( mdnam, 34, e_error );
            iq := iq^.ide_nxt
          end                                  { While iq }
        end;                                   { if typ_parmlst <> nil then  }
        if sy = rparen then INSYMBOL
                       else SRC_ERROR( mdnam, 24, e_error );

        { Now we generates the size computing }
(*
WRITELN( 'NEW CALL typ_comp_size : ', typ_comp_size<>nil );
if typ_comp_size<>nil then LGT_WRITE( 8, 0, typ_comp_size );
*)
        lgt1 := LGT_TYPE_COMPUTE( typ_sizesrv, typ_comp_size, typ_size, nil );
(*
        if typ_comp_size = nil then
          lgt1 := LGT_NEW_ECONST( typ_std[form_int], typ_size )
        else
          lgt1 := LGT_TYPE_EVAL( typ_comp_size, nil );

WRITELN( ' Computed Size to allocate = ' );
LGT_WRITE( 8, 0, lgt1 );
WRITELN( ' ---' );
*)

        { We Must generate all parametrized type sub-object of the new allocated object }
        if typ_hasidsc then INIT_D_DYN( ty, target, lgth2, lgtl2, true );

        iq := typ_parmlst;                     { Do nothing when there is not parametrized object creation }
        { Loop on all type parameter to reset to tpa_sub state }
        while iq <> nil do
        begin
          iq^.ide_tkind  := tpa_sub;
          iq^.ide_tlink2 := nil;
          iq := iq^.ide_nxt
        end;

        { New/Newh_entry_proc should be defined by pas$basicdef and pas_*.std file }
        lgt2 := LGT_NEW_CALL( target_ty, new_fnc, lgt1 );

        { We must set the type descriptor }
        target^.lgt_nxt := lgt2;               { Link target with the call of NEW }
        { Generate the istore Optional }
        LGT_NEW( lgt2, target_ty, lgt_codep, target );
        lgt2^.lgt_pcode := pcod_istore;

        { Attach the istore: malloc(n) -> pv }
        if lgth1 = nil then lgth1 := lgt2
                       else lgtl1^.lgt_nxt := lgt2;
        lgt2^.lgt_nxt := lgth2;                { Attach it to the descriptor set list }
        LGT_NEW( lgth2, nil, lgt_ctlflow, lgth1 );
        lgth2^.lgt_stm := stm_sequence
      end
      else                                     { Into with ty^ => the object to allocate }
      begin                                    { For type without parameters (Standard Pascal NEW call) }
        ish := typ_size;
        if ish <= 0 then SRC_ERROR( mdnam, 130, e_severe );
        if typ_form = form_record then
        begin                                  { Compute the size to allocate }
          lgt1 := typ_recvar;                  { Get info. for the first variant }
          if lgt1 <> nil then                  { Skip any LINK for derived type definition }
            if lgt1^.lgt_kind = lgt_null then lgt1 := lgt1^.lgt_parmlst;
          while (sy = comma) and (lgt1 <> nil) do
          begin
            lgt2 := lgt1^.lgt_parmlst;         { Get the case table pointer }
            lgt3 := lgt2^.lgt_nxt;             { Get the other node }
            INSYMBOL;                          { Gobble up the comma }
            { Get the selector value }
            lgt4 := EXPRESSION_TYPE( lgt3^.lgt_nxt^.lgt_typ );
            jsh := -1;
            with lgt4^ do
            begin
              if lgt_kind = lgt_const then     { Get the selector value }
                jsh := lgt_cte^.val_ival
              else
                SRC_ERROR( mdnam, 181, e_error );
              LGT_FREE_TREE( lgt4 )
            end;
            with lgt2^, lgt_cte^ do
            begin                              { With the case table }
              jsh := jsh - lgt_disp;
              if (jsh >= 0) and (jsh < val_size) then
              begin
                jsh := ORD( lgt2^.lgt_cte^.val_tab^.lw[jsh] );
                if jsh >= 0 then
                  lgt3 := lgt3^.lgt_nxt^.lgt_nxt;      { Get the first variant ref. }
                while (jsh > 0) and (lgt3 <> nil) do
                begin
                  jsh := jsh - 1;
                  lgt3 := lgt3^.lgt_nxt
                end;
                if lgt3 = nil then lgt3 := lgt2^.lgt_nxt
              end
            end;
            with lgt3^.lgt_typ^ do
            begin
              lgt1 := typ_recvar;
              ish  := typ_size
            end
          end
        end;
        if sy = rparen then INSYMBOL           { Gobble up ")" }
                       else begin SRC_ERROR( mdnam, 23, e_error );
                                  SKIP_SYMBOL( rparen )
                            end;
        { Generate the istore }
        LGT_NEW( lgth2, target_ty, lgt_codep, target );
        lgth2^.lgt_pcode := pcod_istore;
        lgt1 := LGT_NEW_ECONST( typ_std[form_int], ish );
        { new/newh_entry_proc should be defined by pas$basicdef and pas_*.std file }
        lgt2 := LGT_NEW_CALL( target_ty, new_fnc, lgt1 );
        target^.lgt_nxt := lgt2
      end
    end
    else                                       { if ty^ = nil then }
    begin                                      { No allocation to do one previous error }
      LGT_FREE_TREE( target );
      SRC_ERROR( mdnam, 180, e_severe )
    end                                        { if ty^ = nil then };
  end                                          { with sy_sym do };
  NEW_CALL := lgth2
end NEW_CALL;



function  DISPOSE_CALL( free_fnc: pro_ptr ): lgt_ptr;
const
  mdnam = 'FREE';

var
  lgp, lgr: lgt_ptr;

begin
  with sy_sym do
  begin
    if sy = lparen then INSYMBOL
                   else SRC_ERROR( mdnam, 22, e_error );
    { Get a pointer expression }
    lgp := EXPRESSION_TYPE( typ_std[form_pointer] );
    lgr := LGT_NEW_CALL( nil, free_fnc, lgp );
    if sy = comma then SKIP_SYMBOL( rparen );
    if sy = rparen then INSYMBOL           { Gobble up ")" }
                   else begin SRC_ERROR( mdnam, 23, e_error );
                              SKIP_SYMBOL( rparen )
                        end
  end;
  DISPOSE_CALL := lgr
end DISPOSE_CALL;



function GEN_LIST_AGREGAT_SET( ty: typ_ptr; bcte: boolean ): lgt_ptr;
{ To generate a constant or Expression Set Construction.
}
const
  mdnam = 'SAGR';

var
  i, iv, jv, max, mmax:   integer;
  j:                      0..max_setw-1;
  tyel, tyse:             typ_ptr;
  lgtc, lgth, lgtl, lgtv: lgt_ptr;
  bconst, bfirst:         boolean;
  sval:                   set_table;

begin
  bfirst := true;
  INSYMBOL;                                     { Gobble up the "[" }
  with sy_sym do
  if sy = rbrack then
  begin                                         { Empty set }
    LGT_NEW( lgtv, typ_std[form_wwset], lgt_const, nil );
    if ty <> nil then lgtv^.lgt_typ := ty;
    VAL_NEW( lgtv^.lgt_cte, lgtv^.lgt_typ );
    with lgtv^.lgt_cte^ do
    begin
      val_size    := 0;
      val_set.ssv := []
    end
  end
  else
  begin                                         { Not empty set }
    lgtv   := nil;
    lgth   := nil;
    lgtl   := nil;
    bconst := false;                            { Assume no constant part until shown otherwise }
    mmax   := -1;                               { Assume empty set }
    for i := 0 to dst_seti - 1 do sval[i].ssv := [];
    tyse   :=  ty;
    tyel   := nil;
    if ty <> nil then
    with ty^ do
    begin
      tyel := typ_seltype;
      max  := typ_cardinality
    end;

    { Collect all SET expressions }
    repeat
      if bfirst then bfirst := false
                else INSYMBOL;                  { Gobble up the separator }
      { Get one expression }
      if tyel = nil then
      begin                                     { We must define a type for the set elements }
        { Get an enummerated expression }
        lgtc := EXPRESSION_TYPE( typ_std[form_ennum] );
        if lgtc^.lgt_kind = lgt_empty then
        begin
          SRC_ERROR( mdnam, 137, e_error );
          LGT_FREE( lgtc )
        end
        else
        begin
          tyel := lgtc^.lgt_typ;                { Define the Type of the Set Element }
          if tyel <> nil then
          begin
            max := -1;
            while (tyel <> nil) and (max < 0) do
              case tyel^.typ_form of
                form_char, form_lit, form_int: max := tyel^.typ_max;
                form_range: tyel := tyel^.typ_parent;
              otherwise
                SRC_ERROR( mdnam, 110, e_error );
                tyel := typ_std[form_int];
                max := 0
              end;
           if max < 0 then SRC_ERROR( mdnam, 110, e_error )
           else
              { We limit the cardinality of any set at the dst_seta Value }
              if max >= dst_seta then max := dst_seta - 1
          end;
          if max < 0 then tyel := nil;

          { Build the SET related type if it is not already defined }
          if (ty = nil) and (tyel <> nil) then
          begin                                 { Used for the dynamic part when it is existing }
            if max < dst_setw then IDE_NEW_TYP( form_set, tyse )
                              else IDE_NEW_TYP( form_lset, tyse );
            with tyse^ do
            begin
              typ_seltype     := tyel;
              typ_cardinality := max + 1;
              if max < dst_setw then
                typ_align     := typ_std[form_wset]^.typ_align
              else
                typ_align     := typ_std[form_wlset]^.typ_align;
              { Get the set size in word set element }
              iv := (typ_cardinality + dst_setw - 1) div dst_setw;
              { Convert size in byte }
              typ_size := (iv*dst_setw + 7) div 8
            end
          end
        end
      end
      else                                      { Get the type element enummerated expression }
        lgtc := EXPRESSION_TYPE( tyel );

      if lgtc^.lgt_kind = lgt_const then
      begin                                     { Constant expression found }
        bconst := true;                         { Set as some constante part exist }
        iv := LGT_GET_ECONST( lgtc, -1 );
        LGT_FREE( lgtc );
        if sy = twodot then
        begin { Manage the range notation : iv is the minimum }
          INSYMBOL;
          lgtc := EXPRESSION_TYPE( tyel );      { Get the maximum value }
          if lgtc^.lgt_kind <> lgt_const then
          begin                                 { We must have a constant value }
            SRC_ERROR( mdnam, 53, e_error );
            jv := iv
          end
          else jv := LGT_GET_ECONST( lgtc, iv );
          LGT_FREE( lgtc )
        end else jv := iv;
        if (iv < 0) or (iv > max) or (jv < iv) or (jv > max) then
        begin
          SRC_ERROR( mdnam, 138, e_error );
          jv := iv - 1                          { To force skip the set setting }
        end;
        for ii := iv to jv do
        begin
          if ii > mmax then mmax := ii;
          i := ii div dst_setw;                 { Get the array table index }
          j := ii rem dst_setw;                 { Get the set element in array }
          if j in sval[i].ssv then SRC_ERROR( mdnam, 139, e_error )
                              else sval[i].ssv := sval[i].ssv + [j]
        end
      end
      else if lgtc^.lgt_kind <> lgt_empty then
      begin                                     { Expression value }
        if bcte then SRC_ERROR( mdnam, 140, e_severe );
        if tyse^.typ_simple then
        begin                                   { Simple set }
          lgtc := LGT_NEW_CODE( pcod_setgen, lgtc );
          lgtc^.lgt_typ := tyse;
          if lgtv <> nil then
          begin
            lgtv^.lgt_nxt := lgtc;
            lgtv := LGT_NEW_CODE( pcod_bis, lgtv );
            lgtv^.lgt_typ := tyse
          end
          else lgtv := lgtc
        end
        else
        begin
          lgtc := LGT_NEW_CALL( tyse, set_entry_proc, lgtc );
          CALL_SETTING( lgtc );
          if lgtv <> nil then
          begin
            lgtv^.lgt_nxt := lgtc;
            lgtv := EXP_GENOP( add_op, lgtv );
            lgtv^.lgt_typ := tyse
          end
          else lgtv := lgtc
        end
      end
      else
      begin                                     { Illegal null value }
        SRC_ERROR( mdnam, 141, e_error );
        LGT_FREE( lgtc )
      end
    until sy <> comma;                          { End of repeat on all SET values }

    if bconst then
    begin                                       { Some constante value(s) was specified }
      if (lgtv = nil) and (tyse <> nil) and (ty = nil) then
      with tyse^ do
      begin                                     { Constant Only : We can reduce the Allocation as Used }
        typ_cardinality := mmax + 1;
        max := mmax;
        if mmax >= dst_setw then
        begin
          typ_simple := false;                  { Confirm a Large Set type }
          typ_form   := form_lset;
          typ_size   := ((typ_cardinality + dst_setw - 1) div dst_setw)*
                        typ_std[form_wset]^.typ_size;
          typ_align.int := typ_std[form_wlset]^.typ_align.int
        end
        else
        begin
          typ_simple := true;                   { Force Small Set type }
          typ_form   := form_set;
          typ_size   := (typ_cardinality + 7) div 8;
          case typ_size of
            1: typ_align.int := 0;
            2: typ_align.int := 1;
          otherwise
            typ_size := 4;
            typ_align.int := typ_std[form_wset]^.typ_align.int
          end
        end;
      end;

      if max < dst_setw then                    { Constant part can be set in form_wset cte }
      begin
        lgtc := LGT_NEW_ECONST( tyse, sval[0].siv )
      end
      else
      begin                                     { Generate a large set constant }
        LGT_NEW( lgtc, tyse, lgt_const, nil );
        VAL_NEW( lgtc^.lgt_cte, tyse );
        with lgtc^.lgt_cte^ do
        begin
          NEW( val_sar );
          val_size := (mmax + dst_setw) div dst_setw;
          for i := 0 to val_size - 1 do
            val_sar^[i].siv := sval[i].siv
        end
      end
    end;

    if mmax >= 0 then                           { A constant value was specified }
      if lgtv = nil then                        { Constant Only }
        lgtv := lgtc
      else
      begin                                     { Constant part + variable part }
        lgtc^.lgt_nxt := lgtv;
        lgtv := EXP_GENOP( add_op, lgtc );
        lgtv^.lgt_typ := tyse
      end
  end;
  GEN_LIST_AGREGAT_SET := lgtv
end GEN_LIST_AGREGAT_SET;




function  GET_AGREGATE( ty: typ_ptr ): lgt_ptr;
{ To generate any Agregat (Structured object value constructor).
}
const
  mdnam = 'AGRE';

var
  sep:                          symbol;
  bcte:                        boolean;
  dim, dim_descr, els, size:   integer;
  ipf:                         ide_ptr;
  tyc:                         typ_ptr;
  lgr, lgth, lgtl, lgtc, lgtt: lgt_ptr;
  pv, pvl:                     val_ptr;


  procedure GEN_LIST_AGREGAT_TAB( ty: typ_ptr );
  const
    mdnam = 'TAGR';

  var
    min, i:      integer;
    lgtc, lgta:  lgt_ptr;
    tyx, tye:    typ_ptr;

  begin
    with sy_sym do
    begin
      with ty^ do
      begin
        tyx  := typ_indtype;                    { Get the array index type }
        tye  := typ_aeltype;                    { Get the array element type }
      end;

      if tyx <>  nil then
      with tyx^ do
        if typ_form <> form_range then
          if typ_unsigned then                  { Fixed array index limits }
            dim := (typ_umax + 1) - typ_umin
          else
            dim := typ_max - typ_min + 1
        else
        begin                                   { Parametrized Array }
          lgtc := LGT_TYPE_EVAL( typ_nvalue, nil );
          if lgtc^.lgt_kind = lgt_const then
          begin
            dim := lgtc^.lgt_cte^.val_ival;
            LGT_FREE( lgtc )
          end
          else SRC_ERROR( mdnam, 142, e_fatal )
        end
      else dim := 0;
      with ty^ do
        if typ_el_comp_size <> nil then
        begin
          lgtc := LGT_TYPE_EVAL( typ_el_comp_size, nil );
          if lgtc^.lgt_kind = lgt_const then
          begin                                 { Get the array element size }
            els := lgtc^.lgt_cte^.val_ival;
            LGT_FREE( lgtc )
          end
          else SRC_ERROR( mdnam, 142, e_fatal )
        end
        else els := typ_el_size;

      if tye = nil then dim := 0;

      i := 0;
      sy := comma;
      while (i < dim) and (sy = comma) do
      begin
        INSYMBOL;
        i := i + 1;
        if (sy = lbrack) or (sy = lparen) then
          { Sub_Agregat }
          lgtc := GET_AGREGATE( ty^.typ_aeltype )
        else
          lgtc := EXPRESSION_TYPE( ty^.typ_aeltype );
        if lgtc^.lgt_kind <> lgt_const then bcte := false;

        if lgth = nil then lgth := lgtc
                      else lgtl^.lgt_nxt := lgtc;
        lgtl := lgtc
      end;
      if i < dim then
        SRC_ERROR( mdnam, 144, e_severe )       { Some elements are missing }
      else
        if sy <> sep then
        begin                                   { Too many agregat elements, extra ignored }
          SRC_ERROR( mdnam, 146, e_error );
          SKIP_SYMBOL( sep )
        end
    end
  end GEN_LIST_AGREGAT_TAB;



  procedure GEN_LIST_AGREGAT_REC( ty: typ_ptr );
  const
    mdnam = 'RAGR';

  var
    disp, isel, imin, imax:      integer;
    lgtcase, lgtc, lgtab,
    lgtoth, lgtsel, lgt, lgtn:   lgt_ptr;
    ipf:                         ide_ptr;
    tab:                         tab_ptr;

  begin
    with sy_sym, ty^ do
    begin
      sy   := comma;                            { Simule a value separator }
      ipf  := typ_firstfield;
      { Get the main part of the record }
      while (sy = comma) and (ipf <> nil) do
      begin
        INSYMBOL;                               { Gobble up the separator }
        if (sy = lbrack) or (sy = lparen) then
        begin
          lgtc := GET_AGREGATE( ipf^.ide_typ )  { Sub_Agregat }
        end
        else
          lgtc := EXPRESSION_TYPE( ipf^.ide_typ );

        if lgtc^.lgt_kind <> lgt_const then bcte := false;

        if lgth = nil then lgth := lgtc
                      else lgtl^.lgt_nxt := lgtc;
        lgtl := lgtc;
        if ipf = typ_lastfield then ipf := nil
                               else ipf := ipf^.ide_nxt
      end;

      { Get Possible Case definition (Can be link by a lgt_null node)  }
      lgtcase := typ_recvar;
      if lgtcase <> nil then
        if lgtcase^.lgt_kind = lgt_null then lgtcase := lgtcase^.lgt_parmlst;

      if lgtcase = nil then
      begin                                     { We are at end of the record - or at end of the last variant }
        if ipf <> nil then
          SRC_ERROR( mdnam, 144, e_severe )     { Some data are missing  ? }
        else                                    { Too many data ? }
          if sy <> sep then
          begin                                 { Too many agregat elements, extra ignored }
            SRC_ERROR( mdnam, 146, e_error );
            SKIP_SYMBOL( sep )
          end;
        return
      end;

      with lgtcase^ do
      begin                                     { We have some variants to manage }
        lgtab  := lgt_parmlst;                  { Get the case table lgt node }
        lgtoth := lgtab^.lgt_nxt;               { Get the other node }
        lgtsel := lgtoth^.lgt_nxt;              { Get the selector node }
        with lgtab^ do
        begin
          imin := lgt_disp;                     { Get the minimum value of the selector }
          if lgt_cte <> nil then
          with lgt_cte^ do
          begin                                 { Get the number of table entry }
            imax := val_size + imin - 1;
            tab  := val_tab                     { Get the table address }
          end
          else tab := nil
        end;
        if typ_parmlst <> nil then              { Record with type argument(s) }
        begin
          lgtc := LGT_TYPE_EVAL( lgtsel, nil );
          with lgtc^ do
            if lgt_kind <> lgt_const then SRC_ERROR( mdnam, 142, e_severe )
            else
            if lgt_cte <> nil then isel := lgt_cte^.val_ival
                              else isel := imin - 1;
          LGT_FREE( lgtc )
        end
        else                                    { No parameter - Classic Pascal case in a record }
        begin
          if sy = comma then INSYMBOL
                        else SRC_ERROR( mdnam, 29, e_severe );
          { Get the selector value - must be a constant }
          isel := EXP_GENNUM( lgtsel^.lgt_typ );
          if lgtsel^.lgt_lide <> nil then       { We must set a selector field }
          begin
            disp := lgtsel^.lgt_lide^.ide_offset;
            lgtc := LGT_NEW_ECONST( lgtsel^.lgt_typ, isel );
            { Set the target offset }
            lgtc^.lgt_disp := disp;

            if lgth = nil then lgth := lgtc
                          else lgtl^.lgt_nxt := lgtc;
            lgtl := lgtc
          end
        end;
        { Now isel is the selector value and the selector field id initialized }
        lgt := lgtsel^.lgt_nxt;                 { Assume the first variant }
        if (isel < imin) or (isel > imax) then  { othercase }
          lgt := lgtoth
        else
        begin
          isel := ORD( tab^.lw[isel-imin] );
          if isel < 0 then lgt := lgtoth
          else
          begin
            while (isel > 0) and (lgt <> nil) do
            begin
              lgt := lgt^.lgt_nxt; isel := isel - 1
            end;
            if lgt = nil then lgt := lgtoth
          end
        end;
        if lgt <> nil then
          if lgt^.lgt_typ <> nil then GEN_LIST_AGREGAT_REC( lgt^.lgt_typ )
      end
    end
  end GEN_LIST_AGREGAT_REC;



begin { GET_AGREGATE }
  with sy_sym, ty^ do
  if (typ_form = form_set) or (typ_form = form_lset) then
  begin
    if sy <> lbrack then SRC_ERROR( mdnam, 25, e_error );
    lgr := GEN_LIST_AGREGAT_SET( ty, false );
    if sy = rbrack then INSYMBOL
                   else SRC_ERROR( mdnam, 26, e_error )
  end
  else
  if typ_simple then
    SRC_ERROR( mdnam, 131, e_severe )
  else
  begin
    bcte := true;                               { Until shown otherwise }
    lgr  := nil;
    lgth := nil;
    lgtl := nil;
    if sy = lparen then sep := rparen
                   else sep := rbrack;
    size := typ_size;
    dim_descr := 0;                             { Initialize the Descriptor size (in elem.) }
    sy   := comma;

    if typ_parmlst <> nil then
    begin                                       { * Management of Type Parameters as front values in the Agregat * }
      ipf  := typ_parmlst;                      { Prepare the loop on all type formal parameters }
      if typ_subtype then
      begin                                     { For a subtype of a parametrised type }

        TYPE_PARM_CTE_INIT( ty, lgth, lgtl, dim_descr );
(*
        lgtt := typ_actual;                     { ... and get the head of actual expression list }
        if ipf <> nil then                      { Loop on all actual parameters }
        repeat
          with ipf^ do
          begin
            lgtc := LGT_TYPE_EVAL( lgtt, nil );
            { Force the cte. type to be conform with the type parameter declaration }
            lgtc^.lgt_typ := ide_typ;
            lgtc^.lgt_cte^.val_typ := ide_typ;
            if lgtc^.lgt_kind <> lgt_const then SRC_ERROR( mdnam, 132, e_severe )
                                           else lgtc^.lgt_cte^.val_size := ide_typ^.typ_size;
            lgtc^.lgt_disp := ide_toffset;      { Set the node offset }
            if lgth = nil then lgth := lgtc     { Append each node to the expression List (a queue) }
                          else lgtl^.lgt_nxt := lgtc;
            lgtl := lgtc;
            { Set the dynamic link for the type parameter identifier(s) }
            ide_tlink2 := lgtc;
            ide_tkind  := tpa_eval;             (* tpa_dycte; (* /// *)
(*          lgtt := lgtt^.lgt_nxt;              { Continue to the next }
            ipf  := ide_nxt
          end;
          dim_descr := dim_descr + 1            { Update the Descriptor Element Count }
        until (ipf = nil) or (lgtt = nil)
*)
      end
      else
      begin                                     { For a parametrised type }
        repeat
          INSYMBOL;                             { Gobble up the separator }
          with ipf^ do
          begin
            tyc  := ide_typ;                    { Get the type_parameter type }
            { Get the type_parameter value }
            lgtc := EXPRESSION_TYPE( tyc );
            with lgtc^ do
            begin
              if lgt_kind = lgt_empty then      { No actual value }
              begin                             { We must use a default value }
                lgt_kind := lgt_const;
                lgt_cte  := ide_cteval;
                { Undefined default value for a type argument ? }
                if lgt_cte = nil then SRC_ERROR_S( mdnam, 157, e_severe, ipf^.ide_name^ );
                VAL_NEW( lgt_cte, tyc );
                lgt_lide := nil;
                lgt_typ := tyc
              end
              else                              { Actual value must be a constant }
                if lgt_kind <> lgt_const then SRC_ERROR( mdnam, 132, e_severe );
              lgt_disp := ide_toffset           { Set the node offset }
            end;

            { Set the dynamic link for the type parameter identifier(s) }
            ide_tlink2 := lgtc;
            ide_tkind  := tpa_eval
          end;
          if lgth = nil then lgth := lgtc
                        else lgtl^.lgt_nxt := lgtc;
          lgtl := lgtc;

          ipf  := ipf^.ide_nxt;                 { Continue to the next }
          dim_descr := dim_descr + 1            { Update the Descriptor Element Count }
        until (ipf = nil) or (sy <> comma)
      end
    end;

    { Now we compute the object size }
    if (typ_parmlst <> nil) and (typ_comp_size <> nil) then
    begin
      lgtt := LGT_TYPE_EVAL( typ_comp_size, nil );
      if lgtt^.lgt_kind = lgt_const then
      begin                                     { Get the size in bytes and free the lgt record }
        size := lgtt^.lgt_cte^.val_ival;
        LGT_FREE( lgtt )
      end else SRC_ERROR( mdnam, 142, e_severe )
    end;

    { Get the list of value to put in the agregat }
    if sy <> comma then SRC_ERROR( mdnam, 29, e_error );

    case typ_form of
      form_lset, form_set:
        begin
          if sy = lparen then SRC_ERROR( mdnam, 133, e_error );
          lgtc := GEN_LIST_AGREGAT_SET( ty, false );
          if lgtc^.lgt_kind <> lgt_const then bcte := false;  

          if lgth = nil then lgth := lgtc
                        else lgtl^.lgt_nxt := lgtc;
          lgtl := lgtc
        end;

      form_variant, form_record:
        GEN_LIST_AGREGAT_REC( ty );

      form_array:
        GEN_LIST_AGREGAT_TAB( ty );

    otherwise
      SRC_ERROR( mdnam, 131, e_severe );
      SKIP_SYMBOL( sep )
    end;

    if sy = sep then INSYMBOL
                else SRC_ERROR( mdnam, 26, e_error );

    if typ_parmlst <> nil then TYPE_PARM_CTE_RELEASE( ty );
(*
    if typ_parmlst <> nil then (* /// *)
(*  begin
      { Loop on all type parameter to reset to tpa_sub state }
      ipf := typ_parmlst;
      while ipf <> nil do
      begin
        ipf^.ide_tkind := tpa_sub;
        ipf^.ide_tlink2 := nil;
        ipf := ipf^.ide_nxt
      end
    end;
*)

    { Now we Generate the Agregate val_rec List }
    if bcte then
    begin                                       { It is a constant agregat }
      LGT_NEW( lgr, ty, lgt_const, nil );
      case ty^.typ_form of
        form_array, form_conf, form_record:
          begin
            VAL_NEW( lgr^.lgt_cte, ty );
            lgr^.lgt_cte^.val_lst := nil;
            pvl := nil;
            with lgr^, lgt_cte^ do
            begin
              val_descr := dim_descr;
              val_size := size;                 { Set the total size of the agregat }
              while lgth <> nil do              { Loop on all value elements }
                with lgth^ do
                begin
                  lgtc := lgth;
                  pv := nil;
                  VAL_COPY( lgtc^.lgt_cte, pv, true );
                  if pvl = nil then lgr^.lgt_cte^.val_lst := pv
                               else pvl^.val_next := pv;
                  if ty^.typ_form <> form_record then
                    { Does not change the size of descriptor elements }
                    if dim_descr > 0 then dim_descr := dim_descr - 1
                                     else if pv^.val_kind = form_string then pv^.val_size := els - stri_stroffset
                                                                        else pv^.val_size := els;
                  pvl  := pv;
                  lgth := lgth^.lgt_nxt;
                  lgtc^.lgt_cte := nil;
                  LGT_FREE( lgtc )
                end
            end
          end;

      otherwise
        VAL_COPY( lgth^.lgt_cte, lgr^.lgt_cte, true );
        lgr^.lgt_cte^.val_descr := dim_descr
      end
    end
    else
    begin                                       { Agregate as some variable values }
      { The dynamic agregat is not implemented }
      SRC_ERROR( mdnam, 143, e_severe );
      LGT_FREE_TREE( lgth );
      lgr := LGT_NEW_ECONST( typ_std[form_wild], 0 )
    end
  end;
  GET_AGREGATE := lgr
end GET_AGREGATE;



function EXP_CONST_SET: lgt_ptr;
const
  mdnam = 'CSET';

var
  lgr: lgt_ptr;

begin
  lgr := GEN_LIST_AGREGAT_SET( nil, false );
  if sy_sym.sy = rbrack then INSYMBOL
                        else SRC_ERROR( mdnam, 26, e_error );
  EXP_CONST_SET := lgr
end EXP_CONST_SET;



function GET_PROCREF: pro_ptr;
const
  mdnam = 'GPRO';

var
  pw, pr: pro_ptr;

begin
  pr :=   nil;
  pw := owner;
  while (pw <> nil) and (pr = nil) do
    case pw^.pro_pkind of
      { We find the entry }
      pro_main, pro_decl, pro_global, pro_inline: pr := pw;
      { We continue the search }
      pro_block: pw := pw^.pro_owner;
    otherwise
      { Illegal return value reference }
      SRC_ERROR( mdnam, 171, e_severe );
      pw := nil
    end;
  GET_PROCREF := pr
end GET_PROCREF;



function EXP_GENERIC_REF( ty: typ_ptr ): lgt_ptr;
const
  mdnam = 'EXGE';

var
  ip:  ide_ptr;
  pr:  pro_ptr;
  pg:  gen_ptr;
  lgt: lgt_ptr;

begin
(*
if cmp_cmpdbg then
WRITELN( ' *** GENERIC REF' );
*)
  pr := nil;                                                   { Init entry descr. pointer to nil (does not match) }
  INSYMBOL;                                                    { Gobble up the "[" and get the entry identifier }
  with sy_sym do
  if sy = identsy then                                         { We expect a generic or formal entry identifier }
  begin
    ip := IDE_SEARCH( [cla_type, cla_fentry, cla_genwfent, cla_generic]);
    if ip <> ide_udptr[cla_type] then
    with ip^ do
    begin
      INSYMBOL;
      if sy = rbrack then INSYMBOL
                     else SRC_ERROR( mdnam, 26, e_error );
      case ide_class of
        cla_type, cla_genwfent, cla_generic:
          begin      { * For generic we must determine that is the compatible entry in the list }
            pg := ide_gfirst;
            while (pg <> nil) and not COMP_PROC_ARG( pg^.gen_proc, ty^.typ_entry ) do pg := pg^.gen_link;
            if pg = nil then pr := nil
                        else pr := pg^.gen_proc;               { pr is the selected entry descriptor }
            if pr^.pro_lex > 1 then SRC_ERROR_S( mdnam, 401, e_error, ide_name^ )
          end;

        cla_fentry: { * For formal entry, we check the compatibility with the requested entry type }
          if COMP_PROC_ARG( ide_entry, ty^.typ_entry ) then pr := ide_entry
                                                       else pr := nil;

      otherwise
      end;
      if pr <> nil then                                        { pr is the entry to return }
      begin
        LGT_NEW( lgt, ty, lgt_eproref, nil );                  { Get the form_fentry value of the specified entry }
        lgt^.lgt_pro := pr
      end
    end
  end;
  if pr = nil then
  begin
    SRC_ERROR( mdnam, 402, e_severe );
    lgt := LGT_NEW_ECONST( typ_std[form_nil], 0 )              { nil is returned on undeclared entry identifier }
  end;
  EXP_GENERIC_REF := lgt
end EXP_GENERIC_REF;



function EXP_IDENTIFIER: lgt_ptr;
const
  mdnam = 'RFOB';

var
  lgt, lgt1:    lgt_ptr;
  ip, ipr:      ide_ptr;
  pt:           typ_ptr;
  pr:           pro_ptr;
  i, j, sa, sl: integer;

begin { EXP_IDENTIFIER }
  with sy_sym do
  begin
    if sy = functionsy then
    begin
      pr := GET_PROCREF;                               { Get the current procedure/function descriptor }
      if pr <> nil then                                { A Procedure/Function is found }
        if pr^.pro_typ <> nil then                     { It is a Function }
          if not pr^.pro_typ^.typ_simple then
          begin
            INSYMBOL;                                  { Gobble up the function Keyword }
            lastsymb  := sy;
            sy_search := pr^.pro_parmlst;
            sy := identsy
          end;
      if sy = functionsy then
      begin
        SRC_ERROR( mdnam, 190, e_severe );
        INSYMBOL
      end
    end;

    if sy = identsy then
    begin
      if sy_search = nil then
      begin
        ip := IDE_SEARCH( [cla_type, cla_tparam, cla_konst, cla_varbl, cla_field,
                           cla_fentry, cla_genwfent, cla_generic]);
        INSYMBOL                                       { Gobble up the identifier }
      end
      else
      begin
        ip := sy_search;
        sy := lastsymb;
        sy_search := nil
      end;

      if ip <> nil then
      begin
        with ip^ do
          case ide_class of

          cla_type:
            if ip = ide_udptr[cla_type] then
              { For undeclared identifier }
              lgt := LGT_NEW_ECONST( typ_std[form_wild], 0 )
            else
            case sy of
              attrsign: lgt := ATTR_TYPE( nil, ide_typ );
              lparen:
                if ide_gfirst <> nil then lgt := CALL_GENERIC( ip, true )
                                     else lgt := GET_AGREGATE( ide_typ );
              lbrack:
                if ide_typ <> nil then
                  if ide_typ^.typ_form = form_fentry then lgt := EXP_GENERIC_REF( ide_typ )
                                                     else lgt := GET_AGREGATE( ide_typ );
            otherwise
              SRC_ERROR( mdnam, 36, e_severe )
            end;

          cla_genwfent,
          cla_fentry:
            lgt := CALL_FORMAL_PROC( ip, true );

          cla_generic:
            lgt := CALL_GENERIC( ip, true );

          cla_tparam:
            begin
              case ide_tkind of
                tpa_dycte: { Cte. or Dynamic allocation }
                  if ide_cteval <> nil then
                  begin
                    LGT_NEW( lgt, ide_typ, lgt_const, nil );   { Allocate a node }
                    with lgt^ do
                    begin
                      lgt_cte  := ide_cteval;
                      VAL_NEW( lgt_cte, ide_typ )
                    end
                  end
                  else
                    { Defined via a dynamic expression }
                    lgt := EXPRESSION_TYPE( ide_typ );

                tpa_sub: { Referenced in subtype definition }
                  begin { Defined via call parameter }
                    LGT_NEW( lgt, ide_typ, lgt_varbl, nil );   { Allocate a node }
                    if ide_tlink = nil then ide_tlink := lgt;
(* ///
                    ide_tlink2 := lgt;
*)
                    ide_tlink2 := nil;
                    with lgt^ do
                    begin
                      lgt_ide  := ip;
                      lgt_status := [lgt_in]
                    end
                  end;

                tpa_local: { Referenced as descriptor part }
                  with lex_ident_tree[ident_disp] do
                    if disp_kind = dsp_record then     { Direct reference }
                    begin
                      LGT_NEW_COPY( disp_lgt, lgt );   { Copy the reference }
                      with lgt^ do
                      begin { Set the field offset }
                        lgt_typ  := ide_typ;
                        lgt_disp := lgt_disp + ide_toffset
                      end
                    end
                    else
                    begin { disp_kind = dsp_drecord or dsp_vrecord }
                      LGT_NEW_COPY( disp_lgt, lgt );
                      LGT_NEW( lgt, ide_typ, lgt_indir, lgt );
                      lgt^.lgt_disp := ide_toffset;
                      if disp_usage >= 0 then
                        disp_usage := disp_usage + 1   { Set the use count }
                      else
                      with lex_ident_tree[ident_disp - 1] do
                        disp_usage := disp_usage + 1
                    end;

              otherwise
              end { case };
              lgt^.lgt_lide   := ip;                   { Set the label identifier }
              lgt^.lgt_status := [lgt_in]              { Assume read only }
            end;


          cla_varbl:
            begin
              lgt := LGT_NEW_IDREF( ip, nil );         { Allocate ref. node }
              with lgt^ do
              begin
                if owner^.pro_lex >= ide_lex then
                  ide_vacc := ide_vacc + [var_intaccess];

                case ide_vkind of
                  var_global,
                  var_static,
                  var_decl,
                  var_result:
                    begin
                      { We must generate an varbl init for all subtype obj. }
                      if (ide_typ^.typ_subtype or ide_typ^.typ_hasidsc) and
                         (not (var_inited in ide_vacc)) then
                           INIT_D_VARBL( ip );
                      { We must generate any varbl initialization for
                        the dynamic variable. }

                      if (ide_vkind = var_decl) and    { For automatic varbl ... }
                         (ide_lex > 1) and             { ... of a local proc./funct.  ... }
                         (ide_inival <> nil) and       { ... with an initial value }
                         (not (var_initialized in ide_vacc)) then
                           INITIALIZE_VARBL( ip )      { Build an init statement }
                    end;


                  var_refer:
                    begin                              { The refer parameter give a pointer as value }
                      lgt_typ := typ_std[form_nil];
                      lgt_status := [lgt_in]
                    end;

                otherwise
                  { Nothing to do }
                end
              end;
              lgt^.lgt_lide   := ip                    { Set the label identifier }
            end;

          cla_konst:
            begin
              lgt := LGT_NEW_IDREF( ip, nil );         { Allocate ref. node }
              lgt^.lgt_lide   := ip                    { Set the label identifier }
            end;

          cla_field:
            with lex_ident_tree[ident_disp] do
            begin
              LGT_NEW_COPY( disp_lgt, lgt );           { Copy the reference }
              if disp_kind = dsp_record then           { Direct reference }
              begin
                if lgt^.lgt_typ^.typ_descr_size > 0 then curr_descr := lgt;
                LGT_NEW( lgt, ide_typ, lgt_offset, lgt );
                lgt^.lgt_disp := ide_offset            { Set the field offset }
              end
              else
              begin                                    { disp_kind = dsp_drecord/dsp_vrecord }
                with lgt^ do
                if lgt_typ^.typ_form = form_organization then
                begin
                  ipr := lgt_typ^.typ_parent^.typ_ide;
                  lgt_nxt :=  LGT_NEW_ECONST( typ_std[form_int], ide_offset );
                  if ipr <> nil then
                    lgt := EXP_GENOPER( ipr^.ide_name^, ipr^.ide_gfirst, lgt )
                  else
                    SRC_ERROR( mdnam, 998, e_severe ); { No parnet type for an organisation }
                  lgt^.lgt_typ := ide_typ
                end
                else
                begin
                  LGT_NEW( lgt, lgt^.lgt_typ^.typ_eltype, lgt_indir, lgt );
                  if lgt^.lgt_typ^.typ_descr_size > 0 then curr_descr := lgt;
                  with lgt^ do
                  LGT_NEW( lgt, ide_typ, lgt_offset, lgt );
                  lgt^.lgt_disp := ide_offset
                end;
                if disp_usage >= 0 then
                  disp_usage := disp_usage + 1         { Set the use count }
                else
                  with lex_ident_tree[ident_disp - 1] do
                    disp_usage := disp_usage + 1
              end;
              with lgt^ do
              begin
                lgt_status := disp_lgt^.lgt_status + [lgt_add];
                lgt_lide   := ip                       { Set the label identifier }
              end
            end
          end { case }
      end
      else
      begin
        SRC_ERROR( mdnam, 107, e_severe );
        lgt := LGT_NEW_ECONST( typ_std[form_wild], 0 )
      end
    end
    else                                               { Constant case }
    begin
      case sy of
        nilsy:     lgt := LGT_NEW_ECONST( typ_std[form_nil], 0 );
        intconst:  lgt := LGT_NEW_ECONST( typ_std[form_int], sy_ival );
        singleconst:
          begin                                        { Single Precision Constant }
            lgt := LGT_NEW_ECONST( typ_std[form_single], 0 );
            lgt^.lgt_cte^.val_rval := sy_rval
          end;
        doubleconst:
          begin                                        { Double Precision Constant }
            lgt := LGT_NEW_ECONST( typ_std[form_double], 0 );
            lgt^.lgt_cte^.val_rval := sy_rval
          end;
        stringconst:
          begin
            lgt := LGT_NEW_ECONST( typ_std[form_char],
                                   ORD( sy_string.body[1] ) );
            if sy_string.length <> 1 then
            with lgt^, lgt_cte^ do
            begin                                      { String of char }
              { Link in the constant string }
              lgt_typ   := typ_std[form_record];
              val_kind  := form_string;
              val_size  := sy_string.length;
              val_typ   := lgt_typ;
              if sy_string.length > 0 then
              begin
                NEW( val_str, sy_string.length );
                val_str^ := sy_string
              end
              else val_str := nil
            end;
          end;
      otherwise
        { Null Reference }
        if spc_opearg then SRC_ERROR( mdnam, 44, e_error );
        LGT_NEW( lgt, typ_std[form_wild], lgt_empty, nil )
        {/// lgt := LGT_NEW_ECONST( typ_std[form_wild], 0 ) ///}
      end { case sy };

      if lgt^.lgt_kind <> lgt_empty then INSYMBOL
    end
  end;
  EXP_IDENTIFIER := lgt
end EXP_IDENTIFIER;



function EXP_INDIR( pobj: lgt_ptr ): lgt_ptr;
const
  mdnam = 'INDI';
var
  robj:   lgt_ptr;
  tyk:  typ_forms;

begin
  robj := pobj;
  with pobj^.lgt_typ^ do
  begin
    case typ_form of
      form_file:
        begin { * <file>^ -->  <a_file_element> }
          pobj^.lgt_typ := typ_std[form_nil];
          LGT_NEW( robj, typ_std[form_nil], lgt_indir, pobj );
          with robj^ do lgt_status := lgt_status + [lgt_add];
          LGT_NEW( robj, typ_eltype, lgt_indir, robj )
        end;

      form_pointer:
        begin { * <varbl_pointer>^ -->  <pointed object> }
          LGT_NEW( robj, typ_eltype, lgt_indir, pobj );
          { Except for record, we must add the descriptor size as base offset }
        end;

      form_fentry:
        begin { * <entry_pointer>^ -->  <an_entry_to_active> }
          robj := CALL_INDIRECT_PROC( pobj )
        end;

    otherwise
      SRC_ERROR( mdnam, 151, e_severe );               { Not a pointer }
    end;
    if typ_form <> form_fentry then
      with robj^ do lgt_status := lgt_status + [lgt_add];
  end;
  EXP_INDIR := robj
end EXP_INDIR;



function EXP_FIELD( pobj: lgt_ptr ): lgt_ptr;
{ To handle the "." between a record id. and a field id }
const
  mdnam = 'GFLD';

var
  ipf: ide_ptr;
  dsp: integer;
  ber: boolean;

begin
  ber := false;
  ipf :=   nil;
  dsp :=     0;
  if sy_sym.sy = identsy then
  begin
    with pobj^, lgt_typ^ do
    begin
      if typ_parmlst <> nil then
      begin                                    { In first search in type parameter list }
        ipf := LEVEL_SEARCH( typ_parmlst );
        if ipf <> nil then                     { Existing type parameter in this record }
        with ipf^ do
        begin
          if lgt_kind <> lgt_const then lgt_lide := ipf;
          dsp := ide_toffset                   { Get the exact offset }
        end
      end;
      { Search for a record field when not already found as a type parameter }
      if ipf = nil then { If no type parameter ident found }
        if typ_form <> form_record then        { It is not a record or descr type }
        begin
          pobj := LGT_NEW_ECONST( typ_std[form_wild], 0 );
          SRC_ERROR( mdnam, 152, e_severe );
          ber := true
        end
        else
        begin
          ipf := LEVEL_SEARCH( typ_firstfield );
          if ipf <> nil then                   { Existing field in this record }
          with ipf^ do
          begin
            if lgt_kind <> lgt_const then lgt_lide := ipf;
            dsp := ide_offset                  { Set the offset }
          end
          else
        end;

      if ipf <> nil then
      with ipf^ do
      begin
        if (dsp <> 0) and (curr_descr = pobj) then
          if lgt_kind = lgt_const then begin  LGT_NEW_COPY( pobj, pobj ); pobj^.lgt_typ := ide_typ  end
                                  else begin
                                         LGT_NEW( pobj, ide_typ, lgt_offset, pobj );
                                         pobj^.lgt_status := pobj^.lgt_parmlst^.lgt_status
                                       end
        else
          begin  dsp := lgt_disp + dsp; lgt_typ  := ide_typ  end;
        pobj^.lgt_disp := lgt_disp + dsp
      end
      else
      begin
        pobj := LGT_NEW_ECONST( typ_std[form_wild], 0 );
        SRC_ERROR_S( mdnam, 153, e_error, sy_ident );   { Not existing field }
        ber := true
      end
    end;
    INSYMBOL;                                  { Gobble up the field name }
  end
  else
  begin
    SRC_ERROR( mdnam, 156, e_severe );         { A field identifier was expected }
    ber :=true
  end;

  with pobj^ do
    if ber then lgt_typ := typ_std[form_wild]  { Force the wild type for context compatibility }
    else
    begin
      lgt_disp := dsp;                         { Set the new (field) offset }
      lgt_status := lgt_status + [lgt_add];
      if lgt_kind = lgt_const then             { When it is simple type inside a structured constant ... }
        if lgt_typ <> nil then                 { We can extract it }
          if lgt_typ^.typ_simple then LGT_EXTRACT_SIMPLE_CTE( pobj )
    end;

  EXP_FIELD := pobj
end EXP_FIELD;



function EXP_INDEX( pobj: lgt_ptr ): lgt_ptr;
const
  mdnam = 'INDX';

var
  iv, jv, kv, lv:                       integer;
  lgta, lgtr, lgt1, lgt2, lgt3, lgt4:   lgt_ptr;

begin
  lgta := pobj;


  if COMP_TYPE( pobj^.lgt_typ, typ_std[form_record], true ) then
  begin { Standard string can be used as an array }
    curr_descr := pobj;
    LGT_NEW( lgta, typ_std[form_record]^.typ_lastfield^.ide_typ, lgt_offset, pobj );
    lgta^.lgt_disp := typ_std[form_record]^.typ_lastfield^.ide_offset
  end
  else
  with pobj^, lgt_typ^ do
  if pobj^.lgt_typ^.typ_descr_size > 0 then
  begin
    curr_descr := pobj;
    LGT_NEW( lgta, pobj^.lgt_typ, lgt_offset, pobj );
    lgta^.lgt_disp := pobj^.lgt_disp + pobj^.lgt_typ^.typ_descr_size
  end
  else lgta := pobj;

  with lgta^ do
  begin
    with lgt_typ^ do
    if (typ_form = form_array) or (typ_form = form_conf) then
    begin
      { Get the index value }
      lgt1 := EXPRESSION_TYPE( typ_indtype );
      if lgt1^.lgt_kind = lgt_const then
      begin
        iv := lgt1^.lgt_cte^.val_ival;
        LGT_FREE( lgt1 )
      end;
      lgt2 := nil;
      lgt3 := nil;
      lgt4 := nil;
      { Evaluate the index and its limits }
      with typ_indtype^ do
      if typ_form = form_range then                    { Dynamic range }
        if typ_low^.lgt_kind = lgt_const then
        begin
          jv := typ_low^.lgt_cte^.val_ival;            { Low bound is a constant }
          lgt3 := typ_high
        end
        else                                           { Range of variable low limit }
        begin
          lgt2 := LGT_TYPE_EVAL( typ_low, curr_descr );
(*
WRITELN( lst_current^.lst_file, ' EXP_INDEX V typ_low : ' );
LGT_WRITE_TREE( 4, typ_low );
LGT_WRITE_TREE( 4, curr_descr );
LGT_WRITE_TREE( 4, lgt2 );
*)
          if typ_high^.lgt_kind = lgt_const then
          begin
            kv := typ_high^.lgt_cte^.val_ival;
            lgt3 := typ_high
          end
        end
      else                                             { Fixed index range }
      begin
        jv := typ_min;
        kv := typ_max
      end;
      { Evaluate the array element size }
      if typ_el_size > 0 then lv := typ_el_size
      else                                             { Parametric size of the element }
      begin
        lgt4 := LGT_TYPE_EVAL( typ_el_comp_size, curr_descr );
        if lgt4 <> nil then
        with lgt4^ do
          if lgt_kind = lgt_const then
          begin
            lv := lgt_cte^.val_ival;
            LGT_FREE( lgt4 )                           { LGT_FREE set the pointer to nil }
          end
      end;
      { Now we can generate the indexation }
      if (lgt1 = nil) and (lgt2 = nil) then
      begin { When low bound and index are constant }
        if (iv < jv) or ((lgt3 = nil) and (iv > kv)) then
          SRC_ERROR( mdnam, 154, e_error );
        iv := iv - jv;                                 { Get an index starting from 0 }
        if lgt4 = nil then                             { Constant element size }
        begin { Modify the displacement of the node }
          lgtr := lgta;
          lgtr^.lgt_disp := lgt_disp + iv * lv;        { Modify the offset }
          lgtr^.lgt_typ := typ_aeltype                 { Set the resulting type }
        end
        else
        begin { * Create an index node for variable element size and fix indexing }
          lgt1 := LGT_NEW_ECONST( int_typ, iv );
          lgta^.lgt_nxt := lgt1;                       { Establish the array to index link }
          lgt1^.lgt_nxt := lgt4;
          LGT_NEW( lgtr, typ_aeltype, lgt_index, lgta );       { Create the index node }
          lgtr^.lgt_status := lgta^.lgt_status;        { Set the array in/out access code }
          lgtr^.lgt_typlnk := lgt_typ                  { Get the element type }
        end
      end
      else
      begin { * Index or low bound are variable }
        LGT_NEW( lgtr, typ_aeltype, lgt_index, lgta ); { Create the index node }
        lgtr^.lgt_typlnk := lgt_typ;                   { Get the element type }
        if lgt4 = nil then                             { * The Element size is constant }
        begin
          if lgt1 = nil then                           { * The index is fixed }
          begin
            lgt1 := LGT_NEW_CODE( pcod_ineg, lgt2 );
            lgtr^.lgt_disp := iv * lv                  { Set displacement }
          end
          else
          begin                                        { * Index is variable }
            if lgt2 = nil then                         { The low bound is fixed }
              lgtr^.lgt_disp := - jv * lv
            else
            begin { Index and Low Bound are variable }
              { Form the code for <index> - <low_bound> }
              lgt1^.lgt_nxt := lgt2;
              lgt1 := LGT_NEW_CODE( pcod_isub, lgt1 );
            end;
          end;
          lgt1^.lgt_nxt := LGT_NEW_ECONST( int_typ, lv )
        end
        else
        begin { * The Element size is Variable }
          if lgt1 = nil then                           { The index is fixed }
          begin
            if iv <> 0 then                            { The index is not 0 }
              lgt1 := LGT_NEW_ECONST( int_typ, iv )
          end
          else
            if lgt2 = nil then                         { The low bound is fixed }
              if jv <> 0 then                          { The low limit is not 0 }
                lgt2 := LGT_NEW_ECONST( int_typ, jv );

          if lgt1 = nil then                           { The index is 0 }
            lgt1 := LGT_NEW_CODE( pcod_ineg, lgt1 )
          else
            if lgt2 <> nil then                        { The low limit is not 0 }
            begin
              lgt1^.lgt_nxt := lgt2;                   { Link low limit to index }
              lgt1 := LGT_NEW_CODE( pcod_isub, lgt1 )
            end;
          lgt1^.lgt_nxt := lgt4
        end;
        lgta^.lgt_nxt := lgt1                          { Link 0 starting index to array }
      end
    end
    else
    begin { "[" used on a not array object }
      SRC_ERROR( mdnam, 155, e_severe );               { Not an array }
      lgt_typ := typ_std[form_wild];
      lgt_parmlst := nil;
      lgtr := pobj;
      SKIP_SYMBOL( rbrack )                            { Skip to end of subscript }
    end;

    with lgtr^ do
    begin
(*
      if lgt_typ <> nil then
      with lgt_typ^ do
        if (typ_form <> form_record) and (typ_form <> form_variant) then
begin
  WRITELN( lst_current^.lst_file, ' Mod disp from ', lgt_disp:0, ' to ', lgt_disp + typ_descr_size:0 );
        lgt_disp := lgt_disp + typ_descr_size;
end;
*)
      lgt_status := lgt_status + [lgt_add];
      if lgt_kind = lgt_const then
        if lgt_typ <> nil then
          if lgt_typ^.typ_simple then LGT_EXTRACT_SIMPLE_CTE( lgtr )
    end
  end;
  EXP_INDEX := lgtr
end EXP_INDEX;



function EXPRESSION {: lgt_ptr was forward };
const
  mdnam = 'EXPR';

var
  pbin:  lgt_ptr;
  oper:  operator;

  function EXP_AND: lgt_ptr;
  var
    pbin:  lgt_ptr;
    oper:  operator;

    function EXP_NOT: lgt_ptr;
    var
      puna: lgt_ptr;
      oper: operator;

      function EXP_REL: lgt_ptr;
      var
        pbin:  lgt_ptr;
        oper:  operator;

        function EXP_ADD: lgt_ptr;
        var
          pbin:  lgt_ptr;
          oper:  operator;

          function EXP_MUL: lgt_ptr;
          var
            pbin:  lgt_ptr;
            oper:  operator;

            function EXP_POW: lgt_ptr; 
            var
              pbin:  lgt_ptr;
              oper:  operator;

              function EXP_UNA: lgt_ptr;
              var
                puna, vsave:   lgt_ptr;
                oper:         operator;
                more:          boolean;

              begin { EXP_UNA }
                with sy_sym do
                begin
                  if (sy = addop) and ((op = sub_op) or (op = add_op)) then
                    sy := unaop;
                  if sy = unaop then
                  begin
                    if op <> add_op then oper := op
                                    else oper := no_op;
                    INSYMBOL;
                    puna := EXP_UNA;
                    if oper <> no_op then
                      if puna^.lgt_kind <> lgt_empty then
                        puna := EXP_GENOP( oper, puna )
                  end
                  else
                  if sy = lparen then
                  begin
                    INSYMBOL;
                    puna := EXPRESSION;
                    if sy = rparen then INSYMBOL
                                   else SRC_ERROR( mdnam, 23, e_severe )
                  end
                  else
                  if sy = lbrack then
                    puna := EXP_CONST_SET      { Structured Constant ? }
                  else
                  begin
                    { /// vsave := curr_descr; }
                    puna := EXP_IDENTIFIER;    { Get the object }
                    more := (puna^.lgt_kind <> lgt_empty);
                    if puna^.lgt_typ^.typ_descr_size > 0 then curr_descr := puna;
                    while more do
                    case sy of
                      indirsign:
                        begin                  { Indirect Element Specification }
                          INSYMBOL;            { Gobble up "^" }
                          puna := EXP_INDIR( puna );
                          if puna^.lgt_typ^.typ_descr_size <> 0 then curr_descr := puna
                        end;

                      lbrack:                  { Array Element Specification }
                        begin
                          sy := comma;
                          while sy = comma do
                          begin
                            INSYMBOL;          { Gobble up "[" or "," }
                            puna := EXP_INDEX( puna );
                            if puna^.lgt_typ^.typ_descr_size <> 0 then curr_descr := puna
                          end;
                          if sy = rbrack then INSYMBOL
                          else SRC_ERROR( mdnam, 26, e_error )
                        end;

                      period:                  { Field Specification }
                        begin
                          INSYMBOL;            { Gobble up "." }
                          puna := EXP_FIELD( puna );
                          if puna^.lgt_typ^.typ_descr_size <> 0 then curr_descr := puna
                        end;

                      attrsign:
                          puna := ATTR_TYPE( puna, puna^.lgt_typ );

                    otherwise
                      more := false
                    end;
                    { /// curr_descr := vsave }
                  end
                end;
                spc_opearg := false;           { Clear the "don't accept" empty expression flag }
                EXP_UNA := puna
              end EXP_UNA;

            begin { EXP_POW }
              pbin := EXP_UNA;
              if pbin^.lgt_kind <> lgt_empty then
              with sy_sym do
                if sy = powop then
                begin                          { Get the definition list head }
                  oper := op;
                  INSYMBOL;
                  spc_opearg := true;
                  pbin^.lgt_nxt := EXP_UNA;
                  pbin := EXP_GENOP( oper, pbin )
                end;
              EXP_POW := pbin
            end EXP_POW;

          begin { EXP_MUL }
            pbin := EXP_POW;
            if pbin^.lgt_kind <> lgt_empty then
            with sy_sym do
              while sy = mulop do
              begin                            { Get the definition list head }
                oper := op;
                INSYMBOL;
                spc_opearg := true;
                pbin^.lgt_nxt := EXP_POW;
                pbin := EXP_GENOP( oper, pbin )
              end;
            EXP_MUL := pbin
          end EXP_MUL;

        begin { EXP_ADD }
          pbin := EXP_MUL;
          if pbin^.lgt_kind <> lgt_empty then
          with sy_sym do
            while sy = addop do
            begin
              oper := op;                      { Get the definition list head }
              INSYMBOL;
              spc_opearg := true;
              pbin^.lgt_nxt := EXP_MUL;
              pbin := EXP_GENOP( oper, pbin )
            end;
          EXP_ADD := pbin
        end EXP_ADD;

      begin { EXP_REL }
        pbin := EXP_ADD;
        if pbin^.lgt_kind <> lgt_empty then
        with sy_sym do
          while sy = relop do
          begin
            oper := op;                        { Get the definition list head }
            INSYMBOL;
            spc_opearg := true;
            pbin^.lgt_nxt := EXP_ADD;
            pbin := EXP_GENOP( oper, pbin )
          end;
        EXP_REL := pbin
      end EXP_REL;

    begin { EXP_NOT }
      with sy_sym do
        if sy = notop then
        begin
          oper := op;                          { Keep the Operator }
          INSYMBOL;
          puna := EXP_NOT;
          spc_opearg := true;
          if puna^.lgt_kind <> lgt_empty then
            puna := EXP_GENOP( oper, puna )
        end
        else
          puna := EXP_REL;
      EXP_NOT := puna
    end EXP_NOT;

  begin { EXP_AND }
    pbin := EXP_NOT;
    if pbin^.lgt_kind <> lgt_empty then
    with sy_sym do
      while sy = lgandop do
      begin
        oper := op;                            { Keep the Operator }
        INSYMBOL;
        spc_opearg := true;
        pbin^.lgt_nxt := EXP_NOT;
        pbin := EXP_GENOP( oper, pbin )
      end;
    EXP_AND := pbin
  end EXP_AND;

begin { EXPRESSION }
  pbin := EXP_AND;
  if pbin^.lgt_kind <> lgt_empty then
  with sy_sym do
    while sy = lgorop do
    begin
      oper := op;                              { Keep the Operator }
      INSYMBOL;
      spc_opearg := true;
      pbin^.lgt_nxt := EXP_AND;
      pbin := EXP_GENOP( oper, pbin )
    end;
  EXPRESSION := pbin
end EXPRESSION;




function STATELIST( stopper: symbol; seq_flg: boolean ): lgt_ptr; forward;



function STATEMENT( lgp: lgt_ptr; bsequ: boolean ): lgt_ptr; forward;



procedure VARBL_SETTING(v_class: class_types;
                        var isz, aln: integer; ty: typ_ptr); forward;



procedure TYPE_SPC( var it: typ_ptr;                   { Create type pointer }
                            descr_sz: integer;         { Descriptor size or 0 }
                            parm: ide_ptr;             { Parameter ide. root }
                            bdeforg,                   { To allow the organization definition }
                            buseorg: boolean );        { To allow the short organization specification }
                  forward;



function CASE_DEFINITION { ( mode: symbol; ty: typ_ptr ): lgt_ptr was forward };
{ The mode parameter is used to specified a mode as this :
   typesy for a generic case type and ...
   intconst for a constant case in a type definition :
     ty is unused,
     the result is a lgt_ctlflow/stm_case record with
        the complet case choices description.

   recordsy for a record type :
     ty must be the form_record/variant type descriptor pointer,
     the result function is nil.

   becomes for an expression case choice,
   and beginsy for a case statement :
     For this two last case the result function is the
     appropriate executable lgt record.
     In the expression case choice ty must be the type of the target.

  Any cte selector case are immediatly solved.
}
{
  This routine built this lgt_rec structure :

  --> denots the lgt_nxt link.
  !  denots the lgt_parmlst link.

--> (lgt_ctlflow) -->
    ( stm_case  )      { the disp is the number of associated work }{
         !
         !
    ( lgt_const ) --> ( other nd ) --> ( sel. ) --> ( w#0 ) --> ( w#1 ) ...
    ( lgt_disp  )                         !
  min. value of sel.                      !
    ( val_size )                          !
   (max - min + 1)                     selector
         !!                              tree
    table of work #                   expression
  for each sel. value.

}
const
  mdnam = 'CASD';

  max_case = 511 { 512 labels allowed };

var
  ncase, shift, offset_base, i,
  cv, cv1, min, max:      integer;
  id, id1, tnext:         ide_ptr;
  it:                     typ_ptr;
  case_table: array[0..max_case] of integer;   { Table of work numbers }
  lgt1, lgt2, lgt3, lgt4: lgt_ptr;
  save_label_flag, binsy, bfound,              { To save the label INSYMBOL flag }
  bendcase, bsf:          boolean;
  ch:                     char;

  function CASE_WORK_LIST( mode: symbol; ty: typ_ptr; blist: boolean ): lgt_ptr;
  var
    lgt:  lgt_ptr;
    tp:   typ_ptr;
    ialn: integer;

  begin
    lgt := nil;
    with sy_sym do
    case mode of
      typesy, intconst:
        begin { Type case form }
          LGT_NEW( lgt, nil, lgt_null, nil );
          TYPE_SPC( lgt^.lgt_typ, 0, nil, false, false );
          if (sy <> semicolon) and (sy <> endsy) and (sy <> othersy) then
            SRC_ERROR( mdnam, 35, e_error )
        end;

      recordsy: { Record case form }
        with ty^ do
        begin
          if sy = lparen then INSYMBOL         { Gobble up left parenthesys }
                         else SRC_ERROR( mdnam, 22, e_error );
          IDE_NEW_TYP( form_variant, tp );
          LGT_NEW( lgt, tp, lgt_null, nil );
          with tp^ do
          begin
            typ_size := offset_base;           { Get parent size as offset origine }
            typ_firstfield := nil;             { Init the record variant record }
            typ_lastfield := nil;
            typ_recvar := nil;
            VARBL_SETTING( cla_field, typ_size, ialn, tp );
            if tnext = nil then
              typ_firstfield := lex_ident_tree[curr_disp].disp_tree
            else
              typ_firstfield := tnext^.ide_nxt;
            if typ_lastfield = nil then
              typ_lastfield := lex_ident_tree[curr_disp].disp_ide_last;
            tnext := typ_lastfield
          end;
          { Adjust the maximum size of the entire record }
          if tp^.typ_size > typ_size then typ_size := tp^.typ_size
          else if tp^.typ_size < 0 then typ_size := -1;
          { Adjust the maximum alignement of the entire record }
          if ialn > typ_align.int then typ_align.int := ialn;
          if sy = rparen then INSYMBOL         { Gobble up right parenthesys }
                         else SRC_ERROR( mdnam, 23, e_error )
        end;

      becomes: { Expression value }
        begin
          lgt := EXPRESSION_TYPE( ty );
          if (sy <> comma) and (sy <> endsy) and (sy <> othersy) then
            SRC_ERROR( mdnam, 35, e_error )
        end;

    otherwise
      if blist then lgt := STATELIST( endsy, true )
               else lgt := STATEMENT( nil, true );
      if lgt = nil then
      begin
        LGT_NEW( lgt, nil, lgt_null, nil );
        if blist then
          with lgt^ do
            lgt_status := lgt_status  + [lgt_spc]      { To flag otherwise statement }
      end;
      if (sy <> semicolon) and (sy <> endsy) and (sy <> othersy) then
          SRC_ERROR( mdnam, 35, e_error )
    end { case };
    CASE_WORK_LIST := lgt
  end CASE_WORK_LIST;


begin { CASE_DEFINITION }
  with sy_sym do
  begin
    if mode = recordsy then
      offset_base := ABS( ty^.typ_size )       { Set the offset base }
    else
      offset_base := 0;                        { No record }
    it := nil;                                 { Assume to case <type_id> form }
    if mode = recordsy then                    { Case in a record }
    begin                                      { "case <type_id> of" is allowed inside a record/variant def. }
                                               { "case <selector>:<sel_type> of" is also allowed }
      if ty <> nil then
        tnext := ty^.typ_lastfield;            { If no selector node it is the last field }
      sy_casedef := true;
      ch := SRC_SEARCH_CHAR;                   { Get the none space character without continue the source read. }
      if ch = ':' then                         { See "case s:t of" or "case s of" }
      begin                                    { Forms "case <sel>:<type> of" }
        IDE_NEW( cla_field, nil, id1 );
        tnext := id1;                          { The next is the selector field }
        INSYMBOL;                              { Gobble up the selector field identifier }
        if sy <> colon then SRC_ERROR( mdnam, 29, e_error )
                       else INSYMBOL;
        { sy_sym -> the type identifier of selector }
        bsf := true
      end
      else bsf := false;                       { Forms "case <sel_exp> of" or "case <type> of" }

      { We check for type identifier to distinguish the form <sel_exp> }
      err_prt := false;                        { Disable undeclared ident msg }
      id := IDE_SEARCH( [cla_type] );          { Look for type name selector }
      err_prt := true;                         { Enable undeclared ident msg }
      if (not bsf) and (id <> nil) then
      begin
        ch := SRC_SEARCH_CHAR;                 { Look at for next character }
        if (ch = '"') or (ch ='(') then id := nil
      end;
      if id <> nil then                        { A type name is specified }
      begin                                    { Forms "case <type> of" or "case <sel>:<type> of" }
        it := id^.ide_typ;                     { Get the related type def. }
        if not COMP_TYPE( it, typ_std[form_ennum], false ) then
        begin                                  { The type must be an ennumerated type }
          { Illegal record case type }
          SRC_ERROR( mdnam, 60, e_error );
          it := typ_std[form_int]              { Set integer on type error }
        end;
        if bsf then
        with id1^ do
        begin                                  { Allocate room for selector }
          ide_typ := it;
          ide_offset  := IDE_TYP_ALIGN( offset_base, it );
          offset_base := ide_offset + it^.typ_size;
          { Adjust the record alignement contrainst if required }
          if it^.typ_align.int > ty^.typ_align.int then
            ty^.typ_align.int := it^.typ_align.int
        end;
        { Built a selector ref as a null lgt_rec }
        LGT_NEW( lgt1, it, lgt_null, nil );
        if bsf then lgt1^.lgt_lide := id1;
        INSYMBOL                               { Gobble up the type identifier }
      end
    end;

    if it = nil then
    begin                                      { No type_id selector }
      { Get the selector expression }
      lgt1 := EXPRESSION_TYPE( typ_std[form_ennum] );
      if (mode = typesy) or (mode = recordsy) then     { type decl flow }
        TYPE_CHECK_PARM( lgt1 )                { Check for legal in type definition }
      else if mode = intconst then             { Generic declaration }
        if lgt1^.lgt_kind <> lgt_const then
          { The case is only allowed with a cte. selector in this context }
          SRC_ERROR( mdnam, 61, e_severe );
      it := lgt1^.lgt_typ                      { Get the selector type }
    end;

    if sy <> ofsy then SRC_ERROR( mdnam, 51, e_error );

    LGT_NEW( lgt3, lgt1^.lgt_typ, lgt_const, nil );
    with lgt3^ do
    begin
      lgt_nxt := lgt1;                         { Link to selector expression }
      VAL_NEW( lgt_cte, nil );
      lgt_cte^.val_kind := form_wild
    end;
    LGT_NEW( lgt4, lgt1^.lgt_typ, lgt_ctlflow, lgt3 );
    lgt4^.lgt_stm := stm_case;
    for cv := 0 to max_case do  case_table[cv] := -1   { Otherwise Default };
    ncase := 0; min := 1; max := 0;
    bendcase := false;
    binsy := true;
    save_label_flag := sy_label_flag;          { Save the label INSYMBOL flag }
    repeat                                     { Loop on each case entry }
      if binsy then sy := comma;               { Simule a comma }
      sy_label_flag := false;                  { The label should not be proceed by INSYMBOL }
      while (sy = comma) or (not binsy) do
      begin
        if binsy then INSYMBOL                 { Gobble up the comma or "of" when required }
                 else binsy := true;
        { Get a constante }
        cv := EXP_GENNUM( it );                { Get a label value }
        if sy = twodot then
        begin
          INSYMBOL; i := EXP_GENNUM( it );
          if i < cv then
          begin
            i := cv; SRC_ERROR( mdnam, 62, e_error )
          end
        end else i := cv;
        repeat
          if min > max then
          begin                                { Init min, max, shift }
            min := cv; max := cv; shift := cv;
            case_table[0] := ncase             { It is 0 }
          end
          else
          begin
            if cv > max then max := cv
            else if cv < min then min := cv;
            cv1 := cv - shift;
            if cv1 < 0 then cv1 := cv1 + max_case + 1  { Modulus };
            if (cv1 < 0) or (cv1 > max_case) then
              { To large case selector range }
               SRC_ERROR( mdnam, 63, e_severe )
            else
            begin
              { Case label value was already present ? yes => error }
              if case_table[cv1] <> -1 then
                SRC_ERROR( mdnam, 64, e_error )
              else
                case_table[cv1] := ncase
            end
          end;
          cv := cv + 1
        until cv > i
      end; { while (sy = comma) ... }
      if sy = colon then INSYMBOL else SRC_ERROR( mdnam, 31, e_error );
      sy_label_flag := save_label_flag;        { Restore the label insymbol flag }
      { Compile the work to execute in this case }
      lgt2 := CASE_WORK_LIST( mode, ty, false );
      if sy = semicolon then
      begin
        sy_label_flag := false;                { The label should not be proceed by INSYMBOL }
        INSYMBOL;                              { Gobble up the semicolon }
        binsy := false                         { Suppress the next insymbol for case continuation }
      end;

      if lgt2 = nil then LGT_NEW( lgt2, nil, lgt_null, nil );
      lgt1^.lgt_nxt := lgt2; lgt1 := lgt2;
      ncase := ncase + 1                       { Update the work number }
    until (sy = othersy) or (sy = endsy) or (sy = rparen) or (sy = eofsy);
    sy_label_flag := save_label_flag;          { Restore the label insymbol flag }
    if sy = othersy then
    begin
      INSYMBOL;                                { Gobble up "otherwise" }
      lgt1 := CASE_WORK_LIST( mode, ty, true )
    end
    else
    begin
      LGT_NEW( lgt1, nil, lgt_null, nil );
      if mode = recordsy then
      begin
        IDE_NEW_TYP( form_variant, lgt1^.lgt_typ );
        with lgt1^.lgt_typ^ do
        begin
          typ_firstfield := nil;
          typ_lastfield  := nil;
          typ_recvar     := nil;
          typ_size := offset_base
        end
      end
    end;
    lgt2 := lgt3^.lgt_nxt;                     { Re-take case selector pointer }
    lgt1^.lgt_nxt := lgt2;                     { Link case job(s) to selector }
    lgt3^.lgt_nxt := lgt1;                     { Insert the ith. before the sel. expr. }
    if mode <> recordsy then INSYMBOL;         { Gobble up the end statement }
    { Now we output the sequence in the data space }
    lgt4^.lgt_disp := ncase;
    with lgt3^, lgt_cte^ do
    begin
      lgt_disp := min;
      val_size := max - min + 1;               { Set the case table size one word by entry }
      val_tab  := TAB_NEW( val_size );
      cv := min - shift;
      if cv < 0 then cv := cv + max_case + 1;  { Modulus }
      for i := 0 to max - min do
      begin
        val_tab^.lw[i] := case_table[cv];
        cv := cv + 1;
        if cv > max_case then cv := 0          { Modulus }
      end
    end
  end;
  sy_casedef := false;
  CASE_DEFINITION := lgt4
end CASE_DEFINITION;



procedure SET_ALIGNMENT_SPC( var sz, aln: integer );
{ To set the specified size and alignment (read from source in bits, output in bytes) }
const
  mdnam = 'ALGN';

var
  i: integer;

begin
  with sy_sym do
  begin
    { When positif, spc_asize is the size to allocate (in bytes) and spc_align the related alignement }
    if spc_asize > 0 then
    begin
      sz := spc_asize; i := sz; spc_asize := -1;
      if spc_align < 0 then
      begin { Default is alignement on the size }
        aln := 1;
        while aln < i do aln := 2 * aln;
        aln := aln - 1
      end
    end;
    if spc_align >= 0 then
    begin  aln := spc_align; spc_align := -1  end;
    if sy = usesy then
    begin
      INSYMBOL;                                { Gobble up "use" }
      { Get size specification in byte }
      sz := ( EXP_GENNUM( typ_std[form_int] ) + 7 ) div 8;
      if sz < 1 then sz := 1;
      i := sz;                                 { Assume memory unit alignment on size unit }
      if sy = comma then
      begin
        INSYMBOL;
        i := ( EXP_GENNUM( typ_std[form_int] ) + 7 ) div 8;
        if i > 256 then SRC_ERROR( mdnam, 231, e_error )
      end;
      if (i < 0) or (i > 256) then i := typ_std[form_double]^.typ_size;
      if i <= 1 then aln := 0 else
      begin
        aln := 1;
        while aln < i do aln := 2 * aln;
        aln := aln - 1
      end
    end
  end
end SET_ALIGNMENT_SPC;



procedure CONFORMANT_DEF( var tr: typ_ptr; var ndim: integer );
{ Procedure to generate a conformant array index definition }
const
  mdnam = 'CNFA';

var
  it:       typ_ptr;
  ip1, ip2: ide_ptr;
  lgt:      lgt_ptr;

begin
  ip1 := nil; ip2 := nil;
  IDE_NEW_TYP( form_range, tr );
  with sy_sym, tr^ do
  begin
    if sy = identsy then IDE_NEW( cla_varbl, nil, ip1 )
                    else SRC_ERROR( mdnam, 232, e_severe );
    INSYMBOL;
    if sy = twodot then
    begin
      INSYMBOL;                                { Gobble up ".." }
      if sy = identsy then IDE_NEW( cla_varbl, nil, ip2 )
                      else SRC_ERROR( mdnam, 232, e_severe );
      INSYMBOL
    end;
    if sy = colon then
    begin
      INSYMBOL; { Gobble up ":" }
      TYPE_SPC( typ_parent, 0, nil, false, false );    { Get the index type }
      typ_size  := typ_parent^.typ_size;
      typ_align := typ_parent^.typ_align;
      if ip1 <> nil then
      begin
        ip1^.ide_typ   := typ_parent;
        ip1^.ide_vkind := var_vformal;
        ip1^.ide_vacc  := [var_in];
        if ip2 = nil then
        begin
          typ_low    := LGT_NEW_ECONST( typ_parent, 1 );
          typ_high   := LGT_NEW_IDREF( ip1, nil );
          typ_nvalue := LGT_LINK( typ_high );
          typ_nvalue^.lgt_typ := int_typ;
          ndim := ndim + 1
        end
        else
        begin
          ip2^.ide_typ   := typ_parent;
          ip2^.ide_vkind := var_vformal;
          ip2^.ide_vacc  := [var_in];
          typ_low        := LGT_NEW_IDREF( ip1, nil );
          typ_high       := LGT_NEW_IDREF( ip2, nil );
          lgt            := LGT_LINK( typ_high );
          lgt^.lgt_nxt   := LGT_LINK( typ_low );
          lgt            := LGT_NEW_CODE( pcod_isub, lgt );
          lgt^.lgt_nxt   := LGT_NEW_ECONST( int_typ, 1 );
          typ_nvalue     := LGT_NEW_CODE( pcod_iadd, lgt );
          ndim := ndim + 2
        end
      end
    end else SRC_ERROR( mdnam, 31, e_severe )
  end
end CONFORMANT_DEF;



procedure ARRAY_DEF( var art: typ_ptr; bconf: boolean; var ndim: integer  );
{ Array Type Definition Procedure }
const
  mdnam = 'ARRY';

var
  dim, els, iv:       integer;
  p1, p2:             typ_ptr;
  lgt, lgi, lge, lgs: lgt_ptr;
  aln:                align_byte;
  fia:                boolean;

begin { ARRAY_DEF }
  INSYMBOL; { Gobble up "[" or "," }
  if bconf then IDE_NEW_TYP( form_conf, art )
           else IDE_NEW_TYP( form_array, art );
  with sy_sym, art^ do
  begin
    typ_indtype := nil;
    if bconf then
      CONFORMANT_DEF( typ_indtype, ndim )              { Get conformant index type }
    else
    begin
      TYPE_SPC( typ_indtype, 0, nil, false, false );   { Get index type }
      ndim := ndim + 2
    end;
    lgi := nil; dim := 1;
    if typ_indtype <> nil then
    with typ_indtype^ do
    begin
      case typ_form of
        form_char, form_lit, form_int:
          if typ_unsigned then dim  := typ_umax - typ_umin + 1
                          else dim  := typ_max - typ_min + 1;

        form_range: lgi := LGT_LINK( typ_nvalue );

      otherwise
        SRC_ERROR( mdnam, 210, e_severe )
      end;
    end;

    { *** Get all dependent array element specifications }
    if sy = comma then
    begin { Multi dimension array or array of array }
      ARRAY_DEF( typ_aeltype, bconf, ndim );
      typ_idim := ndim
    end
    else
    begin                                              { Final array element }
      typ_idim := ndim;
      if sy = rbrack then INSYMBOL
                     else SRC_ERROR( mdnam, 26, e_error );
      if sy = ofsy then INSYMBOL
                   else SRC_ERROR( mdnam, 51, e_error );
      TYPE_SPC( typ_aeltype, 0, nil, false, false )    { Get element type }
    end;

    { Get the Array Element Size }
    if typ_aeltype <> nil then
    begin
      { Copy the alignement info from the element one's }
      typ_align.int := typ_aeltype^.typ_align.int;

      with typ_aeltype^ do
      begin
        lgs := nil;
        els := typ_size;
        lge := typ_comp_size;
        aln := typ_align;
        if els > 0 then els := TYP_ALIGNEMENT( els, typ_align );
        if els >= 0 then lge := nil
      end;
      if lge <> nil then
        if lge^.lgt_kind = lgt_const then els := lge^.lgt_cte^.val_ival
                                     else LGT_COPY_TREE( lge, lgs );
      if (lgs <> nil) and (typ_align.int > 0) and       { When the sise is variable and an alignment is required ... }
         (typ_aeltype^.typ_form <> form_array) then     { ... the element is not an array ( he alignments are same for array and its element) then ... }
      begin                                             { ... we lust generate a Run Time Alignement. }
        fia := true;
        if (lgs^.lgt_kind = lgt_codep) and
           (lgs^.lgt_pcode = pcod_iadd) and
           (lgs^.lgt_parmlst <> nil) then
          if lgs^.lgt_parmlst^.lgt_nxt <> nil then
          with lgs^.lgt_parmlst^.lgt_nxt^ do
            if (lgt_kind = lgt_const) and (lgt_cte <> nil) then
            begin
              iv := lgt_cte^.val_ival + aln.int;
              VAL_FREE( lgt_cte );
              VAL_NEW( lgt_cte, int_typ );
              lgt_cte^.val_ival := iv;
              fia := false
            end;
        if fia then
        begin
          lgs^.lgt_nxt := LGT_NEW_ECONST( int_typ, aln.int );
          lgs := LGT_NEW_CODE( pcod_iadd, lgs )
        end;
        lgs^.lgt_nxt := LGT_NEW_ECONST( int_typ, aln.int );
        lgs := LGT_NEW_CODE( pcod_bic, lgs )
      end;

      typ_el_comp_size := lgs;
      typ_el_size := els;

      { For any element with Descriptor, we set the internal descriptor flag }
      if typ_aeltype^.typ_hasidsc or
         (typ_aeltype^.typ_descr_size > 0) then typ_hasidsc := true;

      { Set the array size in bytes }
      typ_size := typ_el_size * dim;
      if (lgi = nil) and (typ_el_comp_size = nil) then { No multiply }        
        typ_comp_size := nil
      else
      begin
        if lgi = nil then
        begin
          lgi := LGT_NEW_ECONST( int_typ, dim );
          lgi^.lgt_nxt := typ_el_comp_size;
          typ_comp_size := LGT_NEW_CODE( pcod_imul, lgi )
        end
        else
        if typ_el_comp_size = nil then
          if typ_el_size = 1 then
            typ_comp_size := lgi
          else
          begin
            lgi^.lgt_nxt := LGT_NEW_ECONST( int_typ, typ_el_size );
            typ_comp_size := LGT_NEW_CODE( pcod_imul, lgi )
          end
        else
        begin
          lgi^.lgt_nxt := typ_el_comp_size;
          typ_comp_size := LGT_NEW_CODE( pcod_imul, lgi )
        end;
        typ_size := -1;                                { Set the dynamic size flag }
      end
    end
  end
end ARRAY_DEF;




procedure TYPE_SPC {( var it: typ_ptr;                Create type pointer,
                            descr_sz: integer;        Descriptor size or 0,
                            parm: ide_ptr;            Parameter ide. root,
                            bdeforg,                  To allow definition or use (short) of organization.
                            buseorg: boolean ); forward;  };
const
  mdnam = 'TYPS';

var
  pro:             pro_ptr;
  lgt, lgt1, lgt2: lgt_ptr;
  r:                  real;
  i, iv, il, sz, aln, maln, sav_descr, ndim: integer;
  ip, iq, ip1:     ide_ptr;
  p1, p2, p3, p4:  typ_ptr;
  pv, pvh, pvl:    val_ptr;
  bneg, b_new:     boolean;

begin { TYPE_SPC }
  sav_descr := sy_descr_size;                                  { Save descriptor size }
  sy_descr_size := 0;                                          { Disable the descriptor allocator for recursive call }
  sy_type_gfirst := nil;                                       { No generic definition is assumed }
  with sy_sym do
  begin
    p1 := nil;
    if sy = packedsy then INSYMBOL;
    case sy of
      typesy:                                                  { Generic type definition }
        begin
          sav_descr := 0;                                      { Disable the local descritor size allocator }
          INSYMBOL;                                            { Gobble up "type" }
          { We expect a case }
          if sy <> casesy then SRC_ERROR( mdnam, 182, e_error )
                          else INSYMBOL;
          IDE_NEW_TYP( form_generic, p1 );                     { Built a generic type }
          p1^.typ_comp_size := CASE_DEFINITION( typesy, nil )
        end;

      newsy:                                                   { New version of a defined type }
        begin
          INSYMBOL;                                            { Gobble up "new" }
          ip := IDE_SEARCH( [cla_type] );
          INSYMBOL;
          if ip <> ide_udptr[cla_type] then                    { Declared type }
          with ip^ do
          begin
            IDE_NEW_TYP( ip^.ide_typ^.typ_form, p1 );
            sy_type_gfirst := ide_gfirst;
            with p1^ do
            begin
              typ_parent     := ide_typ;
              typ_parmlst    := typ_parent^.typ_parmlst;
              typ_size       := typ_parent^.typ_size;
              typ_descr_size := typ_parent^.typ_descr_size;
              typ_align      := typ_parent^.typ_align;
              typ_inival     := typ_parent^.typ_inival;
              typ_hasidsc    := typ_parent^.typ_hasidsc;
              if typ_comp_size <> nil then
                typ_comp_size := LGT_LINK( typ_parent^.typ_comp_size );
              case typ_form of
                form_char, form_lit, form_int:
                  begin
                    typ_min := typ_parent^.typ_min;
                    typ_max := typ_parent^.typ_max;
                    typ_unsigned := typ_parent^.typ_unsigned;
                    typ_idelist := typ_parent^.typ_idelist
                  end;

                form_range:
                  begin
                    typ_nvalue := LGT_LINK( typ_parent^.typ_nvalue );
                    typ_high   := LGT_LINK( typ_parent^.typ_high   );
                    typ_low    := LGT_LINK( typ_parent^.typ_low    )
                  end;

                form_single, form_double: ;    { Nothing to do }

                form_private, form_organization,
                form_file, form_pointer:
                    typ_eltype  := typ_parent^.typ_eltype;

                form_set, form_lset:
                    typ_seltype := typ_parent^.typ_seltype;

                form_array:
                  begin
                    typ_el_size := typ_parent^.typ_el_size;
                    if typ_parent^.typ_el_comp_size <> nil then
                      typ_el_comp_size
                                 := LGT_LINK( typ_parent^.typ_el_comp_size )
                    else
                      typ_el_comp_size := nil;
                    typ_aeltype := typ_parent^.typ_aeltype;
                    typ_indtype := typ_parent^.typ_indtype
                  end;

                form_record:
                  begin
                    typ_firstfield := typ_parent^.typ_firstfield;
                    typ_lastfield  := typ_parent^.typ_lastfield;
                    if typ_parent^.typ_recvar <> nil then
                      typ_recvar   :=  LGT_LINK( typ_parent^.typ_recvar )
                    else
                      typ_recvar := nil
                  end;

                form_wlit,
                form_ennum,
                form_wwset,
                form_wild:
                  begin
                    sz  := typ_size;
                    aln := typ_align.int;
                    SET_ALIGNMENT_SPC( sz, aln );
                    if sz < typ_size then SRC_ERROR( mdnam, 214, e_error )
                                     else typ_size := sz;
                    if aln >= 0 then typ_align.int := aln
                  end;

              otherwise
                { Other are illegal }
                SRC_ERROR( mdnam, 206, e_severe )
              end;
            end
          end
        end;

      privatesy:
        begin
          if parm <> nil then SRC_ERROR( mdnam, 207, e_error );
          INSYMBOL;                                            { Gobble up "private" }
          if sy = pointersy then
            if bdeforg then
            begin                                              { For "private access" definition }
              INSYMBOL;                                        { Gobble up "access" }
              IDE_NEW_TYP( form_organization, p1 );
              with p1^ do
              begin
                typ_eltype := nil;
                typ_size   := fptr_size;
                typ_align  := typ_std[form_pointer]^.typ_align;
                typ_comp_size := nil
              end
            end
            { Illegal except for type definition }
            else SRC_ERROR( mdnam, 208, e_severe )
          else
          begin                                                { Normal undefined type }
            IDE_NEW_TYP( form_private, p1 );
            with p1^ do
            begin
              typ_eltype := nil;
              typ_comp_size := nil;
              { Default to integer Alignement }
              typ_align := typ_std[form_int]^.typ_align;
              typ_size  := 1                                   { It is the minimum possible size }
            end;
          end;
          with p1^ do
          begin
            { Get size and alignement specification in bits }
            sz  := typ_size;
            aln := typ_align.int;
            SET_ALIGNMENT_SPC( sz, aln );
            if sy_init_mod and (sy = colon) then DATA_FORMAT_SET( p1 );
            if sz < typ_size then SRC_ERROR( mdnam, 214, e_error )
                             else typ_size := sz;
            if aln >= 0 then typ_align.int := aln
          end
        end;

      arraysy:
        begin
          INSYMBOL;                                            { Gobble up "array" }
          if sy <> lbrack then SRC_ERROR( mdnam, 25, e_error );
          ndim := 0;
          ARRAY_DEF( p1, false, ndim );
          { Set the prototype type for ennumerated image type }
          if ima_typ = nil then ima_typ := p1
        end;

      recordsy:
        begin
          il := curr_disp;
          IDE_NEW_TYP( form_record, p1 );                      { Create a typ_rec descriptor }
          with p1^ do
          begin                                                { It is a new record }
            typ_descr_size := descr_sz;                        { Set the descriptor size }
            typ_size := typ_descr_size;                        { Set the size count origine }
            typ_firstfield := nil; typ_lastfield := nil;
            typ_recvar := nil;
            ip := nil
          end;
          INSYMBOL;                                            { Gobble up "record" or "=>" }
          NEW_DISP_LEVEL( nil, dsp_record );                   { Create a field display }
          has_intdesc := false;
          VARBL_SETTING( cla_field, p1^.typ_size, maln, p1 );
          with p1^ do
          begin
            typ_hasidsc       := has_intdesc;                  { Set the internal descriptor flag when required }
            typ_firstfield    := lex_ident_tree[curr_disp].disp_tree;
            if typ_recvar = nil then
              typ_lastfield   := lex_ident_tree[curr_disp].disp_ide_last;
            { Remove the record display level }
            curr_disp := PRED( curr_disp )
          end;
          { For variant the link of the previous field is done by IDE_NEW }
          if sy = endsy then INSYMBOL else SRC_ERROR( mdnam, 54, e_error );
          if typ_std[form_record] = nil then
          begin                                                { First record declaration is used as standard string def. }
            typ_std[form_record] := p1;
            with p1^ do
            begin
              stri_descrsz   := typ_descr_size;
              stri_lengthsz  := typ_firstfield^.ide_typ^.typ_size;
              stri_stroffset := typ_firstfield^.ide_nxt^.ide_offset
            end
          end
        end;

      filesy:                                                  { For file definition }
        begin
          INSYMBOL;                                            { Gobble up "file" keyword }
          if sy = ofsy then INSYMBOL else SRC_ERROR( mdnam, 51, e_error );
          IDE_NEW_TYP( form_file, p1 );                        { Create a typ_rec descriptor }
          with p1^ do
          begin
            typ_align  := typ_std[form_wfile]^.typ_align;
            typ_size   := typ_std[form_wfile]^.typ_size;
            typ_inival := typ_std[form_wfile]^.typ_inival;
            typ_parent := typ_std[form_wfile];
            { Get the file element type }
            TYPE_SPC( typ_eltype, 0, nil, false, false );

            { For any element type with Descriptor, we set the internal descriptor flag }
            if typ_eltype^.typ_hasidsc or (typ_eltype^.typ_descr_size > 0) then typ_hasidsc := true;

            if typ_eltype^.typ_size <= 0 then SRC_ERROR( mdnam, 149, e_severe )
          end;
          if typ_std[form_file] = nil then
            { First file declaration is used as standard text file def. }
            typ_std[form_file] := p1
        end;

      pointersy,
      indirsign:                                               { For pointer }
        begin
          INSYMBOL;                                            { Gobble up the access keyword ( or "^") }
          if (sy = proceduresy) or (sy = functionsy) then
            p1 := FORMAL_PROC_PTR( sy = functionsy )
          else
          begin
            IDE_NEW_TYP( form_pointer, p1 );                   { Create a typ_rec descriptor }
            with p1^ do
            begin
              typ_align := typ_std[form_nil]^.typ_align;
              typ_size := fptr_size;
              typ_parent := typ_std[form_nil];                 { All pointer has the nil type as parent }
              err_prt := false;                                { No error for forward def. }
              ip := IDE_SEARCH([cla_type]);                    { Look for the type identifier }
              err_prt := true;                                 { Reset normal error }
              if ip = nil then
              begin
                IDE_NEW( cla_type, p1, ip );                   { Create the identifier }
                ip^.ide_forlnk := fw_ptr;
                fw_ptr := ip
              end
              else typ_eltype := ip^.ide_typ;
              INSYMBOL;                                        { Gobble up the pointed type identifier }
              { Set the pointer conversion from any pointer type }
              sy_type_gfirst := NEW_OPER( pcod_noop, p1, typ_std[form_pointer], cv_nop, [a_nil] )
            end
          end
        end;

      lparen:
        if ima_typ <> nil then
        if ima_typ^.typ_parmlst <> nil then
        begin                                                  { Enumerate type }
          INSYMBOL;                                            { Gobble up the "(" }
          if typ_std[form_lit]^.typ_max = 0 then               { Boolean def. }
            p1 := typ_std[form_lit]
          else
            IDE_NEW_TYP( form_lit, p1 );                       { Create a typ_rec descriptor }
          with p1^ do
          begin
            typ_size     := typ_std[form_char]^.typ_size;      { Default size }
            typ_min      := 0;
            typ_max      := -1; typ_parent := nil;
            typ_unsigned := true;              { Always unsigned }
            typ_align    := typ_std[form_char]^.typ_align;
            il  := 0;
            pvh := nil;
            sz  := 0;
            while sy = identsy do
            begin
              if sy_ident.l > il then il := sy_ident.l;        { Build max. id. len. }
              IDE_NEW( cla_konst, p1, ip);                     { Create the const ident }
              { Link to current ident block list }
              if typ_idelist = nil then typ_idelist := ip;
              typ_max := SUCC( typ_max );
              with ip^ do
              begin
                { Creates the Literal Constant record }
                VAL_NEW( ide_value, p1 );
                with ide_value^ do
                begin
                  val_kind := form_lit;
                  val_ival := typ_max
                end;
                pv := nil;
                { Create the related identifier cte. string }
                VAL_NEW( pv, nil );
                { ... with the appropriate links }
                if pvh = nil then pvh := pv
                             else pvl^.val_next := pv;
                pvl := pv;
                with pv^ do
                begin
                  val_kind := form_string;
                  val_size := 0;                               { Temporary }
                  NEW( val_str, sy_ident.l + 1 );
                  val_typ  := ima_typ^.typ_aeltype;
                  with val_str^ do
                  begin                                        { Add the string size as the first string's character }
                    length  := sy_ident.l + 1;
                    body[1] := CHR( sy_ident.l );
                    for i := 1 to sy_ident.l do
                      body[i+1] := sy_ident.s[i]
                  end
                end
              end;
              INSYMBOL;
              if sy = comma then INSYMBOL
              else
                if sy <> rparen then SRC_ERROR( mdnam, 23, e_error);
              if sy = comma then SRC_ERROR( mdnam, 27, e_error )
            end                                                { While sy = identsy };
            INSYMBOL;                                          { Gobble up the ")" }
            { Creates the constant image string table subtype parm. List }
            lgt1 := LGT_NEW_ECONST( typ_std[form_int], il );
            lgt2 := LGT_NEW_ECONST( typ_std[form_int], typ_max );
            lgt2^.lgt_nxt := lgt1;
            p2 := TYPE_PARM_SET( ima_typ^.typ_ide, lgt2 );
            { Set the correct identifier size of each constant }
            pv := pvh;
            while pv <> nil do
            with pv^ do
            begin
              val_size := il + 1;                              { Set the correct string id. allocated size }
              pv := val_next
            end;
            { Creates the constant image string table }
            { Build the ennumerated range cte for descriptor }
            with ima_typ^.typ_parmlst^ do
            if ide_nxt <> nil then
            begin
              VAL_NEW( pv, ide_nxt^.ide_typ );
              with pv^, ide_nxt^ do
              begin                                            { Set the allocated size for identifier strings }
                val_ival := il;
                if ide_typ <> nil then val_size := ide_typ^.typ_size;
                val_next := pvh
              end;
              pvh := pv;
              pv := nil; VAL_NEW( pv, ide_typ );
              with pv^ do
              begin                                            { Allocate the size of the main array }
                val_ival := typ_max;
                if ide_typ <> nil then val_size := ide_typ^.typ_size;
                val_next :=  pvh
              end;
              pvh := pv
            end;
            LGT_NEW( typ_idetab, p2, lgt_const, nil );
            VAL_NEW( typ_idetab^.lgt_cte, p2 );
            with typ_idetab^, lgt_cte^ do
            begin
              val_size := p2^.typ_size;
              val_lst  := pvh
            end;
            if typ_max > 255 then
            begin
              { Set appropriate size and alignement motion }
              if typ_max > 65535 then typ_size := 4
                                 else typ_size := 2
            end;
            { Get size and alignment specification in bits }
            sz  := typ_size;
            aln := sz - 1;
            SET_ALIGNMENT_SPC( sz, aln );
            if sy_init_mod and (sy = colon) then DATA_FORMAT_SET( p1 );
            if sz < typ_size then SRC_ERROR( mdnam, 214, e_error )
                             else typ_size := sz;
            if aln >= 0 then typ_align.int := aln
          end { with p1^ do };
          { Set the default conversion from any enumerate type }
          sy_type_gfirst := NEW_OPER( pcod_noop, p1, typ_std[form_ennum], cv_nop, [] )
       end;

      setsy:
        begin                                                   { Set Construction }
          INSYMBOL;                                             { Gobble up "set" }
          if sy = ofsy then INSYMBOL else SRC_ERROR( mdnam, 51, e_error );
          TYPE_SPC( p2, 0, nil, false, false );
          if p2^.typ_form > form_int then
          begin                                                 { The element type must be a fixed ennumerated type }
            SRC_ERROR( mdnam, 215, e_severe );
            p2 := typ_std[form_lit]                             { Set boolean type }
          end;
          { Get cardinality }
          i := p2^.typ_max + 1;
          if i > dst_seta then i := dst_seta;
          { Round up to a byte number }
          il := ( i + 7 ) div 8;
          { The possible set sizes are : 1, 2 or n*4 }
          if il > 2 then il := (( il + 3 ) div 4)*4;

          { Create a typ_rec descriptor }
          if i > dst_setw then
          begin                                                 { For large Set }
            IDE_NEW_TYP( form_lset, p1 );
            aln := typ_std[form_wlset]^.typ_align.int
          end
          else
          begin
            IDE_NEW_TYP( form_set, p1 );
            sz := 1;
            case il of
                1: aln := 0;
                2: aln := 1;
              3,4: aln := 3;
            otherwise
              aln := typ_std[form_wset]^.typ_align.int
            end
          end;
          with p1^ do
          begin
            typ_cardinality := i;
            typ_seltype     := p2;
            typ_size        := il;
            sz  := il;
            SET_ALIGNMENT_SPC( sz, aln );
            { Too small used size }
            if il > sz then
            begin
              SRC_ERROR( mdnam, 214, e_warning );
              sz := il
            end;
            { Set alignment and size }
            typ_size := sz;
            if aln >= 0 then typ_align.int := aln;
            {Set the Image tabble for the element type of a set of integer or char }
            if p2 <> nil then
            with p2^ do
              if typ_form = form_int then
              with usi_tab^ do
              begin
                LGT_NEW( typ_idetab, ide_typ, lgt_const, nil );
                VAl_COPY( ide_value, typ_idetab^.lgt_cte, false )
              end
              else if typ_form = form_char then
              with csi_tab^ do
              begin
                LGT_NEW( typ_idetab, ide_typ, lgt_const, nil);
                VAL_COPY( ide_value, typ_idetab^.lgt_cte, false )
              end
          end
        end;

      ifsy:
        begin
          SRC_ERROR( mdnam, 219, e_error );
          p1 := nil
        end;

      casesy:
        begin
          lgt1 := CASE_DEFINITION( intconst, nil );
          p1 := lgt1^.lgt_typ; LGT_FREE( lgt1 )
        end;

    otherwise
        begin
          p1 := nil;
          if sy = identsy then
          begin
            ip := IDE_SEARCH( [cla_type,cla_konst,cla_tparam,cla_generic] );
            p1 := ip^.ide_typ;
            if ip <> ide_udptr[cla_type] then                   { Declared object }
              { See if declared type }
              if ip^.ide_class = cla_type then
              begin
                p1 := ip^.ide_typ;
                INSYMBOL;                                       { Gobble up the identifier }
                { Import the synonymous generic definition }
                sy_type_gfirst := ip^.ide_gfirst;
                if sy = lparen then                             { Some arguments are given }
                begin
                  with ip^ do
                  if ide_typ^.typ_parmlst = nil then
                  begin                                         { Argument(s) given for a type without formal }
                    SRC_ERROR( mdnam, 206, e_error );
                    SKIP_SYMBOL( rparen )
                  end
                  else
                  begin
                    lgt := nil;
                    ip1 := ide_typ^.typ_parmlst;                { Get type arg. list head }
                    sy  := comma;
                    while ip1 <> nil do
                    begin                                       { Scan of the type arg. list }
                      if sy = comma then INSYMBOL;              { Gobble up "(" or "," }
                      if (sy = comma) or (sy = rparen) then     { Default value }
                        if ip1^.ide_cteval <> nil then
                        begin                                   { A default value is defined for this argument }
                          LGT_NEW( lgt1, ip1^.ide_typ, lgt_const, nil );
                          lgt1^.lgt_cte := ip1^.ide_cteval;
                          VAL_NEW( ip1^.ide_cteval, ip1^.ide_typ )
                        end
                        else SRC_ERROR_S( mdnam, 228, e_severe, ip1^.ide_name^ )
                      else                                      { A value type parameter is provided }
                        lgt1 := EXPRESSION_TYPE( ip1^.ide_typ );
                      { Link the parameter expression in a queue }
                      if lgt = nil then lgt := lgt1
                                   else lgt2^.lgt_nxt := lgt1;
                      lgt2 := lgt1;
                      ip1 := ip1^.ide_nxt                       { Skip to next one }
                    end;
                    if sy = rparen then INSYMBOL
                                   else SRC_ERROR( mdnam, 23, e_error );
                    p1 := TYPE_PARM_SET( ip, lgt )
                  end
                end
                else
                with ip^ do
                begin
                  if ide_typ^.typ_form = form_organization then
                  begin { The ip type must be private to be change in organization }
                    if sy = ofsy then
                    begin
                      INSYMBOL;                                 { Gobble up the "of" symbol }
                      iq := IDE_SEARCH( [cla_type] );
                      INSYMBOL;
                      if iq <> ide_udptr[cla_type] then         { Declared type }
                      begin
                        IDE_NEW_TYP( form_organization, p1 );
                        with p1^ do
                        begin
                          typ_parent      := ide_typ;
                          typ_eltype      := iq^.ide_typ;
                          typ_parmlst     := typ_eltype^.typ_parmlst;
                          typ_descr_size  := 0;
                          { Attach the organization generic function/procedure }
                          sy_type_gfirst  := ide_gfirst;
                          typ_comp_size   := nil;
                          typ_size        := ide_typ^.typ_size;
                          typ_hasidsc     := ide_typ^.typ_hasidsc;

                          {/// if typ_eltype^.typ_form <> form_record then SRC_ERROR( mdnam, 999, e_severe ) ///}
                        end
                      end
                    end
                    else
                      {/// if not buseorg then SRC_ERROR( mdnam, 999, e_severe ); ///}
                  end;
                  p1^.typ_hasidsc := ide_typ^.typ_hasidsc or (ide_typ^.typ_descr_size > 0)
                end
              end
              else p1 := nil
          end;

          if p1 = nil then                                      { Not a type identifier }
          begin                                                 { Range specification }
            { Get the minimum value, must be ennumerat type }
            lgt1 := EXPRESSION_TYPE( typ_std[form_ennum],,, true );
            if sy = twodot then INSYMBOL else SRC_ERROR( mdnam, 28, e_error );
            lgt2 := EXPRESSION_TYPE( lgt1^.lgt_typ,,, true );
            sz  := lgt1^.lgt_typ^.typ_size;
            aln := lgt1^.lgt_typ^.typ_align.int;
            SET_ALIGNMENT_SPC( sz, aln );                       { Get size and alignement in bytes }
            if sz < 4 then i := 2**(8*sz) else i := maxint;
            with lgt1^ do
              if (lgt_kind = lgt_const) and (lgt2^.lgt_kind = lgt_const) then
              begin                                             { Fixed range limits }
                IDE_NEW_TYP_RANGE( lgt_cte^.val_ival,
                                   lgt2^.lgt_cte^.val_ival, lgt_typ, p1 );

                if sy_init_mod and (sy = colon) then DATA_FORMAT_SET( p1 );
                LGT_FREE( lgt1 ); LGT_FREE( lgt2 );
                with p1^ do
                begin
                  typ_unsigned := ( typ_min >= 0 );
                  if sy_fix_range_ctl then
                  begin
                    if typ_unsigned then
                    begin
                      if typ_umin > typ_umax then
                      begin
                        typ_umax := typ_umin;
                        SRC_ERROR( mdnam, 211, e_error )
                      end
                    end
                    else
                      if typ_min > typ_max then
                      begin
                        typ_max := typ_min;
                        SRC_ERROR( mdnam, 211, e_error )
                      end;
                    if typ_unsigned then
                    begin
                      if sz < 4 then
                      if typ_umax >= i then
                      begin
                        sz := 4;
                        SRC_ERROR( mdnam, 212, e_error ); aln := 0
                      end
                    end
                    else
                    begin
                      if i <> maxint then i := i div 2;
                      if (typ_max >= i) or (typ_min < -i)  then
                      begin
                        sz := 4;
                        SRC_ERROR( mdnam, 213, e_error ); aln := 0
                      end
                    end
                  end
                end
              end
              else
              begin                                            { Dynamic range limits }
                IDE_NEW_TYP( form_range, p1 );
                with p1^ do
                begin
                  typ_parent := lgt_typ;                       { Link with the parent type }
                  if sy_fix_range_ctl then                     { Any dyn. is legal for for index }
                  begin
                    TYPE_CHECK_PARM( lgt1 );                   { Check for legal range bounds }
                    TYPE_CHECK_PARM( lgt2 )
                  end;
                  if lgt2^.lgt_kind <> lgt_const then
                    { The variable max value must be linked for conversion }
                    typ_high := LGT_NEW_CODE( pcod_noop, lgt2 )
                  else
                    { The constant max value can be used directly }
                    typ_high := lgt2;

                  typ_high^.lgt_typ := p1;                     { Set the High value range type }
                  if lgt1^.lgt_kind = lgt_const then
                  with lgt1^ do
                  begin                                        { The low limit is a constante }
                    typ_low := lgt1;
                    lgt_typ :=   p1;                           { Set the Low value range type }
                    if lgt_cte^.val_ival = 1 then              { typ_high is el.# }
                      { High limit = number of element (always variable) }
                      typ_nvalue := LGT_NEW_CODE( pcod_noop, lgt2 )
                    else
                    begin                                      { We must substract (low - 1) }
                      { The low limit must be decrease from 1 before ... }
                      typ_high^.lgt_nxt := LGT_NEW_ECONST( typ_std[form_int],
                                                 lgt_cte^.val_ival - 1 );
                      { Substract from the variable high limit }
                      typ_nvalue := LGT_NEW_CODE( pcod_isub, typ_high )
                    end
                  end
                  else                                         { Low is variable }
                  begin
                    { Built a conversion link with the expression of min val. }
                    typ_low := LGT_NEW_CODE( pcod_noop, lgt1 );
                    typ_low^.lgt_typ := p1;
                    if lgt2^.lgt_kind = lgt_const then
                    { The high limit is a constante,
                        that be incremented before ... }
                    begin
                      i := lgt2^.lgt_cte^.val_ival + 1;
                      if i = 0 then
                        { Substract can be replace by a negate ... }
                        typ_nvalue := LGT_NEW_CODE( pcod_ineg, typ_high )
                      else
                      begin                                    { ... to substract the low limit }
                        lgt1 := LGT_NEW_ECONST( typ_std[form_int], i );
                        lgt1^.lgt_nxt := typ_low;
                        typ_nvalue := LGT_NEW_CODE( pcod_isub, lgt1 )
                      end
                    end
                    else
                    begin                                      { All limits are variable }
                      typ_high^.lgt_nxt := typ_low;
                      lgt1 := LGT_NEW_CODE( pcod_isub, typ_high );
                      typ_nvalue := LGT_NEW_CODE( pcod_succ, lgt1 )
                    end
                  end
                end
              end;

            { Set the (Dynamic/Static) Range Allocation Size and Alignement }
            with p1^ do
            begin
              typ_size := sz;
              if aln >= 0 then typ_align.int := aln
            end
          end
        end;

    end { case };
    it := p1;                                                  { Give final type descriptor pointer };
  end
end TYPE_SPC;



procedure SET_DECL_ATTRIBUTE;
const
  mdnam = 'DATT';

var
  ipa: ide_ptr;

begin
  with sy_sym do
  begin
    INSYMBOL;                                  { Get the attribute }
    case sy of
      staticsy: begin  attr_kind := var_static; INSYMBOL  end;
      standardsy, globalsy, externalsy:
        begin
          if sy = globalsy then attr_kind := var_global
          else
          begin
            attr_kind := var_external;
            if sy = standardsy then
              if sy_init_mod then attr_kind := var_standard
                             else SRC_ERROR( mdnam, 992, e_error )
          end;
          INSYMBOL;
          attr_nam := nil;
          SET_STRNAME( attr_nam )
        end;

      identsy:
        begin
          ipa := LEVEL_SEARCH( attr_list );
          if ipa <> nil then
          case ipa^.ide_attr of
            atts_byte:     spc_asize    :=  1;
            atts_word:     spc_asize    :=  2;
            atts_long:     spc_asize    :=  4;
          otherwise
            SRC_ERROR_S( mdnam, 165, e_error, sy_ident )
          end
          else
            SRC_ERROR( mdnam, 162, e_error )
        end;

    otherwise
      SRC_ERROR( mdnam, 163, e_error );
      SKIP_SYMBOL( rbrack )
    end;
    if sy = rbrack then INSYMBOL
                   else SRC_ERROR( mdnam, 26, e_error )
  end
end SET_DECL_ATTRIBUTE;



procedure VARBL_SETTING {( v_class: class_types;
                           var isz, aln: integer; ty: typ_ptr ) was forward};
{ ty is the record type pointer if v_class = cla_field 
   this typ_rec record can be have typ_form equal to :
      form_record for a main record,
      form_variant for a variant record. }

const
  mdnam = 'VARB';

var
  it, it1:       typ_ptr;
  ip0, ip1, ip2, ip3, ipa: ide_ptr;
  i, n:          integer;
  lgtval, lgt1:  lgt_ptr;
  init_value:    val_ptr;
  acc:           var_access;
  ext_nam:       nam_ptr;
  vk, vext:      var_kind;
  bstp, bh, btw, bvl: boolean;

begin { VARBL_SETTING }
  bstp      := false;
  vext      := attr_kind;                              { Get the global state for external/global attribute ... }
  ext_nam   := nil;
  attr_kind := var_decl;                               { ... and set the normal local declaration mode at end }
  if attr_nam <> nil then
  begin { Signal any ignored external name }
    SRC_ERROR_S( mdnam, 166, e_warning, attr_nam^ );
    attr_nam   := nil
  end;
  n := 0;                                              { Init the maximum of alignement specification value }
  ip0 := nil; ip2 := nil;                              { Pointer of the previous ident in the list }
  { Get the last pointer as begining of field list }
  if v_class = cla_field then
    { We must not change if cla_type }
    ty^.typ_firstfield := lex_ident_tree[curr_disp].disp_ide_last;

  with sy_sym do
  while (sy = identsy) or (sy = lbrack) do
  begin
    ip3 := nil;                                        { No previous identifier exists in the sub list }
    init_value := nil;
    acc := [var_in, var_out];
    repeat
      case v_class of
        cla_varbl:
          begin
            if sy = lbrack then
            begin
              SET_DECL_ATTRIBUTE;
              if sy = identsy then
              begin { The attribute set is used here }
                vk        := attr_kind;
                ext_nam   := attr_nam;
                attr_kind := var_decl;                 { Reset the default declaration kind }
                attr_nam  := nil                       { Without external name }
              end
              else bstp := true                        { The attribute set is not used here }
            end
            else
            begin
              vk      := vext;
              ext_nam := nil
            end;
            if not bstp then
            begin
              cmp_twicedclon := true;
              IDE_NEW( cla_varbl, nil, ip1 );          { Create the new identifier }
              cmp_twicedclon := false;
              { Set allocation class when specified }
              if (vk <> var_decl) and (ext_nam <> nil) then
              with ip1^ do
              begin { Set an external name when it is defined }
                if ide_extnam <> nil then
                  if MATCH( ext_nam^, ide_extnam^ ) <> 0 then
                    SRC_ERROR_S( mdnam, 218, e_error, ide_name^ );
                ide_extnam := ext_nam
              end
            end
          end;
        cla_tparam:IDE_NEW( cla_tparam, nil, ip1 );    { Create the new type parm. }
        cla_type,                                      { Denotes field continuation mode }
        cla_field: IDE_NEW( cla_field, nil, ip1)       { Create the new rec. field }
      otherwise
      end;

      if not bstp then
      begin { Do not stop }
        if not cmp_twicedcl then
        begin                                          { Link Only when not Twice declared }
          if ip2 <> nil then ip2^.ide_nxt := ip1       { Previous link to curr. }
          else                                         { First in the full list }
            if ip0 = nil then ip0 := ip1               { First Variable };
          if ip3 = nil then ip3 := ip1;                { Keep the first of the curr. sub list }
          ip2 := ip1
        end;
        INSYMBOL;
        if sy = comma then INSYMBOL else
          if sy <> colon then SRC_ERROR( mdnam, 29, e_error );
        if sy = comma then SRC_ERROR( mdnam, 27, e_error )
      end
    until (sy <> identsy) and (sy <> lbrack);

    if not bstp then
    begin
      INSYMBOL;                                        { Gobble up the colon ":" }
      { Support of common attribute }
      spc_align := -1;                                 { Set to no specified alignement }
      spc_asize := -1;                                 { Set to no specified size }
      bh := false;                                     { Assume not hidden until shown otherwise }
      if sy = lbrack then
      begin { Handle the prefix type PASCAL II allocation class attribute }
        sy := comma;
        while sy = comma do
        begin
          INSYMBOL;                                    { Get the attribute }
          case sy of
            staticsy: begin  vk := var_static; INSYMBOL  end;
            globalsy, externalsy, standardsy:
              begin
                if sy = globalsy then vk := var_global
                                 else vk := var_external;
                if sy = standardsy then
                  if sy_init_mod then vk := var_standard       { /// was attr_kind := }
                                 else SRC_ERROR( mdnam, 992, e_error );
                INSYMBOL
              end;
            identsy:
              begin
                ipa := LEVEL_SEARCH( attr_list );
                INSYMBOL;
                if ipa <> nil then
                case ipa^.ide_attr of
                  atts_global:   vk := var_global;
                  atts_external: vk := var_external;
                  atts_static:   vk := var_static;
                  atts_hidden:   bh := true;
                  atts_volatil:                        { Presently Ignored };
                  atts_byte:     spc_asize    :=  1;
                  atts_word:     spc_asize    :=  2;
                  atts_long:     spc_asize    :=  4
                otherwise
                  SRC_ERROR_S( mdnam, 165, e_error, sy_ident )
                end
                else
                  SRC_ERROR_S( mdnam, 167, e_error, sy_ident )
              end;
          otherwise
            SRC_ERROR( mdnam, 163, e_error );
            SKIP_SYMBOL( rbrack )
          end
        end;
        if sy = rbrack then INSYMBOL
                       else SRC_ERROR( mdnam, 26, e_error )
      end;
      if (sy = privatesy) and (v_class = cla_varbl) then
      begin  INSYMBOL; bh := true  end;

      { Set up the globaly specified allocation class }
      { The "[global/external] var" construct. is effective when
        global/external/static are not localy specified }
      if (vk = var_decl) and (vext <> var_decl) then
      begin  vk := vext; ext_nam := nil  end;

      TYPE_SPC( it, 0, nil, false, false );            { Get the type specification }

      case v_class of
        cla_varbl:
          { When we have a variable size type with defined attached subtype,
            we use it in place of specified type. }
          if (it^.typ_size < 0) and (it^.typ_attsub <> nil) then
            it := it^.typ_attsub;
        cla_tparam:
          if it <> nil then
          with it^ do
          begin
            case typ_form of
              form_char, form_lit, form_int: ;
            otherwise
              SRC_ERROR( mdnam, 207, e_severe )
            end
          end;
        cla_field:
          with it^ do
          { Set the internal descriptor flag when required }
            if typ_hasidsc or (typ_descr_size > 0) then has_intdesc := true;

      otherwise
      end;

      { Update when required, the maximum alignement specification }
      with it^ do
      begin
        if n < typ_align.int then n := typ_align.int;
        { Get the default init value when defined for the type }
        init_value := typ_inival
      end;

      if v_class = cla_varbl then
      begin { Handle the post type PASCAL II allocation class }
        if vk = var_decl then
        case sy of
          staticsy:   begin vk := var_static;    INSYMBOL end;
          globalsy:   begin vk := var_global;    INSYMBOL end;
          externalsy: begin vk := var_external;  INSYMBOL end;
        otherwise
        end;
        if sy = insy then
        begin
          acc := [var_in];
          INSYMBOl
        end
      end;

      if (sy = becomes) or (sy = valuesy) then
        if v_class = cla_field then
        begin
          SRC_ERROR( mdnam, 220, e_error )             { Illegal for record's field declaration }
        end
        else
        begin                                          { Initial Value Specified }
          INSYMBOL;                                    { Gobble up ":=" or "value" }
          if (sy <> lparen) and (sy <> lbrack) then
            lgtval := EXPRESSION_TYPE( it )
          else
            lgtval := GET_AGREGATE( it );

          if lgtval^.lgt_kind <> lgt_const then
            SRC_ERROR( mdnam, 216, e_severe )          { Initial value is not a constant }
          else
          with lgtval^ do
          begin
            init_value := lgt_cte;
            lgt_cte := nil
          end;
          bvl := true;
          LGT_FREE_TREE( lgtval )
        end
      else bvl := false;

      { Handle the separator }
      if sy = semicolon then INSYMBOL                  { Skip any trailing identifier }
      else
        if sy = identsy then SRC_ERROR_S( mdnam, 52, e_error, sy_ident );

      { Set varbl identifier fields }
      if ip3 <> nil then                               { Does not anything when the identifier list is empty }
      repeat
        with ip3^ do
        begin
          it1 := ide_typ;
          ide_typ := it;                               { Set descriptor type pointer }
          if isz > 0 then isz := IDE_TYP_ALIGN( isz, it );     { *///* before was without condition }
          case v_class of
            cla_varbl:
              begin
                ide_vacc   := acc;                     { Set the variable access }
                if bh then ide_vacc := ide_vacc + [var_hidden];
                { Check and Set twice declared external variable become global }
                if (ide_vkind = var_external) or (ide_psect > 0) then
                begin { Check if Global and external type does not match }
                  if (it1 <> nil) and (it1 <> it) then
                    SRC_ERROR_S( mdnam, 217, e_severe, ide_name^ );
                  ide_vkind := vk
                end
                else
                begin { Set the requested kind for new variable }
                  if ide_vkind = var_tmp then ide_vkind := vk;
                  case ide_vkind of
                    var_global, var_external, var_standard:
                      begin
                        if ide_extnam = nil then       { Default external name }
                          SET_GBL_DEF_NAM( ide_extnam, ide_name^, 'V' );
                        ide_psect := -1
                      end;
                  otherwise
                    { Set the Global section for all common environments }
                    if (var_hidden in ide_vacc) or (cmp_igenv <> 0) then
                      ide_psect := -1; 
                  end;
                end;

                if init_value <> nil then
                  if (ide_vkind = var_external) or (ide_psect > 0) then
                  begin
                    if bvl then SRC_ERROR_S( mdnam, 209, e_error, ide_name^ );
                    { We must erase the initial type value
                      to do not free the value record }
                    init_value := nil
                  end
                  else
                  begin
                    ide_inival := init_value;
                    VAL_NEW( ide_inival, it );
                    with ide_inival^ do
                    begin
                      val_acc   := ip1^.ide_vacc;
                      val_psect := ide_psect
                    end
                  end;

                case ide_vkind of
                  var_global:
                    begin { Any visible variable must have an allocation }
                      if ide_typ^.typ_subtype or ide_typ^.typ_hasidsc then INIT_D_VARBL( ip3 );
                      ALL_NEW( ide_all, it, ip3, ide_vkind );
                      ide_all^.all_cte := ide_inival;
                      if all_fglobal = nil then all_fglobal := ide_all
                                           else all_lglobal^.all_nxt := ide_all;
                      ide_all^.all_prd := all_lglobal;
                      all_lglobal := ide_all
                    end;
                  var_decl, var_static:
                    if ide_psect = 0 then
                    begin
                      if ide_typ^.typ_subtype or ide_typ^.typ_hasidsc then INIT_D_VARBL( ip3 );
                      ALL_NEW( ide_all, it, ip3, ide_vkind );
                      ide_all^.all_cte := ide_inival;
                      if all_fstatic = nil then all_fstatic := ide_all
                                           else all_lstatic^.all_nxt := ide_all;
                      ide_all^.all_prd := all_lstatic;
                      all_lstatic := ide_all
                    end
                otherwise
                end
              end;

            cla_type,cla_field:
              with it^ do
              begin
                ide_offset := isz;
                if isz < 0 then                        { Previous Dynamic size of field was not allowed }
                  { A variable size field of record must be the last one }
                  SRC_ERROR( mdnam, 221, e_severe )
              end;

            cla_tparam:
              begin
                ide_tkind := tpa_sub;                  { Set as no value assigned } (* /// *)
                ide_cteval := init_value;

                { For any type parm. we must set the default values at max. }
                if ide_cteval = nil then
                begin
                  VAL_NEW( ide_cteval, it );
                  with ide_cteval^, it^ do
                  case typ_form of
                    form_char:
                      val_ival := typ_max;
                    form_lit, form_int:
                      if typ_max > 32767 then val_ival := 32767
                                         else val_ival := typ_max;
                  otherwise
                  end
                end
                else
                  VAL_NEW( ide_cteval, it );
                ide_toffset := isz
              end

          end;

          if isz >= 0 then                             { Not previously dynamic }
            if it^.typ_size >= 0 then                  { Current object has not a dynamic size }
              isz := isz + it^.typ_size
            else
              if ((v_class = cla_field) or (v_class = cla_type)) and
                 (it^.typ_comp_size <> nil) then
              begin { Build the tree for allocated size computing }
                lgt1 := LGT_LINK( it^.typ_comp_size );
                if isz > 0 then
                begin
                  lgt1^.lgt_nxt := LGT_NEW_ECONST( typ_std[form_int], isz );
                  ty^.typ_comp_size := LGT_NEW_CODE( pcod_iadd, lgt1 )
                end
                else ty^.typ_comp_size := lgt1;
                isz := -1                              { Flag for dynamic size part }
              end
              else
                { A dynamic size object cannot define except in
                  dynamicly allocated mode ( array or at the end of record ) }
                SRC_ERROR( mdnam, 301, e_severe )
        end;
        ip3 := ip3^.ide_nxt                            { Skip to next identifier of the same type }
      until ip3 = nil;
      if bvl and (init_value <> nil) then VAL_FREE( init_value );
      bvl := false
    end
  end { while full list };

  if not bstp then
  with sy_sym do
  case v_class of
    cla_field, cla_type: { Record/variant part }
      with ty^ do
      case sy of
        endsy: { End of record or variant }
          if (v_class = cla_field) and (isz >= 0) then
            typ_comp_size := LGT_NEW_ECONST( typ_std[form_int], isz );

        rparen:
          begin
            if (v_class = cla_field) and (isz >= 0) then
              typ_comp_size := LGT_NEW_ECONST( typ_std[form_int], isz );
            if ty^.typ_form <> form_variant then
            begin { When illegal out of a case }
              SRC_ERROR( mdnam, 223, e_error ); INSYMBOL
            end
          end;

        casesy:
          with ty^, lex_ident_tree[curr_disp] do
            if typ_size < 0 then
            begin { Case it allowed only after a fixed size part of record }
              SRC_ERROR( mdnam, 224, e_severe );
              INSYMBOL; SKIP_SYMBOL( endsy )
            end
            else
            begin { Variant part definition }
              INSYMBOL;                                { Gobble up the "case" }
              if v_class = cla_field then
                if typ_lastfield = nil then
                  typ_firstfield := disp_tree
                else                                   { We skip the last field of the previous record/variant }
                  typ_firstfield := typ_lastfield^.ide_nxt;
              typ_lastfield := disp_ide_last;          { Set the last field pointer }
              typ_recvar := CASE_DEFINITION( recordsy, ty );
              typ_comp_size := LGT_NEW_CODE( pcod_noop, typ_recvar )   { Size is always an integer }
            end;

        otherwise
          { end record, end case, ";", or when expected }
          SRC_ERROR( mdnam, 225, e_error )
        end;

  cla_tparam: if sy <> rparen then SRC_ERROR( mdnam, 23, e_error )
                              else INSYMBOL
  otherwise
  end;
  { update the global type alignement specification when required }
  aln := n;
  if ty <> nil then
  with ty^ do
    if n > typ_align.int then typ_align.int := n
end VARBL_SETTING;



procedure CONSTDECL;
const
  mdnam = 'COND';

var
  lgt: lgt_ptr;
  ip:  ide_ptr;
  bh:  boolean;

begin { CONSTDECL }
  ident_disp := curr_disp;
  with sy_sym do
  begin
    while (sy = identsy) or (sy = privatesy) do
    begin
      if sy = privatesy then
      begin
        INSYMBOL;
        bh := true;
      end
      else bh := false;
      if sy <> identsy then
      begin
        SRC_ERROR( mdnam, 107, e_severe );
        SKIP_SYMBOL( semicolon )
      end
      else
      begin
        IDE_NEW( cla_konst, nil, ip);
        INSYMBOL;                              { Get the "=" }

        if (sy <> relop) or (op <> eq_op) then
          SRC_ERROR( mdnam, 30, e_error )
        else
          INSYMBOL;
        lgt := EXPRESSION;
        with ip^, lgt^ do
        begin
          if lgt_kind <> lgt_const then SRC_ERROR( mdnam, 53, e_severe )
          else
          begin
            ide_typ   := lgt_typ;
            ide_value := lgt_cte;
            ide_ckind := var_static;
            lgt_cte   := nil;
            if (ide_value <> nil) and (not bh) and (cmp_igenv = 0) then
            if ide_typ <> nil then
            with ide_value^ do
            begin                              { Global constant in an environment }
              val_psect := 0;
              val_acc   := val_acc - [var_hidden];
              CTE_ALLOCATE( ide_value, ip )
            end;
            { Set during initialization process }
            if sy_init_mod then                { In Compiler SetUp mode }
              if ide_typ^.typ_form = form_array then
                if usi_tab = nil then usi_tab := ip
                                 else if csi_tab = nil then csi_tab := ip
          end
        end;
        if lgt <> nil then LGT_FREE_TREE( lgt )
      end;
      if (sy = comma) or (sy = semicolon) then INSYMBOL
    end { while }
  end
end CONSTDECL;



procedure TYPEDECL;
const
  mdnam = 'TYPD';

var
  bnorec:                           boolean;
  i, sav_disp, isz, aln, maln, max: integer;
  umax:                            unsigned;
  ip, p1, p2, p3, ipa:              ide_ptr;
  it, q, q1:                        typ_ptr;
  lgt, lgt1, lgt2, lgt3:            lgt_ptr;
  chain:                            id_name;
  bh:                               boolean;

begin { TYPEDECL }
  ident_disp := curr_disp;
  with sy_sym do
  begin
    if sy_init_mod then                                { In Compiler SetUp mode }
      while sy = withsy do
      begin
        INSYMBOL;                                      { Gobble up "with" }
        if sy = identsy then
        begin
          p1 := IDE_SEARCH( [cla_type] );              { Look for a defined type }
          if p1 <> nil then q := p1^.ide_typ
                       else q := nil;
          if q <> nil then
          begin
            INSYMBOL;                                  { Gobble up the type symbol }
            if sy = usesy then                         { Set a Size and Alignement specification }
            with q^ do
            begin
              isz := typ_size;
              aln := 0;
              SET_ALIGNMENT_SPC( isz, aln );
              typ_size := isz; typ_align.int := aln;

              if (typ_form = form_int) or
                 (typ_form = form_lit) or
                 (typ_form = form_char) then
                if isz < 4 then
                begin
                  if typ_unsigned then
                  begin { Only the integer can be use to calibrate the ennumerated types }
                    typ_umin := 0;
                    umax := 2**(8*isz);
                    if typ_umax > umax then typ_umax := umax - 1
                  end
                  else
                  begin
                    max := 2**(8*isz - 1);
                    if typ_max >= max then typ_max := max - 1;
                    if typ_min <= -max then typ_min := -max
                  end
                end
                else
                  if typ_unsigned then begin  typ_min := 0; typ_max := -1  end
                                  else begin  typ_max := maxint; typ_min := -typ_max - 1  end;

              case typ_form of
                form_int:
                  begin
                    inte_size := typ_size;
                    uns_typ^.typ_size      := typ_size;
                    uns_typ^.typ_align.int := typ_align.int
                  end;
                form_nil, form_pointer:
                  begin
                    fptr_size := typ_size;
                    typ_std[form_nil]^.typ_size          :=      typ_size;
                    typ_std[form_nil]^.typ_align.int     := typ_align.int;
                    typ_std[form_pointer]^.typ_size      :=      typ_size;
                    typ_std[form_pointer]^.typ_align.int := typ_align.int;
                    typ_std[form_pointer]^.typ_size      :=      typ_size;
                    typ_std[form_pointer]^.typ_align.int := typ_align.int;
                    typ_std[form_wfile]^.typ_size        :=      typ_size; { By default a file must be a kind of pointer }
                    typ_std[form_wfile]^.typ_align.int   := typ_align.int
                  end;
                form_single: sngl_size := typ_size;
                form_double: dble_size := typ_size;
                form_wwset, form_wset:
                  begin
                    dst_setw := typ_size*8;
                    dst_seti := (dst_seta + dst_setw - 1) div dst_setw;
                    typ_std[form_wlset]^.typ_align.int := typ_align.int;
                    typ_std[form_wwset]^.typ_align.int := typ_align.int;
                    typ_std[form_wset]^.typ_align.int  := typ_align.int;
                    typ_std[form_wwset]^.typ_size      := typ_size;
                    typ_std[form_wset]^.typ_size       := typ_size
                  end;
                form_wlset:
                  begin
                    dst_seta := typ_size*8;
                    dst_seti := (dst_seta + dst_setw - 1) div dst_setw;
                    typ_std[form_wwset]^.typ_align.int := typ_align.int;
                    typ_std[form_wset]^.typ_align.int  := typ_align.int
                  end;
                form_wfile:
                  begin
                    { The alignement of a file must be equal of pointer one }
                    maln := typ_std[form_pointer]^.typ_align.int;
                    if maln <> aln then typ_align.int := maln;
                    { The file size must be equal of multiple of pointer size }
                    maln := typ_std[form_wfile]^.typ_size;
                    if isz <> maln then
                    begin
                      if isz < maln then isz := maln
                        else if isz mod maln <> 0 then isz := maln*(isz div maln + 1);
                      typ_size := isz;
                    end;
                  end;

              otherwise
              end;
              if sy = colon then   DATA_FORMAT_SET( q );{ Set any target computer characteristics }

              if sy = semicolon then INSYMBOL
                                else SRC_ERROR( mdnam, 21, e_error )
            end
            else SKIP_SYMBOL( semicolon );
          end
          else
          begin { Unexisting type to modify }
            SRC_ERROR( mdnam, 8001, e_severe );
            SKIP_SYMBOL( semicolon )
          end
        end
        else
        begin
          SRC_ERROR( mdnam, 8002, e_severe );
          SKIP_SYMBOL( semicolon )
        end
      end;

    { * * * Normal Type declaration Flow * * * }

    while sy = identsy do                              { Loop on Definitions }
    begin
      p1 := fw_ptr; ip := nil;
      while (p1 <> nil) and (ip = nil) do
      begin
        with p1^ do
          if MATCH( ide_name^, sy_ident ) = 0 then
          begin
            ip := p1;                                  { Save the already created identifier }
            if p1 = fw_ptr then fw_ptr := fw_ptr^.ide_forlnk
            else p2^.ide_forlnk := p1^.ide_forlnk      { Take of from forward list }
          end;
        p2 := p1; p1 := p1^.ide_forlnk
      end;
      if ip = nil then
      begin
        { /// We should verify that the identifier is not a formal parameter /// }
        IDE_NEW( cla_type, nil, ip);                   { Create the type identifier }
        q := nil
      end
      else q := ip^.ide_typ;                           { Get the forward typ_rec address }
      with ip^ do
      begin
        sav_disp := curr_disp;                         { Save the display level }
        INSYMBOL;                                      { Get the "=" or "(" }
        isz := 0;
        if sy = lparen then                            { Get type parameter list }
        begin
          INSYMBOL;                                    { Gobble up "(" }
          NEW_DISP_LEVEL( nil, dsp_proc );             { Create a new display }
          VARBL_SETTING( cla_tparam, isz, maln, nil );
          p1 := lex_ident_tree[curr_disp].disp_tree;   { Get the parameter list }
          p3 := p1; { /// }
          lgt1 := nil;
          while p3 <> nil do
          begin { Loop on all type-parm. to build the def. parm. list value }
            LGT_NEW( lgt3, p3^.ide_typ, lgt_const, nil );
            lgt3^.lgt_cte := p3^.ide_cteval;
            VAL_NEW( lgt3^.lgt_cte, p3^.ide_typ );
            if lgt1 = nil then lgt1 := lgt3
                          else lgt2^.lgt_nxt := lgt3;
            lgt2 := lgt3;
            p3 := p3^.ide_nxt
          end
        end
        else p1 := nil;

        if (sy <> relop) or (op <> eq_op) then SRC_ERROR( mdnam, 30, e_error )
                                          else INSYMBOL;

        if sy = lbrack then
        begin { Handle the prefix type PASCAL II allocation class attribute }
          sy := comma;
          while sy = comma do
          begin
            INSYMBOL;                                  { Get the attribute }
            if sy = identsy then
            begin
              ipa := LEVEL_SEARCH( attr_list );
              INSYMBOL;
              if ipa <> nil then
              case ipa^.ide_attr of
                atts_hidden:   bh := true;
                atts_byte:     spc_asize    :=  1;
                atts_word:     spc_asize    :=  2;
                atts_long:     spc_asize    :=  4
              otherwise
                SRC_ERROR_S( mdnam, 161, e_error, sy_ident )
              end
              else
                SRC_ERROR_S( mdnam, 167, e_error, sy_ident )
            end
            else
            begin
              SRC_ERROR( mdnam, 163, e_error );
              SKIP_SYMBOL( rbrack )
            end
          end;
          if sy = rbrack then INSYMBOL
                         else SRC_ERROR( mdnam, 26, e_error )
        end;

        { Set the specified type descriptor pointer }
        TYPE_SPC( ide_typ, isz, p1, true, false );

        curr_disp  :=       sav_disp;                  { Restore the original display level }
        ide_gfirst := sy_type_gfirst;                  { Set the initial generic setting }
        ide_glast  :=            nil;                  { Link to previous type identifier definition }
        tcas_flag  :=          false;                  { Clear the Flag to signal a dynamic case in a record }
        with ide_typ^ do
        if p1 <> nil then
        begin                                          { For type with formal parameter(s) }
          { Set the appropriate alignement for the first no descr. object
            and for the whole of object }
          case typ_form of
            form_range, form_generic,
            form_set, form_lset, form_array, form_record:
              begin
                typ_descr_size := IDE_TYP_ALIGN( isz, ide_typ );
                typ_parmlst := p1;                     { Attach the type formal list to type here }
                if maln > ide_typ^.typ_align.int then
                  ide_typ^.typ_align.int := maln;
                if typ_size < 0 then
                begin
                  lgt := LGT_TYPE_EVAL( typ_comp_size, nil );
                  if lgt^.lgt_kind = lgt_const then
                  begin                                { To set a default size (Must be < 0) }
                    typ_size := - lgt^.lgt_cte^.val_ival;
                    { Force a negative value }
                    if typ_size >= 0 then typ_size := -1;
                    LGT_FREE( lgt )
                  end
                end
              end;
          otherwise
            { This type cannot have parameter }
            SRC_ERROR( mdnam, 205, e_severe )
          end;

          bnorec := (typ_form <> form_record);

          if bnorec then
          begin                                        { A descriptor size must be allocated }
            if typ_comp_size = nil then
              typ_size := typ_size + typ_descr_size
            else
            begin
              if typ_comp_size^.lgt_kind = lgt_const then
              begin
                with typ_comp_size^ do
                  if lgt_cte <> nil then
                    lgt_cte^.val_ival := lgt_cte^.val_ival + typ_descr_size
              end
              else
              begin
                typ_comp_size^.lgt_nxt := LGT_NEW_ECONST( typ_std[form_int],
                                                          typ_descr_size );
                typ_comp_size := LGT_NEW_CODE( pcod_iadd, typ_comp_size )
              end
            end
          end;

          if tcas_flag then LGT_GEN_ROUTINE( ide_typ ) { Build the Case related service routine }
        end;

        { ///  curr_disp := sav_disp;                  { /// Restore the original display level }
        with ide_typ^ do
          if typ_ide = nil then                        { When it is a copy type but a really new type ... }
          begin
            if typ_parent <> nil then                  { Get generic(s) of parent }
              if typ_parent^.typ_ide <> nil then       { If possible ... }
             (* sy_type_gfirst := typ_parent^.typ_ide^.ide_gfirst; *)
                ide_gfirst := typ_parent^.typ_ide^.ide_gfirst;
            typ_ide := ip                              { ... set the revers identifier pointer }
          end;

        if q <> nil then q^.typ_eltype := ide_typ;     { Resolve forward pointer }

        { Manage a type initial value when specified }
        if (sy = becomes) or (sy = valuesy) then
        begin
          INSYMBOL;                            { gobble up ":=" or "value" }
          if (sy = lbrack) or (sy = lparen) then lgt := GET_AGREGATE( ide_typ )
                                            else lgt := EXPRESSION_TYPE( ide_typ );
          if lgt^.lgt_kind <> lgt_const then
            SRC_ERROR( mdnam, 53, e_severe )

          else
          with lgt^ do
          begin
            ide_typ^.typ_inival := lgt_cte;
            lgt_cte := nil
          end;
          LGT_FREE_TREE( lgt )
        end;

        { Build an attached sub-type for each type with parameter }
        if (p1 <> nil) and(ide_typ <> nil) then
          { A type with parameters is defined }
          ide_typ^.typ_attsub := TYPE_PARM_SET( ip, lgt1 );
        if sy = semicolon then INSYMBOL
                          else SRC_ERROR( mdnam, 21, e_error )

(*
        ;DUMP_TYPES( 8, ide_typ )
*)
      end { With ip^ do }
    end { while }
  end { with sy_sym }
end TYPEDECL;



procedure VARDECL;
const
  mdnam = 'VARD';

var
  ifr, il, ip: ide_ptr;                        { Pointer of the variable list }
  isz, maln: integer;                          { Size to allocate at this block }

begin { VARDECL }
  ident_disp := curr_disp;
  isz := 0;
  with owner^ do
    VARBL_SETTING( cla_varbl, isz, maln, nil );
end VARDECL;



procedure LABELDECL;
const
  mdnam = 'LABD';

var
  ip: ide_ptr;
  bc: boolean;

begin { LABELDECL }
  bc := false;
  with sy_sym do
  begin
    repeat
      INSYMBOL;                                { Get the label identifier - Gobble up the separator }
      if sy = intconst then IDE_INT_LABEL;
      if sy <> identsy then SRC_ERROR( mdnam, 69, e_severe )
                                               { Create the new label identifier record ... }
      else
      begin
        IDE_NEW( cla_label, nil, ip );
        if ip <> nil then
        with ip^ do
        begin
          with owner^ do
            if pro_labelhde = nil then pro_labelhde := ip
                                  else lab_end_list^.ide_labnxt := ip;
          lab_end_list := ip;
          ide_labflg := [lab_decl]
        end
      end;
      INSYMBOL                                 { ... and gobble up it }
    until sy <> comma;
    if sy = semicolon then INSYMBOL
                      else SRC_ERROR( mdnam, 21, e_error )
  end
end LABELDECL;



procedure STATEMENTDECL;
{ Procedure to create a user statement definition }
const
  mdnam = 'STAD';

var
  sta:    [static] sta_rec := [nil, true, false, nil, nil, nil, nil, nil];
  ips:    sta_ptr;
  ip, iq: ide_ptr;
  ty:     typ_ptr;
  lg:     lgt_ptr;
  ndim:   integer;

begin
  with sy_sym do
  begin
    INSYMBOL;                                  { Get the new statement identifier to declare }
    if sy <> identsy then
    begin
      SRC_ERROR( mdnam, 107, e_severe );
      SKIP_SYMBOL( semicolon, true )
    end
    else
    begin                                      { Create the new statement identifier record }
      err_prt := false;                        { Disable error message }
      iq := IDE_SEARCH( [cla_statement] );     { Look at for a previous statement declaration with the same name }
      err_prt := true;                         { Re-enable error message }
      if iq <> nil then
        if iq^.ide_lex <> curr_lex then ip := nil      { Id. in the previous Lex }
                                   else ip := iq       { Id. in the Curr. Lex }
      else ip := nil;

      if ip = nil then                         { The identifier does not exist in the current Lex }
        IDE_NEW( cla_statement, nil, ip );     { Create the new identifier ... }
      INSYMBOL;                                { ... and gobble up it }

      with sta do
      begin
        if sy = withsy then
        begin
          INSYMBOL;
          if sy = packedsy then INSYMBOL;      { Ignore any packed specification }
          if sy = arraysy then
          begin                                { To accept any conformant array type }
            INSYMBOL;                          { Gobble up "array" }
            if sy <> lbrack then SRC_ERROR( mdnam, 25, e_error );
            ndim := 0;
            { Array_def add some var_vformal readonly parameters }
            ARRAY_DEF( sta_otyp, true, ndim )
          end
          else
            TYPE_SPC( sta_otyp, 0, nil, false, true );

          if sy = becomes then                 { A default context expression is specified }
          begin
            INSYMBOL;
            sta_dfcntx := EXPRESSION_TYPE( sta_otyp )   { Get it }
          end;
          if sy = repeatsy then
          begin  sta_rcnt := true; INSYMBOL  end;
          if sy = dosy then INSYMBOL
                       else SRC_ERROR( mdnam, 55, e_error )
        end;
        if sy = identsy then
        begin
          sta_select := IDE_SEARCH( [cla_type, cla_generic] );
          INSYMBOL
        end;
        if sy = comma then INSYMBOL
                      else SRC_ERROR( mdnam, 29, e_error );
        if sy = identsy then
        begin
          sta_prstat := IDE_SEARCH( [cla_type, cla_generic] );
          INSYMBOL
        end else SRC_ERROR_S( mdnam, 42, e_severe, ip^.ide_name^ );
        if sy = comma then
        begin
          INSYMBOL;
          if sy = identsy then
          begin
            sta_ndstat := IDE_SEARCH( [cla_type, cla_generic] );
            INSYMBOL
          end
          else SRC_ERROR_S( mdnam, 43, e_error, ip^.ide_name^ )
        end
      end;

      if error_result <= e_warning then
      begin                                    { When no arror was occurred }
        NEW( ips );                            { Create the new statement record }
        ips^ := sta;                           { Load the statement record }
        with ip^ do
        begin                                  { Link this statement record with the identifier }
          if ide_stalast = nil then
          begin                                { No previous local definitions }
            if iq <> nil then                  { A previous definition was existing in an external Lex }
              ips^.sta_nxt := iq^.ide_stafirst;{ Link it to the external Lex definitions }
            ide_stafirst := ips;               { Set the link with this first? statement definition }
            ide_stalast  := ips
          end
          else
          begin                                { Some Previous local definition exist }
            ips^.sta_nxt := ide_stalast^.sta_nxt;      { Carry the Link to external Lex }
            ide_stalast^.sta_nxt := ips;       { Link the previuos definition to the new current one }
            ide_stalast := ips                 { Set as the new last in the current Lex }
          end
        end
      end
    end;
    if sy = semicolon then INSYMBOL
                      else SRC_ERROR( mdnam, 21, e_error )
  end
end STATEMENTDECL;




{******************************************************}
{*** Generic Procedure/Function Declaration routine ***}
{******************************************************}


function  ARGUMENT_LIST { ( var pr: pro_ptr; isfunct, no_entry: boolean ): boolean; Was Forward };
{ Parmlist parses the argument list and determines how parameters are to be passed.
  For large value_ parameters ( arrays, records ), an implementation dependant decision
  is made.
  isfunct must be set to manage the returned function type.
  If no_entry is set, an error message is emitted when a formal entry (procedure/function)
  argument is found.
  The returned value is true when a Entry argument was found.
}
const
  mdnam = 'ARGL';

var
  lgt:                     lgt_ptr;
  saveowner:               pro_ptr;
  ip1, ip2, ip3:           ide_ptr;
  tp1, tp2:                typ_ptr;
  acckind:              var_access;
  lvkind:                 var_kind;
  npa, npt, ndim:          integer;
  isfnc, fentry, battr:    boolean;
  defval:                  val_ptr;
  fprop:               oparg_flags;


begin { ARGUMENT_LIST }
  fentry := false;                                     { Assume no formal entry as argument until shown otherwise }
  saveowner := owner;                                  { Save current owner }
  owner :=  pr;                                        { Set current procedure as owner of new created type }
  ip1   := nil;                                        { Set the argument list to empty state }
  npa   :=   0;                                        { Init the total argument count }
  with sy_sym, pr^ do
  begin
    if sy = lparen then                                { When some argument are specified }
    begin
      sy := semicolon;
      repeat { * Loop on the argument sub-list (<access_mode> <arg._list> : [<attr>] <type>) }
        INSYMBOL;                                      { Gobble up "(" or ";" }
        if (sy = proceduresy) or (sy = functionsy) then
        begin                                          { Formal Entry (=procedure/function) definition }
          if no_entry then SRC_ERROR( mdnam, 125, e_severe );  { Formal entry on a generic is not allowed }
          fentry := true;                              { Set the formal entry flag }
          isfnc := (sy = functionsy);
          INSYMBOL;
          ip3 := FORMAL_PROC_DECL( isfnc );            { Build the Formal Entry Identifier and Descriptor }
          npa := npa + 1;                              { Update the total count of argument }
          { Link inside the list done by IDE_NEW }
          if ip1 = nil then ip1 := ip3;                { Set the begin of the full list }
          ip2 := ip3                                   { Set ip2 as first sub list pointer }
        end
        else
        begin                                          { Variable Formal Parameter }
          npt     := 0;                                { Init the partial argument list counter }
          acckind := [var_in,var_out];                 { Assume in/out mode inside procedure ... }
          battr   := false;                            { ... and no specified attribute }
          fprop   :=    [];                            { The default is without special formal properties }
          lvkind  := var_vformal;                      { Default argument access to "by value" model }
          repeat                                       { When required, Set the specified access attribute }
            case sy of
              varsy:    lvkind := var_formal;
              invarsy:  begin  acckind := [var_in];  lvkind := var_formal  end;
              outvarsy: begin  acckind := [var_out]; lvkind := var_formal  end;
            otherwise
              battr := true
            end;
            if not battr then INSYMBOL                 { Gobble up the Access Keyword ("var", "in-var" or "out_var") }
          until battr;

          ip2 := nil;                                  { A new sub list is begining }
          while sy = identsy do
          begin
            IDE_NEW( cla_varbl, nil, ip3 );            { The formal var_vkind is var_tmp }
            npa := npa + 1;                            { Update the partial and total argument counts }
            npt := npt + 1;
            { Link inside the sub list }
            if ip2 = nil then
            begin { * Begin of a sub list }
              if ip1 = nil then ip1 := ip3;            { Set begin of the full list}
              ip2 := ip3                               { Set ip2 as first sub-list pointer }
            end;
            INSYMBOL;                                  { Gobble up the identifier }
            if sy = comma then INSYMBOL                { Gobble up the comma separator if given }
              else                                     { Else ==> ":" must be present as the end of argument sub-list }
                if sy <> colon then SRC_ERROR( mdnam, 29, e_error )
          end;
          { Gobble up the separator ":" before the }
          if sy <> colon then SRC_ERROR( mdnam, 31, e_error )
                         else INSYMBOL { Gobble up ":" };
          { Parse the type. we can use short org. spc. }
          if sy = lbrack then
          begin { * Attribute management }
            repeat
              INSYMBOL;                                { Gobble up "[" or "," }
              if sy = identsy then
              begin
                ip3 := LEVEL_SEARCH( attr_list );
                INSYMBOL;                              { Gobble up the attribute }
                if ip3 <> nil then
                case ip3^.ide_attr of                  { Set the specified access attribute }
                  attr_name:     acckind := acckind + [var_named];
                  attr_card:     acckind := acckind + [var_card];
                  attr_size:     acckind := acckind + [var_size];
                  attr_image:    acckind := acckind + [var_image];
                  atts_optional:
                    begin
                      if lvkind <> var_formal then
                        SRC_ERROR( mdnam, 242, e_error );
                      acckind := acckind + [var_optional];
                    end;
                  atts_readonly: acckind := acckind + [var_in] - [var_out];
                  attp_ind: fprop := fprop + [a_ind];
                  attp_dir: fprop := fprop + [a_dir];
                  attp_sty: fprop := fprop + [a_sty];
                  attp_ety: fprop := fprop + [a_ety];
                  attp_rty: fprop := fprop + [a_rty];
                otherwise  
                end
              end
              else SRC_ERROR( mdnam, 2, e_severe )
            until sy <> comma;
            if sy = rbrack then INSYMBOL
                           else SRC_ERROR( mdnam, 26, e_error )
          end;
          { * Get the argument type * }
          if sy = packedsy then INSYMBOL;              { Ignore any packed specification }
          if sy = arraysy then                         {  Conformant Array Management }
          begin { * The common conformant array type are not supported (one type for each array) }
            if npt > 1 then SRC_ERROR( mdnam, 243, e_severe );
            INSYMBOL;                                  { Gobble up "array" }
            if sy <> lbrack then SRC_ERROR( mdnam, 25, e_error );
            ndim := 0;
            if not sy_init_mod then
              if (lvkind = var_vformal) and (not cmp_dynamic) then
              begin
                lvkind := var_formal; acckind := [var_in];
                SRC_ERROR( mdnam, 229, e_warning )
              end;
            { Array_def add some var_vformal readonly arguments }
            ARRAY_DEF( tp1, true, ndim )
          end
          else
          begin { * Standard Argument type }
            TYPE_SPC( tp1, 0, nil, false, true );
            if tp1 <> nil then
              if not sy_init_mod then
                if (tp1^.typ_size < 0) and (lvkind = var_vformal) and
                   (not cmp_dynamic) then
                begin
                  lvkind := var_formal; acckind := [var_in];
                  SRC_ERROR( mdnam, 226, e_warning )
                end
          end;
          if sy = becomes then                         { Default value Management }
          begin
            INSYMBOL;
            lgt := EXPRESSION_TYPE( tp1 );
            with lgt^ do
            if lgt_kind <> lgt_const then
              SRC_ERROR( mdnam, 53, e_severe )
            else
            begin
              defval := lgt_cte;
              lgt_cte := nil
            end;
            if (lvkind = var_formal) and (var_out in acckind) then
              SRC_ERROR( mdnam, 241, e_error )
          end
          else defval := nil                           { No default value };
          ip3 := ip2;                                  { Start type assignement from begin of sublist }
          while ip3 <> nil do
          begin
            with ip3^ do
            if ide_vkind = var_tmp then                { Keep conformant array sub vformal }
            begin
              ide_typ    := tp1;
              ide_vacc   := acckind;
              ide_vkind  := lvkind;
              ide_inival := defval;
              ide_sprop  := fprop;
              if defval <> nil then VAL_NEW( ide_inival, tp1 )
            end;
            ip2 := ip3; ip3 := ip3^.ide_nxt
          end;
          if defval <> nil then VAL_FREE( defval )
        end
      until sy <> semicolon;
      if sy = rparen then INSYMBOL
                     else SRC_ERROR( mdnam, 23, e_error );
    end;
    pro_typ := nil;                                    { Assume its not a function }
    if isfunct then
    begin { * Parse function type }
      if sy = colon then INSYMBOL else SRC_ERROR( mdnam, 31, e_error );
      { Parse the function type, short org. ref. allowed }
      acckind := [var_in,var_out,var_used];
      if sy = lbrack then
      begin { * Attribute management }
        repeat
          INSYMBOL;                                    { Gobble up "[" or "," }
          if sy = identsy then
          begin
            ip3 := LEVEL_SEARCH( attr_list );
            INSYMBOL;                                  { Gobble up the attribute }
            if ip3 <> nil then
              case ip3^.ide_attr of
                attr_card:  acckind := acckind + [var_card];
                attr_size:  acckind := acckind + [var_size];
              otherwise  
              end
          end
          else SRC_ERROR( mdnam, 2, e_severe )
        until sy <> comma;
        if sy = rbrack then INSYMBOL
                       else SRC_ERROR( mdnam, 26, e_error );
      end;
      TYPE_SPC( pro_typ, 0, nil, false, true );
      { To have always an expression type }
      if pro_typ = nil then pro_typ := typ_std[form_wild]
    end;
    if pro_typ <> nil then                             { Legal function }
    if not pro_typ^.typ_simple then
    begin
      with pro_typ^ do
        if (typ_size < 0) and (typ_attsub <> nil) then
          pro_typ := typ_attsub;

      { ip2 -> on the last parameter }
      IDE_CREATE_NAME( '.rv' );                        { Enter Dummy Ident for Returned Value }
      IDE_NEW( cla_varbl, pro_typ, ip3 );
      if ip1 <> nil then                               { Some argument(s) are defined }
        ip2^.ide_nxt := nil;                           { Destroy the IDE_NEW link of this pseudo arg. (ip2 -> the last arg.) }
      with ip3^ do
      begin
        ide_nxt := ip1; ip1 := ip3;                    { Link in first parameter }
        ide_vacc := acckind;
        ide_vkind := var_result
      end
    end;
    pro_nparm   := npa;                                { Set the total argument count }
    pro_parmlst := ip1;
    with lex_ident_tree[curr_disp] do
    begin { * Copy (Save) some argument list specific values }
      pro_idetree := disp_tree;                        { Argument list tree root identifier }
      pro_idelast := disp_ide_last;                    { Argument list last identifier }
      pro_prmtyls := disp_typ_hde                      { Argument list first related type record }
    end
  end;
  owner := saveowner;
  ARGUMENT_LIST := fentry
end ARGUMENT_LIST;



function FORMAL_PROC_DECL {( isfunction: boolean ): ide_ptr; Was Forward };
{ To Create a Formal Procedure/Function structure }
const
  mdnam = 'FPDE';

var
  ty:                  typ_ptr;
  ip, iq:              ide_ptr;
  pr, pr1:             pro_ptr;
  oldlevel, olddisp:   integer;
  flg:                 boolean;

begin { FORMAL_PROC_DECL }
  with sy_sym do
  if sy = identsy then
  begin
    ip := LEVEL_SEARCH( lex_ident_tree[curr_disp].disp_tree );
    if ip <> nil then SRC_ERROR( mdnam, 101, e_severe );
    IDE_NEW( cla_fentry, nil, ip );                    { Create the formal procedure pointer identifier }
    NEW( pr, pro_formal );                             { Allocate the procedure descriptor }
    with pr^ do
    begin { * Fill the procedure descriptor }
      pro_next     :=          nil;
      pro_link     :=          nil;
      pro_flags    :=           [];
      pro_stdname  :=          nil;
      pro_operator :=        no_op;
      pro_geneide  :=          nil;
      pro_idetree  :=          nil;
      pro_idelast  :=          nil;
      pro_parmlst  :=          nil;                    { No parameters }
      pro_lex      :=     curr_lex;
      pro_parmsize :=            0;
      pro_nparm    :=            0;
      pro_typ      :=          nil;
      pro_prmtyls  :=          nil;                    { No type }
      pro_pkind    :=   pro_formal;
      pro_f_all    :=          nil
    end;
    ip^.ide_entry := pr;                               { Link the identifier with the entry descriptor }

    oldlevel :=  curr_lex; 
    olddisp  := curr_disp;
    if curr_lex < max_lex then curr_lex := SUCC( curr_lex )
                          else SRC_ERROR( mdnam, 1002, e_severe );
    NEW_DISP_LEVEL( pr, dsp_proc );
    lex_ident_level[curr_lex] := curr_disp;
    INSYMBOL;
    flg := ARGUMENT_LIST( pr, isfunction, false );     { Look for parameter list }
    curr_lex := oldlevel; curr_disp := olddisp;

    { Now set the default entry when given }
    if sy = becomes then
    begin { * Manage the default entry when specified }
      INSYMBOL;                                        { Gobble up the ":=" operator }
      if sy = identsy then
      begin
        { Search the identifier }
        iq := IDE_SEARCH( [cla_type, cla_fentry, cla_genwfent, cla_generic] );
        if iq <> ide_udptr[cla_type] then              { if it is Defined identifier }
        with iq^, ide_typ^ do
        begin { * Look at for formal procedure identifier }
          pr1 := nil;
          if ide_class = cla_fentry then
          begin
             pr1 := ide_entry;
             if pr1 = pr then SRC_ERROR( mdnam, 403, e_severe )        { Cannot loop on the formal procedure definition }
          end
          else
          begin
            if (ide_glast <> ide_gfirst) and (ide_glast <> nil) then
              SRC_ERROR_S( mdnam, 118, e_error, sy_ident )
            else
            with ide_gfirst^ do
              if gen_blt then SRC_ERROR( mdnam, 998, e_fatal )
                         else pr1 := gen_proc
          end;
          { Now we must verify the compatibilty between the model and the default}
          if not COMP_PROC_ARG( pr1, pr ) then SRC_ERROR( mdnam, 119, e_severe )
                                          else ip^.ide_defentry := pr1;
          INSYMBOL                                     { Gobble up the default procedure }
        end
      end
(*    else if sy = nilsy then INSYMBOL /// *)
      else SRC_ERROR( mdnam, 32, e_severe )            { An Entry identifier was expected }
    end
  end
  else
  begin
    ip := ide_udptr[cla_fentry];
    SRC_ERROR( mdnam, 107, e_severe )
  end;
  FORMAL_PROC_DECL := ip
end FORMAL_PROC_DECL;




function FORMAL_PROC_PTR { ( isfunction: boolean ): typ_ptr; Was Forward };
{ To Create a Formal Procedure/Function structure }
const
  mdnam = 'FPDE';

var
  ty:                  typ_ptr;
  iq:                  ide_ptr;
  pr, pr1:             pro_ptr;
  oldlevel, olddisp:   integer;
  flg:                 boolean;

begin { FORMAL_PROC_PTR }
  with sy_sym do
  begin
    NEW( pr, pro_formal );                              { Allocate the procedure descriptor }
    with pr^ do
    begin { * Fill the procedure descriptor }
      pro_next     :=          nil;
      pro_link     :=          nil;
      pro_flags    :=           [];
      pro_stdname  :=          nil;
      pro_operator :=        no_op;
      pro_geneide  :=          nil;
      pro_idetree  :=          nil;
      pro_idelast  :=          nil;
      pro_parmlst  :=          nil;                     { No parameters }
      pro_lex      :=     curr_lex;
      pro_parmsize :=            0;
      pro_nparm    :=            0;
      pro_typ      :=          nil;
      pro_prmtyls  :=          nil;                     { No type }
      pro_pkind    :=   pro_formal;
      pro_f_all    :=          nil
    end;
    oldlevel :=  curr_lex; 
    olddisp  := curr_disp;
    if curr_lex < max_lex then curr_lex := SUCC( curr_lex )
                          else SRC_ERROR( mdnam, 1002, e_severe );
    NEW_DISP_LEVEL( pr, dsp_proc );
    lex_ident_level[curr_lex] := curr_disp;
    INSYMBOL;                                           { Gobble up the keyword procedure or function }
    flg := ARGUMENT_LIST( pr, isfunction, false );      { Look for parameter list }
    curr_lex := oldlevel; curr_disp := olddisp;
    { Now set the default entry when given }
    if sy = becomes then
    begin { * Manage the default entry when specified }
      INSYMBOL;                                         { Gobble up the ":=" operator }
      if sy = identsy then
      begin
        { Search the identifier }
        iq := IDE_SEARCH( [cla_type, cla_fentry, cla_genwfent, cla_generic] );
        if iq <> ide_udptr[cla_type] then               { if it is Defined identifier }
        with iq^, ide_typ^ do
        begin { * Look at for formal procedure identifier }
          pr1 := nil;
          if ide_class = cla_fentry then
          begin
             pr1 := ide_entry;
             if pr1 = pr then SRC_ERROR( mdnam, 403, e_severe )     { Cannot loop on the formal procedure definition }
          end
          else
          begin
            if (ide_glast <> ide_gfirst) and (ide_glast <> nil) then
              SRC_ERROR_S( mdnam, 118, e_error, sy_ident )
            else
            with ide_gfirst^ do
              if gen_blt then SRC_ERROR( mdnam, 998, e_fatal )
                         else pr1 := gen_proc
          end;
          { Now we must verify the compatibilty between the model and the default}
          if not COMP_PROC_ARG( pr1, pr ) then SRC_ERROR( mdnam, 119, e_severe )
                                          else iq^.ide_defentry := pr1;
          INSYMBOL                                      { Gobble up the default procedure }
        end
      end
      else SRC_ERROR( mdnam, 32, e_severe )             { An Entry identifier was expected }
    end
    else pr1 := nil
  end;
  IDE_NEW_TYP( form_fentry, ty );                       { Create the Entry Pointer Type Descriptor }
  with ty^ do
  begin
    typ_parent := nil; { /// typ_std[form_nil]; }
    typ_align  := typ_std[form_nil]^.typ_align;
    typ_size   :=         fptr_size;
    typ_return :=       pr^.pro_typ;
    typ_entry  :=                pr
  end;
  FORMAL_PROC_PTR := ty
end FORMAL_PROC_PTR;



procedure INSERT_NEW_GENERIC( var pgfirst, pglast: gen_ptr; pg: gen_ptr; bwfent: boolean );
const
  mdnam = 'IGEN';

{ Put a gen_ptr (entry descriptor access record) in a generic entry list }
begin
  if pg <> nil then
  begin
    if bwfent and (pgfirst <> nil) then        { Send an error for multi definition of a generic ... }
      SRC_ERROR( mdnam, 114, e_severe );       { ... with formal procedure in the same lex }

    if sy_generic_qmod then                    { Use the Queue mode (default in first init_mode) }
    begin
      if pgfirst = nil then pgfirst := pg      { Link new entry at the end of queue (first position when the queue is empty) }
                       else pglast^.gen_link := pg;
      pglast := pg                             { Update the last pointer }
    end
    else
    begin                                      { Use the default fifo mode }
      pg^.gen_link := pgfirst;                 { Link to entry of more external lex display
                                                 or to previous entry in the list }
      pgfirst := pg;                           { The new first entry is the actual entry (FIFO logique) }
      if pglast = nil then pglast := pg        { The last entry (for generic search scan) if the first inserted one }
    end;
  end
end INSERT_NEW_GENERIC;



procedure GENE_DECL;
{ To create a generic name for many procedures or functions }
const
  mdnam = 'GEND';

var
  bfunc,                                       { To switch between procedure and function (true) }
  formal_entry,                                { To flag the use of a formal procedure/function }
  cannot_formal,                               { To flag formal proc/func. impossible }
  wasforward,                                  { To flag a forward procedure }
  to_compile,                                  { If this entry must be compiled (global or local) }
  biniskip,
  bpo1,                                        { Flag set for a not defined operator }
  bfirst:              boolean;                { Flag to indicate the first use of generic name }

  save_ide,                                    { Save some ident name }
  saved_name:          id_name;                { To save the procedure/generic/type name }
  savesym:             sym_rec;                { To save sy_sym } 

  pk:                pro_kinds;                { Entry Specification (global external) }

  dcl_name,                                    { Used name for declaration }
  extern_name:         nam_ptr;                { Related external name }

  oldfwptr,                                    { Pointer type forward def. pointer save }
  ip1,                                         { Pointer of more global local identifier }
  ip:                  ide_ptr;                { Pointer of related identifier }
  pr:                  pro_ptr;                { Pointer of the procedure block }
  pg:                  gen_ptr;                { Pointer of the generic entry }
  typ:                 typ_ptr;
  geneclass:       class_types;                { Generic class type memory }
  op1:                operator;                { Generic operator memory }
  po1, po2:            ope_ptr;
  procdisp, proclex,                           { Procedure disp and lex }
  oldlevel, olddisp,                           { Previous disp and lex }
  i, npa:              integer;                { Count and Formal Flag Number for Generic Operator }



procedure PROC_DECL( pgf, pgl: gen_ptr );
{ Return the procedure definition pointer.
  If pr was not nil at call then a forward declaration is completed.
  If bfunc is true we create a function
}
const
  mdnam = 'DPRO';

var
  i:          integer;
  id1, id2:   ide_ptr;
  bnew,
  binsymbol,
  bsemicolon: boolean;
  tpr:        pro_ptr;

begin { PROC_DECL }
  to_compile := false;                                 { Until showed otherwise }
  pg  := nil;                                          { Assume not generic mode until showed otherwise }
  id1 := nil;
  INSYMBOL;                                            { Gobble up the procedure/function/generic name/operator }
  { A forward procedure/function can be have a new definition }
  if sy_sym.sy = lparen then wasforward := false;
  if not wasforward then
  begin { Create the new procedure structures }
    NEW( pr );                                         { Create the procedure record definition }
    with pr^ do
    begin
      pro_next     :=      nil;
      pro_link     :=      nil;
      pro_flags    :=       [];
      pro_stdname  :=      nil;
      pro_operator :=    no_op;
      pro_geneide  :=      nil;
      pro_idetree  :=      nil;
      pro_idelast  :=      nil;
      pro_parmlst  :=      nil;                        { No parameters }
      pro_lex      := curr_lex;
      pro_parmsize :=        0;                        { Define empty parameter space }
      pro_nparm    :=        0;
      pro_typ      :=      nil;
      pro_prmtyls  :=      nil;                        { No type }
      pro_pkind    := pro_decl;                        { Until showed otherwise }
      { To Compile entry information init }
      pro_owner    :=    owner;
      pro_srcinfo  :=      nil;
      pro_lgt      :=      nil;                        { Empty logical tree }
      pro_lst      :=      nil;
      pro_init_hde :=      nil;                        { Init the init node list }
      pro_opelst   :=      nil;
      pro_labelhde :=      nil;
      pro_reserved :=      nil;                        { The reserved list is set to be empty }
      pro_cntxide  :=      nil;
      pro_loclst   :=      nil;                        { No local identifier definition }
      pro_typlst   :=      nil;                        { No local type definition }
      pro_fdyn_all :=      nil;
      pro_ldyn_all :=      nil;                        { No current dynamic allocation }
      pro_reglist  :=      nil;
      pro_labelenv :=       -1;                        { Global label environment count }
      pro_labelcnt :=        0;
      pro_envidx   :=        0;                        { Init the Lex Access environment }
      pro_stk_size :=        0;                        { Init the temporary dynamic stack size }
      pro_dyn_size :=        0;
      pro_intacc   :=    false                         { Init of flag for internal access }
    end
  end
  else
  with pr^ do                                          { Was forward or new generic definition }
  begin                                                { Must restore argument list to id1 }
    id1 := pro_parmlst;
    if pro_typ <> nil then                             { if it i a Function with a not simple type result, }
      if not pro_typ^.typ_simple then                  { ... we must skip the dummy argument for the function ... }
        id1 := id1^.ide_nxt                            { ... result because the tree id. root is the first arg. }
  end;

  { Create the new lex display for this entry (procedure or function) }
  if curr_lex < max_lex then curr_lex := SUCC( curr_lex )
                        else SRC_ERROR( mdnam, 1002, e_severe );
  NEW_DISP_LEVEL( pr, dsp_proc );
  lex_ident_tree[curr_disp].disp_tree := id1;          { Attache the argument identifier tree }
  lex_ident_level[curr_lex]   :=   curr_disp;          { lex = curr_lex base is curr_disp }
  procdisp := curr_disp; proclex := curr_lex;          { Save Proc. Display and Lex }

  with sy_sym do
  begin
    if not wasforward then                             { Except when a forward definition was present, ... }
    begin                                              { ...we must parse and generate the argument list }
      formal_entry := ARGUMENT_LIST( pr, bfunc, cannot_formal );

      if sy = semicolon then INSYMBOL
                        else SRC_ERROR( mdnam, 21, e_error );

      { Check for available number of argument(s) for operator }
      { if npa <> 0 then the number of argument(s) must be np }
      if npa <> 0 then                                 { Good number of argument for operator (if noop then npa = 0) ? }
        if npa > 0 then
          if pr^.pro_nparm <> npa then SRC_ERROR_S( mdnam, 127, e_error, saved_name )
          else                                         { neg/sub case }
            if (pr^.pro_nparm <> 1) and (pr^.pro_nparm <> 2) then
              SRC_ERROR_S( mdnam, 127, e_error, saved_name );

      { Look for the same procedure/function entry in the lex }
      pg := COMPARE_PROC_ARGID( pgf, pgl, pr );        { Found Only User (Not builtin) procedure }
      bnew := (pg = nil);
      if not bnew then
      begin { * We must use the new arg. definition, because the old-one can use other arg. names }
        tpr :=               pr;                       { The new descriptor address is saved (as temporary) }
        pr  :=     pg^.gen_proc;                       { The previously defined entry descriptor is keep as the normal one. }
        id1 :=  pr^.pro_parmlst;                       { Get the old arg. list head }
        id2 := tpr^.pro_parmlst;                       { Get the new arg. list head }
        while (id1 <> nil) and (id2 <> nil) do
        begin
          DISPOSE( id1^.ide_name );                    { Free the old identifier name }
          id1^.ide_name := id2^.ide_name;              { Set the new name in place }
          id1 := id1^.ide_nxt; id2 := id2^.ide_nxt     { Skip to next argument }
        end;
        with lex_ident_tree[curr_disp], pr^ do
        begin                                          { Use the old procedure definition, free the new one's }
          FREE_IDE_LIST( tpr^.pro_parmlst );           { Free all argument identifiers }
          FREE_TYP_LIST( tpr^.pro_prmtyls );           { Free all argument type descr. }
          disp_owner     :=          pr;               { Force the current lex owner to be the prevously entry }
          disp_tree      := pro_idetree;               { Force the parameter list head to be the identifier root of lex }
                                                       { disp_lgt should be nil }
                                                       { disp_kind must not change }
          disp_ide_last  := pro_idelast;
          disp_typ_hde   := pro_prmtyls                { Set the Head list of argument related typ_rec }
                                                       { disp_lex must not change }
                                                       { disp_usage should be 0 }
                                                       { disp_data_size should be 0 }
        end;
        pg := nil;                                     { We do not create a new entry but change only its access class }
        { Allowed only for external or forward }
        case pr^.pro_pkind of
          pro_external:
            if pk <> pro_global then SRC_ERROR_S( mdnam, 100, e_error, saved_name );
          pro_forward:
              if pk <> pro_decl then SRC_ERROR_S( mdnam, 100, e_error, saved_name );
        otherwise
          SRC_ERROR_S( mdnam, 102, e_error, saved_name );
          pk := pro_global
        end;
        DISPOSE( tpr );                                { Free the procedure/function def. block }
        pr^.pro_pkind := pro_decl                      { Set entry to be a local generic entry (by default) }
      end
      else                                             { It is a new entry in the generic search list }
      begin                                            { Create a complet new procedure entry with a generic entry }
        NEW( pg, true );                               { Create a generic entry }
        with pg^ do
        begin
          gen_link :=   nil;
          gen_blt  := false;                           { Set not builtin/hardware def. flag }
          gen_proc :=    pr                            { Set the procedure pointer }
        end;
        { Build (or append to) the list of all defined entries (procedures/functions) }
        if pro_d_first = nil then pro_d_first          := pr
                             else pro_d_last^.pro_link := pr;
        pro_d_last := pr
      end
    end
    else
    with pr^ do
    begin                                              { Entry was Forward }
      if sy = semicolon then INSYMBOL
                        else SRC_ERROR( mdnam, 21, e_error );
      if pro_pkind = pro_external then pk := pro_global;
      pro_pkind := pro_decl
    end;
  end;

  with pr^, sy_sym do
  begin
    if sy = forwardsy then
    begin
      if wasforward or (pro_pkind <> pro_decl) then SRC_ERROR_S( mdnam, 128, e_error, saved_name )
                                               else                       pro_pkind := pro_forward;
      INSYMBOL;                                        { Gobble up "forward" }
      if sy = stringconst then SET_STDNAME( pr )       { Set any external name }
      else
        if bfirst and (pro_lex <= 1) then
        begin
          pro_operator := op1;
          NEW( pro_stdname );                          { Set the std. name (or user procedure name) }
          if pro_operator = no_op then                 { For procedure/type generic }
            pro_stdname^ := saved_name                 { Set the user Pascal Name }
          else
            pro_stdname^ := opname[op1] 
        end
        else { Built a synthetic stdname }
          pro_stdname := NEW_INT_NAME( 'PRC_', proc_seq );

      if sy = semicolon then INSYMBOL
                        else SRC_ERROR( mdnam, 21, e_error )
    end
    else
    if (sy = externalsy) or ((sy = standardsy) and sy_init_mod) then
    begin
      if pro_pkind <> pro_decl then
        { Illegal external/standard procedure defined twice }
        SRC_ERROR_S( mdnam, 108, e_error, saved_name );
      if sy = externalsy then
      begin
        pro_pkind   := pro_external;
        pro_lex     := 1                               { Force lex of external procedure }
      end
      else
      begin
        { Declared in standard processing only }
        pro_pkind := pro_standard;
        pro_lex   := 0                                 { Force Lex of Standard Procedure }
      end;
      INSYMBOL;                                        { Gobble up "external"/"standard" }

      if sy = stringconst then                         { Set the external name }
        { When the user give an external name }
        SET_STDNAME( pr )                              { Set it }
      else
        if (pk = pro_pkind) and (extern_name <> nil) then
          pro_stdname := extern_name
        else
        begin { For the first procedure with the specified name }
          pro_operator := op1;
          if pro_operator = no_op then                 { For procedure/type generic }
            SET_GBL_DEF_NAM( pro_stdname, saved_name, 'P' )
          else
            SET_GBL_DEF_NAM( pro_stdname, opname[op1], 'P' )
        end;

      if sy = semicolon then INSYMBOL
                        else SRC_ERROR( mdnam, 21, e_error )
    end
    else                                               { Not (forward or external(except by attribute) or standard) }
    begin                                              { The procedure can be compiled if it was not previously external }
      to_compile := true;                              { Assumed now }
      { Declared now or external/global by attribute }
      if pk <> pro_decl then
      begin                                            { Not local procedure/function }
        pro_pkind := pk;
        pro_lex   :=  1;                               { Force Lex of external and global  procedure }
        if extern_name <> nil then                     { When a new external name is specified }
          if bnew then pro_stdname := extern_name
          else
          begin
            if pro_stdname <> nil then                 { If an external name was already defined, }
              if MATCH( pro_stdname^, extern_name^ ) <> 0 then { ... and the two name does not match : }
                SRC_ERROR( mdnam, 129, e_warning )     { The external nale of external declaration is keep
                                                         and the new one is ignored to preserve all reference
                                                         from any environment file. }
          end
        else                                           { No external name specified }
          if pro_operator = no_op then                 { For procedure/type generic }
            SET_GBL_DEF_NAM( pro_stdname, saved_name, 'P' )
          else
            SET_GBL_DEF_NAM( pro_stdname, opname[op1], 'P' );

        { Force the no compilation for external entry and check lex for global entry }
        case pk of
          pro_external: to_compile := false;           { No compilation for external }
          pro_global:
            if oldlevel > 1 then                       { Cannot accept a global entry body inside an other one }
              SRC_ERROR( mdnam, 404, e_error );
        otherwise
        end
      end;

      binsymbol  := false;
      bsemicolon := false;
      repeat
        case sy of
          inlinesy:
            begin                                      { Procedure usable to compute a constant expression }
              INSYMBOL; pro_flags := [prf_inline];
              bsemicolon := true
            end;

          globalsy,
          stringconst:
            begin
              if sy = globalsy then
              begin  pro_pkind := pro_global; INSYMBOL  end;
              if sy = stringconst then SET_STDNAME( pr )       { Set it }
                                  else SRC_ERROR( mdnam, 58, e_error );
              bsemicolon := true
            end;

        otherwise
          binsymbol := true;
          if bsemicolon  then
            if sy = semicolon then INSYMBOL
                              else SRC_ERROR( mdnam, 21, e_error )
        end
      until binsymbol;

      if pro_stdname = nil then                        { When the ext. name is undefined }
        { Always here for a local procedure }
        if bfirst and (pro_lex <= 1) then              { For the first use }
        begin                                          { For the first procedure with the specified name }
          pro_operator := op1;
          NEW( pro_stdname );                          { Set the standard name (or user procedure name) }
          if pro_operator = no_op then pro_stdname^ := saved_name
                                  else pro_stdname^ := opname[op1] 
        end                                            { For second use of generic identifier }
        else                                           { Built a synthetic stdname }
          pro_stdname := NEW_INT_NAME( 'PRC_', proc_seq )
    end;

    curr_lex  := oldlevel;                             { Return to Lex level and Display level of the Entry Owner }
    curr_disp :=  olddisp;
    fw_ptr    := oldfwptr
  end
end PROC_DECL;




procedure PROC_BODY;
var
  glic:  integer;
  ip:    ide_ptr;
  lgt:   lgt_ptr;

begin
  curr_disp    :=     procdisp;
  curr_lex     :=      proclex;                        { Reset procedure lex level }
  with sy_sym, pr^ do
  begin                                                { Parse procedure definition }
    if cmp_traceopt > 0 then
    begin
      if cmp_trace >= 0 then glic := 3  
               { To generate a call back-tracing }
                        else glic := 5;                { To generate an init back-tracing }
      cmp_trace := cmp_traceopt;
      GEN_CNTXVAR( pr, dcl_name )
    end
    else
      if cmp_trace > 0 then cmp_trace := 0;

    LGT_ALL_FPARM( pr );                               { Allocate mem. descr. for the formals }

    CMP_BLOCK( pr, true, glic );                       { Compile block and set as current procedure }

    if sy = endsy then INSYMBOL
                  else SRC_ERROR( mdnam, 54, e_severe );
    if sy = identsy then                               { An identifier is found after the procedure end }
      if op1 = no_op then                              { Name of generic expected }
      { named procedure/function/generic/type }
        with saved_name do
          if ( sy = identsy ) and (MATCH( saved_name, sy_ident ) = 0) then
               INSYMBOL
          else SRC_ERROR_S( mdnam, 71, e_error, sy_ident )
      else
        { Operator is expected }
        if ((sy = becomes) and ( op1 = ass_op)) or ( op = op1 ) then INSYMBOL
        else SRC_ERROR( mdnam, 72, e_error );

    if sy <> semicolon then SRC_ERROR( mdnam, 21, e_error );
    COMPILE_SET_SBTTL( owner );
    if sy = semicolon then INSYMBOL;

    { *** Activate the pass 2 on this procedure if it is not online *** }
    if cmp_objf and (error_result <= e_warning) then
    begin
      { Generate a return back tracing when required }
      if (cmp_trace > 0) and (pro_lgt <> nil) then 
        GEN_LINETRACE( pr, pro_lgt, pro_lst, 4 );

      if pro_lgt <> pro_lst then
      begin
        LGT_NEW( pro_lgt, nil, lgt_ctlflow, pro_lgt );
        pro_lgt^.lgt_stm := stm_sequence;
        pro_lst := pro_lgt
      end;

      if pro_pkind = pro_inline then
        pro_flags := pro_flags + [prf_inline,prf_tocomp]
      else
        pro_flags := pro_flags + [prf_tocomp];

      { Build the procedure/function list }
      if pro_last = nil then pro_first := pr
                        else pro_last^.pro_next := pr;
      pro_last := pr;

      { Now expend all called inline procedure }
      CMP_PASS2( pr );                                 { Perform the pass2 of compilation }
      { Now free all variables and type definition blocks - *** does not make it *** }
      {*///* if owner^.pro_pkind <> pro_inline then IDE_FREE_LEX( pr ) *///*}
    end;
    { Restore original lex }
    curr_lex := oldlevel; curr_disp := olddisp;
    fw_ptr := oldfwptr
  end
end PROC_BODY;



begin { GENE_DECL }
  wasforward     :=      false;                        { Assume not forward until showed otherwise }
  cannot_formal  :=       true;                        { Assume not formal entry possibility }
  formal_entry   :=      false;                        { Assume no formal entry in arg. list until showed otherwise }
  pr           :=          nil;                        { Assume not forward until shown otherwise }
  op1          :=        no_op;
  bfirst       :=        false;                        { Assume no previuosly defined generic identifier }
  ip   :=  nil;    ip1 :=  nil;
  npa  :=    0;

  oldfwptr     :=       fw_ptr;                        { Preserve state of current procedure }
  oldlevel     :=     curr_lex;
  olddisp      :=    curr_disp;

  with sy_sym do
  begin                                                { Save the entry (procedure/generic/type) name }
    pk           :=   pro_decl;
    extern_name  :=        nil;
    if attr_kind <> var_decl then
    begin                                              { Some global/external attribute are specified }
      case attr_kind of
        var_global, var_external:
          begin
            if attr_kind = var_global then pk := pro_global
                                      else pk := pro_external;
            if attr_nam <> nil then
            begin  extern_name := attr_nam; attr_nam := nil  end
          end;
      otherwise
        SRC_ERROR( mdnam, 81, e_error )
      end;
      attr_kind  := var_decl;                          { Set the default declaration kind ... }
      attr_nam   := nil                                { ... without external name }
    end;

    bfunc := (sy = functionsy);                        { Test for procedure or function }
    INSYMBOL;                                          { ... and gobble up the keyword }
    case sy of
      identsy: { * Generic or Type identifier }
        begin
          saved_name := sy_ident;                      { Save the identifier name }
          err_prt := false;                            { Disable error message }
          ip1 := IDE_SEARCH( [cla_type, cla_genwfent, cla_generic] );
          err_prt := true;                             { Re-enable error message }
          if ip1 <> nil then                           { The identifier was existing }
            if ip1^.ide_lex <> curr_lex then ip := nil { Id. in previous Lex }
                                        else ip := ip1 { Id. in the Curr. Lex }
          else ip := nil;                              { N.B. ip1 is always the original identifier in the more external lex }

          if ip <> nil then
          with ip^ do
          begin                                        { An identifier with this name is existing in this lex }
            dcl_name := ide_name;
            case ide_class of
              cla_type, cla_genwfent, cla_generic:
                if ide_gproc <> nil then               { Use the last forward entry reference }
                begin                                  { To get the last forward/external declaration }
                  wasforward := true;
                  pr := ide_gproc;
                  with pr^ do
                    if (pro_pkind = pro_forward) or (pro_pkind = pro_external) then
                      cannot_formal := false;          { We can accept formal entry arguments }
                end;

            otherwise
              { Identifier declared twice }
              SRC_ERROR_S( mdnam, 101, e_severe, ide_name^ )
            end;
            { Built this procedure or complete it ( forward case ) }
            PROC_DECL( ide_gfirst, ide_glast );
            { Link the new entry in the generic entry list }
            INSERT_NEW_GENERIC( ide_gfirst, ide_glast, pg, ide_class = cla_genwfent );
(*
              { We link this procedure in the generic list }
              if ide_glast = nil then                  { No local definition (not in the current display) }
                if ide_class = cla_genwfent then
                  { We try to define a generic with some procedure or function
                    used as formal parameter(s) }
                  SRC_ERROR( mdnam, 114, e_severe )
                else
                begin                                  { List is empty }
                  pg^.gen_link := ide_gfirst;          { Link to parent def. }
                  ide_gfirst := pg; ide_glast := pg
                end
              else
              begin { * List is not empty }            { Set as the last in the list }
                pg^.gen_link := ide_glast^.gen_link;   { Link to external lex }
                ide_glast^.gen_link := pg;             { Link to the old last proc }
                ide_glast := pg                        { Set as the new last one }
              end
*)
          end
          else
          begin { * The identifier is not existing in this lex }
            { It is the first procedure with this name in this lex }
            cannot_formal := false;                    { We can declare a new procedure }
            NEW( dcl_name );                           { Create the New ident name record }
            with sy_ident do
            begin                                      { Copy the identifier string name }
              dcl_name^.l := l;
              for i := 1 to l do dcl_name^.s[i] := s[i]
            end;

            bfirst := ( ip1 = nil);                    { Set the previously def. identifier flag (used for def. stdname) }
            PROC_DECL( nil,  nil );                    { Built the procedure Definition }
            save_ide :=   sy_ident;                    { ... and save some ident name }
            sy_ident := saved_name;                    { Set the original name for IDE_NEW }
            if formal_entry then                       { When some formal entry are used by this generic entry ... }
            begin { * We built a wf generic entry }    { ... we Create the new identifier of cla_genwfent class. }
              IDE_NEW( cla_genwfent, pr^.pro_typ, ip );
              with ip^ do
              begin
                ide_gfirst :=  pg;                     { Attach the Procedure Definition }
                ide_glast  := nil;                     { To flag pseudo-generic mode }
                { Set the forward pointer when required }
                if (pr^.pro_pkind = pro_forward) or
                   (pr^.pro_pkind = pro_external) then ide_gproc := pr
                                                  else ide_gproc := nil
              end
            end
            else
            begin { * We must create a generic or a type link.
                      In first we look for an old definition }
              if ip1 <> nil then
              begin                                    { Old generic exist in other Lex }
                geneclass    := ip1^.ide_class;        { Get the class }
                pg^.gen_link := ip1^.ide_gfirst        { Link Procedure to prv. def. }
              end
              else
              begin                                    { First Generic Definition }
                geneclass    :=    cla_generic;
                pg^.gen_link :=            nil
              end;

              IDE_NEW( geneclass, pr^.pro_typ, ip );   { Create New Identifier }

(*            INSERT_NEW_GENERIC( ip^.ide_gfirst, ip^.ide_glast, pg, geneclass = cla_genwfent );*)

              with ip^ do
              begin
                ide_gfirst := pg; ide_glast := pg;
                { Set the forward pointer when required }
                if pr^.pro_pkind = pro_forward then ide_gproc := pr
                                               else ide_gproc := nil
              end

            end;
            sy_ident := save_ide;                      { Restore some ident name }
          end;

          if sy_init_mod then                          { Initialyse Compiler Mode }
          begin
            biniskip := true;
            case sy_sym.sy of
              newsy:     new_entry_proc     :=    pg^.gen_proc;
              newhsy:    newh_entry_proc    :=    pg^.gen_proc;
              disposesy: dispose_entry_proc :=    pg^.gen_proc;
              setsy:     set_entry_proc     :=    pg^.gen_proc;

              opensy:    iof_std_open       :=      ip;
              filesy:    iof_std_close      :=      ip;
              resetsy:   inp_std_sel        :=      ip;
              readsy:    inp_std_gene       :=      ip;
              readlnsy:  inp_std_eoln       :=      ip;
              invarsy:   inp_std_bin        :=      ip;
              rewritesy: out_std_sel        :=      ip;
              writesy:   out_std_gene       :=      ip;
              writelnsy: out_std_eoln       :=      ip;
              outvarsy:  out_std_bin        :=      ip;

              recordsy:  gen_std_string1    :=      ip;
              arraysy:   gen_std_cnfardsc   :=      ip;

            otherwise
              biniskip := false;
            end;
            if biniskip then
            begin
              INSYMBOL;
              if sy = semicolon then INSYMBOL
                                else SRC_ERROR( mdnam, 21, e_error )
            end
          end;

          if pr <> nil then pr^.pro_geneide := ip
        end;

      unaop,
      powop,
      mulop,
      addop,
      relop,
      notop,
      lgandop,
      lgorop,
      becomes: { * Operator }
        begin
          if sy = unaop then npa := 1                  { Fix the possible number of arguments }
                        else npa := 2;
          if sy = becomes then
          begin                                        { A procedure is expected }
            if bfunc then SRC_ERROR( mdnam, 115, e_severe );
            op1 := ass_op
          end else
          begin
            op1 := op;                                 { A function is expected }
            if not bfunc then SRC_ERROR( mdnam, 116, e_severe )
          end;
          if op1 = sub_op then npa := -1;

          saved_name := opname[op1];                   { Used only for error messages }

          NEW( dcl_name );                             { Build a Pascal entry name }
          with opname[op1] do
          begin { * Set a Default Procedure/Function name for the Operator }
            dcl_name^.l := l + 2;
            dcl_name^.s[1] := 'O';
            dcl_name^.s[2] := '_';
            for i := 1 to l do dcl_name^.s[2+i] := s[i]
          end;

          po1 := ope_table[op1];                { Get this operator context }
          if po1 <> nil then bpo1 := (po1^.ope_lex = curr_lex)
                        else bpo1 := false;
          if bpo1 then                          { Update for Same Lex or Forward }
            with po1^ do
            begin                               { Extend the definition in the same lex }
              pr := nil;
              PROC_DECL( ope_gfirst, ope_glast );
              INSERT_NEW_GENERIC( ope_gfirst, ope_glast, pg, false )
(*
              if pg <> nil then
              begin { * Put the definition in the last place }
                pg^.gen_link := ope_glast^.gen_link;   { Link to external lex }
                ope_glast^.gen_link := pg;             { Link to the old last proc }
                ope_glast := pg                        { Set as the new last one }
              end
*)
            end
          else                                  { The operator was not defined }
          begin { * Create a new definition list of operator in the current Lex }
            pr := nil;
            PROC_DECL( nil, nil );              { Create the procedure entry }
            if pg <> nil then
            begin
              NEW( po2 );
              with po2^ do
              begin
                ope_operator    :=         op1; { Set Associated Operator }
                ope_lex         :=    curr_lex; { Set Owner Lex }
                ope_nxt :=   owner^.pro_opelst; { Link other op. def. in Lex }
                ope_llnk        :=         po1; { Save the current op. definition }
                ope_gfirst      :=          pg; { Create the one elem. list }
                ope_glast       :=          pg;
                if po1 = nil then               { First definition of this operator }
                  pg^.gen_link  :=         nil
                else                            { No: Link to previous def. in the more global lex }
                  pg^.gen_link  := po1^.ope_gfirst;
              end
            end;
            owner^.pro_opelst   :=         po2; { Update the Lex op. def. List }
            ope_table[op1]      :=         po2  { Install this definition }
          end;
          { Set the procedure Operator Field }
          if pr <> nil then pr^.pro_operator := op1

(* ///
;WRITELN( ' Create the operator def. of "', op1, '" lst = ', op1 = concat_op, ', bpo1 = ', bpo1 )
;if op1 = concat_op then WIEW_OPER_DEF( op1 );
*)

        end;

    otherwise
      SRC_ERROR( mdnam, 117, e_severe );
    end { case }
  end;
  if to_compile then PROC_BODY
end GENE_DECL;




function STATEMENT { ( lgp: lgt_ptr; bsequ: boolean ): lgt_ptr }; { Was Forward }
const
  mdnam = 'STAT';

var
  stat_label, ip, flb: ide_ptr;
  lgt, lgtt:           lgt_ptr;
  sta_sym:             sym_rec;
  nwstk:               stk_ptr;



function GEN_ASSIGN( target: lgt_ptr; bovr: boolean ): lgt_ptr;
const
  mdnam = 'GASS';

var
  source, lgt: lgt_ptr;
  berr, blab:  boolean;

begin
  blab := sy_label_flag;
  sy_label_flag := false;

  { Get the source of assignement }
  source := EXPRESSION;                                { Get the source }

  sy_label_flag := blab;

  target^.lgt_nxt := source;                           { Link source and target for GENERIC_SEARCH }
  if target^.lgt_kind = lgt_call then                  { When the target is a call }
  with target^.lgt_pro^ do
  begin                                                { Assignement is allowed only for organization }
    berr := true;
    if pro_typ <> nil then
      if pro_typ^.typ_form = form_organization then berr := false;
    if berr then SRC_ERROR( mdnam, 175, e_severe )
  end;
  lgt := LGT_GEN_STORE( target, false, bovr );
  GEN_ASSIGN := lgt
end GEN_ASSIGN;



function RETURNSTATE( ip: ide_ptr ): lgt_ptr;
const
  mdnam = 'RETU';

var
  lgt, lgt1, target: lgt_ptr;
  pr:                pro_ptr;
  bnr:               boolean;

begin
  { If ip <> nil then sy_sym -> First element after the ip identifier
                 else sy_sym -> first syntax unit after RETURN }
  { Set function result statement management }
  lgt    := nil;
  pr     := GET_PROCREF;
  { When OK pr -> procedure/function block }
  if pr <> nil then
  with pr^ do
  begin
    if pro_typ = nil then                              { We are compiling a procedure }
      if ip <> nil then
      begin                                            { Illegal form <procedure_id> := <expr> }
        { Illegal use of <geneid> := ... }
        SRC_ERROR_S( mdnam, 172, e_severe, ip^.ide_name^ );
        SKIP_SYMBOL( semicolon )
      end
      else
      begin                                            { Procedure statement Return }
        LGT_NEW( lgt, nil, lgt_ctlflow, nil );
        lgt^.lgt_stm := stm_return
      end
    else
    begin                                              { We are compiling a function }
      target     :=  nil;
      return_flg := true;                              { Flag the use of Return variable }
      if ip <> nil then
        { Form <function_id> := <expr> }
        if ip <> pro_geneide then                      { Error on the function identifier }
        begin
          SRC_ERROR_S( mdnam, 405, e_severe, ip^.ide_name^ );
          SKIP_SYMBOL( semicolon );
          { /// return /// }
        end;

      if pro_typ^.typ_simple then                      { It is a simple function }
      begin
        LGT_NEW( target, pro_typ, lgt_result, nil );
        target^.lgt_pro := pr;
        if ip <> nil then
          if sy_sym.sy = becomes then INSYMBOL
                                 else SRC_ERROR( mdnam, 32, e_error )
      end
      else                                             { Use the Procedure target related variable }
      begin
        if (ip = nil) or (sy_sym.sy = becomes) then
        begin                                          { Get assignation target }
          target := LGT_NEW_IDREF( pro_parmlst, nil );
          with pro_parmlst^ do
            if (ide_typ^.typ_subtype or ide_typ^.typ_hasidsc) and
               (not (var_inited in ide_vacc)) then
              INIT_D_VARBL( pro_parmlst );
          if ip <> nil then INSYMBOL                   { Gobble up := }
        end
        else
        begin { * Partial Return value setup (always ip <> nil) }
          sy_search :=     pro_parmlst;                { Set the target id. for EXP_IDENTIFIER }
          lastsymb  :=       sy_sym.sy;                { Save the last symbol }
          sy_sym.sy :=         identsy;                { ... and force the identifier symbol }
          target    :=      EXPRESSION;
          if sy_sym.sy = becomes then INSYMBOL
                                 else SRC_ERROR( mdnam, 32, e_error )
        end;
      end;

      { Get the Source expression value and generate the assignation }
      lgt := GEN_ASSIGN( target, true );

      if ip = nil then
      begin                                            { Function Return Statement }
        LGT_NEW( lgt, nil, lgt_ctlflow, lgt );
        lgt^.lgt_stm := stm_return
      end
    end
  end;
  RETURNSTATE := lgt
end RETURNSTATE;



function ASSIGNMENTSTATE( ip : ide_ptr ): lgt_ptr;
const
  mdnam = 'ASSI';   
var
  berr:        boolean;
  lgt, target: lgt_ptr;

begin { ASSIGNMENTSTATE }
  sy_search :=        ip;                              { Update the search pointer for expression }
                                                       { The INSYMBOL was performed by STATEMENT }
  lastsymb  := sy_sym.sy;                              { Save the last symbol }
  sy_sym.sy :=   identsy;                              { ... and force the identifier symbol }
  target := EXPRESSION;                                { Get assignation target }
  with target^, sy_sym do
  case lgt_kind of
    lgt_index, lgt_indir, lgt_offset, lgt_varbl, lgt_call, lgt_icall:
(*
      if (lgt_typ = typ_std[form_null]) and (lgt_kind = lgt_icall) then
begin
WRITELN( ' ASSIGNMENTSTATE Calls CALL_INDIRECT_PROC.' );

        lgt := CALL_INDIRECT_PROC( target )            { Pointed procedure can be called here }
end
      else
*)
      if (lgt_typ = typ_std[form_null]) and (lgt_kind = lgt_icall) then
        lgt := target
      else
      begin
        if not (lgt_out in lgt_status) then
          { Try to modify the value of a read only object }
          SRC_ERROR( mdnam, 173, e_error );

        if sy <> becomes then SRC_ERROR( mdnam, 32, e_error)
                         else INSYMBOL;                { Gobble up ":=" }
        lgt := GEN_ASSIGN( target, false )             { Generate the assignement }
      end;

  otherwise
    { Not Allowed Target }
    SRC_ERROR( mdnam, 174, e_severe );
    SKIP_SYMBOL( semicolon );
    LGT_FREE_TREE( target );                           { Free all the target definition }
    lgt := nil
  end { case };
  ASSIGNMENTSTATE := lgt
end ASSIGNMENTSTATE;



function WITH_STATE: lgt_ptr;
const
  mdnam = 'WITH';

var
  lgtw_stack, lgtw, lgtw1, lgtw2:   lgt_ptr;
  rec_ty, ptr_ty:                   typ_ptr;
  wloc:                             all_ptr;
  ipf, nclb:                        ide_ptr;
  nrw, ndsp:                        integer;
  berr, bindir, bdyn, bseq, btmp:   boolean;

begin { WITH_STATE }
  nrw          :=    0;
  lgtw_stack   :=  nil;
  berr         := true;
  with sy_sym do
  repeat
    lgtw1      :=           EXPRESSION;                { Get the record specification }
    bindir     :=                false;                { Assume not indirect until shown otherwise }
    btmp       :=                false;                { Assume no use of temporary variable }
    ptr_ty     :=                  nil;
    rec_ty     :=       lgtw1^.lgt_typ;                { Get the record type descritor }

    with rec_ty^, lgtw1^ do
      if ((typ_form = form_pointer) or
          (typ_form = form_file) or
          (typ_form = form_organization)) and
         (typ_eltype <> nil) then
      { With used with a file variable, record pointer or record organization }
      begin
        bdyn   :=                 true;                { Now we force the dynamic and the indirect modes ... }
        bindir :=                 true;                { ... because the object has the properties of a pointer. }
        ptr_ty :=               rec_ty;                { Set the new pointer and pointed type references }
        rec_ty :=   ptr_ty^.typ_eltype
      end
      else { * Set the dynamic mode when the record is not a constant
               or a variable (for the last the record address is fixed) }
        bdyn := (lgt_kind <> lgt_const) and (lgt_kind <> lgt_varbl);

    if rec_ty^.typ_form <> form_record then rec_ty := nil;     { The final type MUST be a record ... }

    berr := (rec_ty = nil);                            { ... else we must emit an ERROR message ! }

    if berr then
    begin                                              { Not a record  }
      SRC_ERROR( mdnam, 176, e_severe );
      SKIP_SYMBOL( endsy )
    end
    else
    if bdyn then
    begin { * Dynamic address : Get an address node of the record }
      if not bindir then                               { A record was specified => Get its address }
        if (lgtw1^.lgt_kind = lgt_indir) and (lgtw1^.lgt_disp = 0) then        { When the top node was a simple indirection : }
        begin                                          { The record reference is already indirect (as with <exp>^ do) }
          lgtw2  := lgtw1^.lgt_parmlst;                { Get the address, }
          LGT_FREE( lgtw1 );                           { ... free the indirect node }
          ptr_ty := lgtw2^.lgt_typ;                    { ... and update the record type }
          lgtw1  := lgtw2                              { Now, lgtw1 is the expression of the record address }
        end
        else
        begin { * The reference is direct }
          if ptr_ty = nil then                         { If undef. pointer type, we creates a new pointer type }
            IDE_NEW_TYP( form_pointer, ptr_ty );
          with ptr_ty^ do
          begin                                        { Creates an indirect pointer reference ... }
            typ_align  := typ_std[form_nil]^.typ_align;
            typ_size   := fptr_size;
            typ_eltype := rec_ty
          end;
          LGT_NEW( lgtw1, ptr_ty, lgt_address, lgtw1 ) { ... and an address node of the record }
        end;

      { Now, in all case, lgtw1 is the expression of the record address }

      with lgtw1^ do                                   { Done for any dynamic record access }
      begin { * Allocate a new temporary variable to keep the record address }
        btmp := true;                                  { Flags the use of a temporary allocation }
        LGT_NEW( lgtw2, ptr_ty, lgt_varbl, nil );      { Create an hidden pointer variable  and ... }
        ALL_NEW( lgtw2^.lgt_alloc, ptr_ty, nil, var_tmp );
        lgtw2^.lgt_nxt := lgtw1;
        lgtw1 := LGT_NEW_CODE( pcod_istore, lgtw2 );   { ... build its initialization to the record address }
        lgtw1^.lgt_disp := 0;
        lgtw1^.lgt_nxt := lgtw_stack;                  { Push it in the current stack }
        lgtw_stack := lgtw1
      end
    end
    else
      lgtw2 := lgtw1;                                  { For static (not dyn.), we use the direct access to var/const record }

    { lgtw_stack is a stack of pcod_istore node (if bdyn) or variable ref } 
    { lgtw2 is the reference of the pointer to use or of the referenced record }

    if curr_disp < max_disp then
    begin
      nrw := SUCC( nrw );                              { We create a new identifier display level ... }
      NEW_DISP_LEVEL( nil, dsp_record );
      with lex_ident_tree[curr_disp] do
      begin
        disp_lgt := lgtw2;                             { ... to get the directv access to the record field }
        with rec_ty^ do
          if typ_parmlst <> nil then                   { If the record type has some argument(s) ... }
          begin
            ipf := typ_parmlst;
            while ipf <> nil do                        { ... we set all these arguments as directly usable, }
            begin
              ipf^.ide_tkind := tpa_local;
              ipf := ipf^.ide_nxt
            end;
            disp_tree := typ_parmlst                   { ... set the argument(s) list as visible. }
          end
          else
            disp_tree := typ_firstfield;               { Else we set the records fields as visible. }

        disp_usage := 0;                               { Initialize the use count }
        if bdyn then
          if btmp then disp_kind := dsp_drecord        { Dynamic ref. of record with hidden variable pointer }
                  else disp_kind := dsp_vrecord        { Dynamic ref. of variable rec. -- presently, cannot occure }
                else disp_kind   := dsp_record;        { Direct ref. of record }
        if (rec_ty^.typ_parmlst <> nil) and
           (rec_ty^.typ_form = form_record) then
        begin { * Create a new display level for make visible the record fields of a record type with arguments }
          nrw := SUCC(nrw);
          NEW_DISP_LEVEL( nil, dsp_record );
          lex_ident_tree[curr_disp] := lex_ident_tree[curr_disp - 1];
          with lex_ident_tree[curr_disp] do
          begin
            disp_tree := rec_ty^.typ_firstfield;
            disp_usage := -1                           { Mark for link with previous }
          end
        end
      end
    end
    else
      SRC_ERROR( mdnam, 1003, e_fatal );               { Display overflow }
    if sy = comma then INSYMBOL;
  until sy <> identsy;
  with sy_sym do
  begin
    if sy = dosy then INSYMBOL else SRC_ERROR( mdnam, 55, e_error );

    { Compile all STATEMENTs of with block }
    nclb := cntx_label;
    cntx_lblvl := cntx_lblvl + 1;
    lgtw := STATEMENT( nil, true );                    { Compile all the statements in the with block }

    if lgtw <> nil then
    with lgtw^ do                                      { Set bseq boolean when head statment was a list of statement }
      if lgt_kind = lgt_ctlflow then
        case lgt_stm of
          stm_parallel,
          stm_sequence: bseq := true;

        otherwise
          bseq := false;
        end
      else
        bseq := false
    else LGT_NEW( lgtw, nil, lgt_null, nil );

    LABEL_PURGE( nclb );                               { Purge any label that could be defined in the with block }

    { Now inserts store code or frees the not used code }
    while nrw > 0 do
    begin
      with lex_ident_tree[curr_disp] do
      begin
        if disp_usage >= 0 then                        { True basic level - not secondary }
          if disp_usage = 0 then
            { Always true for direct ref. or unused dynamic ref. }
            case disp_kind of
              dsp_record,  { * Direct ref. }
              dsp_vrecord: { * Dynamic without tmp variable }
                           LGT_FREE_TREE( disp_lgt );

              dsp_drecord: { * Dynamic with tmp variable }
                begin                                  { Free the store ref. }
                  lgtw1 := lgtw_stack;
                  lgtw_stack := lgtw1^.lgt_nxt;
                  lgtw1^.lgt_nxt := nil;
                  ALL_FREE( disp_lgt^.lgt_alloc );     { Free the with pointer }
                  disp_lgt := nil;
                  LGT_FREE_TREE( lgtw1 )
                end;
            otherwise
            end
          else                                         { Possible only for dynamic and var dynamic ref.
                                                         We must insert at the begining of with block code }
            if disp_kind = dsp_drecord then
            begin
              lgtw1 := lgtw_stack;                     { Pop out the temporary record address }
              lgtw_stack := lgtw1^.lgt_nxt;

              if bseq then                             { We insert to the current sequence }
              begin
                lgtw1^.lgt_nxt := lgtw^.lgt_parmlst;
                lgtw^.lgt_parmlst := lgtw1
              end
              else                                     { We create a sequence node }
              begin
                bseq := true;
                lgtw1^.lgt_nxt := lgtw;
                LGT_NEW( lgtw, nil, lgt_ctlflow, lgtw1 );
                lgtw^.lgt_stm := stm_sequence
              end
            end;

        ipf := disp_tree;
        if ipf^.ide_class = cla_tparam then
          { Reset all type parameters as locally unusable }
          while ipf <> nil do
          begin
            ipf^.ide_tkind  := tpa_sub;
            ipf^.ide_tlink2 := nil;
            ipf := ipf^.ide_nxt
          end
      end;
      curr_disp := PRED(curr_disp);
      nrw := nrw - 1
    end
  end;
  WITH_STATE := lgtw
end WITH_STATE;



function IFSTATE: lgt_ptr;
const
  mdnam = 'IFST';
var
  nclb:                  ide_ptr;
  lgt, lgt1, lgt2, lgt3: lgt_ptr;

begin
  { Get boolean expression }
  lgt1 := EXPRESSION_TYPE( typ_std[form_lit], false, true );
  lgt2 := nil;
  lgt3 := nil;
  nclb := cntx_label;
  with sy_sym, lgt1^ do
  begin
    if sy = thensy then INSYMBOL else SRC_ERROR( mdnam, 56, e_error );
    { Get statement(s) if true }
    cntx_lblvl := cntx_lblvl + 1;
    lgt2 := STATEMENT( nil, true );
    LABEL_PURGE( nclb );
    if sy <> semicolon then
      if sy = elsesy then
      begin
        INSYMBOL;                              { Gobble up "else" }
        cntx_lblvl := cntx_lblvl + 1;
        lgt3 := STATEMENT( nil, true );
        LABEL_PURGE( nclb )
      end;

    if (lgt2 = nil) and (lgt3 = nil) then
    begin
      LGT_FREE( lgt1 );                        { Elliminate this expression tree }
      lgt := nil
    end else
    begin                                      { We must generate any things }
      if lgt_kind = lgt_const then             { Elliminate unusable code }
      begin
        if lgt_cte^.val_ival > 0 then
        begin                                  { We take the true way }
          lgt := lgt2;
          LGT_FREE_TREE( lgt3 )
        end
        else
        begin                                  { We take the false way }
          lgt := lgt3;
          LGT_FREE_TREE( lgt2 )
        end;
        LGT_FREE( lgt1 )

      end
      else                                     { Not a constante }
      begin
        if lgt2 = nil then                     { Else case only }
        begin
          lgt1 := EXP_GENOP( not_op, lgt1 );
          lgt1^.lgt_nxt := lgt3
        end
        else
        begin
          lgt1^.lgt_nxt := lgt2;
          lgt2^.lgt_nxt := lgt3
        end;
        LGT_NEW( lgt, nil, lgt_ctlflow, lgt1 );
        lgt^.lgt_stm := stm_if
      end
    end
  end;
  IFSTATE := lgt
end IFSTATE;



function EXITSTATE: lgt_ptr;
const
  mdnam = 'EXST';

var
  ip, lb:          ide_ptr;
  lgt, lgt1, lgt2: lgt_ptr;

begin
  with sy_sym do
  begin { * Assume current loop exit until showed otherwise }
    LGT_NEW( lgt1, nil, lgt_null, loop_lgt );
    if loop_lgt = nil then                     { Default to current procedure }
      SRC_ERROR( mdnam, 244, e_error );
    LGT_NEW( lgt, nil, lgt_ctlflow, lgt1 );
    lgt^.lgt_stm := stm_exit;
    if sy = intconst then IDE_INT_LABEL;
    if sy = identsy then
    begin                                      { some target is specified }
      ip := IDE_SEARCH( [cla_label] );
      if ip = ide_udptr[cla_label] then ip := nil;     { Undeclared }
      if ip <> nil then                        { Declared target }
      with ip^ do
      begin
        { We must check if this label exit is possible target }
        lb:= cntx_label;
        while (lb <> nil) and (lb <> ip) do  lb := lb^.ide_lablnk;
          if lb = nil then
            { Bad target label -> it is not an outer block label }
            SRC_ERROR( mdnam, 177, e_severe );
        ide_labflg := ide_labflg + [lab_mark];
        lgt1^.lgt_parmlst := ide_lablgt;
(*
        lgt2 := ide_lablgt;
        while lgt2 <> nil do
          if lgt2^.lgt_kind = lgt_srcinfo then lgt2 := lgt2^.lgt_nxt
          else begin  lgt1^.lgt_parmlst := lgt2; lgt2 := nil  end
*)
      end;
      INSYMBOL                                 { Gobble up the "label" }
    end;

    if sy = ifsy then
    begin
      INSYMBOL;                                { Gobble up "if" }
      { Get boolean expression }
      lgt1^.lgt_nxt := EXPRESSION_TYPE( typ_std[form_lit] );
    end
  end;
  EXITSTATE := lgt
end EXITSTATE;



function LOOPSTATE( symb: symbol ): lgt_ptr;
{ Use for the loop, while and repeat statement }
const
  mdnam = 'LOOP';

var
  ty:                                  typ_ptr;
  loop_id, for_id, nclb:               ide_ptr;
  loop_lgt_sav, lgt, lgt1, lgt2, lgt3: lgt_ptr;

begin
  loop_lgt_sav := loop_lgt;                    { Save the external loop pointer }
  LGT_NEW( loop_lgt, nil, lgt_ctlflow, nil );  { Built the loop node }
  loop_lgt^.lgt_stm := stm_loop;
  lgt := loop_lgt;
  if symb = whilesy then
  begin                                        { Get the condition of loop }
    lgt1 := EXPRESSION_TYPE( typ_std[form_lit] );
    if sy_sym.sy = dosy then INSYMBOL
                        else SRC_ERROR( mdnam, 55, e_error )
  end
  else
    LGT_NEW( lgt1, nil, lgt_null, nil );
  lgt^.lgt_parmlst := lgt1;

  with sy_sym do
  begin
    loop_id := stat_label;
    if loop_id <> nil then loop_id^.ide_lablgt := loop_lgt;

    nclb := cntx_label;                        { Save the current label list, for all internal label }

    cntx_lblvl := cntx_lblvl + 1;

    { Get statement(s) until next end without stm_sequence generation }
    case symb of
      whilesy: lgt1^.lgt_nxt := STATEMENT( nil, true );

      repeatsy:
        begin
          lgt2 := STATELIST( untilsy, false );
          if sy = untilsy then INSYMBOL
                          else SRC_ERROR( mdnam, 57, e_error );

          { Force the cond. expr. in the exit node }
          LGT_NEW( lgt3, nil, lgt_null, nil );
          with lgt3^ do
          begin
            lgt_nxt     := EXPRESSION_TYPE( typ_std[form_lit] );
            lgt_parmlst := loop_lgt { set loop ref. }
          end;
          LGT_NEW( lgt3, nil, lgt_ctlflow, lgt3 );
          lgt3^.lgt_stm := stm_exit;
          if lgt2 <> nil then
          begin
            lgt_end_list^.lgt_nxt := lgt3;
            lgt1^.lgt_nxt := lgt2
          end
          else
            lgt1^.lgt_nxt := lgt3
        end;

      loopsy: 
        begin
          lgt1^.lgt_nxt := STATELIST( endsy, false );
          if sy <> endsy then SRC_ERROR( mdnam, 54, e_error )
                         else INSYMBOL;        { Gobble up the end statement }
          if sy = identsy then
            if loop_id = IDE_SEARCH( [cla_label] ) then
              INSYMBOL
            else
              SRC_ERROR_S( mdnam, 179, e_error, sy_ident )
        end
    end;
    LABEL_PURGE( nclb )
  end;
  { Restore the initial context }
  loop_lgt := loop_lgt_sav;
  LOOPSTATE := lgt
end LOOPSTATE;



function FORSTATE: lgt_ptr;
const
  mdnam = 'FOR_';

var
  iloop, sav_disp: integer;
  ty:              typ_ptr := nil;
  pcd:             pcod_codes;
  loop_id, for_id, nclb: ide_ptr;
  loop_lgt_sav, l_sequ, l_start, l_end, l_inf, l_sup: lgt_ptr;
  l_curr:          lgt_ptr := nil;

begin
  loop_lgt_sav := loop_lgt;                    { Save the external loop pointer }
  sav_disp     := curr_disp;
  nclb         := cntx_label;
  NEW_DISP_LEVEL( owner, dsp_stmflow );
  with sy_sym do
  if sy <> identsy then SRC_ERROR( mdnam, 168, e_error )
  else
  begin
    IDE_NEW( cla_varbl, nil, for_id );         { Create this identifier as temporary }
    INSYMBOL;                                  { Gobble up the loop identifier }
    if sy = becomes then INSYMBOL else SRC_ERROR( mdnam, 32, e_error );
    sy_fix_range_ctl := false;
    l_curr := EXPRESSION_TYPE( typ_std[form_ennum], false, true );

    { Get start EXPRESSION ptr }
    case sy of
      tosy:
        begin
          INSYMBOL;
          pcd := pcod_inc
        end;

      downtosy:
        begin
          INSYMBOL;
          pcd := pcod_dec
        end;

    otherwise
      SRC_ERROR( mdnam, 59, e_error );
      pcd := pcod_inc
    end { Case };

    l_end := EXPRESSION_TYPE( l_curr^.lgt_typ, false, true );

    if sy = dosy then INSYMBOL
                 else SRC_ERROR( mdnam, 55, e_error );

    LGT_NEW( loop_lgt, typ_std[form_int], lgt_ctlflow, nil );
    loop_lgt^.lgt_stm := stm_for;

    if pcd = pcod_dec then
    begin { * Permute the start and end values }
      l_start := l_end;
      { Keep the start value in l_curr for the variable init }
      if l_curr^.lgt_kind = lgt_const then LGT_NEW_COPY( l_curr, l_end )
                                      else l_end   := l_curr
    end
    else
      { Keep the start value in l_curr }
      if l_curr^.lgt_kind = lgt_const then LGT_NEW_COPY( l_curr, l_start )
                                      else l_start := l_curr;

    if l_start^.lgt_kind = lgt_const then
    begin { * expr - (cte-1)  or cte -(cte-1) }
      l_sup := l_end;
      l_inf := LGT_NEW_ECONST(l_start^.lgt_typ, l_start^.lgt_cte^.val_ival - 1)
    end
    else
    begin
      l_inf := l_start;
      if l_end^.lgt_kind = lgt_const then      { (cte+1) - expr }
        l_sup := LGT_NEW_ECONST( l_end^.lgt_typ, l_end^.lgt_cte^.val_ival + 1 )
      else
      begin { * (expr+1) - expr }
        l_end^.lgt_nxt := LGT_NEW_ECONST( typ_std[form_int], 1 );
        l_sup := LGT_NEW_CODE( pcod_iadd, l_end )
      end
    end;

    l_end := LGT_NEW_ADDSUB( true, true, l_sup, l_inf );

    { Now l_end -> tree for number of loop }
    loop_lgt^.lgt_parmlst := l_end;

    sy_fix_range_ctl := true;

    with for_id^ do
    begin
      ide_typ   := l_start^.lgt_typ;           { Set control index type }
      ide_vacc  := [var_in];
      ide_vkind := var_decl
    end;

    loop_id := stat_label;
    if loop_id <> nil then
    with loop_id^ do
    begin
      ide_lablnk := cntx_label;
      cntx_label := loop_id;
      ide_lablgt := loop_lgt
    end;

    cntx_lblvl := cntx_lblvl + 1;

    { Get statement(s) until next end without stm_sequence generation }
    l_start := STATEMENT( nil, true );
    l_end^.lgt_nxt := l_start;

    if var_used in for_id^.ide_vacc then       { Index variable is used }
    begin
      { Built the index references }
      { l_curr = l_start }
      { if l_curr^.lgt_kind <> lgt_const then ///}
      l_curr := LGT_LINK( l_curr );
      l_curr := LGT_NEW_IDREF( for_id, l_curr );
      l_curr := LGT_NEW_CODE( pcod_istore, l_curr );   { Built the store index }
      l_curr^.lgt_nxt := loop_lgt;             { Link with the loop statement }
      { Built the mother sequence }
      LGT_NEW( loop_lgt, nil, lgt_ctlflow, l_curr );
      loop_lgt^.lgt_stm := stm_sequence;

      { Append the inc/dec node at the end of statelist }
      l_curr := LGT_NEW_IDREF( for_id, nil );
      l_curr := LGT_NEW_CODE( pcd, l_curr );   { Create the inc/dec node }
      l_curr^.lgt_typ := ty;
      if l_start <> nil then l_start^.lgt_nxt := l_curr
                        else l_end^.lgt_nxt := l_curr  { Impossible ! }
    end
    else
      { We must free the unused node (for cte only - otherwise it is used) }
      if l_curr^.lgt_kind = lgt_const then LGT_FREE( l_curr );

    l_curr := loop_lgt                         { Save for return }
  end;
  { Restore the initial context }
  loop_lgt := loop_lgt_sav;
  { ///if loop_id <> nil then cntx_label := loop_id^.ide_lablnk; ///}
  if curr_disp > sav_disp then                 { No disp overflow }
    { Set the previous display in the reserved list }
    IDE_RESERVE_DISP( sav_disp );
  LABEL_PURGE( nclb );
  FORSTATE := l_curr
end FORSTATE;


function GOTOSTATE: lgt_ptr;
const
  mdnam = 'GTOL';

var
  plb: ide_ptr;
  lgt: lgt_ptr;

begin
  lgt := nil;
  if sy_sym.sy = intconst then IDE_INT_LABEL;
  if sy_sym.sy <> identsy then SRC_ERROR( mdnam, 69, e_severe );
  err_prt := false;                            { Set for no error when no declared identifier }
  plb := IDE_SEARCH( [cla_label] );
  err_prt := true;                             { Reset for error when undeclared identifier }
  { For undeclared label, creates it automaticaly }
  if plb = nil then
  begin
    IDE_NEW( cla_label, nil, plb );
    with owner^ do
      if pro_labelhde = nil then pro_labelhde := plb
                            else lab_end_list^.ide_labnxt := plb;
    lab_end_list := plb
  end;
  LGT_NEW( lgt, nil, lgt_ctlflow, nil );
  with lgt^, plb^ do
  begin
    if ide_lex <> curr_lex then
    begin                                      { Jump go out of current procedure/function }
      lgt_stm    := stm_jump;
      { Set the label with no local use }
      ide_labflg := ide_labflg + [lab_inref,lab_refer]
    end
    else
    begin { Local goto }
      ide_labflg := ide_labflg + [lab_refer];  { set the label as used }
      if lab_hidden in ide_labflg then
        { Label is out of local scope }
        SRC_ERROR( mdnam, 70, e_error )
      else
        ide_lablvl := cntx_lblvl;
      lgt_stm := stm_goto;                     { Local goto }
    end;
    lgt_lab := plb                             { Set the link between goto and the label ident. }
  end;
  INSYMBOL;
  GOTOSTATE := lgt
end GOTOSTATE;


function BEGINSTATE: lgt_ptr;
const
  mdnam = 'BEGS';

var
  nclb: ide_ptr;
  lgt:  lgt_ptr;

begin
  nclb := cntx_label;
  cntx_lblvl := cntx_lblvl + 1;
  lgt  := STATELIST( endsy, true );
  if sy_sym.sy = endsy then INSYMBOL
                       else SRC_ERROR( mdnam, 54, e_error );
  LABEL_PURGE( nclb );
  BEGINSTATE := lgt
end BEGINSTATE;


procedure LABEL_ATTACH( lab_list: ide_ptr; trg: lgt_ptr );
begin
  if lab_list <> nil and trg <> nil then
    trg^.lgt_lide := lab_list;                       { Attach the local label list to the common target }
(*
  with trg^ do
  begin
    lgt_lide := lab_list;                            { Attach the local label list to the common target ... }
    lgt_status := lgt_status + [lgt_lbl]             { ... and set the related labeled flag in the target }
  end;
*)
  while lab_list <> nil do                           { Loop to attach all new label(s) at the target lgt node }
  with lab_list^ do
  begin
    ide_lablgt := trg; lab_list := ide_labsyn
  end
end LABEL_ATTACH;



begin { STATEMENT }
  lgt           := nil;
  lgtt          := nil;
  stat_label    := nil;
  nwstk := wildtmp_stk;

  with sy_sym do
  begin
    flb := nil;                                         { Set the local synonymous label list to be empty }
    if sy = labelsy then
    repeat                                              { Set the current label as a label node }
      err_prt := false;                                 { Set for no error when no declared identifier }
      ip := IDE_SEARCH( [cla_label] );
      err_prt := true;                                  { Reset for error when undeclared identifier }
      { Create the new label when not already declared }
      if ip <> nil then
        { Ignore any external block label }
        if ip^.ide_lex <> curr_lex then ip := nil
        else
          if lab_defined in ip^.ide_labflg then
            { Already defined label => error }
            SRC_ERROR_S( mdnam, 75, e_severe, sy_ident );

      if ip = nil then                                  { Create the label when it is not exist (neither declared, ... }
      begin                                             { ... defined or goto referenced) in the current entry block }
        IDE_NEW( cla_label, nil, ip );
        with owner^ do                                  { Put it in the current entry block label list }
          if pro_labelhde = nil then pro_labelhde := ip
                                else lab_end_list^.ide_labnxt := ip;
        lab_end_list := ip
      end;

      with ip^ do
      begin
        ide_lablnk := cntx_label;                       { Put it in the current entry defined label list }
        cntx_label :=         ip;
        ide_labflg := ide_labflg + [lab_defined];       { Set as defined label }
        if lab_refer in ide_labflg then
          if ide_lablvl < cntx_lblvl then
            SRC_ERROR_S( mdnam, 70, e_error, sy_ident ) { Out of scope label ERROR }
      end;
      if flb = nil then flb := ip;                      { Keep the memory of the first label }
      ip^.ide_labsyn := stat_label;                     { Put also this label in the local synonymous label list ...(LIFO) }
      stat_label := ip;                                 { ... (LIFO) because the ordering has no matter }
      INSYMBOL                                          { Gobble up the label }
    until sy <> labelsy;                                { End of label loop }

    if cmp_trace > 0 then                               { Back Tracing enable }
    case sy of
      beginsy, semicolon,                               { No tracing for begin or null statement }
      loopsy, repeatsy: ;                               { No tracing for repeat or loop statement }

    otherwise
      if glicd < 2 then                                 { New code line, can be forced, can be with change context }
        if stat_label <> nil then                       { The statement is labeled }
          if lab_inref in stat_label^.ide_labflg then glicd := 2    { + Context (possible goto from more internal routine) }
                                                 else glicd := 1;   { Line Only }

      lgtt := LGT_NEW_LINE( owner, lgp, glicd );        { Generate a new info source line node when required }

      if stat_label <> nil then                         { when the statement must be labeled }
      begin
        if lgtt = nil then                              { If a previous srcinfo node was updated ... }
        begin                                           { A previous lgt_srcInfo node (lgp^) has been updated }
          if lgp <> nil then                            { Witout syntax error, this should be always true }
            flb^.ide_labsyn := lgp^.lgt_lide;           { Attach the new label LIFO to the Previous one to form one list }             
          LABEL_ATTACH( stat_label, lgp )               { Attach all label to the unique target lgt node } 
        end
        else                                            { A new lgt_srcInfo node has been created }
          LABEL_ATTACH( stat_label, lgtt );             { Attach all label(s) to the unique target lgt node } 
        stat_label := nil                               { Set to null pointer to signal no label for next statement }
      end;
      glicd := 0                                        { Just change the line number for the next statement }
    end
  end;

  sta_sym := sy_sym;
  with sta_sym do
  begin
    if (sy <> endsy) and (sy <> eofsy) and (sy <> untilsy) and
       (sy <> identsy) and (sy <> semicolon) then INSYMBOL;
    case sy of
      eofsy: { eofstate } ;
      identsy:
        begin
          ip := IDE_SEARCH( [cla_varbl, cla_field,
                             cla_fentry, cla_genwfent, cla_generic, cla_statement]);
(*        if ip <> ide_udptr[cla_varbl] then
          begin
            SRC_ERROR_S( mdnam, 104, e_error, sy_ident )       { Undeclared };
            SKIP_SYMBOL( semicolon )
          end
          else
*)
          with ip^ do
          begin
            INSYMBOL;                                          { Gobble up the identifier }
            case ide_class of
              cla_statement:
                lgt := USER_STATE_CALL( ip );

              cla_fentry:
                begin
                  lgt := CALL_FORMAL_PROC( ip, false );
                  if lgt <> nil then lgt^.lgt_typ := nil
                end;

              cla_genwfent,
              cla_generic:
                case sy_sym.sy of
                  becomes, { * Complete Function return value }
                  period,  { * Return Record Function Field Value }
                  lbrack:  { * Return Array Function Element Value }
                    lgt := RETURNSTATE( ip );

                otherwise
                  if ide_class = cla_generic then lgt := CALL_GENERIC( ip, false )
                                             else lgt := CALL_FORMAL_PROC( ip, false );
                  if lgt <> nil then lgt^.lgt_typ := nil
                end;

            otherwise
              lgt := ASSIGNMENTSTATE( ip );
            end
          end
        end;

      beginsy:    lgt := BEGINSTATE;
      ifsy:       lgt := IFSTATE;
      loopsy,
      repeatsy,
      whilesy:    lgt := LOOPSTATE( sy );
      forsy:      lgt := FORSTATE;
      exitsy:     lgt := EXITSTATE;
      withsy:     lgt := WITH_STATE;
      casesy:     lgt := CASE_DEFINITION( casesy, nil );
      gotosy:     lgt := GOTOSTATE;

      newsy:      lgt := NEW_CALL( new_entry_proc );
      newhsy:     lgt := NEW_CALL( newh_entry_proc );
      disposesy:  lgt := DISPOSE_CALL( dispose_entry_proc );

      opensy:     lgt := OPEN_CALL( 0 );
      resetsy:    lgt := OPEN_CALL( 1 );
      rewritesy:  lgt := OPEN_CALL( 2 );
      appendsy:   lgt := OPEN_CALL( 3 );

      readsy:
        lgt := READWRITE_CALL( std_inp_file, inp_std_sel, inp_std_gene,
                                             inp_std_bin,          nil );
      readlnsy:
        lgt := READWRITE_CALL( std_inp_file, inp_std_sel, inp_std_gene,
                                             inp_std_bin, inp_std_eoln );
      readvsy:
        lgt := READWRITE_CALL(          nil, inp_std_sel, inp_std_gene,
                                                     nil, inp_std_eoln );
      writesy:
        lgt := READWRITE_CALL( std_out_file, out_std_sel, out_std_gene,
                                             out_std_bin,          nil );
      writelnsy:
        lgt := READWRITE_CALL( std_out_file, out_std_sel, out_std_gene,
                                             out_std_bin, out_std_eoln );
      writevsy:
        lgt := READWRITE_CALL(          nil, out_std_sel, out_std_gene,
                                                     nil, out_std_eoln );

      returnsy:
        lgt := RETURNSTATE( nil );

    otherwise
    end;
    if stat_label <> nil then
    begin { * A New defined label was pending }
      if lgt = nil then LGT_NEW( lgt, nil, lgt_empty, nil );
      LABEL_ATTACH( stat_label, lgt )                   { Attach all label to the unique target lgt node } 
    end
  end;

  if lgt <> nil then
  begin
    if lgtt <> nil then
    begin                                               { When 2 lgt statement node was created ... }                          
      lgtt^.lgt_nxt := lgt;
      if bsequ then                                     { ... and a unique node was expected ... }
      begin
        LGT_NEW( lgt, nil, lgt_ctlflow, lgtt );         { ... assemble these nodes to one sequence node }
        lgt^.lgt_stm := stm_sequence;
        lgt_last_enode := lgt
      end
      else
      begin
        lgt_last_enode := lgt;
        lgt := lgtt
      end
    end
    else
      lgt_last_enode := lgt
  end
  else
  begin                                                 { lgt_last_node must set to nil when no statement are generated }
    if lgtt <> nil then lgt := lgtt;
    lgt_last_enode := lgt
  end;

  TMPSTK_FREE( nwstk );                                 { Free any stack temporary allocations }
  STATEMENT := lgt
end STATEMENT;



function STATELIST
         {( stopper: symbol; seq_flg: boolean ): lgt_ptr was forward };
const
  mdnam = 'STLI';

var
  lgt, lgt1, lgt2: lgt_ptr;


begin { STATELIST }
  with src_control^ do src_insnb := src_insnb + 1;
  lgt  := nil;
  lgt1 := nil;
  with sy_sym do
  begin
    while sy = semicolon do INSYMBOL           { Skip any trailing statement };
    if ((sy <> stopper) and (sy <> eofsy) and (sy <> endsy))
          and not emergency_stop then
    begin
      lgt  := STATEMENT( nil, false );
      lgt1 := lgt_last_enode;

      while ((sy <> stopper) and (sy <> eofsy) and (sy <> endsy))
            and not emergency_stop do
      begin
        if sy = semicolon then
          while sy = semicolon do INSYMBOL     { Skip any trailing statement }
        else SRC_ERROR( mdnam, 21, e_error );
        if ((sy <> stopper) and (sy <> eofsy) and (sy <> endsy))
            and not emergency_stop then
        begin
          lgt2 := STATEMENT( lgt1, false );
          if lgt2 <> nil then                  { Perform the statement link in a list }
          begin
            if lgt = nil then lgt := lgt2
                         else lgt1^.lgt_nxt := lgt2;
            lgt1 := lgt_last_enode
          end
        end
      end
    end
  end;
  with src_control^ do src_insnb := src_insnb - 1;
  lgt_end_list := lgt1;                        { Keep the last statement node address }
  if seq_flg and (lgt <> lgt1) then
  begin                                        { More than one statement }
    LGT_NEW( lgt1, nil, lgt_ctlflow, lgt );
    lgt1^.lgt_stm := stm_sequence;
    STATELIST := lgt1
  end
  else STATELIST := lgt
end STATELIST;




begin { CMP_BLOCK }
  { Create the local display }
  if curr_lex > 0 then
  begin
    NEW_DISP_LEVEL( owner, dsp_proc );
(*  lex_ident_level[curr_lex] := curr_disp { Lex = curr_lex base is curr_disp } *)
  end;

  return_flg           :=        false;        { Init with no return statement/assignement }
  loop_lgt             :=          nil;        { No loop id }
  fw_ptr               :=          nil;        { Init the block }
  var_lst_end          :=          nil;        { Variable list end init }
  sav_label            :=   cntx_label;        { Save the more external label list }
  cntx_label           :=          nil;        { and set the local one's at empty state }
  with owner^ do
  begin
    pro_opelst         :=          nil;        { Set the local generic list to empty }
    pro_loclst         :=          nil;        { Initialize the local variable list }
    pro_typlst         :=          nil         { Initialize also the local type list }
  end;

  COMPILE_SET_SBTTL( owner );

  with sy_sym do
  begin
    attr_kind          :=     var_decl;        { Set the default declaration kind }
    attr_nam           :=          nil;        { ... without external name }
    repeat
      pro_current      :=        owner;        { Reset the current procedure pointer }
      cprc_disp        :=    curr_disp;        { Set the current label display }

      { Get any prefix attributes }
      if sy = lbrack then SET_DECL_ATTRIBUTE;
      case sy of

        constsy:
          begin
            INSYMBOL;
            CONSTDECL
          end;

        typesy:
          begin
            INSYMBOL;
            TYPEDECL
          end;

        varsy:
          begin
            if sy_init_mod then                { Enable the system variable init mode }
              sy_var_init_mod := true;
            INSYMBOL;
            VARDECL;
            if sy_init_mod then                { Enable the system variable init mode }
              sy_var_init_mod := false
          end;

        labeldclsy: LABELDECL;

        statementsy: STATEMENTDECL;

        proceduresy,
        functionsy:
          begin
            GENE_DECL;
            COMPILE_SET_SBTTL( owner );
            cntx_varbl := owner^.pro_cntxide
          end;

        beginsy, endsy, eofsy: ;

      otherwise
        SRC_ERROR( mdnam, 91, e_error );
        INSYMBOL
      end

    until (sy = eofsy) or (sy = beginsy) or (sy = endsy);

    if curr_lex > 0 then
    if sy = beginsy then
    begin
      { Create the Temp. Var for Large size function return Value }
      IDE_CREATE_NAME( '.temp' );
      IDE_NEW_TYP( form_wild, wildtmp_typ );

      wildtmp_typ^.typ_size    :=    0;
      IDE_NEW( cla_varbl, wildtmp_typ, wildtmp_ide );
      wildtmp_ide^.ide_vacc := [var_in,var_out];
      wildtmp_psz      :=            0;        { Set without previous size }
      wildtmp_pal.int  :=            0;        { Set without previous alignment }
      wildtmp_stk      :=          nil;        { Set the stack at empty state }

      cntx_lblvl       :=            0;        { Set the local label level }
      cprc_disp        :=    curr_disp;        { Set the current label display }
      pro_current      :=        owner;        { Reset the current procedure pointer }
      COMPILE_SET_SBTTL( owner );

      if fw_ptr <> nil then                    { Some forward reference are not solved }
      begin
        if var_lst_end <> nil then var_lst_end^.ide_nxt := fw_ptr
                              else owner^.pro_loclst := fw_ptr;
        SRC_ERROR( mdnam, 92, e_severe )
      end;

      { Enable the label processing }
      sy_label_flag := true;

      INSYMBOL; { Gobble up 'begin' }

      with owner^ do
      begin
        { Compile all statements }
        pro_lgt := STATELIST( endsy, false );

        if pro_typ <> nil then
          if not return_flg then SRC_ERROR( mdnam, 74, e_severe );

        { Insert the init sequences as the first statements to execute }
        if pro_init_hde <> nil then
        begin
          pro_lst^.lgt_nxt := pro_lgt;         { Link with the initial sequence }
          pro_lgt := pro_init_hde
        end;
        pro_lst := lgt_end_list
      end;

      { Cancel all operator definitions }
      p_ope := owner^.pro_opelst;
      while p_ope <> nil do
      begin
        with p_ope^ do 
        begin
          ope_table[ope_operator] := ope_llnk; { Restore old ope definitions}
          { /// To free all procedures  do not do it here /// }
          { /// FREE_GENERIC_LIST( ope_gfirst, ope_glast ); /// }
          { *** But we can free the gen block directly here *** }
          p_ope2 := ope_nxt
        end;
        DISPOSE( p_ope );
        p_ope := p_ope2
      end;

      { Disable the label processing }
      sy_label_flag := false
    end
  end;

  { Look for undefined referenced label }
  if owner^.pro_pkind >= pro_block then
  begin
    cntx_label := owner^.pro_labelhde;
    while (cntx_label <> sav_label) and (cntx_label <> nil) do
    with cntx_label^ do
    begin
      if lab_refer in ide_labflg then
        { Some local label(s) is(are) used and not defined }
        { /// Should be indicate type label identifier in the error message ///}
        if not (lab_defined in ide_labflg) then SRC_ERROR( mdnam, 66, e_severe );
      cntx_label := ide_labnxt
    end
  end;
  cntx_label := sav_label                      { Restore the more external label list }
end CMP_BLOCK;



[global]
procedure CMP_INIT;
{ Generale Initialisation Procedure to enable the initial context }
const
  mdnam     =     'MAIN';
  srcdelete =      false;                      { Do not delete PAS.INI }

var
  ipmain, ip:  ide_ptr;
  {tmpsrc:     str_ptr;}
  i, ierr:     integer;
  ic:             char;

begin { CMP_INIT }

  emergency_stop   :=     false                { Set for pas run };

  INSY_INIT;                                   { Initialize the init source read }

  if emergency_stop then PASCAL_EXIT( 2 );

  opt_exec         :=    false;                { Execution disable until showed otherwise }

  cmp_cmpdbg       :=    false;                { Assume no compiler code debugging }

  cmp_range        :=    false;                { Assume no run-time range check, to opt. speed }
  cmp_dynamic      :=    false;                { Assume  auto. variable size allocation disable }
  cmp_genenv       :=    false;                { Assume no environment to generate }
  cmp_listlvl      :=        1;                { Assume a User Listing Level of 1 }
  cmp_igenv        :=       -1;                { Until shown otherwise }

  cmp_macf         :=    false;                { Disable the P code listing output }
  cmp_cobj         :=    false;                { Disable global code P binary generation }
  cmp_objf         :=    false;                { Disable binary code P object output }
  cmp_bltt         :=    false;                { Disable the in-line tree built }
  cmp_opt          :=     true;                { Enable the code optimization }
  cmp_debugopt     :=    false;                { Disable the debug }
  cmp_debug        :=    false;
  cmp_traceopt     :=        5;                { Enable tracing option by 5 lines increment }
  cmp_trace        :=       -1;                { Set tracing mode in disable state }
  cmp_tracecount   :=        0;
  cmp_twicedclon   :=    false;                { Set the normal declaration mode }

  sy_init_mod      :=     true;                { Enable the init mode }
  sy_generic_qmod  :=     true;                { Enable th Queue mode for insertion in generic lists }
  sy_var_init_mod  :=    false;

  sy_casedef       :=    false;                { Flag for case definition advent }

  INSYMBOL;                                    { Get the first source symbol of std definition file }

  COMPILE_SET_TITLE;
  COMPILE_SET_SBTTL( lex_ident_tree[0].disp_owner );

  GENERATION_SETTING;                          { Set all code generator specific setting }

  { Compile standard def. }
  CMP_BLOCK( lex_ident_tree[0].disp_owner, true, 0 );

  if error_result <> e_success then
    emergency_stop := true;                    { We must not have error on init }

  if emergency_stop then PASCAL_EXIT( 2 );
(*
  { Create the Pascal Environment Path string constant (used to find some standard files) }
  IDE_CREATE_NAME( 'cpascal_environment' );
  IDE_NEW( cla_konst, typ_std[form_record], ip );
  VAL_NEW( ip^.ide_value, typ_std[form_record] );
  with ip^, ide_value^ do
  begin
    ide_ckind := var_static;
    val_kind  := form_string;
    val_size  := cpas_env_dir.length;
    val_typ   := typ_std[form_record];
    if val_size > 0 then
    begin
      NEW( val_str, val_size );
      val_str^ := cpas_env_dir;
      val_psect := 0;
      val_acc := val_acc - [var_hidden];
      CTE_ALLOCATE( ide_value, ip )
    end
    else val_str := nil
  end;
*)
  { Create the standard context type (used for execution tracing) as an unnamed record type }
  cntx_procname    :=                  fptr_size;      { We suppose that alignement and size match }
  cntx_srcfname    :=  cntx_procname + fptr_size;
  cntx_linenbr     :=  cntx_srcfname + fptr_size;
  cntx_size        :=  cntx_linenbr  + inte_size;      { Align for int match with ! }
  IDE_NEW_TYP( form_record, cntx_typ );
  with cntx_typ^ do
  begin
    typ_align.int  := typ_std[form_pointer]^.typ_align.int;
    typ_size       := cntx_size;
    typ_firstfield := nil;
    typ_lastfield  := nil;
    typ_recvar     := nil
  end;
  if cmp_trace > 0 then cmp_tracecount := 0;   { Force the back-tracing }
  sy_init_mod      := false;                   { Disable the init mode }
  sy_generic_qmod  := false                    { Disable the generic list insertion Queue mode }
end CMP_INIT;




procedure CMP_PASS2 { ( pr: pro_ptr ); was forward };
begin
  with pr^ do
  begin
(*
    if cmp_macf then
    begin
      LGT_DUMP_PROC( pr );                     { Do a lgt first lvl dump listing }
      LST_PAGE
    end;
*)
    LGT_PASS1_COMPLET( pr );                   { Complete the PASS1 LGT generation }

    if cmp_macf then
    begin
      LGT_DUMP_PROC( pr );                     { Do a lgt first lvl dump listing }
      LST_PAGE
    end;
(*
    LST_PAGE;
*)
    case pro_pkind of
      { The code generator is called only for the pro_decl procedure/function }
      pro_main, pro_decl, pro_global:
        begin
          { LGT_OPTIMIZE_TREE( pr, cmp_opt );  { Perform necessary optimization
                                                 and optional optimization if asked }
          GENERATE_CODE_P1( pr )               { Perform the pre-generation of code }
        end;
    otherwise
    end
  end
end CMP_PASS2;



[global]
function CMP_COMPILE( interactive: boolean ): error_sev;
const
  mdnam = 'CMPM';
  srcdelete = false;

var
  i:           integer;
  moduleflg:   boolean;
  package:     pro_ptr;
  ipmain, ip:  ide_ptr;
  ierr, icd:   integer;
  envp:        env_ptr;

begin { CMP_COMPILE }
  emergency_stop       :=        false;
  moduleflg            :=        false;

  env_file             :=          nil;
  env_first            :=          nil;
  env_last             :=          nil;

  with sy_sym do
  begin { * Initialize standard ok. }
    if not emergency_stop then
    begin
      COMPILE_SET_TITLE;

      { Set user init source listing mode - disable }
      { With src_control^ do  src_flags := src_flags + [src_blist];}

      { Set listing default }
      with src_control^ do
      begin
        src_level      :=            1;         { Listing level }
        src_lstmxlev   :=  cmp_listlvl          { Maximum listing level at 1 }
      end;

      { Init sy_ch for INSYMBOL }
      sy_ch            :=          ' ';
      INSYMBOL;

      sy_fix_range_ctl :=         true;         { Enable fixed range bound check }

      DISPOSE( lst_current^.lst_sbttl );        { Clear old module title }

      NEW( package );                           { Create the new package descriptor }
      pro_current      :=      package;         { Set the current procedure }

      if sy = usesy then
      begin { * Form use '<env_file>', ... }
        sy             :=        comma;
        repeat
          INSYMBOL;
          if (sy = stringconst) and (sy_string.length > 0) then
            SET_ENV_FILE_SPC( nil )
          else
            SRC_ERROR( mdnam, 58, e_severe );
          INSYMBOL
        until sy <> comma;
        if sy = semicolon then INSYMBOL
                          else SRC_ERROR( mdnam, 21, e_error )
      end
      else if sy = lbrack then
      begin { * form [inherit('<env_file>', ...)] and/or
                     [environment('<env_file>', ...)] }
        sy := comma;
        repeat
          INSYMBOL;
          if sy = identsy then
          begin
            ip := LEVEL_SEARCH( attr_list );
            if ip <> nil then
              repeat
                INSYMBOL;
                case ip^.ide_attr of
                  atts_inherit:
                    begin
                      if sy <> lparen then SRC_ERROR( mdnam, 22, e_error );
                      sy := comma;
                      repeat
                        INSYMBOL;
                        if (sy = stringconst) and (sy_string.length > 0) then
                          SET_ENV_FILE_SPC( nil )
                        else
                          SRC_ERROR( mdnam, 58, e_severe );
                        INSYMBOL
                      until sy <> comma;
                      if sy = rparen then INSYMBOL
                      else SRC_ERROR( mdnam, 23, e_error )
                    end;

                  atts_environment:
                    begin
                      if sy = lparen then INSYMBOL
                      else SRC_ERROR( mdnam, 22, e_error );
                      if (sy = stringconst) and (sy_string.length > 0) then
                      begin
                        NEW( env_file, sy_string.length );
                        env_file^ := sy_string;
                        cmp_genenv := true;
                        cmp_igenv  := 0;
                        INSYMBOL
                      end
                      else
                      begin
                        cmp_genenv := false;
                        cmp_igenv := -1
                      end;
                      if sy = rparen then INSYMBOL
                      else SRC_ERROR( mdnam, 23, e_error )
                    end;
                otherwise
                  SRC_ERROR_S( mdnam, 3, e_warning, sy_ident )
                end
              until (sy = eofsy) or (sy = comma) or (sy = rbrack)
          end
          else SRC_ERROR( mdnam, 2, e_severe )
        until sy <> comma;
        if sy = rbrack then INSYMBOL
                       else SRC_ERROR( mdnam, 26, e_error )
      end;

      if cmp_igenv >= 0 then cmp_genenv :=  true
                        else cmp_genenv := false;

      if sy = modulesy then                     { A module definition is begining }
      begin
        INSYMBOL;                               { Get the package identifier }
        moduleflg := true;
        if sy <> identsy then
        begin
          SRC_ERROR( mdnam, 93, e_fatal );
          emergency_stop := true
        end
      end
      else
      if sy = programsy then                    { A program definition is begining }
      begin
        INSYMBOL;                               { Get the program identifier }
        if sy <> identsy then
        begin
          SRC_ERROR( mdnam, 93, e_fatal );
          emergency_stop := true
        end
      end
      else
        SRC_ERROR( mdnam, 94, e_fatal )
    end;

    if not emergency_stop then
    begin
      with package^ do
      begin
        { Create the Package Level where the module/program name is defined }
        curr_lex   := SUCC( curr_lex );         { Set the main/module lex level (must be 1) }
        NEW_DISP_LEVEL( package, dsp_proc );    { Create the user bottom level }
        { Mark the limit of search for user identifiers,
          the user definitions can shadow any symbol of .standard. (lex = 0) level }
        lex_ident_level[curr_lex] := curr_disp; { The display level should be 1 (not critical) }

        IDE_NEW( cla_generic, nil, ipmain );    { Create the program (or module) identifier }

        pro_next        :=                 nil; { Init the procedure link }
        pro_link        :=                 nil;
        pro_flags       :=        [prf_tocomp]; { Set the procedure use flags }
        pro_stdname     :=    ipmain^.ide_name; { Set the module/main name }
        pro_operator    :=               no_op;
        pro_geneide     :=              ipmain; { Set the related identifier link }
        pro_idetree     :=                 nil;
        pro_idelast     :=                 nil;
        pro_parmlst     :=                 nil;
        pro_lex         :=                   0;
        pro_parmsize    :=                   0; { Not used for main or module (no arguments) }
        pro_nparm       :=                   0; { Module number set to 0 for local access }
        pro_typ         :=                 nil; { Main and module cannot have return value }
        pro_prmtyls     :=                 nil; { Not used for main or module (no arguments) }
        if moduleflg then pro_pkind := pro_package      { Set as a declared module (== package) }
                     else pro_pkind := pro_main;        { Set as a declared main program }

        pro_owner       :=                 nil; { No owner for program of module }
        pro_srcinfo     :=                 nil;
        pro_lgt         :=                 nil; { Empty code assumed }
        pro_lst         :=                 nil;
        pro_init_hde    :=                 nil; { Set the node list to the empty state }
        pro_opelst      :=                 nil; { Empty new operator def. }
        pro_labelhde    :=                 nil; { Empty label list }
        pro_reserved    :=                 nil; { The reserved list is set to be empty }
        pro_cntxide     :=                 nil; { No Procedure context }
        pro_loclst      :=                 nil; { Local identifier list head is empty }
        pro_typlst      :=                 nil; { Local type list head is empty }

        pro_fdyn_all    :=                 nil;
        pro_ldyn_all    :=                 nil; { No current dynamic allocation }
        pro_reglist     :=                 nil; { init to no register use }
        pro_labelenv    :=                  -1; { Global label environment count } 
        pro_labelcnt    :=                   0;
        pro_envidx      :=                   0; { Init the Lex Access environment }
        pro_stk_size    :=                   0; { No stack or dynamic allocation }
        pro_dyn_size    :=                   0;
        pro_intacc      :=               false; { Init of flag for internal access }


        pas_main := package;                    { Set the main specification }
        INSYMBOL;                               { Gobble up the module/program name }
        if sy = lparen then
        begin
          sy := comma;
          while sy = comma do
          begin
            INSYMBOL;                           { Gobble up the comma }
            if sy = identsy then INSYMBOL
                            else SRC_ERROR( mdnam, 95, e_warning )
          end;
          if sy = rparen then INSYMBOL
                         else SRC_ERROR( mdnam, 23, e_error )
        end;
        if sy = semicolon then INSYMBOL
                          else SRC_ERROR( mdnam, 21, e_error )
      end;

      { Load all specified environment files }
      if env_first <> nil then PAS_READ_ENV_FILE;

      if cmp_debugopt then
      begin
        cmp_debug      :=         true;
        cmp_traceopt   :=            1
      end;

      if cmp_traceopt > 0 then
      begin { * Create the context variable and set it }
        GEN_CNTXVAR( package, ipmain^.ide_name );
        cmp_trace     :=  cmp_traceopt;
        icd := 5                                { Init Tracing }
      end
      else icd         :=            0;

      CMP_BLOCK( package, true, icd );          { Compile the block }

      if (cmp_trace > 0) and (not moduleflg) then
        { Set a End of Back Tracing statement }
        with package^ do
          GEN_LINETRACE( package, pro_lgt, pro_lst, 6 );

      if sy = endsy then INSYMBOL
                    else SRC_ERROR( mdnam, 54, e_error );
      if sy = identsy then                      { An identifier is found after the procedure end }
        { Named program/module }
        if ( sy = identsy ) and (MATCH( ipmain^.ide_name^, sy_ident ) = 0) then
          INSYMBOL
        else
          SRC_ERROR_S( mdnam, 96, e_warning, sy_ident );

      if sy = period then INSYMBOL
                     else SRC_ERROR( mdnam, 21, e_warning );
      if sy <> eofsy then
      begin { * Ignore any things after period }
        SRC_ERROR( mdnam, 991, e_warning ); 
        while sy <> eofsy do INSYMBOL
      end
      else SRC_END_OF_LINE;
      if pro_last = nil then pro_first := package
                        else pro_last^.pro_next := package;
      pro_last := package;

      { Set any error to stop PAS }
      if error_result > e_warning then
        emergency_stop := true
      else
      begin
        with package^ do
          if pro_lgt <> pro_lst then
          begin
            LGT_NEW( pro_lgt, nil, lgt_ctlflow, pro_lgt );
            pro_lgt^.lgt_stm := stm_sequence;
            pro_lst := pro_lgt
          end;
        CMP_PASS2( package )
      end;

      if cmp_macf then
      begin
        LGT_DUMP_STATIC( package );             { Do a lgt first lvl dump listing }
        with lst_current^ do LST_PAGE
      end;

      if error_result > e_warning then emergency_stop := true
      else
      begin
        PAS_WRITE_ENV_FILE;
        GENERATE_CODE_P2
      end
    end
  end { * with sy_sym do };
  CMP_COMPILE := error_result
end CMP_COMPILE;


end.
