/* hp2100_cpu3.c: HP 2100/1000 FFP and DBI microcode simulator

   Copyright (c) 2005-2018, 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 Processor and Double Integer instructions

   28-Jul-18    JDB     Renamed hp2100_fp1.h to hp2100_cpu_fp.h
   24-Aug-17    JDB     op_ffp_f definition is now conditional on HAVE_INT64
   27-Mar-17    JDB     Improved the comments for the FFP instructions
   05-Aug-16    JDB     Renamed the P register from "PC" to "PR"
   24-Dec-14    JDB     Added casts for explicit downward conversions
   09-May-12    JDB     Separated assignments from conditional expressions
   11-Sep-08    JDB     Moved microcode function prototypes to hp2100_cpu1.h
   05-Sep-08    JDB     Removed option-present tests (now in UIG dispatchers)
   05-Aug-08    JDB     Updated mp_dms_jmp calling sequence
   27-Feb-08    JDB     Added DBI self-test instruction
   23-Oct-07    JDB     Fixed unsigned-divide bug in .DDI
   17-Oct-07    JDB     Fixed unsigned-multiply bug in .DMP
   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, March 1980)
     - HP 1000 M/E/F-Series Computers Engineering and Reference Documentation
         (92851-90001, March 1981)
     - Macro/1000 Reference Manual
         (92059-90001, December 1992)

   Firmware-specific references:
     - DOS/RTE Relocatable Library Reference Manual
         (24998-90001, October 1981)
     - Implementing the HP 2100 Fast FORTRAN Processor
         (12907-90010, November 1974)
     - 93585A Microcode Source
         (93585-18002 Rev. 2005)
     - 93585A Double Integer Instructions Installation and Reference Manual
         (93585-90007, February 1984)
*/



#include "hp2100_defs.h"
#include "hp2100_cpu.h"
#include "hp2100_cpu_dmm.h"
#include "hp2100_cpu_fp.h"



/* 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.

   Implementation 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.

    9. The protected memory lower bound for the .GOTO instruction is 2.

   10. The OP_N (none) operand pattern is used here for all double-integer
       instructions.  They are dispatched to the DBI handler for execution,
       where the correct operands will be retrieved
*/

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

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                       /*  ---    ---    ---    ---  */
  };

#endif                                                  /* end of int64 support */

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 intrq)
{
OP fpop;
OPS op, op2;
uint32 entry;
HP_WORD 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 */

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

if (!(cpu_configuration & CPU_1000_F)) {                /* 2100/M/E-Series? */
    if (op_ffp_e [entry] != OP_N) {
        reason = cpu_ops (op_ffp_e [entry], op);        /* get instruction operands */

        if (reason != SCPE_OK)                          /* evaluation failed? */
            return reason;                              /* return reason for failure */
        }
    }

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

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

        if (reason != SCPE_OK)                          /* evaluation failed? */
            return reason;                              /* return reason for failure */
        }

    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;
            PR = (PR + 1) & LA_MASK;                    /* P+2 return for firmware w/DBI */
            return reason;

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

        case 004:                                       /* .DCO 105204 (OP_N) */
            return cpu_dbi (0105324u);                  /* 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 (0105330u);                  /* remap to double int handler */

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

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

        case 013:                                       /* .DDS 105213 (OP_N) */
            return cpu_dbi (0105333u);                  /* 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 (!(cpu_configuration & CPU_1000))            /* must be 1000 M/E-series */
            return STOP (cpu_ss_unimpl);                /* 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 (!(cpu_configuration & CPU_1000))            /* must be 1000 */
            return STOP (cpu_ss_unimpl);                /* trap if not */

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

        fpop = ReadOp (op[0].word, fp_x);               /* read unpacked */
        O = fp_nrpack (&fpop, fpop, SEXT16 (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? */
            PR = err_PR;                                /* 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? */
            PR = err_PR;                                /* 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? */
            PR = err_PR;                                /* 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? */
            PR = err_PR;                                /* 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 (!(cpu_configuration & CPU_1000))            /* must be 1000 */
            return STOP (cpu_ss_unimpl);                /* 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 (!(cpu_configuration & CPU_1000))            /* must be 1000 */
            return STOP (cpu_ss_unimpl);                /* trap if not */

        if (intrq) {                                    /* interrupt pending? */
            PR = err_PR;                                /* 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 (!(cpu_configuration & CPU_1000))            /* must be 1000 */
            return STOP (cpu_ss_unimpl);                /* trap if not */

        if (intrq) {                                    /* interrupt pending? */
            PR = err_PR;                                /* 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 (cpu_configuration & CPU_2100)
            PR = (PR + 1) & LA_MASK;                    /* 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 (SEXT16 (op[1].word) < 1)                    /* index < 1? */
            op[1].word = 1;                             /* reset min */

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

        MR = ReadW (sa);                                /* get jump target */
        reason = cpu_resolve_indirects (TRUE);          /* resolve indirects */

        if (reason != SCPE_OK) {                        /* resolution failed? */
            PR = err_PR;                                /* irq restarts instruction */
            break;
            }

        mp_check_jmp (MR, 2);                           /* validate jump addr */
        PCQ_ENTRY;                                      /* record last P */
        PR = MR;                                        /* 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 */
            reason = cpu_ops (OP_KK, op2);              /* get 1st, 2nd ranges */
            if (reason != SCPE_OK) {                    /* evaluation failed? */
                PR = err_PR;                            /* 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) & R_MASK;   /* return element address */
        break;

    case 023:                                           /* .ENTR 105223 (OP_A) */
        MA = PR - 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++) {
            MR = ReadW (sa++);                          /* get addr of actual */
            reason = cpu_resolve_indirects (TRUE);      /* resolve indirects */

            if (reason != SCPE_OK) {                    /* resolution failed? */
                PR = err_PR;                            /* irq restarts instruction */
                break;
                }

            WriteW (da++, MR);                          /* put addr into formal */
            }

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

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

    case 025:                                           /* .PWR2 105225 (OP_RK) */
        if (!(cpu_configuration & CPU_1000))            /* must be 1000 */
            return STOP (cpu_ss_unimpl);                /* trap if not */

        fp_unpack (&fpop, &expon, op[0], fp_f);         /* unpack value */
        expon = expon + SEXT16 (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 (!(cpu_configuration & CPU_1000))            /* must be 1000 */
            return STOP (cpu_ss_unimpl);                /* trap if not */

        fp_unpack (&fpop, &expon, op[0], fp_f);         /* unpack value */
        AR = expon & R_MASK;                            /* 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 & LA_MASK;                              /* addr must be direct */

        do {
            WriteW (BR, j);                             /* write value to address */
            j = (j + 1) & D16_MASK;                     /* incr value */
            BR = (BR + 1) & LA_MASK;                    /* 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 */
                PR = err_PR;                            /* restart instruction */
                break;
                }
            }
        while (op[0].word != 0);                        /* loop until count exhausted */
        break;

    case 030:                                           /* .PACK 105230 (OP_RC) */
        if (!(cpu_configuration & CPU_1000))            /* must be 1000 */
            return STOP (cpu_ss_unimpl);                /* trap if not */

        O = fp_nrpack (&fpop, op[0],                    /* nrm/rnd/pack value */
                       SEXT16 (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 (!(cpu_configuration & CPU_1000_E_F))        /* must be 1000 E- or F-series */
            return STOP (cpu_ss_unimpl);                /* 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) & LA_MASK;                    /* bump source addr */
            BR = (BR + 1) & LA_MASK;                    /* bump destination addr */
            }

        E = 0;                                          /* routine clears E */

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

    default:                                            /* others unimplemented */
        reason = STOP (cpu_ss_unimpl);
        }

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.

   There was no equivalent M-Series microcode, due to the limited micromachine
   address space on that system.

   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    93585A   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.

   Implementation notes:

    1. Opcodes 105335-105337 are NOPs in the microcode.  They generate
       unimplemented instructions stops under simulation.

    2. This is an implementation of Revision 2 of the microcode, which was
       released as ROM part numbers 93585-80003, 93585-80005, and 93585-80001
       (Revision 1 substituted -80002 for -80005).

    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.
*/

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 (HP_WORD IR)
{
OP din;
OPS op;
uint32 entry, t;
t_stat reason = SCPE_OK;

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

if (op_dbi[entry] != OP_N) {
    reason = cpu_ops (op_dbi [entry], op);              /* get instruction operands */
    if (reason != SCPE_OK)                              /* evaluation failed? */
        return reason;                                  /* return reason for failure */
    }

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

    case 000:                                           /* [test] 105320 (OP_N) */
        XR = 2;                                         /* set revision */
        BR = 0377;                                      /* side effect of microcode */
        SR = 0102077;                                   /* set "pass" code */
        PR = (PR + 1) & LA_MASK;                        /* return to P+1 */
        t = (AR << 16) | BR;                            /* set t for return */
        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) & D32_SIGN) != 0);
        break;

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

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

            t_int64 t64;

            t64 = (t_int64) INT32 (op[0].dword) *       /* multiply signed values */
                  (t_int64) INT32 (op[1].dword);
            O = ((t64 < -(t_int64) 0x80000000) ||       /* overflow if out of range */
                 (t64 >  (t_int64) 0x7FFFFFFF));
            if (O)
                t = D32_SMAX;                           /* if overflow, rtn max pos */
            else
                t = (uint32) (t64 & D32_MASK);          /* 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)                                      /* if overflow occurred */
                t = D32_SMAX;                           /*   then return the largest positive number */
            else if (sign)                              /* otherwise if the result is negative */
                t = ~t + 1;                             /*   then return the twos complement (set if O = 0 above) */

#endif                                                  /* end of int64 support */

        }
        break;

    case 003:                                           /* .DNG 105323 (OP_J) */
        t = ~op[0].dword + 1;                           /* negate value */
        O = (op[0].dword == D32_SIGN);                  /* 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)
            PR = (PR + 1) & LA_MASK;                    /* < rtns to P+2 */
        else if ((int32) op[0].dword > (int32) op[1].dword)
            PR = (PR + 2) & LA_MASK;                    /* > 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 == D32_SMIN) &&              /*   or max neg div -1 */
              ((int32) op[1].dword == -1)));
        if (O)
            t = D32_SMAX;                               /* rtn max pos for ovf */
        else
            t = (uint32) (INT32 (op[0].dword) /         /* else return quotient */
                          INT32 (op[1].dword));
        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) & D32_SIGN) != 0);
        break;

    case 010:                                           /* .DIN 105330 (OP_J) */
        t = op[0].dword + 1;                            /* increment value */
        O = (t == D32_SMIN);                            /* 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 == D32_SMAX);                            /* 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)
            PR = (PR + 1) & LA_MASK;                    /* 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)
            PR = (PR + 1) & LA_MASK;                    /* 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 unimplemented */
        t = (AR << 16) | BR;                            /* set t for NOP */
        reason = STOP (cpu_ss_unimpl);
        }

if (reason == SCPE_OK) {                                /* if return OK */
    AR = UPPER_WORD (t);                                /*   break result */
    BR = LOWER_WORD (t);                                /*     into A and B */
    }

return reason;
}
