![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to interp.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 / codegen|
Return to interp.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / codegen |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: structure Interp : sig val interp : Lambda.lexp -> 'a end = struct
3:
4:
5: open Access Basics Lambda ErrorMsg
6: structure U = System.Unsafe
7: val cast = U.cast
8: datatype 'a env = BIND of 'a env * lvar * 'a
9:
10: val MTENV : 'a env = cast()
11:
12: fun realc s =
13: let val (sign,s) = case explode s of "~"::rest => (~1.0,rest) | s => (1.0,s)
14: fun j(exp,d::dl,mant) = j(exp,dl,mant * 0.1 + real(d))
15: | j(0,nil,mant) = mant*sign
16: | j(exp,nil,mant) = if exp>0 then j(exp-1,nil,mant*10.0)
17: else j(exp+1,nil,mant*0.1)
18: fun h(esign,wholedigits,diglist,exp,nil) =
19: j(esign*exp+wholedigits-1,diglist,0.0)
20: | h(es,fd,dl,exp,d::s) = h(es,fd,dl,exp*10+(ord d - ord "0"),s)
21: fun g(i,r,"E"::"~"::s)=h(~1,i,r,0,s)
22: | g(i,r,"E"::s)=h(1,i,r,0,s)
23: | g(i,r,d::s) = g(i, (ord d - ord "0")::r, s)
24: | g(i,r,nil) = h(1,i,r,0,nil)
25: fun f(i,r,"."::s)=g(i,r,s)
26: | f(i,r,s as "E"::_)=g(i,r,s)
27: | f(i,r,d::s) = f(i+1,(ord(d)-ord("0"))::r,s)
28: in f(0,nil,s)
29: end
30:
31: fun look v =
32: let fun f(BIND(e,w,x)) = if v=w then x else f e
33: in f
34: end
35:
36: val upd = BIND
37:
38: val rec M =
39: fn APP(FN(v,b),a) => let val a' = M a and b' = M b
40: in fn r => cast(b' (upd(r,v, cast (a' r))))
41: end
42: | APP(a,b) => cast let val a' = cast(M a) and b' = M b
43: in fn r => cast((a' r) (b' r))
44: end
45: | FN(v,b) => let val b' = M b
46: in fn r => cast (fn x => b' (upd(r,v,x)))
47: end
48: | SELECT(i,a) => let val a' = cast(M a)
49: in fn r => cast(U.subscript(a' r, i))
50: end
51: | RECORD nil => (fn r => cast())
52: | RECORD [a,b] => let val a' = M a and b' = M b
53: in fn r => cast (a' r, b' r)
54: end
55: | RECORD [a,b,c] => let val a' = M a and b' = M b and c' = M c
56: in fn r => cast (a' r, b' r, c' r)
57: end
58: | RECORD [a,b,c,d] => let val a' = M a and b' = M b
59: and c' = M c and d' = M d
60: in fn r => cast (a' r, b' r, c' r, d' r)
61: end
62: | RECORD [a,b,c,d,e] => let val a' = M a and b' = M b
63: and c' = M c and d' = M d
64: and e' = M e
65: in fn r => cast (a' r, b' r, c' r, d' r, e' r)
66: end
67: | RECORD [a,b,c,d,e,f] => let val a' = M a and b' = M b
68: and c' = M c and d' = M d
69: and e' = M e and f' = M f
70: in fn r => cast (a' r, b' r, c' r, d' r, e' r, f' r)
71: end
72: | RECORD l => let val l' = map M l
73: in fn r => (cast arrayoflist)(map (fn x => x r) l')
74: end
75: | INT i => (fn r => cast i)
76: | STRING s => (fn r => cast s)
77: | REAL s => let val x = realc s in fn r => cast x end
78: | PRIM P.cast => (fn r => cast(fn x => x))
79: | PRIM P.+ => (fn r => cast Integer.+)
80: | PRIM P.- => (fn r => cast Integer.-)
81: | PRIM P.* => (fn r => cast Integer.*)
82: | PRIM P.div => (fn r => cast Integer.div)
83: | PRIM P.orb => (fn r => cast Bits.orb)
84: | PRIM P.andb => (fn r => cast Bits.andb)
85: | PRIM P.xorb => (fn r => cast Bits.xorb)
86: | PRIM P.rshift => (fn r => cast Bits.rshift)
87: | PRIM P.lshift => (fn r => cast Bits.lshift)
88: | PRIM P.! => (fn r => cast !)
89: | PRIM P.:= => (fn r => cast op :=)
90: | PRIM P.unboxedassign => (fn r => cast op :=)
91: | PRIM P.makeref => (fn r => cast ref)
92: | PRIM P.~ => (fn r => cast Integer.~)
93: | PRIM P.ieql => (fn r => cast (fn(a:int,b) => a=b))
94: | PRIM P.ineq => (fn r => cast (fn(a:int,b) => a<>b))
95: | PRIM P.> => (fn r => cast Integer.>)
96: | PRIM P.< => (fn r => cast Integer.<)
97: | PRIM P.>= => (fn r => cast Integer.>=)
98: | PRIM P.<= => (fn r => cast Integer.<=)
99: | PRIM P.subscript => (fn r => cast U.subscript)
100: | PRIM P.update => (fn r => cast U.update)
101: | PRIM P.unboxedupdate => (fn r => cast U.update)
102: | PRIM P.alength => (fn r => cast Array.length)
103: | PRIM P.slength => (fn r => cast String.size)
104: | PRIM P.store => (fn r => cast U.store)
105: | PRIM P.ordof => (fn r => cast U.ordof)
106: | PRIM P.fneg => (fn r => cast Real.~)
107: | PRIM P.fadd => (fn r => cast Real.+)
108: | PRIM P.fdiv => (fn r => cast Real./)
109: | PRIM P.fmul => (fn r => cast Real.*)
110: | PRIM P.fsub => (fn r => cast Real.-)
111: | PRIM P.feql => (fn r => cast (fn(a:real,b)=>a=b))
112: | PRIM P.fneq => (fn r => cast (fn(a:real,b)=>a<>b))
113: | PRIM P.fgt => (fn r => cast Real.>)
114: | PRIM P.fge => (fn r => cast Real.>=)
115: | PRIM P.fle => (fn r => cast Real.<=)
116: | PRIM P.flt => (fn r => cast Real.<)
117: | PRIM P.boxed => (fn r => cast U.boxed)
118: | PRIM P.callcc => (fn r => cast callcc)
119: | PRIM P.throw => (fn r => cast throw)
120: | PRIM _ => impossible "bad primop in interp"
121: | VAR v => look v
122: | HANDLE(a,b) => let val a' = cast (M a) and b' = cast(M b)
123: in fn r => (a' r handle e => b' r e)
124: end
125: | RAISE a => let val a' = cast (M a) in fn r => raise(a' r) end
126: | FIX(nl,fl,b) =>
127: let fun g(n::nl,f::fl) = let val f' = M f
128: val fl' = g(nl,fl)
129: in fn rr => cast (upd(fl' rr,n,
130: fn x => cast(f'(!rr)) x))
131: end
132: | g(nil,_) = cast(fn rr => !rr)
133: val l = g(nl,fl)
134: val b' = cast(M b)
135: in fn r => cast (let val rr = ref (cast r)
136: in rr := l (cast rr); b'(!rr)
137: end)
138: end
139: | SWITCH(e,l as (DATAcon(DATACON{rep=VARIABLE _,...}), _)::_, SOME d) =>
140: let fun trans(DATAcon(DATACON{rep=VARIABLE(PATH p), const=true,...}), a)=
141: (rev(1::p), M a)
142: | trans(DATAcon(DATACON{rep=VARIABLE(PATH p), const=false,...}), a)=
143: (rev p, M a)
144: val cases = map trans l and d' = M d and e' = M e
145: in fn r => cast(let val e'' : int = U.subscript(cast(e' r),1)
146: fun select(x,i::rest) = select(U.subscript(cast x,i),rest)
147: | select(x,nil) = cast x
148: fun find ((v::path, answer)::rest) =
149: if select(look v r,path)=e'' then answer r
150: else find rest
151: | find nil = d' r
152: in find cases
153: end)
154: end
155: | SWITCH(e,l as (REALcon _, _)::_, SOME d) =>
156: let fun trans(REALcon i, a)= (realc i, M a)
157: val cases = map trans l and d' = M d and e' = M e
158: in fn r => cast (let val e'':real = cast(e' r)
159: fun find ((i, answer)::rest) =
160: if i=e'' then answer r else find rest
161: | find nil = d' r
162: in find cases
163: end)
164: end
165: | SWITCH(e,l as (INTcon _, _)::_, SOME d) =>
166: let fun trans(INTcon i, a)= (i, M a)
167: val cases = map trans l and d' = M d and e' = M e
168: in fn r => cast (let val e'':int = cast(e' r)
169: fun find ((i, answer)::rest) =
170: if i=e'' then answer r else find rest
171: | find nil = d' r
172: in find cases
173: end)
174: end
175: | SWITCH(e,l as (STRINGcon _, _)::_, SOME d) =>
176: let fun trans(STRINGcon i, a)= (i, M a)
177: val cases = map trans l and d' = M d and e' = M e
178: in fn r => cast(let val e'':string = cast(e' r)
179: fun find ((i, answer)::rest) =
180: if i=e'' then answer r else find rest
181: | find nil = d' r
182: in find cases
183: end)
184: end
185: | SWITCH(e, l as (DATAcon(DATACON _), _)::_, d) =>
186: let val d' = case d of SOME d0 => M d0
187: | NONE => fn r => impossible "no default in interp"
188: val e' = M e
189: fun f((DATAcon(DATACON{rep=CONSTANT i,...}),ans)::rest) =
190: let val rest' = f rest
191: val ans' = M ans
192: in fn x => if x=i then ans' else rest' x
193: end
194: | f((DATAcon(DATACON{rep=TAGGED i,...}),ans)::rest) =
195: let val rest' = f rest
196: val ans' = M ans
197: in fn x => if U.boxed x andalso U.subscript(cast x,1)=i
198: then ans' else rest' x
199: end
200: | f((DATAcon(DATACON{rep=TRANSPARENT,...}),ans)::rest) =
201: let val rest' = f rest
202: val ans' = M ans
203: in fn x => if U.boxed x
204: then ans' else rest' x
205: end
206: | f((DATAcon(DATACON{rep=TRANSB,...}),ans)::rest) =
207: let val rest' = f rest
208: val ans' = M ans
209: in fn x => if U.boxed x
210: then ans' else rest' x
211: end
212: | f nil = fn x => d'
213: val cases = f l
214: in fn r => cases(e' r) r
215: end
216:
217: fun interp lexp = cast(M lexp MTENV)
218:
219:
220: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.