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