CVS: sml-dist/src/compiler/FLINT/trans translate.sml, 1.33.4.31, 1.33.4.32

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

Modified Files:
      Tag: primop-branch-2
	translate.sml 
Log Message:
inl_infPrec still not correct, but getting there...

Index: translate.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/trans/translate.sml,v
retrieving revision 1.33.4.31
retrieving revision 1.33.4.32
diff -C2 -d -r1.33.4.31 -r1.33.4.32
*** translate.sml	22 Sep 2006 19:07:06 -0000	1.33.4.31
--- translate.sml	25 Sep 2006 03:26:52 -0000	1.33.4.32
***************
*** 614,617 ****
--- 614,655 ----
  	system/smlnj/init/core-intinf.sml:51:    val finToInf  : int32 * bool -> intinf
   *)
+ fun inlToInfPrec (opname, coerceFnName, primop, primoplt) =
+    let 
+ 	val (orig_arg_lt, res_lt) =
+ 		case LT.ltd_arrow primoplt of
+ 	    	(_, [a], [r]) => (a, r)
+ 	  	| _ => bug ("unexpected type of " ^ opname)
+     	val extra_arg_lt =
+ 		if coerceFnName = "finToInf" then
+ 			LT.ltc_arrow(LT.ffc_var(true,false), [LT.ltc_int32 ,LT.ltc_bool], [res_lt])
+ 		else
+ 			LT.ltc_parrow(LT.ltc_int32, res_lt)
+         val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
+         val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
+         val x = mkv ()
+     in
+        FN (x, orig_arg_lt,
+ 	  APP (PRIM (primop, new_lt, []),
+ 	       RECORD [VAR x, coreAcc coerceFnName]))
+     end
+ 
+ fun inlFromInfPrec (opname, coerceFnName, primop, primoplt) =    
+     let 
+ 	val (orig_arg_lt, res_lt) =
+ 		case LT.ltd_arrow primoplt of
+ 	    	(_, [a], [r]) => (a, r)
+ 	  	| _ => bug ("unexpected type of " ^ opname)
+     	val extra_arg_lt =
+ 		LT.ltc_parrow (orig_arg_lt, LT.ltc_int32)
+         val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
+         val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
+         val x = mkv ()
+     in
+        FN (x, orig_arg_lt,
+ 	  APP (PRIM (primop, new_lt, []),
+ 	       RECORD [VAR x, coreAcc coerceFnName]))
+     end
+     
+   
  fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
      val (orig_arg_lt, res_lt) =
***************
*** 621,625 ****
      val extra_arg_lt =
  	LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
! 		       else (LT.ltc_int32, orig_arg_lt))
      val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
      val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
--- 659,663 ----
      val extra_arg_lt =
  	LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
! 		       else (LT.ltc_int32, res_lt (* orig_arg_lt *) ))
      val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
      val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
***************
*** 627,636 ****
      (** Begin DEBUG edits *)
      val y = mkv ()	
!     (** val coreOcc = (if corename = "finToInf" then
  			FN(y, LT.ltc_int32 (** Where should this type come from *), 
  			   APP(coreAcc corename, RECORD [VAR y,
  				falseLexp 
  				(** Apply to CoreBasicType falseDcon ...  *) ]))
! 		   else coreAcc corename) *)
      (** End DEBUG edits *)
      val e = 	
--- 665,674 ----
      (** Begin DEBUG edits *)
      val y = mkv ()	
!     val coreOcc = (if corename = "finToInf" then
  			FN(y, LT.ltc_int32 (** Where should this type come from *), 
  			   APP(coreAcc corename, RECORD [VAR y,
  				falseLexp 
  				(** Apply to CoreBasicType falseDcon ...  *) ]))
! 		   else coreAcc corename) 
      (** End DEBUG edits *)
      val e = 	
***************
*** 833,843 ****
  
  	| g (p as PO.TEST_INF prec) =
! 	    inl_infPrec ("TEST_INF", "testInf", p, lt, true)
  	| g (p as PO.TRUNC_INF prec) =
! 	    inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
  	| g (p as PO.EXTEND_INF prec) =
! 	    inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
  	| g (p as PO.COPY_INF prec) =
! 	    inl_infPrec ("COPY", "finToInf", p, lt, false) 
  	(* default handling for all other primops *)
          | g p = PRIM(p, lt, ts) 
--- 871,882 ----
  
  	| g (p as PO.TEST_INF prec) =
! 	    inlFromInfPrec ("TEST_INF", "testInf", p, lt)
  	| g (p as PO.TRUNC_INF prec) =
! 	    inlFromInfPrec ("TRUNC_INF", "truncInf", p, lt)
  	| g (p as PO.EXTEND_INF prec) =
! 	    (* inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false) *)
! 	    inlToInfPrec("EXTEND_INF", "finToInf", p, lt)
  	| g (p as PO.COPY_INF prec) =
! 	    inlToInfPrec ("COPY", "copyInf", p, lt) 
  	(* default handling for all other primops *)
          | g p = PRIM(p, lt, ts) 


-------------------------------------------------------------------------
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