15.4.630  src/lib/compiler/front/typer/basics/pick-valcon-form.pkg

## pick-valcon-form.pkg 

# Compiled by:
#     src/lib/compiler/front/typer/typer.sublib

stipulate
    package tdt =  type_declaration_types;                      # type_declaration_types        is from   src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
herein 
    api Pick_Valcon_Form {
        #
         infer:  Bool                                              #  "isRecursive" 
                 -> List( (symbol::Symbol, Bool, tdt::Typoid) )
                 -> (List(varhome::Valcon_Form), varhome::Valcon_Signature);

    };
end;

stipulate
    package tj  =  type_junk;                                   # type_junk                     is from   src/lib/compiler/front/typer-stuff/types/type-junk.pkg
    include package   varhome;
    include package   type_declaration_types;                           # type_declaration_types        is from   src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
herein 

    package   pick_valcon_form
    : (weak)  Pick_Valcon_Form                                  # Pick_Valcon_Form              is from   src/lib/compiler/front/typer/basics/pick-valcon-form.pkg
    {
        fun err s
            =
            error_message::impossible ("Conrep: " + s);

        fun count predicate l
            =
            {   fun test (a ! rest, acc)   =>   test (rest, if (predicate a ) 1+acc; else acc;fi);
                   test (NIL,    acc)   =>   acc; end;

                test (l, 0);
            };

        fun reduce type
            =
            case (tj::head_reduce_typoid  type)
                #
                TYPESCHEME_TYPOID { typescheme => TYPESCHEME { body, ... }, ... }
                    =>
                    reduce body;
                #
                other => other;
            esac;

        fun notconst (_, TRUE, _) => FALSE;
        /*
          | notconst(_, _, TYPCON_TYPOID(_,[t, _])) = 
              (case (reduce t) 
                of TYPCON_TYPOID (RECORD_TYPE NIL, _) => FALSE
                 | _ => TRUE)
        */
           notconst _ => TRUE;
        end;

        # fun show ((symbol, _, _) ! syms, r ! rs) = 
        #      (print (symbol::name symbol); print ":   "; 
        #      PPBasics::prettyprintSumtypeConstructorRepresentation r; print "\n"; show (syms, rs))
        #   | show _ = (print "\n")


        #  The first argument indicates whether 
        #  this is a recursive sumtype:        

        fun infer FALSE ([(_, FALSE, TYPCON_TYPOID(_,[type, _]))])
                => 
                case (reduce type) 
                     # The TRANSPARENT Valcon_Form is temporarily turned off;
                     # it should be working very soon. Ask zsh. XXX BUGGO FIXME
                     #
#                (TYPCON_TYPOID (RECORD_TYPE NIL, _)) => ([CONSTANT 0], CSIG (0, 1))
                     _ => ([UNTAGGED], CONSTRUCTOR_SIGNATURE (1, 0));
                esac;

            infer _ cons
                =>
                decide (0, 0, cons, [])
                where

                    multiple = (count notconst cons) > 1;

                    fun decide (ctag, vtag, (_, TRUE, _) ! rest, reps)
                            => 
                            if ( multiple
                                 and
                                 *typer_control::boxedconstconreps
                            )
                                 decide (ctag,   vtag+1, rest, (TAGGED   vtag) ! reps);
                            else decide (ctag+1, vtag,   rest, (CONSTANT ctag) ! reps);
                            fi;

                        decide (ctag, vtag, (_, FALSE, TYPCON_TYPOID(_,[type, _])) ! rest, reps)
                            =>
                            case (reduce type, multiple)

                                 #  XXX BUGGO FIXME 
                                 #
#                                (TYPCON_TYPOID (RECORD_TYPE NIL, _), _)
#                                    => 
#                                    decide (ctag+1, vtag, rest, (CONSTANT ctag) ! reps)

                                (_, TRUE)  => decide (ctag, vtag+1, rest, (TAGGED vtag) ! reps);
                                (_, FALSE) => decide (ctag, vtag+1, rest, (UNTAGGED     ! reps));
                            esac;


                       decide (_, _, _ ! _, _) => err "unexpected Valcon_Form-decide";
                       decide (ctag, vtag, [], reps) => (reverse reps, CONSTRUCTOR_SIGNATURE (vtag, ctag));
                    end;
                end;
        end;

        # ** infer = \\ l => let l' = infer l in show (l, l'); l' end **
    };                                                                  # package pick_valcon_form
end;                                                                    # stipulate