Return to equal.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / src / translate

Annotation of researchv10no/cmd/sml/src/translate/equal.sml, revision 1.1

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: (* equal.sml *)
        !             3: signature EQUAL =
        !             4: sig
        !             5:   structure Basics : BASICS
        !             6:   structure Lambda : LAMBDA
        !             7:   val equal : Basics.ty -> Lambda.lexp
        !             8: end
        !             9: 
        !            10: structure Equal : EQUAL =
        !            11: struct
        !            12: 
        !            13:   structure Basics : BASICS = Basics
        !            14:   structure Lambda : LAMBDA = Lambda
        !            15: 
        !            16: open ErrorMsg Basics Lambda Access BasicTypes TypesUtil
        !            17: 
        !            18: fun translatepath [v] = VAR v
        !            19:   | translatepath (x::p) = SELECT(x,translatepath p)
        !            20:   | translatepath nil = ErrorMsg.impossible "equal.translatepath nil"
        !            21: 
        !            22: fun argType(POLYty{tyfun=TYFUN{arity,body=CONty(_,[domain,_])},...}, args) =
        !            23:       applyTyfun(TYFUN{arity=arity,body=domain},args)
        !            24:   | argType(CONty(_,[argty,_]), []) = argty
        !            25:   | argType _ = impossible "Equal.argType"
        !            26: 
        !            27: 
        !            28: exception Poly
        !            29: 
        !            30: fun atomeq tyc =
        !            31:          if eqTycon(tyc,!intTycon) 
        !            32:             orelse eqTycon(tyc,!boolTycon)
        !            33:             orelse eqTycon(tyc,!refTycon)
        !            34:             orelse eqTycon(tyc,!arrayTycon) then PRIM P.ieql
        !            35:          else if eqTycon(tyc,!realTycon) then PRIM P.feql
        !            36:          else if eqTycon(tyc,!stringTycon) then 
        !            37:            translatepath(!CoreInfo.stringequalPath)
        !            38:          else raise Poly
        !            39: 
        !            40: exception Notfound
        !            41: 
        !            42: val trueLexp = CON(trueDcon,RECORD[])
        !            43: val falseLexp = CON(falseDcon,RECORD[])
        !            44: 
        !            45: fun equal (concreteType : ty) : lexp =
        !            46:     let val cache : (ty * lexp * lexp ref) list ref = ref nil
        !            47:        fun enter ty =
        !            48:            let val v = VAR(mkLvar())
        !            49:                val r = ref v
        !            50:             in if !System.Control.debugging 
        !            51:                  then (print "enter: "; PrintType.printType ty; print "\n")
        !            52:                  else ();
        !            53:                cache := (ty, v, r) :: !cache; (v,r)
        !            54:            end
        !            55:        fun find ty =
        !            56:            let fun f ((t,v,e)::r) = if equalType(ty,t) then v else f r
        !            57:                  | f nil = (if !System.Control.debugging
        !            58:                              then print "find-notfound\n"
        !            59:                              else ();
        !            60:                             raise Notfound)
        !            61:             in if !System.Control.debugging 
        !            62:                 then (print "find: "; PrintType.printType ty; print "\n")
        !            63:                 else ();
        !            64:                f (!cache)
        !            65:            end
        !            66: 
        !            67:        fun test(ty) =
        !            68:        (if !System.Control.debugging
        !            69:         then (print "test: "; PrintType.printType ty; print "\n")
        !            70:         else ();
        !            71:         case ty
        !            72:          of VARty(ref(INSTANTIATED t)) => test t
        !            73:           | FLEXRECORDty(ref(CLOSED t)) => test t
        !            74:           | CONty(ref(tyc as TYCON{kind=ABStyc,eq=ref YES,...}),tyl) =>  atomeq tyc
        !            75:           | CONty(ref(tyc as TYCON{kind=ABStyc,eq=ref NO,...}),tyl) =>
        !            76:               impossible("Attempt to test opaque type for equality: "
        !            77:                                     ^ Symbol.name(tycName tyc))
        !            78:           | CONty(ref(TYCON{kind=DEFtyc _,...}),tyl) => test(reduceType ty)
        !            79:           | CONty(ref(tyc as
        !            80:                       TYCON{kind=DATAtyc([DATACON{const=false,rep,typ,...}]),
        !            81:                             ...}),
        !            82:                   tyl) =>
        !            83:               (case rep
        !            84:                  of TRANSPARENT => 
        !            85:                       (find ty handle Notfound =>
        !            86:                         let val (eqv,patch) = enter ty
        !            87:                             val v = mkLvar()
        !            88:                             val ty' = argType(!typ,tyl)
        !            89:                          in patch := FN(v,APP(test ty', VAR v));
        !            90:                             eqv
        !            91:                         end)
        !            92:                   | REF => atomeq tyc
        !            93:                   | _ => impossible "Equal #498")
        !            94:           | CONty(ref(TYCON{kind,...}), tyl) =>
        !            95:              (find ty
        !            96:               handle Notfound =>
        !            97:               let val v = mkLvar() and x=mkLvar() and y=mkLvar()
        !            98:                   val (eqv, patch) = enter ty
        !            99:                   fun inside (DATACON{const=true,...}) = trueLexp
        !           100:                     | inside (c as DATACON{typ, const=false,...}) =
        !           101:                         APP(test(argType(!typ,tyl)),
        !           102:                             RECORD[DECON(c, VAR x),
        !           103:                                    DECON(c, VAR y)])
        !           104:                   val body = 
        !           105:                       case kind
        !           106:                         of DATAtyc([dcon]) =>
        !           107:                              inside dcon       
        !           108:                          | DATAtyc(dcons) =>
        !           109:                              let fun concase dcon =
        !           110:                                      (DATAcon(dcon),
        !           111:                                       SWITCH(VAR y,[(DATAcon(dcon), inside dcon)],
        !           112:                                            SOME(falseLexp)))
        !           113:                               in SWITCH(VAR x,map concase dcons,NONE)
        !           114:                              end
        !           115:                          | RECORDtyc _ =>
        !           116:                            let fun loop(n,[ty]) =
        !           117:                                         APP(test(ty), RECORD[SELECT(n, VAR x),
        !           118:                                                SELECT(n, VAR y)])
        !           119:                                  | loop(n,ty::r) =
        !           120:                                      SWITCH(loop(n,[ty]),
        !           121:                                       [(DATAcon(trueDcon), loop(n+1,r)),
        !           122:                                        (DATAcon(falseDcon), falseLexp)],
        !           123:                                       NONE)
        !           124:                                  | loop(_,nil) = trueLexp
        !           125:                             in loop(0,tyl)
        !           126:                            end
        !           127:                          | _ => raise Poly
        !           128:                in patch := FN(v,APP(FN(x,APP(FN(y,body),
        !           129:                                              SELECT(1,VAR v))),
        !           130:                                     SELECT(0,VAR v)));
        !           131:                   eqv
        !           132:               end)
        !           133:           | _ => raise Poly)
        !           134: 
        !           135:        val body = test(concreteType)
        !           136: 
        !           137:      in FIX(map (fn (_,VAR v,_) => v | _ => impossible "Equal #324") (!cache),
        !           138:            map (fn (_,_,e) => !e) (!cache),
        !           139:            body)
        !           140:     end
        !           141:     handle Poly => translatepath(!CoreInfo.polyequalPath)
        !           142:          | Syntax =>
        !           143:           (print "equal: type = ";
        !           144:            PrintType.resetPrintType();
        !           145:            PrintType.printType concreteType; print"\n";
        !           146:            RECORD[])
        !           147:                
        !           148: end (* struct *)
        !           149: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.