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