%{  -----  VAX-11 ASSEMBLER  -----  }%

let type Pass' = [| Fst; Snd:(|ObjCode: text; ObjCodeLength: int|) |];

let NCGen : (text -> text) ref = ref (\x.x);
let BCText : (text -> text) ref = ref (\x.x);

%AJGDEL let NCAssembleText = ref (\x.fail);%
%AJGDEL let BCAssembleText = ref (\x.fail);%

let TextSize = ref 0;

let {
 MC =
 (|  McTrue=    3; McFalse=    4;  McSmallNum=  (4,3,183,0);  McNum=     5;
     McTuple=     (2,0,0,12); McTuple0=    2; McTuple2=     83; McRef = 14;
     McVariant=   (10,11,0,13); McDestTailApply= 218;
     McQuaDot=   (15,16,0,24); McQuaIs=  (22,23,0,26); McQuaAs=   (0,0,0,27);
     McDestTuple=172;  McDestTuple_n0=173;  McDestTuple_20=181;
     McDestVariant=28; McDestBigVar=137; McCase=      29;
     McJump=      (215,56); McTrueJump= (217,57);  McFalseJump= (216,58);
     McClosure=  (145,146,0,60); McDumClosure=(0,147,0,61);  McRecClosure=62;
     McDestNil=    68; McDestPointer= 174; McDestConst=
          \x. case x of [|Bool. fail; Int. 200; String. 204; Real. 201|];
     McSaveFrame= 71;  McApplFrame=  72; McRestFrame= 73;
     McFunId=     75;  McFunComp=    76;
     McRaise = %80% 138;   McHandle=   %205% 139;  McUnTrap=    79; McPopTrap=  206;
     McReturn=    (171,94,70,0);
     McSlide= (%pop% 64, %squeeze% (0,93,212,66), 213, 175);
     McTailApply = (203, (96,95,74,0), 214, 97);
     McGetLocal=  (124,125,207,63);   McGetFree=   (0,211,210,1);
     McGetLiteral=(0,209,208,99);       McCurrClos= 182;
     McEqual= \x. case x of [|Bool. 41; Int. 42; String. 43; Real. 189;
                              Ref. 127|];
     McPrint= \x. case x of [|Bool. 87; Int. 88; String. 89; Real. 199|];
     McBind = 140; McNCApplFrame = 72; McNCDestTailApply = 218;
     McNCTailApply = 97     %AJG NC,BC unified (no fixed switches) %
|)

and EmitByte (Byte: int, Pass:Pass', AddrCount): int =
  ( let NewAddrCount = AddrCount+1 in
    case Pass of
    [| Fst. NewAddrCount;
       Snd=x.(StoreByte(Byte,x.ObjCode,(x.ObjCodeLength-NewAddrCount));
              NewAddrCount)|] )

and EmitWord (Word: int, Pass:Pass', AddrCount): int =
  ( let NewAddrCount = AddrCount+2 in
    case Pass of
    [| Fst. NewAddrCount;
       Snd=x.(StoreWord(Word,x.ObjCode,(x.ObjCodeLength-NewAddrCount));
              NewAddrCount)|] )

and EmitLong (Long: int, Pass:Pass', AddrCount): int =
  ( let NewAddrCount = AddrCount+4 in
    case Pass of
    [| Fst. NewAddrCount;
       Snd=x.(StoreLong(Long,x.ObjCode,(x.ObjCodeLength-NewAddrCount));
              NewAddrCount)|] )

enc EmitOpCode = EmitByte

enc SizeOp(n, optuple, Pass:Pass', AddrCount: int) =
    let (op0,op1,opb,opw) = optuple in
    if n<0 then (outtok(`Assembler error: `);
                 printint(op0); outtok(`,`);
                 printint(op1); outtok(`,`);
                 printint(opb); outtok(`,`);
                 printint(opw); newline(1); failwith `Assemble-SizeOp-0`)
    else if n=0 And op0<>0 then EmitOpCode(op0,Pass,AddrCount)
    else if n=1 And op1<>0 then EmitOpCode(op1,Pass,AddrCount)
    else if n<256 And opb<>0 
         then (let NewAddrCount = EmitByte(n,Pass,AddrCount) in 
               EmitOpCode(opb,Pass,NewAddrCount))
    else if n<65536 And opw<>0 
         then (let NewAddrCount = EmitWord(n,Pass,AddrCount) in 
               EmitOpCode(opw,Pass,NewAddrCount))
    else (outtok(`Assembler error: `);
          printint(op0); outtok(`,`);
          printint(op1); outtok(`,`);
          printint(opb); outtok(`,`);
          printint(opw); newline(1); failwith `Assemble-SizeOp-0`)

enc JumpOp(n, tl, (opb, opw), Pass:Pass', AddrCount: int) =
    if (n<128) And (n > 0) And opb<>0 And (tl > 0)
         then (let NewAddrCount = EmitByte(n,Pass,AddrCount) in 
               EmitOpCode(opb,Pass,NewAddrCount))
    else (let NewAddrCount = EmitWord(n,Pass,AddrCount) in 
               EmitOpCode(opw,Pass,NewAddrCount))

enc SlideOp(NumArgs, NumJunk, (op0,op1,opb,opn), Pass:Pass', AddrCount: int) =
          if NumArgs=0 then
            (let NewAddrCount = EmitWord(NumJunk,Pass,AddrCount) 
              in EmitOpCode(op0,Pass,NewAddrCount))
          else if NumArgs=1 then 
             SizeOp(NumJunk,op1,Pass,AddrCount)  %old Squeeze%
          else if (NumArgs < 256) And (NumJunk < 255)
          then
          ( let NewAddrCount = EmitByte(NumArgs-1,Pass,AddrCount)
            enc NewerAddrCount = EmitByte(NumJunk,Pass,NewAddrCount)
             in EmitOpCode(opb,Pass,NewerAddrCount))
          else
          ( let NewAddrCount = EmitWord(NumArgs-1,Pass,AddrCount)
            enc NewerAddrCount = EmitWord(NumJunk,Pass,NewAddrCount)
             in EmitOpCode(opn,Pass,NewerAddrCount))

and LabRef(l: SMCode', AddrCount) = AddrCount -
                               !((repSMCode' (l)) as OpLabel.Address) 

enc rec EqualLiteral(lit1: literals', lit2: literals') =
    let lit1 = (repliterals' lit1).LiteralForm in
    let lit2 = (repliterals' lit2).LiteralForm in
    case lit1 of
    [| LiteralString=Tok.  (lit2 as LiteralString) = Tok;
       LiteralText=(Name,_,_,Text). 
         EqualObject(mkobj(lit1 as LiteralText), mkobj(lit2 as LiteralText)); 
       LiteralClosure=(Name,_,_,Text). 
         EqualObject(
           mkobj(lit1 as LiteralClosure), mkobj(lit2 as LiteralClosure)); 
       LiteralInt=Num. (lit2 as LiteralInt) = Num;
       LiteralFloat=Num. (lit2 as LiteralFloat) = Num;
       LiteralBool=Bool. (lit2 as LiteralBool) = Bool;
       LiteralTuple=l. EqList(EqualLiteral, l, lit2 as LiteralTuple);
       LiteralVariant=(n,x). let (m,y) = lit2 as LiteralVariant in
                             if n=m then EqualLiteral(x,y) else false;
       GlobalObject=Obj.  EqualObject((lit2 as GlobalObject), Obj)
    |] ?? [`As`] false 

enc {rec AlreadySeen(Literal, LiteralList) =
     if null(LiteralList) then false
     else if EqualLiteral(hd(LiteralList), Literal) then true
     else AlreadySeen(Literal, tl(LiteralList))}

enc {LiteralPosition(Literal, LiteralList) =
     literalpos(Literal, LiteralList, length(LiteralList))
     where rec literalpos(lit, litlist, pos) =
           if null(litlist) then failwith `LiteralPosition`
           else if EqualLiteral(hd(litlist), lit) then pos-1
           else literalpos(lit, tl(litlist),pos-1)}

enc {rec AssemCaseList(CaseNum: int, List: SMCode' list, Pass,
                       addrcount: int) =
  if null(List) then addrcount else
   ( let newaddrcount = AssemCaseList(CaseNum+1,tl(List),Pass,addrcount)
      in EmitWord(LabRef(hd List,newaddrcount) + 2*(CaseNum+2),
                  Pass,newaddrcount))}

and {rec AssemInst(SMInstr: SMCode', Pass: Pass', 
                   Literals: (literals' list) ref,  AddrCount): int =
      case repSMCode' SMInstr of
      [|OpThread = _ . failwith `AssemInst`;
        OpLabel=(| Label;Address;NextOp |). (Address := AddrCount; AddrCount);
        OpNCBind=n. (let NewAddrCount = EmitByte(n,Pass,AddrCount) in 
                   EmitOpCode(MC.McBind,Pass,NewAddrCount));
        OpBCBind=n. (let NewAddrCount = EmitByte(n,Pass,AddrCount) in 
                   EmitOpCode(MC.McBind,Pass,NewAddrCount));
        OpNCDestTailApply=n. (let NewAddrCount = EmitByte(n,Pass,AddrCount) in 
                   EmitOpCode(MC.McNCDestTailApply,Pass,NewAddrCount));
        OpBCDestTailApply=n. (let NewAddrCount = EmitByte(n,Pass,AddrCount) in 
                   EmitOpCode(MC.McDestTailApply,Pass,NewAddrCount));
        OpGetLocal=(x,y). SizeOp(x, MC.McGetLocal,Pass,AddrCount);
        OpGetFree=x. SizeOp(x, MC.McGetFree,Pass,AddrCount); 
        OpCurrClos. EmitOpCode(MC.McCurrClos,Pass,AddrCount);
        OpPrimitive=x. if (x = 6) then AddrCount
                       else EmitOpCode(x,Pass,AddrCount);

        OpRecord=n.
%AM: the following line indicates that SizeOp could be cleverer!!%
          if n=2 then EmitOpCode(MC.McTuple2,Pass,AddrCount)
                 else SizeOp(n, MC.McTuple,Pass,AddrCount);
        OpVariant=CaseNum. SizeOp(CaseNum, MC.McVariant,Pass,AddrCount);
        OpRef. EmitOpCode(MC.McRef, Pass, AddrCount);

        OpEqual=t. EmitOpCode((MC.McEqual)(t),Pass,AddrCount);
        OpPrint=t. EmitOpCode((MC.McPrint)(t),Pass,AddrCount);

        OpQuaDot=FieldIndex. SizeOp(FieldIndex, MC.McQuaDot,Pass,AddrCount);
        OpDestTuple=(|Size;Displ|).
          if Displ=0 then
            if Size=2 then EmitOpCode(MC.McDestTuple_20,Pass,AddrCount)
            else ( let NewAddrCount = EmitWord(Size,Pass,AddrCount)
                   in EmitOpCode(MC.McDestTuple_n0,Pass,NewAddrCount))
          else
          ( let NewAddrCount = EmitWord(Displ,Pass,AddrCount)
            enc NewerAddrCount = EmitWord(Size,Pass,NewAddrCount)
             in EmitOpCode(MC.McDestTuple,Pass,NewerAddrCount));

        OpQuaIs=IsCaseIndex. SizeOp(IsCaseIndex, MC.McQuaIs,Pass,AddrCount);
        OpQuaAs=AsCaseIndex. SizeOp(AsCaseIndex, MC.McQuaAs,Pass,AddrCount);
        OpDestVariant=x.
          ( let NewAddrCount = EmitWord(x.DVarCaseIndex,Pass,AddrCount)
            enc NewerAddrCount = EmitWord(x.DVarArgDispl,Pass,NewAddrCount)
             in EmitOpCode(MC.McDestVariant,Pass,NewerAddrCount));
        OpDestBigVar=x.
          ( let NewAddrCount = EmitWord(x,Pass,AddrCount)
             in EmitOpCode(MC.McDestBigVar,Pass,NewAddrCount));
        OpCase=Cases.
            let NewAddrCount = AssemCaseList(0,Cases,Pass,AddrCount)
            enc NewerAddrCount = EmitWord(length(Cases),Pass,NewAddrCount)
             in EmitOpCode(MC.McCase,Pass,NewerAddrCount);
        OpJump=(|JumpType; Target|).
          let displ = LabRef(Target,AddrCount) 
          enc targetlab = !((repSMCode'(Target)) as OpLabel.Address) in
          case JumpType of
           [| Always. JumpOp(displ,targetlab,MC.McJump,Pass,AddrCount);
              IfTrue. JumpOp(displ,targetlab,MC.McTrueJump,Pass,AddrCount);
              IfFalse.JumpOp(displ,targetlab,MC.McFalseJump,Pass,AddrCount)
           |];
        OpClosure=FreeVarNum.
          let (op0,op1,opb,opw) = MC.McClosure in
          if FreeVarNum = 0 then EmitOpCode(op0,Pass,AddrCount)
          else if FreeVarNum = 1 then EmitOpCode(op1,Pass,AddrCount)
          else ( let NewAddrCount = EmitWord(FreeVarNum+1,Pass,AddrCount)
                  in EmitOpCode(opw,Pass,NewAddrCount));
        OpDumClosure=DumFreeVarNum.
          let (op0,op1,opb,opw) = MC.McDumClosure in
          if DumFreeVarNum = 1 then EmitOpCode(op1,Pass,AddrCount)
          else ( let NewAddrCount = EmitWord(DumFreeVarNum+1,Pass,AddrCount)
                  in EmitOpCode(opw,Pass,NewAddrCount));
        OpRecClosure=x.
          ( let NewAddrCount =
                EmitWord(x.RecClosDispl+1+x.RecFreeVarNum,Pass,AddrCount)
            enc NewerAddrCount = EmitWord(x.RecFreeVarNum+1,Pass,NewAddrCount)
             in EmitOpCode(MC.McRecClosure,Pass,NewerAddrCount));

        OpDestNil=Displ.
          ( let NewAddrCount = EmitWord(Displ,Pass,AddrCount)
             in EmitOpCode(MC.McDestNil,Pass,NewAddrCount));
        OpDestPointer=Displ.
          ( let NewAddrCount = EmitWord(Displ,Pass,AddrCount)
             in EmitOpCode(MC.McDestPointer,Pass,NewAddrCount));
        OpDestConst=(Displ,t).
          ( let NewAddrCount = EmitWord(Displ,Pass,AddrCount)
             in EmitOpCode((MC.McDestConst)(t),Pass,NewAddrCount));

        OpReturn=RetSqueeze. SizeOp(RetSqueeze, MC.McReturn,Pass,AddrCount);
        OpSaveFrame. EmitOpCode(MC.McSaveFrame,Pass,AddrCount);
        OpNCApplFrame. EmitOpCode(MC.McNCApplFrame,Pass,AddrCount);
        OpBCApplFrame. EmitOpCode(MC.McApplFrame,Pass,AddrCount);
        OpRestFrame. EmitOpCode(MC.McRestFrame,Pass,AddrCount);

        OpNCTailApply=(|NumArgs; NumJunk|). 
          ( let NewAddrCount = EmitWord(NumArgs-1,Pass,AddrCount)
            enc NewerAddrCount = EmitWord(NumJunk,Pass,NewAddrCount)
             in EmitOpCode(MC.McNCTailApply,Pass,NewerAddrCount));
        OpBCTailApply=(|NumArgs; NumJunk|). 
          SlideOp(NumArgs, NumJunk, MC.McTailApply, Pass, AddrCount);
        OpSlide=(|NumArgs; NumJunk|). 
          SlideOp(NumArgs, NumJunk, MC.McSlide, Pass, AddrCount);

        OpFunId. EmitOpCode(MC.McFunId,Pass,AddrCount);
        OpFunComp. EmitOpCode(MC.McFunComp,Pass,AddrCount);
        OpHandle=Cases.
            let NewAddrCount = AssemCaseList(0,Cases,Pass,AddrCount)
            enc NewerAddrCount = EmitWord(length(Cases),Pass,NewAddrCount)
             in EmitOpCode(MC.McHandle,Pass,NewerAddrCount);
        OpUnTrap=UnTrapTarget.
          ( let NewAddrCount =
                EmitWord(LabRef(UnTrapTarget,AddrCount),Pass,AddrCount)
             in EmitOpCode(MC.McUnTrap,Pass,NewAddrCount));
        OpPopTrap. EmitOpCode(MC.McPopTrap,Pass,AddrCount);
        OpRaise. EmitOpCode(MC.McRaise,Pass,AddrCount);
        OpGetLiteral=(|LiteralType; LiteralsNeeded|).
	  let (try: int opt) = case (repliterals' LiteralType).LiteralForm of
          [| LiteralInt=n.
               if n< ~1000000000 Or n>1000000000 then [|absent|]
               else [|present=(if 0<=n And n<=255
                         then SizeOp(n,MC.McSmallNum,Pass,AddrCount)
                         else (let NewAddrCount = EmitLong(n,Pass,AddrCount)
                               in EmitOpCode(MC.McNum,Pass,NewAddrCount)))|];
             LiteralTuple=l. if null(l)
               then [|present=EmitOpCode(MC.McTuple0,Pass,AddrCount)|]
               else [|absent|];
             LiteralBool=b.
               [| present=EmitOpCode((if b then MC.McTrue else MC.McFalse),
                                     Pass,AddrCount) |];
             LiteralVariant=(n,x). [|absent|];
%               if nulltuple(x) then EmitIntConst(n))        %
             LiteralString=s.  [|absent|];
             LiteralText=x.    [|absent|];
             LiteralClosure=x. [|absent|];
             LiteralFloat=Num. [|absent|];
             GlobalObject=Obj. [|absent|]
          |]
          in case try of
          [| present=x. x;
             absent.
               ( if Pass is Fst then
                   if AlreadySeen(LiteralType, !Literals) then ()
                   else Literals := LiteralType:: !Literals
                 else ();
                 SizeOp(LiteralPosition(LiteralType,!Literals),
                        MC.McGetLiteral,Pass,AddrCount))
          |]
      |]}

}

ins rec {Assem(Prog: SMCode' list, Pass: Pass',
               Literals: (literals' list) ref)
               : int # (literals' list ref) =
  (let AddrCount = MapAssemInst(Prog,0,Pass,Literals)
    in (AddrCount,Literals))

and MapAssemInst(smcodelist,addrcount,pass,literals) =
    let rec {maplist(smcodelist,addrcount) =
        if null(smcodelist) then addrcount
        else let {(smhd::smtl) = smcodelist
             enc  hdop = repSMCode'(smhd) 
             enc  tlred = maplist(smtl,addrcount)}
              in (if hdop is OpThread
                  then maplist((hdop as OpThread),tlred)
                  else AssemInst(smhd,pass,literals,tlred)) }
     in maplist(smcodelist, addrcount)

and ConvertLit(Lit:literals'): object =
  let (|LiteralForm; LiteralValue|) = repliterals' Lit in
  case !LiteralValue of
  [| present=x. x;
     absent.
       let y = case LiteralForm of
         [| LiteralString=x.  mkobj(x);
            LiteralText=(Name,_,_,Text). mkobj(AssembleText(Name,Text));
            LiteralClosure=(Name,_,_,Text). 
                     mkobj(makeclosure0(AssembleText(Name,Text)));
            LiteralInt=n. mkobj(n);
            LiteralFloat=x. mkobj(x);
            LiteralBool=b. mkobj(b);
            LiteralTuple=l. mkobj(tupleoflist(map ConvertLit l));
            LiteralVariant=(n,x). variantobject(n, ConvertLit x);
            GlobalObject=Obj.  Obj |]
       in (LiteralValue := [|present=y|]; y)           
  |]
and ConvertLiterals(LiteralList:literals' list, sofar): object list =
    if null(LiteralList) then sofar
    else ConvertLiterals(tl(LiteralList), ConvertLit(hd LiteralList):: sofar) 

and AssembleText(Name: Atom', Prog: SMCode' list): text =
( let (ObjCodeLength,Literals) = Assem(Prog,[|Fst|],
                                       ref [
        mkliterals'[|LiteralString=repAtom'(Name)|]
                                           ]) in
  let ObjCode = maketext(ObjCodeLength,
                         makeliteral(ConvertLiterals(!Literals,[])),
                         0,0) in (
  Do (Assem(Prog, [|Snd= (|ObjCode;ObjCodeLength|) |], Literals));
  TextSize := !TextSize + ObjCodeLength;
  if repSMCode'(hd(Prog)) is OpNCBind 
  Or repSMCode'(hd(Prog)) is OpNCDestTailApply
      then (!NCGen)ObjCode
  else (!BCText)(ObjCode)))


and Assemble(Prog: SMCode' list): closure =
  (TextSize := 0;
   makeclosure0(AssembleText(AtomTopLevel, Prog)))
};

%AJGDEL BCAssembleText := AssembleText;%
%AJGDEL NCAssembleText := %
%AJGDEL  (\(x,y). (outtok(`NCAssembleText called`); newline(1); AssembleText(x,tl y)));%
