Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/C/Applications/Moscow ML 1.42/src/compiler/Compiler.sml

Text File | 1997-08-18 | 12.7 KB | 450 lines | [TEXT/R*ch]

(* Compiler.sml *)

open List Obj BasicIO Nonstdio Fnlib Mixture Const Globals Location Units;
open Types Smlperv Asynt Parser Ovlres Infixres Elab Sigmtch;
open Tr_env Front Back Pr_zam Emit_phr;

(* Lexer of stream *)

fun createLexerStream (is : BasicIO.instream) =
  Lexing.createLexer (fn buff => fn n => Nonstdio.buff_input is buff 0 n)
;

(* Parsing functions *)

fun parsePhrase parsingFun lexingFun lexbuf =
  let fun skip() =
    (case lexingFun lexbuf of
        EOF => ()
      | SEMICOLON => ()
      | _ => skip())
    handle LexicalError(_,_,_) =>
      skip()
  in
    parsingFun lexingFun lexbuf
    handle
        Parsing.ParseError f =>
           let val pos1 = Lexing.getLexemeStart lexbuf
               val pos2 = Lexing.getLexemeEnd lexbuf
           in
             Lexer.resetLexerState();
             if f (Obj.repr EOF) orelse
                f (Obj.repr SEMICOLON)
             then () else skip();
             msgIBlock 0;
             errLocation (Loc(pos1, pos2));
             errPrompt "Syntax error.";
             msgEOL();
             msgEBlock();
             raise Toplevel
           end
       | LexicalError(msg, pos1, pos2) =>
           (msgIBlock 0;
            if pos1 >= 0 andalso pos2 >= 0 then
              errLocation (Loc(pos1, pos2))
            else ();
            errPrompt "Lexical error: "; msgString msg;
            msgString "."; msgEOL();
            msgEBlock();
            skip();
            raise Toplevel)
       | Toplevel =>
           (skip ();
            raise Toplevel)
  end
;

fun parsePhraseAndClear parsingFun lexingFun lexbuf =
  let val phr =
    parsePhrase parsingFun lexingFun lexbuf
    handle x => (Lexer.resetLexerState(); Parsing.clearParser(); raise x)
  in
    Lexer.resetLexerState();
    Parsing.clearParser();
    phr
  end;

val parseToplevelPhrase =
  parsePhraseAndClear Parser.ToplevelPhrase Lexer.Token
;

val parseStructFile =
  parsePhraseAndClear Parser.StructFile Lexer.Token
;

val parseSigFile =
  parsePhraseAndClear Parser.SigFile Lexer.Token
;

fun isInTable key tbl =
  (Hasht.find tbl key; true)
  handle Subscript => false
;

fun filter p xs =
  rev(foldL (fn x => fn acc => if p x then x::acc else acc) [] xs)
;

fun filterExcRenList excRenList cBas =
  filter (fn ({qual, id}, _) => isInTable id cBas) excRenList
;

fun filterValRenList valRenList cBas =
  filter (fn (id, stamp) => isInTable id cBas) valRenList
;

fun cleanEnvAcc [] acc = acc
  | cleanEnvAcc ((k, v) :: rest) acc =
      if exists (fn (k', _) => k = k') acc then
        cleanEnvAcc rest acc
      else
        cleanEnvAcc rest ((k, v) :: acc)
;

fun cleanEnv env =
  cleanEnvAcc (foldEnv (fn a => fn x => fn acc => (a,x)::acc) [] env) []
;

(* Reporting the results of compiling a phrase *)

val verbose = ref false;

fun reportFixityResult (id, status) =
(
  (case status of
       NONFIXst =>
         msgString "nonfix "
     | INFIXst i =>
         (msgString "infix ";
          msgInt i; msgString " ")
     | INFIXRst i =>
         (msgString "infixr ";
          msgInt i; msgString " "));
  msgString id
);

fun reportEquOfType equ =
  msgString
    (case equ of
         FALSEequ => ""
       | TRUEequ => "eq"
       | REFequ => "prim_EQ")
;

fun reportLhsOfTypeResult (tyname : TyName) =
  let val vs = newTypeVars (#tnArity (!(#info tyname)))
      val lhs = type_con (map TypeOfTypeVar vs) tyname
  in printType lhs end
;

fun reportTypeResult (tyname : TyName) =
  let val {qualid, info} = tyname
      val {tnEqu, tnStr, ...} = !info
  in
    case tnStr of
        NILts =>
          (reportEquOfType tnEqu;
           msgString "type ";
           reportLhsOfTypeResult tyname)
      | TYPEts(vs, tau) =>
          let val lhs = type_con (map TypeOfTypeVar vs) tyname in
            msgString "type ";
            resetTypePrinter();
            collectExplicitVars lhs;
            collectExplicitVars tau;
            printNextType lhs; msgString " ="; msgBreak(1, 2);
            printNextType tau;
            resetTypePrinter()
          end
      | DATATYPEts dt =>
          let val uname = #qual qualid
              val sign = if uname = currentUnitName()
                        then (!currentSig)
                        else findSig Location.nilLocation uname
              val CE = findConstructors sign dt
          in
            if null CE then
              (msgString "abstype ";
               reportLhsOfTypeResult tyname)
            else
              (msgString "datatype ";
               reportLhsOfTypeResult tyname)
          end
      | REAts _ =>
             fatalError "reportTypeResult"
  end
;

fun lookup_new_cBas cBas id =
  (lookupEnv cBas id : ConStatus)
  handle Subscript => fatalError "lookup_new_cBas"
;

fun report_comp_results iBas cBas static_VE static_TE =
(
  app (fn x =>
         (msgIBlock 0; reportFixityResult x; msgEOL(); msgEBlock()))
      (cleanEnv iBas);
  app (fn (id, tn) =>
         (msgIBlock 0; reportTypeResult tn; msgEOL(); msgEBlock()))
      (cleanEnv static_TE);
  app
    (fn (id, sch) =>
       let val status = lookup_new_cBas cBas id in
         msgIBlock 0;
         msgCBlock 0;
         msgString
           (case #info status of
               VARname  _ => "val "
             | PRIMname _ => "val "
             | CONname  _ => "con "
             | EXNname  _ => "exn "
             | REFname    => "con ");
         msgString id;
         msgString " :"; msgBreak(1, 2); printScheme sch;
         msgEBlock();
         msgEOL();
         msgEBlock()
       end)
    (cleanEnv static_VE);
    msgFlush()
);

(* To write the signature of the unit currently compiled *)
(* The same value has to be written twice, because it's unclear *)
(* how to `open` a file in "read/write" mode in a Caml Light program. *)

fun writeCompiledSignature filename_ui =
  let val sigStamp = ref dummySigStamp
      val sigLen = ref 0
  in
    let val os = open_out_bin filename_ui in
      (output_value os (!currentSig);
       sigLen := pos_out os;
       close_out os)
      handle x =>
        (close_out os;
         remove_file filename_ui;
         raise x)
    end;
    let val is = open_in_bin filename_ui in
      let val sigImage = input(is, !sigLen)
      prim_val md5sum_ : string -> string = 1 "md5sum"
      in
        if size sigImage < !sigLen then raise Size else ();
        close_in is;
        remove_file filename_ui;
        sigStamp := md5sum_ sigImage
      end
      handle x =>
        (close_in is;
         remove_file filename_ui;
         raise x)
    end;
    let val os = open_out_bin filename_ui in
      (output(os, !sigStamp);
       output_value os (!currentSig);
       close_out os)
      handle x =>
        (close_out os;
         remove_file filename_ui;
         raise x)
    end;
    !sigStamp
  end;

(* Checks and error messages for compiling units *)

fun checkUnitId msg (locid as (loc, id)) uname =
    if id <> uname then
    (msgIBlock 0;
     errLocation loc;
     errPrompt "Error: "; msgString msg;
     msgString " name and file name are incompatible";
     msgEOL();
     msgEBlock();
     raise Toplevel)
    else ();

fun checkExists filename_ui filename_sig filename_sml =
    if not(file_exists filename_ui) then
    (msgIBlock 0;
     errPrompt "File "; msgString filename_sig;
     msgString " must be compiled before ";
     msgString filename_sml; msgEOL();
     msgEBlock();
     raise Toplevel)
    else ();

fun checkNotExists filename_sig filename_sml =
    if file_exists filename_sig then
    (msgIBlock 0;
     errPrompt "File "; msgString filename_sig;
     msgString " exists, but there is no signature constraint in ";
     msgString filename_sml; msgEOL();
     msgEBlock();
     raise Toplevel)
    else ();

(* Compiling a signature *)

fun compileSpecPhrase spec =
  let val (iBas, cBas) = resolveToplevelSpec spec
      val (VE, TE) = elabToplevelSpec spec
  in
    updateCurrentInfixBasis iBas;
    extendCurrentConBasis cBas;
    extendCurrentStaticTE TE;
    updateCurrentStaticVE VE;
    if !verbose then
      (report_comp_results iBas cBas VE TE;
       msgFlush())
    else ()
  end
;

fun compileSignature uname filename =
  let
      val source_name = filename ^ ".sig"
      val target_name = filename ^ ".ui"
      (* val () = (msgIBlock 0;
                   msgString "[compiling file \""; msgString source_name;
                   msgString "\"]"; msgEOL(); msgEBlock();) *)
      val () = startCompilingUnit uname
      val () = initInitialEnvironments()
      val is = open_in_bin source_name
      val () = remove_file target_name;
      val lexbuf = createLexerStream is
      fun compileSig (AnonSig specs) =
      app compileSpecPhrase specs
    | compileSig (NamedSig{locsigid, specs}) =
      (checkUnitId "signature" locsigid uname;
       app compileSpecPhrase specs)
  in
       input_name   := source_name;
       input_stream := is;
       input_lexbuf := lexbuf;
       (compileSig (parseSigFile lexbuf);
        ignore (rectifySignature ());
        ignore (writeCompiledSignature target_name);
        close_in is)
       handle x => (close_in is; raise x)
  end
;

(* Compiling an implementation *)

(* This is written in tail-recursive form to ensure *)
(* that the intermediate results will be discarded. *)

fun updateCurrentCompState ((iBas, cBas, VE, TE), RE) =
(
  updateCurrentInfixBasis iBas;
  updateCurrentConBasis cBas;
  updateCurrentStaticTE TE;
  updateCurrentStaticVE VE;
  updateCurrentRenEnv RE;
  if !verbose then
    (report_comp_results iBas cBas VE TE;
     msgFlush())
  else ()
);

fun compLamPhrase os state (RE, lams) =
(
  app
    (fn (is_pure, lam) =>
       ((* msgIBlock 0; printLam lam; msgEOL(); msgEBlock(); *)
       emit_phrase os
         let val zam = compileLambda is_pure lam in
           (* printZamPhrase zam; msgFlush(); *)
           zam
         end))
    lams;
    updateCurrentCompState (state, RE)
);

fun compResolvedDecPhrase os (iBas, cBas, dec) =
  let val (VE, TE) = elabToplevelDec dec in
    resolveOvlDec dec;
    compLamPhrase os (iBas, cBas, VE, TE) (translateToplevelDec dec)
  end
;

fun compileImplPhrase os dec =
  compResolvedDecPhrase os (resolveToplevelDec dec)
;

fun compileAndEmit uname filename specSig_opt decs =
  let
    val filename_ui  = filename ^ ".ui"
    val filename_uo  = filename ^ ".uo"
    (* val () = (msgIBlock 0;
                 msgString "[compiling file \""; msgString filename_sml;
                 msgString "\"]"; msgEOL(); msgEBlock()) *)
    val () = startCompilingUnit uname
    val () = initInitialEnvironments()
    val os = open_out_bin filename_uo
  in
    ( start_emit_phrase os;
      app (compileImplPhrase os) decs;
      let val (excRenList, valRenList) = rectifySignature() in
          (case specSig_opt of
               NONE =>
                 let val sigStamp = writeCompiledSignature filename_ui in
                   end_emit_phrase
                     excRenList valRenList
                     sigStamp (#uMentions (!currentSig))
                     os
                 end
             | SOME specSig =>
                 let val {uConBasis, uStamp, ...} = specSig in
                   matchSignature os (!currentSig) specSig;
                   end_emit_phrase
                     (filterExcRenList excRenList uConBasis)
                     (filterValRenList valRenList uConBasis)
                     (getOption (!uStamp)) (#uMentions (!currentSig))
                     os
                 end);
          close_out os
        end
    )
    handle x => (close_out os; remove_file filename_uo; raise x)
  end;

fun compileUnitBody uname filename =
  let val filename_sig = filename ^ ".sig"
      val filename_ui  = filename ^ ".ui"
      val filename_sml = filename ^ ".sml"
      val is = open_in_bin filename_sml
      val lexbuf = createLexerStream is
      fun compileStruct (AnonStruct decs) =
      if file_exists filename_sig then
          (hasSpecifiedSignature := true;
           checkExists filename_ui filename_sig filename_sml;
           compileAndEmit uname filename (SOME (readSig uname)) decs)
      else
          (hasSpecifiedSignature := false;
           remove_file filename_ui;
           compileAndEmit uname filename NONE decs)
    | compileStruct (NamedStruct{locstrid, locsigid = NONE, decs}) =
      (checkUnitId "structure" locstrid uname;
       checkNotExists filename_sig filename_sml;
       hasSpecifiedSignature := false;
       remove_file filename_ui;
       compileAndEmit uname filename NONE decs)
    | compileStruct (NamedStruct _) = fatalError "compileUnitBody"
    | compileStruct (Abstraction{locstrid, locsigid, decs}) =
      (checkUnitId "structure" locstrid uname;
       checkUnitId "signature" locsigid uname;
       checkExists filename_ui filename_sig filename_sml;
       hasSpecifiedSignature := true;
       compileAndEmit uname filename (SOME (readSig uname)) decs)
  in
      input_name := filename_sml;
      input_stream := is;
      input_lexbuf := lexbuf;
      (compileStruct (parseStructFile lexbuf))
      handle x => (close_in is; raise x)
  end;