let ValPrintFn = ref (\x.\t.outstring `?`);
let TypPrintFn = ref (\t.outstring `?`);

nonfix printADT 149 1;

fun printADT (x:'a) = (printADT x ; ());

let InitPrintFns =
 (| ADT = \(ob,_). printADT(castobj(ob):'a);
    Fun = \(ob,[_;_]). outtok `Fn`;
    Bool = \(ob,[]). printbool(castobj(ob):bool);
    Star = \(ob: object, [printelt]).
                 (outtok `[`;
                  listprint(castobj(ob):object list, printelt, `,`);
                  outtok `]`);
    Tuple = \(ob:object, FnList: (object->void) list).
                ( outtok(`(`);
                  if null(FnList) then ()
                  else ( let rec f(l: (object->void) list, n) =
                           ( (hd l)(objectfield(ob,n));
                             if null(tl l) then ()
                             else (outtok(`,`); f(tl(l),n+1))) in
                         f(FnList,0));
                  outtok(`)`));
    Sum = \(ob:object, [printl; printr]).
                  varcase castobj(ob): [|inl:object; inr:object|] of
                  [| inl=x. (outtok `(inl `; printl x; outtok `)`);
                     inr=x. (outtok `(inr `; printr x; outtok `)`) |];
    Ref = \(ob: object, [printelt]).
                 (outtok `(ref `;
                  printelt(!(castobj(ob): object ref));
                  outtok `)`);
    Int = \(ob,[]). printint(castobj(ob):int);
    Real = \(ob,[]). printreal(castobj(ob):real);
    String = \(ob,[]). printtok(castobj(ob):string);
    Dynamic = \(ob,[]).
                 let (v,t) = castobj(ob):object#TypTerm' in 
                 ( outtok `<`; (!ValPrintFn) t v;
                   outtok `:`; (!TypPrintFn) t;
                   outtok `>` )
 |);

%AM syntax printing routines%

let PrintBra(TagSort) =
  outtok(varcase TagSort of [| Record. `{ `; Variant. `{| ` |]);
let PrintKet(TagSort) =
  outtok(varcase TagSort of [| Record. ` }`; Variant. ` |}` |]);
let PrintConst(c: SynConst') =
  case c of
  [| int=x.  printint(x);
     real=x.  printreal(x);
     string=x.  printstring(x) |];


let PrintPath(path: Path' opt) =
  if path is present 
  then (listprint((path as present), PrintAtom, `.`); outtok `.`)
  else ();



let rec SynTypTermPrint(TypTerm: SynTypTerm', Depth: int): void =
  if Depth=1 then outtok(`%`)
  else case repSynTypTerm' TypTerm of
  [| SynTypVar=x. PrintAtom(x.VarIde);
    SynTypAppl=x.
        if null(x.Args) then
	  ( PrintAtom(x.OperIde))
        else if repAtom'(x.OperIde) = repAtom'(AtomArrow) then
 	( outtok(`(`);
	  SynTypTermPrint(hd(x.Args),Depth-1);
	  PrintAtom(AtomArrow);
	  SynTypTermPrint(hd(tl(x.Args)),Depth-1);
	  outtok(`)`)
	)
	else if repAtom'(x.OperIde) = repAtom'(AtomCross) then
	( outtok(`(`);
	  listprint(x.Args, (\q.SynTypTermPrint(q,Depth-1)), `*`) ;
	  outtok(`)`)
	)
	else
        ( outtok(`(`);
          outtok(`(`);
          listprint(x.Args, (\q.SynTypTermPrint(q,Depth-1)), `,`);
          outtok(`)`);
          outtok(` `); PrintAtom(x.OperIde); 
          outtok(`)`));
    SynTypTagAppl=x.
      ( PrintBra(x.TagSort);
        if null(x.Args) then outtok(` `)
        else listprint(x.Args,
                       (\q. (PrintAtom(q.Tag); 
                             outtok(`:`); 
                             SynTypTermPrint(q.Arg,Depth-1))),
                       `; `);
        PrintKet(x.TagSort))
  |];


let TypParamsPrint(Params: SynTypParams'): void =
  if null(Params) then () else
  ( if null(tl Params) then () else outtok(`(`);
    listprint(Params,PrintAtom,`,`);
    if null(tl Params) then () else outtok(`)`);
    outtok(` `));


let rec {SynTermPrint (Term: SynTerm', Depth: int): void =
  if Depth=1 then outtok(`%`)
  else case repSynTerm' Term of
  [|SynIde=x. ( PrintAtom(x.Ide));
    SynConst=x.  PrintConst(x);
    SynTuple=x. (outtok(`(`); listprint(x, (\q.SynTermPrint(q,Depth-1)), `,`);
                outtok(`)`));
    SynList=x.
      ( outtok(`[`);
        listprint(x, (\q.SynTermPrint(q,Depth-1)), `,`);
        outtok(`]`));
    SynRecord=x.
      ( PrintBra[|Record|];
	if null(x) then outtok(` `) else
        listprint(x, (\q.(PrintAtom(q.RecKey); outtok(`=`);
                          SynTermPrint(q.RecField,Depth-1))),
                  `;`);
        PrintKet[|Record|]);
    SynVariant=x.
      ( PrintBra[|Variant|];
        PrintAtom(x.VarKey);
        if (if (repSynTerm'(x.VarField) is SynTuple)    
            then null(repSynTerm'(x.VarField) as SynTuple) else false)
        then ()
        else (outtok(`=`); SynTermPrint(x.VarField,Depth-1));
        PrintKet[|Variant|]);
    SynCond=x.
      ( outtok(`(if `); SynTermPrint(x.CondIf,Depth-1);
        outtok(` then `); SynTermPrint(x.CondThen,Depth-1);
        outtok(` else `); SynTermPrint(x.CondElse,Depth-1); outtok(`)`));
    SynWhile=x.
      ( outtok(`(while `); SynTermPrint(x.WhileCond,Depth-1);
        outtok(` do `); SynTermPrint(x.WhileBody,Depth-1); outtok(`)`));
    SynLamb=x.
      ( outtok(`(fn `);
        SynMatchPrint(x.Match, Depth-1);
        outtok(`)`));
    SynAppl=x.
      if x.HowRead = Niladic
      then (outtok(`(`); SynTermPrint(x.Fun,Depth-1);
            outtok(` `); SynTermPrint(x.Arg,Depth-1); outtok(`)`))
      else if x.HowRead = Monadic
      then (outtok(`(`); SynTermPrint(x.Fun,Depth);    %AM: always atom%
            outtok(` `); SynTermPrint(x.Arg,Depth-1); outtok(`)`))
      else % Assume Diadic for now %
          ( let [Fst;Snd] = repSynTerm'(x.Arg) as SynTuple in (
            outtok(`(`); SynTermPrint(Fst,Depth-1);
            outtok(` `); SynTermPrint(x.Fun,Depth);    %AM: always atom%
            outtok(` `); SynTermPrint(Snd,Depth-1); outtok(`)`)));
    SynCase=x.
      ( outtok(`varcase `); SynTermPrint(x.Select,Depth-1); outtok(` of `);
        PrintBra[|Variant|];
        listprint(x.Cases, (\q.SynTermCasePrint(q,Depth-1)), `; `);
        PrintKet[|Variant|]);
    SynJumpcase=x.
      ( outtok(`(jumpcase `); SynTermPrint(x.Select,Depth-1); outtok(` of `);
        outtok(` of `);
        listprint(x.Cases, (\q.SynTermCasePrint(q,Depth-1)), `; `);
        outtok(`)`));
    SynNewCase=x.
      ( outtok(`(case `); SynTermPrint(x.Select,Depth-1); outtok(` of `);
        SynMatchPrint(x.Match,Depth-1); outtok(`)`));
    SynLet=x.
      ( outtok(`(let `); SynDeclPrint(x.Decl,Depth-1);
        outtok(` in `); SynTermPrint(x.Scope,Depth-1); outtok(`)`));
    SynQuaOp=x.
      ( outtok(`(`); SynTermPrint(x.QuaArg,Depth-1);
        case x.QuaOp of
        [| SynQuaDot. outtok(`.`);
           SynQuaIs.  outtok(` is `);
           SynQuaAs.  outtok(` as `) |];
        PrintAtom(x.QuaIde); outtok(`)`));
    SynForce=x.
      ( SynTermPrint(x.ForceTerm,Depth-1);
        outtok(` : `); SynTypTermPrint(x.ForceType,Depth-1));
    SynTagType=x.
      ( case x.Purpose of 
        [| Print. outtok `print `; Dynamic. outtok `dynamic `;
           Cast. outtok `cast ` |];
        SynTermPrint(x.Arg,Depth-1) );
    SynTrap=x.
      ( outtok(`(`); SynTermPrint(x.TrapLft,Depth-1);
        case x.TrapClass of
        [| SynTrapAll. outtok(` ? `);
           SynTrapList=(|TrapList|).
            ( outtok(` ?? `); SynTermPrint(TrapList,Depth-1);
              outtok(` `));
           SynTrapLamb=(|TrapBind|).
            ( outtok(` ?\ `); SynBindPrint(TrapBind,Depth-1);
              outtok(`.`))
        |];
        SynTermPrint(x.TrapRht,Depth-1); outtok(`)`));
    SynHandle=x.
     ( SynTermPrint(x.HandLft,Depth-1); outtok ` handle `;
       outtok(`(`); SynMatchPrint(x.Match,Depth-1); outtok(`)`));
    SynRaise=x.
      (outtok(`raise `); SynTermPrint(x.ExcArg,Depth-1));
    SynSequence=x.
      ( outtok(`(`);
        let rec flat(|SeqLft; SeqRht|) =
        ( SynTermPrint(SeqLft,Depth-1); outtok(`;`);
          if repSynTerm'(SeqRht) is SynSequence
          then flat(repSynTerm'(SeqRht) as SynSequence)
          else SeqRht)
        in SynTermPrint(flat(x),Depth-1);
        outtok(`)`))
  |]

and SynTermCasePrint( Case: SynTermCase', Depth: int ): unit =
    (PrintAtom(Case.Tag); outtok(`=`);
     SynBindPrint(Case.Bind,Depth-1); outtok(`. `);
     SynTermPrint(Case.Body,Depth-1))

and SynBindPrint(Bind': SynBind', Depth: int): void =
  if Depth=1 then outtok(`%`) else
  case (repSynBind' Bind') of
  [| SynBindIde=(|Ide; Binder; PreBinder|). PrintAtom(Binder.Ide);
    SynBindAny.    outtok(`_`);
    SynBindBoth=(x,y).
      ( outtok(`(`); SynBindPrint(x,Depth-1);
        outtok(`==`); SynBindPrint(y,Depth-1); outtok(`)`));
    SynBindConst=x.  PrintConst(x);
    SynBindTuple=x.
      ( outtok(`(`); listprint(x, (\q.SynBindPrint(q,Depth-1)), `,`);
        outtok(`)`));
    SynBindAppl=x.
      if x.HowRead <= Monadic
      then (outtok(`(`);  PrintAtom(x.Ide);
            outtok(` `); SynBindPrint(x.Arg,Depth-1); outtok(`)`))
      else % Assume Diadic for now %
          ( let [Fst;Snd] = repSynBind'(x.Arg) as SynBindTuple in (
            outtok(`(`); SynBindPrint(Fst,Depth-1);
            outtok(` `); PrintAtom(x.Ide);
            outtok(` `); SynBindPrint(Snd,Depth-1); outtok(`)`)));
    SynBindRecord=(x,Flexi).
      ( PrintBra[|Record|];
        if null(x) then outtok(` `) else
        listprint(x, (\q.( PrintAtom(q.RecKey); outtok(`=`);
                           SynBindPrint(q.RecField,Depth-1))), `,`);
        if Flexi is flexi then outtok(`, ...`) else ();
        PrintKet[|Record|]);
    SynBindVariant=x.
      ( PrintBra[|Variant|];
        PrintAtom(x.VarKey);
        if repSynBind'(x.VarField) is SynBindAny then ()
        else (outtok(`=`); SynBindPrint(x.VarField,Depth-1));
        PrintKet[|Variant|]);
    SynBindForce=x.
      ( SynBindPrint(x.ForceBind,Depth-1); outtok(` : `);
        SynTypTermPrint(x.ForceType,Depth-1))
  |]


%RJGDEL    and SynHandRulePrint(x: SynHandRule', Depth: int): void = outtok (`synhan!`)%
%RJG  varcase x of%
%  [| Proper=x.%
%       ( PrintAtom(x.HandIde); outstring(` with `);%
%         SynMatchPrint(x.HandAction, Depth-1));%
%     WildCard=x.%
%       ( outstring(`? `);%
%         varcase x.HandExcName of%
%         [| absent. ();%
%            present=y. SynBindPrint(y,Depth-1) |];%
%         outstring(`=> `);%
%         SynTermPrint(x.HandAction,Depth-1))%
%  |]%

and SynRulePrint((bind,term): SynRule', Depth: int): void =
  if Depth=1 then outtok(`%`)
  else (SynBindPrint(bind,Depth-1); outtok(`=>`);
        SynTermPrint(term,Depth-1))

and SynMatchPrint(x: SynMatch', Depth: int): void =
  if Depth=1 then outtok(`%`)
  else listprint(x, (\q. SynRulePrint(q,Depth-1)), ` | `)












and SynDeclPrint(Decl: SynDecl', Depth: int): void =
 (if Depth=1 then outtok(`%`)
  else case repSynDecl' Decl of
  [| SynDeclDefVal=x.
      ( SynBindPrint(x.Bind,Depth-1); outtok(` = `);
        SynTermPrint(x.Term,Depth-1));
     SynDeclDefTyp=x.
      (  case x.DefSort of
         [| ShortHand=r. (outtok `type `; TypParamsPrint(x.Params);
			  PrintAtom(x.Bind); outtok(` = `);
                          SynTypTermPrint(r.SynBinding,Depth-1));
            Isomorphism=(| Extensible=exbl; Extending=exng; Constrs=y |).
             ( outtok `datatype `; TypParamsPrint(x.Params);
	       PrintAtom(x.Bind); outtok(` = `);
               if exng then (outtok ` ... `; 
                             if null(y) then () else outtok `| `) else ();
               listprint(y, (\q.(PrintAtom(q.AbsBinder.Ide);
                                     outtok(` of `);
                                     SynTypTermPrint(q.Term,Depth-1))),
                                ` | `);
               if exbl then outtok ` ...` else ())
         |]);
    SynDeclDefExcon=x. 
       (outtok `con `; 
        PrintAtom(x.AbsBinder.Ide); outtok(` = `);
        PrintAtom(x.CopyIde));

    SynDeclAnd=x.
      ( outtok(`{`); SynDeclPrint(x.Lft,Depth-1); outtok(` and `);
        SynDeclPrint(x.Rht,Depth-1); outtok(`}`));
    SynDeclEnc=x.
      ( outtok(`{`); SynDeclPrint(x.Ext,Depth-1); outtok(` enc `);
        SynDeclPrint(x.Int,Depth-1); outtok(`}`));
    SynDeclIns=x.
      ( outtok(`{`); SynDeclPrint(x.Outs,Depth-1); outtok(` ins `);
        SynDeclPrint(x.Ins,Depth-1); outtok(`}`));
    SynDeclWith=x.
      ( outtok(`{`); SynDeclPrint(x.WithExt,Depth-1); outtok(` with `);
        SynDeclPrint(x.WithInt,Depth-1); outtok(`}`));
    SynDeclRec=x.
      ( outtok(`{rec `); SynDeclPrint(x.Rec,Depth-1); outtok(`}`))

  |] %; newline(1) % )
};
%%
let blankfield = `     `
and startthreaded = `{ ` and endthreaded = `} ` and boththreaded = `{}`
and nonthreadedfield = `  `

enc printheader(threadfield, labelfield, level) =
    (outstring(threadfield); repeattok(level,blankfield); 
     outstring(labelfield))
and paddedlabel(l) = 
   (let lab = tokofint((repSMCode' l) as OpLabel . Label) #@ `:` in
    substring(`     `,1,5-LengthTok(lab)) #@ lab ) ?? [`As`] ` ???:`
and printlab(x : SMCode') =
  printint(repSMCode'(x) as OpLabel . Label)  ?? [`As`] outstring `?`
and printtypedesc(x) =
  outstring(case x of [|Bool. `Bool`; Int. `Int`; 
                        String. `String`; Real. `Real` |])
and printeqtypedesc(x) =
  outstring(case x of [|Bool. `Bool`; Int. `Int`; 
                        String. `String`; Real. `Real`; Ref. `Ref` |])

ins rec printliteral(Literal: literals', level: int) =
  case (repliterals' Literal).LiteralForm of
    [|LiteralText=(Name,ArgSiz,CtlSiz,Text).
        (outstring(`Text for `); PrintAtom(Name); 
         outstring(` (`); printint ArgSiz; outstring`,`;
         printint CtlSiz; outstring(`) `); newline(1);
         PrintCodeList(nonthreadedfield,blankfield,level+1,Text));
      LiteralClosure=(Name,ArgSiz,CtlSiz,Text).
        (outstring(`Closure for `); PrintAtom(Name); 
         outstring(` (`); printint ArgSiz; outstring`,`;
         printint CtlSiz; outstring(`) `); newline(1);
         PrintCodeList(nonthreadedfield,blankfield,level+1,Text));
      LiteralString=s.  printstring(s);
      GlobalObject=Ide. outstring(`<global>`);
      LiteralInt=n.     printint(n);
      LiteralFloat=r.   printreal(r);
      LiteralBool=b.    outstring(if b then `True` else `False`);
      LiteralTuple=l.   
        (outstring(`Tuple(`);
         listprint(l, (\q.printliteral(q,level)), `,`);
         outstring(`)`));
      LiteralVariant=(n,x).
        (outstring(`Variant(`); printint n; outstring(`:`);
                                printliteral(x,level); outstring(`)`))
    |]

and PrintCodeList(threadfield, labelfield, level, prog: SMCode' list) =
  if null prog
  then if labelfield = blankfield then () 
       else (printheader(nonthreadedfield,labelfield,level); newline(1))
  else let h::t = prog enc reph = repSMCode' h in
    (if ((reph is OpLabel) Or (reph is OpThread))
     And (labelfield = blankfield) then ()
     else if null t 
     then if threadfield = startthreaded
          then printheader(boththreaded, labelfield, level)
          else printheader(endthreaded, labelfield, level)
     else printheader(threadfield, labelfield, level);
     case reph of
     [|OpThread=code.              
          PrintCodeList(startthreaded, labelfield, level, code);
       OpNCBind=TupleSize. (outstring(`NCBind `); printint(TupleSize));
       OpBCBind=TupleSize. (outstring(`BCBind `); printint(TupleSize));
       OpNCDestTailApply=TupleSize. (outstring(`NCDestTailApply `); 
                                   printint(TupleSize));
       OpBCDestTailApply=TupleSize. (outstring(`BCDestTailApply `); 
                                   printint(TupleSize));
       OpGetLocal=(LocDispl,LastUse). 
           (outstring(`GetLocal `); printint(LocDispl);
            if LastUse then outstring(` (last use)`) else ());
       OpGetFree=FreeDispl. (outstring(`GetFree `); printint(FreeDispl));
       OpCurrClos. outstring(`GetCurrClos`);
       OpPrimitive=OpCode. (outstring(`Opcode `); printint(OpCode));
       OpRecord=FieldNum. (outstring(`Tuple `); printint(FieldNum));
       OpVariant=CaseNum. (outstring(`Variant `); printint(CaseNum));
       OpRef. outstring(`Ref`);
       OpEqual=t. (outstring(`Eq`); printeqtypedesc(t));
       OpPrint=t. (outstring(`Print`); printtypedesc(t));
       OpQuaDot=FieldIndex. (outstring(`Dot `); printint(FieldIndex));
       OpDestTuple=(|Displ; Size|).
         (outstring(`DestTuple `); printint(Size);
          outstring(` `); printint(Displ));
       OpQuaIs=IsCaseIndex. (outstring(`Is `); printint(IsCaseIndex));
       OpQuaAs=AsCaseIndex. (outstring(`As `); printint(AsCaseIndex));
       OpDestVariant=(|DVarCaseIndex;DVarArgDispl|).
         (outstring(`DestVariant `); printint(DVarCaseIndex);
          outstring(` `); printint(DVarArgDispl));
       OpDestBigVar=x.
         (outstring(`DestBigVar `); printint(x));
       OpCase=Cases.
         % Each branch of the case starts with an OpLabel %
         (outstring(`Case [`); 
          listprint(Cases, printlab, `;`);
          outstring(`]`));
       % All jump destinations start with an OpLabel %
       OpJump = (|JumpType; Target|).
         case JumpType of
         [|Always. (outstring(`Jump `); printlab(Target));
           IfTrue. (outstring(`TrueJump `); printlab(Target));
           IfFalse.(outstring(`FalseJump `); printlab(Target))
         |];
       OpClosure=FreeVarNum. (outstring(`Closure `); printint(FreeVarNum));
       OpDumClosure=DumFreeVarNum. 
         (outstring(`DumClosure `); printint(DumFreeVarNum));
       OpRecClosure=x.
         (outstring(`RecClosure `); printint(x.RecFreeVarNum);
          outstring(`,`); printint(x.RecClosDispl));
       OpDestNil=Displ. (outstring(`DestNil `); printint(Displ));
       OpDestPointer=Displ. (outstring(`DestPointer `); printint(Displ));
       OpDestConst=(Displ,t). (outstring(`Dest`); printtypedesc(t);
                               outstring(` `); printint(Displ));
       OpReturn=RetSqueeze. (outstring(`Return `); printint(RetSqueeze));
       OpSaveFrame. outstring(`SaveFrame`);
       OpNCApplFrame. outstring(`NCApplFrame`);
       OpBCApplFrame. outstring(`BCApplFrame`);
       OpRestFrame. outstring(`RestFrame`);
       OpNCTailApply=(|NumArgs; NumJunk|).
         (outstring(`NCTailApply `); 
          printint(NumArgs); outstring(`,`);
          printint(NumJunk));
       OpBCTailApply=(|NumArgs; NumJunk|).
         (outstring(`BCTailApply `); 
          printint(NumArgs); outstring(`,`);
          printint(NumJunk));
       OpSlide=(|NumArgs; NumJunk|).
         (outstring(`Slide `); 
          printint(NumArgs); outstring(`,`);
          printint(NumJunk));
       OpFunId. outstring(`Id`);
       OpFunComp. outstring(`Comp`);
       % All trap destinations start with an OpLabel %
       OpHandle=Cases.
         (outstring(`Handle [`); 
          listprint(Cases, printlab, `;`);
          outstring(`]`));
       OpRaise. outstring(`Raise`);
       OpUnTrap=UnTrapTarget.
         (outstring(`UnTrap `); printlab(UnTrapTarget));
       OpPopTrap. outstring(`PopTrap`);
       OpLabel=x. ();
       OpGetLiteral=x. 
         (outstring(`GetLiteral `); printliteral(x.LiteralType,level))
     |];
     
     if reph is OpThread
     then 
        PrintCodeList(nonthreadedfield, blankfield, level, t)
     else if reph is OpLabel
     then 
        (if labelfield = blankfield then () else newline(1);
         PrintCodeList(nonthreadedfield, paddedlabel(h), level, t))
     else (newline(1);
           PrintCodeList(nonthreadedfield, blankfield, level, t))
    )

ins SMCodeListPrint (prog: SMCode' list, Indent: int)
= PrintCodeList(startthreaded, blankfield, 0, prog);
