Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/benchmarks/programs/ray/interp.sml
ViewVC logotype

Annotation of /sml/trunk/benchmarks/programs/ray/interp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 193 - (view) (download)

1 : monnier 193 (* interp.sml
2 :     *
3 :     * COPYRIGHT (c) 1992 AT&T Bell Laboratories
4 :     *)
5 :    
6 :     structure Interp =
7 :     struct
8 :    
9 :     local
10 :     val exit = OS.Process.exit
11 :     fun ordof(s, i) = Char.ord(String.sub(s, i))
12 :     exception NotAChar
13 :     exception NotAReal
14 :     fun fromStr x =
15 :     (case Char.fromString x
16 :     of SOME c => c
17 :     | NONE => raise NotAChar)
18 :    
19 :     fun strToReal s =
20 :     (case Real.fromString s
21 :     of SOME r => r
22 :     | _ => raise NotAReal)
23 :    
24 :     fun intToReal x =
25 :     (strToReal ((Int.toString x) ^ ".0"))
26 :    
27 :    
28 :     val explode = (fn x => map Char.toString (explode x))
29 :     val implode = (fn x => implode (map fromStr x))
30 :    
31 :     open Objects
32 :     val dict = ref ([] : {key : string, value : object} list)
33 :     fun dictInsert (NAME key, value) = let
34 :     fun find [] = [{key=key, value=value}]
35 :     | find (x::r) = if (key = #key x)
36 :     then {key=key, value=value}::r
37 :     else x :: (find r)
38 :     in
39 :     dict := find(!dict)
40 :     end
41 :     | dictInsert _ = raise Fail "dictInsert"
42 :     fun prObj outStrm obj = let
43 :     fun printf args = TextIO.output(outStrm, implode args)
44 :     fun pr (NUMBER n) = printf[" ", Real.toString n, "\n"]
45 :     | pr (NAME s) = printf[" ", s, "\n"]
46 :     | pr (LITERAL s) = printf[" ", s, "\n"]
47 :     | pr (LIST l) = app pr l
48 :     | pr MARK = printf[" MARK\n"]
49 :     | pr (OPERATOR _) = printf[" <operator>\n"]
50 :     | pr TOP = printf[" TOP OF STACK\n"]
51 :     | pr _ = printf[" <object>\n"]
52 :     in
53 :     pr obj
54 :     end
55 :     in
56 :    
57 :     exception Stop
58 :    
59 :     fun error opName stk = let
60 :     fun prStk ([], _) = ()
61 :     | prStk (_, 0) = ()
62 :     | prStk (obj::r, i) = (prObj TextIO.stdErr obj; prStk(r, i-1))
63 :     in
64 :     TextIO.output(TextIO.stdErr, "ERROR: "^opName^"\n");
65 :     prStk (stk, 10);
66 :     raise (Fail opName)
67 :     end
68 :    
69 :     fun installOperator (name, rator) =
70 :     dictInsert (NAME name, OPERATOR rator)
71 :    
72 :     fun ps_def (v::k::r) = (dictInsert(k, v); r)
73 :     | ps_def stk = error "ps_def" stk
74 :    
75 :     local
76 :     fun binOp (f, opName) = let
77 :     fun g ((NUMBER arg1)::(NUMBER arg2)::r) =
78 :     NUMBER(f(arg2, arg1)) :: r
79 :     | g stk = error opName stk
80 :     in
81 :     g
82 :     end
83 :     in
84 :     val ps_add = binOp (op +, "add")
85 :     val ps_sub = binOp (op -, "sub")
86 :     val ps_mul = binOp (op *, "mul")
87 :     val ps_div = binOp (op /, "div")
88 :     end
89 :    
90 :     fun ps_rand stk = (NUMBER 0.5)::stk (** ??? **)
91 :    
92 :     fun ps_print (obj::r) = (prObj TextIO.stdOut obj; r)
93 :     | ps_print stk = error "print" stk
94 :    
95 :     fun ps_dup (obj::r) = (obj::obj::r)
96 :     | ps_dup stk = error "dup" stk
97 :    
98 :     fun ps_stop _ = raise Stop
99 :    
100 :     (* initialize dictionary and begin parsing input *)
101 :     fun parse inStrm = let
102 :     fun getc () = case TextIO.input1 inStrm of NONE => ""
103 :     | SOME c => Char.toString c
104 :     fun peek () = case TextIO.lookahead inStrm
105 :     of SOME x => Char.toString x
106 :     | _ => ""
107 :     (* parse one token from inStrm *)
108 :     fun toke deferred = let
109 :     fun doChar "" = exit 0
110 :     | doChar "%" = let
111 :     fun lp "\n" = doChar(getc())
112 :     | lp "" = exit 0
113 :     | lp _ = lp(getc())
114 :     in
115 :     lp(getc())
116 :     end
117 :     | doChar "{" = (MARK, deferred+1)
118 :     | doChar "}" = (UNMARK, deferred-1)
119 :     | doChar c = if Char.isSpace (fromStr c)
120 :     then doChar(getc())
121 :     else let
122 :     fun lp buf = (case peek()
123 :     of "{" => buf
124 :     | "}" => buf
125 :     | "%" => buf
126 :     | c => if Char.isSpace(fromStr c)
127 :     then buf
128 :     else (getc(); lp(c::buf))
129 :     (* end case *))
130 :     val tok = implode (rev (lp [c]))
131 :     val hd = ordof(tok, 0)
132 :     in
133 :     if (hd = ord (#"/"))
134 :     then (LITERAL(substring(tok, 1, size tok - 1)), deferred)
135 :     else
136 :     if ((Char.isDigit (chr hd)) orelse (hd = ord (#"-")))
137 :     then (NUMBER(strToReal(tok)), deferred)
138 :     else (NAME tok, deferred)
139 :     end
140 :     in
141 :     doChar(getc())
142 :     end
143 :     (* execute a token (if not deferred) *)
144 :     fun exec (UNMARK, stk, _) = let
145 :     fun lp ([], _) = raise Fail "MARK"
146 :     | lp (MARK::r, l) = (LIST l)::r
147 :     | lp (x::r, l) = lp (r, x::l)
148 :     in
149 :     lp (stk, [])
150 :     end
151 :     | exec (OPERATOR f, stk, 0) = f stk
152 :     | exec (LIST l, stk, 0) = let
153 :     fun execBody ([], stk) = stk
154 :     | execBody (obj::r, stk) = (exec(obj, stk, 0); execBody(r, stk))
155 :     in
156 :     execBody (l, stk)
157 :     end
158 :     | exec (NAME s, stk, 0) = let
159 :     fun find [] = raise Fail "undefined name"
160 :     | find ({key, value}::r) = if (key = s) then value else find r
161 :     in
162 :     exec (find (!dict), stk, 0)
163 :     end
164 :     | exec (obj, stk, _) = obj::stk
165 :     fun lp (stk, level) = let
166 :     val (obj, level) = toke level
167 :     val stk = exec (obj, stk, level)
168 :     in
169 :     lp (stk, level)
170 :     end
171 :     in
172 :     installOperator ("add", ps_add);
173 :     installOperator ("def", ps_def);
174 :     installOperator ("div", ps_div);
175 :     installOperator ("dup", ps_dup);
176 :     installOperator ("mul", ps_mul);
177 :     installOperator ("print", ps_print);
178 :     installOperator ("rand", ps_rand);
179 :     installOperator ("stop", ps_stop);
180 :     installOperator ("sub", ps_sub);
181 :     (lp ([], 0)) handle Stop => ()
182 :     end (* parse *)
183 :    
184 :     end (* local *)
185 :    
186 :     end (* Interp *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0