! FPConst
!
! A slightly scary FP library demonstration that uses signalling NaNs to
! allow simple declaration of FP constants.
!
! The new syntax supplied is
!
!   Array twenty --> FPCONST "20";
!
! or
!
!   Object xxx
!     with number FPCONST "1E6";
!
! It works by FPCONST being a specific signalling NaN bitfield, and installing
! an invalid operation handler that catches use of such signalling NaNs,
! substituting in the appropriate values, then restarting the operation.
!
! The trap handler must be installed by calling FPConstInit(). The FPConst
! trap handler will pass control onto any previously installed trap handler
! if the trap was not due to a "FPCONST" signalling NaN.
!
! Now, I'm not sure that this is a terribly efficient way of doing things,
! or less error-prone than using finit() manually, but it does at least serve
! as a demonstration of writing trap handlers.

System_file;

Constant FPCONST $7F81;

Global old_ivo_enable;
Global old_ivo_handler;

Array AI_1 --> 3;
Array AI_2 --> 3;

[ fpconst_create dest OP
                  h l;
  h = OP-->1;
  l = OP-->2;
  @log_shift l 0-8 -> l;
  @log_shift h 8 -> h;
  l = h | l;
  finit(dest, l);
  if (OP-->0 < 0)
    fneg(dest, dest);
  return dest;
];

[ fpconst_ivo_handler dest fmt op rounding reason OP1 OP2;
  if (reason ~= InvReason_SigNaN)
    jump notforus;
  
  @check_arg_count 5 ?~noop;

  fcpyx(AI_1, OP1);
  fcpyx(AI_2, OP2);
  
  !print (frawx) AI_1, " ", (frawx) AI_2; new_line;
  
  if (issignallingx(AI_1) && (AI_1-->1 & $FF00) == $0100)
  {
    fpconst_create(AI_1, AI_1);
    if (fmt ~= FE_FMT_S or FE_FMT_P) fstox(AI_1, AI_1);
  }
  else if (fmt == FE_FMT_S)
    fxtos(AI_1, AI_1);
  
  @check_arg_count 6 ?~noop;
  if (issignallingx(AI_2) && (AI_2-->1 & $FF00) == $0100)
  {
    fpconst_create(AI_2, AI_2);
    if (fmt ~= FE_FMT_S) fstox(AI_2, AI_2);
  }
  else if (fmt == FE_FMT_S)
    fxtos(AI_2, AI_2);
  
 .noop;
 
  !print (frawx) AI_1, " ", (frawx) AI_2; new_line;
  !print op;
 
  switch (fmt)
  {
  FE_FMT_S:
    switch (op)
    {
      FE_OP_ADD: fadd(dest, AI_1, AI_2, rounding);
      FE_OP_SUB: fsub(dest, AI_1, AI_2, rounding);
      FE_OP_MUL: fmul(dest, AI_1, AI_2, rounding);
      FE_OP_DIV: fdiv(dest, AI_1, AI_2, rounding);
      FE_OP_REM: frem(dest, AI_1, AI_2, rounding);
      FE_OP_CONV,
      FE_OP_DEC: fcpy(dest, AI_1);
      FE_OP_RND: frnd(dest, AI_1, rounding);
      FE_OP_SQT: fsqt(dest, AI_1, rounding);
      default: print "[** FPConst - fmt = S; op = ", op, " **]^"; quit;
    }
  FE_FMT_X:
    switch (op)
    {
      FE_OP_ADD: faddx(dest, AI_1, AI_2, rounding);
      FE_OP_SUB: fsubx(dest, AI_1, AI_2, rounding);
      FE_OP_MUL: fmulx(dest, AI_1, AI_2, rounding);
      FE_OP_DIV: fdivx(dest, AI_1, AI_2, rounding);
      FE_OP_REM: fremx(dest, AI_1, AI_2, rounding);
      FE_OP_CONV: fcpyx(dest, AI_1);
      FE_OP_RND: frndx(dest, AI_1, rounding);
      FE_OP_SQT: fsqtx(dest, AI_1, rounding);
      default: print "[** FPConst - fmt = X; op = ", op, " **]^"; quit;
    }
  FE_FMT_I:
    switch (op)
    {
      FE_OP_CMP: return fcmpx(AI_1, AI_2);
      FE_OP_CMPE: return fcmpex(AI_1, AI_2);
      FE_OP_FIX: return fxtoi(AI_1, rounding);
      default: print "[** FPConst - fmt = I; op = ", op, " **]^"; quit;
    }
  FE_FMT_P:
    switch (op)
    {
      FE_OP_DEC: fstop(dest, AI_1, rounding);
      default: print "[** FPConst - fmt = P; op = ", op, " **]^"; quit;
    }
  default: print "[** FPConst - fmt = ", fmt, "; op = ", op, " **]^"; quit;
  }
  return;
  
 .notforus;
  if (old_ivo_enable)
  {
    @check_arg_count 5 ?n2;
    @call_vs2 old_ivo_handler dest fmt op reason -> sp;
    @ret_popped;
   .n2;
    @check_arg_count 6 ?n3;
    @call_vs2 old_ivo_handler dest fmt op reason OP1 -> sp;
    @ret_popped;
   .n3;
    @call_vs2 old_ivo_handler dest fmt op reason OP1 OP2 -> sp;
    @ret_popped;
  }
  else
  {
    fesetexcept(FE_INVALID);
    ! It's up to us to create the result
    switch (fmt)
    {
      FE_FMT_P: dest-->0 = $0FF8; dest-->1 = $0000;
                dest-->2 = (reason/10)*16 + (reason%10);
      FE_FMT_S: dest-->0 = $7FC0; dest-->1 = reason;
      FE_FMT_X: dest-->0 = $03FF; dest-->1 = $4000; dest-->2 = reason*256;
      FE_FMT_I: switch (op)
                { FE_OP_CMP, FE_OP_CMPE: return FCMP_U;
                  default: return $8000;
                }
      default: print "[** FPConst - fmt = ", fmt, "; op = ", op, " **]^"; quit;
    }
  }
];

[ FPConstInit;
  old_ivo_enable = fetesttrap(FE_INVALID);
  old_ivo_handler = fegettraphandler(FE_INVALID);
  fesettraphandler(fpconst_ivo_handler, FE_INVALID);
  feenabletrap(FE_INVALID);
];