Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/C/Applications/Moscow ML 1.31/source code/mosml/src/compiler/Mixture.sml

Text File | 1996-07-03 | 6.1 KB | 248 lines | [TEXT/R*ch]

open BasicIO Nonstdio Fnlib Config PP;

exception Toplevel;
exception EndOfFile;
exception LexicalError of string * int * int;

val toplevel = ref false;

val pp_out = mk_ppstream
{
  linewidth = 79,
  flush     = fn() => flush_out std_out,
  consumer  = outputc std_out
};

fun msgCBlock offset = begin_block pp_out CONSISTENT offset;
fun msgIBlock offset = begin_block pp_out INCONSISTENT offset;
fun msgEBlock() = end_block pp_out;
fun msgBreak size_offset = add_break pp_out size_offset;
fun msgClear() = clear_ppstream pp_out;
fun msgFlush() = flush_ppstream pp_out;

val msgString = add_string pp_out;

fun msgChar (i : char) = msgString (String.str i);
fun msgInt  (i : int)  = msgString (makestring i);
fun msgReal (r : real) = msgString (makestring r);

fun msgEOL() = add_newline pp_out;

fun msgPrompt s =
  (if !toplevel then msgString toplevel_output_prompt
                else msgString batch_output_prompt;
  msgString s)
;

fun msgContPrompt s =
  (if !toplevel then msgString toplevel_output_cont_prompt
                else msgString batch_output_cont_prompt;
  msgString s)
;

fun errPrompt s =
  (if !toplevel then msgString toplevel_error_prompt
                else msgString batch_error_prompt;
  msgString s)
;

(* Handling files and directories *)

val path_library = ref "";
val load_path = ref ([] : string list);

fun cannot_find filename =
  raise (Fail ("Cannot find file "^filename))
;

fun find_in_path filename =
  if file_exists filename then
    filename
  else if Filename.is_absolute filename then
    cannot_find filename
  else
    let fun h [] =
              cannot_find filename
          | h (a::rest) =
              let val b = Filename.concat a filename in
                if file_exists b then b else h rest
              end
    in h (!load_path) end
;

fun remove_file f =
  Miscsys.remove f
    handle Io _ => ()
;

(* ---------- *)

datatype Lab =
    INTlab of int
  | STRINGlab of string
;

type 'a Row = (Lab * 'a) list;

fun printLab (STRINGlab s) = msgString s
  | printLab (INTlab i) = msgInt i
;

val labOne = INTlab 1
and labTwo = INTlab 2
;

fun isPairRow [(INTlab 1, _), (INTlab 2, _)] = true
  | isPairRow [(INTlab 2, _), (INTlab 1, _)] = true
  | isPairRow _ = false
;

fun isTupleRow' n [] = true
  | isTupleRow' n (((INTlab i), _) :: fs) =
      if n = i then isTupleRow' (n+1) fs else false
  | isTupleRow' n _ = false

fun isTupleRow fs =
  (List.length fs <> 1) andalso (isTupleRow' 1 fs)
;

fun mkPairRow x1 x2 = [(labOne, x1), (labTwo, x2)];

fun mkTupleRow' n [] = []
  | mkTupleRow' n (x :: xs) =
      (INTlab n, x) :: mkTupleRow' (n+1) xs
;

fun mkTupleRow xs = mkTupleRow' 1 xs;

fun lt_lab (STRINGlab s1) (STRINGlab s2)  = s1 < s2
  | lt_lab (STRINGlab _)  (INTlab _)      = true
  | lt_lab (INTlab _)     (STRINGlab _)   = false
  | lt_lab (INTlab i1)    (INTlab i2)     = i1 < i2
;

fun insertField (lab, x) fields =
  case fields of
      [] => [(lab, x)]
    | (lab', x') :: rest =>
        if lt_lab lab lab' then
          (lab, x) :: fields
        else if lt_lab lab' lab then
          (lab', x') :: insertField (lab, x) rest
        else
          fatalError "insertField"
;

fun sortRow row = foldL insertField [] row;

(* --- Local environments --- *)

datatype ('a, 'b) Env
  = NILenv
  | BNDenv of 'a * 'b * ('a, 'b) Env
  | TOPenv of ('a, 'b) Hasht.t * ('a, 'b) Env
  | COMPenv of ('a, 'b) Env * ('a, 'b) Env
;

fun plusEnv NILenv env2   = env2
  | plusEnv env1   NILenv = env1
  | plusEnv env1   env2   = COMPenv(env2, env1)
;

fun lookupEnv env key =
  let val rec search = fn
       NILenv => raise Subscript
     | BNDenv(k, v, env) =>
         if key = k then v else search env
     | TOPenv(x, env) =>
         (Hasht.find x key handle Subscript => search env)
     | COMPenv(env1, env2) =>
         (search env1 handle Subscript => search env2)
  in search env end
;

fun bindInEnv env k v = BNDenv(k, v, env);
fun bindTopInEnv env x = TOPenv(x, env);

fun mk1Env k v = BNDenv(k, v, NILenv);
fun mk1TopEnv x = TOPenv(x, NILenv);

fun revEnvAcc NILenv acc = acc
  | revEnvAcc (BNDenv(k, v, env)) acc =
      revEnvAcc env (BNDenv(k, v, acc))
  | revEnvAcc (TOPenv(x, env)) acc =
      revEnvAcc env (TOPenv(x, acc))
  | revEnvAcc (COMPenv(env1, env2)) acc =
      revEnvAcc env2 (revEnvAcc env1 acc)
;

fun revEnv env = revEnvAcc env NILenv;

fun domHashTbl tbl =
  let val dom = ref [] in
    Hasht.apply (fn key => fn v =>
      if member key (!dom) then () else dom := key :: !dom)
      tbl;
    !dom
  end;

fun traverseEnv action env =
  let fun traverse NILenv = ()
        | traverse (BNDenv(k, v, env)) =
            (action k v; traverse env)
        | traverse (TOPenv(x, env)) =
            let val dom = domHashTbl x in
              List.app (fn k => action k (Hasht.find x k)) dom;
              traverse env
            end
        | traverse (COMPenv(env1, env2)) =
            (traverse env1; traverse env2)
  in traverse env end
;

fun mapEnv f env0 =
  case env0 of
      NILenv => NILenv
    | BNDenv(k, v, env) =>
        bindInEnv (mapEnv f env) k (f k v)
    | TOPenv(x, env) =>
        let val dom = domHashTbl x in
          foldL (fn k => fn env => bindInEnv env k (f k (Hasht.find x k)))
                (mapEnv f env) dom
        end
    | COMPenv(env1, env2) =>
        COMPenv(mapEnv f env1, mapEnv f env2)
;

fun foldEnv f u env0 =
  case env0 of
      NILenv => u
    | BNDenv(k, v, env) =>
        f k v (foldEnv f u env)
    | TOPenv(x, env) =>
        let val dom = domHashTbl x in
          foldL (fn k => f k (Hasht.find x k)) (foldEnv f u env) dom
        end
    | COMPenv(env1, env2) =>
        foldEnv f (foldEnv f u env2) env1
;

(* --- Stamps of compiled signatures --- *)

type SigStamp = string;

val char_star = Char.chr 42;
val dummySigStamp = CharVector.tabulate(20, fn _ => char_star);

(* This table is used by `load' to prevent mismatching *)
(* versions of compiled units from being loaded, and also *)
(* to prevent the same unit from being loaded twice. *)

val watchDog = ref (Hasht.new 17 : (string, SigStamp) Hasht.t);

(* The list of automatically preloaded units. *)
(* Some of them are also preopened. *)

val preloadedUnits = ref ([] : string list);
val preopenedPreloadedUnits = ref ([] : string list);