% ML Compiler ($Header: /a/rathlin/disk/src/master/edml/EDML4/EdinburghML/UPTODATE/RCS/mlmain.ml,v 2.1 91/09/06 14:20:45 edml Exp $)%

let MLParserPhase(MLState) = (
   Timings.Parser := CpuTime();
   if !Print.Space then Space.Parser := StoreAllocated() else ();
   if !Print.TraceML then (outtok(`ML 'Parsing'...`); newline(1)) else ();
   let mlparse = inl(MLReadSynDecl(MLState)) in (
      if !Print.ParseTree And isl(mlparse)
      then SynDeclPrint(outl(mlparse),0)
      else ();
      if !Print.Space 
      then Space.Parser := subtract(!Space.Parser, StoreAllocated())
      else ();
      Timings.Parser := CpuTime() - !Timings.Parser;
      mlparse ) );

let MLAnalyserPhase(Parse) 
    = if (isl Parse)
      then (Timings.Analyser := CpuTime();
	    if !Print.Space then Space.Analyser := StoreAllocated() else ();
            if !Print.TraceML then (outtok(`ML TypeChecking...`); newline(1))
                              else ();
	    let newenvs = 
		inl(Analyse(outl(Parse))) in
	    (if !Print.Space 
	     then Space.Analyser := subtract(!Space.Analyser, StoreAllocated())
	     else ();
	     Timings.Analyser := CpuTime() - !Timings.Analyser; newenvs))
      else (if !Print.Space then Space.Analyser := NoSpace else ();
	    Timings.Analyser := 0; inr());

let MLCompilerPhase(Parse)
    = if (isl Parse)
      then (Timings.Compiler := CpuTime();
	    if !Print.Space then Space.Compiler := StoreAllocated() else ();
	    if !Print.TraceML then (outtok(`ML Compiling...`); newline(1))
                              else ();
	    let SMCode = inl(Compile(outl(Parse))) in
	    (bpt(``);
	     if !Print.StackCode And isl(SMCode)
	     then SMCodeListPrint(outl(SMCode),0) else ();
	     if !Print.Space 
	     then Space.Compiler := subtract(!Space.Compiler, StoreAllocated())
	     else ();
	     Timings.Compiler := CpuTime() - !Timings.Compiler; SMCode))
      else (if !Print.Space then Space.Compiler := NoSpace else ();
	    Timings.Compiler := 0; inr());

let MLAssemblerPhase(MLSMCode)
    = if (isl MLSMCode)
      then (Timings.Assembler := CpuTime();
	    if !Print.Space then Space.Assembler := StoreAllocated() else ();
	    if !Print.TraceML then (outtok(`ML Assembling...`); newline(1))
                              else ();
	    let ObjCode = 
	    inl(forgettype(Assemble(outl(MLSMCode))):(void->object)) in
	    (if !Print.Space 
	     then Space.Assembler := subtract(!Space.Assembler, StoreAllocated())
	     else ();
	     Timings.Assembler := CpuTime() - !Timings.Assembler; ObjCode))
      else (if !Print.Space then Space.Assembler := NoSpace else ();
	    Timings.Assembler := 0; inr());

let MLRunCode(ObjCode, MLNewLocAllEnvironment, MLState)
    = if  (isl ObjCode) And (isl MLNewLocAllEnvironment)
      then (Timings.Results := CpuTime();
	    if !Print.Space then Space.Results := StoreAllocated() else ();
	    if !Print.TraceML then (outtok(`ML objcode running...`);newline(1))
            else ();
	    let Result = inl(outl(ObjCode)()) 
            enc MLTopAllEnv = TopEnvOfSysState(MLState) 
            enc () = PrintTopEnv := MLTopAllEnv in
	    (if !Print.Space 
	     then Space.Results := subtract(!Space.Results, StoreAllocated())
	     else ();
	     Timings.Results := CpuTime() - !Timings.Results;
             AnalTopEnv := inr(MLTopAllEnv);
	     if isl(Result)
	     then UpdateAndShowEnvs(outl(Result),
				    outl(MLNewLocAllEnvironment),
				    MLTopAllEnv)
	     else ();
             AnalTopEnv := inl();
	     if !Debug.ValEnv then DebugValEnv(MLTopAllEnv.Val)
	     else ();
%RJGDEL 	     if !Debug.ExcEnv then DebugExcEnv(MLTopAllEnv.Exc)%
%RJGDEL 	     else ();%
	     if !Debug.TypeEnv then DebugTypEnv(MLTopAllEnv.Typ)
	     else ();
	     PrintTopEnv := NilTopEnv
	    )
	   )
      else (if !Print.Space then Space.Results := NoSpace else ();
	    Timings.Results := 0);


%%
let MLOneStep(MLState): unit =
    let () = MLUndoLocalSynEnv(BldOfSynStream(SynStreamOfSysState(MLState)))
    enc () = AnalTopEnv := inr(TopEnvOfSysState(MLState))
    enc MLParseTree =
	MLParserPhase(MLState)
	?? [`CtrlZ`] ( MLClearLocalSynEnv(); failwith `CtrlZ` )
    enc MLDeltaTopEnv = MLAnalyserPhase(MLParseTree)
    enc MLSMCode  =   MLCompilerPhase(MLParseTree)
    enc MLObjCode =   MLAssemblerPhase(MLSMCode) 
    enc () = MLClearLocalSynEnv()
    enc () = AnalTopEnv := inl() 
    in	MLRunCode(MLObjCode, MLDeltaTopEnv, MLState);

let MLHalfStep(SMCode, DeltaTopEnv, MLState): unit =
    let _ = if !Print.StackCode
	    then (PrintLn(); SMCodeListPrint(SMCode,0); PrintLn()) else ()
    enc MLObjCode =   MLAssemblerPhase(inl SMCode) 
    in MLRunCode(MLObjCode, inl(DeltaTopEnv), MLState);


let NewOneStep(MLState) =
    MLOneStep(MLState)
	 ?? [`Interrupt`] ( outtok(`Interrupt`);newline(1);())
	 ?? [`Reenter`] ( AbortToInteractiveSysState(MLState); () )
	 ?? [`CtrlZ`;`ExitML`;`FatalCrash`] ()
	 ?\ e ( printExnObject(e,TopEnvOfSysState(MLState).Val));

let NewML(MLState) =
   let rec DebugLoop(n) =
      let x =
	  ( let _ = MLOneStep(MLState)
	    enc tim = OutputTimings() 
	    enc sp = OutputSpace()
	    in inl(n) ) 
	 % Memo:  The following sequence of failure traps may only approximate
	    what we really want. %
	 ?? [`Interrupt`] ( outtok(`Interrupt`);newline(1);failwith `Reenter` )
	 ?? [`Reenter`] ( AbortToInteractiveSysState(MLState); inl(n) )
	 ?? [`CtrlZ`;`ExitML`;`FatalCrash`] % exit % inr()  
	 ?\ e ( printExnObject(e,TopEnvOfSysState(MLState).Val);
	       let (s:string,_) = castobj(mkobj e)
	       in if s = `CtlStackOverFlow` orelse s = `ArgStackOverFlow` then
	             printStackOverflow ()
		  else if s = `Interrupt` then
		          AbortToInteractiveSysState(MLState)
		       else ();
	       inl(n) )
      in if isl(x) then DebugLoop(outl x) else ()
   in DebugLoop(0);


let type MLState' = (MLLexMode,MLLex,MLClz,MLInfo)SysState;

let EmptyMLState( sysTitle: string, MLBld: MLBasicLanguageData ): MLState' =
    let bufstream = NewBufStream(MonFnOpen,MonFnClose)
    in NewSysState(
	sysTitle, bufstream, NewSynStream(MLBld)(bufstream), ResetTopEnv() );

let NewUse newMLState = app (UseFileInSysState newMLState 256);
let NewUseString newMLState = app (UseStringInSysState newMLState);

let NewExportMLState newMLState (fileName,sysTitle,useFileNameList) = (
    CloseSynStream(SynStreamOfSysState(newMLState));
    newline(1); outtok(`Exporting ML system to:	 `); outtok(fileName);
    newline(2); 
    let smashFn() = (
	Do(ExportCurrentState(fileName));
	newline(2); outtok(sysTitle); newline(2);
	NewUse newMLState useFileNameList;
	UseStdIn(256,BufStreamOfSysState(newMLState));
	NewML(newMLState) )
    in SmashState( NewState (
	    [NewProcess(smashFn,ArgStackSize,CtlStackSize)] )) );

let NewExportFunction (fileName,function:unit -> unit,stacksize) = (
    newline(1); outtok(`Exporting function to:	 `); outtok(fileName);
    newline(2); 
    let smashFn() = (
	Do(ExportCurrentState(fileName));
	function() ?\failxn () )
    in SmashState( NewState (
	    [NewProcess(smashFn,stacksize,stacksize)] )) );

let NewSwitchMLState currentMLState newMLState useFileNameList = (
    CloseSynStream(SynStreamOfSysState(currentMLState));
    let smashFn() = (
	newline(1); outtok(`[Switching to new ML State]`); newline(1);
	outtok(SysTitleOfSysState(newMLState));	 newline(1);
	NewUse newMLState useFileNameList;
	UseStdIn(256,BufStreamOfSysState(newMLState));
	NewML(newMLState) )
    in SmashState( NewState (
	    [NewProcess(smashFn,ArgStackSize,CtlStackSize)] )) );


%Was MLINIT...%

SetupEqFn (AllocTypTuple[]) (InitEqFns.Tuple);
SetupEqFn (AllocTypFun(AllocTypUnit,AllocTypUnit)) (InitEqFns.Fun);

let InitMLState(): MLState' =
%AM: I am deeply suspicious but here goes...%
  let  _ = Print.StackCode:=true in
  let NewMLState = EmptyMLState( `Hyper-Transfer-ML`, HTML )
  enc topenv = TopEnvOfSysState(NewMLState)
  enc  _ = MLHalfStep([EmitRecord(0);EmitReturn(1)],
		      InitLocAllEnv1([]), NewMLState)
  enc protocommand = implode [
       ` datatype bool = false | true `;
       ` datatype 'a list = op :: of ('a # 'a list) | nil `;
       ` datatype '_weak ref = ref of '_weak  `;
       ` datatype 'l + 'r = inl of 'l | inr of 'r `;
       ` abstype int = int with () = () end `;
       ` abstype real = real with () = () end `;
       ` abstype string = string with () = () end `;
       ` abstype Dynamic = Dynamic with () = () end `;
       ` abstype '_weak array = array with () = () end `;
       ` datatype exn = ... `
       ]
  enc _ = UseString(protocommand, BufStreamOfSysState(NewMLState))
  enc _ = AnalFudgeFns := [ (InitPrintFns.Bool,InitEqFns.Bool);
			    (InitPrintFns.Star,InitEqFns.Star);
			    (InitPrintFns.Ref,InitEqFns.Ref);
			    (InitPrintFns.Sum,InitEqFns.Sum);
			    (InitPrintFns.Int,InitEqFns.Int);
			    (InitPrintFns.Real,InitEqFns.Real);
			    (InitPrintFns.String,InitEqFns.String);
			    (InitPrintFns.Dynamic,InitEqFns.Dynamic)]
%			    (InitPrintFns.Xn,InitEqFns.Xn)]%
  enc _ = MLOneStep(NewMLState)
  enc OhDear = \x. failwith `InitMLState`
  enc Bool = fst(RetrieveTypFromTop(AtomBool, topenv.Typ, OhDear))
  enc Int = fst(RetrieveTypFromTop(AtomInt, topenv.Typ, OhDear))
  enc Real = fst(RetrieveTypFromTop(AtomFloat, topenv.Typ, OhDear))
  enc String = fst(RetrieveTypFromTop(AtomString, topenv.Typ, OhDear))
  enc Dynamic = fst(RetrieveTypFromTop(absAtom' `Dynamic`, topenv.Typ, OhDear))
  enc Xn = fst(RetrieveTypFromTop(AtomXn, topenv.Typ, OhDear))
  enc tem1 = fst(RetrieveTypFromTop(AtomList, topenv.Typ, OhDear))
  enc tem2 = (repTypTerm' tem1) as TypAbsOper
  enc List = \arg. ReAllocTypAbsOper(tem2, [arg])
  enc _ = AnalFudgeType := inr(| Bool; Star=List; Int; Real; String; Dynamic; Xn |)
  %AM: here the dubious bit ends...%
  
  enc (| TypVar; EtyTypVar; Unit; Arrow; Cross |) = InitTypConstructors
  enc A = TypVar() enc E = EtyTypVar()
  enc locpairenv = InitLocAllEnv2(
	    append(map (\(x,y,z). (AllocBindPseudo(x,y),z))
		       [(AtomEqual,[|OpEqual|],Arrow(Cross(E,E),Bool));
			(AtomNotEq,[|OpNotEq|],Arrow(Cross(E,E),Bool))
		       ],
		   map (\(x,y). (AllocBindIde(x),y))
			%AM: use an ADT in the next line...%
		       [(absAtom'(`CurrentMLState`),Arrow(Unit,A));
%AJGDEL		        (absAtom'(`TheAssembler`),Unit);%
                        (absAtom'(`TextSize`),Unit);
			(absAtom'(`use`),Arrow(List(String),Unit))
		       ]))
%RJGDEL 	    [(AllocBindIde(AtomOldFail), String)])%
  enc (SMCode: SMCode' list) =
%AM: these next three values shouldn't get used! %
    CompBinCombinator(AtomEqual, absSMCode'[|OpEqual=[|Bool|]|],
    CompBinCombinator(AtomNotEq, absSMCode'[|OpEqual=[|Bool|]|],
    CompLiteral([|GlobalObject=mkobj(\().NewMLState)|],
%AJGDEL    CompLiteral([|GlobalObject=mkobj(TheAssembler)|],%
    CompLiteral([|GlobalObject=mkobj(TextSize)|],
    CompLiteral([|GlobalObject=mkobj(NewUse NewMLState)|],
%AM: the next line(s) set up initial exception names%
    CompLiteral([|GlobalObject=mkobj(ref AtomOldFail)|],
    [EmitRecord(6%AJG: Watch this Val%);EmitReturn(1)]))))))
  enc  _ = MLHalfStep(SMCode, locpairenv, NewMLState)
  enc _ = Print.StackCode:=false
  in  NewMLState;

%Was PRUNE...%

let MLValIdes = "
    ExportML ExportFunction ML
    = <>
    Do I K
    o & #
    printdot
    true false Not And Or printbool
    ~ * // div mod + - > < >= <= min max AppInt' AppInt printint
    printreal realofstring
    explode implode explodeascii implodeascii tokofint intoftok LengthTok
	substring #<= #< #>= #> #@ tokhash ScanTokUntilIn ScanTokWhileIn
	printstring outstring printtok outtok 
    fst snd pair
    inl inr outl outr isl isr
    :: nil cons hd tl null LengthList length @ append rev reverse
	MapList' MapList map' map AppList' RevAppList' AppList app' app
	aplist revaplist nth LftReduceList RhtReduceList itlist revitlist
	ReduceList exists split sum listprint
    MemberTok
    ref ! := deref


    syscall sys collect use TextSize
    CurrentMLState vms e v ie emacs chdir CpuTime






    infile outfile screen
    Print Debug
    Openstream Createstream Readstream Writestream
    CloseInStream CloseOutStream
    MoveWithinBuffer BufferOfLength ReadToBuffer 
    lineterm output_string_fn newline_fn check_minimum_fn
";

let MLTypIdes = "string list unit + bool ref  -> * int
		 instream outstream Print' Debug'";


