CVS: sml-dist/src/compiler/FLINT/kernel ltykernel.sml, 1.18.12.8, 1.18.12.9

Update of /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12898/compiler/FLINT/kernel

Modified Files:
      Tag: primop-branch-2
	ltykernel.sml 
Log Message:


Index: ltykernel.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sml,v
retrieving revision 1.18.12.8
retrieving revision 1.18.12.9
diff -C2 -d -r1.18.12.8 -r1.18.12.9
*** ltykernel.sml	1 Aug 2006 23:01:19 -0000	1.18.12.8
--- ltykernel.sml	2 Aug 2006 20:59:42 -0000	1.18.12.9
***************
*** 1,3 ****
! (* COPYRIGHT (c) 1997 YALE FLINT PROJECT *)
  (* ltykernel.sml *)
  
--- 1,3 ----
!  (* COPYRIGHT (c) 1997 YALE FLINT PROJECT *)
  (* ltykernel.sml *)
  
***************
*** 484,490 ****
            "TSUM(" ^ (plist(tc_print, tcs)) ^ ")"
        | TC_FIX ((_, tc, ts), i) =>
!           if false (* tc_eqv(x,tcc_bool) *) then "B" 
!           else if false (* tc_eqv(x,tcc_list) *) then "LST" 
!                else (let (* val ntc = case ts of [] => tc
                                              | _ => tcc_app(tc, ts) *)
                           val _ = 1
--- 484,490 ----
            "TSUM(" ^ (plist(tc_print, tcs)) ^ ")"
        | TC_FIX ((_, tc, ts), i) =>
!           (* if tc_eqv(x,tcc_bool) then "B" 
!           else if tc_eqv(x,tcc_list) then "LST" 
!                else *) (let (* val ntc = case ts of [] => tc
                                              | _ => tcc_app(tc, ts) *)
                           val _ = 1
***************
*** 877,883 ****
  and stripInd t = (case tc_outX t of TC_IND (x,_) => stripInd x | _ => t)
  
  (** normalizing an arbitrary tyc into a simple weak-head-normal-form *)
  and tc_whnm t = if tcp_norm(t) then t else 
!   let val nt = tc_lzrd t
     in case (tc_outX nt)
         of TC_APP(tc, tcs) =>
--- 877,910 ----
  and stripInd t = (case tc_outX t of TC_IND (x,_) => stripInd x | _ => t)
  
+ and printParamArgs (tc,tcs) = 
+     let 
+ 	fun getArity(TC_FN(params, _)) = 
+ 	    (print "printParamArgs TC_FN \n"; 
+ 	     length params)
+ 	  | getArity(TC_APP(tc, _)) = 
+ 	    (case (tc_outX tc)
+ 	      of (TC_FN(_, tc')) => getArity (tc_outX tc')
+ 	       | _ => 0)
+ 	  | getArity(TC_FIX((numFamily,tc,freetycs),_)) = 
+ 	    (case (tc_outX tc) of
+ 		 (TC_FN _) =>
+ 		 (getArity (tc_outX tc))
+ 	       | _ => 0)
+ 	  | getArity _ = (print ("getArity on:\n "^tc_print tc^"\n"); 0)
+ 	val numParams = getArity (tc_outX tc)
+     in
+ 	if numParams = (length tcs) then 
+ 	    print ("(TC_APP params args matched "^Int.toString (length tcs)^")\n")
+ 	else print ("(TC_APP of " ^tc_print tc^ "\nparams "
+ 		    ^ Int.toString numParams
+ 		    ^ "\nargument list length: " 
+ 		    ^ Int.toString (length tcs) 
+ 		    ^ ")\n")
+     end
+ 	
  (** normalizing an arbitrary tyc into a simple weak-head-normal-form *)
  and tc_whnm t = if tcp_norm(t) then t else 
!   let (* val _ = print ">>tc_whnm not norm\n" *)
!       val nt = tc_lzrd t
     in case (tc_outX nt)
         of TC_APP(tc, tcs) =>
***************
*** 903,907 ****
                     | ((TC_SEQ _) | (TC_TUPLE _) | (TC_ARROW _) | (TC_IND _)) =>
                         bug "unexpected tycs in tc_whnm-TC_APP"
!                    | _ => let val xx = tcc_app(tc', tcs) 
                             in stripInd xx
                            end
--- 930,935 ----
                     | ((TC_SEQ _) | (TC_TUPLE _) | (TC_ARROW _) | (TC_IND _)) =>
                         bug "unexpected tycs in tc_whnm-TC_APP"
!                    | _ => let val _ = printParamArgs (tc', tcs)
! 			      val xx = tcc_app(tc', tcs) 
                             in stripInd xx
                            end
***************
*** 954,959 ****
                (case (tc_outX nt)
                  of TC_FN (ks, tc) => tcc_fn(ks, tc_norm tc)
!                  | TC_APP (tc, tcs) => 
!                      tcc_app(tc_norm tc, map tc_norm tcs)
                   | TC_SEQ tcs => tcc_seq(map tc_norm tcs)
                   | TC_PROJ (tc, i) => tcc_proj(tc_norm tc, i)
--- 982,986 ----
                (case (tc_outX nt)
                  of TC_FN (ks, tc) => tcc_fn(ks, tc_norm tc)
!                  | TC_APP (tc, tcs) => tcc_app(tc_norm tc, map tc_norm tcs)
                   | TC_SEQ tcs => tcc_seq(map tc_norm tcs)
                   | TC_PROJ (tc, i) => tcc_proj(tc_norm tc, i)


-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys -- and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV