Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/ltykernel.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/ltykernel.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 2005, Tue Aug 1 23:01:55 2006 UTC revision 2006, Wed Aug 2 20:59:42 2006 UTC
# Line 483  Line 483 
483        | TC_SUM tcs =>        | TC_SUM tcs =>
484            "TSUM(" ^ (plist(tc_print, tcs)) ^ ")"            "TSUM(" ^ (plist(tc_print, tcs)) ^ ")"
485        | TC_FIX ((_, tc, ts), i) =>        | TC_FIX ((_, tc, ts), i) =>
486            if false (* tc_eqv(x,tcc_bool) *) then "B"            (* if tc_eqv(x,tcc_bool) then "B"
487            else if false (* tc_eqv(x,tcc_list) *) then "LST"            else if tc_eqv(x,tcc_list) then "LST"
488                 else (let (* val ntc = case ts of [] => tc                 else *) (let (* val ntc = case ts of [] => tc
489                                              | _ => tcc_app(tc, ts) *)                                              | _ => tcc_app(tc, ts) *)
490                           val _ = 1                           val _ = 1
491                        in ("DT{" ^ "DATA"  ^ "[" ^ (tc_print tc)                        in ("DT{" ^ "DATA"  ^ "[" ^ (tc_print tc)
# Line 876  Line 876 
876  (** taking out the TC_IND indirection *)  (** taking out the TC_IND indirection *)
877  and stripInd t = (case tc_outX t of TC_IND (x,_) => stripInd x | _ => t)  and stripInd t = (case tc_outX t of TC_IND (x,_) => stripInd x | _ => t)
878    
879    and printParamArgs (tc,tcs) =
880        let
881            fun getArity(TC_FN(params, _)) =
882                (print "printParamArgs TC_FN \n";
883                 length params)
884              | getArity(TC_APP(tc, _)) =
885                (case (tc_outX tc)
886                  of (TC_FN(_, tc')) => getArity (tc_outX tc')
887                   | _ => 0)
888              | getArity(TC_FIX((numFamily,tc,freetycs),_)) =
889                (case (tc_outX tc) of
890                     (TC_FN _) =>
891                     (getArity (tc_outX tc))
892                   | _ => 0)
893              | getArity _ = (print ("getArity on:\n "^tc_print tc^"\n"); 0)
894            val numParams = getArity (tc_outX tc)
895        in
896            if numParams = (length tcs) then
897                print ("(TC_APP params args matched "^Int.toString (length tcs)^")\n")
898            else print ("(TC_APP of " ^tc_print tc^ "\nparams "
899                        ^ Int.toString numParams
900                        ^ "\nargument list length: "
901                        ^ Int.toString (length tcs)
902                        ^ ")\n")
903        end
904    
905  (** normalizing an arbitrary tyc into a simple weak-head-normal-form *)  (** normalizing an arbitrary tyc into a simple weak-head-normal-form *)
906  and tc_whnm t = if tcp_norm(t) then t else  and tc_whnm t = if tcp_norm(t) then t else
907    let val nt = tc_lzrd t    let (* val _ = print ">>tc_whnm not norm\n" *)
908          val nt = tc_lzrd t
909     in case (tc_outX nt)     in case (tc_outX nt)
910         of TC_APP(tc, tcs) =>         of TC_APP(tc, tcs) =>
911              (let val tc' = tc_whnm tc              (let val tc' = tc_whnm tc
# Line 902  Line 929 
929                         end                         end
930                     | ((TC_SEQ _) | (TC_TUPLE _) | (TC_ARROW _) | (TC_IND _)) =>                     | ((TC_SEQ _) | (TC_TUPLE _) | (TC_ARROW _) | (TC_IND _)) =>
931                         bug "unexpected tycs in tc_whnm-TC_APP"                         bug "unexpected tycs in tc_whnm-TC_APP"
932                     | _ => let val xx = tcc_app(tc', tcs)                     | _ => let val _ = printParamArgs (tc', tcs)
933                                  val xx = tcc_app(tc', tcs)
934                             in stripInd xx                             in stripInd xx
935                            end                            end
936               end)               end)
# Line 953  Line 981 
981          (let val res =          (let val res =
982                (case (tc_outX nt)                (case (tc_outX nt)
983                  of TC_FN (ks, tc) => tcc_fn(ks, tc_norm tc)                  of TC_FN (ks, tc) => tcc_fn(ks, tc_norm tc)
984                   | TC_APP (tc, tcs) =>                   | TC_APP (tc, tcs) => tcc_app(tc_norm tc, map tc_norm tcs)
                      tcc_app(tc_norm tc, map tc_norm tcs)  
985                   | TC_SEQ tcs => tcc_seq(map tc_norm tcs)                   | TC_SEQ tcs => tcc_seq(map tc_norm tcs)
986                   | TC_PROJ (tc, i) => tcc_proj(tc_norm tc, i)                   | TC_PROJ (tc, i) => tcc_proj(tc_norm tc, i)
987                   | TC_SUM tcs => tcc_sum (map tc_norm tcs)                   | TC_SUM tcs => tcc_sum (map tc_norm tcs)

Legend:
Removed from v.2005  
changed lines
  Added in v.2006

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0