/* hp2100_cpu3.c: HP 2100/1000 FFP/DBI instructions

   Copyright (c) 2005-2006, J. David Bryan

   Permission is hereby granted, free of charge, to any person obtaining a
   copy of this software and associated documentation files (the "Software"),
   to deal in the Software without restriction, including without limitation
   the rights to use, copy, modify, merge, publish, distribute, sublicense,
   and/or sell copies of the Software, and to permit persons to whom the
   Software is furnished to do so, subject to the following conditions:

   The above copyright notice and this permission notice shall be included in
   all copies or substantial portions of the Software.

   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
   THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
   IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
   CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

   Except as contained in this notice, the name of the author shall not be
   used in advertising or otherwise to promote the sale, use or other dealings
   in this Software without prior written authorization from the author.

   CPU3         Fast FORTRAN and Double Integer instructions

   16-Oct-06    JDB     Calls FPP for extended-precision math
   12-Oct-06    JDB     Altered DBLE, DDINT for F-Series FFP compatibility
   26-Sep-06    JDB     Moved from hp2100_cpu1.c to simplify extensions
   09-Aug-06    JDB     Added double-integer instruction set
   18-Feb-05    JDB     Add 2100/21MX Fast FORTRAN Processor instructions

   Primary references:
   - HP 1000 M/E/F-Series Computers Technical Reference Handbook
        (5955-0282, Mar-1980)
   - HP 1000 M/E/F-Series Computers Engineering and Reference Documentation
        (92851-90001, Mar-1981)
   - Macro/1000 Reference Manual (92059-90001, Dec-1992)

   Additional references are listed with the associated firmware
   implementations, as are the HP option model numbers pertaining to the
   applicable CPUs.
*/

#include "hp2100_defs.h"
#include "hp2100_cpu.h"
#include "hp2100_cpu1.h"

#if defined (HAVE_INT64)                                /* int64 support available */
#include "hp2100_fp1.h"
#else                                                   /* int64 support unavailable */
#include "hp2100_fp.h"
#endif                                                  /* end of int64 support */


t_stat cpu_ffp (uint32 IR, uint32 intrq);               /* Fast FORTRAN Processor */
t_stat cpu_dbi (uint32 IR, uint32 intrq);               /* Double-Integer instructions */


/* Fast FORTRAN Processor.

   The Fast FORTRAN Processor (FFP) is a set of FORTRAN language accelerators
   and extended-precision (three-word) floating point routines.  Although the
   FFP is an option for the 2100 and later CPUs, each implements the FFP in a
   slightly different form.

   Option implementation by CPU was as follows:

      2114    2115    2116    2100   1000-M  1000-E  1000-F
     ------  ------  ------  ------  ------  ------  ------
      N/A     N/A     N/A    12907A  12977B  13306B   std

   The instruction codes are mapped to routines as follows:

     Instr.   2100  1000-M 1000-E 1000-F    Instr.   2100  1000-M 1000-E 1000-F
     ------  ------ ------ ------ ------    ------  ------ ------ ------ ------
     105200    --   [nop]  [nop]  [test]    105220  .XFER  .XFER  .XFER  .XFER
     105201   DBLE   DBLE   DBLE   DBLE     105221  .GOTO  .GOTO  .GOTO  .GOTO
     105202   SNGL   SNGL   SNGL   SNGL     105222  ..MAP  ..MAP  ..MAP  ..MAP
     105203  .XMPY  .XMPY  .XMPY  .DNG      105223  .ENTR  .ENTR  .ENTR  .ENTR
     105204  .XDIV  .XDIV  .XDIV  .DCO      105224  .ENTP  .ENTP  .ENTP  .ENTP
     105205  .DFER  .DFER  .DFER  .DFER     105225    --   .PWR2  .PWR2  .PWR2
     105206    --   .XPAK  .XPAK  .XPAK     105226    --   .FLUN  .FLUN  .FLUN
     105207    --    XADD   XADD  .BLE      105227  $SETP  $SETP  $SETP  $SETP

     105210    --    XSUB   XSUB  .DIN      105230    --   .PACK  .PACK  .PACK
     105211    --    XMPY   XMPY  .DDE      105231    --     --   .CFER  .CFER
     105212    --    XDIV   XDIV  .DIS      105232    --     --     --   ..FCM
     105213  .XADD  .XADD  .XADD  .DDS      105233    --     --     --   ..TCM
     105214  .XSUB  .XSUB  .XSUB  .NGL      105234    --     --     --     --
     105215    --   .XCOM  .XCOM  .XCOM     105235    --     --     --     --
     105216    --   ..DCM  ..DCM  ..DCM     105236    --     --     --     --
     105217    --   DDINT  DDINT  DDINT     105237    --     --     --     --

   The F-Series maps different instructions to several of the standard FFP
   opcodes.  We first look for these and dispatch them appropriately before
   falling into the handler for the common instructions.

   The math functions use the F-Series FPP for implementation.  The FPP requires
   that the host compiler support 64-bit integers.  Therefore, if 64-bit
   integers are not available, the math instructions of the FFP are disabled.
   We allow this partial implementation as an aid in running systems generated
   for the FFP.  Most system programs did not use the math instructions, but
   almost all use .ENTR.  Supporting the latter even on systems that do not
   support the former still allows such systems to boot.

   Notes:

     1. The "$SETP" instruction is sometimes listed as ".SETP" in the
        documentation.

     2. Extended-precision arithmetic routines (e.g., .XMPY) exist on the
        1000-F, but they are assigned instruction codes in the single-precision
        floating-point module range.  They are replaced by several double
        integer instructions, which we dispatch to the double integer handler.

     3. The software implementation of ..MAP supports 1-, 2-, or 3-dimensional
        arrays, designated by setting A = -1, 0, and +1, respectively.  The
        firmware implementation supports only 2- and 3-dimensional access.

     4. The documentation for ..MAP for the 2100 FFP shows A = 0 or -1 for two
        or three dimensions, respectively, but the 1000 FFP shows A = 0 or +1.
        The firmware actually only checks the LSB of A.

     5. The .DFER and .XFER implementations for the 2100 FFP return X+4 and Y+4
        in the A and B registers, whereas the 1000 FFP returns X+3 and Y+3.

     6. The .XFER implementation for the 2100 FFP returns to P+2, whereas the
        1000 implementation returns to P+1.

     7. The firmware implementations of DBLE, .BLE, and DDINT clear the overflow
        flag.  The software implementations do not change overflow.

     8. The M/E-Series FFP arithmetic instructions (.XADD, etc.) return negative
        infinity on negative overflow and positive infinity on positive
        overflow.  The equivalent F-Series instructions return positive infinity
        on both.

   Additional references:
    - DOS/RTE Relocatable Library Reference Manual (24998-90001, Oct-1981)
    - Implementing the HP 2100 Fast FORTRAN Processor (12907-90010, Nov-1974)
*/

static const OP_PAT op_ffp_f[32] = {                    /* patterns for F-Series only */
  OP_N,    OP_AAF,  OP_AX,   OP_N,                      /* [tst]  DBLE   SNGL   .DNG  */
  OP_N,    OP_AA,   OP_A,    OP_AAF,                    /* .DCO   .DFER  .XPAK  .BLE  */
  OP_N,    OP_N,    OP_N,    OP_N,                      /* .DIN   .DDE   .DIS   .DDS  */
  OP_AT,   OP_A,    OP_A,    OP_AAX,                    /* .NGL   .XCOM  ..DCM  DDINT */
  OP_N,    OP_AK,   OP_KKKK, OP_A,                      /* .XFER  .GOTO  ..MAP  .ENTR */
  OP_A,    OP_RK,   OP_R,    OP_K,                      /* .ENTP  .PWR2  .FLUN  $SETP */
  OP_RC,   OP_AA,   OP_R,    OP_A,                      /* .PACK  .CFER  ..FCM  ..TCM */
  OP_N,    OP_N,    OP_N,    OP_N                       /*  ---    ---    ---    ---  */
  };

static const OP_PAT op_ffp_e[32] = {                    /* patterns for 2100/M/E-Series */
  OP_N,    OP_AAF,  OP_AX,   OP_AXX,                    /* [nop]  DBLE   SNGL   .XMPY */
  OP_AXX,  OP_AA,   OP_A,    OP_AAXX,                   /* .XDIV  .DFER  .XPAK  XADD  */
  OP_AAXX, OP_AAXX, OP_AAXX, OP_AXX,                    /* XSUB   XMPY   XDIV   .XADD */
  OP_AXX,  OP_A,    OP_A,    OP_AAX,                    /* .XSUB  .XCOM  ..DCM  DDINT */
  OP_N,    OP_AK,   OP_KKKK, OP_A,                      /* .XFER  .GOTO  ..MAP  .ENTR */
  OP_A,    OP_RK,   OP_R,    OP_K,                      /* .ENTP  .PWR2  .FLUN  $SETP */
  OP_RC,   OP_AA,   OP_N,    OP_N,                      /* .PACK  .CFER   ---    ---  */
  OP_N,    OP_N,    OP_N,    OP_N                       /*  ---    ---    ---    ---  */
  };

t_stat cpu_ffp (uint32 IR, uint32 intrq)
{
OP fpop;
OPS op, op2;
uint32 entry;
uint32 j, sa, sb, sc, da, dc, ra, MA;
int32 expon;
t_stat reason = SCPE_OK;

#if defined (HAVE_INT64)                                /* int64 support available */

int32 i;

#endif                                                  /* end of int64 support */

if ((cpu_unit.flags & UNIT_FFP) == 0)                   /* FFP option installed? */
    return stop_inst;

entry = IR & 037;                                       /* mask to entry point */

if (UNIT_CPU_MODEL != UNIT_1000_F) {                    /* 2100/M/E-Series? */
    if (op_ffp_e[entry] != OP_N)
        if (reason = cpu_ops (op_ffp_e[entry], op, intrq))  /* get instruction operands */
            return reason;
    }

#if defined (HAVE_INT64)                                /* int64 support available */

else {                                                  /* F-Series */
    if (op_ffp_f[entry] != OP_N)
        if (reason = cpu_ops (op_ffp_f[entry], op, intrq))  /* get instruction operands */
            return reason;

    switch (entry) {                                    /* decode IR<4:0> */

        case 000:                                       /* [tst] 105200 (OP_N) */
            XR = 4;                                     /* firmware revision */
            SR = 0102077;                               /* test passed code */
            AR = 0;                                     /* test clears A/B */
            BR = 0;
            PC = (PC + 1) & VAMASK;                     /* P+2 return for firmware w/DBI */
            return reason;

        case 003:                                       /* .DNG 105203 (OP_N) */
            return cpu_dbi (0105323, intrq);            /* remap to double int handler */

        case 004:                                       /* .DCO 105204 (OP_N) */
            return cpu_dbi (0105324, intrq);            /* remap to double int handler */

        case 007:                                       /* .BLE 105207 (OP_AAF) */
            O = fp_cvt (&op[2], fp_f, fp_t);            /* convert value and clear overflow */
            WriteOp (op[1].word, op[2], fp_t);          /* write double-precision value */
            return reason;

        case 010:                                       /* .DIN 105210 (OP_N) */
            return cpu_dbi (0105330, intrq);            /* remap to double int handler */

        case 011:                                       /* .DDE 105211 (OP_N) */
            return cpu_dbi (0105331, intrq);            /* remap to double int handler */

        case 012:                                       /* .DIS 105212 (OP_N) */
            return cpu_dbi (0105332, intrq);            /* remap to double int handler */

        case 013:                                       /* .DDS 105213 (OP_N) */
            return cpu_dbi (0105333, intrq);            /* remap to double int handler */

        case 014:                                       /* .NGL 105214 (OP_AT) */
            O = fp_cvt (&op[1], fp_t, fp_f);            /* convert value */
            AR = op[1].fpk[0];                          /* move MSB to A */
            BR = op[1].fpk[1];                          /* move LSB to B */
            return reason;

        case 032:                                       /* ..FCM 105232 (OP_R) */
            O = fp_pcom (&op[0], fp_f);                 /* complement value */
            AR = op[0].fpk[0];                          /* return result */
            BR = op[0].fpk[1];                          /* to A/B registers */
            return reason;

        case 033:                                       /* ..TCM 105233 (OP_A) */
            fpop = ReadOp (op[0].word, fp_t);           /* read 4-word value */
            O = fp_pcom (&fpop, fp_t);                  /* complement it */
            WriteOp (op[0].word, fpop, fp_t);           /* write 4-word value */
            return reason;
        }                                               /* fall thru if not special to F */
    }

#endif                                                  /* end of int64 support */

switch (entry) {                                        /* decode IR<4:0> */

/* FFP module 1 */

    case 000:                                           /* [nop] 105200 (OP_N) */
        if (UNIT_CPU_TYPE != UNIT_TYPE_1000)            /* must be 1000 M/E-series */
            return stop_inst;                           /* trap if not */
        break;

#if defined (HAVE_INT64)                                /* int64 support available */

    case 001:                                           /* DBLE 105201 (OP_AAF) */
        O = fp_cvt (&op[2], fp_f, fp_x);                /* convert value and clear overflow */
        WriteOp (op[1].word, op[2], fp_x);              /* write extended-precision value */
        break;

    case 002:                                           /* SNGL 105202 (OP_AX) */
        O = fp_cvt (&op[1], fp_x, fp_f);                /* convert value */
        AR = op[1].fpk[0];                              /* move MSB to A */
        BR = op[1].fpk[1];                              /* move LSB to B */
        break;

    case 003:                                           /* .XMPY 105203 (OP_AXX) */
        i = 0;                                          /* params start at op[0] */
        goto XMPY;                                      /* process as XMPY */

    case 004:                                           /* .XDIV 105204 (OP_AXX) */
        i = 0;                                          /* params start at op[0] */
        goto XDIV;                                      /* process as XDIV */

#endif                                                  /* end of int64 support */

    case 005:                                           /* .DFER 105205 (OP_AA) */
        BR = op[0].word;                                /* get destination address */
        AR = op[1].word;                                /* get source address */
        goto XFER;                                      /* do transfer */

#if defined (HAVE_INT64)                                /* int64 support available */

    case 006:                                           /* .XPAK 105206 (OP_A) */
        if (UNIT_CPU_TYPE != UNIT_TYPE_1000)            /* must be 1000 */
            return stop_inst;                           /* trap if not */

        if (intrq) {                                    /* interrupt pending? */
            PC = err_PC;                                /* restart instruction */
            break;
            }

        fpop = ReadOp (op[0].word, fp_x);               /* read unpacked */
        O = fp_nrpack (&fpop, fpop, (int16) AR, fp_x);  /* nrm/rnd/pack mantissa, exponent */
        WriteOp (op[0].word, fpop, fp_x);               /* write result */
        break;

    case 007:                                           /* XADD 105207 (OP_AAXX) */
        i = 1;                                          /* params start at op[1] */
    XADD:                                               /* enter here from .XADD */
        if (intrq) {                                    /* interrupt pending? */
            PC = err_PC;                                /* restart instruction */
            break;
            }

        O = fp_exec (001, &fpop, op[i + 1], op[i + 2]); /* three-word add */
        WriteOp (op[i].word, fpop, fp_x);               /* write sum */
        break;

    case 010:                                           /* XSUB 105210 (OP_AAXX) */
        i = 1;                                          /* params start at op[1] */
    XSUB:                                               /* enter here from .XSUB */
        if (intrq) {                                    /* interrupt pending? */
            PC = err_PC;                                /* restart instruction */
            break;
            }

        O = fp_exec (021, &fpop, op[i + 1], op[i + 2]); /* three-word subtract */
        WriteOp (op[i].word, fpop, fp_x);               /* write difference */
        break;

    case 011:                                           /* XMPY 105211 (OP_AAXX) */
        i = 1;                                          /* params start at op[1] */
    XMPY:                                               /* enter here from .XMPY */
        if (intrq) {                                    /* interrupt pending? */
            PC = err_PC;                                /* restart instruction */
            break;
            }

        O = fp_exec (041, &fpop, op[i + 1], op[i + 2]); /* three-word multiply */
        WriteOp (op[i].word, fpop, fp_x);               /* write product */
        break;

    case 012:                                           /* XDIV 105212 (OP_AAXX) */
        i = 1;                                          /* params start at op[1] */
     XDIV:                                              /* enter here from .XDIV */
        if (intrq) {                                    /* interrupt pending? */
            PC = err_PC;                                /* restart instruction */
            break;
            }

        O = fp_exec (061, &fpop, op[i + 1], op[i + 2]); /* three-word divide */
        WriteOp (op[i].word, fpop, fp_x);               /* write quotient */
        break;

    case 013:                                           /* .XADD 105213 (OP_AXX) */
        i = 0;                                          /* params start at op[0] */
        goto XADD;                                      /* process as XADD */

    case 014:                                           /* .XSUB 105214 (OP_AXX) */
        i = 0;                                          /* params start at op[0] */
        goto XSUB;                                      /* process as XSUB */

    case 015:                                           /* .XCOM 105215 (OP_A) */
        if (UNIT_CPU_TYPE != UNIT_TYPE_1000)            /* must be 1000 */
            return stop_inst;                           /* trap if not */

        fpop = ReadOp (op[0].word, fp_x);               /* read unpacked */
        AR = fp_ucom (&fpop, fp_x);                     /* complement and rtn exp adj */
        WriteOp (op[0].word, fpop, fp_x);               /* write result */
        break;

    case 016:                                           /* ..DCM 105216 (OP_A) */
        if (UNIT_CPU_TYPE != UNIT_TYPE_1000)            /* must be 1000 */
            return stop_inst;                           /* trap if not */

        if (intrq) {                                    /* interrupt pending? */
            PC = err_PC;                                /* restart instruction */
            break;
            }

        fpop = ReadOp (op[0].word, fp_x);               /* read operand */
        O = fp_pcom (&fpop, fp_x);                      /* complement (can't ovf neg) */
        WriteOp (op[0].word, fpop, fp_x);               /* write result */
        break;

    case 017:                                           /* DDINT 105217 (OP_AAX) */
        if (UNIT_CPU_TYPE != UNIT_TYPE_1000)            /* must be 1000 */
            return stop_inst;                           /* trap if not */

        if (intrq) {                                    /* interrupt pending? */
            PC = err_PC;                                /* restart instruction */
            break;
            }

        O = fp_trun (&fpop, op[2], fp_x);               /* truncate operand (can't ovf) */
        WriteOp (op[1].word, fpop, fp_x);               /* write result */
        break;

#endif                                                  /* end of int64 support */

/* FFP module 2 */

    case 020:                                           /* .XFER 105220 (OP_N) */
        if (UNIT_CPU_TYPE == UNIT_TYPE_2100)
            PC = (PC + 1) & VAMASK;                     /* 2100 .XFER returns to P+2 */
    XFER:                                               /* enter here from .DFER */
        sc = 3;                                         /* set count for 3-wd xfer */
        goto CFER;                                      /* do transfer */

    case 021:                                           /* .GOTO 105221 (OP_AK) */
        if ((int16) op[1].word < 1)                     /* index < 1? */
            op[1].word = 1;                             /* reset min */

        sa = PC + op[1].word - 1;                       /* point to jump target */
        if (sa >= op[0].word)                           /* must be <= last target */
            sa = op[0].word - 1;

        da = ReadW (sa);                                /* get jump target */
        if (reason = resolve (da, &MA, intrq)) {        /* resolve indirects */
            PC = err_PC;                                /* irq restarts instruction */
            break;
            }

        mp_dms_jmp (MA);                                /* validate jump addr */
        PCQ_ENTRY;                                      /* record last PC */
        PC = MA;                                        /* jump */
        BR = op[0].word;                                /* (for 2100 FFP compat) */
        break;

    case 022:                                           /* ..MAP 105222 (OP_KKKK) */
        op[1].word = op[1].word - 1;                    /* decrement 1st subscr */

        if ((AR & 1) == 0)                              /* 2-dim access? */
            op[1].word = op[1].word +                   /* compute element offset */
                         (op[2].word - 1) * op[3].word;
        else {                                          /* 3-dim access */
            if (reason = cpu_ops (OP_KK, op2, intrq)) { /* get 1st, 2nd ranges */
                PC = err_PC;                            /* irq restarts instruction */
                break;
                }
            op[1].word = op[1].word +                   /* offset */
                         ((op[3].word - 1) * op2[1].word +
                          op[2].word - 1) * op2[0].word;
            }

        AR = (op[0].word + op[1].word * BR) & DMASK;    /* return element address */
        break;

    case 023:                                           /* .ENTR 105223 (OP_A) */
        MA = PC - 3;                                    /* get addr of entry point */
    ENTR:                                               /* enter here from .ENTP */
        da = op[0].word;                                /* get addr of 1st formal */
        dc = MA - da;                                   /* get count of formals */
        sa = ReadW (MA);                                /* get addr of return point */
        ra = ReadW (sa++);                              /* get rtn, ptr to 1st actual */
        WriteW (MA, ra);                                /* stuff rtn into caller's ent */
        sc = ra - sa;                                   /* get count of actuals */
        if (sc > dc)                                    /* use min (actuals, formals) */
            sc = dc;

        for (j = 0; j < sc; j++) {
            MA = ReadW (sa++);                          /* get addr of actual */
            if (reason = resolve (MA, &MA, intrq)) {    /* resolve indirect */
                PC = err_PC;                            /* irq restarts instruction */
                break;
                }
            WriteW (da++, MA);                          /* put addr into formal */
            }

        AR = ra;                                        /* return address */
        BR = da;                                        /* addr of 1st unused formal */
        break;

    case 024:                                           /* .ENTP 105224 (OP_A) */
        MA = PC - 5;                                    /* get addr of entry point */
        goto ENTR;

    case 025:                                           /* .PWR2 105225 (OP_RK) */
        if (UNIT_CPU_TYPE != UNIT_TYPE_1000)            /* must be 1000 */
            return stop_inst;                           /* trap if not */

        fp_unpack (&fpop, &expon, op[0], fp_f);         /* unpack value */
        expon = expon + (int16) (op[1].word);           /* multiply by 2**n */
        fp_pack (&fpop, fpop, expon, fp_f);             /* repack value */
        AR = fpop.fpk[0];                               /* return result */
        BR = fpop.fpk[1];                               /* to A/B registers */
        break;

    case 026:                                           /* .FLUN 105226 (OP_R) */
        if (UNIT_CPU_TYPE != UNIT_TYPE_1000)            /* must be 1000 */
            return stop_inst;                           /* trap if not */

        fp_unpack (&fpop, &expon, op[0], fp_f);         /* unpack value */
        AR = (int16) expon;                             /* return expon to A */
        BR = fpop.fpk[1];                               /* and low mant to B */
        break;

    case 027:                                           /* $SETP 105227 (OP_K) */
        j = sa = AR;                                    /* save initial value */
        sb = BR;                                        /* save initial address */
        AR = 0;                                         /* AR will return = 0 */
        BR = BR & VAMASK;                               /* addr must be direct */

        do {
            WriteW (BR, j);                             /* write value to address */
            j = (j + 1) & DMASK;                        /* incr value */
            BR = (BR + 1) & VAMASK;                     /* incr address */
            op[0].word = op[0].word - 1;                /* decr count */
            if (op[0].word && intrq) {                  /* more and intr? */
                AR = sa;                                /* restore A */
                BR = sb;                                /* restore B */
                PC = err_PC;                            /* restart instruction */
                break;
                }
            }
        while (op[0].word != 0);                        /* loop until count exhausted */
        break;

    case 030:                                           /* .PACK 105230 (OP_RC) */
        if (UNIT_CPU_TYPE != UNIT_TYPE_1000)            /* must be 1000 */
            return stop_inst;                           /* trap if not */

        O = fp_nrpack (&fpop, op[0],                    /* nrm/rnd/pack value */
                       (int16) (op[1].word), fp_f);
        AR = fpop.fpk[0];                               /* return result */
        BR = fpop.fpk[1];                               /* to A/B registers */
        break;

    case 031:                                           /* .CFER 105231 (OP_AA) */
        if ((UNIT_CPU_MODEL != UNIT_1000_E) &&          /* must be 1000 E-series */
            (UNIT_CPU_MODEL != UNIT_1000_F))            /* or 1000 F-series */
            return stop_inst;                           /* trap if not */

        BR = op[0].word;                                /* get destination address */
        AR = op[1].word;                                /* get source address */
        sc = 4;                                         /* set for 4-wd xfer */
    CFER:                                               /* enter here from .XFER */
        for (j = 0; j < sc; j++) {                      /* xfer loop */
            WriteW (BR, ReadW (AR));                    /* transfer word */
            AR = (AR + 1) & VAMASK;                     /* bump source addr */
            BR = (BR + 1) & VAMASK;                     /* bump destination addr */
            }

        E = 0;                                          /* routine clears E */

        if (UNIT_CPU_TYPE == UNIT_TYPE_2100) {          /* 2100 (and .DFER/.XFER)? */
            AR = (AR + 1) & VAMASK;                     /* 2100 FFP returns X+4, Y+4 */
            BR = (BR + 1) & VAMASK;
            }
        break;

    default:                                            /* others undefined */
        reason = stop_inst;
        }

return reason;
}


/* Double-Integer Instructions.

   The double-integer instructions were added to the HP instruction set at
   revision 1920 of the 1000-F.  They were immediately adopted in a number of HP
   software products, most notably the RTE file management package (FMP)
   routines.  As these routines are used in nearly every RTE program, F-Series
   programs were almost always a few hundred bytes smaller than their M- and
   E-Series counterparts.  This became significant as RTE continued to grow in
   size, and some customer programs ran out of address space on E-Series
   machines.

   While HP never added double-integer instructions to the standard E-Series, a
   product from the HP "specials group," HP 93585A, provided microcoded
   replacements for the E-Series.  This could provide just enough address-space
   savings to allow programs to load in E-Series systems, in addition to
   accelerating these common operations.

   M-Series microcode was never offered by HP.  However, it costs us nothing to
   enable double-integer instructions for M-Series simulations.  This has the
   concomitant advantage that it allows RTE-6/VM to run under SIMH (for
   simulation, we must SET CPU 1000-M, because RTE-6/VM looks for the OS and VM
   microcode -- which we do not implement yet -- if it detects an E- or F-Series
   machine).

   Option implementation by CPU was as follows:

      2114    2115    2116    2100   1000-M  1000-E  1000-F
     ------  ------  ------  ------  ------  ------  ------
      N/A     N/A     N/A     N/A     N/A    93575A   std

   The routines are mapped to instruction codes as follows:

     Instr.  1000-E   1000-F   Description
     ------  ------   ------  -----------------------------------------
     [test]  105320     --    [self test]
     .DAD    105321   105014  Double integer add
     .DMP    105322   105054  Double integer multiply
     .DNG    105323   105203  Double integer negate
     .DCO    105324   105204  Double integer compare
     .DDI    105325   105074  Double integer divide
     .DDIR   105326   105134  Double integer divide (reversed)
     .DSB    105327   105034  Double integer subtract
     .DIN    105330   105210  Double integer increment
     .DDE    105331   105211  Double integer decrement
     .DIS    105332   105212  Double integer increment and skip if zero
     .DDS    105333   105213  Double integer decrement and skip if zero
     .DSBR   105334   105114  Double integer subtraction (reversed)

   On the F-Series, the double-integer instruction codes are split among the
   floating-point processor and the Fast FORTRAN Processor ranges.  They are
   dispatched from those respective simulators for processing here.

   Notes:

     1. The E-Series opcodes are listed in Appendix C of the Macro/1000 manual.
        These should be the same opcodes as given in the 93585A manual listed
        below, but no copy of the reference below has been located to confirm
        the proper opcodes.  This module should be corrected if needed when such
        documentation is found.

     2. The action of the self-test instruction (105320) is unknown.  At the
        moment, we take an unimplemented instruction trap for this.  When
        documentation explaining the action is located, it will be implemented.

     3. The F-Series firmware executes .DMP and .DDI/.DDIR by floating the
        32-bit double integer to a 48-bit extended-precision number, calling the
        FPP to execute the extended-precision multiply/divide, and then fixing
        the product to a 32-bit double integer.  We simulate these directly with
        64- or 32-bit integer arithmetic.

   Additional references:
    - 93575A Double Integer Instructions Installation and Reference Manual
      (93575-90007)
*/

static const OP_PAT op_dbi[16] = {
  OP_N,    OP_JD,   OP_JD,   OP_J,                      /* [test] .DAD   .DMP   .DNG  */
  OP_JD,   OP_JD,   OP_JD,   OP_JD,                     /* .DCO   .DDI   .DDIR  .DSB  */
  OP_J,    OP_J,    OP_A,    OP_A,                      /* .DIN   .DDE   .DIS   .DDS  */
  OP_JD,   OP_N,    OP_N,    OP_N                       /* .DSBR   ---    ---    ---  */
  };

t_stat cpu_dbi (uint32 IR, uint32 intrq)
{
OP din;
OPS op;
uint32 entry, t;
t_stat reason = SCPE_OK;

if ((cpu_unit.flags & UNIT_DBI) == 0)                   /* DBI option installed? */
    return stop_inst;

entry = IR & 017;                                       /* mask to entry point */

if (op_dbi[entry] != OP_N)
    if (reason = cpu_ops (op_dbi[entry], op, intrq))    /* get instruction operands */
        return reason;

switch (entry) {                                        /* decode IR<3:0> */

    case 000:                                           /* [test] 105320 (OP_N) */
        t = (AR << 16) | BR;                            /* set t for nop */
        reason = stop_inst;                             /* function unknown; not impl. */
        break;

    case 001:                                           /* .DAD 105321 (OP_JD) */
        t = op[0].dword + op[1].dword;                  /* add values */
        E = E | (t < op[0].dword);                      /* carry if result smaller */
        O = (((~op[0].dword ^ op[1].dword) &            /* overflow if sign wrong */
              (op[0].dword ^ t) & SIGN32) != 0);
        break;

    case 002:                                           /* .DMP 105322 (OP_JD) */
        {

#if defined (HAVE_INT64)                                /* int64 support available */

            t_int64 t64;

            t64 = (t_int64) op[0].dword *               /* multiply values */
                  (t_int64) op[1].dword;
            O = ((t64 < -(t_int64) 0x80000000) ||       /* overflow if out of range */
                 (t64 >  (t_int64) 0x7FFFFFFF));
            if (O)
                t = ~SIGN32;                            /* if overflow, rtn max pos */
            else
                t = (uint32) (t64 & DMASK32);           /* else lower 32 bits of result */

#else                                                   /* int64 support unavailable */

            uint32 sign, xu, yu, rh, rl;

            sign = ((int32) op[0].dword < 0) ^          /* save sign of result */
                   ((int32) op[1].dword < 0);

            xu = (uint32) abs ((int32) op[0].dword);    /* make operands pos */
            yu = (uint32) abs ((int32) op[1].dword);

            if ((xu & 0xFFFF0000) == 0 &&               /* 16 x 16 multiply? */
                (yu & 0xFFFF0000) == 0) {
                t = xu * yu;                            /* do it */
                O = 0;                                  /* can't overflow */
                }

            else if ((xu & 0xFFFF0000) != 0 &&          /* 32 x 32 multiply? */
                     (yu & 0xFFFF0000) != 0)
                O = 1;                                  /* always overflows */

            else {                                      /* 16 x 32 or 32 x 16 */
                rl = (xu & 0xFFFF) * (yu & 0xFFFF);     /* form 1st partial product */

                if ((xu & 0xFFFF0000) == 0)
                    rh = xu * (yu >> 16) + (rl >> 16);  /* 16 x 32 2nd partial */
                else
                    rh = (xu >> 16) * yu + (rl >> 16);  /* 32 x 16 2nd partial */

                O = (rh > 0x7FFF + sign);               /* check for out of range */
                if (O == 0)
                    t = (rh << 16) | (rl & 0xFFFF);     /* combine partials */
                }

            if (O)
                t = ~SIGN32;                            /* if overflow, rtn max pos */
            else if (sign)
                t = ~t + 1;                             /* if result neg, 2s compl */

#endif                                                  /* end of int64 support */

        }
        break;

    case 003:                                           /* .DNG 105323 (OP_J) */
        t = ~op[0].dword + 1;                           /* negate value */
        O = (op[0].dword == SIGN32);                    /* overflow if max neg */
        if (op[0].dword == 0)                           /* borrow if result zero */
            E = 1;
        break;

    case 004:                                           /* .DCO 105324 (OP_JD) */
        t = op[0].dword;                                /* copy for later store */
        if ((int32) op[0].dword < (int32) op[1].dword)
            PC = (PC + 1) & VAMASK;                     /* < rtns to P+2 */
        else if ((int32) op[0].dword > (int32) op[1].dword)
            PC = (PC + 2) & VAMASK;                     /* > rtns to P+3 */
        break;                                          /* = rtns to P+1 */

    case 005:                                           /* .DDI 105325 (OP_JD) */
    DDI:
        O = ((op[1].dword == 0) ||                      /* overflow if div 0 */
             ((op[0].dword == SIGN32) &&                /*   or max neg div -1 */
              ((int32) op[1].dword == -1)));
        if (O)
            t = ~SIGN32;                                /* rtn max pos for ovf */
        else
            t = op[0].dword / op[1].dword;              /* else return quotient */
        break;

    case 006:                                           /* .DDIR 105326 (OP_JD) */
        t = op[0].dword;                                /* swap operands */
        op[0].dword = op[1].dword;
        op[1].dword = t;
        goto DDI;                                       /* continue at .DDI */

    case 007:                                           /* .DSB 105327 (OP_JD) */
    DSB:
        t = op[0].dword - op[1].dword;                  /* subtract values */
        E = E | (op[0].dword < op[1].dword);            /* borrow if minu < subtr */
        O = (((op[0].dword ^ op[1].dword) &             /* overflow if sign wrong */
              (op[0].dword ^ t) & SIGN32) != 0);
        break;

    case 010:                                           /* .DIN 105330 (OP_J) */
        t = op[0].dword + 1;                            /* increment value */
        O = (t == SIGN32);                              /* overflow if sign flipped */
        if (t == 0)
            E = 1;                                      /* carry if result zero */
        break;

    case 011:                                           /* .DDE 105331 (OP_J) */
        t = op[0].dword - 1;                            /* decrement value */
        O = (t == ~SIGN32);                             /* overflow if sign flipped */
        if ((int32) t == -1)
            E = 1;                                      /* borrow if result -1 */
        break;

    case 012:                                           /* .DIS 105332 (OP_A) */
        din = ReadOp (op[0].word, in_d);                /* get value */
        t = din.dword = din.dword + 1;                  /* increment value */
        WriteOp (op[0].word, din, in_d);                /* store it back */
        if (t == 0)
            PC = (PC + 1) & VAMASK;                     /* skip if result zero */
        break;

    case 013:                                           /* .DDS 105333 (OP_A) */
        din = ReadOp (op[0].word, in_d);                /* get value */
        t = din.dword = din.dword - 1;                  /* decrement value */
        WriteOp (op[0].word, din, in_d);                /* write it back */
        if (t == 0)
            PC = (PC + 1) & VAMASK;                     /* skip if result zero */
        break;

    case 014:                                           /* .DSBR 105334 (OP_JD) */
        t = op[0].dword;                                /* swap operands */
        op[0].dword = op[1].dword;
        op[1].dword = t;
        goto DSB;                                       /* continue at .DSB */

    default:                                            /* others undefined */
        t = (AR << 16) | BR;                            /* set t for nop */
        reason = stop_inst;
        }

if (reason == SCPE_OK) {                                /* if return OK */
    AR = (t >> 16) & DMASK;                             /*   break result */
    BR = t & DMASK;                                     /*   into A and B */
    }

return reason;
}
