%  ML Abstract Machine Code Compiler                                    %
%                                                                       %
%                                                                       %

% the next functions are a fiddle until we can write absSMCode' in a pattern %

let codeof = hd[forgettype; map repSMCode'];
let abscodeof = hd[forgettype; map absSMCode'];

let LabelCounter = ref NullLabel;

let EmitGetLocal (VarDispl: int, LastUse: bool): SMCode' =
  absSMCode'([|OpGetLocal=(VarDispl,LastUse)|]);

let EmitGetFree (VarDispl: int): SMCode' =
  absSMCode'([|OpGetFree=VarDispl|]);

let EmitPrimOp(OpCodeNum: int): SMCode' =
  absSMCode'([|OpPrimitive=OpCodeNum|]);

let EmitRecord (NewFieldNum: int): SMCode' =
  absSMCode'([|OpRecord=NewFieldNum|]);

let EmitQuaDot (NewFieldIndex: int): SMCode' =
  absSMCode'([|OpQuaDot=NewFieldIndex|]);

let EmitDestTuple(Size:int, Displ: int): SMCode' =
  absSMCode'[|OpDestTuple=(|Displ;Size|)|];

let EmitVariant (CaseNum: int): SMCode' =
  absSMCode'([|OpVariant=CaseNum|]);

let EmitQuaIs (NewIsCaseIndex: int): SMCode' =
  absSMCode'([|OpQuaIs=NewIsCaseIndex|]);

let EmitQuaAs (NewAsCaseIndex: int): SMCode' =
  absSMCode'([|OpQuaAs=NewAsCaseIndex|]);

let EmitDestVariant (DVarCaseIndex: int, DVarArgDispl: int): SMCode' =
  absSMCode'([|OpDestVariant=(|DVarCaseIndex; DVarArgDispl|)|]);

let EmitDestBigVar (DVarArgDispl: int): SMCode' =
  absSMCode'([|OpDestBigVar=DVarArgDispl|]);

let EmitCase (Cases: SMCode' list): SMCode' =
  absSMCode'([|OpCase=Cases|]);

%AM: the next two routines check their arg and then turn a cons into
     a void or a ('a # 'a list) %
let EmitDestNil(Displ: int): SMCode' =
  absSMCode'([|OpDestNil=Displ|])
and EmitDestPointer(Displ: int): SMCode' =
  absSMCode'([|OpDestPointer=Displ|]);

let EmitJump (JumpType, Target: SMCode'): SMCode' =
  absSMCode'([|OpJump=(|JumpType; Target|)|]);

let EmitClosure (FreeNum: int): SMCode' =
  absSMCode'([|OpClosure=FreeNum|]);

let EmitDumClosure (FreeNum: int): SMCode' =
  absSMCode'([|OpDumClosure=FreeNum|]);

let EmitRecClosure (RecFreeVarNum: int, RecClosDispl: int): SMCode' =
  absSMCode'([|OpRecClosure=(|RecFreeVarNum; RecClosDispl|)|]);

let EmitReturn(Depth: int): SMCode' =
  absSMCode'([|OpReturn=Depth|]);

let EmitSlide(NumArgs: int, NumJunk: int): SMCode' =
  absSMCode'([|OpSlide=(|NumArgs; NumJunk|)|]);

let EmitTailApply(NumArgs: int, NumJunk: int): SMCode' =
  absSMCode'([|OpBCTailApply=(|NumArgs; NumJunk|)|]);

let EmitNCTailApply(NumArgs: int, NumJunk: int): SMCode' =
  absSMCode'([|OpNCTailApply=(|NumArgs; NumJunk|)|]);

let EmitHandle(Target: SMCode' list): SMCode' =
  absSMCode'[|OpHandle=Target|];

let mkliterals'(LiteralForm) =
  absliterals'(| LiteralForm; LiteralValue=ref[|absent|] |);

let EmitLiteral(LiteralForm, LiteralsNeeded): SMCode' =
  absSMCode'([|OpGetLiteral=
   (| LiteralType = mkliterals'(LiteralForm); LiteralsNeeded|)|]);

%%
let IllTypedEqualityType = ref([|None|]:[|None; Typ: TypTerm'|]);

let OnEqErrorShowType (Type: TypTerm') =
  IllTypedEqualityType:=[|Typ=Type|];


let EqualityError (Msg: tok) =
  (outstring(`Invalid type of args to '=', '<>' or 'print':    `);
   case (!IllTypedEqualityType) of
   [| None.  ();
      Typ=Typ. ErrorTypePrint(Typ, ref [], false) |];
   newline(1); outstring(Msg); newline(1);
   ReEnter() );


let CompPrimOp (OpCode: int, RhtProg: SMCode' list): SMCode' list =
  absSMCode'([|OpPrimitive=OpCode|])::RhtProg;

let CompOp (Op, RhtProg: SMCode' list): SMCode' list =
  absSMCode'(Op)::RhtProg;

let CompGetLocal(VarDispl: int, LastUse: bool,
                 RhtProg: SMCode' list): SMCode' list =
  if (VarDispl > 0) Or null(RhtProg)
  then EmitGetLocal(VarDispl,LastUse)::RhtProg
  else 
    (let [|OpReturn=x|]::rest = codeof RhtProg 
       %"GetLocal 0; Return n+1" --> "Return n"%
     in EmitReturn(x-1)::abscodeof(rest))
?? varstruct
    (let oper::[|OpReturn=x|]::rest = codeof RhtProg 
       %"GetLocal 0; Op; Return 1" --> "Op; Return 0"%
       % worry about this for diadic ops AND EVEN MORE ESPECIALLY LABELS%
     in if x = 1 And Not (oper is OpLabel)
        then absSMCode'(oper)::EmitReturn(0)::abscodeof(rest)
        else EmitGetLocal(VarDispl,LastUse)::RhtProg)
?? varstruct
    EmitGetLocal(VarDispl,LastUse)::RhtProg;

let Thread(code:SMCode' list, rest:SMCode' list): SMCode' list =
  if null(code) then rest
  else if null(tl code) then (hd code)::rest
  else absSMCode'([|OpThread=code|])::rest;

%%
% Literal simplification package... %

let rec ArgList(Prog: SMCode' list): literals' list # SMCode' list =
  if null Prog then failwith `ArgList` else
  if repSMCode'(hd Prog) is OpGetLiteral
  then let (restlits, restprog) = ArgList(tl Prog) in
       ((repSMCode'(hd Prog) as OpGetLiteral).LiteralType :: restlits,
        restprog)
  else ([], Prog)

ins rec {SimplifyLiteral(literal, RhtProg: SMCode' list): SMCode' list =
  let (args,DestOp::restprog) = ArgList(EmitLiteral(literal,0)::RhtProg)
  enc destop = repSMCode'(DestOp) in
  if destop is OpRecord
  then CompLiteral([|LiteralTuple=args|], restprog)
  else if destop is OpVariant
  then let [arg] = args in
       CompLiteral([|LiteralVariant=(destop as OpVariant,arg)|], restprog)
  else failwith `SimplifyLiteral`

and CompLiteral(literal, RhtProg: SMCode' list): SMCode' list =
  if null RhtProg then EmitLiteral(literal,0)::RhtProg
  else let nextop = repSMCode'(hd(RhtProg)) in
    if ((nextop as OpClosure) = 0) ?? [`As`] false
    then if literal is LiteralText
         then CompLiteral([|LiteralClosure = (literal as LiteralText)|],
                          tl(RhtProg))
         else EmitLiteral(literal,0)::RhtProg
    else if nextop is OpGetLiteral
    then let (|LiteralType; LiteralsNeeded|) = nextop as OpGetLiteral in
      if LiteralsNeeded=0
      then EmitLiteral(literal,0)::RhtProg
      else if LiteralsNeeded = 1
        then SimplifyLiteral(literal, RhtProg)
        else EmitLiteral(literal,LiteralsNeeded-1)::RhtProg
    else if (nextop is OpRecord) Or (nextop is OpVariant)
    then let numargs = if nextop is OpVariant then 1
                       else nextop as OpRecord in
      if numargs = 1
      then SimplifyLiteral(literal, RhtProg)
      else EmitLiteral(literal,numargs-1)::RhtProg
    else EmitLiteral(literal,0)::RhtProg
};

let CompConst(c: SynConst', RhtProg: SMCode' list): SMCode' list =
  case c of
  [| int=n. CompLiteral([|LiteralInt=n|],RhtProg);
     real=x. CompLiteral([|LiteralFloat=x|],RhtProg);
     string=s. CompLiteral([|LiteralString=s|],RhtProg) |];

let CompDestConst(c: SynConst', Displ: int,
                  RhtProg: SMCode' list): SMCode' list =
  (\t.CompConst(c, absSMCode'[|OpDestConst=(Displ,t)|]::RhtProg)) (
        case c of [| int.[|Int|]; real.[|Real|]; string.[|String|] |]);

let CompQuaDot((QuaNum,QuaMax):int#int, RhtProg: SMCode' list): SMCode' list =
  EmitQuaDot(QuaNum)::RhtProg; 

let CompQuaIs((QuaNum,QuaMax):int#int, RhtProg: SMCode' list): SMCode' list =
  EmitQuaIs(QuaNum)::RhtProg;

let CompQuaAs((QuaNum,QuaMax):int#int, RhtProg: SMCode' list): SMCode' list =
  EmitQuaAs(QuaNum)::RhtProg;


%%
let type VarType = [|Val; Str|];

let {type StkPos' <=> int}
enc type FVL' = (| List: (SynBindIde'  # VarType) list ref; 
                   EndLocals: StkPos'; MaxArgStk: int ref; MaxCtlStk: int ref;
                   CurrFn: [|NoFun: unit ; Fun: (SynBindIde' # SMCode')|] |)

with ExtendStk(Bind': SynBindIde', OldStk: StkPos') =
%the StkPosn field in SynBindIde is only not abstract because this would
 create to big a recursive definition of the analyser and compiler types%
( Bind'.StkPosn := [|Local=repStkPos'(OldStk)|];
  absStkPos'(repStkPos'(OldStk)+1))
and NullExtendStk(OldStk: StkPos', n:int) = absStkPos'(repStkPos'(OldStk)+n)
and NullStk = absStkPos'(0)
and repStkPos' = repStkPos'
and StkDif(New: StkPos', Old: StkPos') = repStkPos'(New)-repStkPos'(Old)
and FindVar (Ide: SynBindIde', Locals: StkPos', vartype: VarType,
             Frees: FVL'): [|ArgStack:int; Closure:int; Global:object|] =
    let FreeList = Frees.List in
    case !Ide.StkPosn of
    [| Global=Obj. [|Global=Obj|];
       Local=n. if n >= repStkPos'(Frees.EndLocals)
		  then [|ArgStack = (repStkPos'(Locals)-n-1)|]
	        else let rec FindFV(l: (SynBindIde' # VarType) list) =
                  if null(l)
                  then (FreeList := (Ide, vartype) :: !FreeList; 
                        length(!FreeList))
                  else let (sb,vne) = hd l in
		  if EqAtom(Ide.Ide, sb.Ide) And
                          vartype = vne then length(l)
                  else FindFV(tl l)
	        in [| Closure = FindFV(!FreeList) |]
    |];

let CompIde(Posn: [|Local:int; Global:object |], Locals: StkPos', RhtProg) =
    case Posn of
    [|Local=n. 
        CompGetLocal(repStkPos'(Locals) - n - 1, false, RhtProg);

      Global=obj.
        CompLiteral([|GlobalObject=obj|], RhtProg)          
    |];


let CompVar(Ide: SynBindIde', vartype:VarType,
            LastUse:bool, Locals: StkPos',
            Frees: FVL', RhtProg: SMCode' list): SMCode' list =
       case FindVar(Ide,Locals,vartype,Frees) of
            [|ArgStack=d.    CompGetLocal(d,LastUse,RhtProg);
              Closure=d.     EmitGetFree(d) ::RhtProg;
              Global=obj.    CompLiteral([|GlobalObject=obj|],RhtProg)
            |]

% CompQVar loads a function which has a quick entry point for multiple
  arguments, and selects the quick version, given that its arguments have
  already been spread on the stack. %
and CompQVar(Ide: SynBindIde', vartype: VarType,
             LastUse:bool, Locals: StkPos',
             Frees: FVL', RhtProg: SMCode' list): SMCode' list =

       case FindVar(Ide,Locals,vartype,Frees) of
            [|ArgStack=d. CompGetLocal(d,LastUse,(EmitQuaDot(1)::RhtProg));
              Closure=d.  EmitGetFree(d) ::(EmitQuaDot(1)::RhtProg);
              Global=obj. CompLiteral([|GlobalObject=
                              closureFV1(castobj(obj):closure)|], RhtProg)
                           ? failwith `CompQVar`
              % If it's a top-level object do the selection at compile time %
    |]


and DumClosPos(Ide: SynBindIde', Locals: StkPos', Frees: FVL'): int =
  case FindVar(Ide,Locals,[|Val|],Frees) of
  [|ArgStack=d. d;
    Closure=d.  failwith `DumClosPos`;
    Global=obj. failwith `DumClosPos`
  |];

%%
let CompCase(Cases: SMCode' list, RhtProg: SMCode' list): SMCode' list =
  EmitCase(Cases)::RhtProg;

let CompDestTuple(Size:int, Displ: int, RhtProg: SMCode' list): SMCode' list =
  if Displ <> 0 Or null(RhtProg)
  then EmitDestTuple(Size, Displ)::RhtProg
  else 
    (let [|OpGetLocal=(x,y)|]::[|OpSlide=(|NumArgs;NumJunk|)|]::rest = 
         codeof RhtProg in
     if (x < Size) And (x = NumJunk) And (NumArgs = 1) 
     then %"DestTuple n,0; GetLocal m (0<=m<n); Slide 1,n"
            --> "Dot n-(m+1)"%
        EmitQuaDot(Size - (x + 1))::abscodeof rest
    else failwith `Bind`)
?? varstruct
    (let [|OpSlide=(|NumArgs; NumJunk|)|]::rest = codeof RhtProg in
     if (NumArgs = 1) And (NumJunk = (Size-1))
     then %"DestTuple n,0; Slide 1,(n-1)" --> "Dot n-1"%
        EmitQuaDot(Size - 1)::abscodeof rest
     else EmitDestTuple(Size, Displ)::RhtProg)
?? varstruct
    EmitDestTuple(Size, Displ)::RhtProg;

let CompDestVariant((QuaNum,QuaMax):int#int,
                     DVarArgDispl: int, RhtProg: SMCode' list)
                     : SMCode' list =
  EmitDestVariant(QuaNum,DVarArgDispl)::RhtProg;

let CompDestBigVar(DVarArgDispl: int, RhtProg: SMCode' list)
                     : SMCode' list =
  EmitDestBigVar(DVarArgDispl)::RhtProg;

let CompRecord (Size: int, RhtProg: SMCode' list): SMCode' list =
  if Size=0 
  then 
     (let [|OpVariant=n|]::rest = codeof RhtProg in
      % "Tuple 0; Variant n" --> "Int n" due to variant optimisation %
      CompLiteral([|LiteralInt=n|], tl RhtProg))
   ?? varstruct
     CompLiteral([|LiteralTuple=[]|], RhtProg)
  else EmitRecord(Size)::RhtProg;

let CompVariant((QuaNum,QuaMax):int#int, RhtProg: SMCode' list)
                : SMCode' list =
  EmitVariant(QuaNum)::RhtProg;

let CompIncRefAt(RhtProg: SMCode' list): SMCode' list =
  EmitPrimOp(135) :: RhtProg;

let CompBigVar(RhtProg: SMCode' list): SMCode' list =
  EmitPrimOp(133) :: RhtProg;
%---------------------------------------------------------------%

let CompLabel (RhtProg: SMCode' list): SMCode' list =
   if ((repSMCode'(hd(RhtProg)) is OpLabel) ?? [`Hd`] false)
   then RhtProg
   else (LabelCounter:= !LabelCounter+1;
         absSMCode'([|OpLabel = (|Label= !LabelCounter; Address=ref 0;
                                  NextOp = if null RhtProg then [|Unknown|]
                                           else [|Known = hd(RhtProg)|]|)|])::
         RhtProg);
 
let AbbrevJump(Target: SMCode') =
  if (repSMCode'(Target) as OpLabel).NextOp is Unknown
  then Target
  else let targetOp = (repSMCode'(Target) as OpLabel).NextOp as Known in
  % "LabRef Li;...; Li: Jump Lj" --> "LabRef Lj;...; Li:Jump Lj" %
  if (((repSMCode'(targetOp) as OpJump).JumpType is Always) ?? [`As`] false)
  then (repSMCode'(targetOp) as OpJump).Target
  else Target;

let rec CompJump (JumpType: [|Always; IfTrue; IfFalse|],
                  Target: SMCode', RhtProg: SMCode' list): SMCode' list =
  if (EQPTR(Target, hd(RhtProg)) ?? [`Hd`] false) then RhtProg
  else if (repSMCode'(Target) as OpLabel).NextOp is Unknown
       then EmitJump(JumpType,Target)::RhtProg
  else let targetOp = 
           repSMCode'((repSMCode'(Target) as OpLabel).NextOp as Known) in
         %"AnyJump Li;...; Li:Jump Lj" --> "AnyJump Lj;...; Li:Jump Lj"%
       if (((targetOp as OpJump).JumpType is Always) ?? [`As`] false)
       then CompJump(JumpType,(targetOp as OpJump).Target, RhtProg)
       else if (targetOp is OpReturn) And (JumpType is Always)
         %"Jump Li;...; Li:Return n" --> "Return n;...; Li:Return n"%
       then EmitReturn(targetOp as OpReturn)::RhtProg
       else EmitJump(JumpType,Target)::RhtProg;

let CompClosure (FreeNum: int, RhtProg: SMCode' list): SMCode' list =
  EmitClosure(FreeNum)::RhtProg;

let CompDumClosure (FreeNum: int, RhtProg: SMCode' list): SMCode' list =
  EmitDumClosure(FreeNum)::RhtProg;

let CompRecClosure (FreeNum: int, Displ: int,
                    RhtProg: SMCode' list): SMCode' list =
  EmitRecClosure(FreeNum,Displ)::RhtProg;

let CompSqueeze(Depth: int, RhtProg: SMCode' list): SMCode' list =
  if Depth=0 then RhtProg else
  (let [|OpSlide=(|NumArgs; NumJunk|)|]::rest = codeof RhtProg
    %"Squeeze n; Squeeze m" --> "Squeeze n+m"%
   in if NumArgs=1 
      then EmitSlide(1,Depth+NumJunk)::tl(RhtProg)
      else EmitSlide(1,Depth)::RhtProg)
?? varstruct
  (let [|OpReturn=n|]::rest = codeof RhtProg
    %"Squeeze n; Return m" --> "Return n+m"%
   in EmitReturn(Depth+n)::tl(RhtProg))
?? varstruct
  (let [|OpLabel=x|]::[|OpReturn=n|]::rest = codeof RhtProg
    %"Squeeze n; Label l; Return m" --> "Return n+m; Label l; Return m"%
   in EmitReturn(Depth+n)::RhtProg)
?? varstruct
   EmitSlide(1,Depth)::RhtProg;

let CompApply (NumArgs: int, RhtProg: SMCode' list): SMCode' list =
  (let [|OpSaveFrame|]::rest = codeof RhtProg
     %"RestFrame; SaveFrame" --> ""%
   in absSMCode'([|OpSaveFrame|])::absSMCode'([|OpBCApplFrame|])::abscodeof rest)
?? varstruct
%RJG take out tail recursive calls if Optimising off%
  if Not(!Debug.Optimise) then
   (absSMCode'([|OpSaveFrame|])::
      absSMCode'([|OpBCApplFrame|])::
         absSMCode'([|OpRestFrame|])::RhtProg)
  else
  ((let [|OpReturn=n|]::rest = codeof RhtProg
     %"<n args> SF; AF; RF; Return m" --> "TailApply n m"%
   in EmitTailApply(NumArgs, n)::abscodeof rest)
?? varstruct
  (let [|OpLabel=_|]::[|OpReturn=n|]::rest = codeof RhtProg
     %"<n args> SF; AF; RF; L1:Return m" --> "TailApply n m; L1:Return m"%
   in EmitTailApply(NumArgs, n)::RhtProg)
?? varstruct
  (absSMCode'([|OpSaveFrame|])::
      absSMCode'([|OpBCApplFrame|])::
         absSMCode'([|OpRestFrame|])::RhtProg));

let CompNCApply (NumArgs: int, RhtProg: SMCode' list): SMCode' list =
  (let [|OpSaveFrame|]::rest = codeof RhtProg
     %"RestFrame; SaveFrame" --> ""%
   in absSMCode'([|OpSaveFrame|])::absSMCode'([|OpNCApplFrame|])::abscodeof rest)
?? varstruct
  (let [|OpReturn=n|]::rest = codeof RhtProg
     %"<n args> SF; AF; RF; Return m" --> "TailApply n m"%
   in EmitNCTailApply(NumArgs, n)::abscodeof rest)
?? varstruct
  (let [|OpLabel=_|]::[|OpReturn=n|]::rest = codeof RhtProg
     %"<n args> SF; AF; RF; L1:Return m" --> "TailApply n m; L1:Return m"%
   in EmitNCTailApply(NumArgs, n)::RhtProg)
?? varstruct
  (absSMCode'([|OpSaveFrame|])::
      absSMCode'([|OpNCApplFrame|])::
         absSMCode'([|OpRestFrame|])::RhtProg);


let CompFunId(RhtProg: SMCode' list): SMCode' list =
  (let [|OpSaveFrame|]::[|OpBCApplFrame|]::[|OpRestFrame|]::rest =codeof RhtProg
     %"FunId; SF; AF; RF" --> ""%
   in abscodeof rest)
?? varstruct
  (let [|OpSaveFrame|]::[|OpBCApplFrame|]::[|OpBCApplFrame|]::rest =codeof RhtProg
     %"FunId; SF; AF; AF" --> "SF; AF"%
   in absSMCode'([|OpSaveFrame|])::absSMCode'([|OpBCApplFrame|])::
      abscodeof rest)
?? varstruct
  (let [|OpFunComp|]::rest =codeof RhtProg
     %"FunId; FunComp" --> ""%
   in abscodeof rest)
?? varstruct
  CompOp([|OpFunId|],RhtProg);



%AM these next two routines are also used in MLINIT.  BEWARE%
let CompMonCombinator (Name: Atom', MonOp: SMCode', 
                       RhtProg: SMCode' list): SMCode' list =
  CompLiteral([|LiteralText=(Name, 0, 0, [MonOp; 
                                          EmitReturn(0)])|],
  EmitClosure(0)::
  RhtProg);

let CompBinCombinator (Name: Atom', BinOp: SMCode', 
                       RhtProg: SMCode' list): SMCode' list = 
  CompLiteral([|LiteralText=(Name, 0, 0, [EmitDestTuple(2,0);
                                          BinOp; 
                                          EmitReturn(0)])|],
  EmitClosure(0)::
  RhtProg);


%AM: tidy this up later%
let CompConstrFun(x: SynDataDef', RhtProg: SMCode' list): SMCode' list =
  let i = x.AbsBinder.Ide in
  let p = x.AbsBinder.Constructor as yes
  enc (rep,n,max,impappl) = !p
  enc _ =  x.AbsBinder.Inline :=
    if (max < MaxInt) orelse impappl % RJG extensible constructor %
    then 
	let inlinecode = case rep of
	    [| variant. if max=1 then [] else CompVariant((n,max),[]);
	       xcon=xc. %extensible RJG 10-Mar-89%
	       CompLiteral([|LiteralString=repAtom' i|],
                CompLiteral([|GlobalObject=mkobj(xc)|],
		 CompIncRefAt(CompRecord(2,[]))));
	       pointer. [];
               zero. [];
%AM: the next line does a spurious CompLabel to stop literal optimisation%
               ref. [absSMCode'[|OpRef|]]
             |]
           in [|present = (0,0,inlinecode) |]
    else [| absent |]
  in if impappl then case rep of
  [| variant. if max=1 then CompRecord(0,RhtProg)
              else CompRecord(0,CompVariant((n,max),RhtProg));
     xcon=xc. %extensible%
	       CompLiteral([|LiteralString=repAtom' i|],
	        CompLiteral([|GlobalObject=mkobj(xc)|],
		 CompIncRefAt(CompRecord(2,RhtProg))));

     pointer. failwith `CompConstrFun`;
     zero.    CompRecord(0,RhtProg);
     ref.     failwith `CompConstrFun`
  |]
  else case rep of
  [| variant. if max=1 then CompFunId(RhtProg)
              else CompMonCombinator(i, EmitVariant(n), RhtProg);
     xcon=xc. CompLiteral([|LiteralString=repAtom' i|],
               CompLiteral([|GlobalObject=mkobj(xc)|],
		 EmitPrimOp(134) %OpXConClosure% :: RhtProg));

     pointer. CompFunId(RhtProg);
     zero.    CompFunId(RhtProg);
     ref.     CompMonCombinator(i, absSMCode'[|OpRef|], RhtProg)
  |];


let rec SideEffects(Term: SynTerm'): bool =
  case repSynTerm'(Term) of
  [|SynIde. false;
    SynConst=c. false;
    SynTuple=l. exists(SideEffects,l);
    SynList=l. exists(SideEffects,l);
    SynRecord=l. exists((\q.SideEffects(q.RecField)),l);
    SynVariant=x. SideEffects(x.VarField);
    SynCond=(|CondIf; CondThen; CondElse|).
      exists(SideEffects,[CondIf; CondThen; CondElse]);
    SynWhile=(|WhileCond; WhileBody|).
      exists(SideEffects,[WhileCond; WhileBody]);
    SynLamb=x. false;
    SynAppl. true;
    SynCase=(|Select; Cases|).
      if SideEffects(Select) then true else
      exists((\q.SideEffects(q.Body)), Cases);
    SynJumpcase=(|Select; Cases|).
      if SideEffects(Select) then true else
      exists((\q.SideEffects(q.Body)), Cases);
    SynLet. true;	%AM: a binding failure may occur%
    SynQuaOp=x. SideEffects(x.QuaArg);
    SynForce=x. SideEffects(x.ForceTerm);
    SynTagType=x. SideEffects(x.Arg);
    SynTrap.true;	%AM cowardly%
    SynNewCase.true;
    SynHandle.true;
    SynRaise.true;
    SynSequence=(|SeqLft; SeqRht|).
      exists(SideEffects,[SeqLft; SeqRht])
  |];

%%
%RJG 10-Feb-89 added Frees for extensible datatypes%
%RJG 19-Dec-89 fixed old unary record bug%
let CompBind(Bind': SynBind', Locals: StkPos', Frees: FVL', RhtProg: SMCode' list)
            : (StkPos' # SMCode' list) =

%AM: new version of CompStr 4/9/84.  Note that it relies on
     the side effect of ExtendStk.  Beautify later? %
  let rec {CompStr (Struct: SynBind', Here: StkPos', Locals: StkPos',
                    RhtProg: SMCode' list): (StkPos' # SMCode' list) =
    case repSynBind'(Struct) of
    [|SynBindIde=(|Ide; Binder; PreBinder|).
        case !PreBinder of
        [| absent. (Do (ExtendStk(Binder,Here)); (Locals,RhtProg));
           present=x. CompApplStr(x,absSynBind'[|SynBindTuple=[]|],
                                  Here,Locals,RhtProg) |];
      SynBindAny.
        (Locals,RhtProg);
      SynBindBoth=(x,y).
        let (newlocals,xcode) = CompStr(x,Here,NullExtendStk(Locals,1),[])
        enc (newerlocals,ycode) = CompStr(y,Locals,newlocals,RhtProg)
        in (newerlocals, EmitGetLocal(StkDif(Locals,Here)-1,false)::
                         append(xcode,ycode));
      SynBindTuple=x.
        if null(x) then (Locals,RhtProg) else
        let (newlocals,fstcode) =
          CompStr(hd x, Here, NullExtendStk(Locals,length(x)-1), [])
        and rec f(l,here,locs) = if null(l) then (locs,RhtProg) else
          let (newlocs,hdcode) = CompStr(hd l, here, locs, [])
          enc (newerlocs,tlcode) = f(tl l, NullExtendStk(here,1), newlocs)
          in (newerlocs, append(hdcode,tlcode))
        enc (newerlocals,restcode) = f(tl x, Locals, newlocals)
        in (newerlocals, 
            CompDestTuple(length(x),StkDif(Locals,Here)-1,
               append(fstcode,restcode)));
      SynBindRecord=(x,y).
        let x':SynBindRecord' list = 
            case y of [|solid. x; flexi=f. (!f)() |] in
        if null(x') Or null(x) then (Locals,RhtProg) else
        if null(tl(x)) And y is flexi %RJG unary record bug fix%
                                      % then compile code like a QuaDot ...%
        then let (newlocals,destcode) =
          CompStr((hd x).RecField,Locals,NullExtendStk(Locals,1), []) 
        enc rec posn(tag,taglist:SynBindRecord' list) =
                     if EqAtom(tag,hd(taglist).RecKey) then 0
                     else 1+posn(tag,tl(taglist))
        in (newlocals, 
            CompGetLocal(StkDif(Locals,Here)-1,false,
            CompQuaDot((posn((hd x).RecKey,x'),length(x')),
               append(destcode,RhtProg))))
        else 
        let (newlocals,fstcode) =
          CompStr((hd x').RecField,Here,NullExtendStk(Locals,length(x')-1), [])
        and rec f(l:SynBindRecord' list,here,locs) = 
          if null(l) then (locs,RhtProg) else
          let (newlocs,hdcode) = CompStr((hd l).RecField, here, locs, [])
          enc (newerlocs,tlcode) = f(tl l, NullExtendStk(here,1), newlocs)
          in (newerlocs, append(hdcode,tlcode))
        enc (newerlocals,restcode) = f(tl x', Locals, newlocals)
        in (newerlocals, 
            CompDestTuple(length(x'),StkDif(Locals,Here)-1,
               append(fstcode,restcode)));
      SynBindAppl=x.
        CompApplStr(!x.Binder, x.Arg, Here, Locals, RhtProg);
      SynBindConst=c.
        (Locals, CompDestConst(c, StkDif(Locals,Here)-1, RhtProg));
      SynBindVariant=(|VarKey; VarField; VarPos|).
        let (newlocals,newCode) = CompStr(VarField,Here,Locals,RhtProg)
	enc %RJG for extensible datatypes%
	    (n,m) = (!VarPos)VarKey
        in if m<MaxInt then (newlocals, CompDestVariant((n,m),
                                       StkDif(Locals,Here)-1,newCode))
	   else %extensible% failwith `CompStr:unimplemented DestBigVar`;
      SynBindForce=(|ForceBind; ForceType|).
        CompStr(ForceBind,Here,Locals,RhtProg)
    |]

  and CompApplStr(Ide: SynBindIde', Arg: SynBind', Here: StkPos', Locals: StkPos',
                  RhtProg: SMCode' list): (StkPos' # SMCode' list) =
    let (newlocals,code) = CompStr(Arg, Here, Locals, RhtProg)
    enc displ = StkDif(Locals,Here)-1
    in (newlocals,
        case Ide.Constructor of
        [| no. failwith `SynBindAppl`;
           yes=x. let (rep,n,max,_) = !x in case rep of
             [| variant. if max=1 then code else
                         CompDestVariant((n,max),displ,code);
                xcon=xc. CompVar(Ide,[|Val|],false,Locals,Frees,
                         CompDestBigVar(displ,code));
                pointer. EmitDestPointer(displ) :: code;
                zero.  EmitDestNil(displ) :: code;
                ref. CompDestTuple(1,displ,code)
             |]
        |])
   }
  in CompStr(Bind', Locals, NullExtendStk(Locals,1), RhtProg);


let CompHandle(Cases: SMCode' list, RhtProg: SMCode' list): SMCode' list =
  EmitHandle(Cases)::RhtProg;        %AM: get trapall case specially?%

let CompTrap(Target: SMCode', RhtProg: SMCode' list): SMCode' list = 
  CompRecord(0, CompRecord(1, CompHandle([AbbrevJump Target], RhtProg)));

let CompTrapLambda(Target: SMCode', RhtProg: SMCode' list): SMCode' list = 
  CompRecord(0, CompHandle([AbbrevJump Target], RhtProg));

let CompPopTrap(RhtProg: SMCode' list): SMCode' list = 
  (let [|OpJump=(|JumpType=[|Always|];Target|) |] :: rest = codeof RhtProg
   in absSMCode'[|OpUnTrap=Target|] :: tl RhtProg)
?? varstruct (absSMCode'[|OpPopTrap|] :: RhtProg);

let CompUnTrap(Target: SMCode', RhtProg: SMCode' list): SMCode' list = 
  CompPopTrap(CompJump([|Always|],Target,RhtProg));

%%
%AM: the following predicate spots the code produced by ()=() ...%
let IsTrivEqCode(x: SMCode' list): bool =
  (let [ [|OpGetLiteral=(|LiteralType;LiteralsNeeded|)|];
         [|OpSlide=(|NumArgs;NumJunk|)|] ] = codeof x
   enc [|LiteralBool=x|] = repliterals'(LiteralType).LiteralForm
   in x And NumArgs=1 And NumJunk=2)
?? varstruct false;

let OldRhtProg = [];     %AM: aide memoire%

let CompEqualRecord(SubEqCode: (SMCode' list) list): SMCode' list =
  if null(SubEqCode)
    then CompLiteral([|LiteralBool=true|],CompSqueeze(2,OldRhtProg))
    else let ContProg = CompLabel(CompSqueeze(2,OldRhtProg)) in
      let FieldMax = length(SubEqCode) in
      let rec f(FieldNum:int, SubEqCode) =
         CompGetLocal(1,false,
         CompQuaDot((FieldNum,FieldMax),
         CompGetLocal(1,false,
         CompQuaDot((FieldNum,FieldMax),
         Thread(hd SubEqCode,
         if null(tl SubEqCode)
         then ContProg
         else let NextProg = CompLabel(f(FieldNum+1, tl(SubEqCode))) in
           CompJump([|IfTrue|],hd(NextProg),
           CompLiteral([|LiteralBool=false|],
           CompJump([|Always|],hd(ContProg),NextProg))) )))))
      in f(0, SubEqCode);

let CompEqualVariant(SubEqCode: (SMCode' list) list): SMCode' list =
  let ContProg = CompLabel(CompSqueeze(2,OldRhtProg)) in
  let ContProg1 = CompLabel(CompSqueeze(1,ContProg)) in
  let FalseProg = CompLabel(CompLiteral([|LiteralBool=false|], ContProg1)) in
  let CaseMax = length(SubEqCode) in
  let f SubEqCode
        ((CaseList: SMCode' list,NextProg:SMCode' list), CaseNum:int) =
    let ThisProg = 
      CompLabel(
      CompGetLocal(1,false,
      CompQuaIs((CaseNum-1,CaseMax),
      if IsTrivEqCode(SubEqCode)
      then CompJump([|Always|],hd(ContProg1), NextProg)
      else CompJump([|IfFalse|],hd(FalseProg),
           CompGetLocal(1,false,
           CompQuaAs((CaseNum-1,CaseMax),
           Thread(SubEqCode,
           CompJump([|Always|],hd(ContProg),NextProg))))) )))
    in ((hd ThisProg::CaseList, ThisProg), CaseNum-1)
  in CompGetLocal(1,false,
     CompCase(fst(itlist f SubEqCode (([],FalseProg),CaseMax))));


let rec CompEqualSimp(Typ: TypTerm'):SMCode' list =
  let Typ2 = PruneEqType(Typ) in
  case repTypTerm'(Typ2) of
  [|TypVar=tv. [EmitPrimOp(40 %Eq%)];
    TypConVar. EqualityError(`I cannot compare types containing type constructor variables`);
    TypDefOper=x. failwith `CompEq`;	% FullPrune got rid of this %
    TypAbsOper=x. (!x.AbsInfo.AbsEqFn)(map CompEqualSimp (x.AbsArgs))
        ?? [`CompEqualADT`] [EmitPrimOp(40 %Eq%)];
    TypTagOper=x. 
      case x.TagSort of
      [| Record.
           case !x.TagList of
           [| TagInstance. failwith `CompEq`;
              Solid=l. [EmitPrimOp(40 %Eq%)];
              Flexi. EqualityError(`I cannot compare flexible records`) |];
        Variant. 
           case !x.TagList of
           [| TagInstance. failwith `CompEq`;
              Solid=l. [EmitPrimOp(40 %Eq%)];
              Flexi. EqualityError(`I cannot compare flexible variants`) |]
      |]
    |]

ins CompEqual(Typ: TypTerm', RhtProg: SMCode' list):SMCode' list =
 ( OnEqErrorShowType(Typ);
   Thread(CompEqualSimp(Typ), RhtProg));


let rec CompWriteSimp(Typ: TypTerm', RhtProg: SMCode' list):SMCode' list =
  let Typ2 = PruneEqType(Typ) in
  case repTypTerm'(Typ2) of
  [|TypVar=tv.    EqualityError(`I cannot print polymorphic objects`);
    TypConVar. failwith `CompPrint:ConVar`;
    TypDefOper=x. Crash();	% FullPrune got rid of this %
    TypAbsOper=x.
%      let AbsOperStamp, AbsArgs = x.AbsInfo.AbsOperStamp, x.AbsArgs in %
      EqualityError(`I cannot print abstract data types`);
    TypTagOper=x.
      EqualityError(`Record/Variant printing unimplemented`)
  |]

ins CompWrite(Typ: TypTerm', RhtProg: SMCode' list):SMCode' list =
 ( OnEqErrorShowType(Typ);
   CompWriteSimp(Typ, RhtProg));


let InitEqFns =
 (| ADT = \l. EqualityError(`I cannot compare abstract types`);
    Bool = \[].CompOp([|OpEqual=[|Bool|]|],OldRhtProg);
    Int = \[].CompOp([|OpEqual=[|Int|]|],OldRhtProg);
    Real = \[].CompOp([|OpEqual=[|Real|]|],OldRhtProg);
    String = \[].CompOp([|OpEqual=[|String|]|],OldRhtProg);
    Dynamic = \l. EqualityError(`I cannot compare dynamic types`);
    Ref = \l.CompOp([|OpEqual=[|Ref|]|],OldRhtProg);
    Sum = CompEqualVariant;
    Tuple = CompEqualRecord;
    Fun = \l. EqualityError(`I cannot compare functions`);
    Star = \[elteqcode].(
  let LoopLab =  hd(CompLabel([]))
  enc ContProg = CompLabel(CompSqueeze(2,OldRhtProg))
  enc FResProg = CompLabel(
                 CompLiteral([|LiteralBool=false|],
                 ContProg))
  enc NullLftProg = CompLabel(
                    CompGetLocal(1,false,
                    CompPrimOp(19 %Null%,
                    CompJump([|IfTrue|],hd(FResProg),
                    EmitDestTuple(2,1)::EmitDestTuple(2,1)::
                    EmitGetLocal(3,false)::EmitGetLocal(3,false)::
                    EmitSlide(4,2)::        %AM: a clumsy way to do it%
                    Thread(elteqcode,
                    CompJump([|IfTrue|],LoopLab,FResProg))))))
  in LoopLab::CompGetLocal(0,false,
              EmitPrimOp(19 %Null%)::
              CompJump([|IfFalse|],hd(NullLftProg),
              CompGetLocal(1,false,
              CompPrimOp(19 %Null%,
              CompJump([|Always|],hd(ContProg),NullLftProg)))))
) |);


%AM: size of the top \-binder of an identifier, used for optimising
     tuple arguments to a function into multiple values on a stack.
     Note that result ~1 indicates that the pattern is 'complicated'%
let rec TopPatternSize(bind: SynBind'): int = case repSynBind'(bind) of
    [|SynBindIde=x. ~1;
      SynBindAny.   ~1;
      SynBindConst. ~1;
      SynBindBoth.  ~1;
      SynBindTuple=BindTuple. length(BindTuple);
      SynBindRecord=(BindRecord,Flexi). 
        case Flexi of 
        [| solid. length(BindRecord);
           flexi=f.
             if null(tl(BindRecord))
             then ~1 % treat {x,...} like a QuaDot %
             else length((!f)()) % return full length of record %
        |]; 
      SynBindAppl=x. ~1;
      SynBindVariant=x. ~1;
      SynBindForce=x. TopPatternSize(x.ForceBind) |];  

%AM: the type checker has ensured that the Bind's in a Match will have
     TopPatternSize's equal to one another, or ~1%
let MatchArity(x: SynMatch'):int =
    if null(x) then failwith `MatchArity`
    else let (bind1,body1)::rest = x in
         if null(rest) then TopPatternSize(bind1)
         else ~1;

% This version of failable will be used when type x = data ... is implemented.
let rec failable(bind: SynBind'): bool = case repSynBind'(bind) of
    [|SynBindIde=x. false;   ***BEWARE***
      SynBindAny.   false;
      SynBindBoth=(x,y).   failable(x) Or failable(y);
      SynBindTuple=BindTuple. exists(failable,BindTuple);
      SynBindRecord=(BindRecord,Flexi). 
                           exists((\q.failable(q.RecField)),BindRecord);
      SynBindAppl=x. true;
      SynBindConst=x. true;
      SynBindVariant=x. true;
      SynBindForce=x. failable(x.ForceBind) |];  
%
let rec failable(x: SMCode' list): bool =
  if null(x) then false
  else let opcode = repSMCode'(hd x) in
       if opcode is OpDestTuple Or opcode is OpGetLocal 
       Or opcode is OpQuaDot
       then failable(tl x)
       else true;


let rec CompFVL(FVL: (SynBindIde' # VarType) list,
                Locals: StkPos', Frees: FVL', LastUse,
		RhtProg: SMCode' list): SMCode' list =
    if null(FVL) then RhtProg 
    else let (sb,vt) = hd FVL in
       CompVar(sb,vt,
               exists((\x.EQPTR(x,sb)),LastUse),Locals,Frees,
       CompFVL(tl FVL, NullExtendStk(Locals,1), Frees, LastUse, RhtProg));

let GenerateInlineCode (code: SMCode' list, RhtProg: SMCode' list)
   : SMCode' list =
   let {LabelledRhtProg = CompLabel(RhtProg) 
   enc  rec lookup labels target =
        if null labels then failwith `GenerateInlineCode`
        else if EQPTR(fst(hd(labels)), target) then snd(hd(labels))
        else lookup (tl(labels)) target
   enc  rec generatelabels(code,labels) =
        if null code then labels
        else let h::t = code in
           let newlabels = generatelabels(t,labels)
           enc opcode = repSMCode' h in
              if opcode is OpLabel
              then let newlabel = hd(CompLabel([])) in
                   ((h, newlabel)::newlabels)
              else newlabels
   enc  rec mapinline(code,rhtprog,labels) =
        if null code then rhtprog
        else let h::t = code in
           let rest = mapinline(t,rhtprog,labels)
           enc opcode = repSMCode' h in
              if opcode is OpJump
              then 
                 CompJump((opcode as OpJump).JumpType,
                          (lookup labels ((opcode as OpJump).Target)), rest)
              else if opcode is OpUnTrap
              then CompUnTrap(
                      (lookup labels ((opcode as OpUnTrap))), rest)
              else if opcode is OpHandle
              then CompHandle(
                      (map (lookup labels) (opcode as OpHandle)), rest)
              else if opcode is OpCase
              then CompCase(
                      (map (lookup labels) (opcode as OpCase)), rest)
              else if opcode is OpLabel
              then (lookup labels h)::rest
              else if opcode is OpReturn
              then CompSqueeze(opcode as OpReturn,
                   CompJump([|Always|],hd(LabelledRhtProg),rest))
              else (h::rest) } in
   mapinline(code, LabelledRhtProg, generatelabels(code,[]));


let CheckForInlineCode((name,maxarg,maxctl,funcode),
                       maxlen: int): InlineCode' =
    let inlinelength = 
           (RhtReduceList
               (\e.\l. if (l > maxlen) 
                       Or (repSMCode'(e) is OpCurrClos) 
                       Or (repSMCode'(e) is OpNCTailApply) %AJG-17/6/91%
                       Or (repSMCode'(e) is OpBCTailApply) 
                       Or (repSMCode'(e) is OpThread) %shouldn't happen%
                       then failwith `inlinelength`
                       else if repSMCode'(e) is OpLabel
                       then l
                       else l+1)
               funcode
               0)
        ?? [`inlinelength`] ~1
     in if (inlinelength >= 0) And (!Debug.Optimise)
        then [|present=(maxarg,maxctl,funcode)|]
        else [|absent|];


let UpdateSynBindIde( SgSBI: SynBindIde', StSBI: SynBindIde' ): unit =
    ( SgSBI.References := !StSBI.References;
      if (SgSBI.Constructor) is yes And (StSBI.Constructor) is yes then
         ((SgSBI.Constructor) as yes) := !((StSBI.Constructor) as yes)
      else ();
      SgSBI.Inline := !StSBI.Inline;
      SgSBI.StkPosn := [| Local= ~1 |];
      SgSBI.NativeCoded := !StSBI.NativeCoded;
      SgSBI.MinFunArity := !StSBI.MinFunArity;
      SgSBI.UserArity := !StSBI.UserArity
      %* SMorUser field not copied; change when overloading introduced? *% );

use "pattcomp.ml";

%AJG % let Functionliteralname = ref AtomLambda;
%AJG % let NativeOption : (string -> bool) ref = ref (\x.false);

let rec
{   CompMatch(Rules: SynMatch', Locals: StkPos', Frees: FVL',
              Continuation: SMCode' list -> SMCode' list,
              RhtProg: SMCode' list): SMCode' list =
    let _ = if !Print.ObjectCode
            then mktree (map (\(b,t):SynRule'. b) Rules)
            else ()
    enc iterfun(bind:SynBind',body:SynTerm')
               (last:bool,rhtprog:SMCode' list) = (false,
        let newlocals = if last then Locals else NullExtendStk(Locals,1)
        enc (newerlocals,bindcode) = CompBind(bind,newlocals,Frees,[])
        enc bodycode contprog =
            CompTerm(body,newerlocals,Frees,
            CompSqueeze(StkDif(newerlocals,Locals),
            Continuation(contprog)))
        in if failable(bindcode)
           then let catchprog = CompLabel(EmitSlide(0,1)::rhtprog) in
             CompTrap(hd catchprog,
             append((if last then bindcode else CompGetLocal(0,false,bindcode)),
             CompPopTrap(bodycode(catchprog))))
        else let code = 
          append((if last then bindcode else CompGetLocal(0,false,bindcode)),
                 bodycode(RhtProg)) in
            (let [|OpGetLocal=(0,_)|] :: [|OpQuaDot=x|] ::
                 [|OpReturn=1|]::rest =
                 codeof code
                 %"GetLocal 0; Dot n; Return 1" --> "Dot n; Return 0"%
              in EmitQuaDot(x)::EmitReturn(0)::abscodeof(rest))
            ?? varstruct code )   %AM: skip following cases/raise%

    in
      (if ((!Debug.CheckMatchLimit)>0) then (Do CheckMatch(Rules)) else ();
       snd(itlist iterfun Rules
%RJGraise%      (true, %CompRecord 0,%
%RJG match                   CompLiteral([|LiteralString=`Match`|],%
%RJG match                      CompLiteral([|GlobalObject=mkobj(Match)|],%
%RJGraise            CompRecord(1, CompOp([|OpRaise|], RhtProg))))))%
%RJGmatch%            CompPrimOp(254 %OpRaiseMatch%,
                                 RhtProg))))


%RJG 08-Mar-89%
%RJG - taken out "last" checks, not wanted here!%
% e.g.  (raise Io "foo") handle Io "few" => 0%
    and CompMatchXn(Rules: SynMatch', Locals: StkPos', Frees: FVL',
              Continuation: SMCode' list -> SMCode' list,
              RhtProg: SMCode' list): SMCode' list = 
    let _ = if !Print.ObjectCode
            then mktree (map (\(b,t):SynRule'. b) Rules)
            else ()
    enc iterfun(bind:SynBind',body:SynTerm')
               (last:bool,rhtprog:SMCode' list) = (false,
        let newlocals = %if last then Locals else% NullExtendStk(Locals,1)
        enc (newerlocals,bindcode) = CompBind(bind,newlocals,Frees,[])
        enc bodycode contprog =
            CompTerm(body,newerlocals,Frees,
            CompSqueeze(StkDif(newerlocals,Locals),
            Continuation(contprog)))
        in if failable(bindcode)
           then let catchprog = CompLabel(EmitSlide(0,1)::rhtprog) in
             CompTrap(hd catchprog,
             append((%if last then bindcode else% CompGetLocal(0,false,bindcode)),
             CompPopTrap(bodycode(catchprog))))
        else let code = 
          append((%if last then bindcode else% CompGetLocal(0,false,bindcode)),
                 bodycode(RhtProg)) in
            (let [|OpGetLocal=(0,_)|] :: [|OpQuaDot=x|] ::
                 [|OpReturn=1|]::rest =
                 codeof code
                 %"GetLocal 0; Dot n; Return 1" --> "Dot n; Return 0"%
              in EmitQuaDot(x)::EmitReturn(0)::abscodeof(rest))
            ?? varstruct code )   %AM: skip following cases/raise%

    in
      (if ((!Debug.CheckMatchLimit)>0) then (Do CheckMatch(Rules)) else ();
       snd(itlist iterfun Rules
                  ( true, CompPrimOp(253 %OpReRaise%, RhtProg))))

%%
and CompLambda (synlamb, Locals: StkPos', Frees: FVL',
                ClosProgFun: int -> SMCode' list, 
                DummyFun: SMCode' list,
                BindIde: SynBindIde' opt) 
               : int # SMCode' list # InlineCode' # bool =
    let (|Match=Rules; LastUseFreeVar|) = synlamb
    enc FrontLabel = if BindIde is present then CompLabel([]) else []
%AJGDEL enc Name = case BindIde of [|absent. AtomLambda; present=b. b.Ide |]%
    enc Name = case BindIde of [|absent. !Functionliteralname; 
                                 present=b. b.Ide |]
    enc _ = Functionliteralname := Name  %AJG minor hack to give better info%
    enc CurrFn = case BindIde of
     [| absent. [|NoFun|];
        present=b. [|Fun=(b,hd FrontLabel)|] |]: [|NoFun; Fun: SynBindIde'#SMCode'|]
    enc NewFrees = (| List=ref []; EndLocals=Locals; MaxArgStk=ref 0;
                      MaxCtlStk=ref 0; CurrFn=CurrFn |):FVL' in
    %AM: merge/improve TopPatternSize/CompBind relationship sometime!%
    let topbindsize = MatchArity(Rules)
    enc simplebinder = (topbindsize>=0)
    enc _ = case BindIde of [|present=x.
%AJG%		x.NativeCoded := ((!Debug.NativeCodeFns) Or
%AJG(does not work yet)%	(!NativeOption)(forgettype(Name)));
%AJGDEL x.NativeCoded := !Debug.NativeCodeFns;%
                              absent. ()|]
    enc (bodytext,code) = if simplebinder
      then let [(Bind',Body)] = Rules		%AM: ensured by MatchArity%
           enc (newlocals,bindcode) =
              if topbindsize = 0 then (Locals, [EmitSlide(0,1)])
              else CompBind(Bind',Locals,Frees,[])
           enc bindsize = StkDif(newlocals,Locals)
           enc bodytext = if !Debug.NativeCodeFns
	                  then 
	                     (Name,100,100,
                              absSMCode'[|OpNCBind = topbindsize|]::
			      append(FrontLabel,
                              append(tl bindcode,
                              CompTerm(Body,newlocals,NewFrees,
                              [EmitReturn(bindsize)]))))
			  else
			     (Name,100,100,
                              append(FrontLabel,
                              append(tl bindcode,
                              CompTerm(Body,newlocals,NewFrees,
                              [EmitReturn(bindsize)])))) in
           (bodytext,CompLiteral([|LiteralText=bodytext|],
                     CompClosure(length(!NewFrees.List),
                     CompLiteral([|LiteralText=(Name,100,100, 
                                   if (((repSMCode'(hd bindcode) 
                                   as OpDestTuple).Size = topbindsize) And
                                       ((repSMCode'(hd bindcode) 
                                   as OpDestTuple).Displ = 0)) ? false
                                   then 
				      if !Debug.NativeCodeFns
                                      then [absSMCode'
                                         [|OpNCDestTailApply=topbindsize|]] 
                                      else [absSMCode'
                                         [|OpBCDestTailApply=topbindsize|]] 
                                   else
				      if !Debug.NativeCodeFns
                                      then [absSMCode'[|OpNCBind=topbindsize|];
                                            hd bindcode; EmitGetFree(1);
                                            absSMCode'([|OpNCTailApply=
						       (|NumArgs=topbindsize; 
							 NumJunk=0|)|])] 
                                      else [absSMCode'[|OpBCBind=topbindsize|];
                                            hd bindcode; EmitGetFree(1);
                                            EmitTailApply(topbindsize,0)] )|],
                     ClosProgFun(1)))))
      else 

%AJGDEL
   if !Debug.NativeCodeFns
           then let bodytext = (Name,100,100,
                         absSMCode'[|OpNCBind = 1|]::
                         append(FrontLabel,
                         CompMatch(Rules, Locals, NewFrees,
                                   (\r.EmitReturn(0)::r), []))) in
                (bodytext,CompLiteral([|LiteralText=bodytext|],
			  CompClosure(length(!NewFrees.List),
                          CompLiteral([|LiteralText=(Name,100,100, 
                                   [absSMCode'[|OpBCBind=1|];
                                            EmitGetFree(1);
                                            absSMCode'([|OpNCTailApply=
						       (|NumArgs=1; 
							 NumJunk=0|)|])] )|],
                          ClosProgFun(1)))))

AJGDEL%
% Changes for NC4ESML %
     if !Debug.NativeCodeFns
	then let bodytext = (Name,100,100,
                        absSMCode'[|OpNCBind = 1|]::  % tag native text %
                         append(FrontLabel,
                         CompMatch(Rules, Locals, NewFrees,
                                   (\r.EmitReturn(0)::r), []))) in
                (bodytext,CompLiteral([|LiteralText=bodytext|],
                          ClosProgFun(length(!NewFrees.List))))
% End of Changes for NC4ESML %

           else let bodytext = (Name,100,100,
                         append(FrontLabel,
                         CompMatch(Rules, Locals, NewFrees,
                                   (\r.EmitReturn(0)::r), []))) in
                (bodytext,CompLiteral([|LiteralText=bodytext|],
                          ClosProgFun(length(!NewFrees.List))))
    enc numfrees = length(!NewFrees.List)
    enc dumsize = if simplebinder 
%AJGDEL Or !Debug.NativeCodeFns %
  then 1 else numfrees
    in case BindIde of   %AM: explicit name available: set InlineCode field%
    [|present=x. if (!Debug.InlineCode > 0) And (numfrees = 0)
        then 
           if (!x.MinFunArity > 0) And (!x.References = 1)
           then % the function is only used once so inline expand the call 
                  if possible %
             let inlinecode = CheckForInlineCode(bodytext, 500) in
             if (inlinecode is present) And
                Not ((!x.Inline) is usedasclosure)
             then (dumsize, DummyFun, inlinecode,false)
             else (dumsize, code, inlinecode,true)
           else
             (dumsize, code, 
              CheckForInlineCode(bodytext, !Debug.InlineCode),true)
        else (dumsize, 
              CompFVL(!NewFrees.List,Locals,Frees,!LastUseFreeVar,code), 
              [|absent|], true);
      absent.(dumsize, 
              CompFVL(!NewFrees.List,Locals,Frees,!LastUseFreeVar,code), 
              [|absent|], true)
    |]
%%
enc CompCurrClos(topcurrclos: SMCode', appcode: SMCode' list): SMCode' list = 
   if repSMCode'(hd(appcode)) is OpBCTailApply
   then
      let [|OpBCTailApply=(|NumArgs;NumJunk|)|]::rest =
          codeof appcode in
      EmitSlide(NumArgs,NumJunk)::
      CompJump([|Always|], topcurrclos, abscodeof rest)
   else
% section added by AJG for NC tail apply %
if repSMCode'(hd(appcode)) is OpNCTailApply  
   then
      let [|OpNCTailApply=(|NumArgs;NumJunk|)|]::rest =
          codeof appcode in
      EmitSlide(NumArgs,NumJunk)::
      CompJump([|Always|], topcurrclos, abscodeof rest)
   else
      absSMCode'[|OpCurrClos|]::appcode

enc CompCall(Fun: SynTerm',Arg: SynTerm', Locals: StkPos',
             Frees: FVL', RhtProg: SMCode' list): SMCode' list =

  let CompFunSpread(Arg:SynTerm', ArgsRequired: Arity', Locals: StkPos', 
                    RhtProg: SMCode' list): SMCode' list =
    if Not (ArgsRequired>=0) then CompTerm(Arg,Locals,Frees,RhtProg) else
    let rec LoadTuple(l,Locals,RhtProg) =
      if null(l) then RhtProg
      else CompTerm(hd(l), Locals, Frees,
                    LoadTuple(tl(l), NullExtendStk(Locals,1), RhtProg)) in
    let repArg = repSynTerm'(Arg) in
    if repArg is SynTuple then % we have a syntactic tuple %
      if length(repArg as SynTuple)<>ArgsRequired then failwith `CompFunSpread`
      else LoadTuple(repArg as SynTuple, Locals, RhtProg)
    else if repArg is SynRecord then % we have a syntactic record %
      if length(repArg as SynRecord)<>ArgsRequired then failwith `CompFunSpread`
      else LoadTuple(map (\q.q.RecField) (repArg as SynRecord), Locals, RhtProg)
    else % typing means we have a semantic tuple of the correct length...%
      CompTerm(Arg,Locals,Frees,
               (if ArgsRequired=0 then EmitSlide(0,1)::RhtProg
                else CompDestTuple(ArgsRequired,0,RhtProg)))
  in
  let repFun = repSynTerm'(Fun) in
    if repFun is SynIde
    then % simple identifier rator %
      let (|Ide; LastUse; Binder; MonoType|) = repFun as SynIde in
      let Binder = (!Binder)() in
      case Binder.SMorUser of
      [| NonPrimitive. % user defined function name %
           let spread = !Binder.UserArity
           enc InlineCode = !Binder.Inline in
           if InlineCode is present
           then let (maxarg,maxctl,incode) = InlineCode as present in
                CompFunSpread(Arg,spread,Locals,
                   GenerateInlineCode(incode, RhtProg))
           else let nargs = if spread>=0 then spread else 1
                enc newlocals = NullExtendStk(Locals,nargs) 
                enc appcode   = if !Binder.NativeCoded
                                then CompNCApply(nargs,RhtProg) 
                                else CompApply(nargs,RhtProg) 
                enc currfn    = (EQPTR((fst(Frees.CurrFn as Fun)), 
                                       Binder) ?? [`As`] false) in
              (Binder.Inline := [|usedasclosure|];
               CompFunSpread(Arg,spread,Locals,
               if currfn
               then CompCurrClos(snd(Frees.CurrFn as Fun),appcode)
               else if spread>=0 
% AJGDEL Or !Binder.NativeCoded %
then    % fast entry point call %
                  CompQVar(Binder,[|Val|],!LastUse,newlocals,Frees,appcode)
               else
                  CompVar(Binder,[|Val|],!LastUse,newlocals,Frees,appcode)));

        OverLoaded.
%RJGrai   CompRecord(0,%
          CompLiteral([|LiteralString=`overload internal error`|],
%RJGrai)% CompRecord(1, CompOp([|OpRaise|],RhtProg)));

        PseudoOp=OpCode.
        let primcode = case OpCode of
         [|OpEqual. CompEqual(!MonoType, RhtProg);
           OpNotEq. CompEqual(!MonoType, CompPrimOp(30 %Not%,RhtProg));
           OpWrite. CompWrite(!MonoType, RhtProg) |]
        in if OpCode is OpWrite
        then CompTerm(Arg,Locals,Frees,primcode)
        else CompFunSpread(Arg,2,Locals,primcode)
      |]
    else if repFun is SynLamb
      then 
        let bindide = (| Ide = dummyAtom; References = ref 1;
                         StkPosn = ref [|Local= ~1|]; 
                         Constructor = [|no|]; 
                         Inline = ref [|absent|];
                         MinFunArity = ref 1; NativeCoded = ref false;
                         SMorUser = [|NonPrimitive|]; 
                         UserArity = ref (MatchArity((repFun as SynLamb).Match))
                      |): SynBindIde'
        enc (dumsize, code, inlinecode, fnpresent) =
            CompLambda(repFun as SynLamb,
                       Locals,Frees, (\q.CompClosure(q,[])),
                       CompRecord(0,[]), [|present = bindide|]) 
         in if inlinecode is present
            then let (maxarg,maxctl,incode) = inlinecode as present in
                 CompFunSpread(Arg,!(bindide.UserArity),Locals,
                   GenerateInlineCode(incode, RhtProg))
            else Thread(code,
                 CompTerm(Arg,NullExtendStk(Locals,1),Frees,
                 CompGetLocal(1,false, 
                 CompApply(1,
                 CompSqueeze(1,RhtProg)))))   
            
    else 
      let newlocals = NullExtendStk(Locals,1) in
      if (if SideEffects(Fun) then SideEffects(Arg)
          else false)           %AM: get new ML order of eval%
      then CompTerm(Fun,Locals,Frees,
           CompTerm(Arg,newlocals,Frees,
           CompGetLocal(1,false, 
%AM: this and the squeeze is really a permute%
%AJG -- are these the Apply rather than BCApply ? %
           CompApply(1,
           CompSqueeze(1,RhtProg)))))
      else CompTerm(Arg,Locals,Frees,
           CompTerm(Fun,newlocals,Frees,
           CompApply(1,RhtProg)))


enc CompTerm(Term: SynTerm', Locals: StkPos',
             Frees: FVL', RhtProg: SMCode' list): SMCode' list =
  case repSynTerm'(Term) of
  [|SynIde=(|Ide; LastUse;  Binder; MonoType|).
      let Binder = ((!Binder)()):SynBindIde' in
      case (Binder:SynBindIde').SMorUser of
      [| NonPrimitive.
           case (Binder:SynBindIde').Constructor of    %AM: hack for SML...%
           [| no. CompVar(Binder,[|Val|],!LastUse,Locals,Frees,RhtProg);
              yes=p. let (_,_,max,impappl) = !p 
                     in
                     if impappl then %RJG never inline expand extensibles%
		      if max<MaxInt then CompCall(Term,absSynTerm'[|SynTuple=[]|],Locals,Frees,RhtProg)
		      else %extnsible% CompVar(Binder,[|Val|],!LastUse,Locals,Frees,RhtProg)
                     else CompVar(Binder,[|Val|],!LastUse,Locals,Frees,RhtProg)
           |];
         OverLoaded.
           CompVar(Binder,[|Val|],!LastUse,Locals,Frees,RhtProg);

         PseudoOp=OpCode.
         case OpCode of
          [|OpEqual. % \a,b. a=b %
              CompBinCombinator(Ide,
                absSMCode'[|OpThread=CompEqual(!MonoType,[])|],
                                RhtProg);
            OpNotEq. % \a,b. a<>b %
              CompBinCombinator(Ide,
                absSMCode'[|OpThread=CompEqual(!MonoType,
                                                  [EmitPrimOp(30 %Not%)])|],
                                RhtProg);
            OpWrite. % \x. write(x) %
              CompMonCombinator(Ide,
                absSMCode'[|OpThread=CompWrite(!MonoType,[])|], RhtProg)
         |]
      |];

    SynConst=c. CompConst(c,RhtProg);
    SynTuple=RecList.
      ReduceList(
                 (\h,(n,l). ((n+1,NullExtendStk(l,1)),l)),
                 (\(n,l).CompRecord(n,RhtProg)),
                 (\h,l,p'.
                    (CompTerm(h,l,Frees,p')))
                ) RecList (0,Locals);
    SynList=TermList.
      ReduceList(
                 (\h,(p,l). ((CompRecord(2,p), NullExtendStk(l,1)),l)),
                 (\p,l. CompRecord(0,p)),
                 (\h,l,p'. CompTerm(h,l,Frees,p'))
                ) TermList (RhtProg, Locals);
    SynRecord=RecList.
      ReduceList(
                 (\h,(n,l). ((n+1,NullExtendStk(l,1)),l)),
                 (\(n,l).CompRecord(n,RhtProg)),
                 (\h,l,p'.
                    (CompTerm(h.RecField,l,Frees,p')))
                ) RecList (0,Locals);
    SynVariant=(|VarKey;VarField;VarPos|).
      CompTerm(VarField,Locals,Frees,
               CompVariant((!VarPos)VarKey,RhtProg));
    SynCond=(|CondIf; CondThen; CondElse|).
      let {LabelledRhtProg = CompLabel(RhtProg)
      enc  ElseProg = 
           CompLabel(CompTerm(CondElse,Locals,Frees,
                              LabelledRhtProg))
      enc  ThenProg = CompTerm(CondThen,Locals,Frees,
                               CompJump([|Always|],hd(LabelledRhtProg),ElseProg))
      enc  IfProg = CompJump([|IfFalse|],hd(ElseProg),ThenProg) }
       in CompTerm(CondIf,Locals,Frees,IfProg);
    SynWhile=(|WhileCond; WhileBody|).
      let {LabelledRhtProg = CompLabel(CompRecord(0,RhtProg))
      enc  LabelledStart = CompLabel([])
      enc  BodyProg = CompTerm(WhileBody,Locals,Frees,
                      EmitSlide(0,1)::
                      CompJump([|Always|],hd(LabelledStart),LabelledRhtProg))
      enc  WhileProg = CompJump([|IfFalse|],hd(LabelledRhtProg),BodyProg) }
       in Thread(LabelledStart,CompTerm(WhileCond,Locals,Frees,WhileProg));
    SynLamb=x. let (dumsize, code, inlinecode, fnpresent) =
      CompLambda(x,Locals,Frees, (\q.CompClosure(q,RhtProg)),
                 CompRecord(0,RhtProg),[|absent|]) in code;
    SynAppl=(|Fun; Arg; HowRead|).
      CompCall(Fun, Arg, Locals, Frees, RhtProg);
    SynCase=(|Select; Cases|).
      let ContProg = CompLabel(RhtProg) 
      enc CaseCode(|Tag; Bind=Bind'; Body|)(CaseList,rhtprog) =
           let (newlocals,bindcode) = CompBind(Bind',Locals,Frees,[]) 
           enc thisprog = CompLabel(
                          append(bindcode,
                          CompTerm(Body,newlocals,Frees,
                          CompSqueeze(StkDif(newlocals,Locals),
                          CompJump([|Always|],hd(ContProg),rhtprog)))))
           in (hd thisprog::CaseList, thisprog)
      in CompTerm(Select,Locals,Frees,
                  CompCase(itlist CaseCode Cases ([],ContProg)));
    SynJumpcase=(|Select; Cases|).
      let ContProg = CompLabel(RhtProg) 
      enc CaseCode(|Tag; Bind=Bind'; Body|)(CaseList,rhtprog) =
           let (newlocals,bindcode) = CompBind(Bind',Locals,Frees,[]) 
           enc thisprog = CompLabel(
                          append(bindcode,
                          CompTerm(Body,newlocals,Frees,
                          CompSqueeze(StkDif(newlocals,Locals),
                          CompJump([|Always|],hd(ContProg),rhtprog)))))
           in (hd thisprog::CaseList, thisprog)
      in CompTerm(Select,Locals,Frees,
                  CompCase(itlist CaseCode Cases ([],ContProg)));
    SynLet=(|Decl; Scope|).
      let (code,newlocals) =
          CompDecl(Decl,Locals,Frees,[])
       in append(code,
                 CompTerm(Scope,newlocals,Frees,
                          CompSqueeze(StkDif(newlocals,Locals),RhtProg)));
    SynQuaOp=(|QuaOp; QuaArg; QuaIde; QuaPos|).
      CompTerm(QuaArg,Locals,Frees,
               case QuaOp of
               [|SynQuaDot. CompQuaDot((!QuaPos)QuaIde,RhtProg);
                 SynQuaIs.  CompQuaIs ((!QuaPos)QuaIde,RhtProg);
                 SynQuaAs.  CompQuaAs ((!QuaPos)QuaIde,RhtProg)
               |]);
    SynForce=(|ForceTerm; ForceType|).
      CompTerm(ForceTerm,Locals,Frees,RhtProg);
    SynTagType=(|Arg; Type; Purpose|).
      case Purpose of
      [|Print.  CompTerm(Arg,Locals,Frees,
                CompGetLocal(0,false,
                CompLiteral([|GlobalObject=mkobj((!ValPrintFn)(!Type))|],
                CompApply(1,
                CompGetLocal(1,true,
                CompSqueeze(2,RhtProg))))));
        Dynamic.CompTerm(Arg,Locals,Frees,
                CompLiteral([|GlobalObject=mkobj(!Type)|],
                CompRecord(2,RhtProg)));
        Cast.   let RestProg = 
                    CompLabel(EmitQuaDot(0)::RhtProg)
                enc ErrorProg = 
%RJGraise           CompRecord(0,%
                    CompLiteral([|LiteralString=`coerce`|],
%RJGraise)%         CompRecord(1, CompOp([|OpRaise|],RestProg)))

                 in CompTerm(Arg,Locals,Frees,
                    CompGetLocal(0,false,
                    EmitQuaDot(1)::
                    CompLiteral([|GlobalObject=mkobj(!Type)|],
                    CompRecord(2,
                    CompLiteral([|GlobalObject=mkobj(InstanceOf)|],
                    CompApply(1,
                    CompJump([|IfTrue|],hd(RestProg), ErrorProg)))))))
      |];
    SynTrap=(|TrapLft; TrapRht; TrapClass|).
      let restprog = CompLabel(RhtProg)
      and localsintrap = Locals in          %AM: get this for new traps%
      case TrapClass of
      [|SynTrapAll.
%RJG hndl% let thenprog = CompLabel(EmitSlide(0,1)::
                             CompTerm(TrapRht,Locals,Frees,
                                restprog))
           in CompTrap(hd(thenprog),
                       CompTerm(TrapLft,localsintrap,Frees,
                                CompUnTrap(hd(restprog),thenprog)));
        SynTrapList=(|TrapList|).
          let thenprog = CompLabel(EmitSlide(0,1)::
                                   CompTerm(TrapRht,Locals,Frees,
                                            restprog))
           in CompLiteral([|LiteralInt=0|],
              CompTerm(TrapList,NullExtendStk(Locals,1),Frees,
              CompRecord(2,
              CompHandle([AbbrevJump(hd thenprog)],
              CompTerm(TrapLft,localsintrap,Frees,
              CompUnTrap(hd(restprog),thenprog))))));
        SynTrapLamb=(|TrapBind|).
          let thenprog = 
               CompLabel(             %EmitQuaDot(0):: RJG now returns exn%
                 CompTerm(TrapRht,    %AM: next line should go via CompBind%
                          ExtendStk((repSynBind'(TrapBind) as SynBindIde).Binder,
                                    NullExtendStk(Locals,1)),
%RJG handle%              Frees,CompSqueeze(1,restprog)))
           in CompTrapLambda(hd(thenprog),
                       CompTerm(TrapLft,localsintrap,Frees,
                                CompUnTrap(hd(restprog),thenprog)))
      |];
    SynNewCase=x.
      let ContProg = CompLabel(RhtProg) in
      CompTerm(x.Select,Locals,Frees,
          CompMatch(x.Match,Locals,Frees,
                    (\r.CompJump([|Always|],hd(ContProg),r)), ContProg));
    SynHandle=h. 
      let LabContProg = CompLabel(RhtProg)
      enc LabCasesProg = CompLabel( CompMatchXn(h.Match, Locals, Frees,
			    (\r.CompJump([|Always|],hd(LabContProg),r)),
			    LabContProg))
      in CompTrap( hd(LabCasesProg),
		   CompTerm(h.HandLft, Locals, Frees,
		   CompUnTrap(hd(LabContProg),LabCasesProg)));

    SynRaise=x.
%RJG 09-Mar-89%
      let RaiseProg = CompOp([|OpRaise|],RhtProg)
      in   CompTerm(x.ExcArg,Locals,Frees,
		    if EqAtom(x.ExcIde,AtomOldFail)
		    then      CompRecord(1, RaiseProg)
		    else      RaiseProg);

    SynSequence=(|SeqLft; SeqRht|).
      let newlocals = NullExtendStk(Locals,1) in
      CompTerm(SeqLft,Locals,Frees,
               CompTerm(SeqRht,newlocals,Frees,
                        CompSqueeze(1,RhtProg)))
  |]

%%
%AM: note that the following code does not need to distinguish 
     'and','enc', 'ins' etc since this has all been done by MLANAL.%

enc CompDecl (Decl: SynDecl', Locals: StkPos', Frees: FVL',
              RhtProg: SMCode' list): (SMCode' list # StkPos') =
  case repSynDecl'(Decl) of
  [| SynDeclDefVal=(|Bind=Bind'; BindType; Term|).
       if  (repSynTerm'(Term) is SynLamb)
       And (repSynBind'(Bind') is SynBindIde)
       then let lambterm = (repSynTerm'(Term) as SynLamb)
            and LhsIde = (repSynBind'(Bind') as SynBindIde).Binder in (
            LhsIde.UserArity := MatchArity(lambterm.Match);
            let  (newlocals,code) = CompBind(Bind',Locals,Frees,RhtProg)
            enc  (dumsize, newcode, inlinecode, fnpresent) =
                 CompLambda(lambterm,Locals,Frees,(\q.CompClosure(q,code)),
                            CompRecord(0,RhtProg),[|present=LhsIde|])
            enc  _ = if (!LhsIde.Inline) is present then ()
                     else LhsIde.Inline := inlinecode
            in (newcode, newlocals))
       else (if  (repSynTerm'(Term) is SynIde)
             And (repSynBind'(Bind') is SynBindIde)
             then let RhsIde = (!(repSynTerm'(Term) as SynIde).Binder)()
                  and LhsIde = (repSynBind'(Bind') as SynBindIde).Binder
                  in (LhsIde.UserArity := !RhsIde.UserArity;
                      LhsIde.Inline := !RhsIde.Inline)
             else ();
             let (newlocals,code) = CompBind(Bind',Locals,Frees,RhtProg)
             in (CompTerm(Term,Locals,Frees,code), newlocals));
    SynDeclDefTyp=x.
      case x.DefSort of
      [| ShortHand. (RhtProg,Locals);
         Isomorphism=(| Constrs=l; Extending=exng; Extensible=exbl |).
           (itlist(\x.\prog.CompConstrFun(x,prog)) l RhtProg,
            revitlist(\x.\locs.ExtendStk(x.AbsBinder,locs)) l Locals)
      |];
    SynDeclDefExcon=x. failwith `CompDecl:SynDeclDefExc`;
%RJGDEL       ( case x.ExcSort of%
%RJGDEL         [| Generative. CompLiteral([|LiteralString=repAtom'(x.Bind.Ide)|],%
%RJGDEL                        absSMCode'[|OpRef|]::RhtProg);%
           % Ref rather than Record(1) to prevent literal optimisation %
%RJGDEL            ShortHand=y. CompVar(!y.Binder, [|Exc|], false, Locals, Frees, RhtProg)%
%RJGDEL         |],%
%RJGDEL         ExtendStk(x.Bind,Locals));%
    SynDeclAnd=(|Lft; Rht|).
      let (lftcode, newlocals) = CompDecl(Lft,Locals,Frees,[])
      enc (rhtcode, newerlocals) = CompDecl(Rht,newlocals,Frees,RhtProg)
       in (Thread(lftcode, rhtcode), newerlocals);
    SynDeclEnc=(|Ext; Int|).
      let (extcode, newlocals) = CompDecl(Ext,Locals,Frees,[])
      enc (intcode, newerlocals) = CompDecl(Int,newlocals,Frees,RhtProg)
       in (Thread(extcode, intcode), newerlocals);
    SynDeclIns=(|Outs; Ins|).
      let (outscode, ownlocals) = CompDecl(Outs,Locals,Frees,[])
      enc (inscode, newlocals) = CompDecl(Ins,ownlocals,Frees,RhtProg)
       in (Thread(outscode, inscode), newlocals);
    SynDeclWith=(|WithExt; WithInt|).
      let (withextcode, ownlocals) = CompDecl(WithExt,Locals,Frees,[])
      enc (withintcode, newlocals) = CompDecl(WithInt,ownlocals,Frees,RhtProg)
       in (Thread(withextcode, withintcode), newlocals);
    SynDeclRec=(|Rec|).
      let newlocals = CompRecDeclVars(Rec,Locals)
      enc (DumCode, StuffCode) = 
                  CompRecDecl(Rec,newlocals,Frees,([],RhtProg))
       in (Thread(DumCode, StuffCode), newlocals)

  |]


enc CompRecDeclVars(Decl: SynDecl', Locals: StkPos'): StkPos' =
  case repSynDecl'(Decl) of
  [| SynDeclDefVal=(|Bind=Bind'; BindType; Term|).
      % Assume (MLANAL) that Term is a SynLamb and Bind' is a SynBindIde%
      let lambterm = (repSynTerm'(Term) as SynLamb)
      and LhsIde = (repSynBind'(Bind') as SynBindIde).Binder in (
      LhsIde.UserArity := MatchArity(lambterm.Match);
      ExtendStk(LhsIde,Locals));
    SynDeclDefTyp=x.
      case x.DefSort of
      [| ShortHand. Locals;
         Isomorphism=(| Constrs=l; Extending=exng; Extensible=exbl |).
           revitlist(\x.\locs.ExtendStk(x.AbsBinder,locs)) l Locals |];
    SynDeclDefExcon=x. ExtendStk(x.AbsBinder,Locals);
    SynDeclAnd=(|Lft; Rht|).
      let newlocals = CompRecDeclVars(Lft,Locals)
      in CompRecDeclVars(Rht,newlocals);
    SynDeclEnc=(|Ext; Int|).
      let newlocals = CompRecDeclVars(Ext,Locals)
      in CompRecDeclVars(Int,newlocals);
    SynDeclIns=x. failwith `CompRecDeclVars`;
    SynDeclWith=x. failwith `CompRecDeclVars`;
    SynDeclRec=(|Rec|).
      CompRecDeclVars(Rec,Locals)

  |]


enc CompRecDecl(Decl: SynDecl', Locals: StkPos',
                Frees: FVL', (LftProg: SMCode' list, RhtProg: SMCode' list)
               ): SMCode' list # SMCode' list =
  case repSynDecl'(Decl) of
  [| SynDeclDefVal=(|Bind=Bind'; BindType; Term|).
      % Assume (MLANAL) that Term is a SynLamb and Bind' is a SynBindIde%
      let lambterm = (repSynTerm'(Term) as SynLamb)
      enc LhsIde = (repSynBind'(Bind') as SynBindIde).Binder
      enc clospos = DumClosPos(LhsIde, Locals, Frees)
      enc (dumsize, stuffcode, inlinecode, fnpresent) =
              CompLambda(lambterm,Locals,Frees,
                         (\q.CompRecClosure(q,clospos,RhtProg)), 
                         RhtProg, [|present=LhsIde|])
      enc  _ = if (!LhsIde.Inline) is present then ()
               else LhsIde.Inline := inlinecode
      in if (dumsize = 0) And fnpresent
      then (let [|OpGetLiteral=(|LiteralType; LiteralsNeeded|) |]::
                [|OpRecClosure=y|]::rest = codeof stuffcode
            enc [|LiteralText=x|] = (repliterals' LiteralType).LiteralForm
            in (CompLiteral([|LiteralClosure=x|],LftProg), abscodeof rest))
       ?? varstruct
          (CompDumClosure(dumsize,LftProg), stuffcode)
      else 
         (CompDumClosure(dumsize,LftProg), stuffcode);
    SynDeclDefTyp=x.
      case x.DefSort of
      [| ShortHand.   (LftProg,RhtProg);
         Isomorphism=(| Constrs=l; Extending=extending; Extensible=extable |).
           (itlist(\x.\r.CompConstrFun(x,r)) l LftProg, RhtProg) |];
    SynDeclDefExcon=x.
      let CopySBIde(old:SynBindIde',new:SynBindIde'):void =
       let _ = (new.Constructor) as yes := !(old.Constructor) as yes
       enc _ = new.Inline := !(old.Inline)
       enc _ = new.NativeCoded := !(old.NativeCoded)
       enc _ = new.MinFunArity := !(old.MinFunArity)
       enc _ = new.UserArity := !(old.UserArity)
       in ()

      enc binder = (!x.Binder) ()
      enc _ = CopySBIde(binder,x.AbsBinder)
      enc curLocals = absStkPos'(repStkPos' (Locals) -
                    DumClosPos(x.AbsBinder, Locals, Frees) - 1)
      in
      (CompVar(binder, [|Val|], false, curLocals, Frees, LftProg),RhtProg);
    SynDeclAnd=(|Lft; Rht|).
      CompRecDecl(Lft,Locals,Frees,
                  CompRecDecl(Rht,Locals,Frees,(LftProg,RhtProg)));
    SynDeclEnc=(|Ext; Int|).
      CompRecDecl(Ext,Locals,Frees,
                  CompRecDecl(Int,Locals,Frees,(LftProg,RhtProg)));
    SynDeclIns=x. failwith `CompRecDecl`;
    SynDeclWith=x. failwith `CompRecDecl`;
    SynDeclRec=(|Rec|).
      CompRecDecl(Rec,Locals,Frees,(LftProg,RhtProg))

  |]
};

%%
let Compile(Decl: SynDecl'): SMCode' list =
  (LabelCounter := NullLabel;
   let topfrees = (| List=ref []; EndLocals=NullStk; CurrFn=[|NoFun|];
                     MaxArgStk=ref 0; MaxCtlStk=ref 0 |): FVL'
   enc (code, newenv) = CompDecl(Decl,NullStk,topfrees,[]) in 
   if null(!topfrees.List)
   then Thread(code, [EmitRecord(StkDif(newenv,NullStk));EmitReturn(1)])
   else failwith `Compile - top level frees`);
