PreviousUpNext

15.4.516  src/lib/compiler/back/top/translate/template-expansion.pkg

## template-expansion.pkg 

# Compiled by:
#     src/lib/compiler/core.sublib



#DO set_control "compiler::trap_int_overflow" "TRUE";

stipulate
    package ds  =  deep_syntax;                         # deep_syntax                   is from   src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg
    package err =  error_message;                       # error_message                 is from   src/lib/compiler/front/basics/errormsg/error-message.pkg
    package tdt =  type_declaration_types;              # type_declaration_types        is from   src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
    package mtt =  more_type_types;                     # more_type_types               is from   src/lib/compiler/front/typer/types/more-type-types.pkg
    package vac =  variables_and_constructors;          # variables_and_constructors    is from   src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg
    package vh  =  varhome;                             # varhome                       is from   src/lib/compiler/front/typer-stuff/basics/varhome.pkg
    package tj  =  type_junk;                           # type_junk                     is from   src/lib/compiler/front/typer-stuff/types/type-junk.pkg
    #
    include package   translate_deep_syntax_pattern_to_lambdacode_junk;
#    include package   more_type_types;
    #
herein 

    package template_expansion {
        #
        exception LOOKUP;

        fun lookup
                ( a as vac::PLAIN_VARIABLE { varhome=>vh::HIGHCODE_VARIABLE a', ... }, 
                      (vac::PLAIN_VARIABLE { varhome=>vh::HIGHCODE_VARIABLE b, ... }, c) ! d
                )
                => 
                a' == b   ??   c
                          ::   lookup (a, d);

            lookup (vac::PLAIN_VARIABLE _, (vac::PLAIN_VARIABLE _, _) ! _)
                =>
                err::impossible "833 in tempexpn";

            lookup _
                =>
                raise exception LOOKUP;
        end;

        issue_highcode_codetemp
            =
            highcode_codetemp::issue_highcode_codetemp;

        exception CANNOT_MATCH;

        fun foo x =  err::impossible "no templates yet";
        /*
                (case lookup (x, *constructor_env)
                  of { representation = TEMPLrep (NO_PATTERN, _, _), ... } => raise exception CANNOT_MATCH 
                   | { representation = TEMPLrep x, ... } => x 
                   | _ => raise exception Internal 1)
                except Lookup => raise exception (Internal 2) 
        */

        fun foo' x =  err::impossible "no symbolic constants yet";
        /*
                (case lookup (x, *constructor_env)
                  of { representation = CONSTrep (NO_PATTERN, _), ... } => raise exception CANNOT_MATCH 
                   | { representation = CONSTrep x, ... } => x 
                   | _ => raise exception Internal 3)
                except Lookup => raise exception (Internal 4)
        */

        fun and_patterns (ds::WILDCARD_PATTERN, pattern) => pattern;
            and_patterns (pattern, ds::WILDCARD_PATTERN) => pattern;

            and_patterns (ds::TYPE_CONSTRAINT_PATTERN (pattern, _), pattern') => and_patterns (pattern, pattern');
            and_patterns (pattern, ds::TYPE_CONSTRAINT_PATTERN (pattern', _)) => and_patterns (pattern, pattern');

            and_patterns (ds::VARIABLE_IN_PATTERN v, pattern) => ds::AS_PATTERN (ds::VARIABLE_IN_PATTERN v, pattern);
            and_patterns (pattern, ds::VARIABLE_IN_PATTERN v) => ds::AS_PATTERN (ds::VARIABLE_IN_PATTERN v, pattern);

            and_patterns (ds::CONSTRUCTOR_PATTERN (k, t), ds::CONSTRUCTOR_PATTERN (k', t'))
                => 
                if   (con_eq (k, k'))   ds::CONSTRUCTOR_PATTERN (k, t);
                elif (abstract k )      ds::AS_PATTERN (ds::CONSTRUCTOR_PATTERN (k, t),   ds::CONSTRUCTOR_PATTERN (k', t'));
                elif (abstract k' )     ds::AS_PATTERN (ds::CONSTRUCTOR_PATTERN (k', t'), ds::CONSTRUCTOR_PATTERN (k, t));
                else                    raise exception CANNOT_MATCH;
                fi;

            and_patterns (ds::CONSTRUCTOR_PATTERN (k, t), ds::APPLY_PATTERN (k', t', pattern))
                =>
                if   (abstract k )   ds::AS_PATTERN (ds::CONSTRUCTOR_PATTERN (k, t), ds::APPLY_PATTERN (k', t', pattern));
                elif (abstract k')   ds::AS_PATTERN (ds::APPLY_PATTERN (k', t', pattern), ds::CONSTRUCTOR_PATTERN (k, t));
                else                 raise exception CANNOT_MATCH;
                fi;

            and_patterns (ds::APPLY_PATTERN (k', t', pattern), ds::CONSTRUCTOR_PATTERN (k, t))
                =>
                if   (abstract k )   ds::AS_PATTERN (ds::CONSTRUCTOR_PATTERN (k, t), ds::APPLY_PATTERN (k', t', pattern));
                elif (abstract k')   ds::AS_PATTERN (ds::APPLY_PATTERN (k', t', pattern), ds::CONSTRUCTOR_PATTERN (k, t));
                else                 raise exception CANNOT_MATCH;
                fi;

            and_patterns (ds::APPLY_PATTERN (k, t, pattern), ds::APPLY_PATTERN (k', t', pattern'))
                =>
                if   (con_eq (k, k'))

                     ds::APPLY_PATTERN (k, t, and_patterns (pattern, pattern'));

                elif (abstract k)

                     ds::AS_PATTERN (ds::APPLY_PATTERN (k, t, pattern), ds::APPLY_PATTERN (k', t', pattern'));

                elif (abstract k')

                     ds::AS_PATTERN (ds::APPLY_PATTERN (k', t', pattern'), ds::APPLY_PATTERN (k, t, pattern));
                else
                     raise exception CANNOT_MATCH;
                fi;

            and_patterns (ds::CONSTRUCTOR_PATTERN (k, t), pattern)
               =>
               if   (abstract k)
                    ds::AS_PATTERN (ds::CONSTRUCTOR_PATTERN (k, t), pattern);
               else
                    err::impossible "Non abstract ds::CONSTRUCTOR_PATTERN & non constructor pattern in andPattern";
               fi;

            and_patterns (pattern, ds::CONSTRUCTOR_PATTERN (k, t))
               =>
               if   (abstract k)
                    ds::AS_PATTERN (ds::CONSTRUCTOR_PATTERN (k, t), pattern);
               else
                    err::impossible "non constructor pattern & Non abstract ds::CONSTRUCTOR_PATTERN in andPattern";
               fi;

            and_patterns (ds::APPLY_PATTERN (k, t, pattern), pattern')
               =>
               if   (abstract k)
                    ds::AS_PATTERN (ds::APPLY_PATTERN (k, t, pattern), pattern');
               else
                    err::impossible "Non abstract ds::APPLY_PATTERN & non constructor pattern in andPattern";
               fi;

            and_patterns (pattern, ds::APPLY_PATTERN (k, t, pattern'))
               => 
               if   (abstract k)

                    ds::AS_PATTERN (ds::APPLY_PATTERN (k, t, pattern'), pattern);
               else
                    err::impossible "non constructor pattern & Non abstract ds::APPLY_PATTERN in andPattern";
               fi;


            and_patterns (ds::AS_PATTERN (ds::TYPE_CONSTRAINT_PATTERN (pattern1, _), pattern2), pattern)
               =>
               and_patterns (ds::AS_PATTERN (pattern1, pattern2), pattern); 


            and_patterns (pattern, ds::AS_PATTERN (ds::TYPE_CONSTRAINT_PATTERN (pattern1, _), pattern2))
               =>
               and_patterns (pattern, ds::AS_PATTERN (pattern1, pattern2)); 


            and_patterns (ds::AS_PATTERN (pattern1, pattern2), pattern)
               =>
               ds::AS_PATTERN (pattern1, and_patterns (pattern2, pattern));


            and_patterns (pattern, ds::AS_PATTERN (pattern1, pattern2))
               =>
               ds::AS_PATTERN (pattern1, and_patterns (pattern2, pattern));


            and_patterns (ds::INT_CONSTANT_IN_PATTERN (p as (s, t)), ds::INT_CONSTANT_IN_PATTERN (s', t'))
                =>
                if (tj::typoids_are_equal (t, mtt::int_typoid) )
                         if ((literal_to_num::int s) == (literal_to_num::int s'))
                                ds::INT_CONSTANT_IN_PATTERN p;
                           else raise exception CANNOT_MATCH;fi;
                elif (tj::typoids_are_equal (t, mtt::int1_typoid) )

                         if (literal_to_num::one_word_int s  ==  literal_to_num::one_word_int s')
                                ds::INT_CONSTANT_IN_PATTERN p;
                         else
                              raise exception CANNOT_MATCH;
                         fi;
                else
                     err::impossible "and_patterns/ds::INT_CONSTANT_IN_PATTERN in tempexpn";
                fi
                except
                    OVERFLOW = err::impossible "overflow during int or word pattern comparisons";

            and_patterns (ds::UNT_CONSTANT_IN_PATTERN (p as (w, t)), ds::UNT_CONSTANT_IN_PATTERN (w', t'))
                =>
                if (tj::typoids_are_equal (t, mtt::unt_typoid) )

                    if  (literal_to_num::unt w   !=  literal_to_num::unt w')   raise exception CANNOT_MATCH;   fi;

                    ds::UNT_CONSTANT_IN_PATTERN p;

                elif (tj::typoids_are_equal (t, mtt::unt8_typoid) )

                    if (literal_to_num::one_byte_unt w  !=  literal_to_num::one_byte_unt w')   raise exception CANNOT_MATCH;   fi;

                    ds::UNT_CONSTANT_IN_PATTERN p;

                elif (tj::typoids_are_equal (t, mtt::unt1_typoid) )

                    if (literal_to_num::one_word_unt w  !=  literal_to_num::one_word_unt w')   raise exception CANNOT_MATCH;   fi;

                    ds::UNT_CONSTANT_IN_PATTERN  p;

                else
                     err::impossible "and_patterns/ds::UNT_CONSTANT_IN_PATTERN in tempexpn";
                fi
                except
                    OVERFLOW = err::impossible "overflow during int or word pattern comparisons";

            and_patterns (ds::FLOAT_CONSTANT_IN_PATTERN r, ds::FLOAT_CONSTANT_IN_PATTERN r')
                => 
                if (r == r')   ds::FLOAT_CONSTANT_IN_PATTERN r;
                else           raise exception CANNOT_MATCH;
                fi;

            and_patterns (ds::STRING_CONSTANT_IN_PATTERN s, ds::STRING_CONSTANT_IN_PATTERN s')
                =>
                if (s == s')   ds::STRING_CONSTANT_IN_PATTERN s;
                else           raise exception CANNOT_MATCH;
                fi;

            and_patterns (ds::CHAR_CONSTANT_IN_PATTERN s, ds::CHAR_CONSTANT_IN_PATTERN s')
                =>
                if (s == s')   ds::CHAR_CONSTANT_IN_PATTERN s;
                else           raise exception CANNOT_MATCH;
                fi;

            and_patterns (pattern1 as ds::RECORD_PATTERN { fields=>p, ... }, 
                         pattern2 as ds::RECORD_PATTERN { fields=>q, ... } )
               =>
               make_recordpat pattern1 (multi_and (map #2 p, map #2 q));

         # ****************** how to and two types ? *************************
            and_patterns (ds::VECTOR_PATTERN (p, t), ds::VECTOR_PATTERN (p', t'))
                =>
                if  (length p == length p')
                     ds::VECTOR_PATTERN (multi_and (p, p'), t); 
                else
                     raise exception CANNOT_MATCH;
                fi;

            and_patterns (p1, p2)
                => 
                err::impossible "bas andPattern call";
        end 

        also
        fun multi_and (NIL, NIL)
                =>
                NIL;

            multi_and (pattern ! rest, pattern' ! rest')
                => 
                (and_patterns (pattern, pattern')) ! (multi_and (rest, rest'));

            multi_and _
                =>
                err::impossible "bad multi_and call";
        end;

        fun macro_expand_patexp (ds::VARIABLE_IN_PATTERN v, dictionary)
                =>
                lookup (v, dictionary);

            macro_expand_patexp (ds::AS_PATTERN (pattern1, pattern2), dictionary)
                =>
                and_patterns (macro_expand_patexp (pattern1, dictionary), macro_expand_patexp (pattern2, dictionary));

            macro_expand_patexp (ds::TYPE_CONSTRAINT_PATTERN (pattern, _), dictionary)
                =>
                macro_expand_patexp (pattern, dictionary);

            macro_expand_patexp (ds::APPLY_PATTERN (k, t, pattern), dictionary)
                => 
                ds::APPLY_PATTERN (k, t, macro_expand_patexp (pattern, dictionary));

            macro_expand_patexp (pattern as ds::RECORD_PATTERN { fields, ... }, dictionary)
                =>
                make_recordpat pattern (multi_macro_expand_patexp (map #2 fields, dictionary));

            macro_expand_patexp (ds::VECTOR_PATTERN (pats, t), dictionary)
                =>
                ds::VECTOR_PATTERN (multi_macro_expand_patexp (pats, dictionary), t);

            macro_expand_patexp (pattern, dictionary)
                =>
                pattern;
        end 

        also
        fun multi_macro_expand_patexp (NIL, dictionary)
                =>
                NIL;

            multi_macro_expand_patexp (pattern ! rest, dictionary)
                => 
                macro_expand_patexp    (pattern, dictionary)
                !
                multi_macro_expand_patexp (rest, dictionary);

        end;

        fun instance (ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { path, vartypoid_ref, inlining_data, ... } ))
                =>
                VARSIMP (vac::PLAIN_VARIABLE { varhome=>vh::HIGHCODE_VARIABLE (issue_highcode_codetemp()), path, vartypoid_ref, inlining_data } );

            instance (ds::VARIABLE_IN_PATTERN _)
                =>
                err::impossible "bad variable in match";

            instance (ds::RECORD_PATTERN { fields, ... } )
                => 
                RECORDSIMP (map (\\ (lab, pattern)=>(lab, instance pattern); end ) fields);
        
            instance (ds::TYPE_CONSTRAINT_PATTERN (pattern, _))
                =>
                instance pattern;

            instance pattern
                =>
                err::impossible "bad instance call";
        end;

        fun simp_to_pattern (VARSIMP v)
                =>
                ds::VARIABLE_IN_PATTERN v;

            simp_to_pattern (RECORDSIMP labsimps)
                => 
                ds::RECORD_PATTERN {
                    fields => map   (\\ (lab, simp)= (lab, simp_to_pattern simp))   labsimps,
                    is_incomplete => FALSE,
                    type_ref => REF tdt::UNDEFINED_TYPOID
                };
        end;

        fun trivpat_triv_dictionary (ds::VARIABLE_IN_PATTERN v, VARSIMP x)
                =>
                [(v, ds::VARIABLE_IN_PATTERN x)];

            trivpat_triv_dictionary (ds::TYPE_CONSTRAINT_PATTERN (tpat, _), simp)
                => 
                trivpat_triv_dictionary (tpat, simp);

            trivpat_triv_dictionary (ds::RECORD_PATTERN { fields, ... }, RECORDSIMP labsimps)
                =>
                multi_trivpat_triv_dictionary (map #2 fields, map #2 labsimps);

            trivpat_triv_dictionary _
                =>
                err::impossible "trivpat_triv_dictionary";
        end 

        also
        fun multi_trivpat_triv_dictionary (NIL, NIL)
                =>
                NIL;

            multi_trivpat_triv_dictionary (tpat ! trest, simp ! srest)
                =>
                (trivpat_triv_dictionary (tpat, simp))@(multi_trivpat_triv_dictionary (trest, srest));

            multi_trivpat_triv_dictionary _
                =>
                err::impossible "multiTrivpatTrivDict";
        end;

        fun wild_dictionary (ds::VARIABLE_IN_PATTERN v)             => [(v, ds::WILDCARD_PATTERN)];
            wild_dictionary (ds::TYPE_CONSTRAINT_PATTERN (tpat, _)) => wild_dictionary tpat;
            wild_dictionary (ds::RECORD_PATTERN { fields, ... } )     => list::cat (map (wild_dictionary o #2) fields);

            wild_dictionary _                                   => err::impossible "wild_dictionary called on non-trivpat";
        end;

        fun match_trivial_pattern (ds::VARIABLE_IN_PATTERN v, pattern)
                =>
                ([(v, pattern)], NIL, NIL);

            match_trivial_pattern (ds::TYPE_CONSTRAINT_PATTERN (tpat, _), pattern)
                =>
                match_trivial_pattern (tpat, pattern);

            match_trivial_pattern (tpat, ds::TYPE_CONSTRAINT_PATTERN (pattern, _))
                =>
                match_trivial_pattern (tpat, pattern);

            match_trivial_pattern (ds::RECORD_PATTERN { fields=>tps, ... }, ds::RECORD_PATTERN { fields=>ps, ... } )
                =>
                multi_match_trivpat (map #2 tps, map #2 ps);

            match_trivial_pattern (tpat, ds::WILDCARD_PATTERN)
                => 
                (wild_dictionary tpat, NIL, NIL);

            match_trivial_pattern (tpat, ds::VARIABLE_IN_PATTERN v)
                =>
                {   a =   instance tpat;
                    b =   trivpat_triv_dictionary (tpat, a);

                    (b, [(v, a)], NIL);
                };

            match_trivial_pattern (tpat, ds::CONSTRUCTOR_PATTERN (k, t))
                =>
                {   a =   instance tpat;
                    b =   trivpat_triv_dictionary (tpat, a);

                    (b, NIL, [(a, ds::CONSTRUCTOR_PATTERN (k, t))]);
                };

            match_trivial_pattern (tpat, ds::APPLY_PATTERN (k, t, pattern))
                =>
                {   a = instance tpat;
                    b = trivpat_triv_dictionary (tpat, a);

                    (b, NIL, [(a, ds::APPLY_PATTERN (k, t, pattern))]);
                };

            match_trivial_pattern (tpat, ds::AS_PATTERN (ds::CONSTRUCTOR_PATTERN (k, t), pattern))
                =>
                {   a = instance tpat;

                    my  (pattern', var_dictionary, constr)
                        = 
                        match_trivial_pattern (tpat, and_patterns (simp_to_pattern a, pattern));

                    (pattern', var_dictionary, (a, ds::CONSTRUCTOR_PATTERN (k, t)) ! constr);
                };

            match_trivial_pattern (tpat, ds::AS_PATTERN (ds::APPLY_PATTERN (k, t, spat), pattern))
                =>
                {   a = instance tpat;

                    my  (pattern', var_dictionary, constr)
                        = 
                        match_trivial_pattern (tpat, and_patterns (simp_to_pattern a, pattern));

                    (pattern', var_dictionary, (a, ds::APPLY_PATTERN (k, t, spat)) ! constr);
                };

            match_trivial_pattern (tpat, ds::AS_PATTERN (ds::VARIABLE_IN_PATTERN v, pattern))
                =>
                {   a = instance tpat;

                    my  (pattern', var_dictionary, constr)
                        = 
                        match_trivial_pattern (tpat, and_patterns (simp_to_pattern a, pattern));

                    (pattern', (v, a) ! var_dictionary, constr);
                };

            match_trivial_pattern (tpat, ds::AS_PATTERN (ds::TYPE_CONSTRAINT_PATTERN (pattern1, _), pattern2))
               =>
               match_trivial_pattern (tpat, ds::AS_PATTERN (pattern1, pattern2));

            match_trivial_pattern (tpat, pattern)
                =>
                err::impossible "bad match_trivial_pattern call";
       end 

       also
       fun multi_match_trivpat (NIL, NIL)
               =>
               (NIL, NIL, NIL);

           multi_match_trivpat (tpat ! trest, pattern ! prest)
                =>
                {   my (patenv,  varenv,  constr ) =   multi_match_trivpat (trest, prest);
                    my (patenv', varenv', constr') =   match_trivial_pattern (tpat, pattern);

                    (patenv@patenv', varenv@varenv', constr@constr');
                };

            multi_match_trivpat _
                =>
                err::impossible "bad multi_match_trivpat call";
       end;

        fun new_vars (RECORDSIMP labsimps, dictionary)
                => 
                multi_new_vars (map #2 labsimps, dictionary);

            new_vars (VARSIMP (v as vac::PLAIN_VARIABLE { path, vartypoid_ref, inlining_data, ... } ), dictionary)
                =>
                {   lookup (v, dictionary);
                    dictionary;
                }
                except
                    lookup
                        =
                        (   v,

                            vac::PLAIN_VARIABLE {
                                path,
                                vartypoid_ref,
                                varhome  => vh::HIGHCODE_VARIABLE (issue_highcode_codetemp()),
                                inlining_data
                            }
                        )
                        !
                        dictionary;



            new_vars (VARSIMP _, _)
                =>
                err::impossible "bad instance call to newVars";
       end 

       also
       fun multi_new_vars (NIL, dictionary)
                =>
                dictionary;

            multi_new_vars (simp ! rest, dictionary)
                =>
                multi_new_vars (rest, new_vars (simp, dictionary));
        end;

        fun macro_expand_local_vars (NIL, dictionary)
                =>
                dictionary;

            macro_expand_local_vars ((path, pattern) ! rest, dictionary)
                =>
                macro_expand_local_vars (rest, new_vars (path, dictionary));
        end;

        fun inst_simpexp (VARSIMP v, dictionary)
                =>
                VARSIMP (lookup (v, dictionary));

            inst_simpexp (RECORDSIMP labsimps, dictionary)
                => 
                RECORDSIMP (multi_inst_simpexp (labsimps, dictionary));
       end 

       also
       fun multi_inst_simpexp (NIL, dictionary)
                =>
                NIL;

            multi_inst_simpexp((lab, simpexp) ! rest, dictionary)
                => 
                (   lab,
                    inst_simpexp (simpexp, dictionary)
                )
                !
                (multi_inst_simpexp (rest, dictionary));
        end;

        fun macro_expand_constrs (NIL, loc_dictionary, dictionary)
                =>
                NIL;

            macro_expand_constrs((simpexp, pattern) ! rest, loc_dictionary, dictionary)
                => 
                (inst_simpexp (simpexp, loc_dictionary), macro_expand_patexp (pattern, dictionary))
                !
                (macro_expand_constrs (rest, loc_dictionary, dictionary));
        end;    

        fun liftenv NIL
                =>
                NIL;

            liftenv ((v, x) ! rest)
                =>
                (   v,
                    ds::VARIABLE_IN_PATTERN x
                )
                !
                (liftenv rest);
        end;

        fun templ_expand (k, pattern)
            =
            {   my  (patexp, trivpat, constrs)
                    =
                    foo k;

                my  (dictionary, varnames, newconstrs)
                    =
                    match_trivial_pattern (trivpat, pattern);

                dictionary' =   macro_expand_local_vars (constrs, NIL);

                new_dictionary =   dictionary @ (liftenv dictionary');

                (   macro_expand_patexp (patexp, new_dictionary),
                    newconstrs @ (macro_expand_constrs (constrs, dictionary', new_dictionary)),
                    varnames
                );
            };

        fun const_expand k
            =
            {   my  (patexp, constrs)
                    =
                    foo' k;

                new_dictionary
                    =
                    macro_expand_local_vars (constrs, NIL);

                l_new_dictionary
                    =
                    liftenv new_dictionary;

                ( macro_expand_patexp (patexp, l_new_dictionary),
                  macro_expand_constrs (constrs, new_dictionary, l_new_dictionary),
                  NIL
                );
            };

        fun multi_template_expand NIL
                =>
                (NIL, NIL, NIL);

            multi_template_expand (pattern ! rest)
                =>
                {   my (pats', constr1, varenv1)
                       =
                       multi_template_expand rest;

                    my (pattern', constr2, varenv2)
                       =
                       template_expand_pattern pattern;

                    ( pattern' ! pats',
                      constr1 @ constr2,
                      varenv1 @ varenv2
                    );
                };
        end 

        also
        fun template_expand_pattern (ds::APPLY_PATTERN (k, t, pattern))
                =>
                {   my (pattern', pat_constraints, pat_varenv)
                        =
                        template_expand_pattern  pattern;

                    if (template k)

                        my (new_pattern, k_constraints, k_varenv)
                            =
                            templ_expand (k, pattern');

                        (new_pattern, pat_constraints@k_constraints, pat_varenv@k_varenv);

                    else

                        (ds::APPLY_PATTERN (k, t, pattern'), pat_constraints, pat_varenv);
                    fi;
                };

            template_expand_pattern (ds::CONSTRUCTOR_PATTERN (k, t))
                =>
                if (template k)

                    my (new_pattern, constraints, varenv)
                        =
                        const_expand k;
                
                    (new_pattern, constraints, varenv);
                else
                    (ds::CONSTRUCTOR_PATTERN (k, t), NIL, NIL);
                fi;

            template_expand_pattern (pattern as ds::RECORD_PATTERN { fields, ... } )
                =>
                {   my (pats', constr, varenv)
                        =
                        multi_template_expand (map #2 fields);

                    ( make_recordpat pattern pats',
                      constr,
                      varenv
                    );
                };

            template_expand_pattern (ds::VECTOR_PATTERN (pats, t))
                =>
                {   my (pats', constr, varenv)
                        =
                        multi_template_expand  pats;

                    ( ds::VECTOR_PATTERN (pats, t),
                      constr,
                      varenv
                    );
                };

            template_expand_pattern (ds::AS_PATTERN (pattern1, pattern2))
                =>
                {   my (pattern1', constr1, varenv1) = template_expand_pattern pattern1;
                    my (pattern2', constr2, varenv2) = template_expand_pattern pattern2;

                    (ds::AS_PATTERN (pattern1', pattern2'), constr1@constr2, varenv1@varenv2);
                };

            template_expand_pattern (ds::TYPE_CONSTRAINT_PATTERN (pattern, _))
                =>
                template_expand_pattern pattern;

            template_expand_pattern pattern
                =>
                (pattern, NIL, NIL);
        end;

        fun fully_expand_naming varenv (VARSIMP v)
                =>
                fully_expand_naming varenv (lookup (v, varenv))
                except
                    lookup = VARSIMP v;

            fully_expand_naming varenv (RECORDSIMP labsimps)
                =>
                RECORDSIMP 
                    (map (\\ (lab, simp)=>(lab, fully_expand_naming varenv simp); end ) labsimps);
        end;

        fun fully_expand_naming_trivpat varenv (ds::VARIABLE_IN_PATTERN v)
                =>
                fully_expand_naming_trivpat varenv (simp_to_pattern (lookup (v, varenv)))
                except
                    lookup = ds::VARIABLE_IN_PATTERN v;

            fully_expand_naming_trivpat varenv (pattern as ds::RECORD_PATTERN { fields, ... } )
                =>
                make_recordpat pattern (map (fully_expand_naming_trivpat varenv o #2) fields);

            fully_expand_naming_trivpat varenv (ds::TYPE_CONSTRAINT_PATTERN (pattern, _))
                =>
                fully_expand_naming_trivpat varenv pattern;

            fully_expand_naming_trivpat _ _ 
                => 
                err::impossible "fully_expand_naming_trivpat miscalled";
        end;


    };                                  # package template_expansion 
end;                                    # toplevel stipulate 


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext