PreviousUpNext

15.4.518  src/lib/compiler/back/top/translate/translate-deep-syntax-pattern-to-lambdacode-junk.pkg

## translate-deep-syntax-pattern-to-lambdacode-junk.pkg 

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



###           "Never take anything on authority."
###
###                           -- Guy L. Steele Jr



#  TODO: this module requires a api !         XXX BUGGO FIXME

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 ty  =  types;                                       # types                         is from   src/lib/compiler/front/typer-stuff/types/types.pkg
    package vac =  variables_and_constructors;                  # variables_and_constructors    is from   src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg
herein

    package translate_deep_syntax_pattern_to_lambdacode_junk {
        #

        Simp 
          = VARSIMP     vac::Variable 
          | RECORDSIMP  List( (ty::Label, Simp) )
          ;

        Dconinfo = (ty::Valcon, List( ty::Type ));

        Path_Constant 
          = DATAPCON    Dconinfo
          | INTPCON     Int
          | INT1PCON   one_word_int::Int
          | INTEGERPCON  multiword_int::Int
          | UNTPCON     Unt
          | UNT1PCON   one_word_unt::Unt
          | REALPCON    String
          | STRINGPCON  String
          | VLENPCON   (Int, ty::Type)
          ; 

        Path
          = RECORD_PATH  List( Path )
          | PI_PATH     (Int, Path)
          | VPI_PATH    (Int,  ty::Type, Path)
          | VLEN_PATH   (Path, ty::Type)
          | DELTA_PATH  (Path_Constant, Path)
          | ROOT_PATH
          ;

        Dectree
          = CASETEST  (Path,
                      varhome::Valcon_Signature,
                      List  ((Path_Constant, Dectree)),
                      Null_Or( Dectree ))
          | ABSTEST0  (Path, Dconinfo, Dectree, Dectree)
          | ABSTEST1  (Path, Dconinfo, Dectree, Dectree)
          | RHS  Int                                            # "RHS" == "Right Hand Side"
          | BIND  (Path, Dectree);

        fun bug s
            =
            err::impossible ("translate_deep_syntax_pattern_to_lambdacode_junk: " + s);

        fun make_recordpat (ds::RECORD_PATTERN { fields, is_incomplete=>FALSE, type_ref, ... } ) pats
                =>
                ds::RECORD_PATTERN
                  {
                    fields => paired_lists::map
                                  (fn((id, _), p) = (id, p))
                                  (fields, pats),

                    is_incomplete => FALSE,

                    type_ref
                  };

            make_recordpat (ds::RECORD_PATTERN { is_incomplete => TRUE, ... } ) _
                   =>
                   bug "incomplete record passed to mkRECORDpat";

            make_recordpat _ _
                 =>
                 bug "non record passed to mkRECORDpat";
        end;

        fun con_eq ( ty::VALCON { form=>a1, ... },
                     ty::VALCON { form=>a2, ... }
                   )
            =
            a1 == a2;

        fun con_eq' ( ( ty::VALCON { form=>a1, ... }, _),
                      ( ty::VALCON { form=>a2, ... }, _)
                    )
            =
            a1 == a2;

        /*
        fun constant_eq (INTcon n, INTcon n') = n == n'
          | constant_eq (WORDcon n, WORDcon n') = n == n'
          | constant_eq (INT1con n, INT1con n') = n == n'
          | constant_eq (WORD32con n, WORD32con n') = n == n'
          | constant_eq (REALcon r, REALcon r') = r == r'
          | constant_eq (STRINGcon s, STRINGcon s') = s == s'
          | constant_eq (VLENcon n, VLENcon n') = n == n'
          | constant_eq (Valcon(_, krep, _), Valcon(_, krep', _)) = krep == krep'
          | constant_eq _ = FALSE
        */

        fun constant_eq (DATAPCON (d1, _), DATAPCON (d2, _)) => con_eq (d1, d2);
            constant_eq (INTPCON    n,     INTPCON    n')    =>   n == n';
            constant_eq (INT1PCON  n,     INT1PCON  n')    =>   n == n';
            constant_eq (INTEGERPCON n,     INTEGERPCON n')    =>   n == n';
            constant_eq (UNTPCON    n,     UNTPCON    n')    =>   n == n';
            constant_eq (UNT1PCON  n,     UNT1PCON  n')    =>   n == n';
            constant_eq (REALPCON   r,     REALPCON   r')    =>   r == r';
            constant_eq (STRINGPCON s,     STRINGPCON s')    =>   s == s';
            constant_eq (VLENPCON (n, _),  VLENPCON (n', _)) =>   n == n';
            constant_eq _ => FALSE;
        end;


        fun path_eq (RECORD_PATH (a ! ar), RECORD_PATH (b ! br))
                => 
                path_eq (a, b) and path_eq (RECORD_PATH ar, RECORD_PATH br);

            path_eq (RECORD_PATH NIL, RECORD_PATH NIL) => TRUE;
            path_eq (PI_PATH (i1, p1), PI_PATH (i2, p2))       =>   i1 == i2 and path_eq (p1, p2);
            path_eq (VPI_PATH (i1, _, p1), VPI_PATH (i2, _, p2)) =>   i1 == i2 and path_eq (p1, p2);
            path_eq (VLEN_PATH (p1, _), VLEN_PATH (p2, _)) => path_eq (p1, p2);
            path_eq (DELTA_PATH (c1, p1), DELTA_PATH (c2, p2)) => 
                                constant_eq (c1, c2) and path_eq (p1, p2);
            path_eq (ROOT_PATH, ROOT_PATH) => TRUE;
            path_eq _ => FALSE;
        end;

        fun get_path (a, (b, c) ! d)
                => 
               if (path_eq (a, b))    c;
               else                   get_path (a, d);
               fi; 

            get_path _ => bug "unexpected args in get_path";
        end;

        fun abstract x      = FALSE;
        fun template x      = FALSE;
        fun is_an_exception x = FALSE;

        fun signature_of_constructor (ty::VALCON { signature, ... } )
            =
            signature;

        fun unary (ty::VALCON { is_constant, ... }, _)
            =
            is_constant;                                                        # Constructor takes no arguments, e.g. TRUE, FALSE, NULL ...

    };          #  package translate_deep_syntax_pattern_to_lambdacode_junk 
end;




Comments and suggestions to: bugs@mythryl.org

PreviousUpNext