! ZCALC
!
! Example/test program for floating-point library

Zcharacter terminating 133;

Include "FP";

Array inputbuf -> 256;

Array py_temp --> 2;
Array py_p --> 2;
Array py_q --> 2;
Array py_r --> 2;
Array py_s --> 2;
Array py_0 --> $0000 $0000;
Array py_2 --> $4000 $0000;
Array py_4 --> $4080 $0000;

[ hypot dest x y
        p q r s;
  p = py_p;
  q = py_q;
  fabs(p, x);
  fabs(q, y);

  ! Ensure p >= q
  x = fcmp(p, q);
  if (x == FCMP_L)
  {
    r = p; p = q; q = r;
  }
  else if (x == FCMP_U)
  {
    ! Tedious NaN handling. Like C, hypot(nan,inf)=inf
    if (isinf(q)) { fcpy(dest, q); return; }
    if (~~isinf(p)) { fadd(dest, p, q); return; }
  }
  
  if (feq(p, py_0) || isinf(p)) { fcpy(dest, p); return; }
  
  r = py_r;
  s = py_s;
  for (::)
  {
    fdiv(r, q, p);
    fmul(r, r, r);
    fadd(s, r, py_4);
    if (feq(s, py_4)) { fcpy(dest, p); return; }
    fdiv(r, r, s);
    fmul(py_temp, py_2, r);
    fmul(py_temp, py_temp, p);
    fadd(p, p, py_temp);
    fmul(q, q, r);
  }
];

[ zsciitable s
             len i;
  len = s-->0;
  s = s + 2;
  for (i=0: i<len: i++)
  {
    print (char) s->i;
  }
];

Global CalcMode = fp;

Array CalcAns -> 200;

[ printcopyright c;
  if ($32-->0 < $0100) { print "(c)"; return; }
  @"EXT:12S" 169 -> c;
  if (c & 1)
    @"EXT:11" 169;
  else
    print "(c)";
];

[ calculator term i n p;
  style bold;
  print "ZCALC^";
  style roman;
  print "An interactive FP library demonstration^
         Copyright ";
  printcopyright();
  print " 2002 by Kevin Bracey^
         Release ", ($02-->0 & $03FF), " / Serial number ";
  for (i=0:i<6:i++) print (char) $12->i;
  print " / Inform v"; inversion;
  print "^^I'm a calculator. I can do simple operations like 3/4 and 2+2.^^
         Numbers can be entered in decimal, eg ~3.3~, ~-.23~, or ~3.3E-22~, or
         in hex, eg ~$23~, ~-$1F.CCCCC~, ~$8.4P2~.^^
         Operators supported are: ~+~, ~-~, ~*~ (or ~x~), ~/~, ~%~, ~&~
         (hypoteneuse), ~c~ (compare), ~r~ (round to integer) and
         ~q~ (square root).^^
         Different output modes can be selected by typing G, E, F, H or R. G, E
         and F can be followed by a precision specifier.^^
         The rounding mode can be changed by typing U, D, N, or Z.^^
         Pressing F1 inserts the previous answer (to full precision).^^";
  for (::)
  {
    inputbuf->0 = 40;
    inputbuf->1 = 0;
    style bold;
    do
    {
      @aread inputbuf 0 -> term;
      if (term==133)
      {
        p = 2 + inputbuf->1;
        n = CalcAns-->0;
        if ((inputbuf->1 + n) <= 40)
        {
          print (zsciitable) CalcAns;
          for (i=0: i<n: i++, p++)
            inputbuf->p = CalcAns->(i+2);
          inputbuf->1 = inputbuf->1 + n;
        }
      }
    } until (term==10 || term==13);
    style roman;
    calculate(inputbuf+2,inputbuf->1,CalcAns);
  }
];

Array CalcX --> 2;
Array CalcY --> 2;

[ calculate buf sl store len c func p;
  p = buf;
  if (sl==0) { print "Pardon?^"; return; }
  c = p->0;
  if ((c>='e' && c<='h') || c=='r')
  {
    switch (c)
    {
      'g': fesetprintmode(FE_PRINT_G); CalcMode=fp;
      'f': fesetprintmode(FE_PRINT_F); CalcMode=fp;
      'e': fesetprintmode(FE_PRINT_E); CalcMode=fp;
      'h': CalcMode=fhex;
      'r': CalcMode=fraw;
    }
    len=0;
    sl--;
    p++;
    if (sl~=0)
    {
      while (sl)
      {
        c = p->0;
        p++;
        sl--;
        if (c>='0' && c<='9')
          len=len*10+c-'0';
        else
          break;
      }
      fesetprintprecision(len);
    }
    !if (store && store-->0)
      jump answer;
    !else
    !  print "Output format changed^";
    !return;
  }
  len = strtof(CalcX, p, sl);
  if (len==0)
  {
    switch (c)
    {
      'u': fesetround(FE_UPWARD);     "Round upwards";
      'd': fesetround(FE_DOWNWARD);   "Round downwards";
      'n': fesetround(FE_TONEAREST);  "Round to nearest";
      'z': fesetround(FE_TOWARDZERO); "Round toward zero";
      default: "Syntax error";
    }
  }
  sl = sl - len;
  p = p + len;
  if (sl == 0) jump answer;
  c = p->0;
  while (c==' ')
  {
    p++;
    sl--;
    if (sl==0) jump answer;
    c = p->0;
  }
  switch (c)
  {
    '+': func = fadd;
    '-': func = fsub;
    '*','x': func = fmul;
    '/': func = fdiv;
    '%': func = frem;
    '&': func = hypot;
    'c': func = fcmp;
    'r': func = frnd;
    'q': func = fsqrt;
    default: print "Syntax error^"; return;
  }
  if (func ~= frnd or fsqrt)
  {
    p++;
    sl--;
    len = strtof(CalcY, p, sl);
    if (len==0) { print "Syntax error^"; return; }
  }
  if (func==fcmp)
  {
    c = fcmp(CalcX, CalcY);
    switch (c)
    {
      FCMP_U: "Unordered";
      FCMP_L: "Less than";
      FCMP_E: "Equal";
      FCMP_G: "Greater than";
    }
  }  
  feclearexcept(FE_ALL_EXCEPT);
  if (func == frnd or fsqrt)
    func.call(CalcX, CalcX);
  else
    func.call(CalcX, CalcX, CalcY);
  c=fetestexcept(FE_ALL_EXCEPT);
  if (c)
  {
    style underline;
    print (char) '(';
    if (c & FE_INVALID)
      { print "Invalid"; c = c &~ FE_INVALID; if (c) print (char) ','; }
    if (c & FE_OVERFLOW)
      { print "Overflow"; c = c &~ FE_OVERFLOW; if (c) print (char) ','; }
    if (c & FE_UNDERFLOW)
      { print "Underflow"; c = c &~ FE_UNDERFLOW; if (c) print (char) ','; }
    if (c & FE_DIVBYZERO)
      { print "DivByZero"; c = c &~ FE_DIVBYZERO; if (c) print (char) ','; }
    if (c & FE_INEXACT)
        print "Inexact";
    print (char) ')'; new_line;
    style roman;
  }
 .answer;
  print (char) '='; CalcMode(CalcX); new_line;
  if (store)
  {
    @output_stream 3 store;
    c = fesetprintprecision(9); 
    p = fesetprintmode(FE_PRINT_G);
    CalcMode(CalcX);
    fesetprintprecision(c);
    fesetprintmode(p);
    @output_stream $FFFD;
  }
];

[ Main;
  calculator();
];