Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Tracker SCM

SCM Repository

[smlnj] Diff of /sml/branches/FLINT/src/compiler/FLINT/reps/equalNEW.sml
ViewVC logotype

Diff of /sml/branches/FLINT/src/compiler/FLINT/reps/equalNEW.sml

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

revision 44, Sun Mar 22 20:10:57 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 1  Line 1 
1  (* COPYRIGHT (c) 1996 Bell Laboratories *)  (* COPYRIGHT (c) 1996 Bell Laboratories *)
2  (* equal.sml *)  (* equal.sml *)
3    
4  signature EQUAL =  signature EQUAL_NEW =
5  sig  sig
6    
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     *)     *)
   val equal : FLINT.lvar * FLINT.lvar * FLINT.tyc -> FLINT.lexp  
11    val equal_branch : FLINT.primop * FLINT.value list * FLINT.lexp * FLINT.lexp    val equal_branch : FLINT.primop * FLINT.value list * FLINT.lexp * FLINT.lexp
12                       -> FLINT.lexp                       -> FLINT.lexp
13    val equal_branch : FLINT.primop * FLINT.value list * FLINT.lvar * FLINT.lexp    val equal_primop : FLINT.primop * FLINT.value list * FLINT.lvar * FLINT.lexp
14                       -> FLINT.lexp                       -> FLINT.lexp
15    val debugging : bool ref    val debugging : bool ref
16    
17  end (* signature EQUAL *)  end (* signature EQUAL *)
18    
19    
20  structure Equal : EQUAL =  structure EqualNEW : EQUAL_NEW =
21  struct  struct
22    
23  local structure BT = BasicTypes  local structure BT = BasicTypes
# Line 61  Line 60 
60   *                   Commonly-used Lambda Types                             *   *                   Commonly-used Lambda Types                             *
61   ****************************************************************************)   ****************************************************************************)
62    
63  fun eqLty lt  = LT.ltc_arrow((true,true), [lt, lt], [LT.ltc_bool])  (** assumptions: typed created here will be reprocessed in wrapping.sml *)
64    fun eqLty lt  = LT.ltc_arrow(LT.ffc_rrflint, [lt, lt], [LT.ltc_bool])
65  fun eqTy tc   = eqLty(LT.ltc_tyc tc)  fun eqTy tc   = eqLty(LT.ltc_tyc tc)
66    
67  val inteqty   = eqLty (LT.ltc_int)  val inteqty   = eqLty (LT.ltc_int)
# Line 93  Line 93 
93        let val x = mkv()        let val x = mkv()
94         in LET([x], APP(v, vs),         in LET([x], APP(v, vs),
95              SWITCH(VAR x, BT.boolsign,              SWITCH(VAR x, BT.boolsign,
96                     [(DATAcon(trueDcon', [], mkv()), e1)                     [(DATAcon(trueDcon', [], mkv()), e1),
97                      (DATAcon(falseDcon', [], mkv()), e2)], NONE))                      (DATAcon(falseDcon', [], mkv()), e2)], NONE))
98        end        end
99    | branch(EBIND e, vs, e1, e2) =    | branch(EBIND e, vs, e1, e2) =
# Line 143  Line 143 
143    else if isRef(tc) then ptrEq(PO.PTREQL, tc)    else if isRef(tc) then ptrEq(PO.PTREQL, tc)
144    else raise Poly    else raise Poly
145    
146  val fk = FK_FUN(isrec=NONE, known=false, fixed=(true,true), inline=true)  val fkfun = FK_FUN{isrec=NONE, known=false, fixed=LT.ffc_rrflint, inline=true}
147    
148  fun test(tc, 0) = raise Poly  fun test(tc, 0) = raise Poly
149    | test(tc, depth) =    | test(tc, depth) =
# Line 163  Line 163 
163                      | loop(_, []) = trueLexp()                      | loop(_, []) = trueLexp()
164    
165                    val lt = LT.ltc_tyc tc                    val lt = LT.ltc_tyc tc
166                 in patch := (fk, v, [(x, lt), (y, lt)], loop(0, ts));                 in patch := SOME (fkfun, v, [(x, lt), (y, lt)], loop(0, ts));
167                    VBIND(VAR v)                    VBIND(VAR v)
168                end)                end)
169          end)          end)
# Line 197  Line 197 
197  fun equal_primop ((d, p, lt, ts), vs, v, e) =  fun equal_primop ((d, p, lt, ts), vs, v, e) =
198    (case (d, p, ts)    (case (d, p, ts)
199      of (SOME{default=pv, table=[(_,sv)]}, PO.POLYEQL, [tc]) =>      of (SOME{default=pv, table=[(_,sv)]}, PO.POLYEQL, [tc]) =>
200            primop(equal(pv, sv, tc), vs, e1, e2)            primop(equal(pv, sv, tc), vs, v, e)
201       | _ => bug "unexpected case in equal_branch")       | _ => bug "unexpected case in equal_branch")
202    
203  end (* toplevel local *)  end (* toplevel local *)

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

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