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/trunk/src/compiler/FLINT/trans/pequal.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/FLINT/trans/pequal.sml

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

revision 17, Wed Mar 11 21:00:18 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 3  Line 3 
3    
4  signature PEQUAL =  signature PEQUAL =
5  sig  sig
6      type toTcLt = (Types.ty -> PLambdaType.tyc) * (Types.ty -> PLambdaType.lty)
7    (*    (*
8     * Constructing generic equality functions; the current version will     * Constructing generic equality functions; the current version will
9     * use runtime polyequal function to deal with abstract types. (ZHONG)     * use runtime polyequal function to deal with abstract types. (ZHONG)
10     *)     *)
11    val equal : {getStrEq : unit -> PLambda.lexp,    val equal : {getStrEq : unit -> PLambda.lexp,
12                 getPolyEq : unit -> PLambda.lexp} * StaticEnv.staticEnv                 getPolyEq : unit -> PLambda.lexp} * StaticEnv.staticEnv
13                 -> (Types.ty * Types.ty * DebIndex.depth) -> PLambda.lexp                 -> (Types.ty * Types.ty * toTcLt) -> PLambda.lexp
14    
15    val debugging : bool ref    val debugging : bool ref
16    
# Line 25  Line 25 
25        structure T  = Types        structure T  = Types
26        structure BT = BasicTypes        structure BT = BasicTypes
27        structure LT = PLambdaType        structure LT = PLambdaType
       structure TT = TransTypes  
28        structure TU = TypesUtil        structure TU = TypesUtil
29        structure SE = StaticEnv        structure SE = StaticEnv
30        structure PO = PrimOp        structure PO = PrimOp
# Line 38  Line 37 
37  fun bug msg = ErrorMsg.impossible("Equal: "^msg)  fun bug msg = ErrorMsg.impossible("Equal: "^msg)
38  val say = Control.Print.say  val say = Control.Print.say
39    
40    type toTcLt = (ty -> LT.tyc) * (ty -> LT.lty)
41    
42  val --> = BT.-->  val --> = BT.-->
43  infix -->  infix -->
44    
# Line 51  Line 52 
52    
53  (** translating the typ field in DATACON into lty; constant datacons  (** translating the typ field in DATACON into lty; constant datacons
54      will take ltc_unit as the argument *)      will take ltc_unit as the argument *)
55  fun toDconLty d ty =  fun toDconLty (toTyc, toLty) ty =
56    (case ty    (case ty
57      of POLYty{sign, tyfun=TYFUN{arity, body}} =>      of POLYty{sign, tyfun=TYFUN{arity, body}} =>
58           if BT.isArrowType body then TT.toLty d ty           if BT.isArrowType body then toLty ty
59           else TT.toLty d (POLYty{sign=sign,           else toLty (POLYty{sign=sign,
60                                 tyfun=TYFUN{arity=arity,                                 tyfun=TYFUN{arity=arity,
61                                                body=BT.-->(BT.unitTy, body)}})                                                body=BT.-->(BT.unitTy, body)}})
62       | _ => if BT.isArrowType ty then TT.toLty d ty       | _ => if BT.isArrowType ty then toLty ty
63              else TT.toLty d (BT.-->(BT.unitTy, ty)))              else toLty (BT.-->(BT.unitTy, ty)))
64    
65  (*  (*
66   * Is TU.dconType necessary, or could a variant of transTyLty that   * Is TU.dconType necessary, or could a variant of transTyLty that
67   * just takes tyc and domain be used in transDcon???   * just takes tyc and domain be used in transDcon???
68   *)   *)
69  fun transDcon(tyc, {name,rep,domain}, d) =  fun transDcon(tyc, {name,rep,domain}, toTcLt) =
70        (name, rep, toDconLty d (TU.dconType(tyc,domain)))        (name, rep, toDconLty toTcLt (TU.dconType(tyc,domain)))
71    
72  val (trueDcon', falseDcon') =  val (trueDcon', falseDcon') =
73    let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)    let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)
# Line 145  Line 146 
146   *              equal --- the equality function generator                   *   *              equal --- the equality function generator                   *
147   ****************************************************************************)   ****************************************************************************)
148  fun equal ({getStrEq, getPolyEq}, env)  fun equal ({getStrEq, getPolyEq}, env)
149            (polyEqTy : ty, concreteType : ty, d) =            (polyEqTy : ty, concreteType : ty, toTcLc as (toTyc, toLty)) =
150  let  let
151    
152  val cache : (ty * lexp * lexp ref) list ref = ref nil  val cache : (ty * lexp * lexp ref) list ref = ref nil
# Line 175  Line 176 
176        f (!cache)        f (!cache)
177    end    end
178    
179  fun eqTy ty = eqLty(TT.toLty d ty)  fun eqTy ty = eqLty(toLty ty)
180  fun ptrEq(p, ty) = PRIM(p, eqTy ty, [])  fun ptrEq(p, ty) = PRIM(p, eqTy ty, [])
181  fun prim(p, lt) = PRIM(p, lt, [])  fun prim(p, lt) = PRIM(p, lt, [])
182    
# Line 218  Line 219 
219                           COND(loop(n,[ty]), loop(n+1,r), falseLexp)                           COND(loop(n,[ty]), loop(n+1,r), falseLexp)
220                       | loop(_,nil) = trueLexp                       | loop(_,nil) = trueLexp
221    
222                     val lt = TT.toLty d ty                     val lt = toLty ty
223                  in patch := FN(v, LT.ltc_tuple [lt,lt],                  in patch := FN(v, LT.ltc_tuple [lt,lt],
224                               LET(x, SELECT(0, VAR v),                               LET(x, SELECT(0, VAR v),
225                                 LET(y, SELECT(1, VAR v),                                 LET(y, SELECT(1, VAR v),
# Line 261  Line 262 
262                                              in APP(test(argt, depth-1),                                              in APP(test(argt, depth-1),
263                                                     RECORD[VAR ww, VAR uu])                                                     RECORD[VAR ww, VAR uu])
264                                             end)))                                             end)))
265                             val lt = TT.toLty d ty                             val lt = toLty ty
266                             val argty = LT.ltc_tuple [lt,lt]                             val argty = LT.ltc_tuple [lt,lt]
267                             val pty = LT.ltc_parrow(argty, boolty)                             val pty = LT.ltc_parrow(argty, boolty)
268    
# Line 284  Line 285 
285                                        val sign = getCsig(dcons,0,0)                                        val sign = getCsig(dcons,0,0)
286    
287                                        fun concase dcon =                                        fun concase dcon =
288                                          let val tcs = map (TT.toTyc d) tyl                                          let val tcs = map toTyc tyl
289                                              val ww = mkv() and uu = mkv()                                              val ww = mkv() and uu = mkv()
290                                              val dc = transDcon(tyc,dcon,d)                                              val dc = transDcon(tyc,dcon,toTcLc)
291                                              val dconx = DATAcon(dc, tcs, ww)                                              val dconx = DATAcon(dc, tcs, ww)
292                                              val dcony = DATAcon(dc, tcs, uu)                                              val dcony = DATAcon(dc, tcs, uu)
293                                           in (dconx,                                           in (dconx,
# Line 328  Line 329 
329  end handle Poly =>  end handle Poly =>
330    (GENOP({default=getPolyEq(),    (GENOP({default=getPolyEq(),
331            table=[([LT.tcc_string], getStrEq())]},            table=[([LT.tcc_string], getStrEq())]},
332           PO.POLYEQL, TT.toLty d polyEqTy,           PO.POLYEQL, toLty polyEqTy,
333           [TT.toTyc d concreteType]))           [toTyc concreteType]))
334    
335    
336  end (* toplevel local *)  end (* toplevel local *)

Legend:
Removed from v.17  
changed lines
  Added in v.45

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