1(* Rtvals.sml *)
2
3open List Misc Obj BasicIO Nonstdio Miscsys Memory Fnlib Config Mixture;
4open Const Smlexc Globals Units Types Symtable;
5
6(* --- Run-time values --- *)
7
8(* Encoding and decoding *)
9
10fun decode_int (v : obj) = (magic_obj v : int);
11
12fun decode_word (v : obj) = (magic_obj v : word);
13
14fun decode_char (v : obj) = (magic_obj v : char);
15
16fun decode_real (v : obj) = (magic_obj v : real);
17
18fun decode_string (v : obj) = (magic_obj v : string);
19
20(* Exceptions *)
21
22fun decode_exn (v : obj) (c0 : QualifiedIdent -> unit)
23                         (c1 : QualifiedIdent -> obj -> Type option -> unit) =
24    let val strref = getExnStrref v
25	val arg = obj_field v 1
26	fun prExn exnPrName NONE         = c0 exnPrName
27	  | prExn exnPrName (SOME argTy) = c1 exnPrName arg (SOME argTy)
28    in prExn { qual = "", id = [!strref] } (Smlexc.exnArgType strref arg) end
29
30(* Run-time environments *)
31
32fun getGlobalVal (slot : int) =
33  Vector.sub(global_data, slot)
34;
35
36fun setGlobalVal (slot : int) (v : obj) =
37  let prim_val update_ : 'a Vector.vector -> int -> 'a -> unit
38                           = 3 "set_vect_item"
39  in update_ global_data slot v end
40;
41
42(* Block values *)
43
44fun decode_block (v : obj) =
45  if not(is_block v) then
46    fatalError "block expected"
47  else
48    let val len = obj_size v
49        fun makeArgs i =
50              if i>= len then [] else obj_field v i :: makeArgs (i+1)
51    in (obj_tag v, makeArgs 0) end
52;
53
54fun decode_unit (v : obj) = ();
55
56fun decode_pair (v : obj) = (magic_obj v : obj * obj);
57
58fun decode_boolean (v : obj) = (magic_obj v : bool);
59
60fun decode_list (v : obj) = (magic_obj v : obj list);
61
62fun decode_vector (v : obj) = (magic_obj v : obj Vector.vector);
63
64(* --- Value printing --- *)
65
66fun prSeq lbr rbr printer sep ts vs =
67  let fun loop [] [] = ()
68        | loop [t] [v] = printer t v
69        | loop (t :: ts) (v :: vs) =
70            (printer t v; msgString sep; msgBreak(1, 1); loop ts vs)
71        | loop _ _ = fatalError "prSeq: length mismatch"
72  in
73    msgIBlock 0; msgString lbr;
74    loop ts vs;
75    msgString rbr; msgEBlock()
76  end
77;
78
79fun prInt (v: obj) =
80  let val n = decode_int v
81  in msgString (sml_string_of_int n) end
82;
83
84fun prWord (v: obj) =
85  let val n = decode_word v
86  in msgString (sml_hexstring_of_word n) end
87;
88
89fun prChar (v : obj) =
90  let val c = decode_char v
91  in msgString (sml_makestring_of_char c) end
92;
93
94fun prReal (v : obj) =
95  let val r = decode_real v
96  in msgString (sml_string_of_float r) end
97;
98
99fun prString (v : obj) =
100  let val s = decode_string v
101  in msgString (sml_makestring_of_string s) end
102;
103
104fun prLiteralConst (depth: int) (v: obj) =
105  if not(is_block v) then
106    prInt v
107  else if depth <= 0 then
108    msgString "#"
109  else
110    let val tag = obj_tag v
111        val len = obj_size v
112    in
113      if tag = realTag then
114        prReal v
115      else if tag = stringTag then
116        prString v
117      else
118        (msgString "(BLOCK "; msgInt tag;
119         for (fn i => (msgString " ";
120                       prLiteralConst (depth-1) (obj_field v i)))
121             0 (len-1);
122         msgString ")")
123    end
124;
125
126fun printLiteralConst (v: obj) =
127  prLiteralConst 10 v
128;
129
130fun prGeneric (v : obj) =
131  if not(is_block v) then
132    msgString "<poly>"
133  else
134    let val tag = obj_tag v in
135      if tag = realTag then prReal v
136      else if tag = stringTag then prString v
137      else msgString "<poly>"
138    end
139;
140
141val installedPrinters = ref([] : (TyName * (ppstream -> obj -> unit)) list);
142
143fun findInstalledPrinter tyname =
144  let fun loop [] = NONE
145        | loop ((tyname', p) :: rest) =
146            if isEqTN tyname tyname' then (SOME p) else (loop rest)
147  in loop (!installedPrinters) end
148;
149
150val printDepth = ref 20;
151val printLength = ref 200;
152
153fun prVal (depth: int) (prior: int) (tau: Type) (v: obj) =
154  let fun prP s = if prior > 0 then msgString s else ()
155      fun prD f = if depth <= 0 then msgString "#" else f()
156      and prExn (e : obj) =			(* e : exn *)
157	  decode_exn (repr e)
158	             (fn q => (prP " "; printVQ q))
159	             (fn q => fn va => fn tyOpt =>
160		              (prP "(";
161			       printVQ q; msgString " ";
162			       (case tyOpt of
163				    NONE    => prGeneric va
164				  | SOME ty => prVal (depth-1) 1 ty va);
165			       prP ")" ))
166      fun prettyprint printer pp_out v =
167	  printer pp_out v
168	  handle e => (msgString "<installed prettyprinter failed: ";
169		       prExn (repr e); msgString ">")
170      val tau = normType tau
171  in
172    case tau of
173      VARt _ => (prP " "; prGeneric v)
174    | ARROWt _ => (prP " "; msgString "fn")
175    | RECt rt =>
176        let val {fields=fs, ...} = !rt
177            val (_, vs) = decode_block v
178        in
179          if isTupleRow fs then
180            (prD (fn() =>
181               prSeq "(" ")" (prTupleField (depth-1)) "," fs vs))
182          else
183            (prD (fn() =>
184               prSeq "{" "}" (prField (depth-1)) "," fs vs))
185        end
186    | CONt(ts, tyapp) =>
187        (case conEnvOfTyApp tyapp of
188           NONE =>
189            (case tyapp of
190		 NAMEtyapp tyname =>
191		     (case findInstalledPrinter tyname of
192			  SOME printer => prettyprint printer pp_out v
193			| NONE =>
194				if (isEqTN tyname tyname_int) then (prP " "; prInt v)
195				else if (isEqTN tyname tyname_word)
196					 then (prP " "; prWord v)
197                                else if (isEqTN tyname tyname_word8)
198					 then (prP " "; prWord v)
199				else if (isEqTN tyname tyname_char)
200					 then (prP " "; prChar v)
201				else if (isEqTN tyname tyname_real)
202					 then (prP " "; prReal v)
203				else if (isEqTN tyname tyname_string)
204					 then (prP " "; prString v)
205   			        else if (isEqTN tyname tyname_exn) then prExn v
206				else if (isEqTN tyname tyname_ref) then
207				    let val t = hd ts
208					val x = obj_field v 0
209				    in
210					prD (fn() =>
211					     (prP "(";printVQ (#qualid tyname);
212					      prVal (depth-1) 1 t x; prP ")"))
213				    end
214				else if (isEqTN tyname tyname_vector) then
215				    let val vs = decode_vector v in
216					prD (fn() =>
217					     (prP " ";
218					      prVector (depth-1)
219					               (!printLength)
220						       (hd ts)
221						       vs))
222				    end
223				else
224				    (msgString "<";
225				     msgString (hd (#id (#qualid tyname)));
226				     msgString ">"))
227	       | APPtyapp _ =>(msgString "<";
228			       prTyApp 0 tyapp;
229			       msgString ">"))
230         | SOME (ConEnv CE) =>
231             ( if (case tyapp of
232		       NAMEtyapp tyname =>
233			 (case findInstalledPrinter tyname of
234			       SOME printer => (prettyprint printer pp_out v;true)
235			     | NONE => false)
236		      | _ => false)
237		then ()
238		else
239                    if null CE then
240                      (msgString "<"; prTyApp 0 tyapp;
241                       msgString ">")
242                    else if #conSpan(! (#info (hd CE))) = 1 andalso
243                            #conArity(! (#info (hd CE))) = 1
244                    then
245                      let val ci = hd CE
246                          val {qualid, info} = ci
247                          val {conArity, conIsGreedy, conType, ...} = !info
248                      in
249                        case specialization conType of
250                            ARROWt(a_t, r_t) =>
251                              (unify tau r_t;
252                               (prD (fn() =>
253                                  (prP "("; printVQ qualid;
254                                   prVal (depth-1) 1 a_t v;
255                                   prP ")"))))
256                          | _ => fatalError "prVal"
257                      end
258                    else
259                      let val i = obj_tag v
260                          val ci = nth(CE, i)
261                          val {qualid, info} = ci
262                          val {conArity, conIsGreedy, conType, ...} = !info
263                      in
264                       if case tyapp of
265			   NAMEtyapp tyname =>
266			       if (isEqTN tyname tyname_list) then
267				   (prD (fn() =>
268					 (prP " ";
269					  prList (depth-1) (!printLength)
270					  (hd ts) (decode_list v)));
271				    true)
272			       else false
273			  | _ => false
274			then ()
275                        else if conArity = 0 then
276                          (prD (fn() => (prP " "; printVQ qualid)))
277                        else
278                          case specialization conType of
279                              ARROWt(a_t, r_t) =>
280                                (unify tau r_t;
281                                 (prD (fn() =>
282                                    (prP "("; printVQ qualid;
283                                     if conIsGreedy
284                                       then prVal (depth-1) 1 a_t v
285                                       else prVal (depth-1) 1 a_t (obj_field v 0);
286                                     prP ")"))))
287                            | _ => fatalError "prVal"
288                      end)
289	 | _ => fatalError "prVal 1")
290 | PACKt (EXISTSexmod(T,STRmod S)) =>  (prP " "; msgString "[structure ...]")
291 | PACKt (EXISTSexmod(T,FUNmod F)) =>  (prP " "; msgString "[functor ...]")
292end
293
294and prField (depth: int) (lab, t) v =
295  (msgIBlock 0; printLab lab; msgString " ="; msgBreak(1, 2);
296   prVal depth 0 t v; msgEBlock())
297
298and prTupleField (depth: int) (lab, t) v =
299  prVal depth 0 t v
300
301and prList (depth: int) (len: int) tau v =
302  case v of
303      [] => msgString "[]"
304    | x :: xs =>
305        if len <= 0 then
306          msgString "[...]"
307        else
308          (msgIBlock 0; msgString "["; prVal depth 0 tau x;
309           prListTail depth (len-1) tau xs)
310
311and prListTail (depth: int) (len: int) tau = fn
312    [] => (msgString "]"; msgEBlock())
313  | x :: xs =>
314      (msgString ","; msgBreak(1, 1);
315       if len <= 0 then
316         (msgString "...]"; msgEBlock())
317       else
318         (prVal depth 0 tau x; prListTail depth (len-1) tau xs))
319
320and prVector (depth: int) (maxlen: int) tau v =
321  let val len = Vector.length v
322      fun loop count i =
323        if i = len then msgString "]"
324        else if count <= 0 then
325          (msgString ","; msgBreak(1, 2); msgString "...]")
326        else
327          (msgString ","; msgBreak(1, 2);
328           prVal depth 0 tau (Vector.sub(v, i));
329           loop (count-1) (i+1))
330  in
331    msgIBlock 0;
332    if len = 0 then msgString "#[]"
333    else if maxlen <= 0 then msgString "#[...]" else
334      (msgString "#["; prVal depth 0 tau (Vector.sub(v, 0));
335       loop (maxlen-1) 1);
336    msgEBlock()
337  end
338;
339
340fun printVal (scheme: TypeScheme) (v: obj) =
341  prVal (!printDepth) 0 (specialization scheme) v
342;
343
344fun evalPrint (sc : obj) (v : obj) =
345  (printVal (magic_obj sc : TypeScheme) v; msgFlush(); v)
346;
347
348fun evalInstallPP (sc : obj) (p : ppstream -> 'a -> unit) =
349  case normType(specialization (magic_obj sc : TypeScheme)) of
350      CONt([], NAMEtyapp tyname) =>
351	  installedPrinters :=
352	  (tyname, magic p : ppstream -> obj -> unit)
353	  :: !installedPrinters
354(*
355      CONt([], NAMEtyapp tyname) =>
356        (case #tnStr(! (#info tyname)) of
357             DATATYPEts _ =>
358               installedPrinters :=
359                 (tyname, magic p : ppstream -> obj -> unit)
360                 :: !installedPrinters
361	   | NILts =>
362               installedPrinters :=
363                 (tyname, magic p : ppstream -> obj -> unit)
364                 :: !installedPrinters
365           | _ =>
366              raise Fail "installPP: pp's argument is not a nullary type constructor")
367*)
368    |  CONt(_ :: _, tyname) =>
369        raise Fail "installPP: pp's argument type is not a nullary type constructor"
370    | _ =>
371        raise Fail "installPP: pp's argument type is not a type constructor"
372;
373
374(* === End of Primitives === *)
375
376(* --- Handling global dynamic environment --- *)
377
378fun loadGlobalDynEnv uname env =
379(
380  app (fn(id,_) =>
381             ignore (get_slot_for_defined_variable ({qual=uname, id=[id]}, 0)))
382    env;
383  if number_of_globals() >= Vector.length global_data then
384      realloc_global_data(number_of_globals())
385  else ();
386  app (fn(id,v) =>
387            let val slot = get_slot_for_variable ({qual=uname, id=[id]}, 0)
388            in setGlobalVal slot v end)
389          env
390);
391
392fun resetGlobalDynEnv() = init_linker_tables();
393