PreviousUpNext

15.4.505  src/lib/compiler/back/top/lambdacode/prettyprint-lambdacode-expression.pkg

## prettyprint-lambdacode-expression.pkg 

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



#              "We do not stop playing because we grow old.
#               We grow old because we stop playing."



stipulate
    package ds  =  deep_syntax;                 # deep_syntax           is from   src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg
    package tmp =  highcode_codetemp;           # highcode_codetemp     is from   src/lib/compiler/back/top/highcode/highcode-codetemp.pkg
    package lcf =  lambdacode_form;             # lambdacode_form       is from   src/lib/compiler/back/top/lambdacode/lambdacode-form.pkg
    package syx =  symbolmapstack;              # symbolmapstack        is from   src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg
herein

    api Prettyprint_Lambdacode_Expression {
        #
         print_casetag:    lcf::Casetag -> Void;
         print_lexp:       lcf::Lambdacode_Expression -> Void;
         print_match:      syx::Symbolmapstack -> List( (ds::Case_Pattern, lcf::Lambdacode_Expression) ) -> Void;
         print_fun:        lcf::Lambdacode_Expression -> tmp::Codetemp -> Void;

         string_tag:  lcf::Lambdacode_Expression -> String;
    };
end;

stipulate
    package hbo =  highcode_baseops;            # highcode_baseops      is from   src/lib/compiler/back/top/highcode/highcode-baseops.pkg
    package hcf =  highcode_form;               # highcode_form         is from   src/lib/compiler/back/top/highcode/highcode-form.pkg
    package tmp =  highcode_codetemp;           # highcode_codetemp     is from   src/lib/compiler/back/top/highcode/highcode-codetemp.pkg
    package lcf =  lambdacode_form;             # lambdacode_form       is from   src/lib/compiler/back/top/lambdacode/lambdacode-form.pkg
    package pp  =  prettyprint;                 # prettyprint           is from   src/lib/prettyprint/big/src/prettyprint.pkg
    package pu  =  print_junk;                  # print_junk            is from   src/lib/compiler/front/basics/print/print-junk.pkg
    package sy  =  symbol;                      # symbol                is from   src/lib/compiler/front/basics/map/symbol.pkg
    package vh  =  varhome;                     # varhome               is from   src/lib/compiler/front/typer-stuff/basics/varhome.pkg
    #
    include print_junk; 
herein 

    package   prettyprint_lambdacode_expression
    : (weak)  Prettyprint_Lambdacode_Expression
    {
        #

        say =  global_controls::print::say;

        fun sayrep representation
            =
            say (vh::print_representation representation);

        name_of_highcode_codetemp =  tmp::name_of_highcode_codetemp;

        fun bug s
            =
            error_message::impossible ("MCprint: " + s);

        fun app2 (f, [], []) => ();
            app2 (f, a ! r, b ! z) => { f (a, b); app2 (f, r, z);};
            app2 (f, _, _) => bug "unexpected list arguments in function app2";
        end;

        margin = REF 0;

        fun indent i
            =
            margin := *margin + i;

        exception UNDENT;

        fun undent i
            = 
            {   margin := *margin - i;

                if (*margin < 0)   raise exception UNDENT;   fi;
            };

        fun dent ()
            =
            tab *margin;

        fun whitespace ()
            =
            cat (ws *margin)
            where
                fun ws (n)
                    =
                    if   (n < 0)
                         raise exception UNDENT;
                    else if   (n >= 8)
                              "\t" ! ws (n - 8);
                         else   str = case n    0 => "";       1 => " ";  2 => "  ";
                                                3 => "   ";    4 => "    "; 
                                                5 => "     ";  6 => "      "; 
                                                _ => "       ";
                                      esac;
                               [str];
                         fi;
                    fi;
            end;


        fun print_casetag x
            =
            say (print_casetag' x)
            where
                fun print_casetag' (lcf::VAL_CASETAG ((symbol, _, _), _, v)) => ((sy::name symbol) + " " + (name_of_highcode_codetemp v));
                    #
                    print_casetag' (lcf::INT_CASETAG     i) =>  int::to_string i;
                    print_casetag' (lcf::INT1_CASETAG   i) =>  "(I32)" + (one_word_int::to_string i);
                    print_casetag' (lcf::INTEGER_CASETAG i) =>  "II" + multiword_int::to_string i;
                    print_casetag' (lcf::UNT_CASETAG     i) =>  "(W)" + (unt::to_string i);
                    print_casetag' (lcf::UNT1_CASETAG   i) =>  "(W32)" + (one_word_unt::to_string i);
                    print_casetag' (lcf::FLOAT64_CASETAG r) =>  r;
                    print_casetag' (lcf::STRING_CASETAG  s) =>  pu::heap_string s;                      #  was pu::print_heap_string s 
                    print_casetag' (lcf::VLEN_CASETAG    n) =>  int::to_string n;
                end;
            end;

        # Use of complex in printLexp may
        # lead to stupid n^2 behavior:
        #
        fun complex le
            = 
            g le
            where
                fun h [] => FALSE;
                    h (a ! r) => g a or h r;
                end 

                also
                fun g (lcf::FN(_, _, b)) => g b;
                    g (lcf::MUTUALLY_RECURSIVE_FNS (vl, _, ll, b)) => TRUE;
                    g (lcf::APPLY (lcf::FN _, _)) => TRUE;
                    g (lcf::APPLY (l, r)) => g l or g r;

                    g (lcf::LET _) => TRUE;
                    g (lcf::TYPEFUN(_, b)) => g b;
                    g (lcf::APPLY_TYPEFUN (l, [])) => g l; 
                    g (lcf::APPLY_TYPEFUN (l, _)) => TRUE;
                    g (lcf::GENOP(_, _, _, _)) => TRUE;
                    g (lcf::PACK(_, _, _, l)) => g l;

                    g (lcf::RECORD l) => h l;
                    g (lcf::PACKAGE_RECORD l) => h l;
                    g (lcf::VECTOR (l, _)) => h l;
                    g (lcf::GET_FIELD(_, l)) => g l;

                    g (lcf::SWITCH _) => TRUE;
                    g (lcf::CONSTRUCTOR(_, _, l)) => TRUE;
          #         g (DECON(_, _, l)) = TRUE 

                    g (lcf::EXCEPT _) => TRUE; 
                    g (lcf::RAISE (l, _)) => g l;
                    g (lcf::EXCEPTION_TAG (l, _)) => g l;

                    g (lcf::BOX(_, _, l)) => g l;
                    g (lcf::UNBOX(_, _, l)) => g l;
                    g _ => FALSE;
              end;
            end;

        fun print_lexp l
            = 
            {   fun pr_lty    t =  say (hcf::uniqtype_to_string t);
                fun pr_typ t =  say (hcf::uniqtyp_to_string t);
                fun pr_knd    k =  say (hcf::uniqkind_to_string k);

                fun plist (p, [],    sep) => ();
                    plist (p, a ! r, sep) => { p a; apply (fn x =  { say sep; p x;}) r;};
                end;

                fun g (lcf::VAR     v) =>  say (name_of_highcode_codetemp v);
                    g (lcf::INT     i) =>                 say (int::to_string   i);
                    g (lcf::UNT     i) =>  { say "(U)";   say (unt::to_string   i); };
                    g (lcf::INT1   i) =>  { say "(I32)"; say (one_word_int::to_string i); };
                    g (lcf::UNT1   i) =>  { say "(U32)"; say (one_word_unt::to_string i); };
                    g (lcf::FLOAT64 s) => say s;
                    g (lcf::STRING  s) => say (heap_string s);
                    g (lcf::EXCEPTION_TAG (l, _)) => g l;

                    g (r as lcf::RECORD l)
                        =>
                        if (complex r)
                            #
                            say "lcf::RECORD";
                            indent 7;
                            pu::print_closed_sequence ("(", ",\n" + whitespace(), ")") g l;
                            undent 7;
                        else
                            say "lcf::RECORD";
                            pu::print_closed_sequence ("(", ", ", ")") g l;
                        fi;

                    g (r as lcf::PACKAGE_RECORD l)
                        =>
                        if (complex r)
                            #
                            say "lcf::PACKAGE_RECORD";
                            indent 7;
                            pu::print_closed_sequence ("(", ",\n" + whitespace(), ")") g l;
                            undent 7;
                        else
                            say "lcf::PACKAGE_RECORD";
                            pu::print_closed_sequence ("(", ", ", ")") g l;
                        fi;

                    g (r as lcf::VECTOR (l, _))
                        =>
                        if (complex r)
                            #
                            say "lcf::VECTOR";
                            indent 7;
                            pu::print_closed_sequence ("(", ",\n" + whitespace(), ")") g l;
                            undent 7;
                        else
                            say "lcf::VECTOR";
                            pu::print_closed_sequence ("(", ", ", ")") g l;
                        fi;

                    g (lcf::BASEOP (p, t, ts))
                        => 
                        {   say ("lcf::BASEOP (" + (hbo::baseop_to_string p) + ", ");
                            pr_lty t; 
                            say ", ["; plist (pr_typ, ts, ", ");
                            say "])";
                        };

                    g (l as lcf::GET_FIELD (i, _))
                        =>
                        {   fun gather (lcf::GET_FIELD (i, l))
                                    =>
                                    {   my (more, root) = gather l;
                                        (i ! more, root);
                                    };

                                gather l
                                    =>
                                    (NIL, l);
                            end;

                            my (path, root)
                                =
                                gather l;

                            fun ipr (i: Int)
                                =
                                say (int::to_string i);

                            g root;

                            pu::print_closed_sequence ("[", ", ", "]") ipr (reverse path);
                       };

                    g (lcf::FN (v, t, l))
                        => 
                        {   say "lcf::FN(";
                            say (name_of_highcode_codetemp v);
                            say " : "; 
                            pr_lty t;
                            say ", ";

                            if (complex l)
                                #
                                newline();
                                indent 3;
                                dent();
                                g l;
                                say ")";
                                undent 3;
                            else
                                g l;
                                say ")";
                            fi;
                        };

                    g (lcf::CONSTRUCTOR((s, c, lt), ts, l))
                        => 
                        {   say "lcf::CONSTRUCTOR((";
                            say (sy::name s);
                            say ", ";
                            sayrep c;
                            say ", ";

                            pr_lty lt;
                            say "), [";
                            plist (pr_typ, ts, ", ");
                            say "], ";

                            if (complex l)
                                indent 4;
                                g l;
                                say ")";
                                undent 4;
                            else
                                g l;
                                say ")";
                            fi;
                        };
           /*
                   | g (DECON((s, c, lt), ts, l)) = 
                       (say "DECON(("; say (sy::name s); say ", "; sayrep c; say ", ";
                        prLty lt; say "), ["; plist (prTypeConstructor, ts, ", "); say "], ";
                        if complex l then (indent 4; g l; say ")"; undent 4)
                        else (g l; say ")"))
           */
                    g (lcf::APPLY (lcf::FN (v, _, l), r))
                        =>
                        {   say "(lcf::APPLY) ";
                            g (lcf::LET (v, r, l));
                        };

                    g (lcf::LET (v, r, l))
                        => 
                        {   lv = name_of_highcode_codetemp v;
                            len = size lv + 3;
                            say lv; say " = ";

                            if (complex r)
                                indent 2;
                                newline();
                                dent();
                                g r;
                                undent 2;
                            else
                                indent len ;
                                g r;
                                undent len;
                            fi;

                            newline();
                            dent();
                            g l;
                        };

                    g (lcf::APPLY (l, r))
                        => 
                        {   say "lcf::APPLY(";

                            if (complex l or complex r)

                                 indent 4;
                                 g l; say ",\n"; dent();
                                 g r; say ")"; undent 4;
                            else
                                 g l; say ", ";
                                 g r; say ")";
                            fi;
                        };

                    g (lcf::TYPEFUN (ks, b))
                        => 
                        {   say "lcf::TYPEFUN(";

                            apply (fn k = { pr_knd k; say ", ";})
                                  ks; 

                            if (complex b) 

                                newline();
                                indent 3;
                                dent();
                                g b;
                                say ")";
                                undent 3;
                            else
                                g b;
                                say ")";
                            fi;
                        };

                    g (lcf::APPLY_TYPEFUN (l, ts))
                        => 
                        {   say "lcf::APPLY_TYPEFUN("; 

                            if (complex l) 

                                indent 4;
                                g l;
                                say ",\n";
                                dent();
                                say "[";
                                plist (pr_typ, ts, ", "); say "])";
                                undent 4;
                            else
                                g l;
                                say ", [";
                                plist (pr_typ, ts, ", ");
                                say "])";
                            fi;
                        };

                    g (lcf::GENOP (dictionary, p, t, ts))
                        => 
                        {   say ("lcf::GENOP (" + (hbo::baseop_to_string p) + ", ");
                            pr_lty t; 
                            say ", [";
                            plist (pr_typ, ts, ", ");
                            say "])";
                        };

                    g (lcf::PACK (lt, ts, nts, l))
                        => 
                        {   say "lcf::PACK("; 

                            app2 ( fn (tc, ntc)
                                       =
                                       {   say "<";
                                           pr_typ tc;
                                           say ", ";
                                           pr_typ ntc;
                                           say ">, ";
                                       },
                                   ts,
                                   nts
                                 );

                            say " ";
                            pr_lty lt;
                            say ", ";

                            if (complex l) 

                                newline();
                                indent 3;
                                dent();
                                g l;
                                say ")";
                                undent 3;
                            else
                                g l;
                                say ")";
                            fi;
                        };

                    g (lcf::SWITCH (l, _, llist, default))
                        =>
                        {   fun switch [(c, l)]
                                    =>
                                    {   print_casetag c;
                                        say " => ";
                                        indent 8;
                                        g l;
                                        undent 8;
                                    };

                                switch ((c, l) ! more)
                                    => 
                                    {   print_casetag c;
                                        say " => ";
                                        indent 8;
                                        g l;
                                        undent 8;
                                        newline();
                                        dent();
                                        switch more;
                                    };

                                switch []
                                    =>
                                    bug "unexpected case in switch";
                            end; 

                           say "lcf::SWITCH ";
                           indent 7; g l; undent 6; newline(); dent();
                           say "of "; indent 3; switch llist;

                           case (default, llist)
                               (NULL, _) => ();
                               (THE l, NIL) => { say "_ => "; indent 5; g l; undent 5;};
                               (THE l, _) => { newline(); dent(); say "_ => ";
                                              indent 5; g l; undent 5;};
                           esac;

                           undent 4;
                       };

                    g (lcf::MUTUALLY_RECURSIVE_FNS (varlist, ltylist, lexplist, lambda_expression))
                        =>
                        {   fun flist ([v],[t],[l])
                                    =>
                                    {   lv = name_of_highcode_codetemp v;
                                        len = size lv + 2;
                                        say lv; say " : ";pr_lty t;say " . ";
                                        indent len ; g l; undent len;
                                    };

                                flist (v ! vs, t ! ts, l ! ls)
                                    =>
                                    {   lv = name_of_highcode_codetemp v;
                                        len = size lv + 2;
                                        say lv; say " : "; pr_lty t; say " . ";
                                        indent len ; g l; undent len;
                                        newline(); dent(); flist (vs, ts, ls);
                                    };

                                flist (NIL, NIL, NIL)
                                    => ();

                                flist _
                                    =>
                                    bug "unexpected cases in flist";
                            end;

                            say "lcf::MUTUALLY_RECURSIVE_FNS("; indent 4; flist (varlist, ltylist, lexplist); 
                            undent 4; newline(); dent(); say "IN  ";
                            indent 4; g lambda_expression; say ")"; undent 4;
                        };

                    g (lcf::RAISE (l, t))
                        => 
                        {   say "lcf::RAISE(";
                            pr_lty t;
                            say ", ";
                            indent 6;
                            g l;
                            say ")";
                            undent 6;
                        };

                    g (lcf::EXCEPT (lambda_expression, withlexp))
                        =>
                        {   say "lcf::EXCEPT "; indent 7; g lambda_expression; undent 5; newline(); dent();
                            say "WITH "; indent 5; g withlexp; undent 7;
                        };

                    g (lcf::BOX (t, _, l))
                        => 
                        {   say "lcf::BOX("; pr_typ t; say ", "; indent 5; newline(); dent(); g l; 
                            say ")"; undent 5;
                        };

                    g (lcf::UNBOX (t, _, l))
                        => 
                        {   say "lcf::UNBOX("; pr_typ t; say ", "; indent 7; 
                            newline(); dent(); g l; say ")"; undent 7;
                        };
                end;

                g l;
                newline();
                newline();
            };

        fun print_match dictionary ((p, r) ! more)
                =>
                {   pp::with_prettyprint_device
                        (error_message::default_plaint_sink ())
                        (fn stream
                            =
                            {   unparse_deep_syntax::unparse_pattern
                                    dictionary
                                    stream
                                    (p, *global_controls::print::print_depth);

                                pp::newline stream;
                            }
                        );

                    say " => ";
                    print_lexp r;
                    print_match dictionary more;
                };

            print_match _ []
                =>
                ();
        end;

        fun print_fun l v
            =
            find l
            where
                fun last (vh::HIGHCODE_VARIABLE x) =>  x; 
                    last (vh::PATH (r, _))         =>  last r;
                    last _                         =>  bug "unexpected varhome in last";
                end;

                recursive my find
                    =
                    fn lcf::VAR w
                         =>
                         if (v==w)
                              say("lcf::VAR " + name_of_highcode_codetemp v + " is free in <lambda_expression>\n"); ();
                         fi;

                        l as lcf::FN (w, _, b)
                            =>
                            if (v == w)   print_lexp l;
                            else          find b;
                            fi;

                        l as lcf::MUTUALLY_RECURSIVE_FNS (vl, _, ll, b)
                            => 
                            if (list::exists (fn w =  v==w) vl)
                                #
                                print_lexp l;
                            else
                                apply find ll;
                                find b;
                            fi;

                        lcf::APPLY (l, r) => { find l; find r;};
                        lcf::LET (w, l, r) => { if (v==w ) print_lexp l; else find l;fi; find r;};

                        lcf::PACK (_, _, _, r) =>  find r;
                        lcf::TYPEFUN    (_, r) =>  find r;
                        lcf::APPLY_TYPEFUN (l, _) =>  find l;

                        lcf::SWITCH (l, _, ls, d)
                            =>
                            {   find l;

                                apply (fn (_, l) =  find l)
                                      ls;

                                case d    NULL  => ();
                                          THE l => find l;
                                esac;
                            };

                        lcf::RECORD         l =>  apply find l; 
                        lcf::PACKAGE_RECORD l =>  apply find l; 
                        lcf::VECTOR (l, t)    =>  apply find l; 

                        lcf::GET_FIELD(_, l) => find l;

                        lcf::CONSTRUCTOR((_, vh::EXCEPTION p, _), _, e)
                            =>
                            {   find (lcf::VAR (last p));
                                find e;
                            };

                        lcf::CONSTRUCTOR(_, _, e) => find e;

      #                 DECON((_, vh::EXCEPTION p, _), _, e) => (find (lcf::VAR (last p)); find e);
      #                 DECON(_, _, e) => find e  ;

                        lcf::EXCEPT (e, h) => { find e; find h;}; 
                        lcf::RAISE  (l, _) => find l;

                        lcf::INT   _ => ();
                        lcf::UNT   _ => (); 

                        lcf::INT1 _ => ();
                        lcf::UNT1 _ => (); 

                        lcf::STRING  _ => ();
                        lcf::FLOAT64 _ => ();

                        lcf::EXCEPTION_TAG (e, _) => find e;
                        lcf::BASEOP _ => ();

                        lcf::GENOP ( { default=>e1, table=>es }, _, _, _)
                            => 
                            {   find  e1;
                                apply  (fn (_, x) = find x)  es;
                            };

                        lcf::BOX  (_, _, e) =>  find e;
                        lcf::UNBOX(_, _, e) =>  find e;
                    end;

            end;

        fun string_tag (lcf::VAR                    _) =>  "lcf::VAR";
            string_tag (lcf::INT                    _) =>  "lcf::INT";
            string_tag (lcf::INT1                  _) =>  "lcf::INT1";
            string_tag (lcf::UNT                    _) =>  "lcf::UNT";
            string_tag (lcf::UNT1                  _) =>  "lcf::UNT1";
            string_tag (lcf::FLOAT64                _) =>  "lcf::FLOAT64";
            string_tag (lcf::STRING                 _) =>  "lcf::STRING";
            string_tag (lcf::BASEOP                _) =>  "lcf::BASEOP";
            string_tag (lcf::GENOP                  _) =>  "lcf::GENOP";
            #
            string_tag (lcf::FN                     _) => "lcf::FN";
            string_tag (lcf::MUTUALLY_RECURSIVE_FNS _) => "lcf::MUTUALLY_RECURSIVE_FNS";
            string_tag (lcf::APPLY                  _) => "lcf::APPLY";
            string_tag (lcf::LET                    _) => "STIPULATE";
            string_tag (lcf::TYPEFUN                _) => "lcf::TYPEFUN";
            string_tag (lcf::APPLY_TYPEFUN             _) => "lcf::APPLY_TYPEFUN";
            string_tag (lcf::EXCEPTION_TAG          _) => "lcf::EXCEPTION_TAG";
            string_tag (lcf::RAISE                  _) => "lcf::RAISE";
            string_tag (lcf::EXCEPT                 _) => "lcf::EXCEPT";
            string_tag (lcf::CONSTRUCTOR            _) => "lcf::CONSTRUCTOR";
            string_tag (lcf::SWITCH                 _) => "lcf::SWITCH";
            string_tag (lcf::VECTOR                 _) => "lcf::VECTOR";
            string_tag (lcf::RECORD                 _) => "lcf::RECORD";
            string_tag (lcf::PACKAGE_RECORD         _) => "lcf::PACKAGE_RECORD";
            string_tag (lcf::GET_FIELD                 _) => "lcf::GET_FIELD";
            string_tag (lcf::PACK                   _) => "lcf::PACK";
            string_tag (lcf::BOX                    _) => "lcf::BOX";
            string_tag (lcf::UNBOX                  _) => "lcf::UNBOX";
        end;
    };                                                                          #  package prettyprint_lambdacode_expression 
end;                                                                            #  toplevel stipulate 




Comments and suggestions to: bugs@mythryl.org

PreviousUpNext