![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to translate.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / translate|
Return to translate.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / translate |
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.