Return to translate.sml CVS log

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

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

1.1     ! root        1: (* Copyright 1989 by AT&T Bell Laboratories *)
        !             2: signature TRANSLATE = sig
        !             3:        val transDec : Absyn.dec -> Lambda.lexp -> Lambda.lexp
        !             4: end
        !             5: 
        !             6: structure Translate : TRANSLATE =
        !             7: struct
        !             8: open Access Absyn Lambda Basics BasicTypes Nonrec ErrorMsg Unboxed
        !             9: 
        !            10: val unitLexp = RECORD []
        !            11: 
        !            12: fun composeNOT (x) =  
        !            13:     let val v = mkLvar()
        !            14:     in FN(v,SWITCH(APP(x, VAR v),
        !            15:                    [(DATAcon falseDcon, CON(trueDcon,unitLexp)),
        !            16:                    (DATAcon trueDcon, CON(falseDcon,unitLexp))],NONE))
        !            17:     end
        !            18: 
        !            19: val elemgtr = (fn ((LABEL{number=x,...},_),(LABEL{number=y,...},_))=> x>y);
        !            20: val sorted = Sort.sorted elemgtr
        !            21: val sortrec = Sort.sort elemgtr
        !            22:                
        !            23: val [bogusID,matchsym,bindsym] = map Symbol.symbol ["bogus","Match","Bind"]
        !            24: 
        !            25: fun raisematch() = (WILDpat,RAISE(CON(!CoreInfo.exnMatch,unitLexp)))
        !            26: 
        !            27: fun reraise() =
        !            28:     let val v = mkLvar()
        !            29:     in (VARpat(VALvar{name=[bogusID],access=LVAR v, typ=ref UNDEFty}), RAISE(VAR v))
        !            30:     end
        !            31: 
        !            32: val printDepth = System.Control.Print.printDepth
        !            33: 
        !            34: fun translatepath [v] = VAR v
        !            35:   | translatepath (x::p) = SELECT(x,translatepath p)
        !            36:   | translatepath nil = impossible "translate.translatepath nil"
        !            37: 
        !            38: fun fill (APPpat(_,p)) = fill p
        !            39:   | fill (CONSTRAINTpat (p,_)) = fill p
        !            40:   | fill (LAYEREDpat (p,q)) = (fill p; fill q)
        !            41:   | fill (RECORDpat {pats = ref (_::_),...}) = ()
        !            42:   | fill (RECORDpat {fields,flex=false,pats,...}) =
        !            43:         pats := map (fn (_,p) => (fill p; p)) fields
        !            44:   | fill (pat as RECORDpat {fields,flex=true,typ,pats}) =
        !            45:        (app (fn (_,p) => fill p) fields;
        !            46:         let fun find (FLEXRECORDty(ref(CLOSED ty))) = find(ty)
        !            47:               | find (t as CONty(ref(TYCON{kind=RECORDtyc labels,...}),_)) = 
        !            48:                                (typ := t; labels)
        !            49:               | find _ = (PrintAbsyn.printPat(pat,!printDepth);
        !            50:                           condemn "unresolved flexible record")
        !            51:             fun merge (a as ((id,p)::r), lab::s) =
        !            52:                   if Symbol.eq(id,lab) then p :: merge(r,s) 
        !            53:                   else WILDpat :: merge(a,s)
        !            54:                | merge (nil, lab::s) = WILDpat :: merge(nil,s)
        !            55:               | merge (nil,nil) = nil
        !            56:               | merge _ = impossible "merge in translate"
        !            57:           in pats := (merge(fields, find(!typ)) handle Syntax => [WILDpat])
        !            58:          end)
        !            59:   | fill _ = ()
        !            60: 
        !            61: fun polyequal() = translatepath(!CoreInfo.polyequalPath)
        !            62: 
        !            63: fun getEqualElem (CONty(_,[CONty(_,[t,_]),_])) = t
        !            64:   | getEqualElem _ = VARty(ref(IBOUND 0))
        !            65: 
        !            66: fun thinStr(e,NONE) = e
        !            67:   | thinStr(e,SOME(v,locs)) = APP(FN(v,RECORD(map transLoc locs)), e)
        !            68: 
        !            69: and transLoc trans =
        !            70:  case trans
        !            71:    of VALtrans(PATH p) => translatepath p
        !            72:     | VALtrans(INLINE P.eql) => polyequal()
        !            73:     | VALtrans(INLINE P.neq) => composeNOT(polyequal())
        !            74:     | VALtrans(INLINE i) => PRIM i
        !            75:     | THINtrans(PATH p,v,locs) => thinStr(translatepath p, SOME(v,locs))
        !            76:     | CONtrans(d as DATACON{const=true,...}) => CON(d, unitLexp)
        !            77:     | CONtrans(d as DATACON{const=false,...}) => 
        !            78:         let val v = mkLvar() in FN(v,CON(d, VAR v)) end
        !            79:     | _ => impossible "transLoc in translate"
        !            80: 
        !            81: 
        !            82: 
        !            83: fun transStr (VARstr(STRvar{access=PATH(path),...})) = translatepath path
        !            84:   | transStr (STRUCTstr{body,locations}) = 
        !            85:                makedec (SEQdec body) (RECORD(map transLoc locations))
        !            86:   | transStr (APPstr{oper=FCTvar{access=LVAR(v),...},argexp,argthin}) =
        !            87:              APP(VAR v, thinStr(transStr argexp, argthin))
        !            88:   | transStr (LETstr(d,body)) = makedec d (transStr body)
        !            89:   | transStr _ = impossible "Translate.transStr"
        !            90: 
        !            91: and makedec (VALdec vbl) =
        !            92:     fold (fn (VB{pat=VARpat(VALvar{access=INLINE(_),...}),...},b) => b
        !            93:           | (VB{pat=CONSTRAINTpat(VARpat(VALvar{access=INLINE _,...}),_),
        !            94:                    exp=_,...},b) => b
        !            95:           | (VB{pat=VARpat(VALvar{access=LVAR v,...}),exp,...},b) => 
        !            96:                APP(FN(v,b), translate exp)
        !            97:           | (VB{pat,exp,...},b) => 
        !            98:              (fill pat; 
        !            99:               APP(MC.bindCompile 
        !           100:                   [(pat,b),(WILDpat,RAISE(CON(!CoreInfo.exnBind,unitLexp)))],
        !           101:                   translate exp)))
        !           102:         vbl
        !           103:   | makedec (a as VALRECdec rvbl) =
        !           104:       (makedec (nonrec a)
        !           105:        handle Isrec =>
        !           106:        (fn e => FIX(fold
        !           107:         (fn (RVB{var=VALvar{access=LVAR(var),...},exp,...}, (vlist,llist,lexp))
        !           108:               => (var::vlist,  translate exp :: llist,  lexp)
        !           109:           | _ => impossible "#73 in translate")
        !           110:         rvbl (nil,nil,e))))
        !           111:   | makedec (LOCALdec(localdec,visibledec)) = 
        !           112:           makedec(SEQdec[localdec,visibledec])
        !           113: 
        !           114:   | makedec (EXCEPTIONdec ebl) =
        !           115:       fold(fn (EBgen{exn=DATACON{rep=VARIABLE(LVAR v),name,const,...},...},lexp)=>
        !           116:                APP(FN(v,lexp),
        !           117:                    if const
        !           118:                    then RECORD[unitLexp,CON(refDcon,STRING (Symbol.name name))]
        !           119:                    else CON(refDcon,STRING (Symbol.name name)))
        !           120:            | (EBdef{exn=DATACON{rep=VARIABLE(LVAR v),...},
        !           121:                     edef=DATACON{rep=VARIABLE(PATH p),...}},
        !           122:               lexp) => APP(FN(v,lexp),translatepath p)
        !           123:            | _ => impossible "in makedec EXCEPTIONdec")
        !           124:          ebl
        !           125: 
        !           126:   | makedec (SEQdec decl) =
        !           127:      (* fold (fn (dec,exp) => makedec dec exp) decl *)
        !           128:       let fun f(a::r) = (makedec a) o (f r) | f nil = (fn e=>e) in f decl end
        !           129: 
        !           130:   | makedec (DATATYPEdec _) = (fn e => e)
        !           131:   | makedec (ABSTYPEdec{body,...}) = makedec body
        !           132:   | makedec (TYPEdec _) = (fn e => e)
        !           133:   | makedec (STRdec sbl) =
        !           134:       fold(fn (STRB{strvar=STRvar{access=LVAR(v),...},def,thin,...},lexp) =>
        !           135:              APP(FN(v,lexp),thinStr(transStr def, thin))
        !           136:            | _ => impossible "makedec(STRdec) in translate")
        !           137:          sbl
        !           138:   | makedec (ABSdec sbl) = makedec(STRdec sbl)
        !           139:   | makedec (FCTdec fbl) =
        !           140:       fold(fn (FCTB{fctvar=FCTvar{access=LVAR(v),binding,...},def,thin,
        !           141:                    param=STRvar{access=LVAR p,...},...},
        !           142:               lexp) =>
        !           143:               APP(FN(v,lexp),FN(p,thinStr(transStr def, thin)))
        !           144:            | _ => impossible "makedec(FCTdec) in translate")
        !           145:          fbl
        !           146:   | makedec (SIGdec _) = (fn e => e)
        !           147:   | makedec (OPENdec _) = (fn e => e)
        !           148:   | makedec (MARKdec(dec,a,b)) = makedec dec
        !           149: 
        !           150: and transrules rules = map (fn (RULE(p,e)) => ((fill p; p), translate e)) rules
        !           151: 
        !           152: and translate exp =
        !           153:   case exp 
        !           154:    of  INTexp i => INT i
        !           155:      | REALexp r => REAL r
        !           156:      | STRINGexp s => STRING s
        !           157:      | RECORDexp l =>
        !           158:        if sorted l
        !           159:        then RECORD(map (fn(_,e)=>translate e) l)
        !           160:        else let val vars = map (fn (l,e) => (l,(e,mkLvar()))) l
        !           161:                 fun bind ((_,(e,v)), x) = APP(FN(v, x), translate e)
        !           162:             in fold bind vars (RECORD(map (fn(_,(_,v))=>VAR v) (sortrec vars)))
        !           163:             end
        !           164:     | SEQexp [e] => translate e
        !           165:     | SEQexp (e::r) => APP(FN(mkLvar(), translate(SEQexp r)), translate e)
        !           166:     | APPexp(CONexp dcon, e) => CON (dcon, translate e)
        !           167:     | MARKexp(e,_,_) => translate e
        !           168:     | CONexp(dcon as DATACON{const=false,...}) =>
        !           169:        let val v = mkLvar () in FN(v,CON (dcon, VAR v)) end
        !           170:     | CONexp (dcon as DATACON{const=true,...}) => CON(dcon, unitLexp)
        !           171:     | VARexp (ref(VALvar{access=PATH(path),...})) => translatepath path
        !           172:     | VARexp (ref(VALvar{access=INLINE P.eql,typ=ref ty,...})) => 
        !           173:              Equal.equal(getEqualElem ty)
        !           174:     | VARexp (ref(VALvar{access=INLINE P.neq,typ=ref ty,...})) => 
        !           175:              composeNOT(Equal.equal(getEqualElem ty))
        !           176:     | VARexp (ref(VALvar{access=INLINE P.:=,typ=ref ty,...})) => 
        !           177:              PRIM(unboxedAssign ty)
        !           178:     | VARexp (ref(VALvar{access=INLINE P.update,typ=ref ty,...})) => 
        !           179:              PRIM(unboxedUpdate ty)
        !           180:     | VARexp (ref(VALvar{access=INLINE(n),typ=ref ty,...})) => PRIM n
        !           181:     | VARexp (ref(OVLDvar{name,...})) =>
        !           182:             (complain("unresolved overloading: "^Symbol.name name); unitLexp)
        !           183:     | APPexp (f,a) => APP(translate f, translate a)
        !           184:     | CONSTRAINTexp (e,t) => translate e
        !           185:     | HANDLEexp (e,HANDLER(FNexp l)) =>
        !           186:        let val rules = transrules l
        !           187:            fun anywild (WILDpat,_) = true
        !           188:              | anywild (VARpat _,_) = true
        !           189:              | anywild _ = false
        !           190:            val rules = if exists anywild rules then rules@[(WILDpat,unitLexp)]
        !           191:                        else rules@[reraise(),(WILDpat,unitLexp)]
        !           192:         in HANDLE (translate e, MC.matchCompile rules)
        !           193:        end
        !           194:     | RAISEexp e => RAISE (translate e)
        !           195:     | FNexp l => MC.matchCompile((transrules l)@[raisematch()])
        !           196:     | CASEexp (e,l) => APP(MC.matchCompile((transrules l)@[raisematch()]),
        !           197:                           translate e)
        !           198:     | LETexp (d,e) => makedec d (translate e)
        !           199:     | x => (PrintAbsyn.printExp(x,0,!printDepth); impossible "in translate")
        !           200: 
        !           201: val transDec = makedec
        !           202: 
        !           203: end (* structure Translate *)

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