![[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.