%Was VALPRINT.ML... %
% ML print routines - note that the type `object` is currently
  implemented as a hack, as are
    castobj, objectfield, objectcasenum, objectcaseval.
  They should be implemented as type 'general' (see AM).
%

let PrintTopEnv = ref(NilTopEnv);

let rec { RecordPrint(Val: object, TagList: TypTagList'): void =
( PrintBra[|Record|];
  if null(TagList) then outtok(` `)
  else ( let rec f(l: TypTagList', n) =
	   ( PrintAtom((hd l).Tag); outtok(`=`);
	     ValPrint((hd l).Typ, true ) (objectfield(Val,n));
	     if null(tl l) then ()
	     else (outtok(`, `); f(tl(l),n+1))) in
	 f(TagList,0));
  PrintKet[|Record|])

and VariantPrint(Val: object, TagList: TypTagList'): void =
( PrintBra[|Variant|];
  let FieldTyp = nth(TagList, objectcasenum(Val)+1) in (
  PrintAtom(FieldTyp.Tag);
  if IsTrivType(FieldTyp.Typ) then ()
  else (outtok(`=`); ValPrint(FieldTyp.Typ, true ) 
			     (objectcaseval(Val))));
  PrintKet[|Variant|])

and ValPrint(Typ: TypTerm', TopLevel:bool)(Val: object): void =
( let Typ = FullPrune Typ in
  case repTypTerm' Typ of
  [| TypVar.		%AM: only value of type 'a is bottom%
       outtok `?`;
    TypDefOper. failwith `ValPrint:DefOper`;	%AM: FullPrune got rid of this%
    TypConVar. outtok `?TypConVar?`;
    TypAbsOper=x.
       if null(!(x.AbsInfo.AbsCons)) Or IsListType( x.AbsInfo.AbsHandle )
       then 
	 (if TopLevel then () else outtok(` `);
	  (!x.AbsInfo.AbsPrintFn)(Val, map (\x.ValPrint(x,true))
		  			   (x.AbsArgs)))
       else
          if !x.AbsInfo.Extensible > 0 then outtok(`-`)
	  else
	  % There must be a better way than this, but here goes .... ! %
	    let rec findcons(abscons:(|VarName: SynBindIde'; 
				       VarType: TypTerm'|) list ,v) =
		if null abscons then failwith `ValPrint:findcons`
		else let (rep,n,max,imp) = !(((hd abscons).VarName.Constructor)
					     as yes) in
		   case rep of
		   [|variant. if max = 1 then hd abscons
			      else if objectcasenum(v) = n then hd abscons
			      else findcons(tl(abscons),v);
		     xcon=y.  failwith `ValPrint:findcons`; %RJG shouldnt get here%
		     pointer. if null(castobj(v)) then findcons(tl(abscons),v)
			      else hd abscons;
		     zero.    if null(castobj(v)) then hd abscons
			      else findcons(tl(abscons),v);
		     ref.     hd abscons |]
	    enc const = findcons(!(x.AbsInfo.AbsCons),Val)
	    enc def = if IsFunType(const.VarType) then
			 FreshType(const.VarType)
		      else
			 AllocTypFun( AllocTypUnit, FreshType(const.VarType) )
	    enc dom = GenTypVar(false,false,false,MaxInt,true)
	    enc contyp = (Unify(def,AllocTypFun(dom,FreshType(Typ))); FullPrune(def))
	    enc casetype = FullPrune(dom)
	    enc (rep,n,max,_) = !((const.VarName.Constructor) as yes)
	     in case rep of
		[|pointer.(if TopLevel then () else outtok(`(`);
			   PrintAtom(const.VarName.Ide);
			   ValPrint (casetype,false) (castobj(Val));
			   if TopLevel then () else outtok(`)`));
		  zero.	  (if TopLevel then () else outtok(` `);
			   PrintAtom(const.VarName.Ide));
		  variant.(if TopLevel then () else outtok(`(`);
			   PrintAtom(const.VarName.Ide);
			   if IsTrivType(casetype) then ()
			   else if max = 1
			   then ValPrint (casetype,false) Val
			   else ValPrint (casetype,false)
						 (objectcaseval(Val));
			   if TopLevel then () else outtok(`)`));
  	          xcon=y.  failwith `ValPrint:findcons`; %RJG shouldnt get here%
		  ref.	  (if TopLevel then () else outtok(`(`);
			   PrintAtom(const.VarName.Ide);
			   ValPrint (casetype,false)
				    (objectcaseval(Val));
			   if TopLevel then () else outtok(`)`))|] ;
    TypTagOper=x.
      case x.TagSort of 
      [|Record. RecordPrint(Val,(!x.TagList) as Solid);
	Variant. VariantPrint(Val,(!x.TagList) as Solid) |]
  |])
};

ValPrintFn := \t.ValPrint(t,true);

let rec PrintTypeCons(AbsCons:(|VarName: SynBindIde'; VarType: TypTerm'|) list,
		      %{VAR}%TypVarEnv, TypEnv) =
   if null AbsCons then ()
   else let (|VarName; VarType|) = hd AbsCons 
	enc t = (repTypTerm' VarType) as TypAbsOper in
	(PrintTypeCons(tl(AbsCons), TypVarEnv, TypEnv);
	 if null(tl AbsCons) then () else outtok(` | `);
	 PrintAtom(VarName.Ide);
	 if EqHandle(t.AbsInfo.AbsHandle,TypFunHandle)
	 then (outtok(` of `);
	       TypePrint(hd(t.AbsArgs),TypVarEnv,TypEnv, !PrintTopEnv,true,true))
	 else () );

%Was MLDEBG...%
let ShowValBinding(VarName: SynBindIde', VarType: TypTerm', VarValue: object, 
		TypVarEnv: TypVarEnv' ref, TypEnv, 
		First: bool, Tab: int) =
   (if !Print.VarNames Or !Print.VarValues Or !Print.VarTypes
    then ( outtok(if First then `> ` else `  `); repeattok(Tab,` `) )
    else ();
    if !Print.VarNames And Not (EqAtom(VarName.Ide,AtomIt)) then 
       (outtok(if (VarName.Constructor) is yes
	       then `con ` else `val `);
	PrintAtom(VarName.Ide)) 
    else (); 
    if !Print.VarValues 
    then (if EqAtom(VarName.Ide,AtomIt) then () else outtok(` = `); 
          (ValPrint (VarType,true) VarValue)) 
    else ();
    if !Print.VarTypes 
    then (outtok(` : `);
	  TypePrint(VarType,%{VAR}%TypVarEnv,TypEnv,!PrintTopEnv,true,true))
    else ();
    PrintLn());

let rec ShowValEnvironment(New: LocEnv', V: object, TypEnv, First: bool ref, Tab: int): void =
  if null(New) then ()
  else  ( let Cell = hd New
	  in if IsHiddenVar( Cell ) then ()
	     else let x = !Cell.VarName.StkPosn
	          enc valu = case x of
		             [| Global=g. g;
			        Local=l. if l>= 0 then objectfield( V, l )
			                 else failwith(`ShowValEnv`)
                             |]
                  in ( ShowValBinding(Cell.VarName, !Cell.VarType, valu, (ref[]), TypEnv, !First, Tab);
	               First:=false );
	  ShowValEnvironment(tl New, V,  TypEnv,  %{VAR}%First, Tab) );
 
let UpdateValEnvironment(New: LocEnv', TopEnv: TopValEnv', Val: object): void =
( let rec f(New: LocEnv') =
     if null(New) then ()
     else ( let Cell = hd New in
	    let AnsPos = ((!Cell.VarName.StkPosn) as Local) ?? [`As`] ~1 in
	    if IsHiddenVar(Cell) then ()
	    else if AnsPos<0 then failwith `UpdateEnvironment`
	    else UpdateTopValEnv(TopEnv, Cell.VarName, !Cell.VarType,
     			         objectfield(Val, AnsPos));
	    f(tl New) )
  in f(New) );

%%
let ShowTypBinding(typ:TypTerm',tve:TypVarEnv' ref,te,first:bool,tab:int):void =
    let isabstype = null(!((repTypTerm'(typ) as TypAbsOper).AbsInfo.AbsCons)) ? false in
    ( if first then outtok(`> `) else outtok(`  `); repeattok(tab,` `);
      outtok(if isabstype then `type ` else
	     if repTypTerm'(typ) is TypAbsOper then `datatype ` else `type `);
      if !Print.VarTypes 
      then  case repTypTerm'(typ) of
	    [| TypVar. Crash();
	       TypConVar=x.
	          if (!x.Instance) is absent then
		     TypePrint(typ,tve,te, !PrintTopEnv,true,false)
		  else
		     ( TypePrint( typ,tve,te,!PrintTopEnv,true,false );
		       outtok( ` = `);
		       TypePrint( FullPrune(typ), tve, te, !PrintTopEnv, true, true ) );
	       TypDefOper=x.
		  ( TypePrint(typ,%{VAR}%tve,te,!PrintTopEnv,true,true);
		    outtok(` = `);
		    TypePrint(x.DefBody,%{VAR}%tve,te,!PrintTopEnv,true,true) );
	       TypAbsOper=x. 
		  ( TypePrint(typ,%{VAR}%tve,te,!PrintTopEnv,true,true);
		    if isabstype orelse !x.AbsInfo.Extensible > 0  then ()
		    else ( outtok(` = `);
			   PrintTypeCons(!x.AbsInfo.AbsCons,%{VAR}%tve,te) ) );
	       TypTagOper. outtok(`<label>`) |]
      else ();
      PrintLn()
    );

let rec ShowTypEnvironment(LocTypIdeEnv: LocTypEnv', TypEnv, First: bool ref, Tab: int): void =
  if null(LocTypIdeEnv) then () else
  ( let Cell = hd(LocTypIdeEnv)
    in	if IsHiddenType(Cell) then ()
	else ( ShowTypBinding(!(Cell.TypIde),(ref[]),TypEnv,!First,Tab);
	       First := false );
    ShowTypEnvironment(tl LocTypIdeEnv,TypEnv,%{VAR}%First,Tab) );

let rec UpdateTypEnvironment(e: LocTypEnv', TopTypEnv: TopTypEnv'): void =
  if null(e) then () else
  ( let Cell = hd e: LocTypEnvCell' in
    if IsHiddenType(Cell) then ()
    else UpdateTopTypEnv(Cell.TypNam, !Cell.TypIde, Cell.Multiadic, TopTypEnv);
    UpdateTypEnvironment(tl e,TopTypEnv) );


%%
%RJGDEL let ShowExcBinding(name:SynBindIde',typ:TypTerm',tve:TypVarEnv' ref,%
%RJGDEL 		   te,first:bool,tab:int):void =%
%RJGDEL   ( if first then outtok(`> `) else outtok(`  `); repeattok(tab,` `);%
%RJGDEL     outtok(`exception `);%
%RJGDEL     PrintAtom(name.Ide);%
%RJGDEL     if !Print.VarTypes %
%RJGDEL        then (outtok(` : `); TypePrint(typ,{VAR}tve,te,!PrintTopEnv,true,true))%
%RJGDEL        else ();%
%RJGDEL     PrintLn()%
%RJGDEL   );%

%RJGDEL let rec ShowExcEnvironment(e: LocExcEnv', TypEnv, First: bool ref, Tab: int): void =%
%RJGDEL   if null(e) then () else%
%RJGDEL     ( let Cell = hd e%
%RJGDEL       in if IsHiddenExc(Cell) then ()%
%RJGDEL 	 else ( ShowExcBinding(Cell.ExcIde,Cell.ExcTyp,(ref[]),TypEnv,!First,Tab);%
%RJGDEL 		First := false );%
%RJGDEL       ShowExcEnvironment(tl e,TypEnv, {VAR}First,Tab) );%

%AM: modulo types this is very like UpdateValEnvironment %
%RJGDEL let UpdateExcEnvironment(e: LocExcEnv', TopEnv: TopExcEnv', Val: object): void =%
%RJGDEL ( let rec f(e: LocExcEnv') =%
%RJGDEL      if null(e) then ()%
%RJGDEL      else ( let Cell = hd e in%
%RJGDEL 	    let AnsPos = ((!Cell.ExcIde.StkPosn) as Local) ?? [`As`] ~1 in%
%RJGDEL 	    if IsHiddenExc(Cell) then ()%
%RJGDEL 	    else if AnsPos<0 then failwith `UpdateExcEnvironment`%
%RJGDEL 	    else UpdateTopExcEnv(TopEnv, Cell.ExcIde, Cell.ExcTyp,%
%RJGDEL 				 objectfield(Val, AnsPos));%
%RJGDEL 	    f(tl e) )%
%RJGDEL   in f(e) );%

%%

let ShowAllEnvs(Env:LocAllEnv',Val:object):void =
  (let First = ref true in (
   if !Print.Types
   then ShowTypEnvironment(Env.Typ, Env.Typ, First,0)
   else ();
%RJGDEL    if true%
%RJGDEL    then ShowExcEnvironment(Env.Exc, Env.Typ, First,0)%
%RJGDEL    else ();%
   if !Print.VarNames
   then ShowValEnvironment(Env.Val, Val, Env.Typ, First,0)
   else ()) );

let UpdateAndShowEnvs(Val:object, Env: LocAllEnv', TopEnv:TopAllEnv') =
    (UpdateValEnvironment(Env.Val, TopEnv.Val, Val);
    UpdateTypEnvironment(Env.Typ, TopEnv.Typ);
%RJGDEL     UpdateExcEnvironment(Env.Exc, TopEnv.Exc, Val);%
    ShowAllEnvs(Env,Val)
   );

%%
let DebugTypEnv(e: TopTypEnv'): void =
    let tve = ref []
    enc _ = ( outtok(`* Type environment *`); PrintLn() )
    in	IterTopTypEnv(e,\(_,typ,_).ShowTypBinding(typ,tve,NilEnv,true,0));

%RJGDEL let DebugExcEnv(e:TopExcEnv'):void =%
%RJGDEL     let tve = ref []%
%RJGDEL     enc _ = ( outtok(`* Exception environment *`); PrintLn() )%
%RJGDEL     in	IterTopExcEnv(e,\(id,typ).ShowExcBinding(id,typ,tve,NilEnv,true,0));%

let DebugValEnv(e: TopValEnv'): void =
    let tve = ref []
    enc _ = ( outtok(`* Value environment *`); PrintLn() )
    in	IterTopValEnv(e,\(id,typ,valu).ShowValBinding(id,typ,valu,tve,NilEnv,true,0));

%%
let Timing(f) = \x.(let Start=CpuTime() in
		       let Result = f(x) in
			  let Finish = CpuTime() in
			     (Result, Finish-Start));

let type Timings' = (|Parser   : int ref;
		      Analyser : int ref;
		      Compiler : int ref;
		      Assembler: int ref;
		      Results  : int ref |);

let Timings = (|Parser = ref 0; 
		Analyser = ref 0;
		Compiler = ref 0;
		Assembler= ref 0;
		Results	 = ref 0 |): Timings';

let OutputTimings()
    = if !Print.Timings
      then (outtok (`Parser: `);     printint (!Timings.Parser);    
	    outtok (`  Analyser: `); printint (!Timings.Analyser);
	    outtok (`  Compiler: `); printint (!Timings.Compiler);
	    outtok (`  Assembler: `);printint (!Timings.Assembler);
	    outtok (`  Results: `);  printint (!Timings.Results);
	    newline(1))
      else ();

let type Space' = (|Parser   : (int array) ref;
		    Analyser : (int array) ref;
		    Compiler : (int array) ref;
		    Assembler: (int array) ref;
		    Results  : (int array) ref |);

let NoSpace = array(11,0);

let Space = (|Parser   = ref NoSpace; 
	      Analyser = ref NoSpace;
	      Compiler = ref NoSpace;
	      Assembler= ref NoSpace;
	      Results  = ref NoSpace |): Space';

let OutputSpace()
    = if !Print.Space
      then (outtok (`Parser - `);     PrintStoreUsed (!Space.Parser);    
            newline(1);outtok(`Analyser - `); PrintStoreUsed(!Space.Analyser);
            newline(1);outtok(`Compiler - `); PrintStoreUsed(!Space.Compiler);
            newline(1);outtok(`Assembler - `);PrintStoreUsed(!Space.Assembler);
            newline(1);outtok(`Results - `);  PrintStoreUsed(!Space.Results);
            newline(1) )
      else ();


%RJG printExnObject prints an exception object %

let printExnObject (e:exn,v:TopValEnv'):void =
% takes an exn object, retrieves same named object from ValEnv and
  uses type information to print arguments if the two objects are
  identical i.e. if both objects contain the same string pointer
  Note: all exn objects are tuples containing string,int and optional
  argument.  Nullary exn constructors are 2-tuples of this form and
  Non-nullary constructors are closures containing int and string
  global variables (looked at as object#int#string tuples) %

  let (ename,eno):string#int = forgettype e  %all exn objects%
  enc Unknown = `Unknown`                    %fail name%
  enc info = inl(RetrieveValFromTop(absAtom' ename,v,
					    CheckForBuiltInExc(v,\x.failwith Unknown)))
             ?? [Unknown] inr ()
  enc pexn (s) = (outtok ename; space 1; outtok s)
  in
  ( if (!Debug.Optimise) then (outtok
`Warning: optimisations enabled - some functions may be missing from the trace`; newline 1)
    else ();
    outtok `Exception: `;
    if isl(info) then
      let (ett:TypTerm',esbi:SynBindIde',_,_) = outl(info)
      in  if (repTypTerm'(ett) is TypAbsOper) 
          then 
           let argprintlist = (repTypTerm'(ett) as TypAbsOper).AbsArgs
           in
            if (Not(null argprintlist)) then
             let (_,_,cnameo:object)= forgettype((!esbi.StkPosn) as Global)
             in if EqualObject(cnameo,mkobj ename)
              then
              let (_,_,earg:object)= forgettype e
              in
                (outtok ename; space 1; 
                 ValPrint (hd(argprintlist),true) earg)
            else %unequal% pexn(`[hidden]`)
            else %nullary% pexn(``)
          else %notabscon - unknown% pexn(`[hidden]`)
    else %unknown% pexn(`[hidden]`);
    outtok ` raised`;
    newline 1);

let printStackOverflow () =
(outtok `Stack overflow occurred`; newline 1;
outtok `Check that your functions will terminate and make sure that your code`;
newline 1;
outtok `was compiled with the optimiser enabled`; newline 1);
