13c13
< *              ---  Version  3.1-B2 -- 31/07/2016 ---                   *
---
> *              ---  Version  3.1-B3 -- 30/09/2016 ---                   *
304a305,323
> function CHILDREN_TYPE( eff, frm: typ_ptr; bsym: boolean ): boolean;
> { Function that return true when frm is a parent type of eff.
> }
> var
>   b: boolean := false;
> 
> begin
>   if frm <> nil then
>   begin
>     while (eff <> nil) and (eff <> frm) do  eff := eff^.typ_parent;
>     b := (eff = frm);
>     if not b and bsym then b := CHILDREN_TYPE( frm, eff, false )
>   end;
>   CHILDREN_TYPE := b
> end CHILDREN_TYPE;
> 
> 
> 
> [global]
342d360
<  peff, pfrm: typ_ptr;
347d364
<   b1 :=  ( eff = frm );
348a366,367
>   begin
>     b1 := CHILDREN_TYPE( eff, frm, false );
351,375c370,378
<     begin
< (*    if not exact then *)
<       begin
<         peff := eff^.typ_parent;
<         repeat
<           if peff <> nil then
<           with peff^ do
<           begin
<             b1 := ( frm = peff );
<             peff := typ_parent
<           end
<         until b1 or (peff = nil)
<       end;
<       if not b1 then
<       with frm^ do
<       begin
<         { Test for formal is a range of a effective type }
<         if typ_form = form_range then
<           b1 := COMP_TYPE( typ_parent, eff, exact );   { In this case, it is ok. }
< 
<         if not b1 then
<           { Other cases }
<           if (eff^.typ_form <= form_wild) and (typ_form <= form_wild) then
<           begin
<             tst := comp_table[eff^.typ_form, typ_form];
---
>     with frm^ do
>     begin { Test for formal is a range of a effective type }
>       if typ_form = form_range then
>       b1 := COMP_TYPE( typ_parent, eff, exact );   { In this case, it is ok. }
> 
>       if not b1 then { Other cases }
>         if (eff^.typ_form <= form_wild) and (typ_form <= form_wild) then
>         begin
>           tst := comp_table[eff^.typ_form, typ_form];
378c381
<             WRITELN( ' Comp_Table[', eff^.typ_form, ', ', typ_form, '] = ', comp_table[eff^.typ_form, typ_form] );
---
>           WRITELN( ' Comp_Table[', eff^.typ_form, ', ', typ_form, '] = ', comp_table[eff^.typ_form, typ_form] );
380a384,427
> (* eff = nil avec frm = fentry OK mais frm = nil avec eff = fentry bad *)
> (*        if not (exact and (tst = ok) and (eff^.typ_form <> typ_form)) then *)
>           case tst of
>             ok: b1 := true;
> 
>             svr,
>             ver: case typ_form of { Case on Formal typ_form }
>                    form_lit,
>                    form_int,
>                    form_char:    { * For ennumerated types we must verify the range compatibility }
>                      if typ_fxdrange then
>                        if not exact then b1 := (COMP_SCALAR( eff, frm ) <= 2)
>                                     else b1 := (COMP_SCALAR( eff, frm ) =  0) and (typ_size = eff^.typ_size);
> 
>                    form_set,
>                    form_lset:    { * For the set (small or large), the element types must be compatibles }
>                      b1 := COMP_TYPE( eff^.typ_seltype, typ_seltype, exact );
> 
>                    form_array:   { * For Array, the element type must be sames and the index type must be compatibles }
>                      b1 := COMP_TYPE( eff^.typ_aeltype, typ_aeltype, true ) and
>                            COMP_TYPE( eff^.typ_indtype, typ_indtype, true );
> 
>                    form_conf:    { * For conformant formal type, we must check the compatibilities of elements and indexies }
>                      b1 := COMP_TYPE( eff^.typ_aeltype, typ_aeltype, true ) and
>                            COMP_TYPE( eff^.typ_indtype, typ_indtype^.typ_parent, true );
> 
>                    form_pointer: { * For pointer the pointed types must be compatibles }
>                      if typ_eltype = nil then b1 := eff^.typ_form = form_pointer
>                                          else b1 := COMP_TYPE( eff^.typ_eltype, typ_eltype, true ); 
> 
>                    form_fentry:  { * For formal/pointer_of procedure/function, we must verify the proc./funct. compatibility }
>                      if typ_entry = nil then b1 := (eff^.typ_form = form_fentry)
>                                         else b1 := COMP_PROC_ARG( eff^.typ_entry, typ_entry );
> 
>                  otherwise  { Always bad }
>                  end { case typ_form };
> 
>             cha: { When the Formal parameter is a standard string }
>               b1 := COMP_TYPE( frm, typ_std[form_record], false );
> 
>             str: { When the Effective parameter is a standard string }
>               if COMP_TYPE( eff, typ_std[form_record], false ) then
>                 { Effective Standard string used as array of char }
>                 b1 := COMP_TYPE( eff^.typ_lastfield^.ide_typ, frm, false );
382,424d428
<             if not (exact and (tst = ok) and (eff^.typ_form <> typ_form)) then
<             case tst of
<               ok: b1 := true;
< 
<               svr,
<               ver: case typ_form of { Case on Formal typ_form }
<                      form_lit,
<                      form_int,
<                      form_char:    { * For ennumerated types we must verify the range compatibility }
<                        if typ_fxdrange then
<                          if not exact then b1 := (COMP_SCALAR( eff, frm ) <= 2)
<                                       else b1 := (COMP_SCALAR( eff, frm ) =  0) and (typ_size = eff^.typ_size);
< 
<                      form_set,
<                      form_lset:    { * For the set (small or large), the element types must be compatibles }
<                        b1 := COMP_TYPE( eff^.typ_seltype, typ_seltype, exact );
< 
<                      form_array:   { * For Array, the element type must be sames and the index type must be compatibles }
<                        b1 := (eff^.typ_aeltype = typ_aeltype) and
<                              COMP_TYPE( eff^.typ_indtype, typ_indtype, true );
< 
<                      form_conf:    { * For conformant formal type, we must check the compatibilities of elements and indexies }
<                        b1 := COMP_TYPE( eff^.typ_aeltype, typ_aeltype, true ) and
<                              COMP_TYPE( eff^.typ_indtype, typ_indtype^.typ_parent, true );
< 
<                      form_pointer: { * For pointer the pointed types must be compatibles }
<                        if typ_eltype = nil then b1 := eff^.typ_form = form_pointer
<                                            else b1 := COMP_TYPE( eff^.typ_eltype, typ_eltype, true ); 
< 
<                      form_fentry:  { * For formal/pointer_of procedure/function, we must verify the proc./funct. compatibility }
<                        if typ_entry = nil then b1 := (eff^.typ_form = form_fentry)
<                                           else b1 := COMP_PROC_ARG( eff^.typ_entry, typ_entry );
< 
<                    otherwise  { Always bad }
<                    end { case typ_form };
< 
<               cha: { When the Formal parameter is a standard string }
<                 b1 := COMP_TYPE( frm, typ_std[form_record], false );
< 
<               str: { When the Effective parameter is a standard string }
<                 if COMP_TYPE( eff, typ_std[form_record], false ) then
<                   { Effective Standard string used as array of char }
<                   b1 := COMP_TYPE( eff^.typ_lastfield^.ide_typ, frm, false );
426,429c430,431
< 
<             otherwise { always bad }
<             end { case comp_table ... }
<         end
---
>           otherwise { always bad }
>           end { case comp_table ... }
431,432c433,434
<     end;
<  
---
>     end
>   end;
447c449
<   goodparam := true;                                   { Until showed otherwise }
---
>   goodparam := true;                                    { Until showed otherwise }
449c451
<     if (epr <> nil) and (fpr <> nil) then              { Both rec.ord pro_rec must be existing }
---
>     if (epr <> nil) and (fpr <> nil) then               { Both rec.ord pro_rec must be existing }
452c454
<         goodparam := false                             { The returned type must be same }
---
>         goodparam := false                              { The returned type must be same }
455c457
<         eid := epr^.pro_parmlst;                       { Get the arguments list heads }
---
>         eid := epr^.pro_parmlst;                        { Get the arguments list heads }
457,458c459,461
<         if epr^.pro_typ <> nil then                    { For functions, skip returned value }
<         begin  eid := eid^.ide_nxt; fid := fid^.ide_nxt  end;
---
>         if epr^.pro_typ <> nil then                     { For functions, skip returned value when the return tpe is not simple }
>           if not epr^.pro_typ^.typ_simple then
>           begin  eid := eid^.ide_nxt; fid := fid^.ide_nxt  end;
465c468
<               goodparam := COMP_TYPE( eid^.ide_typ, fid^.ide_typ, fid^.ide_vkind <> var_vformal );
---
>               goodparam := COMP_TYPE( eid^.ide_typ, fid^.ide_typ, true (* /// fid^.ide_vkind <> var_vformal *) );
2069a2073
> (*
2070a2075
> *)
2327a2333
> (*
2330c2336
< 
---
> *)
2477,2485c2483,2493
< procedure GENERIC_SEARCH( var id:   id_name;
<                               npa:  integer;
<                           var pg:   gen_ptr;
<                           parm_lst: lgt_ptr );
< { Procedure to find the procedure to choice in a generic list }
< { npa is the given parameter number }    
< { pg ins in/out pointer in the generic list }
< { On a success the procedure CALL_SETTING is called just before return
<   if the selected action is a procedure/function ( not a builtin operator ) }
---
> procedure GENERIC_SEARCH( var   id:       id_name;
>                                npa:       integer;
>                                 pg:       gen_ptr;
>                                 parm_lst: lgt_ptr
>                         );
> { Procedure to find the procedure to choice in a generic list :
>   npa is the given parameter number,
>   pg ins in/out pointer in the generic list,
>   On a success the procedure CALL_SETTING is called just before return.
>   if the selected action is a procedure/function ( not a builtin operator.
> }
2510c2518,2520
< %ifdef %DEBUG %then*)
---
> %ifdef %DEBUG %then
> *)
> 
2555c2565
< *)
---
>  *)
2557c2567
< begin
---
> begin { GENERIC_SEARCH }
2579a2590,2623
>                form_eqst: { * Type exactly same (or children type) and without (type) parameter }
> (*              case gen_p2^.typ_form of
>                    form_pointer:
>                      begin
>                        found := COMP_TYPE( lgt_nxt^.lgt_typ, lgt_typ, true ) and        { ptr := ptr or wptr := ptr or wptr ... }
>                                 ((lgt_nxt^.lgt_typ^.typ_form = form_pointer) or         { ... but only wild pointer or ptr here. }
>                                  (lgt_nxt^.lgt_typ^.typ_form = form_nil));
>                        if not found then
>                        begin
>                          found := (lgt_typ^.typ_form = form_pointer) and (lgt_nxt^.lgt_kind = lgt_const) and (lgt_nxt^.lgt_typ^.typ_form = form_nil);
>                          if not found and (gen_pcode <> pcod_istore) then
>                            found := (lgt_nxt^.lgt_typ^.typ_form = form_pointer) and (lgt_kind = lgt_const) and (lgt_typ^.typ_form = form_nil)
>                        end            
>                      end;
> 
>                   form_fentry:
>                     begin
>                        found := COMP_TYPE( lgt_nxt^.lgt_typ, lgt_typ, true ) and { Compatible type of routine pointer ... }
>                                 (lgt_typ^.typ_form = form_fentry) and            { ... but no wild pointer here. }
>                                 (lgt_nxt^.lgt_typ^.typ_form = form_fentry);
>                        if not found then
>                        begin
>                          found := (lgt_typ^.typ_form = form_fentry) and (lgt_nxt^.lgt_kind = lgt_const) and (lgt_nxt^.lgt_typ^.typ_form = form_nil);
>                          if not found and (gen_pcode <> pcod_istore) then
>                            found := (lgt_nxt^.lgt_typ^.typ_form = form_fentry) and (lgt_kind = lgt_const) and (lgt_typ^.typ_form = form_nil);
>                        end
>                      end;
> 
>                  otherwise
>                    found := COMP_TYPE( lgt_nxt^.lgt_typ, lgt_typ, true ) and      { Exactly the same types, ... }
>                             (lgt_typ^.typ_descr_size = 0) and                     { ... No descriptor, ... }
>                             (lgt_typ^.typ_size = lgt_nxt^.lgt_typ^.typ_size) and  { .. exactly the same size ... }
>                             COMP_TYPE( lgt_nxt^.lgt_typ, gen_p2, false );         { ... and compatible type with the model. }
>                  end;
2580a2625
> *)
2585a2631
> 
2601c2647
<              end;
---
>              end
