BSD 4_4_Lite1 development
authorCSRG <csrg@ucbvax.Berkeley.EDU>
Wed, 30 Mar 1994 20:05:47 +0000 (12:05 -0800)
committerCSRG <csrg@ucbvax.Berkeley.EDU>
Wed, 30 Mar 1994 20:05:47 +0000 (12:05 -0800)
Work on file usr/src/contrib/calc-2.9.3t6/cmath.h
Work on file usr/src/contrib/calc-2.9.3t6/alloc.c
Work on file usr/src/contrib/calc-2.9.3t6/addop.c
Work on file usr/src/contrib/calc-2.9.3t6/alloc.h
Work on file usr/src/contrib/calc-2.9.3t6/CHANGES
Work on file usr/src/contrib/calc-2.9.3t6/LIBRARY
Work on file usr/src/contrib/calc-2.9.3t6/BUGS
Work on file usr/src/contrib/calc-2.9.3t6/calc.h
Work on file usr/src/contrib/calc-2.9.3t6/README
Work on file usr/src/contrib/calc-2.9.3t6/calc.c
Work on file usr/src/contrib/calc-2.9.3t6/Makefile
Work on file usr/src/contrib/calc-2.9.3t6/calc.man
Work on file usr/src/contrib/calc-2.9.3t6/assocfunc.c
Work on file usr/src/contrib/calc-2.9.3t6/help/builtin
Work on file usr/src/contrib/calc-2.9.3t6/func.h
Work on file usr/src/contrib/calc-2.9.3t6/help/define
Work on file usr/src/contrib/calc-2.9.3t6/config.c
Work on file usr/src/contrib/calc-2.9.3t6/comfunc.c
Work on file usr/src/contrib/calc-2.9.3t6/const.c
Work on file usr/src/contrib/calc-2.9.3t6/help/config
Work on file usr/src/contrib/calc-2.9.3t6/help/command
Work on file usr/src/contrib/calc-2.9.3t6/file.c
Work on file usr/src/contrib/calc-2.9.3t6/help/file
Work on file usr/src/contrib/calc-2.9.3t6/endian.c
Work on file usr/src/contrib/calc-2.9.3t6/commath.c
Work on file usr/src/contrib/calc-2.9.3t6/help/expression
Work on file usr/src/contrib/calc-2.9.3t6/codegen.c
Work on file usr/src/contrib/calc-2.9.3t6/func.c
Work on file usr/src/contrib/calc-2.9.3t6/help/environment
Work on file usr/src/contrib/calc-2.9.3t6/help/credit
Work on file usr/src/contrib/calc-2.9.3t6/help/usage
Work on file usr/src/contrib/calc-2.9.3t6/help/overview
Work on file usr/src/contrib/calc-2.9.3t6/help/Makefile
Work on file usr/src/contrib/calc-2.9.3t6/help/interrupt
Work on file usr/src/contrib/calc-2.9.3t6/help/assoc
Work on file usr/src/contrib/calc-2.9.3t6/help/help
Work on file usr/src/contrib/calc-2.9.3t6/help/statement
Work on file usr/src/contrib/calc-2.9.3t6/hist.c
Work on file usr/src/contrib/calc-2.9.3t6/help/history
Work on file usr/src/contrib/calc-2.9.3t6/input.c
Work on file usr/src/contrib/calc-2.9.3t6/help/list
Work on file usr/src/contrib/calc-2.9.3t6/help/mat
Work on file usr/src/contrib/calc-2.9.3t6/help/operator
Work on file usr/src/contrib/calc-2.9.3t6/help/types
Work on file usr/src/contrib/calc-2.9.3t6/label.c
Work on file usr/src/contrib/calc-2.9.3t6/help/intro
Work on file usr/src/contrib/calc-2.9.3t6/label.h
Work on file usr/src/contrib/calc-2.9.3t6/hist.h
Work on file usr/src/contrib/calc-2.9.3t6/help/obj.file
Work on file usr/src/contrib/calc-2.9.3t6/help/variable
Work on file usr/src/contrib/calc-2.9.3t6/help/todo
Work on file usr/src/contrib/calc-2.9.3t6/lib/lucas_chk.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/pell.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/pi.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/poly.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/ellip.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/README
Work on file usr/src/contrib/calc-2.9.3t6/lib/lucas.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/quat.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/psqrt.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/mersenne.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/pollard.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/lucas_tbl.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/mod.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/regress.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/bigprime.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/deg.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/Makefile
Work on file usr/src/contrib/calc-2.9.3t6/lib/unitfrac.cal
Work on file usr/src/contrib/calc-2.9.3t6/matfunc.c
Work on file usr/src/contrib/calc-2.9.3t6/longbits.c
Work on file usr/src/contrib/calc-2.9.3t6/lib/randmprime.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/nextprim.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/solve.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/surd.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/test1000.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/chrem.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/sumsq.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/varargs.cal
Work on file usr/src/contrib/calc-2.9.3t6/listfunc.c
Work on file usr/src/contrib/calc-2.9.3t6/lib/bindings
Work on file usr/src/contrib/calc-2.9.3t6/lint.sed
Work on file usr/src/contrib/calc-2.9.3t6/lib/altbind
Work on file usr/src/contrib/calc-2.9.3t6/lib/bernoulli.cal
Work on file usr/src/contrib/calc-2.9.3t6/lib/cryrand.cal
Work on file usr/src/contrib/calc-2.9.3t6/symbol.h
Work on file usr/src/contrib/calc-2.9.3t6/qfunc.c
Work on file usr/src/contrib/calc-2.9.3t6/symbol.c
Work on file usr/src/contrib/calc-2.9.3t6/token.c
Work on file usr/src/contrib/calc-2.9.3t6/opcodes.c
Work on file usr/src/contrib/calc-2.9.3t6/qmod.c
Work on file usr/src/contrib/calc-2.9.3t6/qtrans.c
Work on file usr/src/contrib/calc-2.9.3t6/qmath.h
Work on file usr/src/contrib/calc-2.9.3t6/string.h
Work on file usr/src/contrib/calc-2.9.3t6/obj.c
Work on file usr/src/contrib/calc-2.9.3t6/string.c
Work on file usr/src/contrib/calc-2.9.3t6/opcodes.h
Work on file usr/src/contrib/calc-2.9.3t6/stdarg.h
Work on file usr/src/contrib/calc-2.9.3t6/qmath.c
Work on file usr/src/contrib/calc-2.9.3t6/qio.c
Work on file usr/src/contrib/calc-2.9.3t6/value.c
Work on file usr/src/contrib/calc-2.9.3t6/zmath.h
Work on file usr/src/contrib/calc-2.9.3t6/zmod.c
Work on file usr/src/contrib/calc-2.9.3t6/zmul.c
Work on file usr/src/contrib/calc-2.9.3t6/zmath.c
Work on file usr/src/contrib/calc-2.9.3t6/zio.c
Work on file usr/src/contrib/calc-2.9.3t6/token.h
Work on file usr/src/contrib/calc-2.9.3t6/version.c
Work on file usr/src/contrib/calc-2.9.3t6/try_stdarg.c
Work on file usr/src/contrib/calc-2.9.3t6/value.h
Work on file usr/src/contrib/calc-2.9.3t6/zfunc.c

Synthesized-from: CSRG/cd2/4.4BSD-Lite1

111 files changed:
usr/src/contrib/calc-2.9.3t6/BUGS [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/CHANGES [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/LIBRARY [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/Makefile [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/README [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/addop.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/alloc.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/alloc.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/assocfunc.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/calc.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/calc.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/calc.man [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/cmath.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/codegen.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/comfunc.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/commath.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/config.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/const.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/endian.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/file.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/func.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/func.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/Makefile [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/assoc [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/builtin [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/command [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/config [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/credit [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/define [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/environment [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/expression [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/file [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/help [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/history [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/interrupt [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/intro [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/list [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/mat [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/obj.file [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/operator [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/overview [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/statement [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/todo [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/types [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/usage [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/help/variable [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/hist.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/hist.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/input.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/label.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/label.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/Makefile [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/README [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/altbind [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/bernoulli.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/bigprime.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/bindings [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/chrem.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/cryrand.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/deg.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/ellip.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/lucas.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/lucas_chk.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/lucas_tbl.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/mersenne.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/mod.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/nextprim.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/pell.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/pi.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/pollard.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/poly.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/psqrt.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/quat.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/randmprime.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/regress.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/solve.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/sumsq.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/surd.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/test1000.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/unitfrac.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lib/varargs.cal [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/lint.sed [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/listfunc.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/longbits.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/matfunc.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/obj.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/opcodes.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/opcodes.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/qfunc.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/qio.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/qmath.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/qmath.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/qmod.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/qtrans.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/stdarg.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/string.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/string.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/symbol.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/symbol.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/token.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/token.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/try_stdarg.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/value.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/value.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/version.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/zfunc.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/zio.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/zmath.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/zmath.h [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/zmod.c [new file with mode: 0644]
usr/src/contrib/calc-2.9.3t6/zmul.c [new file with mode: 0644]

diff --git a/usr/src/contrib/calc-2.9.3t6/BUGS b/usr/src/contrib/calc-2.9.3t6/BUGS
new file mode 100644 (file)
index 0000000..0ae3f64
--- /dev/null
@@ -0,0 +1,23 @@
+We welcome comments, suggestions and most importantly, fixes in the
+form of a patch.  Send such items to:
+
+    dbell@canb.auug.org.au
+    chongo@toad.com                {uunet,pyramid,sun}!hoptoad!chongo
+
+The following are the known bugs and mis-features in 2.9.3.  
+
+    * Saber C warns about several problems related to accessing memory
+      that has not been previously set.  Purify, on the other hand,
+      does not issue such warnings.  These problems need to be looked
+      into and if they are real, they need to be fixed.
+
+      One may not need Saber C to work on this problem.  The warning
+      spots have been marked as comments in the source.  To find these
+      warnings, grep for the XXX symbol in the source.
+
+    * Purify reports that calc leaks memory.  Plug these leaks or
+      determine that such leaks are non-issues.
+    
+    * Calc does not support negative mods.
+
+    * The output of list(2,3,4) is indented differently from list().
diff --git a/usr/src/contrib/calc-2.9.3t6/CHANGES b/usr/src/contrib/calc-2.9.3t6/CHANGES
new file mode 100644 (file)
index 0000000..2aad68e
--- /dev/null
@@ -0,0 +1,219 @@
+Following is the change from calc version 2.9.2 to 2.9.3t6:
+
+    WARNING: This patch is an unofficial alpha test patch by chongo@toad.com
+            (Landon Curt Noll) which as not been fully reviewed.  Blame
+            chongo for any problems this patch may cause!  The paranoid may
+            want to use 2.9.2 or wait for 2.9.4.
+
+    Calc can now compile on OSF/1, SGI and IBM RS6000 systems.
+
+    A number of systems that have both <varargs.h> and <stdarg.h> do
+    not correctly implement both types.  On some System V, MIPS and DEC
+    systems, vsprintf() and <stdarg.h> do not mix.  While calc will
+    pass the regression test, use of undefined variables will cause
+    problems.  The Makefile has been modified to look for this problem
+    and work around it.
+
+    Added randmprime.cal which find a prime of the form h*2^n-1 >= 2^x
+    for some given x.  The initial search points for 'h' and 'n'
+    are selected by a cryptographic pseudo-random generator.
+
+    The library script nextprim.cal is now a link to nextprime.cal.
+    The lib/Makefile will take care of this link and install.
+
+    The show command now takes singular forms.  For example, the
+    command 'show builtin' does the same as 'show builtins'.  This
+    allows show to match the historic singular names used in
+    the help system.
+
+    Synced 'show builtin' output with 'help builtin' output.
+
+    Certain 64 bit processors such as the Alpha are now supported.
+
+    Added -once to the READ command.  The command:
+
+       read -once filename
+
+    like the regular READ expect that it will ignore filename if
+    is has been previously read.
+
+    Improved the makefile.  One now can select the compiler type.  The
+    make dependency lines are now simple foo.o: bar.h lines.  While
+    this makes for a longer list, it is easier to maintain and will
+    make future Makefile patches smaller.  Added special options for
+    gcc version 1 & 2, and for cc on RS6000 systems.
+
+    Calc compiles cleanly under the watchful eye of gcc version 2.4.5
+    with the exception of warnings about 'aggregate has a partly
+    bracketed initializer'.  (gcc v2 should allow you to disable
+    this type of warning with using -Wall)
+
+    Fixed a longjmp bug that clobbered a local variable in main().
+
+    Fixed a number of cases where local variables or malloced storage was
+    being used before being set.
+
+    Fixed a number of fence post errors resulting in reads or writes
+    just outside of malloced storage.
+
+    A certain parallel processor optimizer would give up on
+    code in cases where math_error() was called.  The obscure
+    work-a-rounds involved initializing or making static, certain
+    local variables.
+
+    The cryrand.cal library has been improved.  Due to the way
+    the initial quadratic residues are selected, the random numbers
+    produced differ from previous versions.
+
+    The printing of a leading '~' on rounded values is now a config
+    option.  By default, tilde is still printed.  See help/config for
+    details.
+
+    The builtin function base() may be used to set the output mode or
+    base.  Calling base(16) is a convenient shorthand for typing
+    config("mode","hex").  See help/builtin.
+
+    The printing of a leading tab is now a config option.  This does not
+    alter the format of functions such as print or printf.  By default,
+    a tab is printed.  See help/config for details.
+
+    The value atan2(0,0) now returns 0 value in conformance with
+    the 4.3BSD ANSI/IEEE 754-1985 math library.
+
+    For all values of x, x^0 yields 1.  The major change here is
+    that 0^0 yields 1 instead of an error.
+
+    Fixed gcd() bug that caused gcd(2,3,1/2) to ignore the 1/2 arg.
+
+    Fixed ltol() rounding so that exact results are returned, similar
+    to the way sqrt() and hypot() round, when they exist.
+
+    The file help/full is now being built.
+
+    The man page is not installed by default.  One may install either
+    the man page source or the cat (formatted man) page.  See the
+    Makefile for details.
+
+    Added a quit binding.  The file lib/bindings2 shows how this new
+    binding may be used.
+
+    One can now do a 'make check' to run the calc regression test
+    within in the source tree.
+
+    The regression test code is now more extensive.
+
+    Updated the help/todo list.  A BUGS file was added.  Volunteers are
+    welcome to send in patches!
+
+Following is the change from calc version 2.9.1 to 2.9.2:
+
+    Fixed floor() for values -1 < x < 0.
+
+    Fixed ceil() for values -1 < x < 0.
+
+    Fixed frac() for values < 0 so that int(x) + frac(x) == x.
+
+    Fixed wild fetch bug in zdiv, zquo and zmod code.
+
+    Fixed bug which caused regression test #719 to fail on some machines.
+
+    Added more regression test code.
+
+Following is the change from calc version 2.9.0 to 2.9.1:
+
+    A major bug was fixed in subtracting two numbers when the first
+    number was zero.  The problem caused wrong answers and core dumps.
+
+Following is a list of visible changes to calc from version 1.27.0 to 2.9.0:
+
+    Full prototypes have been provided for all C functions, and are used
+    if calc is compiled with an ANSI compiler.
+
+    Newly defined variables are now initialized to the value of zero instead
+    of to the null value.  The elements of new objects are also initialized
+    to the value of zero instead of null.
+
+    The gcd, lcm, and ismult functions now work for fractional values.
+
+    A major bug in the // division for fractions with a negative divisor
+    was fixed.
+
+    A major bug in the calculation of ln for small values was fixed.
+
+    A major bug in the calculation of the ln and power functions for complex
+    numbers was fixed.
+
+    A major lack of precision for sin and tan for small values was fixed.
+
+    A major lack of precision for complex square roots was fixed.
+
+    The "static" keyword has been implemented for variables.  So permanent
+    variables can be defined to have either file scope or function scope.
+
+    Initialization of variables during their declaration are now allowed.
+    This is most convenient for the initialization of static variables.
+
+    The matrix definition statement can now be used within a declaration
+    statement, to immediately define a variable as a matrix.
+
+    Initializations of the elements of matrices are now allowed.  One-
+    dimensional matrices may have implicit bounds when initialization is
+    used.
+
+    The obj definition statement can now be used within a declaration
+    statement, to immediately define a variable as an object.
+
+    Object definitions can be repeated as long as they are exactly the same
+    as the previous definition.  This allows the rereading of files which
+    happen to define objects.
+
+    The integer, rational, and complex routines have been made into a
+    'libcalc.a' library so that they can be used in other programs besides
+    the calculator.  The "math.h" include file has been split into three
+    include files: "zmath.h", "qmath.h", and "cmath.h".
+
+Following is a list of visible changes to calc from version 1.26.4 to 1.27.0:
+
+    Added an assoc function to return a new type of value called an
+    association.  Such values are indexed by one or more arbitrary values.
+    They are stored in a hash table for quick access.
+
+    Added a hash() function which accepts one or more values and returns
+    a quickly calculated small non-negative hash value for those values.
+
+Following is a list of visible changes to calc from version 1.26.2 to 1.26.4:
+
+    Misc fixes to Makefiles.
+
+    Misc lint fixes.
+
+    Misc portability fixes.
+
+    Misc typo and working fixes to comments, help files and the man page.
+
+Following is a list of visible changes to calc from version 1.24.7 to 1.26.2:
+
+    There is a new emacs-like command line editing and edit history
+    feature.  The old history mechanism has been removed.  The key
+    bindings for the new editing commands are slightly configurable
+    since they are read in from an initialization file.  This file is
+    usually called /usr/lib/calc/bindings, but can be changed by the
+    CALCBINDINGS environment variable.  All editing code is
+    self-contained in the new files hist.c and hist.h, which can be
+    easily extracted and used in other programs.
+
+    Two new library files have been added: chrem.cal and cryrand.cal.
+    The first of these solves the chinese remainder problem for a set
+    of modulos and remainders.  The second of these implements several
+    very good random number generators for large numbers.
+
+    A small bug which allowed division by zero was fixed.
+
+    A major bug in the mattrans function was fixed.
+
+    A major bug in the acos function for negative arguments was fixed.
+
+    A major bug in the strprintf function when objects were being printed
+    was fixed.
+
+    A small bug in the library file regress.cal was fixed.
diff --git a/usr/src/contrib/calc-2.9.3t6/LIBRARY b/usr/src/contrib/calc-2.9.3t6/LIBRARY
new file mode 100644 (file)
index 0000000..7aab3dd
--- /dev/null
@@ -0,0 +1,352 @@
+       USING THE ARBITRARY PRECISION ROUTINES IN A C PROGRAM
+
+
+Part of the calc release consists of an arbitrary precision math library.
+This library is used by the calc program to perform its own calculations.
+If you wish, you can ignore the calc program entirely and call the arbitrary
+precision math routines from your own C programs.
+
+The library is called libmath.a, and provides routines to handle arbitrary
+precision arithmetic with integers, rational numbers, or complex numbers.
+There are also many numeric functions such as factorial and gcd, along
+with some transcendental functions such as sin and exp.
+
+-------------
+INCLUDE FILES
+-------------
+
+To use any of these routines in your own programs, you need to include the
+appropriate include file.  These include files are:
+
+       zmath.h         (for integer arithmetic)
+       qmath.h         (for rational arithmetic)
+       cmath.h         (for complex number arithmetic)
+
+You never need to include more than one of the above files, even if you wish
+to use more than one type of arithmetic, since qmath.h automatically includes
+zmath.h, and cmath.h automatically includes qmath.h.
+
+The prototypes for the available routines are listed in the above include
+files.  Some of these routines are meant for internal use, and so aren't
+convenient for outside use.  So you should read the source for a routine
+to see if it really does what you think it does.  I won't guarantee that
+obscure internal routines won't change or disappear in future releases!
+
+When calc is installed, all of the include files needed to build
+libcalc.a along with the library itself (and the lint library
+llib-lcalc.ln, if made) are installed into ${LIBDIR}.
+
+External programgs may want to compile with:
+       
+       -I${LIBDIR} -L${LIBDIR} -lcalc
+
+--------------
+ERROR HANDLING
+--------------
+
+You program MUST provide a function called math_error.  This is called by
+the math routines on an error condition, such as malloc failures or a
+division by zero.  The routine is called in the manner of printf, with a
+format string and optional arguments.  (However, none of the low level math
+routines currently uses formatting, so if you are lazy you can simply use
+the first argument as a simple error string.)  For example, one of the
+error calls you might expect to receive is:
+
+       math_error("Division by zero");
+
+Your program can handle errors in basically one of two ways.  Firstly, it
+can simply print the error message and then exit.  Secondly, you can make
+use of setjmp and longjmp in your program.  Use setjmp at some appropriate
+level in your program, and use longjmp in the math_error routine to return
+to that level and so recover from the error.  This is what the calc program
+does.
+
+---------------
+OUTPUT ROUTINES
+---------------
+
+The output from the routines in the library normally goes to stdout.  You
+can divert that output to either another FILE handle, or else to a string.
+Read the routines in zio.c to see what is available.  Diversions can be
+nested.
+
+You use math_setfp to divert output to another FILE handle.  Calling
+math_setfp with stdout restores output to stdout.
+
+Use math_divertio to begin diverting output into a string.  Calling
+math_getdivertedio will then return a string containing the output, and
+clears the diversion.  The string is reallocated as necessary, but since
+it is in memory, there are obviously limits on the amount of data that can
+be diverted into it.  The string needs freeing when you are done with it.
+
+Calling math_cleardiversions will clear all the diversions to strings, and
+is useful on an error condition to restore output to a known state.  You
+should also call math_setfp on errors if you had changed that.
+
+If you wish to mix your own output with numeric output from the math routines,
+then you can call math_chr, math_str, math_fill, math_fmt, or math_flush.
+These routines output single characters, output null-terminated strings,
+output strings with space filling, output formatted strings like printf, and
+flush the output.  Output from these routines is diverted as described above.
+
+You can change the default output mode by calling math_setmode, and you can
+change the default number of digits printed by calling math_setdigits.  These
+routines return the previous values.  The possible modes are described in
+zmath.h.
+
+--------------
+USING INTEGERS
+--------------
+
+The arbitrary precision integer routines define a structure called a ZVALUE.
+This is defined in zmath.h.  A ZVALUE contains a pointer to an array of
+integers, the length of the array, and a sign flag.  The array is allocated
+using malloc, so you need to free this array when you are done with a
+ZVALUE.  To do this, you should call zfree with the ZVALUE as an argument
+(or call freeh with the pointer as an argument) and never try to free the
+array yourself using free.  The reason for this is that sometimes the pointer
+points to one of two statically allocated arrays which should NOT be freed.
+
+The ZVALUE structures are passed to routines by value, and are returned
+through pointers.  For example, to multiply two small integers together,
+you could do the following:
+
+       ZVALUE  z1, z2, z3;
+
+       itoz(3L, &z1);
+       itoz(4L, &z2);
+       zmul(z1, z2, &z3);
+
+Use zcopy to copy one ZVALUE to another.  There is no sharing of arrays
+between different ZVALUEs even if they have the same value, so you MUST
+use this routine.  Simply assigning one value into another will cause
+problems when one of the copies is freed.  However, the special ZVALUE
+values _zero_ and _one_ CAN be assigned to variables directly, since their
+values of 0 and 1 are so common that special checks are made for them.
+
+For initial values besides 0 or 1, you need to call itoz to convert a long
+value into a ZVALUE, as shown in the above example.  Or alternatively,
+for larger numbers you can use the atoz routine to convert a string which
+represents a number into a ZVALUE.  The string can be in decimal, octal,
+hex, or binary according to the leading digits.
+
+Always make sure you free a ZVALUE when you are done with it or when you
+are about to overwrite an old ZVALUE with another value by passing its
+address to a routine as a destination value, otherwise memory will be
+lost.  The following shows an example of the correct way to free memory
+over a long sequence of operations.
+
+       ZVALUE z1, z2, z3;
+
+       z1 = _one_;
+       atoz("12345678987654321", &z2);
+       zadd(z1, z2, &z3);
+       zfree(z1);
+       zfree(z2);
+       zsquare(z3, &z1);
+       zfree(z3);
+       itoz(17L, &z2);
+       zsub(z1, z2, &z3);
+       zfree(z1);
+       zfree(z2);
+       zfree(z3);
+
+There are some quick checks you can make on integers.  For example, whether
+or not they are zero, negative, even, and so on.  These are all macros
+defined in zmath.h, and should be used instead of checking the parts of the
+ZVALUE yourself.  Examples of such checks are:
+
+       ziseven(z)      (number is even)
+       zisodd(z)       (number is odd)
+       ziszero(z)      (number is zero)
+       zisneg(z)       (number is negative)
+       zispos(z)       (number is positive)
+       zisunit(z)      (number is 1 or -1)
+       zisone(z)       (number is 1)
+
+There are two types of comparisons you can make on ZVALUEs.  This is whether
+or not they are equal, or the ordering on size of the numbers.  The zcmp
+function tests whether two ZVALUEs are equal, returning TRUE if they differ.
+The zrel function tests the relative sizes of two ZVALUEs, returning -1 if
+the first one is smaller, 0 if they are the same, and 1 if the first one
+is larger.
+
+---------------
+USING FRACTIONS
+---------------
+
+The arbitrary precision fractional routines define a structure called NUMBER.
+This is defined in qmath.h.  A NUMBER contains two ZVALUEs for the numerator
+and denominator of a fraction, and a count of the number of uses there are
+for this NUMBER.  The numerator and denominator are always in lowest terms,
+and the sign of the number is contained in the numerator.  The denominator
+is always positive.  If the NUMBER is an integer, the denominator has the
+value 1.
+
+Unlike ZVALUEs, NUMBERs are passed using pointers, and pointers to them are
+returned by functions.  So the basic type for using fractions is not really
+(NUMBER), but is (NUMBER *).  NUMBERs are allocated using the qalloc routine.
+This returns a pointer to a number which has the value 1.  Because of the
+special property of a ZVALUE of 1, the numerator and denominator of this
+returned value can simply be overwritten with new ZVALUEs without needing
+to free them first.  The following illustrates this:
+
+       NUMBER *q;
+
+       q = qalloc();
+       itoz(55L, &q->num);
+
+A better way to create NUMBERs with particular values is to use the itoq,
+iitoq, or atoq functions.  Using itoq makes a long value into a NUMBER,
+using iitoq makes a pair of longs into the numerator and denominator of a
+NUMBER (reducing them first if needed), and atoq converts a string representing
+a number into the corresponding NUMBER.  The atoq function accepts input in
+integral, fractional, real, or exponential formats.  Examples of allocating
+numbers are:
+
+       NUMBER *q1, *q2, *q3;
+
+       q1 = itoq(66L);
+       q2 = iitoq(2L, 3L);
+       q3 = atoq("456.78");
+
+Also unlike ZVALUEs, NUMBERs are quickly copied.  This is because they contain
+a link count, which is the number of pointers there are to the NUMBER.  The
+qlink macro is used to copy a pointer to a NUMBER, and simply increments
+the link count and returns the same pointer.  Since it is a macro, the
+argument should not be a function call, but a real pointer variable.  The
+qcopy routine will actually make a new copy of a NUMBER, with a new link
+count of 1.  This is not usually needed.
+
+NUMBERs are deleted using the qfree routine.  This decrements the link count
+in the NUMBER, and if it reaches zero, then it will deallocate both of
+the ZVALUEs contained within the NUMBER, and then puts the NUMBER structure
+onto a free list for quick reuse.  The following is an example of allocating
+NUMBERs, copying them, adding them, and finally deleting them again.
+
+       NUMBER *q1, *q2, *q3;
+
+       q1 = itoq(111L);
+       q2 = qlink(q1);
+       q3 = qadd(q1, q2);
+       qfree(q1);
+       qfree(q2);
+       qfree(q3);
+
+Because of the passing of pointers and the ability to copy numbers easily,
+you might wish to use the rational number routines even for integral
+calculations.  They might be slightly slower than the raw integral routines,
+but are more convenient to program with.
+
+The prototypes for the fractional routines are defined in qmath.h.
+Many of the definitions for integer functions parallel the ones defined
+in zmath.h.  But there are also functions used only for fractions.
+Examples of these are qnum to return the numerator, qden to return the
+denominator, qint to return the integer part of, qfrac to return the
+fractional part of, and qinv to invert a fraction.
+
+There are some transcendental functions in the library, such as sin and cos.
+These cannot be evaluated exactly as fractions.  Therefore, they accept
+another argument which tells how accurate you want the result.  This is an
+"epsilon" value, and the returned value will be within that quantity of
+the correct value.  This is usually an absolute difference, but for some
+functions (such as exp), this is a relative difference.  For example, to
+calculate sin(0.5) to 100 decimal places, you could do:
+
+       NUMBER *q, *ans, *epsilon;
+
+       q = atoq("0.5");
+       epsilon = atoq("1e-100");
+       ans = qsin(q, epsilon);
+
+There are many convenience macros similar to the ones for ZVALUEs which can
+give quick information about NUMBERs.  In addition, there are some new ones
+applicable to fractions.  These are all defined in qmath.h.  Some of these
+macros are:
+
+       qiszero(q)      (number is zero)
+       qisneg(q)       (number is negative)
+       qispos(q)       (number is positive)
+       qisint(q)       (number is an integer)
+       qisfrac(q)      (number is fractional)
+       qisunit(q)      (number is 1 or -1)
+       qisone(q)       (number is 1)
+
+The comparisons for NUMBERs are similar to the ones for ZVALUEs.  You use the
+qcmp and qrel functions.
+
+There are four predefined values for fractions.  You should qlink them when
+you want to use them.  These are _qzero_, _qone_, _qnegone_, and _qonehalf_.
+These have the values 0, 1, -1, and 1/2.  An example of using them is:
+
+       NUMBER *q1, *q2;
+
+       q1 = qlink(&_qonehalf_);
+       q2 = qlink(&_qone_);
+
+---------------------
+USING COMPLEX NUMBERS
+---------------------
+
+The arbitrary precision complex arithmetic routines define a structure
+called COMPLEX.  This is defined in cmath.h.  This contains two NUMBERs
+for the real and imaginary parts of a complex number, and a count of the
+number of links there are to this COMPLEX number.
+
+The complex number routines work similarly to the fractional routines.
+You can allocate a COMPLEX structure using comalloc (NOT calloc!).
+You can construct a COMPLEX number with desired real and imaginary
+fractional parts using qqtoc.  You can copy COMPLEX values using clink
+which increments the link count.  And you free a COMPLEX value using cfree.
+The following example illustrates this:
+
+       NUMBER *q1, *q2;
+       COMPLEX *c1, *c2, *c3;
+
+       q1 = itoq(3L);
+       q2 = itoq(4L);
+       c1 = qqtoc(q1, q2);
+       qfree(q1);
+       qfree(q2);
+       c2 = clink(c1);
+       c3 = cmul(c1, c2);
+       cfree(c1);
+       cfree(c2);
+       cfree(c3);
+
+As a shortcut, when you want to manipulate a COMPLEX value by a real value,
+you can use the caddq, csubq, cmulq, and cdivq routines.  These accept one
+COMPLEX value and one NUMBER value, and produce a COMPLEX value.
+
+There is no direct routine to convert a string value into a COMPLEX value.
+But you can do this yourself by converting two strings into two NUMBERS,
+and then using the qqtoc routine.
+
+COMPLEX values are always returned from these routines.  To split out the
+real and imaginary parts into normal NUMBERs, you can simply qlink the
+two components, as shown in the following example:
+
+       COMPLEX *c;
+       NUMBER *rp, *ip;
+
+       c = calloc();
+       rp = qlink(c->real);
+       ip = qlink(c->imag);
+
+There are many macros for checking quick things about complex numbers,
+similar to the ZVALUE and NUMBER macros.  In addition, there are some
+only used for complex numbers.  Examples of macros are:
+
+       cisreal(c)      (number is real)
+       cisimag(c)      (number is pure imaginary)
+       ciszero(c)      (number is zero)
+       cisrunit(c)     (number is 1 or -1)
+       cisiunit(c)     (number is i or -i)
+       cisunit(c)      (number is 1, -1, i, or -i)
+
+There is only one comparison you can make for COMPLEX values, and that is
+for equality.  The ccmp function returns TRUE if two complex numbers differ.
+
+There are three predefined values for complex numbers.  You should clink
+them when you want to use them.  They are _czero_, _cone_, and _conei_.
+These have the values 0, 1, and i.
diff --git a/usr/src/contrib/calc-2.9.3t6/Makefile b/usr/src/contrib/calc-2.9.3t6/Makefile
new file mode 100644 (file)
index 0000000..d325fda
--- /dev/null
@@ -0,0 +1,1100 @@
+#!/bin/make
+#
+# Copyright (c) 1994 David I. Bell and Landon Curt Noll
+# Permission is granted to use, distribute, or modify this source,
+# provided that this copyright notice remains intact.
+#
+# Arbitrary precision calculator.
+#
+# calculator by David I. Bell
+# Makefile by Landon Curt Noll
+
+##############################################################################
+#-=-=-=-=-=-=-=-=- You may want to change some values below -=-=-=-=-=-=-=-=-#
+##############################################################################
+
+# Determine the type of terminal controls that you want to use
+#
+#      VARARG value      meaning
+#      ------------      -------
+#      (nothing)         let the makefile guess at what you need
+#      -DUSE_TERMIOS     use struct termios from <termios.h>
+#      -DUSE_TERMIO      use struct termios from <termio.h>
+#      -DUSE_SGTTY       use struct sgttyb from <sys/ioctl.h>
+#
+TERMCONTROL=
+#TERMCONTROL= -DUSE_TERMIOS
+#TERMCONTROL= -DUSE_TERMIO
+#TERMCONTROL= -DUSE_SGTTY
+
+# Determine the type of varargs that you want to use
+#
+#      VARARG value      meaning
+#      ------------      -------
+#      (nothing)         let the makefile guess at what you need
+#      STDARG            you have ANSI C and /usr/include/stdarg.h
+#      VARARGS           you have /usr/include/varargs.h
+#      SIMULATE_STDARG   use simulated ./stdarg.h
+#
+# Try defining VARARG to be nothing.  The makefile will look for the
+# needed .h files, trying for stdarg.h first.
+#
+VARARG=
+#VARARG= STDARG
+#VARARG= VARARGS
+#VARARG= SIMULATE_STDARG
+
+# If your system does not have a vsprintf() function, you could be in trouble.
+#
+#      vsprintf(stream, format, ap)
+#
+# This function works like sprintf except that the 3rd arg is a va_list
+# strarg (or varargs) list.
+#
+# If you have vsprintf, then define DONT_HAVE_VSPRINTF to be an empty string.
+# Some old systems do not have vsprintf().  If you do not have vsprintf()
+# then define DONT_HAVE_VSPRINTF to be -DDONT_HAVE_VSPRINTF and hope for
+# the best.
+#
+DONT_HAVE_VSPRINTF=
+#DONT_HAVE_VSPRINTF= -DDONT_HAVE_VSPRINTF
+
+# Determine the byte order of your machine
+#
+#    Big Endian:       Amdahl, 68k, Pyramid, Mips, Sparc, ...
+#    Little Endian:    Vax, 32k, Spim (Dec Mips), i386, i486, ...
+#
+# If in doubt, leave BYTE_ORDER empty.  This makefile will attempt to
+# use BYTE_ORDER in <machine/endian.h> or it will attempt to run
+# the endian program.  If you get syntax errors when you compile,
+# try forcing the value to be BIG_ENDIAN and run the calc regression
+# tests. (see the README file)  If the calc regression tests fail, do
+# a make clobber and try LITTLE_ENDIAN.  If that fails, ask a wizard
+# for help.
+#
+BYTE_ORDER=
+#BYTE_ORDER= BIG_ENDIAN
+#BYTE_ORDER= LITTLE_ENDIAN
+
+# Determine the number of bits in a long
+#
+# If in doubt, leave LONG_BITS empty.  This makefile will run
+# the longbits program to determine the length.
+#
+LONG_BITS=
+#LONG_BITS= 32
+#LONG_BITS= 64
+
+# Determine whether to use the standard malloc or the alternative one
+# included with the calculator.  On some machines, the alternative malloc
+# may be faster.  It also can help to debug malloc problems.
+#
+# Define MALLOC to be -DCALC_MALLOC to use the internal malloc routines.
+#
+# If in doubt, leave MALLOC empty.
+#
+MALLOC=
+#MALLOC= -DCALC_MALLOC
+
+# where to install binary files
+#
+#BINDIR= /usr/local/bin
+#BINDIR= /usr/bin
+BINDIR= /usr/contrib/bin
+
+# where to install the lib/*.cal files
+#
+# ${TOPDIR} is the directory under which the calc directory will be placed.
+# ${LIBDIR} is where the *.cal, bindings and help directory are installed.
+# ${HELPDIR} is where the help directory is installed.
+#
+#TOPDIR= /usr/local/lib
+#TOPDIR= /usr/lib
+TOPDIR= /usr/libdata
+
+LIBDIR= ${TOPDIR}/calc
+HELPDIR= ${LIBDIR}/help
+
+# where man pages are installed
+#
+# Use MANDIR= to disable installation of the calc man (source) page.
+#
+MANDIR=
+#MANDIR=/usr/local/man/man1
+#MANDIR=/usr/man/man1
+#MANDIR=/usr/share/man/man1
+#MANDIR=/usr/man/u_man/man1
+#MANDIR=/usr/contrib/man/man1
+
+# where cat (formatted man) pages are installed
+#
+# Use CATDIR= to disable installation of the calc cat (formatted) page.
+#
+CATDIR=
+#CATDIR=/usr/local/man/cat1
+#CATDIR=/usr/man/cat1
+#CATDIR=/usr/share/man/cat1
+#CATDIR=/usr/man/u_man/cat1
+#CATDIR=/usr/contrib/man/cat1
+
+# extenstion to add on to the calc man page filename
+#
+# This is ignored if CATDIR is empty.
+#
+MANEXT= 1
+#MANEXT= l
+
+# extenstion to add on to the calc man page filename
+#
+# This is ignored if CATDIR is empty.
+#
+#CATEXT= 1
+CATEXT= 0
+#CATEXT= l
+
+# how to format a man page
+#
+# We will execute ${NROFF} ${NROFF_ARG} calc.1 to format the calc man page.
+#
+# This is ignored if CATDIR is empty.
+NROFF= nroff
+#NROFF= groff
+NROFF_ARG = -man
+#NROFF_ARG = -mandoc
+
+# If the $CALCPATH environment variable is not defined, then the following
+# path will be search for calc lib routines.
+#
+CALCPATH= .:./lib:~/lib:${LIBDIR}
+
+# If the $CALCRC environment variable is not defined, then the following
+# path will be search for calc lib routines.
+#
+CALCRC= ${LIBDIR}/startup:~/.calcrc
+
+# If the $CALCBINDINGS environment variable is not defined, then the following
+# file will be used for the command line and edit history key bindings.
+#
+CALCBINDINGS= ${LIBDIR}/bindings
+#CALCBINDINGS= ${LIBDIR}/altbind
+
+# If $PAGER is not set, use this program to display a help file
+#
+CALCPAGER= more
+#CALCPAGER= pg
+#CALCPAGER= cat
+#CALCPAGER= less
+
+# Compile/Debug options for ${CC} and ${LD}
+#
+DEBUG= -O
+#DEBUG= -O2
+#DEBUG= -O3
+#DEBUG= -g
+#DEBUG= -gx
+#DEBUG= -WM,-g
+#DEBUG=
+
+# On systems that have dynamic shared libs, you want want to disable them
+# for faster calc startup.
+#
+NO_SHARED=
+#NO_SHARED= -dn
+
+# If you are running an an old BSD system, then you may not have
+# the following functions:
+#
+#      memcpy()        strchr()        memset()
+#
+# If you do not have these functions, define OLD_BSD to be -DOLD_BSD,
+# otherwise define OLD_BSD to be an empty string.
+#
+# Modern BSD and BSD-like systems have these functions and thus don't
+# need OLD_BSD.  If you don't know, try using the empty string and if
+# you get complaints, try -DOLD_BSD.
+#
+OLD_BSD=
+#OLD_BSD= -DOLD_BSD
+
+# Some old systems don't know what a uid_t is.  Define UID_T if you get
+# an error regarding 'uid_t' when compiling files such as calc.c
+#
+UID_T=
+#UID_T= -DUID_T
+
+# Some systems require one to use ranlib to add a symbol table to
+# a *.a library.  Set RANLIB to the utility that performs this action.
+# Set RANLIB to : if your system does not need such a utility.
+#
+RANLIB=ranlib
+#RANLIB=:
+
+# Some systems are able to form lint libs.  How it is formed depends
+# on your system.  If you do not care about lint, use : as the
+# LINTLIB value.
+#
+#    System type    LINTLIB recomendation
+#
+#      BSD         ${LINT} ${LCFLAGS} ${LINTFLAGS} -u -Ccalc
+#      SYSV        ${LINT} ${LCFLAGS} ${LINTFLAGS} -u -o calc
+#      disable     :
+#
+LINTLIB= ${LINT} ${LCFLAGS} ${LINTFLAGS} -u -Ccalc
+#LINTLIB= ${LINT} ${LCFLAGS} ${LINTFLAGS} -u -o calc
+#LINTLIB= :
+
+# The lint flags vary from system to system.  Some systems have the
+# opposite meaning for the flags below.  Other systems change flag
+# meaning altogether.
+#
+#       System    LINTFLAGS recomendation
+#
+#      SunOs     -a -h -v -z
+#
+LINTFLAGS= -a -h -v -z
+#LINTFLAGS=
+
+# Select your compiler type
+#
+# LCFLAGS are flags that both ${CC} and ${LINT} can use
+# LDFLAGS are flags that both ${CC} amd ${LD} can use
+# CCMAIN are flags for ${CC} when compiling only files with main()
+# CCOPT ate flags for ${CC} only
+# CFLAGS are the default flags given to ${CC}
+#
+# If you do not wish to use purify, leave ${PURIFY} commented out.
+#
+#PURIFY= /u2/purify/purify -logfile=pure.out
+#PURIFY= /u2/purify/purify
+#
+###
+#
+# common cc
+#
+LCFLAGS= ${MALLOC} ${OLD_BSD} ${DONT_HAVE_VSPRINTF} ${UID_T}
+LDFLAGS= ${DEBUG}
+CCMAIN=
+CCOPT=
+CFLAGS= ${CCOPT} ${LDFLAGS} ${LCFLAGS}
+CC= ${PURIFY} cc
+#
+# for RS6000 cc
+#
+#LCFLAGS= ${MALLOC} ${OLD_BSD} ${DONT_HAVE_VSPRINTF} ${UID_T}
+#LDFLAGS= ${DEBUG}
+#CCMAIN=
+#CCOPT=
+#CFLAGS= ${CCOPT} ${LDFLAGS} ${LCFLAGS} -qlanglvl=ansi
+#CC= ${PURIFY} cc
+#
+# for gcc1
+#
+#LCFLAGS= ${MALLOC} ${OLD_BSD} ${DONT_HAVE_VSPRINTF} ${UID_T}
+#LDFLAGS= ${DEBUG}
+#CCMAIN=
+#CCOPT= -Wall
+#CFLAGS= ${CCOPT} ${LDFLAGS} ${LCFLAGS} -ansi
+#CC= ${PURIFY} gcc
+#
+# for gcc2
+#
+#LCFLAGS= ${MALLOC} ${OLD_BSD} ${DONT_HAVE_VSPRINTF} ${UID_T}
+#LDFLAGS= ${DEBUG}
+#CCMAIN= -Wno-return-type
+#CCOPT= -Wall -Wno-implicit -Wno-comment
+#CFLAGS= ${CCOPT} ${LDFLAGS} ${LCFLAGS} -ansi
+#CC= ${PURIFY} gcc
+
+##############################################################################
+#-=-=-=-=-=-=-=-=- Be careful if you change something below -=-=-=-=-=-=-=-=-#
+##############################################################################
+
+# standard utilities used during make
+#
+SHELL= /bin/sh
+MAKE= make
+SED= sed
+TEE= tee
+LINT= lint
+CTAGS= ctags
+LD= ${CC}
+
+#
+# the source files which are built into a math library
+#
+LIBSRC = alloc.c comfunc.c commath.c qfunc.c qio.c qmath.c qmod.c qtrans.c \
+       zfunc.c zio.c zmath.c zmod.c zmul.c
+
+#
+# the object files which are built into a math library
+#
+LIBOBJS = alloc.o comfunc.o commath.o qfunc.o qio.o qmath.o qmod.o qtrans.o \
+       zfunc.o zio.o zmath.o zmod.o zmul.o
+
+#
+# the calculator source files
+#
+CALCSRC = addop.c assocfunc.c calc.c codegen.c config.c const.c        file.c \
+       func.c hist.c input.c label.c listfunc.c matfunc.c obj.c opcodes.c \
+       string.c symbol.c token.c value.c version.c
+
+#
+# we build these .o files for calc
+#
+CALCOBJS = addop.o assocfunc.o calc.o codegen.o config.o const.o file.o \
+       func.o hist.o input.o label.o listfunc.o matfunc.o obj.o opcodes.o \
+       string.o symbol.o token.o value.o version.o
+
+# we build these .h files during the make
+#
+BUILD_H_SRC= args.h config.h endian.h have_malloc.h have_stdlib.h \
+       have_string.h longbits.h terminal.h
+
+# these .h files are needed by programs that use libcalc.a
+#
+LIB_H_SRC= alloc.h args.h cmath.h endian.h have_malloc.h have_stdlib.h \
+       have_string.h longbits.h qmath.h stdarg.h zmath.h
+
+# these .h files are neither built, nor required by libcalc.a
+#
+CALC_H_SRC= calc.h config.h func.h hist.h label.h opcodes.h stdarg.h \
+       string.h symbol.h terminal.h token.h value.h
+
+# there are the complete list of .h files
+#
+H_SRC = ${CALC_H_SRC} ${LIB_H_SRC}
+
+# The code program is not part of the calc distribution, don't worry
+# if you do not have it.
+#
+CODEOBJS= code.o
+
+
+all: calc calc.1
+
+calc: libcalc.a ${CALCOBJS}
+       ${LD} ${LDFLAGS} ${CALCOBJS} libcalc.a -o calc ${NO_SHARED}
+
+calc.o: calc.c
+       ${CC} ${CFLAGS} ${CCMAIN} -c calc.c
+
+hsrc: ${BUILD_H_SRC}
+
+hist.o: hist.c Makefile
+       ${CC} ${CFLAGS} ${TERMCONTROL} -c hist.c
+
+libcalc.a: ${LIBOBJS} Makefile
+       rm -f libcalc.a
+       ar qc libcalc.a ${LIBOBJS}
+       ${RANLIB} libcalc.a
+
+endian: endian.c
+       -@rm -f endian.o endian
+       ${CC} ${CFLAGS} ${CCMAIN} endian.c -o endian ${NO_SHARED}
+
+longbits: longbits.c
+       -@rm -f longbits.o longbits
+       ${CC} ${CFLAGS} ${CCMAIN} longbits.c -o longbits ${NO_SHARED}
+
+config.h: Makefile
+       rm -f config.h
+       @echo 'forming config.h'
+       @echo '/*' > config.h
+       @echo ' * DO NOT EDIT -- generated by the Makefile' >> config.h
+       @echo ' */' >> config.h
+       @echo '' >> config.h
+       @echo '/* the default :-separated search path */' >> config.h
+       @echo '#ifndef DEFAULTCALCPATH' >> config.h
+       @echo '#define DEFAULTCALCPATH "${CALCPATH}"' >> config.h
+       @echo '#endif /* DEFAULTCALCPATH */' >> config.h
+       @echo '' >> config.h
+       @echo '/* the default :-separated startup file list */' >> config.h
+       @echo '#ifndef DEFAULTCALCRC' >> config.h
+       @echo '#define DEFAULTCALCRC "${CALCRC}"' >> config.h
+       @echo '#endif /* DEFAULTCALCRC */' >> config.h
+       @echo '' >> config.h
+       @echo '/* the default key bindings file */' >> config.h
+       @echo '#ifndef DEFAULTCALCBINDINGS' >> config.h
+       @echo '#define DEFAULTCALCBINDINGS "${CALCBINDINGS}"' >> config.h
+       @echo '#endif /* DEFAULTCALCBINDINGS */' >> config.h
+       @echo '' >> config.h
+       @echo '/* the location of the help directory */' >> config.h
+       @echo '#ifndef HELPDIR' >> config.h
+       @echo '#define HELPDIR "${HELPDIR}"' >> config.h
+       @echo '#endif /* HELPDIR */' >> config.h
+       @echo '' >> config.h
+       @echo '/* the default pager to use */' >> config.h
+       @echo '#ifndef DEFAULTCALCPAGER' >> config.h
+       @echo '#define DEFAULTCALCPAGER "${CALCPAGER}"' >> config.h
+       @echo '#endif /* DEFAULTCALCPAGER */' >> config.h
+       @echo 'config.h formed'
+
+endian.h: endian Makefile
+       rm -f endian.h
+       @echo 'forming endian.h'
+       @echo '/*' > endian.h
+       @echo ' * DO NOT EDIT -- generated by the Makefile' >> endian.h
+       @echo ' */' >> endian.h
+       @echo '' >> endian.h
+       -@if [ X"${BYTE_ORDER}" = X ]; then \
+               if [ -f /usr/include/machine/endian.h ]; then \
+                       echo '#include <machine/endian.h>' >> endian.h; \
+               else \
+                       ./endian >> endian.h; \
+               fi; \
+       else \
+           echo "#define BYTE_ORDER ${BYTE_ORDER}" >> endian.h; \
+       fi
+       @echo 'endian.h formed'
+
+longbits.h: longbits
+       rm -f longbits.h
+       @echo 'forming longbits.h'
+       @echo '/*' > longbits.h
+       @echo ' * DO NOT EDIT -- generated by the Makefile' >> longbits.h
+       @echo ' */' >> longbits.h
+       @echo '' >> longbits.h
+       -@if [ X"${LONG_BITS}" = X ]; then \
+               ./longbits >> longbits.h; \
+       else \
+               echo "#define LONG_BITS ${LONG_BITS}" >> longbits.h; \
+       fi
+       @echo 'longbits.h formed'
+
+have_malloc.h: Makefile
+       rm -f have_malloc.h
+       @echo 'forming have_malloc.h'
+       @echo '/*' > have_malloc.h
+       @echo ' * DO NOT EDIT -- generated by the Makefile' >> have_malloc.h
+       @echo ' */' >> have_malloc.h
+       @echo '' >> have_malloc.h
+       @echo '/* do we have /usr/include/malloc.h? */' > have_malloc.h
+       -@if [ -f /usr/include/malloc.h ]; then \
+               echo '#define HAVE_MALLOC_H  /* yes */' >> have_malloc.h; \
+       else \
+               echo '#undef HAVE_MALLOC_H   /* no */' >> have_malloc.h; \
+       fi
+       @echo 'have_malloc.h formed'
+
+have_stdlib.h: Makefile
+       rm -f have_stdlib.h
+       @echo 'forming have_stdlib.h'
+       @echo '/*' > have_stdlib.h
+       @echo ' * DO NOT EDIT -- generated by the Makefile' >> have_stdlib.h
+       @echo ' */' >> have_stdlib.h
+       @echo '' >> have_stdlib.h
+       @echo '/* do we have /usr/include/stdlib.h? */' > have_stdlib.h
+       -@if [ -f /usr/include/stdlib.h ]; then \
+               echo '#define HAVE_STDLIB_H  /* yes */' >> have_stdlib.h; \
+       else \
+               echo '#undef HAVE_STDLIB_H   /* no */' >> have_stdlib.h; \
+       fi
+       @echo 'have_stdlib.h formed'
+
+have_string.h: Makefile
+       rm -f have_string.h
+       @echo 'forming have_string.h'
+       @echo '/*' > have_string.h
+       @echo ' * DO NOT EDIT -- generated by the Makefile' >> have_string.h
+       @echo ' */' >> have_string.h
+       @echo '' >> have_string.h
+       @echo '/* do we have /usr/include/string.h? */' > have_string.h
+       -@if [ -f /usr/include/string.h ]; then \
+               echo '#define HAVE_STRING_H  /* yes */' >> have_string.h; \
+       else \
+               echo '#undef HAVE_STRING_H   /* no */' >> have_string.h; \
+       fi
+       @echo 'have_string.h formed'
+
+terminal.h: Makefile
+       rm -f terminal.h
+       @echo 'forming terminal.h'
+       @echo '/*' > terminal.h
+       @echo ' * DO NOT EDIT -- generated by the Makefile' >> terminal.h
+       @echo ' */' >> terminal.h
+       @echo '' >> terminal.h
+       @echo '#if !defined(USE_TERMIOS)' >> terminal.h
+       @echo '#if !defined(USE_TERMIO)' >> terminal.h
+       @echo '#if !defined(USE_SGTTY)' >> terminal.h
+       -@if [ -f /usr/include/termios.h ]; then \
+               echo '#define USE_TERMIOS  /* <termios.h> */' >> terminal.h; \
+               echo '#undef USE_TERMIO    /* <termio.h> */' >> terminal.h; \
+               echo '#undef USE_SGTTY     /* <sys/ioctl.h> */' >> terminal.h; \
+       elif [ -f /usr/include/termio.h ]; then \
+               echo '#undef USE_TERMIOS   /* <termios.h> */' >> terminal.h; \
+               echo '#define USE_TERMIO   /* <termio.h> */' >> terminal.h; \
+               echo '#undef USE_SGTTY     /* <sys/ioctl.h> */' >> terminal.h; \
+       else \
+               echo '#undef USE_TERMIOS   /* <termios.h> */' >> terminal.h; \
+               echo '#undef USE_TERMIO    /* <termio.h> */' >> terminal.h; \
+               echo '#define USE_SGTTY    /* <sys/ioctl.h> */' >> terminal.h; \
+       fi
+       @echo '#endif' >> terminal.h
+       @echo '#endif' >> terminal.h
+       @echo '#endif' >> terminal.h
+       @echo 'terminal.h formed'
+
+args.h: Makefile try_stdarg.c
+       rm -f args.h
+       @echo 'forming args.h'
+       @echo '/*' > args.h
+       @echo ' * DO NOT EDIT -- generated by the Makefile' >> args.h
+       @echo ' */' >> args.h
+       @echo '' >> args.h
+       @echo '/* what sort of variable args do we have? */' >> args.h
+       -@if [ ! -z "${VARARG}" ]; then \
+               echo '#define ${VARARG}' >> args.h; \
+       elif [ -f /usr/include/stdarg.h -a -f /usr/include/varargs.h ]; then \
+               rm -f try_stdarg; \
+               ${CC} ${CFLAGS} ${CCMAIN} try_stdarg.c -o try_stdarg; \
+               if ./try_stdarg; then \
+                   echo '#define STDARG' >> args.h; \
+               else \
+                   echo '#define VARARGS' >> args.h; \
+               fi; \
+               rm -f try_stdarg core core.try_stdarg; \
+       elif [ -f /usr/include/stdarg.h ]; then \
+               echo '#define STDARG' >> args.h; \
+       elif [ -f /usr/include/varargs.h ]; then \
+               echo '#define VARARGS' >> args.h; \
+       else \
+               echo '#define SIMULATE_STDARG' >> args.h; \
+       fi
+       @echo 'args.h formed'
+
+calc.1: calc.man
+       rm -f calc.1
+       ${SED} -e 's:$${LIBDIR}:${LIBDIR}:g' < calc.man > calc.1
+
+llib-lcalc.ln: ${BUILD_H_SRC} ${LIBSRC} Makefile
+       rm -f llib-lcalc.ln llib.out
+       -touch llib-lcalc.ln
+       ${LINTLIB} ${LIBSRC} 2>&1 | ${SED} -f lint.sed | ${TEE} llib.out
+
+lint: ${BUILD_H_SRC} ${CALCSRC} llib-lcalc.ln lint.sed Makefile
+       rm -f lint.out
+       ${LINT} ${LINTFLAGS} ${LCFLAGS} llib-lcalc.ln ${CALCSRC} 2>&1 | \
+           ${SED} -f lint.sed | ${TEE} lint.out
+
+tags: ${CALCSRC} ${LIBSRC} ${H_SRC} Makefile
+       ${CTAGS} ${CALCSRC} ${LIBSRC} ${H_SRC}
+
+check: calc ./lib/regress.cal ./lib/lucas.cal ./lib/lucas_chk.cal \
+       ./lib/test1000.cal ./lib/surd.cal ./lib/cryrand.cal
+       CALCPATH="./lib" ./calc -q read regress
+
+lintclean:
+       rm -f llib-lcalc.ln llib.out lint.out
+
+clean:
+       rm -f ${LIBOBJS} ${CALCOBJS} ${CODEOBJS}
+       rm -f endian.o try_stdarg.o try_stdarg
+       cd help; ${MAKE} -f Makefile \
+           LIBDIR=${LIBDIR} HELPDIR=${HELPDIR} clean
+       cd lib; ${MAKE} -f Makefile LIBDIR=${LIBDIR} clean
+
+clobber: lintclean
+       rm -f ${LIBOBJS} ${CALCOBJS} ${CODEOBJS}
+       rm -f tags calc code libcalc.a
+       rm -f ${BUILD_H_SRC} calc.1 endian longbits
+       rm -f *_pure_*.[oa]
+       rm -f *.pure_hardlink *.pure_linkinfo
+       cd help; ${MAKE} -f Makefile \
+           LIBDIR=${LIBDIR} HELPDIR=${HELPDIR} clobber
+       cd lib; ${MAKE} -f Makefile LIBDIR=${LIBDIR} clobber
+
+install: calc libcalc.a ${LIB_H_SRC} calc.1
+       -@if [ ! -d ${LIBDIR} ]; then \
+               echo mkdir ${LIBDIR}; \
+               mkdir ${LIBDIR}; \
+       fi
+       -chmod 0755 ${LIBDIR}
+       -@if [ ! -d ${HELPDIR} ]; then \
+               echo mkdir ${HELPDIR}; \
+               mkdir ${HELPDIR}; \
+       fi
+       -chmod 0755 ${HELPDIR}
+       -@if [ ! -d ${BINDIR} ]; then \
+               echo mkdir ${BINDIR}; \
+               mkdir ${BINDIR}; \
+       fi
+       -chmod 0755 ${BINDIR}
+       rm -f ${BINDIR}/calc
+       cp calc ${BINDIR}
+       -chmod 0555 ${BINDIR}/calc
+       cd help; ${MAKE} -f Makefile \
+           LIBDIR=${LIBDIR} HELPDIR=${HELPDIR} install
+       cd lib; ${MAKE} -f Makefile LIBDIR=${LIBDIR} install
+       rm -f ${LIBDIR}/libcalc.a
+       cp libcalc.a ${LIBDIR}/libcalc.a
+       -chmod 0644 ${LIBDIR}/libcalc.a
+       ${RANLIB} ${LIBDIR}/libcalc.a
+       @for i in ${LIB_H_SRC}; do \
+               echo rm -f ${LIBDIR}/$$i; \
+               rm -f ${LIBDIR}/$$i; \
+               echo cp $$i ${LIBDIR}; \
+               cp $$i ${LIBDIR}; \
+               echo chmod 0444 ${LIBDIR}/$$i; \
+               chmod 0444 ${LIBDIR}/$$i; \
+       done
+       @: If lint was made, install the lint library.
+       -@if [ -f llib-lcalc.ln ]; then \
+               echo rm -f ${LIBDIR}/llib-lcalc.ln; \
+               rm -f ${LIBDIR}/llib-lcalc.ln; \
+               echo cp llib-lcalc.ln ${LIBDIR}; \
+               cp llib-lcalc.ln ${LIBDIR}; \
+               echo chmod 0444 ${LIBDIR}/llib-lcalc.ln; \
+               chmod 0444 ${LIBDIR}/llib-lcalc.ln; \
+       fi
+       @: The code program is not part of the calc distribution, do not worry
+       @: if you do not have it.
+       -@if [ -f code ]; then \
+               echo chmod +x code; \
+               chmod +x code; \
+               echo rm -f ${BINDIR}/code; \
+               rm -f ${BINDIR}/code; \
+               echo cp code ${BINDIR}; \
+               cp code ${BINDIR}; \
+               echo chmod 0555 ${BINDIR}/code; \
+               chmod 0555 ${BINDIR}/code; \
+       fi
+       -@if [ -z "${MANDIR}" ]; then \
+           echo "calc man page not installed, $${MANDIR} is empty"; \
+       else \
+           echo "rm -f ${MANDIR}/calc.${MANEXT}"; \
+           rm -f ${MANDIR}/calc.${MANEXT}; \
+           echo "cp calc.1 ${MANDIR}/calc.${MANEXT}"; \
+           cp calc.1 ${MANDIR}/calc.${MANEXT}; \
+           echo "chmod 0444 ${MANDIR}/calc.${MANEXT}"; \
+           chmod 0444 ${MANDIR}/calc.${MANEXT}; \
+       fi
+       -@if [ -z "${CATDIR}" ]; then \
+           echo "calc cat page not installed, $${CATDIR} is empty"; \
+       else \
+           echo "rm -f ${CATDIR}/calc.${CATEXT}"; \
+           rm -f ${CATDIR}/calc.${CATEXT}; \
+           echo "${NROFF} ${NROFF_ARG} calc.1 > ${CATDIR}/calc.${CATEXT}"; \
+           ${NROFF} ${NROFF_ARG} calc.1 > ${CATDIR}/calc.${CATEXT}; \
+           echo "chmod 0444 ${CATDIR}/calc.${CATEXT}"; \
+           chmod 0444 ${CATDIR}/calc.${CATEXT}; \
+       fi
+
+# The code program is not part of the calc distribution, don't worry
+# if you do not have it.
+#
+code: ${CODEOBJS} libcalc.a
+       ${LD} ${LDFLAGS} ${CODEOBJS} libcalc.a -o code ${NO_SHARED}
+
+code.o: alloc.h args.h endian.h have_malloc.h have_stdlib.h have_string.h \
+       longbits.h qmath.h stdarg.h zmath.h
+       ${CC} ${CFLAGS} code.c -c
+
+
+# make depend stuff
+#
+addop.o: addop.c
+addop.o: alloc.h
+addop.o: calc.h
+addop.o: cmath.h
+addop.o: endian.h
+addop.o: func.h
+addop.o: have_malloc.h
+addop.o: have_stdlib.h
+addop.o: have_string.h
+addop.o: label.h
+addop.o: longbits.h
+addop.o: opcodes.h
+addop.o: qmath.h
+addop.o: string.h
+addop.o: symbol.h
+addop.o: token.h
+addop.o: value.h
+addop.o: zmath.h
+alloc.o: alloc.c
+alloc.o: alloc.h
+alloc.o: have_malloc.h
+alloc.o: have_stdlib.h
+alloc.o: have_string.h
+assocfunc.o: alloc.h
+assocfunc.o: assocfunc.c
+assocfunc.o: cmath.h
+assocfunc.o: endian.h
+assocfunc.o: have_malloc.h
+assocfunc.o: have_stdlib.h
+assocfunc.o: have_string.h
+assocfunc.o: longbits.h
+assocfunc.o: qmath.h
+assocfunc.o: value.h
+assocfunc.o: zmath.h
+calc.o: alloc.h
+calc.o: calc.c
+calc.o: calc.h
+calc.o: cmath.h
+calc.o: config.h
+calc.o: endian.h
+calc.o: func.h
+calc.o: have_malloc.h
+calc.o: have_stdlib.h
+calc.o: have_string.h
+calc.o: hist.h
+calc.o: label.h
+calc.o: longbits.h
+calc.o: opcodes.h
+calc.o: qmath.h
+calc.o: symbol.h
+calc.o: token.h
+calc.o: value.h
+calc.o: zmath.h
+codegen.o: alloc.h
+codegen.o: calc.h
+codegen.o: cmath.h
+codegen.o: codegen.c
+codegen.o: config.h
+codegen.o: endian.h
+codegen.o: func.h
+codegen.o: have_malloc.h
+codegen.o: have_stdlib.h
+codegen.o: have_string.h
+codegen.o: label.h
+codegen.o: longbits.h
+codegen.o: opcodes.h
+codegen.o: qmath.h
+codegen.o: string.h
+codegen.o: symbol.h
+codegen.o: token.h
+codegen.o: value.h
+codegen.o: zmath.h
+comfunc.o: alloc.h
+comfunc.o: cmath.h
+comfunc.o: comfunc.c
+comfunc.o: endian.h
+comfunc.o: have_malloc.h
+comfunc.o: have_stdlib.h
+comfunc.o: have_string.h
+comfunc.o: longbits.h
+comfunc.o: qmath.h
+comfunc.o: zmath.h
+commath.o: alloc.h
+commath.o: cmath.h
+commath.o: commath.c
+commath.o: endian.h
+commath.o: have_malloc.h
+commath.o: have_stdlib.h
+commath.o: have_string.h
+commath.o: longbits.h
+commath.o: qmath.h
+commath.o: zmath.h
+config.o: alloc.h
+config.o: calc.h
+config.o: cmath.h
+config.o: config.c
+config.o: endian.h
+config.o: have_malloc.h
+config.o: have_stdlib.h
+config.o: have_string.h
+config.o: longbits.h
+config.o: qmath.h
+config.o: value.h
+config.o: zmath.h
+const.o: alloc.h
+const.o: calc.h
+const.o: cmath.h
+const.o: const.c
+const.o: endian.h
+const.o: have_malloc.h
+const.o: have_stdlib.h
+const.o: have_string.h
+const.o: longbits.h
+const.o: qmath.h
+const.o: value.h
+const.o: zmath.h
+file.o: alloc.h
+file.o: args.h
+file.o: calc.h
+file.o: cmath.h
+file.o: endian.h
+file.o: file.c
+file.o: have_malloc.h
+file.o: have_stdlib.h
+file.o: have_string.h
+file.o: longbits.h
+file.o: qmath.h
+file.o: stdarg.h
+file.o: value.h
+file.o: zmath.h
+func.o: alloc.h
+func.o: calc.h
+func.o: cmath.h
+func.o: endian.h
+func.o: func.c
+func.o: func.h
+func.o: have_malloc.h
+func.o: have_stdlib.h
+func.o: have_string.h
+func.o: label.h
+func.o: longbits.h
+func.o: opcodes.h
+func.o: qmath.h
+func.o: string.h
+func.o: symbol.h
+func.o: token.h
+func.o: value.h
+func.o: zmath.h
+hist.o: have_string.h
+hist.o: hist.c
+hist.o: hist.h
+hist.o: terminal.h
+input.o: alloc.h
+input.o: calc.h
+input.o: cmath.h
+input.o: config.h
+input.o: endian.h
+input.o: have_malloc.h
+input.o: have_stdlib.h
+input.o: have_string.h
+input.o: hist.h
+input.o: input.c
+input.o: longbits.h
+input.o: qmath.h
+input.o: value.h
+input.o: zmath.h
+label.o: alloc.h
+label.o: calc.h
+label.o: cmath.h
+label.o: endian.h
+label.o: func.h
+label.o: have_malloc.h
+label.o: have_stdlib.h
+label.o: have_string.h
+label.o: label.c
+label.o: label.h
+label.o: longbits.h
+label.o: opcodes.h
+label.o: qmath.h
+label.o: string.h
+label.o: token.h
+label.o: value.h
+label.o: zmath.h
+listfunc.o: alloc.h
+listfunc.o: cmath.h
+listfunc.o: endian.h
+listfunc.o: have_malloc.h
+listfunc.o: have_stdlib.h
+listfunc.o: have_string.h
+listfunc.o: listfunc.c
+listfunc.o: longbits.h
+listfunc.o: qmath.h
+listfunc.o: value.h
+listfunc.o: zmath.h
+matfunc.o: alloc.h
+matfunc.o: cmath.h
+matfunc.o: endian.h
+matfunc.o: have_malloc.h
+matfunc.o: have_stdlib.h
+matfunc.o: have_string.h
+matfunc.o: longbits.h
+matfunc.o: matfunc.c
+matfunc.o: qmath.h
+matfunc.o: value.h
+matfunc.o: zmath.h
+obj.o: alloc.h
+obj.o: calc.h
+obj.o: cmath.h
+obj.o: endian.h
+obj.o: func.h
+obj.o: have_malloc.h
+obj.o: have_stdlib.h
+obj.o: have_string.h
+obj.o: label.h
+obj.o: longbits.h
+obj.o: obj.c
+obj.o: opcodes.h
+obj.o: qmath.h
+obj.o: string.h
+obj.o: symbol.h
+obj.o: value.h
+obj.o: zmath.h
+opcodes.o: alloc.h
+opcodes.o: args.h
+opcodes.o: calc.h
+opcodes.o: cmath.h
+opcodes.o: endian.h
+opcodes.o: func.h
+opcodes.o: have_malloc.h
+opcodes.o: have_stdlib.h
+opcodes.o: have_string.h
+opcodes.o: hist.h
+opcodes.o: label.h
+opcodes.o: longbits.h
+opcodes.o: opcodes.c
+opcodes.o: opcodes.h
+opcodes.o: qmath.h
+opcodes.o: stdarg.h
+opcodes.o: symbol.h
+opcodes.o: value.h
+opcodes.o: zmath.h
+qfunc.o: alloc.h
+qfunc.o: endian.h
+qfunc.o: have_malloc.h
+qfunc.o: have_stdlib.h
+qfunc.o: have_string.h
+qfunc.o: longbits.h
+qfunc.o: qfunc.c
+qfunc.o: qmath.h
+qfunc.o: zmath.h
+qio.o: alloc.h
+qio.o: args.h
+qio.o: endian.h
+qio.o: have_malloc.h
+qio.o: have_stdlib.h
+qio.o: have_string.h
+qio.o: longbits.h
+qio.o: qio.c
+qio.o: qmath.h
+qio.o: stdarg.h
+qio.o: zmath.h
+qmath.o: alloc.h
+qmath.o: endian.h
+qmath.o: have_malloc.h
+qmath.o: have_stdlib.h
+qmath.o: have_string.h
+qmath.o: longbits.h
+qmath.o: qmath.c
+qmath.o: qmath.h
+qmath.o: zmath.h
+qmod.o: alloc.h
+qmod.o: endian.h
+qmod.o: have_malloc.h
+qmod.o: have_stdlib.h
+qmod.o: have_string.h
+qmod.o: longbits.h
+qmod.o: qmath.h
+qmod.o: qmod.c
+qmod.o: zmath.h
+qtrans.o: alloc.h
+qtrans.o: endian.h
+qtrans.o: have_malloc.h
+qtrans.o: have_stdlib.h
+qtrans.o: have_string.h
+qtrans.o: longbits.h
+qtrans.o: qmath.h
+qtrans.o: qtrans.c
+qtrans.o: zmath.h
+string.o: alloc.h
+string.o: calc.h
+string.o: cmath.h
+string.o: endian.h
+string.o: have_malloc.h
+string.o: have_stdlib.h
+string.o: have_string.h
+string.o: longbits.h
+string.o: qmath.h
+string.o: string.c
+string.o: string.h
+string.o: value.h
+string.o: zmath.h
+symbol.o: alloc.h
+symbol.o: calc.h
+symbol.o: cmath.h
+symbol.o: endian.h
+symbol.o: func.h
+symbol.o: have_malloc.h
+symbol.o: have_stdlib.h
+symbol.o: have_string.h
+symbol.o: label.h
+symbol.o: longbits.h
+symbol.o: opcodes.h
+symbol.o: qmath.h
+symbol.o: string.h
+symbol.o: symbol.c
+symbol.o: symbol.h
+symbol.o: token.h
+symbol.o: value.h
+symbol.o: zmath.h
+token.o: alloc.h
+token.o: args.h
+token.o: calc.h
+token.o: cmath.h
+token.o: endian.h
+token.o: have_malloc.h
+token.o: have_stdlib.h
+token.o: have_string.h
+token.o: longbits.h
+token.o: qmath.h
+token.o: stdarg.h
+token.o: string.h
+token.o: token.c
+token.o: token.h
+token.o: value.h
+token.o: zmath.h
+value.o: alloc.h
+value.o: calc.h
+value.o: cmath.h
+value.o: endian.h
+value.o: func.h
+value.o: have_malloc.h
+value.o: have_stdlib.h
+value.o: have_string.h
+value.o: label.h
+value.o: longbits.h
+value.o: opcodes.h
+value.o: qmath.h
+value.o: string.h
+value.o: symbol.h
+value.o: value.c
+value.o: value.h
+value.o: zmath.h
+version.o: alloc.h
+version.o: calc.h
+version.o: cmath.h
+version.o: endian.h
+version.o: have_malloc.h
+version.o: have_stdlib.h
+version.o: have_string.h
+version.o: longbits.h
+version.o: qmath.h
+version.o: value.h
+version.o: version.c
+version.o: zmath.h
+zfunc.o: alloc.h
+zfunc.o: endian.h
+zfunc.o: have_malloc.h
+zfunc.o: have_stdlib.h
+zfunc.o: have_string.h
+zfunc.o: longbits.h
+zfunc.o: zfunc.c
+zfunc.o: zmath.h
+zio.o: alloc.h
+zio.o: args.h
+zio.o: endian.h
+zio.o: have_malloc.h
+zio.o: have_stdlib.h
+zio.o: have_string.h
+zio.o: longbits.h
+zio.o: stdarg.h
+zio.o: zio.c
+zio.o: zmath.h
+zmath.o: alloc.h
+zmath.o: endian.h
+zmath.o: have_malloc.h
+zmath.o: have_stdlib.h
+zmath.o: have_string.h
+zmath.o: longbits.h
+zmath.o: zmath.c
+zmath.o: zmath.h
+zmod.o: alloc.h
+zmod.o: endian.h
+zmod.o: have_malloc.h
+zmod.o: have_stdlib.h
+zmod.o: have_string.h
+zmod.o: longbits.h
+zmod.o: zmath.h
+zmod.o: zmod.c
+zmul.o: alloc.h
+zmul.o: endian.h
+zmul.o: have_malloc.h
+zmul.o: have_stdlib.h
+zmul.o: have_string.h
+zmul.o: longbits.h
+zmul.o: zmath.h
+zmul.o: zmul.c
diff --git a/usr/src/contrib/calc-2.9.3t6/README b/usr/src/contrib/calc-2.9.3t6/README
new file mode 100644 (file)
index 0000000..2699638
--- /dev/null
@@ -0,0 +1,65 @@
+# Copyright (c) 1994 David I. Bell
+# Permission is granted to use, distribute, or modify this source,
+# provided that this copyright notice remains intact.
+#
+# Arbitrary precision calculator.
+
+I am allowing this calculator to be freely distributed for personal uses.
+Like all multi-precision programs, you should not depend absolutely on
+its results, since bugs in such programs can be insidious and only rarely 
+show up.
+  
+-dbell-
+
+p.s. By Landon Curt Noll
+
+Building calc in 3 easy steps:
+
+    1) Look at the makefile, and adjust it to suit your needs.
+
+       Here are some Makefile hints:
+
+          In the past, some people have had to adjust the VARARG or
+          TERMCONTROL because the Makefile cannot always guess
+          correctly for certain systems.  You may need to play with
+          these values if you experience problems.
+
+          The default compiler used is 'cc'.  The default compiler flag 
+          is '-O'.  If you have gcc, or gcc v2 (or better) you should use
+          that instead.   Some compilers allow for optimization beyond
+          just -O (gcc v2 has -O2, mips cc has -O3).  You should select
+          the best flag for speed optimization.  Calc can be cpu intensive
+          so selecting a quality compiler and good optimization level can
+          really pay off.
+
+    2) build calc:
+
+       make all
+
+    3) test calc:
+
+       make check
+
+For further reading:
+
+    LIBRARY
+       explains how programs can use libcalc.a to take advantage 
+       of the calc multi-precision routines.  
+
+    help/todo
+       current wish list for calc
+
+    CHANGES
+       recent changes to calc
+
+    BUGS 
+       known bugs and mis-features
+    
+    help/full
+       full set of calc documentation
+
+If you find bugs (better yet if you have bug fixes); or if you have
+suggested changes (better yet if you have patches), send them to:
+
+    dbell@canb.auug.org.au
+    chongo@toad.com                {uunet,pyramid,sun}!hoptoad!chongo
diff --git a/usr/src/contrib/calc-2.9.3t6/addop.c b/usr/src/contrib/calc-2.9.3t6/addop.c
new file mode 100644 (file)
index 0000000..cc34b36
--- /dev/null
@@ -0,0 +1,438 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Add opcodes to a function being compiled.
+ */
+
+#include "calc.h"
+#include "opcodes.h"
+#include "string.h"
+#include "func.h"
+#include "token.h"
+#include "label.h"
+#include "symbol.h"
+
+
+#define        FUNCALLOCSIZE   20      /* reallocate size for functions */
+#define        OPCODEALLOCSIZE 100     /* reallocate size for opcodes in functions */
+
+
+static long maxopcodes;                /* number of opcodes available */
+static long newindex;          /* index of new function */
+static long oldop;             /* previous opcode */
+static long debugline;         /* line number of latest debug opcode */
+static long funccount;         /* number of functions */
+static long funcavail;         /* available number of functions */
+static FUNC *functemplate;     /* function definition template */
+static FUNC **functions;       /* table of functions */
+static STRINGHEAD funcnames;   /* function names */
+static int codeflag;
+
+
+/*
+ * Initialize the table of user defined functions.
+ */
+void
+initfunctions()
+{
+       initstr(&funcnames);
+       maxopcodes = OPCODEALLOCSIZE;
+       functemplate = (FUNC *) malloc(funcsize(maxopcodes));
+       if (functemplate == NULL)
+               math_error("Cannot allocate function template");
+       functions = (FUNC **) malloc(sizeof(FUNC *) * FUNCALLOCSIZE);
+       if (functions == NULL)
+               math_error("Cannot allocate function table");
+       funccount = 0;
+       funcavail = FUNCALLOCSIZE;
+}
+
+
+/*
+ * Show the list of user defined functions.
+ */
+void
+showfunctions()
+{
+       FUNC **fpp;             /* pointer into function table */
+       FUNC *fp;               /* current function */
+
+       if (funccount == 0) {
+               printf("No user functions defined.\n");
+               return;
+       }
+       printf("Name Arguments\n");
+       printf("---- ---------\n");
+       for (fpp = &functions[funccount - 1]; fpp >= functions; fpp--) {
+               fp = *fpp;
+               if (fp == NULL)
+                       continue;
+               printf("%-12s %-2d\n", fp->f_name, fp->f_paramcount);
+       }
+       printf("\n");
+}
+
+
+/*
+ * Initialize a function for definition.
+ * Newflag is TRUE if we should allocate a new function structure,
+ * instead of the usual overwriting of the template function structure.
+ * The new structure is returned in the global curfunc variable.
+ */
+void
+beginfunc(name, newflag)
+       char *name;                     /* name of function */
+       BOOL newflag;                   /* TRUE if need new structure */
+{
+       register FUNC *fp;              /* current function */
+
+       newindex = adduserfunc(name);
+       maxopcodes = OPCODEALLOCSIZE;
+       fp = functemplate;
+       if (newflag) {
+               fp = (FUNC *) malloc(funcsize(maxopcodes));
+               if (fp == NULL)
+                       math_error("Cannot allocate temporary function");
+       }
+       fp->f_next = NULL;
+       fp->f_localcount = 0;
+       fp->f_opcodecount = 0;
+       fp->f_savedvalue.v_type = V_NULL;
+       fp->f_name = namestr(&funcnames, newindex);
+       curfunc = fp;
+       initlocals();
+       initlabels();
+       oldop = OP_NOP;
+       debugline = 0;
+       errorcount = 0;
+}
+
+
+/*
+ * Commit the just defined function for use.
+ * This replaces any existing definition for the function.
+ * This should only be called for normal user-defined functions.
+ */
+void
+endfunc()
+{
+       register FUNC *fp;              /* function just finished */
+       long size;                      /* size of just created function */
+
+       checklabels();
+       if (errorcount) {
+               printf("\"%s\": %ld error%s\n", curfunc->f_name, errorcount,
+                       ((errorcount == 1) ? "" : "s"));
+               return;
+       }
+       size = funcsize(curfunc->f_opcodecount);
+       fp = (FUNC *) malloc(size);
+       if (fp == NULL)
+               math_error("Cannot commit function");
+       memcpy((char *) fp, (char *) curfunc, size);
+       if (curfunc != functemplate)
+               free(curfunc);
+       if (codeflag) {
+               for (size = 0; size < fp->f_opcodecount; ) {
+                       printf("%ld: ", (long)size);
+                       size += dumpop(&fp->f_opcodes[size]);
+               }
+       }
+       if (functions[newindex])
+               free(functions[newindex]);
+       functions[newindex] = fp;
+       objuncache();
+       if (inputisterminal())
+               printf("\"%s\" defined\n", fp->f_name);
+}
+
+
+/*
+ * Find the user function with the specified name, and return its index.
+ * If the function does not exist, its name is added to the function table
+ * and an error will be generated when it is called if it is still undefined.
+ */
+long
+adduserfunc(name)
+       char *name;             /* name of function */
+{
+       long index;             /* index of function */
+
+       index = findstr(&funcnames, name);
+       if (index >= 0)
+               return index;
+       if (funccount >= funcavail) {
+               functions = (FUNC **) realloc(functions,
+                       sizeof(FUNC *) * (funcavail + FUNCALLOCSIZE));
+               if (functions == NULL)
+                       math_error("Failed to reallocate function table");
+               funcavail += FUNCALLOCSIZE;
+       }
+       if (addstr(&funcnames, name) == NULL)
+               math_error("Cannot save function name");
+       index = funccount++;
+       functions[index] = NULL;
+       return index;
+}
+
+
+/*
+ * Clear any optimization that may be done for the next opcode.
+ * This is used when defining a label.
+ */
+void
+clearopt()
+{
+       oldop = OP_NOP;
+       debugline = 0;
+}
+
+
+/*
+ * Find a function structure given its index.
+ */
+FUNC *
+findfunc(index)
+       long index;
+{
+       if ((unsigned long) index >= funccount)
+               math_error("Undefined function");
+       return functions[index];
+}
+
+
+/*
+ * Return the name of a function given its index.
+ */
+char *
+namefunc(index)
+       long index;
+{
+       return namestr(&funcnames, index);
+}
+
+
+/*
+ * Let a matrix indexing operation know that it will be treated as a write
+ * reference instead of just as a read reference.
+ */
+void
+writeindexop()
+{
+       if (oldop == OP_INDEXADDR)
+               curfunc->f_opcodes[curfunc->f_opcodecount - 1] = TRUE;
+}
+
+
+/*
+ * Add an opcode to the current function being compiled.
+ * Note: This can change the curfunc global variable when the
+ * function needs expanding.
+ */
+void
+addop(op)
+       long op;
+{
+       register FUNC *fp;              /* current function */
+       NUMBER *q;
+
+       fp = curfunc;
+       if ((fp->f_opcodecount + 5) >= maxopcodes) {
+               maxopcodes += OPCODEALLOCSIZE;
+               fp = (FUNC *) malloc(funcsize(maxopcodes));
+               if (fp == NULL)
+                       math_error("cannot malloc function");
+               memcpy((char *) fp, (char *) curfunc,
+                       funcsize(curfunc->f_opcodecount));
+               if (curfunc != functemplate)
+                       free(curfunc);
+               curfunc = fp;
+       }
+       /*
+        * Check the current opcode against the previous opcode and try to
+        * slightly optimize the code depending on the various combinations.
+        */
+       if (op == OP_GETVALUE) {
+               switch (oldop) {
+
+               case OP_NUMBER: case OP_ZERO: case OP_ONE: case OP_IMAGINARY:
+               case OP_GETEPSILON: case OP_SETEPSILON: case OP_STRING:
+               case OP_UNDEF: case OP_GETCONFIG: case OP_SETCONFIG:
+                       return;
+               case OP_DUPLICATE:
+                       fp->f_opcodes[fp->f_opcodecount - 1] = OP_DUPVALUE;
+                       oldop = OP_DUPVALUE;
+                       return;
+               case OP_FIADDR:
+                       fp->f_opcodes[fp->f_opcodecount - 1] = OP_FIVALUE;
+                       oldop = OP_FIVALUE;
+                       return;
+               case OP_GLOBALADDR:
+                       fp->f_opcodes[fp->f_opcodecount - 2] = OP_GLOBALVALUE;
+                       oldop = OP_GLOBALVALUE;
+                       return;
+               case OP_LOCALADDR:
+                       fp->f_opcodes[fp->f_opcodecount - 2] = OP_LOCALVALUE;
+                       oldop = OP_LOCALVALUE;
+                       return;
+               case OP_PARAMADDR:
+                       fp->f_opcodes[fp->f_opcodecount - 2] = OP_PARAMVALUE;
+                       oldop = OP_PARAMVALUE;
+                       return;
+               case OP_ELEMADDR:
+                       fp->f_opcodes[fp->f_opcodecount - 2] = OP_ELEMVALUE;
+                       oldop = OP_ELEMVALUE;
+                       return;
+               }
+       }
+       if ((op == OP_NEGATE) && (oldop == OP_NUMBER)) {
+               q = constvalue(fp->f_opcodes[fp->f_opcodecount - 1]);
+               fp->f_opcodes[fp->f_opcodecount - 1] = addqconstant(qneg(q));
+               oldop = OP_NUMBER;
+               return;
+       }
+       if ((op == OP_POWER) && (oldop == OP_NUMBER)) {
+               if (qcmpi(constvalue(fp->f_opcodes[fp->f_opcodecount - 1]), 2L) == 0) {
+                       fp->f_opcodecount--;
+                       fp->f_opcodes[fp->f_opcodecount - 1] = OP_SQUARE;
+                       oldop = OP_SQUARE;
+                       return;
+               }
+               if (qcmpi(constvalue(fp->f_opcodes[fp->f_opcodecount - 1]), 4L) == 0) {
+                       fp->f_opcodes[fp->f_opcodecount - 2] = OP_SQUARE;
+                       fp->f_opcodes[fp->f_opcodecount - 1] = OP_SQUARE;
+                       oldop = OP_SQUARE;
+                       return;
+               }
+       }
+       if ((op == OP_POP) && (oldop == OP_ASSIGN)) {   /* optimize */
+               fp->f_opcodes[fp->f_opcodecount - 1] = OP_ASSIGNPOP;
+               oldop = OP_ASSIGNPOP;
+               return;
+       }
+       /*
+        * No optimization possible, so store the opcode.
+        */
+       fp->f_opcodes[fp->f_opcodecount] = op;
+       fp->f_opcodecount++;
+       oldop = op;
+}
+
+
+/*
+ * Add an opcode and and one integer argument to the current function
+ * being compiled.
+ */
+void
+addopone(op, arg)
+       long op;
+       long arg;
+{
+       NUMBER *q;
+
+       switch (op) {
+       case OP_NUMBER:
+               q = constvalue(arg);
+               if (q == NULL)
+                       break;
+               if (qiszero(q)) {
+                       addop(OP_ZERO);
+                       return;
+               }
+               if (qisone(q)) {
+                       addop(OP_ONE);
+                       return;
+               }
+               break;
+
+       case OP_DEBUG:
+               if ((traceflags & TRACE_NODEBUG) || (arg == debugline))
+                       return;
+               debugline = arg;
+               if (oldop == OP_DEBUG) {
+                       curfunc->f_opcodes[curfunc->f_opcodecount - 1] = arg;
+                       return;
+               }
+               break;
+       }
+       addop(op);
+       curfunc->f_opcodes[curfunc->f_opcodecount] = arg;
+       curfunc->f_opcodecount++;
+}
+
+
+/*
+ * Add an opcode and and two integer arguments to the current function
+ * being compiled.
+ */
+void
+addoptwo(op, arg1, arg2)
+       long op;
+       long arg1;
+       long arg2;
+{
+       addop(op);
+       curfunc->f_opcodes[curfunc->f_opcodecount++] = arg1;
+       curfunc->f_opcodes[curfunc->f_opcodecount++] = arg2;
+}
+
+
+/*
+ * Add an opcode and a character pointer to the function being compiled.
+ */
+void
+addopptr(op, ptr)
+       long op;
+       char *ptr;
+{
+       char **ptraddr;
+
+       addop(op);
+       ptraddr = (char **) &curfunc->f_opcodes[curfunc->f_opcodecount];
+       *ptraddr = ptr;
+       curfunc->f_opcodecount += PTR_SIZE;
+}
+
+
+/*
+ * Add an opcode and an index and an argument count for a function call.
+ */
+void
+addopfunction(op, index, count)
+       int count;
+       long op;
+       long index;
+{
+       long newop;
+
+       if ((op == OP_CALL) && ((newop = builtinopcode(index)) != OP_NOP)) {
+               if ((newop == OP_SETCONFIG) && (count == 1))
+                       newop = OP_GETCONFIG;
+               if ((newop == OP_SETEPSILON) && (count == 0))
+                       newop = OP_GETEPSILON;
+               if ((newop == OP_ABS) && (count == 1))
+                       addop(OP_GETEPSILON);
+               addop(newop);
+               return;
+       }
+       addop(op);
+       curfunc->f_opcodes[curfunc->f_opcodecount++] = index;
+       curfunc->f_opcodes[curfunc->f_opcodecount++] = count;
+}
+
+
+/*
+ * Add a jump-type opcode and a label to the function being compiled.
+ */
+void
+addoplabel(op, label)
+       long op;
+       LABEL *label;           /* label to be added */
+{
+       addop(op);
+       uselabel(label);
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/alloc.c b/usr/src/contrib/calc-2.9.3t6/alloc.c
new file mode 100644 (file)
index 0000000..673e86f
--- /dev/null
@@ -0,0 +1,610 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Description:
+ *     This is a very fast storage allocator. It allocates blocks of a small
+ *     number of different sizes, and keeps free lists of each size.  Blocks
+ *     that don't exactly fit are passed up to the next larger size.  In this
+ *     implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
+ *     This is designed for use in a program that uses vast quantities of
+ *     memory, but bombs when it runs out.
+ *
+ * Abnormal Conditions
+ *     This is a public domain storage allocator.
+ *
+ * Modifications:
+ *     Date            Programmer              Description of modification
+ *     27-FEB-90       Landon Curt Noll        most systems can ignore alloc.c
+ *     2-OCT-89        David I. Bell           Add free list. Sbrk now optional
+ *     30-JUN-87       Peter Miller            Made it work on Slimos.
+ *     21-FEB-82       Chris Kingsley          Initial Coding
+ *                     kingsley@cit-20         Caltech
+ */
+
+#include <stdio.h>
+#include "alloc.h"
+#include "have_stdlib.h"
+
+#ifdef HAVE_STDLIB_H
+# include <stdlib.h>
+#endif
+
+#if 0
+#define DEBUG  1               /* defined if debugging code enabled */
+#define MSTATS 1               /* defined if memory statistics kept */
+#endif
+#define        NO_SBRK 1               /* defined if cannot use sbrk */
+
+
+#if defined(CALC_MALLOC)
+/*
+ * Make these functions really accessible here.
+ */
+#undef malloc
+#undef realloc
+#undef free
+
+
+#ifdef DEBUG
+#define assert(x,v) if ((x)==0) assertfailed(v)
+#else
+#define assert(x,v)
+#endif
+
+typedef unsigned char u_char;
+typedef unsigned short u_short;
+typedef unsigned int u_int;
+typedef char * caddr_t;
+
+#ifdef NO_SBRK
+extern char * malloc();
+extern char * realloc();
+#else
+extern char * sbrk();
+#endif
+
+
+/*
+ * The overhead on a block is at least 4 bytes.  When free, this space
+ * contains a pointer to the next free block, and the bottom two bits must
+ * be zero.  When in use, the first byte is set to MAGIC, and the second
+ * byte is the size index.  The remaining bytes are for alignment.
+ * If range checking (RCHECK) is enabled and the size of the block fits
+ * in two bytes, then the top two bytes hold the size of the requested block
+ * plus the range checking words, and the header word MINUS ONE.
+ */
+
+union overhead
+{
+       union overhead * ov_next;       /* when free */
+       struct
+       {
+               u_char ovu_magic;       /* magic number */
+               u_char ovu_index;       /* bucket # */
+#define ov_magic ovu.ovu_magic
+#define ov_index ovu.ovu_index
+#ifdef RCHECK
+               u_short ovu_size;       /* actual block size */
+               u_int ovu_rmagic;       /* range magic number */
+#define ov_size ovu.ovu_size
+#define ov_rmagic ovu.ovu_rmagic
+#endif
+       } ovu;
+};
+
+#define QUANTUM_NBITS  4
+#define QUANTUM                (1<<QUANTUM_NBITS)
+
+#define MAGIC  0xff            /* magic # on accounting info */
+#define RMAGIC 0x55555555      /* magic # on range info */
+#ifdef RCHECK
+#define RSLOP  sizeof(u_int)
+#else
+#define RSLOP  0
+#endif
+
+/*
+ * nextf[i] is the pointer to the next free block of size 2^(i+3).  The
+ * smallest allocatable block is 8 bytes.  The overhead information
+ * precedes the data area returned to the user.
+ */
+
+#define NBUCKETS       32      /* we can't run out on a 32 bit machine! */
+static union overhead * nextf[NBUCKETS];
+static union overhead *watchloc = 0;   /* location to be watched */
+
+#ifdef MSTATS
+
+/*
+ * nmalloc[i] is the difference between the number of mallocs and frees
+ * for a given block size.
+ */
+
+static u_int nmalloc[NBUCKETS];
+
+#endif
+
+
+/*
+ * Watch some allocated memory to see if it gets blasted.
+ */
+allocwatch(cp)
+       char *cp;
+{
+       if (cp == NULL) {
+               watchloc = NULL;
+               return;
+       }
+       watchloc = (union overhead *)cp - 1;
+       assert(watchloc->ov_magic == MAGIC, 10);
+}
+
+
+alloccheck()
+{
+       assert((watchloc == NULL) || (watchloc->ov_magic == MAGIC), 11);
+}
+
+
+/*
+ * NAME
+ *     morecore - get more memory
+ *
+ * SYNOPSIS
+ *     void
+ *     morecore(bucket)
+ *     int bucket;
+ *
+ * DESCRIPTION
+ *     Morecore is used to allocate more memory to the indicated bucket.
+ *
+ * RETURNS
+ *     void
+ */
+static void
+morecore(bucket)
+       register u_int  bucket;
+{
+       register union overhead * op;
+       register u_int  rnu;    /* 2^rnu bytes will be requested */
+       register u_int  nblks;  /* become nblks blocks of the desired size */
+       register u_int  siz;
+
+       assert(bucket >= QUANTUM_NBITS, 1);
+       assert(bucket < NBUCKETS, 2);
+       assert(!nextf[bucket], 3);
+#ifndef NO_SBRK
+       /*
+        * Insure memory is allocated on a page boundary.
+        * Should make getpageize() call?
+        */
+#define PAGE_SIZE (1<<10)
+       siz = (u_int)sbrk(0);
+       if(siz & (PAGE_SIZE-1))
+               sbrk(PAGE_SIZE - (siz & (PAGE_SIZE-1)));
+#endif
+
+       /* take 2k unless the block is bigger than that */
+       rnu = (bucket <= 11) ? 11 : bucket;
+       assert(rnu >= bucket, 4);
+       nblks = 1L << (rnu - bucket); /* how many blocks to get */
+       siz = 1L << rnu;
+
+#ifndef NO_SBRK
+       op = (union overhead *)sbrk(siz);
+       /* no more room! */
+       if ((int)op == -1)
+               return;
+       /*
+        * Round up to minimum allocation size boundary
+        * and deduct from block count to reflect.
+        */
+       if((int)op & (QUANTUM-1))
+       {
+               op = (union overhead *)(((int)op + QUANTUM) &~ (QUANTUM-1));
+               nblks--;
+       }
+#else
+       op = (union overhead *)malloc(siz);
+       /* no more room! */
+       if (!op)
+               return;
+#endif
+       /*
+        * Add new memory allocated to the
+        * free list for this hash bucket.
+        */
+       nextf[bucket] = op;
+       siz = 1L << bucket;
+       while (--nblks)
+       {
+               op->ov_next = (union overhead *)((caddr_t)op + siz);
+               op = op->ov_next;
+       }
+}
+
+
+/*
+ * NAME
+ *     mem_alloc - memory allocator
+ *
+ * SYNOPSIS
+ *     char *
+ *     mem_alloc()
+ *
+ * DESCRIPTION
+ *     Mem_alloc is used to allocate memory large enought to fit the requested
+ *     size, and on a boundary suitable for placing any value.
+ *
+ * RETURNS
+ *     char *, pointer to base of dynamic memory allocated
+ *
+ * CAVEAT
+ *     Use mem_free() when you are finished with the space.
+ */
+char *
+mem_alloc(nbytes)
+       register unsigned long int nbytes;
+{
+       register union overhead *p;
+       register int    bucket;
+       register unsigned long int shiftr;
+
+       if (nbytes > ((unsigned int) -1))
+               return NULL;
+       assert((watchloc == NULL) || (watchloc->ov_magic == MAGIC), 12);
+       /*
+        * Convert amount of memory requested into
+        * closest block size stored in hash buckets
+        * which satisfies request.  Account for
+        * space used per block for accounting.
+        */
+       nbytes = (nbytes + sizeof (union overhead) + RSLOP + (QUANTUM-1)) &~ (QUANTUM-1);
+       shiftr = (nbytes - 1) >> QUANTUM_NBITS;
+       /* apart from this loop, this is O(1) */
+       bucket = QUANTUM_NBITS;
+       while(shiftr)
+       {
+               shiftr >>= 1;
+               bucket++;
+       }
+
+       /*
+        * If nothing in hash bucket right now,
+        * request more memory from the system.
+        */
+       if (!nextf[bucket])
+               morecore(bucket);
+       if (!(p = nextf[bucket]))
+               return (char*)0;
+       /* remove from linked list */
+       nextf[bucket] = p->ov_next;
+       p->ov_magic = MAGIC;
+       p->ov_index = bucket;
+#ifdef MSTATS
+       nmalloc[bucket]++;
+#endif
+#ifdef RCHECK
+       /*
+        * Record allocated size of block and
+        * bound space with magic numbers
+        */
+       if (nbytes <= (1L<<16))
+               p->ov_size = nbytes - 1;
+       p->ov_rmagic = RMAGIC;
+       *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
+#endif
+       return ((char *)(p + 1));
+}
+
+
+/*
+ * NAME
+ *     mem_free - free memory
+ *
+ * SYNOPSIS
+ *     int
+ *     mem_free(cp)
+ *     char * cp;
+ *
+ * DESCRIPTION
+ *     Mem_free is used to release space allocated by mem_alloc
+ *     or mem_realloc.
+ *
+ * RETURNS
+ *     int
+ *
+ * CAVEAT
+ *     do not pass mem_free() an argument that was returned by mem_alloc()
+ *     or mem_realloc().
+ */
+int
+mem_free(cp)
+       char *  cp;
+{
+       register u_int  bucket;
+       register union overhead *op;
+
+       assert((watchloc == NULL) || (watchloc->ov_magic == MAGIC), 13);
+       if (!cp)
+               return;
+       op = (union overhead *)cp - 1;
+       assert(op->ov_magic == MAGIC, 5);       /* make sure it was in use */
+       assert(op->ov_index < NBUCKETS, 6);
+       assert(op->ov_index >= QUANTUM_NBITS, 7);
+#ifdef RCHECK
+       assert(op->ov_index > 16 || op->ov_size == (1L<<op->ov_index)-1, 8);
+       assert(op->ov_rmagic == RMAGIC, 9);
+       assert(op->ov_index > 16 || *(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC, 10);
+#endif
+#ifndef DEBUG
+       if(op->ov_magic != MAGIC)
+               return;         /* sanity */
+#endif
+       bucket = op->ov_index;
+       op->ov_next = nextf[bucket];
+       nextf[bucket] = op;
+#ifdef MSTATS
+       nmalloc[bucket]--;
+#endif
+}
+
+
+/*
+ * NAME
+ *     findbucket - find a bucket
+ *
+ * SYNOPSIS
+ *     int
+ *     findbucket(freep, srchlen)
+ *     union overhead * freep;
+ *     int srchlen;
+ *
+ * DESCRIPTION
+ *     Findbucket is used to find the bucket a free block is in.
+ *     Search ``srchlen'' elements of each free list for a block whose
+ *     header starts at ``freep''.  If srchlen is -1 search the whole list.
+ *
+ * RETURNS
+ *     bucket number, or -1 if not found.
+ */
+static int
+findbucket(freep, srchlen)
+       union overhead *        freep;
+       int     srchlen;
+{
+       register union overhead *p;
+       register int    i, j;
+
+       for (i = 0; i < NBUCKETS; i++)
+       {
+               j = 0;
+               for (p = nextf[i]; p && j != srchlen; p = p->ov_next)
+               {
+                       if (p == freep)
+                               return i;
+                       j++;
+               }
+       }
+       return -1;
+}
+
+
+/*
+ * When a program attempts "storage compaction" as mentioned in the
+ * old malloc man page, it realloc's an already freed block.  Usually
+ * this is the last block it freed; occasionally it might be farther
+ * back.  We have to search all the free lists for the block in order
+ * to determine its bucket: first we make one pass thru the lists
+ * checking only the first block in each; if that fails we search
+ * ``realloc_srchlen'' blocks in each list for a match (the variable
+ * is extern so the caller can modify it).  If that fails we just copy
+ * however many bytes was given to realloc() and hope it's not huge.
+ */
+
+static int realloc_srchlen = 4;        /* 4 should be plenty, -1 =>'s whole list */
+
+/*
+ * NAME
+ *     mem_realloc - change size
+ *
+ * SYNOPSIS
+ *     char
+ *     mem_realloc(cp, nbytes)
+ *     char * cp;
+ *     u_int nbytes;
+ *
+ * DESCRIPTION
+ *     Mem_realloc is used to enlarge a chunk of memory
+ *     returned by mem_alloc() or mem_realloc().
+ *
+ * RETURNS
+ *     char *, pointer to base of dynamic memory allocated
+ *
+ * CAVEAT
+ *     Use mem_free() when you are finished with the space.
+ */
+char *
+mem_realloc(cp, nbytes)
+       char *cp;
+       unsigned long   nbytes;
+{
+       register u_int  old_nbytes;
+       register union overhead *op;
+       char *  res;
+       register u_int  old_bucket;
+       short   was_alloced = 0;
+
+       if (nbytes > ((unsigned int) -1))
+               return NULL;
+       assert((watchloc == NULL) || (watchloc->ov_magic == MAGIC), 14);
+       if (!cp)
+               return mem_alloc(nbytes);
+       op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
+       if (op->ov_magic == MAGIC)
+       {
+               was_alloced++;
+               old_bucket = op->ov_index;
+       }
+       else
+       {
+               /*
+                * Already free, doing "compaction".
+                *
+                * Search for the old block of memory on the
+                * free list. First, check the most common
+                * case (last element free'd), then (this failing)
+                * the last ``realloc_srchlen'' items free'd.
+                * If all lookups fail, then assume the size of
+                * the memory block being realloc'd is the
+                * smallest possible.
+                */
+               if
+               (
+                       (old_bucket = findbucket(op, 1)) == -1
+               &&
+                       (old_bucket = findbucket(op, realloc_srchlen)) == -1
+               )
+                       old_bucket = QUANTUM_NBITS;
+       }
+       old_nbytes = (1L << old_bucket) - sizeof(union overhead) - RSLOP;
+
+       /*
+        * avoid the copy if same size block
+        */
+       if
+       (
+               was_alloced
+       &&
+               nbytes <= old_nbytes
+       &&
+               nbytes > (old_nbytes >> 1) - sizeof(union overhead) - RSLOP
+       )
+               return cp;
+
+       /*
+        * grab another chunk
+        */
+       if(!(res = mem_alloc(nbytes)))
+               return (char*)0;
+       assert(cp != res, 11);
+       memcpy(res, cp, (nbytes < old_nbytes) ? nbytes : old_nbytes);
+       if(was_alloced)
+               mem_free(cp);
+       return res;
+}
+
+#else /*CALC_MALLOC*/
+
+#undef MSTATS
+
+#endif /*CALC_MALLOC*/
+
+
+
+/*
+ * Allocate a new item from the specified free list.
+ * Returns NULL if no item can be allocated.
+ */
+ALLOCITEM *
+allocitem(fp)
+       FREELIST *fp;           /* free list header */
+{
+       FREEITEM *ip;           /* allocated item */
+
+       if (fp->curfree > 0) {
+               fp->curfree--;
+               ip = fp->freelist;
+               fp->freelist = ip->next;
+               return (ALLOCITEM *) ip;
+       }
+       ip = (FREEITEM *) malloc(fp->itemsize);
+       if (ip == NULL)
+               return NULL;
+       return (ALLOCITEM *) ip;
+}
+
+
+/*
+ * Free an item by placing it back on a free list.
+ * If too many items are on the list, it is really freed.
+ */
+void
+freeitem(fp, ip)
+       FREELIST *fp;           /* freelist header */
+       FREEITEM *ip;           /* item to be freed */
+{
+       if (ip == NULL)
+               return;
+       if (fp->curfree >= fp->maxfree) {
+               free((char *) ip);
+               return;
+       }
+       ip->next = fp->freelist;
+       fp->freelist = ip;
+       fp->curfree++;
+}
+
+
+/*
+ * NAME
+ *     mem_stats - print memory statistics
+ *
+ * SYNOPSIS
+ *     void
+ *     mem_stats(s)
+ *     char * s;
+ *
+ * DESCRIPTION
+ *     Mem_stats is used to print out statistics about current memory usage.
+ *     ``s'' is the title string
+ *
+ *     Prints two lines of numbers, one showing the length of the free list
+ *     for each size category, the second showing the number of mallocs -
+ *     frees for each size category.
+ *
+ * RETURNS
+ *     void
+ */
+/*ARGSUSED*/
+void
+mem_stats(s)
+       char *  s;
+{
+#ifdef MSTATS
+       register int    i, j;
+       register union overhead *p;
+       int     totfree = 0;
+       int     totused = 0;
+
+       fprintf(stderr, "Memory allocation statistics %s\n", s);
+       fprintf(stderr, "%11s:%12s%12s%12s\n", "Bucket", "In Use", "Free", "Sum");
+       for (i = 0; i < NBUCKETS; i++)
+       {
+               for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
+                       ;
+               if(!j && !nmalloc[i])
+                       continue;
+               fprintf(stderr, "%11d:%12d%12d%12d\n", (1L<<i), nmalloc[i], j, j+nmalloc[i]);
+               totfree += j * (1L << i);
+               totused += nmalloc[i] * (1L << i);
+       }
+       fprintf(stderr, "%11s:%12d%12d%12d\n", "Totals", totused, totfree, totused+totfree);
+#else
+       fprintf(stderr, 
+           "Memory allocation stats were not compiled into calc\n");
+#endif
+}
+
+#ifdef DEBUG
+void
+assertfailed(n)
+{
+       printf("Assertion %d failed\n", n);
+       exit(1);
+}
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/alloc.h b/usr/src/contrib/calc-2.9.3t6/alloc.h
new file mode 100644 (file)
index 0000000..37c4b35
--- /dev/null
@@ -0,0 +1,121 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Allocator definitions (fast malloc and free)
+ */
+
+#if !defined(CALC_MALLOC)
+
+#include "have_malloc.h"
+#ifdef HAVE_MALLOC_H
+# include <malloc.h>
+#else
+# if defined(__STDC__)
+   extern void *malloc();
+   extern void *realloc();
+   extern void free();
+# else
+   extern char *malloc();
+   extern char *realloc();
+   extern void free();
+# endif
+#endif
+
+#include "have_string.h"
+
+#ifdef HAVE_STRING_H
+# include <string.h>
+
+#else
+
+# ifdef OLD_BSD
+extern void bcopy();
+extern void bfill();
+extern char *index();
+# else /* OLD_BSD */
+extern void memcpy();
+extern void memset();
+#  if defined(__STDC__)
+extern void *strchr();
+#  else
+extern char *strchr();
+#  endif
+# endif /* OLD_BSD */
+extern void strcpy();
+extern void strncpy();
+extern void strcat();
+extern int strcmp();
+extern long strlen();  /* should be size_t, but old systems don't have it */
+
+#endif
+
+#ifdef OLD_BSD
+#undef memcpy
+#define memcpy(s1, s2, n) bcopy(s2, s1, n)
+#undef memset
+#define memset(s, c, n) bfill(s, n, c)
+#undef strchr
+#define strchr(s, c) index(s, c)
+#endif
+
+#ifdef DONT_HAVE_VSPRINTF
+/*
+ * Hack aleart!!!
+ *
+ * Systems that do not have vsprintf() need something.  In some cases
+ * the sprintf function will deal correctly with the va_alist 3rd arg.
+ * Hope for the best!
+ */
+#define vsprintf sprintf
+#endif
+
+#define mem_alloc malloc
+#define mem_realloc realloc
+#define mem_free free
+
+#else /*!CALC_MALLOC*/
+
+#define malloc(a) mem_alloc((long) a)
+#define realloc(a,b) mem_realloc((char *) a, (long) b)
+#define free(a) mem_free((char *) a)
+extern char *mem_alloc();
+extern char *mem_realloc();
+extern int mem_free();         /* MUST be int even though no return value */
+
+#endif /*!CALC_MALLOC*/
+
+
+/*
+ * An item to be placed on a free list.
+ * These items are overlayed on top of the actual item being managed.
+ * Therefore, the managed items must be at least this size!
+ * Also, all items on a single free list must be the same size.
+ */
+struct free_item {
+       struct free_item *next;                 /* next item on free list */
+};
+typedef struct free_item FREEITEM;
+
+
+/*
+ * The actual free list header.
+ */
+typedef struct {
+       long            itemsize;       /* size of an item being managed */
+       long            maxfree;        /* maximum number of free items */
+       long            curfree;        /* current number of free items */
+       FREEITEM        *freelist;      /* the free list */
+} FREELIST;
+
+#if defined(__STDC__)
+typedef void ALLOCITEM;
+#else
+typedef char ALLOCITEM;
+#endif
+extern ALLOCITEM * allocitem( /* FREELIST * */ );
+extern void freeitem( /* FREELIST *, char * */ );
+extern void mem_stats();
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/assocfunc.c b/usr/src/contrib/calc-2.9.3t6/assocfunc.c
new file mode 100644 (file)
index 0000000..d058a74
--- /dev/null
@@ -0,0 +1,513 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Association table routines.
+ * An association table is a type of value which can be "indexed" by
+ * one or more arbitrary values.  Each element in the table is thus an
+ * association between a particular set of index values and a result value.
+ * The elements in an association table are stored in a hash table for
+ * quick access.
+ */
+
+#include "value.h"
+
+
+#define        MINHASHSIZE     31      /* minimum size of hash tables */
+#define        GROWHASHSIZE    50      /* approximate growth for hash tables */
+#define        CHAINLENGTH     10      /* desired number of elements on a hash chain */
+#define        ELEMSIZE(n)     (sizeof(ASSOCELEM) + (sizeof(VALUE) * ((n) - 1)))
+
+
+static ASSOCELEM *elemindex MATH_PROTO((ASSOC *ap, long index));
+static BOOL compareindices MATH_PROTO((VALUE *v1, VALUE *v2, long dim));
+static void resize MATH_PROTO((ASSOC *ap, long newsize));
+static void assoc_elemfree MATH_PROTO((ASSOCELEM *ep));
+static long nextprime MATH_PROTO((long n));
+
+
+/*
+ * Return the address of the value specified by normal indexing of
+ * an association.  The create flag is TRUE if a value is going to be
+ * assigned into the specified indexing location.  If create is FALSE and
+ * the index value doesn't exist, a pointer to a NULL value is returned.
+ */
+VALUE *
+associndex(ap, create, dim, indices)
+       ASSOC *ap;              /* association to index into */
+       BOOL create;            /* whether to create the index value */
+       long dim;               /* dimension of the indexing */
+       VALUE *indices;         /* table of values being indexed by */
+{
+       ASSOCELEM **listhead;
+       ASSOCELEM *ep;
+       static VALUE val;
+       HASH hash;
+       int i;
+
+       if (dim <= 0)
+               math_error("No dimensions for indexing association");
+
+       /*
+        * Calculate the hash value to use for this set of indices
+        * so that we can first select the correct hash chain, and
+        * also so we can quickly compare each element for a match.
+        */
+       hash = 0;
+       for (i = 0; i < dim; i++)
+               /* ignore Saber-C warning about Over/underflow */
+               hash = hash * 67319821 + hashvalue(&indices[i]);
+
+       /*
+        * Search the correct hash chain for the specified set of indices.
+        * If found, return the address of the found element's value.
+        */
+       listhead = &ap->a_table[hash % ap->a_size];
+       for (ep = *listhead; ep; ep = ep->e_next) {
+               if ((ep->e_hash != hash) || (ep->e_dim != dim))
+                       continue;
+               if (compareindices(ep->e_indices, indices, dim))
+                       return &ep->e_value;
+       }
+
+       /*
+        * The set of indices was not found.
+        * Either return a pointer to a NULL value for a read reference,
+        * or allocate a new element in the list for a write reference.
+        */
+       if (!create) {
+               val.v_type = V_NULL;
+               return &val;
+       }
+
+       ep = (ASSOCELEM *) malloc(ELEMSIZE(dim));
+       if (ep == NULL)
+               math_error("Cannot allocate association element");
+       ep->e_dim = dim;
+       ep->e_hash = hash;
+       ep->e_value.v_type = V_NULL;
+       for (i = 0; i < dim; i++)
+               copyvalue(&indices[i], &ep->e_indices[i]);
+       ep->e_next = *listhead;
+       *listhead = ep;
+       ap->a_count++;
+
+       resize(ap, ap->a_count / CHAINLENGTH);
+
+       return &ep->e_value;
+}
+
+
+/*
+ * Search an association for the specified value starting at the
+ * specified index.  Returns the element number (zero based) of the
+ * found value, or -1 if the value was not found.
+ */
+long
+assocsearch(ap, vp, index)
+       ASSOC *ap;
+       VALUE *vp;
+       long index;
+{
+       ASSOCELEM *ep;
+
+       if (index < 0)
+               index = 0;
+       while (TRUE) {
+               ep = elemindex(ap, index);
+               if (ep == NULL)
+                       return -1;
+               if (!comparevalue(&ep->e_value, vp))
+                       return index;
+               index++;
+       }
+}
+
+
+/*
+ * Search an association backwards for the specified value starting at the
+ * specified index.  Returns the element number (zero based) of the
+ * found value, or -1 if the value was not found.
+ */
+long
+assocrsearch(ap, vp, index)
+       ASSOC *ap;
+       VALUE *vp;
+       long index;
+{
+       ASSOCELEM *ep;
+
+       if (index >= ap->a_count)
+               index = ap->a_count - 1;
+       while (TRUE) {
+               ep = elemindex(ap, index);
+               if (ep == NULL)
+                       return -1;
+               if (!comparevalue(&ep->e_value, vp))
+                       return index;
+               index--;
+       }
+}
+
+
+/*
+ * Return the address of an element of an association indexed by the
+ * double-bracket operation.
+ */
+static ASSOCELEM *
+elemindex(ap, index)
+       ASSOC *ap;              /* association to index into */
+       long index;             /* index of desired element */
+{
+       ASSOCELEM *ep;
+       int i;
+
+       if ((index < 0) || (index > ap->a_count))
+               return NULL;
+
+       /*
+        * This loop should be made more efficient by remembering
+        * previously requested locations within the association.
+        */
+       for (i = 0; i < ap->a_size; i++) {
+               for (ep = ap->a_table[i]; ep; ep = ep->e_next) {
+                       if (index-- == 0)
+                               return ep;
+               }
+       }
+       return NULL;
+}
+
+
+/*
+ * Return the address of the value specified by double-bracket indexing
+ * of an association.  Returns NULL if there is no such element.
+ */
+VALUE *
+assocfindex(ap, index)
+       ASSOC *ap;              /* association to index into */
+       long index;             /* index of desired element */
+{
+       ASSOCELEM *ep;
+
+       ep = elemindex(ap, index);
+       if (ep == NULL)
+               return NULL;
+       return &ep->e_value;
+}
+
+
+/*
+ * Compare two associations to see if they are identical.
+ * Returns TRUE if they are different.
+ */
+BOOL
+assoccmp(ap1, ap2)
+       ASSOC *ap1, *ap2;
+{
+       ASSOCELEM **table1;
+       ASSOCELEM *ep1;
+       ASSOCELEM *ep2;
+       long size1;
+       long size2;
+       HASH hash;
+       long dim;
+
+       if (ap1 == ap2)
+               return FALSE;
+       if (ap1->a_count != ap2->a_count)
+               return TRUE;
+
+       table1 = ap1->a_table;
+       size1 = ap1->a_size;
+       size2 = ap2->a_size;
+       while (size1-- > 0) {
+               for (ep1 = *table1++; ep1; ep1 = ep1->e_next) {
+                       hash = ep1->e_hash;
+                       dim = ep1->e_dim;
+                       for (ep2 = ap2->a_table[hash % size2]; ;
+                               ep2 = ep2->e_next)
+                       {
+                               if (ep2 == NULL)
+                                       return TRUE;
+                               if (ep2->e_hash != hash)
+                                       continue;
+                               if (ep2->e_dim != dim)
+                                       continue;
+                               if (compareindices(ep1->e_indices,
+                                       ep2->e_indices, dim))
+                                               break;
+                       }
+                       if (comparevalue(&ep1->e_value, &ep2->e_value))
+                               return TRUE;
+               }
+       }
+       return FALSE;
+}
+
+
+/*
+ * Copy an association value.
+ */
+ASSOC *
+assoccopy(oldap)
+       ASSOC *oldap;
+{
+       ASSOC *ap;
+       ASSOCELEM *oldep;
+       ASSOCELEM *ep;
+       ASSOCELEM **listhead;
+       int oldhi;
+       int i;
+
+       ap = assocalloc(oldap->a_count / CHAINLENGTH);
+       ap->a_count = oldap->a_count;
+
+       for (oldhi = 0; oldhi < oldap->a_size; oldhi++) {
+               for (oldep = oldap->a_table[oldhi]; oldep;
+                       oldep = oldep->e_next)
+               {
+                       ep = (ASSOCELEM *) malloc(ELEMSIZE(oldep->e_dim));
+                       if (ep == NULL)
+                               math_error("Cannot allocate association element");
+                       ep->e_dim = oldep->e_dim;
+                       ep->e_hash = oldep->e_hash;
+                       ep->e_value.v_type = V_NULL;
+                       for (i = 0; i < ep->e_dim; i++)
+                               copyvalue(&oldep->e_indices[i], &ep->e_indices[i]);
+                       copyvalue(&oldep->e_value, &ep->e_value);
+                       listhead = &ap->a_table[ep->e_hash % ap->a_size];
+                       ep->e_next = *listhead;
+                       *listhead = ep;
+               }
+       }
+       return ap;
+}
+
+
+/*
+ * Resize the hash table for an association to be the specified size.
+ * This is only actually done if the growth from the previous size is
+ * enough to make this worthwhile.
+ */
+static void
+resize(ap, newsize)
+       ASSOC *ap;
+       long newsize;
+{
+       ASSOCELEM **oldtable;
+       ASSOCELEM **newtable;
+       ASSOCELEM **oldlist;
+       ASSOCELEM **newlist;
+       ASSOCELEM *ep;
+       int i;
+
+       if (newsize < ap->a_size + GROWHASHSIZE)
+               return;
+
+       newsize = nextprime(newsize);
+       newtable = (ASSOCELEM **) malloc(sizeof(ASSOCELEM *) * newsize);
+       if (newtable == NULL)
+               math_error("No memory to grow association");
+       for (i = 0; i < newsize; i++)
+               newtable[i] = NULL;
+
+       oldtable = ap->a_table;
+       oldlist = oldtable;
+       for (i = 0; i < ap->a_size; i++) {
+               while (*oldlist) {
+                       ep = *oldlist;
+                       *oldlist = ep->e_next;
+                       newlist = &newtable[ep->e_hash % newsize];
+                       ep->e_next = *newlist;
+                       *newlist = ep;
+               }
+               oldlist++;
+       }
+
+       ap->a_table = newtable;
+       ap->a_size = newsize;
+       free((char *) oldtable);
+}
+
+
+/*
+ * Free an association element, along with any contained values.
+ */
+static void
+assoc_elemfree(ep)
+       ASSOCELEM *ep;
+{
+       int i;
+
+       for (i = 0; i < ep->e_dim; i++)
+               freevalue(&ep->e_indices[i]);
+       freevalue(&ep->e_value);
+       ep->e_dim = 0;
+       ep->e_next = NULL;
+       free((char *) ep);
+}
+
+
+/*
+ * Allocate a new association value with an initial hash table.
+ * The hash table size is set at specified (but at least a minimum size).
+ */
+ASSOC *
+assocalloc(initsize)
+       long initsize;
+{
+       register ASSOC *ap;
+       int i;
+
+       if (initsize < MINHASHSIZE)
+               initsize = MINHASHSIZE;
+       ap = (ASSOC *) malloc(sizeof(ASSOC));
+       if (ap == NULL)
+               math_error("No memory for association");
+       ap->a_count = 0;
+       ap->a_size = initsize;
+       ap->a_table = (ASSOCELEM **) malloc(sizeof(ASSOCELEM *) * initsize);
+       if (ap->a_table == NULL) {
+               free((char *) ap);
+               math_error("No memory for association");
+       }
+       for (i = 0; i < initsize; i++)
+               ap->a_table[i] = NULL;
+       return ap;
+}
+
+
+/*
+ * Free an association value, along with all of its elements.
+ */
+void
+assocfree(ap)
+       register ASSOC *ap;
+{
+       ASSOCELEM **listhead;
+       ASSOCELEM *ep;
+       ASSOCELEM *nextep;
+       int i;
+
+       listhead = ap->a_table;
+       for (i = 0; i < ap->a_size; i++) {
+               nextep = *listhead;
+               *listhead = NULL;
+               while (nextep) {
+                       ep = nextep;
+                       nextep = ep->e_next;
+                       assoc_elemfree(ep);
+               }
+               listhead++;
+       }
+       free((char *) ap->a_table);
+       ap->a_table = NULL;
+       free((char *) ap);
+}
+
+
+/*
+ * Print out an association along with the specified number of
+ * its elements.  The elements are printed out in shortened form.
+ */
+void
+assocprint(ap, max_print)
+       ASSOC *ap;
+       long max_print;
+{
+       ASSOCELEM *ep;
+       long index;
+       long i;
+       int savemode;
+
+       if (max_print <= 0) {
+               math_fmt("assoc (%ld element%s)", ap->a_count,
+                       ((ap->a_count == 1) ? "" : "s"));
+               return;
+       }
+       math_fmt("\n  assoc (%ld element%s):\n", ap->a_count,
+               ((ap->a_count == 1) ? "" : "s"));
+
+       for (index = 0; ((index < max_print) && (index < ap->a_count));
+               index++)
+       {
+               ep = elemindex(ap, index);
+               if (ep == NULL)
+                       continue;
+               math_str("  [");
+               for (i = 0; i < ep->e_dim; i++) {
+                       if (i)
+                               math_chr(',');
+                       savemode = math_setmode(MODE_FRAC);
+                       printvalue(&ep->e_indices[i],
+                               (PRINT_SHORT | PRINT_UNAMBIG));
+                       math_setmode(savemode);
+               }
+               math_str("] = ");
+               printvalue(&ep->e_value, PRINT_SHORT | PRINT_UNAMBIG);
+               math_chr('\n');
+       }
+       if (max_print < ap->a_count)
+               math_str("  ...\n");
+}
+
+
+/*
+ * Return a trivial hash value for an association.
+ */
+HASH
+assochash(ap)
+       ASSOC *ap;
+{
+       return ap->a_count * 700001;
+}
+
+
+/*
+ * Compare two lists of index values to see if they are identical.
+ * Returns TRUE if they are the same.
+ */
+static BOOL
+compareindices(v1, v2, dim)
+       VALUE *v1;
+       VALUE *v2;
+       long dim;
+{
+       int i;
+
+       for (i = 0; i < dim; i++)
+               if (v1[i].v_type != v2[i].v_type)
+                       return FALSE;
+
+       while (dim-- > 0)
+               if (comparevalue(v1++, v2++))
+                       return FALSE;
+
+       return TRUE;
+}
+
+
+/*
+ * Return the next prime number up from the specified value.
+ * This is used to pick a good hash table size.
+ */
+static long
+nextprime(n)
+       long n;
+{
+       long i;
+
+       if ((n & 0x01) == 0)
+               n++;
+       while (TRUE) {
+               for (i = 3; n % i; i += 2) {
+                       if (i * i > n)
+                               return n;
+               }
+               n += 2;
+       }
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/calc.c b/usr/src/contrib/calc-2.9.3t6/calc.c
new file mode 100644 (file)
index 0000000..4b8f98c
--- /dev/null
@@ -0,0 +1,260 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Arbitrary precision calculator.
+ */
+
+#include <signal.h>
+#include <pwd.h>
+#include <sys/types.h>
+
+#include "calc.h"
+#include "hist.h"
+#include "func.h"
+#include "opcodes.h"
+#include "config.h"
+#include "token.h"
+#include "symbol.h"
+
+
+/*
+ * Common definitions
+ */
+long maxprint;         /* number of elements to print */
+int abortlevel;                /* current level of aborts */
+BOOL inputwait;                /* TRUE if in a terminal input wait */
+jmp_buf jmpbuf;                /* for errors */
+
+static int q_flag = FALSE;     /* TRUE => don't execute rc files */
+
+char *calcpath;                /* $CALCPATH or default */
+char *calcrc;          /* $CALCRC or default */
+char *calcbindings;    /* $CALCBINDINGS or default */
+char *home;            /* $HOME or default */
+static char *pager;    /* $PAGER or default */
+char *shell;           /* $SHELL or default */
+
+static void intint();  /* interrupt routine */
+static void initenv(); /* initialize/default special environment vars */
+
+#if defined(__STDC__)
+#include <unistd.h>
+#include <stdlib.h>
+#else
+extern struct passwd *getpwuid();
+#if defined (UID_T)
+typedef unsigned short uid_t;
+#endif
+extern char *getenv();
+extern uid_t geteuid();
+#endif
+extern void file_init();
+extern void zio_init();
+
+
+/*
+ * Top level calculator routine.
+ */
+main(argc, argv)
+       int argc;
+       char **argv;
+{
+       static char *str;       /* current option string or expression */
+       char cmdbuf[MAXCMD+1];  /* command line expression */
+
+       file_init();
+       zio_init();
+       initenv();
+       argc--;
+       argv++;
+       while ((argc > 0) && (**argv == '-')) {
+               for (str = &argv[0][1]; *str; str++) switch (*str) {
+                       case 'h':
+                               givehelp(DEFAULTCALCHELP);
+                               exit(0);
+                               break;
+                       case 'q':
+                               q_flag = TRUE;
+                               break;
+                       default:
+                               printf("Unknown option\n");
+                               exit(1);
+               }
+               argc--;
+               argv++;
+       }
+       str = cmdbuf;
+       *str = '\0';
+       while (--argc >= 0) {
+               *str++ = ' ';
+               strcpy(str, *argv++);
+               str += strlen(str);
+               str[0] = '\n';
+               str[1] = '\0';
+       }
+       str = cmdbuf;
+       if (*str == '\0') {
+               str = NULL;
+               version(stdout);
+               printf("[Type \"exit\" to exit, or \"help\" for help.]\n\n");
+
+               switch (hist_init(calcbindings)) {
+               case HIST_NOFILE:
+                       fprintf(stderr,
+                               "Cannot open key bindings file \"%s\", fancy editing disabled.\n",
+                               calcbindings);
+                       break;
+
+               case HIST_NOTTY:
+                       fprintf(stderr,
+                               "Cannot set terminal modes, fancy editing disabled.\n");
+                       break;
+               }
+       }
+       if (setjmp(jmpbuf) == 0) {
+               initmasks();
+               inittokens();
+               initglobals();
+               initfunctions();
+               initstack();
+               resetinput();
+               math_cleardiversions();
+               math_setfp(stdout);
+               math_setmode(MODE_INITIAL);
+               math_setdigits((long)DISPLAY_DEFAULT);
+               maxprint = MAXPRINT_DEFAULT;
+               _epsilon_ = atoq(EPSILON_DEFAULT);
+               _epsilonprec_ = qprecision(_epsilon_);
+               if (str) {
+                       if (q_flag == FALSE) {
+                               runrcfiles();
+                               q_flag = TRUE;
+                       }
+                       (void) openstring(str);
+                       getcommands(FALSE);
+                       exit(0);
+               }
+       }
+       if (str)
+               exit(1);
+       abortlevel = 0;
+       _math_abort_ = FALSE;
+       inputwait = FALSE;
+       (void) signal(SIGINT, intint);
+       math_cleardiversions();
+       math_setfp(stdout);
+       resetscopes();
+       resetinput();
+       if (q_flag == FALSE) {
+               runrcfiles();
+               q_flag = TRUE;
+       }
+       (void) openterminal();
+       getcommands(TRUE);
+       exit(0);
+       /*NOTREACHED*/
+}
+
+
+/*
+ * initenv - obtain $CALCPATH, $CALCRC, $CALCBINDINGS, $HOME, $PAGER
+ * and $SHELL values
+ *
+ * If $CALCPATH, $CALCRC, $CALCBINDINGS, $PAGER or $SHELL do not exist,
+ * use the default values.  If $PAGER or $SHELL is an empty string, also
+ * use a default value. If $HOME does not exist, or is empty, use the home
+ * directory information from the password file.
+ */
+static void
+initenv()
+{
+       struct passwd *ent;             /* our password entry */
+
+       /* determine the $CALCPATH value */
+       calcpath = getenv(CALCPATH);
+       if (calcpath == NULL)
+               calcpath = DEFAULTCALCPATH;
+
+       /* determine the $CALCRC value */
+       calcrc = getenv(CALCRC);
+       if (calcrc == NULL) {
+               calcrc = DEFAULTCALCRC;
+       }
+
+       /* determine the $CALCBINDINGS value */
+       calcbindings = getenv(CALCBINDINGS);
+       if (calcbindings == NULL) {
+               calcbindings = DEFAULTCALCBINDINGS;
+       }
+
+       /* determine the $HOME value */
+       home = getenv(HOME);
+       if (home == NULL || home[0] == '\0') {
+               ent = getpwuid(geteuid());
+               if (ent == NULL) {
+                       /* just assume . is home if all else fails */
+                       home = ".";
+               }
+               home = (char *)malloc(strlen(ent->pw_dir)+1);
+               strcpy(home, ent->pw_dir);
+       }
+
+       /* determine the $PAGER value */
+       pager = getenv(PAGER);
+       if (pager == NULL || *pager == '\0') {
+               pager = DEFAULTCALCPAGER;
+       }
+
+       /* determine the $SHELL value */
+       shell = getenv(SHELL);
+       if (shell == NULL)
+               shell = DEFAULTSHELL;
+}
+
+
+void
+givehelp(type)
+       char *type;             /* the type of help to give, NULL => index */
+{
+       char *helpcmd;          /* what to execute to print help */
+
+       /* catch the case where we just print the index */
+       if (type == NULL) {
+               type = DEFAULTCALCHELP;         /* the help index file */
+       }
+
+       /* form the help command name */
+       helpcmd = (char *)malloc(
+               sizeof("if [ ! -d \"")+sizeof(HELPDIR)+1+strlen(type)+
+               sizeof("\" ];then ")+
+               strlen(pager)+1+1+sizeof(HELPDIR)+1+strlen(type)+1+1+
+               sizeof(";else echo no such help;fi"));
+       sprintf(helpcmd, 
+           "if [ -r \"%s/%s\" ];then %s \"%s/%s\";else echo no such help;fi", 
+           HELPDIR, type, pager, HELPDIR, type);
+
+       /* execute the help command */
+       system(helpcmd);
+       free(helpcmd);
+}
+
+
+/*
+ * Interrupt routine.
+ */
+/*ARGSUSED*/
+static void
+intint(arg)
+       int arg;        /* to keep ANSI C happy */
+{
+       (void) signal(SIGINT, intint);
+       if (inputwait || (++abortlevel >= ABORT_NOW))
+               math_error("\nABORT");
+       if (abortlevel >= ABORT_MATH)
+               _math_abort_ = TRUE;
+       printf("\n[Abort level %d]\n", abortlevel);
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/calc.h b/usr/src/contrib/calc-2.9.3t6/calc.h
new file mode 100644 (file)
index 0000000..7e3a6ef
--- /dev/null
@@ -0,0 +1,155 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Definitions for calculator program.
+ */
+
+#ifndef        CALC_H
+#define        CALC_H
+
+
+#include <stdio.h>
+#include <setjmp.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include "value.h"
+
+
+/*
+ * Configuration definitions
+ */
+#define        CALCPATH        "CALCPATH"      /* environment variable for files */
+#define        CALCRC          "CALCRC"        /* environment variable for startup */
+#define        CALCBINDINGS    "CALCBINDINGS"  /* environment variable for hist bindings */
+#define        HOME            "HOME"          /* environment variable for home dir */
+#define        PAGER           "PAGER"         /* environment variable for help */
+#define        SHELL           "SHELL"         /* environment variable for shell */
+#define DEFAULTCALCHELP        "help"          /* help file that -h prints */
+#define DEFAULTSHELL   "sh"            /* default shell to use */
+#define        CALCEXT         ".cal"  /* extension for files read in */
+#define        PATHSIZE        1024    /* maximum length of path name */
+#define        HOMECHAR        '~'     /* char which indicates home directory */
+#define DOTCHAR                '.'     /* char which indicates current directory */
+#define        PATHCHAR        '/'     /* char which separates path components */
+#define        LISTCHAR        ':'     /* char which separates paths in a list */
+#define        MAXCMD          1024    /* maximum length of command invocation */
+#define        MAXERROR        512     /* maximum length of error message string */
+
+#define        SYMBOLSIZE      256     /* maximum symbol name size */
+#define        MAXINDICES      20      /* maximum number of indices for objects */
+#define        MAXLABELS       100     /* maximum number of user labels in function */
+#define        MAXOBJECTS      10      /* maximum number of object types */
+#define        MAXSTRING       1024    /* maximum size of string constant */
+#define        MAXSTACK        1000    /* maximum depth of evaluation stack */
+#define        MAXFILES        20      /* maximum number of opened files */
+#define PROMPT1                "> "    /* normal prompt */
+#define PROMPT2                ">> "   /* prompt when inside multi-line input */
+
+
+#define        TRACE_NORMAL    0x00    /* normal trace flags */
+#define        TRACE_OPCODES   0x01    /* trace every opcode */
+#define        TRACE_NODEBUG   0x02    /* suppress debugging opcodes */
+#define        TRACE_MAX       0x03    /* maximum value for trace flag */
+
+#define DISPLAY_DEFAULT 20     /* default digits for float display */
+#define EPSILON_DEFAULT "1e-20"        /* allowed error for float calculations */
+#define MAXPRINT_DEFAULT 16    /* default number of elements printed */
+
+#define ABORT_NONE     0       /* abort not needed yet */
+#define ABORT_STATEMENT        1       /* abort on statement boundary */
+#define ABORT_OPCODE   2       /* abort on any opcode boundary */
+#define ABORT_MATH     3       /* abort on any math operation */
+#define ABORT_NOW      4       /* abort right away */
+
+#define CONFIG_MODE    1       /* types of configuration parameters */
+#define CONFIG_DISPLAY 2
+#define CONFIG_EPSILON 3
+#define CONFIG_TRACE   4
+#define CONFIG_MAXPRINT        5
+#define        CONFIG_MUL2     6
+#define        CONFIG_SQ2      7
+#define        CONFIG_POW2     8
+#define        CONFIG_REDC2    9
+#define CONFIG_TILDE   10
+#define CONFIG_TAB     11
+
+
+/*
+ * File ids corresponding to standard in, out, error, and when not in use.
+ */
+#define        FILEID_STDIN    ((FILEID) 0)
+#define        FILEID_STDOUT   ((FILEID) 1)
+#define        FILEID_STDERR   ((FILEID) 2)
+#define        FILEID_NONE     ((FILEID) -1)
+
+/*
+ * File I/O routines.
+ */
+extern FILEID openid MATH_PROTO((char *name, char *mode));
+extern FILEID indexid MATH_PROTO((long index));
+extern BOOL validid MATH_PROTO((FILEID id));
+extern BOOL errorid MATH_PROTO((FILEID id));
+extern BOOL eofid MATH_PROTO((FILEID id));
+extern BOOL closeid MATH_PROTO((FILEID id));
+extern int getcharid MATH_PROTO((FILEID id));
+extern void idprintf MATH_PROTO((FILEID id, char *fmt, int count, VALUE **vals));
+extern void printid MATH_PROTO((FILEID id, int flags));
+extern void flushid MATH_PROTO((FILEID id));
+extern void readid MATH_PROTO((FILEID id, char **retptr));
+
+
+/*
+ * Input routines.
+ */
+extern FILE *f_open MATH_PROTO((char *name, char *mode));
+extern int openstring MATH_PROTO((char *str));
+extern int openterminal MATH_PROTO((void));
+extern int opensearchfile MATH_PROTO((char *name, char *pathlist, char *exten, int reopen_ok));
+extern char *nextline MATH_PROTO((void));
+extern int nextchar MATH_PROTO((void));
+extern void reread MATH_PROTO((void));
+extern void resetinput MATH_PROTO((void));
+extern void setprompt MATH_PROTO((char *));
+extern BOOL inputisterminal MATH_PROTO((void));
+extern char *inputname MATH_PROTO((void));
+extern long linenumber MATH_PROTO((void));
+extern void runrcfiles MATH_PROTO((void));
+
+
+/*
+ * Other routines.
+ */
+extern NUMBER *constvalue MATH_PROTO((long index));
+extern long addnumber MATH_PROTO((char *str));
+extern long addqconstant MATH_PROTO((NUMBER *q));
+extern void initstack MATH_PROTO((void));
+extern void version MATH_PROTO((FILE *stream));
+extern void getcommands MATH_PROTO((BOOL toplevel));
+extern void givehelp MATH_PROTO((char *type));
+
+extern void getconfig MATH_PROTO((int type, VALUE *vp));
+extern void setconfig MATH_PROTO((int type, VALUE *vp));
+extern int configtype MATH_PROTO((char *name));
+
+
+/*
+ * Global data definitions.
+ */
+extern long maxprint;          /* number of elements to print */
+extern int abortlevel;         /* current level of aborts */
+extern BOOL inputwait;         /* TRUE if in a terminal input wait */
+extern FLAG traceflags;                /* tracing flags */
+extern VALUE *stack;           /* execution stack */
+extern jmp_buf jmpbuf;         /* for errors */
+
+extern char *calcpath;         /* $CALCPATH or default */
+extern char *calcrc;           /* $CALCRC or default */
+extern char *calcbindings;     /* $CALCBINDINGS or default */
+extern char *home;             /* $HOME or default */
+extern char *shell;            /* $SHELL or default */
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/calc.man b/usr/src/contrib/calc-2.9.3t6/calc.man
new file mode 100644 (file)
index 0000000..7e23695
--- /dev/null
@@ -0,0 +1,300 @@
+.\"
+.\" Copyright (c) 1994 David I. Bell and Landon Curt Noll
+.\" Permission is granted to use, distribute, or modify this source,
+.\" provided that this copyright notice remains intact.
+.\"
+.\" calculator by David I. Bell
+.\" man page by Landon Noll
+.TH calc 1 "^..^" "15nov93"
+.SH NAME
+\f4calc\f1 \- arbitrary precision calculator
+.SH SYNOPSIS
+\f4calc\fP
+[
+\f4\-h\fP
+] [
+\f4\-q\fP
+] [
+.I calc_cmd
+\&.\|.\|.
+]
+.SH DESCRIPTION
+\&
+.br
+CALC COMMAND LINE
+.PP
+.TP
+\f4 \-h\f1
+Print a help message.
+This option implies \f4 \-q\f1.
+This is equivalent to the calc command \f4help help\fP.
+.TP
+\f4 \-q\f1
+Disable the use of the \f4$CALCRC\f1 startup library scripts.
+.PP
+Without \f4calc_cmd\fPs, \f4calc\fP operates interactively.
+If one or more \f4calc_cmd\fPs are given on the command line,
+\f4calc\fP will execute them and exit.
+.PP
+Normally on startup, \f4calc\fP attempts to execute a collection 
+of library scripts.
+The environment variable \f4$CALCRC\f1 (if non-existent then
+a compiled in value) contains a \f4:\fP separated list of
+startup library scripts.
+No error conditions are produced if these startup library scripts
+are not found.
+.PP
+Filenames are subject to ``~'' expansion (see below).
+The environment variable \f4$CALCPATH\fP (if non-existent then
+a compiled in value) contains a \f4:\fP separated list of search
+directories.
+If a file does not begin with \f4/\fP, \f4~\fP or \f4./\fP,
+then it is searched for under each directory listed in the \f4$CALCPATH\fP.
+It is an error if no such readable file is found.
+.PP
+For more information use the following calc commands:
+.PP
+.in 1.0i
+help usage
+.br
+help help
+.br
+help environment
+.in -1.0i
+.PP
+OVERVIEW
+.PP
+\f4Calc\fP is arbitrary precision arithmetic system that uses 
+a C-like language.
+\f4Calc\fP is useful as a calculator, an algorithm prototyped
+and as a mathematical research tool.
+More importantly, \f4calc\fP provides one with a machine
+independent means of computation.
+.PP
+\f4Calc\fP comes with a rich set of builtin mathematical 
+and programmatic functions.
+.PP
+\f4Calc\fP is distributed with library of scripts.
+Written in the same C-like language, library scripts may be
+read in and executed during a \f4calc\fP session.
+These library scripts are also provided because they are
+useful and to serve as examples of the \f4calc\fP language.
+One may further extend \f4calc\fP thru the
+use of user defined scripts.
+.PP
+Internally calc represents numeric values as fractions reduced to their
+lowest terms.
+The numerators and denominators of these factions may grow to
+arbitrarily large values.
+Numeric values read in are automatically converted into rationals.
+The user need not be aware of this internal representation.
+.PP
+For more information use the following calc commands:
+.PP
+.in 1.0i
+help intro
+.br
+help builtin
+.br
+help stdlib
+.br
+help define
+.br
+show builtins
+.br
+show functions
+.in -1.0i
+.PP
+DATA TYPES
+.PP
+Fundamental builtin data types include integers, real numbers, 
+rational numbers, complex numbers and strings.
+.PP
+By use of an object, one may define an arbitrarily complex
+data types.
+One may define how such objects behave a wide range of
+operations such as addition, subtraction,
+multiplication, division, negation, squaring, modulus,
+rounding, exponentiation, equality, comparison, printing
+and so on.
+.PP
+For more information use the following calc commands:
+.PP
+.in 1.0i
+help types
+.br
+help obj
+.br
+show objfuncs
+.in -1.0i
+.PP
+VARIABLES
+.PP
+Variables in \f4calc\fP are typeless.
+In other words, the fundamental type of a variable is determined by its content.
+Before a variable is assigned a value it has the value of zero.
+.PP
+The scope of a variable may be global, local to a file, or local to a
+procedure.
+Values may be grouped together in a matrix, or into a
+a list that permits stack and queue style operations.
+.PP
+For more information use the following calc commands:
+.PP
+.in 1.0i
+help variable
+.br
+help mat
+.br
+help list
+.br
+show globals
+.in -1.0i
+.PP
+INPUT/OUTPUT
+.PP
+A leading ``0x'' implies a hexadecimal value,
+a leading ``0b'' implies a binary value,
+and a ``0'' followed by a digit implies an octal value.
+Complex numbers are indicated by a trailing ``i'' such as in ``3+4i''.
+Strings may be delimited by either a pair of single or double quotes.
+By default, \f4calc\fP prints values as if they were floating point numbers.
+One may change the default to print values in a number of modes
+including fractions, integers and exponentials.
+.PP
+A number of stdio-like file I/O operations are provided.
+One may open, read, write, seek and close files.
+Filenames are subject to ``\~'' expansion to home directories
+in a way similar to that of the Korn or C-Shell.
+.PP
+For example:
+.PP
+.in 1.0i
+~/.calcrc
+.br
+~chongo/lib/fft_multiply.cal
+.in -1.0i
+.PP
+For more information use the following calc command:
+.PP
+.in 1.0i
+help file
+.in -1.0i
+.PP
+CALC LANGUAGE
+.PP
+The \f4calc\fP language is a C-like language.
+The language includes commands such as variable declarations, 
+expressions, tests, labels, loops, file operations, function calls.
+These commands are very similar to their counterparts in C.
+.PP
+The language also include a number of commands particular
+to \f4calc\fP itself.
+These include commands such as function definition, help, 
+reading in library scripts, dump files to a file, error notification, 
+configuration control and status.
+.PP
+For more information use the following calc command:
+.PP
+.in 1.0i
+help command
+.br
+help statement
+.br
+help expression
+.br
+help operator
+.br
+help config
+.in -1.0i
+.PP
+.SH FILES
+\&
+.br
+.PD 0
+.TP 20
+${LIBDIR}/*.cal
+library scripts shipped with calc
+.br
+.sp
+.TP 20
+${LIBDIR}/help/*
+help files
+.br
+.sp
+.TP 20
+${LIBDIR}/bindings
+command line editor bindings
+.sp
+.SH ENVIRONMENT
+\&
+.br
+.PD 0
+.TP 5
+CALCPATH
+A :-separated list of directories used to search for
+scripts filenames that do not begin with /, ./ or ~.
+.br
+.sp
+Default value: .:./lib:~/lib:${LIBDIR}
+.br
+.sp
+.TP 5
+CALCRC
+On startup (unless \-h or \-q was given on the command
+line), calc searches for files along this :-separated
+environment variable.
+.br
+.sp
+Default value: ${LIBDIR}/startup:~/.calcrc
+.br
+.sp
+.TP 5
+CALCBINDINGS
+On startup (unless \-h or \-q was given on the command
+line), calc reads key bindings from the filename specified
+by this environment variable.
+.br
+.sp
+Default value: ${LIBDIR}/bindings
+.sp
+.SH CREDIT
+\&
+.br
+Written by David I. Bell.
+.sp
+Thanks for suggestions and encouragement from Peter Miller,
+Neil Justusson, and Landon Noll.
+.sp
+Portions of this program are derived from an earlier set of
+public domain arbitrarily precision routines which was posted
+to the net around 1984.  By now, there is almost no recognizable 
+code left from that original source.
+.sp
+Most of this source and binary is:
+.sp
+.PP
+.in 1.0i
+Copyright (c) 1994 David I. Bell
+.sp
+.in -1.0i
+.PP
+Some files are a copyrighted David I. Bell and Landon Noll.
+.sp
+Permission is granted to use, distribute, or modify this source,
+provided that this copyright notice remains intact.
+.sp
+Send calc comments, suggestions, bug fixes, enhancements
+and interesting calc scripts that you would like you see included 
+in future distributions to:
+.sp
+.PP
+.in 1.0i
+dbell@canb.auug.org.au
+.br
+chongo@toad.com
+.sp
+.in -1.0i
+.PP
+.sp
+Enjoy!
diff --git a/usr/src/contrib/calc-2.9.3t6/cmath.h b/usr/src/contrib/calc-2.9.3t6/cmath.h
new file mode 100644 (file)
index 0000000..a2ab6ff
--- /dev/null
@@ -0,0 +1,109 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Data structure declarations for extended precision complex arithmetic.
+ */
+
+#ifndef        CMATH_H
+#define        CMATH_H
+
+#include "qmath.h"
+
+
+/*
+ * Complex arithmetic definitions.
+ */
+typedef struct {
+       NUMBER *real;           /* real part of number */
+       NUMBER *imag;           /* imaginary part of number */
+       long links;             /* link count */
+} COMPLEX;
+
+
+/*
+ * Input, output, and conversion routines.
+ */
+extern COMPLEX *comalloc MATH_PROTO((void));
+extern COMPLEX *qqtoc MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern void comfree MATH_PROTO((COMPLEX *c));
+extern void comprint MATH_PROTO((COMPLEX *c));
+extern void cprintfr MATH_PROTO((COMPLEX *c));
+
+
+/*
+ * Basic numeric routines.
+ */
+extern COMPLEX *cadd MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
+extern COMPLEX *csub MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
+extern COMPLEX *cmul MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
+extern COMPLEX *cdiv MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
+extern COMPLEX *caddq MATH_PROTO((COMPLEX *c, NUMBER *q));
+extern COMPLEX *csubq MATH_PROTO((COMPLEX *c, NUMBER *q));
+extern COMPLEX *cmulq MATH_PROTO((COMPLEX *c, NUMBER *q));
+extern COMPLEX *cdivq MATH_PROTO((COMPLEX *c, NUMBER *q));
+extern COMPLEX *cmodq MATH_PROTO((COMPLEX *c, NUMBER *q));
+extern COMPLEX *cquoq MATH_PROTO((COMPLEX *c, NUMBER *q));
+extern COMPLEX *cscale MATH_PROTO((COMPLEX *c, long i));
+extern COMPLEX *cshift MATH_PROTO((COMPLEX *c, long i));
+extern COMPLEX *cround MATH_PROTO((COMPLEX *c, long i));
+extern COMPLEX *cbround MATH_PROTO((COMPLEX *c, long i));
+extern COMPLEX *csquare MATH_PROTO((COMPLEX *c));
+extern COMPLEX *cconj MATH_PROTO((COMPLEX *c));
+extern COMPLEX *creal MATH_PROTO((COMPLEX *c));
+extern COMPLEX *cimag MATH_PROTO((COMPLEX *c));
+extern COMPLEX *cneg MATH_PROTO((COMPLEX *c));
+extern COMPLEX *cinv MATH_PROTO((COMPLEX *c));
+extern COMPLEX *cint MATH_PROTO((COMPLEX *c));
+extern COMPLEX *cfrac MATH_PROTO((COMPLEX *c));
+extern BOOL ccmp MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
+
+
+/*
+ * More complicated functions.
+ */
+extern COMPLEX *cpowi MATH_PROTO((COMPLEX *c, NUMBER *q));
+extern HASH chash MATH_PROTO((COMPLEX *c));
+
+
+/*
+ * Transcendental routines.  These all take an epsilon argument to
+ * specify how accurately these are to be calculated.
+ */
+extern COMPLEX *cpower MATH_PROTO((COMPLEX *c1, COMPLEX *c2, NUMBER *epsilon));
+extern COMPLEX *csqrt MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
+extern COMPLEX *croot MATH_PROTO((COMPLEX *c, NUMBER *q, NUMBER *epsilon));
+extern COMPLEX *cexp MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
+extern COMPLEX *cln MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
+extern COMPLEX *ccos MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
+extern COMPLEX *csin MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
+extern COMPLEX *cpolar MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *epsilon));
+
+
+/*
+ * macro expansions to speed this thing up
+ */
+#define cisreal(c)     (qiszero((c)->imag))
+#define cisimag(c)     (qiszero((c)->real) && !cisreal(c))
+#define ciszero(c)     (cisreal(c) && qiszero((c)->real))
+#define cisone(c)      (cisreal(c) && qisone((c)->real))
+#define cisnegone(c)   (cisreal(c) && qisnegone((c)->real))
+#define cisrunit(c)    (cisreal(c) && qisunit((c)->real))
+#define cisiunit(c)    (qiszero((c)->real) && qisunit((c)->imag))
+#define        cisunit(c)      (cisrunit(c) || cisiunit(c))
+#define cistwo(c)      (cisreal(c) && qistwo((c)->real))
+#define cisint(c)      (qisint((c)->real) && qisint((c)->imag))
+#define ciseven(c)     (qiseven((c)->real) && qiseven((c)->imag))
+#define cisodd(c)      (qisodd((c)->real) || qisodd((c)->imag))
+#define clink(c)       ((c)->links++, (c))
+
+
+/*
+ * Pre-defined values.
+ */
+extern COMPLEX _czero_, _cone_, _conei_;
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/codegen.c b/usr/src/contrib/calc-2.9.3t6/codegen.c
new file mode 100644 (file)
index 0000000..8d10195
--- /dev/null
@@ -0,0 +1,1937 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Module to generate opcodes from the input tokens.
+ */
+
+#include "calc.h"
+#include "token.h"
+#include "symbol.h"
+#include "label.h"
+#include "opcodes.h"
+#include "string.h"
+#include "func.h"
+#include "config.h"
+
+static BOOL rdonce;    /* TRUE => do not reread this file */
+
+FUNC *curfunc;
+
+static BOOL getfilename(), getid();
+static void getshowcommand(), getfunction(), getbody(), getdeclarations();
+static void getstatement(), getobjdeclaration(), getobjvars();
+static void getmatdeclaration(), getsimplebody(), getonedeclaration();
+static void getcondition(), getmatargs(), getelement(), usesymbol();
+static void definesymbol(), getcallargs();
+static int getexprlist(), getassignment(), getaltcond(), getorcond();
+static int getandcond(), getrelation(), getsum(), getproduct();
+static int getorexpr(), getandexpr(), getshiftexpr(), getterm();
+static int getidexpr();
+static long getinitlist();
+
+
+/*
+ * Read all the commands from an input file.
+ * These are either declarations, or else are commands to execute now.
+ * In general, commands are terminated by newlines or semicolons.
+ * Exceptions are function definitions and escaped newlines.
+ * Commands are read and executed until the end of file.
+ * The toplevel flag indicates whether we are at the top interactive level.
+ */
+void
+getcommands(toplevel)
+       BOOL toplevel;
+{
+       char name[PATHSIZE+1];  /* program name */
+
+       if (!toplevel)
+               enterfilescope();
+       for (;;) {
+               (void) tokenmode(TM_NEWLINES);
+               switch (gettoken()) {
+
+               case T_DEFINE:
+                       getfunction();
+                       break;
+
+               case T_EOF:
+                       if (!toplevel)
+                               exitfilescope();
+                       return;
+
+               case T_HELP:
+                       if (!getfilename(name, FALSE, NULL)) {
+                               strcpy(name, DEFAULTCALCHELP);
+                       }
+                       givehelp(name);
+                       break;
+
+               case T_READ:
+                       if (!getfilename(name, TRUE, &rdonce))
+                               break;
+                       switch (opensearchfile(name,calcpath,CALCEXT,rdonce)) {
+                       case 0:
+                               getcommands(FALSE);
+                               break;
+                       case 1:
+                               /* previously read and -once was given */
+                               break;
+                       default:
+                               scanerror(T_NULL, "Cannot open \"%s\"\n", name);
+                               break;
+                       }
+                       break;
+
+               case T_WRITE:
+                       if (!getfilename(name, TRUE, NULL))
+                               break;
+                       if (writeglobals(name))
+                               scanerror(T_NULL, "Error writing \"%s\"\n", name);
+                       break;
+
+               case T_SHOW:
+                       rescantoken();
+                       getshowcommand();
+                       break;
+
+               case T_NEWLINE:
+               case T_SEMICOLON:
+                       break;
+
+               default:
+                       rescantoken();
+                       initstack();
+                       if (evaluate(FALSE))
+                               updateoldvalue(curfunc);
+               }
+       }
+}
+
+
+/*
+ * Evaluate a line of statements.
+ * This is done by treating the current line as a function body,
+ * compiling it, and then executing it.  Returns TRUE if the line
+ * successfully compiled and executed.  The last expression result
+ * is saved in the f_savedvalue element of the current function.
+ * The nestflag variable should be FALSE for the outermost evaluation
+ * level, and TRUE for all other calls (such as the 'eval' function).
+ * The function name begins with an asterisk to indicate specialness.
+ */
+BOOL
+evaluate(nestflag)
+       BOOL nestflag;          /* TRUE if this is a nested evaluation */
+{
+       char *funcname;
+       BOOL gotstatement;
+
+       funcname = (nestflag ? "**" : "*");
+       beginfunc(funcname, nestflag);
+       gotstatement = FALSE;
+       for (;;) {
+               switch (gettoken()) {
+                       case T_SEMICOLON:
+                               break;
+
+                       case T_NEWLINE:
+                       case T_EOF:
+                               goto done;
+
+                       case T_GLOBAL:
+                       case T_LOCAL:
+                       case T_STATIC:
+                               if (gotstatement) {
+                                       scanerror(T_SEMICOLON, "Declarations must be used before code");
+                                       return FALSE;
+                               }
+                               rescantoken();
+                               getdeclarations();
+                               break;
+
+                       default:
+                               rescantoken();
+                               getstatement(NULL_LABEL, NULL_LABEL,
+                                       NULL_LABEL, NULL_LABEL);
+                               gotstatement = TRUE;
+               }
+       }
+
+done:
+       addop(OP_UNDEF);
+       addop(OP_RETURN);
+       checklabels();
+       if (errorcount)
+               return FALSE;
+       calculate(curfunc, 0);
+       return TRUE;
+}
+
+
+/*
+ * Get a function declaration.
+ * func = name '(' '' | name [ ',' name] ... ')' simplebody
+ *     | name '(' '' | name [ ',' name] ... ')' body.
+ */
+static void
+getfunction()
+{
+       char *name;             /* parameter name */
+       int type;               /* type of token read */
+
+       (void) tokenmode(TM_DEFAULT);
+       if (gettoken() != T_SYMBOL) {
+               scanerror(T_NULL, "Function name expected");
+               return;
+       }
+       beginfunc(tokenstring(), FALSE);
+       enterfuncscope();
+       if (gettoken() != T_LEFTPAREN) {
+               scanerror(T_SEMICOLON, "Left parenthesis expected for function");
+               return;
+       }
+       for (;;) {
+               type = gettoken();
+               if (type == T_RIGHTPAREN)
+                       break;
+               if (type != T_SYMBOL) {
+                       scanerror(T_COMMA, "Bad function definition");
+                       return;
+               }
+               name = tokenstring();
+               switch (symboltype(name)) {
+                       case SYM_UNDEFINED:
+                       case SYM_GLOBAL:
+                       case SYM_STATIC:
+                               (void) addparam(name);
+                               break;
+                       default:
+                               scanerror(T_NULL, "Parameter \"%s\" is already defined", name);
+               }
+               type = gettoken();
+               if (type == T_RIGHTPAREN)
+                       break;
+               if (type != T_COMMA) {
+                       scanerror(T_COMMA, "Bad function definition");
+                       return;
+               }
+       }
+       switch (gettoken()) {
+               case T_ASSIGN:
+                       rescantoken();
+                       getsimplebody();
+                       break;
+               case T_LEFTBRACE:
+                       rescantoken();
+                       getbody(NULL_LABEL, NULL_LABEL, NULL_LABEL,
+                               NULL_LABEL, TRUE);
+                       break;
+               default:
+                       scanerror(T_NULL,
+                               "Left brace or equals sign expected for function");
+                       return;
+       }
+       addop(OP_UNDEF);
+       addop(OP_RETURN);
+       endfunc();
+       exitfuncscope();
+}
+
+
+/*
+ * Get a simple assignment style body for a function declaration.
+ * simplebody = '=' assignment '\n'.
+ */
+static void
+getsimplebody()
+{
+       if (gettoken() != T_ASSIGN) {
+               scanerror(T_SEMICOLON, "Missing equals for simple function body");
+               return;
+       }
+       (void) tokenmode(TM_NEWLINES);
+       (void) getexprlist();
+       addop(OP_RETURN);
+       if (gettoken() != T_SEMICOLON)
+               rescantoken();
+       if (gettoken() != T_NEWLINE)
+               scanerror(T_NULL, "Illegal function definition");
+}
+
+
+/*
+ * Get the body of a function, or a subbody of a function.
+ * body = '{' [ declarations ] ... [ statement ] ... '}'
+ *     | [ declarations ] ... [statement ] ... '\n'
+ */
+static void
+getbody(contlabel, breaklabel, nextcaselabel, defaultlabel, toplevel)
+       LABEL *contlabel, *breaklabel, *nextcaselabel, *defaultlabel;
+       BOOL toplevel;
+{
+       BOOL gotstatement;      /* TRUE if seen a real statement yet */
+       int oldmode;
+
+       if (gettoken() != T_LEFTBRACE) {
+               scanerror(T_SEMICOLON, "Missing left brace for function body");
+               return;
+       }
+       oldmode = tokenmode(TM_DEFAULT);
+       gotstatement = FALSE;
+       while (TRUE) {
+               switch (gettoken()) {
+               case T_RIGHTBRACE:
+                       (void) tokenmode(oldmode);
+                       return;
+
+               case T_GLOBAL:
+               case T_LOCAL:
+               case T_STATIC:
+                       if (!toplevel) {
+                               scanerror(T_SEMICOLON, "Declarations must be at the top of the function");
+                               return;
+                       }
+                       if (gotstatement) {
+                               scanerror(T_SEMICOLON, "Declarations must be used before code");
+                               return;
+                       }
+                       rescantoken();
+                       getdeclarations();
+                       break;
+
+               default:
+                       rescantoken();
+                       getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel);
+                       gotstatement = TRUE;
+               }
+       }
+}
+
+
+/*
+ * Get a line of possible local, global, or static variable declarations.
+ * declarations = { LOCAL | GLOBAL | STATIC } onedeclaration
+ *     [ ',' onedeclaration ] ... ';'.
+ */
+static void
+getdeclarations()
+{
+       int type;
+
+       type = gettoken();
+
+       if ((type != T_LOCAL) && (type != T_GLOBAL) && (type != T_STATIC)) {
+               rescantoken();
+               return;
+       }
+
+       while (TRUE) {
+               getonedeclaration(type);
+
+               switch (gettoken()) {
+                       case T_COMMA:
+                               continue;
+
+                       case T_NEWLINE:
+                       case T_SEMICOLON:
+                               return;
+
+                       default:
+                               scanerror(T_SEMICOLON, "Bad syntax in declaration statement");
+                               return;
+               }
+       }
+}
+
+
+/*
+ * Get a single declaration of a symbol of the specified type.
+ * onedeclaration = name [ '=' getassignment ]
+ *     | 'obj' type name [ '=' objvalues ]
+ *     | 'mat' name '[' matargs ']' [ '=' matvalues ].
+ */
+static void
+getonedeclaration(type)
+       int type;
+{
+       char *name;             /* name of symbol seen */
+       int symtype;            /* type of symbol */
+       int vartype;            /* type of variable being defined */
+       LABEL label;
+
+       switch (type) {
+               case T_LOCAL:
+                       symtype = SYM_LOCAL;
+                       break;
+               case T_GLOBAL:
+                       symtype = SYM_GLOBAL;
+                       break;
+               case T_STATIC:
+                       symtype = SYM_STATIC;
+                       clearlabel(&label);
+                       addoplabel(OP_INITSTATIC, &label);
+                       break;
+               default:
+                       symtype = SYM_UNDEFINED;
+                       break;
+       }
+
+       vartype = gettoken();
+       switch (vartype) {
+               case T_SYMBOL:
+                       name = tokenstring();
+                       definesymbol(name, symtype);
+                       break;
+
+               case T_MAT:
+                       addopone(OP_DEBUG, linenumber());
+                       getmatdeclaration(symtype);
+                       if (symtype == SYM_STATIC)
+                               setlabel(&label);
+                       return;
+
+               case T_OBJ:
+                       addopone(OP_DEBUG, linenumber());
+                       getobjdeclaration(symtype);
+                       if (symtype == SYM_STATIC)
+                               setlabel(&label);
+                       return;
+
+               default:
+                       scanerror(T_COMMA, "Bad syntax for declaration");
+                       return;
+       }
+
+       if (gettoken() != T_ASSIGN) {
+               rescantoken();
+               if (symtype == SYM_STATIC)
+                       setlabel(&label);
+               return;
+       }
+
+       /*
+        * Initialize the variable with the expression.  If the variable is
+        * static, arrange for the initialization to only be done once.
+        */
+       addopone(OP_DEBUG, linenumber());
+       usesymbol(name, FALSE);
+       getassignment();
+       addop(OP_ASSIGNPOP);
+       if (symtype == SYM_STATIC)
+               setlabel(&label);
+}
+
+
+/*
+ * Get a statement.
+ * statement = IF condition statement [ELSE statement]
+ *     | FOR '(' [assignment] ';' [assignment] ';' [assignment] ')' statement
+ *     | WHILE condition statement
+ *     | DO statement WHILE condition ';'
+ *     | SWITCH condition '{' [caseclause] ... '}'
+ *     | CONTINUE ';'
+ *     | BREAK ';'
+ *     | RETURN assignment ';'
+ *     | GOTO label ';'
+ *     | MAT name '[' value [ ':' value ] [',' value [ ':' value ] ] ']' ';'
+ *     | OBJ type '{' arg [ ',' arg ] ... '}' ] ';'
+ *     | OBJ type name [ ',' name ] ';'
+ *     | PRINT assignment [, assignment ] ... ';'
+ *     | QUIT [ string ] ';'
+ *     | SHOW item ';'
+ *     | body
+ *     | assignment ';'
+ *     | label ':' statement
+ *     | ';'.
+ */
+static void
+getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel)
+       LABEL *contlabel;       /* label for continue statement */
+       LABEL *breaklabel;      /* label for break statement */
+       LABEL *nextcaselabel;   /* label for next case statement */
+       LABEL *defaultlabel;    /* label for default case */
+{
+       LABEL label1, label2, label3, label4;   /* locations for jumps */
+       int type;
+       BOOL printeol;
+
+       addopone(OP_DEBUG, linenumber());
+       switch (gettoken()) {
+       case T_NEWLINE:
+       case T_SEMICOLON:
+               return;
+
+       case T_RIGHTBRACE:
+               scanerror(T_NULL, "Extraneous right brace");
+               return;
+
+       case T_CONTINUE:
+               if (contlabel == NULL_LABEL) {
+                       scanerror(T_SEMICOLON, "CONTINUE not within FOR, WHILE, or DO");
+                       return;
+               }
+               addoplabel(OP_JUMP, contlabel);
+               break;
+
+       case T_BREAK:
+               if (breaklabel == NULL_LABEL) {
+                       scanerror(T_SEMICOLON, "BREAK not within FOR, WHILE, or DO");
+                       return;
+               }
+               addoplabel(OP_JUMP, breaklabel);
+               break;
+
+       case T_GOTO:
+               if (gettoken() != T_SYMBOL) {
+                       scanerror(T_SEMICOLON, "Missing label in goto");
+                       return;
+               }
+               addop(OP_JUMP);
+               addlabel(tokenstring());
+               break;
+
+       case T_RETURN:
+               switch (gettoken()) {
+                       case T_NEWLINE:
+                       case T_SEMICOLON:
+                               addop(OP_UNDEF);
+                               addop(OP_RETURN);
+                               return;
+                       default:
+                               rescantoken();
+                               (void) getexprlist();
+                               if (curfunc->f_name[0] == '*')
+                                       addop(OP_SAVE);
+                               addop(OP_RETURN);
+               }
+               break;
+
+       case T_LEFTBRACE:
+               rescantoken();
+               getbody(contlabel, breaklabel, nextcaselabel, defaultlabel, FALSE);
+               return;
+
+       case T_IF:
+               clearlabel(&label1);
+               clearlabel(&label2);
+               getcondition();
+               addoplabel(OP_JUMPEQ, &label1);
+               getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
+               if (gettoken() != T_ELSE) {
+                       setlabel(&label1);
+                       rescantoken();
+                       return;
+               }
+               addoplabel(OP_JUMP, &label2);
+               setlabel(&label1);
+               getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
+               setlabel(&label2);
+               return;
+
+       case T_FOR:     /* for (a; b; c) x */
+               clearlabel(&label1);
+               clearlabel(&label2);
+               clearlabel(&label3);
+               clearlabel(&label4);
+               contlabel = NULL_LABEL;
+               breaklabel = &label4;
+               if (gettoken() != T_LEFTPAREN) {
+                       scanerror(T_SEMICOLON, "Left parenthesis expected");
+                       return;
+               }
+               if (gettoken() != T_SEMICOLON) {        /* have 'a' part */
+                       rescantoken();
+                       (void) getexprlist();
+                       addop(OP_POP);
+                       if (gettoken() != T_SEMICOLON) {
+                               scanerror(T_SEMICOLON, "Missing semicolon");
+                               return;
+                       }
+               }
+               if (gettoken() != T_SEMICOLON) {        /* have 'b' part */
+                       setlabel(&label1);
+                       contlabel = &label1;
+                       rescantoken();
+                       (void) getexprlist();
+                       addoplabel(OP_JUMPNE, &label3);
+                       addoplabel(OP_JUMP, breaklabel);
+                       if (gettoken() != T_SEMICOLON) {
+                               scanerror(T_SEMICOLON, "Missing semicolon");
+                               return;
+                       }
+               }
+               if (gettoken() != T_RIGHTPAREN) {       /* have 'c' part */
+                       if (label1.l_offset <= 0)
+                               addoplabel(OP_JUMP, &label3);
+                       setlabel(&label2);
+                       contlabel = &label2;
+                       rescantoken();
+                       (void) getexprlist();
+                       addop(OP_POP);
+                       if (label1.l_offset > 0)
+                               addoplabel(OP_JUMP, &label1);
+                       if (gettoken() != T_RIGHTPAREN) {
+                               scanerror(T_SEMICOLON, "Right parenthesis expected");
+                               return;
+                       }
+               }
+               setlabel(&label3);
+               if (contlabel == NULL_LABEL)
+                       contlabel = &label3;
+               getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
+               addoplabel(OP_JUMP, contlabel);
+               setlabel(breaklabel);
+               return;
+
+       case T_WHILE:
+               contlabel = &label1;
+               breaklabel = &label2;
+               clearlabel(contlabel);
+               clearlabel(breaklabel);
+               setlabel(contlabel);
+               getcondition();
+               addoplabel(OP_JUMPEQ, breaklabel);
+               getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
+               addoplabel(OP_JUMP, contlabel);
+               setlabel(breaklabel);
+               return;
+
+       case T_DO:
+               contlabel = &label1;
+               breaklabel = &label2;
+               clearlabel(contlabel);
+               clearlabel(breaklabel);
+               clearlabel(&label3);
+               setlabel(&label3);
+               getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
+               if (gettoken() != T_WHILE) {
+                       scanerror(T_SEMICOLON, "WHILE keyword expected for DO statement");
+                       return;
+               }
+               setlabel(contlabel);
+               getcondition();
+               addoplabel(OP_JUMPNE, &label3);
+               setlabel(breaklabel);
+               return;
+
+       case T_SWITCH:
+               breaklabel = &label1;
+               nextcaselabel = &label2;
+               defaultlabel = &label3;
+               clearlabel(breaklabel);
+               clearlabel(nextcaselabel);
+               clearlabel(defaultlabel);
+               getcondition();
+               if (gettoken() != T_LEFTBRACE) {
+                       scanerror(T_SEMICOLON, "Missing left brace for switch statement");
+                       return;
+               }
+               addoplabel(OP_JUMP, nextcaselabel);
+               rescantoken();
+               getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel);
+               addoplabel(OP_JUMP, breaklabel);
+               setlabel(nextcaselabel);
+               if (defaultlabel->l_offset > 0)
+                       addoplabel(OP_JUMP, defaultlabel);
+               else
+                       addop(OP_POP);
+               setlabel(breaklabel);
+               return;
+
+       case T_CASE:
+               if (nextcaselabel == NULL_LABEL) {
+                       scanerror(T_SEMICOLON, "CASE not within SWITCH statement");
+                       return;
+               }
+               clearlabel(&label1);
+               addoplabel(OP_JUMP, &label1);
+               setlabel(nextcaselabel);
+               clearlabel(nextcaselabel);
+               (void) getexprlist();
+               if (gettoken() != T_COLON) {
+                       scanerror(T_SEMICOLON, "Colon expected after CASE expression");
+                       return;
+               }
+               addoplabel(OP_CASEJUMP, nextcaselabel);
+               setlabel(&label1);
+               getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel);
+               return;
+
+       case T_DEFAULT:
+               if (gettoken() != T_COLON) {
+                       scanerror(T_SEMICOLON, "Colon expected after DEFAULT keyword");
+                       return;
+               }
+               if (defaultlabel == NULL_LABEL) {
+                       scanerror(T_SEMICOLON, "DEFAULT not within SWITCH statement");
+                       return;
+               }
+               if (defaultlabel->l_offset > 0) {
+                       scanerror(T_SEMICOLON, "Multiple DEFAULT clauses in SWITCH");
+                       return;
+               }
+               clearlabel(&label1);
+               addoplabel(OP_JUMP, &label1);
+               setlabel(defaultlabel);
+               addop(OP_POP);
+               setlabel(&label1);
+               getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel);
+               return;
+
+       case T_ELSE:
+               scanerror(T_SEMICOLON, "ELSE without preceeding IF");
+               return;
+
+       case T_MAT:
+               getmatdeclaration(SYM_UNDEFINED);
+               break;
+
+       case T_OBJ:
+               getobjdeclaration(SYM_UNDEFINED);
+               break;
+
+       case T_PRINT:
+               printeol = TRUE;
+               for (;;) {
+                       switch (gettoken()) {
+                               case T_RIGHTBRACE:
+                               case T_NEWLINE:
+                                       rescantoken();
+                                       /*FALLTHRU*/
+                               case T_SEMICOLON:
+                                       if (printeol)
+                                               addop(OP_PRINTEOL);
+                                       return;
+                               case T_COLON:
+                                       printeol = FALSE;
+                                       break;
+                               case T_COMMA:
+                                       printeol = TRUE;
+                                       addop(OP_PRINTSPACE);
+                                       break;
+                               case T_STRING:
+                                       printeol = TRUE;
+                                       addopptr(OP_PRINTSTRING, tokenstring());
+                                       break;
+                               default:
+                                       printeol = TRUE;
+                                       rescantoken();
+                                       (void) getassignment();
+                                       addopone(OP_PRINT, (long) PRINT_NORMAL);
+                       }
+               }
+
+       case T_QUIT:
+               switch (gettoken()) {
+                       case T_STRING:
+                               addopptr(OP_QUIT, tokenstring());
+                               break;
+                       default:
+                               addopptr(OP_QUIT, NULL);
+                               rescantoken();
+               }
+               break;
+
+       case T_SYMBOL:
+               if (nextchar() == ':') {        /****HACK HACK ****/
+                       definelabel(tokenstring());
+                       getstatement(contlabel, breaklabel, 
+                               NULL_LABEL, NULL_LABEL);
+                       return;
+               }
+               reread();
+               /* fall into default case */
+
+       default:
+               rescantoken();
+               type = getexprlist();
+               if (contlabel || breaklabel || (curfunc->f_name[0] != '*')) {
+                       addop(OP_POP);
+                       break;
+               }
+               addop(OP_SAVE);
+               if (isassign(type) || (curfunc->f_name[1] != '\0')) {
+                       addop(OP_POP);
+                       break;
+               }
+               addop(OP_PRINTRESULT);
+               break;
+       }
+       switch (gettoken()) {
+               case T_RIGHTBRACE:
+               case T_NEWLINE:
+               case T_EOF:
+                       rescantoken();
+                       break;
+               case T_SEMICOLON:
+                       break;
+               default:
+                       scanerror(T_SEMICOLON, "Semicolon expected");
+                       break;
+       }
+}
+
+
+/*
+ * Read in an object declaration.
+ * This is of the following form:
+ *     OBJ type [ '{' id [ ',' id ] ... '}' ]  [ objlist ].
+ * The OBJ keyword has already been read.  Symtype is SYM_UNDEFINED if this
+ * is an OBJ statement, otherwise this is part of a declaration which will
+ * define new symbols with the specified type.
+ */
+static void
+getobjdeclaration(symtype)
+       int symtype;
+{
+       char *name;                     /* name of object type */
+       int count;                      /* number of elements */
+       int index;                      /* current index */
+       int i;                          /* loop counter */
+       BOOL err;                       /* error flag */
+       int indices[MAXINDICES];        /* indices for elements */
+
+       err = FALSE;
+       if (gettoken() != T_SYMBOL) {
+               scanerror(T_SEMICOLON, "Object type name missing");
+               return;
+       }
+       name = addliteral(tokenstring());
+       if (gettoken() != T_LEFTBRACE) {
+               rescantoken();
+               getobjvars(name, symtype);
+               return;
+       }
+       /*
+        * Read in the definition of the elements of the object.
+        */
+       count = 0;
+       for (;;) {
+               if (gettoken() != T_SYMBOL) {
+                       scanerror(T_SEMICOLON, "Missing element name in OBJ statement");
+                       return;
+               }
+               index = addelement(tokenstring());
+               for (i = 0; i < count; i++) {
+                       if (indices[i] == index) {
+                               scanerror(T_NULL, "Duplicate element name \"%s\"", tokenstring());
+                               err = TRUE;
+                               break;
+                       }
+               }
+               indices[count++] = index;
+               switch (gettoken()) {
+                       case T_RIGHTBRACE:
+                               if (!err)
+                                       (void) defineobject(name, indices, count);
+                               switch (gettoken()) {
+                                       case T_SEMICOLON:
+                                       case T_NEWLINE:
+                                               rescantoken();
+                                               return;
+                               }
+                               rescantoken();
+                               getobjvars(name, symtype);
+                               return;
+                       case T_COMMA:
+                       case T_SEMICOLON:
+                       case T_NEWLINE:
+                               break;
+                       default:
+                               scanerror(T_SEMICOLON, "Bad object element definition");
+                               return;
+               }
+       }
+}
+
+
+/*
+ * Routine to collect a set of variables for the specified object type
+ * and initialize them as being that type of object.
+ * Here
+ *     objlist = name initlist [ ',' name initlist ] ... ';'.
+ * If symtype is SYM_UNDEFINED, then this is an OBJ statement where the
+ * values can be any variable expression, and no symbols are to be defined.
+ * Otherwise this is part of a declaration, and the variables must be raw
+ * symbol names which are defined with the specified symbol type.
+ */
+static void
+getobjvars(name, symtype)
+       int symtype;
+       char *name;             /* object name */
+{
+       long index;             /* index for object */
+       char *symname;
+
+       index = checkobject(name);
+       if (index < 0) {
+               scanerror(T_SEMICOLON, "Object %s has not been defined yet", name);
+               return;
+       }
+       for (;;) {
+               if (symtype == SYM_UNDEFINED)
+                       (void) getidexpr(TRUE, TRUE);
+               else {
+                       if (gettoken() != T_SYMBOL) {
+                               scanerror(T_SEMICOLON, "Missing object variable name");
+                               return;
+                       }
+                       symname = tokenstring();
+                       definesymbol(symname, symtype);
+                       usesymbol(symname, FALSE);
+               }
+               addopone(OP_OBJCREATE, index);
+               (void) getinitlist();
+               switch (gettoken()) {
+                       case T_COMMA:
+                               break;
+                       case T_SEMICOLON:
+                       case T_NEWLINE:
+                               rescantoken();
+                               return;
+                       default:
+                               scanerror(T_SEMICOLON, "Bad OBJ statement");
+                               return;
+               }
+       }
+}
+
+
+/*
+ * Read a matrix definition declaration for a one or more dimensional matrix.
+ * The MAT keyword has already been read.  This also handles an optional
+ * matrix initialization list enclosed in braces.  Symtype is SYM_UNDEFINED
+ * if this is part of a MAT statement which handles any variable expression.
+ * Otherwise this is part of a declaration and only a symbol name is allowed.
+ */
+static void
+getmatdeclaration(symtype)
+       int symtype;
+{
+       long dim;
+       long index;
+       long count;
+       long patchpc;
+       char *name;
+
+       if (symtype == SYM_UNDEFINED)
+               (void) getidexpr(FALSE, TRUE);
+       else {
+               if (gettoken() != T_SYMBOL) {
+                       scanerror(T_COMMA, "Missing matrix variable name");
+                       return;
+               }
+               name = tokenstring();
+               definesymbol(name, symtype);
+               usesymbol(name, FALSE);
+       }
+
+       if (gettoken() != T_LEFTBRACKET) {
+               scanerror(T_SEMICOLON, "Missing left bracket for MAT");
+               return;
+       }
+       dim = 1;
+
+       /*
+        * If there are no bounds given for the matrix, then they must be
+        * implicitly defined by a list of initialization values.  Put in
+        * a dummy number in the opcode stream for the bounds and remember
+        * its location.  After we know how many values are in the list, we
+        * will patch the correct value back into the opcode.
+        */
+       if (gettoken() == T_RIGHTBRACKET) {
+               clearopt();
+               patchpc = curfunc->f_opcodecount + 1;
+               addopone(OP_NUMBER, (long) -1);
+               clearopt();
+               addop(OP_ZERO);
+               addopone(OP_MATCREATE, dim);
+               count = getinitlist();
+               if (count == 0) {
+                       scanerror(T_NULL, "Initialization required for implicit matrix bounds");
+                       return;
+               }
+               index = addqconstant(itoq(count - 1));
+               if (index < 0)
+                       math_error("Cannot allocate constant");
+               curfunc->f_opcodes[patchpc] = index;
+               return;
+       }
+
+       /*
+        * This isn't implicit, so we expect expressions for the bounds.
+        */
+       rescantoken();
+       while (TRUE) {
+               (void) getassignment();
+               switch (gettoken()) {
+                       case T_RIGHTBRACKET:
+                       case T_COMMA:
+                               rescantoken();
+                               addop(OP_ONE);
+                               addop(OP_SUB);
+                               addop(OP_ZERO);
+                               break;
+                       case T_COLON:
+                               (void) getassignment();
+                               break;
+                       default:
+                               rescantoken();
+               }
+               switch (gettoken()) {
+                       case T_RIGHTBRACKET:
+                               if (gettoken() != T_LEFTBRACKET) {
+                                       rescantoken();
+                                       addopone(OP_MATCREATE, dim);
+                                       (void) getinitlist();
+                                       return;
+                               }
+                               /* proceed into comma case */
+                               /*FALLTHRU*/
+                       case T_COMMA:
+                               if (++dim <= MAXDIM)
+                                       break;
+                               scanerror(T_SEMICOLON, "Only %ld dimensions allowed", MAXDIM);
+                               return;
+                       default:
+                               scanerror(T_SEMICOLON, "Illegal matrix definition");
+                               return;
+               }
+       }
+}
+
+
+/*
+ * Get an optional initialization list for a matrix or object definition.
+ * Returns the number of elements that are in the list, or -1 on parse error.
+ * This assumes that the address of a matrix or object variable is on the
+ * stack, and so this routine will pop it off when complete.
+ *     initlist = [ '=' '{' assignment [ ',' assignment ] ... '}' ].
+ */
+static long
+getinitlist()
+{
+       long index;
+       int oldmode;
+
+       if (gettoken() != T_ASSIGN) {
+               rescantoken();
+               addop(OP_POP);
+               return 0;
+       }
+
+       oldmode = tokenmode(TM_DEFAULT);
+
+       if (gettoken() != T_LEFTBRACE) {
+               scanerror(T_SEMICOLON, "Missing brace for initialization list");
+               (void) tokenmode(oldmode);
+               return -1;
+       }
+
+       for (index = 0; ; index++) {
+               getassignment();
+               addopone(OP_ELEMINIT, index);
+               switch (gettoken()) {
+                       case T_COMMA:
+                               continue;
+
+                       case T_RIGHTBRACE:
+                               (void) tokenmode(oldmode);
+                               addop(OP_POP);
+                               return index + 1;
+
+                       default:
+                               scanerror(T_SEMICOLON, "Bad initialization list");
+                               (void) tokenmode(oldmode);
+                               return -1;
+               }
+       }
+}
+
+
+/*
+ * Get a condition.
+ * condition = '(' assignment ')'.
+ */
+static void
+getcondition()
+{
+       if (gettoken() != T_LEFTPAREN) {
+               scanerror(T_SEMICOLON, "Missing left parenthesis for condition");
+               return;
+       }
+       (void) getexprlist();
+       if (gettoken() != T_RIGHTPAREN) {
+               scanerror(T_SEMICOLON, "Missing right parenthesis for condition");
+               return;
+       }
+}
+
+
+/*
+ * Get an expression list consisting of one or more expressions,
+ * separated by commas.  The value of the list is that of the final expression.
+ * This is the top level routine for parsing expressions.
+ * Returns flags describing the type of assignment or expression found.
+ * exprlist = assignment [ ',' assignment ] ...
+ */
+static int
+getexprlist()
+{
+       int     type;
+
+       type = getassignment();
+       while (gettoken() == T_COMMA) {
+               addop(OP_POP);
+               (void) getassignment();
+               type = EXPR_RVALUE;
+       }
+       rescantoken();
+       return type;
+}
+
+
+/*
+ * Get an assignment (or possibly just an expression).
+ * Returns flags describing the type of assignment or expression found.
+ * assignment = lvalue '=' assignment
+ *     | lvalue '+=' assignment
+ *     | lvalue '-=' assignment
+ *     | lvalue '*=' assignment
+ *     | lvalue '/=' assignment
+ *     | lvalue '%=' assignment
+ *     | lvalue '//=' assignment
+ *     | lvalue '&=' assignment
+ *     | lvalue '|=' assignment
+ *     | lvalue '<<=' assignment
+ *     | lvalue '>>=' assignment
+ *     | lvalue '^=' assignment
+ *     | lvalue '**=' assignment
+ *     | orcond.
+ */
+static int
+getassignment()
+{
+       int type;               /* type of expression */
+       long op;                /* opcode to generate */
+
+       type = getaltcond();
+       switch (gettoken()) {
+               case T_ASSIGN:          op = 0; break;
+               case T_PLUSEQUALS:      op = OP_ADD; break;
+               case T_MINUSEQUALS:     op = OP_SUB; break;
+               case T_MULTEQUALS:      op = OP_MUL; break;
+               case T_DIVEQUALS:       op = OP_DIV; break;
+               case T_SLASHSLASHEQUALS: op = OP_QUO; break;
+               case T_MODEQUALS:       op = OP_MOD; break;
+               case T_ANDEQUALS:       op = OP_AND; break;
+               case T_OREQUALS:        op = OP_OR; break;
+               case T_LSHIFTEQUALS:    op = OP_LEFTSHIFT; break;
+               case T_RSHIFTEQUALS:    op = OP_RIGHTSHIFT; break;
+               case T_POWEREQUALS:     op = OP_POWER; break;
+
+               case T_NUMBER:
+               case T_IMAGINARY:
+               case T_STRING:
+               case T_SYMBOL:
+               case T_OLDVALUE:
+               case T_LEFTPAREN:
+               case T_PLUSPLUS:
+               case T_MINUSMINUS:
+               case T_NOT:
+                       scanerror(T_NULL, "Missing operator");
+                       return type;
+
+               default:
+                       rescantoken();
+                       return type;
+       }
+       if (isrvalue(type)) {
+               scanerror(T_NULL, "Illegal assignment");
+               (void) getassignment();
+               return (EXPR_RVALUE | EXPR_ASSIGN);
+       }
+       writeindexop();
+       if (op)
+               addop(OP_DUPLICATE);
+       (void) getassignment();
+       if (op) {
+               addop(op);
+       }
+       addop(OP_ASSIGN);
+       return (EXPR_RVALUE | EXPR_ASSIGN);
+}
+
+
+/*
+ * Get a possible conditional result expression (question mark).
+ * Flags are returned indicating the type of expression found.
+ * altcond = orcond [ '?' orcond ':' altcond ].
+ */
+static int
+getaltcond()
+{
+       int type;               /* type of expression */
+       LABEL donelab;          /* label for done */
+       LABEL altlab;           /* label for alternate expression */
+
+       type = getorcond();
+       if (gettoken() != T_QUESTIONMARK) {
+               rescantoken();
+               return type;
+       }
+       clearlabel(&donelab);
+       clearlabel(&altlab);
+       addoplabel(OP_JUMPEQ, &altlab);
+       (void) getorcond();
+       if (gettoken() != T_COLON) {
+               scanerror(T_SEMICOLON, "Missing colon for conditional expression");
+               return EXPR_RVALUE;
+       }
+       addoplabel(OP_JUMP, &donelab);
+       setlabel(&altlab);
+       (void) getaltcond();
+       setlabel(&donelab);
+       return EXPR_RVALUE;
+}
+
+
+/*
+ * Get a possible conditional or expression.
+ * Flags are returned indicating the type of expression found.
+ * orcond = andcond [ '||' andcond ] ...
+ */
+static int
+getorcond()
+{
+       int type;               /* type of expression */
+       LABEL donelab;          /* label for done */
+
+       clearlabel(&donelab);
+       type = getandcond();
+       while (gettoken() == T_OROR) {
+               addoplabel(OP_CONDORJUMP, &donelab);
+               (void) getandcond();
+               type = EXPR_RVALUE;
+       }
+       rescantoken();
+       if (donelab.l_chain > 0)
+               setlabel(&donelab);
+       return type;
+}
+
+
+/*
+ * Get a possible conditional and expression.
+ * Flags are returned indicating the type of expression found.
+ * andcond = relation [ '&&' relation ] ...
+ */
+static int
+getandcond()
+{
+       int type;               /* type of expression */
+       LABEL donelab;          /* label for done */
+
+       clearlabel(&donelab);
+       type = getrelation();
+       while (gettoken() == T_ANDAND) {
+               addoplabel(OP_CONDANDJUMP, &donelab);
+               (void) getrelation();
+               type = EXPR_RVALUE;
+       }
+       rescantoken();
+       if (donelab.l_chain > 0)
+               setlabel(&donelab);
+       return type;
+}
+
+
+/*
+ * Get a possible relation (equality or inequality), or just an expression.
+ * Flags are returned indicating the type of relation found.
+ * relation = sum '==' sum
+ *     | sum '!=' sum
+ *     | sum '<=' sum
+ *     | sum '>=' sum
+ *     | sum '<' sum
+ *     | sum '>' sum
+ *     | sum.
+ */
+static int
+getrelation()
+{
+       int type;               /* type of expression */
+       long op;                /* opcode to generate */
+
+       type = getsum();
+       switch (gettoken()) {
+               case T_EQ: op = OP_EQ; break;
+               case T_NE: op = OP_NE; break;
+               case T_LT: op = OP_LT; break;
+               case T_GT: op = OP_GT; break;
+               case T_LE: op = OP_LE; break;
+               case T_GE: op = OP_GE; break;
+               default:
+                       rescantoken();
+                       return type;
+       }
+       (void) getsum();
+       addop(op);
+       return EXPR_RVALUE;
+}
+
+
+/*
+ * Get an expression made up of sums of products.
+ * Flags indicating the type of expression found are returned.
+ * sum = product [ {'+' | '-'} product ] ...
+ */
+static int
+getsum()
+{
+       int type;               /* type of expression found */
+       long op;                /* opcode to generate */
+
+       type = getproduct();
+       for (;;) {
+               switch (gettoken()) {
+                       case T_PLUS:    op = OP_ADD; break;
+                       case T_MINUS:   op = OP_SUB; break;
+                       default:
+                               rescantoken();
+                               return type;
+               }
+               (void) getproduct();
+               addop(op);
+               type = EXPR_RVALUE;
+       }
+}
+
+
+/*
+ * Get the product of arithmetic or expressions.
+ * Flags indicating the type of expression found are returned.
+ * product = orexpr [ {'*' | '/' | '//' | '%'} orexpr ] ...
+ */
+static int
+getproduct()
+{
+       int type;               /* type of value found */
+       long op;                /* opcode to generate */
+
+       type = getorexpr();
+       for (;;) {
+               switch (gettoken()) {
+                       case T_MULT:    op = OP_MUL; break;
+                       case T_DIV:     op = OP_DIV; break;
+                       case T_MOD:     op = OP_MOD; break;
+                       case T_SLASHSLASH: op = OP_QUO; break;
+                       default:
+                               rescantoken();
+                               return type;
+               }
+               (void) getorexpr();
+               addop(op);
+               type = EXPR_RVALUE;
+       }
+}
+
+
+/*
+ * Get an expression made up of arithmetic or operators.
+ * Flags indicating the type of expression found are returned.
+ * orexpr = andexpr [ '|' andexpr ] ...
+ */
+static int
+getorexpr()
+{
+       int type;               /* type of value found */
+
+       type = getandexpr();
+       while (gettoken() == T_OR) {
+               (void) getandexpr();
+               addop(OP_OR);
+               type = EXPR_RVALUE;
+       }
+       rescantoken();
+       return type;
+}
+
+
+/*
+ * Get an expression made up of arithmetic and operators.
+ * Flags indicating the type of expression found are returned.
+ * andexpr = shiftexpr [ '&' shiftexpr ] ...
+ */
+static int
+getandexpr()
+{
+       int type;               /* type of value found */
+
+       type = getshiftexpr();
+       while (gettoken() == T_AND) {
+               (void) getshiftexpr();
+               addop(OP_AND);
+               type = EXPR_RVALUE;
+       }
+       rescantoken();
+       return type;
+}
+
+
+/*
+ * Get a shift or power expression.
+ * Flags indicating the type of expression found are returned.
+ * shift = term '^' shiftexpr
+ *      | term '<<' shiftexpr
+ *      | term '>>' shiftexpr
+ *      | term.
+ */
+static int
+getshiftexpr()
+{
+       int type;               /* type of value found */
+       long op;                /* opcode to generate */
+
+       type = getterm();
+       switch (gettoken()) {
+               case T_POWER:           op = OP_POWER; break;
+               case T_LEFTSHIFT:       op = OP_LEFTSHIFT; break;
+               case T_RIGHTSHIFT:      op = OP_RIGHTSHIFT; break;
+               default:
+                       rescantoken();
+                       return type;
+       }
+       (void) getshiftexpr();
+       addop(op);
+       return EXPR_RVALUE;
+}
+
+
+/*
+ * Get a single term.
+ * Flags indicating the type of value found are returned.
+ * term = lvalue
+ *     | lvalue '[' assignment ']'
+ *     | lvalue '++'
+ *     | lvalue '--'
+ *     | '++' lvalue
+ *     | '--' lvalue
+ *     | real_number
+ *     | imaginary_number
+ *     | '.'
+ *     | string
+ *     | '(' assignment ')'
+ *     | function [ '(' [assignment  [',' assignment] ] ')' ]
+ *     | '!' term
+ *     | '+' term
+ *     | '-' term.
+ */
+static int
+getterm()
+{
+       int type;               /* type of term found */
+
+       type = gettoken();
+       switch (type) {
+               case T_NUMBER:
+                       addopone(OP_NUMBER, tokennumber());
+                       type = (EXPR_RVALUE | EXPR_CONST);
+                       break;
+
+               case T_IMAGINARY:
+                       addopone(OP_IMAGINARY, tokennumber());
+                       type = (EXPR_RVALUE | EXPR_CONST);
+                       break;
+
+               case T_OLDVALUE:
+                       addop(OP_OLDVALUE);
+                       type = 0;
+                       break;
+
+               case T_STRING:
+                       addopptr(OP_STRING, tokenstring());
+                       type = (EXPR_RVALUE | EXPR_CONST);
+                       break;
+
+               case T_PLUSPLUS:
+                       if (isrvalue(getterm()))
+                               scanerror(T_NULL, "Bad ++ usage");
+                       writeindexop();
+                       addop(OP_PREINC);
+                       type = (EXPR_RVALUE | EXPR_ASSIGN);
+                       break;
+
+               case T_MINUSMINUS:
+                       if (isrvalue(getterm()))
+                               scanerror(T_NULL, "Bad -- usage");
+                       writeindexop();
+                       addop(OP_PREDEC);
+                       type = (EXPR_RVALUE | EXPR_ASSIGN);
+                       break;
+
+               case T_NOT:
+                       (void) getterm();
+                       addop(OP_NOT);
+                       type = EXPR_RVALUE;
+                       break;
+
+               case T_MINUS:
+                       (void) getterm();
+                       addop(OP_NEGATE);
+                       type = EXPR_RVALUE;
+                       break;
+
+               case T_PLUS:
+                       (void) getterm();
+                       type = EXPR_RVALUE;
+                       break;
+
+               case T_LEFTPAREN:
+                       type = getexprlist();
+                       if (gettoken() != T_RIGHTPAREN)
+                               scanerror(T_SEMICOLON, "Missing right parenthesis");
+                       break;
+
+               case T_SYMBOL:
+                       rescantoken();
+                       type = getidexpr(TRUE, FALSE);
+                       break;
+
+               case T_LEFTBRACKET:
+                       scanerror(T_NULL, "Bad index usage");
+                       type = 0;
+                       break;
+
+               case T_PERIOD:
+                       scanerror(T_NULL, "Bad element reference");
+                       type = 0;
+                       break;
+
+               default:
+                       if (iskeyword(type)) {
+                               scanerror(T_NULL, "Expression contains reserved keyword");
+                               type = 0;
+                               break;
+                       }
+                       rescantoken();
+                       scanerror(T_NULL, "Missing expression");
+                       type = 0;
+       }
+       switch (gettoken()) {
+               case T_PLUSPLUS:
+                       if (isrvalue(type))
+                               scanerror(T_NULL, "Bad ++ usage");
+                       writeindexop();
+                       addop(OP_POSTINC);
+                       return (EXPR_RVALUE | EXPR_ASSIGN);
+               case T_MINUSMINUS:
+                       if (isrvalue(type))
+                               scanerror(T_NULL, "Bad -- usage");
+                       writeindexop();
+                       addop(OP_POSTDEC);
+                       return (EXPR_RVALUE | EXPR_ASSIGN);
+               default:
+                       rescantoken();
+                       return type;
+       }
+}
+
+
+/*
+ * Read in an identifier expressions.
+ * This is a symbol name followed by parenthesis, or by square brackets or
+ * element refernces.  The symbol can be a global or a local variable name.
+ * Returns the type of expression found.
+ */
+static int
+getidexpr(okmat, autodef)
+       BOOL okmat, autodef;
+{
+       int type;
+       char name[SYMBOLSIZE+1];        /* symbol name */
+
+       type = 0;
+       if (!getid(name))
+               return type;
+       switch (gettoken()) {
+               case T_LEFTPAREN:
+                       getcallargs(name);
+                       type = EXPR_RVALUE;
+                       break;
+               case T_ASSIGN:
+                       autodef = TRUE;
+                       /* fall into default case */
+               default:
+                       rescantoken();
+                       usesymbol(name, autodef);
+       }
+       /*
+        * Now collect as many element references and matrix index operations
+        * as there are following the id.
+        */
+       for (;;) {
+               switch (gettoken()) {
+                       case T_LEFTBRACKET:
+                               rescantoken();
+                               if (!okmat)
+                                       return type;
+                               getmatargs();
+                               type = 0;
+                               break;
+                       case T_PERIOD:
+                               getelement();
+                               type = 0;
+                               break;
+                       case T_LEFTPAREN:
+                               scanerror(T_NULL, "Function calls not allowed as expressions");
+                       default:
+                               rescantoken();
+                               return type;
+               }
+       }
+}
+
+
+/*
+ * Read in a filename for a read or write command.
+ * Both quoted and unquoted filenames are handled here.
+ * The name must be terminated by an end of line or semicolon.
+ * Returns TRUE if the filename was successfully parsed.
+ */
+static BOOL
+getfilename(name, msg_ok, once)
+       char name[PATHSIZE+1];
+       BOOL msg_ok;            /* TRUE => ok to print error messages */
+       BOOL *once;             /* non-NULL => set to TRUE of -once read */
+{
+       /* look at the next token */
+       (void) tokenmode(TM_NEWLINES | TM_ALLSYMS);
+       switch (gettoken()) {
+               case T_STRING:
+               case T_SYMBOL:
+                       break;
+               default:
+                       if (msg_ok)
+                               scanerror(T_SEMICOLON, "Filename expected");
+                       return FALSE;
+       }
+       strcpy(name, tokenstring());
+
+       /* determine if we care about a possible -once option */
+       if (once != NULL) {
+               /* we care about a possible -once option */
+               if (strcmp(name, "-once") == 0) {
+                       /* -once option found */
+                       *once = TRUE;
+                       /* look for the filename */
+                       switch (gettoken()) {
+                               case T_STRING:
+                               case T_SYMBOL:
+                                       break;
+                               default:
+                                       if (msg_ok)
+                                               scanerror(T_SEMICOLON, 
+                                                   "Filename expected");
+                                       return FALSE;
+                       }
+                       strcpy(name, tokenstring());
+               } else {
+                       *once = FALSE;
+               }
+       }
+
+       /* look at the next token */
+       switch (gettoken()) {
+               case T_SEMICOLON:
+               case T_NEWLINE:
+               case T_EOF:
+                       break;
+               default:
+                       if (msg_ok)
+                               scanerror(T_SEMICOLON, 
+                                   "Missing semicolon after filename");
+                       return FALSE;
+       }
+       return TRUE;
+}
+
+
+/*
+ * Read the show command and display useful information.
+ */
+static void
+getshowcommand()
+{
+       char name[SYMBOLSIZE+1];
+
+       if ((gettoken() != T_SHOW) || (gettoken() != T_SYMBOL)) {
+               scanerror(T_SEMICOLON, "Bad syntax for SHOW command");
+               return;
+       }
+       strcpy(name, tokenstring());
+       switch (gettoken()) {
+               case T_NEWLINE:
+               case T_SEMICOLON:
+                       break;
+               default:
+                       scanerror(T_SEMICOLON, "Bad syntax for SHOW command");
+       }
+       switch ((int) stringindex("builtins\0builtin\0globals\0global\0functions\0function\0objfuncs\0objfunc\0memory\0", name)) {
+               case 1:
+               case 2:
+                       showbuiltins();
+                       break;
+               case 3:
+               case 4:
+                       showglobals();
+                       break;
+               case 5:
+               case 6:
+                       showfunctions();
+                       break;
+               case 7:
+               case 8:
+                       showobjfuncs();
+                       break;
+               case 9:
+                       mem_stats("");
+                       break;
+               default:
+                       scanerror(T_NULL, "Unknown SHOW parameter \"%s\"", name);
+       }
+}
+
+
+/*
+ * Read in a set of matrix index arguments, surrounded with square brackets.
+ * This also handles double square brackets for 'fast indexing'.
+ */
+static void
+getmatargs()
+{
+       int dim;
+
+       if (gettoken() != T_LEFTBRACKET) {
+               scanerror(T_NULL, "Matrix indexing expected");
+               return;
+       }
+       /*
+        * Parse all levels of the array reference
+        * Look for the 'fast index' first.
+        */
+       if (gettoken() == T_LEFTBRACKET) {
+               (void) getassignment();
+               if ((gettoken() != T_RIGHTBRACKET) ||
+                       (gettoken() != T_RIGHTBRACKET)) {
+                               scanerror(T_NULL, "Bad fast index usage");
+                               return;
+               }
+               addop(OP_FIADDR);
+               return;
+       }
+       rescantoken();
+       /*
+        * Normal indexing with the indexes separated by commas.
+        * Initialize the flag in the opcode to assume that the array
+        * element will only be referenced for reading.  If the parser
+        * finds that the element will be referenced for writing, then
+        * it will call writeindexop to change the flag in the opcode.
+        */
+       dim = 1;
+       for (;;) {
+               (void) getassignment();
+               switch (gettoken()) {
+                       case T_RIGHTBRACKET:
+                               if (gettoken() != T_LEFTBRACKET) {
+                                       rescantoken();
+                                       addoptwo(OP_INDEXADDR, (long) dim,
+                                               (long) FALSE);
+                                       return;
+                               }
+                               /* proceed into comma case */
+                               /*FALLTHRU*/
+                       case T_COMMA:
+                               if (++dim > MAXDIM)
+                                       scanerror(T_NULL, "Too many dimensions for array reference");
+                               break;
+                       default:
+                               rescantoken();
+                               scanerror(T_NULL, "Missing right bracket in array reference");
+                               return;
+               }
+       }
+}
+
+
+/*
+ * Get an element of an object reference.
+ * The leading period which introduces the element has already been read.
+ */
+static void
+getelement()
+{
+       long index;
+       char name[SYMBOLSIZE+1];
+
+       if (!getid(name))
+               return;
+       index = findelement(name);
+       if (index < 0) {
+               scanerror(T_NULL, "Element \"%s\" is undefined", name);
+               return;
+       }
+       addopone(OP_ELEMADDR, index);
+}
+
+
+/*
+ * Read in a single symbol name and copy its value into the given buffer.
+ * Returns TRUE if a valid symbol id was found.
+ */
+static BOOL
+getid(buf)
+       char buf[SYMBOLSIZE+1];
+{
+       int type;
+
+       type = gettoken();
+       if (iskeyword(type)) {
+               scanerror(T_NULL, "Reserved keyword used as symbol name");
+               type = T_SYMBOL;
+       }
+       if (type != T_SYMBOL) {
+               rescantoken();
+               scanerror(T_NULL, "Symbol name expected");
+               *buf = '\0';
+               return FALSE;
+       }
+       strncpy(buf, tokenstring(), SYMBOLSIZE);
+       buf[SYMBOLSIZE] = '\0';
+       return TRUE;
+}
+
+
+/*
+ * Define a symbol name to be of the specified symbol type.  This also checks
+ * to see if the symbol was already defined in an incompatible manner.
+ */
+static void
+definesymbol(name, symtype)
+       int symtype;
+       char *name;
+{
+       switch (symboltype(name)) {
+               case SYM_UNDEFINED:
+               case SYM_GLOBAL:
+               case SYM_STATIC:
+                       if (symtype == SYM_LOCAL)
+                               (void) addlocal(name);
+                       else
+                               (void) addglobal(name, (symtype == SYM_STATIC));
+                       break;
+
+               case SYM_PARAM:
+               case SYM_LOCAL:
+                       scanerror(T_COMMA, "Variable \"%s\" is already defined", name);
+                       return;
+       }
+
+}
+
+
+/*
+ * Check a symbol name to see if it is known and generate code to reference it.
+ * The symbol can be either a parameter name, a local name, or a global name.
+ * If autodef is true, we automatically define the name as a global symbol
+ * if it is not yet known.
+ */
+static void
+usesymbol(name, autodef)
+       char *name;             /* symbol name to be checked */
+       BOOL autodef;
+{
+       switch (symboltype(name)) {
+               case SYM_LOCAL:
+                       addopone(OP_LOCALADDR, (long) findlocal(name));
+                       return;
+               case SYM_PARAM:
+                       addopone(OP_PARAMADDR, (long) findparam(name));
+                       return;
+               case SYM_GLOBAL:
+               case SYM_STATIC:
+                       addopptr(OP_GLOBALADDR, (char *) findglobal(name));
+                       return;
+       }
+       /*
+        * The symbol is not yet defined.
+        * If we are at the top level and we are allowed to, then define it.
+        */
+       if ((curfunc->f_name[0] != '*') || !autodef) {
+               scanerror(T_NULL, "\"%s\" is undefined", name);
+               return;
+       }
+       (void) addglobal(name, FALSE);
+       addopptr(OP_GLOBALADDR, (char *) findglobal(name));
+}
+
+
+/*
+ * Get arguments for a function call.
+ * The name and beginning parenthesis has already been seen.
+ * callargs = [ [ '&' ] assignment  [',' [ '&' ] assignment] ] ')'.
+ */
+static void
+getcallargs(name)
+       char *name;             /* name of function */
+{
+       long index;             /* function index */
+       long op;                /* opcode to add */
+       int argcount;           /* number of arguments */
+       int type;
+       BOOL addrflag;
+
+       op = OP_CALL;
+       index = getbuiltinfunc(name);
+       if (index < 0) {
+               op = OP_USERCALL;
+               index = adduserfunc(name);
+       }
+       if (gettoken() == T_RIGHTPAREN) {
+               if (op == OP_CALL)
+                       builtincheck(index, 0);
+               addopfunction(op, index, 0);
+               return;
+       }
+       rescantoken();
+       argcount = 0;
+       for (;;) {
+               argcount++;
+               addrflag = (gettoken() == T_AND);
+               if (!addrflag)
+                       rescantoken();
+               type = getassignment();
+               if (addrflag) {
+                       if (isrvalue(type))
+                               scanerror(T_NULL, "Taking address of non-variable");
+                       writeindexop();
+               }
+               if (!addrflag && (op != OP_CALL))
+                       addop(OP_GETVALUE);
+               switch (gettoken()) {
+                       case T_RIGHTPAREN:
+                               if (op == OP_CALL)
+                                       builtincheck(index, argcount);
+                               addopfunction(op, index, argcount);
+                               return;
+                       case T_COMMA:
+                               break;
+                       default:
+                               scanerror(T_SEMICOLON, "Missing right parenthesis in function call");
+                               return;
+               }
+       }
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/comfunc.c b/usr/src/contrib/calc-2.9.3t6/comfunc.c
new file mode 100644 (file)
index 0000000..04bbda3
--- /dev/null
@@ -0,0 +1,595 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Extended precision complex arithmetic non-primitive routines
+ */
+
+#include "cmath.h"
+
+
+/*
+ * Round a complex number to the specified number of decimal places.
+ * This simply means to round each of the components of the number.
+ * Zero decimal places means round to the nearest complex integer.
+ */
+COMPLEX *
+cround(c, places)
+       COMPLEX *c;
+       long places;
+{
+       COMPLEX *res;           /* result */
+
+       res = comalloc();
+       res->real = qround(c->real, places);
+       res->imag = qround(c->imag, places);
+       return res;
+}
+
+
+/*
+ * Round a complex number to the specified number of binary decimal places.
+ * This simply means to round each of the components of the number.
+ * Zero binary places means round to the nearest complex integer.
+ */
+COMPLEX *
+cbround(c, places)
+       COMPLEX *c;
+       long places;
+{
+       COMPLEX *res;           /* result */
+
+       res = comalloc();
+       res->real = qbround(c->real, places);
+       res->imag = qbround(c->imag, places);
+       return res;
+}
+
+
+/*
+ * Compute the result of raising a complex number to an integer power.
+ */
+COMPLEX *
+cpowi(c, q)
+       COMPLEX *c;             /* complex number to be raised */
+       NUMBER *q;              /* power to raise it to */
+{
+       COMPLEX *tmp, *res;     /* temporary values */
+       long power;             /* power to raise to */
+       unsigned long bit;      /* current bit value */
+       int sign;
+
+       if (qisfrac(q))
+               math_error("Raising number to non-integral power");
+       if (zisbig(q->num))
+               math_error("Raising number to very large power");
+       power = (zistiny(q->num) ? z1tol(q->num) : z2tol(q->num));
+       if (ciszero(c) && (power == 0))
+               math_error("Raising zero to zeroth power");
+       sign = 1;
+       if (qisneg(q))
+               sign = -1;
+       /*
+        * Handle some low powers specially
+        */
+       if (power <= 4) {
+               switch ((int) (power * sign)) {
+                       case 0:
+                               return clink(&_cone_);
+                       case 1:
+                               return clink(c);
+                       case -1:
+                               return cinv(c);
+                       case 2:
+                               return csquare(c);
+                       case -2:
+                               tmp = csquare(c);
+                               res = cinv(tmp);
+                               comfree(tmp);
+                               return res;
+                       case 3:
+                               tmp = csquare(c);
+                               res = cmul(c, tmp);
+                               comfree(tmp);
+                               return res;
+                       case 4:
+                               tmp = csquare(c);
+                               res = csquare(tmp);
+                               comfree(tmp);
+                               return res;
+               }
+       }
+       /*
+        * Compute the power by squaring and multiplying.
+        * This uses the left to right method of power raising.
+        */
+       bit = TOPFULL;
+       while ((bit & power) == 0)
+               bit >>= 1L;
+       bit >>= 1L;
+       res = csquare(c);
+       if (bit & power) {
+               tmp = cmul(res, c);
+               comfree(res);
+               res = tmp;
+       }
+       bit >>= 1L;
+       while (bit) {
+               tmp = csquare(res);
+               comfree(res);
+               res = tmp;
+               if (bit & power) {
+                       tmp = cmul(res, c);
+                       comfree(res);
+                       res = tmp;
+               }
+               bit >>= 1L;
+       }
+       if (sign < 0) {
+               tmp = cinv(res);
+               comfree(res);
+               res = tmp;
+       }
+       return res;
+}
+
+
+/*
+ * Calculate the square root of a complex number, with each component
+ * within the specified error.  If the number is a square, then the error
+ * is zero.  For sqrt(a + bi), this calculates:
+ *     R = sqrt(a^2 + b^2)
+ *     U = sqrt((R + abs(a))/2)
+ *     V = b/(2 * U)
+ *     then sqrt(a + bi) = U + Vi if a >= 0,
+ *     or abs(V) + sgn(b) * U  if a < 0
+ */
+COMPLEX *
+csqrt(c, epsilon)
+       COMPLEX *c;
+       NUMBER *epsilon;
+{
+       COMPLEX *r;
+       NUMBER *A, *B, *R, *U, *V, *tmp1, *tmp2, *epsilon2;
+       long m, n;
+
+       if (ciszero(c) || cisone(c))
+               return clink(c);
+       if (cisreal(c)) {
+               r = comalloc();
+               if (!qisneg(c->real)) {
+                       r->real = qsqrt(c->real, epsilon);
+                       return r;
+               }
+               tmp1 = qneg(c->real);
+               r->imag = qsqrt(tmp1, epsilon);
+               qfree(tmp1);
+               return r;
+       }
+
+       A = qlink(c->real);
+       B = qlink(c->imag);
+       n = zhighbit(B->num) - zhighbit(B->den);
+       if (!qiszero(A)) {
+               m = zhighbit(A->num) - zhighbit(A->den);
+               if (m > n)
+                       n = m;
+       }
+       epsilon2 = qscale(epsilon, n/2);
+       R = qhypot(A, B, epsilon2);
+       qfree(epsilon2);
+       if (qisneg(A))
+               tmp1 = qsub(R, A);
+       else
+               tmp1 = qadd(R, A);
+       qfree(A);
+       tmp2 = qscale(tmp1, -1L);
+       qfree(tmp1);
+       U = qsqrt(tmp2, epsilon);
+       qfree(tmp2);
+       qfree(R);
+       if (qiszero(U)) {
+               qfree(B);
+               qfree(U);
+               return clink(&_czero_);
+       }
+       tmp1 = qdiv(B, U);
+       V = qscale(tmp1, -1L);
+       qfree(tmp1);
+       r = comalloc();
+       if (qisneg(c->real)) {
+               if (qisneg(B)) {        
+                       tmp1 = qneg(U);
+                       qfree(U);
+                       U = tmp1;
+                       tmp2 = qabs(V);
+                       qfree(V);
+                       V = tmp2;
+               }
+               r->real = V;
+               r->imag = U;
+       } else {
+               r->real = U;
+               r->imag = V;
+       }
+       qfree(B);
+       return r;
+}
+
+
+/*
+ * Take the Nth root of a complex number, where N is a positive integer.
+ * Each component of the result is within the specified error.
+ */
+COMPLEX *
+croot(c, q, epsilon)
+       COMPLEX *c;
+       NUMBER *q, *epsilon;
+{
+       COMPLEX *r;
+       NUMBER *a2pb2, *root, *tmp1, *tmp2, *epsilon2;
+
+       if (qisneg(q) || qiszero(q) || qisfrac(q))
+               math_error("Taking bad root of complex number");
+       if (cisone(c) || qisone(q))
+               return clink(c);
+       if (qistwo(q))
+               return csqrt(c, epsilon);
+       r = comalloc();
+       if (cisreal(c) && !qisneg(c->real)) {
+               r->real = qroot(c->real, q, epsilon);
+               return r;
+       }
+       /*
+        * Calculate the root using the formula:
+        *      croot(a + bi, n) =
+        *              cpolar(qroot(a^2 + b^2, 2 * n), qatan2(b, a) / n).
+        */
+       epsilon2 = qscale(epsilon, -8L);
+       tmp1 = qsquare(c->real);
+       tmp2 = qsquare(c->imag);
+       a2pb2 = qadd(tmp1, tmp2);
+       qfree(tmp1);
+       qfree(tmp2);
+       tmp1 = qscale(q, 1L);
+       root = qroot(a2pb2, tmp1, epsilon2);
+       qfree(a2pb2);
+       qfree(tmp1);
+       tmp1 = qatan2(c->imag, c->real, epsilon2);
+       qfree(epsilon2);
+       tmp2 = qdiv(tmp1, q);
+       qfree(tmp1);
+       r = cpolar(root, tmp2, epsilon);
+       qfree(root);
+       qfree(tmp2);
+       return r;
+}
+
+
+/*
+ * Calculate the complex exponential function to the desired accuracy.
+ * We use the formula:
+ *     exp(a + bi) = exp(a) * (cos(b) + i * sin(b)).
+ */
+COMPLEX *
+cexp(c, epsilon)
+       COMPLEX *c;
+       NUMBER *epsilon;
+{
+       COMPLEX *r;
+       NUMBER *tmp1, *tmp2, *epsilon2;
+
+       if (ciszero(c))
+               return clink(&_cone_);
+       r = comalloc();
+       if (cisreal(c)) {
+               r->real = qexp(c->real, epsilon);
+               return r;
+       }
+       epsilon2 = qscale(epsilon, -2L);
+       r->real = qcos(c->imag, epsilon2);
+       r->imag = qlegtoleg(r->real, epsilon2, _sinisneg_);
+       if (qiszero(c->real)) {
+               qfree(epsilon2);
+               return r;
+       }
+       tmp1 = qexp(c->real, epsilon2);
+       qfree(epsilon2);
+       tmp2 = qmul(r->real, tmp1);
+       qfree(r->real);
+       r->real = tmp2;
+       tmp2 = qmul(r->imag, tmp1);
+       qfree(r->imag);
+       qfree(tmp1);
+       r->imag = tmp2;
+       return r;
+}
+
+
+/*
+ * Calculate the natural logarithm of a complex number within the specified
+ * error.  We use the formula:
+ *     ln(a + bi) = ln(a^2 + b^2) / 2 + i * atan2(b, a).
+ */
+COMPLEX *
+cln(c, epsilon)
+       COMPLEX *c;
+       NUMBER *epsilon;
+{
+       COMPLEX *r;
+       NUMBER *a2b2, *tmp1, *tmp2;
+
+       if (ciszero(c))
+               math_error("Logarithm of zero");
+       if (cisone(c))
+               return clink(&_czero_);
+       r = comalloc();
+       if (cisreal(c) && !qisneg(c->real)) {
+               r->real = qln(c->real, epsilon);
+               return r;
+       }
+       tmp1 = qsquare(c->real);
+       tmp2 = qsquare(c->imag);
+       a2b2 = qadd(tmp1, tmp2);
+       qfree(tmp1);
+       qfree(tmp2);
+       tmp1 = qln(a2b2, epsilon);
+       qfree(a2b2);
+       r->real = qscale(tmp1, -1L);
+       qfree(tmp1);
+       r->imag = qatan2(c->imag, c->real, epsilon);
+       return r;
+}
+
+
+/*
+ * Calculate the complex cosine within the specified accuracy.
+ * This uses the formula:
+ *     cos(a + bi) = cos(a) * cosh(b) - sin(a) * sinh(b) * i.
+ */
+COMPLEX *
+ccos(c, epsilon)
+       COMPLEX *c;
+       NUMBER *epsilon;
+{
+       COMPLEX *r;
+       NUMBER *cosval, *coshval, *tmp1, *tmp2, *tmp3, *epsilon2;
+       int negimag;
+
+       if (ciszero(c))
+               return clink(&_cone_);
+       r = comalloc();
+       if (cisreal(c)) {
+               r->real = qcos(c->real, epsilon);
+               return r;
+       }
+       if (qiszero(c->real)) {
+               r->real = qcosh(c->imag, epsilon);
+               return r;
+       }
+       epsilon2 = qscale(epsilon, -2L);
+       coshval = qcosh(c->imag, epsilon2);
+       cosval = qcos(c->real, epsilon2);
+       negimag = !_sinisneg_;
+       if (qisneg(c->imag))
+               negimag = !negimag;
+       r->real = qmul(cosval, coshval);
+       /*
+        * Calculate the imaginary part using the formula:
+        *      sin(a) * sinh(b) = sqrt((1 - a^2) * (b^2 - 1)).
+        */
+       tmp1 = qsquare(cosval);
+       qfree(cosval);
+       tmp2 = qdec(tmp1);
+       qfree(tmp1);
+       tmp1 = qneg(tmp2);
+       qfree(tmp2);
+       tmp2 = qsquare(coshval);
+       qfree(coshval);
+       tmp3 = qdec(tmp2);
+       qfree(tmp2);
+       tmp2 = qmul(tmp1, tmp3);
+       qfree(tmp1);
+       qfree(tmp3);
+       r->imag = qsqrt(tmp2, epsilon2);
+       qfree(tmp2);
+       qfree(epsilon2);
+       if (negimag) {
+               tmp1 = qneg(r->imag);
+               qfree(r->imag);
+               r->imag = tmp1;
+       }
+       return r;
+}
+
+
+/*
+ * Calculate the complex sine within the specified accuracy.
+ * This uses the formula:
+ *     sin(a + bi) = sin(a) * cosh(b) + cos(a) * sinh(b) * i.
+ */
+COMPLEX *
+csin(c, epsilon)
+       COMPLEX *c;
+       NUMBER *epsilon;
+{
+       COMPLEX *r;
+
+       NUMBER *cosval, *coshval, *tmp1, *tmp2, *epsilon2;
+
+       if (ciszero(c))
+               return clink(&_czero_);
+       r = comalloc();
+       if (cisreal(c)) {
+               r->real = qsin(c->real, epsilon);
+               return r;
+       }
+       if (qiszero(c->real)) {
+               r->imag = qsinh(c->imag, epsilon);
+               return r;
+       }
+       epsilon2 = qscale(epsilon, -2L);
+       coshval = qcosh(c->imag, epsilon2);
+       cosval = qcos(c->real, epsilon2);
+       tmp1 = qlegtoleg(cosval, epsilon2, _sinisneg_);
+       r->real = qmul(tmp1, coshval);
+       qfree(tmp1);
+       tmp1 = qsquare(coshval);
+       qfree(coshval);
+       tmp2 = qdec(tmp1);
+       qfree(tmp1);
+       tmp1 = qsqrt(tmp2, epsilon2);
+       qfree(tmp2);
+       r->imag = qmul(tmp1, cosval);
+       qfree(tmp1);
+       qfree(cosval);
+       if (qisneg(c->imag)) {
+               tmp1 = qneg(r->imag);
+               qfree(r->imag);
+               r->imag = tmp1;
+       }
+       return r;
+}
+
+
+/*
+ * Convert a number from polar coordinates to normal complex number form
+ * within the specified accuracy.  This produces the value:
+ *     q1 * cos(q2) + q1 * sin(q2) * i.
+ */
+COMPLEX *
+cpolar(q1, q2, epsilon)
+       NUMBER *q1, *q2, *epsilon;
+{
+       COMPLEX *r;
+       NUMBER *tmp, *epsilon2;
+       long scale;
+
+       r = comalloc();
+       if (qiszero(q1) || qiszero(q2)) {
+               r->real = qlink(q1);
+               return r;
+       }
+       epsilon2 = epsilon;
+       if (!qisunit(q1)) {
+               scale = zhighbit(q1->num) - zhighbit(q1->den) + 1;
+               if (scale > 0)
+                       epsilon2 = qscale(epsilon, -scale);
+       }
+       r->real = qcos(q2, epsilon2);
+       r->imag = qlegtoleg(r->real, epsilon2, _sinisneg_);
+       if (epsilon2 != epsilon)
+               qfree(epsilon2);
+       if (qisone(q1))
+               return r;
+       tmp = qmul(r->real, q1);
+       qfree(r->real);
+       r->real = tmp;
+       tmp = qmul(r->imag, q1);
+       qfree(r->imag);
+       r->imag = tmp;
+       return r;
+}
+
+
+/*
+ * Raise one complex number to the power of another one to within the
+ * specified error.
+ */
+COMPLEX *
+cpower(c1, c2, epsilon)
+       COMPLEX *c1, *c2;
+       NUMBER *epsilon;
+{
+       COMPLEX *tmp1, *tmp2;
+       NUMBER *epsilon2;
+
+       if (cisreal(c2) && qisint(c2->real))
+               return cpowi(c1, c2->real);
+       if (cisone(c1) || ciszero(c1))
+               return clink(c1);
+       epsilon2 = qscale(epsilon, -4L);
+       tmp1 = cln(c1, epsilon2);
+       tmp2 = cmul(tmp1, c2);
+       comfree(tmp1);
+       tmp1 = cexp(tmp2, epsilon);
+       comfree(tmp2);
+       qfree(epsilon2);
+       return tmp1;
+}
+
+
+/*
+ * Return a trivial hash value for a complex number.
+ */
+HASH
+chash(c)
+       COMPLEX *c;
+{
+       HASH hash;
+
+       hash = qhash(c->real);
+       if (!cisreal(c))
+               hash += qhash(c->imag) * 2000029;
+       return hash;
+}
+
+
+/*
+ * Print a complex number in the current output mode.
+ */
+void
+comprint(c)
+       COMPLEX *c;
+{
+       NUMBER qtmp;
+
+       if (_outmode_ == MODE_FRAC) {
+               cprintfr(c);
+               return;
+       }
+       if (!qiszero(c->real) || qiszero(c->imag))
+               qprintnum(c->real, MODE_DEFAULT);
+       qtmp = c->imag[0];
+       if (qiszero(&qtmp))
+               return;
+       if (!qiszero(c->real) && !qisneg(&qtmp))
+               math_chr('+');
+       if (qisneg(&qtmp)) {
+               math_chr('-');
+               qtmp.num.sign = 0;
+       }
+       qprintnum(&qtmp, MODE_DEFAULT);
+       math_chr('i');
+}
+
+
+/*
+ * Print a complex number in rational representation.
+ * Example:  2/3-4i/5
+ */
+void
+cprintfr(c)
+       COMPLEX *c;
+{
+       NUMBER *r;
+       NUMBER *i;
+
+       r = c->real;
+       i = c->imag;
+       if (!qiszero(r) || qiszero(i))
+               qprintfr(r, 0L, FALSE);
+       if (qiszero(i))
+               return;
+       if (!qiszero(r) && !qisneg(i))
+               math_chr('+');
+       zprintval(i->num, 0L, 0L);
+       math_chr('i');
+       if (qisfrac(i)) {
+               math_chr('/');
+               zprintval(i->den, 0L, 0L);
+       }
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/commath.c b/usr/src/contrib/calc-2.9.3t6/commath.c
new file mode 100644 (file)
index 0000000..945ed78
--- /dev/null
@@ -0,0 +1,603 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Extended precision complex arithmetic primitive routines
+ */
+
+#include "cmath.h"
+
+
+COMPLEX _czero_ =              { &_qzero_, &_qzero_, 1 };
+COMPLEX _cone_ =               { &_qone_, &_qzero_, 1 };
+COMPLEX _conei_ =              { &_qzero_, &_qone_, 1 };
+
+static COMPLEX _cnegone_ =     { &_qnegone_, &_qzero_, 1 };
+
+
+/*
+ * Free list for complex numbers.
+ */
+static FREELIST freelist = {
+       sizeof(COMPLEX),        /* size of an item */
+       100                     /* number of free items to keep */
+};
+
+
+/*
+ * Add two complex numbers.
+ */
+COMPLEX *
+cadd(c1, c2)
+       COMPLEX *c1, *c2;
+{
+       COMPLEX *r;
+
+       if (ciszero(c1))
+               return clink(c2);
+       if (ciszero(c2))
+               return clink(c1);
+       r = comalloc();
+       if (!qiszero(c1->real) || !qiszero(c2->real))
+               r->real = qadd(c1->real, c2->real);
+       if (!qiszero(c1->imag) || !qiszero(c2->imag))
+               r->imag = qadd(c1->imag, c2->imag);
+       return r;
+}
+
+
+/*
+ * Subtract two complex numbers.
+ */
+COMPLEX *
+csub(c1, c2)
+       COMPLEX *c1, *c2;
+{
+       COMPLEX *r;
+
+       if ((c1->real == c2->real) && (c1->imag == c2->imag))
+               return clink(&_czero_);
+       if (ciszero(c2))
+               return clink(c1);
+       r = comalloc();
+       if (!qiszero(c1->real) || !qiszero(c2->real))
+               r->real = qsub(c1->real, c2->real);
+       if (!qiszero(c1->imag) || !qiszero(c2->imag))
+               r->imag = qsub(c1->imag, c2->imag);
+       return r;
+}
+
+
+/*
+ * Multiply two complex numbers.
+ * This saves one multiplication over the obvious algorithm by
+ * trading it for several extra additions, as follows.  Let
+ *     q1 = (a + b) * (c + d)
+ *     q2 = a * c
+ *     q3 = b * d
+ * Then (a+bi) * (c+di) = (q2 - q3) + (q1 - q2 - q3)i.
+ */
+COMPLEX *
+cmul(c1, c2)
+       COMPLEX *c1, *c2;
+{
+       COMPLEX *r;
+       NUMBER *q1, *q2, *q3, *q4;
+
+       if (ciszero(c1) || ciszero(c2))
+               return clink(&_czero_);
+       if (cisone(c1))
+               return clink(c2);
+       if (cisone(c2))
+               return clink(c1);
+       if (cisreal(c2))
+               return cmulq(c1, c2->real);
+       if (cisreal(c1))
+               return cmulq(c2, c1->real);
+       /*
+        * Need to do the full calculation.
+        */
+       r = comalloc();
+       q2 = qadd(c1->real, c1->imag);
+       q3 = qadd(c2->real, c2->imag);
+       q1 = qmul(q2, q3);
+       qfree(q2);
+       qfree(q3);
+       q2 = qmul(c1->real, c2->real);
+       q3 = qmul(c1->imag, c2->imag);
+       q4 = qadd(q2, q3);
+       r->real = qsub(q2, q3);
+       r->imag = qsub(q1, q4);
+       qfree(q1);
+       qfree(q2);
+       qfree(q3);
+       qfree(q4);
+       return r;
+}
+
+
+/*
+ * Square a complex number.
+ */
+COMPLEX *
+csquare(c)
+       COMPLEX *c;
+{
+       COMPLEX *r;
+       NUMBER *q1, *q2;
+
+       if (ciszero(c))
+               return clink(&_czero_);
+       if (cisrunit(c))
+               return clink(&_cone_);
+       if (cisiunit(c))
+               return clink(&_cnegone_);
+       r = comalloc();
+       if (cisreal(c)) {
+               r->real = qsquare(c->real);
+               return r;
+       }
+       if (cisimag(c)) {
+               q1 = qsquare(c->imag);
+               r->real = qneg(q1);
+               qfree(q1);
+               return r;
+       }
+       q1 = qsquare(c->real);
+       q2 = qsquare(c->imag);
+       r->real = qsub(q1, q2);
+       qfree(q1);
+       qfree(q2);
+       q1 = qmul(c->real, c->imag);
+       r->imag = qscale(q1, 1L);
+       qfree(q1);
+       return r;
+}
+
+
+/*
+ * Divide two complex numbers.
+ */
+COMPLEX *
+cdiv(c1, c2)
+       COMPLEX *c1, *c2;
+{
+       COMPLEX *r;
+       NUMBER *q1, *q2, *q3, *den;
+
+       if (ciszero(c2))
+               math_error("Division by zero");
+       if ((c1->real == c2->real) && (c1->imag == c2->imag))
+               return clink(&_cone_);
+       r = comalloc();
+       if (cisreal(c1) && cisreal(c2)) {
+               r->real = qdiv(c1->real, c2->real);
+               return r;
+       }
+       if (cisimag(c1) && cisimag(c2)) {
+               r->real = qdiv(c1->imag, c2->imag);
+               return r;
+       }
+       if (cisimag(c1) && cisreal(c2)) {
+               r->imag = qdiv(c1->imag, c2->real);
+               return r;
+       }
+       if (cisreal(c1) && cisimag(c2)) {
+               q1 = qdiv(c1->real, c2->imag);
+               r->imag = qneg(q1);
+               qfree(q1);
+               return r;
+       }
+       if (cisreal(c2)) {
+               r->real = qdiv(c1->real, c2->real);
+               r->imag = qdiv(c1->imag, c2->real);
+               return r;
+       }
+       q1 = qsquare(c2->real);
+       q2 = qsquare(c2->imag);
+       den = qadd(q1, q2);
+       qfree(q1);
+       qfree(q2);
+       q1 = qmul(c1->real, c2->real);
+       q2 = qmul(c1->imag, c2->imag);
+       q3 = qadd(q1, q2);
+       qfree(q1);
+       qfree(q2);
+       r->real = qdiv(q3, den);
+       qfree(q3);
+       q1 = qmul(c1->real, c2->imag);
+       q2 = qmul(c1->imag, c2->real);
+       q3 = qsub(q2, q1);
+       qfree(q1);
+       qfree(q2);
+       r->imag = qdiv(q3, den);
+       qfree(q3);
+       qfree(den);
+       return r;
+}
+
+
+/*
+ * Invert a complex number.
+ */
+COMPLEX *
+cinv(c)
+       COMPLEX *c;
+{
+       COMPLEX *r;
+       NUMBER *q1, *q2, *den;
+
+       if (ciszero(c))
+               math_error("Inverting zero");
+       r = comalloc();
+       if (cisreal(c)) {
+               r->real = qinv(c->real);
+               return r;
+       }
+       if (cisimag(c)) {
+               q1 = qinv(c->imag);
+               r->imag = qneg(q1);
+               qfree(q1);
+               return r;
+       }
+       q1 = qsquare(c->real);
+       q2 = qsquare(c->imag);
+       den = qadd(q1, q2);
+       qfree(q1);
+       qfree(q2);
+       r->real = qdiv(c->real, den);
+       q1 = qdiv(c->imag, den);
+       r->imag = qneg(q1);
+       qfree(q1);
+       qfree(den);
+       return r;
+}
+
+
+/*
+ * Negate a complex number.
+ */
+COMPLEX *
+cneg(c)
+       COMPLEX *c;
+{
+       COMPLEX *r;
+
+       if (ciszero(c))
+               return clink(&_czero_);
+       r = comalloc();
+       if (!qiszero(c->real))
+               r->real = qneg(c->real);
+       if (!qiszero(c->imag))
+               r->imag = qneg(c->imag);
+       return r;
+}
+
+
+/*
+ * Take the integer part of a complex number.
+ * This means take the integer part of both components.
+ */
+COMPLEX *
+cint(c)
+       COMPLEX *c;
+{
+       COMPLEX *r;
+
+       if (cisint(c))
+               return clink(c);
+       r = comalloc();
+       r->real = qint(c->real);
+       r->imag = qint(c->imag);
+       return r;
+}
+
+
+/*
+ * Take the fractional part of a complex number.
+ * This means take the fractional part of both components.
+ */
+COMPLEX *
+cfrac(c)
+       COMPLEX *c;
+{
+       COMPLEX *r;
+
+       if (cisint(c))
+               return clink(&_czero_);
+       r = comalloc();
+       r->real = qfrac(c->real);
+       r->imag = qfrac(c->imag);
+       return r;
+}
+
+
+/*
+ * Take the conjugate of a complex number.
+ * This negates the complex part.
+ */
+COMPLEX *
+cconj(c)
+       COMPLEX *c;
+{
+       COMPLEX *r;
+
+       if (cisreal(c))
+               return clink(c);
+       r = comalloc();
+       if (!qiszero(c->real))
+               r->real = qlink(c->real);
+       r->imag = qneg(c->imag);
+       return r;
+}
+
+
+/*
+ * Return the real part of a complex number.
+ */
+COMPLEX *
+creal(c)
+       COMPLEX *c;
+{
+       COMPLEX *r;
+
+       if (cisreal(c))
+               return clink(c);
+       r = comalloc();
+       if (!qiszero(c->real))
+               r->real = qlink(c->real);
+       return r;
+}
+
+
+/*
+ * Return the imaginary part of a complex number as a real.
+ */
+COMPLEX *
+cimag(c)
+       COMPLEX *c;
+{
+       COMPLEX *r;
+
+       if (cisreal(c))
+               return clink(&_czero_);
+       r = comalloc();
+       r->real = qlink(c->imag);
+       return r;
+}
+
+
+/*
+ * Add a real number to a complex number.
+ */
+COMPLEX *
+caddq(c, q)
+       COMPLEX *c;
+       NUMBER *q;
+{
+       COMPLEX *r;
+
+       if (qiszero(q))
+               return clink(c);
+       r = comalloc();
+       r->real = qadd(c->real, q);
+       r->imag = qlink(c->imag);
+       return r;
+}
+
+
+/*
+ * Subtract a real number from a complex number.
+ */
+COMPLEX *
+csubq(c, q)
+       COMPLEX *c;
+       NUMBER *q;
+{
+       COMPLEX *r;
+
+       if (qiszero(q))
+               return clink(c);
+       r = comalloc();
+       r->real = qsub(c->real, q);
+       r->imag = qlink(c->imag);
+       return r;
+}
+
+
+/*
+ * Shift the components of a complex number left by the specified
+ * number of bits.  Negative values shift to the right.
+ */
+COMPLEX *
+cshift(c, n)
+       COMPLEX *c;
+       long n;
+{
+       COMPLEX *r;
+
+       if (ciszero(c) || (n == 0))
+               return clink(c);
+       r = comalloc();
+       r->real = qshift(c->real, n);
+       r->imag = qshift(c->imag, n);
+       return r;
+}
+
+
+/*
+ * Scale a complex number by a power of two.
+ */
+COMPLEX *
+cscale(c, n)
+       COMPLEX *c;
+       long n;
+{
+       COMPLEX *r;
+
+       if (ciszero(c) || (n == 0))
+               return clink(c);
+       r = comalloc();
+       r->real = qscale(c->real, n);
+       r->imag = qscale(c->imag, n);
+       return r;
+}
+
+
+/*
+ * Multiply a complex number by a real number.
+ */
+COMPLEX *
+cmulq(c, q)
+       COMPLEX *c;
+       NUMBER *q;
+{
+       COMPLEX *r;
+
+       if (qiszero(q))
+               return clink(&_czero_);
+       if (qisone(q))
+               return clink(c);
+       if (qisnegone(q))
+               return cneg(c);
+       r = comalloc();
+       r->real = qmul(c->real, q);
+       r->imag = qmul(c->imag, q);
+       return r;
+}
+
+
+/*
+ * Divide a complex number by a real number.
+ */
+COMPLEX *
+cdivq(c, q)
+       COMPLEX *c;
+       NUMBER *q;
+{
+       COMPLEX *r;
+
+       if (qiszero(q))
+               math_error("Division by zero");
+       if (qisone(q))
+               return clink(c);
+       if (qisnegone(q))
+               return cneg(c);
+       r = comalloc();
+       r->real = qdiv(c->real, q);
+       r->imag = qdiv(c->imag, q);
+       return r;
+}
+
+
+/*
+ * Take the integer quotient of a complex number by a real number.
+ * This is defined to be the result of doing the quotient for each component.
+ */
+COMPLEX *
+cquoq(c, q)
+       COMPLEX *c;
+       NUMBER *q;
+{
+       COMPLEX *r;
+
+       if (qiszero(q))
+               math_error("Division by zero");
+       r = comalloc();
+       r->real = qquo(c->real, q);
+       r->imag = qquo(c->imag, q);
+       return r;
+}
+
+
+/*
+ * Take the modulus of a complex number by a real number.
+ * This is defined to be the result of doing the modulo for each component.
+ */
+COMPLEX *
+cmodq(c, q)
+       COMPLEX *c;
+       NUMBER *q;
+{
+       COMPLEX *r;
+
+       if (qiszero(q))
+               math_error("Division by zero");
+       r = comalloc();
+       r->real = qmod(c->real, q);
+       r->imag = qmod(c->imag, q);
+       return r;
+}
+
+
+/*
+ * Construct a complex number given the real and imaginary components.
+ */
+COMPLEX *
+qqtoc(q1, q2)
+       NUMBER *q1, *q2;
+{
+       COMPLEX *r;
+
+       if (qiszero(q1) && qiszero(q2))
+               return clink(&_czero_);
+       r = comalloc();
+       if (!qiszero(q1))
+               r->real = qlink(q1);
+       if (!qiszero(q2))
+               r->imag = qlink(q2);
+       return r;
+}
+
+
+/*
+ * Compare two complex numbers for equality, returning FALSE if they are equal,
+ * and TRUE if they differ.
+ */
+BOOL
+ccmp(c1, c2)
+       COMPLEX *c1, *c2;
+{
+       BOOL i;
+
+       i = qcmp(c1->real, c2->real);
+       if (!i)
+               i = qcmp(c1->imag, c2->imag);
+       return i;
+}
+
+
+/*
+ * Allocate a new complex number.
+ */
+COMPLEX *
+comalloc()
+{
+       COMPLEX *r;
+
+       r = (COMPLEX *) allocitem(&freelist);
+       if (r == NULL)
+               math_error("Cannot allocate complex number");
+       r->links = 1;
+       r->real = qlink(&_qzero_);
+       r->imag = qlink(&_qzero_);
+       return r;
+}
+
+
+/*
+ * Free a complex number.
+ */
+void
+comfree(c)
+       COMPLEX *c;
+{
+       if (--(c->links) > 0)
+               return;
+       qfree(c->real);
+       qfree(c->imag);
+       freeitem(&freelist, (FREEITEM *) c);
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/config.c b/usr/src/contrib/calc-2.9.3t6/config.c
new file mode 100644 (file)
index 0000000..eba006a
--- /dev/null
@@ -0,0 +1,376 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Configuration routines.
+ */
+
+#include "calc.h"
+
+
+/*
+ * Configuration parameter name and type.
+ */
+typedef struct {
+       char *name;     /* name of configuration string */
+       int type;       /* type for configuration */
+} CONFIG;
+
+
+/*
+ * Table of configuration types that can be set or read.
+ */
+static CONFIG configs[] = {
+       "trace",        CONFIG_TRACE,
+       "display",      CONFIG_DISPLAY,
+       "epsilon",      CONFIG_EPSILON,
+       "mode",         CONFIG_MODE,
+       "maxprint",     CONFIG_MAXPRINT,
+       "mul2",         CONFIG_MUL2,
+       "sq2",          CONFIG_SQ2,
+       "pow2",         CONFIG_POW2,
+       "redc2",        CONFIG_REDC2,
+       "tilde",        CONFIG_TILDE,
+       "tab",          CONFIG_TAB,
+       NULL,           0
+};
+
+
+/*
+ * Possible output modes.
+ */
+static CONFIG modes[] = {
+       "frac",         MODE_FRAC,
+       "decimal",      MODE_FRAC,
+       "dec",          MODE_FRAC,
+       "int",          MODE_INT,
+       "real",         MODE_REAL,
+       "exp",          MODE_EXP,
+       "hexadecimal",  MODE_HEX,
+       "hex",          MODE_HEX,
+       "octal",        MODE_OCTAL,
+       "oct",          MODE_OCTAL,
+       "binary",       MODE_BINARY,
+       "bin",          MODE_BINARY,
+       NULL,           0
+};
+
+
+/*
+ * Possible binary config state values
+ */
+static CONFIG truth[] = {
+       "y",            TRUE,
+       "n",            FALSE,
+       "yes",          TRUE,
+       "no",           FALSE,
+       "set",          TRUE,
+       "unset",        FALSE,
+       "on",           TRUE,
+       "off",          FALSE,
+       "true",         TRUE,
+       "false",        FALSE,
+       "t",            TRUE,
+       "f",            FALSE,
+       "1",            TRUE,
+       "0",            FALSE,
+       NULL,           0
+};
+
+
+/*
+ * Given a string value which represents a configuration name, return
+ * the configuration type for that string.  Returns negative type if
+ * the string is unknown.
+ */
+int
+configtype(name)
+       char *name;             /* configuration name */
+{
+       CONFIG *cp;             /* current config pointer */
+
+       for (cp = configs; cp->name; cp++) {
+               if (strcmp(cp->name, name) == 0)
+                       return cp->type;
+       }
+       return -1;
+}
+
+
+/*
+ * Given the name of a mode, convert it to the internal format.
+ * Returns -1 if the string is unknown.
+ */
+static int
+modetype(name)
+       char *name;             /* mode name */
+{
+       CONFIG *cp;             /* current config pointer */
+
+       for (cp = modes; cp->name; cp++) {
+               if (strcmp(cp->name, name) == 0)
+                       return cp->type;
+       }
+       return -1;
+}
+
+
+/*
+ * Given the name of a truth value, convert it to a BOOL or -1.
+ * Returns -1 if the string is unknown.
+ */
+static int
+truthtype(name)
+       char *name;             /* mode name */
+{
+       CONFIG *cp;             /* current config pointer */
+
+       for (cp = truth; cp->name; cp++) {
+               if (strcmp(cp->name, name) == 0)
+                       return cp->type;
+       }
+       return -1;
+}
+
+
+/*
+ * Given the mode type, convert it to a string representing that mode.
+ * Where there are multiple strings representing the same mode, the first
+ * one in the table is used.  Returns NULL if the node type is unknown.
+ * The returned string cannot be modified.
+ */
+static char *
+modename(type)
+       int type;
+{
+       CONFIG *cp;             /* current config pointer */
+
+       for (cp = modes; cp->name; cp++) {
+               if (type == cp->type)
+                       return cp->name;
+       }
+       return NULL;
+}
+
+
+/*
+ * Set the specified configuration type to the specified value.
+ * An error is generated if the type number or value is illegal.
+ */
+void
+setconfig(type, vp)
+       int type;
+       VALUE *vp;
+{
+       NUMBER *q;
+       long temp;
+
+       switch (type) {
+               case CONFIG_TRACE:
+                       if (vp->v_type != V_NUM)
+                               math_error("Non-numeric for trace");
+                       q = vp->v_num;
+                       temp = qtoi(q);
+                       if (qisfrac(q) || !zistiny(q->num) ||
+                               ((unsigned long) temp > TRACE_MAX))
+                                       math_error("Bad trace value");
+                       traceflags = (FLAG)temp;
+                       break;
+
+               case CONFIG_DISPLAY:
+                       if (vp->v_type != V_NUM)
+                               math_error("Non-numeric for display");
+                       q = vp->v_num;
+                       temp = qtoi(q);
+                       if (qisfrac(q) || qisneg(q) || !zistiny(q->num))
+                               temp = -1;
+                       math_setdigits(temp);
+                       break;
+
+               case CONFIG_MODE:
+                       if (vp->v_type != V_STR)
+                               math_error("Non-string for mode");
+                       temp = modetype(vp->v_str);
+                       if (temp < 0)
+                               math_error("Unknown mode \"%s\"", vp->v_str);
+                       math_setmode((int) temp);
+                       break;
+
+               case CONFIG_EPSILON:
+                       if (vp->v_type != V_NUM)
+                               math_error("Non-numeric for epsilon");
+                       setepsilon(vp->v_num);
+                       break;
+
+               case CONFIG_MAXPRINT:
+                       if (vp->v_type != V_NUM)
+                               math_error("Non-numeric for maxprint");
+                       q = vp->v_num;
+                       temp = qtoi(q);
+                       if (qisfrac(q) || qisneg(q) || !zistiny(q->num))
+                               temp = -1;
+                       if (temp < 0)
+                               math_error("Maxprint value is out of range");
+                       maxprint = temp;
+                       break;
+
+               case CONFIG_MUL2:
+                       if (vp->v_type != V_NUM)
+                               math_error("Non-numeric for mul2");
+                       q = vp->v_num;
+                       temp = qtoi(q);
+                       if (qisfrac(q) || qisneg(q))
+                               temp = -1;
+                       if (temp == 0)
+                               temp = MUL_ALG2;
+                       if (temp < 2)
+                               math_error("Illegal mul2 value");
+                       _mul2_ = temp;
+                       break;
+
+               case CONFIG_SQ2:
+                       if (vp->v_type != V_NUM)
+                               math_error("Non-numeric for sq2");
+                       q = vp->v_num;
+                       temp = qtoi(q);
+                       if (qisfrac(q) || qisneg(q))
+                               temp = -1;
+                       if (temp == 0)
+                               temp = SQ_ALG2;
+                       if (temp < 2)
+                               math_error("Illegal sq2 value");
+                       _sq2_ = temp;
+                       break;
+
+               case CONFIG_POW2:
+                       if (vp->v_type != V_NUM)
+                               math_error("Non-numeric for pow2");
+                       q = vp->v_num;
+                       temp = qtoi(q);
+                       if (qisfrac(q) || qisneg(q))
+                               temp = -1;
+                       if (temp == 0)
+                               temp = POW_ALG2;
+                       if (temp < 1)
+                               math_error("Illegal pow2 value");
+                       _pow2_ = temp;
+                       break;
+
+               case CONFIG_REDC2:
+                       if (vp->v_type != V_NUM)
+                               math_error("Non-numeric for redc2");
+                       q = vp->v_num;
+                       temp = qtoi(q);
+                       if (qisfrac(q) || qisneg(q))
+                               temp = -1;
+                       if (temp == 0)
+                               temp = REDC_ALG2;
+                       if (temp < 1)
+                               math_error("Illegal redc2 value");
+                       _redc2_ = temp;
+                       break;
+
+
+               case CONFIG_TILDE:
+                       if (vp->v_type == V_NUM) {
+                               q = vp->v_num;
+                               tilde_ok = !qiszero(q);
+                       } else if (vp->v_type == V_STR) {
+                               temp = truthtype(vp->v_str);
+                               if (temp < 0) {
+                                       math_error("Illegal truth value");
+                               }
+                               tilde_ok = temp;
+                       }
+                       break;
+               case CONFIG_TAB:
+                       if (vp->v_type == V_NUM) {
+                               q = vp->v_num;
+                               tab_ok = !qiszero(q);
+                       } else if (vp->v_type == V_STR) {
+                               temp = truthtype(vp->v_str);
+                               if (temp < 0) {
+                                       math_error("Illegal truth value");
+                               }
+                               tab_ok = temp;
+                       }
+                       break;
+
+               default:
+                       math_error("Setting illegal config parameter");
+       }
+}
+
+
+/*
+ * Get the current value of the specified configuration type.
+ * An error is generated if the type number is illegal.
+ */
+void
+getconfig(type, vp)
+       int type;
+       VALUE *vp;
+{
+       switch (type) {
+               case CONFIG_TRACE:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq((long) traceflags);
+                       break;
+
+               case CONFIG_DISPLAY:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq(_outdigits_);
+                       break;
+
+               case CONFIG_MODE:
+                       vp->v_type = V_STR;
+                       vp->v_subtype = V_STRLITERAL;
+                       vp->v_str = modename(_outmode_);
+                       break;
+
+               case CONFIG_EPSILON:
+                       vp->v_type = V_NUM;
+                       vp->v_num = qlink(_epsilon_);
+                       break;
+
+               case CONFIG_MAXPRINT:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq(maxprint);
+                       break;
+
+               case CONFIG_MUL2:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq(_mul2_);
+                       break;
+
+               case CONFIG_SQ2:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq(_sq2_);
+                       break;
+
+               case CONFIG_POW2:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq(_pow2_);
+                       break;
+
+               case CONFIG_REDC2:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq(_redc2_);
+                       break;
+               
+               case CONFIG_TILDE:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq(tilde_ok);
+               
+               case CONFIG_TAB:
+                       vp->v_type = V_NUM;
+                       vp->v_num = itoq(tab_ok);
+                       break;
+
+               default:
+                       math_error("Getting illegal config parameter");
+       }
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/const.c b/usr/src/contrib/calc-2.9.3t6/const.c
new file mode 100644 (file)
index 0000000..55487b6
--- /dev/null
@@ -0,0 +1,108 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Constant number storage module.
+ */
+
+#include "calc.h"
+
+#define CONSTALLOCSIZE 400     /* number of constants to allocate */
+
+
+static long constcount;                /* number of constants defined */
+static long constavail;                /* number of constants available */
+static NUMBER **consttable;    /* table of constants */
+
+
+/*
+ * Read in a constant number and add it to the table of constant numbers,
+ * creating a new entry if necessary.  The incoming number is a string
+ * value which must have a correct format, otherwise an undefined number
+ * will result.  Returns the index of the number in the constant table.
+ * Returns zero if the number could not be saved.
+ */
+long
+addnumber(str)
+       char *str;              /* string representation of number */
+{
+       NUMBER *q;
+
+       q = atoq(str);
+       if (q == NULL)
+               return 0;
+       return addqconstant(q);
+}
+
+
+/*
+ * Add a particular number to the constant table.
+ * Returns the index of the number in the constant table, or zero
+ * if the number could not be saved.  The incoming number if freed
+ * if it is already in the table.
+ */
+long
+addqconstant(q)
+       register NUMBER *q;     /* number to be added */
+{
+       register NUMBER **tp;   /* pointer to current number */
+       register NUMBER *t;     /* number being tested */
+       long index;             /* index into constant table */
+       long numlen;            /* numerator length */
+       long denlen;            /* denominator length */
+       HALF numlow;            /* bottom value of numerator */
+       HALF denlow;            /* bottom value of denominator */
+
+       numlen = q->num.len;
+       denlen = q->den.len;
+       numlow = q->num.v[0];
+       denlow = q->den.v[0];
+       tp = &consttable[1];
+       for (index = 1; index <= constcount; index++) {
+               t = *tp++;
+               if ((numlen != t->num.len) || (numlow != t->num.v[0]))
+                       continue;
+               if ((denlen != t->den.len) || (denlow != t->den.v[0]))
+                       continue;
+               if (q->num.sign != t->num.sign)
+                       continue;
+               if (qcmp(q, t) == 0) {
+                       qfree(q);
+                       return index;
+               }
+       }
+       if (constavail <= 0) {
+               if (consttable == NULL) {
+                       tp = (NUMBER **)
+                               malloc(sizeof(NUMBER *) * (CONSTALLOCSIZE + 1));
+                       *tp = NULL;
+               } else
+                       tp = (NUMBER **) realloc((char *) consttable,
+                       sizeof(NUMBER *) * (constcount+CONSTALLOCSIZE + 1));
+               if (tp == NULL)
+                       return 0;
+               consttable = tp;
+               constavail = CONSTALLOCSIZE;
+       }
+       constavail--;
+       constcount++;
+       consttable[constcount] = q;
+       return constcount;
+}
+
+
+/*
+ * Return the value of a constant number given its index.
+ * Returns address of the number, or NULL if the index is illegal.
+ */
+NUMBER *
+constvalue(index)
+       long index;
+{
+       if ((index <= 0) || (index > constcount))
+               return NULL;
+       return consttable[index];
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/endian.c b/usr/src/contrib/calc-2.9.3t6/endian.c
new file mode 100644 (file)
index 0000000..fee7bae
--- /dev/null
@@ -0,0 +1,72 @@
+/*
+ * endian - Determine the byte order of a long on your machine.
+ *
+ * Big Endian:     Amdahl, 68k, Pyramid, Mips, Sparc, ...
+ * Little Endian:   Vax, 32k, Spim (Dec Mips), i386, i486, ...
+ */
+/*
+ * Copyright (c) 1993 by Landon Curt Noll.  All Rights Reserved.
+ *
+ * Permission to use, copy, modify, and distribute this software and
+ * its documentation for any purpose and without fee is hereby granted,
+ * provided that the above copyright, this permission notice and text
+ * this comment, and the disclaimer below appear in all of the following:
+ *
+ *     supporting documentation
+ *     source copies
+ *     source works derived from this source
+ *     binaries derived from this source or from derived source
+ *
+ * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
+ * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO
+ * EVENT SHALL LANDON CURT NOLL BE LIABLE FOR ANY SPECIAL, INDIRECT OR
+ * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF
+ * USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ *
+ * chongo was here     /\../\
+ */
+
+#include <stdio.h>
+
+/* byte order array */
+char byte[8] = { (char)0x12, (char)0x36, (char)0x48, (char)0x59,
+                (char)0x01, (char)0x23, (char)0x45, (char)0x67 };
+
+main()
+{
+    /* pointers into the byte order array */
+    int *intp = (int *)byte;
+#if defined(DEBUG)
+    short *shortp = (short *)byte;
+    long *longp = (long *)byte;
+
+    printf("byte: %02x %02x %02x %02x %02x %02x %02x %02x\n",
+       byte[0], byte[1], byte[2], byte[3],
+       byte[4], byte[5], byte[6], byte[7]);
+    printf("short: %04x %04x %04x %04x\n",
+       shortp[0], shortp[1], shortp[2], shortp[3]);
+    printf("int: %08x %08x\n",
+       intp[0], intp[1]);
+    printf("long: %08x %08x\n",
+       longp[0], longp[1]);
+#endif
+
+    /* Print the standard <machine/endian.h> defines */
+    printf("#define BIG_ENDIAN\t4321\n");
+    printf("#define LITTLE_ENDIAN\t1234\n");
+
+    /* Determine byte order */
+    if (intp[0] == 0x12364859) {
+       /* Most Significant Byte first */
+       printf("#define BYTE_ORDER\tBIG_ENDIAN\n");
+    } else if (intp[0] == 0x59483612) {
+       /* Least Significant Byte first */
+       printf("#define BYTE_ORDER\tLITTLE_ENDIAN\n");
+    } else {
+       fprintf(stderr, "Unknown int Byte Order, set BYTE_ORDER in Makefile\n");
+       exit(1);
+    }
+    exit(0);
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/file.c b/usr/src/contrib/calc-2.9.3t6/file.c
new file mode 100644 (file)
index 0000000..3f40b89
--- /dev/null
@@ -0,0 +1,550 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * File I/O routines callable by users.
+ */
+
+#include "stdarg.h"
+#include "calc.h"
+
+
+#define        READSIZE        1024    /* buffer size for reading */
+
+/*
+ * Definition of opened files.
+ */
+typedef struct {
+       FILEID id;              /* id to identify this file */
+       FILE *fp;               /* real file structure for I/O */
+       char *name;             /* file name */
+       BOOL reading;           /* TRUE if opened for reading */
+       BOOL writing;           /* TRUE if opened for writing */
+       char *mode;             /* open mode */
+} FILEIO;
+
+
+/*
+ * Table of opened files.
+ * The first three entries always correspond to stdin, stdout, and stderr,
+ * and cannot be closed.  Their file ids are always 0, 1, and 2.
+ */
+static FILEIO files[MAXFILES] = {
+       FILEID_STDIN,  NULL,  "(stdin)",  TRUE, FALSE, "reading",
+       FILEID_STDOUT, NULL, "(stdout)", FALSE, TRUE, "writing",
+       FILEID_STDERR, NULL, "(stderr)", FALSE, TRUE, "writing"
+};
+
+static FILEID lastid = FILEID_STDERR;          /* last allocated file id */
+
+
+/*
+ * file_init - perform needed initilization work
+ *
+ * On some systems, one cannot initialize a pointer to a FILE *.
+ * This routine, called once at startup is a work-a-round for
+ * systems with such bogons.
+ */
+void
+file_init()
+{
+    static int done = 0;       /* 1 => routine already called */
+
+    if (!done) {
+       files[0].fp = stdin;
+       files[1].fp = stdout;
+       files[2].fp = stderr;
+       done = 1;
+    }
+}
+
+
+/*
+ * Open the specified file name for reading or writing as determined by
+ * the specified mode ("r", "w", or "a").  Returns a file id which can be
+ * used to do I/O to the file, or else FILEID_NONE if the open failed.
+ * Aborts with an error if too many files are opened or the mode is illegal.
+ */
+FILEID
+openid(name, mode)
+       char *name;             /* file name */
+       char *mode;             /* open mode */
+{
+       FILEIO *fiop;           /* file structure */
+       FILEID id;              /* new file id */
+       int count;
+
+       if (((*mode != 'r') && (*mode != 'w') && (*mode != 'a')) || mode[1])
+               math_error("Illegal mode for fopen");
+
+       count = MAXFILES;
+       do {
+               if (--count < 0)
+                       math_error("Too many open files");
+               id = ++lastid;
+               fiop = &files[id % MAXFILES];
+
+       } while (fiop->reading || fiop->writing);
+
+       fiop->name = (char *)malloc(strlen(name) + 1);
+       if (fiop->name == NULL) {
+               lastid--;
+               math_error("No memory for filename");
+       }
+       strcpy(fiop->name, name);
+
+       fiop->fp = f_open(name, mode);
+       if (fiop->fp == NULL) {
+               free(fiop->name);
+               fiop->name = NULL;
+               lastid--;
+               return FILEID_NONE;
+       }
+
+       switch (*mode) {
+               case 'r':
+                       fiop->mode = "reading";
+                       fiop->reading = TRUE;
+                       break;
+               case 'w':
+                       fiop->mode = "writing";
+                       fiop->writing = TRUE;
+                       break;
+               case 'a':
+                       fiop->mode = "appending";
+                       fiop->writing = TRUE;
+                       break;
+       }
+
+       fiop->id = id;
+
+       return id;
+}
+
+
+/*
+ * Find the file I/O structure for the specified file id, and verify that
+ * it is opened in the required manner ('r' for reading or 'w' for writing).
+ * If mode is 0, then no open checks are made at all, and NULL is then
+ * returned if the id represents a closed file.
+ */
+static FILEIO *
+findid(id, mode)
+       int mode;
+       FILEID id;
+{
+       FILEIO *fiop;           /* file structure */
+       static char *msg;
+       BOOL flag = 0;
+
+       if ((id < 0) || (id > lastid))
+               math_error("Illegal file id");
+
+       fiop = &files[id % MAXFILES];
+
+       switch (mode) {
+               case 'r':
+                       msg = "Reading from";
+                       flag = fiop->reading;
+                       break;
+               case 'w':
+                       msg = "Writing to";
+                       flag = fiop->writing;
+                       break;
+               case 0:
+                       msg = NULL;
+                       break;
+               default:
+                       math_error("Unknown findid mode");
+       }
+
+       if (fiop->id != id) {
+               if (msg)
+                       math_error("%s closed file", msg);
+               return NULL;
+       }
+
+       if (msg && !flag)
+               math_error("%s file not opened that way", msg);
+       
+       return fiop;
+}
+
+
+/*
+ * Return whether or not a file id is valid.  This is used for if tests.
+ */
+BOOL
+validid(id)
+       FILEID id;
+{
+       return (findid(id, 0) != NULL);
+}
+
+
+/*
+ * Return the file id for the entry in the file table at the specified index.
+ * Returns FILEID_NONE if the index is illegal or the file is closed.
+ */
+FILEID
+indexid(index)
+       long index;
+{
+       FILEIO *fiop;           /* file structure */
+
+       if ((index < 0) || (index >= MAXFILES))
+               return FILEID_NONE;
+
+       fiop = &files[index];
+       if (fiop->reading || fiop->writing)
+               return fiop->id;
+
+       return FILEID_NONE;
+}
+
+
+/*
+ * Close the specified file id.  Returns TRUE if there was an error.
+ * Closing of stdin, stdout, or stderr is illegal, but closing of already
+ * closed files is allowed.
+ */
+BOOL
+closeid(id)
+       FILEID id;
+{
+       FILEIO *fiop;           /* file structure */
+       int err;
+
+       if ((id == FILEID_STDIN) || (id == FILEID_STDOUT) ||
+               (id == FILEID_STDERR))
+                       math_error("Cannot close stdin, stdout, or stderr");
+
+       fiop = findid(id, 0);
+       if (fiop == NULL)
+               return FALSE;
+
+       fiop->id = FILEID_NONE;
+       if (!fiop->reading && !fiop->writing)
+               math_error("Closing non-opened file");
+       fiop->reading = FALSE;
+       fiop->writing = FALSE;
+
+       if (fiop->name)
+               free(fiop->name);
+       fiop->name = NULL;
+
+       err = ferror(fiop->fp);
+       err |= fclose(fiop->fp);
+       fiop->fp = NULL;
+
+       return (err != 0);
+}
+
+
+/*
+ * Return whether or not an error occurred to a file.
+ */
+BOOL
+errorid(id)
+       FILEID id;
+{
+       FILEIO *fiop;           /* file structure */
+
+       fiop = findid(id, 0);
+       if (fiop == NULL)
+               math_error("Closed file for ferror");
+       return (ferror(fiop->fp) != 0);
+}
+
+
+/*
+ * Return whether or not end of file occurred to a file.
+ */
+BOOL
+eofid(id)
+       FILEID id;
+{
+       FILEIO *fiop;           /* file structure */
+
+       fiop = findid(id, 0);
+       if (fiop == NULL)
+               math_error("Closed file for feof");
+       return (feof(fiop->fp) != 0);
+}
+
+
+/*
+ * Flush output to an opened file.
+ */
+void
+flushid(id)
+       FILEID id;
+{
+       FILEIO *fiop;           /* file structure */
+
+       fiop = findid(id, 'w');
+       fflush(fiop->fp);
+}
+
+
+/*
+ * Read the next line from an opened file.
+ * Returns a pointer to an allocated string holding the null-terminated
+ * line (without any terminating newline), or else a NULL pointer on an
+ * end of file or error.
+ */
+void
+readid(id, retptr)
+       FILEID  id;             /* file to read from */
+       char **retptr;          /* returned pointer to string */
+{
+       FILEIO *fiop;           /* file structure */
+       char *str;              /* current string */
+       int len;                /* current length of string */
+       int totlen;             /* total length of string */
+       char buf[READSIZE];     /* temporary buffer */
+
+       totlen = 0;
+       str = NULL;
+
+       fiop = findid(id, 'r');
+
+       while (fgets(buf, READSIZE, fiop->fp) && buf[0]) {
+               len = strlen(buf);
+               if (totlen)
+                       str = (char *)realloc(str, totlen + len + 1);
+               else
+                       str = (char *)malloc(len + 1);
+               if (str == NULL)
+                       math_error("No memory in freadline");
+               strcpy(&str[totlen], buf);
+               totlen += len;
+               if (buf[len - 1] == '\n') {
+                       str[totlen - 1] = '\0';
+                       *retptr = str;
+                       return;
+               }
+       }
+       if (totlen && ferror(fiop->fp)) {
+               free(str);
+               str = NULL;
+       }
+       *retptr = str;
+}
+
+
+/*
+ * Return the next character from an opened file.
+ * Returns EOF if there was an error or end of file.
+ */
+int
+getcharid(id)
+       FILEID id;
+{
+       return fgetc(findid(id, 'r')->fp);
+}
+
+
+/*
+ * Print out the name of an opened file.
+ * If the file has been closed, a null name is printed.
+ * If flags contain PRINT_UNAMBIG then extra information is printed
+ * identifying the output as a file and some data about it.
+ */
+void
+printid(id, flags)
+       int flags;
+       FILEID id;
+{
+       FILEIO *fiop;           /* file structure */
+       FILE *fp;
+
+       fiop = findid(id, 0);
+       if (fiop == NULL) {
+               math_str((flags & PRINT_UNAMBIG) ? "FILE (closed)" : "\"\"");
+               return;
+       }
+       if ((flags & PRINT_UNAMBIG) == 0) {
+               math_chr('"');
+               math_str(fiop->name);
+               math_chr('"');
+               return;
+       }
+
+       fp = fiop->fp;
+       math_fmt("FILE \"%s\" (%s, pos %ld", fiop->name,  fiop->mode,
+               ftell(fp));
+       if (ferror(fp))
+               math_str(", error");
+       if (feof(fp))
+               math_str(", eof");
+       math_chr(')');
+}
+
+
+/*
+ * Print a formatted string similar to printf.  Various formats of output
+ * are possible, depending on the format string AND the actual types of the
+ * values.  Mismatches do not cause errors, instead something reasonable is
+ * printed instead.  The output goes to the file with the specified id.
+ */
+void
+idprintf(id, fmt, count, vals)
+       int count;
+       FILEID id;                      /* file id to print to */
+       char *fmt;                      /* standard format string */
+       VALUE **vals;                   /* table of values to print */
+{
+       FILEIO *fiop;
+       VALUE *vp;
+       char *str;
+       int ch, len;
+       int oldmode, newmode;
+       long olddigits, newdigits;
+       long width, precision;
+       BOOL didneg, didprecision;
+
+       fiop = findid(id, 'w');
+
+       math_setfp(fiop->fp);
+
+       while ((ch = *fmt++) != '\0') {
+               if (ch == '\\') {
+                       ch = *fmt++;
+                       switch (ch) {
+                               case 'n': ch = '\n'; break;
+                               case 'r': ch = '\r'; break;
+                               case 't': ch = '\t'; break;
+                               case 'f': ch = '\f'; break;
+                               case 'v': ch = '\v'; break;
+                               case 'b': ch = '\b'; break;
+                               case 0:
+                                       math_setfp(stdout);
+                                       return;
+                       }
+                       math_chr(ch);
+                       continue;
+               }
+
+               if (ch != '%') {
+                       math_chr(ch);
+                       continue;
+               }
+
+               /*
+                * Here to handle formats.
+                */
+               didneg = FALSE;
+               didprecision = FALSE;
+               width = 0;
+               precision = 0;
+
+               ch = *fmt++;
+               if (ch == '-') {
+                       didneg = TRUE;
+                       ch = *fmt++;
+               }
+               while ((ch >= '0') && (ch <= '9')) {
+                       width = width * 10 + (ch - '0');
+                       ch = *fmt++;
+               }
+               if (ch == '.') {
+                       didprecision = TRUE;
+                       ch = *fmt++;
+                       while ((ch >= '0') && (ch <= '9')) {
+                               precision = precision * 10 + (ch - '0');
+                               ch = *fmt++;
+                       }
+               }
+               if (ch == 'l')
+                       ch = *fmt++;
+
+               oldmode = _outmode_;
+               newmode = oldmode;
+               olddigits = _outdigits_;
+               newdigits = olddigits;
+               if (didprecision)
+                       newdigits = precision;
+
+               switch (ch) {
+                       case 'd':
+                       case 's':
+                       case 'c':
+                               break;
+                       case 'f':
+                               newmode = MODE_REAL;
+                               break;
+                       case 'e':
+                               newmode = MODE_EXP;
+                               break;
+                       case 'r':
+                               newmode = MODE_FRAC;
+                               break;
+                       case 'o':
+                               newmode = MODE_OCTAL;
+                               break;
+                       case 'x':
+                               newmode = MODE_HEX;
+                               break;
+                       case 'b':
+                               newmode = MODE_BINARY;
+                               break;
+                       case 0:
+                               math_setfp(stdout);
+                               return;
+                       default:
+                               math_chr(ch);
+                               continue;
+               }
+
+               if (--count < 0)
+                       math_error("Not enough arguments for fprintf");
+               vp = *vals++;
+
+               math_setdigits(newdigits);
+               math_setmode(newmode);
+
+               /*
+                * If there is no width specification, or if the type of
+                * value requires multiple lines, then just output the
+                * value directly.
+                */
+               if ((width == 0) ||
+                       (vp->v_type == V_MAT) || (vp->v_type == V_LIST))
+               {
+                       printvalue(vp, PRINT_NORMAL);
+                       math_setmode(oldmode);
+                       math_setdigits(olddigits);
+                       continue;
+               }
+
+               /*
+                * There is a field width.  Collect the output in a string,
+                * print it padded appropriately with spaces, and free it.
+                * However, if the output contains a newline, then ignore
+                * the field width.
+                */
+               math_divertio();
+               printvalue(vp, PRINT_NORMAL);
+               str = math_getdivertedio();
+               if (strchr(str, '\n'))
+                       width = 0;
+               len = strlen(str);
+               while (!didneg && (width > len)) {
+                       width--;
+                       math_chr(' ');
+               }
+               math_str(str);
+               free(str);
+               while (didneg && (width > len)) {
+                       width--;
+                       math_chr(' ');
+               }
+               math_setmode(oldmode);
+               math_setdigits(olddigits);
+       }
+       math_setfp(stdout);
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/func.c b/usr/src/contrib/calc-2.9.3t6/func.c
new file mode 100644 (file)
index 0000000..a360396
--- /dev/null
@@ -0,0 +1,2161 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Built-in functions implemented here
+ */
+
+#include <sys/types.h>
+#include <sys/times.h>
+#include <time.h>
+
+#include "calc.h"
+#include "opcodes.h"
+#include "token.h"
+#include "func.h"
+#include "string.h"
+#include "symbol.h"
+
+
+/* if HZ & CLK_TCK are not defined, pick typical values, hope for the best */
+#if !defined(HZ)
+#  define HZ 60
+#endif
+#if !defined(CLK_TCK)
+# undef CLK_TCK
+# define CLK_TCK HZ
+#endif
+
+extern int errno;
+
+
+/*
+ * Totally numeric functions.
+ */
+static NUMBER *f_cfsim();      /* simplify number using continued fractions */
+static NUMBER *f_ilog();       /* return log of one number to another */
+static NUMBER *f_faccnt();     /* count of divisions */
+static NUMBER *f_min();                /* minimum of several arguments */
+static NUMBER *f_max();                /* maximum of several arguments */
+static NUMBER *f_hmean();      /* harmonic mean */
+static NUMBER *f_trunc();      /* truncate number to specified decimal places */
+static NUMBER *f_btrunc();     /* truncate number to specified binary places */
+static NUMBER *f_gcd();                /* greatest common divisor */
+static NUMBER *f_lcm();                /* least common multiple */
+static NUMBER *f_xor();                /* xor of several arguments */
+static NUMBER *f_ceil();       /* ceiling of a fraction */
+static NUMBER *f_floor();      /* floor of a fraction */
+static NUMBER *f_meq();                /* numbers are same modular value */
+static NUMBER *f_isrel();      /* two numbers are relatively prime */
+static NUMBER *f_ismult();     /* whether one number divides another */
+static NUMBER *f_mne();                /* whether a and b are not equal modulo c */
+static NUMBER *f_isset();      /* tests if a bit of a num (base 2) is set */
+static NUMBER *f_highbit();    /* high bit number in base 2 representation */
+static NUMBER *f_lowbit();     /* low bit number in base 2 representation */
+static NUMBER *f_near();       /* whether two numbers are near each other */
+static NUMBER *f_legtoleg();   /* positive form of leg to leg */
+static NUMBER *f_ilog10();     /* integer log of number base 10 */
+static NUMBER *f_ilog2();      /* integer log of number base 2 */
+static NUMBER *f_digits();     /* number of digits of number */
+static NUMBER *f_digit();      /* digit at specified decimal place of number */
+static NUMBER *f_places();     /* number of decimal places of number */
+static NUMBER *f_primetest();  /* primality test */
+static NUMBER *f_issquare();   /* whether number is a square */
+static NUMBER *f_runtime();    /* user runtime in seconds */
+static NUMBER *f_base();       /* set default output base */
+
+
+/*
+ * General functions.
+ */
+static VALUE f_hash();         /* produce hash from values */
+static VALUE f_bround();       /* round number to specified binary places */
+static VALUE f_round();                /* round number to specified decimal places */
+static VALUE f_det();          /* determinant of matrix */
+static VALUE f_mattrans();     /* return transpose of matrix */
+static VALUE f_matdim();       /* dimension of matrix */
+static VALUE f_matmax();       /* maximum index of matrix dimension */
+static VALUE f_matmin();       /* minimum index of matrix dimension */
+static VALUE f_matfill();      /* fill matrix with values */
+static VALUE f_listpush();     /* push element onto front of list */
+static VALUE f_listpop();      /* pop element from front of list */
+static VALUE f_listappend();   /* append element to end of list */
+static VALUE f_listremove();   /* remove element from end of list */
+static VALUE f_listinsert();   /* insert element into list */
+static VALUE f_listdelete();   /* delete element from list */
+static VALUE f_strlen();       /* length of string */
+static VALUE f_char();         /* character value of integer */
+static VALUE f_substr();       /* extract substring */
+static VALUE f_strcat();       /* concatenate strings */
+static VALUE f_ord();          /* get ordinal value for character */
+static VALUE f_avg();          /* average of several arguments */
+static VALUE f_ssq();          /* sum of squares */
+static VALUE f_poly();         /* result of evaluating polynomial */
+static VALUE f_sqrt();         /* square root of a number */
+static VALUE f_root();         /* number taken to root of another */
+static VALUE f_exp();          /* complex exponential */
+static VALUE f_ln();           /* complex natural logarithm */
+static VALUE f_power();                /* one value to another power */
+static VALUE f_cos();          /* complex cosine */
+static VALUE f_sin();          /* complex sine */
+static VALUE f_polar();                /* polar representation of complex number */
+static VALUE f_arg();          /* argument of complex number */
+static VALUE f_list();         /* create a list */
+static VALUE f_size();         /* number of elements in object */
+static VALUE f_search();       /* search matrix or list for match */
+static VALUE f_rsearch();      /* search matrix or list backwards for match */
+static VALUE f_cp();           /* cross product of vectors */
+static VALUE f_dp();           /* dot product of vectors */
+static VALUE f_prompt();       /* prompt for input line */
+static VALUE f_eval();         /* evaluate string into value */
+static VALUE f_str();          /* convert value to string */
+static VALUE f_fopen();                /* open file for reading or writing */
+static VALUE f_fprintf();      /* print data to file */
+static VALUE f_strprintf();    /* return printed data as a string */
+static VALUE f_fgetline();     /* read next line from file */
+static VALUE f_fgetc();                /* read next char from file */
+static VALUE f_fflush();       /* flush output to file */
+static VALUE f_printf();       /* print data to stdout */
+static VALUE f_fclose();       /* close file */
+static VALUE f_ferror();       /* whether error occurred */
+static VALUE f_feof();         /* whether end of file reached */
+static VALUE f_files();                /* return file handle or number of files */
+static VALUE f_assoc();                /* return a new association value */
+
+
+#define IN 100         /* maximum number of arguments */
+#define        FE 0x01         /* flag to indicate default epsilon argument */
+#define        FA 0x02         /* preserve addresses of variables */
+
+
+/*
+ * List of primitive built-in functions
+ */
+static struct builtin {
+       char *b_name;           /* name of built-in function */
+       short b_minargs;        /* minimum number of arguments */
+       short b_maxargs;        /* maximum number of arguments */
+       short b_flags;          /* special handling flags */
+       short b_opcode;         /* opcode which makes the call quick */
+       NUMBER *(*b_numfunc)(); /* routine to calculate numeric function */
+       VALUE (*b_valfunc)();   /* routine to calculate general values */
+       char *b_desc;           /* description of function */
+} builtins[] = {
+       "abs", 1, 2, 0, OP_ABS, 0, 0, "absolute value within accuracy b",
+       "acos", 1, 2, FE, OP_NOP, qacos, 0, "arccosine of a within accuracy b",
+       "acosh", 1, 2, FE, OP_NOP, qacosh, 0, "hyperbolic arccosine of a within accuracy b",
+       "append", 2, 2, FA, OP_NOP, 0, f_listappend, "append value to end of list",
+       "appr", 1, 2, FE, OP_NOP, qbappr, 0, "approximate a with simpler fraction to within b",
+       "arg", 1, 2, 0, OP_NOP, 0, f_arg, "argument (the angle) of complex number",
+       "asin", 1, 2, FE, OP_NOP, qasin, 0, "arcsine of a within accuracy b",
+       "asinh", 1, 2, FE, OP_NOP, qasinh, 0, "hyperbolic arcsine of a within accuracy b",
+       "assoc", 0, 0, 0, OP_NOP, 0, f_assoc, "create new association array",
+       "atan", 1, 2, FE, OP_NOP, qatan, 0, "arctangent of a within accuracy b",
+       "atan2", 2, 3, FE, OP_NOP, qatan2, 0, "angle to point (b,a) within accuracy c",
+       "atanh", 1, 2, FE, OP_NOP, qatanh, 0, "hyperbolic arctangent of a within accuracy b",
+       "avg", 1, IN, 0, OP_NOP, 0, f_avg, "arithmetic mean of values",
+       "base", 0, 1, 0, OP_NOP, f_base, 0, "set default output base",
+       "bround", 1, 2, 0, OP_NOP, 0, f_bround, "round value a to b number of binary places",
+       "btrunc", 1, 2, 0, OP_NOP, f_btrunc, 0, "truncate a to b number of binary places",
+       "ceil", 1, 1, 0, OP_NOP, f_ceil, 0, "smallest integer greater than or equal to number",
+       "cfappr", 1, 2, FE, OP_NOP, qcfappr, 0, "approximate a within accuracy b using\n\t\t    continued fractions",
+       "cfsim", 1, 1, 0, OP_NOP, f_cfsim, 0, "simplify number using continued fractions",
+       "char", 1, 1, 0, OP_NOP, 0, f_char, "character corresponding to integer value",
+       "cmp", 2, 2, 0, OP_CMP, 0, 0, "compare values returning -1, 0, or 1",
+       "comb", 2, 2, 0, OP_NOP, qcomb, 0, "combinatorial number a!/b!(a-b)!",
+       "config", 1, 2, 0, OP_SETCONFIG, 0, 0, "set or read configuration value",
+       "conj", 1, 1, 0, OP_CONJUGATE, 0, 0, "complex conjugate of value",
+       "cos", 1, 2, 0, OP_NOP, 0, f_cos, "cosine of value a within accuracy b",
+       "cosh", 1, 2, FE, OP_NOP, qcosh, 0, "hyperbolic cosine of a within accuracy b",
+       "cp", 2, 2, 0, OP_NOP, 0, f_cp, "Cross product of two vectors",
+       "delete", 2, 2, FA, OP_NOP, 0, f_listdelete, "delete element from list a at position b",
+       "den", 1, 1, 0, OP_DENOMINATOR, qden, 0, "denominator of fraction",
+       "det", 1, 1, 0, OP_NOP, 0, f_det, "determinant of matrix",
+       "digit", 2, 2, 0, OP_NOP, f_digit, 0, "digit at specified decimal place of number",
+       "digits", 1, 1, 0, OP_NOP, f_digits, 0, "number of digits in number",
+       "dp", 2, 2, 0, OP_NOP, 0, f_dp, "Dot product of two vectors",
+       "epsilon", 0, 1, 0, OP_SETEPSILON, 0, 0, "set or read allowed error for real calculations",
+       "eval", 1, 1, 0, OP_NOP, 0, f_eval, "Evaluate expression from string to value",
+       "exp", 1, 2, 0, OP_NOP, 0, f_exp, "exponential of value a within accuracy b",
+       "fcnt", 2, 2, 0, OP_NOP, f_faccnt, 0, "count of times one number divides another",
+       "fib", 1, 1, 0, OP_NOP, qfib, 0, "Fibonacci number F(n)",
+       "frem", 2, 2, 0, OP_NOP, qfacrem, 0, "number with all occurrences of factor removed",
+       "fact", 1, 1, 0, OP_NOP, qfact, 0, "factorial",
+       "fclose", 1, 1, 0, OP_NOP, 0, f_fclose, "close file",
+       "feof", 1, 1, 0, OP_NOP, 0, f_feof, "whether EOF reached for file",
+       "ferror", 1, 1, 0, OP_NOP, 0, f_ferror, "whether error occurred for file",
+       "fflush", 1, 1, 0, OP_NOP, 0, f_fflush, "flush output to file",
+       "fgetc", 1, 1, 0, OP_NOP, 0, f_fgetc, "read next char from file",
+       "fgetline", 1, 1, 0, OP_NOP, 0, f_fgetline, "read next line from file",
+       "files", 0, 1, 0, OP_NOP, 0, f_files, "return opened file or max number of opened files",
+       "floor", 1, 1, 0, OP_NOP, f_floor, 0, "greatest integer less than or equal to number",
+       "fopen", 2, 2, 0, OP_NOP, 0, f_fopen, "open file name a in mode b",
+       "fprintf", 2, IN, 0, OP_NOP, 0, f_fprintf, "print formatted output to opened file",
+       "frac", 1, 1, 0, OP_FRAC, qfrac, 0, "fractional part of value",
+       "gcd", 1, IN, 0, OP_NOP, f_gcd, 0, "greatest common divisor",
+       "gcdrem", 2, 2, 0, OP_NOP, qgcdrem, 0, "a divided repeatedly by gcd with b",
+       "hash", 1, IN, 0, OP_NOP, 0, f_hash, "return non-negative hash value for one or\n\t\t    more values",
+       "highbit", 1, 1, 0, OP_NOP, f_highbit, 0, "high bit number in base 2 representation",
+       "hmean", 1, IN, 0, OP_NOP, f_hmean, 0, "harmonic mean of values",
+       "hypot", 2, 3, FE, OP_NOP, qhypot, 0, "hypotenuse of right triangle within accuracy c",
+       "ilog", 2, 2, 0, OP_NOP, f_ilog, 0, "integral log of one number with another",
+       "ilog10", 1, 1, 0, OP_NOP, f_ilog10, 0, "integral log of a number base 10",
+       "ilog2", 1, 1, 0, OP_NOP, f_ilog2, 0, "integral log of a number base 2",
+       "im", 1, 1, 0, OP_IM, 0, 0, "imaginary part of complex number",
+       "insert", 3, 3, FA, OP_NOP, 0, f_listinsert, "insert value c into list a at position b",
+       "int", 1, 1, 0, OP_INT, qint, 0, "integer part of value",
+       "inverse", 1, 1, 0, OP_INVERT, 0, 0, "multiplicative inverse of value",
+       "iroot", 2, 2, 0, OP_NOP, qiroot, 0, "integer b'th root of a",
+       "isassoc", 1, 1, 0, OP_ISASSOC, 0, 0, "whether a value is an association",
+       "iseven", 1, 1, 0, OP_ISEVEN, 0, 0, "whether a value is an even integer",
+       "isfile", 1, 1, 0, OP_ISFILE, 0, 0, "whether a value is a file",
+       "isint", 1, 1, 0, OP_ISINT, 0, 0, "whether a value is an integer",
+       "islist", 1, 1, 0, OP_ISLIST, 0, 0, "whether a value is a list",
+       "ismat", 1, 1, 0, OP_ISMAT, 0, 0, "whether a value is a matrix",
+       "ismult", 2, 2, 0, OP_NOP, f_ismult, 0, "whether a is a multiple of b",
+       "isnull", 1, 1, 0, OP_ISNULL, 0, 0, "whether a value is the null value",
+       "isnum", 1, 1, 0, OP_ISNUM, 0, 0, "whether a value is a number",
+       "isobj", 1, 1, 0, OP_ISOBJ, 0, 0, "whether a value is an object",
+       "isodd", 1, 1, 0, OP_ISODD, 0, 0, "whether a value is an odd integer",
+       "isqrt", 1, 1, 0, OP_NOP, qisqrt, 0, "integer part of square root",
+       "isreal", 1, 1, 0, OP_ISREAL, 0, 0, "whether a value is a real number",
+       "isset", 2, 2, 0, OP_NOP, f_isset, 0, "whether bit b of abs(a) (in base 2) is set",
+       "isstr", 1, 1, 0, OP_ISSTR, 0, 0, "whether a value is a string",
+       "isrel", 2, 2, 0, OP_NOP, f_isrel, 0, "whether two numbers are relatively prime",
+       "issimple", 1, 1, 0, OP_ISSIMPLE, 0, 0, "whether value is a simple type",
+       "issq", 1, 1, 0, OP_NOP, f_issquare, 0, "whether or not number is a square",
+       "istype", 2, 2, 0, OP_ISTYPE, 0, 0, "whether the type of a is same as the type of b",
+       "jacobi", 2, 2, 0, OP_NOP, qjacobi, 0, "-1 => a is not quadratic residue mod b\n\t\t  1 => b is composite, or a is quad residue of b",
+       "lcm", 1, IN, 0, OP_NOP, f_lcm, 0, "least common multiple",
+       "lcmfact", 1, 1, 0, OP_NOP, qlcmfact, 0, "lcm of all integers up till number",
+       "lfactor", 2, 2, 0, OP_NOP, qlowfactor, 0, "lowest prime factor of a in first b primes",
+       "list", 0, IN, 0, OP_NOP, 0, f_list, "create list of specified values",
+       "ln", 1, 2, 0, OP_NOP, 0, f_ln, "natural logarithm of value a within accuracy b",
+       "lowbit", 1, 1, 0, OP_NOP, f_lowbit, 0, "low bit number in base 2 representation",
+       "ltol", 1, 2, FE, OP_NOP, f_legtoleg, 0, "leg-to-leg of unit right triangle (sqrt(1 - a^2))",
+       "matdim", 1, 1, 0, OP_NOP, 0, f_matdim, "number of dimensions of matrix",
+       "matfill", 2, 3, FA, OP_NOP, 0, f_matfill, "fill matrix with value b (value c on diagonal)",
+       "matmax", 2, 2, 0, OP_NOP, 0, f_matmax, "maximum index of matrix a dim b",
+       "matmin", 2, 2, 0, OP_NOP, 0, f_matmin, "minimum index of matrix a dim b",
+       "mattrans", 1, 1, 0, OP_NOP, 0, f_mattrans, "transpose of matrix",
+       "max", 1, IN, 0, OP_NOP, f_max, 0, "maximum value",
+       "meq", 3, 3, 0, OP_NOP, f_meq, 0, "whether a and b are equal modulo c",
+       "min", 1, IN, 0, OP_NOP, f_min, 0, "minimum value",
+       "minv", 2, 2, 0, OP_NOP, qminv, 0, "inverse of a modulo b",
+       "mmin", 2, 2, 0, OP_NOP, qminmod, 0, "a mod b value with smallest abs value",
+       "mne", 3, 3, 0, OP_NOP, f_mne, 0, "whether a and b are not equal modulo c",
+       "near", 2, 3, 0, OP_NOP, f_near, 0, "sign of (abs(a-b) - c)",
+       "norm", 1, 1, 0, OP_NORM, 0, 0, "norm of a value (square of absolute value)",
+       "null", 0, 0, 0, OP_UNDEF, 0, 0, "null value",
+       "num", 1, 1, 0, OP_NUMERATOR, qnum, 0, "numerator of fraction",
+       "ord", 1, 1, 0, OP_NOP, 0, f_ord, "integer corresponding to character value",
+       "param", 1, 1, 0, OP_ARGVALUE, 0, 0, "value of parameter n (or parameter count if n\n\t\t    is zero)",
+       "perm", 2, 2, 0, OP_NOP, qperm, 0, "permutation number a!/(a-b)!",
+       "pfact", 1, 1, 0, OP_NOP, qpfact, 0, "product of primes up till number",
+       "pi", 0, 1, FE, OP_NOP, qpi, 0, "value of pi accurate to within epsilon",
+       "places", 1, 1, 0, OP_NOP, f_places, 0, "places after decimal point (-1 if infinite)",
+       "pmod", 3, 3, 0, OP_NOP, qpowermod,0, "mod of a power (a ^ b (mod c))",
+       "polar", 2, 3, 0, OP_NOP, 0, f_polar, "complex value of polar coordinate (a * exp(b*1i))",
+       "poly", 2, IN, 0, OP_NOP, 0, f_poly, "(a1,a2,...,an,x) = a1*x^n+a2*x^(n-1)+...+an",
+       "pop", 1, 1, FA, OP_NOP, 0, f_listpop, "pop value from front of list",
+       "power", 2, 3, 0, OP_NOP, 0, f_power, "value a raised to the power b within accuracy c",
+       "ptest", 2, 2, 0, OP_NOP, f_primetest, 0, "probabilistic primality test",
+       "printf", 1, IN, 0, OP_NOP, 0, f_printf, "print formatted output to stdout",
+       "prompt", 1, 1, 0, OP_NOP, 0, f_prompt, "prompt for input line using value a",
+       "push", 2, 2, FA, OP_NOP, 0, f_listpush, "push value onto front of list",
+       "quomod", 4, 4, 0, OP_QUOMOD, 0, 0, "set c and d to quotient and remainder of a\n\t\t    divided by b",
+       "rcin", 2, 2, 0, OP_NOP, qredcin, 0, "convert normal number a to REDC number mod b",
+       "rcmul", 3, 3, 0, OP_NOP, qredcmul, 0, "multiply REDC numbers a and b mod c",
+       "rcout", 2, 2, 0, OP_NOP, qredcout, 0, "convert REDC number a mod b to normal number",
+       "rcpow", 3, 3, 0, OP_NOP, qredcpower, 0, "raise REDC number a to power b mod c",
+       "rcsq", 2, 2, 0, OP_NOP, qredcsquare, 0, "square REDC number a mod b",
+       "re", 1, 1, 0, OP_RE, 0, 0, "real part of complex number",
+       "remove", 1, 1, FA, OP_NOP, 0, f_listremove, "remove value from end of list",
+       "root", 2, 3, 0, OP_NOP, 0, f_root, "value a taken to the b'th root within accuracy c",
+       "round", 1, 2, 0, OP_NOP, 0, f_round, "round value a to b number of decimal places",
+       "rsearch", 2, 3, 0, OP_NOP, 0, f_rsearch, "reverse search matrix or list for value b\n\t\t    starting at index c",
+       "runtime", 0, 0, 0, OP_NOP, f_runtime, 0, "user mode cpu time in seconds",
+       "scale", 2, 2, 0, OP_SCALE, 0, 0, "scale value up or down by a power of two",
+       "search", 2, 3, 0, OP_NOP, 0, f_search, "search matrix or list for value b starting\n\t\t    at index c",
+       "sgn", 1, 1, 0, OP_SGN, qsign, 0, "sign of value (-1, 0, 1)",
+       "sin", 1, 2, 0, OP_NOP, 0, f_sin, "sine of value a within accuracy b",
+       "sinh", 1, 2, FE, OP_NOP, qsinh, 0, "hyperbolic sine of a within accuracy b",
+       "size", 1, 1, 0, OP_NOP, 0, f_size, "total number of elements in value",
+       "sqrt", 1, 2, 0, OP_NOP, 0, f_sqrt, "square root of value a within accuracy b",
+       "ssq", 1, IN, 0, OP_NOP, 0, f_ssq, "sum of squares of values",
+       "str", 1, 1, 0, OP_NOP, 0, f_str, "simple value converted to string",
+       "strcat", 1,IN, 0, OP_NOP, 0, f_strcat, "concatenate strings together",
+       "strlen", 1, 1, 0, OP_NOP, 0, f_strlen, "length of string",
+       "strprintf", 1, IN, 0, OP_NOP, 0, f_strprintf, "return formatted output as a string",
+       "substr", 3, 3, 0, OP_NOP, 0, f_substr, "substring of a from position b for c chars",
+       "swap", 2, 2, 0, OP_SWAP, 0, 0, "swap values of variables a and b (can be dangerous)",
+       "tan", 1, 2, FE, OP_NOP, qtan, 0, "tangent of a within accuracy b",
+       "tanh", 1, 2, FE, OP_NOP, qtanh, 0, "hyperbolic tangent of a within accuracy b",
+       "trunc", 1, 2, 0, OP_NOP, f_trunc, 0, "truncate a to b number of decimal places",
+       "xor", 1, IN, 0, OP_NOP, f_xor, 0, "logical xor",
+       NULL, 0, 0, 0, OP_NOP, 0, 0, NULL /* end of table */
+};
+
+
+/*
+ * Call a built-in function.
+ * Arguments to the function are on the stack, but are not removed here.
+ * Functions are either purely numeric, or else can take any value type.
+ */
+VALUE
+builtinfunc(index, argcount, stck)
+       int argcount;
+       long index;
+       VALUE *stck;            /* arguments on the stack */
+{
+       VALUE *sp;              /* pointer to stack entries */
+       VALUE **vpp;            /* pointer to current value address */
+       struct builtin *bp;     /* builtin function to be called */
+       long i;                 /* index */
+       NUMBER *numargs[IN];    /* numeric arguments for function */
+       VALUE *valargs[IN];     /* addresses of actual arguments */
+       VALUE result;           /* general result of function */
+
+       if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
+               math_error("Bad built-in function index");
+       bp = &builtins[index];
+       if (argcount < bp->b_minargs)
+               math_error("Too few arguments for builtin function \"%s\"", bp->b_name);
+       if ((argcount > bp->b_maxargs) || (argcount > IN))
+               math_error("Too many arguments for builtin function \"%s\"", bp->b_name);
+       /*
+        * If an address was passed, then point at the real variable,
+        * otherwise point at the stack value itself (unless the function
+        * is very special).
+        */
+       sp = stck - argcount + 1;
+       vpp = valargs;
+       for (i = argcount; i > 0; i--) {
+               if ((sp->v_type != V_ADDR) || (bp->b_flags & FA))
+                       *vpp = sp;
+               else
+                       *vpp = sp->v_addr;
+               sp++;
+               vpp++;
+       }
+       /*
+        * Handle general values if the function accepts them.
+        */
+       if (bp->b_valfunc) {
+               vpp = valargs;
+               if ((bp->b_minargs == 1) && (bp->b_maxargs == 1))
+                       result = (*bp->b_valfunc)(vpp[0]);
+               else if ((bp->b_minargs == 2) && (bp->b_maxargs == 2))
+                       result = (*bp->b_valfunc)(vpp[0], vpp[1]);
+               else if ((bp->b_minargs == 3) && (bp->b_maxargs == 3))
+                       result = (*bp->b_valfunc)(vpp[0], vpp[1], vpp[2]);
+               else
+                       result = (*bp->b_valfunc)(argcount, vpp);
+               return result;
+       }
+       /*
+        * Function must be purely numeric, so handle that.
+        */
+       vpp = valargs;
+       for (i = 0; i < argcount; i++) {
+               if ((*vpp)->v_type != V_NUM)
+                       math_error("Non-real argument for builtin function %s", bp->b_name);
+               numargs[i] = (*vpp)->v_num;
+               vpp++;
+       }
+       result.v_type = V_NUM;
+       if (!(bp->b_flags & FE) && (bp->b_minargs != bp->b_maxargs)) {
+               result.v_num = (*bp->b_numfunc)(argcount, numargs);
+               return result;
+       }
+       if ((bp->b_flags & FE) && (argcount < bp->b_maxargs))
+               numargs[argcount++] = _epsilon_;
+
+       switch (argcount) {
+               case 0:
+                       result.v_num = (*bp->b_numfunc)();
+                       break;
+               case 1:
+                       result.v_num = (*bp->b_numfunc)(numargs[0]);
+                       break;
+               case 2:
+                       result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1]);
+                       break;
+               case 3:
+                       result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1], numargs[2]);
+                       break;
+               default:
+                       math_error("Bad builtin function call");
+       }
+       return result;
+}
+
+
+static VALUE
+f_eval(vp)
+       VALUE *vp;
+{
+       FUNC    *oldfunc;
+       FUNC    *newfunc;
+       VALUE   result;
+
+       if (vp->v_type != V_STR)
+               math_error("Evaluating non-string argument");
+       (void) openstring(vp->v_str);
+       oldfunc = curfunc;
+       enterfilescope();
+       if (evaluate(TRUE)) {
+               exitfilescope();
+               freevalue(stack--);
+               newfunc = curfunc;
+               curfunc = oldfunc;
+               result = newfunc->f_savedvalue;
+               newfunc->f_savedvalue.v_type = V_NULL;
+               if (newfunc != oldfunc)
+                       free(newfunc);
+               return result;
+       }
+       exitfilescope();
+       newfunc = curfunc;
+       curfunc = oldfunc;
+       freevalue(&newfunc->f_savedvalue);
+       newfunc->f_savedvalue.v_type = V_NULL;
+       if (newfunc != oldfunc)
+               free(newfunc);
+       math_error("Evaluation error");
+       /*NOTREACHED*/
+       abort ();
+}
+
+
+static VALUE
+f_prompt(vp)
+       VALUE *vp;
+{
+       VALUE result;
+       char *cp;
+       char *newcp;
+
+       if (inputisterminal()) {
+               printvalue(vp, PRINT_SHORT);
+               math_flush();
+       }
+       cp = nextline();
+       if (cp == NULL)
+               math_error("End of file while prompting");
+       if (*cp == '\0') {
+               result.v_type = V_STR;
+               result.v_subtype = V_STRLITERAL;
+               result.v_str = "";
+               return result;
+       }
+       newcp = (char *)malloc(strlen(cp) + 1);
+       if (newcp == NULL)
+               math_error("Cannot allocate string");
+       strcpy(newcp, cp);
+       result.v_str = newcp;
+       result.v_type = V_STR;
+       result.v_subtype = V_STRALLOC;
+       return result;
+}
+
+
+static VALUE
+f_str(vp)
+       VALUE *vp;
+{
+       VALUE result;
+       static char *cp;
+
+       switch (vp->v_type) {
+               case V_STR:
+                       copyvalue(vp, &result);
+                       return result;
+               case V_NULL:
+                       result.v_str = "";
+                       result.v_type = V_STR;
+                       result.v_subtype = V_STRLITERAL;
+                       return result;
+               case V_NUM:
+                       math_divertio();
+                       qprintnum(vp->v_num, MODE_DEFAULT);
+                       cp = math_getdivertedio();
+                       break;
+               case V_COM:
+                       math_divertio();
+                       comprint(vp->v_com);
+                       cp = math_getdivertedio();
+                       break;
+               default:
+                       math_error("Non-simple type for string conversion");
+       }
+       result.v_str = cp;
+       result.v_type = V_STR;
+       result.v_subtype = V_STRALLOC;
+       return result;
+}
+
+
+static VALUE
+f_poly(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *x;
+       VALUE result, tmp;
+
+       x = vals[--count];
+       copyvalue(*vals++, &result);
+       while (--count > 0) {
+               mulvalue(&result, x, &tmp);
+               freevalue(&result);
+               addvalue(*vals++, &tmp, &result);
+               freevalue(&tmp);
+       }
+       return result;
+}
+
+
+static NUMBER *
+f_mne(val1, val2, val3)
+       NUMBER *val1, *val2, *val3;
+{
+       return itoq((long) qcmpmod(val1, val2, val3));
+}
+
+
+static NUMBER *
+f_isrel(val1, val2)
+       NUMBER *val1, *val2;
+{
+       if (qisfrac(val1) || qisfrac(val2))
+               math_error("Non-integer for isrel");
+       return itoq((long) zrelprime(val1->num, val2->num));
+}
+
+
+static NUMBER *
+f_issquare(vp)
+       NUMBER *vp;
+{
+       return itoq((long) qissquare(vp));
+}
+
+
+static NUMBER *
+f_primetest(val1, val2)
+       NUMBER *val1, *val2;
+{
+       return itoq((long) qprimetest(val1, val2));
+}
+
+
+static NUMBER *
+f_isset(val1, val2)
+       NUMBER *val1, *val2;
+{
+       if (qisfrac(val2))
+               math_error("Non-integral bit position");
+       if (qiszero(val1) || (qisint(val1) && qisneg(val2)))
+               return qlink(&_qzero_);
+       if (zisbig(val2->num)) {
+               if (qisneg(val2))
+                       math_error("Very large bit position");
+               return qlink(&_qzero_);
+       }
+       return itoq((long) qisset(val1, qtoi(val2)));
+}
+
+
+static NUMBER *
+f_digit(val1, val2)
+       NUMBER *val1, *val2;
+{
+       if (qisfrac(val2))
+               math_error("Non-integral digit position");
+       if (qiszero(val1) || (qisint(val1) && qisneg(val2)))
+               return qlink(&_qzero_);
+       if (zisbig(val2->num)) {
+               if (qisneg(val2))
+                       math_error("Very large digit position");
+               return qlink(&_qzero_);
+       }
+       return itoq((long) qdigit(val1, qtoi(val2)));
+}
+
+
+static NUMBER *
+f_digits(val)
+       NUMBER *val;
+{
+       return itoq((long) qdigits(val));
+}
+
+
+static NUMBER *
+f_places(val)
+       NUMBER *val;
+{
+       return itoq((long) qplaces(val));
+}
+
+
+static NUMBER *
+f_xor(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val, *tmp;
+
+       val = qlink(*vals);
+       while (--count > 0) {
+               tmp = qxor(val, *++vals);
+               qfree(val);
+               val = tmp;
+       }
+       return val;
+}
+
+
+static NUMBER *
+f_min(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val, *tmp;
+
+       val = qlink(*vals);
+       while (--count > 0) {
+               tmp = qmin(val, *++vals);
+               qfree(val);
+               val = tmp;
+       }
+       return val;
+}
+
+
+static NUMBER *
+f_max(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val, *tmp;
+
+       val = qlink(*vals);
+       while (--count > 0) {
+               tmp = qmax(val, *++vals);
+               qfree(val);
+               val = tmp;
+       }
+       return val;
+}
+
+
+static NUMBER *
+f_gcd(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val, *tmp;
+
+       val = qabs(*vals);
+       while (--count > 0) {
+               tmp = qgcd(val, *++vals);
+               qfree(val);
+               val = tmp;
+       }
+       return val;
+}
+
+
+static NUMBER *
+f_lcm(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val, *tmp;
+
+       val = qabs(*vals);
+       while (--count > 0) {
+               tmp = qlcm(val, *++vals);
+               qfree(val);
+               val = tmp;
+               if (qiszero(val))
+                       break;
+       }
+       return val;
+}
+
+
+static VALUE
+f_hash(count, vals)
+       int count;
+       VALUE **vals;
+{
+       HASH hash;
+       long lhash;
+       VALUE result;
+
+       hash = 0;
+       while (count-- > 0)
+               hash = hash * 947369 + hashvalue(*vals++);
+       lhash = (long) hash;
+       if (lhash < 0)
+               lhash = -lhash;
+       if (lhash < 0)
+               lhash = 0;
+       result.v_num = itoq(lhash);
+       result.v_type = V_NUM;
+       return result;
+}
+
+
+static VALUE
+f_avg(count, vals)
+       int count;
+       VALUE **vals;
+{
+       int i;
+       VALUE result;
+       VALUE tmp;
+       VALUE div;
+
+       result.v_num = qlink(&_qzero_);
+       result.v_type = V_NUM;
+       for (i = count; i > 0; i--) {
+               addvalue(&result, *vals++, &tmp);
+               freevalue(&result);
+               result = tmp;
+       }
+       if (count <= 1)
+               return result;
+       div.v_num = itoq((long) count);
+       div.v_type = V_NUM;
+       divvalue(&result, &div, &tmp);
+       qfree(div.v_num);
+       return tmp;
+}
+
+
+static NUMBER *
+f_hmean(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val, *tmp, *tmp2, *num;
+
+       num = itoq(count);
+       val = qinv(*vals);
+       while (--count > 0) {
+               tmp2 = qinv(*++vals);
+               tmp = qadd(val, tmp2);
+               qfree(tmp2);
+               qfree(val);
+               val = tmp;
+       }
+       tmp = qdiv(num, val);
+       qfree(num);
+       qfree(val);
+       return tmp;
+}
+
+
+static VALUE
+f_ssq(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result, tmp1, tmp2;
+
+       squarevalue(*vals++, &result);
+       while (--count > 0) {
+               squarevalue(*vals++, &tmp1);
+               addvalue(&tmp1, &result, &tmp2);
+               freevalue(&tmp1);
+               freevalue(&result);
+               result = tmp2;
+       }
+       return result;
+}
+
+
+static NUMBER *
+f_ismult(val1, val2)
+       NUMBER *val1, *val2;
+{
+       return itoq((long) qdivides(val1, val2));
+}
+
+
+static NUMBER *
+f_meq(val1, val2, val3)
+       NUMBER *val1, *val2, *val3;
+{
+       NUMBER *tmp, *res;
+
+       tmp = qsub(val1, val2);
+       res = itoq((long) qdivides(tmp, val3));
+       qfree(tmp);
+       return res;
+}
+
+
+static VALUE
+f_exp(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+       NUMBER *err;
+
+       err = _epsilon_;
+       if (count == 2) {
+               if (vals[1]->v_type != V_NUM)
+                       math_error("Non-real epsilon value for exp");
+               err = vals[1]->v_num;
+       }
+       switch (vals[0]->v_type) {
+               case V_NUM:
+                       result.v_num = qexp(vals[0]->v_num, err);
+                       result.v_type = V_NUM;
+                       break;
+               case V_COM:
+                       result.v_com = cexp(vals[0]->v_com, err);
+                       result.v_type = V_COM;
+                       break;
+               default:
+                       math_error("Bad argument type for exp");
+       }
+       return result;
+}
+
+
+static VALUE
+f_ln(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+       COMPLEX ctmp;
+       NUMBER *err;
+
+       err = _epsilon_;
+       if (count == 2) {
+               if (vals[1]->v_type != V_NUM)
+                       math_error("Non-real epsilon value for ln");
+               err = vals[1]->v_num;
+       }
+       switch (vals[0]->v_type) {
+               case V_NUM:
+                       if (!qisneg(vals[0]->v_num) && !qiszero(vals[0]->v_num)) {
+                               result.v_num = qln(vals[0]->v_num, err);
+                               result.v_type = V_NUM;
+                               break;
+                       }
+                       ctmp.real = vals[0]->v_num;
+                       ctmp.imag = &_qzero_;
+                       ctmp.links = 1;
+                       result.v_com = cln(&ctmp, err);
+                       result.v_type = V_COM;
+                       break;
+               case V_COM:
+                       result.v_com = cln(vals[0]->v_com, err);
+                       result.v_type = V_COM;
+                       break;
+               default:
+                       math_error("Bad argument type for ln");
+       }
+       return result;
+}
+
+
+static VALUE
+f_cos(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+       COMPLEX *c;
+       NUMBER *err;
+
+       err = _epsilon_;
+       if (count == 2) {
+               if (vals[1]->v_type != V_NUM)
+                       math_error("Non-real epsilon value for cos");
+               err = vals[1]->v_num;
+       }
+       switch (vals[0]->v_type) {
+               case V_NUM:
+                       result.v_num = qcos(vals[0]->v_num, err);
+                       result.v_type = V_NUM;
+                       break;
+               case V_COM:
+                       c = ccos(vals[0]->v_com, err);
+                       result.v_com = c;
+                       result.v_type = V_COM;
+                       if (cisreal(c)) {
+                               result.v_num = qlink(c->real);
+                               result.v_type = V_NUM;
+                               comfree(c);
+                       }
+                       break;
+               default:
+                       math_error("Bad argument type for cos");
+       }
+       return result;
+}
+
+
+static VALUE
+f_sin(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+       COMPLEX *c;
+       NUMBER *err;
+
+       err = _epsilon_;
+       if (count == 2) {
+               if (vals[1]->v_type != V_NUM)
+                       math_error("Non-real epsilon value for sin");
+               err = vals[1]->v_num;
+       }
+       switch (vals[0]->v_type) {
+               case V_NUM:
+                       result.v_num = qsin(vals[0]->v_num, err);
+                       result.v_type = V_NUM;
+                       break;
+               case V_COM:
+                       c = csin(vals[0]->v_com, err);
+                       result.v_com = c;
+                       result.v_type = V_COM;
+                       if (cisreal(c)) {
+                               result.v_num = qlink(c->real);
+                               result.v_type = V_NUM;
+                               comfree(c);
+                       }
+                       break;
+               default:
+                       math_error("Bad argument type for sin");
+       }
+       return result;
+}
+
+
+static VALUE
+f_arg(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+       COMPLEX *c;
+       NUMBER *err;
+
+       err = _epsilon_;
+       if (count == 2) {
+               if (vals[1]->v_type != V_NUM)
+                       math_error("Non-real epsilon value for arg");
+               err = vals[1]->v_num;
+       }
+       result.v_type = V_NUM;
+       switch (vals[0]->v_type) {
+               case V_NUM:
+                       if (qisneg(vals[0]->v_num))
+                               result.v_num = qpi(err);
+                       else
+                               result.v_num = qlink(&_qzero_);
+                       break;
+               case V_COM:
+                       c = vals[0]->v_com;
+                       if (ciszero(c))
+                               result.v_num = qlink(&_qzero_);
+                       else
+                               result.v_num = qatan2(c->imag, c->real, err);
+                       break;
+               default:
+                       math_error("Bad argument type for arg");
+       }
+       return result;
+}
+
+
+static NUMBER *
+f_legtoleg(val1, val2)
+       NUMBER *val1, *val2;
+{
+       return qlegtoleg(val1, val2, FALSE);
+}
+
+
+static NUMBER *
+f_trunc(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val;
+
+       val = &_qzero_;
+       if (count == 2)
+               val = vals[1];
+       return qtrunc(*vals, val);
+}
+
+
+static VALUE
+f_bround(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *vp, tmp, res;
+
+       if (count > 1)
+               vp = vals[1];
+       else {
+               tmp.v_type = V_INT;
+               tmp.v_num = 0;
+               vp = &tmp;
+       }
+       broundvalue(vals[0], vp, &res);
+       return res;
+}
+
+
+static VALUE
+f_round(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *vp, tmp, res;
+
+       if (count > 1)
+               vp = vals[1];
+       else {
+               tmp.v_type = V_INT;
+               tmp.v_num = 0;
+               vp = &tmp;
+       }
+       roundvalue(vals[0], vp, &res);
+       return res;
+}
+
+
+static NUMBER *
+f_btrunc(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val;
+
+       val = &_qzero_;
+       if (count == 2)
+               val = vals[1];
+       return qbtrunc(*vals, val);
+}
+
+
+static NUMBER *
+f_near(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       NUMBER *val;
+
+       val = _epsilon_;
+       if (count == 3)
+               val = vals[2];
+       return itoq((long) qnear(vals[0], vals[1], val));
+}
+
+
+static NUMBER *
+f_cfsim(val)
+       NUMBER *val;
+{
+       return qcfappr(val, NULL);
+}
+
+
+static NUMBER *
+f_ceil(val)
+       NUMBER *val;
+{
+       NUMBER *val2;
+
+       if (qisint(val))
+               return qlink(val);
+       val2 = qint(val);
+       if (qisneg(val))
+               return val2;
+       val = qinc(val2);
+       qfree(val2);
+       return val;
+}
+
+
+static NUMBER *
+f_floor(val)
+       NUMBER *val;
+{
+       NUMBER *val2;
+
+       if (qisint(val))
+               return qlink(val);
+       val2 = qint(val);
+       if (!qisneg(val))
+               return val2;
+       val = qdec(val2);
+       qfree(val2);
+       return val;
+}
+
+
+static NUMBER *
+f_highbit(val)
+       NUMBER *val;
+{
+       if (qiszero(val))
+               math_error("Highbit of zero");
+       if (qisfrac(val))
+               math_error("Highbit of non-integer");
+       return itoq(zhighbit(val->num));
+}
+
+
+static NUMBER *
+f_lowbit(val)
+       NUMBER *val;
+{
+       if (qiszero(val))
+               math_error("Lowbit of zero");
+       if (qisfrac(val))
+               math_error("Lowbit of non-integer");
+       return itoq(zlowbit(val->num));
+}
+
+
+static VALUE
+f_sqrt(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *vp, err, result;
+
+       if (count > 1)
+               vp = vals[1];
+       else {
+               err.v_num = _epsilon_;
+               err.v_type = V_NUM;
+               vp = &err;
+       }
+       sqrtvalue(vals[0], vp, &result);
+       return result;
+}
+
+
+static VALUE
+f_root(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *vp, err, result;
+
+       if (count > 2)
+               vp = vals[3];
+       else {
+               err.v_num = _epsilon_;
+               err.v_type = V_NUM;
+               vp = &err;
+       }
+       rootvalue(vals[0], vals[1], vp, &result);
+       return result;
+}
+
+
+static VALUE
+f_power(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *vp, err, result;
+
+       if (count > 2)
+               vp = vals[2];
+       else {
+               err.v_num = _epsilon_;
+               err.v_type = V_NUM;
+               vp = &err;
+       }
+       powervalue(vals[0], vals[1], vp, &result);
+       return result;
+}
+
+
+static VALUE
+f_polar(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *vp, err, result;
+       COMPLEX *c;
+
+       if (count > 2)
+               vp = vals[2];
+       else {
+               err.v_num = _epsilon_;
+               err.v_type = V_NUM;
+               vp = &err;
+       }
+       if ((vals[0]->v_type != V_NUM) || (vals[1]->v_type != V_NUM))
+               math_error("Non-real argument for polar");
+       if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num))
+               math_error("Bad epsilon value for polar");
+       c = cpolar(vals[0]->v_num, vals[1]->v_num, vp->v_num);
+       result.v_com = c;
+       result.v_type = V_COM;
+       if (cisreal(c)) {
+               result.v_num = qlink(c->real);
+               result.v_type = V_NUM;
+               comfree(c);
+       }
+       return result;
+}
+
+
+static NUMBER *
+f_ilog(val1, val2)
+       NUMBER *val1, *val2;
+{
+       return itoq(qilog(val1, val2));
+}
+
+
+static NUMBER *
+f_ilog2(val)
+       NUMBER *val;
+{
+       return itoq(qilog2(val));
+}
+
+
+static NUMBER *
+f_ilog10(val)
+       NUMBER *val;
+{
+       return itoq(qilog10(val));
+}
+
+
+static NUMBER *
+f_faccnt(val1, val2)
+       NUMBER *val1, *val2;
+{
+       return itoq(qdivcount(val1, val2));
+}
+
+
+static VALUE
+f_matfill(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *v1, *v2, *v3;
+       VALUE result;
+
+       v1 = vals[0];
+       v2 = vals[1];
+       v3 = (count == 3) ? vals[2] : NULL;
+       if (v1->v_type != V_ADDR)
+               math_error("Non-variable argument for matfill");
+       v1 = v1->v_addr;
+       if (v1->v_type != V_MAT)
+               math_error("Non-matrix for matfill");
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if (v3 && (v3->v_type == V_ADDR))
+               v3 = v3->v_addr;
+       matfill(v1->v_mat, v2, v3);
+       result.v_type = V_NULL;
+       return result;
+}
+
+
+static VALUE
+f_mattrans(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if (vp->v_type != V_MAT)
+               math_error("Non-matrix argument for mattrans");
+       result.v_type = V_MAT;
+       result.v_mat = mattrans(vp->v_mat);
+       return result;
+}
+
+
+static VALUE
+f_det(vp)
+       VALUE *vp;
+{
+       if (vp->v_type != V_MAT)
+               math_error("Non-matrix argument for det");
+       return matdet(vp->v_mat);
+}
+
+
+static VALUE
+f_matdim(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if (vp->v_type != V_MAT)
+               math_error("Non-matrix argument for matdim");
+       result.v_type = V_NUM;
+       result.v_num = itoq((long) vp->v_mat->m_dim);
+       return result;
+}
+
+
+static VALUE
+f_matmin(v1, v2)
+       VALUE *v1, *v2;
+{
+       VALUE result;
+       NUMBER *q;
+       long i;
+
+       if ((v1->v_type != V_MAT) || (v2->v_type != V_NUM))
+               math_error("Bad argument type for matmin");
+       q = v2->v_num;
+       i = qtoi(q);
+       if (qisfrac(q) || qisneg(q) || (i <= 0) || (i > v1->v_mat->m_dim))
+               math_error("Bad dimension value for matmin");
+       result.v_type = V_NUM;
+       result.v_num = itoq(v1->v_mat->m_min[i - 1]);
+       return result;
+}
+
+
+static VALUE
+f_matmax(v1, v2)
+       VALUE *v1, *v2;
+{
+       VALUE result;
+       NUMBER *q;
+       long i;
+
+       if ((v1->v_type != V_MAT) || (v2->v_type != V_NUM))
+               math_error("Bad argument type for matmax");
+       q = v2->v_num;
+       i = qtoi(q);
+       if (qisfrac(q) || qisneg(q) || (i <= 0) || (i > v1->v_mat->m_dim))
+               math_error("Bad dimension value for matmax");
+       result.v_type = V_NUM;
+       result.v_num = itoq(v1->v_mat->m_max[i - 1]);
+       return result;
+}
+
+
+static VALUE
+f_cp(v1, v2)
+       VALUE *v1, *v2;
+{
+       VALUE result;
+
+       if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
+               math_error("Non-matrix argument for cross product");
+       result.v_type = V_MAT;
+       result.v_mat = matcross(v1->v_mat, v2->v_mat);
+       return result;
+}
+
+
+static VALUE
+f_dp(v1, v2)
+       VALUE *v1, *v2;
+{
+       if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT))
+               math_error("Non-matrix argument for dot product");
+       return matdot(v1->v_mat, v2->v_mat);
+}
+
+
+static VALUE
+f_strlen(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if (vp->v_type != V_STR)
+               math_error("Non-string argument for strlen");
+       result.v_type = V_NUM;
+       result.v_num = itoq((long) strlen(vp->v_str));
+       return result;
+}
+
+
+static VALUE
+f_strcat(count, vals)
+       int count;
+       VALUE **vals;
+{
+       register VALUE **vp;
+       register char *cp;
+       int i;
+       long len;
+       long lengths[IN];
+       VALUE result;
+
+       len = 1;
+       vp = vals;
+       for (i = 0; i < count; i++) {
+               if ((*vp)->v_type != V_STR)
+                       math_error("Non-string argument for strcat");
+               lengths[i] = strlen((*vp)->v_str);
+               len += lengths[i];
+               vp++;
+       }
+       cp = (char *)malloc(len);
+       if (cp == NULL)
+               math_error("No memory for strcat");
+       result.v_str = cp;
+       result.v_type = V_STR;
+       result.v_subtype = V_STRALLOC;
+       i = 0;
+       for (vp = vals; count-- > 0; vp++) {
+               strcpy(cp, (*vp)->v_str);
+               cp += lengths[i++];
+       }
+       return result;
+}
+
+
+static VALUE
+f_substr(v1, v2, v3)
+       VALUE *v1, *v2, *v3;
+{
+       NUMBER *q1, *q2;
+       long i1, i2, len;
+       char *cp;
+       VALUE result;
+
+       if (v1->v_type != V_STR)
+               math_error("Non-string argument for substr");
+       if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
+               math_error("Non-numeric positions for substr");
+       q1 = v2->v_num;
+       q2 = v3->v_num;
+       if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2))
+               math_error("Illegal positions for substr");
+       i1 = qtoi(q1);
+       i2 = qtoi(q2);
+       cp = v1->v_str;
+       len = strlen(cp);
+       result.v_type = V_STR;
+       if (i1 > 0)
+               i1--;
+       if (i1 >= len) {        /* indexing off of end */
+               result.v_subtype = V_STRLITERAL;
+               result.v_str = "";
+               return result;
+       }
+       cp += i1;
+       len -= i1;
+       if ((i2 >= len) && (v1->v_subtype == V_STRLITERAL)) {
+               result.v_subtype = V_STRLITERAL;
+               result.v_str = cp;
+               return result;
+       }
+       if (len > i2)
+               len = i2;
+       if (len == 1) {
+               result.v_subtype = V_STRLITERAL;
+               result.v_str = charstr(*cp);
+               return result;
+       }
+       result.v_subtype = V_STRALLOC;
+       result.v_str = (char *)malloc(len + 1);
+       if (result.v_str == NULL)
+               math_error("No memory for substr");
+       strncpy(result.v_str, cp, len);
+       result.v_str[len] = '\0';
+       return result;
+}
+
+
+static VALUE
+f_char(vp)
+       VALUE *vp;
+{
+       long num;
+       NUMBER *q;
+       VALUE result;
+
+       if (vp->v_type != V_NUM)
+               math_error("Non-numeric argument for char");
+       q = vp->v_num;
+       num = qtoi(q);
+       if (qisneg(q) || qisfrac(q) || zisbig(q->num) || (num > 255))
+               math_error("Illegal number for char");
+       result.v_type = V_STR;
+       result.v_subtype = V_STRLITERAL;
+       result.v_str = charstr((int) num);
+       return result;
+}
+
+
+static VALUE
+f_ord(vp)
+       VALUE *vp;
+{
+       char *str;
+       VALUE result;
+
+       if (vp->v_type != V_STR)
+               math_error("Non-string argument for ord");
+       str = vp->v_str;
+       if (str[0] && str[1])
+               math_error("Multi-character string given for ord");
+       result.v_type = V_NUM;
+       result.v_num = itoq((long) (*str & 0xff));
+       return result;
+}
+
+
+static VALUE
+f_size(vp)
+       VALUE *vp;
+{
+       long count;
+       VALUE result;
+
+       switch (vp->v_type) {
+               case V_NULL:    count = 0; break;
+               case V_MAT:     count = vp->v_mat->m_size; break;
+               case V_LIST:    count = vp->v_list->l_count; break;
+               case V_ASSOC:   count = vp->v_assoc->a_count; break;
+               case V_OBJ:     count = vp->v_obj->o_actions->count; break;
+               default:        count = 1; break;
+       }
+       result.v_type = V_NUM;
+       result.v_num = itoq(count);
+       return result;
+}
+
+
+static VALUE
+f_search(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       long start;
+       long index = -1;
+       VALUE result;
+
+       v1 = *vals++;
+       v2 = *vals++;
+       start = 0;
+       if (count == 3) {
+               if ((*vals)->v_type != V_NUM)
+                       math_error("Non-numeric start index for search");
+               q = (*vals)->v_num;
+               if (qisfrac(q) || qisneg(q))
+                       math_error("Bad start index for search");
+               start = qtoi(q);
+       }
+       switch (v1->v_type) {
+               case V_MAT:
+                       index = matsearch(v1->v_mat, v2, start);
+                       break;
+               case V_LIST:
+                       index = listsearch(v1->v_list, v2, start);
+                       break;
+               case V_ASSOC:
+                       index = assocsearch(v1->v_assoc, v2, start);
+                       break;
+               default:
+                       math_error("Bad argument type for search");
+       }
+       result.v_type = V_NULL;
+       if (index >= 0) {
+               result.v_type = V_NUM;
+               result.v_num = itoq(index);
+       }
+       return result;
+}
+
+
+static VALUE
+f_rsearch(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       long start;
+       long index = -1;
+       VALUE result;
+
+       v1 = *vals++;
+       v2 = *vals++;
+       start = MAXFULL;
+       if (count == 3) {
+               if ((*vals)->v_type != V_NUM)
+                       math_error("Non-numeric start index for rsearch");
+               q = (*vals)->v_num;
+               if (qisfrac(q) || qisneg(q))
+                       math_error("Bad start index for rsearch");
+               start = qtoi(q);
+       }
+       switch (v1->v_type) {
+               case V_MAT:
+                       index = matrsearch(v1->v_mat, v2, start);
+                       break;
+               case V_LIST:
+                       index = listrsearch(v1->v_list, v2, start);
+                       break;
+               case V_ASSOC:
+                       index = assocrsearch(v1->v_assoc, v2, start);
+                       break;
+               default:
+                       math_error("Bad argument type for rsearch");
+       }
+       result.v_type = V_NULL;
+       if (index >= 0) {
+               result.v_type = V_NUM;
+               result.v_num = itoq(index);
+       }
+       return result;
+}
+
+
+static VALUE
+f_list(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+
+       result.v_type = V_LIST;
+       result.v_list = listalloc();
+       while (count-- > 0)
+               insertlistlast(result.v_list, *vals++);
+       return result;
+}
+
+
+/*ARGSUSED*/
+static VALUE
+f_assoc(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+
+       result.v_type = V_ASSOC;
+       result.v_assoc = assocalloc(0L);
+       return result;
+}
+
+
+static VALUE
+f_listinsert(v1, v2, v3)
+       VALUE *v1, *v2, *v3;
+{
+       VALUE result;
+
+       if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
+               math_error("Inserting into non-list variable");
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
+               math_error("Non-integral index for list insert");
+       if (v3->v_type == V_ADDR)
+               v3 = v3->v_addr;
+       insertlistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), v3);
+       result.v_type = V_NULL;
+       return result;
+}
+
+
+static VALUE
+f_listpush(v1, v2)
+       VALUE *v1, *v2;
+{
+       VALUE result;
+
+       if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
+               math_error("Pushing onto non-list variable");
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       insertlistfirst(v1->v_addr->v_list, v2);
+       result.v_type = V_NULL;
+       return result;
+}
+
+
+static VALUE
+f_listappend(v1, v2)
+       VALUE *v1, *v2;
+{
+       VALUE result;
+
+       if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
+               math_error("Appending to non-list variable");
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       insertlistlast(v1->v_addr->v_list, v2);
+       result.v_type = V_NULL;
+       return result;
+}
+
+
+static VALUE
+f_listdelete(v1, v2)
+       VALUE *v1, *v2;
+{
+       VALUE result;
+
+       if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST))
+               math_error("Deleting from non-list variable");
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v2->v_type != V_NUM) || qisfrac(v2->v_num))
+               math_error("Non-integral index for list delete");
+       removelistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), &result);
+       return result;
+}
+
+
+static VALUE
+f_listpop(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
+               math_error("Popping from non-list variable");
+       removelistfirst(vp->v_addr->v_list, &result);
+       return result;
+}
+
+
+static VALUE
+f_listremove(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST))
+               math_error("Removing from non-list variable");
+       removelistlast(vp->v_addr->v_list, &result);
+       return result;
+}
+
+
+/*
+ * Return the current runtime of calc in seconds.
+ * This is the user mode time only.
+ */
+static NUMBER *
+f_runtime()
+{
+       struct tms buf;
+
+       times(&buf);
+       return iitoq((long) buf.tms_utime, (long) CLK_TCK);
+}
+
+
+static VALUE
+f_fopen(v1, v2)
+       VALUE *v1, *v2;
+{
+       VALUE result;
+       FILEID id;
+
+       if (v1->v_type != V_STR)
+               math_error("Non-string filename for fopen");
+       if (v2->v_type != V_STR)
+               math_error("Non-string mode for fopen");
+       id = openid(v1->v_str, v2->v_str);
+       if (id == FILEID_NONE) {
+               result.v_type = V_NUM;
+               result.v_num = itoq((long) errno);
+       } else {
+               result.v_type = V_FILE;
+               result.v_file = id;
+       }
+       return result;
+}
+
+
+static VALUE
+f_fclose(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if (vp->v_type != V_FILE)
+               math_error("Non-file for fclose");
+       if (closeid(vp->v_file)) {
+               result.v_type = V_NUM;
+               result.v_num = itoq((long) errno);
+       } else
+               result.v_type = V_NULL;
+       return result;
+}
+
+
+static VALUE
+f_ferror(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if (vp->v_type != V_FILE)
+               math_error("Non-file for ferror");
+       result.v_type = V_NUM;
+       result.v_num = itoq((long) errorid(vp->v_file));
+       return result;
+}
+
+
+static VALUE
+f_feof(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if (vp->v_type != V_FILE)
+               math_error("Non-file for feof");
+       result.v_type = V_NUM;
+       result.v_num = itoq((long) eofid(vp->v_file));
+       return result;
+}
+
+
+static VALUE
+f_fflush(vp)
+       VALUE *vp;
+{
+       VALUE result;
+
+       if (vp->v_type != V_FILE)
+               math_error("Non-file for fflush");
+       flushid(vp->v_file);
+       result.v_type = V_NULL;
+       return result;
+}
+
+
+static VALUE
+f_fprintf(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+
+       if (vals[0]->v_type != V_FILE)
+               math_error("Non-file for fprintf");
+       if (vals[1]->v_type != V_STR)
+               math_error("Non-string format for fprintf");
+       idprintf(vals[0]->v_file, vals[1]->v_str, count - 2, vals + 2);
+       result.v_type = V_NULL;
+       return result;
+}
+
+
+static VALUE
+f_printf(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+
+       if (vals[0]->v_type != V_STR)
+               math_error("Non-string format for printf");
+       idprintf(FILEID_STDOUT, vals[0]->v_str, count - 1, vals + 1);
+       result.v_type = V_NULL;
+       return result;
+}
+
+
+static VALUE
+f_strprintf(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+
+       if (vals[0]->v_type != V_STR)
+               math_error("Non-string format for strprintf");
+       math_divertio();
+       idprintf(FILEID_STDOUT, vals[0]->v_str, count - 1, vals + 1);
+       result.v_str = math_getdivertedio();
+       result.v_type = V_STR;
+       result.v_subtype = V_STRALLOC;
+       return result;
+}
+
+
+static VALUE
+f_fgetc(vp)
+       VALUE *vp;
+{
+       VALUE result;
+       int ch;
+
+       if (vp->v_type != V_FILE)
+               math_error("Non-file for fgetc");
+       ch = getcharid(vp->v_file);
+       result.v_type = V_NULL;
+       if (ch != EOF) {
+               result.v_type = V_STR;
+               result.v_subtype = V_STRLITERAL;
+               result.v_str = charstr(ch);
+       }
+       return result;
+}
+
+
+static VALUE
+f_fgetline(vp)
+       VALUE *vp;
+{
+       VALUE result;
+       char *str;
+
+       if (vp->v_type != V_FILE)
+               math_error("Non-file for fgetline");
+       readid(vp->v_file, &str);
+       result.v_type = V_NULL;
+       if (str) {
+               result.v_type = V_STR;
+               result.v_subtype = V_STRALLOC;
+               result.v_str = str;
+       }
+       return result;
+}
+
+
+static VALUE
+f_files(count, vals)
+       int count;
+       VALUE **vals;
+{
+       VALUE result;
+
+       if (count == 0) {
+               result.v_type = V_NUM;
+               result.v_num = itoq((long) MAXFILES);
+               return result;
+       }
+       if ((vals[0]->v_type != V_NUM) || qisfrac(vals[0]->v_num))
+               math_error("Non-integer for files");
+       result.v_type = V_NULL;
+       result.v_file = indexid(qtoi(vals[0]->v_num));
+       if (result.v_file != FILEID_NONE)
+               result.v_type = V_FILE;
+       return result;
+}
+
+
+/*
+ * return a numerical 'value' of the mode/base
+ */
+static NUMBER *
+base_value(mode)
+       long mode;      /* a MODE_XYZ value */
+{
+       NUMBER *result;
+
+       /* return the old base */
+       switch (mode) {
+       case MODE_DEFAULT:
+               if (_outmode_ == MODE_DEFAULT) {
+                       result = itoq(10); /* firewall */
+               } else {
+                       result = base_value(_outmode_);
+               }
+               break;
+       case MODE_FRAC:
+               result = qalloc();
+               itoz(3, &result->den);
+               break;
+       case MODE_INT:
+               result = itoq(-10);
+               break;
+       case MODE_REAL:
+               result = itoq(10);
+               break;
+       case MODE_EXP:
+               result = qalloc();
+               ztenpow(20, &result->num);
+               break;
+       case MODE_HEX:
+               result = itoq(16);
+               break;
+       case MODE_OCTAL:
+               result = itoq(8);
+               break;
+       case MODE_BINARY:
+               result = itoq(2);
+               break;
+       default:
+               result = itoq(0);
+               break;
+       }
+       return result;
+}
+
+
+/*
+ * set the default output base/mode
+ */
+static NUMBER *
+f_base(count, vals)
+       int count;
+       NUMBER **vals;
+{
+       long base;      /* output base/mode */
+       long oldbase=0; /* output base/mode */
+
+       /* deal with just a query */
+       if (count != 1) {
+               return base_value(_outmode_);
+       }
+
+       /* deal with the specal modes first */
+       if (qisfrac(vals[0])) {
+               return base_value(math_setmode(MODE_FRAC));
+       }
+       if (vals[0]->num.len > 64/BASEB) {
+               return base_value(math_setmode(MODE_EXP));
+       }
+
+       /* set the base, if possible */
+       base = qtoi(vals[0]);
+       switch (base) {
+       case -10:
+               oldbase = math_setmode(MODE_INT);
+               break;
+       case 2:
+               oldbase = math_setmode(MODE_BINARY);
+               break;
+       case 8:
+               oldbase = math_setmode(MODE_OCTAL);
+               break;
+       case 10:
+               oldbase = math_setmode(MODE_REAL);
+               break;
+       case 16:
+               oldbase = math_setmode(MODE_HEX);
+               break;
+       default:
+               math_error("Unsupported base");
+               break;
+       }
+
+       /* return the old base */
+       return base_value(oldbase);
+}
+
+
+/*
+ * Show the list of primitive built-in functions
+ */
+void
+showbuiltins()
+{
+       register struct builtin *bp;    /* current function */
+
+       printf("\nName\tArgs\tDescription\n\n");
+       for (bp = builtins; bp->b_name; bp++) {
+               printf("%-9s ", bp->b_name);
+               if (bp->b_maxargs == IN)
+                       printf("%d+    ", bp->b_minargs);
+               else if (bp->b_minargs == bp->b_maxargs)
+                       printf("%-6d", bp->b_minargs);
+               else
+                       printf("%d-%-4d", bp->b_minargs, bp->b_maxargs);
+               printf(" %s\n", bp->b_desc);
+       }
+       printf("\n");
+}
+
+
+/*
+ * Return the index of a built-in function given its name.
+ * Returns minus one if the name is not known.
+ */
+int
+getbuiltinfunc(name)
+       char *name;
+{
+       register struct builtin *bp;
+
+       for (bp = builtins; bp->b_name; bp++) {
+               if ((*name == *bp->b_name) && (strcmp(name, bp->b_name) == 0))
+               return (bp - builtins);
+       }
+       return -1;
+}
+
+
+/*
+ * Given the index of a built-in function, return its name.
+ */
+char *
+builtinname(index)
+       long index;
+{
+       if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
+               return "";
+       return builtins[index].b_name;
+}
+
+
+/*
+ * Given the index of a built-in function, and the number of arguments seen,
+ * determine if the number of arguments are legal.  This routine is called
+ * during parsing time.
+ */
+void
+builtincheck(index, count)
+       int count;
+       long index;
+{
+       register struct builtin *bp;
+
+       if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
+               math_error("Unknown built in index");
+       bp = &builtins[index];
+       if (count < bp->b_minargs)
+               scanerror(T_NULL, "Too few arguments for builtin function \"%s\"",
+       bp->b_name);
+       if (count > bp->b_maxargs)
+               scanerror(T_NULL, "Too many arguments for builtin function \"%s\"",
+                       bp->b_name);
+}
+
+
+/*
+ * Return the opcode for a built-in function that can be used to avoid
+ * the function call at all.
+ */
+int
+builtinopcode(index)
+       long index;
+{
+       if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1)
+               return OP_NOP;
+       return builtins[index].b_opcode;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/func.h b/usr/src/contrib/calc-2.9.3t6/func.h
new file mode 100644 (file)
index 0000000..8bd9b28
--- /dev/null
@@ -0,0 +1,80 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ */
+
+
+#ifndef        FUNC_H
+#define        FUNC_H
+
+#include "calc.h"
+#include "label.h"
+
+
+/*
+ * Structure of a function.
+ * The f_opcodes array is actually of variable size.
+ */
+typedef struct func FUNC;
+struct func {
+       FUNC *f_next;                   /* next function in list */
+       unsigned long f_opcodecount;    /* size of opcode array */
+       unsigned int f_localcount;      /* number of local variables */
+       unsigned int f_paramcount;      /* max number of parameters */
+       char *f_name;                   /* function name */
+       VALUE f_savedvalue;             /* saved value of last expression */
+       long f_opcodes[1];              /* array of opcodes (variable length) */
+};
+
+
+/*
+ * Amount of space needed to allocate a function of n opcodes.
+ */
+#define funcsize(n) (sizeof(FUNC) + (n) * sizeof(long))
+
+
+/*
+ * Size of a character pointer rounded up to a number of opcodes.
+ */
+#define PTR_SIZE ((sizeof(char *) + sizeof(long) - 1) / sizeof(long))
+
+
+/*
+ * The current function being compiled.
+ */
+extern FUNC *curfunc;
+
+
+/*
+ * Functions to handle functions.
+ */
+extern FUNC *findfunc MATH_PROTO((long index));
+extern char *namefunc MATH_PROTO((long index));
+extern BOOL evaluate MATH_PROTO((BOOL nestflag));
+extern long adduserfunc MATH_PROTO((char *name));
+extern void beginfunc MATH_PROTO((char *name, BOOL newflag));
+extern int builtinopcode MATH_PROTO((long index));
+extern char *builtinname MATH_PROTO((long index));
+extern int dumpop MATH_PROTO((long *pc));
+extern void addop MATH_PROTO((long op));
+extern void endfunc MATH_PROTO((void));
+extern void addopone MATH_PROTO((long op, long arg));
+extern void addoptwo MATH_PROTO((long op, long arg1, long arg2));
+extern void addoplabel MATH_PROTO((long op, LABEL *label));
+extern void addopptr MATH_PROTO((long op, char *ptr));
+extern void writeindexop MATH_PROTO((void));
+extern void showbuiltins MATH_PROTO((void));
+extern int getbuiltinfunc MATH_PROTO((char *name));
+extern void builtincheck MATH_PROTO((long index, int count));
+extern void addopfunction MATH_PROTO((long op, long index, int count));
+extern void showfunctions MATH_PROTO((void));
+extern void initfunctions MATH_PROTO((void));
+extern void clearopt MATH_PROTO((void));
+extern void updateoldvalue MATH_PROTO((FUNC *fp));
+extern void calculate MATH_PROTO((FUNC *fp, int argcount));
+extern VALUE builtinfunc MATH_PROTO((long index, int argcount, VALUE *stck));
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/help/Makefile b/usr/src/contrib/calc-2.9.3t6/help/Makefile
new file mode 100644 (file)
index 0000000..f2c11c4
--- /dev/null
@@ -0,0 +1,123 @@
+#
+# help - makefile for calc help files
+#
+# Copyright (c) 1994 David I. Bell and Landon Curt Noll
+# Permission is granted to use, distribute, or modify this source,
+# provided that this copyright notice remains intact.
+#
+# Arbitrary precision calculator.
+#
+# calculator by David I. Bell
+# makefile by Landon Curt Noll
+
+SHELL= /bin/sh
+
+# Normally, the upper level makefile will set these values.  We provide
+# a default here just in case you want to build from this directory.
+#
+TOPDIR= /usr/local/lib
+#TOPDIR= /usr/lib
+#TOPDIR= /usr/libdata
+
+LIBDIR= ${TOPDIR}/calc
+HELPDIR= ${LIBDIR}/help
+
+# standard tools
+SED= sed
+
+# Standard help files
+#
+# The obj.file is special and is not listed here.
+#
+STD_HELP_FILES1= intro overview help assoc builtin command config \
+       define environment expression file history interrupt list mat
+STD_HELP_FILES2= operator statement types usage variable
+STD_HELP_FILES3= todo credit
+STD_HELP_FILES= ${STD_HELP_FILES1} ${STD_HELP_FILES2} ${STD_HELP_FILES3}
+
+# Help files that are constructed from other sources
+#
+# The obj.file is special and is not listed here.
+#
+BUILT_HELP_FILES= bindings altbind changes libcalc stdlib bugs
+
+all: ${STD_HELP_FILES} obj.file ${BUILT_HELP_FILES} full
+
+bindings: ../lib/bindings
+       rm -f bindings
+       cp ../lib/bindings bindings
+       chmod 0444 bindings
+
+altbind: ../lib/altbind
+       rm -f altbind
+       cp ../lib/altbind altbind
+       chmod 0444 altbind
+
+stdlib: ../lib/README
+       rm -f stdlib
+       cp ../lib/README stdlib
+       chmod 0444 stdlib
+
+changes: ../CHANGES
+       rm -f changes
+       cp ../CHANGES changes
+       chmod 0444 changes
+
+libcalc: ../LIBRARY
+       rm -f libcalc
+       ${SED} -e 's:$${LIBDIR}:${LIBDIR}:g' < ../LIBRARY > libcalc
+       chmod 0444 libcalc
+
+bugs: ../BUGS
+       rm -f bugs
+       cp ../BUGS bugs
+       chmod 0444 bugs
+
+full: ${STD_HELP_FILES} ${BUILT_HELP_FILES} Makefile
+       rm -f full
+       -for i in ${STD_HELP_FILES1} obj.file ${STD_HELP_FILES2} \
+           ${BUILT_HELP_FILES} ${STD_HELP_FILES3}; do \
+           if [ Xintro != X"$$i" ]; then \
+               echo "\f"; \
+           fi; \
+           if [ Xobj.file = X"$$i" ]; then \
+               j=obj; \
+           else \
+               j=$$i; \
+           fi; \
+           echo "*************"; \
+           echo "* $$j"; \
+           echo "*************"; \
+           echo ""; \
+           cat $$i; \
+       done > full
+
+clean:
+
+clobber:
+       rm -f ${BUILT_HELP_FILES} full
+
+install: all
+       -@if [ ! -d ${TOPDIR} ]; then \
+               echo mkdir ${TOPDIR}; \
+               mkdir ${TOPDIR}; \
+       fi
+       -@if [ ! -d ${LIBDIR} ]; then \
+               echo mkdir ${LIBDIR}; \
+               mkdir ${LIBDIR}; \
+       fi
+       -@if [ ! -d ${HELPDIR} ]; then \
+               echo mkdir ${HELPDIR}; \
+               mkdir ${HELPDIR}; \
+       fi
+       @for i in ${STD_HELP_FILES} ${BUILT_HELP_FILES} full; do \
+               echo rm -f ${HELPDIR}/$$i; \
+               rm -f ${HELPDIR}/$$i; \
+               echo cp $$i ${HELPDIR}; \
+               cp $$i ${HELPDIR}; \
+               echo chmod 0444 ${HELPDIR}/$$i; \
+               chmod 0444 ${HELPDIR}/$$i; \
+       done
+       rm -f ${HELPDIR}/obj
+       cp obj.file ${HELPDIR}/obj
+       chmod 0444 ${HELPDIR}/obj
diff --git a/usr/src/contrib/calc-2.9.3t6/help/assoc b/usr/src/contrib/calc-2.9.3t6/help/assoc
new file mode 100644 (file)
index 0000000..c644048
--- /dev/null
@@ -0,0 +1,55 @@
+Using associations
+
+       Associations are special values that act like matrices, except
+       that they are more general (and slower) than normal matrices.
+       Unlike matrices, associations can be indexed by arbitrary values.
+       For example, if 'val' was an association, you could do the following:
+
+               val['hello'] = 11;
+               val[4.5] = val['hello'];
+               print val[9/2];
+
+       and 11 would be printed.
+
+       Associations are created by the 'assoc' function.  It takes no
+       arguments, and simply returns an empty association.  You can then
+       insert elements into the association by indexing the returned value
+       as shown above.
+
+       Associations are multi-dimensional.  You can index them using one to
+       four dimensions as desired, and the elements with different numbers
+       of dimensions will remain separated.  For example, 'val[3]' and
+       'val[3,0]' can both be used in the same association and will be
+       distinct elements.
+
+       When references are made to undefined elements of an association,
+       a null value is simply returned.  Therefore no bounds errors can
+       occur when indexing an association.  Assignments of a null value
+       to an element of an association does not delete the element, but
+       a later reference to that element will return the null value as if
+       the element was undefined.  Elements with null values are implicitly
+       created on certain other operations which require an address to be
+       taken, such as the += operator and using & in a function call.
+
+       The elements of an association are stored in a hash table for
+       quick access.  The index values are hashed to select the correct
+       hash chain for a small sequential search for the element.  The hash
+       table will be resized as necessary as the number of entries in
+       the association becomes larger.
+
+       The size function returns the number of elements in an association.
+       This size will include elements with null values.
+
+       Double bracket indexing can be used for associations to walk through
+       the elements of the association.  The order that the elements are
+       returned in as the index increases is essentially random.  Any
+       change made to the association can reorder the elements, this making
+       a sequential scan through the elements difficult.
+
+       The search and rsearch functions can search for an element in an
+       association which has the specified value.  They return the index
+       of the found element, or a NULL value if the value was not found.
+
+       Associations can be copied by an assignment, and can be compared
+       for equality.  But no other operations on associations have meaning,
+       and are illegal.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/builtin b/usr/src/contrib/calc-2.9.3t6/help/builtin
new file mode 100644 (file)
index 0000000..dc62b1f
--- /dev/null
@@ -0,0 +1,285 @@
+Builtin functions
+
+       There is a large number of built-in functions.  Many of the
+       functions work on several types of arguments, whereas some only
+       work for the correct types (e.g., numbers or strings).  In the
+       following description, this is indicated by whether or not the
+       description refers to values or numbers.  This display is generated
+       by the 'show builtin' command.
+
+           Name      Args   Description
+
+           abs       1-2    absolute value within accuracy b
+           acos      1-2    arccosine of a within accuracy b
+           acosh     1-2    hyperbolic arccosine of a within accuracy b
+           append    2      append value to end of list
+           appr      1-2    approximate a with simpler fraction to within b
+           arg       1-2    argument (the angle) of complex number
+           asin      1-2    arcsine of a within accuracy b
+           asinh     1-2    hyperbolic arcsine of a within accuracy b
+           assoc     0      create new association array
+           atan      1-2    arctangent of a within accuracy b
+           atan2     2-3    angle to point (b,a) within accuracy c
+           atanh     1-2    hyperbolic arctangent of a within accuracy b
+           avg       1+     arithmetic mean of values
+           base      0-1    get/set default output base
+           bround    1-2    round value a to b number of binary places
+           btrunc    1-2    truncate a to b number of binary places
+           ceil      1      smallest integer greater than or equal to number
+           cfappr    1-2    approximate a within accuracy b using
+                               continued fractions
+           cfsim     1      simplify number using continued fractions
+           char      1      character corresponding to integer value
+           cmp       2      compare values returning -1, 0, or 1
+           comb      2      combinatorial number a!/b!(a-b)!
+           config    1-2    set or read configuration value
+           conj      1      complex conjugate of value
+           cos       1-2    cosine of value a within accuracy b
+           cosh      1-2    hyperbolic cosine of a within accuracy b
+           cp        2      cross product of two vectors
+           delete    2      delete element from list a at position b
+           den       1      denominator of fraction
+           det       1      determinant of matrix
+           digit     2      digit at specified decimal place of number
+           digits    1      number of digits in number
+           dp        2      dot product of two vectors
+           epsilon   0-1    set or read allowed error for real calculations
+           eval      1      evaluate expression from string to value
+           exp       1-2    exponential of value a within accuracy b
+           fcnt      2      count of times one number divides another
+           fib       1      Fibonacci number F(n)
+           frem      2      number with all occurrences of factor removed
+           fact      1      factorial
+           fclose    1      close file
+           feof      1      whether EOF reached for file
+           ferror    1      whether error occurred for file
+           fflush    1      flush output to file
+           fgetc     1      read next char from file
+           fgetline  1      read next line from file
+           files     0-1    return opened file or max number of opened files
+           floor     1      greatest integer less than or equal to number
+           fopen     2      open file name a in mode b
+           fprintf   2+     print formatted output to opened file
+           frac      1      fractional part of value
+           gcd       1+     greatest common divisor
+           gcdrem    2      a divided repeatedly by gcd with b
+           hash      1+     return non-negative hash value for one or
+                               more values
+           highbit   1      high bit number in base 2 representation
+           hmean     1+     harmonic mean of values
+           hypot     2-3    hypotenuse of right triangle within accuracy c
+           ilog      2      integral log of one number with another
+           ilog10    1      integral log of a number base 10
+           ilog2     1      integral log of a number base 2
+           im        1      imaginary part of complex number
+           insert    3      insert value c into list a at position b
+           int       1      integer part of value
+           inverse   1      multiplicative inverse of value
+           iroot     2      integer b'th root of a
+           isassoc   1      whether a value is an association
+           iseven    1      whether a value is an even integer
+           isfile    1      whether a value is a file
+           isint     1      whether a value is an integer
+           islist    1      whether a value is a list
+           ismat     1      whether a value is a matrix
+           ismult    2      whether a is a multiple of b
+           isnull    1      whether a value is the null value
+           isnum     1      whether a value is a number
+           isobj     1      whether a value is an object
+           isodd     1      whether a value is an odd integer
+           isqrt     1      integer part of square root
+           isreal    1      whether a value is a real number
+           isset     2      whether bit b of abs(a) (in base 2) is set
+           isstr     1      whether a value is a string
+           isrel     2      whether two numbers are relatively prime
+           issimple  1      whether value is a simple type
+           issq      1      whether or not number is a square
+           istype    2      whether the type of a is same as the type of b
+           jacobi    2      -1 => a is not quadratic residue mod b
+                             1 => b is composite, or a is quad residue of b
+           lcm       1+     least common multiple
+           lcmfact   1      lcm of all integers up till number
+           lfactor   2      lowest prime factor of a in first b primes
+           list      0+     create list of specified values
+           ln        1-2    natural logarithm of value a within accuracy b
+           lowbit    1      low bit number in base 2 representation
+           ltol      1-2    leg-to-leg of unit right triangle (sqrt(1 - a^2))
+           matdim    1      number of dimensions of matrix
+           matfill   2-3    fill matrix with value b (value c on diagonal)
+           matmax    2      maximum index of matrix a dim b
+           matmin    2      minimum index of matrix a dim b
+           mattrans  1      transpose of matrix
+           max       1+     maximum value
+           meq       3      whether a and b are equal modulo c
+           min       1+     minimum value
+           minv      2      inverse of a modulo b
+           mmin      2      a mod b value with smallest abs value
+           mne       3      whether a and b are not equal modulo c
+           near      2-3    sign of (abs(a-b) - c)
+           norm      1      norm of a value (square of absolute value)
+           null      0      null value
+           num       1      numerator of fraction
+           ord       1      integer corresponding to character value
+           param     1      value of parameter n (or parameter count if n
+                               is zero)
+           perm      2      permutation number a!/(a-b)!
+           pfact     1      product of primes up till number
+           pi        0-1    value of pi accurate to within epsilon
+           places    1      places after decimal point (-1 if infinite)
+           pmod      3      mod of a power (a ^ b (mod c))
+           polar     2-3    complex value of polar coordinate (a * exp(b*1i))
+           poly      2+     (a1,a2,...,an,x) = a1*x^n+a2*x^(n-1)+...+an
+           pop       1      pop value from front of list
+           power     2-3    value a raised to the power b within accuracy c
+           ptest     2      probabilistic primality test
+           printf    1+     print formatted output to stdout
+           prompt    1      prompt for input line using value a
+           push      2      push value onto front of list
+           quomod    4      set c and d to quotient and remainder of a
+                               divided by b
+           rcin      2      convert normal number a to REDC number mod b
+           rcmul     3      multiply REDC numbers a and b mod c
+           rcout     2      convert REDC number a mod b to normal number
+           rcpow     3      raise REDC number a to power b mod c
+           rcsq      2      square REDC number a mod b
+           re        1      real part of complex number
+           remove    1      remove value from end of list
+           root      2-3    value a taken to the b'th root within accuracy c
+           round     1-2    round value a to b number of decimal places
+           rsearch   2-3    reverse search matrix or list for value b
+                               starting at index c
+           runtime   0      user mode cpu time in seconds
+           scale     2      scale value up or down by a power of two
+           search    2-3    search matrix or list for value b starting
+                               at index c
+           sgn       1      sign of value (-1, 0, 1)
+           sin       1-2    sine of value a within accuracy b
+           sinh      1-2    hyperbolic sine of a within accuracy b
+           size      1      total number of elements in value
+           sqrt      1-2    square root of value a within accuracy b
+           ssq       1+     sum of squares of values
+           str       1      simple value converted to string
+           strcat    1+     concatenate strings together
+           strlen    1      length of string
+           strprintf 1+     return formatted output as a string
+           substr    3      substring of a from position b for c chars
+           swap      2      swap values of variables a and b (can be dangerous)
+           tan       1-2    tangent of a within accuracy b
+           tanh      1-2    hyperbolic tangent of a within accuracy b
+           trunc     1-2    truncate a to b number of decimal places
+           xor       1+     logical xor
+
+       The config function sets or reads the value of a configuration
+       parameter.  The first argument is a string which names the parameter
+       to be set or read.  If only one argument is given, then the current
+       value of the named parameter is returned.  If two arguments are given,
+       then the named parameter is set to the value of the second argument,
+       and the old value of the parameter is returned.  Therefore you can
+       change a parameter and restore its old value later.  The possible
+       parameters are explained in the next section.
+
+       The scale function multiplies or divides a number by a power of 2.
+       This is used for fractional calculations, unlike the << and >>
+       operators, which are only defined for integers.  For example,
+       scale(6, -3) is 3/4.
+
+       The quomod function is used to obtain both the quotient and remainder
+       of a division in one operation.  The first two arguments a and b are
+       the numbers to be divided.  The last two arguments c and d are two
+       variables which will be assigned the quotient and remainder.  For
+       nonnegative arguments, the results are equivalent to computing a//b
+       and a%b.  If a is negative and the remainder is nonzero, then the
+       quotient will be one less than a//b.  This makes the following three
+       properties always hold:  The quotient c is always an integer.  The
+       remainder d is always 0 <= d < b.  The equation a = b * c + d always
+       holds.  This function returns 0 if there is no remainder, and 1 if
+       there is a remainder.  For examples, quomod(10, 3, x, y) sets x to 3,
+       y to 1, and returns the value 1, and quomod(-4, 3.14159, x, y) sets x
+       to -2, y to 2.28318, and returns the value 1.
+
+       The eval function accepts a string argument and evaluates the
+       expression represented by the string and returns its value.
+       The expression can include function calls and variable references.
+       For example, eval("fact(3) + 7") returns 13.  When combined with
+       the prompt function, this allows the calculator to read values from
+       the user.  For example, x=eval(prompt("Number: ")) sets x to the
+       value input by the user.
+
+       The digit and isset functions return individual digits of a number,
+       either in base 10 or in base 2, where the lowest digit of a number
+       is at digit position 0.  For example, digit(5678, 3) is 5, and
+       isset(0b1000100, 2) is 1.  Negative digit positions indicate places
+       to the right of the decimal or binary point, so that for example,
+       digit(3.456, -1) is 4.
+
+       The ptest function is a primality testing function.  The first
+       argument is the suspected prime to be tested.  The second argument
+       is an iteration count.  The function returns 0 if the number is
+       definitely not prime, and 1 is the number is probably prime.  The
+       chance of a number which is probably prime being actually composite
+       is less than 1/4 raised to the power of the iteration count.  For
+       example, for a random number p, ptest(p, 10) incorrectly returns 1
+       less than once in every million numbers, and you will probably never
+       find a number where ptest(p, 20) gives the wrong answer.
+
+       The functions rcin, rcmul, rcout, rcpow, and rcsq are used to
+       perform modular arithmetic calculations for large odd numbers
+       faster than the usual methods.  To do this, you first use the
+       rcin function to convert all input values into numbers which are
+       in a format called REDC format.  Then you use rcmul, rcsq, and
+       rcpow to multiply such numbers together to produce results also
+       in REDC format.  Finally, you use rcout to convert a number in
+       REDC format back to a normal number.  The addition, subtraction,
+       negation, and equality comparison between REDC numbers are done
+       using the normal modular methods.  For example, to calculate the
+       value 13 * 17 + 1 (mod 11), you could use:
+
+               p = 11;
+               t1 = rcin(13, p);
+               t2 = rcin(17, p);
+               t3 = rcin(1, p);
+               t4 = rcmul(t1, t2, p);
+               t5 = (t4 + t3) % p;
+               answer = rcout(t5, p);
+
+       The swap function exchanges the values of two variables without
+       performing copies.  For example, after:
+
+               x = 17;
+               y = 19;
+               swap(x, y);
+
+       then x is 19 and y is 17.  This function should not be used to
+       swap a value which is contained within another one.  If this is
+       done, then some memory will be lost.  For example, the following
+       should not be done:
+
+               mat x[5];
+               swap(x, x[0]);
+
+       The hash function returns a relatively small non-negative integer
+       for one or more input values.  The hash values should not be used
+       across runs of the calculator, since the algorithms used to generate
+       the hash value may change with different versions of the calculator.
+
+       The base function allows one to specify how numbers should be
+       printer.  The base function provides a numeric shorthand to the
+       config("mode") interface.  With no args, base() will return the
+       current mode.  With 1 arg, base(val) will set the mode according to
+       the arg and return the previous mode.
+
+       The following convention is used to declare modes:
+
+                base    config
+               value    string
+
+                  2    "binary"        binary fractions
+                  8    "octal"         octal fractions
+                 10    "real"          decimal floating point
+                 16    "hex"           hexadecimal fractions
+                -10    "int"           decimal integer
+                1/3    "frac"          decimal fractions
+               1e20    "exp"           decimal exponential
+       
+       For convenience, any non-integer value is assumed to mean "frac",
+       and any integer >= 2^64 is assumed to mean "exp".
diff --git a/usr/src/contrib/calc-2.9.3t6/help/command b/usr/src/contrib/calc-2.9.3t6/help/command
new file mode 100644 (file)
index 0000000..6cf440e
--- /dev/null
@@ -0,0 +1,82 @@
+Command sequence
+
+       This is a sequence of any the following command formats, where
+       each command is terminated by a semicolon or newline.  Long command
+       lines can be extended by using a back-slash followed by a newline
+       character.  When this is done, the prompt shows a double angle
+       bracket to indicate that the line is still in progress.  Certain
+       cases will automatically prompt for more input in a similar manner,
+       even without the back-slash.  The most common case for this is when
+       a function is being defined, but is not yet completed.
+
+       Each command sequence terminates only on an end of file.  In
+       addition, commands can consist of expression sequences, which are
+       described in the next section.
+
+
+       NOTE: Calc commands are in lower case.   UPPER case is used below
+             for emphasis only, and should be considered in lower case.
+
+
+       DEFINE function(params) { body }
+       DEFINE function(params) = expression
+               This first form defines a full function which can consist
+               of declarations followed by many statements which implement
+               the function.
+
+               The second form defines a simple function which calculates
+               the specified expression value from the specified parameters.
+               The expression cannot be a statement.  However, the comma
+               and question mark operators can be useful.  Examples of
+               simple functions are:
+
+                       define sumcubes(a, b) = a^3 + b^3;
+                       define pimod(a) = a % pi();
+
+       HELP
+               This displays a general help message.
+
+       READ filename
+               This reads definitions from the specified filename.
+               The name can be quoted if desired.  The calculator
+               uses the CALCPATH environment variable to search
+               through the specified directories for the filename,
+               similarly to the use of the PATH environment variable.
+               If CALCPATH is not defined, then a default path which is
+               usually ":/usr/local/lib/calc" is used (that is, the current 
+               directory followed by a general calc library directory).  
+               The ".cal" extension is defaulted for input files, so 
+               that if "filename" is not found, then "filename.cal" is 
+               then searched for.  The contents of the filename are 
+               command sequences which can consist of expressions to 
+               evaluate or functions to define, just like at the top 
+               level command level.
+
+       READ -once filename
+               This command acts like the regular READ expect that it 
+               will ignore filename if is has been previously read.
+
+               This command is particularly useful in a library that
+               needs to read a 2nd library.  By using the READ -once
+               command, one will not reread that 2nd library, nor will
+               once risk entering into a infinite READ loop (where
+               that 2nd library directly or indirectly does a READ of
+               the first library).
+
+       WRITE filename
+               This writes the values of all global variables to the
+               specified filename, in such a way that the file can be
+               later read in order to recreate the variable values.
+               For speed reasons, values are written as hex fractions.
+               This command currently only saves simple types, so that
+               matrices, lists, and objects are not saved.  Function
+               definitions are also not saved.
+
+       QUIT
+               This leaves the calculator, when given as a top-level
+               command.
+
+
+       Also see the help topic:
+
+               statement       flow control and declaration statements
diff --git a/usr/src/contrib/calc-2.9.3t6/help/config b/usr/src/contrib/calc-2.9.3t6/help/config
new file mode 100644 (file)
index 0000000..eb84b0b
--- /dev/null
@@ -0,0 +1,114 @@
+Configuration parameters
+
+       Configuration parameters affect how the calculator performs certain
+       operations, and affects all future calculations.  These parameters
+       affect the accuracy of calculations, the displayed format of results,
+       and which algorithms are used for calculations.  The parameters are
+       read or set using the "config" built-in function.  The following
+       parameters can be specified:
+
+               "trace"         turns tracing on or off (for debugging).
+               "display"       sets number of digits in prints.
+               "epsilon"       sets error value for transcendentals.
+               "maxprint"      sets maximum number of elements printed.
+               "mode"          sets printout mode.
+               "mul2"          sets size for alternative multiply.
+               "sq2"           sets size for alternative squaring.
+               "pow2"          sets size for alternate powering.
+               "redc2"         sets size for alternate REDC.
+               "tilde"         enable/disable printing of the roundoff '~'
+               "tab"           enable/disable printing of leading tabs
+
+       The use of the trace flag is for debugging, and its meaning may
+       change in the future.  A value of 1 causes the calculator to print
+       its internal opcodes as it executes functions.  A value of zero
+       disables tracing again.
+
+       Display specifies how many digits after the decimal point should
+       be printed when printing real or exponential numbers.  The initial
+       display value is 20.  This parameter does not affect the accuracy
+       of a calculation, since it only has meaning when printing results.
+
+       Epsilon specifies the required precision of calculations by
+       setting the maximum allowed error for transcendental functions.
+       The error is an absolute error value for many functions, but
+       for some functions it is a relative error.  The initial value
+       is 1e-20.  Functions which require an epsilon value accept an
+       optional argument which overrides this default epsilon value for
+       that single call.  The built-in function "epsilon" also can be
+       used to read or set this value, and is provided for ease of use.
+
+       Mode specifies how numbers should be printed.  Mode is a string
+       value indicating the printout method.  The initial mode is "real".
+       Possible modes are:
+
+               "frac"          decimal fractions
+               "int"           decimal integer
+               "real"          decimal floating point
+               "exp"           decimal exponential
+               "hex"           hex fractions
+               "oct"           octal fractions
+               "bin"           binary fractions
+
+       Maxprint specifies the maximum number of elements to be displayed
+       when a matrix or list is printed.  The initial value is 16 elements.
+
+       Mul2 and sq2 specify the sizes of numbers at which calc switches
+       from its first to its second algorithm for multiplying and squaring.
+       The first algorithm is the usual method of cross multiplying, which
+       runs in a time of O(N^2).  The second method is a recursive and
+       complicated method which runs in a time of O(N^1.585).  The argument
+       for these parameters is the number of binary words at which the
+       second algorithm begins to be used.  The minimum value is 2, and
+       the maximum value is very large.  If 2 is used, then the recursive
+       algorithm is used all the way down to single digits, which becomes
+       slow since the recursion overhead is high.  If a number such as
+       1000000 is used, then the recursive algorithm is never used, causing
+       calculations for large numbers to slow down.  For a typical example
+       on a 386, the two algorithms are about equal in speed for a value
+       of 20, which is about 100 decimal digits.  A value of zero resets
+       the parameter back to its default value.  Usually there is no need
+       to change these parameters.
+
+       Pow2 specifies the sizes of numbers at which calc switches from
+       its first to its second algorithm for calculating powers modulo
+       another number.  The first algorithm for calculating modular powers
+       is by repeated squaring and multiplying and dividing by the modulus.
+       The second method uses the REDC algorithm given by Peter Montgomery
+       which avoids divisions.  The argument for pow2 is the size of the
+       modulus at which the second algorithm begins to be used.
+
+       Redc2 specifies the sizes of numbers at which calc switches from
+       its first to its second algorithm when using the REDC algorithm.
+       The first algorithm performs a multiply and a modular reduction
+       together in one loop which runs in O(N^2).  The second algorithm
+       does the REDC calculation using three multiplies, and runs in
+       O(N^1.585).  The argument for redc2 is the size of the modulus at
+       which the second algorithm begins to be used.
+
+       Tilde controls the printing of a leading tilde ('~') in front
+       of rounded values.  By default for integer, real, or exponential 
+       formats, a leading '~' indicates that the number was truncated 
+       to the number of decimal places specified by the default precision.
+       The second config arg may be any truth value.
+
+       Tab controls the printing of a tab before values.  By default,
+       printed expressions proceeded by a tab.  This config option
+       does not control the format of functions such as print or printf.
+       The second config arg may be any truth value.
+
+       The following are synonyms for true:
+
+           "on"   "yes"   "y"   "true"   "t"   "1"   any non-zero number
+
+       The following are synonyms for false:
+
+           "off"  "no"    "n"   "false"  "f"   "0"   the number zero (0)
+
+       Examples of setting some parameters are:
+
+               config("mode", "exp");      exponential output
+               config("display", 50);      50 digits of output
+               epsilon(epsilon() / 8);     3 bits more accuracy
+               config("tilde", 0)          disable roundoff tilde printing
+               config("tab", "off")        disable leading tab printing
diff --git a/usr/src/contrib/calc-2.9.3t6/help/credit b/usr/src/contrib/calc-2.9.3t6/help/credit
new file mode 100644 (file)
index 0000000..1bea6c2
--- /dev/null
@@ -0,0 +1,36 @@
+Credits
+
+       Written by David I. Bell.
+
+       Thanks for suggestions and encouragement from Peter Miller,
+       Neil Justusson, and Landon Noll.
+
+       Thanks to Stephen Rothwell for writing the original version of
+       hist.c which is used to do the command line editing.
+
+       Thanks to Ernest W. Bowen for supplying some improvements in
+       accuracy and generality for some numeric functions.  Much of
+       this was in terms of actual code which I gratefully accepted.
+
+       Portions of this program are derived from an earlier set of
+       public domain arbitrarily precision routines which was posted
+       to the net around 1984.  By now, there is almost no recognizable 
+       code left from that original source.
+
+       Most of this source and binary is:
+
+               Copyright (c) 1993 David I. Bell
+
+       A few files are a joint copyright between David I. Bell and Landon Noll.
+
+       Permission is granted to use, distribute, or modify this source,
+       provided that this copyright notice remains intact.
+
+       Send calc comments, suggestions, bug fixes, enhancements and
+       interesting calc scripts that you would like you see included in
+       future distributions to:
+
+               dbell@canb.auug.org.au
+               chongo@toad.com
+
+       Enjoy!
diff --git a/usr/src/contrib/calc-2.9.3t6/help/define b/usr/src/contrib/calc-2.9.3t6/help/define
new file mode 100644 (file)
index 0000000..45c5ab9
--- /dev/null
@@ -0,0 +1,68 @@
+Function definitions
+
+       Function definitions are introduced by the 'define' keyword.
+       Other than this, the basic structure of a function is like in C.
+       That is, parameters are specified for the function within parenthesis,
+       the function body is introduced by a left brace, variables are
+       declared for the function, statements implementing the function
+       follow, and the function is ended with a right brace.
+
+       There are some subtle differences, however.  The types of parameters
+       and variables are not defined at compile time, but instead are typed
+       at runtime.  Thus there is no definitions needed to distinguish
+       between integers, fractions, complex numbers, matrices, and so on.
+       Thus when declaring parameters for a function, only the name of
+       the parameter is needed.  Thus there are never any declarations
+       between the function parameter list and the body of the function.
+
+       For example, the following function computes a factorial:
+
+               define factorial(n)
+               {
+                       local   ans;
+
+                       ans = 1;
+                       while (n > 1)
+                               ans *= n--;
+                       return ans;
+               }
+
+       If a function is very simple and just returns a value, then the
+       function can be defined in shortened manner by using an equals sign
+       in place of the left brace.  In this case, the function declaration
+       is terminated by a newline character, and its value is the specified
+       expression.  Statements such as 'if' are not allowed.  An optional
+       semicolon ending the expression is allowed.  As an example, the
+       average of two numbers could be defined as:
+
+               define average(a, b) = (a + b) / 2;
+
+       Functions can be defined which can be very complex.  These can be
+       defined on the command line if desired, but editing of partial
+       functions is not possible past a single line.  If an error is made
+       on a previous line, then the function must be finished (with probable
+       errors) and reentered from the beginning.  Thus for complicated
+       functions, it is best to use an editor to create the function in a
+       file, and then enter the calculator and read in the file containing
+       the definition.
+
+       The parameters of a function can be referenced by name, as in
+       normal C usage, or by using the 'param' function.  This function
+       returns the specified parameter of the function it is in, where
+       the parameters are numbered starting from 1.  The total number
+       of parameters to the function is returned by using 'param(0)'.
+       Using this function allows you to implement varargs-like routines
+       which can handle any number of calling parameters.  For example:
+
+               define sc()
+               {
+                       local s, i;
+
+                       s = 0;
+                       for (i = 1; i <= param(0); i++)
+                               s += param(i)^3;
+                       return s;
+               }
+
+       defines a function which returns the sum of the cubes of all it's
+       parameters.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/environment b/usr/src/contrib/calc-2.9.3t6/help/environment
new file mode 100644 (file)
index 0000000..50ca1eb
--- /dev/null
@@ -0,0 +1,83 @@
+Environment variables
+
+       CALCPATH
+
+           A :-separated list of directories used to search for
+           scripts filenames that do not begin with /, ./ or ~.
+
+           If this variable does not exist, a compiled value
+           is used.  Typically compiled in value is:
+
+                       .:./lib:~/lib:${LIBDIR}/calc
+       
+           where ${LIBDIR} is usually:
+
+                       /usr/local/lib/calc
+
+           This value is used by the READ command.  It is an error
+           if no such readable file is found.
+       
+       
+       CALCRC
+
+           On startup (unless -h or -q was given on the command
+           line), calc searches for files along the :-separated
+           $CALCRC environment variable.
+
+           If this variable does not exist, a compiled value
+           is used.  Typically compiled in value is:
+
+                       ${LIBDIR}/startup:~/.calcrc
+       
+           where ${LIBDIR} is usually:
+
+                       /usr/local/lib/calc
+
+           Missing files along the $CALCRC path are silently ignored.
+       
+       CALCBINDINGS
+
+           On startup (unless -h or -q was given on the command
+           line), calc reads key bindings from the filename specified
+           in the $CALCRC environment variable.  These key bindings
+           are used for command line editing and the command history.
+
+           If this variable does not exist, a compiled value is used.
+           Typically compiled in value is:
+
+                       ${LIBDIR}/bindings
+       
+           where ${LIBDIR} is usually:
+
+                       /usr/local/lib/calc
+
+           If the file could not be opened, or if standard input is not
+           a terminal, then calc will still run, but fancy command line
+           editing is disabled.
+
+       HOME
+
+           This value is taken to be the home directory of the
+           current user.  It is used when files begin with '~/'.
+
+           If this variable does not exist, the home directory password 
+           entry of the current user is used.  If that information
+           is not available, '.' is used.
+       
+       PAGER
+
+           When invoking help, this environment variable is used
+           to display a help file.
+
+           If this variable does not exist, a compiled value
+           is used.  Typically compiled in value is something
+           such as 'more', 'less', 'pg' or 'cat'.
+       
+       SHELL
+
+           When a !-command is used, the program indicated by
+           this environment variable is used.
+
+           If this variable does not exist, a compiled value
+           is used.  Typically compiled in value is something
+           such as 'sh' is used.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/expression b/usr/src/contrib/calc-2.9.3t6/help/expression
new file mode 100644 (file)
index 0000000..a2fb251
--- /dev/null
@@ -0,0 +1,35 @@
+Expression sequences
+
+       This is a sequence of statements, of which expression statements
+       are the commonest case.  Statements are separated with semicolons,
+       and the newline character generally ends the sequence.  If any
+       statement is an expression by itself, or is associated with an
+       'if' statement which is true, then two special things can happen.
+       If the sequence is executed at the top level of the calculator,
+       then the value of '.' is set to the value of the last expression.
+       Also, if an expression is a non-assignment, then the value of the
+       expression is automatically printed if its value is not NULL.
+       Some operations such as pre-increment and plus-equals are also
+       treated as assignments.
+
+       Examples of this are the following:
+
+       expression              sets '.' to             prints
+       ----------              -----------             ------
+       3+4                     7                       7
+       2*4; 8+1; fact(3)       6                       8, 9, and 6
+       x=3^2                   9                       -
+       if (3 < 2) 5; else 6    6                       6
+       x++                     old x                   -
+       print fact(4)           -                       24
+       null()                  null()                  -
+
+       Variables can be defined at the beginning of an expression sequence.
+       This is most useful for local variables, as in the following example,
+       which sums the square roots of the first few numbers:
+
+       local s, i; s = 0; for (i = 0; i < 10; i++) s += sqrt(i); s
+
+       If a return statement is executed in an expression sequence, then
+       the result of the expression sequence is the returned value.  In
+       this case, '.' is set to the value, but nothing is printed.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/file b/usr/src/contrib/calc-2.9.3t6/help/file
new file mode 100644 (file)
index 0000000..5df37f9
--- /dev/null
@@ -0,0 +1,156 @@
+Using files
+
+       The calculator provides some functions which allow the program to
+       read or write text files.  These functions use stdio internally,
+       and the functions appear similar to some of the stdio functions.
+       Some differences do occur, as will be explained here.
+
+       Names of files are subject to ~ expansion just like the C or
+       Korn shell.  For example, the file name:
+
+               ~/.rc.cal
+       
+       refers to the file '.rc.cal' under your home directory.  The
+       file name:
+
+               ~chongo/.rc.cal
+
+       refers to the a file 'rc.cal' under the home directory of 'chongo'.
+
+       A file can be opened for either reading, writing, or appending.
+       To do this, the 'fopen' function is used, which accepts a filename
+       and an open mode, both as strings.  You use 'r' for reading, 'w'
+       for writing, and 'a' for appending.  For example, to open the file
+       'foo' for reading, the following could be used:
+
+               fd = fopen('foo', 'r');
+
+       If the open is unsuccessful, the numeric value of errno is returned.
+       If the open is successful, a value of type 'file' will be returned.
+       You can use the 'isfile' function to test the return value to see
+       if the open succeeded.  You should assign the return value of fopen
+       to a variable for later use.  File values can be copied to more than
+       one variable, and using any of the variables with the same file value
+       will produce the same results.
+
+       If you overwrite a variable containing a file value or don't save the
+       result of an 'fopen', the opened file still remains open.  Such 'lost'
+       files can be recovered by using the 'files' function.  This function
+       either takes no arguments or else takes one integer argument.  If no
+       arguments are given, then 'files' returns the maximum number of opened
+       files.  If an argument is given, then the 'files' function uses it as
+       an index into an internal table of open files, and returns a value
+       referring to one the open files.  If that entry in the table is not
+       in use, then the null value is returned instead.  Index 0 always
+       refers to standard input, index 1 always refers to standard output,
+       and index 2 always refers to standard error.  These three files are
+       already open by the calculator and cannot be closed.  As an example
+       of using 'files', if you wanted to assign a file value which is
+       equivalent to stdout, you could use:
+
+               stdout = files(1);
+
+       The 'fclose' function is used to close a file which had been opened.
+       When this is done, the file value associated with the file remains
+       a file value, but appears 'closed', and cannot be used in further
+       file-related calls (except fclose) without causing errors.  This same
+       action occurs to all copies of the file value.  You do not need to
+       explicitly close all the copies of a file value.  The 'fclose'
+       function returns the numeric value of errno if there had been an
+       error using the file, or the null value if there was no error.
+
+       File values can be printed.  When this is done, the filename of the
+       opened file is printed inside of quote marks.  If the file value had
+       been closed, then the null string is printed.  If a file value is the
+       result of a top-level expression, then in addition to the filename,
+       the open mode, file position, and possible EOF, error, and closed
+       status is also displayed.
+
+       File values can be used inside of 'if' tests.  When this is done,
+       an opened file is TRUE, and a closed file is FALSE.  As an example
+       of this, the following loop will print the names of all the currently
+       opened non-standard files with their indexes, and then close them:
+
+               for (i = 3; i < files(); i++) {
+                       if (files(i)) {
+                               print i, files(i);
+                               fclose(files(i));
+                       }
+               }
+
+       The functions to read from files are 'fgetline' and 'fgetc'.
+       The 'fgetline' function accepts a file value, and returns the next
+       input line from a file.  The line is returned as a string value, and
+       does not contain the end of line character.  Empty lines return the
+       null string.  When the end of file is reached, fgetline returns the
+       null value.  (Note the distinction between a null string and a null
+       value.)  If the line contained a numeric value, then the 'eval'
+       function can then be used to convert the string to a numeric value.
+       Care should be used when doing this, however, since eval will
+       generate an error if the string doesn't represent a valid expression.
+       The 'fgetc' function returns the next character from a file as a
+       single character string.  It returns the null value when end of file
+       is reached.
+
+       The 'printf' and 'fprintf' functions are used to print results to a
+       file (which could be stdout or stderr).  The 'fprintf' function
+       accepts a file variable, whereas the 'printf' function assumes the
+       use of 'files(1)' (stdout).  They both require a format string, which
+       is used in almost the same way as in normal C.  The differences come
+       in the interpretation of values to be printed for various formats.
+       Unlike in C, where an unmatched format type and value will cause
+       problems, in the calculator nothing bad will happen.  This is because
+       the calculator knows the types of all values, and will handle them
+       all reasonably.  What this means is that you can (for example), always
+       use %s or %d in your format strings, even if you are printing a non-
+       string or non-numeric value.  For example, the following is valid:
+
+               printf("Two values are %d and %s\n", "fred", 4567);
+
+       and will print "Two values are fred and 4567".
+
+       Using particular format characters, however, is still useful if
+       you wish to use width or precision arguments in the format, or if
+       you wish to print numbers in a particular format.  The following
+       is a list of the possible numeric formats:
+
+               %d              print in currently defined numeric format
+               %f              print as floating point
+               %e              print as exponential
+               %r              print as decimal fractions
+               %x              print as hex fractions
+               %o              print as octal fractions
+               %b              print as binary fractions
+
+       Note then, that using %d in the format makes the output configurable
+       by using the 'config' function to change the output mode, whereas
+       the other formats override the mode and force the output to be in
+       the specified format.
+
+       Using the precision argument will override the 'config' function
+       to set the number of decimal places printed.  For example:
+
+               printf("The number is %.100f\n", 1/3);
+
+       will print 100 decimal places no matter what the display configuration
+       value is set to.
+
+       The %s and %c formats are identical, and will print out the string
+       representation of the value.  In these cases, the precision argument
+       will truncate the output the same way as in standard C.
+
+       If a matrix or list is printed, then the output mode and precision
+       affects the printing of each individual element.  However, field
+       widths are ignored since these values print using multiple lines.
+       Field widths are also ignored if an object value prints on multiple
+       lines.
+
+       The final file-related functions are 'fflush', 'ferror', and 'feof'.
+       The 'fflush' function forces buffered output to a file.  The 'ferror'
+       function returns nonzero if an error had occurred to a file.  The
+       'feof' function returns nonzero if end of file has been reached
+       while reading a file.
+
+       The 'strprintf' function formats output similarly to 'printf',
+       but the output is returned as a string value instead of being
+       printed.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/help b/usr/src/contrib/calc-2.9.3t6/help/help
new file mode 100644 (file)
index 0000000..14d7f06
--- /dev/null
@@ -0,0 +1,50 @@
+For more information while running calc, type  help  followed by one of the
+following topics:
+
+       topic           description
+       -----           -----------
+       intro           introduction to calc
+       overview        overview of calc
+       help            this file
+
+       assoc           using associations
+       builtin         builtin functions
+       command         top level commands
+       config          configuration parameters
+       define          how to define functions
+       environment     how environment variables effect calc
+       expression      expression sequences
+       file            using files
+       history         command history
+       interrupt       how interrupts are handled
+       list            using lists
+       mat             using matrices
+       obj             user defined data types
+       operator        math, relational, logic and variable access operators
+       statement       flow control and declaration statements
+       stdlib          description of some lib files shipped with calc
+       types           builtin data types
+       usage           how to invoke the calc command
+       variable        variables and variable declarations
+
+       bindings        input & history character bindings
+       altbind         alternative input & history character bindings
+       changes         recent changes to calc
+       libcalc         using the arbitrary precision routines in a C program
+       stdlib          standard calc library files and standards
+       bugs            known bugs and mis-features
+       todo            needed enhancements and wish list
+       credit          who wrote calc and who helped
+
+       full            all of the above
+
+For example:
+
+       help usage
+
+will print the calc command usage information.  One can obtain calc help
+without invoking any startup code by running calc as follows:
+
+       calc -q help topic
+
+where 'topic' is one of the topics listed above.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/history b/usr/src/contrib/calc-2.9.3t6/help/history
new file mode 100644 (file)
index 0000000..c682446
--- /dev/null
@@ -0,0 +1,61 @@
+Command history
+
+       There is a command line editor and history mechanism built
+       into calc, which is active when stdin is a terminal.  When
+       stdin is not a terminal, then the command line editor is
+       disabled.
+
+       Lines of input to calc are always terminated by the return
+       (or enter) key.  When the return key is typed, then the current
+       line is executed and is also saved into a command history list
+       for future recall.
+
+       Before the return key is typed, the current line can be edited
+       using emacs-like editing commands.  As examples, ^A moves to
+       the beginning of the line, ^F moves forwards through the line,
+       backspace removes characters from the line, and ^K kills the
+       rest of the line.
+
+       Previously entered commands can be recalled by using the history
+       list.  The history list functions in a LRU manner, with no
+       duplicated lines.  This means that the most recently entered
+       lines are always at the end of the history list where they are
+       easiest to recall.
+
+       Typing <esc>h lists all of the commands in the command history
+       and numbers the lines.  The most recently executed line is always
+       number 1, the next most recent number 2, and so on.  The numbering
+       for a particular command therefore changes as lines are entered.
+
+       Typing a number at the beginning of a line followed by <esc>g
+       will recall that numbered line.  So that for example, 2<esc>g
+       will recall the second most recent line that was entered.
+
+       The ^P and ^N keys move up and down the lines in the history list.
+       If they attempt to go off the top or bottom of the list, then a
+       blank line is shown to indicate this, and then they wrap around
+       to the other end of the list.
+
+       Typing a string followed by a ^R will search backwards through
+       the history and recall the most recent command which begins
+       with that string.
+
+       Typing ^O inserts the current line at the end of the history list
+       without executing it, and starts a new line.  This is useful to
+       rearrange old history lines to become recent, or to save a partially
+       completed command so that another command can be typed ahead of it.
+
+       If your terminal has arrow keys which generate escape sequences
+       of a particular kind (<esc>[A and so on), then you can use
+       those arrow keys in place of the ^B, ^F, ^P, and ^N keys.
+
+       The actual keys used for editing are defined in a bindings file,
+       usually called /usr/local/lib/calc/bindings.  Changing the entries 
+       in this file will change the key bindings used for editing.  If the 
+       file is not readable, then a message will be output and command
+       line editing is disabled.  In this case you can only edit each
+       line as provided by the terminal driver in the operating system.
+
+       A shell command can be executed by typing '!cmd', where cmd
+       is the command to execute.  If cmd is not given, then a shell
+       command level is started.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/interrupt b/usr/src/contrib/calc-2.9.3t6/help/interrupt
new file mode 100644 (file)
index 0000000..ac2fd21
--- /dev/null
@@ -0,0 +1,28 @@
+Interrupts
+
+       While a calculation is in progress, you can generate the SIGINT
+       signal, and the calculator will catch it.  At appropriate points
+       within a calculation, the calculator will check that the signal
+       has been given, and will abort the calculation cleanly.  If the
+       calculator is in the middle of a large calculation, it might be
+       a while before the interrupt has an effect.
+
+       You can generate the SIGINT signal multiple times if necessary,
+       and each time the calculator will abort the calculation at a more
+       risky place within the calculation.  Each new interrupt prints a
+       message of the form:
+
+               [Abort level n]
+
+       where n ranges from 1 to 3.  For n equal to 1, the calculator will
+       abort calculations at the next statement boundary.  For n equal to 2,
+       the calculator will abort calculations at the next opcode boundary.
+       For n equal to 3, the calculator will abort calculations at the next
+       lowest level arithmetic operation boundary.
+
+       If a final interrupt is given when n is 3, the calculator will
+       immediately abort the current calculation and longjmp back to the
+       top level command level.  Doing this may result in corrupted data
+       structures and unpredictable future behavior, and so should only
+       be done as a last resort.  You are advised to quit the calculator
+       after this has been done.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/intro b/usr/src/contrib/calc-2.9.3t6/help/intro
new file mode 100644 (file)
index 0000000..37fdd79
--- /dev/null
@@ -0,0 +1,55 @@
+Quick introduction
+
+       This is an interactive calculator which provides for easy large
+       numeric calculations, but which also can be easily programmed
+       for difficult or long calculations.  It can accept a command line
+       argument, in which case it executes that single command and exits.
+       Otherwise, it enters interactive mode.  In this mode, it accepts
+       commands one at a time, processes them, and displays the answers.
+       In the simplest case, commands are simply expressions which are
+       evaluated.  For example, the following line can be input:
+
+               3 * (4 + 1)
+
+       and the calculator will print 15.
+
+       The special '.' symbol (called dot), represents the result of the
+       last command expression, if any.  This is of great use when a series
+       of partial results are calculated, or when the output mode is changed
+       and the last result needs to be redisplayed.  For example, the above
+       result can be doubled by typing:
+
+               . * 2
+
+       and the calculator will print 30.
+
+       For more complex calculations, variables can be used to save the
+       intermediate results.  For example, the result of adding 7 to the
+       previous result can be saved by typing:
+
+               old = . + 7
+
+       Functions can be used in expressions.  There are a great number of
+       pre-defined functions.  For example, the following will calculate
+       the factorial of the value of 'old':
+
+               fact(old)
+
+       and the calculator prints 13763753091226345046315979581580902400000000.
+       Notice that numbers can be very large. (There is a practical limit
+       of several thousand digits before calculations become too slow.)
+
+       The calculator can calculate transcendental functions, and accept and
+       display numbers in real or exponential format. For example, typing:
+
+               config("display", 50)
+               epsilon(1e-50)
+               sin(1)
+
+       prints "~.84147098480789650665250232163029899962256306079837".
+
+       The calculator also knows about complex numbers, so that typing:
+
+               (2+3i) * (4-3i)
+
+       prints "17+6i".
diff --git a/usr/src/contrib/calc-2.9.3t6/help/list b/usr/src/contrib/calc-2.9.3t6/help/list
new file mode 100644 (file)
index 0000000..7568326
--- /dev/null
@@ -0,0 +1,44 @@
+Using lists
+
+       Lists are a sequence of values which are doubly linked so that
+       elements can be removed or inserted anywhere within the list.
+       The function 'list' creates a list with possible initial elements.
+       For example,
+
+               x = list(4, 6, 7);
+
+       creates a list in the variable x of three elements, in the order
+       4, 6, and 7.
+
+       The 'push' and 'pop' functions insert or remove an element from
+       the beginning of the list.  The 'append' and 'remove' functions
+       insert or remove an element from the end of the list.  The 'insert'
+       and 'delete' functions insert or delete an element from the middle
+       (or ends) of a list.  The functions which insert elements return
+       the null value, but the functions which remove an element return
+       the element as their value.  The 'size' function returns the number
+       of elements in the list.
+
+       Note that these functions manipulate the actual list argument,
+       instead of returning a new list.  Thus in the example:
+
+               push(x, 9);
+
+       x becomes a list of four elements, in the order 9, 4, 6, and 7.
+       Lists can be copied by assigning them to another variable.
+
+       An arbitrary element of a linked list can be accessed by using the
+       double-bracket operator.  The beginning of the list has index 0.
+       Thus in the new list x above, the expression x[[0]] returns the
+       value of the first element of the list, which is 9.  Note that this
+       indexing does not remove elements from the list.
+
+       Since lists are doubly linked in memory, random access to arbitrary
+       elements can be slow if the list is large.  However, for each list
+       a pointer is kept to the latest indexed element, thus relatively
+       sequential accesses to the elements in a list will not be slow.
+
+       Lists can be searched for particular values by using the 'search'
+       and 'rsearch' functions.  They return the element number of the
+       found value (zero based), or null if the value does not exist in
+       the list.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/mat b/usr/src/contrib/calc-2.9.3t6/help/mat
new file mode 100644 (file)
index 0000000..fb9a6b8
--- /dev/null
@@ -0,0 +1,102 @@
+Using matrices
+
+       Matrices can have from 1 to 4 dimensions, and are indexed by a
+       normal-sized integer.  The lower and upper bounds of a matrix can
+       be specified at runtime.  The elements of a matrix are defaulted
+       to zeroes, but can be assigned to be of any type.  Thus matrices
+       can hold complex numbers, strings, objects, etc.  Matrices are
+       stored in memory as an array so that random access to the elements
+       is easy.
+
+       Matrices are normally indexed using square brackets.  If the matrix
+       is multi-dimensional, then an element can be indexed either by
+       using multiple pairs of square brackets (as in C), or else by
+       separating the indexes by commas.  Thus the following two statements
+       reference the same matrix element:
+
+               x = name[3][5];
+               x = name[3,5];
+
+       The double-square bracket operator can be used on any matrix to
+       make references to the elements easy and efficient.  This operator
+       bypasses the normal indexing mechanism, and treats the array as if
+       it was one-dimensional and with a lower bound of zero.  In this
+       indexing mode, elements correspond to the normal indexing mode where
+       the rightmost index increases most frequently.  For example, when
+       using double-square bracket indexing on a two-dimensional matrix,
+       increasing indexes will reference the matrix elements left to right,
+       row by row.  Thus in the following example, 'x' and 'y' are copied
+       from the same matrix element:
+
+               mat m[1:2, 1:3];
+               x = m[2,1];
+               y = m[[3]];
+
+       There are functions which return information about a matrix.
+       The 'size' functions returns the total number of elements.
+       The 'matdim', 'matmin', and 'matmax' functions return the number
+       of dimensions of a matrix, and the lower and upper index bounds
+       for a dimension of a matrix.  For square matrices, the 'det'
+       function calculates the determinant of the matrix.
+
+       Some functions return matrices as their results.  These functions
+       do not affect the original matrix argument, but instead return
+       new matrices.  For example, the 'mattrans' function returns the
+       transpose of a matrix, and 'inverse' returns the inverse of a
+       matrix.  So to invert a matrix called 'x', you could use:
+
+               x = inverse(x);
+
+       The 'matfill' function fills all elements of a matrix with the
+       specified value, and optionally fills the diagonal elements of a
+       square matrix with a different value.  For example:
+
+               matfill(x,1);
+
+       will fill any matrix with ones, and:
+
+               matfill(x, 0, 1);
+
+       will create an identity matrix out of any square matrix.  Note that
+       unlike most matrix functions, this function does not return a matrix
+       value, but manipulates the matrix argument itself.
+
+       Matrices can be multiplied by numbers, which multiplies each element
+       by the number.  Matrices can also be negated, conjugated, shifted,
+       rounded, truncated, fractioned, and modulo'ed.  Each of these
+       operations is applied to each element.
+
+       Matrices can be added or multiplied together if the operation is
+       legal.  Note that even if the dimensions of matrices are compatible,
+       operations can still fail because of mismatched lower bounds.  The
+       lower bounds of two matrices must either match, or else one of them
+       must have a lower bound of zero.  Thus the following code:
+
+               mat x[3:3];
+               mat y[4:4];
+               z = x + y;
+
+       fails because the calculator does not have a way of knowing what
+       the bounds should be on the resulting matrix.  If the bounds match,
+       then the resulting matrix has the same bounds.  If exactly one of
+       the lower bounds is zero, then the resulting matrix will have the
+       nonzero lower bounds.  Thus means that the bounds of a matrix are
+       preserved when operated on by matrices with lower bounds of zero.
+       For example:
+
+               mat x[3:7];
+               mat y[5];
+               z = x + y;
+
+       will succeed and assign the variable 'z' a matrix whose
+       bounds are 3-7.
+
+       Vectors are matrices of only a single dimension.  The 'dp' and 'cp'
+       functions calculate the dot product and cross product of a vector
+       (cross product is only defined for vectors of size 3).
+
+       Matrices can be searched for particular values by using the 'search'
+       and 'rsearch' functions.  They return the element number of the
+       found value (zero based), or null if the value does not exist in the
+       matrix.  Using the element number in double-bracket indexing will
+       then refer to the found element.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/obj.file b/usr/src/contrib/calc-2.9.3t6/help/obj.file
new file mode 100644 (file)
index 0000000..18f9eb5
--- /dev/null
@@ -0,0 +1,176 @@
+Using objects
+
+       Objects are user-defined types which are associated with user-
+       defined functions to manipulate them.  Object types are defined
+       similarly to structures in C, and consist of one or more elements.
+       The advantage of an object is that the user-defined routines are
+       automatically called by the calculator for various operations,
+       such as addition, multiplication, and printing.  Thus they can be
+       manipulated by the user as if they were just another kind of number.
+
+       An example object type is "surd", which represents numbers of the form
+
+               a + b*sqrt(D),
+
+       where D is a fixed integer, and 'a' and 'b' are arbitrary rational
+       numbers.  Addition, subtraction, multiplication, and division can be
+       performed on such numbers, and the result can be put unambiguously
+       into the same form.  (Complex numbers are an example of surds, where
+       D is -1.)
+
+       The "obj" statement defines either an object type or an actual
+       variable of that type.  When defining the object type, the names of
+       its elements are specified inside of a pair of braces.  To define
+       the surd object type, the following could be used:
+
+               obj surd {a, b};
+
+       Here a and b are the element names for the two components of the
+       surd object.  An object type can be defined more than once as long
+       as the number of elements and their names are the same.
+
+       When an object is created, the elements are all defined with zero
+       values.  A user-defined routine should be provided which will place
+       useful values in the elements.  For example, for an object of type
+       'surd', a function called 'surd' can be defined to set the two
+       components as follows:
+
+               define surd(a, b)
+               {
+                       local x;
+
+                       obj surd x;
+                       x.a = a;
+                       x.b = b;
+                       return x;
+               }
+
+       When an operation is attempted for an object, user functions with
+       particular names are automatically called to perform the operation.
+       These names are created by concatenating the object type name and
+       the operation name together with an underscore.  For example, when
+       multiplying two objects of type surd, the function "surd_mul" is
+       called.
+
+       The user function is called with the necessary arguments for that
+       operation.  For example, for "surd_mul", there are two arguments,
+       which are the two numbers.  The order of the arguments is always
+       the order of the binary operands.  If only one of the operands to
+       a binary operator is an object, then the user function for that
+       object type is still called.  If the two operands are of different
+       object types, then the user function that is called is the one for
+       the first operand.
+
+       The above rules mean that for full generality, user functions
+       should detect that one of their arguments is not of its own object
+       type by using the 'istype' function, and then handle these cases
+       specially.  In this way, users can mix normal numbers with object
+       types.  (Functions which only have one operand don't have to worry
+       about this.)  The following example of "surd_mul" demonstrates how
+       to handle regular numbers when used together with surds:
+
+               define surd_mul(a, b)
+               {
+                       local x;
+
+                       obj surd x;
+                       if (!istype(a, x)) {    
+                               /* a not of type surd */
+                               x.a = b.a * a;
+                               x.b = b.b * a;
+                       } else if (!istype(b, x)) {
+                               /* b not of type surd */
+                               x.a = a.a * b;
+                               x.b = a.b * b;
+                       } else {                        
+                               /* both are surds */
+                               x.a = a.a * b.a + D * a.b * b.b;
+                               x.b = a.a * b.b + a.b * b.a;
+                       }
+                       if (x.b == 0)
+                               return x.a;     /* normal number */
+                       return x;               /* return surd */
+               }
+
+       In order to print the value of an object nicely, a user defined
+       routine can be provided.  For small amounts of output, the print
+       routine should not print a newline.  Also, it is most convenient
+       if the printed object looks like the call to the creation routine.
+       For output to be correctly collected within nested output calls,
+       output should only go to stdout.  This means use the 'print'
+       statement, the 'printf' function, or the 'fprintf' function with
+       'files(1)' as the output file.  For example, for the "surd" object:
+
+               define surd_print(a)
+               {
+                       print "surd(" : a.a : "," : a.b : ")" : ;
+               }
+
+       It is not necessary to provide routines for all possible operations
+       for an object, if those operations can be defaulted or do not make
+       sense for the object.  The calculator will attempt meaningful
+       defaults for many operations if they are not defined.  For example,
+       if 'surd_square' is not defined to square a number, then 'surd_mul'
+       will be called to perform the squaring.  When a default is not
+       possible, then an error will be generated.
+
+       Please note: Arguments to object functions are always passed by
+       reference (as if an '&' was specified for each variable in the call).
+       Therefore, the function should not modify the parameters, but should
+       copy them into local variables before modifying them.  This is done
+       in order to make object calls quicker in general.
+
+       The double-bracket operator can be used to reference the elements
+       of any object in a generic manner.  When this is done, index 0
+       corresponds to the first element name, index 1 to the second name,
+       and so on.  The 'size' function will return the number of elements
+       in an object.
+
+       The following is a list of the operations possible for objects.
+       The 'xx' in each function name is replaced with the actual object
+       type name.  This table is displayed by the 'show objfuncs' command.
+
+               Name    Args    Comments
+
+               xx_print    1   print value, default prints elements
+               xx_one      1   multiplicative identity, default is 1
+               xx_test     1   logical test (false,true => 0,1), 
+                                   default tests elements
+               xx_add      2   
+               xx_sub      2   subtraction, default adds negative
+               xx_neg      1   negative
+               xx_mul      2   
+               xx_div      2   non-integral division, default multiplies 
+                                   by inverse
+               xx_inv      1   multiplicative inverse
+               xx_abs      2   absolute value within given error
+               xx_norm     1   square of absolute value
+               xx_conj     1   conjugate
+               xx_pow      2   integer power, default does multiply, 
+                                   square, inverse
+               xx_sgn      1   sign of value (-1, 0, 1)
+               xx_cmp      2   equality (equal,non-equal => 0,1), 
+                                   default tests elements
+               xx_rel      2   inequality (less,equal,greater => -1,0,1)
+               xx_quo      2   integer quotient
+               xx_mod      2   remainder of division
+               xx_int      1   integer part
+               xx_frac     1   fractional part
+               xx_inc      1   increment, default adds 1
+               xx_dec      1   decrement, default subtracts 1
+               xx_square   1   default multiplies by itself
+               xx_scale    2   multiply by power of 2
+               xx_shift    2   shift left by n bits (right if negative)
+               xx_round    2   round to given number of decimal places
+               xx_bround   2   round to given number of binary places
+               xx_root     3   root of value within given error
+               xx_sqrt     2   square root within given error
+
+
+       Also see the library files:
+
+               dms.cal
+               mod.cal
+               poly.cal
+               quat.cal
+               surd.cal
diff --git a/usr/src/contrib/calc-2.9.3t6/help/operator b/usr/src/contrib/calc-2.9.3t6/help/operator
new file mode 100644 (file)
index 0000000..964869e
--- /dev/null
@@ -0,0 +1,129 @@
+Operators
+
+       The operators are similar to C, but the precedence of some of
+       the operators differs.  In addition, there are several additional
+       operators, and some C operators are missing.  The following list
+       gives the operators arranged in order of precedence, from the
+       least tightly binding to the most tightly binding:
+
+       ,       Comma operator.
+               For situations in which a comma is used for another purpose
+               (function arguments, array indexing, and the print statement),
+               parenthesis must be used around the comma operator.
+
+       ? :     Conditional value.
+               a ? b : c  returns b if a is nonzero, c otherwise.
+               Thus it is equivalent to: if (a) return b; else return c;.
+               All that is required of the arguments in this function
+               is that the is-it-nonzero test is meaningful for a.
+
+       =  +=  -=  *=  /=  %=  //=  &=  |=  <<=  >>=  ^=  **=
+               Assignments.
+
+       ||      Logical OR.
+               Unlike C, the result is the first non-zero expression or 0,
+               instead of just 0 or 1.  Thus a || b is equivalent to
+               a ? a : b.
+
+       &&      Logical AND.
+               Unlike C, the result is the last expression or 0,
+               instead of just 0 or 1.  Thus a && b is equivalent to
+               !a ? 0 : (!b ? 0 : b).
+
+       ==  !=  <=  >=  <  >
+               Relations.
+
+       +  -
+               Binary plus and minus.
+
+       *  /  //  %
+               Multiply, divide. and modulo.
+               Please Note: The '/' operator is a fractional divide,
+               whereas the '//' is an integral divide.  Thus think of '/'
+               as division of real numbers, and think of '//' as division
+               of integers (e.g., 8 / 3 is 8/3 whereas 8 // 3 is 2).
+               The '%' is integral or fractional modulus (e.g., 11%4 is 3,
+               and 10%pi() is ~.575222).
+
+       |       Bitwise OR.
+               In a | b, both a and b are to be real integers;
+               the signs of a and b are ignored, i.e.
+               a | b = abs(a) | abs(b) and the result will
+               be a non-negative integer.
+
+       &       Bitwise AND.
+               In a & b, both a and b are to be real integers;
+               the signs of a and b are ignored as for a | b.
+
+       ^  **  <<  >>
+               Powers and shifts.
+               The '^' and '**' are both exponentiation, e.g. 2^3
+               returns 8, 2^-3 returns .125.  In a ^ b, b has to be
+               an integer and if a is zero, nonnegative.  0^0 returns
+               the value 1.
+
+               For the shift operators both arguments are to be
+               integers, or if the first is complex, it is to have
+               integral real and imaginary parts.  Changing the
+               sign of the second argument reverses the shift, e.g.
+               a >> -b = a << b.  The result has the same sign as
+               the first argument except that a nonzero value is
+               reduced to zero by a sufficiently long shift to the
+               right.  These operators associate right to left,
+               e.g.  a << b ^ c = a << (b ^ c).
+
+       +  -  !
+               Unary operators.
+               The '!' is the logical NOT operator: !a returns 0 if
+               a is nonzero, and 1 if a is zero, i.e. it is
+               equivalent to a ? 0 : 1.  Be careful about
+               using this as the first character of a top level command,
+               since it is also used for executing shell commands.
+
+       ++  --
+               Pre or post incrementing or decrementing.
+               These are applicable only to variables.
+
+       [ ]  [[ ]]  .  ( )
+               Indexing, double-bracket indexing, element references,
+               and function calls.  Indexing can only be applied to matrices,
+               element references can only be applied to objects, but
+               double-bracket indexing can be applied to matrices, objects,
+               or lists.
+
+       variables  constants  .  ( )
+               These are variable names and constants, the special '.' symbol,
+               or a parenthesized expression.  Variable names begin with a
+               letter, but then can contain letters, digits, or underscores.
+               Constants are numbers in various formats, or strings inside
+               either single or double quote marks.
+
+
+       The most significant difference from the order of precedence in
+       C is that | and & have higher precedence than ==, +, -, *, / and %.
+       For example, in C a == b | c * d is interpreted as:
+
+               (a == b) | (c * d)
+
+       and calc it is:
+
+               a == ((b | c) * d)
+
+
+       Most of the operators will accept any real or complex numbers
+       as arguments.  The exceptions are:
+
+       /  //  %
+               Second argument must be nonzero.
+
+       ^
+               The exponent must be an integer.  When raising zero
+               to a power, the exponent must be non-negative.
+
+       |  &
+               Both both arguments must be integers.
+
+       <<  >>
+               The shift amount must be an integer.  The value being
+               shifted must be an integer or a complex number with
+               integral real and imaginary parts.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/overview b/usr/src/contrib/calc-2.9.3t6/help/overview
new file mode 100644 (file)
index 0000000..a1e9104
--- /dev/null
@@ -0,0 +1,123 @@
+                       CALC - An arbitrary precision calculator.
+                               by David I. Bell
+
+
+       This is a calculator program with arbitrary precision arithmetic.
+       All numbers are represented as fractions with arbitrarily large
+       numerators and denominators which are always reduced to lowest terms.
+       Real or exponential format numbers can be input and are converted
+       to the equivalent fraction.  Hex, binary, or octal numbers can be
+       input by using numbers with leading '0x', '0b' or '0' characters.
+       Complex numbers can be input using a trailing 'i', as in '2+3i'.
+       Strings and characters are input by using single or double quotes.
+
+       Commands are statements in a C-like language, where each input
+       line is treated as the body of a procedure.  Thus the command
+       line can contain variable declarations, expressions, labels,
+       conditional tests, and loops.  Assignments to any variable name
+       will automatically define that name as a global variable.  The
+       other important thing to know is that all non-assignment expressions
+       which are evaluated are automatically printed.  Thus, you can evaluate 
+       an expression's value by simply typing it in.
+
+       Many useful built-in mathematical functions are available.  Use
+       the 'show builtins' command to list them.  You can also define
+       your own functions by using the 'define' keyword, followed by a
+       function declaration very similar to C.  Functions which only
+       need to return a simple expression can be defined using an
+       equals sign, as in the example 'define sc(a,b) = a^3 + b^3'.
+       Variables in functions can be defined as either 'global', 'local',
+       or 'static'.  Global variables are common to all functions and the
+       command line, whereas local variables are unique to each function
+       level, and are destroyed when the function returns.  Static variables
+       are scoped within single input files, or within functions, and are
+       never destroyed.  Variables are not typed at definition time, but
+       dynamically change as they are used.  So you must supply the correct
+       type of variable to those functions and operators which only work
+       for a subset of types.
+
+       By default, arguments to functions are passed by value (even
+       matrices).  For speed, you can put an ampersand before any
+       variable argument in a function call, and that variable will be
+       passed by reference instead.  However, if the function changes
+       its argument, the variable will change.  Arguments to built-in
+       functions and object manipulation functions are always called
+       by reference.  If a user-defined function takes more arguments
+       than are passed, the undefined arguments have the null value.
+       The 'param' function returns function arguments by argument
+       number, and also returns the number of arguments passed.  Thus
+       functions can be written to handle an arbitrary number of
+       arguments.
+
+       The mat statement is used to create a matrix.  It takes a
+       variable name, followed by the bounds of the matrix in square
+       brackets.  The lower bounds are zero by default, but colons can
+       be used to change them.  For example 'mat foo[3, 1:10]' defines
+       a two dimensional matrix, with the first index ranging from 0
+       to 3, and the second index ranging from 1 to 10.  The bounds of
+       a matrix can be an expression calculated at runtime.
+
+       Lists of values are created using the 'list' function, and values can
+       be inserted or removed from either the front or the end of the list.
+       List elements can be indexed directly using double square brackets.
+
+       The obj statement is used to create an object.  Objects are
+       user-defined values for which user-defined routines are
+       implicitly called to perform simple actions such as add,
+       multiply, compare, and print. Objects types are defined as in
+       the example 'obj complex {real, imag}', where 'complex' is the
+       name of the object type, and 'real' and 'imag' are element
+       names used to define the value of the object (very much like
+       structures).  Variables of an object type are created as in the
+       example 'obj complex x,y', where 'x' and 'y' are variables.
+       The elements of an object are referenced using a dot, as in the
+       example 'x.real'. All user-defined routines have names composed
+       of the object type and the action to perform separated by an
+       underscore, as in the example 'complex_add'.  The command 'show
+       objfuncs' lists all the definable routines.  Object routines
+       which accept two arguments should be prepared to handle cases
+       in which either one of the arguments is not of the expected
+       object type.
+
+       These are the differences between the normal C operators and
+       the ones defined by the calculator.  The '/' operator divides
+       fractions, so that '7 / 2' evaluates to 7/2. The '//' operator
+       is an integer divide, so that '7 // 2' evaluates to 3.  The '^'
+       operator is a integral power function, so that 3^4 evaluates to
+       81.  Matrices of any dimension can be treated as a zero based
+       linear array using double square brackets, as in 'foo[[3]]'.
+       Matrices can be indexed by using commas between the indices, as
+       in foo[3,4].  Object and list elements can be referenced by
+       using double square brackets.
+
+       The print statement is used to print values of expressions.
+       Separating values by a comma puts one space between the output
+       values, whereas separating values by a colon concatenates the
+       output values.  A trailing colon suppresses printing of the end
+       of line.  An example of printing is 'print \"The square of\",
+       x, \"is\", x^2\'.
+
+       The 'config' function is used to modify certain parameters that
+       affect calculations or the display of values.  For example, the
+       output display mode can be set using 'config(\"mode\", type)',
+       where 'type' is one of 'frac', 'int', 'real', 'exp', 'hex',
+       'oct', or 'bin'.  The default output mode is real.  For the
+       integer, real, or exponential formats, a leading '~' indicates
+       that the number was truncated to the number of decimal places
+       specified by the default precision.  If the '~' does not
+       appear, then the displayed number is the exact value.
+
+       The number of decimal places printed is set by using
+       'config(\"display\", n)'.  The default precision for
+       real-valued functions can be set by using 'epsilon(x)', where x
+       is the required precision (such as 1e-50).
+
+       There is a command stack feature so that you can easily
+       re-execute previous commands and expressions from the terminal.
+       You can also edit the current command before it is completed.
+       Both of these features use emacs-like commands.
+
+       Files can be read in by using the 'read filename' command.
+       These can contain both functions to be defined, and expressions
+       to be calculated.  Global variables which are numbers can be
+       saved to a file by using the 'write filename' command.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/statement b/usr/src/contrib/calc-2.9.3t6/help/statement
new file mode 100644 (file)
index 0000000..9206652
--- /dev/null
@@ -0,0 +1,273 @@
+Statements
+
+       Statements are very much like C statements.  Most statements act
+       identically to those in C, but there are minor differences and
+       some additions.  The following is a list of the statement types,
+       with explanation of the non-C statements.  In this list, upper
+       case words identify the keywords which are actually in lower case.
+       Statements are generally terminated with semicolons, except if the
+       statement is the compound one formed by matching braces.  Various
+       expressions are optional and may be omitted (as in RETURN).
+
+
+       NOTE: Calc commands are in lower case.   UPPER case is used below
+             for emphasis only, and should be considered in lower case.
+
+
+       IF (expr) statement
+       IF (expr) statement ELSE statement
+       FOR (optionalexpr ; optionalexpr ; optionalexpr) statement
+       WHILE (expr) statement
+       DO statement WHILE (expr)
+       CONTINUE
+       BREAK
+       GOTO label
+               These all work like in normal C.
+
+       RETURN optionalexpr
+               This returns a value from a function.  Functions always
+               have a return value, even if this statement is not used.
+               If no return statement is executed, or if no expression
+               is specified in the return statement, then the return
+               value from the function is the null type.
+
+       SWITCH (expr) { caseclauses }
+               Switch statements work similarly to C, except for the
+               following.  A switch can be done on any type of value,
+               and the case statements can be of any type of values.
+               The case statements can also be expressions calculated
+               at runtime.  The calculator compares the switch value
+               with each case statement in the order specified, and
+               selects the first case which matches.  The default case
+               is the exception, and only matches once all other cases
+               have been tested.
+
+       { statements }
+               This is a normal list of statements, each one ended by
+               a semicolon.  Unlike the C language, no declarations are
+               permitted within an inner-level compound statement.
+               Declarations are only permitted at the beginning of a
+               function definition, or at the beginning of an expression
+               sequence.
+
+       MAT variable [dimension] [dimension] ...
+       MAT variable [dimension, dimension, ...]
+       MAT variable [] = { value, ... }
+               This creates a matrix variable with the specified dimensions.
+               Matrices can have from 1 to 4 dimensions.  When specifying
+               multiple dimensions, you can use either the standard C syntax,
+               or else you can use commas for separating the dimensions.
+               For example, the following two statements are equivalent,
+               and so will create the same two dimensional matrix:
+
+                       mat foo[3][6];
+                       mat foo[3,6];
+
+               By default, each dimension is indexed starting at zero,
+               as in normal C, and contains the specified number of
+               elements.  However, this can be changed if a colon is
+               used to separate two values.  If this is done, then the
+               two values become the lower and upper bounds for indexing.
+               This is convenient, for example, to create matrices whose
+               first row and column begin at 1.  Examples of matrix
+               definitions are:
+
+                       mat x[3]        one dimension, bounds are 0-2
+                       mat foo[4][5]   two dimensions, bounds are 0-3 and 0-4
+                       mat a[-7:7]     one dimension, bounds are (-7)-7
+                       mat s[1:9,1:9]  two dimensions, bounds are 1-9 and 1-9
+
+               Note that the MAT statement is not a declaration, but is
+               executed at runtime.  Within a function, the specified
+               variable must already be defined, and is just converted to
+               a matrix of the specified size, and all elements are set
+               to the value of zero.  For convenience, at the top level
+               command level, the MAT command automatically defines a
+               global variable of the specified name if necessary.
+
+               Since the MAT statement is executed, the bounds on the
+               matrix can be full expressions, and so matrices can be
+               dynamically allocated.  For example:
+
+                       size = 20;
+                       mat data[size*2];
+
+               allocates a matrix which can be indexed from 0 to 39.
+
+               Initial values for the elements of a matrix can be specified
+               by following the bounds information with an equals sign and
+               then a list of values enclosed in a pair of braces.  Even if
+               the matrix has more than one dimension, the elements must be
+               specified as a linear list.  If too few values are specified,
+               the remaining values are set to zero.  If too many values are
+               specified, a runtime error will result.  Examples of some
+               initializations are:
+
+                       mat table1[5] = {77, 44, 22};
+                       mat table2[2,2] = {1, 2, 3, 4};
+
+               When an initialization is done, the bounds of the matrix
+               can optionally be left out of the square brackets, and the
+               correct bounds (zero based) will be set.  This can only be
+               done for one-dimensional matrices.  An example of this is:
+
+                       mat fred[] = {99, 98, 97};
+
+               The MAT statement can also be used in declarations to set
+               variables as being matrices from the beginning.  For example:
+
+                       local mat temp[5];
+                       static mat strtable[] = {"hi", "there", "folks");
+
+       OBJ type { elementnames } optionalvariables
+       OBJ type variable
+
+               These create a new object type, or create one or more
+               variables of the specified type.  For this calculator,
+               an object is just a structure which is implicitly acted
+               on by user defined routines.  The user defined routines
+               implement common operations for the object, such as plus
+               and minus, multiply and divide, comparison and printing.
+               The calculator will automatically call these routines in
+               order to perform many operations.
+       
+               To create an object type, the data elements used in
+               implementing the object are specified within a pair
+               of braces, separated with commas.  For example, to
+               define an object will will represent points in 3-space,
+               whose elements are the three coordinate values, the
+               following could be used:
+       
+                       obj point {x, y, z};
+       
+               This defines an object type called point, whose elements
+               have the names x, y, and z.  The elements are accessed
+               similarly to structure element accesses, by using a period.
+               For example, given a variable 'v' which is a point object,
+               the three coordinates of the point can be referenced by:
+
+                       v.x
+                       v.y
+                       v.z
+
+               A particular object type can only be defined once, and
+               is global throughout all functions.  However, different
+               object types can be used at the same time.
+
+               In order to create variables of an object type, they
+               can either be named after the right brace of the object
+               creation statement, or else can be defined later with
+               another obj statement.  To create two points using the
+               second (and most common) method, the following is used:
+
+                       obj point p1, p2;       
+
+               This statement is executed, and is not a declaration.
+               Thus within a function, the variables p1 and p2 must have
+               been previously defined, and are just changed to be the
+               new object type.  For convenience, at the top level command
+               level, object variables are automatically defined as being
+               global when necessary.
+
+               Initial values for an object can be specified by following
+               the variable name by an equals sign and a list of values
+               enclosed in a pair of braces.  For example:
+
+                       obj point pt = {5, 6};
+
+               The OBJ statement can also be used in declarations to set
+               variables as being objects from the beginning.  If multiple
+               variables are specified, then each one is defined as the
+               specified object type.  Examples of declarations are:
+
+                       local obj point temp1;
+                       static obj point temp2 = {4, 3};
+                       global obj point p1, p2, p3;
+
+       EXIT string
+       QUIT string
+
+               This command is used in two cases.  At the top command
+               line level, quit will exit from the calculator.  This
+               is the normal way to leave the calculator.  In any other
+               use, quit will abort the current calculation as if an
+               error had occurred.  If a string is given, then the string
+               is printed as the reason for quitting, otherwise a general
+               quit message is printed.  The routine name and line number
+               which executed the quit is also printed in either case.
+
+               Quit is useful when a routine detects invalid arguments,
+               in order to stop a calculation cleanly.  For example,
+               for a square root routine, an error can be given if the
+               supplied parameter was a negative number, as in:
+
+                       define mysqrt(n)
+                       {
+                               if (n < 0)
+                                       quit "Negative argument";
+                               ...
+                       }
+
+               Exit is an alias for quit.
+
+
+       PRINT exprs
+
+               For interactive expression evaluation, the values of all
+               typed-in expressions are automatically displayed to the
+               user.  However, within a function or loop, the printing of
+               results must be done explicitly.  This can be done using
+               the 'printf' or 'fprintf' functions, as in standard C, or
+               else by using the built-in 'print' statement.  The advantage
+               of the print statement is that a format string is not needed.
+               Instead, the given values are simply printed with zero or one
+               spaces between each value.
+
+               Print accepts a list of expressions, separated either by
+               commas or colons.  Each expression is evaluated in order
+               and printed, with no other output, except for the following
+               special cases.  The comma which separates expressions prints
+               a single space, and a newline is printed after the last
+               expression unless the statement ends with a colon.  As
+               examples:
+
+                       print 3, 4;             prints "3 4" and newline.
+                       print 5:;               prints "5" with no newline.
+                       print 'a' : 'b' , 'c';  prints "ab c" and newline.
+                       print;                  prints a newline.
+
+               For numeric values, the format of the number depends on the
+               current "mode" configuration parameter.  The initial mode
+               is to print real numbers, but it can be changed to other
+               modes such as exponential, decimal fractions, or hex.
+
+               If a matrix or list is printed, then the elements contained
+               within the matrix or list will also be printed, up to the
+               maximum number specified by the "maxprint" configuration
+               parameter.  If an element is also a matrix or a list, then
+               their values are not recursively printed.  Objects are printed
+               using their user-defined routine.  Printing a file value
+               prints the name of the file that was opened.
+
+
+       SHOW item
+
+               This command displays some information.
+               The following is a list of the various items:
+
+                       builtins        built in functions
+                       globals         global variables
+                       functions       user-defined functions
+                       objfuncs        possible object functions
+                       memory          memory usage
+
+               Singular forms of item may also be used.  The following 
+               statement are the same:
+
+                       show builtins
+                       show builtin
+       
+
+       Also see the help topic:
+
+               command         top level commands
diff --git a/usr/src/contrib/calc-2.9.3t6/help/todo b/usr/src/contrib/calc-2.9.3t6/help/todo
new file mode 100644 (file)
index 0000000..8c20b02
--- /dev/null
@@ -0,0 +1,219 @@
+Needed enhancements
+
+       Send calc comments, suggestions, bug fixes, enhancements and
+       interesting calc scripts that you would like you see included in
+       future distributions to:
+
+               dbell@canb.auug.org.au
+               chongo@toad.com
+
+       The following items are in the calc wish list.  Programs like this
+       can be extended and improved forever.
+
+       *  Implement an autoload feature.  Associate a calc library filename
+          with a function or global variable.  On the first reference of
+          such item, perform an automatic load of that file.
+
+       *  Use faster multiply and divide algorithms for large numbers.
+
+       *  Add error handling statements, so that QUITs, errors from the 
+          'eval' function, division by zeroes, and so on can be caught.
+          This should be done using syntax similar to:
+
+                   ONERROR statement DO statement;
+
+          Something like signal isn't versatile enough.
+
+       *  Add a debugging capability so that functions can be single stepped,
+          breakpoints inserted, variables displayed, and so on.
+
+       *  Figure out how to write all variables out to a file, including
+          deeply nested arrays, lists, and objects.
+
+       *  Implement pointers.
+
+       *  Eliminate the need for the define keyword by doing smarter parsing.
+
+       *  Allow results of a command (or all commands) to be re-directed to a 
+          file or piped into a command.
+
+       *  Add some kind of #include and #define facility.  Perhaps use
+          the C pre-processor itself?
+
+       *  Allow one to undefine anything.  Allow one to test if anything
+          is defined.
+
+       *  Support a more general input and output base mode other than
+          just dec, hex or octal.
+
+       *  Implement a form of symbolic algebra.  Work on this has already
+          begun.  This will use backquotes to define expressions, and new
+          functions will be able to act on expressions.  For example:
+
+               x = `hello * strlen(mom)`;
+               x = sub(x, `hello`, `hello + 1`);
+               x = sub(x, `hello`, 10, `mom`, "curds");
+               eval(x);
+
+          prints 55.
+       
+       *  Place the results of previous commands into a parallel history list.
+          Add a binding that returns the saved result of the command so
+          that one does not need to re-execute a previous command simply
+          to obtain its value.
+
+          If you have a command that takes a very long time to execute,
+          it would be nice if you could get at its result without having
+          to spend the time to reexecute it.
+
+       *  Add a binding to delete a value from the history list.
+
+          One may need to remove a large value from the history list if
+          it is very large.  Deleting the value would replace the history
+          entry with a null value.
+
+       *  Add a binding to delete a command from the history list.
+
+          Since you can delete values, you might as well be able to
+          delete commands.
+
+       *  All one to alter the size of the history list thru config().
+
+          In some cases, 256 values is too small, in others it is too large.
+
+       *  Add a builtin that returns a value from the history list.
+          As an example:
+
+               histval(-10)
+       
+          returns the 10th value on the history value list, if such 
+          a value is in the history list (null otherwise).  And:
+
+               histval(23)
+       
+          return the value of the 23rd command given to calc, if
+          such a value is in the history list (null otherwise).
+
+          It would be very helpful to use the history values in
+          subsequent equations.
+
+       *  Add a builtin that returns command as a string from the
+          history list.  As an example:
+
+               history(-10)
+       
+          returns a string containing the 10th command on the
+          history list, if a such a value is in the history list 
+          (empty string otherwise).  And:
+
+               history(23)
+       
+          return the string containing the 23rd command given to calc, if
+          such a value is in the history list (empty string otherwise).
+
+          One could use the eval() function to re-evaluate the command.
+
+       *  Allow one to optionally restore the command number to calc 
+          prompts.  When going back in the history list, indicate the 
+          command number that is being examined.
+
+          The command number was a useful item.  When one is scanning the
+          history list, knowing where you are is hard without it.  It can
+          get confusing when the history list wraps or when you use
+          search bindings.  Command numbers would be useful in
+          conjunction with positive args for the history() and histval()
+          functions as suggested above.
+
+       *  Add a builtin that returns the current command number.
+          For example:
+
+               cmdnum()
+
+          returns the current command number.
+
+          This would allow one to tag a value in the history list.  One
+          could save the result of cmdnum() in a variable and later use
+          it as an arg to the histval() or history() functions.
+
+       *  Add a builtin to determine if an object as been defined.
+          For example:
+
+               isobjdef("surd")
+
+          would return true if one had previously defined the
+          surd object.  I.e., if "obj surd {...};" had been
+          executed.
+
+          One cannot redefine an object.  If a script defines an object,
+          one cannot reload it without getting lots of already defined
+          errors.  If two scripts needed the same object, both could
+          define it and use isobjdef() to avoid redefinition problems.
+
+       *  Add a builtin to determine if a function as been defined.
+          For example:
+
+               isfunct("foo")
+
+          would return true if foo has been defined as a function.
+
+       *  Permit one to destroy an object.
+
+          What if one does want to redefine an object?  Consider the case
+          where one it debugging a script and wants to reload it.  If
+          that script defines an object you are doomed.  Perhaps
+          destroying a object would undefine all of its related functions
+          and values?
+
+       *  One some machines (such as the 486), floating point can be faster 
+          than integer arithmetic.  Often such floating point would allow
+          for a larger base than 2^16, allowing calc to run even faster.
+          Allow calc to take advantage of such hardware.
+       
+       *  Add NAN (Not A Number) to calc.  Where is it reasonable, change 
+          calc to process these values in way similar to that of the IEEE 
+          floating point.
+       
+       *  Add a factoring builtin functions.  Provide functions that perform 
+          multiple polynomial quadratic sieves, elliptic curve, difference 
+          of two squares, N-1 factoring as so on.  Provide a easy general 
+          factoring builtin (say factor(foo)) that would attempt to apply
+          whatever process was needed based on the value.
+
+          Factoring builtins would return a matrix of factors.
+
+          It would be handy to configure, via config(), the maximum time
+          that one should try to factor a number.  By default the time
+          should be infinite.  If one set the time limit to a finite
+          value and the time limit was exceeded, the factoring builtin
+          would return whatever if had found thus far, even if no new 
+          factors had been found.
+
+          Another factoring configuration interface, via config(), that
+          is needed would be to direct the factoring builtins to return
+          as soon as a factor was found.
+
+       *  Allow one to config calc break up long output lines.
+
+          The command:  calc '2^100000'  will produce one very long
+          line.  Many times this is reasonable.  Long output lines
+          are a problem for some utilities.  It would be nice if one
+          could configure, via config(), calc to fold long lines.
+
+          By default, calc should continue to produce long lines.
+
+          One option to config should be to specify the length to
+          fold output.  Another option should be to append a trailing
+          \ on folded lines (as some symbolic packages use).
+
+       *  Add scanf() and fscanf() functions.
+
+          The scanf function should be able to handle both long lines
+          and split lines with trailing \'s.  It should also be able
+          to ignore the leading ~.
+
+       *  Add the ability to read and write a value in some binary form.
+
+          Clearly this is easy for non-neg integers.  The question of
+          everything else is worth pondering.
+       
+       *  Allow one to use the READ and WRITE commands inside a function.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/types b/usr/src/contrib/calc-2.9.3t6/help/types
new file mode 100644 (file)
index 0000000..4def492
--- /dev/null
@@ -0,0 +1,102 @@
+Builtin types
+
+       The calculator has the following built-in types.
+
+       null value
+               This is the undefined value type.  The function 'null'
+               returns this value.  Functions which do not explicitly
+               return a value return this type.  If a function is called
+               with fewer parameters than it is defined for, then the
+               missing parameters have the null type.  The null value is
+               false if used in an IF test.
+
+       rational numbers
+               This is the basic data type of the calculator.
+               These are fractions whose numerators and denominators
+               can be arbitrarily large.  The fractions are always
+               in lowest terms.  Integers have a denominator of 1.
+               The numerator of the number contains the sign, so that
+               the denominator is always positive.  When a number is
+               entered in floating point or exponential notation, it is
+               immediately converted to the appropriate fractional value.
+               Printing a value as a floating point or exponential value
+               involves a conversion from the fractional representation.
+
+               Numbers are stored in binary format, so that in general,
+               bit tests and shifts are quicker than multiplies and divides.
+               Similarly, entering or displaying of numbers in binary,
+               octal, or hex formats is quicker than in decimal.  The
+               sign of a number does not affect the bit representation
+               of a number.
+
+       complex numbers
+               Complex numbers are composed of real and imaginary parts,
+               which are both fractions as defined above.  An integer which
+               is followed by an 'i' character is a pure imaginary number.
+               Complex numbers such as "2+3i" when typed in, are processed
+               as the sum of a real and pure imaginary number, resulting
+               in the desired complex number.  Therefore, parenthesis are
+               sometimes necessary to avoid confusion, as in the two values:
+
+                       1+2i ^2         (which is -3)
+                       (1+2i) ^2       (which is -3+4i)
+
+               Similar care is required when entering fractional complex
+               numbers.  Note the differences below:
+
+                       3/4i            (which is -(3/4)i)
+                       3i/4            (which is (3/4)i)
+
+               The imaginary unit itself is input using "1i".
+
+       strings
+               Strings are a sequence of zero or more characters.
+               They are input using either of the single or double
+               quote characters.  The quote mark which starts the
+               string also ends it.  Various special characters can
+               also be inserted using back-slash.  Example strings:
+
+                       "hello\n"
+                       "that's all"
+                       'lots of """"'
+                       'a'
+                       ""
+
+               There is no distinction between single character and
+               multi-character strings.  The 'str' and 'ord' functions
+               will convert between a single character string and its
+               numeric value.  The 'str' and 'eval' functions will
+               convert between longer strings and the corresponding
+               numeric value (if legal).  The 'strcat', 'strlen', and
+               'substr' functions are also useful.
+
+       matrices
+               These are one to four dimensional matrices, whose minimum
+               and maximum bounds can be specified at runtime.  Unlike C,
+               the minimum bounds of a matrix do not have to start at 0.
+               The elements of a matrix can be of any type.  There are
+               several built-in functions for matrices.  Matrices are
+               created using the 'mat' statement.
+
+       associations
+               These are one to four dimensional matrices which can be
+               indexed by arbitrary values, instead of just integers.
+               These are also known as associative arrays.  The elements of
+               an association can be of any type.  Very few operations are
+               permitted on an association except for indexing.  Associations
+               are created using the 'assoc' function.
+
+       lists
+               These are a sequence of values, which are linked together
+               so that elements can be easily be inserted or removed
+               anywhere in the list.  The values can be of any type.
+               Lists are created using the 'list' function.
+
+       files
+               These are text files opened using stdio.  Files may be opened
+               for sequential reading, writing, or appending.  Opening a
+               file using the 'fopen' function returns a value which can
+               then be used to perform I/O to that file.  File values can
+               be copied by normal assignments between variables, or by
+               using the result of the 'files' function.  Such copies are
+               indistinguishable from each other.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/usage b/usr/src/contrib/calc-2.9.3t6/help/usage
new file mode 100644 (file)
index 0000000..1b2bf61
--- /dev/null
@@ -0,0 +1,18 @@
+Calc command line
+
+       Calc has the following command line:
+
+               calc [-h] [-q] [calc_command ...]
+
+               -h      print a help message  (equivalent to the
+                       help command)
+
+               -q      By default, calc executes each file specified
+                       in the :-separated list found in the environment
+                       variable $CALCRC.  If $CALCRC does not exist,
+                       an internal default is used.
+
+       If some calc_commands arguments are given on the command line,
+       calc executes these commands and then exists.  If no command
+       line arguments are given, calc prompts and reads commands
+       from standard input.
diff --git a/usr/src/contrib/calc-2.9.3t6/help/variable b/usr/src/contrib/calc-2.9.3t6/help/variable
new file mode 100644 (file)
index 0000000..55fd26a
--- /dev/null
@@ -0,0 +1,82 @@
+Variable declarations
+
+       Variables can be declared as either being global, local, or static.
+       Global variables are visible to all functions and on the command
+       line, and are permanent.  Local variables are visible only within
+       a single function or command sequence.  When the function or command
+       sequence returns, the local variables are deleted.  Static variables
+       are permanent like global variables, but are only visible within the
+       same input file or function where they are defined.
+
+       To declare one or more variables, the 'local', 'global', or 'static'
+       keywords are used, followed by the desired list of variable names,
+       separated by commas.  The definition is terminated with a semicolon.
+       Examples of declarations are:
+
+               local   x, y, z;
+               global  fred;
+               local   foo, bar;
+               static  var1, var2, var3;
+
+       Variables may have initializations applied to them.  This is done
+       by following the variable name by an equals sign and an expression.
+       Global and local variables are initialized each time that control
+       reaches them (e.g., at the entry to a function which contains them).
+       Static variables are initialized once only, at the time that control
+       first reaches them (but in future releases the time of initialization
+       may change).  Unlike in C, expressions for static variables may
+       contain function calls and refer to variables.  Examples of such
+       initializations are:
+
+               local   a1 = 7, a2 = 3;
+               static  b = a1 + sin(a2);
+
+       Within function declarations, all variables must be defined.
+       But on the top level command line, assignments automatically define
+       global variables as needed.  For example, on the top level command
+       line, the following defines the global variable x if it had not
+       already been defined:
+
+               x = 7
+
+       The static keyword may be used at the top level command level to
+       define a variable which is only accessible interactively, or within
+       functions defined interactively.
+
+       Variables have no fixed type, thus there is no need or way to
+       specify the types of variables as they are defined.  Instead, the
+       types of variables change as they are assigned to or are specified
+       in special statements such as 'mat' and 'obj'.  When a variable is
+       first defined using 'local', 'global', or 'static', it has the
+       value of zero.
+
+       If a procedure defines a local or static variable name which matches
+       a global variable name, or has a parameter name which matches a
+       global variable name, then the local variable or parameter takes
+       precedence within that procedure, and the global variable is not
+       directly accessible.
+
+       The MAT and OBJ keywords may be used within a declaration statement
+       in order to initially define variables as that type.  Initialization
+       of these variables are also allowed.  Examples of such declarations
+       are:
+
+               static mat table[3] = {5, 6, 7};
+               local obj point p1, p2;
+
+       There are no pointers in the calculator language, thus all
+       arguments to user-defined functions are normally passed by value.
+       This is true even for matrices, strings, and lists.  In order
+       to circumvent this, the '&' operator is allowed before a variable
+       when it is an argument to a function.  When this is done, the
+       address of the variable is passed to the function instead of its
+       value.  This is true no matter what the type of the variable is.
+       This allows for fast calls of functions when the passed variable
+       is huge (such as a large array).  However, the passed variable can
+       then be changed by the function if the parameter is assigned into.
+       The function being called does not need to know if the variable
+       is being passed by value or by address.
+
+       Built-in functions and object functions always accept their
+       arguments as addresses, thus there is no need to use '&' when
+       calling built-in functions.
diff --git a/usr/src/contrib/calc-2.9.3t6/hist.c b/usr/src/contrib/calc-2.9.3t6/hist.c
new file mode 100644 (file)
index 0000000..ea1592b
--- /dev/null
@@ -0,0 +1,1404 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Adapted from code written by Stephen Rothwell.
+ *
+ * Interactive readline module.  This is called to read lines of input,
+ * while using emacs-like editing commands within a command stack.
+ * The key bindings for the editing commands are (slightly) configurable.
+ */
+
+#include <stdio.h>
+#include <ctype.h>
+#include <pwd.h>
+#include "hist.h"
+#include "terminal.h"
+#include "have_string.h"
+
+
+#if defined(USE_TERMIOS)
+# include <termios.h>
+# define TTYSTRUCT     struct  termios
+#else /* USE_SGTTY */
+# if defined(USE_TERMIO)
+#  include <termio.h>
+#  define TTYSTRUCT    struct  termio
+# else /* USE_TERMIO */
+   /* assume USE_SGTTY */
+#  include <sys/ioctl.h>
+#  define TTYSTRUCT    struct  sgttyb
+# endif /* USE_TERMIO */
+#endif /* USE_SGTTY */
+
+#ifdef HAVE_STRING_H
+# include <string.h>
+#endif
+
+
+#define        STDIN           0
+#define        SAVE_SIZE       256             /* size of save buffer */
+#define        MAX_KEYS        60              /* number of key bindings */
+
+
+#define CONTROL(x)             ((char)(((int)(x)) & 0x1f))
+
+static struct {
+       char    *prompt;
+       char    *buf;
+       char    *pos;
+       char    *end;
+       char    *mark;
+       int     bufsize;
+       int     linelen;
+       int     histcount;
+       int     curhist;
+} HS;
+
+
+typedef        void (*FUNCPTR)();
+
+typedef struct {
+       char    *name;
+       FUNCPTR func;
+} FUNC;
+
+
+static void    flush_input(), start_of_line(), end_of_line();
+static void    forward_char(), backward_char(), forward_word();
+static void    backward_word(), delete_char(), forward_kill_char();
+static void    backward_kill_char(), forward_kill_word(), kill_line();
+static void    new_line(), save_line(), forward_history();
+static void    backward_history(), insert_char();
+static void    goto_line(), list_history(), refresh_line(), swap_chars();
+static void    set_mark(), yank(), save_region(), kill_region();
+static void    reverse_search(), quote_char(), uppercase_word();
+static void    lowercase_word(), ignore_char(), arrow_key(), quit_calc();
+
+
+static FUNC    funcs[] =
+{
+       {"ignore-char",         ignore_char},
+       {"flush-input",         flush_input},
+       {"start-of-line",       start_of_line},
+       {"end-of-line",         end_of_line},
+       {"forward-char",        forward_char},
+       {"backward-char",       backward_char},
+       {"forward-word",        forward_word},
+       {"backward-word",       backward_word},
+       {"delete-char",         delete_char},
+       {"forward-kill-char",   forward_kill_char},
+       {"backward-kill-char",  backward_kill_char},
+       {"forward-kill-word",   forward_kill_word},
+       {"uppercase-word",      uppercase_word},
+       {"lowercase-word",      lowercase_word},
+       {"kill-line",           kill_line},
+       {"goto-line",           goto_line},
+       {"new-line",            new_line},
+       {"save-line",           save_line},
+       {"forward-history",     forward_history},
+       {"backward-history",    backward_history},
+       {"insert-char",         insert_char},
+       {"list-history",        list_history},
+       {"refresh-line",        refresh_line},
+       {"swap-chars",          swap_chars},
+       {"set-mark",            set_mark},
+       {"yank",                yank},
+       {"save-region",         save_region},
+       {"kill-region",         kill_region},
+       {"reverse-search",      reverse_search},
+       {"quote-char",          quote_char},
+       {"arrow-key",           arrow_key},
+       {"quit",                quit_calc},
+       {NULL,                  NULL}
+};
+
+
+typedef struct key_ent KEY_ENT;
+typedef struct key_map KEY_MAP;
+
+struct key_ent {
+       FUNCPTR         func;
+       KEY_MAP         *next;
+};
+
+
+struct key_map {
+       char            *name;
+       KEY_ENT         default_ent;
+       KEY_ENT         *map[256];
+};
+
+
+static char    base_map_name[] = "base-map";
+static char    esc_map_name[] = "esc-map";
+
+
+static KEY_MAP maps[] = {
+       {base_map_name},
+       {esc_map_name}
+};
+
+
+#define        INTROUND        (sizeof(int) - 1)
+#define        HISTLEN(hp)     ((((hp)->len + INTROUND) & ~INTROUND) + sizeof(int))
+#define        HISTOFFSET(hp)  (((char *) (hp)) - histbuf)
+#define        FIRSTHIST       ((HIST *) histbuf)
+#define        NEXTHIST(hp)    ((HIST *) (((char *) (hp)) + HISTLEN(hp)))
+
+
+typedef struct {
+       int     len;            /* length of data */
+       char    data[1];        /* varying length data */
+} HIST;
+
+
+static int             inited;
+static int             canedit;
+static int             histused;
+static int             key_count;
+static int             save_len;
+static TTYSTRUCT       oldtty;
+static KEY_MAP         *cur_map;
+static KEY_MAP         *base_map;
+static KEY_ENT         key_table[MAX_KEYS];
+static char            histbuf[HIST_SIZE + 1];
+static char            save_buffer[SAVE_SIZE];
+
+
+static FUNCPTR find_func();
+static HIST    *get_event();
+static HIST    *find_event();
+static void    read_key();
+static void    erasechar();
+static void    newline();
+static void    backspace();
+static void    beep();
+static void    echo_char();
+static void    echo_string();
+static void    savetext();
+static void    memrcpy();
+static int     read_bindings();
+static int     in_word();
+
+
+/*
+ * Read a line into the specified buffer.  The line ends in a newline,
+ * and is NULL terminated.  Returns the number of characters read, or
+ * zero on an end of file or error.  The prompt is printed before reading
+ * the line.
+ */
+int
+hist_getline(prompt, buf, len)
+       char    *prompt;
+       char    *buf;
+       int     len;
+{
+       if (!inited)
+               (void) hist_init((char *) NULL);
+
+       HS.prompt = prompt;
+       HS.bufsize = len - 2;
+       HS.buf = buf;
+       HS.pos = buf;
+       HS.end = buf;
+       HS.mark = NULL;
+       HS.linelen = -1;
+
+       fputs(prompt, stdout);
+       fflush(stdout);
+
+       if (!canedit) {
+               if (fgets(buf, len, stdin) == NULL)
+                       return 0;
+               return strlen(buf);
+       }
+
+       while (HS.linelen < 0)
+               read_key();
+
+       return HS.linelen;
+}
+
+
+/*
+ * Initialize the module by reading in the key bindings from the specified
+ * filename, and then setting the terminal modes for noecho and cbreak mode.
+ * If the supplied filename is NULL, then a default filename will be used.
+ * Returns zero if successful, or a nonzero error code if unsuccessful.
+ * If this routine fails, hist_getline, hist_saveline, and hist_term can
+ * still be called but all fancy editing is disabled.
+ */
+int
+hist_init(filename)
+       char    *filename;
+{
+       TTYSTRUCT       newtty;
+
+       if (inited)
+               return HIST_INITED;
+
+       inited = 1;
+       canedit = 0;
+
+       if (filename == NULL)
+               filename = HIST_BINDING_FILE;
+
+       if (read_bindings(filename))
+               return HIST_NOFILE;
+
+#ifdef USE_SGTTY
+       if (ioctl(STDIN, TIOCGETP, &oldtty) < 0)
+               return HIST_NOTTY;
+
+       newtty = oldtty;
+       newtty.sg_flags &= ~ECHO;
+       newtty.sg_flags |= CBREAK;
+
+       if (ioctl(STDIN, TIOCSETP, &newtty) < 0)
+               return HIST_NOTTY;
+#endif
+
+#ifdef USE_TERMIO
+       if (ioctl(STDIN, TCGETA, &oldtty) < 0)
+               return HIST_NOTTY;
+
+       newtty = oldtty;
+       newtty.c_lflag &= ~(ECHO | ECHOE | ECHOK);
+       newtty.c_iflag |= ISTRIP;
+       newtty.c_lflag &= ~ICANON;
+       newtty.c_cc[VMIN] = 1;
+       newtty.c_cc[VTIME] = 0;
+
+       if (ioctl(STDIN, TCSETAW, &newtty) < 0)
+               return HIST_NOTTY;
+#endif
+
+#ifdef USE_TERMIOS
+       if (tcgetattr(STDIN, &oldtty) < 0)
+               return HIST_NOTTY;
+
+       newtty = oldtty;
+       newtty.c_lflag &= ~(ECHO | ECHOE | ECHOK);
+       newtty.c_iflag |= ISTRIP;
+       newtty.c_lflag &= ~ICANON;
+       newtty.c_cc[VMIN] = 1;
+       newtty.c_cc[VTIME] = 0;
+
+       if (tcsetattr(STDIN, TCSANOW, &newtty) < 0)
+               return HIST_NOTTY;
+#endif
+
+       canedit = 1;
+
+       return HIST_SUCCESS;
+}
+
+
+/*
+ * Reset the terminal modes just before exiting.
+ */
+void
+hist_term()
+{
+       if (!inited || !canedit) {
+               inited = 0;
+               return;
+       }
+
+#ifdef USE_SGTTY
+       (void) ioctl(STDIN, TIOCSETP, &oldtty);
+#endif
+
+#ifdef USE_TERMIO
+       (void) ioctl(STDIN, TCSETAW, &oldtty);
+#endif
+
+#ifdef USE_TERMIOS
+       (void) tcsetattr(STDIN, TCSANOW, &oldtty);
+#endif
+}
+
+
+static KEY_MAP *
+find_map(map)
+       char    *map;
+{
+       int     i;
+
+       for (i = 0; i < sizeof(maps) / sizeof(maps[0]); i++) {
+               if (strcmp(map, maps[i].name) == 0)
+                       return &maps[i];
+       }
+       return NULL;
+}
+
+
+static void
+unbind_key(map, key)
+       int key;
+       KEY_MAP         *map;
+{
+       map->map[key] = NULL;
+}
+
+
+static void
+raw_bind_key(map, key, func, next_map)
+       int key;
+       KEY_MAP         *map;
+       FUNCPTR         func;
+       KEY_MAP         *next_map;
+{
+       if (map->map[key] == NULL) {
+               if (key_count >= MAX_KEYS)
+                       return;
+               map->map[key] = &key_table[key_count++];
+       }
+       map->map[key]->func = func;
+       map->map[key]->next = next_map;
+}
+
+
+static KEY_MAP *
+do_map_line(line)
+       char    line[];
+{
+       char    *cp;
+       char    *map_name;
+
+       cp = line;
+       while (isspace(*cp))
+               cp++;
+       if (*cp == '\0')
+               return NULL;
+       map_name = cp;
+       while ((*cp != '\0') && !isspace(*cp))
+               cp++;
+       *cp = '\0';
+       return find_map(map_name);
+}
+
+
+static void
+do_bind_line(map, line)
+       KEY_MAP         *map;
+       char            line[];
+{
+       char            *cp;
+       char            key;
+       char            *func_name;
+       char            *next_name;
+       KEY_MAP         *next;
+       FUNCPTR         func;
+
+       if (map == NULL)
+               return;
+       cp = line;
+       key = *cp++;
+       if (*cp == '\0') {
+               unbind_key(map, key);
+               return;
+       }
+       if (key == '^') {
+               if (*cp == '?') {
+                       key = 0177;
+                       cp++;
+               } else
+                       key = CONTROL(*cp++);
+       }
+       else if (key == '\\')
+               key = *cp++;
+
+       while (isspace(*cp))
+               cp++;
+       if (*cp == '\0') {
+               unbind_key(map, key);
+               return;
+       }
+
+       func_name = cp;
+       while ((*cp != '\0') && !isspace(*cp))
+               cp++;
+       if (*cp) {
+               *cp++ = '\0';
+               while (isspace(*cp))
+                       cp++;
+       }
+       func = find_func(func_name);
+       if (func == NULL) {
+               fprintf(stderr, "Unknown function \"%s\"\n", func_name);
+               return;
+       }
+
+       if (*cp == '\0') {
+               next = map->default_ent.next;
+               if (next == NULL)
+                       next = base_map;
+       } else {
+               next_name = cp;
+               while ((*cp != '\0') && !isspace(*cp))
+                       cp++;
+               if (*cp) {
+                       *cp++ = '\0';
+                       while (isspace(*cp))
+                               cp++;
+               }
+               next = find_map(next_name);
+               if (next == NULL)
+                       return;
+       }
+       raw_bind_key(map, key, func, next);
+}
+
+
+static void
+do_default_line(map, line)
+       KEY_MAP         *map;
+       char            *line;
+{
+       char            *cp;
+       char            *func_name;
+       char            *next_name;
+       KEY_MAP         *next;
+       FUNCPTR         func;
+
+       if (map == NULL)
+               return;
+       cp = line;
+       while (isspace(*cp))
+               cp++;
+       if (*cp == '\0')
+               return;
+
+       func_name = cp;
+       while ((*cp != '\0') && !isspace(*cp))
+               cp++;
+       if (*cp != '\0')
+       {
+               *cp++ = '\0';
+               while (isspace(*cp))
+                       cp++;
+       }
+       func = find_func(func_name);
+       if (func == NULL)
+               return;
+
+       if (*cp == '\0')
+               next = map;
+       else
+       {
+               next_name = cp;
+               while ((*cp != '\0') && !isspace(*cp))
+                       cp++;
+               if (*cp != '\0')
+               {
+                       *cp++ = '\0';
+                       while (isspace(*cp))
+                               cp++;
+               }
+               next = find_map(next_name);
+               if (next == NULL)
+                       return;
+       }
+
+       map->default_ent.func = func;
+       map->default_ent.next = next;
+}
+
+
+/*
+ * Read bindings from specified file.
+ * Returns nonzero on error.
+ */
+static int
+read_bindings(bindfile)
+       char    *bindfile;
+{
+       char    *cp;
+       KEY_MAP *input_map;
+       FILE    *fp;
+       char    line[100];
+
+       base_map = find_map(base_map_name);
+       cur_map = base_map;
+       input_map = base_map;
+
+       fp = fopen(bindfile, "r");
+       if (fp == NULL)
+               return 1;
+
+       while (fgets(line, sizeof(line) - 1, fp)) {
+               cp = line;
+               while (isspace(*cp))
+                       cp++;
+
+               if ((*cp == '\0') || (*cp == '#') || (*cp == '\n'))
+                       continue;
+
+               if (cp[strlen(cp) - 1] == '\n')
+                       cp[strlen(cp) - 1] = '\0';
+
+               if (memcmp(cp, "map", 3) == 0)
+                       input_map = do_map_line(&cp[3]);
+               else if (memcmp(cp, "default", 7) == 0)
+                       do_default_line(input_map, &cp[7]);
+               else
+                       do_bind_line(input_map, cp);
+       }
+       fclose(fp);
+       return 0;
+}
+
+
+static void
+read_key()
+{
+       KEY_ENT         *ent;
+       int             key;
+
+       fflush(stdout);
+       key = fgetc(stdin);
+       if (key == EOF) {
+               HS.linelen = 0;
+               HS.buf[0] = '\0';
+               return;
+       }
+
+       ent = cur_map->map[key];
+       if (ent == NULL)
+               ent = &cur_map->default_ent;
+       if (ent->next)
+               cur_map = ent->next;
+       if (ent->func)
+               (*ent->func)(key);
+       else
+               insert_char(key);
+}
+
+
+/*
+ * Return the Nth history event, indexed from zero.
+ * Earlier history events are lower in number.
+ */
+static HIST *
+get_event(n)
+       int n;
+{
+       register HIST * hp;
+
+       if ((n < 0) || (n >= HS.histcount))
+               return NULL;
+       hp = FIRSTHIST;
+       while (n-- > 0)
+               hp = NEXTHIST(hp);
+       return hp;
+}
+
+
+/*
+ * Search the history list for the specified pattern.
+ * Returns the found history, or NULL.
+ */
+static HIST *
+find_event(pat, len)
+       int len;
+       char *  pat;
+{
+       register HIST * hp;
+
+       for (hp = FIRSTHIST; hp->len; hp = NEXTHIST(hp)) {
+               if ((hp->len == len) && (memcmp(hp->data, pat, len) == 0))
+                       return hp;
+       }
+       return NULL;
+}
+
+
+/*
+ * Insert a line into the end of the history table.
+ * If the line already appears in the table, then it is moved to the end.
+ * If the table is full, then the earliest commands are deleted as necessary.
+ * Warning: the incoming line cannot point into the history table.
+ */
+void
+hist_saveline(line, len)
+       int len;
+       char *  line;
+{
+       HIST *  hp;
+       HIST *  hp2;
+       int     left;
+
+       if ((len > 0) && (line[len - 1] == '\n'))
+               len--;
+       if (len <= 0)
+               return;
+
+       /*
+        * See if the line is already present in the history table.
+        * If so, and it is already at the end, then we are all done.
+        * Otherwise delete it since we will reinsert it at the end.
+        */
+       hp = find_event(line, len);
+       if (hp) {
+               hp2 = NEXTHIST(hp);
+               left = histused - HISTOFFSET(hp2);
+               if (left <= 0)
+                       return;
+               histused -= HISTLEN(hp);
+               memcpy(hp, hp2, left + 1);
+               HS.histcount--;
+       }
+
+       /*
+        * If there is not enough room left in the history buffer to add
+        * the new command, then repeatedly delete the earliest command
+        * as many times as necessary in order to make enough room.
+        */
+       while ((histused + len) >= HIST_SIZE) {
+               hp = (HIST *) histbuf;
+               hp2 = NEXTHIST(hp);
+               left = histused - HISTOFFSET(hp2);
+               histused -= HISTLEN(hp);
+               memcpy(hp, hp2, left + 1);
+               HS.histcount--;
+       }
+
+       /*
+        * Add the line to the end of the history table.
+        */
+       hp = (HIST *) &histbuf[histused];
+       hp->len = len;
+       memcpy(hp->data, line, len);
+       histused += HISTLEN(hp);
+       histbuf[histused] = 0;
+       HS.curhist = ++HS.histcount;
+}
+
+
+/*
+ * Find the function for a specified name.
+ */
+static FUNCPTR
+find_func(name)
+       char    *name;
+{
+       FUNC    *fp;
+
+       for (fp = funcs; fp->name; fp++) {
+               if (strcmp(fp->name, name) == 0)
+                       return fp->func;
+       }
+       return NULL;
+}
+
+
+static void
+arrow_key()
+{
+       switch (fgetc(stdin)) {
+               case 'A':
+                       backward_history();
+                       break;
+               case 'B':
+                       forward_history();
+                       break;
+               case 'C':
+                       forward_char();
+                       break;
+               case 'D':
+                       backward_char();
+                       break;
+       }
+}
+
+
+static void
+back_over_char(ch)
+       char    ch;
+{
+       backspace();
+       if (!isprint(ch))
+               backspace();
+}
+
+
+static void
+remove_char(ch)
+       char    ch;
+{
+       erasechar();
+       if (!isprint(ch))
+               erasechar();
+}
+
+
+static void
+echo_rest_of_line()
+{
+       echo_string(HS.pos, HS.end - HS.pos);
+}
+
+
+static void
+goto_start_of_line()
+{
+       while (HS.pos > HS.buf)
+               back_over_char(*--HS.pos);
+}
+
+
+static void
+goto_end_of_line()
+{
+       echo_rest_of_line();
+       HS.pos = HS.end;
+}
+
+
+static void
+decrement_end(n)
+       int n;
+{
+       HS.end -= n;
+       if (HS.mark && (HS.mark > HS.end))
+               HS.mark = NULL;
+}
+
+
+static void
+ignore_char()
+{
+}
+
+
+static void
+flush_input()
+{
+       echo_rest_of_line();
+       while (HS.end > HS.buf)
+               remove_char(*--HS.end);
+       HS.pos = HS.buf;
+       HS.mark = NULL;
+}
+
+
+static void
+start_of_line()
+{
+       goto_start_of_line();
+}
+
+
+static void
+end_of_line()
+{
+       goto_end_of_line();
+}
+
+
+static void
+forward_char()
+{
+       if (HS.pos < HS.end)
+               echo_char(*HS.pos++);
+}
+
+
+static void
+backward_char()
+{
+       if (HS.pos > HS.buf)
+               back_over_char(*--HS.pos);
+}
+
+
+static void
+uppercase_word()
+{
+       while ((HS.pos < HS.end) && !in_word(*HS.pos))
+               echo_char(*HS.pos++);
+       while ((HS.pos < HS.end) && in_word(*HS.pos)) {
+               if ((*HS.pos >= 'a') && (*HS.pos <= 'z'))
+                       *HS.pos += 'A' - 'a';
+               echo_char(*HS.pos++);
+       }
+}
+
+
+static void
+lowercase_word()
+{
+       while ((HS.pos < HS.end) && !in_word(*HS.pos))
+               echo_char(*HS.pos++);
+       while ((HS.pos < HS.end) && in_word(*HS.pos)) {
+               if ((*HS.pos >= 'A') && (*HS.pos <= 'Z'))
+                       *HS.pos += 'a' - 'A';
+               echo_char(*HS.pos++);
+       }
+}
+
+
+static void
+forward_word()
+{
+       while ((HS.pos < HS.end) && !in_word(*HS.pos))
+               echo_char(*HS.pos++);
+       while ((HS.pos < HS.end) && in_word(*HS.pos))
+               echo_char(*HS.pos++);
+}
+
+
+static void
+backward_word()
+{
+       if ((HS.pos > HS.buf) && in_word(*HS.pos))
+               back_over_char(*--HS.pos);
+       while ((HS.pos > HS.buf) && !in_word(*HS.pos))
+               back_over_char(*--HS.pos);
+       while ((HS.pos > HS.buf) && in_word(*HS.pos))
+               back_over_char(*--HS.pos);
+       if ((HS.pos < HS.end) && !in_word(*HS.pos))
+               echo_char(*HS.pos++);
+}
+
+
+static void
+forward_kill_char()
+{
+       int     rest;
+       char    ch;
+
+       rest = HS.end - HS.pos;
+       if (rest-- <= 0)
+               return;
+       ch = *HS.pos;
+       if (rest > 0) {
+               memcpy(HS.pos, HS.pos + 1, rest);
+               *(HS.end - 1) = ch;
+       }
+       echo_rest_of_line();
+       remove_char(ch);
+       decrement_end(1);
+       while (rest > 0)
+               back_over_char(HS.pos[--rest]);
+}
+
+
+static void
+delete_char()
+{
+       if (HS.end > HS.buf)
+               forward_kill_char();
+}
+
+
+static void
+backward_kill_char()
+{
+       if (HS.pos > HS.buf) {
+               HS.pos--;
+               back_over_char(*HS.pos);
+               forward_kill_char();
+       }
+}
+
+
+static void
+forward_kill_word()
+{
+       char    *cp;
+
+       if (HS.pos >= HS.end)
+               return;
+       echo_rest_of_line();
+       for (cp = HS.end; cp > HS.pos;)
+               remove_char(*--cp);
+       cp = HS.pos;
+       while ((cp < HS.end) && !in_word(*cp))
+               cp++;
+       while ((cp < HS.end) && in_word(*cp))
+               cp++;
+       savetext(HS.pos, cp - HS.pos);
+       memcpy(HS.pos, cp, HS.end - cp);
+       decrement_end(cp - HS.pos);
+       echo_rest_of_line();
+       for (cp = HS.end; cp > HS.pos;)
+               back_over_char(*--cp);
+}
+
+
+static void
+kill_line()
+{
+       if (HS.end <= HS.pos)
+               return;
+       savetext(HS.pos, HS.end - HS.pos);
+       echo_rest_of_line();
+       while (HS.end > HS.pos)
+               remove_char(*--HS.end);
+       decrement_end(0);
+}
+
+
+/*
+ * This is the function which completes a command line editing session.
+ * The final line length is returned in the HS.linelen variable.
+ * The line is NOT put into the edit history, so that the caller can
+ * decide whether or not this should be done.
+ */
+static void
+new_line()
+{
+       int     len;
+
+       newline();
+       fflush(stdout);
+
+       HS.mark = NULL;
+       HS.end[0] = '\n';
+       HS.end[1] = '\0';
+       len = HS.end - HS.buf + 1;
+       if (len <= 1) {
+               HS.curhist = HS.histcount;
+               HS.linelen = 1;
+               return;
+       }
+       HS.curhist = HS.histcount;
+       HS.pos = HS.buf;
+       HS.end = HS.buf;
+       HS.linelen = len;
+}
+
+
+static void
+save_line()
+{
+       int     len;
+
+       len = HS.end - HS.buf;
+       if (len > 0) {
+               hist_saveline(HS.buf, len);
+               flush_input();
+       }
+       HS.curhist = HS.histcount;
+}
+
+
+static void
+goto_line()
+{
+       int     num;
+       char    *cp;
+       HIST    *hp;
+
+       num = 0;
+       cp = HS.buf;
+       while ((*cp >= '0') && (*cp <= '9') && (cp < HS.pos))
+               num = num * 10 + (*cp++ - '0');
+       if ((num <= 0) || (num > HS.histcount) || (cp != HS.pos)) {
+               beep();
+               return;
+       }
+       flush_input();
+       HS.curhist = HS.histcount - num;
+       hp = get_event(HS.curhist);
+       memcpy(HS.buf, hp->data, hp->len);
+       HS.end = &HS.buf[hp->len];
+       goto_end_of_line();
+}
+
+
+static void
+forward_history()
+{
+       HIST    *hp;
+
+       flush_input();
+       if (++HS.curhist >= HS.histcount)
+               HS.curhist = 0;
+       hp = get_event(HS.curhist);
+       if (hp) {
+               memcpy(HS.buf, hp->data, hp->len);
+               HS.end = &HS.buf[hp->len];
+       }
+       goto_end_of_line();
+}
+
+
+static void
+backward_history()
+{
+       HIST    *hp;
+
+       flush_input();
+       if (--HS.curhist < 0)
+               HS.curhist = HS.histcount - 1;
+       hp = get_event(HS.curhist);
+       if (hp) {
+               memcpy(HS.buf, hp->data, hp->len);
+               HS.end = &HS.buf[hp->len];
+       }
+       goto_end_of_line();
+}
+
+
+static void
+insert_char(key)
+       int key;
+{
+       int     len;
+       int     rest;
+
+       len = HS.end - HS.buf;
+       if (len >= HS.bufsize) {
+               beep();
+               return;
+       }
+       rest = HS.end - HS.pos;
+       if (rest > 0)
+               memrcpy(HS.pos + 1, HS.pos, rest);
+       HS.end++;
+       *HS.pos++ = key;
+       echo_char(key);
+       echo_rest_of_line();
+       while (rest > 0)
+               back_over_char(HS.pos[--rest]);
+}
+
+
+static void
+insert_string(str, len)
+       int len;
+       char    *str;
+{
+       int     rest;
+       int     totallen;
+
+       if (len <= 0)
+               return;
+       totallen = (HS.end - HS.buf) + len;
+       if (totallen > HS.bufsize) {
+               beep();
+               return;
+       }
+       rest = HS.end - HS.pos;
+       if (rest > 0)
+               memrcpy(HS.pos + len, HS.pos, rest);
+       HS.end += len;
+       memcpy(HS.pos, str, len);
+       HS.pos += len;
+       echo_string(str, len);
+       echo_rest_of_line();
+       while (rest > 0)
+               back_over_char(HS.pos[--rest]);
+}
+
+
+static void
+list_history()
+{
+       HIST    *hp;
+       int     num;
+
+       for (num = 0; num < HS.histcount; num++) {
+               hp = get_event(num);
+               printf("\n%3d: ", HS.histcount - num);
+               echo_string(hp->data, hp->len);
+       }
+       refresh_line();
+}
+
+
+static void
+refresh_line()
+{
+       char    *cp;
+
+       newline();
+       fputs(HS.prompt, stdout);
+       if (HS.end > HS.buf) {
+               echo_string(HS.buf, HS.end - HS.buf);
+               cp = HS.end;
+               while (cp > HS.pos)
+                       back_over_char(*--cp);
+       }
+}
+
+
+static void
+swap_chars()
+{
+       char    ch1;
+       char    ch2;
+
+       if ((HS.pos <= HS.buf) || (HS.pos >= HS.end))
+               return;
+       ch1 = *HS.pos--;
+       ch2 = *HS.pos;
+       *HS.pos++ = ch1;
+       *HS.pos = ch2;
+       back_over_char(ch2);
+       echo_char(ch1);
+       echo_char(ch2);
+       back_over_char(ch2);
+}
+
+
+static void
+set_mark()
+{
+       HS.mark = HS.pos;
+}
+
+
+static void
+save_region()
+{
+       int     len;
+
+       if (HS.mark == NULL)
+               return;
+       len = HS.mark - HS.pos;
+       if (len > 0)
+               savetext(HS.pos, len);
+       if (len < 0)
+               savetext(HS.mark, -len);
+}
+
+
+static void
+kill_region()
+{
+       char    *cp;
+       char    *left;
+       char    *right;
+
+       if ((HS.mark == NULL) || (HS.mark == HS.pos))
+               return;
+
+       echo_rest_of_line();
+       if (HS.mark < HS.pos) {
+               left = HS.mark;
+               right = HS.pos;
+               HS.pos = HS.mark;
+       } else {
+               left = HS.pos;
+               right = HS.mark;
+               HS.mark = HS.pos;
+       }
+       savetext(left, right - left);
+       for (cp = HS.end; cp > left;)
+               remove_char(*--cp);
+       if (right < HS.end)
+               memcpy(left, right, HS.end - right);
+       decrement_end(right - left);
+       echo_rest_of_line();
+       for (cp = HS.end; cp > HS.pos;)
+               back_over_char(*--cp);
+}
+
+
+static void
+yank()
+{
+       insert_string(save_buffer, save_len);
+}
+
+
+static void
+reverse_search()
+{
+       int     len;
+       int     count;
+       int     testhist;
+       HIST    *hp;
+       char    *save_pos;
+
+       count = HS.histcount;
+       len = HS.pos - HS.buf;
+       if (len <= 0)
+               count = 0;
+       testhist = HS.curhist;
+       do {
+               if (--count < 0) {
+                       beep();
+                       return;
+               }
+               if (--testhist < 0)
+                       testhist = HS.histcount - 1;
+               hp = get_event(testhist);
+       } while ((hp == NULL) || (hp->len < len) ||
+               memcmp(hp->data, HS.buf, len));
+
+       HS.curhist = testhist;
+       save_pos = HS.pos;
+       flush_input();
+       memcpy(HS.buf, hp->data, hp->len);
+       HS.end = &HS.buf[hp->len];
+       goto_end_of_line();
+       while (HS.pos > save_pos)
+               back_over_char(*--HS.pos);
+}
+
+
+static void
+quote_char()
+{
+       int     ch;
+
+       ch = fgetc(stdin);
+       if (ch != EOF)
+               insert_char(ch);
+}
+
+
+/*
+ * Save data in the save buffer.
+ */
+static void
+savetext(str, len)
+       int len;
+       char    *str;
+{
+       save_len = 0;
+       if (len <= 0)
+               return;
+       if (len > SAVE_SIZE)
+               len = SAVE_SIZE;
+       memcpy(save_buffer, str, len);
+       save_len = len;
+}
+
+
+/*
+ * Test whether a character is part of a word.
+ */
+static int
+in_word(ch)
+       char    ch;
+{
+       return (isalnum(ch) || (ch == '_'));
+}
+
+
+static void
+erasechar()
+{
+       fputs("\b \b", stdout);
+}
+
+
+static void
+newline()
+{
+       fputc('\n', stdout);
+}
+
+
+static void
+backspace()
+{
+       fputc('\b', stdout);
+}
+
+
+static void
+beep()
+{
+       fputc('\007', stdout);
+}
+
+
+static void
+echo_char(ch)
+       int ch;
+{
+       if (isprint(ch))
+               putchar(ch);
+       else {
+               putchar('^');
+               putchar((ch + '@') & 0x7f);
+       }
+}
+
+
+static void
+echo_string(str, len)
+       int len;
+       char    *str;
+{
+       while (len-- > 0)
+               echo_char(*str++);
+}
+
+
+static void
+memrcpy(dest, src, len)
+       int len;
+       char    *dest, *src;
+{
+       dest += len - 1;
+       src += len - 1;
+       while (len-- > 0)
+               *dest-- = *src--;
+}
+
+
+static void
+quit_calc()
+{
+       hist_term();
+       putchar('\n');
+       exit(0);
+}
+
+
+#ifdef HIST_TEST
+
+/*
+ * Main routine to test history.
+ */
+main(argc, argv)
+       int     argc;
+       char    *argv[];
+{
+       char    *filename;
+       int     len;
+       char    buf[256];
+
+       filename = NULL;
+       if (argc > 1)
+               filename = argv[1];
+
+       switch (hist_init(filename)) {
+               case HIST_SUCCESS:
+                       break;
+               case HIST_NOFILE:
+                       fprintf(stderr, "Binding file was not found\n");
+                       break;
+               case HIST_NOTTY:
+                       fprintf(stderr, "Cannot set terminal parameters\n");
+                       break;
+               case HIST_INITED:
+                       fprintf(stderr, "Hist is already inited\n");
+                       break;
+               default:
+                       fprintf(stderr, "Unknown error from hist_init\n");
+                       break;
+       }
+
+       do {
+               len = hist_getline("HIST> ", buf, sizeof(buf));
+               hist_saveline(buf, len);                
+       } while (len && (buf[0] != 'q'));
+
+       hist_term();
+
+       return 0;
+}
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/hist.h b/usr/src/contrib/calc-2.9.3t6/hist.h
new file mode 100644 (file)
index 0000000..c3b2c8f
--- /dev/null
@@ -0,0 +1,55 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Definitions for command history module.
+ */
+
+
+#ifdef __STDC__
+#define        HIST_PROTO(a) a
+#else
+#define        HIST_PROTO(a) ()
+#endif
+
+
+/*
+ * Default binding file and history size.
+ */
+#ifndef        HIST_BINDING_FILE
+#define        HIST_BINDING_FILE       "/usr/lib/hist.bind"
+#endif
+
+#ifndef        HIST_SIZE
+#define        HIST_SIZE               (1024*10)
+#endif
+
+
+/* 
+ * path search defines
+ */
+#define        HOMECHAR        '~'     /* char which indicates home directory */
+#define DOTCHAR                '.'     /* char which indicates current directory */
+#define        PATHCHAR        '/'     /* char which separates path components */
+#define        LISTCHAR        ':'     /* char which separates paths in a list */
+#define        PATHSIZE        1024    /* maximum length of path name */
+
+
+/*
+ * Possible returns from hist_init.  Note that an error from hist_init does
+ * not prevent calling the other routines, but fancy command line editing
+ * is then disabled.
+ */
+#define        HIST_SUCCESS    0       /* successfully inited */
+#define        HIST_INITED     1       /* initialization is already done */
+#define        HIST_NOFILE     2       /* bindings file could not be read */
+#define        HIST_NOTTY      3       /* terminal modes could not be set */
+
+
+extern int     hist_init HIST_PROTO((char *filename));
+extern void    hist_term HIST_PROTO((void));
+extern int     hist_getline HIST_PROTO((char *prompt, char *buf, int len));
+extern void    hist_saveline HIST_PROTO((char *line, int len));
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/input.c b/usr/src/contrib/calc-2.9.3t6/input.c
new file mode 100644 (file)
index 0000000..1137126
--- /dev/null
@@ -0,0 +1,768 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Nested input source file reader.
+ * For terminal input, this also provides a simple command stack.
+ */
+
+#include <ctype.h>
+#include <pwd.h>
+#include "calc.h"
+#include "config.h"
+#include "hist.h"
+
+
+#define TTYSIZE                100     /* reallocation size for terminal buffers */
+#define DEPTH          10      /* maximum depth of input */
+#define IS_READ                1       /* reading normally */
+#define IS_REREAD      2       /* reread current character */
+#define chartoint(ch)  ((ch) & 0xff)   /* make sure char is not negative */
+#define READSET_ALLOC  8       /* readset to allocate chunk size */
+
+
+typedef struct {
+       int i_state;            /* state (read, reread) */
+       int i_char;             /* currently read char */
+       long i_line;            /* line number */
+       char *i_str;            /* current string for input (if not NULL) */
+       char *i_origstr;        /* original string so it can be freed */
+       char *i_ttystr;         /* current character of tty line (or NULL) */
+       FILE *i_fp;             /* current file for input (if not NULL) */
+       char *i_name;           /* file name if known */
+} INPUT;
+
+
+/* files that calc has read or included */
+typedef struct {
+       int active;             /* != 0 => active entry, 0 => unused entry */
+       char *name;             /* name used to read file */
+       char *path;             /* real path used to open file */
+       struct stat inode;      /* inode information for file */
+} READSET;
+
+static READSET *readset = NULL;                /* array of files read */
+static int maxreadset = 0;             /* length of readset */
+
+static int linesize;           /* current max size of input line */
+static char *linebuf;          /* current input line buffer */
+static char *prompt;           /* current prompt for terminal */
+static BOOL noprompt;          /* TRUE if should not print prompt */
+
+static int depth;              /* current input depth */
+static INPUT *cip;             /* current input source */
+static INPUT inputs[DEPTH];    /* input sources */
+
+
+static int openfile MATH_PROTO((char *name));
+static int ttychar MATH_PROTO((void));
+static void closeinput MATH_PROTO((void));
+static int isinoderead MATH_PROTO((struct stat *sbuf));
+static int findfreeread MATH_PROTO((void));
+static int addreadset MATH_PROTO((char *name, char *path, struct stat *sbuf));
+
+
+/*
+ * Open an input file by possibly searching through a path list
+ * and also possibly applying the specified extension.  For example:
+ * opensearchfile("barf", ".:/tmp", ".c") searches in order for the
+ * files "./barf", "./barf.c", "/tmp/barf", and "/tmp/barf.c".
+ *
+ * Returns -1 if we could not open a file or error.  
+ * Returns 1 if file was opened and added to/updated in the readset.   
+ * Returns 0 if file was already in the readset and reopen was 0.
+ */
+int
+opensearchfile(name, pathlist, extension, rd_once)
+       char *name;             /* file name to be read */
+       char *pathlist;         /* list of colon separated paths (or NULL) */
+       char *extension;        /* extra extension to try (or NULL) */
+       int rd_once;            /* TRUE => do not reread a file */
+{
+       int i;
+       char *cp;
+       char path[PATHSIZE+1];  /* name being searched for */
+       struct stat statbuf;    /* stat of the path */
+
+       /*
+        * Don't try the extension if the filename already contains it.
+        */
+       if (extension) {
+               i = strlen(name) - strlen(extension);
+               if ((i >= 0) && (strcmp(&name[i], extension) == 0))
+                       extension = NULL;
+       }
+       /*
+        * If the name is absolute, or if there is no path list, then
+        * make one which just searches for the name straight.  Then
+        * search through the path list for the file, without and with
+        * the specified extension.
+        */
+       if (name[0] == PATHCHAR || 
+           name[0] == HOMECHAR || 
+           (name[0] == DOTCHAR && name[1] == PATHCHAR) || 
+           pathlist == NULL) {
+               pathlist = "";
+       }
+       pathlist--;
+       do {
+               pathlist++;
+               cp = path;
+               while (*pathlist && (*pathlist != LISTCHAR))
+                       *cp++ = *pathlist++;
+               if (cp != path)
+                       *cp++ = PATHCHAR;
+               strcpy(cp, name);
+               i = openfile(path);
+               if ((i < 0) && extension) {
+                       strcat(path, extension);
+                       i = openfile(path);
+               }
+       } while ((i < 0) && *pathlist);
+
+       /* examine what our search produced */
+       if (i < 0 || cip->i_fp == NULL) {
+               /* cannot find a file to open */
+               return -1;
+       }
+       if (fstat(fileno(cip->i_fp), &statbuf) < 0) {
+               /* unable to fstat the open file */
+               return -1;
+       }
+
+       /* note if we will reopen a file and if that is allowed */
+       if (rd_once == TRUE && isinoderead(&statbuf) >= 0) {
+               /* file is in readset and reopen is false */
+               closeinput();
+               return 1;
+       }
+
+       /* add this name to the readset */
+       if (addreadset(name, path, &statbuf) < 0) {
+               /* cannot add to readset */
+               closeinput();
+               return -1;
+       }
+
+       /* file was added to/updated in readset */
+       return 0;
+}
+
+
+/*
+ * Given a filename with a leading ~, expand it into a home directory for 
+ * that user.  This function will malloc the space for the expanded path.
+ *
+ * If the path is just ~, or begins with ~/, expand it to the home
+ * directory of the current user.  If the environment variable $HOME
+ * is known, it will be used, otherwise the password file will be
+ * consulted.
+ *
+ * If the path is just ~username, or ~username/, expand it to the home
+ * directory of that user by looking it up in the password file.
+ *
+ * If the password file must be consulted and the username is not found
+ * a NULL pointer is returned.
+ */
+static char *
+homeexpand(name)
+       char *name;             /* a filename with a leading ~ */
+{
+       struct passwd *ent;     /* password entry */
+       char *home2;            /* fullpath of the home directory */
+       char *fullpath;         /* the malloced expanded path */
+       char *after;            /* after the ~user or ~ */
+       char username[PATHSIZE+1];      /* extratced username */
+
+       /* firewall */
+       if (name[0] != HOMECHAR)
+               return NULL;
+
+       /*
+        * obtain the home directory component
+        */
+       switch (name[1]) {
+       case PATHCHAR:          /* ~/... */
+       case '\0':              /* ~ */
+               home2 = home;
+               after = name+1;
+               break;
+       default:                /* ~username or ~username/... */
+
+               /* extract the username after the ~ */
+               after = (char *)strchr(name+2, PATHCHAR);
+               if (after == NULL) {
+                       /* path is just ~username */
+                       ent = (struct passwd *)getpwnam(name+1);
+                       if (ent == NULL) {
+                               /* unknown user */
+                               return NULL;
+                       }
+                       /* just malloc the home directory and return it */
+                       fullpath = (char *)malloc(strlen(ent->pw_dir)+1);
+                       strcpy(fullpath, ent->pw_dir);
+                       return fullpath;
+               }
+               if (after-name > PATHSIZE+1) {
+                       /* username is too big */
+                       return NULL;
+               }
+               strncpy(username, name+1, after-name-1);
+               username[after-name-1] = '\0';
+
+               /* get that user's home directory */
+               ent = (struct passwd *)getpwnam(username);
+               if (ent == NULL) {
+                       /* unknown user */
+                       return NULL;
+               }
+               home2 = ent->pw_dir;
+               break;
+       }
+
+       /*
+        * build the fullpath given the home directory
+        */
+       fullpath = (char *)malloc(strlen(home2)+strlen(after)+1);
+       sprintf(fullpath, "%s%s", home2, after);
+       return fullpath;
+}
+
+
+/*
+ * f_open - ~-expand a filename and fopen() it
+ */
+FILE *
+f_open(name, mode)
+       char *name;             /* the filename to open */
+       char *mode;             /* the fopen mode to use */
+{
+       FILE *fp;               /* open file descriptor */
+       char *fullname;         /* file name with HOMECHAR expansion */
+
+       /*
+        * expand ~ if needed
+        */
+       if (name[0] == HOMECHAR) {
+               fullname = homeexpand(name);
+               if (fullname == NULL)
+                       return NULL;
+               fp = fopen(fullname, mode);
+               free(fullname);
+       } else {
+               fp = fopen(name, mode);
+       }
+       return fp;
+}
+
+
+/*
+ * Setup for reading from a input file.
+ * Returns -1 if file could not be opened.
+ */
+static int
+openfile(name)
+       char *name;             /* file name to be read */
+{
+       FILE *fp;               /* open file descriptor */
+
+       if (depth >= DEPTH)
+                return -1;
+       fp = f_open(name, "r");
+       if (fp == NULL)
+                return -1;
+       cip++;
+       cip->i_state = IS_READ;
+       cip->i_char = '\0';
+       cip->i_str = NULL;
+       cip->i_origstr = NULL;
+       cip->i_ttystr = NULL;
+       cip->i_fp = fp;
+       cip->i_line = 1;
+       cip->i_name = (char *)malloc(strlen(name) + 1);
+       strcpy(cip->i_name, name);
+       depth++;
+       return 0;
+}
+
+
+/*
+ * Open a string for scanning. String is ended by a null character.
+ * String is copied into local memory so it can be trashed afterwards.
+ * Returns -1 if cannot open string.
+ */
+int
+openstring(str)
+       char *str;              /* string to be opened */
+{
+       char *cp;               /* copied string */
+
+       if ((depth >= DEPTH) || (str == NULL))
+                return -1;
+       cp = (char *)malloc(strlen(str) + 1);
+       if (cp == NULL)
+                return -1;
+       strcpy(cp, str);
+       cip++;
+       cip->i_state = IS_READ;
+       cip->i_char = '\0';
+       cip->i_str = cp;
+       cip->i_origstr = cp;
+       cip->i_fp = NULL;
+       cip->i_name = NULL;
+       cip->i_ttystr = NULL;
+       cip->i_line = 1;
+       depth++;
+       return 0;
+}
+
+
+/*
+ * Set to read input from the terminal.
+ * Returns -1 if there is no more depth for input.
+ */
+int
+openterminal()
+{
+       if (depth >= DEPTH)
+                return -1;
+       cip++;
+       cip->i_state = IS_READ;
+       cip->i_char = '\0';
+       cip->i_str = NULL;
+       cip->i_origstr = NULL;
+       cip->i_ttystr = NULL;
+       cip->i_fp = NULL;
+       cip->i_name = NULL;
+       cip->i_line = 1;
+       depth++;
+       return 0;
+}
+
+
+/*
+ * Close the current input source.
+ */
+static void
+closeinput()
+{
+       if (depth <= 0)
+               return;
+       if (cip->i_origstr)
+               free(cip->i_origstr);
+       if (cip->i_fp)
+               fclose(cip->i_fp);
+       if (cip->i_name)
+               free(cip->i_name);
+       cip--;
+       depth--;
+}
+
+
+/*
+ * Reset the input sources back to the initial state.
+ */
+void
+resetinput()
+{
+       while (depth > 0)
+               closeinput();
+       cip = inputs;
+       noprompt = FALSE;
+}
+
+
+/*
+ * Set the prompt for terminal input.
+ */
+void
+setprompt(str)
+       char *str;
+{
+       prompt = str;
+       noprompt = FALSE;
+}
+
+
+/*
+ * Read the next character from the current input source.
+ * End of file closes current input source, and returns EOF character.
+ */
+int
+nextchar()
+{
+       int ch;                 /* current input character */
+
+       if (depth == 0)         /* input finished */
+                return EOF;
+       if (cip->i_state == IS_REREAD) {        /* rereading current char */
+                ch = cip->i_char;
+                cip->i_state = IS_READ;
+                if (ch == '\n')
+                       cip->i_line++;
+                return ch;
+       }
+       if (cip->i_str) {               /* from string */
+               ch = chartoint(*cip->i_str++);
+               if (ch == '\0')
+                       ch = EOF;
+       } else if (cip->i_fp) {         /* from file */
+               ch = fgetc(cip->i_fp);
+       } else {                        /* from terminal */
+               ch = ttychar();
+       }
+       if (ch == EOF) {                /* fix up end of file */
+               closeinput();
+               ch = EOF;
+       }
+       if (depth > 0)
+               cip->i_char = ch;       /* save for rereads */
+       if (ch == '\n')
+               cip->i_line++;
+       return ch;
+}
+
+
+/*
+ * Read in the next line of input from the current input source.
+ * The line is terminated with a null character, and does not contain
+ * the final newline character.  The returned string is only valid
+ * until the next such call, and so must be copied if necessary.
+ * Returns NULL on end of file.
+ */
+char *
+nextline()
+{
+       char *cp;
+       int ch;
+       int len;
+
+       cp = linebuf;
+       if (linesize == 0) {
+               cp = (char *)malloc(TTYSIZE + 1);
+               if (cp == NULL)
+                       math_error("Cannot allocate line buffer");
+               linebuf = cp;
+               linesize = TTYSIZE;
+       }
+       len = 0;
+       for (;;) {
+               noprompt = TRUE;
+               ch = nextchar();
+               noprompt = FALSE;
+               if (ch == EOF)
+                       return NULL;
+               if (ch == '\0')
+                       continue;
+               if (ch == '\n')
+                       break;
+               if (len >= linesize) {
+                       cp = (char *)realloc(cp, linesize + TTYSIZE + 1);
+                       if (cp == NULL)
+                               math_error("Cannot realloc line buffer");
+                       linebuf = cp;
+                       linesize += TTYSIZE;
+               }
+               cp[len++] = (char)ch;
+       }
+       cp[len] = '\0';
+       return linebuf;
+}
+
+
+/*
+ * Read the next character from the terminal.
+ * The routines in the history module are called so that the user
+ * can use a command history and emacs-like editing of the line.
+ */
+static int
+ttychar()
+{
+       int ch;                 /* current char */
+       int len;                /* length of current command */
+       static char charbuf[1000];
+
+       /*
+        * If we have more to read from the saved command line, then do that.
+        * When we see a newline character, then clear the pointer so we will
+        * read a new line on the next call.
+        */
+       if (cip->i_ttystr) {
+               ch = chartoint(*cip->i_ttystr++);
+               if (ch == '\n')
+                       cip->i_ttystr = NULL;
+               return ch;
+       }
+
+       /*
+        * We need another complete line.
+        */
+       abortlevel = 0;
+       inputwait = TRUE;
+       len = hist_getline(noprompt ? "" : prompt, charbuf, sizeof(charbuf));
+       if (len == 0) {
+               inputwait = FALSE;
+               return EOF;
+       }
+       inputwait = FALSE;
+
+       /*
+        * Handle shell escape if present
+        */
+       if (charbuf[0] == '!') {                /* do a shell command */
+               char *cmd;
+
+               cmd = charbuf + 1;
+               if (*cmd == '\0' || *cmd == '\n')
+                       cmd = shell;
+               system(cmd);
+               return '\n';
+       }
+       hist_saveline(charbuf, len);
+
+       /*
+        * Return the first character of the line, and set up to
+        * return the rest of it with later calls.
+        */
+       ch = chartoint(charbuf[0]);
+       if (ch != '\n')
+               cip->i_ttystr = charbuf + 1;
+       return ch;
+}
+
+
+/*
+ * Return whether or not the input source is the terminal.
+ */
+BOOL
+inputisterminal()
+{
+       return ((depth <= 0) || ((cip->i_str == NULL) && (cip->i_fp == NULL)));
+}
+
+
+/*
+ * Return the name of the current input file.
+ * Returns NULL for terminal or strings.
+ */
+char *
+inputname()
+{
+       if (depth <= 0)
+               return NULL;
+       return cip->i_name;
+}
+
+
+/*
+ * Return the current line number.
+ */
+long
+linenumber()
+{
+       if (depth > 0)
+               return cip->i_line;
+       return 1;
+}
+
+
+/*
+ * Restore the next character to be read again on the next nextchar call.
+ */
+void
+reread()
+{
+       if ((depth <= 0) || (cip->i_state == IS_REREAD))
+               return;
+       cip->i_state = IS_REREAD;
+       if (cip->i_char == '\n')
+               cip->i_line--;
+}
+
+
+/*
+ * Process all startup files found in the $CALCRC path.
+ */
+void
+runrcfiles()
+{
+       char path[PATHSIZE+1];  /* name being searched for */
+       char *cp;
+       char *newcp;
+       char *p;
+       int i;
+
+       /* execute each file in the list */
+       for (cp=calcrc, newcp=(char *)strchr(calcrc, LISTCHAR);
+            cp != NULL && *cp;
+            cp = newcp, 
+                newcp=(newcp) ? (char *)strchr(newcp+1, LISTCHAR) : NULL) {
+
+               /* load file name into the path */
+               if (newcp == NULL) {
+                       strcpy(path, cp);
+               } else {
+                       strncpy(path, cp, newcp-cp);
+                       path[newcp-cp] = '\0';
+               }
+
+               /* find the start of the path */
+               p = (path[0] == ':') ? path+1 : path;
+               if (p[0] == '\0') {
+                       continue;
+               }
+
+               /* process the current file in the list */
+               i = openfile(p);
+               if (i < 0)
+                       continue;
+               getcommands(FALSE);
+       }
+}
+
+
+/*
+ * isinoderead - determine if we have read a given dev/inode
+ *
+ * This function returns the index of the readset element that matches
+ * a given device/inode, -1 otherwise.
+ */
+static int
+isinoderead(sbuf)
+       struct stat *sbuf;              /* stat of the inode in question */
+{
+       int i;
+
+       /* deal with the empty case */
+       if (readset == NULL || maxreadset <= 0) {
+               /* readset is empty */
+               return -1;
+       }
+
+       /* scan the entire readset */
+       for (i=0; i < maxreadset; ++i) { 
+               if (readset[i].active && 
+                   sbuf->st_dev == readset[i].inode.st_dev &&
+                   sbuf->st_ino == readset[i].inode.st_ino) {
+                       /* found a match */
+                       return i;
+               }
+       }
+
+       /* no match found */
+       return -1;
+}
+
+
+/*
+ * findfreeread - find the next free readset element
+ *
+ * This function will return the index of the next free readset element.
+ * If needed, this function will allocate new readset elements.
+ *
+ * This function returns the index of the next free element, or -1.
+ */
+static int
+findfreeread()
+{
+       int i;
+
+       /* deal with an empty readset case */
+       if (readset == NULL || maxreadset <= 0) {
+
+               /* malloc a new readset */
+               readset = (READSET *)malloc((READSET_ALLOC+1)*sizeof(READSET));
+               if (readset == NULL) {
+                       return -1;
+               }
+               maxreadset = READSET_ALLOC;
+               for (i=0; i < READSET_ALLOC; ++i) {
+                       readset[i].active = 0;
+               }
+
+               /* return first entry */
+               return 0;
+       }
+
+       /* try to find a free readset entry */
+       for (i=0; i < maxreadset; ++i) {
+               if (readset[i].active == 0) {
+                       /* found a free readset entry */
+                       return i;
+               }
+       }
+
+       /* all readset entries are in use, allocate more */
+       readset = (READSET *)realloc(readset, 
+           (maxreadset+READSET_ALLOC) * sizeof(READSET));
+       if (readset == NULL) {
+               return -1;
+       }
+       for (i=0; i < READSET_ALLOC; ++i) {
+               readset[i+maxreadset].active = 0;
+       }
+       maxreadset += READSET_ALLOC;
+
+       /* return the furst newly allocated free entry */
+       return maxreadset-READSET_ALLOC;
+}
+
+
+/*
+ * addreadset - add a entry to the readset array if it is not already there
+ *
+ * This function attempts to add a file into the readset.  If the readset
+ * has an entry with a matching dev/inode, then that entry is updated with
+ * the new name and path.  If no such readset entry is found, a new entry
+ * is added.
+ *
+ * This function returns the index of the readset entry, or -1 if error.
+ */
+static int
+addreadset(name, path, sbuf)
+       char *name;     /* name given to read or include */
+       char *path;     /* full pathname of file */
+       struct stat *sbuf;      /* stat of the path */
+{
+       int ret;                /* index to return */
+
+       /* find the inode */
+       ret = isinoderead(sbuf);
+       if (ret < 0) {
+               /* not in readset, find a free node */
+               ret = findfreeread();
+               if (ret < 0) {
+                       /* cannot find/form a free readset entry */
+                       return -1;
+               }
+       } else {
+               /* found an readset entry, free old readset data */
+               if (readset[ret].name != NULL) {
+                       free(readset[ret].name);
+               }
+               if (readset[ret].path != NULL) {
+                       free(readset[ret].path);
+               }
+       }
+
+       /* load our information into the readset entry */
+       readset[ret].name = (char *)malloc(strlen(name)+1);
+       if (readset[ret].name == NULL) {
+               return -1;
+       }
+       strcpy(readset[ret].name, name);
+       readset[ret].path = (char *)malloc(strlen(path)+1);
+       if (readset[ret].path == NULL) {
+               return -1;
+       }
+       strcpy(readset[ret].path, path);
+       readset[ret].inode = *sbuf;
+       readset[ret].active = 1;
+
+       /* return index of the newly added entry */
+       return ret;
+}
+
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/label.c b/usr/src/contrib/calc-2.9.3t6/label.c
new file mode 100644 (file)
index 0000000..549ad89
--- /dev/null
@@ -0,0 +1,176 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Label handling routines.
+ */
+
+#include "calc.h"
+#include "token.h"
+#include "label.h"
+#include "string.h"
+#include "opcodes.h"
+#include "func.h"
+
+static long labelcount;                        /* number of user labels defined */
+static STRINGHEAD labelnames;          /* list of user label names */
+static LABEL labels[MAXLABELS];                /* list of user labels */
+
+
+/*
+ * Initialize the table of labels for a function.
+ */
+void
+initlabels()
+{
+       labelcount = 0;
+       initstr(&labelnames);
+}
+
+
+/*
+ * Define a user named label to have the offset of the next opcode.
+ */
+void
+definelabel(name)
+       char *name;                     /* label name */
+{
+       register LABEL *lp;             /* current label */
+       long i;                         /* current label index */
+
+       i = findstr(&labelnames, name);
+       if (i >= 0) {
+               lp = &labels[i];
+               if (lp->l_offset) {
+                       scanerror(T_NULL, "Label \"%s\" is multiply defined",
+                               name);
+                       return;
+               }
+               setlabel(lp);
+               return;
+       }
+       if (labelcount >= MAXLABELS) {
+               scanerror(T_NULL, "Too many labels in use");
+               return;
+       }
+       lp = &labels[labelcount++];
+       lp->l_chain = 0;
+       lp->l_offset = curfunc->f_opcodecount;
+       lp->l_name = addstr(&labelnames, name);
+       clearopt();
+}
+
+
+/*
+ * Add the offset corresponding to the specified user label name to the
+ * opcode table for a function. If the label is not yet defined, then a
+ * chain of undefined offsets is built using the offset value, and it
+ * will be fixed up when the label is defined.
+ */
+void
+addlabel(name)
+       char *name;                     /* user symbol name */
+{
+       register LABEL *lp;             /* current label */
+       long i;                         /* counter */
+
+       for (i = labelcount, lp = labels; --i >= 0; lp++) {
+               if (strcmp(name, lp->l_name))
+                       continue;
+               uselabel(lp);
+               return;
+       }
+       if (labelcount >= MAXLABELS) {
+               scanerror(T_NULL, "Too many labels in use");
+               return;
+       }
+       lp = &labels[labelcount++];
+       lp->l_offset = 0;
+       lp->l_chain = curfunc->f_opcodecount;
+       lp->l_name = addstr(&labelnames, name);
+       addop((long)0);
+}
+
+
+/*
+ * Check to make sure that all labels are defined.
+ */
+void
+checklabels()
+{
+       register LABEL *lp;             /* label being checked */
+       long i;                         /* counter */
+
+       for (i = labelcount, lp = labels; --i >= 0; lp++) {
+               if (lp->l_offset > 0)
+                       continue;
+               scanerror(T_NULL, "Label \"%s\" was never defined",
+                       lp->l_name);
+       }
+}
+
+
+/*
+ * Clear an internal label for use.
+ */
+void
+clearlabel(lp)
+       register LABEL *lp;     /* label being cleared */
+{
+       lp->l_offset = 0;
+       lp->l_chain = 0;
+       lp->l_name = NULL;
+}
+
+
+/*
+ * Set any label to have the value of the next opcode in the current
+ * function being defined.  If there were forward references to it,
+ * all such references are patched up.
+ */
+void
+setlabel(lp)
+       register LABEL *lp;     /* label being set */
+{
+       register FUNC *fp;      /* current function */
+       long curfix;            /* offset of current location being fixed */
+       long nextfix;           /* offset of next location to fix up */
+       long offset;            /* offset of this label */
+
+       fp = curfunc;
+       offset = fp->f_opcodecount;
+       nextfix = lp->l_chain;
+       while (nextfix > 0) {
+               curfix = nextfix;
+               nextfix = fp->f_opcodes[curfix];
+               fp->f_opcodes[curfix] = offset;
+       }
+       lp->l_chain = 0;
+       lp->l_offset = offset;
+       clearopt();
+}
+
+
+/*
+ * Use the specified label at the current location in the function
+ * being compiled.  This adds one word to the current function being
+ * compiled.  If the label is not yet defined, a patch chain is built
+ * so the reference can be fixed when the label is defined.
+ */
+void
+uselabel(lp)
+       register LABEL *lp;             /* label being used */
+{
+       long offset;                    /* offset being added */
+
+       offset = curfunc->f_opcodecount;
+       if (lp->l_offset > 0) {
+               addop(lp->l_offset);
+               return;
+       }
+       addop(lp->l_chain);
+       lp->l_chain = offset;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/label.h b/usr/src/contrib/calc-2.9.3t6/label.h
new file mode 100644 (file)
index 0000000..043f982
--- /dev/null
@@ -0,0 +1,37 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ */
+
+#ifndef        LABEL_H
+#define        LABEL_H
+
+
+#include "zmath.h"
+
+
+#define        NULL_LABEL      ((LABEL *) 0)
+
+
+/*
+ * Label structures.
+ */
+typedef struct {
+       long l_offset;            /* offset into code of label */
+       long l_chain;             /* offset into code of undefined chain */
+       char *l_name;             /* name of label if any */
+} LABEL;
+
+
+extern void initlabels MATH_PROTO((void));
+extern void definelabel MATH_PROTO((char *name));
+extern void addlabel MATH_PROTO((char *name));
+extern void clearlabel MATH_PROTO((LABEL *lp));
+extern void setlabel MATH_PROTO((LABEL *lp));
+extern void uselabel MATH_PROTO((LABEL *lp));
+extern void checklabels MATH_PROTO((void));
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/Makefile b/usr/src/contrib/calc-2.9.3t6/lib/Makefile
new file mode 100644 (file)
index 0000000..d947e19
--- /dev/null
@@ -0,0 +1,64 @@
+#
+# lib - makefile for calc library scripts
+#
+# Copyright (c) 1994 David I. Bell and Landon Curt Noll
+# Permission is granted to use, distribute, or modify this source,
+# provided that this copyright notice remains intact.
+#
+# Arbitrary precision calculator.
+#
+# calculator by David I. Bell
+# makefile by Landon Curt Noll
+
+# Normally, the upper level makefile will set these values.  We provide
+# a default here just in case you want to build from this directory.
+#
+# where to install things
+TOPDIR= /usr/local/lib
+#TOPDIR= /usr/lib
+#TOPDIR= /usr/libdata
+
+LIBDIR= ${TOPDIR}/calc
+
+# The calc files to install
+#
+CALC_FILES= README bigprime.cal deg.cal ellip.cal lucas.cal lucas_chk.cal \
+       lucas_tbl.cal mersenne.cal mod.cal nextprim.cal pell.cal pi.cal \
+       pollard.cal poly.cal psqrt.cal quat.cal regress.cal solve.cal \
+       sumsq.cal surd.cal unitfrac.cal varargs.cal chrem.cal cryrand.cal \
+       bindings altbind randmprime.cal test1000.cal
+
+SHELL= /bin/sh
+
+all: ${CALC_FILES} nextprime.cal
+
+# link nextprime.cal to nextprim.cal
+#
+nextprime.cal: nextprim.cal
+       rm -f nextprime.cal
+       ln nextprim.cal nextprime.cal
+
+clean:
+
+clobber:
+       rm -f nextprime.cal
+
+install: all
+       -@if [ ! -d ${TOPDIR} ]; then \
+               echo mkdir ${TOPDIR}; \
+               mkdir ${TOPDIR}; \
+       fi
+       -@if [ ! -d ${LIBDIR} ]; then \
+               echo mkdir ${LIBDIR}; \
+               mkdir ${LIBDIR}; \
+       fi
+       @for i in ${CALC_FILES}; do \
+               echo rm -f ${LIBDIR}/$$i; \
+               rm -f ${LIBDIR}/$$i; \
+               echo cp $$i ${LIBDIR}; \
+               cp $$i ${LIBDIR}; \
+               echo chmod 0444 ${LIBDIR}/$$i; \
+               chmod 0444 ${LIBDIR}/$$i; \
+       done
+       -rm -f ${LIBDIR}/nextprime.cal
+       -ln ${LIBDIR}/nextprim.cal ${LIBDIR}/nextprime.cal 
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/README b/usr/src/contrib/calc-2.9.3t6/lib/README
new file mode 100644 (file)
index 0000000..894d991
--- /dev/null
@@ -0,0 +1,299 @@
+# Copyright (c) 1994 David I. Bell and Landon Curt Noll
+# Permission is granted to use, distribute, or modify this source,
+# provided that this copyright notice remains intact.
+
+The following calc library files are provided because they serve as 
+examples of how use the calc language, and because the authors thought 
+them to be useful!
+
+If you write something that you think is useful, please send it to:
+
+    dbell@canb.auug.org.au
+    chongo@toad.com                 {uunet,pyramid,sun}!hoptoad!chongo
+
+By convention, a lib file only defines and/or initializes functions,
+objects and variables.  (The regression test is an exception.)  Also by
+convention, the a usage message regarding each important object and
+function is printed at the time of the read.
+
+If a lib file needs to load another lib file, it should use the -once
+version of read:
+
+    /* pull in needed library files */
+    read -once "cryrand"
+    read -once "curds"
+
+This will cause the needed library files to be read once.  If these
+files have already been read, the read -once will act as a noop.
+
+By convention, the global variable  lib_debug  is used to control
+the verbosity of debug information printed by lib files.  By default,
+the lib_debug has a value of 0.  If lib_debug < 0, then no debug
+messages are printed.  If lib_debug >= 0, then only usage message 
+regarding each important object are printed at the time of the read.
+If lib_debug == 0, then only such usage messages are printed; no
+other debug information is printed.
+
+To conform to the above convention, your lib files should end with
+lines of the form:
+
+       global lib_debug;
+       if (lib_debug >= 0) {
+           print "funcA(side_a, side_b, side_c) defined";
+           print "funcB(size, mass) defined";
+       }
+
+
+=-=
+
+
+bernoulli.cal
+
+    B(n)
+
+    Calculate the nth Bernoulli number.
+
+
+bigprime.cal
+
+    bigprime(a, m, p) 
+
+    A prime test, base a, on p*2^x+1 for even x>m.
+
+
+chrem.cal
+
+    chrem(r1,m1 [,r2,m2, ...])
+    chrem(rlist, mlist)
+
+    Chinese remainder theorem/problem solver.
+
+
+cryrand.cal
+
+    shufrand()
+    sshufrand(seed)
+    rand([a, [b]])
+    srand(seed)
+    cryrand([a, [b]])
+    scryrand([seed, [len1, len2]])
+    random([a, [b]])
+    srandom(seed)
+    obj cryobj
+    randstate([cryobj | 0])
+    nxtprime(n, [val, modulus])
+
+    Cryptographically strong pseudo-random number generator library.
+    
+
+deg.cal                
+
+    dms(deg, min, sec)
+    dms_add(a, b)
+    dms_neg(a)
+    dms_sub(a, b)
+    dms_mul(a, b)
+    dms_print(a)
+
+    Calculate in degrees, minutes, and seconds.
+
+
+ellip.cal      
+
+    factor(iN, ia, B, force)
+
+    Attempt to factor using the elliptic functions: y^2 = x^3 + a*x + b.
+
+
+lucas.cal
+
+    lucas(h, n)
+
+    Perform a primality test of h*2^n-1, with 1<=h<2*n.
+
+
+lucas_chk.cal
+
+    lucas_chk(high_n)
+
+    Test all primes of the form h*2^n-1, with 1<=h<200 and n <= high_n.
+    Requires lucas.cal to be loaded.  The highest useful high_n is 1000.
+
+
+lucas_tbl.cal
+
+    Lucasian criteria for primality tables.
+
+
+mersenne.cal
+
+    mersenne(p)
+
+    Perform a primality test of 2^p-1, for prime p>1.
+
+
+mod.cal        
+
+    mod(a)
+    mod_print(a)
+    mod_one()
+    mod_cmp(a, b)
+    mod_rel(a, b)
+    mod_add(a, b)
+    mod_sub(a, b)
+    mod_neg(a)
+    mod_mul(a, b)
+    mod_square(a)
+    mod_inc(a)
+    mod_dec(a)
+    mod_inv(a)
+    mod_div(a, b)
+    mod_pow(a, b)
+
+    Routines to handle numbers modulo a specified number.
+
+
+nextprime.cal
+
+    nextprime(n, tries)
+
+    Function to find the next prime (probably).
+
+
+pell.cal
+
+    pellx(D)
+    pell(D)
+
+    Solve Pell's equation; Returns the solution X to: X^2 - D * Y^2 = 1.
+    Type the solution to pells equation for a particular D.
+
+
+pi.cal
+
+    qpi(epsilon)
+
+    Calculate pi within the specified epsilon using the quartic convergence
+    iteration.
+
+
+pollard.cal
+
+    factor(N, N, ai, af)
+
+    Factor using Pollard's p-1 method.
+
+
+poly.cal       
+
+    Calculate with polynomials of one variable.  There are many functions.
+    Read the documentation in the library file.
+
+
+psqrt.cal      
+
+    psqrt(u, p)
+
+    Calculate square roots modulo a prime
+
+
+quat.cal
+
+    quat(a, b, c, d)
+    quat_print(a)
+    quat_norm(a)
+    quat_abs(a, e)
+    quat_conj(a)
+    quat_add(a, b)
+    quat_sub(a, b)
+    quat_inc(a)
+    quat_dec(a)
+    quat_neg(a)
+    quat_mul(a, b)
+    quat_div(a, b)
+    quat_inv(a)
+    quat_scale(a, b)
+    quat_shift(a, b)
+
+    Calculate using quaternions of the form: a + bi + cj + dk.  In these
+    functions, quaternians are manipulated in the form: s + v, where
+    s is a scalar and v is a vector of size 3.
+
+
+randmprime.cal
+
+    randmprime(bits, seed [,dbg])
+
+    Find a prime of the form h*2^n-1 >= 2^bits for some given x.  The initial
+    search points for 'h' and 'n' are selected by a cryptographic pseudo-random
+    number generator.  The optional argument, dbg, if set to 1, 2 or 3
+    turn on various debugging print statements.
+
+
+regress.cal    
+
+    Test the correct execution of the calculator by reading this library file.
+    Errors are reported with '****' mssages, or worse.  :-)
+
+
+solve.cal      
+
+    solve(low, high, epsilon)
+
+    Solve the equation f(x) = 0 to within the desired error value for x.
+    The function 'f' must be defined outside of this routine, and the low
+    and high values are guesses which must produce values with opposite signs.
+
+
+sumsq.cal      
+
+    ss(p)
+
+    Determine the unique two positive integers whose squares sum to the
+    specified prime.  This is always possible for all primes of the form
+    4N+1, and always impossible for primes of the form 4N-1.
+
+
+surd.cal       
+
+    surd(a, b)
+    surd_print(a)
+    surd_conj(a)
+    surd_norm(a)
+    surd_value(a, xepsilon)
+    surd_add(a, b)
+    surd_sub(a, b)
+    surd_inc(a)
+    surd_dec(a)
+    surd_neg(a)
+    surd_mul(a, b)
+    surd_square(a)
+    surd_scale(a, b)
+    surd_shift(a, b)
+    surd_div(a, b)
+    surd_inv(a)
+    surd_sgn(a)
+    surd_cmp(a, b)
+    surd_rel(a, b)
+
+    Calculate using quadratic surds of the form: a + b * sqrt(D).
+
+
+test1000.cal
+
+    This script is used by regress.cal to test the read and use keywords.
+
+
+unitfrac.cal
+
+    unitfrac(x)
+
+    Represent a fraction as sum of distinct unit fractions.
+
+
+varargs.cal
+
+    sc(a, b, ...)
+
+    Example program to use 'varargs'.  Program to sum the cubes of all 
+    the specified numbers.
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/altbind b/usr/src/contrib/calc-2.9.3t6/lib/altbind
new file mode 100644 (file)
index 0000000..583e1d3
--- /dev/null
@@ -0,0 +1,45 @@
+# Alternate key bindings for calc line editing functions
+
+map    base-map
+default        insert-char
+^@     set-mark
+^A     start-of-line
+^B     backward-char
+^D     quit
+^E     end-of-line
+^F     forward-char
+^H     backward-kill-char
+^J     new-line
+^K     kill-line
+^L     refresh-line
+^M     new-line
+^N     forward-history
+^O     save-line
+^P     backward-history
+^R     reverse-search
+^T     swap-chars
+^U     flush-input
+^V     quote-char
+^W     kill-region
+^Y     yank
+^?     delete-char
+^[     ignore-char     esc-map
+
+map    esc-map
+default        ignore-char     base-map
+G      start-of-line
+H      backward-history
+P      forward-history
+K      backward-char
+M      forward-char
+O      end-of-line
+S      delete-char
+g      goto-line
+s      backward-word
+t      forward-word
+d      forward-kill-word
+u      uppercase-word
+l      lowercase-word
+h      list-history
+^[     flush-input
+[      arrow-key
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/bernoulli.cal b/usr/src/contrib/calc-2.9.3t6/lib/bernoulli.cal
new file mode 100644 (file)
index 0000000..64581cf
--- /dev/null
@@ -0,0 +1,64 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Calculate the Nth Bernoulli number B(n).
+ * This uses the following symbolic formula to calculate B(n):
+ *
+ *     (b+1)^(n+1) - b^(n+1) = 0
+ *
+ * where b is a dummy value, and each power b^i gets replaced by B(i).
+ * For example, for n = 3:
+ *     (b+1)^4 - b^4 = 0
+ *     b^4 + 4*b^3 + 6*b^2 + 4*b + 1 - b^4 = 0
+ *     4*b^3 + 6*b^2 + 4*b + 1 = 0
+ *     4*B(3) + 6*B(2) + 4*B(1) + 1 = 0
+ *     B(3) = -(6*B(2) + 4*B(1) + 1) / 4
+ *
+ * The combinatorial factors in the expansion of the above formula are
+ * calculated interatively, and we use the fact that B(2i+1) = 0 if i > 0.
+ * Since all previous B(n)'s are needed to calculate a particular B(n), all
+ * values obtained are saved in an array for ease in repeated calculations.
+ */
+static Bnmax;
+static mat Bn[1001];
+
+
+define B(n)
+{
+       local   nn, np1, i, sum, mulval, divval, combval;
+
+       if (!isint(n) || (n < 0))
+               quit "Non-negative integer required for Bernoulli";
+
+       if (n == 0)
+               return 1;
+       if (n == 1)
+               return -1/2;
+       if (isodd(n))
+               return 0;
+       if (n > 1000)
+               quit "Very large Bernoulli";
+
+       if (n <= Bnmax)
+               return Bn[n];
+
+       for (nn = Bnmax + 2; nn <= n; nn+=2) {
+               np1 = nn + 1;
+               mulval = np1;
+               divval = 1;
+               combval = 1;
+               sum = 1 - np1 / 2;
+               for (i = 2; i < np1; i+=2) {
+                       combval = combval * mulval-- / divval++;
+                       combval = combval * mulval-- / divval++;
+                       sum += combval * Bn[i];
+               }
+               Bn[nn] = -sum / np1;
+       }
+       Bnmax = n;
+       return Bn[n];
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "B(n) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/bigprime.cal b/usr/src/contrib/calc-2.9.3t6/lib/bigprime.cal
new file mode 100644 (file)
index 0000000..83b5237
--- /dev/null
@@ -0,0 +1,32 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * A prime test, base a, on p*2^x+1 for even x>m.
+ */
+
+define bigprime(a, m, p)
+{
+       local n1, n;
+
+       n1 = 2^m * p;
+       for (;;) {
+               m++;
+               n1 += n1;
+               n = n1 + 1;
+               if (isodd(m))
+                       continue;
+               print m;
+               if (pmod(a, n1 / 2, n) != n1)
+                       continue;
+               if (pmod(a, n1 / p, n) == 1)
+                       continue;
+               print " " : n;
+       }
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "bigprime(a, m, p) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/bindings b/usr/src/contrib/calc-2.9.3t6/lib/bindings
new file mode 100644 (file)
index 0000000..694ca38
--- /dev/null
@@ -0,0 +1,45 @@
+# Default key bindings for calc line editing functions
+
+map    base-map
+default        insert-char
+^@     set-mark
+^A     start-of-line
+^B     backward-char
+^D     delete-char
+^E     end-of-line
+^F     forward-char
+^H     backward-kill-char
+^J     new-line
+^K     kill-line
+^L     refresh-line
+^M     new-line
+^N     forward-history
+^O     save-line
+^P     backward-history
+^R     reverse-search
+^T     swap-chars
+^U     flush-input
+^V     quote-char
+^W     kill-region
+^Y     yank
+^?     backward-kill-char
+^[     ignore-char     esc-map
+
+map    esc-map
+default        ignore-char     base-map
+G      start-of-line
+H      backward-history
+P      forward-history
+K      backward-char
+M      forward-char
+O      end-of-line
+S      delete-char
+g      goto-line
+s      backward-word
+t      forward-word
+d      forward-kill-word
+u      uppercase-word
+l      lowercase-word
+h      list-history
+^[     flush-input
+[      arrow-key
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/chrem.cal b/usr/src/contrib/calc-2.9.3t6/lib/chrem.cal
new file mode 100644 (file)
index 0000000..bfbb176
--- /dev/null
@@ -0,0 +1,181 @@
+/*
+ * chrem - Chinese remainder theorem/problem solver
+ *
+ * When possible, chrem finds solutions for x of a set of congruences
+ * of the form:
+ *
+ *                     x = r1 (mod m1)
+ *                     x = r2 (mod m2)
+ *                        ...
+ *
+ * where the residues r1, r2, ... and the moduli m1, m2, ... are
+ * given integers.  The Chinese remainder theorem states that if
+ * m1, m2, ... are relatively prime in pairs, the above congruences
+ * have a unique solution modulo  m1 * m2 * ...   If m1, m2, ...
+ * are not relatively prime in pairs, it is possible that no solution
+ * exists.  If solutions exist, the general solution is expressible as:
+ *
+ *                   x = r (mod m)
+ *
+ * where m = lcm(m1,m2,...), and if m > 0, 0 <= r < m.  This
+ * solution may be interpreted as:
+ *
+ *                  x = r + k * m                      [[NOTE 1]]
+ *
+ * where k is an arbitrary integer.
+ *
+ ***
+ *
+ * usage:
+ *
+ *     chrem(r1,m1 [,r2,m2, ...])
+ *
+ *         r1, r2, ...         remainder integers or null values
+ *         m1, m2, ...         moduli integers
+ *
+ *     chrem(r_list, [m_list])
+ *
+ *         r_list      list (r1,r2, ...)
+ *         m_list      list (m1,m2, ...)
+ *
+ *         If m_list is omitted, then 'defaultmlist' is used.
+ *         This default list is a global value that may be changed
+ *         by the user.  Initially it is the first 8 primes.
+ *
+ * If a remainder is null(), then the corresponding congruence is 
+ * ignored.  This is useful when working with a fixed list of moduli.  
+ * 
+ * If there are more remainders than moduli, then the later moduli are 
+ * ignored.
+ *
+ * The moduli may be any integers, not necessarily relatively prime in 
+ * pairs (as required for the Chinese remainder theorem).  Any moduli 
+ * may be zero;  x = r (mod 0) has the meaning of x = r.
+ *
+ * returns:
+ *
+ *    If args were integer pairs:
+ *
+ *       r             ('r' is defined above, see [[NOTE 1]])
+ *
+ *    If 1 or 2 list args were given:
+ *
+ *       (r, m)        ('r' and 'm' are defined above, see [[NOTE 1]])
+ *
+ * NOTE: In all cases, null() is returned if there is no solution.
+ *
+ ***
+ *
+ * This function may be used to solve the following historical problems:
+ *
+ *   Sun-Tsu, 1st century A.D.  
+ *
+ *     To find a number for which the reminders after division by 3, 5, 7 
+ *     are 2, 3, 2, respectively:
+ *
+ *         chrem(2,3,3,5,2,7) ---> 23
+ *
+ *   Fibonacci, 13th century A.D.
+ *
+ *     To find a number divisible by 7 which leaves remainder 1 when 
+ *     divided by 2, 3, 4, 5, or 6:
+ *
+ *
+ *         chrem(list(0,1,1,1,1,1),list(7,2,3,4,5,6)) ---> (301,420)
+ *
+ *     i.e., any value that is 301 mod 420.
+ *
+ * Written by: Ernest W Bowen <ernie@neumann.une.edu.au>
+ * Interface by: Landon Curt Noll <chongo@toad.com>
+ */
+
+static defaultmlist = list(2,3,5,7,11,13,17,19); /* The first eight primes */
+
+define chrem()
+{
+    local argc;                /* number of args given */
+    local rlist;       /* reminder list - ri */
+    local mlist;       /* modulus list - mi */
+    local list_args;   /* true => args given are lists, not r1,m1, ... */
+    local m,z,r,y,d,t,x,u,i;
+
+    /* 
+     * parse args 
+     */
+    argc = param(0);
+    if (argc == 0) {
+       quit "usage: chrem(r1,m1 [,r2,m2 ...]) or chrem(r_list, m_list)";
+    }
+    list_args = islist(param(1));
+    if (list_args) {
+       rlist = param(1);
+       mlist = (argc == 1) ? defaultmlist : param(2);
+       if (size(rlist) > size(mlist)) {
+           quit "too many residues";
+       }
+    } else {
+       if (argc % 2 == 1) {
+           quit "odd number integers given";
+       }
+       rlist = list();
+       mlist = list();
+       for (i=1; i <= argc; i+=2) {
+           push(rlist, param(i));
+            push(mlist, param(i+1));
+       }
+    }
+
+    /* 
+     * solve the problem found in rlist & mlist 
+     */
+    m = 1; 
+    z = 0;
+    while (size(rlist)) { 
+       r=pop(rlist); 
+       y=abs(pop(mlist));
+       if (r==null()) 
+           continue;
+       if (m) {
+           if (y) {
+               d = t = z - r;
+               m = lcm(x=m, y);
+               while (d % y) { 
+                   u = x; 
+                   x %= y; 
+                   swap(x,y);
+                   if (y==0) 
+                       return;
+                   z += (t *= -u/y);
+               }
+           } else { 
+               if ((r % m) != (z % m)) 
+                   return;
+               else {
+                   m = 0; 
+                   z = r;
+               }
+           }
+       } else if (((y) && (r % y != z % y)) || (r != z)) 
+           return;
+    }
+    if (m) { 
+       z %= m; 
+       if (z < 0) 
+           z += m;
+    }
+
+    /* 
+     * return information as required 
+     */
+    if (list_args) {
+       return list(z,m);
+    } else {
+       return z;
+    }
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "chrem(r1,m1 [,r2,m2 ...]) defined";
+    print "chrem(rlist [,mlist]) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/cryrand.cal b/usr/src/contrib/calc-2.9.3t6/lib/cryrand.cal
new file mode 100644 (file)
index 0000000..17cea48
--- /dev/null
@@ -0,0 +1,2718 @@
+/*
+ * cryrand - cryptographically strong pseudo-random number generator library
+ */
+/*
+ * Copyright (c) 1994 by Landon Curt Noll.  All Rights Reserved.
+ *
+ * Permission to use, copy, modify, and distribute this software and
+ * its documentation for any purpose and without fee is hereby granted,
+ * provided that the above copyright, this permission notice and text
+ * this comment, and the disclaimer below appear in all of the following:
+ *
+ *     supporting documentation
+ *     source copies
+ *     source works derived from this source
+ *     binaries derived from this source or from derived source
+ *
+ * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
+ * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO
+ * EVENT SHALL LANDON CURT NOLL BE LIABLE FOR ANY SPECIAL, INDIRECT OR
+ * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF
+ * USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ *
+ * chongo was here     /\../\
+ */
+
+/*
+ * These routines are written in the calc language.  At the time of this
+ * notice, calc was at version 2.9.2 (We refer to calc, as in the C
+ * program, not the Emacs subsystem).
+ *
+ * Calc is available by anonymous ftp from ftp.uu.net under the 
+ * directory /pub/calc.
+ *
+ * If you can't get calc any other way, EMail a request to my EMail
+ * address as shown below.
+ *
+ * Comments, suggestions, bug fixes and questions about these routines
+ * are welcome.  Send EMail to the address given below.
+ *
+ * Happy bit twiddling,
+ *
+ *                     Landon Curt Noll
+ *
+ *                     chongo@toad.com
+ *                     ...!{pyramid,sun,uunet}!hoptoad!chongo
+ */
+
+/*
+ * AN OVERVIEW OF THE FUNCTIONS:
+ *
+ * This calc library contains several pseudo-random number generators:
+ *
+ *   additive 55:
+ *
+ *     a55rand   - external interface to the additive 55 generator
+ *     sa55rand  - seed the additive 55 generator
+ *
+ *     This is a generator based on the additive 55 generator as
+ *     described in Knuth's "The Art of Computer Programming -
+ *     Seminumerical Algorithms", vol 2, 2nd edition (1981),
+ *     Section 3.2.2, page 27, Algorithm A.
+ *
+ *     The period and other properties of this generator make it very
+ *     useful to 'seed' other generators.
+ *
+ *     This generator is used by other other generators to produce
+ *     various internal values.  In fact, the lower 64 bits of seed
+ *     given to other other generators is passed to sa55rand().
+ *
+ *      If you need a fast generator and do not need a crypto strong one,
+ *      you should consider using the shuffle generator instead.
+ *
+ *   shuffle:
+ *
+ *     shufrand  - generate a pseudo-random value via a shuffle process
+ *     sshufrand - seed the shufrand generator
+ *     rand      - generate a pseudo-random value over a given range
+ *     srand     - seed the random stream generator
+ *
+ *     This is a generator based on the shuffle generator as described in
+ *     Knuth's "The Art of Computer Programming - Seminumerical Algorithms",
+ *     vol 2, 2nd edition (1981), Section 3.2.2, page 32, Algorithm B.
+ *
+ *     The shuffle generator is fast and serves as a fairly good standard
+ *     pseudo-random generator.
+ *
+ *     The shuffle generator is feed random values by the additive 55
+ *     generator via a55rand().  Calling a55rand() or sa55rand() will
+ *     affect the shuffle generator output.
+ *
+ *     The rand function is really another interface to the shuffle
+ *     generator.  Unlike shufrand(), rand() can return a value of any
+ *     given size.  The value returned by rand() may be confined to
+ *     either a half open [0,a) (0 <= value < a) or closed interval
+ *     [a,b] (a <= value <= b).  By default, a 64 bit value is returned.
+ *
+ *     Calling srand() simply calls sshufrand() with the same seed.
+ *
+ *   crypto:
+ *
+ *     cryrand   - produce a cryptographically strong pseudo-random number
+ *     scryrand  - seed the crypto generator
+ *     random    - produce a cryptographically strong pseudo-random number
+ *                 over a given range
+ *     srandom   - seed random
+ *
+ *     This generator is described in the papers:
+ *
+ *         Blum, Blum, and Shub, "Comparison of Two Pseudorandom Number
+ *         Generators", in Chaum, D. et. al., "Advances in Cryptology:
+ *         Proceedings Crypto 82", pp. 61-79, Plenum Press, 1983.
+ *
+ *         Blum, Blum, and Shub, "A Simple Unpredictable Pseudo-Random
+ *         Number Generator", SIAM Journal of Computing, v. 15, n. 2,
+ *         1986, pp. 364-383.
+ *
+ *         U. V. Vazirani and V. V. Vazirani, "Trapdoor Pseudo-Random
+ *         Number Generators with Applications to Protocol Design",
+ *         Proceedings of the 24th  IEEE Symposium on the Foundations
+ *         of Computer Science, 1983, pp. 23-30.
+ *
+ *         U. V. Vazirani and V. V. Vazirani, "Efficient and Secure
+ *         Pseudo-Random Number Generation", Proceedings of the 24th
+ *         IEEE Symposium on the Foundations of Computer Science,
+ *         1984, pp. 458-463.
+ *
+ *         U. V. Vazirani and V. V. Vazirani, "Efficient and Secure
+ *         Pseudo-Random Number Generation", Advances in Cryptology -
+ *         Proceedings of CRYPTO '84, Berlin: Springer-Verlag, 1985,
+ *         pp. 193-202.
+ *
+ *         "Probabilistic Encryption", Journal of Computer & System
+ *         Sciences 28, pp. 270-299.
+ *
+ *     We also refer to this generator as the 'Blum' generator.
+ *
+ *     This generator is considered 'strong' in that it passes all
+ *     polynomial-time statistical tests.
+ *
+ *     The crypto generator is not as fast as most generators, though
+ *     it is not painfully slow either.
+ *
+ *     One may fully seed this generator via scryrand().  Calling
+ *     scryrand() with 1 or 3 arguments will result in the additive
+ *     55 generator being seeded with the same seed.  Calling
+ *     scryrand() with 4 arguments, where the first argument
+ *     is >= 0 will also result in the additive 55 generator
+ *     being seeded with the same seed.
+ *
+ *     The random() generator is really another interface to the
+ *     crypto generator.  Unlike cryrand(), random() can return a
+ *     value confined to either a half open (0 <= value < a) or closed
+ *     interval (a <= value <= b).  By default, a 64 bit value is
+ *     returned.
+ *
+ *     Calling srandom() simply calls scryrand(seed).  The additive
+ *     55 generator will be seeded with the same seed.
+ *
+ * As a bonus, the function 'nxtprime' is provided to produce a probable
+ * prime number.
+ *
+ * All generators come already seeded with precomputed initial constants.
+ * Thus, it is not required to seed a generator before using it.
+ *
+ * Using a seed of '0' will reload generators with their initial states.
+ * In the case of scryrand(), lengths of -1 must also be supplied.
+ *
+ *     sa55rand(0)             initializes only additive 55
+ *     sshufrand(0)            initializes additive 55 and shuffle
+ *     srand(0)                initializes additive 55 and shuffle
+ *     scryrand(0,-1,-1)       initializes all generators
+ *     scryrand(0)             initializes all generators
+ *     srandom(0)              initializes all generators
+ *     randstate(0)            initializes all generators
+ *
+ * All of the above single arg calls are fairly fast.  In fact, passing
+ * seeding with a non-zero seed, in the above cases, where seed is
+ * not excessively large (many bits long), is also reasonably fast.
+ *
+ * The call:
+ *
+ *     scryrand(-1, ip, iq, ir)
+ *
+ * is fast because no checking is performed on the 'ip', 'iq', or 'ir'
+ * when seed is -1.  NOTE: One must ensure that 'ip', 'iq', are valid
+ * Blum primes and that 'ir' is a quadratic residue of their product!
+ *
+ * A call of scryrand(seed,len1,len2), with len1,len2 > 4, (3 args)
+ * is a somewhat slow as the length args increase.  This type of
+ * call selects 2 primes that are used internally by the crypto
+ * generator.  A call of scryrand(seed,ip,iq,ir) where seed >= 0
+ * is as slow as the 3 arg case.  See scryrand() for more information.
+ *
+ * A call of scryrand() (no args) may be used to quickly change the
+ * internal state of the crypto and random generators.  Only one major
+ * internal crypto generator value (a quadratic residue) is randomly
+ * selected via the additive 55 generator.  The other 2 major internal
+ * values (the 2 Blum primes) are preserved.  In this form, the additive
+ * 55 is not seeded.
+ *
+ * Calling scryrand(seed,[len1,len2]) (1 or 3 args), or calling
+ * srandom(seed) will leave the additive 55 and shuffle generator in a
+ * seeded state as if srand(seed) has been called.  Calling
+ * scryrand(seed,ip,iq,ir) (4 args), with seed>0 will also leave
+ * the additive 55 generator in the same scryrand(seed) state.
+ *
+ * Calling scryrand() (no args) will not seed the additive
+ * 55 or shuffle generator before or afterwards.  The additive 55
+ * and shuffle generators will be changed as a side effect of that call.
+ *
+ * Calling srandom(seed) produces the same results as calling scryrand(seed).
+ *
+ * The states of all generators (additive 55, shuffle and crypto) can be
+ * saved and restored via the randstate() function.  Saving the state just
+ * after seeding a generator and restoring it later as a very fast way
+ * to reseed a generator.
+ *
+ * TRUTH IN ADVERTISING:
+ *
+ * The word 'probable', in reference to the nxtprime() function, is used
+ * because of an extremely extremely small chance that a composite (a
+ * non-prime) may be returned.  In no cases will a prime be skipped.
+ * For our purposes, this is sufficient as the chance of returning a
+ * composite is much smaller than the chance that a hardware glitch
+ * will cause nxtprime() to return a bogus result.
+ *
+ * Another "truth in advertising" issue is the use of the term
+ * 'pseudo-random'.  All deterministic generators are pseudo random.
+ * This is opposed to true random generators based on some special
+ * physical device.
+ *
+ * The crypto generator is 'pseudo-random'.  There is no statistical
+ * test, which runs in polynomial time, that can distinguish the crypto
+ * generator from a truly random source.
+ *
+ * A final "truth in advertising" issue deals with how the magic numbers
+ * found in this library were generated.  Detains can be found in the
+ * various functions, while a overview can be found in the SOURCE FOR
+ * MAGIC NUMBERS section below.
+ *
+ ****
+ *
+ * ON THE GENERATORS:
+ *
+ * The additive 55 generator has a good period, and is fast.  It is
+ * reasonable as generators go, though there are better ones available.
+ * We use it in seeding the crypto generator as its period and
+ * other statistical properties are good enough for our purposes.
+ *
+ * This shuffle generator has a very good period, and is fast.  It is
+ * fairly good as generators go, and is better than the additive 55
+ * generator.  Casual direct use of the shuffle generator may be
+ * acceptable.  Because of this, the interface to the shuffle generator,
+ * but not the additive 55 generator, is advertised when this file is
+ * loaded.
+ *
+ * The shuffle generator functions, shufrand() and rand() use the same
+ * seed and tables.  The shuffle generator shuffles the values produced
+ * by the additive 55 generator.  Calling or seeding the additive 55
+ * generator will affect the output of the shuffle generator.
+ *
+ * The crypto generator is the best generator in this package.  It
+ * produces a cryptographically strong pseudo-random bit sequence.
+ * Internally, a fixed number of bits are generated after each
+ * generator iteration.  Any unused bits are saved for the next call
+ * to the generator.  The crypto generator is not too slow, though
+ * seeding the generator from scratch is slow.  Shortcuts and
+ * pre-computer seeds have been provided for this reason.  Use of
+ * crypto should be more than acceptable for many applications.
+ *
+ * The crypto seed is in 4 parts, the additive 55 seed (lower 64
+ * bits of seed), the shuffle seed (all but the lower 64 bits of
+ * seed), and two lengths.  The two lengths specifies the minimum
+ * bit size of two primes used internal to the crypto generator.
+ * Not specifying the lengths, or using -1 will cause crypto to
+ * use the default minimum lengths of 248 and 264 bits, respectively.
+ *
+ * The random() function just another interface to the crypto
+ * generator.  Like rand(), random() provides an interval capability
+ * (closed or open) as well as a 64 bit default return value.
+ * The random() function as good as crypto, and produces numbers
+ * that are equally cryptographically strong.  One may use the
+ * seed functions srandom() or scryrand() for either the random()
+ * or cryrand() functions.
+ *
+ * The seed for all of the generators may be of any size.  Only the
+ * lower 64 bits of seed affect the additive 55 generator.  Bits
+ * beyond the lower 64 bits affect the shuffle generators.  Excessively
+ * large values of seed will result in increased memory usage as
+ * well as a larger seed time for the shuffle and crypto generators.
+ * See REGARDING SEEDS below, for more information.
+ *
+ * One may save and restore the state of all generators via the
+ * randstate() function.
+ *
+ ****
+ *
+ * REGARDING SEEDS:
+ *
+ * Because the generators are interrelated, seeding one generator
+ * will directly or indirectly affect the other generators.  Seeding
+ * the shuffle generator seeds the additive 55 generator.  Seeding
+ * the crypto generator seeds the shuffle generator.
+ *
+ * The seed of '0' implies that a generator should be seeded back
+ * to its initial default state.
+ *
+ * For the moment, seeds < -1 are reserved for future use.  The
+ * value of -1 is used as a special indicator to the fourth form
+ * of scryrand(), and it not a real seed.
+ *
+ * A seed may be of any size.  The additive 55 generator uses only
+ * the lower 64 bits, while the shuffle generator uses bytes beyond
+ * the lower 64 bits.
+ *
+ * To help make the generator produced by seed S, significantly
+ * different from S+1, seeds are scrambled prior to use.  The
+ * function randreseed64() maps [0,2^64) into [0,2^64) in a 1-to-1
+ * and onto fashion.
+ *
+ * The purpose of the randreseed64() is not to add security.  It
+ * simply helps remove the human perception of the relationship
+ * between the seed and the production of the generator.
+ *
+ * The randreseed64() process does not reduce the security of the
+ * generators.  Every seed is converted into a different unique seed.
+ * No seed is ignored or favored.
+ *
+ * There is no limit on the size of a seed.  On the other hand,
+ * extremely large seeds require large tables and long seed times.
+ * Using a seed in the range of [2^64, 2^64 * 128!) should be
+ * sufficient for most purposes.  An easy way to stay within this
+ * range to to use seeds that are between 21 and 215 digits, or 64 to
+ * 780 bits long.
+ *
+ ****
+ *
+ * SOURCE OF MAGIC NUMBERS:
+ *
+ * Most of the magic constants used on this library ultimately are
+ * based on the Rand book of random numbers.  The Rand book contains
+ * 10^6 decimal digits, generated by a physical process.  This book,
+ * produced by the Rand corporation in the 1950's is considered
+ * a standard against which other generators may be measured.
+ *
+ * The Rand book of numbers was groups into groups of 20 digits.
+ * The first 55 groups < 2^64 were used to initialize add55_init_tbl.
+ * The size of 20 digits was used because 2^64 is 20 digits long.
+ * The restriction of < 2^64 was used to prevent modulus biasing.
+ * (see the note on  modulus biasing in rand()).
+ *
+ * The additive 55 generator during seeding is used 128 times to help
+ * remove the initial seed state from the initial values produced.
+ * The loop count of 128 was a power of 2 that permits each of the
+ * 55 table entries to be processed at least twice.
+ *
+ * The function, randreseed64(), uses 4 primes to scramble 64 bits
+ * into 64 bits.  These primes were also extracted from the Rand
+ * book of numbers.  See sshufrand() for details.
+ *
+ * The default shuffle table size of 128 entries is the power of 2
+ * that is longer than the 100 entries recommended by Knuth for
+ * the shuffle algorithm (see the text cited in shufrand()).
+ * We use a power of 2 shuffle table length so that the shuffle
+ * process can select a table entry from a new additive 55 value
+ * by extracting its top most bits.
+ *
+ * The quadratic residue search performed by cryres() starts at
+ * a value that is in the interval [2^sqrpow,n-100], where '2^sqrpow'
+ * is the smallest power of 2 >= 'n^(3/4)' where 'n=p*q'.  We also
+ * reject any initial residue whose square (mod n) does not fit
+ * this same restriction.  Finally, we reject any residue that
+ * is within 100 of its square (mod n).
+ *
+ * The use of 'n^(3/4)' insures that the quadratic residue is
+ * large, but not too large.  We want to avoid residues that are
+ * near 0 or that are near 'n'.  Such residues are trivial or
+ * semi-trivial.  Applying the same restriction to the square
+ * of the initial residue avoid initial residues near 'sqrt(n)'.
+ * Such residues are trivial or semi-trivial as well.
+ *
+ * Avoiding residues whose squares (mod n) are not within 100 of 
+ * itself helps avoid selecting residue sequences (repeated 
+ * squaring mod n) that initally do not change very much.
+ * Such residues might be somewhat trivial, so we play it safe.
+ *
+ * Taking some care to select a good initial residue helps
+ * eliminate cheep search attacks.  It is true that a subsequent
+ * residue could be one of the residues that we would initially
+ * avoid.  However such an occurance will happen after the
+ * generator is well underway and any such information
+ * has been lost.
+ *
+ * The use of '100' in the above initial residue selection is
+ * somewhat arbitrary.  It could be argued that a value as
+ * small as 10 are sufficient.  The value '100' was selected
+ * because it is the first 3 digits of the Rand Book of Numbers.
+ * We used 3 digits instead of 2 or 1 because '10' was too close
+ * for comfort and '1' was clearly too small.
+ *
+ * Because of the initial 'n-100' upper bound part of the initial
+ * residue selection range, the smallest Blum prime that may be
+ * used is 19.  The first 3 Blum primes 3, 7, and 11 cannot be
+ * used.  The largest value of 'n' that is a product of those
+ * Blum primes is 121.  The 'n-100' value (21) is already smaller
+ * than the smallest power of 2 >= 'n^(3/4)'.  The next Blum prime,
+ * 19, produces the smallest value of 'n' (19*19=361) for which
+ * one can find an initial residue that can satisfy the above.
+ * By not considering Blum primes that are less than 5 bits long,
+ * we avoid the smaller problem values.
+ *
+ * The final magic numbers: '248' and '264' are the exponents the
+ * largest powers of 2 that are < the two default Blum primes 'p'
+ * and 'q' used by the crypto generator.  The values of '248' and
+ * '264' implies that the product n=p*q > 2^512.  Each iteration
+ * of the crypto generator produces log2(log2(n=p*q)) random bits.
+ * The crypto generator is the most efficient when n is slightly >
+ * 2^(2^b).  The product n > 2^(2^9)) produces 9 bits as efficiently
+ * as possible under the crypto generator process.
+ *
+ * Not being able to factor 'n=p*q' into 'p' and 'q' does not directly
+ * improve the crypto generator.  On the other hand, it can't hurt.
+ * The two len values differ slightly to avoid factorization attacks
+ * that work on numbers that are a perfect square, or where the two
+ * primes are nearly the same.  I elected to have the sizes differ
+ * by 3% of the product size.  The difference between '248' and
+ * '264', is '16', which is ~3.125% of '512'.  Now 3% of '512' is
+ * '~15.36', and the next largest whole number is '16'.
+ *
+ * The product n=p*q > 2^512 implies a product if at least 155 digits.
+ * A product of two primes that is at least 155 digits is slightly
+ * beyond Number Theory and computer power of Nov 1992, though this
+ * will likely change in the future.
+ *
+ * Again, the ability (or lack thereof) to factor 'n=p*q' does not
+ * directly relate to the strength of the crypto generator.  We
+ * selected n=p*q > 2^512 mainly because '512 was a power of 2 and
+ * only slightly because it is up in the range where it is difficult
+ * to factor.
+ *
+ ****
+ *
+ * FOR THE PARANOID:
+ *
+ * The truly paranoid might suggest that my claims in the MAGIC NUMBERS
+ * section are a lie intended to entrap people.  Well they are not, but
+ * you need not take my word for it.
+ *
+ * The random numbers from the Rand book of random numbers can be
+ * verified by anyone who obtains the book.  As these numbers were
+ * created before I (Landon Curt Noll) was born (you can look up
+ * my birth record if you want), I claim to have no possible influence
+ * on their generation.
+ *
+ * There is a very slight chance that the electronic copy of the
+ * Rand book that I was given access to differs from the printed text.
+ * I am willing to provide access to this electronic copy should
+ * anyone wants to compare it to the printed text.
+ *
+ * One might object to the complexity of the seed scramble/mapping
+ * via the randreseed64() function.  The randreseed64() function maps:
+ *
+ *     1 ==> 4967126403401436567
+ *
+ * calling srand(1) with the randreseed64() process would be the same
+ * as calling srand(4967126403401436567) without it.  No extra security
+ * is gained or reduced by using the randreseed64() process.  The meaning
+ * of seeds are exchanged, but not lost or favored (used by more than
+ * one input seed).
+ *
+ * One could take issue with my selection of the default sizes '248'
+ * and '264'.   As far as I know, 155 digits (512 bits) is beyond the
+ * state of the art of Number Theory and Computation as of 01 Sep 92.
+ * It will likely be true that 155 digit products of two primes could
+ * come within reach in the next few years, but so what?  If you are
+ * truly paranoid, why would you want to use the default seed, which
+ * is well known?
+ *
+ * The paranoid today might consider using the lengths of at least '345'
+ * and '325' will produce a product of two primes that is 202 digits.
+ * (the 2nd and 3rd args of scryrand > 345 & >325 respectively)  Factoring
+ * 200+ digit product of two primes is well beyond the current hopes of
+ * Number Theory and Computer power, though even this limit may be passed
+ * someday.
+ *
+ * One might ask if value of '100' is too small with respect to the
+ * initial residue selection.  Showing that '100' is too small would
+ * be difficult.  Even if one could make that case, the chance that
+ * a 'problem' initial reside would be used would be very very small
+ * for non-trivial values of 'p' and 'q'.
+ *
+ * If all the above fails to pacify the truly paranoid, then one may
+ * select by some independent means, 2 Blum primes (primes mod 4 == 3,
+ * p < q), and a quadratic residue if p*q.  Then by calling:
+ *
+ *     scryrand(-1, p, q, r)
+ *
+ * and then calling cryrand() or random(), one may bypass all magic
+ * numbers and use the pure generator.
+ *
+ * Note that randstate() may also be used by the truly paranoid.
+ * Even though it holds state for the other generators, their states
+ * are independent.
+ *
+ ****
+ *
+ * GOALS:
+ *
+ * The goals of this package are:
+ *
+ *     all magic numbers are explained
+ *
+ *         I distrust systems with constants (magic numbers) and tables
+ *         that have no justification (e.g., DES).  I believe that I have
+ *         done my best to justify all of the magic numbers used.
+ *
+ *      full documentation
+ *
+ *         You have this source file, plus background publications,
+ *         what more could you ask?
+ *
+ *     large selection of seeds
+ *
+ *         Seeds are not limited to a small number of bits.  A seed
+ *         may be of any size.
+ *
+ *     the strength of the generators may be tuned to meet the application need
+ *
+ *         By using the appropriate seed arguments, one may increase
+ *         the strength of the generator to suit the need of the
+ *         application.  One does not have just a few levels.
+ *
+ * This calc lib file is intended for demonstration purposes.  Writing
+ * a C program (with possible assembly or libmp assist) would produce
+ * a faster generator.
+ *
+ * Even though I have done my best to implement a good system, you still
+ * must use these routines your own risk.
+ *
+ * Share and enjoy!  :-)
+ */
+
+
+/*
+ * These constants are used by all of the generators in various direct and
+ * indirect forms.
+ */
+static cry_seed = 0;                   /* master seed */
+static cry_mask = 0xffffffffffffffff;  /* 64 bit work mask */
+
+
+/*
+ * Initial magic values for the additive 55 generator - used by sa55rand()
+ *
+ * These values were generated from the Rand book of random numbers.
+ * In groups of 20 digits, we took the first 55 groups < 2^64.  Leading 
+ * 0 digits were dropped off to avoid confusion with octal values.
+ */
+static mat add55_init_tbl[55] = {
+    10097325337652013586,      8422689531964509303,       9376707153831131165,
+    12807999708015736147,      12171768336606574717,      2051656926866574818,
+     3529647783580834282,      13746700781847540610,     17468509505804776974,
+    14385537637435099817,      14225685144642756788,     11100020401286074697,
+     7207317906119690446,      15474452669527079953,      16868487670307112059,
+     4493524947524633824,      13021248927856520106,     15956600001874392423,
+     1758753794041921585,      1540354560501451176,       5335129695612719255,
+     9973334408846123356,      2295368703230757546,      15020099946907494138,
+    10518216150184876938,      9188200973282539527,       4220863048338987374,
+      682273982071453295,      7706178130835869910,       4618975533122308420,
+      397583911260717646,      5686731560708285046,      10123916228549657560,
+     1304775865627110086,      15501295782182641134,      3061180729620744156,
+     6958929830512809719,      10850627469959910507,     13499063195307571839,
+     6410193623982098952,      4111084083850807341,      17719042079595449953,
+     5462692006544395659,      18288274374963224041,      8337656769629990836,
+     7477446061798548911,      9815931464890815877,       6913451974267278601,
+    11883095286301198901,      14974403441045516019,     14210337129134237821,
+    12883973436502761184,      4285013921797415077,      16435915296724552670,
+     3742838738308012451
+};
+
+
+/*
+ * additive 55 tables - used by a55rand() and sa55rand()
+ */
+static add55_j = 23;           /* the first walking table pointer */
+static add55_k = 54;           /* the second walking table pointer */
+static add55_seed64 = 0;       /* lower 64 bits of the reseeded seed */
+static mat add55_tbl[55];      /* additive 55 state table */
+
+
+/*
+ * cryobj - cryptographic pseudo-random state object
+ */
+obj cryobj {                                                   \
+    p,         /* first Blum prime (prime 3 mod 4) */          \
+    q,         /* second Blum prime (prime 3 mod 4) */         \
+    r,         /* quadratic residue of n=p*q */                \
+    exp,       /* used in computing crypto good bits */        \
+    left,      /* bits unused from the last cryrand() call */  \
+    bitcnt,    /* left contains bitcnt crypto good bits */     \
+    a55j,      /* 1st additive 55 table pointer */             \
+    a55k,      /* 2nd additive 55 table pointer */             \
+    seed,      /* last seed set by sa55rand() or 0 */          \
+    shufy,     /* Y (previous a55rand output for shuffle) */   \
+    shufsz,    /* size of the shuffle table */                 \
+    shuftbl,   /* a matrix of shufsz entries */                \
+    a55tbl     /* additive 55 generator state table */         \
+}
+
+
+/*
+ * initial cryptographic pseudo-random values - used by scryrand()
+ *
+ * These values are what the crypto generator is initialized with
+ * with this library first read.  These values may be reproduced the
+ * hard way by calling scryrand(0,248,264) or scryrand(0,-1,-1).
+ *
+ * We will build up these values a piece at a time to avoid long lines
+ * that are difficult to send via EMail.
+ */
+/* p, first Blum prime */
+static cryrand_init_p = 0x1aa9e726a735044;
+cryrand_init_p <<= 200;
+cryrand_init_p |= 0x73b7457c5297122310880fcbfa8d4e38380a00396d533300bb;
+/* q, second Blum prime */
+static cryrand_init_q = 0xa62ee0481aa12059c3;
+cryrand_init_q <<= 200;
+cryrand_init_q |= 0x79ef44e72ff58ea70cacabbe9d264a0b16db72117d96f77e17;
+/* quadratic residue of n=p*q */
+static cryrand_init_r = 0x3d214853f9a5bb4b12f467c9052129a9;
+cryrand_init_r <<= 200;
+cryrand_init_r |= 0xd215cc6b3c2eae8c7090591b16d8044a886b3c6a58759b1a07;
+cryrand_init_r <<= 200;
+cryrand_init_r |= 0x2b50a914b42e1b6f9703be86742837c4bc637804c2dc668c5b;
+
+/*
+ * cryptographic pseudo-random values - used by cryrand() and scryrand()
+ */
+/* p, first Blum prime */
+static cryrand_p = cryrand_init_p;
+/* q, second Blum prime */
+static cryrand_q = cryrand_init_q;
+/* n = p*q */
+static cryrand_n = cryrand_p*cryrand_q;
+/* quad residue of n */
+static cryrand_r = cryrand_init_r;
+/* this cryrand() running exp used in computing crypto good bits */
+static cryrand_exp = cryrand_r;
+/* good crypto bits unused from the last cryrand() call */
+static cryrand_left = 0;
+/* the value cryrand_left contains cryrand_bitcnt crypto good bits */
+static cryrand_bitcnt = 0;
+
+
+/*
+ * shufrand - shuffle generator constants
+ */
+static shuf_size = 128;                        /* entries in shuffle table */
+static shuf_shift = (64-highbit(shuf_size));   /* shift a55 value to get tbl indx */
+static shuf_y;                         /* Y value (previous output) */
+static mat shuf_tbl[shuf_size];                /* shuffle state table */
+
+
+/*
+ * products of consecutive primes - used by nxtprime()
+ *
+ * We compute these products now to avoid recalculating them on each call.
+ * These values help weed out numbers that have a prime factor < 1000.
+ */
+static nxtprime_pfact10 = pfact(10);
+static nxtprime_pfact100 = pfact(100)/nxtprime_pfact10;
+static nxtprime_pfact1000 = pfact(1000)/nxtprime_pfact100;
+
+
+/*
+ * a55rand - additive 55 pseudo-random number generator
+ *
+ * returns:
+ *     A number in the half open interval [0,2^64)
+ *
+ * This function implements the additive 55 pseudo-random number generator.
+ *
+ * This is a generator based on the additive 55 generator as described in
+ * Knuth's "The Art of Computer Programming - Seminumerical Algorithms",
+ * vol 2, 2nd edition (1981), Section 3.2.2, page 27, Algorithm A.
+ *
+ * This function is called from the shuffle generator function shufrand().
+ *
+ * NOTE: This is NOT Blum's method.  This is used by Blum's method to
+ *       generate some internal values.
+ *
+ * NOTE: If you need a fast generator and do not need a crypto strong one,
+ *       you should consider using the shuffle generator (see shufrand()
+ *      and rand()).  Direct use of this function is not recommended.
+ */
+define
+a55rand()
+{
+    local ret;                 /* the pseudo-random number to return */
+
+    /* generate the next value using the additive 55 generator method */
+    ret = add55_tbl[add55_k] + add55_tbl[add55_j];
+    ret &= cry_mask;
+    add55_tbl[add55_k] = ret;
+
+    /* post-process out data with the seed */
+    ret = xor(ret, add55_seed64);
+
+    /* step the pointers */
+    --add55_j;
+    if (add55_j < 0) {
+       add55_j = 54;
+    }
+    --add55_k;
+    if (add55_k < 0) {
+       add55_k = 54;
+    }
+
+    /* return the new pseudo-random number */
+    return(ret);
+}
+
+
+/*
+ * sa55rand - initialize the additive 55 pseudo-random generator
+ *
+ * given:
+ *     seed
+ *
+ * returns:
+ *     old_seed
+ *
+ * This function seeds the additive 55 pseudo-random generator.
+ *
+ * This is a generator based on the additive 55 generator as described in
+ * Knuth's "The Art of Computer Programming - Seminumerical Algorithms",
+ * vol 2, 2nd edition (1981), Section 3.2.2, page 27, Algorithm A.
+ *
+ * Unlike Knuth's description, we will let a seed post process our data.
+ *
+ * We do not apply the seed processing to the additive 55 table
+ * data as this would disturb its pseudo-random generator properties.
+ * Instead, we xor the output with the low 64 bits of seed.
+ *
+ * If seed == 0:
+ *
+ *    This function produces values in exactly the same way
+ *    described by Knuth.
+ *
+ * else seed > 0:
+ *
+ *    Each value produced is xor-ed by a 64 bit value.  This value
+ *    is the result of randreseed64(rand), which produces a 64
+ *    bit value.
+ *
+ * else seed == -1:
+ *
+ *    This is a reserved seed for sshufrand(0) and srand(0).  One should
+ *    not directly call srand(-1).
+ *
+ * else:
+ *
+ *    Reserved for future use.
+ *
+ * Anyone comfortable with seed == 0 should also be comfortable with
+ * non-zero seeds.  A non-zero seeded sequence will produce a values
+ * that have the exact same pseudo-random properties as the algorithm
+ * described by Knuth.  I.e., the sequence, while different, is as good
+ * (or bad) as the sequence produced by a seed of 0.
+ *
+ * This function updates both the cry_seed and a55_seed64 global values.
+ *
+ * This function is called from the shuffle generator seed function sshufrand().
+ *
+ * NOTE: This is NOT Blum's method.  This is used by Blum's method to
+ *       generate some internal values.
+ *
+ * NOTE: If you need a fast generator and do not need a crypto strong one,
+ *       you should consider using the shuffle generator (see sshufrand()
+ *      and srand()).  Direct use of this function is not recommended.
+ */
+define
+sa55rand(seed)
+{
+    local oldseed;             /* previous seed */
+    local junk;                        /* discards the first few numbers */
+    local j;
+
+    /* firewall */
+    if (!isint(seed)) {
+       quit "bad arg: arg must be an integer";
+    }
+    if (seed < -1) {
+       quit "bad arg: seed < 0 is reserved for future use";
+    }
+
+    /* misc table setup */
+    oldseed = cry_seed;                                /* remember the previous seed */
+    cry_seed = seed;                           /* save the new seed */
+    if (cry_seed == -1) {
+       /* since -1 was a special case, pretend it really was zero */
+       cry_seed = 0;
+    }
+    add55_tbl = add55_init_tbl;        /* reload the table */
+    add55_j = 23;               /* reset first walking table pointer */
+    add55_k = 54;               /* reset second walking table pointer */
+
+    /* obtain our 64 bit xor seed */
+    add55_seed64 = randreseed64(cry_seed);
+
+    /* spin the pseudo-random number generator a while */
+    if (seed == 0) {
+       /* we will act as if sshufrand(0) or srand(0) had been called */
+       for (j=0; j < 513; ++j) {
+           junk = a55rand();
+       }
+    } else {
+       for (j=0; j < 128; ++j) {
+           junk = a55rand();
+       }
+    }
+
+    /* return the old seed */
+    return(oldseed);
+}
+
+
+/*
+ * shufrand - implement the shuffle pseudo-random number generator
+ *
+ * returns:
+ *     A number in the half open interval [0,2^64)
+ *
+ * This function implements the shuffle number generator.
+ *
+ * This is a generator based on the shuffle generator as described in
+ * Knuth's "The Art of Computer Programming - Seminumerical Algorithms",
+ * vol 2, 2nd edition (1981), Section 3.2.2, page 32, Algorithm B.
+ *
+ * The function rand() calls this function.
+ *
+ * NOTE: This is NOT Blum's method.  This is used by Blum's method to
+ *       generate some internal values.
+ *
+ * NOTE: If you do not need a crypto strong pseudo-random generator,
+ *      this function may very well serve your needs.
+ */
+define
+shufrand()
+{
+    local j;           /* table index to replace */
+
+    /*
+     * obtain a new random value
+     * determine the table entry to shuffle
+     * shuffle out the value we will return
+     */
+    shuf_y = shuf_tbl[j = (shuf_y >> shuf_shift)];
+
+    /* shuffle in the new random value */
+    shuf_tbl[j] = a55rand();
+
+    /* return the shuffled out value */
+    return (shuf_y);
+}
+
+
+/*
+ * sshufrand - seed the shuffle pseudo-random generator
+ *
+ * given:
+ *     a seed
+ *
+ * returns:
+ *     the previous seed
+ *
+ * This function implements the shuffle number generator.
+ *
+ * This is a generator based on the shuffle generator as described in
+ * Knuth's "The Art of Computer Programming - Seminumerical Algorithms",
+ * vol 2, 2nd edition (1981), Section 3.2.2, page 32, Algorithm B.
+ *
+ * The low 64 bits of seed are used by the additive 55 generator.
+ * See the sa55rand() function for details.  The remaining bits of seed
+ * are used to perform an initial shuffle on the shuffle state table.
+ * The size of the seed also determines the size of the shuffle table.
+ *
+ * The shuffle table size is always a power of 2, and is at least 128
+ * entries long.  Let the table size be:
+ *
+ *     shuf_size = 2^shuf_pow
+ *
+ * The number of ways one could shuffle that table is:
+ *
+ *     (2^shuf_pow)!
+ *
+ * We select the smallest 'shuf_pow' (and thus the size of the shuffle table)
+ * such that the following are true:
+ *
+ *     (2^shuf_pow)! >= (seed / 2^64)    and    2^shuf_pow >= 128
+ *
+ * Given that we now have the table size of 'shuf_size', we must go about
+ * loading the table and shuffling it.
+ *
+ * Loading is easy, we will generate random values via the additive 55
+ * generator (a55rand()) and load them into successive entries.
+ *
+ * We enumerate the (2^shuf_pow)! values via:
+ *
+ *     shuf_seed = 2*(U[2] + 3*(U[3] + 4*(U[4] + ...
+ *                       + (U[shuf_pow-1]*(shuf_pow-1)) ... )))
+ *     0 <= U[j] < j
+ *
+ * We swap the swap table entries shuf_tbl[U[j]] & shuf_tbl[j-1] for all
+ * 1 < j < shuf_pow.
+ *
+ * We will convert 'seed / 2^64' into shuf_seed, by applying the 64 bit
+ * scramble function on 64 bit chunks of 'seed / 2^64'.
+ *
+ * The function srand() calls this function.
+ *
+ * There is no limit on the size of a seed.  On the other hand,
+ * extremely large seeds require large tables and long seed times.
+ * Using a seed in the range of [2^64, 2^64 * 128!) should be
+ * sufficient for most purposes.  An easy way to stay within this
+ * range to to use seeds that are between 21 and 215 digits long, or
+ * 64 to 780 bits long.
+ *
+ * NOTE: This is NOT Blum's method.  This is used by Blum's method to
+ *       generate some internal values.
+ *
+ * NOTE: If you do not need a crypto strong pseudo-random generator,
+ *      this function may very well serve your needs.
+ */
+define
+sshufrand(seed)
+{
+    local shuf_pow;            /* power of two - log2(shuf_size) */
+    local shuf_seed;           /* seed bits beyond low 64 bits */
+    local oldseed;             /* previous seed */
+    local shift;               /* shift factor to access 64 bit chunks */
+    local swap_indx;           /* what to swap shuf_tbl[0] with */
+    local rval;                        /* random value form additive 55 generator */
+    local j;
+
+    /* firewall */
+    if (!isint(seed)) {
+       quit "bad arg: seed must be an integer";
+    }
+    if (seed < 0) {
+       quit "bad arg: seed < 0 is reserved for future use";
+    }
+
+    /*
+     * seed the additive 55 generator
+     */
+    if (seed == 0) {
+       /* allow sshufrand(0) and srand(0) to arrive at the same state */
+       oldseed = sa55rand(-1);
+    } else {
+       oldseed = sa55rand(seed);
+    }
+
+    /*
+     * form the shuffle table size and constants
+     */
+    shuf_seed = seed >> 64;
+    for (shuf_pow = 7; shuf_seed > (j=fact(1<<(shuf_pow))) && shuf_pow < 64; \
+        ++shuf_pow) {
+    }
+    shuf_size = (1 << shuf_pow);
+    shuf_shift = 64 - shuf_pow;
+    /* reallocate the shuffle table */
+    mat shuf_tbl[shuf_size];
+
+    /*
+     * scramble the seed above the low 64 bits
+     */
+    if (shuf_seed > 0) {
+       j = 0;
+       for (shift=0; shift < highbit(shuf_seed)+1; shift += 64) {
+           j |= (randreseed64(shuf_seed >> shift) << shift);
+       }
+       shuf_seed = j;
+    }
+
+    /*
+     * load the shuffle table
+     */
+    for (j=0; j < shuf_size; ++j) {
+       shuf_tbl[j] = a55rand();
+    }
+    shuf_y = a55rand();                /* get the next Y value */
+
+    /*
+     * We will shuffle based the process outlined in:
+     *
+     * Knuth's "The Art of Computer Programming - Seminumerical Algorithms",
+     * vol 2, 2nd edition (1981), Section 3.4.2, page 139, Algorithm P.
+     *
+     * Here, we will let j run over the range [0,shuf_size) instead of
+     * [shuf_size,0) as outlined in algorithm P.  We will also generate
+     * U values from shuf_seed.
+     */
+    j = 0;
+    while (shuf_seed > 0 && ++j < shuf_size) {
+
+       /* determine what index we will swap with the '0' index */
+       quomod(shuf_seed, (j+1), shuf_seed, swap_indx);
+
+       /* swap table entries, if needed */
+       if (swap_indx != j) {
+           swap(shuf_tbl[j], shuf_tbl[swap_indx]);
+       }
+    }
+
+    /*
+     * run the generator for twice the table size
+     */
+    for (j=0; j < shuf_size*2; ++j) {
+       rval = shufrand();
+    }
+
+    /* return the old seed */
+    return (oldseed);
+}
+
+
+/*
+ * rand - generate a pseudo-random value over a given range via additive 55
+ *
+ * usage:
+ *     rand()          - generate a pseudo-random integer >=0 and < 2^64
+ *     rand(a)         - generate a pseudo-random integer >=0 and < a
+ *     rand(a,b)       - generate a pseudo-random integer >=a and <= b
+ *
+ * returns:
+ *     a large pseudo-random integer over a give range (see usage)
+ *
+ * When no arguments are given, a pseudo-random number in the half open
+ * interval [0,2^64) is produced.  This form is identical to calling
+ * shufrand().
+ *
+ * When 1 argument is given, a pseudo-random number in the half open interval
+ * [0,a) is produced.
+ *
+ * When 2 arguments are given, a pseudo-random number in the closed interval
+ * [a,b] is produced.
+ *
+ * The input values a and b, if given, must be integers.
+ *
+ * This generator is simply a different interface to the shuffle generator.
+ * calling shufrand(), or seeding via sshufrand() will affect the output
+ * of this function.
+ *
+ * NOTE: Unlike cryrand(), this function does not preserve unused bits for
+ *      use by the next function call.
+ *
+ * NOTE: The Un*x rand() function returns only 16 bit or 31 bits, while we
+ *      return a number of any given size (default is 64 bits).
+ *
+ * NOTE: This is NOT Blum's method.  This is used by Blum's method to
+ *       generate some internal values.
+ *
+ * NOTE: If you do not need a crypto strong pseudo-random generator
+ *      this function may very well serve your needs.
+ */
+define
+rand(a,b)
+{
+    local range;               /* we must generate [0,range) first */
+    local offset;              /* what to add to get a adjusted range */
+    local ret;                 /* pseudo-random value */
+    local fullwords;           /* number of full 64 bit chunks in ret */
+    local finalmask;           /* mask of bits in final chunk of range */
+    local j;
+
+    /*
+     * setup and special cases
+     */
+    /* deal with the rand() case */
+    if (isnull(a) && isnull(b)) {
+       /* no args means same range as additive 55 generator */
+       return(a55rand());
+    }
+    /* firewall - args, if given must be in integers */
+    if (!isint(a) || (!isnull(b) && !isint(b))) {
+       quit "bad args: args, if given, must be integers";
+    }
+    /* convert rand(x) into rand(0,x-1) */
+    if (isnull(b)) {
+       /* convert call into a closed interval */
+       b = a-1;
+       a = 0;
+       /* firewall - rand(0) should act like rand(0,0) */
+       if (b == -1) {
+           return(0);
+       }
+    }
+    /* determine the range and offset */
+    if (a >= b) {
+       /* deal with the case of rand(a,a) */
+       if (a == b) {
+           /* not very random, but it is true! */
+           return(a);
+       }
+       range = a-b+1;
+       offset = b;
+    } else {
+       /* convert rand(a,b), where a < b into rand(b,a) */
+       range = b-a+1;
+       offset = a;
+    }
+    /*
+     * At this point, we seek a pseudo-random number [0,range) to which
+     * we will add offset to produce a number [offset,range+offset).
+     */
+    fullwords = highbit(range-1)//64;
+    finalmask = (1 << (1+(highbit(range-1)%64)))-1;
+
+    /*
+     * loop until we get a value that is in range
+     *
+     * A note in modulus biasing:
+     *
+     * We will not fall into the trap of thinking that we can simply take
+     * a value mod 'range'.  Consider the case where 'range' is '80'
+     * and we are given pseudo-random numbers [0,100).  If we took them
+     * mod 80, then the numbers [0,20) would be produced more frequently
+     * because the numbers [81,100) mod 80 wrap back into [0,20).
+     */
+    do {
+       /* load up all lower full 64 bit chunks with pseudo-random bits */
+       ret = 0;
+       for (j=0; j < fullwords; ++j) {
+           ret = ((ret << 64) | shufrand());
+       }
+
+       /* load the highest chunk */
+       ret <<= (highbit(finalmask)+1);
+       ret |= (shufrand() >> (64-highbit(finalmask)-1));
+    } while (ret >= range);
+
+    /*
+     * return the adjusted range value
+     */
+    return(ret+offset);
+}
+
+
+/*
+ * srand - seed the pseudo-random additive 55 generator
+ *
+ * input:
+ *     seed
+ *
+ * returns:
+ *     old_seed
+ *
+ * This function actually seeds the shuffle generator (and indirectly
+ * the additive 55 generator used by rand() and a55rand().
+ *
+ * See sshufrand() and sa55rand() for information about a seed.
+ *
+ * There is no limit on the size of a seed.  On the other hand,
+ * extremely large seeds require large tables and long seed times.
+ * Using a seed in the range of [2^64, 2^64 * 128!) should be
+ * sufficient for most purposes.  An easy way to stay within this
+ * range to to use seeds that are between 21 and 215 digits long, or
+ * 64 to 780 bits long.
+ *
+ * NOTE: This is NOT Blum's method.  This is used by Blum's method to
+ *       generate some internal values.
+ *
+ * NOTE: If you do not need a crypto strong pseudo-random generator
+ *      this function may very well serve your needs.
+ */
+define
+srand(seed)
+{
+    if (!isint(seed)) {
+       quit "bad arg: seed must be an integer";
+    }
+    if (seed < 0) {
+       quit "bad arg: seed < 0 is reserved for future use";
+    }
+    return(sshufrand(seed));
+}
+
+
+/*
+ * cryrand - cryptographically strong pseudo-random number generator
+ *
+ * usage:
+ *     cryrand(len)
+ *
+ * given:
+ *     len         number of pseudo-random bits to generate
+ *
+ * returns:
+ *     a cryptographically strong pseudo-random number of len bits
+ *
+ * Internally, bits are produced log2(log2(n=p*q)) at a time.  If a
+ * call to this function does not exhaust all of the collected bits,
+ * the unused bits will be saved away and used at a later call.
+ * Setting the seed via scryrand() or srandom() will clear out all
+ * unused bits.  Thus:
+ *
+ *     scryrand(0);                    <-- restore generator to initial state
+ *     cryrand(16);                    <-- 16 bits
+ *
+ * will produce the same value as:
+ *
+ *     scryrand(0);                    <-- restore generator to initial state
+ *     cryrand(4)<<12 | cryrand(12);   <-- 4+12 = 16 bits
+ *
+ * and will produce the same value as:
+ *
+ *     scryrand(0);                    <-- restore generator to initial state
+ *     cryrand(3)<<13 | cryrand(7)<<6 | cryrand(6);    <-- 3+7+6 = 16 bits
+ *
+ * The crypto generator is not as fast as most generators, though it is not
+ * painfully slow either.
+ *
+ * NOTE: This function is the Blum cryptographically strong
+ *      pseudo-random number generator.
+ */
+define
+cryrand(len)
+{
+    local goodbits;    /* the number of good bits generated each pass */
+    local goodmask;    /* mask for the low order good bits */
+    local randval;     /* pseudo-random value being generated */
+
+    /*
+     * firewall
+     */
+    if (!isint(len) || len < 1) {
+       quit "bad arg: len must be an integer > 0";
+    }
+
+    /*
+     * Determine how many bits may be generated each pass.
+     *
+     * The result by Alexi et. al., says that the log2(log2(n=p*q))
+     * least significant bits are secure, where log2(x) is log base 2.
+     */
+    goodbits = highbit(highbit(cryrand_n));
+    goodmask = (1 << goodbits)-1;
+
+    /*
+     * If we have bits left over from the previous call, collect
+     * them now.
+     */
+    if (cryrand_bitcnt > 0) {
+
+       /* case where the left over bits are enough for this call */
+       if (len <= cryrand_bitcnt) {
+
+           /* we need only len bits */
+           randval = (cryrand_left >> (cryrand_bitcnt-len));
+
+           /* save the unused bits for later use */
+           cryrand_left &= ((1 << (cryrand_bitcnt-len))-1);
+
+           /* save away the number of bits that we will not use */
+           cryrand_bitcnt -= len;
+
+           /* return our complete result */
+           return(randval);
+
+       /* case where we need more than just the left over bits */
+       } else {
+
+           /* clear out the number of left over bits */
+           len -= cryrand_bitcnt;
+           cryrand_bitcnt = 0;
+
+           /* collect all of the left over bits for now */
+           randval = cryrand_left;
+       }
+
+    /* case where we have no previously left over bits */
+    } else {
+       randval = 0;
+    }
+
+    /*
+     * Pump out len cryptographically strong pseudo-random bits,
+     * 'goodbits' at a time using Blum's process.
+     */
+    while (len >= goodbits) {
+
+       /* generate the bits */
+       cryrand_exp = (cryrand_exp^2) % cryrand_n;
+       randval <<= goodbits;
+       randval |= (cryrand_exp & goodmask);
+
+       /* reduce the need count */
+       len -= goodbits;
+    }
+
+    /* if needed, save the unused bits for later use */
+    if (len > 0) {
+
+       /* generate the bits */
+       cryrand_exp = (cryrand_exp^2) % cryrand_n;
+       randval <<= len;
+       randval |= ((cryrand_exp&goodmask) >> (goodbits-len));
+
+       /* save away the number of bits that we will not use */
+       cryrand_left = cryrand_exp & ((1 << (goodbits-len))-1);
+       cryrand_bitcnt = goodbits-len;
+    }
+
+    /*
+     * return our pseudo-random bits
+     */
+     return(randval);
+}
+
+
+/*
+ * scryrand - seed the cryptographically strong pseudo-random number generator
+ *
+ * usage:
+ *     scryrand(seed)
+ *     scryrand()
+ *     scryrand(seed,len1,len2)
+ *     scryrand(seed,ip,iq,ir)
+ *
+ * input:
+ *     [seed           pseudo-random seed
+ *     [len1 len2]     minimum bit length of the Blum primes 'p' and 'q'
+ *                     -1 => default lengths
+ *     [ip iq ir]      Initial search values for Blum primes 'p', 'q' and
+ *                     a quadratic residue 'r'
+ *
+ * returns:
+ *     the previous seed
+ *
+ *
+ * This function will seed and setup the generator needed to produce
+ * cryptographically strong pseudo-random numbers.  See the function
+ * a55rand() and sshufrand() for information about how 'seed' works.
+ *
+ * The first form of this function are fairly fast if the seed is not
+ * excessively large.  The second form is also fairly fast if the internal
+ * primes are not too large.  The third form, can take a long time to call.
+ * (see below)   The fourth form, if the 'seed' arg is not -1, can take
+ * as long as the third form to call.  If the fourth form is called with
+ * a 'seed' arg of -1, then it is fairly fast.
+ *
+ * Calling scryrand() with 1 or 3 args (first and third forms), or
+ * calling srandom(), or calling scryrand() with 4 args with the first
+ * arg >0, will leave the shuffle generator in a seeded state as if
+ * sshufrand(seed) has been called.
+ *
+ * Calling scryrand() with no args will not seed the shuffle generator,
+ * before or afterwards, however the shuffle generator will have been
+ * changed as a side effect of that call.
+ *
+ * Calling scryrand() with 4 args where the first arg is 0 or '-1'
+ * will not change the other generators.
+ *
+ *
+ * First form of call:  scryrand(seed)
+ *
+ * The first form of this function will seed the shuffle generator
+ * (via srand).  The default precomputed constants will be used.
+ *
+ *
+ * Second form of call:  scryrand()
+ *
+ * Only a new quadratic residue of n=p*q is recomputed.  The previous prime
+ * values are kept.
+ *
+ * Unlike the first and second forms of this function, the shuffle
+ * generator function is not seeded before or after the call.  The
+ * current state is used to generate a new quadratic residue of n=p*q.
+ *
+ *
+ * Third form of call:  scryrand(seed,len1,len2)
+ *
+ * In the third form, 'len1' and 'len2' guide this function in selecting
+ * internally used prime numbers.  The larger the lengths, the longer
+ * the time this function will take.  The impact on execution time of
+ * cryrand() and random() may also be noticed, but not as much.
+ *
+ * If a length is '-1', then the default lengths (248 for len1, and 264
+ * for len2) are used.  The call scryrand(0,-1,-1) recreates the initial
+ * crypto state the slow and hard way.  (use scryrand(0) or srandom(0))
+ *
+ * This function can take a long time to call given reasonable values
+ * of len1 and len2.  On an R3000, the time to seed was:
+ *
+ *     Approx value    digits   seed time
+ *      of len1+len2   in n=p*q           in sec
+ *     ------------   --------    ------
+ *           8            3         0.53
+ *          16            5         0.54
+ *          32           10         0.79
+ *          64           20         1.17
+ *         128           39         2.89
+ *         200           61         4.68
+ *         256           78         7.49
+ *         322          100        12.47
+ *         464          140        35.56
+ *         512          155        53.57
+ *         664          200        83.97
+ *         830          250       122.93
+ *         996          300       242.49
+ *        1024          309       295.66
+ *        1328          400       663.44
+ *        1586          478      2002.10
+ *        1660          500      1643.45  (Faster mult/square methods kick in
+ *        1992          600      2885.81   in certain cases. Type  help config
+ *        2048          617      1578.06   in calc for more details.)
+ *
+ *      NOTE: The small lengths above are given for comparison
+ *            purposes and are NOT recommended for actual use.
+ *
+ *      NOTE: Generating crypto pseudo-random numbers is MUCH
+ *            faster than seeding a crypto generator.
+ *
+ *      NOTE: This calc lib file is intended for demonstration
+ *            purposes.  Writing a C program (with possible assembly
+ *            or libmp assist) would produce a faster generator.
+ *
+ *
+ * Fourth form of call:  scryrand(seed,ip,iq,ir)
+ *
+ * In the fourth form, 'ip', 'iq' and 'ir' serve as initial search
+ * values for the two Blum primes 'p' and 'q' and an associated
+ * quadratic residue 'r' respectively.  Unlike the 3rd form, where
+ * lengths are given, the fourth form allows one to specify minimum
+ * search values.
+ *
+ * The 'seed' value is interpreted as follows:
+ *
+ *   If seed > 0:
+ *
+ *     Seed and use the shuffle generator to generate 3 jump values
+ *     that are in the range '[0,ip)', '[0,iq)' and '[0,ir)' respectively.
+ *     Start searching for legal 'p', 'q' and 'r' values by adding
+ *     the jump values to their respective argument values.
+ *
+ *   If seed == 0:
+ *
+ *     Start searching for legal 'p', 'q' and 'r' values from
+ *     'ip', 'iq' and 'ir' respectively.
+ *
+ *     This form does not change/seed the other generators.
+ *
+ *   If seed == -1:
+ *
+ *     Let 'p' == 'ip', 'q' == 'iq' and 'r' == 'ir'.  Do not check
+ *     if the value given are legal Blum primes or an associated
+ *     quadratic residue respectively.
+ *
+ *     This form does not change/seed the other generators.
+ *
+ *     WARNING: No checks are performed on the args passed.
+ *              Passing improper values will likely produce
+ *              poor results, or worse!
+ *
+ *
+ * It should be noted that calling scryrand() while using the default
+ * primes took only 0.04 seconds.  Calling scryrand(0,-1,-1) took
+ * 47.19 seconds.
+ *
+ * The paranoid, when giving explicit lengths, should keep in mind that
+ * len1 and len2 are the largest powers of 2 that are less than the two
+ * probable primes ('p' and 'q').  These two primes  will be used
+ * internally to cryrand().  For simplicity, we refer to len1 and len2
+ * as bit lengths, even though they are actually 1 less then the
+ * minimum possible prime length.
+ *
+ * The actual lengths may exceed the lengths by slightly more than 3%.
+ * Furthermore, part of the strength of this generator rests on the
+ * difficultly to factor 'p*q'.  Thus one should select 'len1' and 'len2'
+ * (from which 'p' and 'q' are selected) such that factoring a 'len1+len2'
+ * bit number is difficult.
+ *
+ * Not being able to factor 'n=p*q' into 'p' and 'q' does not directly
+ * improve the crypto generator.  On the other hand, it can't hurt.
+ *
+ * There is no limit on the size of a seed.  On the other hand,
+ * extremely large seeds require large tables and long seed times.
+ * Using a seed in the range of [2^64, 2^64 * 128!) should be
+ * sufficient for most purposes.  An easy way to stay within this
+ * range to to use seeds that are between 21 and 215 digits long, or
+ * 64 to 780 bits long.
+ *
+ * NOTE: This function will clear any internally buffer bits.  See
+ *      cryrand() for details.
+ *
+ * NOTE: This function seeds the Blum cryptographically strong
+ *      pseudo-random number generator.
+ */
+define
+scryrand(seed,len1,len2,arg4)
+{
+    local rval;                /* a temporary pseudo-random value */
+    local oldseed;     /* the previous seed */
+    local newres;      /* the new quad res */
+    local ip;          /* initial Blum prime 'p' search value */
+    local iq;          /* initial Blum prime 'q' search value */
+    local ir;          /* initial quadratic residue search value */
+    local sqir;                /* square of ir mod n */
+    local minres;      /* minimum residue allowed */
+    local maxres;      /* maximum residue allowed */
+
+    /*
+     * firewall - avoid bogus args and very trivial lengths
+     */
+    /* catch the case of no args - compute a different quadratic residue */
+    if (isnull(seed) && isnull(len1) && isnull(len2)) {
+
+       /* generate the next quadratic residue */
+       do {
+           newres = cryres(cryrand_n);
+       } while (newres == cryrand_r);
+       cryrand_r = newres;
+       cryrand_exp = cryrand_r;
+
+       /* clear the internal bits */
+       cryrand_left = 0;
+       cryrand_bitcnt = 0;
+
+       /* return the current seed early */
+       return (cry_seed);
+    }
+    if (!isint(seed)) {
+       quit "bad arg: seed arg (1st) must be an integer";
+    }
+    if (param(0) == 4) {
+       if (seed < -1) {
+           quit "bad arg: with 4 args: a seed < -1 is reserved for future use";
+       }
+    } else if (param(0) > 0 && seed < 0) {
+       quit "bad arg: a seed arg (1st) < 0 is reserved for future use";
+    }
+
+    /*
+     * 4 arg case: select or search for 'p', 'q' and 'r' from given values
+     */
+    if (param(0) == 4) {
+
+       /* set initial values */
+       ip = len1;
+       iq = len2;
+       ir = arg4;
+
+       /*
+        * Unless prohibited by a seed of -1, force minimum values on
+        * 'ip', 'iq' and 'ir'.
+        */
+       if (seed >= 0) {
+           /*
+            * Due to the initial quadratic residue selection process,
+            * the smallest Blum prime that is usable is 19.  This
+            * in turn implies that the smallest 'n' is 19*19 = 361.
+            * This in turn imples that the smallest initial residue
+            * that is possible is 128 (for the value 'n = 23*23 = 529).
+            */
+           if (!isint(ip) || ip < 19) {
+              ip = 19;
+           }
+           if (!isint(iq) || iq < 19) {
+              iq = 19;
+           }
+           if (!isint(ir) || ir < 128) {
+              ir = 128;
+           }
+       }
+
+       /*
+        * Determine our prime search points
+        *
+        * Unless we have a seed <= 0, we will add a random 64 bit
+        * value to the initial search points.
+        */
+       if (seed > 0) {
+           /* add in a random value */
+           oldseed = srand(seed);
+           ip += rand(ip);
+           iq += rand(iq);
+       }
+
+       /*
+        * force ip <= iq
+        */
+       if (ip > iq) {
+           swap(ip, iq);
+       }
+
+       /*
+        * find the first Blum prime 'p'
+        */
+       if (seed >= 0) {
+           cryrand_p = nxtprime(ip,3,4);
+       } else {
+           /* seed == -1: assume 'ip' is a Blum prime */
+           cryrand_p = ip;
+       }
+
+       /*
+        * find the 2nd Blum prime 'q' > 'p', if needed
+        */
+       if (seed >= 0) {
+           if (iq <= cryrand_p) {
+               iq = cryrand_p + 2;
+           }
+           cryrand_q = nxtprime(iq,3,4);
+       } else {
+           /* seed == -1: assume 'iq' is a Blum prime */
+           cryrand_q = iq;
+       }
+
+       /* remember our p*q Blum prime product as well */
+       cryrand_n = cryrand_p*cryrand_q;
+
+       /*
+        * search for a quadratic residue
+        */
+       if (seed >= 0) {
+
+           /* 
+            * add in a random value to 'ir' if seeded 
+            *
+            * Unless we have a seed <= 0, we will add a random 64 bit
+            * value to the initial search point.
+            */
+           if (seed > 0) {
+               ir += rand(ir);
+           }
+
+           /*
+            * increment until we find a quadratic value
+            *
+            * p is prime and J(r,p) == 1  ==>  r is a quadratic residue of p
+            * q is prime and J(q,p) == 1  ==>  r is a quadratic residue of q
+            *
+            * J(r,p)*J(r,q) == J(r,p*q)
+            * J(r,p) and J(q,p) == 1      ==>  J(r,p*q) == 1
+            * J(r,p*q) == 1               ==>  r is a quadratic residue of p*q
+            *
+            * We could simply compute the square of a value mod n like
+            * we do in cryres(), but here we want to climb a little higher 
+            * than the ir value given.  We will start sequentially searching
+            * values starting at the initial search point 'ir', while at
+            * same time confining our search to the interval [2^sqrpow,n-100],
+            * where 2^sqrpow is the smallest power of 2 >= n^(3/4).  This
+            * range helps us avoid selecting trivial residues.
+            *
+            * We will also reject any quadratic residue whose square mod n 
+            * is outside of the [2^sqrpow,n-100] range, or whose square mod n 
+            * is within 100 of itself.
+            */
+           minres = 2^(highbit(floor(power(cryrand_n,0.75)))+1);
+           maxres = cryrand_n - 100;
+           --ir;
+           do {
+               /* consdier the next residue that is in the allowed range */
+               ++ir;
+               if (ir < minres || ir > maxres) {
+                   ir = minres;
+               }
+               sqir = pmod(ir, 2, cryrand_n);
+           } while (jacobi(ir,cryrand_p) != 1 ||               \
+                    jacobi(ir,cryrand_q) != 1 ||               \
+                    sqir < minres || sqir > maxres ||          \
+                    abs(sqir-ir) <= 100);
+       }
+       cryrand_r = ir;
+
+       /*
+        * clear the previously unused cryrand bits & other misc setup
+        */
+       cryrand_left = 0;
+       cryrand_bitcnt = 0;
+       cryrand_exp = cryrand_r;
+
+       /*
+        * reseed the generator, if needed
+        *
+        * The crypto generator no longer needs the additive 55 and shuffle
+        * generators.  We however, restore the additive 55 and shuffle
+        * generators back to its seeded state in order to be sure that it
+        * will be left in the same state.
+        *
+        * This will make more reproducible, calls to the additive 55 and
+        * shuffle generator; or more reproducible, calls to this function
+        * without args.
+        */
+       if (seed > 0) {
+           ir = srand(seed);   /* ignore this return value */
+           return(oldseed);
+       } else {
+           /* no seed change, return the current seed */
+           return (cry_seed);
+       }
+    }
+
+    /*
+     * If not the 4 arg case:
+     *
+     * convert explicit -1 args into default values
+     * convert missing args into -1 values (use precomputed tables)
+     */
+    if ((isint(len1) && len1 != -1 && len1 < 5) ||
+       (isint(len2) && len2 != -1 && len2 < 5) ||
+       (!isint(len1) && isint(len2)) ||
+       (isint(len1) && !isint(len2))) {
+       quit "bad args: 2 & 3: if 2nd is given, must be -1 or ints > 4";
+    }
+    if (isint(len1) && len1 == -1) {
+       len1 = 248;     /* default len1 value */
+    }
+    if (isint(len2) && len2 == -1) {
+       len2 = 264;     /* default len2 value */
+    }
+    if (!isint(len1) && !isint(len2)) {
+       /* from here down, -1 means use precomputed values */
+       len1 = -1;
+       len2 = -1;
+    }
+
+    /*
+     * force len1 <= len2
+     */
+    if (len1 > len2) {
+       swap(len1, len2);
+    }
+
+    /*
+     * seed the generator
+     */
+    oldseed = srand(seed);
+
+    /*
+     * generate p and q Blum primes
+     *
+     * The Blum process requires the primes to be of the form 3 mod 4.
+     * We also generate n=p*q for future reference.
+     *
+     * We make sure that the lengths are the minimum lengths possible.
+     * We want some range to select a random prime from, so we
+     * go at least 3 bits higher, and as much as 3% plus 3 bits
+     * higher.  Since the section is a random, how high really
+     * does not matter that much, but we want to avoid going to
+     * an extreme to keep the execution time from getting too long.
+     *
+     * Finally, we generate a quadratic residue of n=p*q.
+     */
+    if (len1 > 0) {
+       /* generate a pseudo-random prime ~len1 bits long */
+       rval = rand(2^(len1-1), 2^((int(len1*1.03))+3));
+       cryrand_p = nxtprime(rval,3,4);
+    } else {
+       /* use precomputed 'p' value */
+       cryrand_p = cryrand_init_p;
+    }
+    if (len2 > 0) {
+       /* generate a pseudo-random prime ~len1 bits long */
+       rval = rand(2^(len2-1), 2^((int(len2*1.03))+3));
+       cryrand_q = nxtprime(rval,3,4);
+    } else {
+       /* use precomputed 'q' value */
+       cryrand_q = cryrand_init_q;
+    }
+
+    /*
+     * find the quadratic residue
+     */
+    cryrand_n = cryrand_p*cryrand_q;
+    if (len1 == 248 && len2 == 264 && seed == 0) {
+       cryrand_r = cryrand_init_r;
+    } else {
+       cryrand_r = cryres(cryrand_n);
+    }
+
+    /*
+     * clear the previously unused cryrand bits & other misc setup
+     */
+    cryrand_left = 0;
+    cryrand_bitcnt = 0;
+    cryrand_exp = cryrand_r;
+
+    /*
+     * reseed the generator
+     *
+     * The crypto generator no longer needs the additive 55 and shuffle
+     * generators.  We however, restore the additive 55 and shuffle
+     * generators back to its seeded state in order to be sure that it
+     * will be left in the same state.
+     *
+     * This will make more reproducible, calls to the additive 55 and
+     * shuffle generator; or more reproducible, calls to this function
+     * without args.
+     */
+    /* we do not care about this old seed */
+    rval = srand(seed);
+
+    /*
+     * return the old seed
+     */
+    return(oldseed);
+}
+
+
+/*
+ * random - a cryptographically strong pseudo-random number generator
+ *
+ * usage:
+ *     random()        - generate a pseudo-random integer >=0 and < 2^64
+ *     random(a)       - generate a pseudo-random integer >=0 and < a
+ *     random(a,b)     - generate a pseudo-random integer >=a and <= b
+ *
+ * returns:
+ *     a large cryptographically strong pseudo-random number  (see usage)
+ *
+ * This function is just another interface to the crypto generator.
+ * (see the cryrand() function).
+ *
+ * When no arguments are given, a pseudo-random number in the half open
+ * interval [0,2^64) is produced.  This form is identical to calling
+ * cryrand(64).
+ *
+ * When 1 argument is given, a pseudo-random number in the half open interval
+ * [0,a) is produced.
+ *
+ * When 2 arguments are given, a pseudo-random number in the closed interval
+ * [a,b] is produced.
+ *
+ * This generator uses the crypto to return a large pseudo-random number.
+ *
+ * The input values a and b, if given, must be integers.
+ *
+ * Internally, bits are produced log2(log2(n=p*q)) at a time.  If a
+ * call to this function does not exhaust all of the collected bits,
+ * the unused bits will be saved away and used at a later call.
+ * Setting the seed via scryrand(), srandom() or cryrand(len,1)
+ * will clear out all unused bits.
+ *
+ * NOTE: The BSD random() function returns only 31 bits, while we return 64.
+ *
+ * NOTE: This function is the Blum cryptographically strong
+ *      pseudo-random number generator.
+ */
+define
+random(a,b)
+{
+    local range;               /* we must generate [0,range) first */
+    local offset;              /* what to add to get a adjusted range */
+    local rangebits;           /* the number of bits in range */
+    local ret;                 /* pseudo-random bit value */
+
+    /*
+     * setup and special cases
+     */
+    /* deal with the rand() case */
+    if (isnull(a) && isnull(b)) {
+       /* no args means return 64 bits */
+       return(cryrand(64));
+    }
+    /* firewall - args, if given must be in integers */
+    if (!isint(a) || (!isnull(b) && !isint(b))) {
+       quit "bad args: args, if given, must be integers";
+    }
+    /* convert rand(x) into rand(0,x-1) */
+    if (isnull(b)) {
+       /* convert call into a closed interval */
+       b = a-1;
+       a = 0;
+       /* firewall - rand(0) should act like rand(0,0) */
+       if (b == -1) {
+           return(0);
+       }
+    }
+    /* determine the range and offset */
+    if (a >= b) {
+       /* deal with the case of rand(a,a) */
+       if (a == b) {
+           /* not very random, but it is true! */
+           return(a);
+       }
+       range = a-b+1;
+       offset = b;
+    } else {
+       /* convert random(a,b), where a<b, into random(b,a) */
+       range = b-a+1;
+       offset = a;
+    }
+    rangebits = highbit(range-1)+1;
+    /*
+     * At this point, we seek a pseudo-random number [0,range) to which
+     * we will add offset to produce a number [offset,range+offset).
+     */
+
+    /*
+     * loop until we get a value that is in range
+     *
+     * We will obtain pseudo-random values over the range [0,2^rangebits)
+     * where 2^rangebits >= range and 2^(rangebits-1) < range.  We
+     * will ignore any results that are > the range that we want.
+     *
+     * A note in modulus biasing:
+     *
+     * We will not fall into the trap of thinking that we can simply take
+     * a value mod 'range'.  Consider the case where 'range' is '80'
+     * and we are given pseudo-random numbers [0,100).  If we took them
+     * mod 80, then the numbers [0,20) would be produced more often
+     * because the numbers [81,100) mod 80 wrap back into [0,20).
+     */
+    do {
+       /* obtain a pseudo-random value */
+       ret = cryrand(rangebits);
+    } while (ret >= range);
+
+    /*
+     * return the adjusted range value
+     */
+    return(ret+offset);
+}
+
+
+/*
+ * srandom - seed the cryptographically strong pseudo-random number generator
+ *
+ * given:
+ *     seed    a random number seed
+ *
+ * returns:
+ *      the previous seed
+ *
+ * This function is just another interface to the crypto generator.
+ * (see the scryrand() function).
+ *
+ * This function makes indirect use of the additive 55 and shuffle
+ * generator.
+ *
+ * There is no limit on the size of a seed.  On the other hand,
+ * extremely large seeds require large tables and long seed times.
+ * Using a seed in the range of [2^64, 2^64 * 128!) should be
+ * sufficient for most purposes.  An easy way to stay within this
+ * range to to use seeds that are between 21 and 215 digits long, or
+ * 64 to 780 bits long.
+ *
+ * NOTE: Calling this function will clear any internally buffer bits.
+ *      See cryrand() for details.
+ *
+ * NOTE: This function seeds the Blum cryptographically strong
+ *      pseudo-random number generator.
+ */
+define
+srandom(seed)
+{
+    if (!isint(seed)) {
+       quit "bad arg: seed must be an integer";
+    }
+    if (seed < 0) {
+       quit "bad arg: seed < 0 is reserved for future use";
+    }
+    return(scryrand(seed));
+}
+
+
+/*
+ * randstate - set/get the state of all of the generators
+ *
+ * usage:
+ *     randstate()     return the current state
+ *     randstate(0)    return the previous state, set the default state
+ *     randstate(cobj) return the previous state, set a new state
+ *
+ * In the first form: randstate()
+ *
+ *     This function returns an cryobj object containing information
+ *     about the current state of all of the generators.
+ *
+ * In the second form: randstate(0)
+ *
+ *     This function sets all of the generators to the default initial
+ *     state (i.e., the state when this library was loaded).
+ *
+ *     This function returns an cryobj object containing information
+ *     about the previous state of all of the generators.
+ *
+ * In the third form: randstate(cobj)
+ *
+ *     This function sets all of the generators to the state as found
+ *     in the cryobj object.
+ *
+ *     This function returns an cryobj object containing information
+ *     about the previous state of all of the generators.
+ *
+ * This function may be used to save and restore cryrand() & random()
+ * generator states.  For example:
+ *
+ *     state = randstate()             <-- save the current state
+ *     random()                        <-- print the next 64 bits
+ *     randstate(state)                <-- restore previous state
+ *     random()                        <-- print the same 64 bits
+ *
+ * One may quickly reseed a generator.  For example:
+ *
+ *     srandom(1,330,350)              <-- seed the generator
+ *     seed1state = randstate()        <-- remember this 1st seeded state
+ *     random()                        <-- print 1st 64 bits seed 1 generator
+ *     srandom(2,331,351)              <-- seed the generator again
+ *     seed2state = randstate()        <-- remember this 2nd seeded state
+ *     random()                        <-- print 1st 64 bits seed 2 generator
+ *
+ *     randstate(seed1state)           <-- reseed to the 1st seeded state
+ *     random()                        <-- reprint 1st 64 bits seed 1 generator
+ *     randstate(seed2state)           <-- reseed to the 2nd seeded state
+ *     random()                        <-- reprint 1st 64 bits seed 2 generator
+ *
+ *     oldstate = randstate(0)         <-- seed to the default generator
+ *     random()                        <-- print 1st 64 bits from default
+ *     a55rand()                       <-- print 1st 64 bits a55 generator
+ *     prevstate = randstate(oldstate) <-- restore seed 2 generator
+ *     random()                        <-- print 2nd 64 bits seed 2 generator
+ *     randstate(prevstate)            <-- restore def generator in progress
+ *     random()                        <-- print 2nd 64 bits default generator
+ *     a55rand()                       <-- print 2nd 64 bits a55 generator
+ *
+ * given:
+ *     cobj    if a cryobj object, use that object to set the current state
+ *             if 0, set to the default state
+ *
+ * return:
+ *     return the state of the crypto pseudo-random number generator in
+ *            the form of an cryobj object, as it was prior to this call
+ *
+ * NOTE: No checking is performed on the data the 3rd form (cryobj object
+ *      arg) is used.  The user must ensure that the arg represents a valid
+ *      generator state.
+ *
+ * NOTE: When using the second form (passing an integer arg), only 0 is
+ *      defined.  All other integer values are reserved for future use.
+ */
+define
+randstate(arg)
+{
+    /* declare our objects */
+    local obj cryobj x;                /* firewall comparator */
+    local obj cryobj prev;     /* previous states of the generators */
+    local junk;                        /* dummy holder of random values */
+
+    /* firewall */
+    if (!isint(arg) && !istype(arg,x) && !isnull(arg)) {
+       quit "bad arg: argument must be integer, an cryobj object or missing";
+    }
+    if (isint(arg) && arg != 0) {
+       quit "bad arg:  non-zero integer arguments are reserved for future use";
+    }
+
+    /*
+     * save the current state
+     */
+    prev.p = cryrand_p;
+    prev.q = cryrand_q;
+    prev.r = cryrand_r;
+    prev.exp = cryrand_exp;
+    prev.left = cryrand_left;
+    prev.bitcnt = cryrand_bitcnt;
+    prev.a55j = add55_j;
+    prev.a55k = add55_k;
+    prev.seed = cry_seed;
+    prev.shufy = shuf_y;
+    prev.shufsz = shuf_size;
+    prev.shuftbl = shuf_tbl;
+    prev.a55tbl = add55_tbl;
+    if (isnull(x)) {
+       /* if no args, just return current state */
+       return (prev);
+    }
+
+    /*
+     * deal with the cryobj arg - set the state
+     */
+    if (istype(arg, x)) {
+       /* set the state from this object */
+       cryrand_p = arg.p;
+       cryrand_q = arg.q;
+       cryrand_n = cryrand_p*cryrand_q;
+       cryrand_r = arg.r;
+       cryrand_exp = arg.exp;
+       cryrand_left = arg.left;
+       cryrand_bitcnt = arg.bitcnt;
+       add55_j = arg.a55j;
+       add55_k = arg.a55k;
+       cry_seed = arg.seed;
+       add55_seed64 = randreseed64(cry_seed);
+       shuf_y = arg.shufy;
+       shuf_size = arg.shufsz;
+       shuf_shift = (64-highbit(shuf_size));
+       shuf_tbl = arg.shuftbl;
+       add55_tbl = arg.a55tbl;
+
+    /*
+     * deal with the 0 integer arg - set the default initial state
+     */
+    } else if (isint(arg) && arg == 0) {
+       cryrand_p = cryrand_init_p;
+       cryrand_q = cryrand_init_q;
+       cryrand_n = cryrand_p * cryrand_q;
+       cryrand_r = cryrand_init_r;
+       cryrand_exp = cryrand_r;
+       cryrand_left = 0;
+       cryrand_bitcnt = 0;
+       cry_seed = 0;
+       cry_seed = sshufrand(0);
+    }
+
+    /*
+     * return the previous state
+     */
+    return (prev);
+}
+
+
+/*
+ * nxtprime - find a probable prime >= n_arg
+ *
+ * usage:
+ *     nxtprime(n_arg)
+ *     nxtprime(n_arg, modval, modulus)
+ *
+ * given:
+ *     n_arg               lower bound of the search
+ *     [modval modulus]    if given, look for numbers mod modulus == modval
+ *
+ * returns:
+ *     A number is that is very likely prime.
+ *
+ * In the first case 'nxtprime(n_arg)', this function returns a probable
+ * prime >= n_arg.  In the second case 'nxtprime(n_arg, v, u)', this
+ * function returns a probable prime >= n_arg that is also == v mod u.
+ *
+ * This function will not skip over a prime, through there is a
+ * extremely unlikely chance that it will return a composite.
+ * The odds that a number returned by this function is not prime
+ * are 1 in 4^50.  The failure rate of this function is many orders
+ * or magnitude lower than the failure rate due to a hardware error.
+ *
+ * NOTE: This function can take a long time, given a large value of n_arg.
+ */
+define
+nxtprime(n_arg, modval, modulus)
+{
+    local modgcd;              /* gcd(modulus,modval) */
+    local n;                   /* value >= n_arg that is being tested */
+    local j;
+
+    /*
+     * firewall
+     */
+    if (!isint(n_arg)) {
+       quit "bad args: 1st arg must be an integer";
+    }
+    if (!isnull(modulus) && !isint(modval)) {
+       quit "bad args: 3rd arg, if 2nd arg is given, must be an integer";
+    }
+    if (!isnull(modulus) && (!isint(modulus) || modulus <= 0)) {
+       quit "bad args: 3nd arg, if given, must be an integer > 0";
+    }
+
+    /*
+     * get values < 3 out of the way
+     */
+    n = n_arg;
+    if (n < 3) {
+       /* get the even prime out of the way, if possible */
+       if (isnull(modulus) ||
+           modulus == 1 ||
+           (n%modulus == modval%modulus)) {
+           /*
+            * 2 is the greatest odd prime, because
+            * 2 is the least even prime  :-)
+            */
+           return(2);
+       }
+       /* we have eliminated everything < 3 */
+       n = 3;
+    }
+
+    /*
+     * convert nxtprime(n) to nxtprime(n,1,2)
+     * convert nxtprime(n,x,1) to nxtprime(n,1,2)
+     * convert nxtprime(n,a,b) to nxtprime(n,a mod b,b)
+     */
+    if (isnull(modulus) || modulus < 2) {
+       modulus = 2;
+       modval = 1;
+    }
+    modval %= modulus;
+
+    /*
+     * catch cases where no more primes == 'modval' mod 'modulus' exist
+     */
+    modgcd = gcd(modval,modulus);
+    if (modgcd > 1) {
+
+       /* if beyond the modgcd, then no primes can exist */
+        if (n > modgcd) {
+           print "n_arg:",n_arg,"  modval:",modval,"  modulus:",modulus;
+           quit "no such prime of that form exists";
+       }
+
+       /* else n <= modgcd, then our only chance is if modgcd is prime */
+       /* reject if modgcd has an obvious prime factor */
+       if (modgcd > 10 && gcd(modgcd,nxtprime_pfact10) != 1) {
+           print "n_arg:",n_arg,"  modval:",modval,"  modulus:",modulus;
+           quit "no such prime of that form exists";
+       }
+       if (modgcd > 100 && gcd(modgcd,nxtprime_pfact100) != 1) {
+           print "n_arg:",n_arg,"  modval:",modval,"  modulus:",modulus;
+           quit "no such prime of that form exists";
+       }
+       if (modgcd > 1000 && gcd(modgcd,nxtprime_pfact1000) != 1) {
+           print "n_arg:",n_arg,"  modval:",modval,"  modulus:",modulus;
+           quit "no such prime of that form exists";
+       }
+
+       /* do 50 probable prime tests, for a 1 in 4^50 false prime rate */
+       if (!ptest(modgcd,50)) {
+           print "n_arg:",n_arg,"  modval:",modval,"  modulus:",modulus;
+           quit "no such prime of that form exists";
+       }
+
+       /* modgcd is the only prime >= n */
+       return(modgcd);
+    }
+
+    /*
+     * bump n up to the next possible case
+     *
+     * n will be an odd number == 'modval' mod 'modulus'
+     */
+    if (n%modulus != modval) {
+       j = n - (n%modulus) + modval;
+       if (j < n) {
+           n = j+modulus;
+       } else {
+           n = j;
+       }
+    }
+    if (n%2 == 0) {
+       n += modulus;
+    }
+
+    /* look for a prime */
+    n = n-modulus;
+    do {
+       /* try the next integer */
+       n = n+modulus;
+
+       /* reject if it has an obvious prime factor */
+       if (n > 10 && gcd(n,nxtprime_pfact10) != 1) {
+           continue;
+       }
+       if (n > 100 && gcd(n,nxtprime_pfact100) != 1) {
+           continue;
+       }
+       if (n > 1000 && gcd(n,nxtprime_pfact1000) != 1) {
+           continue;
+       }
+
+       /* do 50 probable prime tests */
+       if (!ptest(n,50)) {
+           continue;
+       }
+
+       /* n is very likely a prime number */
+       return(n);
+
+    } while (1);
+}
+
+
+/*
+ * cryobj - how to initialize a cryobj object
+ *
+ * given:
+ *     p               first Blum prime (prime 3 mod 4)
+ *     q               second Blum prime (prime 3 mod 4)
+ *     r               quadratic residue of n=p*q
+ *     exp             used in computing crypto good bits
+ *     left            bits unused from the last cryrand() call
+ *     bitcnt          left contains bitcnt crypto good bits
+ *     a55j            1st additive 55 table pointer
+ *     a55k            2nd additive 55 table pointer
+ *     seed            last seed set by sa55rand() or 0
+ *     shufy           Y (previous a55rand() output for shuffle)
+ *     shufsz          size of the shuffle table
+ *     shuftbl         a matrix of shufsz entries
+ *     a55tbl          additive 55 generator state table
+ *
+ * return:
+ *     an cryobj object
+ *
+ * NOTE: This function, by convention, returns an cryobj object.
+ */
+define
+cryobj(p,q,r,exp,left,bitcnt,a55j,a55k,seed,shufy,shufsz,shuftbl,a55tbl)
+{
+    /* declare our objects */
+    local obj cryobj x;
+
+    /* firewall */
+    if (!isint(p) || !isint(q) || !isint(r) || !isint(exp) || \
+       !isint(left) || !isint(bitcnt) || !isint(a55j) || \
+       !isint(a55k) || !isint(seed) || !isint(shufy) || !isint(shufsz)) {
+       quit "bad args: first 11 args must be integers";
+    }
+    if (!ismat(shuftbl) || matdim(shuftbl) != 1 || \
+       matmin(shuftbl,1) != 0 || matmax(shuftbl,1) != shuf_size-1) {
+       quit "bad arg: 12th is not a mat[0:shuf_size-1]";
+    }
+    if (!ismat(a55tbl) || matdim(a55tbl) != 1 || \
+       matmin(a55tbl,1) != 0 || matmax(a55tbl,1) != 54) {
+       quit "bad arg: 13th is not a mat[0:54]";
+    }
+
+    /* initialize object with default startup values */
+    x.p = p;
+    x.q = q;
+    x.r = r;
+    x.exp = exp;
+    x.left = left;
+    x.bitcnt = bitcnt;
+    x.a55j = a55j;
+    x.a55k = a55k;
+    x.seed = seed;
+    x.shufy = shuf_y;
+    x.shufsz = shuf_size;
+    x.shuftbl = shuf_tbl;
+    x.a55tbl = a55tbl;
+
+    /* return the initialized object */
+    return (x);
+}
+
+
+/*
+ * cmpobj - compare two cryrand objects
+ *
+ * usage:
+ *     a       an cryobj object
+ *     b       an cryobj object
+ *
+ * NOTE: This function is intended for debug purposes.
+ */
+define
+cmpobj(a,b)
+{
+    local obj cryobj x;                /* firewall comparator */
+    local shufsiz;
+    local i;
+
+    /* firewall */
+    if (!istype(a, x)) {
+       quit "bad arg: 1st arg is not an cryobj object";
+    }
+    if (!istype(b, x)) {
+       quit "bad arg: 2nd arg is not an cryobj object";
+    }
+    if (!ismat(a.shuftbl) || matdim(a.shuftbl) != 1 || \
+       matmin(a.shuftbl,1) != 0 || matmax(a.shuftbl,1) != a.shufsz-1) {
+       quit "bad arg: 1st arg is not a mat[0:shuf_size-1]";
+    }
+    if (!ismat(b.shuftbl) || matdim(b.shuftbl) != 1 || \
+       matmin(b.shuftbl,1) != 0 || matmax(b.shuftbl,1) != b.shufsz-1) {
+       quit "bad arg: 2nd arg is not a mat[0:shuf_size-1]";
+    }
+    if (!ismat(a.a55tbl) || matdim(a.a55tbl) != 1 || \
+       matmin(a.a55tbl,1) != 0 || matmax(a.a55tbl,1) != 54) {
+       quit "bad arg: 1st arg is not a mat[0:54]";
+    }
+    if (!ismat(b.a55tbl) || matdim(b.a55tbl) != 1 || \
+       matmin(b.a55tbl,1) != 0 || matmax(b.a55tbl,1) != 54) {
+       quit "bad arg: 2nd arg is not a mat[0:54]";
+    }
+
+    /* compare values */
+    if (a.p != b.p) {
+       print "a.p - b.p:", a.p - b.p;
+    }
+    if (a.q != b.q) {
+       print "a.q - b.q:", a.q - b.q;
+    }
+    if (a.r != b.r) {
+       print "a.r - b.r:", a.r - b.r;
+    }
+    if (a.exp != b.exp) {
+       print "a.exp - b.exp:", a.exp - b.exp;
+    }
+    if (a.left != b.left) {
+       print "a.left - b.left:", a.left - b.left;
+    }
+    if (a.bitcnt != b.bitcnt) {
+       print "a.bitcnt - b.bitcnt:", a.bitcnt - b.bitcnt;
+    }
+    if (a.a55j != b.a55j) {
+       print "a.a55j - b.a55j:", a.a55j - b.a55j;
+    }
+    if (a.a55k != b.a55k) {
+       print "a.a55k - b.a55j:", a.a55k - b.a55k;
+    }
+    if (a.seed != b.seed) {
+       print "a.seed - b.seed:", a.seed - b.seed;
+    }
+    if (a.shufy != b.shufy) {
+       print "a.shufy - b.shufy:", a.shufy - b.shufy;
+    }
+    if (a.shufsz != b.shufsz) {
+       print "a.shufsz - b.shufsz:", a.shufsz - b.shufsz;
+       shufsiz = min(a.shufsz, b.shufsz);
+    } else {
+       shufsiz = a.shufsz;
+    }
+    for (i=0; i < shufsiz; ++i) {
+        if (a.shuftbl[i] != b.shuftbl[i]) {
+           print "a.shuftbl[" : i : "] - b.shuftbl[" : i : "]:", \
+             a.shuftbl[i] - b.shuftbl[i];
+        }
+    }
+    if (a.shufsz > shufsiz) {
+       print "    skipping a.shuftbl[" : shufsiz : ".." : a.shufsz-1 : "]";
+    } else if (b.shufsz > shufsiz) {
+       print "    skipping b.shuftbl[" : shufsiz : ".." : b.shufsz-1 : "]";
+    }
+    for (i=0; i < 55; ++i) {
+        if (a.a55tbl[i] != b.a55tbl[i]) {
+           print "a.a55tbl[" : i : "] - b.a55tbl[" : i : "]:", \
+             a.a55tbl[i] - b.a55tbl[i];
+        }
+    }
+}
+
+
+/*
+ * cryobj_print - print the value of a cryobj object
+ *
+ * usage:
+ *     a       an cryobj object
+ *
+ * NOTE: This function is called automatically when an cryobj object
+ *       is displayed.
+ */
+define
+cryobj_print(a)
+{
+    /* declare our objects */
+    local obj cryobj x;                /* firewall comparator */
+
+    /* firewall */
+    if (!istype(a, x)) {
+       quit "bad arg: arg is not an cryobj object";
+    }
+    if (!ismat(a.shuftbl) || matdim(a.shuftbl) != 1 || \
+       matmin(a.shuftbl,1) != 0 || matmax(a.shuftbl,1) != a.shufsz-1) {
+       quit "bad arg: arg is not a mat[0:shuf_size-1]";
+    }
+    if (!ismat(a.a55tbl) || matdim(a.a55tbl) != 1 || \
+       matmin(a.a55tbl,1) != 0 || matmax(a.a55tbl,1) != 54) {
+       quit "bad arg: arg is not a mat[0:54]";
+    }
+
+    /* print the value */
+    print "cryobj(" : a.p : "," : a.q : "," : a.r : "," : a.exp : "," : \
+         a.left : "," : a.bitcnt : "," : a.a55j : "," : a.a55k : "," : \
+         a.seed : "," : a.shufy : "," : a.shufsz : \
+         ",[" : a.shuftbl[0] : "," : a.shuftbl[1] : "," : \
+         a.shuftbl[2] : ",...," : a.shuftbl[52] : "," : \
+         a.shuftbl[53] : "," : a.shuftbl[54] : "]" : \
+         ",[" : a.a55tbl[0] : "," : a.a55tbl[1] : "," : \
+         a.a55tbl[2] : ",...," : a.a55tbl[52] : "," : \
+         a.a55tbl[53] : "," : a.a55tbl[54] : "])" : ;
+}
+
+
+/*
+ * cryres - find a pseudo-random quadratic residue for scryrand() and cryrand()
+ *
+ * given:
+ *     n       product of two Blum primes
+ *
+ * returns:
+ *     a number that is a quadratic residue of n=p*q
+ *
+ * This function is returns the pseudo-random quadratic residue of
+ * the product of two primes.  Normally this function is called
+ * only by the crypto generator.
+ *
+ * NOTE: No check is made to ensure that the values passed are prime.
+ */
+define
+cryres(n)
+{
+    local quadres;     /* quadratic residue of n */
+    local sqquadres;   /* square of quadres mod n */
+    local minres;      /* minimum residue allowed */
+    local maxres;      /* maximum residue allowed */
+    local j;
+
+    /*
+     * firewall
+     */
+    if (!isint(n)) {
+       quit "bad arg: must an integer";
+    }
+
+    /*
+     * find a pseudo-random quadratic residue of n = p*q
+     *
+     * We will start sequentially searching for quadratic residue
+     * values starting at the initial search point 'ir', while at
+     * same time confining our search to the interval [2^sqrpow,n-100],
+     * where 2^sqrpow is the smallest power of 2 >= n^(3/4).  This
+     * range helps us avoid selecting trivial residues.
+     *
+     * We will also reject any quadratic residue whose square mod n 
+     * is outside of the [2^sqrpow,n-100] range, or whose square mod n 
+     * is within 100 of itself.
+     */
+    minres = 2^(highbit(floor(power(n,0.75)))+1);
+    maxres = n - 100;
+    do {
+       /* form a quadratic residue */
+       quadres = pmod(rand(minres,maxres+1), 2, n);
+       sqquadres = pmod(quadres, 2, n);
+    } while (quadres < minres || quadres > maxres ||           \
+            sqquadres < minres || sqquadres > maxres ||        \
+            abs(sqquadres-quadres) <= 100);
+
+    /*
+     * return the quadratic residue of n
+     */
+    return (quadres);
+}
+
+
+/*
+ * randreseed64 - scramble a 64 bit seed
+ *
+ * given:
+ *     a 64 bit seed
+ *
+ * returns:
+ *     a 64 scrambled seed, or 0 if seed was 0
+ *
+ * It is 'nice' when a seed of "n" produces a 'significantly different'
+ * sequence than a seed of "n+1".  Generators, by convention, assign
+ * special significance to the seed of '0'.  It is an unfortunate that
+ * people often pick small seed values, particularly when large seed
+ * are of significance to the generators found in this file.
+ *
+ * If 'seed' is 0, then 0 is returned.  If 'seed' is non-zero, we will
+ * produce a different and unique new scrambled 'seed'.  This scrambling
+ * will effectively eliminate the human factors and perceptions that
+ * are noted above.
+ *
+ * It should be noted that the purpose of this process to scramble a seed
+ * ONLY.  We do not care if these generators produce good random numbers.
+ * We only want to help eliminate the human factors and perceptions
+ * noted above.
+ *
+ * This function scrambles the low 64 bits of a seed, by mapping [0,2^64)
+ * into [0,2^64).  This map is one-to-one and onto.  Mapping is performed
+ * using  a linear congruence generator of the form:
+ *
+ *             X1 <-- (a*X0 + c) mod m
+ *
+ * The generator are based on the linear congruential generators found in
+ * Knuth's "The Art of Computer Programming - Seminumerical Algorithms",
+ * vol 2, 2nd edition (1981), Section 3.6, pages 170-171.
+ *
+ * Because we process 64 bits we will take:
+ *
+ *             m = 2^64                        (based on note ii)
+ *
+ * We will scan the Rand book of numbers to look for an 'a' such that:
+ *
+ *             a mod 8 == 5                    (based on note iii)
+ *             0.01*m < a < 0.99*m             (based on note iv)
+ *             0.01*2^64 < a < 0.99*2^64
+ *
+ * To help keep the generators independent, we want:
+ *
+ *             a is prime
+ *
+ * The choice of an adder 'c' is considered immaterial according (based
+ * in note v).  Knuth suggests 'c==1' or 'c==a'.  We elect to select 'c'
+ * using the same process as we used to select 'a'.  The choice is
+ * 'immaterial' after all, and as long as:
+ *
+ *             gcd(c, m) == 1          (based on note v)
+ *             gcd(c, 2^64) == 1
+ *
+ * the concerns are met.   It can be shown that if we have:
+ *
+ *             gcd(a, c) == 1
+ *
+ * then the adders and multipliers will be more independent.
+ *
+ * We will obtain the values 'a' and 'c for our generator from the
+ * Rand book of numbers.  Because m=2^64 is 20 decimal digits long, we
+ * will search the Rand book of numbers 20 at a time.  We will skip any
+ * of the 55 values that were used to initialize the additive 55 generators.
+ * The values obtained from the Rand book are:
+ *
+ *             a = 6316878969928993981
+ *             c = 1363042948800878693
+ *
+ * As we stated before, we must map 0 ==> 0.  The linear congruence
+ * generator would normally map as follows:
+ *
+ *     0 ==> 1363042948800878693       (0 ==> c)
+ *
+ * To determine which value maps back into 0, we compute:
+ *
+ *     (-c*minv(a,m)) % m
+ *
+ * and thus we find that the congruence generator would also normally map:
+ *
+ *     10239951819489363767 ==> 0
+ *
+ * To overcome this, and preserve the 1-to-1 and onto map, we force:
+ *
+ *     0 ==> 0
+ *     10239951819489363767 ==> 1363042948800878693
+ *
+ * To repeat, this function converts a values into a seed value.  With the
+ * except of 'seed == 0', every value is mapped into a unique seed value.
+ * This mapping need not be complex, random or secure.  All we attempt
+ * to do here is to allow humans who pick small or successive seed values
+ * to obtain reasonably different sequences from the generators below.
+ *
+ * NOTE: This is NOT a pseudo random number generator.  This function is 
+ *      intended to be used internally by sa55rand() and sshufrand().
+ */
+define
+randreseed64(seed)
+{
+    local ret;                 /* return value */
+    local a;                   /* generator 0 multiplier */
+    local c;                   /* generator 0 adder */
+
+    /* firewall */
+    if (!isint(seed)) {
+       quit "bad args: seed must be an integer";
+    }
+    if (seed < 0) {
+       quit "bad arg: seed < 0 is reserved for future use";
+    }
+
+    /* if seed is 0, we will return 0 */
+    if (seed == 0) {
+       return (0);
+    }
+
+    /*
+     * process the low 64 bits of the seed
+     */
+    a = 6316878969928993981;
+    c = 1363042948800878693;
+    ret = (((seed & cry_mask)*a + c) & cry_mask);
+
+    /*
+     * Normally, the above equation would map:
+     *
+     *     f(0) == 1363042948800878693
+     *     f(10239951819489363767) == 0
+     *
+     * However, we have already forced f(0) == 0.  To preserve the
+     * 1-to-1 and onto map property, we force:
+     *
+     *     f(10239951819489363767) ==> 1363042948800878693
+     */
+    if (ret == 0) {
+       ret = c;
+    }
+
+    /* return the scrambled value */
+    return (ret);
+}
+
+
+/*
+ * Initial read execution code
+ */
+cry_seed = srandom(0);         /* pre-initialize the tables */
+cryrand_init_r = cryrand_r;
+global cryrand_ver = "10.7 23:47:35 13-Mar-1994";
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "cryrand_ver:", cryrand_ver;
+    print "shufrand() defined";
+    print "sshufrand(seed) defined";
+    print "rand([a, [b]]) defined";
+    print "srand(seed) defined";
+    print "cryrand([a, [b]]) defined";
+    print "scryrand([seed, [len1, len2]]) defined";
+    print "scryrand(seed, ip, iq, ir) defined";
+    print "random([a, [b]]) defined";
+    print "srandom(seed) defined";
+    print "obj cryobj defined";
+    print "randstate([cryobj | 0]) defined";
+    print "nxtprime(n, [val, modulus]) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/deg.cal b/usr/src/contrib/calc-2.9.3t6/lib/deg.cal
new file mode 100644 (file)
index 0000000..3dbb768
--- /dev/null
@@ -0,0 +1,124 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Calculate in degrees, minutes, and seconds.
+ */
+
+obj dms {deg, min, sec};
+
+define dms(deg, min, sec)
+{
+       local ans;
+
+       if (isnull(sec))
+               sec = 0;
+       if (isnull(min))
+               min = 0;
+       obj dms ans;
+       ans.deg = deg;
+       ans.min = min;
+       ans.sec = sec;
+       fixdms(&ans);
+       return ans;
+}
+
+
+define dms_add(a, b)
+{
+       local obj dms   ans;
+
+       ans.deg = 0;
+       ans.min = 0;
+       ans.sec = 0;
+       if (istype(a, ans)) {
+               ans.deg += a.deg;
+               ans.min += a.min;
+               ans.sec += a.sec;
+       } else
+               ans.deg += a;
+       if (istype(b, ans)) {
+               ans.deg += b.deg;
+               ans.min += b.min;
+               ans.sec += b.sec;
+       } else
+               ans.deg += b;
+       fixdms(&ans);
+       return ans;     
+}
+
+
+define dms_neg(a)
+{
+       local obj dms   ans;
+
+       ans.deg = -ans.deg;
+       ans.min = -ans.min;
+       ans.sec = -ans.sec;
+       return ans;
+}
+
+
+define dms_sub(a, b)
+{
+       return a - b;
+}
+
+
+define dms_mul(a, b)
+{
+       local obj dms   ans;
+
+       if (istype(a, ans) && istype(b, ans))
+               quit "Cannot multiply degrees together";
+       if (istype(a, ans)) {
+               ans.deg = a.deg * b;
+               ans.min = a.min * b;
+               ans.sec = a.sec * b;
+       } else {
+               ans.deg = b.deg * a;
+               ans.min = b.min * a;
+               ans.sec = b.sec * a;
+       }
+       fixdms(&ans);
+       return ans;
+}
+
+
+define dms_print(a)
+{
+       print a.deg : 'd' : a.min : 'm' : a.sec : 's' :;
+}
+
+
+define dms_abs(a)
+{
+       return a.deg + a.min / 60 + a.sec / 3600;
+}
+
+
+define fixdms(a)
+{
+       a.min += frac(a.deg) * 60;
+       a.deg = int(a.deg);
+       a.sec += frac(a.min) * 60;
+       a.min = int(a.min);
+       a.min += a.sec // 60;
+       a.sec %= 60;
+       a.deg += a.min // 60;
+       a.min %= 60;
+       a.deg %= 360;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "obj dms {deg, min, sec} defined";
+    print "dms(deg, min, sec) defined";
+    print "dms_add(a, b) defined";
+    print "dms_neg(a) defined";
+    print "dms_sub(a, b) defined";
+    print "dms_mul(a, b) defined";
+    print "dms_print(a) defined";
+    print "dms_abs(a) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/ellip.cal b/usr/src/contrib/calc-2.9.3t6/lib/ellip.cal
new file mode 100644 (file)
index 0000000..b116ced
--- /dev/null
@@ -0,0 +1,172 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Attempt to factor numbers using elliptic functions.
+ *     y^2 = x^3 + a*x + b   (mod N).
+ *
+ * Many points (x,y) (mod N) are found that solve the above equation,
+ * starting from a trivial solution and 'multiplying' that point together
+ * to generate high powers of the point, looking for such a point whose
+ * order contains a common factor with N.  The order of the group of points
+ * varies almost randomly within a certain interval for each choice of a
+ * and b, and thus each choice provides an independent opportunity to
+ * factor N.  To generate a trivial solution, a is chosen and then b is
+ * selected so that (1,1) is a solution.  The multiplication is done using
+ * the basic fact that the equation is a cubic, and so if a line hits the
+ * curve in two rational points, then the third intersection point must
+ * also be rational.  Thus by drawing lines between known rational points
+ * the number of rational solutions can be made very large.  When modular
+ * arithmetic is used, solving for the third point requires the taking of a
+ * modular inverse (instead of division), and if this fails, then the GCD
+ * of the failing value and N provides a factor of N.  This description is
+ * only an approximation, read "A Course in Number Theory and Cryptography"
+ * by Neal Koblitz for a good explanation.
+ *
+ * factor(iN, ia, B, force)
+ *     iN is the number to be factored.
+ *     ia is the initial value of a in the equation, and each successive
+ *     value of a is an independent attempt at factoring (default 1).
+ *     B is the limit of the primes that make up the high power that the
+ *     point is raised to for each factoring attempt (default 100).
+ *     force is a flag to attempt to factor numbers even if they are
+ *     thought to already be prime (default FALSE).
+ *
+ * Making B larger makes the power the point being raised to contain more
+ * prime factors, thus increasing the chance that the order of the point
+ * will be made up of those factors.  The higher B is then, the greater
+ * the chance that any individual attempt will find a factor.  However,
+ * a higher B also slows down the number of independent functions being
+ * examined.  The order of the point for any particular function might
+ * contain a large prime and so won't succeed even for a really large B,
+ * whereas the next function might have an order which is quickly found.
+ * So you want to trade off the depth of a particular search with the
+ * number of searches made.  For example, for factoring 30 digits, I make
+ * B be about 1000 (probably still too small).
+ *
+ * If you have lots of machines available, then you can run parallel
+ * factoring attempts for the same number by giving different starting
+ * values of ia for each machine (e.g. 1000, 2000, 3000).
+ *
+ * The output as the function is running is (occasionally) the value of a
+ * when a new function is started, the prime that is being included in the
+ * high power being calculated, and the current point which is the result
+ * of the powers so far.
+ *
+ * If a factor is found, it is returned and is also saved in the global
+ * variable f.  The number being factored is also saved in the global
+ * variable N.
+ */
+
+obj point {x, y};
+global N;              /* number to factor */
+global a;              /* first coefficient */
+global b;              /* second coefficient */
+global f;              /* found factor */
+
+
+define factor(iN, ia, B, force)
+{
+       local   C, x, p;
+
+       if (!force && ptest(iN, 50))
+               return 1;
+       if (isnull(B))
+               B = 100;
+       if (isnull(ia))
+               ia = 1;
+       obj point x;
+       a = ia;
+       b = -ia;
+       N = iN;
+       C = isqrt(N);
+       C = 2 * C + 2 * isqrt(C) + 1;
+       f = 0;
+       while (f == 0) {
+               print "A =", a;
+               x.x = 1;
+               x.y = 1;
+               print 2, x;
+               x = x ^ (2 ^ (highbit(C) + 1));
+               for (p = 3; ((p < B) && (f == 0)); p += 2) {
+                       if (!ptest(p, 1))
+                               continue;
+                       print p, x;
+                       x = x ^ (p ^ ((highbit(C) // highbit(p)) + 1));
+               }
+               a++;
+               b--;
+       }
+       return f;
+}
+
+
+define point_print(p)
+{
+       print "(" : p.x : "," : p.y : ")" :;
+}
+
+
+define point_mul(p1, p2)
+{
+       local   r, m;
+
+       if (p2 == 1)
+               return p1;
+       if (p1 == p2)
+               return point_square(&p1);
+       obj point r;
+       m = (minv(p2.x - p1.x, N) * (p2.y - p1.y)) % N;
+       if (m == 0) {
+               if (f == 0)
+                       f = gcd(p2.x - p1.x, N);
+               r.x = 1;
+               r.y = 1;
+               return r;               
+       }
+       r.x = (m^2 - p1.x - p2.x) % N;
+       r.y = ((m * (p1.x - r.x)) - p1.y) % N;
+       return r;
+}
+
+
+define point_square(p)
+{
+       local   r, m;
+
+       obj point r;
+       m = ((3 * p.x^2 + a) * minv(p.y << 1, N)) % N;
+       if (m == 0) {
+               if (f == 0)
+                       f = gcd(p.y << 1, N);
+               r.x = 1;
+               r.y = 1;
+               return r;
+       }
+       r.x = (m^2 - p.x - p.x) % N;
+       r.y = ((m * (p.x - r.x)) - p.y) % N;
+       return r;
+}
+
+
+define point_pow(p, pow)
+{
+       local bit, r, t;
+
+       r = 1;
+       if (isodd(pow))
+               r = p;
+       t = p;
+       for (bit = 2; ((bit <= pow) && (f == 0)); bit <<= 1) {
+               t = point_square(&t);
+               if (bit & pow)
+                       r = point_mul(&t, &r);
+       }
+       return r;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "factor(N, I, B, force) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/lucas.cal b/usr/src/contrib/calc-2.9.3t6/lib/lucas.cal
new file mode 100644 (file)
index 0000000..668d39e
--- /dev/null
@@ -0,0 +1,1013 @@
+/*
+ * Copyright (c) 1993 Landon Curt Noll
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * By: Landon Curt Noll
+ *     chongo@toad.com  -or-  ...!{pyramid,sun,uunet}!hoptoad!chongo
+ *
+ *
+ * lucas - perform a Lucas primality test on h*2^n-1
+ *
+ * HISTORICAL NOTE:
+ *
+ * On 6 August 1989 at 00:53 PDT, the 'Amdahl 6', a team consisting of
+ * John Brown, Landon Curt Noll, Bodo Parady, Gene Smith, Joel Smith and
+ * Sergio Zarantonello proved the following 65087 digit number to be prime:
+ *
+ *                               216193
+ *                     391581 * 2      -1
+ *
+ * At the time of discovery, this number was the largest known prime.
+ * The primality was demonstrated by a program implementing the test
+ * found in these routines.  An Amdahl 1200 takes 1987 seconds to test
+ * the primality of this number.  A Cray 2 took several hours to
+ * confirm this prime.  As of 28 Aug 1993, this prime was the 2nd
+ * largest known prime and the largest known non-Mersenne prime.
+ *
+ * The same team also discovered the following twin prime pair:
+ *
+ *                        11235                   11235
+ *             1706595 * 2     -1      1706595 * 2     +1
+ *
+ * As of 28 Aug 1993, these primes was still the largest known twin prime pair.
+ *
+ * ON GAINING A WORLD RECORD:
+ *
+ * The routines in calc were designed to be portable, and to work on
+ * numbers of 'sane' size.  The Amdahl 6 team used a 'ultra-high speed 
+ * multi-precision' package that a machine dependent collection of routines 
+ * tuned for a long trace vector processor to work with very large numbers.
+ * The heart of the package was a multiplication and square routine that 
+ * was based on the PFA Fast Fourier Transform and on Winograd's radix FFTs.
+ *
+ * Having a fast computer, and a good multi-precision package are
+ * critical, but one also needs to know where to look in order to have
+ * a good chance at a record.  Knowing what to test is beyond the scope
+ * of this routine.  However the following observations are noted:
+ *
+ *     test numbers of the form h*2^n-1
+ *     fix a value of n and vary the value h
+ *     n mod 128 == 0
+ *     h*2^n-1 is not divisible by any small prime < 2^40
+ *     0 < h < 2^39
+ *     h*2^n+1 is not divisible by any small prime < 2^40
+ *
+ * The Mersenne test for '2^n-1' is the fastest known primality test
+ * for a given large numbers.  However, it is faster to search for
+ * primes of the form 'h*2^n-1'.  When n is around 20000, one can find
+ * a prime of the form 'h*2^n-1' in about 1/2 the time.
+ *
+ * Critical to understanding why 'h*2^n-1' is to observe that primes of
+ * the form '2^n-1' seem to bunch around "islands".  Such "islands"
+ * seem to be getting fewer and farther in-between, forcing the time
+ * for each test to grow longer and longer (worse then O(n^2 log n)).
+ * On the other hand, when one tests 'h*2^n-1', fixes 'n' and varies
+ * 'h', the time to test each number remains relatively constant.
+ *
+ * It is clearly a win to eliminate potential test candidates by
+ * rejecting numbers that that are divisible by 'small' primes.  We
+ * (the "Amdahl 6") rejected all numbers that were divisible by primes
+ * less than '2^40'.  We stopped looking for small factors at '2^40'
+ * when the rate of candidates being eliminated was slowed down to
+ * just a trickle.
+ *
+ * The 'n mod 128 == 0' restriction allows one to test for divisibility
+ * of small primes more quickly.  To test of 'q' is a factor of 'k*2^n-1',
+ * one check to see if 'k*2^n mod q' == 1, which is the same a checking
+ * if 'h*(2^n mod q) mod q' == 1.  One can compute '2^n mod q' by making
+ * use of the following:
+ *
+ *     if
+ *             y = 2^x mod q
+ *     then
+ *             2^(2x) mod q   == y^2 mod q             0 bit
+ *             2^(2x+1) mod q == 2*y^2 mod q           1 bit
+ *
+ * The choice of which expression depends on the binary pattern of 'n'.
+ * Since '1' bits require an extra step (multiply by 2), one should
+ * select value of 'n' that contain mostly '0' bits.  The restriction
+ * of 'n mod 128 == 0' ensures that the bottom 7 bits of 'n' are 0.
+ *
+ * By limiting 'h' to '2^39' and eliminating all values divisible by
+ * small primes < twice the 'h' limit (2^40), one knows that all
+ * remaining candidates are relatively prime.  Thus, when a candidate
+ * is proven to be composite (not prime) by the big test, one knows
+ * that the factors for that number (whatever they may be) will not
+ * be the factors of another candidate.
+ *
+ * Finally, one should eliminate all values of 'h*2^n-1' where
+ * 'h*2^n+1' is divisible by a small primes.  The ideas behind this 
+ * point is beyond the scope of this program.
+ */
+
+global pprod256;       /* product of  "primes up to 256" / "primes up to 46" */
+global lib_debug;      /* 1 => print debug statements */
+
+/*
+ * lucas - lucas primality test on h*2^n-1
+ *
+ * ABOUT THE TEST:
+ *
+ * This routine will perform a primality test on h*2^n-1 based on
+ * the mathematics of Lucas, Lehmer and Riesel.  One should read
+ * the following article:
+ *
+ * Ref1:
+ *     "Lucasian Criteria for the Primality of N=h*2^n-1", by Hans Riesel,
+ *     Mathematics of Computation, Vol 23 #108, pp. 869-875, Oct 1969
+ *
+ * The following book is also useful:
+ *
+ * Ref2:
+ *     "Prime numbers and Computer Methods for Factorization", by Hans Riesel,
+ *     Birkhauser, 1985, pp 131-134, 278-285, 438-444
+ *
+ * A few useful Legendre identities may be found in:
+ *
+ * Ref3:
+ *     "Introduction to Analytic Number Theory", by Tom A. Apostol,
+ *     Springer-Verlag, 1984, p 188.
+ *
+ * This test is performed as follows:  (see Ref1, Theorem 5)
+ *
+ *     a) generate u(0)                (see the function gen_u0() below)
+ *
+ *     b) generate u(n-2) according to the rule:
+ *
+ *             u(i+1) = u(i)^2-2 mod h*2^n-1
+ *
+ *     c) h*2^n-1 is prime if and only if u(n-2) == 0          Q.E.D. :-)
+ *
+ * Now the following conditions must be true for the test to work:
+ *
+ *      n >= 2
+ *     h >= 1
+ *      h < 2^n
+ *     h mod 2 == 1
+ *
+ * A few misc notes:
+ *
+ * In order to reduce the number of tests, as attempt to eliminate
+ * any number that is divisible by a prime less than 257.  Valid prime
+ * candidates less than 257 are declared prime as a special case.
+ *
+ * The condition 'h mod 2 == 1' is not a problem.  Say one is testing
+ * 'j*2^m-1', where j is even.  If we note that:
+ *
+ *      j mod 2^x == 0 for x>0   implies   j*2^m-1 == ((j/2^x)*2^(m+x))-1,
+ *
+ * then we can let h=j/2^x and n=m+x and test 'h*2^n-1' which is the value.
+ * We need only consider odd values of h because we can rewrite our numbers
+ * do make this so.
+ *
+ * input:
+ *     h    the h as in h*2^n-1
+ *     n    the n as in h*2^n-1
+ *
+ * returns:
+ *     1 => h*2^n-1 is prime
+ *     0 => h*2^n-1 is not prime
+ *     -1 => a test could not be formed, or h >= 2^n, h <= 0, n <= 0
+ */
+define
+lucas(h, n)
+{
+       local testval;          /* h*2^n-1 */
+       local shiftdown;        /* the power of 2 that divides h */
+       local u;                /* the u(i) sequence value */
+       local v1;               /* the v(1) generator of u(0) */
+       local i;                /* u sequence cycle number */
+       local oldh;             /* pre-reduced h */
+       local oldn;             /* pre-reduced n */
+       local bits;             /* highbit of h*2^n-1 */
+
+       /*
+        * check arg types
+        */
+       if (!isint(h)) {
+               ldebug("lucas", "h is non-int");
+               quit "FATAL: bad args: h must be an integer";
+       }
+       if (!isint(n)) {
+               ldebug("lucas", "n is non-int");
+               quit "FATAL: bad args: n must be an integer";
+       }
+
+       /*
+        * reduce h if even
+        *
+        * we will force h to be odd by moving powers of two over to 2^n
+        */
+       oldh = h;
+       oldn = n;
+       shiftdown = fcnt(h,2);  /* h % 2^shiftdown == 0, max shiftdown */
+       if (shiftdown > 0) {
+               h >>= shiftdown;
+               n += shiftdown;
+       }
+
+       /*
+        * enforce the 0 < h < 2^n rule
+        */
+       if (h <= 0 || n <= 0) {
+               print "ERROR: reduced args violate the rule: 0 < h < 2^n";
+               print "    ERROR: h=":oldh, "n=":oldn, "reduced h=":h, "n=":n;
+               ldebug("lucas", "unknown: h <= 0 || n <= 0");
+               return -1;
+       }
+       if (highbit(h) >= n) {
+               print "ERROR: reduced args violate the rule: h < 2^n";
+               print "    ERROR: h=":oldh, "n=":oldn, "reduced h=":h, "n=":n;
+               ldebug("lucas", "unknown: highbit(h) >= n");
+               return -1;
+       }
+
+       /*
+        * catch the degenerate case of h*2^n-1 == 1
+        */
+       if (h == 1 && n == 1) {
+               ldebug("lucas", "not prime: h == 1 && n == 1");
+               return 0;       /* 1*2^1-1 == 1 is not prime */
+       }
+
+       /*
+        * catch the degenerate case of n==2
+        *
+        * n==2 and 0<h<2^n  ==>  0<h<4
+        *
+        * Since h is now odd  ==>  h==1 or h==3
+        */
+       if (h == 1 && n == 2) {
+               ldebug("lucas", "prime: h == 1 && n == 2");
+               return 1;       /* 1*2^2-1 == 3 is prime */
+       }
+       if (h == 3 && n == 2) {
+               ldebug("lucas", "prime: h == 3 && n == 2");
+               return 1;       /* 3*2^2-1 == 11 is prime */
+       }
+
+       /*
+        * catch small primes < 257
+        *
+        * We check for only a few primes because the other primes < 257
+        * violate the checks above.
+        */
+       if (h == 1) {
+               if (n == 3 || n == 5 || n == 7) {
+                       ldebug("lucas", "prime: 3, 7, 31, 127 are prime");
+                       return 1;       /* 3, 7, 31, 127 are prime */
+               }
+       }
+       if (h == 3) {
+               if (n == 2 || n == 3 || n == 4 || n == 6) {
+                       ldebug("lucas", "prime: 11, 23, 47, 191 are prime");
+                       return 1;       /* 11, 23, 47, 191 are prime */
+               }
+       }
+       if (h == 5 && n == 4) {
+               ldebug("lucas", "prime: 79 is prime");
+               return 1;               /* 79 is prime */
+       }
+       if (h == 7 && n == 5) {
+               ldebug("lucas", "prime: 223 is prime");
+               return 1;               /* 223 is prime */
+       }
+       if (h == 15 && n == 4) {
+               ldebug("lucas", "prime: 239 is prime");
+               return 1;               /* 239 is prime */
+       }
+
+       /*
+        * Avoid any numbers divisible by small primes
+        */
+       /*
+        * check for 3 <= prime factors < 29
+        * pfact(28)/2 = 111546435
+        */
+       testval = h*2^n - 1;
+       if (gcd(testval, 111546435) > 1) {
+               /* a small 3 <= prime < 29 divides h*2^n-1 */
+               ldebug("lucas","not-prime: 3<=prime<29 divides h*2^n-1");
+               return 0;
+       }
+       /*
+        * check for 29 <= prime factors < 47
+        * pfact(46)/pfact(28) = 5864229
+        */
+       if (gcd(testval, 58642669) > 1) {
+               /* a small 29 <= prime < 47 divides h*2^n-1 */
+               ldebug("lucas","not-prime: 29<=prime<47 divides h*2^n-1");
+               return 0;
+       }
+       /*
+        * check for prime 47 <= factors < 257, if h*2^n-1 is large
+        * 2^282 > pfact(256)/pfact(46) > 2^281
+        */
+       bits = highbit(testval);
+       if (bits >= 281) {
+               if (pprod256 <= 0) {
+                       pprod256 = pfact(256)/pfact(46);
+               }
+               if (gcd(testval, pprod256) > 1) {
+                       /* a small 47 <= prime < 257 divides h*2^n-1 */
+                       ldebug("lucas",\
+                           "not-prime: 47<=prime<257 divides h*2^n-1");
+                       return 0;
+               }
+       }
+
+       /*
+        * try to compute u(0)
+        *
+        * We will use gen_v1() to give us a v(1) using the values
+        * of 'h' and 'n'.  We will then use gen_u0() to convert
+        * the v(1) into u(0).
+        *
+        * If gen_v1() returns a negative value, then we failed to
+        * generate a test for h*2^n-1.  This is because h mod 3 == 0
+        * is hard to do, and in rare cases, exceed the tables found
+        * in this program.  We will generate an message and assume
+        * the number is not prime, even though if we had a larger
+        * table, we might have been able to show that it is prime.
+        */
+       v1 = gen_v1(h, n, testval);
+       if (v1 < 0) {
+               /* failure to test number */
+               print "unable to compute v(1) for", h : "*2^" : n : "-1";
+               ldebug("lucas", "unknown: no v(1)");
+               return -1;
+       }
+       u = gen_u0(h, n, testval, v1);
+
+       /*
+        * compute u(n-2)
+        */
+       for (i=3; i <= n; ++i) {
+               u = (u^2 - 2) % testval;
+       }
+
+       /*
+        * return 1 if prime, 0 is not prime
+        */
+       if (u == 0) {
+               ldebug("lucas", "prime: end of test");
+               return 1;
+       } else {
+               ldebug("lucas", "not-prime: end of test");
+               return 0;
+       }
+}
+
+/*
+ * gen_u0 - determine the initial Lucas sequence for h*2^n-1
+ *
+ * According to Ref1, Theorem 5:
+ *
+ *     u(0) = alpha^h + alpha^(-h)
+ *
+ * Now:
+ *
+ *     v(x) = alpha^x + alpha^(-x)     (Ref1, bottom of page 872)
+ *
+ * Therefore:
+ *
+ *     u(0) = v(h)
+ *
+ * We calculate v(h) as follows:       (Ref1, top of page 873)
+ *
+ *     v(0) = alpha^0 + alpha^(-0) = 2
+ *     v(1) = alpha^1 + alpha^(-1) = gen_v1(h,n)
+ *     v(n+2) = v(1)*v(n+1) - v(n)
+ *
+ * This function does not concern itself with the value of 'alpha'.
+ * The gen_v1() function is used to compute v(1), and identity
+ * functions take it from there.
+ *
+ * It can be shown that the following are true:
+ *
+ *     v(2*n) = v(n)^2 - 2
+ *     v(2*n+1) = v(n+1)*v(n) - v(1)
+ *
+ * To prevent v(x) from growing too large, one may replace v(x) with
+ * `v(x) mod h*2^n-1' at any time.
+ *
+ * See the function gen_v1() for details on the value of v(1).
+ *
+ * input:
+ *     h       - h as in h*2^n-1       (h mod 2 != 0)
+ *     n       - n as in h*2^n-1
+ *     testval - h*2^n-1
+ *     v1      - gen_v1(h,n)           (see function below)
+ *
+ * returns:
+ *     u(0)    - initial value for Lucas test on h*2^n-1
+ *     -1      - failed to generate u(0)
+ */
+define
+gen_u0(h, n, testval, v1)
+{
+       local shiftdown;        /* the power of 2 that divides h */
+       local r;                /* low value: v(n) */
+       local s;                /* high value: v(n+1) */
+       local hbits;            /* highest bit set in h */
+       local i;
+
+       /*
+        * check arg types
+        */
+       if (!isint(h)) {
+               quit "bad args: h must be an integer";
+       }
+       if (!isint(n)) {
+               quit "bad args: n must be an integer";
+       }
+       if (!isint(testval)) {
+               quit "bad args: testval must be an integer";
+       }
+       if (!isint(v1)) {
+               quit "bad args: v1 must be an integer";
+       }
+       if (testval <= 0) {
+               quit "bogus arg: testval is <= 0";
+       }
+       if (v1 <= 0) {
+               quit "bogus arg: v1 is <= 0";
+       }
+
+       /*
+        * enforce the h mod rules
+        */
+       if (h%2 == 0) {
+               quit "h must not be even";
+       }
+
+       /*
+        * enforce the h > 0 and n >= 2 rules
+        */
+       if (h <= 0 || n < 1) {
+               quit "reduced args violate the rule: 0 < h < 2^n";
+       }
+       hbits = highbit(h);
+       if (hbits >= n) {
+               quit "reduced args violate the rule: 0 < h < 2^n";
+       }
+
+       /*
+        * build up u2 based on the reversed bits of h
+        */
+       /* setup for bit loop */
+       r = v1;
+       s = (r^2 - 2);
+
+       /*
+        * deal with small h as a special case
+        *
+        * The h value is odd > 0, and it needs to be
+        * at least 2 bits long for the loop below to work.
+        */
+       if (h == 1) {
+               ldebug("gen_u0", "quick h == 1 case");
+               return r%testval;
+       }
+
+       /* cycle from second highest bit to second lowest bit of h */
+       for (i=hbits-1; i > 0; --i) {
+
+               /* bit(i) is 1 */
+               if (isset(h,i)) {
+
+                       /* compute v(2n+1) = v(r+1)*v(r)-v1 */
+                       r = (r*s - v1) % testval;
+
+                       /* compute v(2n+2) = v(r+1)^2-2 */
+                       s = (s^2 - 2) % testval;
+
+               /* bit(i) is 0 */
+               } else {
+
+                       /* compute v(2n+1) = v(r+1)*v(r)-v1 */
+                       s = (r*s - v1) % testval;
+
+                       /* compute v(2n) = v(r)^-2 */
+                       r = (r^2 - 2) % testval;
+               }
+       }
+
+       /* we know that h is odd, so the final bit(0) is 1 */
+       r = (r*s - v1) % testval;
+
+       /* compute the final u2 return value */
+       return r;
+}
+
+/*
+ * Trial tables used by gen_v1()
+ *
+ * When h mod 3 == 0, one needs particular values of D, a and b (see gen_v1
+ * documentation) in order to find a value of v(1).
+ *
+ * This table defines 'quickmax' possible tests to be taken in ascending
+ * order.  The v1_qval[x] refers to a v(1) value from Ref1, Table 1.  A
+ * related D value is found in d_qval[x].  All D values expect d_qval[1]
+ * are also taken from Ref1, Table 1.  The case of D == 21 as listed in
+ * Ref1, Table 1 can be changed to D == 7 for the sake of the test because
+ * of {note 6}.
+ *
+ * It should be noted that the D values all satisfy the selection values
+ * as outlined in the gen_v1() function comments.  That is:
+ *
+ *        D == P*(2^f)*(3^g)
+ *
+ * where f == 0 and g == 0, P == D.  So we simply need to check that
+ * one of the following two cases are true:
+ *
+ *        P mod 4 ==  1  and  J(h*2^n-1 mod P, P) == -1
+ *        P mod 4 == -1  and  J(h*2^n-1 mod P, P) ==  1
+ *
+ * In all cases, the value of r is:
+ *
+ *        r == Q*(2^j)*(3^k)*(z^2)
+ *
+ * where Q == 1.  No further processing is needed to compute v(1) when r 
+ * is of this form.  
+ */
+quickmax = 8;
+mat d_qval[quickmax];
+mat v1_qval[quickmax];
+d_qval[0] = 5;         v1_qval[0] = 3;         /* a=1   b=1  r=4  */
+d_qval[1] = 7;         v1_qval[1] = 5;         /* a=3   b=1  r=12  D=21 */
+d_qval[2] = 13;                v1_qval[2] = 11;        /* a=3   b=1  r=4  */
+d_qval[3] = 11;                v1_qval[3] = 20;        /* a=3   b=1  r=2  */
+d_qval[4] = 29;                v1_qval[4] = 27;        /* a=5   b=1  r=4  */
+d_qval[5] = 53;                v1_qval[5] = 51;        /* a=53  b=1  r=4  */
+d_qval[6] = 17;                v1_qval[6] = 66;        /* a=17  b=1  r=1  */
+d_qval[7] = 19;                v1_qval[7] = 74;        /* a=38  b=1  r=2  */
+
+/*
+ * gen_v1 - compute the v(1) for a given h*2^n-1 if we can
+ *
+ * This function assumes:
+ *
+ *     n > 2                   (n==2 has already been eliminated)
+ *     h mod 2 == 1
+ *     h < 2^n
+ *     h*2^n-1 mod 3 != 0      (h*2^n-1 has no small factors, such as 3)
+ *
+ * The generation of v(1) depends on the value of h.  There are two cases
+ * to consider, h mod 3 != 0, and h mod 3 == 0.
+ *
+ ***
+ *
+ * Case 1:     (h mod 3 != 0)
+ *
+ * This case is easy and always finds v(1).
+ *
+ * In Ref1, page 869, one finds that if:       (or see Ref2, page 131-132)
+ *
+ *     h mod 6 == +/-1
+ *     h*2^n-1 mod 3 != 0
+ *
+ * which translates, gives the functions assumptions, into the condition:
+ *
+ *     h mod 3 != 0
+ *
+ * If this case condition is true, then:
+ *
+ *     u(0) = (2+sqrt(3))^h + (2-sqrt(3))^h            (see Ref1, page 869)
+ *          = (2+sqrt(3))^h + (2+sqrt(3))^(-h)
+ *
+ * and since Ref1, Theorem 5 states:
+ *
+ *     u(0) = alpha^h + alpha^(-h)
+ *     r = abs(2^2 - 1^2*3) = 1
+ *
+ * and the bottom of Ref1, page 872 states:
+ *
+ *     v(x) = alpha^x + alpha^(-x)
+ *
+ * If we let:
+ *
+ *     alpha = (2+sqrt(3))
+ *
+ * then
+ *
+ *     u(0) = v(h)
+ *
+ * so we simply return
+ *
+ *     v(1) = alpha^1 + alpha^(-1)
+ *          = (2+sqrt(3)) + (2-sqrt(3))
+ *          = 4
+ *
+ ***
+ *
+ * Case 2:     (h mod 3 == 0)
+ *
+ * This case is not so easy and finds v(1) in most all cases.  In this
+ * version of this program, we will simply return -1 (failure) if we
+ * hit one of the cases that fall thru the cracks.  This does not happen
+ * often, so this is not too bad.
+ *
+ * Ref1, Theorem 5 contains the following definitions:
+ *
+ *         r = abs(a^2 - b^2*D)
+ *         alpha = (a + b*sqrt(D))^2/r
+ *
+ * where D is 'square free', and 'alpha = epsilon^s' (for some s>0) are units
+ * in the quadratic field K(sqrt(D)).
+ *
+ * One can find possible values for a, b and D in Ref1, Table 1 (page 872).
+ * (see the file lucas_tbl.cal)
+ *
+ * Now Ref1, Theorem 5 states that if:
+ *
+ *     L(D, h*2^n-1) = -1                              [condition 1]
+ *     L(r, h*2^n-1) * (a^2 - b^2*D)/r = -1            [condition 2]
+ *
+ * where L(x,y) is the Legendre symbol (see below), then:
+ *
+ *     u(0) = alpha^h + alpha^(-h)
+ *
+ * The bottom of Ref1, page 872 states:
+ *
+ *     v(x) = alpha^x + alpha^(-x)
+ *
+ * thus since:
+ *
+ *     u(0) = v(h)
+ *
+ * so we want to return:
+ *
+ *     v(1) = alpha^1 + alpha^(-1)
+ *
+ * Therefore we need to take a given (D,a,b), determine if the two conditions
+ * are true, and return the related v(1).
+ *
+ * Before we address the two conditions, we need some background information
+ * on two symbols, Legendre and Jacobi.  In Ref 2, pp 278, 284-285, we find
+ * the following definitions of J(a,p) and L(a,n):
+ *
+ * The Legendre symbol L(a,p) takes the value:
+ *
+ *     L(a,p) == 1     => a is a quadratic residue of p
+ *     L(a,p) == -1    => a is NOT a quadratic residue of p
+ *
+ * when
+ *
+ *     p is prime
+ *     p mod 2 == 1
+ *     gcd(a,p) == 1
+ *
+ * The value x is a quadratic residue of y if there exists some integer z
+ * such that:
+ *
+ *     z^2 mod y == x
+ *
+ * The Jacobi symbol J(x,y) takes the value:
+ *
+ *     J(x,y) == 1     => y is not prime, or x is a quadratic residue of y
+ *     J(x,y) == -1    => x is NOT a quadratic residue of y
+ *
+ * when
+ *
+ *     y mod 2 == 1
+ *     gcd(x,y) == 1
+ *
+ * In the following comments on Legendre and Jacobi identities, we shall
+ * assume that the arguments to the symbolic are valid over the symbol
+ * definitions as stated above.
+ *
+ * In Ref2, pp 280-284, we find that:
+ *
+ *     L(a,p)*L(b,p) == L(a*b,p)                               {A3.5}
+ *     J(x,y)*J(z,y) == J(x*z,y)                               {A3.14}
+ *     L(a,p) == L(p,a) * (-1)^((a-1)*(p-1)/4)                 {A3.8}
+ *     J(x,y) == J(y,x) * (-1)^((x-1)*(y-1)/4)                 {A3.17}
+ *
+ * The equality L(a,p) == J(a,p) when:                         {note 0}
+ *
+ *     p is prime
+ *     p mod 2 == 1
+ *     gcd(a,p) == 1
+ *
+ * It can be shown that (see Ref3):
+ *
+ *     L(a,p) == L(a mod p, p)                                 {note 1}
+ *     L(z^2, p) == 1                                          {note 2}
+ *
+ * From Ref2, table 32:
+ *
+ *     p mod 8 == +/-1   implies  L(2,p) == 1                  {note 3}
+ *     p mod 12 == +/-1  implies  L(3,p) == 1                  {note 4}
+ *
+ * Since h*2^n-1 mod 8 == -1, for n>2, note 3 implies:
+ *
+ *     L(2, h*2^n-1) == 1                      (n>2)           {note 5}
+ *
+ * Since h=3*A, h*2^n-1 mod 12 == -1, for A>0, note 4 implies:
+ *
+ *     L(3, h*2^n-1) == 1                                      {note 6}
+ *
+ * By use of {A3.5}, {note 2}, {note 5} and {note 6}, one can show:
+ *
+ *     L((2^g)*(3^l)*(z^2), h*2^n-1) == 1  (g>=0,l>=0,z>0,n>2) {note 7}
+ *
+ * Returning to the testing of conditions, take condition 1:
+ *
+ *     L(D, h*2^n-1) == -1                     [condition 1]
+ *
+ * In order for J(D, h*2^n-1) to be defined, we must ensure that D
+ * is not a factor of h*2^n-1.  This is done by pre-screening h*2^n-1 to
+ * not have small factors and selecting D less than that factor check limit.
+ *
+ * By use of {note 7}, we can show that when we choose D to be:
+ *
+ *     D is square free
+ *     D = P*(2^f)*(3^g)                       (P is prime>2)
+ *
+ * The square free condition implies f = 0 or 1, g = 0 or 1.  If f and g
+ * are both 1, P must be a prime > 3.
+ *
+ * So given such a D value:
+ *
+ *     L(D, h*2^n-1) == L(P*(2^g)*(3^l), h*2^n-1)
+ *                   == L(P, h*2^n-1) * L((2^g)*(3^l), h*2^n-1)       {A3.5}
+ *                   == L(P, h*2^n-1) * 1                             {note 7}
+ *                   == L(h*2^n-1, P)*(-1)^((h*2^n-2)*(P-1)/4)        {A3.8}
+ *                   == L(h*2^n-1 mod P, P)*(-1)^((h*2^n-2)*(P-1)/4)  {note 1}
+ *                   == J(h*2^n-1 mod P, P)*(-1)^((h*2^n-2)*(P-1)/4)  {note 0}
+ *
+ * When does J(h*2^n-1 mod P, P)*(-1)^((h*2^n-2)*(P-1)/4) take the value of -1,
+ * thus satisfy [condition 1]?  The answer depends on P.  Now P is a prime>2,
+ * thus P mod 4 == 1 or -1.
+ *
+ * Take P mod 4 == 1:
+ *
+ *     P mod 4 == 1  implies  (-1)^((h*2^n-2)*(P-1)/4) == 1
+ *
+ * Thus:
+ *
+ *     L(D, h*2^n-1) == L(h*2^n-1 mod P, P) * (-1)^((h*2^n-2)*(P-1)/4)
+ *                   == L(h*2^n-1 mod P, P)
+ *                   == J(h*2^n-1 mod P, P)
+ *
+ * Take P mod 4 == -1:
+ *
+ *     P mod 4 == -1  implies  (-1)^((h*2^n-2)*(P-1)/4) == -1
+ *
+ * Thus:
+ *
+ *     L(D, h*2^n-1) == L(h*2^n-1 mod P, P) * (-1)^((h*2^n-2)*(P-1)/4)
+ *                   == L(h*2^n-1 mod P, P) * -1
+ *                   == -J(h*2^n-1 mod P, P)
+ *
+ * Therefore [condition 1] is met if, and only if, one of the following
+ * to cases are true:
+ *
+ *     P mod 4 ==  1  and  J(h*2^n-1 mod P, P) == -1
+ *     P mod 4 == -1  and  J(h*2^n-1 mod P, P) ==  1
+ *
+ * Now consider [condition 2]:
+ *
+ *     L(r, h*2^n-1) * (a^2 - b^2*D)/r == -1   [condition 2]
+ *
+ * We select only a, b, r and D values where:
+ *
+ *     (a^2 - b^2*D)/r == -1
+ *
+ * Therefore in order for [condition 2] to be met, we must show that:
+ *
+ *     L(r, h*2^n-1) == 1
+ *
+ * If we select r to be of the form:
+ *
+ *     r == Q*(2^j)*(3^k)*(z^2)                (Q == 1, j>=0, k>=0, z>0)
+ *
+ * then by use of {note 7}:
+ *
+ *     L(r, h*2^n-1) == L(Q*(2^j)*(3^k)*(z^2), h*2^n-1)
+ *                   == L((2^j)*(3^k)*(z^2), h*2^n-1)
+ *                   == 1                                             {note 2}
+ *
+ * and thus, [condition 2] is met.
+ *
+ * If we select r to be of the form:
+ *
+ *     r == Q*(2^j)*(3^k)*(z^2)                (Q is prime>2, j>=0, k>=0, z>0)
+ *
+ * then by use of {note 7}:
+ *
+ *     L(r, h*2^n-1) == L(Q*(2^j)*(3^k)*(z^2), h*2^n-1)
+ *                   == L(Q, h*2^n-1) * L((2^j)*(3^k)*(z^2), h*2^n-1) {A3.5}
+ *                   == L(Q, h*2^n-1) * 1                             {note 2}
+ *                   == L(h*2^n-1, Q) * (-1)^((h*2^n-2)*(Q-1)/4)      {A3.8}
+ *                   == L(h*2^n-1 mod Q, Q)*(-1)^((h*2^n-2)*(Q-1)/4)  {note 1}
+ *                   == J(h*2^n-1 mod Q, Q)*(-1)^((h*2^n-2)*(Q-1)/4)  {note 0}
+ *
+ * When does J(h*2^n-1 mod Q, Q)*(-1)^((h*2^n-2)*(Q-1)/4) take the value of 1,
+ * thus satisfy [condition 2]?  The answer depends on Q.  Now Q is a prime>2,
+ * thus Q mod 4 == 1 or -1.
+ *
+ * Take Q mod 4 == 1:
+ *
+ *     Q mod 4 == 1  implies  (-1)^((h*2^n-2)*(Q-1)/4) == 1
+ *
+ * Thus:
+ *
+ *     L(D, h*2^n-1) == L(h*2^n-1 mod Q, Q) * (-1)^((h*2^n-2)*(Q-1)/4)
+ *                   == L(h*2^n-1 mod Q, Q)
+ *                   == J(h*2^n-1 mod Q, Q)
+ *
+ * Take Q mod 4 == -1:
+ *
+ *     Q mod 4 == -1  implies  (-1)^((h*2^n-2)*(Q-1)/4) == -1
+ *
+ * Thus:
+ *
+ *     L(D, h*2^n-1) == L(h*2^n-1 mod Q, Q) * (-1)^((h*2^n-2)*(Q-1)/4)
+ *                   == L(h*2^n-1 mod Q, Q) * -1
+ *                   == -J(h*2^n-1 mod Q, Q)
+ *
+ * Therefore [condition 2] is met by selecting  D = Q*(2^j)*(3^k)*(z^2),
+ * where Q is prime>2, j>=0, k>=0, z>0; if and only if one of the following
+ * to cases are true:
+ *
+ *     Q mod 4 ==  1  and  J(h*2^n-1 mod Q, Q) == 1
+ *     Q mod 4 == -1  and  J(h*2^n-1 mod Q, Q) == -1
+ *
+ ***
+ *
+ * In conclusion, we can compute v(1) by attempting to do the following:
+ *
+ * h mod 3 != 0
+ *
+ *     we return:
+ *
+ *        v(1) == 4
+ *
+ * h mod 3 == 0
+ *
+ *     define:
+ *
+ *        r == abs(a^2 - b^2*D)
+ *        alpha == (a + b*sqrt(D))^2/r
+ *
+ *     we return:
+ *
+ *        v(1) = alpha^1 + alpha^(-1)
+ *
+ *     if and only if we can find a given a, b, D that obey all the
+ *     following selection rules:
+ *
+ *        D is square free
+ *
+ *        D == P*(2^f)*(3^g)           (P is prime>2, f,g == 0 or 1)
+ *
+ *        (a^2 - b^2*D)/r == -1
+ *
+ *        r == Q*(2^j)*(3^k)*(z^2)     (Q==1 or Q is prime>2, j>=0, k>=0, z>0)
+ *
+ *         one of the following is true:
+ *            P mod 4 ==  1  and  J(h*2^n-1 mod P, P) == -1
+ *            P mod 4 == -1  and  J(h*2^n-1 mod P, P) ==  1
+ *
+ *        if Q is prime, then one of the following is true:
+ *            Q mod 4 ==  1  and  J(h*2^n-1 mod Q, Q) == 1
+ *            Q mod 4 == -1  and  J(h*2^n-1 mod Q, Q) == -1
+ *
+ *     If we cannot find a v(1) quickly enough, then we will give up
+ *     testing h*2^n-1.  This does not happen too often, so this hack
+ *     is not too bad.
+ *
+ ***
+ *
+ * input:
+ *     h       h as in h*2^n-1
+ *     n       n as in h*2^n-1
+ *
+ * output:
+ *     returns v(1), or -1 is there is no quick way
+ */
+define
+gen_v1(h, n)
+{
+       local d;        /* the 'D' value to try */
+       local val_mod;  /* h*2^n-1 mod 'D' */
+       local i;
+
+       /*
+        * check for case 1
+        */
+       if (h % 3 != 0) {
+               /* v(1) is easy to compute */
+               return 4;
+       }
+
+       /*
+        * We will try all 'D' values until we find a proper v(1)
+        * or run out of 'D' values.
+        */
+       for (i=0; i < quickmax; ++i) {
+
+               /* grab our 'D' value */
+               d = d_qval[i];
+
+               /* compute h*2^n-1 mod 'D' quickly */
+               val_mod = (h*pmod(2,n%(d-1),d)-1) % d;
+
+               /*
+                * if 'D' mod 4 == 1, then
+                *      (h*2^n-1) mod 'D' can not be a quadratic residue of 'D'
+                * else
+                *      (h*2^n-1) mod 'D' must be a quadratic residue of 'D'
+                */
+               if (d%4 == 1) {
+                       /* D mod 4 == 1, so check for J(D, h*2^n-1) == -1 */
+                       if (jacobi(val_mod, d) == -1) {
+                               /* it worked, return the related v(1) value */
+                               return v1_qval[i];
+                       }
+               } else {
+                       /* D mod 4 == -1, so check for J(D, h*2^n-1) == 1 */
+                       if (jacobi(val_mod, d) == 1) {
+                               /* it worked, return the related v(1) value */
+                               return v1_qval[i];
+                       }
+               }
+       }
+
+       /*
+        * This is an example of a more complex proof construction.
+        * The code above will not be able to find the v(1) for:
+        *
+        *                      81*2^81-1
+        *
+        * We will check with:
+        *
+        *      v(1)=81      D=6557      a=79      b=1      r=316
+        *
+        * Now, D==79*83 and r=79*2^2.  If we show that:
+        *
+        *      J(h*2^n-1 mod 79, 79) == -1
+        *      J(h*2^n-1 mod 83, 83) == 1
+        *
+        * then we will satisfy [condition 1].  Observe:
+        *
+        *      79 mod 4 == -1  implies  (-1)^((h*2^n-2)*(79-1)/4) == -1
+        *      83 mod 4 == -1  implies  (-1)^((h*2^n-2)*(83-1)/4) == -1
+        *
+        *      J(D, h*2^n-1) == J(83, h*2^n-1) * J(79, h*2^n-1)
+        *                    == J(h*2^n-1, 83) * (-1)^((h*2^n-2)*(83-1)/4) *
+        *                       J(h*2^n-1, 79) * (-1)^((h*2^n-2)*(79-1)/4)
+        *                    == J(h*2^n-1 mod 83, 83) * -1 *
+        *                       J(h*2^n-1 mod 79, 79) * -1
+        *                    ==  1 * -1 *
+        *                       -1 * -1
+        *                    == -1
+        *
+        * We will also satisfy [condition 2].  Observe:
+        *
+        *      (a^2 - b^2*D)/r == (79^2 - 1^1*6557)/316
+        *                      == -1
+        *
+        *      L(r, h*2^n-1) == L(Q*(2^j)*(3^k)*(z^2), h*2^n-1)
+        *                    == L(79, h*2^n-1) * L(2^2, h*2^n-1)
+        *                    == L(79, h*2^n-1) * 1
+        *                    == L(h*2^n-1, 79) * (-1)^((h*2^n-2)*(79-1)/4)
+        *                    == L(h*2^n-1, 79) * -1
+        *                    == L(h*2^n-1 mod 79, 79) * -1
+        *                    == J(h*2^n-1 mod 79, 79) * -1
+        *                    == -1 * -1
+        *                    == 1
+        */
+       if (jacobi( ((h*pmod(2,n%(79-1),79)-1)%79), 79 ) == -1 &&
+           jacobi( ((h*pmod(2,n%(83-1),83)-1)%83), 83 ) == 1) {
+               /* return the associated v(1)=81 */
+               return 81;
+       }
+
+       /* no quick and dirty v(1), so return -1 */
+       return -1;
+}
+
+/*
+ * ldebug - print a debug statement
+ *
+ * input:
+ *     funct   name of calling function
+ *     str     string to print
+ */
+define
+ldebug(funct, str)
+{
+       if (lib_debug > 0) {
+               print "DEBUG:", funct:":", str;
+       }
+       return;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "lucas(h, n) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/lucas_chk.cal b/usr/src/contrib/calc-2.9.3t6/lib/lucas_chk.cal
new file mode 100644 (file)
index 0000000..f1ed7a8
--- /dev/null
@@ -0,0 +1,366 @@
+/*
+ * Copyright (c) 1994 Landon Curt Noll
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * By: Landon Curt Noll
+ *     chongo@toad.com  -or-  ...!{pyramid,sun,uunet}!hoptoad!chongo
+ *
+ *
+ * primes of the form h*2^n-1 for 1<=h<200 and 1<=n<1000
+ *
+ * For all 0 <= i < prime_cnt, h_p[i]*2^n_p[i]-1 is prime.
+ *
+ * These values were taken from:
+ *
+ *     "Prime numbers and Computer Methods for Factorization", by Hans Riesel,
+ *     Birkhauser, 1985, pp 384-387.
+ *
+ * This routine assumes that the file "lucas.cal" has been loaded.
+ *
+ * NOTE: There are several errors in Riesel's table that have been corrected
+ *      in this file:
+ *
+ *             193*2^87-1 is prime
+ *             193*2^97-1 is NOT prime
+ *             199*2^211-1 is prime
+ *             199*2^221-1 is NOT prime
+ */
+
+static prime_cnt = 1145;       /* number of primes in the list */
+
+/* h = prime parameters */
+static mat h_p[prime_cnt] = {
+       1, 1, 1, 1, 1, 1, 1, 1, 1, 1,                   /* element 0 */
+       1, 1, 1, 1, 3, 3, 3, 3, 3, 3,
+       3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+       3, 3, 3, 3, 3, 3, 3, 3, 3, 5,
+       5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+       5, 5, 5, 5, 5, 5, 7, 7, 7, 7,
+       7, 7, 7, 7, 9, 9, 9, 9, 9, 9,
+       9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
+       9, 9, 9, 11, 11, 11, 11, 11, 11, 11,
+       11, 11, 11, 13, 13, 13, 13, 13, 13, 15,
+       15, 15, 15, 15, 15, 15, 15, 15, 15, 15,         /* 100 */
+       15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+       15, 15, 17, 17, 17, 17, 17, 17, 17, 17,
+       17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+       17, 17, 19, 19, 19, 19, 19, 19, 19, 19,
+       19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
+       19, 19, 21, 21, 21, 21, 21, 21, 21, 21,
+       21, 21, 21, 21, 21, 21, 21, 21, 23, 23,
+       23, 23, 23, 23, 23, 23, 23, 25, 25, 25,
+       25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+       25, 25, 25, 27, 27, 27, 27, 27, 27, 27,         /* 200 */
+       27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+       27, 27, 27, 27, 27, 27, 27, 29, 29, 29,
+       29, 29, 31, 31, 31, 31, 31, 31, 31, 31,
+       31, 31, 31, 31, 31, 31, 31, 31, 31, 31,
+       33, 33, 33, 33, 33, 33, 33, 33, 33, 33,
+       33, 33, 33, 33, 33, 33, 33, 33, 33, 33,
+       33, 33, 33, 33, 35, 35, 35, 35, 35, 35,
+       35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+       35, 37, 39, 39, 39, 39, 39, 39, 39, 39,
+       39, 41, 41, 41, 41, 41, 41, 41, 41, 41,         /* 300 */
+       41, 41, 41, 41, 43, 43, 43, 43, 43, 45,
+       45, 45, 45, 45, 45, 45, 45, 45, 45, 45,
+       45, 45, 45, 45, 45, 45, 45, 45, 45, 45,
+       45, 45, 45, 45, 45, 45, 45, 45, 45, 45,
+       45, 45, 45, 45, 45, 47, 47, 47, 47, 49,
+       49, 49, 49, 49, 49, 49, 49, 49, 49, 49,
+       49, 49, 49, 49, 49, 49, 51, 51, 51, 51,
+       51, 51, 51, 51, 51, 51, 51, 51, 51, 51,
+       51, 53, 53, 53, 53, 53, 53, 53, 53, 53,
+       53, 55, 55, 55, 55, 55, 55, 55, 55, 55,         /* 400 */
+       55, 55, 55, 55, 55, 55, 55, 55, 55, 55,
+       57, 57, 57, 57, 57, 57, 57, 57, 57, 57,
+       57, 57, 57, 57, 57, 57, 57, 57, 59, 59,
+       59, 59, 59, 59, 61, 61, 61, 61, 61, 61,
+       61, 61, 61, 61, 61, 61, 61, 61, 61, 61,
+       61, 63, 63, 63, 63, 63, 63, 63, 63, 63,
+       63, 63, 63, 63, 63, 63, 63, 63, 63, 63,
+       63, 63, 63, 63, 65, 65, 65, 65, 65, 65,
+       65, 65, 65, 65, 65, 65, 65, 65, 65, 65,
+       65, 65, 67, 67, 67, 67, 67, 67, 67, 67,         /* 500 */
+       69, 69, 69, 69, 69, 69, 69, 69, 69, 69,
+       69, 69, 69, 69, 69, 69, 69, 69, 69, 69,
+       69, 69, 69, 69, 69, 69, 69, 69, 69, 69,
+       69, 69, 71, 71, 71, 73, 73, 73, 73, 73,
+       73, 75, 75, 75, 75, 75, 75, 75, 75, 75,
+       75, 75, 75, 75, 75, 75, 75, 75, 75, 75,
+       75, 75, 75, 75, 75, 75, 75, 77, 77, 77,
+       77, 77, 77, 77, 77, 77, 77, 77, 77, 79,
+       79, 79, 79, 79, 79, 79, 79, 79, 79, 79,
+       81, 81, 81, 81, 81, 81, 81, 81, 81, 81,         /* 600 */
+       81, 81, 81, 83, 83, 83, 83, 83, 83, 83,
+       83, 83, 83, 83, 83, 83, 83, 83, 83, 83,
+       83, 83, 83, 83, 83, 85, 85, 85, 85, 85,
+       85, 85, 85, 85, 87, 87, 87, 87, 87, 87,
+       87, 87, 87, 87, 87, 87, 87, 87, 87, 87,
+       87, 87, 87, 87, 87, 87, 89, 89, 89, 89,
+       89, 89, 89, 89, 89, 91, 91, 91, 91, 91,
+       91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
+       91, 91, 91, 91, 91, 91, 91, 93, 93, 93,
+       93, 93, 93, 93, 93, 93, 93, 93, 93, 93,         /* 700 */
+       93, 93, 93, 93, 93, 95, 95, 95, 95, 95,
+       95, 95, 95, 95, 95, 97, 97, 97, 97, 97,
+       99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
+       99, 99, 99, 99, 99, 99, 101, 101, 101, 101,
+       103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
+       103, 103, 103, 105, 105, 105, 105, 105, 105, 105,
+       105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
+       105, 105, 107, 107, 107, 107, 107, 107, 107, 107,
+       107, 107, 107, 107, 107, 107, 109, 109, 109, 109,
+       109, 113, 113, 113, 113, 113, 113, 113, 113, 113,       /* 800 */
+       113, 115, 115, 115, 115, 115, 115, 115, 115, 115,
+       115, 115, 115, 115, 115, 115, 115, 119, 119, 119,
+       119, 119, 119, 119, 119, 121, 121, 121, 121, 121,
+       121, 121, 121, 121, 121, 121, 121, 125, 125, 125,
+       125, 125, 125, 127, 127, 131, 131, 131, 131, 131,
+       131, 131, 131, 131, 131, 133, 133, 133, 133, 133,
+       133, 133, 133, 133, 133, 133, 133, 133, 137, 137,
+       137, 137, 139, 139, 139, 139, 139, 139, 139, 139,
+       139, 139, 139, 139, 139, 139, 139, 139, 139, 139,
+       139, 139, 139, 139, 139, 139, 139, 139, 139, 143,       /* 900 */
+       143, 143, 143, 143, 143, 143, 143, 143, 143, 143,
+       143, 143, 143, 143, 143, 143, 143, 143, 143, 143,
+       143, 143, 143, 145, 145, 145, 145, 145, 145, 145,
+       145, 145, 145, 145, 149, 149, 149, 149, 149, 149,
+       149, 151, 151, 151, 155, 155, 155, 155, 155, 155,
+       155, 155, 155, 155, 155, 155, 157, 157, 157, 157,
+       157, 157, 157, 157, 157, 161, 161, 161, 161, 161,
+       161, 161, 161, 161, 161, 161, 161, 161, 161, 161,
+       163, 163, 163, 163, 167, 167, 167, 167, 167, 167,
+       167, 167, 167, 167, 167, 167, 169, 169, 169, 169,       /* 1000 */
+       169, 169, 169, 169, 169, 169, 169, 169, 173, 173,
+       173, 173, 173, 173, 173, 173, 173, 173, 173, 173,
+       173, 173, 173, 173, 175, 175, 175, 175, 175, 175,
+       175, 175, 175, 175, 175, 175, 175, 175, 175, 175,
+       179, 179, 179, 181, 181, 181, 181, 181, 181, 181,
+       181, 181, 181, 181, 181, 181, 181, 181, 181, 181,
+       181, 181, 181, 181, 181, 181, 181, 181, 185, 185,
+       185, 185, 185, 185, 185, 185, 185, 185, 187, 187,
+       187, 187, 187, 191, 193, 193, 193, 193, 193, 193,
+       193, 197, 197, 197, 197, 197, 197, 197, 197, 197,       /* 1100 */
+       197, 197, 197, 197, 197, 197, 197, 197, 197, 199,
+       199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
+       199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
+       199, 199, 199, 199, 199
+};
+
+
+/* n (exponent) prime parameters */
+static mat n_p[prime_cnt] = {
+       2, 3, 5, 7, 13, 17, 19, 31, 61, 89,             /* element 0 */
+       107, 127, 521, 607, 1, 2, 3, 4, 6, 7,
+       11, 18, 34, 38, 43, 55, 64, 76, 94, 103,
+       143, 206, 216, 306, 324, 391, 458, 470, 827, 2,
+       4, 8, 10, 12, 14, 18, 32, 48, 54, 72,
+       148, 184, 248, 270, 274, 420, 1, 5, 9, 17,
+       21, 29, 45, 177, 1, 3, 7, 13, 15, 21,
+       43, 63, 99, 109, 159, 211, 309, 343, 415, 469,
+       781, 871, 939, 2, 26, 50, 54, 126, 134, 246,
+       354, 362, 950, 3, 7, 23, 287, 291, 795, 1,
+       2, 4, 5, 10, 14, 17, 31, 41, 73, 80,            /* 100 */
+       82, 116, 125, 145, 157, 172, 202, 224, 266, 289,
+       293, 463, 2, 4, 6, 16, 20, 36, 54, 60,
+       96, 124, 150, 252, 356, 460, 612, 654, 664, 698,
+       702, 972, 1, 3, 5, 21, 41, 49, 89, 133,
+       141, 165, 189, 293, 305, 395, 651, 665, 771, 801,
+       923, 953, 1, 2, 3, 7, 10, 13, 18, 27,
+       37, 51, 74, 157, 271, 458, 530, 891, 4, 6,
+       12, 46, 72, 244, 264, 544, 888, 3, 9, 11,
+       17, 23, 35, 39, 75, 105, 107, 155, 215, 335,
+       635, 651, 687, 1, 2, 4, 5, 8, 10, 14,           /* 200 */
+       28, 37, 38, 70, 121, 122, 160, 170, 253, 329,
+       362, 454, 485, 500, 574, 892, 962, 4, 16, 76,
+       148, 184, 1, 5, 7, 11, 13, 23, 33, 35,
+       37, 47, 115, 205, 235, 271, 409, 739, 837, 887,
+       2, 3, 6, 8, 10, 22, 35, 42, 43, 46,
+       56, 91, 102, 106, 142, 190, 208, 266, 330, 360,
+       382, 462, 503, 815, 2, 6, 10, 20, 44, 114,
+       146, 156, 174, 260, 306, 380, 654, 686, 702, 814,
+       906, 1, 3, 24, 105, 153, 188, 605, 795, 813,
+       839, 2, 10, 14, 18, 50, 114, 122, 294, 362,     /* 300 */
+       554, 582, 638, 758, 7, 31, 67, 251, 767, 1,
+       2, 3, 4, 5, 6, 8, 9, 14, 15, 16,
+       22, 28, 29, 36, 37, 54, 59, 85, 93, 117,
+       119, 161, 189, 193, 256, 308, 322, 327, 411, 466,
+       577, 591, 902, 928, 946, 4, 14, 70, 78, 1,
+       5, 7, 9, 13, 15, 29, 33, 39, 55, 81,
+       95, 205, 279, 581, 807, 813, 1, 9, 10, 19,
+       22, 57, 69, 97, 141, 169, 171, 195, 238, 735,
+       885, 2, 6, 8, 42, 50, 62, 362, 488, 642,
+       846, 1, 3, 5, 7, 15, 33, 41, 57, 69,            /* 400 */
+       75, 77, 131, 133, 153, 247, 305, 351, 409, 471,
+       1, 2, 4, 5, 8, 10, 20, 22, 25, 26,
+       32, 44, 62, 77, 158, 317, 500, 713, 12, 16,
+       72, 160, 256, 916, 3, 5, 9, 13, 17, 19,
+       25, 39, 63, 67, 75, 119, 147, 225, 419, 715,
+       895, 2, 3, 8, 11, 14, 16, 28, 32, 39,
+       66, 68, 91, 98, 116, 126, 164, 191, 298, 323,
+       443, 714, 758, 759, 4, 6, 12, 22, 28, 52,
+       78, 94, 124, 162, 174, 192, 204, 304, 376, 808,
+       930, 972, 5, 9, 21, 45, 65, 77, 273, 677,       /* 500 */
+       1, 4, 5, 7, 9, 11, 13, 17, 19, 23,
+       29, 37, 49, 61, 79, 99, 121, 133, 141, 164,
+       173, 181, 185, 193, 233, 299, 313, 351, 377, 540,
+       569, 909, 2, 14, 410, 7, 11, 19, 71, 79,
+       131, 1, 3, 5, 6, 18, 19, 20, 22, 28,
+       29, 39, 43, 49, 75, 85, 92, 111, 126, 136,
+       159, 162, 237, 349, 381, 767, 969, 2, 4, 14,
+       26, 58, 60, 64, 100, 122, 212, 566, 638, 1,
+       3, 7, 15, 43, 57, 61, 75, 145, 217, 247,
+       3, 5, 11, 17, 21, 27, 81, 101, 107, 327,        /* 600 */
+       383, 387, 941, 2, 4, 8, 10, 14, 18, 22,
+       24, 26, 28, 36, 42, 58, 64, 78, 158, 198,
+       206, 424, 550, 676, 904, 5, 11, 71, 113, 115,
+       355, 473, 563, 883, 1, 2, 8, 9, 10, 12,
+       22, 29, 32, 50, 57, 69, 81, 122, 138, 200,
+       296, 514, 656, 682, 778, 881, 4, 8, 12, 24,
+       48, 52, 64, 84, 96, 1, 3, 9, 13, 15,
+       17, 19, 23, 47, 57, 67, 73, 77, 81, 83,
+       191, 301, 321, 435, 867, 869, 917, 3, 4, 7,
+       10, 15, 18, 19, 24, 27, 39, 60, 84, 111,        /* 700 */
+       171, 192, 222, 639, 954, 2, 6, 26, 32, 66,
+       128, 170, 288, 320, 470, 1, 9, 45, 177, 585,
+       1, 4, 5, 7, 8, 11, 19, 25, 28, 35,
+       65, 79, 212, 271, 361, 461, 10, 18, 54, 70,
+       3, 7, 11, 19, 63, 75, 95, 127, 155, 163,
+       171, 283, 563, 2, 3, 5, 6, 8, 9, 25,
+       32, 65, 113, 119, 155, 177, 299, 335, 426, 462,
+       617, 896, 10, 12, 18, 24, 28, 40, 90, 132,
+       214, 238, 322, 532, 858, 940, 9, 149, 177, 419,
+       617, 8, 14, 74, 80, 274, 334, 590, 608, 614,    /* 800 */
+       650, 1, 3, 11, 13, 19, 21, 31, 49, 59,
+       69, 73, 115, 129, 397, 623, 769, 12, 16, 52,
+       160, 192, 216, 376, 436, 1, 3, 21, 27, 37,
+       43, 91, 117, 141, 163, 373, 421, 2, 4, 44,
+       182, 496, 904, 25, 113, 2, 14, 34, 38, 42,
+       78, 90, 178, 778, 974, 3, 11, 15, 19, 31,
+       59, 75, 103, 163, 235, 375, 615, 767, 2, 18,
+       38, 62, 1, 5, 7, 9, 15, 19, 21, 35,
+       37, 39, 41, 49, 69, 111, 115, 141, 159, 181,
+       201, 217, 487, 567, 677, 765, 811, 841, 917, 2, /* 900 */
+       4, 6, 8, 12, 18, 26, 32, 34, 36, 42,
+       60, 78, 82, 84, 88, 154, 174, 208, 256, 366,
+       448, 478, 746, 5, 13, 15, 31, 77, 151, 181,
+       245, 445, 447, 883, 4, 16, 48, 60, 240, 256,
+       304, 5, 221, 641, 2, 8, 14, 16, 44, 46,
+       82, 172, 196, 254, 556, 806, 1, 5, 33, 121,
+       125, 305, 445, 473, 513, 2, 6, 18, 22, 34,
+       54, 98, 122, 146, 222, 306, 422, 654, 682, 862,
+       3, 31, 63, 303, 4, 6, 8, 10, 16, 32,
+       38, 42, 52, 456, 576, 668, 1, 5, 11, 17,        /* 1000 */
+       67, 137, 157, 203, 209, 227, 263, 917, 2, 4,
+       6, 16, 32, 50, 76, 80, 96, 104, 162, 212,
+       230, 260, 480, 612, 1, 3, 9, 21, 23, 41,
+       47, 57, 69, 83, 193, 249, 291, 421, 433, 997,
+       8, 68, 108, 3, 5, 7, 9, 11, 17, 23,
+       31, 35, 43, 47, 83, 85, 99, 101, 195, 267,
+       281, 363, 391, 519, 623, 653, 673, 701, 2, 6,
+       10, 18, 26, 40, 46, 78, 230, 542, 1, 17,
+       21, 53, 253, 226, 3, 15, 27, 63, 87, 135,
+       543, 2, 16, 20, 22, 40, 82, 112, 178, 230,      /* 1100 */
+       302, 304, 328, 374, 442, 472, 500, 580, 694, 1,
+       5, 7, 15, 19, 23, 25, 27, 43, 65, 99,
+       125, 141, 165, 201, 211, 331, 369, 389, 445, 461,
+       463, 467, 513, 583, 835
+};
+
+
+/* obtain our required libs */
+read -once "lucas.cal";
+
+
+/*
+ * lucas_chk - check the lucas function on known primes
+ *
+ * This function tests entries in the above h_p, n_p table
+ * when n_p is below a given limit.
+ *
+ * input:
+ *     high_n  skip tests on n_p[i] > high_n
+ *     [quiet] if given and != 0, then do not print individual test results
+ *
+ * returns:
+ *     1       all is ok
+ *     0       something went wrong
+ */
+define
+lucas_chk(high_n, quiet)
+{
+       local i;        /* index */
+       local result;   /* 0 => non-prime, 1 => prime, -1 => bad test */
+       local error;    /* number of errors and bad tests found */
+
+       /*
+        * firewall
+        */
+       if (!isint(high_n)) {
+               ldebug("test_lucas", "high_n is non-int");
+               quit "FATAL: bad args: high_n must be an integer";
+       }
+       if (param(0) == 1) {
+               quiet = 0;
+       }
+
+       /*
+        * scan thru the above prime table
+        */
+       error = 0;
+       for (i=0; i < prime_cnt; ++i) {
+
+               /* skip primes where h>=2^n */
+               if (highbit(h_p[i]) >= n_p[i]) {
+                       if (lib_debug > 0) {
+                               print "h>=2^n skip:", h_p[i]:"*2^":n_p[i]:"-1";
+                       }
+                       continue;
+               }
+
+               /* test the prime if it is small enough */
+               if (n_p[i] <= high_n) {
+
+                       /* test the table value */
+                       result = lucas(h_p[i], n_p[i]);
+
+                       /* report the test */
+                       if (result == 0) {
+                               print "ERROR, bad primality test of",\
+                                   h_p[i]:"*2^":n_p[i]:"-1";
+                               ++error;
+                       } else if (result == 1) {
+                               if (quiet == 0) {
+                                       print h_p[i]:"*2^":n_p[i]:"-1 is prime";
+                               }
+                       } else if (result == -1) {
+                               print "ERROR, failed to compute v(1) for",\
+                                   h_p[i]:"*2^":n_p[i]:"-1";
+                               ++error;
+                       } else {
+                               print "ERROR, bogus return value:", result;
+                               ++error;
+                       }
+               }
+       }
+
+       /* return the full status */
+       if (error == 0) {
+               if (quiet == 0) {
+                       print "lucas_chk(":high_n:") passed";
+               }
+               return 1;
+       } else if (error == 1) {
+               print "lucas_chk(":high_n:") failed", error, "test";
+               return 0;
+       } else {
+               print "lucas_chk(":high_n:") failed", error, "tests";
+               return 0;
+       }
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "lucas_chk(high_n) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/lucas_tbl.cal b/usr/src/contrib/calc-2.9.3t6/lib/lucas_tbl.cal
new file mode 100644 (file)
index 0000000..242f060
--- /dev/null
@@ -0,0 +1,143 @@
+/*
+ * Copyright (c) 1993 Landon Curt Noll
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * By: Landon Curt Noll
+ *     chongo@toad.com  -or-  ...!{pyramid,sun,uunet}!hoptoad!chongo
+ *
+ *
+ * Lucasian criteria for primality
+ *
+ * The following table is taken from:
+ *
+ *     "Lucasian Criteria for the Primality of N=h*2^n-1", by Hans Riesel,
+ *     Mathematics of Computation, Vol 23 #108, p 872.
+ *
+ * The index of the *_val[] arrays correspond to the v(1) values found
+ * in the table.  That is, for v(1) == x:
+ *
+ *     D == d_val[x]
+ *     a == a_val[x]
+ *     b == b_val[x]
+ *     r == r_val[x]           (r == abs(a^2 - b^2*D))
+ *
+ *
+ * Note that when *_val[i] is not a number, the related v(1) value
+ * is not found in Table 1.
+ */
+
+trymax = 100;
+mat d_val[trymax+1];
+mat a_val[trymax+1];
+mat b_val[trymax+1];
+mat r_val[trymax+1];
+/* v1= 0           INVALID */
+/* v1= 1           INVALID */
+/* v1= 2           INVALID */
+d_val[ 3]=   5;  a_val[ 3]= 1;  b_val[ 3]=1;  r_val[ 3]=4;
+d_val[ 4]=   3;  a_val[ 4]= 1;  b_val[ 4]=1;  r_val[ 4]=2;
+d_val[ 5]=  21;  a_val[ 5]= 3;  b_val[ 5]=1;  r_val[ 5]=12;
+d_val[ 6]=   2;  a_val[ 6]= 1;  b_val[ 6]=1;  r_val[ 6]=1;
+/* v1= 7           INVALID */
+d_val[ 8]=  15;  a_val[ 8]= 3;  b_val[ 8]=1;  r_val[ 8]=6;
+d_val[ 9]=  77;  a_val[ 9]= 7;  b_val[ 9]=1;  r_val[ 9]=28;
+d_val[10]=   6;  a_val[10]= 2;  b_val[10]=1;  r_val[10]=2;
+d_val[11]=  13;  a_val[11]= 3;  b_val[11]=1;  r_val[11]=4;
+d_val[12]=  35;  a_val[12]= 5;  b_val[12]=1;  r_val[12]=10;
+d_val[13]= 165;  a_val[13]=11;  b_val[13]=1;  r_val[13]=44;
+/* v1=14           INVALID */
+d_val[15]= 221;  a_val[15]=13;  b_val[15]=1;  r_val[15]=52;
+d_val[16]=   7;  a_val[16]= 3;  b_val[16]=1;  r_val[16]=2;
+d_val[17]= 285;  a_val[17]=15;  b_val[17]=1;  r_val[17]=60;
+/* v1=18           INVALID */
+d_val[19]= 357;  a_val[19]=17;  b_val[19]=1;  r_val[19]=68;
+d_val[20]=  11;  a_val[20]= 3;  b_val[20]=1;  r_val[20]=2;
+d_val[21]= 437;  a_val[21]=19;  b_val[21]=1;  r_val[21]=76;
+d_val[22]=  30;  a_val[22]= 5;  b_val[22]=1;  r_val[22]=5;
+/* v1=23           INVALID */
+d_val[24]= 143;  a_val[24]=11;  b_val[24]=1;  r_val[24]=22;
+d_val[25]=  69;  a_val[25]= 9;  b_val[25]=1;  r_val[25]=12;
+d_val[26]=  42;  a_val[26]= 6;  b_val[26]=1;  r_val[26]=6;
+d_val[27]=  29;  a_val[27]= 5;  b_val[27]=1;  r_val[27]=4;
+d_val[28]= 195;  a_val[28]=13;  b_val[28]=1;  r_val[28]=26;
+d_val[29]=  93;  a_val[29]= 9;  b_val[29]=1;  r_val[29]=12;
+d_val[30]=  14;  a_val[30]= 4;  b_val[30]=1;  r_val[30]=2;
+d_val[31]= 957;  a_val[31]=29;  b_val[31]=1;  r_val[31]=116;
+d_val[32]= 255;  a_val[32]=15;  b_val[32]=1;  r_val[32]=30;
+d_val[33]=1085;  a_val[33]=31;  b_val[33]=1;  r_val[33]=124;
+/* v1=34           INVALID */
+d_val[35]=1221;  a_val[35]=33;  b_val[35]=1;  r_val[35]=132;
+d_val[36]= 323;  a_val[36]=17;  b_val[36]=1;  r_val[36]=34;
+d_val[37]=1365;  a_val[37]=35;  b_val[37]=1;  r_val[37]=140;
+d_val[38]=  10;  a_val[38]= 3;  b_val[38]=1;  r_val[38]=1;
+d_val[39]=1517;  a_val[39]=37;  b_val[39]=1;  r_val[39]=148;
+d_val[40]= 399;  a_val[40]=19;  b_val[40]=1;  r_val[40]=38;
+d_val[41]=1677;  a_val[41]=39;  b_val[41]=1;  r_val[41]=156;
+d_val[42]= 110;  a_val[42]=10;  b_val[42]=1;  r_val[42]=10;
+d_val[43]= 205;  a_val[43]=15;  b_val[43]=1;  r_val[43]=20;
+d_val[44]= 483;  a_val[44]=21;  b_val[44]=1;  r_val[44]=42;
+d_val[45]=2021;  a_val[45]=43;  b_val[45]=1;  r_val[45]=172;
+d_val[46]=  33;  a_val[46]= 6;  b_val[46]=1;  r_val[46]=3;
+/* v1=47           INVALID */
+d_val[48]=  23;  a_val[48]= 5;  b_val[48]=1;  r_val[48]=2;
+d_val[49]=2397;  a_val[49]=47;  b_val[49]=1;  r_val[49]=188;
+d_val[50]=  39;  a_val[50]= 6;  b_val[50]=1;  r_val[50]=3;
+d_val[51]=  53;  a_val[51]= 7;  b_val[51]=1;  r_val[51]=4;
+/* v1=52           INVALID */
+d_val[53]=2805;  a_val[53]=51;  b_val[53]=1;  r_val[53]=204;
+d_val[54]= 182;  a_val[54]=13;  b_val[54]=1;  r_val[54]=13;
+d_val[55]=3021;  a_val[55]=53;  b_val[55]=1;  r_val[55]=212;
+d_val[56]=  87;  a_val[56]= 9;  b_val[56]=1;  r_val[56]=6;
+d_val[57]=3245;  a_val[57]=55;  b_val[57]=1;  r_val[57]=220;
+d_val[58]= 210;  a_val[58]=14;  b_val[58]=1;  r_val[58]=14;
+d_val[59]=3477;  a_val[59]=57;  b_val[59]=1;  r_val[59]=228;
+d_val[60]= 899;  a_val[60]=29;  b_val[60]=1;  r_val[60]=58;
+d_val[61]= 413;  a_val[61]=21;  b_val[61]=1;  r_val[61]=28;
+/* v1=62           INVALID */
+d_val[63]=3965;  a_val[63]=61;  b_val[63]=1;  r_val[63]=244;
+d_val[64]=1023;  a_val[64]=31;  b_val[64]=1;  r_val[64]=62;
+d_val[65]= 469;  a_val[65]=21;  b_val[65]=1;  r_val[65]=28;
+d_val[66]=  17;  a_val[66]= 4;  b_val[66]=1;  r_val[66]=1;
+d_val[67]=4485;  a_val[67]=65;  b_val[67]=1;  r_val[67]=260;
+d_val[68]=1155;  a_val[68]=33;  b_val[68]=1;  r_val[68]=66;
+d_val[69]=4757;  a_val[69]=67;  b_val[69]=1;  r_val[69]=268;
+d_val[70]=  34;  a_val[70]= 6;  b_val[70]=1;  r_val[70]=2;
+d_val[71]=5037;  a_val[71]=69;  b_val[71]=1;  r_val[71]=276;
+d_val[72]=1295;  a_val[72]=35;  b_val[72]=1;  r_val[72]=70;
+d_val[73]= 213;  a_val[73]=15;  b_val[73]=1;  r_val[73]=12;
+d_val[74]=  38;  a_val[74]= 6;  b_val[74]=1;  r_val[74]=2;
+d_val[75]=5621;  a_val[75]=73;  b_val[75]=1;  r_val[75]=292;
+d_val[76]=1443;  a_val[76]=37;  b_val[76]=1;  r_val[76]=74;
+d_val[77]= 237;  a_val[77]=15;  b_val[77]=1;  r_val[77]=12;
+d_val[78]=  95;  a_val[78]=10;  b_val[78]=1;  r_val[78]=5;
+/* v1=79           INVALID */
+d_val[80]=1599;  a_val[80]=39;  b_val[80]=1;  r_val[80]=78;
+d_val[81]=6557;  a_val[81]=79;  b_val[81]=1;  r_val[81]=316;
+d_val[82]= 105;  a_val[82]=10;  b_val[82]=1;  r_val[82]=5;
+d_val[83]=  85;  a_val[83]= 9;  b_val[83]=1;  r_val[83]=4;
+d_val[84]=1763;  a_val[84]=41;  b_val[84]=1;  r_val[84]=82;
+d_val[85]=7221;  a_val[85]=83;  b_val[85]=1;  r_val[85]=332;
+d_val[86]= 462;  a_val[86]=21;  b_val[86]=1;  r_val[86]=21;
+d_val[87]=7565;  a_val[87]=85;  b_val[87]=1;  r_val[87]=340;
+d_val[88]= 215;  a_val[88]=15;  b_val[88]=1;  r_val[88]=10;
+d_val[89]=7917;  a_val[89]=87;  b_val[89]=1;  r_val[89]=348;
+d_val[90]= 506;  a_val[90]=22;  b_val[90]=1;  r_val[90]=22;
+d_val[91]=8277;  a_val[91]=89;  b_val[91]=1;  r_val[91]=356;
+d_val[92]= 235;  a_val[92]=15;  b_val[92]=1;  r_val[92]=10;
+d_val[93]=8645;  a_val[93]=91;  b_val[93]=1;  r_val[93]=364;
+d_val[94]= 138;  a_val[94]=12;  b_val[94]=1;  r_val[94]=6;
+d_val[95]=9021;  a_val[95]=93;  b_val[95]=1;  r_val[95]=372;
+d_val[96]=  47;  a_val[96]= 7;  b_val[96]=1;  r_val[96]=2;
+d_val[97]=1045;  a_val[97]=33;  b_val[97]=1;  r_val[97]=44;
+/* v1=98           INVALID */
+d_val[99]=9797;  a_val[99]=97;  b_val[99]=1;  r_val[99]=388;
+d_val[100]=  51; a_val[100]= 7; b_val[100]=1; r_val[100]=2;
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "d_val[100] defined";
+    print "a_val[100] defined";
+    print "b_val[100] defined";
+    print "r_val[100] defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/mersenne.cal b/usr/src/contrib/calc-2.9.3t6/lib/mersenne.cal
new file mode 100644 (file)
index 0000000..e87bc70
--- /dev/null
@@ -0,0 +1,44 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Perform a primality test of 2^p-1, for prime p>1.
+ */
+
+define mersenne(p)
+{
+       local u, i, p_mask;
+
+       /* firewall */
+       if (! isint(p))
+               quit "p is not an integer";
+
+       /* two is a special case */
+       if (p == 2)
+               return 1;
+
+       /* if p is not prime, then 2^p-1 is not prime */
+       if (! ptest(p,10))
+               return 0;
+
+       /* calculate 2^p-1 for later mods */
+       p_mask = 2^p - 1;
+
+       /* lltest: u(i+1) = u(i)^2 - 2 mod 2^p-1 */
+       u = 4;
+       for (i = 2; i < p; ++i) {
+               u = u^2 - 2;
+               u = u&p_mask + u>>p;
+               if (u > p_mask)
+                       u = u&p_mask + 1;
+       }
+
+       /* 2^p-1 is prime iff u(p) = 0 mod 2^p-1 */
+       return (u == p_mask);
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "mersenne(p) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/mod.cal b/usr/src/contrib/calc-2.9.3t6/lib/mod.cal
new file mode 100644 (file)
index 0000000..3b7b562
--- /dev/null
@@ -0,0 +1,211 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Routines to handle numbers modulo a specified number.
+ *     a (mod N)
+ */
+
+obj mod {a};                   /* definition of the object */
+
+global mod_value = 100;                /* modulus value (value of N) */
+
+
+define mod(a)
+{
+       local obj mod   x;
+
+       if (!isreal(a) || !isint(a))
+               quit "Bad argument for mod function";
+       x.a = a % mod_value;
+       return x;
+}
+
+
+define mod_print(a)
+{
+       if (digits(mod_value) <= 20)
+               print a.a, "(mod", mod_value : ")" :;
+       else
+               print a.a, "(mod N)" :;
+}
+
+
+define mod_one()
+{
+       return mod(1);
+}
+
+
+define mod_cmp(a, b)
+{
+       if (isnum(a))
+               return (a % mod_value) != b.a;
+       if (isnum(b))
+               return (b % mod_value) != a.a;
+       return a.a != b.a;
+}
+
+
+define mod_rel(a, b)
+{
+       if (isnum(a))
+               a = mod(a);
+       if (isnum(b))
+               b = mod(b);
+       if (a.a < b.a)
+               return -1;
+       return a.a != b.a;
+}
+
+
+define mod_add(a, b)
+{
+       local obj mod   x;
+
+       if (isnum(b)) {
+               if (!isint(b))
+                       quit "Adding non-integer";
+               x.a = (a.a + b) % mod_value;
+               return x;
+       }
+       if (isnum(a)) {
+               if (!isint(a))
+                       quit "Adding non-integer";
+               x.a = (a + b.a) % mod_value;
+               return x;
+       }
+       x.a = (a.a + b.a) % mod_value;
+       return x;
+}
+
+
+define mod_sub(a, b)
+{
+       return a + (-b);
+}
+
+
+define mod_neg(a)
+{
+       local obj mod   x;
+
+       x.a = mod_value - a.a;
+       return x;
+}
+
+
+define mod_mul(a, b)
+{
+       local obj mod   x;
+
+       if (isnum(b)) {
+               if (!isint(b))
+                       quit "Multiplying by non-integer";
+               x.a = (a.a * b) % mod_value;
+               return x;
+       }
+       if (isnum(a)) {
+               if (!isint(a))
+                       quit "Multiplying by non-integer";
+               x.a = (a * b.a) % mod_value;
+               return x;
+       }
+       x.a = (a.a * b.a) % mod_value;
+       return x;
+}
+
+
+define mod_square(a)
+{
+       local obj mod   x;
+
+       x.a = a.a^2 % mod_value;
+       return x;
+}
+
+
+define mod_inc(a)
+{
+       local x;
+
+       x = a;
+       if (++x.a == mod_value)
+               x.a = 0;
+       return x;
+}
+
+
+define mod_dec(a)
+{
+       local x;
+
+       x = a;
+       if (--x.a < 0)
+               x.a = mod_value - 1;
+       return x;
+}
+
+
+define mod_inv(a)
+{
+       local obj mod   x;
+
+       x.a = minv(a.a, mod_value);
+       return x;
+}
+
+
+define mod_div(a, b)
+{
+       local c, x, y;
+
+       obj mod x, y;
+       if (isnum(a))
+               a = mod(a);
+       if (isnum(b))
+               b = mod(b);
+       c = gcd(a.a, b.a);
+       x.a = a.a / c;
+       y.a = b.a / c;
+       return x * inverse(y);
+}
+
+
+define mod_pow(a, b)
+{
+       local x, y, z;
+
+       obj mod x;
+       y = a;
+       z = b;
+       if (b < 0) {
+               y = inverse(a);
+               z = -b;
+       }
+       x.a = pmod(y.a, z, mod_value);
+       return x;
+}
+
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "obj mod {a} defined";
+    print "mod(a) defined";
+    print "mod_print(a) defined";
+    print "mod_one(a) defined";
+    print "mod_cmp(a, b) defined";
+    print "mod_rel(a, b) defined";
+    print "mod_add(a, b) defined";
+    print "mod_sub(a, b) defined";
+    print "mod_mod(a, b) defined";
+    print "mod_square(a) defined";
+    print "mod_inc(a) defined";
+    print "mod_dec(a) defined";
+    print "mod_inv(a) defined";
+    print "mod_div(a, b) defined";
+    print "mod_pow(a, b) defined";
+    print "mod_value defined";
+    print "set mod_value as needed";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/nextprim.cal b/usr/src/contrib/calc-2.9.3t6/lib/nextprim.cal
new file mode 100644 (file)
index 0000000..a7d0e8f
--- /dev/null
@@ -0,0 +1,23 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Function to find the next prime (probably).
+ */
+
+define nextprime(n, tries)
+{
+       if (isnull(tries))
+               tries = 20;
+       if (iseven(n))
+               n++;
+       while (ptest(n, tries) == 0)
+               n += 2;
+       return n;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "nextprime(n, tries) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/pell.cal b/usr/src/contrib/calc-2.9.3t6/lib/pell.cal
new file mode 100644 (file)
index 0000000..8986ce4
--- /dev/null
@@ -0,0 +1,74 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Solve Pell's equation; Returns the solution X to: X^2 - D * Y^2 = 1.
+ * Type the solution to pells equation for a particular D.
+ */
+
+define pell(D)
+{
+       local X, Y;
+
+       X = pellx(D);
+       if (isnull(X)) {
+               print "D=":D:" is square";
+               return;
+       }
+       Y = isqrt((X^2 - 1) / D);
+       print X : "^2 - " : D : "*" : Y : "^2 = " : X^2 - D*Y^2;
+}
+
+
+/*
+ * Function to solve Pell's equation
+ * Returns the solution X to:
+ *     X^2 - D * Y^2 = 1
+ */
+define pellx(D)
+{
+       local R, Rp, U, Up, V, Vp, A, T, Q1, Q2, n;
+       local mat ans[2,2];
+       local mat tmp[2,2];
+
+       R = isqrt(D);
+       Vp = D - R^2;
+       if (Vp == 0)
+               return;
+       Rp = R + R;
+       U = Rp;
+       Up = U;
+       V = 1;
+       A = 0;
+       n = 0;
+       ans[0,0] = 1;
+       ans[1,1] = 1;
+       tmp[0,1] = 1;
+       tmp[1,0] = 1;
+       do {
+               T = V;
+               V = A * (Up - U) + Vp;
+               Vp = T;
+               A = U // V;
+               Up = U;
+               U = Rp - U % V;
+               tmp[0,0] = A;
+               ans *= tmp;
+               n++;
+       } while (A != Rp);
+       Q2 = ans[[1]];
+       Q1 = isqrt(Q2^2 * D + 1);
+       if (isodd(n)) {
+               T = Q1^2 + D * Q2^2;
+               Q2 = Q1 * Q2 * 2;
+               Q1 = T;
+       }
+       return Q1;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "pell(D) defined";
+    print "pellx(D) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/pi.cal b/usr/src/contrib/calc-2.9.3t6/lib/pi.cal
new file mode 100644 (file)
index 0000000..fdf965f
--- /dev/null
@@ -0,0 +1,54 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Calculate pi within the specified epsilon using the quartic convergence
+ * iteration.
+ */
+
+define qpi(epsilon)
+{
+       local niter, yn, ym, tm, an, am, t, tn, sqrt2, epsilon2, count, digits;
+       local bits, bits2;
+
+       if (isnull(epsilon))
+               epsilon = epsilon();
+       digits = digits(1/epsilon);
+       if      (digits <=  8) { niter = 1; epsilon =   1e-8; }
+       else if (digits <= 40) { niter = 2; epsilon =  1e-40; }
+       else if (digits <= 170) { niter = 3; epsilon = 1e-170; }
+       else if (digits <= 693) { niter = 4; epsilon = 1e-693; }
+       else {
+               niter = 4;
+               t = 693;
+               while (t < digits) {
+                       ++niter;
+                       t *= 4;
+               }
+       }
+       epsilon2 = epsilon/(digits/10 + 1);
+       digits = digits(1/epsilon2);
+       sqrt2 = sqrt(2, epsilon2);
+       bits = abs(ilog2(epsilon)) + 1;
+       bits2 = abs(ilog2(epsilon2)) + 1;
+       yn = sqrt2 - 1;
+       an = 6 - 4 * sqrt2;
+       tn = 2;
+       for (count = 0; count < niter; count++) {
+               ym = yn;
+               am = an;
+               tn *= 4;
+               t = sqrt(sqrt(1-ym^4, epsilon2), epsilon2);
+               yn = (1-t)/(1+t);
+               an = (1+yn)^4*am-tn*yn*(1+yn+yn^2);
+               yn = bround(yn, bits2);
+               an = bround(an, bits2);
+       }
+       return (bround(1/an, bits));
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "qpi(epsilon) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/pollard.cal b/usr/src/contrib/calc-2.9.3t6/lib/pollard.cal
new file mode 100644 (file)
index 0000000..26195b4
--- /dev/null
@@ -0,0 +1,35 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Factor using Pollard's p-1 method.
+ */
+
+define factor(N, B, ai, af)
+{
+       local   a, k, i, d;
+
+       if (isnull(B))
+               B = 1000;
+       if (isnull(ai))
+               ai = 2;
+       if (isnull(af))
+               af = ai + 20;
+       k = lcmfact(B);
+       d = lfactor(N, B);
+       if (d > 1)
+               return d;
+       for (a = ai; a <= af; a++) {
+               i = pmod(a, k, N);
+               d = gcd(i - 1, N);
+               if ((d > 1) && (d != N))
+                       return d;
+       }
+       return 1;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "factor(N, B, ai, af) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/poly.cal b/usr/src/contrib/calc-2.9.3t6/lib/poly.cal
new file mode 100644 (file)
index 0000000..d64f80f
--- /dev/null
@@ -0,0 +1,728 @@
+/* 
+ * A collection of functions designed for calculations involving
+ *     polynomials in one variable (by Ernest W. Bowen).
+ *
+ * On starting the program the independent variable has identifier x
+ *     and name "x", i.e. the user can refer to it as x, the
+ *     computer displays it as "x".  The name of the independent
+ *     variable is stored as varname, so, for example, varname = "alpha"
+ *     will change its name to "alpha".  At any time, the independent
+ *     variable has only one name.  For some purposes, a name like
+ *     "sin(t)" or "(a + b)" or "\lambda" might be useful;
+ *     names like "*" or "-27" are legal but might give expressions
+ *     that are difficult to intepret.
+ *
+ * Polynomial expressions may be constructed from numbers and the
+ *     independent variable and other polynomials by the algebraic
+ *     operations +, -, *, ^, and if the result is a polynomial /.
+ *     The operations // and % are defined to have the quotient and
+ *     remainder meanings as usually defined for polynomials.
+ *
+ * When polynomials are assigned to idenfifiers, it is convenient to
+ *     think of the polynomials as values.  For example, p = (x - 1)^2
+ *     assigns to p a polynomial value in the same way as q = (7 - 1)^2
+ *     would assign to q a number value.  As with number expressions
+ *     involving operations, the expression used to define the
+ *     polynomial is usually lost; in the above example, the normal
+ *     computer display for p will be  x^2 - 2x + 1.  Different
+ *     identifiers may of course have the same polynomial value.
+ * 
+ * The polynomial we think of as a_0 + a_1 * x + ... + a_n * x^n,
+ *     for number coefficients a_0, a_1, ... a_n may also be
+ *     constructed as pol(a_0, a_1, ..., a_n).  Note that here the
+ *     coefficients are to be in ascending power order.  The independent
+ *     variable is pol(0,1), so to use t, say, as an identifier for
+ *     this, one may assign  t = pol(0,1).  To simultaneously specify
+ *     an identifier and a name for the independent variable, there is
+ *     the instruction var, used as in identifier = var(name).  For
+ *     example, to use "t" in the way "x" is initially, one may give
+ *     the instruction  t = var("t").
+ *
+ * There are four parameters pmode, order, iod and ims for controlling
+ *     the format in which polynomials are displayed.
+ *     The parameter pmode may have values "alg" or "list": the
+ *     former gives a display as an algebraic formula, while
+ *     the latter only lists the coefficients.  Whether the terms or
+ *     coefficients are in ascending or descending power order is
+ *     controlled by order being "up" or "down".  If the
+ *     parameter iod (for integer-only display), the polynomial
+ *     is expressed in terms of a polynomial whose coefficients are
+ *     integers with gcd = 1, the leading coefficient having positive
+ *     real part, with where necessary a leading multiplying integer,
+ *     a Gaussian integer multiplier if the coefficients are complex
+ *     with a common complex factor, and a trailing divisor integer.
+ *     If a non-zero value is assigned to the parameter ims,
+ *     multiplication signs will be inserted where appropriate;
+ *     this may be useful if the expression is to be copied to a
+ *     program or a string to be used with eval. 
+ *
+ * For evaluation of polynomials the standard function is ev(p, t).
+ *     If p is a polynomial and t anything for which the relevant
+ *     operations can be performed, this returns the value of p
+ *     at t.  The function ev(p, t) also accepts lists or matrices
+ *     as possible values for p; each element of p is then evaluated
+ *     at t.  For other p, t is ignored and the value of p is returned.
+ *     If an identifier, a, say, is used for the polynomial, list or
+ *     matrix p, the definition
+ *                     define a(t) = ev(a, t);
+ *     permits a(t) to be used for the value of a at t as if the
+ *     polynomial, list or matrix were a function.  For example,
+ *     if a = 1 + x^2, a(2) will return the value 5, just as if
+ *                     define a(t) = 1 + t^2;
+ *     had been used.   However, when the polynomial definition is
+ *     used, changing the polynomial a will change a(t) to the value
+ *     of the new polynomial at t.  For example,
+ *     after 
+ *             L = list(x, x^2, x^3, x^4);
+               define a(t) = ev(a, t);
+ *     the loop
+ *             for (i = 0; i < 4; i++)
+ *                     print ev(L[[i]], 5);
+ *     may be replaced by
+ *             for (i = 0; i < 4; i++) {
+ *                     a = L[[i]];
+ *                     print a(5);
+ *             } 
+ *      
+ * Matrices with polynomial elements may be added, subtracted and
+ *     multiplied as long as the usual rules for compatibility are
+ *     observed.  Also, matrices may be multiplied by polynomials,
+ *     i.e. if p is a  polynomial and A a matrix whose elements
+ *     may be numbers or polynomials, p * A returns the matrix of
+ *     the same shape as A with each element multiplied by p.
+ *     Square matrices may also be 'substituted for the variable' in
+ *     polynomials, e.g. if A is an m x m matrix, and
+ *     p = x^2 + 3 * x + 2, ev(p, A) returns the same as
+ *     A^2 + 3 * A + 2 * I, where I is the unit m x m matrix.  
+ *     
+ * On starting this program, three demonstration polynomials a, b, c
+ *     have been defined.  The functions a(t), b(t), c(t) corresponding
+ *     to a, b, c, and x(t) corresponding to x, have also been
+ *     defined, so the usual function notation can be used for
+ *     evaluations of a, b, c and x.  For x, as long as x identifies
+ *     the independent variable, x(t) should return the value of t,
+ *     i.e. it acts as an identity function.
+ *     
+ * Functions defined include:
+ *
+ *     monic(a) returns the monic multiple of a, i.e., if a != 0,
+ *             the multiple of a with leading coefficient 1    
+ *     conj(a) returns the complex conjugate of a
+ *     ispmult(a,b) returns 1 or 0 according as a is or is not
+ *             a polynomial multiple of b
+ *     pgcd(a,b) returns the monic gcd of a and b 
+ *     pfgcd(a,b) returns a list of three polynomials (g, u, v)
+ *             where g = pgcd(a,b) and g = u * a + v * b.
+ *     plcm(a,b) returns the monic lcm of a and b
+ *
+ *     interp(X,Y,t) returns the value at t of the polynomial given
+ *             by Newtonian divided difference interpolation, where
+ *             X is a list of x-values, Y a list of corresponding
+ *             y-values.  If t is omitted, the interpolating
+ *             polynomial is returned.  A y-value may be replaced by
+ *             list (y, y_1, y_2, ...), where y_1, y_2, ... are
+ *             the reduced derivatives at the corresponding x;
+ *             i.e. y_r is the r-th derivative divided by fact(r).
+ *     mdet(A) returns the determinant of the square matrix A,
+ *             computed by an algorithm that does not require
+ *             inverses;  the built-in det function usually fails
+ *             for matrices with polynomial elements.  
+ *     D(a,n) returns the n-th derivative of a; if n is omitted,
+ *             the first derivative is returned.
+ *
+ * A first-time user can see what the initially defined polynomials
+ *     a, b and c are, and experiment with the algebraic operations
+ *     and other functions that have been defined by giving
+ *     instructions like:
+ *                     a
+ *                     b
+ *                     c
+ *                     (x^2 + 1) * a
+ *                     a^27
+ *                     a * b   
+ *                     a % b
+ *                     a // b
+ *                     a(1 + x)
+ *                     a(b)
+ *                     conj(c)
+ *                     g = pgcd(a, b)
+ *                     g
+ *                     a / g
+ *                     D(a)
+ *                     mat A[2,2] = {1 + x, x^2, 3, 4*x}
+ *                     mdet(A)
+ *                     D(A)
+ *                     A^2
+ *                     define A(t) = ev(A, t)
+ *                     A(2)
+ *                     A(1 + x)
+ *                     define L(t) = ev(L, t)
+ *                     L = list(x, x^2, x^3, x^4)
+ *                     L(5)
+ *                     a(L)
+ *                     interp(list(0,1,2,3), list(2,3,5,7))
+ *                     interp(list(0,1,2), list(0,list(1,0),2))
+ *
+ * One check on some of the functions is provided by the Cayley-Hamilton
+ *     theorem:  if A is any m x m matrix and I the m x m unit matrix,
+ *     and x is pol(0,1),
+ *                     ev(mdet(x * I - A), A)
+ *     should return the zero m x m matrix.
+ */
+
+obj poly {p};
+
+define pol() {
+       local u,i,s;
+       obj poly u;
+       s = list();
+       for (i=1; i<= param(0); i++) append (s,param(i));
+       i=size(s) -1;
+       while (i>=0 && s[[i]]==0) {i--; remove(s)}
+       u.p = s;
+       return u;
+}
+
+define ispoly(a) {
+       local y;
+       obj poly y;
+       return istype(a,y);
+}
+
+define findlist(a) {
+       if (ispoly(a)) return a.p;
+       if (a) return list(a);
+       return list();
+}
+
+pmode = "alg"; /* The other acceptable pmode is "list" */
+ims = 0;       /* To be non-zero if multiplication signs to be inserted */
+iod = 0;       /* To be non-zero for integer-only display */
+order = "down" /* Determines order in which coefficients displayed */
+
+define poly_print(a) {
+       local f, g, t;
+       if (size(a.p) == 0) {
+               print 0:;
+               return;
+       } 
+       if (iod) {
+               g = gcdcoeffs(a);
+               t = a.p[[size(a.p) - 1]] / g;
+               if (re(t) < 0) { t = -t; g = -g;}
+               if (g != 1) {
+                       if (!isreal(t)) {
+                               if (im(t) > re(t)) g *= 1i;
+                               else if (im(t) <= -re(t)) g *= -1i;
+                       }
+                       if (isreal(g)) f = g;
+                       else f = gcd(re(g), im(g));
+                       if (num(f) != 1) {
+                               print num(f):;
+                               if (ims) print"*":;
+                       }
+                       if (!isreal(g)) {
+                               printf("(%d)", g/f);
+                               if (ims) print"*":;
+                       }
+                       if (pmode == "alg") print"(":;
+                       polyprint(1/g * a);
+                       if (pmode == "alg") print")":;
+                       if (den(f) > 1) print "/":den(f):;
+                       return;
+               }
+       }
+       polyprint(a);
+}
+
+define polyprint(a) {
+       local s,n,i,c;
+       s = a.p;
+       n=size(s) - 1;
+       if (pmode=="alg") {
+               if (order == "up") {
+                       i = 0;
+                       while (!s[[i]]) i++;
+                       pterm (s[[i]], i);
+                       for (i++ ; i <= n; i++) {
+                               c = s[[i]];
+                               if (c) {
+                                       if (isreal(c)) {
+                                               if (c > 0) print" + ":;
+                                               else {
+                                                       print" - ":;
+                                                       c = -c;
+                                               }
+                                       } 
+                                       else print " + ":;
+                                       pterm(c,i);
+                               }
+                       }
+                       return;
+               }
+               if (order == "down") {
+                       pterm(s[[n]],n);
+                       for (i=n-1; i>=0; i--) {
+                               c = s[[i]];
+                               if (c) {
+                                       if (isreal(c)) {
+                                               if (c > 0) print" + ":;
+                                               else {
+                                                       print" - ":;
+                                                       c = -c;
+                                               }
+                                       } 
+                                       else print " + ":;
+                                       pterm(c,i);
+                               }
+                       }
+                       return;
+               }
+               quit "order to be up or down";
+       }
+       if (pmode=="list") {
+               plist(s);
+               return;
+       }
+       print pmode,:"is unknown mode";
+}
+               
+
+define poly_neg(a) {
+       local s,i,y;
+       obj poly y;
+       s = a.p;
+       for (i=0; i< size(s); i++) s[[i]] = -s[[i]];
+       y.p = s;
+       return y;
+}
+
+define poly_conj(a) {
+       local s,i,y;
+       obj poly y;
+       s = a.p;
+       for (i=0; i < size(s); i++) s[[i]] = conj(s[[i]]);
+       y.p = s;
+       return y;
+}
+
+define poly_inv(a) = pol(1)/a; /* This exists only for a of zero degree */
+
+define poly_add(a,b) {
+       local sa, sb, i, y;
+       obj poly y;
+       sa=findlist(a); sb=findlist(b);
+       if (size(sa) > size(sb)) swap(sa,sb);
+       for (i=0; i< size(sa); i++) sa[[i]] += sb[[i]]; 
+       while (i < size(sb)) append (sa, sb[[i++]]);
+       while (i > 0 && sa[[--i]]==0) remove (sa);
+       y.p = sa;
+       return y;
+}
+
+define poly_sub(a,b) {
+        return a + (-b);
+}
+
+define poly_cmp(a,b) {
+       local sa, sb;
+       sa = findlist(a);
+       sb=findlist(b);
+       return  (sa != sb);
+}
+
+define poly_mul(a,b) {
+       local sa,sb,i, j, y;
+       if (ismat(a)) swap(a,b);
+       if (ismat(b)) {
+               y = b;
+               for (i=matmin(b,1); i <= matmax(b,1); i++)
+                       for (j = matmin(b,2); j<= matmax(b,2); j++)
+                               y[i,j] = a * b[i,j];
+               return y;       
+       }
+       obj poly y;
+       sa=findlist(a); sb=findlist(b);
+       y.p = listmul(sa,sb);
+       return y;
+} 
+
+define listmul(a,b) {
+       local da,db, s, i, j, u;
+       da=size(a)-1; db=size(b)-1;
+       s=list();
+       if (da >= 0 && db >= 0) {
+               for (i=0; i<= da+db; i++) { u=0;
+                       for (j = max(0,i-db); j <= min(i, da); j++)
+                       u += a[[j]]*b[[i-j]]; append (s,u);}}
+       return s;
+}
+
+define ev(a,t) {
+       local v, i, j;
+       if (ismat(a)) {
+               v = a;
+               for (i = matmin(a,1); i <= matmax(a,1); i++)
+                       for (j = matmin(a,2); j <= matmax(a,2); j++)
+                               v[i,j] = ev(a[i,j], t);
+               return v;
+       }
+       if (islist(a)) {
+               v = list();
+               for (i = 0; i < size(a); i++)
+                       append(v, ev(a[[i]], t));
+               return v;
+       }
+       if (!ispoly(a)) return a;
+       if (islist(t)) {
+               v = list();
+               for (i = 0; i < size(t); i++)
+                       append(v, ev(a, t[[i]]));
+               return v;
+       }       
+       if (ismat(t)) return evpm(a.p, t);
+       return evp(a.p, t); 
+}
+
+define evp(s,t) {
+       local n,v,i;
+       n = size(s);
+       if (!n) return 0;
+       v = s[[n-1]];
+       for (i = n - 2; i >= 0; i--) v=t * v +s[[i]];
+       return v;
+}
+
+define evpm(s,t) {
+       local m, n, V, i, I;
+       n = size(s);
+       m = matmax(t,1) - matmin(t,1);
+       if (matmax(t,2) - matmin(t,2) != m) quit "Non-square matrix";
+       mat V[m+1, m+1];
+       if (!n) return V;
+       mat I[m+1, m+1];
+       matfill(I, 0, 1);
+       V = s[[n-1]] * I;
+       for (i = n - 2; i >= 0; i--) V = t * V + s[[i]] * I;
+       return V;
+}
+pzero = pol(0);
+x = pol(0,1); 
+varname = "x";
+define x(t) = ev(x, t);
+
+define iszero(a) {
+       if (ispoly(a))
+               return !size(a.p);
+       return a == 0;
+}
+
+define isstring(a) = istype(a, " ");
+
+define var(name) {
+       if (!isstring(name)) quit "Argument of var is to be a string";
+       varname = name;
+       return pol(0,1);
+}
+
+define pcoeff(a) {
+               if (isreal(a)) print a:;
+               else print "(":a:")":;
+}
+
+define pterm(a,n) {
+       if (n==0) {
+               pcoeff(a);
+               return;
+       }
+       if (n==1) {
+               if (a!=1) {
+                       pcoeff(a);
+                       if (ims) print"*":;
+               }
+               print varname:;
+               return;
+       }
+       if (a!=1) {
+               pcoeff(a);
+               if (ims) print"*":;
+       }
+       print varname:"^":n:;
+} 
+
+define plist(s) {
+       local i, n;
+       n = size(s);
+       print "( ":;
+       if (order == "up") {
+               for (i=0; i< n-1 ; i++)
+                       print s[[i]]:",",:;
+               if (n) print s[[i]],")":;
+               else print "0 )":;
+       }
+       else {
+               if (n) print s[[n-1]]:;
+               for (i = n - 2; i >= 0; i--)
+                       print ", ":s[[i]]:;
+               print " )":;
+       }
+}
+
+define deg(a) = size(a.p) - 1;
+
+define polydiv(a,b) {
+       local q, r, d, u, i, m, n, sa, sb, sq;
+       obj poly q, r;
+       sa=findlist(a); sb = findlist(b); sq = list();
+       m=size(sa)-1; n=size(sb)-1;
+       if (n<0) quit "Zero divisor";
+       if (m<n) return list(pzero, a);
+       d = sb[[n]]; 
+       while ( m >= n) { u = sa[[m]]/d;
+               for (i = 0; i< n; i++) sa[[m-n+i]] -= u*sb[[i]];
+               push(sq,u); remove(sa); m--;
+               while (m>=n && sa[[m]]==0) { m--; remove(sa); push(sq,0)}}
+       while (m>=0 && sa[[m]]==0) { m--; remove(sa);}
+       q.p = sq;  r.p = sa;
+       return list(q, r);}
+               
+define poly_mod(a,b)  {
+       local u;
+       u=polydiv(a,b);
+       return u[[1]];
+}
+
+define poly_quo(a,b) {
+       local p;
+       p = polydiv(a,b);
+       return p[[0]];
+}
+
+define ispmult(a,b) = iszero(a % b);
+
+define poly_div(a,b) {
+       if (!ispmult(a,b)) quit "Result not a polynomial";
+       return poly_quo(a,b);
+}
+
+define pgcd(a,b) {
+       local r;
+       if (iszero(a) && iszero(b)) return pzero;
+       while (!iszero(b)) {
+               r = a % b;
+               a = b;
+               b = r;
+       }
+       return monic(a);
+}
+
+define plcm(a,b) = monic( a * b // pgcd(a,b));
+  
+define pfgcd(a,b) {
+       local u, v, u1, v1, s, q, r, d, w;
+       u = v1 = pol(1); v = u1 = pol(0);
+       while (size(b.p) > 0) {s = polydiv(a,b);
+               q = s[[0]];
+               a = b; b = s[[1]]; u -= q*u1; v -= -q*v1;
+               swap(u,u1); swap(v,v1);}
+       d=size(a.p)-1; if (d>=0 && (w= 1/a.p[[d]]) !=1)
+                { a *= w; u *= w; v *= w;}
+       return list(a,u,v);
+}
+  
+define monic(a) {
+       local s, c, i, d, y;
+       if (iszero(a)) return pzero;
+       obj poly y;
+       s = findlist(a);
+       d = size(s)-1;
+       for (i=0; i<=d; i++) s[[i]] /= s[[d]];
+       y.p = s;
+       return y;
+}
+
+define coefficient(a,n) = (n < size(a.p)) ? a.p[[n]] : 0;
+
+define D(a, n) {
+       local i,j,v;
+       if (isnull(n)) n = 1;
+       if (!isint(n) || n < 1) quit "Bad order for derivative";
+       if (ismat(a)) {
+               v = a;
+               for (i = matmin(a,1); i <= matmax(a,1); i++)
+                       for (j = matmin(a,2); j <= matmax(a,2); j++)
+                               v[i,j] = D(a[i,j], n);
+               return v;
+       }
+       if (!ispoly(a)) return 0;
+       return Dp(a,n);
+}
+
+define Dp(a,n) {
+       local i, v;
+       if (n > 1) return Dp(Dp(a, n-1), 1);
+       obj poly v;
+       v.p=list();     
+       for (i=1; i<size(a.p); i++) append (v.p, i*a.p[[i]]);
+       return v;
+}
+
+
+define cgcd(a,b) {
+       if (isreal(a) && isreal(b)) return gcd(a,b);
+       while (a) {
+               b -= bround(b/a) * a;
+               swap(a,b);
+       }
+       if (re(b) < 0) b = -b; 
+       if (im(b) > re(b)) b *= -1i;
+       else if (im(b) <= -re(b)) b *= 1i;
+       return b;
+}
+
+define gcdcoeffs(a) {
+       local s,i,g, c;
+       s = a.p;
+       g=0;
+       for (i=0; i < size(s) && g != 1; i++)
+               if (c = s[[i]]) g = cgcd(g, c);
+       return g;
+}
+
+define interp(X, Y, t) = evalfd(makediffs(X,Y), t);
+
+define makediffs(X,Y) {
+       local U, D, d, x, y, i, j, k, m, n, s;
+       U = D = list();
+       n = size(X);
+       if (size(Y) != n) quit"Arguments to be lists of same size";
+       for (i = n-1; i >= 0; i--) {
+               x = X[[i]];
+               y = Y[[i]];
+               m = size(U);
+               if (isnum(y)) {
+                       d = y;
+                       for (j = 0; j < m; j++) {
+                               d = D[[j]] = (D[[j]]-d)/(U[[j]] - x);
+                       }
+                       push(U, x);
+                       push(D, y);
+               }
+               else {
+                       s = size(y);
+                       for (k = 0; k < s ; k++) {
+                               d = y[[k]];
+                               for (j = 0; j < m; j++) {
+                                       d = D[[j]] = (D[[j]] - d)/(U[[j]] - x);
+                               }
+                       }
+                       for (j=s-1; j >=0; j--) {
+                               push(U,x);
+                               push(D, y[[j]]);
+                       }
+               }
+       }
+       return list(U, D);
+}
+       
+define evalfd(T, t) {
+       local U, D, n, i, v;
+       if (isnull(t)) t = pol(0,1);
+       U = T[[0]];
+       D = T[[1]];
+       n = size(U);
+       v = D[[n-1]];
+       for (i = n-2; i >= 0; i--) 
+               v = v * (t - U[[i]]) + D[[i]];
+       return v;
+}
+
+
+define mdet(A) {
+       local n, i, j, k, I, J;
+       n = matmax(A,1) - (i = matmin(A,1));
+       if (matmax(A,2) - (j = matmin(A,2)) != n)
+               quit "Non-square matrix for mdet";
+       I = J = list();
+       k = n + 1;
+       while (k--) {
+               append(I,i++);
+               append(J,j++);
+       }
+       return M(A, n+1, I, J);
+}
+
+define M(A, n, I, J) {
+       local v, J0, i, j, j1;
+       if (n == 1) return A[ I[[0]], J[[0]] ];
+       v = 0;
+       i = remove(I);
+       for (j = 0; j < n; j++) {
+               J0 = J;
+               j1 = delete(J0, j);
+               v += (-1)^(n-1+j) * A[i, j1] * M(A, n-1, I, J0);
+       }
+       return v;
+}
+
+define mprint(A) {
+       local i,j;
+       if (!ismat(A)) quit "Argument to be a matrix";
+       for (i = matmin(A,1); i <= matmax(A,1); i++) {
+               for (j = matmin(A,2); j <= matmax(A,2); j++)
+                       printf("%8.4d ", A[i,j]);
+               printf("\n");
+       }
+}
+       
+obj poly a;
+obj poly b;
+obj poly c;
+
+define a(t) = ev(a,t);
+define b(t) = ev(b,t);
+define c(t) = ev(c,t);
+
+a=pol(1,4,4,2,3,1);
+b=pol(5,16,8,1);
+c=pol(1+2i,3+4i,5+6i);
+
+global lib_debug;
+if (lib_debug >= 0) {
+       print "obj poly {p} defined";
+       print "pol() defined";
+       print "poly_print(a) defined";
+       print "poly_add(a, b) defined";
+       print "poly_sub(a, b) defined";
+       print "poly_mul(a, b) defined";
+       print "poly_div(a, b) defined";
+       print "poly_quo(a,b) defined";
+       print "poly_mod(a,b) defined";
+       print "poly_neg(a) defined";
+       print "poly_conj(a) defined";
+       print "poly_cmp(a,b) defined";
+       print "iszero(a) defined";
+       print "plist(a) defined";
+       print "listmul(a,b) defined";
+       print "ev(a,t) defined";
+       print "evp(s,t) defined";
+       print "ispoly(a) defined";
+       print "isstring(a) defined";
+       print "var(name) defined";
+       print "pcoeff(a) defined";
+       print "pterm(a,n) defined";
+       print "deg(a) defined";
+       print "polydiv(a,b) defined";
+       print "D(a,n) defined";
+       print "Dp(a,n) defined";
+       print "pgcd(a,b) defined";
+       print "plcm(a,b) defined";
+       print "monic(a) defined";
+       print "pfgcd(a,b) defined";
+       print "interp(X,Y,x) defined";
+       print "makediffs(X,Y) defined";
+       print "evalfd(T,x) defined";
+       print "mdet(A) defined";
+       print "M(A,n,I,J) defined";
+       print "mprint(A) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/psqrt.cal b/usr/src/contrib/calc-2.9.3t6/lib/psqrt.cal
new file mode 100644 (file)
index 0000000..59b6edb
--- /dev/null
@@ -0,0 +1,56 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Calculate square roots modulo a prime.
+ *
+ * Returns null if number is not prime or if there is no square root.
+ * The smaller square root is always returned.
+ */
+
+define psqrt(u, p)
+{
+       local   p1, q, n, y, r, v, w, t, k;
+
+       p1 = p - 1;
+       r = lowbit(p1);
+       q = p >> r;
+       t = 1 << (r - 1);
+       for (n = 2; ; n++) {
+               if (ptest(n, 1) == 0)
+                       continue;
+               y = pmod(n, q, p);
+               k = pmod(y, t, p);
+               if (k == 1)
+                       continue;
+               if (k != p1)
+                       return;
+               break;
+       }
+       t = pmod(u, (q - 1) / 2, p);
+       v = (t * u) % p;
+       w = (t^2 * u) % p;
+       while (w != 1) {
+               k = 0;
+               t = w;
+               do {
+                       k++;
+                       t = t^2 % p;
+               } while (t != 1);
+               if (k == r)
+                       return;
+               t = pmod(y, 1 << (r - k - 1), p);
+               y = t^2 % p;
+               v = (v * t) % p;
+               w = (w * y) % p;
+               r = k;
+       }
+       return min(v, p - v);
+}
+
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "psqrt(u, p) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/quat.cal b/usr/src/contrib/calc-2.9.3t6/lib/quat.cal
new file mode 100644 (file)
index 0000000..485e79f
--- /dev/null
@@ -0,0 +1,216 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Routines to handle quaternions of the form:
+ *     a + bi + cj + dk
+ *
+ * Note: In this module, quaternians are manipulated in the form:
+ *     s + v
+ * Where s is a scalar and v is a vector of size 3.
+ */
+
+obj quat {s, v};               /* definition of the quaternion object */
+
+
+define quat(a,b,c,d)
+{
+       local obj quat  x;
+
+       x.s = isnull(a) ? 0 : a;
+       mat x.v[3];
+       x.v[0] = isnull(b) ? 0 : b;
+       x.v[1] = isnull(c) ? 0 : c;
+       x.v[2] = isnull(d) ? 0 : d;
+       return x;
+}
+
+
+define quat_print(a)
+{
+       print "quat(" : a.s : ", " : a.v[0] : ", " : a.v[1] : ", " : a.v[2] : ")" :;
+}
+
+
+define quat_norm(a)
+{
+       return a.s^2 + dp(a.v, a.v);
+}
+
+
+define quat_abs(a, e)
+{
+       return sqrt(a.s^2 + dp(a.v, a.v), e);
+}
+
+
+define quat_conj(a)
+{
+       local obj quat  x;
+
+       x.s = a.s;
+       x.v = -a.v;
+       return x;
+}
+
+
+define quat_add(a, b)
+{
+       local obj quat  x;
+
+       if (!istype(b, x)) {
+               x.s = a.s + b;
+               x.v = a.v;
+               return x;
+       }
+       if (!istype(a, x)) {
+               x.s = a + b.s;
+               x.v = b.v;
+               return x;
+       }
+       x.s = a.s + b.s;
+       x.v = a.v + b.v;
+       if (x.v)
+               return x;
+       return x.s;
+}
+
+
+define quat_sub(a, b)
+{
+       local obj quat  x;
+
+       if (!istype(b, x)) {
+               x.s = a.s - b;
+               x.v = a.v;
+               return x;
+       }
+       if (!istype(a, x)) {
+               x.s = a - b.s;
+               x.v = -b.v;
+               return x;
+       }
+       x.s = a.s - b.s;
+       x.v = a.v - b.v;
+       if (x.v)
+               return x;
+       return x.s;
+}
+
+
+define quat_inc(a)
+{
+       local   x;
+
+       x = a;
+       x.s++;
+       return x;
+}
+
+
+define quat_dec(a)
+{
+       local   x;
+
+       x = a;
+       x.s--;
+       return x;
+}
+
+
+define quat_neg(a)
+{
+       local obj quat  x;
+
+       x.s = -a.s;
+       x.v = -a.v;
+       return x;
+}
+
+
+define quat_mul(a, b)
+{
+       local obj quat  x;
+
+       if (!istype(b, x)) {
+               x.s = a.s * b;
+               x.v = a.v * b;
+       } else if (!istype(a, x)) {
+               x.s = b.s * a;
+               x.v = b.v * a;
+       } else {
+               x.s = a.s * b.s - dp(a.v, b.v);
+               x.v = a.s * b.v + b.s * a.v + cp(a.v, b.v);
+       }
+       if (x.v)
+               return x;
+       return x.s;
+}
+
+
+define quat_div(a, b)
+{
+       local obj quat  x;
+
+       if (!istype(b, x)) {
+               x.s = a.s / b;
+               x.v = a.v / b;
+               return x;
+       }
+       return a * quat_inv(b);
+}
+
+
+define quat_inv(a)
+{
+       local   x, q2;
+
+       obj quat x;
+       q2 = a.s^2 + dp(a.v, a.v);
+       x.s = a.s / q2;
+       x.v = a.v / (-q2);
+       return x;
+}
+
+
+define quat_scale(a, b)
+{
+       local obj quat  x;
+
+       x.s = scale(a.s, b);
+       x.v = scale(a.v, b);
+       return x;
+}
+
+
+define quat_shift(a, b)
+{
+       local obj quat  x;
+
+       x.s = a.s << b;
+       x.v = a.v << b;
+       if (x.v)
+               return x;
+       return x.s;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "obj quat {s, v} defined";
+    print "quat(a, b, c, d) defined";
+    print "quat_print(a) defined";
+    print "quat_norm(a) defined";
+    print "quat_abs(a, e) defined";
+    print "quat_conj(a) defined";
+    print "quat_add(a, e) defined";
+    print "quat_sub(a, e) defined";
+    print "quat_inc(a) defined";
+    print "quat_dec(a) defined";
+    print "quat_neg(a) defined";
+    print "quat_mul(a, b) defined";
+    print "quat_div(a, b) defined";
+    print "quat_inv(a) defined";
+    print "quat_scale(a, b) defined";
+    print "quat_shift(a, b) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/randmprime.cal b/usr/src/contrib/calc-2.9.3t6/lib/randmprime.cal
new file mode 100644 (file)
index 0000000..ab280c4
--- /dev/null
@@ -0,0 +1,137 @@
+/*
+ * randmprime - generate a random prime of the form h*2^n-1
+ *
+ * Copyright (c) 1993 by Landon Curt Noll.  All Rights Reserved.
+ *
+ * Permission to use, copy, modify, and distribute this software and
+ * its documentation for any purpose and without fee is hereby granted,
+ * provided that the above copyright, this permission notice and text
+ * this comment, and the disclaimer below appear in all of the following:
+ *
+ *     supporting documentation
+ *     source copies
+ *     source works derived from this source
+ *     binaries derived from this source or from derived source
+ *
+ * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
+ * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO
+ * EVENT SHALL LANDON CURT NOLL BE LIABLE FOR ANY SPECIAL, INDIRECT OR
+ * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF
+ * USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ *
+ * chongo was here     /\../\          chongo@toad.com
+ */
+
+/* obtain our required libs */
+read -once "cryrand.cal"
+read -once "lucas.cal"
+
+/*
+ * randmprime - find a random prime of the form h*2^n-1 of a given size
+ *
+ * given:
+ *     bits    minimum bits in prime to return
+ *     seed    random seed for scryrand()
+ *     [dbg]   if given, enable debugging
+ *
+ * returns:
+ *     a prime of the form h*2^n-1
+ */
+define
+randmprime(bits, seed, dbg)
+{
+    local n;           /* n as in h*2^n-1 */
+    local h;           /* h as in h*2^n-1 */
+    local plush;       /* value added to h since the beginning */
+    local init;                /* initial cpu time */
+    local start;       /* cpu time before last test */
+    local stop;                /* cpu time afte last test */
+    local tmp;         /* just a tmp place holder value */
+    local ret;         /* h*2^n-1 that is prime */
+
+    /* firewall */
+    if (param(0) < 2 || param(0) > 3) {
+       quit "bad usage: rndprime(dig, seed [,dbg])";
+    }
+    if (!isint(bits) || bits < 0 || !isint(seed) || seed < 0) {
+       quit "args must be non-negative integers";
+    }
+    if (bits < 1) {
+       bits = 1;
+    }
+    if (param(0) == 2 || dbg < 0) {
+       dbg = 0;
+    }
+
+    /* seed generator */
+    tmp = scryrand(seed);
+
+    /* determine initial h and n values */
+    n = random(bits>>1, highbit(bits)+bits>>1+1);
+    h = cryrand(n);
+    h += iseven(h);
+    while (highbit(h) >= n) {
+       ++n;
+    }
+    if (dbg >= 1) {
+       print "DEBUG3: initial h =", h;
+       print "DEBUG3: initial n =", n;
+    }
+
+    /*
+     * loop until we find a prime
+     */
+    if (dbg >= 1) {
+       start = runtime();
+       init = runtime();
+       plush = 0;
+       print "DEBUG1: testing (h+" : plush : ")*2^" : n : "-1";
+    }
+    while (lucas(h,n) == 0) {
+
+       /* bump h, and n if needed */
+       if (dbg >= 2) {
+           stop = runtime();
+           print "DEBUG2: last test:", stop-start, "   total time:", stop-init;
+       }
+       if (dbg >= 1) {
+           print "DEBUG1: composite: (h+" : plush : ")*2^" : n : "-1";
+           plush += 2;
+       }
+       h += 2;
+       while (highbit(h) >= n) {
+          ++n;
+       }
+       if (dbg >= 1) {
+           print "DEBUG1: testing (h+" : plush : ")*2^" : n : "-1";
+           start = stop;
+       }
+    }
+
+    /* found a prime */
+    if (dbg >= 2) {
+       stop = runtime();
+       print "DEBUG2: last test:", stop-start, "   total time:", stop-init;
+       print "DEBUG3: " : h : "*2^" : n : "-1 is prime";
+    }
+    if (dbg >= 1) {
+       print "DEBUG1: prime: (h+" : plush : ")*2^" : n : "-1";
+    }
+    ret = h*2^n-1;
+    if (dbg >= 3) {
+       print "DEBUG3: highbit(h):", highbit(h);
+       print "DEBUG3: digits(h):", digits(h);
+       print "DEBUG3: highbit(n):", highbit(n);
+       print "DEBUG3: digits(2^n):", int(n*ln(10)/ln(2)+1);
+       print "DEBUG3: highbit(h*2^n-1):", highbit(ret);
+       print "DEBUG3: digits(h*2^n)-1:", digits(ret);
+    }
+    return ret;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "randmprime(bits, seed [,dbg]) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/regress.cal b/usr/src/contrib/calc-2.9.3t6/lib/regress.cal
new file mode 100644 (file)
index 0000000..7da127b
--- /dev/null
@@ -0,0 +1,1276 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Test the correct execution of the calculator by reading this library file.
+ * Errors are reported with '****' messages, or worse.  :-)
+ *
+ * NOTE: Unlike most calc lib files, this one performs its work when
+ *       it is read.  Normally one would just define functions and
+ *      values for later use.  In the case of the regression test,
+ *      we do not want to do this.
+ */
+
+print '000: Beginning regression tests';
+print '001: Beginning regression test suite read';
+print '002: Within each section, output should be numbered sequentially';
+
+
+static err;
+lib_debug = -1;                /* disable lib startup messages */
+print '003: parsed variable definitions';
+
+
+define verify(test, str)
+{
+       if (test != 1) {
+               print '**** Non-true result (' : test : '): ' : str;
+               ++err;
+               return;
+       }
+       print str;
+}
+print '004: parsed verify()';
+
+
+define error(str)
+{
+       print '****' , str;
+       ++err;
+}
+print '005: parsed error(str)';
+
+
+define getglobalvar()
+{
+       global  globalvar;
+
+       return globalvar;
+}
+print '006: parsed getglobalvar()';
+
+
+/*
+ * Test boolean operations and IF tests.
+ *
+ * Some of these tests are done twice, once to print the message and
+ * once to count any errors.  This means that some successful tests
+ * will display a passing message twice.  Oh well, no biggie.
+ */
+define test_booleans()
+{
+       local   x;
+       local   y;
+       local   t1, t2, t3;
+
+       print '100: Beginning test_booleans';
+
+       if (0)
+               print '**** if (0)';
+       if (0)
+               err = err + 1;
+
+       if (1)
+               print '101: if (1)';
+
+       if (2)
+               print '102: if (2)';
+
+       if (1)
+               print '103: if (1) else';
+       else
+               print '**** if (1) else';
+       if (1)
+               print '104: if (1) else';
+       else
+               err = err + 1;
+
+       if (0)
+               print '**** if (0) else';
+       else
+               print '105: if (0) else';
+       if (0)
+               err = err + 1;
+       else
+               print '106: if (0) else';
+
+       if (1 == 1)
+               print '107: if 1 == 1';
+       else
+               print '**** if 1 == 1';
+       if (1 == 1)
+               print '108: if 1 == 1';
+       else
+               err = err + 1;
+
+       if (1 != 2)
+               print '109: if 1 != 2';
+       else
+               print '**** if 1 != 2';
+       if (1 != 2)
+               print '110: if 1 != 2';
+       else
+               err = err + 1;
+
+       verify(1,      '111: verify 1');
+       verify(2 == 2, '112: verify 2 == 2');
+       verify(2 != 3, '113: verify 2 != 3');
+       verify(2 <  3, '114: verify 2 <  3');
+       verify(2 <= 2, '115: verify 2 <= 2');
+       verify(2 <= 3, '116: verify 2 <= 3');
+       verify(3 >  2, '117: verify 3 >  2');
+       verify(2 >= 2, '118: verify 2 >= 2');
+       verify(3 >= 2, '119: verify 3 >= 2');
+       verify(!0,     '120: verify !0');
+       verify(!1 == 0,'121: verify !1 == 0');
+       print '122: Ending test_booleans';
+}
+print '007: parsed test_booleans()';
+
+
+/*
+ * Test variables and simple assignments.
+ */
+define test_variables()
+{
+       local   x1, x2, x3;
+       global  g1, g2;
+       local   t;
+       global  globalvar;
+
+       print '200: Beginning test_variables';
+       x1 = 5;
+       x3 = 7 * 2;
+       x2 = 9 + 1;
+       globalvar = 22;
+       g1 = 19 - 3;
+       g2 = 79;
+       verify(x1 == 5,  '201: x1 == 5');
+       verify(x2 == 10, '202: x2 == 10');
+       verify(x3 == 14, '203: x3 == 14');
+       verify(g1 == 16, '204: g1 == 16');
+       verify(g2 == 79, '205: g2 == 79');
+       verify(globalvar == 22, '204: globalvar == 22');
+       verify(getglobalvar() == 22, '205: getglobalvar() == 22');
+       x1 = x2 + x3 + g1;
+       verify(x1 == 40, '206: x1 == 40');
+       g1 = x3 + g2;
+       verify(g1 == 93, '207: g1 == 207');
+       x1 = 5;
+       verify(x1++ == 5, '208: x1++ == 5');
+       verify(x1 == 6, '209: x1 == 6');
+       verify(++x1 == 7, '210: ++x1 == 7');
+       x1 += 3;
+       verify(x1 == 10, '211: x1 == 10');
+       x1 -= 6;
+       verify(x1 == 4, '212: x1 == 4');
+       x1 *= 3;
+       verify(x1 == 12, '213: x1 == 12');
+       x1 /= 4;
+       verify(x1 == 3, '214: x1 == 3');
+       x1 = x2 = x3;
+       verify(x2 == 14, '215: x2 == 14');
+       verify(x1 == 14, '216: x1 == 14');
+       print '217: Ending test_variables';
+}
+print '008: parsed test_variables()';
+
+
+/*
+ * Test logical AND and OR operators and short-circuit evaluation.
+ */
+define test_logicals()
+{
+       local   x;
+
+       print '300: Beginning test_logicals';
+
+       if (2 && 3) {
+               print '301: if (2 && 3)';
+       } else {
+               print '**** if (2 && 3)';
+               ++err;
+       }
+
+       if (2 && 0) {
+               print '**** if (2 && 0)';
+               ++err;
+       } else {
+               print '302: if (2 && 0)';
+       }
+
+       if (0 && 2) {
+               print '**** if (0 && 2)';
+               ++err;
+       } else {
+               print '303: if (0 && 2)';
+       }
+
+       if (0 && 0) {
+               print '**** if (0 && 0)';
+               ++err;
+       } else {
+               print '304: if (0 && 0)';
+       }
+
+       if (2 || 0) {
+               print '305: if (2 || 0)';
+       } else {
+               print '**** if (2 || 0)';
+               ++err;
+       }
+       
+       if (0 || 2) {
+               print '306: if (0 || 2)';
+       } else {
+               print '**** if (0 || 2)';
+               ++err;
+       }
+
+       if (0 || 0) {
+               print '**** if (0 || 0)';
+               ++err;
+       } else {
+               print '307: if (0 || 0)';
+       }
+
+       x = 2 || 3; verify(x == 2, '308: (2 || 3) == 2');
+       x = 2 || 0; verify(x == 2, '309: (2 || 0) == 2');
+       x = 0 || 3; verify(x == 3, '310: (0 || 3) == 3');
+       x = 0 || 0; verify(x == 0, '311: (0 || 0) == 0');
+       x = 2 && 3; verify(x == 3, '312: (2 && 3) == 3');
+       x = 2 && 0; verify(x == 0, '313: (2 && 0) == 0');
+       x = 0 && 3; verify(x == 0, '314: (0 && 3) == 0');
+       x = 2 || error('2 || error()');
+       x = 0 && error('0 && error()');
+       print '315: Ending test_logicals';
+}
+print '009: parsed test_logicals()';
+
+
+/*
+ * Test simple arithmetic operations and expressions.
+ */
+define test_arithmetic()
+{
+       print '400: Beginning test_arithmetic';
+       verify(3+4==7, '401: 3 + 4 == 7');
+       verify(4-1==3, '402: 4 - 1 == 3');
+       verify(2*3==6, '403: 2 * 3 == 6');
+       verify(8/4==2, '404: 8 / 4 == 2');
+       verify(2^3==8, '405: 2 ^ 3 == 8');
+       verify(9-4-2==3, '406: 9-4-2 == 3');
+       verify(9-4+2==7, '407: 9-4+2 == 6');
+       verify(-5+2==-3,  '408: -5+2 == -3');
+       verify(2*3+1==7, '409: 2*3+1 == 7');
+       verify(1+2*3==7, '410: 1+2*3 == 7');
+       verify((1+2)*3==9, '411: (1+2)*3 == 9');
+       verify(2*(3+1)==8, '412: 2*(3+1) == 8');
+       verify(9-(2+3)==4, '413: 9-(2+3) == 4');
+       verify(9+(2-3)==8, '414: 9+(2-3) == 8');
+       verify((2+3)*(4+5)==45, '415: (2+3)*(4+5) == 45');
+       verify(10/(2+3)==2, '416: 10/(2+3) == 2');
+       verify(12/3+4==8, '417: 12/3+4 == 8');
+       verify(6+12/3==10, '418: 6+12/3 == 10');
+       verify(2+3==1+4, '419: 2+3 == 1+4');
+       verify(-(2+3)==-5, '420: -(2+3) == -5');
+       verify(7&18==2,    '421: 7&18 == 2');
+       verify(3|17==19,   '422: 3|17 == 19');
+       verify(2&3|1==3,   '423: 2&3|1 == 3');
+       verify(2&(3|1)==2, '424: 2&(3|1) == 2');
+       verify(3<<4==48,   '425: 3<<4 == 48');
+       verify(5>>1==2,    '426: 5>>1 == 2');
+       verify(3<<-1==1,   '427: 3<<-1 == 1');
+       verify(5>>-2==20,  '428: 5>>-2 == 20');
+       verify(1<<2<<3==65536, '429: 1<<2<<3 == 65536');
+       verify((1<<2)<<3==32, '430: (1<<2)<<3 == 32');
+       verify(2^3^2==512, '431: 2^3^2 == 512');
+       verify((2^3)^2==64,'432: (2^3)^2 == 64');
+       verify(4//3==1, '433: 4//3==1');
+       verify(4//-3==-1, '434: 4//-3==-1');
+       verify(0.75//-0.51==-1, '435: 0.75//-0.51==-1');
+       verify(0.75//-0.50==-1, '436: 0.75//-0.50==-1');
+       verify(0.75//-0.49==-1, '437: 0.75//-0.49==-1');
+       verify((3/4)//(-1/4)==-3, '438: (3/4)//(-1/4)==-3');
+       verify(7%3==1,     '439: 7%3==1');
+       verify(0-.5==-.5, '440: 0-.5==-.5');
+       verify(0^0 == 1,  '441: 0^0 == 1');
+       verify(0^1 == 0,  '442: 0^1 == 0');
+       verify(1^0 == 1,  '443: 1^0 == 1');
+       verify(1^1 == 1,  '444: 1^1 == 1');
+       verify(1/(.8+.8i)==.625-.625i, '445: 1/(.8+.8i)==.625-.625i');
+       verify((.6+.8i)*(3.6-4.8i)==6, '446: (.6+.8i)*(3.6-4.8i)==6');
+       print '447: Ending test_arithmetic';
+}
+print '010: parsed test_arithmetic()';
+
+
+/*
+ * Test string constants and comparisons
+ */
+define test_strings()
+{
+       local x, y, z;
+
+       print '500: Beginning test_strings';
+       x = 'string';
+       y = "string";
+       z = x;
+       verify(z == "string", '501: z == "string"');
+       verify(z != "foo", '502: z != "foo"');
+       verify(z != 3, '503: z != 3');
+       verify('' == "", '504: \'\' == ""');
+       verify("a" == "a", '505: "a" == "a"');
+       verify("c" != "d", '506: "c" != "d"');
+       verify("" != "a", '507: "" != "a"');
+       verify("rs" < "rt", '508: "rs" < "rt"');
+       verify("rs" < "ss", '509: "rs < "ss"');
+       verify("rs" <= "rs", '510: "rs" <= "rs"');
+       verify("rs" <= "tu", '511: "rs" <= "tu"');
+       verify("rs" > "cd", '512: "rs" > "cd"');
+       verify("rs" >= "rs", '513: "rs" >= "rs"');
+       verify("rs" >= "cd", '514: "rs" >= "cd"'); 
+       verify("abc" > "ab", '515: "abc" > "ab"');
+       print '516: Ending test_strings';
+}
+print '011: parsed test_strings()';
+
+
+/*
+ * Do multiplication and division on three numbers in various ways
+ * and verify the results agree.
+ */
+define muldivcheck(a, b, c, str)
+{
+       local   abc, acb, bac, bca, cab, cba;
+
+       abc = (a * b) * c;
+       acb = (a * c) * b;
+       bac = (b * a) * c;
+       bca = (b * c) * a;
+       cab = (c * a) * b;
+       cba = (c * b) * a;
+
+       if (abc != acb) {print '**** abc != acb:', str; ++err;}
+       if (acb != bac) {print '**** acb != bac:', str; ++err;}
+       if (bac != bca) {print '**** bac != bca:', str; ++err;}
+       if (bca != cab) {print '**** bca != cab:', str; ++err;}
+       if (cab != cba) {print '**** cab != cba:', str; ++err;}
+       if (abc/a != b*c) {print '**** abc/a != bc:', str; ++err;}
+       if (abc/b != a*c) {print '**** abc/b != ac:', str; ++err;}
+       if (abc/c != a*b) {print '**** abc/c != ab:', str; ++err;}
+       print str;
+}
+print '012: parsed muldivcheck(a, b, c, str)';
+
+
+/*
+ * Use the identity for squaring the sum of two squares to check
+ * multiplication and squaring.
+ */
+define squarecheck(a, b, str)
+{
+       local   a2, b2, tab, apb, apb2, t;
+
+       a2 = a^2;
+       b2 = b^2;
+       tab = a * b * 2;
+       apb = a + b;
+       apb2 = apb^2;
+       if (a2 != a*a) {print '**** a^2 != a*a:', str; ++err;}
+       if (b2 != b*b) {print '**** b^2 != b*b:', str; ++err;}
+       if (apb2 != apb*apb) {
+               print '**** (a+b)^2 != (a+b)*(a+b):', str; 
+               ++err;
+       }
+       if (a2+tab+b2 != apb2) {
+               print '**** (a+b)^2 != a^2 + 2ab + b^2:', str; 
+               ++err;
+       }
+       if (a2/a != a) {print '**** a^2/a != a:', str; ++err;}
+       if (b2/b != b) {print '**** b^2/b != b:', str; ++err;}
+       if (apb2/apb != apb) {print '**** (a+b)^2/(a+b) != a+b:', str; ++err;}
+       if (a2*b2 != (a*b)^2) {print '**** a^2*b^2 != (ab)^2:', str; ++err;}
+       print str;
+}
+print '013: parsed squarecheck(a, b, str)';
+
+
+/*
+ * Use the raising of numbers to large powers to check multiplication
+ * and exponentiation.
+ */
+define powercheck(a, p1, p2, str)
+{
+       local   a1, a2, a3;
+
+       a1 = (a^p1)^p2;
+       a2 = (a^p2)^p1;
+       a3 = a^(p1*p2);
+       if (a1 != a2) {print '**** (a^p1)^p2 != (a^p2)^p1:', str; ++err;}
+       if (a1 != a3) {print '**** (a^p1)^p2 != a^(p1*p2):', str; ++err;}
+       print str;
+}
+print '014: parsed powercheck(a, p1, p2, str)';
+
+
+/*
+ * Test fraction reductions.
+ * Arguments MUST be relatively prime.
+ */
+define fraccheck(a, b, c, str)
+{
+       local   ab, bc, ca, aoc, boc, aob;
+
+       ab = a * b;
+       bc = b * c;
+       ca = c * a;
+       aoc = ab / bc;
+       if (num(aoc) != a) {print '**** num(aoc) != a:', str; ++err;}
+       if (den(aoc) != c) {print '**** den(aoc) != c:', str; ++err;}
+       boc = ab / ca;
+       if (num(boc) != b) {print '**** num(boc) != b:', str; ++err;}
+       if (den(boc) != c) {print '**** den(boc) != c:', str; ++err;}
+       aob = ca / bc;
+       if (num(aob) != a) {print '**** num(aob) != a:', str; ++err;}
+       if (den(aob) != b) {print '**** den(aob) != b:', str; ++err;}
+       if (aob*boc != aoc) {print '**** aob*boc != aoc;', str; ++err;}
+       print str;
+}
+print '015: parsed fraccheck(a, b, c, str)';
+
+
+/*
+ * Test multiplication and squaring algorithms.
+ */
+define algcheck(a, b, str)
+{
+       local   ss, ms, t1, t2, t3, t4, t5, t6, t7;
+       local   a1, a2, a3, a4, a5, a6, a7;
+       local   oldmul2, oldsq2;
+
+       oldmul2 = config("mul2", 2);
+       oldsq2 = config("sq2", 2);
+       a1 = a * b;
+       a2 = a * a;
+       a3 = b * b;
+       a4 = a^2;
+       a5 = b^2;
+       a6 = a2^2;
+       a7 = pmod(3,a-1,a);
+       for (ms = 2; ms < 20; ms++) {
+               for (ss = 2; ss < 20; ss++) {
+                       config("mul2", ms);
+                       config("sq2", ss);
+                       t1 = a * b;
+                       t2 = a * a;
+                       t3 = b * b;
+                       t4 = a^2;
+                       t5 = b^2;
+                       t6 = t2^2;
+                       if (((ms + ss) % 37) == 4)
+                               t7 = pmod(3,a-1,a);
+                       if (t1 != a1) {print '**** t1 != a1:', str; ++err;}
+                       if (t2 != a2) {print '**** t2 != a2:', str; ++err;}
+                       if (t3 != a3) {print '**** t3 != a3:', str; ++err;}
+                       if (t4 != a4) {print '**** t4 != a4:', str; ++err;}
+                       if (t5 != a5) {print '**** t5 != a5:', str; ++err;}
+                       if (t6 != a6) {print '**** t6 != a6:', str; ++err;}
+                       if (t7 != a7) {print '**** t7 != a7:', str; ++err;}
+               }
+       }
+       config("mul2", oldmul2);
+       config("sq2", oldsq2);
+       print str;
+}
+print '016: parsed algcheck(a, b, str)';
+
+
+/*
+ * Test big numbers using some identities.
+ */
+define test_bignums()
+{
+       local   a, b, c, d;
+
+       print '600: Beginning test_bignums';
+       a = 64357824568234938591;
+       b = 12764632632458756817;
+       c = 43578234973856347982;
+       muldivcheck(a, b, c, '601: muldivcheck 1');
+       a = 3^100;
+       b = 5^97;
+       c = 7^88;
+       muldivcheck(a, b, c, '602: muldivcheck 2');
+       a = 2^160 - 1;
+       b = 2^161 - 1;
+       c = 2^162 - 1;
+       muldivcheck(a, b, c, '603: muldivcheck 3');
+       a = 3^35 / 5^35;
+       b = 7^35 / 11^35;
+       c = 13^35 / 17^35;
+       muldivcheck(a, b, c, '604: muldivcheck 4');
+       a = (10^97-1) / 9;
+       b = (10^53-1) / 9;
+       c = (10^37-1) / 9;
+       muldivcheck(a, b, c, '605: muldivcheck 5');
+       a = 17^50;
+       b = 19^47;
+       squarecheck(a, b, '606: squarecheck 1');
+       a = 2^111-1;
+       b = 2^17;
+       squarecheck(a, b, '607: squarecheck 2');
+       a = 23^43 / 29^43;
+       b = 31^42 / 37^29;
+       squarecheck(a, b, '608: squarecheck 3');
+       a = 4657892345743659834657238947854639;
+       b = 43784356784365893467659347867689;
+       squarecheck(a, b, '609: squarecheck 4');
+       a = (10^80-1) / 9;
+       b = (10^50-1) / 9;
+       squarecheck(a, b, '610: squarecheck 5');
+       a = 101^99;
+       b = 2 * a;
+       squarecheck(a, b, '611: squarecheck 6');
+       a = (10^19-1) / 9;
+       verify(ptest(a, 20), '612: primetest R19');
+       a = (10^23-1) / 9;
+       verify(ptest(a, 20), '613: primetest R23');
+       a = 2^127 - 1;
+       verify(ptest(a, 1), '614: primetest M127');
+       a = 2^521 - 1;
+       verify(ptest(a, 1), '615: primetest M521');
+       powercheck(17, 127, 30, '616: powercheck 1');
+       powercheck(111, 899, 6, '617: powercheck 2');
+       powercheck(3, 87, 89, '618: powercheck 3');
+       fraccheck(3^200, 5^173, 7^138, '619: fraccheck 1');
+       fraccheck(11^100, 12^98, 13^121, '620: fraccheck 2');
+       fraccheck(101^270, 103^111, 105^200, '621: fraccheck 3');
+       a = 0xffff0000ffffffff00000000ffff0000000000000000ffff;
+       b = 0x555544440000000000000000000000000000000011112222333344440000;
+       c = 0x999911113333000011111111000022220000000000000000333300000000ffff;
+       d = 0x3333ffffffff0000000000000000ffffffffffffffff000000000000;
+       algcheck(a, a, '622: algcheck 1');
+       algcheck(a, b, '623: algcheck 2');
+       algcheck(a, c, '624: algcheck 3');
+       algcheck(a, d, '625: algcheck 4');
+       algcheck(b, b, '626: algcheck 5');
+       algcheck(b, c, '627: algcheck 6');
+       algcheck(b, d, '628: algcheck 7');
+       algcheck(c, c, '629: algcheck 8');
+       algcheck(c, d, '630: algcheck 9');
+       algcheck(d, d, '631: algcheck 10');
+/* The following are pending consideration of the 'nearest' arg to sqrt()
+       a = 2e150;
+       b = 0x3206aa0707c6c1d483b62c784c9371eb507e3ab9b2d511c4bd648e52a5277fe;
+       verify(sqrt(a,1) == b, '632: sqrt(a,1) == b');
+       verify(sqrt(4e1000,1) == 2e500, '633: sqrt(4e1000,1) == 2e500');
+ */
+       print '634: Ending test_bignums';
+}
+print '017: parsed test_bignums()';
+
+
+/*
+ * Test many of the built-in functions.
+ */
+define test_functions()
+{
+       print '700: Beginning test_functions';
+       verify(abs(3) == 3,    '701: abs(3) == 3');
+       verify(abs(-4) == 4,   '702: abs(-4) == 4');
+       verify(avg(7) == 7,    '703: avg(7) == 7');
+       verify(avg(3,5) == 4,  '704: avg(3,5) == 4');
+       verify(cmp(2,3) == -1, '705: cmp(2,3) == -1');
+       verify(cmp(6,6) == 0,  '706: cmp(6,6) == 0');
+       verify(cmp(7,4) == 1,  '707: cmp(7,4) == 1');
+       verify(comb(9,9) == 1, '708: comb(9,9) == 1');
+       verify(comb(5,2) == 10,'709: comb(5,2) == 10');
+       verify(conj(4) == 4,   '710: conj(4) == 4');
+       verify(conj(2-3i) == 2+3i, '711: conj(2-3i) == 2+3i');
+       verify(den(17) == 1,   '712: den(17) == 1');
+       verify(den(3/7) == 7,  '713: den(3/7) == 7');
+       verify(den(-2/3) == 3, '714: den(-2/3) == 3');
+       verify(digits(0) == 1, '715: digits(0) == 1');
+       verify(digits(9) == 1, '716: digits(9) == 1');
+       verify(digits(10) == 2,'717: digits(10) == 2');
+       verify(digits(-691) == 3, '718: digits(-691) == 3');
+       verify(eval('2+3') == 5, "719: eval('2+3') == 5");
+       verify(fcnt(11,3) == 0,'720: fcnt(11,3) == 0');
+       verify(fcnt(18,3) == 2,'721: fcnt(18,3) == 2');
+       verify(fib(0) == 0,    '722: fib(0) == 0');
+       verify(fib(1) == 1,    '723: fib(1) == 1');
+       verify(fib(9) == 34,   '724: fib(9) == 34');
+       verify(frem(12,5) == 12, '725: frem(12,5) == 12');
+       verify(frem(45,3) == 5, '726: frem(45,3) == 5');
+       verify(fact(0) == 1,   '727: fact(0) == 1');
+       verify(fact(1) == 1,   '728: fact(1) == 1');
+       verify(fact(5) == 120, '729: fact(5) == 120');
+       verify(frac(3) == 0,   '730: frac(3) == 0');
+       verify(frac(2/3) == 2/3, '731: frac(2/3) == 2/3');
+       verify(frac(17/3) == 2/3, '732: frac(17/3) == 2/3');
+       verify(gcd(0,3) == 3,  '733: gcd(0,3) == 3');
+       verify(gcd(1,12) == 1, '734: gcd(1,12) == 1');
+       verify(gcd(11,7) == 1, '735: gcd(11,7) == 1');
+       verify(gcd(20,65) == 5, '736: gcd(20,65) == 5');
+       verify(gcdrem(20,3) == 20, '737: gcdrem(20,3) == 20');
+       verify(gcdrem(100,6) == 25, '738: gcdrem(100,6) == 25');
+       verify(highbit(1) == 0, '739: highbit(1) == 0');
+       verify(highbit(15) == 3, '740: highbit(15) == 3');
+       verify(hypot(3,4) == 5, '741: hypot(3,4) == 5');
+       verify(ilog(90,3) == 4, '742: ilog(90,3) == 4');
+       verify(ilog10(123) == 2, '743: ilog10(123) == 2');
+       verify(ilog2(17) == 4, '744: ilog2(17) == 4');
+       verify(im(3) == 0,     '745: im(3) == 0');
+       verify(im(2+3i) == 3,  '746: im(2+3i) == 3');
+       verify(int(5) == 5,    '757: int(5) == 5');
+       verify(int(19/3) == 6, '758: int(19/3) == 6');
+       verify(inverse(3/2) == 2/3, '759: inverse(3/2) == 2/3');
+       verify(iroot(18,2) == 4, '760: iroot(18,2) == 4');
+       verify(iroot(100,3) == 4, '761: iroot(100,3) == 4');
+       verify(iseven(10) == 1, '762: iseven(10) == 1');
+       verify(iseven(13) == 0, '763: iseven(13) == 0');
+       verify(iseven('a') == 0, "764: iseven('a') == 0");
+       verify(isint(7) == 1,  '765: isint(7) == 1');
+       verify(isint(19/2) == 0, '766: isint(19/2) == 0');
+       verify(isint('a') == 0, "767: isint('a') == 0");
+       verify(islist(3) == 0, '768: islist(3) == 0');
+       verify(islist(list(2,3)) == 1, '769: islist(list(2,3)) == 1');
+       verify(ismat(3) == 0, '770: ismat(3) == 0');
+       verify(ismult(7,3) == 0, '771: ismult(7,3) == 0');
+       verify(ismult(15,5) == 1, '772: ismult(15,5) == 1');
+       verify(isnull(3) == 0, '773: isnull(3) == 0');
+       verify(isnull(null()) == 1, '774: isnull(null()) == 1');
+       verify(isnum(2/3) == 1, '775: isnum(2/3) == 1');
+       verify(isnum('xx') == 0, "776: isnum('xx') == 0");
+       verify(isobj(3) == 0, '777: isobj(3) == 0');
+       verify(isodd(7) == 1, '778: isodd(7) == 1');
+       verify(isodd(8) == 0, '779: isodd(8) == 0');
+       verify(isodd('x') == 0, "780: isodd('a') == 0");
+       verify(isqrt(27) == 5, '781: isqrt(27) == 5');
+       verify(isreal(3) == 1, '782: isreal(3) == 1');
+       verify(isreal('x') == 0, "783: isreal('x') == 0");
+       verify(isreal(2+3i) == 0, '784: isreal(2+3i) == 0');
+       verify(isstr(5) == 0,  '785: isstr(5) == 0');
+       verify(isstr('foo') == 1, "786: isstr('foo') == 1");
+       verify(isrel(10,14) == 0, '787: isrel(10,14) == 0');
+       verify(isrel(15,22) == 1, '788: isrel(15,22) == 1');
+       verify(issimple(6) == 1, '789: issimple(6) == 1');
+       verify(issimple(3-2i) == 1, '790: issimple(3-2i) == 1');
+       verify(issimple(list(5)) == 0, '791: issimple(list(5)) == 0');
+       verify(issq(26) == 0, '792: issq(26) == 0');
+       verify(issq(9/4) == 1, '793: issq(9/4) == 1');
+       verify(istype(9,4) == 1, '795: istype(9,4) == 1');
+       verify(istype(3,'xx') == 0, "796: istype(3,'xx') == 0");
+       verify(jacobi(5,11) == 1, '797: jacobi(2,7) == 1');
+       verify(jacobi(6,13) == -1, '798: jacobi(6,13) == 0');
+       verify(lcm(3,4,5,6) == 60, '799: lcm(3,4,5,6) == 60');
+       verify(lcmfact(8) == 840, '800: lcmfact(8) == 840');
+       verify(lfactor(21,5) == 3, '801: lfactor(21,5) == 3');
+       verify(lfactor(97,20) == 1, '802: lfactor(97,20) == 1');
+       verify(lowbit(12) == 2, '803: lowbit(12) == 2');
+       verify(lowbit(17) == 0, '804: lowbit(17) == 0');
+       verify(ltol(1) == 0, '805: ltol(1) == 0');
+       verify(max(3,-9,7,4) == 7, '806: max(3,-9,7,4) == 7');
+       verify(meq(13,33,10) == 1, '807: meq(13,33,10) == 1');
+       verify(meq(7,19,11) == 0, '808: meq(7,19,11) == 0');
+       verify(min(9,5,12) == 5, '809: min(9,5,12) == 5');
+       verify(minv(13,97) == 15, '810: minv(13,97) == 15');
+       verify(mne(16,37,10) == 1, '811: mne(16,37,10) == 1');
+       verify(mne(46,79,11) == 0, '812: mne(46,79,11) == 0');
+       verify(norm(4) == 16,   '813: norm(4) == 16');
+       verify(norm(2-3i) == 13, '814: norm(2-3i) == 13');
+       verify(num(7) == 7,     '815: num(7) == 7');
+       verify(num(11/4) == 11, '816: num(11/4) == 11');
+       verify(num(-9/5) == -9, '817: num(-9/5) == -9');
+       verify(char(ord('a')+2) == 'c', "818: char(ord('a')+2) == 'c'");
+       verify(perm(7,3) == 210, '819: perm(7,3) == 210');
+       verify(pfact(10) == 210, '820: pfact(10) == 210');
+       verify(places(3/7) == -1, '821: places(3/7) == -1');
+       verify(places(.347) == 3, '822: places(.347) == 3');
+       verify(places(17) == 0, '823: places(17) == 0');
+       verify(pmod(3,36,37) == 1, '824: pmod(3,36,37) == 1');
+       verify(poly(2,3,5,2) == 19, '825; poly(2,3,5,2) == 19');
+       verify(ptest(101,10) == 1, '826: ptest(101,10) == 1');
+       verify(ptest(221,30) == 0, '827: ptest(221,30) == 0');
+       verify(re(9) == 9,       '828: re(9) == 9');
+       verify(re(-7+3i) == -7,  '829: re(-7+3i) == -7');
+       verify(scale(3,4) == 48, '830: scale(3,4) == 48');
+       verify(sgn(-4) == -1,    '831: sgn(-4) == -1');
+       verify(sgn(0) == 0,      '832: sgn(0) == 0');
+       verify(sgn(3) == 1,      '833: sgn(3) == 1');
+       verify(size(7) == 1,     '834: size(7) == 1');
+       verify(sqrt(121) == 11,  '835: sqrt(121) == 11');
+       verify(ssq(2,3,4) == 29, '836: ssq(2,3,4) == 29');
+       verify(str(45) == '45',  "837; str(45) == '45'");
+       verify(strcat('a','bc','def')=='abcdef',"838; strcat('a','bc','def')=='abcdef'");
+       verify(strlen('') == 0,  "839: strlen('') == 0");
+       verify(strlen('abcd') == 4, "840: strlen('abcd') == 4");
+       verify(substr('abcd',2,1) == 'b', "841: substr('abcd',2,1) == 'b'");
+       verify(substr('abcd',3,4) == 'cd', "842: substr('abcd',3,4) == 'cd'");
+       verify(substr('abcd',1,3) == 'abc', "843: substr('abcd',1,3) == 'abc'");
+       verify(xor(17,17) == 0,  '844: xor(17,17) == 0');
+       verify(xor(12,5) == 9,   '845: xor(12,5) == 9');
+       verify(mmin(3,7) == 3, '846: mmin(3,7) == 3');
+       verify(mmin(4,7) == -3, '847: mmin(4,7) == -3');
+       verify(digit(123,2) == 1, '848: digit(123,2) == 1');
+       verify(ismult(3/4, 1/7) == 0, '849: ismult(3/4, 1/7) == 0');
+       verify(gcd(3/4, 1/7) == 1/28, '850: gcd(3/4,1/7) == 1/28');
+       verify(gcd(2,3,1/2) == 1/2,     '851: gcd(2,3,1/2) == 1/2');
+       verify(gcd(17,7,1/7) == 1/7,    '852: gcd(17,7,1/7) == 1/7');
+       verify(gcd(2) == 2,             '853: gcd(2) == 2');
+       verify(gcd(-2) == 2,            '854: gcd(-2) == 2');
+       verify(floor(1.5) == 1,         '855: floor(1.5) == 1');
+       verify(floor(.5) == 0,          '856: floor(.5) == 0');
+       verify(floor(-.5) == -1,        '857: floor(-.5) == -1');
+       verify(floor(-1.5) == -2,       '858: floor(-1.5) == -2');
+       verify(ceil(1.5) == 2,          '859: floor(1.5) == 2');
+       verify(ceil(.5) == 1,           '860: floor(.5) == 1');
+       verify(ceil(-.5) == 0,          '861: floor(-.5) == 0');
+       verify(ceil(-1.5) == -1,        '862: floor(-1.5) == -1');
+       verify(frac(-7.2) == -.2,       '863: frac(-7.2) == -.2');
+       verify(gcd(4, 5, 1/3) == 1/3,   '864: gcd(4, 5, 1/3) == 1/3');
+       verify(ltol(7/25) == 24/25,     '865: ltol(7/25) == 24/25');
+       verify(hmean(1,2,3) == 18/11,   '866: hmean(1,2,3) == 18/11');
+       print '867: Ending test_functions';
+}
+print '018: parsed test_functions()';
+
+
+/*
+ * Test matrix operations
+ */
+define test_matrix()
+{
+       static mat b[4,4];
+       static mat binv[4,4] = {
+           0, 1, 0, 0, 2, -3/2, 2, -1/2, -3,
+           0.5, -1.0, 0.5, 1.0, 0.0, 0.0, 0.0
+       };
+
+       print '900: Beginning test_matrix';
+
+       b[0,0] = 0;
+       verify(b[0,0] == 0,     '901: b[0,0] == 0');
+       b[0,1] = 0;
+       verify(b[0,1] == 0,     '902: b[0,1] == 0');
+       b[0,2] = 0;
+       verify(b[0,2] == 0,     '903: b[0,2] == 0');
+       b[0,3] = 1;
+       verify(b[0,3] == 1,     '904: b[0,3] == 1');
+       b[1,0] = 1;
+       verify(b[1,0] == 1,     '905: b[1,0] == 1');
+       b[1,1] = 0;
+       verify(b[1,1] == 0,     '906: b[1,1] == 0');
+       b[1,2] = 0;
+       verify(b[1,2] == 0,     '907: b[1,2] == 0');
+       b[1,3] = 0;
+       verify(b[1,3] == 0,     '908: b[1,3] == 0');
+       b[2,0] = 1;
+       verify(b[2,0] == 1,     '909: b[2,0] == 1');
+       b[2,1] = 1;
+       verify(b[2,1] == 1,     '910: b[2,1] == 1');
+       b[2,2] = 1;
+       verify(b[2,2] == 1,     '911: b[2,2] == 1');
+       b[2,3] = 1;
+       verify(b[2,3] == 1,     '912: b[2,3] == 1');
+       b[3,0] = 1;
+       verify(b[3,0] == 1,     '913: b[3,0] == 1');
+       b[3,1] = 2;
+       verify(b[3,1] == 2,     '914: b[3,1] == 2');
+       b[3,2] = 4;
+       verify(b[3,2] == 4,     '915: b[3,2] == 4');
+       b[3,3] = 8;
+       verify(b[3,3] == 8,     '916: b[3,3] == 8');
+       verify(det(b) == -2,    '917: det(b) == -2');
+       verify(binv[0,0] == 0,  '918: binv[0,0] == 0');
+       verify(binv[0,1] == 1,  '919: binv[0,1] == 1');
+       verify(binv[0,2] == 0,  '920: binv[0,2] == 0');
+       verify(binv[0,3] == 0,  '921: binv[0,3] == 0');
+       verify(binv[1,0] == 2,  '922: binv[1,0] == 2');
+       verify(binv[1,1] == -3/2,       '923: binv[1,1] == -3/2');
+       verify(binv[1,2] == 2,  '924: binv[1,2] == 2');
+       verify(binv[1,3] == -1/2,       '925: binv[1,3] == -1/2');
+       verify(binv[2,0] == -3, '926: binv[2,0] == -3');
+       verify(binv[2,1] == 1/2,        '927: binv[2,1] == 1/2');
+       verify(binv[2,2] == -1, '928: binv[2,2] == -1');
+       verify(binv[2,3] == 1/2,        '929: binv[2,3] == 1/2');
+       verify(binv[3,0] == 1,  '930: binv[3,0] == 1');
+       verify(binv[3,1] == 0,  '931: binv[3,1] == 0');
+       verify(binv[3,2] == 0,  '932: binv[3,2] == 0');
+       verify(binv[3,3] == 0,  '933: binv[3,3] == 0');
+       verify(inverse(b) == binv,      '934: inverse(b) == binv');
+
+       print '999: Ending mat_functions';
+}
+print '019: parsed test_matrix()';
+
+
+read -once "lucas_chk";                /* obtain our needed Lucas library */
+print '020: read lucas_chk';
+
+/*
+ * Test the Lucas primality test library
+ */
+define test_lucas()
+{
+       print '1100: Beginning lucas check test';
+
+       verify(lucas_chk(100,1) == 1,   '1101: lucas_chk(100,1) == 1');
+
+       print '1102: Ending lucas check test';
+}
+print '021: parsed test_lucas()';
+
+
+read -once "surd";             /* obtain our needed surd library */
+print '022: read surd';
+
+/*
+ * Test objects
+ */
+define test_obj()
+{
+       static obj surd a;
+       static obj surd b;
+
+       print '1200: Beginning object test';
+
+       surd_type = -1;
+       verify(surd_type == -1,         '1201: surd_type == -1');
+       a = surd(2,3);
+       print                           '1202: a = surd(2,3)';
+       verify(a == surd(2,3),          '1203: a == surd(2,3)');
+       verify(surd_value(a) == 2+3i,   '1204: surd_value(a) == 2+3i');
+       verify(conj(a) == surd(2,-3),   '1205: conj(a) == surd(2,-3)');
+       verify(norm(a) == 13,           '1206: norm(a) == 13');
+       verify(a+1 == surd(3,3),        '1207: a+1 == surd(3,3)');
+       b = surd(3,4);
+       print                           '1208: b = surd(3,4)';
+       verify(a+b == surd(5,7),        '1209: a+b == surd(5,7)');
+       verify(a-b == surd(-1,-1),      '1210: a-b == surd(-1,-1)');
+       verify(++a == surd(3,3),        '1211: ++a == surd(3,3)');
+       verify(--a == surd(2,3),        '1212: --a == surd(2,3)');
+       verify(-a == surd(-2,-3),       '1213: -a == surd(-2,-3)');
+       verify(a*2 == surd(4,6),        '1214: a*2 == surd(4,6)');
+       verify(a*b == surd(-6,17),      '1215: a*b == surd(-6,17)');
+       verify(a^2 == surd(-5,12),      '1216: a^2 == surd(-5,12)');
+       verify(scale(a,2) == surd(8,12),'1217: scale(a,2) == surd(8,12)');
+       verify(a<<3 == surd(16,24),     '1218: a<<3 == surd(16,24)');
+       verify(a/2 == surd(1,1.5),      '1219: a/2 == surd(1,1.5)');
+       verify(a/b == surd(0.72,0.04),  '1220: a/b == surd(0.72,0.04)');
+       verify(1/b == surd(0.12,-0.16), '1221: 1/b == surd(0.12,-0.16)');
+       verify(inverse(b) == 1/b,       '1222: inverse(b) == 1/b');
+       verify(a != b,                  '1223: a != b');
+       surd_type = 2;
+       print                           '1224: surd_type = 2';
+       verify(surd_type == 2,          '1225: surd_type == 2');
+       verify(sgn(a) == 1,             '1226: sgn(a) == 1');
+       verify(a < b,                   '1227: a < b');
+       verify(a <= a,                  '1228: a < a');
+
+       print '1229: Ending object test';
+}
+print '023: parsed test_obj()';
+
+
+/*
+ * Test associations
+ */
+define test_assoc()
+{
+       static a;
+       static b;
+
+       print '1300: Beginning associations test';
+
+       a = assoc();
+       verify(size(a) == 0,            '1301: size(a) == 0');
+       a["curds"] = 13;
+       print                           '1302: a["curds"] = 13';
+       verify(a["curds"] == 13,        '1303: a["curds"] == 13');
+       a[13] = 17;
+       print                           '1304: a[13] = 17';
+       verify(a[13] == 17,             '1305: a[13] == 17');
+       verify(a[a["curds"]] == 17,     '1306: a[a["curds"]] == 17');
+       a[17] = 19;
+       print                           '1307: a[17] = 19';
+       verify(a[17] == 19,             '1308: a[17] == 19');
+       verify(a[a["curds"]+4] == 19,   '1309: a[a["curds"]+4] == 19');
+       verify(size(a) == 3,            '1310: size(a) == 3');
+       verify(a[[search(a,17)]] == 17, '1311: (a[[search(a,17)]] == 17');
+       verify(isnull(search(a,16)),    '1312: isnull(search(a,16))');
+       a["curds","whey"] = "spider";
+       print                           '1313: a["curds","whey"] = "spider"';
+       verify(a["curds","whey"] == "spider", '1314: a["curds","whey"] == "spider"');
+       verify(a[[rsearch(a,"spider")]] == "spider", '1315: a[[search(a,"spider")]] == "spider"');
+       b = a;
+       print                           '1316: b = a';
+       verify(b[17] == 19,             '1317: b[17] == 19');
+       verify(a == b,                  '1318: a == b');
+
+       print '1319: Ending associations test';
+}
+print '024: parsed test_assoc()';
+
+
+/*
+ * Test lists
+ */
+define test_list()
+{
+       static a;
+       static b;
+
+       print '1400: Beginning list test';
+
+       a = list(2,3,5);
+       verify(a == list(2,3,5),        '1401: a == list(2,3,5)');
+       verify(a[[0]] == 2,             '1402: a[[0]] == 2');
+       verify(a[[1]] == 3,             '1403: a[[1]] == 3');
+       verify(a[[2]] == 5,             '1404: a[[2]] == 5');
+       verify(size(a) == 3,            '1405: size(a) == 3');
+       verify(search(a,3) == 1,        '1406: search(a,3) == 1');
+       verify(isnull(search(a,3,2)),   '1407: isnull(search(a,3,2))');
+       verify(rsearch(a,3,2) == 1,     '1408: rsearch(a,3,2) == 1');
+       push(a,7);
+       print                           '1409: push(a,7)';
+       verify(search(a,7) == 0,        '1410: search(a,7) == 0');
+       verify(pop(a) == 7,             '1411: pop(a) == 7');
+       verify(size(a) == 3,            '1412: size(a) == 3');
+       append(a,7);
+       print                           '1413: append(a,7)';
+       verify(search(a,7) == 3,        '1414: search(a,7) == 3');
+       verify(size(a) == 4,            '1415: size(a) == 4');
+       verify(remove(a) == 7,          '1416: remove(a) == 7');
+       verify(size(a) == 3,            '1417: size(a) == 3');
+       b = a;
+       print                           '1418: b = a';
+       insert(a,1,7);
+       print                           '1410: insert(a,1,7)';
+       verify(search(a,2) == 0,        '1420: search(a,2) == 0');
+       verify(search(a,7) == 1,        '1421: search(a,7) == 1');
+       verify(search(a,3) == 2,        '1422: search(a,3) == 2');
+       verify(search(a,5) == 3,        '1423: search(a,5) == 3');
+       verify(size(a) == 4,            '1424: size(a) == 4');
+       verify(delete(a,1) == 7,        '1425: remove(a) == 7');
+       verify(search(a,2) == 0,        '1426: search(a,2) == 0');
+       verify(search(a,3) == 1,        '1427: search(a,3) == 1');
+       verify(search(a,5) == 2,        '1428: search(a,5) == 2');
+       verify(size(a) == 3,            '1429: size(a) == 3');
+       verify(a == b,                  '1430: a == b');
+
+       print '1431: Ending list test';
+}
+print '025: parsed test_list()';
+
+
+read -once "cryrand";          /* obtain our needed cryrand library */
+print '026: read cryrand';
+
+/*
+ * Test cryrand
+ */
+define test_cryrand()
+{
+       local init;             /* initial generator state */
+       local state0;           /* a generator state */
+       local state1;           /* a generator state */
+       local state2;           /* a generator state */
+       local tmp;
+
+       print '1500: Beginning cryrand test';
+
+       /* test save and restore of the initial state */
+       tmp = scryrand(0);
+       print                             '1501: tmp = scryrand(0)';
+       init = randstate();
+       print                             '1502: init = randstate()';
+       state0 = randstate(0);
+       print                             '1503: state0 = randstate(0)';
+       verify(state0 == init,            '1504: state0 == init');
+
+       /* test the crypto generator and save/restore of non-initial states */
+       verify(cryrand(40) == 0x9325e63866, 
+               '1505: cryrand(40) == 0x9325e63866');
+       state1 = randstate();
+       print                             '1506: state1 = randstate()';
+       verify(cryrand(36) == 0x4a171a7ff,  
+               '1507: cryrand(36) == 0x4a171a7ff');
+       state2 = randstate(state1);
+       print                             '1508: state2 = randstate(state1)';
+       verify(randstate() == state1,     '1509: randstate() == state1');
+       verify(cryrand(36) == 0x4a171a7ff,  
+               '1510: cryrand(36) == 0x4a171a7ff');
+       verify(state2 == randstate(),     '1511: state2 == randstate()');
+       state0 = randstate(init);
+       print                             '1512: state0 = randstate(init)';
+       verify(cryrand(40) == 0x9325e63866, 
+               '1513: cryrand(40) == 0x9325e63866');
+       verify(cryrand(18)<<18 | cryrand(18) == 0x4a171a7ff, \
+               '1514: cryrand(18)<<18 | cryrand(18) == 0x4a171a7ff');
+
+       /* test different forms of seeding the initial state */
+       tmp = srandom(0);
+       print                             '1515: tmp = srandom(0)';
+       verify(randstate() == init,       '1516: randstate() == init');
+       tmp = scryrand(0,-1,-1);
+       print                             '1517: tmp = scryrand(0,-1,-1)';
+       verify(randstate() == init,       '1518: randstate() == init');
+       tmp = sa55rand(0);
+       print                             '1519: tmp = sa55rand(0)';
+       verify(randstate() == init,       '1520: randstate() == init');
+       tmp = sshufrand(0);
+       print                             '1521: tmp = sshufrand(0)';
+       verify(randstate() == init,       '1522: randstate() == init');
+       tmp = srand(0);
+       print                             '1523: tmp = srand(0)';
+       verify(randstate() == init,       '1524: randstate() == init');
+
+       /* test the additive 55 and save/restore of initial state */
+       verify(a55rand() == 0xd83f26be64f3e34c, \
+               '1525: a55rand() == 0xd83f26be64f3e34c');
+       verify(a55rand() == 0x892d51655e2cfadf, \
+               '1526: a55rand() == 0x892d51655e2cfadf');
+       tmp = sa55rand(0);
+       print                             '1527: tmp = sa55rand(0)';
+       verify(a55rand() == 0xd83f26be64f3e34c, \
+               '1528: a55rand() == 0xd83f26be64f3e34c');
+
+       /* test the shuffle generator */
+       tmp = sshufrand(0);
+       print                             '1529: tmp = sshufrand(0)';
+       verify(shufrand() == 0x6a879c9a9cd4111c, \
+               '1530: shufrand() == 0x6a879c9a9cd4111c');
+       verify(shufrand() == 0xedd15f14a5c488c4, \
+               '1531: shufrand() == 0xedd15f14a5c488c4');
+       tmp = sshufrand(0);
+       print                             '1532: tmp = sshufrand(0)';
+       verify(shufrand() == 0x6a879c9a9cd4111c, \
+               '1533: shufrand() == 0x6a879c9a9cd4111c');
+       tmp = srand(0);
+       print                             '1534: tmp = srand(0)';
+       verify(shufrand() == 0x6a879c9a9cd4111c, \
+               '1535: shufrand() == 0x6a879c9a9cd4111c');
+
+       /* test the shuffle and additive 55 generator interaction */
+       tmp = sshufrand(0);
+       print                             '1536: tmp = sshufrand(0)';
+       verify(a55rand() == 0xd83f26be64f3e34c, \
+               '1537: a55rand() == 0xd83f26be64f3e34c');
+       tmp = sa55rand(0);
+       print                             '1538: tmp = sa55rand(0)';
+       verify(shufrand() == 0x6a879c9a9cd4111c, \
+               '1539: shufrand() == 0x6a879c9a9cd4111c');
+
+       /* test the crypto, shuffle and additive 55 interaction */
+       tmp = scryrand(0);
+       print                             '1540: tmp = scryrand(0)';
+       verify(a55rand() == 0xd83f26be64f3e34c, \
+               '1541: a55rand() == 0xd83f26be64f3e34c');
+       verify(cryrand(40) == 0x9325e63866, 
+               '1542: cryrand(40) == 0x9325e63866');
+       tmp = scryrand(0);
+       print                             '1543: tmp = scryrand(0)';
+       verify(shufrand() == 0x6a879c9a9cd4111c, \
+               '1544: shufrand() == 0x6a879c9a9cd4111c');
+       verify(cryrand(40)==0x9325e63866, '1545: cryrand(40) == 0x9325e63866');
+
+       /* test some of the misc generator interfaces */
+       /*scryrand(seed,len1,len2,arg4)
+       random(a,b)
+       nxtprime(n_arg, modval, modulus)*/
+       tmp = srand(0);
+       print                             '1546: tmp = srand(0)';
+       verify(rand(12345678901234567890) == 0x6a879c9a9cd4111c, \
+               '1547: rand(12345678901234567890) == 0x6a879c9a9cd4111c');
+       verify(rand(216091) == 0x880f,    '1548: rand(216091) == 0x880f');
+       tmp = scryrand(12,34,56);
+       print                             '1549: tmp = scryrand(12,34,56)';
+       verify(cryrand(40)==0xf23ddd31f4, '1550: cryrand(40) == 0xf23ddd31f4');
+       tmp = scryrand(78);
+       print                             '1551: tmp = scryrand(78)';
+       verify(cryrand(40)==0xac2b19be92, '1552: cryrand(40) == 0xac2b19be92');
+       tmp = scryrand(78^20+1);
+       print                             '1553: tmp = scryrand(78^20+1)';
+       verify(cryrand(40)==0xff80f86b37, '1554: cryrand(40) == 0xff80f86b37');
+       tmp = scryrand(0,1000,2000,345678);
+       print   '1555: tmp = scryrand(0,1000,2000,345678)';
+       verify(cryrand(40)==0xffd1ced04,  '1556: cryrand(40) == 0xffd1ced04');
+       tmp = scryrand(1,1000,2000,345678);
+       print   '1557: tmp = scryrand(1,1000,2000,345678)';
+       verify(cryrand(40)==0x4539c3849b, '1558: cryrand(40) == 0x4539c3849b');
+       tmp = scryrand(-1,0x5a7,0x8ef,0x936d4);
+       print   '1559: tmp = scryrand(-1,0x5a7,0x8ef,0x936d4)';
+       verify(cryrand(40)==0x4539c3849b, '1560: cryrand(40) == 0x4539c3849b');
+       verify(random() == 0xa5df751ccf2b5a01, \
+               '1561: random() == 0xa5df751ccf2b5a01');
+       tmp = srandom(0);
+       print                             '1562: tmp = srandom(0)';
+       verify(random() == 0x9325e638664a171a, \
+               '1563: random() == 0x9325e638664a171a');
+       verify(random(100) == 0x3f,       '1564: random(100) == 0x3f');
+       verify(random(-46,46) == -1,      '1565: random(-46,46) == -1');
+
+       /* verify nxtprime */
+       verify(nxtprime(100000)==100003,  '1566: nxtprime(100000) == 100003');
+       verify(nxtprime(100000,3,4)==100003,  \
+               '1567: nxtprime(100000,3,4) == 100003');
+       verify(nxtprime(100000,4,7)==100069,  \
+               '1568: nxtprime(100000,4,7) == 100069');
+
+       print '1569: Ending cryrand test';
+}
+print '027: parsed test_cryrand()';
+
+
+/*
+ * Config mode/base testing
+ */
+define test_mode()
+{
+       local tmp;
+
+       print '1600: Beginning cryrand test';
+
+       tmp = config("mode", "frac");
+       print                     '1601: tmp = config("mode", "frac")';
+       tmp = config("mode", "frac");
+       print                     '1602: tmp = config("mode", "frac")';
+       verify(base() == 1/3,     '1603: base() == 1/3');
+
+       tmp = config("mode", "int");
+       print                     '1604: tmp = config("mode", "int")';
+       verify(tmp == "frac",     '1605: tmp == "frac"');
+       verify(base() == -10,     '1606: base() == -10');
+
+       tmp = config("mode", "real");
+       print                     '1607: tmp = config("mode", "real")';
+       verify(tmp == "int",      '1608: tmp == "int"');
+       verify(base() == 10,      '1609: base() == 10');
+
+       tmp = config("mode", "exp");
+       print                     '1610: tmp = config("mode", "exp")';
+       verify(tmp == "real",     '1611: tmp == "real"');
+       verify(base() == 1e20,    '1612: base() == 1e20');
+
+       tmp = config("mode", "hex");
+       print                     '1613: tmp = config("mode", "hex")';
+       verify(tmp == "exp",      '1614: tmp == "exp"');
+       verify(base() == 16,      '1615: base() == 16');
+
+       tmp = config("mode", "oct");
+       print                     '1616: tmp = config("mode", "oct")';
+       verify(tmp == "hexadecimal", \
+               '1617: tmp == "hexadecimal"');
+       verify(base() == 8,       '1618: base() == 8');
+
+       tmp = config("mode", "bin");
+       print                     '1619: tmp = config("mode", "bin")';
+       verify(tmp == "octal",    '1620: tmp == "octal"');
+       verify(base() == 2,       '1621: base() == 2');
+
+       tmp = config("mode", "real");
+       print                     '1621: tmp = config("mode", "real")';
+       verify(tmp == "binary",   '1622: tmp == "binary"');
+
+       tmp = base(1/3);
+       print                     '1623: tmp = base(1/3)';
+       verify(config("mode") == "frac",   '1624: config("mode") == "frac"');
+
+       tmp = base(-10);
+       print                     '1625: tmp = base(-10)';
+       verify(config("mode") == "int",    '1626: config("mode") == "int"');
+
+       tmp = base(10);
+       print                     '1627: tmp = base(10)';
+       verify(config("mode") == "real",   '1628: config("mode") == "real"');
+
+       tmp = base(1e20);
+       print                     '1629: tmp = base(1e20)';
+       verify(config("mode") == "exp",    '1630: config("mode") == "exp"');
+
+       tmp = base(16);
+       print                     '1631: tmp = base(16)';
+       verify(config("mode") == "hexadecimal", \
+               '1632: config("mode") == "hexadecimal"');
+
+       tmp = base(8);
+       print                     '1633: tmp = base(16)';
+       verify(config("mode") == "octal",    '1634: config("mode") == "octal"');
+
+       tmp = base(2);
+       print                     '1635: tmp = base(16)';
+       verify(config("mode") == "binary", \
+               '1636: config("mode") == "binary"');
+
+       tmp = base(10);
+       print                     '1637: tmp = base(10)';
+
+       print '1638: Ending cryrand test';
+}
+print '028: parsed test_mode()';
+
+
+/*
+ * Report the number of errors found.
+ */
+define count_errors()
+{
+       if (err  ==  0) {
+               print "9998: passed all tests  /\\../\\";
+       } else {
+               print "****", err, "error(s) found  \\/++\\/";
+       }
+}
+print '029: parsed count_errors()';
+
+
+print '030: Ending main part of regression test suite read';
+print;
+return test_booleans();
+print;
+return test_variables();
+print;
+return test_logicals();
+print;
+return test_arithmetic();
+print;
+return test_strings();
+print;
+return test_bignums();
+print;
+return test_functions();
+print;
+return test_matrix();
+print;
+print '1000: Beginning read test';
+value = 0;
+verify(value == 0,     '1001: value == 0');
+read "test1000";
+verify(value == 1,     '1002: value == 1');
+read -once "test1000";
+verify(value == 1,     '1003: value == 1');
+read "test1000.cal";
+verify(value == 2,     '1004: value == 2');
+read -once "test1000.cal";
+verify(value == 2,     '1005: value == 2');
+read "test1000.cal";
+verify(value == 3,     '1006: value == 3');
+print '1007: Ending read test';
+print;
+return test_lucas();
+print;
+return test_obj();
+print;
+return test_assoc();
+print;
+return test_list();
+print;
+return test_cryrand();
+print;
+return test_mode();
+print;
+return count_errors();
+print '9999: Ending regression tests';
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/solve.cal b/usr/src/contrib/calc-2.9.3t6/lib/solve.cal
new file mode 100644 (file)
index 0000000..153fa7b
--- /dev/null
@@ -0,0 +1,48 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Solve the equation f(x) = 0 to within the desired error value for x.
+ * The function 'f' must be defined outside of this routine, and the low
+ * and high values are guesses which must produce values with opposite signs.
+ */
+
+define solve(low, high, epsilon)
+{
+       local flow, fhigh, fmid, mid, places;
+
+       if (isnull(epsilon))
+               epsilon = epsilon();
+       if (epsilon <= 0)
+               quit "Non-positive epsilon value";
+       places = highbit(1 + int(1/epsilon)) + 1;
+       flow = f(low);
+       if (abs(flow) < epsilon)
+               return low;
+       fhigh = f(high);
+       if (abs(flow) < epsilon)
+               return high;
+       if (sgn(flow) == sgn(fhigh))
+               quit "Non-opposite signs";
+       while (1) {
+               mid = bround(high - fhigh * (high - low) / (fhigh - flow), places);
+               if ((mid == low) || (mid == high))
+                       places++;
+               fmid = f(mid);
+               if (abs(fmid) < epsilon)
+                       return mid;
+               if (sgn(fmid) == sgn(flow)) {
+                       low = mid;
+                       flow = fmid;
+               } else {
+                       high = mid;
+                       fhigh = fmid;
+               }
+       }
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "solve(low, high, epsilon) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/sumsq.cal b/usr/src/contrib/calc-2.9.3t6/lib/sumsq.cal
new file mode 100644 (file)
index 0000000..2e8eaa2
--- /dev/null
@@ -0,0 +1,44 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Determine the unique two positive integers whose squares sum to the
+ * specified prime.  This is always possible for all primes of the form
+ * 4N+1, and always impossible for primes of the form 4N-1.
+ */
+
+define ss(p)
+{
+       local a, b, i, p4;
+
+       if (p == 2) {
+               print "1^2 + 1^2 = 2";
+               return;
+       }
+       if ((p % 4) != 1) {
+               print p, "is not of the form 4N+1";
+               return;
+       }
+       if (!ptest(p, min(p-2, 10))) {
+               print p, "is not a prime";
+               return;
+       }
+       p4 = (p - 1) / 4;
+       i = 2;
+       do {
+               a = pmod(i++, p4, p);
+       } while ((a^2 % p) == 1);
+       b = p;
+       while (b^2 > p) {
+               i = b % a;
+               b = a;
+               a = i;
+       }
+       print a : "^2 +" , b : "^2 =" , a^2 + b^2;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "ss(p) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/surd.cal b/usr/src/contrib/calc-2.9.3t6/lib/surd.cal
new file mode 100644 (file)
index 0000000..24b2ca7
--- /dev/null
@@ -0,0 +1,288 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Calculate using quadratic surds of the form: a + b * sqrt(D).
+ */
+
+obj surd {a, b};               /* definition of the surd object */
+
+global surd_type = -1;         /* type of surd (value of D) */
+static obj surd surd__;                /* example surd for testing against */
+
+
+define surd(a,b)
+{
+       local x;
+
+       obj surd x;
+       x.a = a;
+       x.b = b;
+       return x;
+}
+
+
+define surd_print(a)
+{
+       print "surd(" : a.a : ", " : a.b : ")" :;
+}
+
+
+define surd_conj(a)
+{
+       local   x;
+
+       obj surd x;
+       x.a = a.a;
+       x.b = -a.b;
+       return x;
+}
+
+
+define surd_norm(a)
+{
+       return a.a^2 + abs(surd_type) * a.b^2;
+}
+
+
+define surd_value(a, xepsilon)
+{
+       local   epsilon;
+
+       epsilon = xepsilon;
+       if (isnull(epsilon))
+               epsilon = epsilon();
+       return a.a + a.b * sqrt(surd_type, epsilon);
+}
+
+define surd_add(a, b)
+{
+       local obj surd  x;
+
+       if (!istype(b, x)) {
+               x.a = a.a + b;
+               x.b = a.b;
+               return x;
+       }
+       if (!istype(a, x)) {
+               x.a = a + b.a;
+               x.b = b.b;
+               return x;
+       }
+       x.a = a.a + b.a;
+       x.b = a.b + b.b;
+       if (x.b)
+               return x;
+       return x.a;
+}
+
+
+define surd_sub(a, b)
+{
+       local obj surd  x;
+
+       if (!istype(b, x)) {
+               x.a = a.a - b;
+               x.b = a.b;
+               return x;
+       }
+       if (!istype(a, x)) {
+               x.a = a - b.a;
+               x.b = -b.b;
+               return x;
+       }
+       x.a = a.a - b.a;
+       x.b = a.b - b.b;
+       if (x.b)
+               return x;
+       return x.a;
+}
+
+
+define surd_inc(a)
+{
+       local   x;
+
+       x = a;
+       x.a++;
+       return x;
+}
+
+
+define surd_dec(a)
+{
+       local   x;
+
+       x = a;
+       x.a--;
+       return x;
+}
+
+
+define surd_neg(a)
+{
+       local obj surd  x;
+
+       x.a = -a.a;
+       x.b = -a.b;
+       return x;
+}
+
+
+define surd_mul(a, b)
+{
+       local obj surd  x;
+
+       if (!istype(b, x)) {
+               x.a = a.a * b;
+               x.b = a.b * b;
+       } else if (!istype(a, x)) {
+               x.a = b.a * a;
+               x.b = b.b * a;
+       } else {
+               x.a = a.a * b.a + surd_type * a.b * b.b;
+               x.b = a.a * b.b + a.b * b.a;
+       }
+       if (x.b)
+               return x;
+       return x.a;
+}
+
+
+define surd_square(a)
+{
+       local obj surd  x;
+
+       x.a = a.a^2 + a.b^2 * surd_type;
+       x.b = a.a * a.b * 2;
+       if (x.b)
+               return x;
+       return x.a;
+}
+
+
+define surd_scale(a, b)
+{
+       local obj surd  x;
+
+       x.a = scale(a.a, b);
+       x.b = scale(a.b, b);
+       return x;
+}
+
+
+define surd_shift(a, b)
+{
+       local obj surd  x;
+
+       x.a = a.a << b;
+       x.b = a.b << b;
+       if (x.b)
+               return x;
+       return x.a;
+}
+
+
+define surd_div(a, b)
+{
+       local x, y;
+
+       if ((a == 0) && b)
+               return 0;
+       obj surd x;
+       if (!istype(b, x)) {
+               x.a = a.a / b;
+               x.b = a.b / b;
+               return x;
+       }
+       y = b;
+       y.b = -b.b;
+       return (a * y) / (b.a^2 - surd_type * b.b^2);
+}
+
+
+define surd_inv(a)
+{
+       return 1 / a;
+}
+
+
+define surd_sgn(a)
+{
+       if (surd_type < 0)
+               quit "Taking sign of complex surd";
+       if (a.a == 0)
+               return sgn(a.b);
+       if (a.b == 0)
+               return sgn(a.a);
+       if ((a.a > 0) && (a.b > 0))
+               return 1;
+       if ((a.a < 0) && (a.b < 0))
+               return -1;
+       return sgn(a.a^2 - a.b^2 * surd_type) * sgn(a.a);
+}
+
+
+define surd_cmp(a, b)
+{
+       if (!istype(a, surd__))
+               return ((b.b != 0) || (a != b.a));
+       if (!istype(b, surd__))
+               return ((a.b != 0) || (b != a.a));
+       return ((a.a != b.a) || (a.b != b.b));
+}
+
+
+define surd_rel(a, b)
+{
+       local x, y;
+
+       if (surd_type < 0)
+               quit "Relative comparison of complex surds";
+       if (!istype(a, surd__)) {
+               x = a - b.a;
+               y = -b.b;
+       } else if (!istype(b, surd__)) {
+               x = a.a - b;
+               y = a.b;
+       } else {
+               x = a.a - b.a;
+               y = a.b - b.b;
+       }
+       if (y == 0)
+               return sgn(x);
+       if (x == 0)
+               return sgn(y);
+       if ((x < 0) && (y < 0))
+               return -1;
+       if ((x > 0) && (y > 0))
+               return 1;
+       return sgn(x^2 - y^2 * surd_type) * sgn(x);
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "obj surd {a, b} defined";
+    print "surd(a, b) defined";
+    print "surd_print(a) defined";
+    print "surd_conj(a) defined";
+    print "surd_norm(a) defined";
+    print "surd_value(a, xepsilon) defined";
+    print "surd_add(a, b) defined";
+    print "surd_sub(a, b) defined";
+    print "surd_inc(a) defined";
+    print "surd_dec(a) defined";
+    print "surd_neg(a) defined";
+    print "surd_mul(a, b) defined";
+    print "surd_square(a) defined";
+    print "surd_scale(a, b) defined";
+    print "surd_shift(a, b) defined";
+    print "surd_div(a, b) defined";
+    print "surd_inv(a) defined";
+    print "surd_sgn(a) defined";
+    print "surd_cmp(a, b) defined";
+    print "surd_rel(a, b) defined";
+    print "surd_type defined";
+    print "set surd_type as needed";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/test1000.cal b/usr/src/contrib/calc-2.9.3t6/lib/test1000.cal
new file mode 100644 (file)
index 0000000..7af42a3
--- /dev/null
@@ -0,0 +1,12 @@
+/*
+ * Copyright (c) 1994 Landon Curt Noll
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * By: Landon Curt Noll
+ *     chongo@toad.com  -or-  ...!{pyramid,sun,uunet}!hoptoad!chongo
+ *
+ * This library is used by the 1000 serise of the regress.cal test suite.
+ */
+
+++value;
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/unitfrac.cal b/usr/src/contrib/calc-2.9.3t6/lib/unitfrac.cal
new file mode 100644 (file)
index 0000000..de3f933
--- /dev/null
@@ -0,0 +1,35 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Represent a fraction as sum of distinct unit fractions.
+ * The output is the unit fractions themselves, and in square brackets,
+ * the number of digits in the numerator and denominator of the value left
+ * to be found.  Numbers larger than 3.5 become very difficult to calculate.
+ */
+
+define unitfrac(x)
+{
+       local   d, di, n;
+
+       if (x <= 0)
+               quit "Non-positive argument";
+       d = 2;
+       do {
+               n = int(1 / x) + 1;
+               if (n > d)
+                       d = n;
+               di = 1/d;
+               print '  [': digits(num(x)): '/': digits(den(x)): ']',, di;
+               x -= di;
+               d++;
+       } while ((num(x) > 1) || (x == di) || (x == 1));
+       print '  [1/1]',, x;
+}
+
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "unitfrac(x) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lib/varargs.cal b/usr/src/contrib/calc-2.9.3t6/lib/varargs.cal
new file mode 100644 (file)
index 0000000..20f50e6
--- /dev/null
@@ -0,0 +1,29 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Example program to use 'varargs'.
+ *
+ * Program to sum the cubes of all the specified numbers.
+ */
+
+define sc()
+{
+       local s, i;
+
+       s = 0;
+       for (i = 1; i <= param(0); i++) {
+               if (!isnum(param(i))) {
+                       print "parameter",i,"is not a number";
+                       continue;
+               }
+               s += param(i)^3;
+       }
+       return s;
+}
+
+global lib_debug;
+if (lib_debug >= 0) {
+    print "sc(a, b, ...) defined";
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/lint.sed b/usr/src/contrib/calc-2.9.3t6/lint.sed
new file mode 100644 (file)
index 0000000..35eb60e
--- /dev/null
@@ -0,0 +1,37 @@
+/: warning: conversion from long may lose accuracy$/d
+/: warning: possible pointer alignment problem$/d
+/^Lint pass[0-9][0-9]*:$/d
+/^[a-zA-Z][a-zA-Z0-9_-]*\.c:[  ]*$/d
+/^addglobal, arg\. 2 used inconsistently[       ]/d
+/^addopptr, arg\. 2 used inconsistently[        ]/d
+/^codegen\.c([0-9]*):getassignment returns value which is sometimes ignored$/d
+/^errno used([         ]*func\.c([0-9]*)[      ]*), but not defined$/d
+/^exit value declared inconsistently[  ]/d
+/^fclose returns value which is sometimes ignored$/d
+/^fflush returns value which is always ignored$/d
+/^fprintf returns value which is always ignored$/d
+/^fputc returns value which is always ignored$/d
+/^fputs returns value which is always ignored$/d
+/^free, arg\. 1 used inconsistently[   ]/d
+/^geteuid value declared inconsistently[       ]/d
+/^geteuid value used inconsistently[   ]/d
+/^getpwuid, arg\. 1 used inconsistently[       ]/d
+/^malloc, arg\. 1 used inconsistently[         ]/d
+/^math_setdigits returns value which is always ignored$/d
+/^math_setmode returns value which is sometimes ignored$/d
+/^memcpy returns value which is always ignored$/d
+/^memcpy value declared inconsistently[        ]/d
+/^memcpy, arg\. [1-3] used inconsistently[     ]/d
+/^memset value declared inconsistently[        ]/d
+/^printf returns value which is always ignored$/d
+/^putc returns value which is always ignored$/d
+/^qcfappr, arg\. 2 used inconsistently[        ]/d
+/^realloc, arg\. [1-2] used inconsistently[    ]/d
+/^sprintf returns value which is always ignored/d
+/^strcat returns value which is always ignored/d
+/^strcpy returns value which is always ignored/d
+/^strncpy returns value which is always ignored/d
+/^strncpy, arg\. [1-3] used inconsistently[    ]/d
+/^system returns value which is always ignored/d
+/^times returns value which is always ignored/d
+/^vsprintf returns value which is always ignored/d
diff --git a/usr/src/contrib/calc-2.9.3t6/listfunc.c b/usr/src/contrib/calc-2.9.3t6/listfunc.c
new file mode 100644 (file)
index 0000000..3337a6e
--- /dev/null
@@ -0,0 +1,549 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * List handling routines.
+ * Lists can be composed of any types of values, mixed if desired.
+ * Lists are doubly linked so that elements can be inserted or
+ * deleted efficiently at any point in the list.  A pointer is
+ * kept to the most recently indexed element so that sequential
+ * accesses are fast.
+ */
+
+#include "value.h"
+
+
+static LISTELEM *elemalloc MATH_PROTO((void));
+static LISTELEM *listelement MATH_PROTO((LIST *lp, long index));
+static void elemfree MATH_PROTO((LISTELEM *ep));
+static void removelistelement MATH_PROTO((LIST *lp, LISTELEM *ep));
+
+
+/*
+ * Free lists for list headers and list elements.
+ */
+static FREELIST        headerfreelist = {
+       sizeof(LIST),           /* size of list header */
+       20                      /* number of free headers to keep */
+};
+
+static FREELIST elementfreelist = {
+       sizeof(LISTELEM),       /* size of list element */
+       1000                    /* number of free list elements to keep */
+};
+
+
+/*
+ * Insert an element before the first element of a list.
+ */
+void
+insertlistfirst(lp, vp)
+       LIST *lp;               /* list to put element onto */
+       VALUE *vp;              /* value to be inserted */
+{
+       LISTELEM *ep;           /* list element */
+
+       ep = elemalloc();
+       copyvalue(vp, &ep->e_value);
+       if (lp->l_count == 0)
+               lp->l_last = ep;
+       else {
+               lp->l_cacheindex++;
+               lp->l_first->e_prev = ep;
+               ep->e_next = lp->l_first;
+       }
+       lp->l_first = ep;
+       lp->l_count++;
+}
+
+
+/*
+ * Insert an element after the last element of a list.
+ */
+void
+insertlistlast(lp, vp)
+       LIST *lp;               /* list to put element onto */
+       VALUE *vp;              /* value to be inserted */
+{
+       LISTELEM *ep;           /* list element */
+
+       ep = elemalloc();
+       copyvalue(vp, &ep->e_value);
+       if (lp->l_count == 0)
+               lp->l_first = ep;
+       else {
+               lp->l_last->e_next = ep;
+               ep->e_prev = lp->l_last;
+       }
+       lp->l_last = ep;
+       lp->l_count++;
+}
+
+
+/*
+ * Insert an element into the middle of list at the given index (zero based).
+ * The specified index will select the new element, so existing elements
+ * at or beyond the index will be shifted down one position.  It is legal
+ * to specify an index which is right at the end of the list, in which
+ * case the element is appended to the list.
+ */
+void
+insertlistmiddle(lp, index, vp)
+       LIST *lp;               /* list to put element onto */
+       long index;             /* element number to insert in front of */
+       VALUE *vp;              /* value to be inserted */
+{
+       LISTELEM *ep;           /* list element */
+       LISTELEM *oldep;        /* old list element at desired index */
+
+       if (index == 0) {
+               insertlistfirst(lp, vp);
+               return;
+       }
+       if (index == lp->l_count) {
+               insertlistlast(lp, vp);
+               return;
+       }
+       oldep = NULL;
+       if ((index >= 0) && (index < lp->l_count))
+               oldep = listelement(lp, index);
+       if (oldep == NULL)
+               math_error("Index out of bounds for list insertion");
+       ep = elemalloc();
+       copyvalue(vp, &ep->e_value);
+       ep->e_next = oldep;
+       ep->e_prev = oldep->e_prev;
+       ep->e_prev->e_next = ep;
+       oldep->e_prev = ep;
+       lp->l_cache = ep;
+       lp->l_cacheindex = index;
+       lp->l_count++;
+}
+
+
+/*
+ * Remove the first element from a list, returning its value.
+ * Returns the null value if no more elements exist.
+ */
+void
+removelistfirst(lp, vp)
+       LIST *lp;               /* list to have element removed */
+       VALUE *vp;              /* location of the value */
+{
+       if (lp->l_count == 0) {
+               vp->v_type = V_NULL;
+               return;
+       }
+       *vp = lp->l_first->e_value;
+       lp->l_first->e_value.v_type = V_NULL;
+       removelistelement(lp, lp->l_first);
+}
+
+
+/*
+ * Remove the last element from a list, returning its value.
+ * Returns the null value if no more elements exist.
+ */
+void
+removelistlast(lp, vp)
+       LIST *lp;               /* list to have element removed */
+       VALUE *vp;              /* location of the value */
+{
+       if (lp->l_count == 0) {
+               vp->v_type = V_NULL;
+               return;
+       }
+       *vp = lp->l_last->e_value;
+       lp->l_last->e_value.v_type = V_NULL;
+       removelistelement(lp, lp->l_last);
+}
+
+
+/*
+ * Remove the element with the given index from a list, returning its value.
+ */
+void
+removelistmiddle(lp, index, vp)
+       LIST *lp;               /* list to have element removed */
+       long index;             /* list element to be removed */
+       VALUE *vp;              /* location of the value */
+{
+       LISTELEM *ep;           /* element being removed */
+
+       ep = NULL;
+       if ((index >= 0) && (index < lp->l_count))
+               ep = listelement(lp, index);
+       if (ep == NULL)
+               math_error("Index out of bounds for list deletion");
+       *vp = ep->e_value;
+       ep->e_value.v_type = V_NULL;
+       removelistelement(lp, ep);
+}
+
+
+/*
+ * Remove an arbitrary element from a list.
+ * The value contained in the element is freed.
+ */
+static void
+removelistelement(lp, ep)
+       register LIST *lp;              /* list header */
+       register LISTELEM *ep;          /* list element to remove */
+{
+       if ((ep == lp->l_cache) || ((ep != lp->l_first) && (ep != lp->l_last)))
+               lp->l_cache = NULL;
+       if (ep->e_next)
+               ep->e_next->e_prev = ep->e_prev;
+       if (ep->e_prev)
+               ep->e_prev->e_next = ep->e_next;
+       if (ep == lp->l_first) {
+               lp->l_first = ep->e_next;
+               lp->l_cacheindex--;
+       }
+       if (ep == lp->l_last)
+               lp->l_last = ep->e_prev;
+       lp->l_count--;
+       elemfree(ep);
+}
+
+
+/*
+ * Search a list for the specified value starting at the specified index.
+ * Returns the element number (zero based) of the found value, or -1 if
+ * the value was not found.
+ */
+long
+listsearch(lp, vp, index)
+       LIST *lp;
+       VALUE *vp;
+       long index;
+{
+       register LISTELEM *ep;
+
+       if (index < 0)
+               index = 0;
+       ep = listelement(lp, index);
+       while (ep) {
+               if (!comparevalue(&ep->e_value, vp)) {
+                       lp->l_cache = ep;
+                       lp->l_cacheindex = index;
+                       return index;
+               }
+               ep = ep->e_next;
+               index++;
+       }
+       return -1;
+}
+
+
+/*
+ * Search a list backwards for the specified value starting at the
+ * specified index.  Returns the element number (zero based) of the
+ * found value, or -1 if the value was not found.
+ */
+long
+listrsearch(lp, vp, index)
+       LIST *lp;
+       VALUE *vp;
+       long index;
+{
+       register LISTELEM *ep;
+
+       if (index >= lp->l_count)
+               index = lp->l_count - 1;
+       ep = listelement(lp, index);
+       while (ep) {
+               if (!comparevalue(&ep->e_value, vp)) {
+                       lp->l_cache = ep;
+                       lp->l_cacheindex = index;
+                       return index;
+               }
+               ep = ep->e_prev;
+               index--;
+       }
+       return -1;
+}
+
+
+/*
+ * Index into a list and return the address for the value corresponding
+ * to that index.  Returns NULL if the element does not exist.
+ */
+VALUE *
+listfindex(lp, index)
+       LIST *lp;               /* list to index into */
+       long index;             /* index of desired element */
+{
+       LISTELEM *ep;
+
+       ep = listelement(lp, index);
+       if (ep == NULL)
+               return NULL;
+       return &ep->e_value;
+}
+
+
+/*
+ * Return the element at a specified index number of a list.
+ * The list is indexed starting at zero, and negative indices
+ * indicate to index from the end of the list.  This routine finds
+ * the element by chaining through the list from the closest one
+ * of the first, last, and cached elements.  Returns NULL if the
+ * element does not exist.
+ */
+static LISTELEM *
+listelement(lp, index)
+       register LIST *lp;      /* list to index into */
+       long index;             /* index of desired element */
+{
+       register LISTELEM *ep;  /* current list element */
+       long dist;              /* distance to element */
+       long temp;              /* temporary distance */
+       BOOL forward;           /* TRUE if need to walk forwards */
+
+       if (index < 0)
+               index += lp->l_count;
+       if ((index < 0) || (index >= lp->l_count))
+               return NULL;
+       /*
+        * Check quick special cases first.
+        */
+       if (index == 0)
+               return lp->l_first;
+       if (index == 1)
+               return lp->l_first->e_next;
+       if (index == lp->l_count - 1)
+               return lp->l_last;
+       if ((index == lp->l_cacheindex) && lp->l_cache)
+               return lp->l_cache;
+       /*
+        * Calculate whether it is better to go forwards from
+        * the first element or backwards from the last element.
+        */
+       forward = ((index * 2) <= lp->l_count);
+       if (forward) {
+               dist = index;
+               ep = lp->l_first;
+       } else {
+               dist = (lp->l_count - 1) - index;
+               ep = lp->l_last;
+       }
+       /*
+        * Now see if we have a cached element and if so, whether or
+        * not the distance from it is better than the above distance.
+        */
+       if (lp->l_cache) {
+               temp = index - lp->l_cacheindex;
+               if ((temp >= 0) && (temp < dist)) {
+                       dist = temp;
+                       ep = lp->l_cache;
+                       forward = TRUE;
+               }
+               if ((temp < 0) && (-temp < dist)) {
+                       dist = -temp;
+                       ep = lp->l_cache;
+                       forward = FALSE;
+               }
+       }
+       /*
+        * Now walk forwards or backwards from the selected element
+        * until we reach the correct element.  Cache the location of
+        * the found element for future use.
+        */
+       if (forward) {
+               while (dist-- > 0)
+                       ep = ep->e_next;
+       } else {
+               while (dist-- > 0)
+                       ep = ep->e_prev;
+       }
+       lp->l_cache = ep;
+       lp->l_cacheindex = index;
+       return ep;
+}
+
+
+/*
+ * Compare two lists to see if they are identical.
+ * Returns TRUE if they are different.
+ */
+BOOL
+listcmp(lp1, lp2)
+       LIST *lp1, *lp2;
+{
+       LISTELEM *e1, *e2;
+       long count;
+
+       if (lp1 == lp2)
+               return FALSE;
+       if (lp1->l_count != lp2->l_count)
+               return TRUE;
+       e1 = lp1->l_first;
+       e2 = lp2->l_first;
+       count = lp1->l_count;
+       while (count-- > 0) {
+               if (comparevalue(&e1->e_value, &e2->e_value))
+                       return TRUE;
+               e1 = e1->e_next;
+               e2 = e2->e_next;
+       }
+       return FALSE;
+}
+
+
+/*
+ * Copy a list
+ */
+LIST *
+listcopy(oldlp)
+       LIST *oldlp;
+{
+       LIST *lp;
+       LISTELEM *oldep;
+
+       lp = listalloc();
+       oldep = oldlp->l_first;
+       while (oldep) {
+               insertlistlast(lp, &oldep->e_value);
+               oldep = oldep->e_next;
+       }
+       return lp;
+}
+
+
+/*
+ * Allocate an element for a list.
+ */
+static LISTELEM *
+elemalloc()
+{
+       LISTELEM *ep;
+
+       ep = (LISTELEM *) allocitem(&elementfreelist);
+       if (ep == NULL)
+               math_error("Cannot allocate list element");
+       ep->e_next = NULL;
+       ep->e_prev = NULL;
+       ep->e_value.v_type = V_NULL;
+       return ep;
+}
+
+
+/*
+ * Free a list element, along with any contained value.
+ */
+static void
+elemfree(ep)
+       LISTELEM *ep;
+{
+       if (ep->e_value.v_type != V_NULL)
+               freevalue(&ep->e_value);
+       freeitem(&elementfreelist, (FREEITEM *) ep);
+}
+
+
+/*
+ * Allocate a new list header.
+ */
+LIST *
+listalloc()
+{
+       register LIST *lp;
+
+       lp = (LIST *) allocitem(&headerfreelist);
+       if (lp == NULL)
+               math_error("Cannot allocate list header");
+       lp->l_first = NULL;
+       lp->l_last = NULL;
+       lp->l_cache = NULL;
+       lp->l_cacheindex = 0;
+       lp->l_count = 0;
+       return lp;
+}
+
+
+/*
+ * Free a list header, along with all of its list elements.
+ */
+void
+listfree(lp)
+       register LIST *lp;
+{
+       register LISTELEM *ep;
+
+       while (lp->l_count-- > 0) {
+               ep = lp->l_first;
+               lp->l_first = ep->e_next;
+               elemfree(ep);
+       }
+       freeitem(&headerfreelist, (FREEITEM *) lp);
+}
+
+
+/*
+ * Print out a list along with the specified number of its elements.
+ * The elements are printed out in shortened form.
+ */
+void
+listprint(lp, max_print)
+       LIST *lp;
+       long max_print;
+{
+       long count;
+       long index;
+       LISTELEM *ep;
+
+       if (max_print > lp->l_count)
+               max_print = lp->l_count;
+       count = 0;
+       ep = lp->l_first;
+       index = lp->l_count;
+       while (index-- > 0) {
+               if ((ep->e_value.v_type != V_NUM) ||
+                       (!qiszero(ep->e_value.v_num)))
+                               count++;
+               ep = ep->e_next;
+       }
+       if (max_print > 0)
+               math_str("\n");
+       math_fmt("list (%ld element%s, %ld nonzero)", lp->l_count,
+               ((lp->l_count == 1) ? "" : "s"), count);
+       if (max_print <= 0)
+               return;
+
+       /*
+        * Walk through the first few list elements, printing their
+        * value in short and unambiguous format.
+        */
+       math_str(":\n");
+       ep = lp->l_first;
+       for (index = 0; index < max_print; index++) {
+               math_fmt("  [[%ld]] = ", index);
+               printvalue(&ep->e_value, PRINT_SHORT | PRINT_UNAMBIG);
+               math_str("\n");
+               ep = ep->e_next;
+       }
+       if (max_print < lp->l_count)
+               math_str("  ...\n");
+}
+
+
+/*
+ * Return a trivial hash value for a list.
+ */
+HASH
+listhash(lp)
+       LIST *lp;
+{
+       HASH hash;
+
+       hash = lp->l_count * 600011;
+       if (lp->l_count > 0)
+               hash = hash * 600043 + hashvalue(&lp->l_first->e_value);
+       if (lp->l_count > 1)
+               hash = hash * 600053 + hashvalue(&lp->l_last->e_value);
+       return hash;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/longbits.c b/usr/src/contrib/calc-2.9.3t6/longbits.c
new file mode 100644 (file)
index 0000000..80229e4
--- /dev/null
@@ -0,0 +1,39 @@
+/*
+ * longbits - Determine the number if bits in a long
+ *
+ * Not all (in fact very few) C pre-processors can do:
+ *
+ *     #if sizeof(long) == 8
+ *
+ * so we have to form LONG_BITS ahead of time.
+ */
+/*
+ * Copyright (c) 1994 by Landon Curt Noll.  All Rights Reserved.
+ *
+ * Permission to use, copy, modify, and distribute this software and
+ * its documentation for any purpose and without fee is hereby granted,
+ * provided that the above copyright, this permission notice and text
+ * this comment, and the disclaimer below appear in all of the following:
+ *
+ *     supporting documentation
+ *     source copies
+ *     source works derived from this source
+ *     binaries derived from this source or from derived source
+ *
+ * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
+ * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO
+ * EVENT SHALL LANDON CURT NOLL BE LIABLE FOR ANY SPECIAL, INDIRECT OR
+ * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF
+ * USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ *
+ * chongo was here     /\../\
+ */
+
+main()
+{
+    printf("#undef LONG_BITS\n");
+    printf("#define LONG_BITS %ld\n", sizeof(long)*8);
+    exit(0);
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/matfunc.c b/usr/src/contrib/calc-2.9.3t6/matfunc.c
new file mode 100644 (file)
index 0000000..581b833
--- /dev/null
@@ -0,0 +1,1361 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Extended precision rational arithmetic matrix functions.
+ * Matrices can contain arbitrary types of elements.
+ */
+
+#include "value.h"
+
+
+static void matswaprow MATH_PROTO((MATRIX *m, long r1, long r2));
+static void matsubrow MATH_PROTO((MATRIX *m, long oprow, long baserow,
+       VALUE *mulval));
+static void matmulrow MATH_PROTO((MATRIX *m, long row, VALUE *mulval));
+static MATRIX *matident MATH_PROTO((MATRIX *m));
+
+
+
+/*
+ * Add two compatible matrices.
+ */
+MATRIX *
+matadd(m1, m2)
+       MATRIX *m1, *m2;
+{
+       int dim;
+
+       long min1, min2, max1, max2, index;
+       VALUE *v1, *v2, *vres;
+       MATRIX *res;
+       MATRIX tmp;
+
+       if (m1->m_dim != m2->m_dim)
+               math_error("Incompatible matrix dimensions for add");
+       tmp.m_dim = m1->m_dim;
+       tmp.m_size = m1->m_size;
+       for (dim = 0; dim < m1->m_dim; dim++) {
+               min1 = m1->m_min[dim];
+               max1 = m1->m_max[dim];
+               min2 = m2->m_min[dim];
+               max2 = m2->m_max[dim];
+               if ((min1 && min2 && (min1 != min2)) || ((max1-min1) != (max2-min2)))
+                       math_error("Incompatible matrix bounds for add");
+               tmp.m_min[dim] = (min1 ? min1 : min2);
+               tmp.m_max[dim] = tmp.m_min[dim] + (max1 - min1);
+       }
+       res = matalloc(m1->m_size);
+       *res = tmp;
+       v1 = m1->m_table;
+       v2 = m2->m_table;
+       vres = res->m_table;
+       for (index = m1->m_size; index > 0; index--)
+               addvalue(v1++, v2++, vres++);
+       return res;
+}
+
+
+/*
+ * Subtract two compatible matrices.
+ */
+MATRIX *
+matsub(m1, m2)
+       MATRIX *m1, *m2;
+{
+       int dim;
+       long min1, min2, max1, max2, index;
+       VALUE *v1, *v2, *vres;
+       MATRIX *res;
+       MATRIX tmp;
+
+       if (m1->m_dim != m2->m_dim)
+               math_error("Incompatible matrix dimensions for sub");
+       tmp.m_dim = m1->m_dim;
+       tmp.m_size = m1->m_size;
+       for (dim = 0; dim < m1->m_dim; dim++) {
+               min1 = m1->m_min[dim];
+               max1 = m1->m_max[dim];
+               min2 = m2->m_min[dim];
+               max2 = m2->m_max[dim];
+               if ((min1 && min2 && (min1 != min2)) || ((max1-min1) != (max2-min2)))
+                       math_error("Incompatible matrix bounds for sub");
+               tmp.m_min[dim] = (min1 ? min1 : min2);
+               tmp.m_max[dim] = tmp.m_min[dim] + (max1 - min1);
+       }
+       res = matalloc(m1->m_size);
+       *res = tmp;
+       v1 = m1->m_table;
+       v2 = m2->m_table;
+       vres = res->m_table;
+       for (index = m1->m_size; index > 0; index--)
+               subvalue(v1++, v2++, vres++);
+       return res;
+}
+
+
+/*
+ * Produce the negative of a matrix.
+ */
+MATRIX *
+matneg(m)
+       MATRIX *m;
+{
+       register VALUE *val, *vres;
+       long index;
+       MATRIX *res;
+
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               negvalue(val++, vres++);
+       return res;
+}
+
+
+/*
+ * Multiply two compatible matrices.
+ */
+MATRIX *
+matmul(m1, m2)
+       MATRIX *m1, *m2;
+{
+       register MATRIX *res;
+       long i1, i2, max1, max2, index, maxindex;
+       VALUE *v1, *v2;
+       VALUE sum, tmp1, tmp2;
+
+       if ((m1->m_dim != 2) || (m2->m_dim != 2))
+               math_error("Matrix dimension must be two for mul");
+       if ((m1->m_max[1] - m1->m_min[1]) != (m2->m_max[0] - m2->m_min[0]))
+               math_error("Incompatible bounds for matrix mul");
+       max1 = (m1->m_max[0] - m1->m_min[0] + 1);
+       max2 = (m2->m_max[1] - m2->m_min[1] + 1);
+       maxindex = (m1->m_max[1] - m1->m_min[1] + 1);
+       res = matalloc(max1 * max2);
+       res->m_dim = 2;
+       res->m_min[0] = m1->m_min[0];
+       res->m_max[0] = m1->m_max[0];
+       res->m_min[1] = m2->m_min[1];
+       res->m_max[1] = m2->m_max[1];
+       for (i1 = 0; i1 < max1; i1++) {
+               for (i2 = 0; i2 < max2; i2++) {
+                       sum.v_num = qlink(&_qzero_);
+                       sum.v_type = V_NUM;
+                       v1 = &m1->m_table[i1 * maxindex];
+                       v2 = &m2->m_table[i2];
+                       for (index = 0; index < maxindex; index++) {
+                               mulvalue(v1, v2, &tmp1);
+                               addvalue(&sum, &tmp1, &tmp2);
+                               freevalue(&tmp1);
+                               freevalue(&sum);
+                               sum = tmp2;
+                               v1++;
+                               v2 += max2;
+                       }
+                       index = (i1 * max2) + i2;
+                       res->m_table[index] = sum;
+               }
+       }
+       return res;
+}
+
+
+/*
+ * Square a matrix.
+ */
+MATRIX *
+matsquare(m)
+       MATRIX *m;
+{
+       register MATRIX *res;
+       long i1, i2, max, index;
+       VALUE *v1, *v2;
+       VALUE sum, tmp1, tmp2;
+
+       if (m->m_dim != 2)
+               math_error("Matrix dimension must be two for square");
+       if ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1]))
+               math_error("Squaring non-square matrix");
+       max = (m->m_max[0] - m->m_min[0] + 1);
+       res = matalloc(max * max);
+       res->m_dim = 2;
+       res->m_min[0] = m->m_min[0];
+       res->m_max[0] = m->m_max[0];
+       res->m_min[1] = m->m_min[1];
+       res->m_max[1] = m->m_max[1];
+       for (i1 = 0; i1 < max; i1++) {
+               for (i2 = 0; i2 < max; i2++) {
+                       sum.v_num = qlink(&_qzero_);
+                       sum.v_type = V_NUM;
+                       v1 = &m->m_table[i1 * max];
+                       v2 = &m->m_table[i2];
+                       for (index = 0; index < max; index++) {
+                               mulvalue(v1, v2, &tmp1);
+                               addvalue(&sum, &tmp1, &tmp2);
+                               freevalue(&tmp1);
+                               freevalue(&sum);
+                               sum = tmp2;
+                               v1++;
+                               v2 += max;
+                       }
+                       index = (i1 * max) + i2;
+                       res->m_table[index] = sum;
+               }
+       }
+       return res;
+}
+
+
+/*
+ * Compute the result of raising a square matrix to an integer power.
+ * Negative powers mean the positive power of the inverse.
+ * Note: This calculation could someday be improved for large powers
+ * by using the characteristic polynomial of the matrix.
+ */
+MATRIX *
+matpowi(m, q)
+       MATRIX *m;              /* matrix to be raised */
+       NUMBER *q;              /* power to raise it to */
+{
+       MATRIX *res, *tmp;
+       long power;             /* power to raise to */
+       unsigned long bit;      /* current bit value */
+
+       if (m->m_dim != 2)
+               math_error("Matrix dimension must be two for power");
+       if ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1]))
+               math_error("Raising non-square matrix to a power");
+       if (qisfrac(q))
+               math_error("Raising matrix to non-integral power");
+       if (zisbig(q->num))
+               math_error("Raising matrix to very large power");
+       power = (zistiny(q->num) ? z1tol(q->num) : z2tol(q->num));
+       if (qisneg(q))
+               power = -power;
+       /*
+        * Handle some low powers specially
+        */
+       if ((power <= 4) && (power >= -2)) {
+               switch ((int) power) {
+                       case 0:
+                               return matident(m);
+                       case 1:
+                               return matcopy(m);
+                       case -1:
+                               return matinv(m);
+                       case 2:
+                               return matsquare(m);
+                       case -2:
+                               tmp = matinv(m);
+                               res = matsquare(tmp);
+                               matfree(tmp);
+                               return res;
+                       case 3:
+                               tmp = matsquare(m);
+                               res = matmul(m, tmp);
+                               matfree(tmp);
+                               return res;
+                       case 4:
+                               tmp = matsquare(m);
+                               res = matsquare(tmp);
+                               matfree(tmp);
+                               return res;
+               }
+       }
+       if (power < 0) {
+               m = matinv(m);
+               power = -power;
+       }
+       /*
+        * Compute the power by squaring and multiplying.
+        * This uses the left to right method of power raising.
+        */
+       bit = TOPFULL;
+       while ((bit & power) == 0)
+               bit >>= 1L;
+       bit >>= 1L;
+       res = matsquare(m);
+       if (bit & power) {
+               tmp = matmul(res, m);
+               matfree(res);
+               res = tmp;
+       }
+       bit >>= 1L;
+       while (bit) {
+               tmp = matsquare(res);
+               matfree(res);
+               res = tmp;
+               if (bit & power) {
+                       tmp = matmul(res, m);
+                       matfree(res);
+                       res = tmp;
+               }
+               bit >>= 1L;
+       }
+       if (qisneg(q))
+               matfree(m);
+       return res;
+}
+
+
+/*
+ * Calculate the cross product of two one dimensional matrices each
+ * with three components.
+ *     m3 = matcross(m1, m2);
+ */
+MATRIX *
+matcross(m1, m2)
+       MATRIX *m1, *m2;
+{
+       MATRIX *res;
+       VALUE *v1, *v2, *vr;
+       VALUE tmp1, tmp2;
+
+       if ((m1->m_dim != 1) || (m2->m_dim != 1))
+               math_error("Matrix not 1d for cross product");
+       if ((m1->m_size != 3) || (m2->m_size != 3))
+               math_error("Matrix not size 3 for cross product");
+       res = matalloc(3L);
+       res->m_dim = 1;
+       res->m_min[0] = 0;
+       res->m_max[0] = 2;
+       v1 = m1->m_table;
+       v2 = m2->m_table;
+       vr = res->m_table;
+       mulvalue(v1 + 1, v2 + 2, &tmp1);
+       mulvalue(v1 + 2, v2 + 1, &tmp2);
+       subvalue(&tmp1, &tmp2, vr + 0);
+       freevalue(&tmp1);
+       freevalue(&tmp2);
+       mulvalue(v1 + 2, v2 + 0, &tmp1);
+       mulvalue(v1 + 0, v2 + 2, &tmp2);
+       subvalue(&tmp1, &tmp2, vr + 1);
+       freevalue(&tmp1);
+       freevalue(&tmp2);
+       mulvalue(v1 + 0, v2 + 1, &tmp1);
+       mulvalue(v1 + 1, v2 + 0, &tmp2);
+       subvalue(&tmp1, &tmp2, vr + 2);
+       freevalue(&tmp1);
+       freevalue(&tmp2);
+       return res;
+}
+
+
+/*
+ * Return the dot product of two matrices.
+ *     result = matdot(m1, m2);
+ */
+VALUE
+matdot(m1, m2)
+       MATRIX *m1, *m2;
+{
+       VALUE *v1, *v2;
+       VALUE result, tmp1, tmp2;
+       long len;
+
+       if ((m1->m_dim != 1) || (m2->m_dim != 1))
+               math_error("Matrix not 1d for dot product");
+       if (m1->m_size != m2->m_size)
+               math_error("Incompatible matrix sizes for dot product");
+       v1 = m1->m_table;
+       v2 = m2->m_table;
+       mulvalue(v1, v2, &result);
+       len = m1->m_size;
+       while (--len > 0) {
+               mulvalue(++v1, ++v2, &tmp1);
+               addvalue(&result, &tmp1, &tmp2);
+               freevalue(&tmp1);
+               freevalue(&result);
+               result = tmp2;
+       }
+       return result;
+}
+
+
+/*
+ * Scale the elements of a matrix by a specified power of two.
+ */
+MATRIX *
+matscale(m, n)
+       MATRIX *m;              /* matrix to be scaled */
+       long n;
+{
+       register VALUE *val, *vres;
+       VALUE num;
+       long index;
+       MATRIX *res;            /* resulting matrix */
+
+       if (n == 0)
+               return matcopy(m);
+       num.v_type = V_NUM;
+       num.v_num = itoq(n);
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               scalevalue(val++, &num, vres++);
+       qfree(num.v_num);
+       return res;
+}
+
+
+/*
+ * Shift the elements of a matrix by the specified number of bits.
+ * Positive shift means leftwards, negative shift rightwards.
+ */
+MATRIX *
+matshift(m, n)
+       MATRIX *m;              /* matrix to be scaled */
+       long n;
+{
+       register VALUE *val, *vres;
+       VALUE num;
+       long index;
+       MATRIX *res;            /* resulting matrix */
+
+       if (n == 0)
+               return matcopy(m);
+       num.v_type = V_NUM;
+       num.v_num = itoq(n);
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               shiftvalue(val++, &num, FALSE, vres++);
+       qfree(num.v_num);
+       return res;
+}
+
+
+/*
+ * Multiply the elements of a matrix by a specified value.
+ */
+MATRIX *
+matmulval(m, vp)
+       MATRIX *m;              /* matrix to be multiplied */
+       VALUE *vp;              /* value to multiply by */
+{
+       register VALUE *val, *vres;
+       long index;
+       MATRIX *res;
+
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               mulvalue(val++, vp, vres++);
+       return res;
+}
+
+
+/*
+ * Divide the elements of a matrix by a specified value, keeping
+ * only the integer quotient.
+ */
+MATRIX *
+matquoval(m, vp)
+       MATRIX *m;              /* matrix to be divided */
+       VALUE *vp;              /* value to divide by */
+{
+       register VALUE *val, *vres;
+       long index;
+       MATRIX *res;
+
+       if ((vp->v_type == V_NUM) && qiszero(vp->v_num))
+               math_error("Division by zero");
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               quovalue(val++, vp, vres++);
+       return res;
+}
+
+
+/*
+ * Divide the elements of a matrix by a specified value, keeping
+ * only the remainder of the division.
+ */
+MATRIX *
+matmodval(m, vp)
+       MATRIX *m;              /* matrix to be divided */
+       VALUE *vp;              /* value to divide by */
+{
+       register VALUE *val, *vres;
+       long index;
+       MATRIX *res;
+
+       if ((vp->v_type == V_NUM) && qiszero(vp->v_num))
+               math_error("Division by zero");
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               modvalue(val++, vp, vres++);
+       return res;
+}
+
+
+MATRIX *
+mattrans(m)
+       MATRIX *m;                      /* matrix to be transposed */
+{
+       register VALUE *v1, *v2;        /* current values */
+       long rows, cols;                /* rows and columns in new matrix */
+       long row, col;                  /* current row and column */
+       MATRIX *res;
+
+       if (m->m_dim != 2)
+               math_error("Matrix dimension must be two for transpose");
+       res = matalloc(m->m_size);
+       res->m_dim = 2;
+       res->m_min[0] = m->m_min[1];
+       res->m_max[0] = m->m_max[1];
+       res->m_min[1] = m->m_min[0];
+       res->m_max[1] = m->m_max[0];
+       rows = (m->m_max[1] - m->m_min[1] + 1);
+       cols = (m->m_max[0] - m->m_min[0] + 1);
+       v1 = res->m_table;
+       for (row = 0; row < rows; row++) {
+               v2 = &m->m_table[row];
+               for (col = 0; col < cols; col++) {
+                       copyvalue(v2, v1);
+                       v1++;
+                       v2 += rows;
+               }
+       }
+       return res;
+}
+
+
+/*
+ * Produce a matrix with values all of which are conjugated.
+ */
+MATRIX *
+matconj(m)
+       MATRIX *m;
+{
+       register VALUE *val, *vres;
+       long index;
+       MATRIX *res;
+
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               conjvalue(val++, vres++);
+       return res;
+}
+
+
+/*
+ * Produce a matrix with values all of which have been rounded to the
+ * specified number of decimal places.
+ */
+MATRIX *
+matround(m, places)
+       MATRIX *m;
+       long places;
+{
+       register VALUE *val, *vres;
+       VALUE tmp;
+       long index;
+       MATRIX *res;
+
+       if (places < 0)
+               math_error("Negative number of places for matround");
+       res = matalloc(m->m_size);
+       *res = *m;
+       tmp.v_type = V_INT;
+       tmp.v_int = places;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               roundvalue(val++, &tmp, vres++);
+       return res;
+}
+
+
+/*
+ * Produce a matrix with values all of which have been rounded to the
+ * specified number of binary places.
+ */
+MATRIX *
+matbround(m, places)
+       MATRIX *m;
+       long places;
+{
+       register VALUE *val, *vres;
+       VALUE tmp;
+       long index;
+       MATRIX *res;
+
+       if (places < 0)
+               math_error("Negative number of places for matbround");
+       res = matalloc(m->m_size);
+       *res = *m;
+       tmp.v_type = V_INT;
+       tmp.v_int = places;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               broundvalue(val++, &tmp, vres++);
+       return res;
+}
+
+
+/*
+ * Produce a matrix with values all of which have been truncated to integers.
+ */
+MATRIX *
+matint(m)
+       MATRIX *m;
+{
+       register VALUE *val, *vres;
+       long index;
+       MATRIX *res;
+
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               intvalue(val++, vres++);
+       return res;
+}
+
+
+/*
+ * Produce a matrix with values all of which have only the fraction part left.
+ */
+MATRIX *
+matfrac(m)
+       MATRIX *m;
+{
+       register VALUE *val, *vres;
+       long index;
+       MATRIX *res;
+
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = m->m_table;
+       vres = res->m_table;
+       for (index = m->m_size; index > 0; index--)
+               fracvalue(val++, vres++);
+       return res;
+}
+
+
+/*
+ * Index a matrix normally by the specified set of index values.
+ * Returns the address of the matrix element if it is valid, or generates
+ * an error if the index values are out of range.  The create flag is TRUE
+ * if the element is to be written, but this is ignored here.
+ */
+/*ARGSUSED*/
+VALUE *
+matindex(mp, create, dim, indices)
+       MATRIX *mp;
+       BOOL create;
+       long dim;               /* dimension of the indexing */
+       VALUE *indices;         /* table of values being indexed by */
+{
+       NUMBER *q;              /* index value */
+       long index;             /* index value as an integer */
+       long offset;            /* current offset into array */
+       int i;                  /* loop counter */
+
+       if ((dim <= 0) || (dim > MAXDIM))
+               math_error("Bad dimension %ld for matrix", dim);
+       if (mp->m_dim != dim)
+               math_error("Indexing a %ldd matrix as a %ldd matrix", mp->m_dim, dim);
+       offset = 0;
+       for (i = 0; i < dim; i++) {
+               if (indices->v_type != V_NUM)
+                       math_error("Non-numeric index for matrix");
+               q = indices->v_num;
+               if (qisfrac(q))
+                       math_error("Non-integral index for matrix");
+               index = qtoi(q);
+               if (zisbig(q->num) || (index < mp->m_min[i]) || (index > mp->m_max[i]))
+                       math_error("Index out of bounds for matrix");
+               offset *= (mp->m_max[i] - mp->m_min[i] + 1);
+               offset += (index - mp->m_min[i]);
+               indices++;
+       }
+       return mp->m_table + offset;
+}
+
+
+/*
+ * Search a matrix for the specified value, starting with the specified index.
+ * Returns the index of the found value, or -1 if the value was not found.
+ */
+long
+matsearch(m, vp, index)
+       MATRIX *m;
+       VALUE *vp;
+       long index;
+{
+       register VALUE *val;
+
+       if (index < 0)
+               index = 0;
+       val = &m->m_table[index];
+       while (index < m->m_size) {
+               if (!comparevalue(vp, val))
+                       return index;
+               index++;
+               val++;
+       }
+       return -1;
+}
+
+
+/*
+ * Search a matrix backwards for the specified value, starting with the
+ * specified index.  Returns the index of the found value, or -1 if the
+ * value was not found.
+ */
+long
+matrsearch(m, vp, index)
+       MATRIX *m;
+       VALUE *vp;
+       long index;
+{
+       register VALUE *val;
+
+       if (index >= m->m_size)
+               index = m->m_size - 1;
+       val = &m->m_table[index];
+       while (index >= 0) {
+               if (!comparevalue(vp, val))
+                       return index;
+               index--;
+               val--;
+       }
+       return -1;
+}
+
+
+/*
+ * Fill all of the elements of a matrix with one of two specified values.
+ * All entries are filled with the first specified value, except that if
+ * the matrix is square and the second value pointer is non-NULL, then
+ * all diagonal entries are filled with the second value.  This routine
+ * affects the supplied matrix directly, and doesn't return a copy.
+ */
+void
+matfill(m, v1, v2)
+       MATRIX *m;              /* matrix to be filled */
+       VALUE *v1;              /* value to fill most of matrix with */
+       VALUE *v2;              /* value for diagonal entries (or NULL) */
+{
+       register VALUE *val;
+       long row, col;
+       long rows;
+       long index;
+
+       if (v2 && ((m->m_dim != 2) ||
+               ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1]))))
+                       math_error("Filling diagonals of non-square matrix");
+       val = m->m_table;
+       for (index = m->m_size; index > 0; index--)
+               freevalue(val++);
+       val = m->m_table;
+       if (v2 == NULL) {
+               for (index = m->m_size; index > 0; index--)
+                       copyvalue(v1, val++);
+               return;
+       }
+       rows = m->m_max[0] - m->m_min[0] + 1;
+       for (row = 0; row < rows; row++) {
+               for (col = 0; col < rows; col++) {
+                       copyvalue(((row != col) ? v1 : v2), val++);
+               }
+       }
+}
+
+
+/*
+ * Set a copy of a square matrix to the identity matrix.
+ */
+static MATRIX *
+matident(m)
+       MATRIX *m;
+{
+       register VALUE *val;    /* current value */
+       long row, col;          /* current row and column */
+       long rows;              /* number of rows */
+       MATRIX *res;            /* resulting matrix */
+
+       if (m->m_dim != 2)
+               math_error("Matrix dimension must be two for setting to identity");
+       if ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1]))
+               math_error("Matrix must be square for setting to identity");
+       res = matalloc(m->m_size);
+       *res = *m;
+       val = res->m_table;
+       rows = (res->m_max[0] - res->m_min[0] + 1);
+       for (row = 0; row < rows; row++) {
+               for (col = 0; col < rows; col++) {
+                       val->v_type = V_NUM;
+                       val->v_num = ((row == col) ? qlink(&_qone_) : qlink(&_qzero_));
+                       val++;
+               }
+       }
+       return res;
+}
+
+
+/*
+ * Calculate the inverse of a matrix if it exists.
+ * This is done by using transformations on the supplied matrix to convert
+ * it to the identity matrix, and simultaneously applying the same set of
+ * transformations to the identity matrix.
+ */
+MATRIX *
+matinv(m)
+       MATRIX *m;
+{
+       MATRIX *res;            /* matrix to become the inverse */
+       long rows;              /* number of rows */
+       long cur;               /* current row being worked on */
+       long row, col;          /* temp row and column values */
+       VALUE *val;             /* current value in matrix*/
+       VALUE mulval;           /* value to multiply rows by */
+       VALUE tmpval;           /* temporary value */
+
+       if (m->m_dim != 2)
+               math_error("Matrix dimension must be two for inverse");
+       if ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1]))
+               math_error("Inverting non-square matrix");
+       /*
+        * Begin by creating the identity matrix with the same attributes.
+        */
+       res = matalloc(m->m_size);
+       *res = *m;
+       rows = (m->m_max[0] - m->m_min[0] + 1);
+       val = res->m_table;
+       for (row = 0; row < rows; row++) {
+               for (col = 0; col < rows; col++) {
+                       if (row == col)
+                               val->v_num = qlink(&_qone_);
+                       else
+                               val->v_num = qlink(&_qzero_);
+                       val->v_type = V_NUM;
+                       val++;
+               }
+       }
+       /*
+        * Now loop over each row, and eliminate all entries in the
+        * corresponding column by using row operations.  Do the same
+        * operations on the resulting matrix.  Copy the original matrix
+        * so that we don't destroy it.
+        */
+       m = matcopy(m);
+       for (cur = 0; cur < rows; cur++) {
+               /*
+                * Find the first nonzero value in the rest of the column
+                * downwards from [cur,cur].  If there is no such value, then
+                * the matrix is not invertible.  If the first nonzero entry
+                * is not the current row, then swap the two rows to make the
+                * current one nonzero.
+                */
+               row = cur;
+               val = &m->m_table[(row * rows) + row];
+               while (testvalue(val) == 0) {
+                       if (++row >= rows) {
+                               matfree(m);
+                               matfree(res);
+                               math_error("Matrix is not invertible");
+                       }
+                       val += rows;
+               }
+               invertvalue(val, &mulval);
+               if (row != cur) {
+                       matswaprow(m, row, cur);
+                       matswaprow(res, row, cur);
+               }
+               /*
+                * Now for every other nonzero entry in the current column, subtract
+                * the appropriate multiple of the current row to force that entry
+                * to become zero.
+                */
+               val = &m->m_table[cur];
+               /* ignore Saber-C warning about bad pointer val */
+               for (row = 0; row < rows; row++, val += rows) {
+                       if ((row == cur) || (testvalue(val) == 0))
+                               continue;
+                       mulvalue(val, &mulval, &tmpval);
+                       matsubrow(m, row, cur, &tmpval);
+                       matsubrow(res, row, cur, &tmpval);
+                       freevalue(&tmpval);
+               }
+               freevalue(&mulval);
+       }
+       /*
+        * Now the original matrix has nonzero entries only on its main diagonal.
+        * Scale the rows of the result matrix by the inverse of those entries.
+        */
+       val = m->m_table;
+       for (row = 0; row < rows; row++) {
+               if ((val->v_type != V_NUM) || !qisone(val->v_num)) {
+                       invertvalue(val, &mulval);
+                       matmulrow(res, row, &mulval);
+                       freevalue(&mulval);
+               }
+               /* ignore Saber-C warning about bad pointer val */
+               val += (rows + 1);
+       }
+       matfree(m);
+       return res;
+}
+
+
+/*
+ * Calculate the determinant of a square matrix.
+ * This is done using row operations to create an upper-diagonal matrix.
+ */
+VALUE
+matdet(m)
+       MATRIX *m;
+{
+       long rows;              /* number of rows */
+       long cur;               /* current row being worked on */
+       long row;               /* temp row values */
+       int neg;                /* whether to negate determinant */
+       VALUE *val;             /* current value */
+       VALUE mulval, tmpval;   /* other values */
+
+       if (m->m_dim != 2)
+               math_error("Matrix dimension must be two for determinant");
+       if ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1]))
+               math_error("Non-square matrix for determinant");
+       /*
+        * Loop over each row, and eliminate all lower entries in the
+        * corresponding column by using row operations.  Copy the original
+        * matrix so that we don't destroy it.
+        */
+       neg = 0;
+       m = matcopy(m);
+       rows = (m->m_max[0] - m->m_min[0] + 1);
+       for (cur = 0; cur < rows; cur++) {
+               /*
+                * Find the first nonzero value in the rest of the column
+                * downwards from [cur,cur].  If there is no such value, then
+                * the determinant is zero.  If the first nonzero entry is not
+                * the current row, then swap the two rows to make the current
+                * one nonzero, and remember that the determinant changes sign.
+                */
+               row = cur;
+               val = &m->m_table[(row * rows) + row];
+               while (testvalue(val) == 0) {
+                       if (++row >= rows) {
+                               matfree(m);
+                               mulval.v_type = V_NUM;
+                               mulval.v_num = qlink(&_qzero_);
+                               return mulval;
+                       }
+                       val += rows;
+               }
+               invertvalue(val, &mulval);
+               if (row != cur) {
+                       matswaprow(m, row, cur);
+                       neg = !neg;
+               }
+               /*
+                * Now for every other nonzero entry lower down in the current column,
+                * subtract the appropriate multiple of the current row to force that
+                * entry to become zero.
+                */
+               row = cur + 1;
+               /* ignore Saber-C warning about bad pointer into val */
+               val = &m->m_table[(row * rows) + cur];
+               /* ignore Saber-C warning about bad pointer into val */
+               for (; row < rows; row++, val += rows) {
+                       if (testvalue(val) == 0)
+                               continue;
+                       mulvalue(val, &mulval, &tmpval);
+                       matsubrow(m, row, cur, &tmpval);
+                       freevalue(&tmpval);
+               }
+               freevalue(&mulval);
+       }
+       /*
+        * Now the matrix is upper-diagonal, and the determinant is the
+        * product of the main diagonal entries, and is possibly negated.
+        */
+       val = m->m_table;
+       mulval.v_type = V_NUM;
+       mulval.v_num = qlink(&_qone_);
+       for (row = 0; row < rows; row++) {
+               mulvalue(&mulval, val, &tmpval);
+               freevalue(&mulval);
+               mulval = tmpval;
+               /* ignore Saber-C warning about bad pointer into val */
+               val += (rows + 1);
+       }
+       matfree(m);
+       if (neg) {
+               negvalue(&mulval, &tmpval);
+               freevalue(&mulval);
+               return tmpval;
+       }
+       return mulval;
+}
+
+
+/*
+ * Local utility routine to swap two rows of a square matrix.
+ * No checks are made to verify the legality of the arguments.
+ */
+static void
+matswaprow(m, r1, r2)
+       MATRIX *m;
+       long r1, r2;
+{
+       register VALUE *v1, *v2;
+       register long rows;
+       VALUE tmp;
+
+       if (r1 == r2)
+               return;
+       rows = (m->m_max[0] - m->m_min[0] + 1);
+       v1 = &m->m_table[r1 * rows];
+       v2 = &m->m_table[r2 * rows];
+       while (rows-- > 0) {
+               tmp = *v1;
+               *v1 = *v2;
+               *v2 = tmp;
+               v1++;
+               v2++;
+       }
+}
+
+
+/*
+ * Local utility routine to subtract a multiple of one row to another one.
+ * The row to be changed is oprow, the row to be subtracted is baserow.
+ * No checks are made to verify the legality of the arguments.
+ */
+static void
+matsubrow(m, oprow, baserow, mulval)
+       MATRIX *m;
+       long oprow, baserow;
+       VALUE *mulval;
+{
+       register VALUE *vop, *vbase;
+       register long entries;
+       VALUE tmp1, tmp2;
+
+       entries = (m->m_max[0] - m->m_min[0] + 1);
+       vop = &m->m_table[oprow * entries];
+       vbase = &m->m_table[baserow * entries];
+       while (entries-- > 0) {
+               mulvalue(vbase, mulval, &tmp1);
+               subvalue(vop, &tmp1, &tmp2);
+               freevalue(&tmp1);
+               freevalue(vop);
+               *vop = tmp2;
+               vop++;
+               vbase++;
+       }
+}
+
+
+/*
+ * Local utility routine to multiply a row by a specified number.
+ * No checks are made to verify the legality of the arguments.
+ */
+static void
+matmulrow(m, row, mulval)
+       MATRIX *m;
+       long row;
+       VALUE *mulval;
+{
+       register VALUE *val;
+       register long rows;
+       VALUE tmp;
+
+       rows = (m->m_max[0] - m->m_min[0] + 1);
+       val = &m->m_table[row * rows];
+       while (rows-- > 0) {
+               mulvalue(val, mulval, &tmp);
+               freevalue(val);
+               *val = tmp;
+               val++;
+       }
+}
+
+
+/*
+ * Make a full copy of a matrix.
+ */
+MATRIX *
+matcopy(m)
+       MATRIX *m;
+{
+       MATRIX *res;
+       register VALUE *v1, *v2;
+       register long i;
+
+       res = matalloc(m->m_size);
+       *res = *m;
+       v1 = m->m_table;
+       v2 = res->m_table;
+       i = m->m_size;
+       while (i-- > 0) {
+               if (v1->v_type == V_NUM) {
+                       v2->v_type = V_NUM;
+                       v2->v_num = qlink(v1->v_num);
+               } else
+                       copyvalue(v1, v2);
+               v1++;
+               v2++;
+       }
+       return res;
+}
+
+
+/*
+ * Allocate a matrix with the specified number of elements.
+ */
+MATRIX *
+matalloc(size)
+       long size;
+{
+       MATRIX *m;
+
+       m = (MATRIX *) malloc(matsize(size));
+       if (m == NULL)
+               math_error("Cannot get memory to allocate matrix of size %d", size);
+       m->m_size = size;
+       return m;
+}
+
+
+/*
+ * Free a matrix, along with all of its element values.
+ */
+void
+matfree(m)
+       MATRIX *m;
+{
+       register VALUE *vp;
+       register long i;
+
+       vp = m->m_table;
+       i = m->m_size;
+       while (i-- > 0) {
+               if (vp->v_type == V_NUM) {
+                       vp->v_type = V_NULL;
+                       qfree(vp->v_num);
+               } else
+                       freevalue(vp);
+               vp++;
+       }
+       free(m);
+}
+
+
+/*
+ * Test whether a matrix has any nonzero values.
+ * Returns TRUE if so.
+ */
+BOOL
+mattest(m)
+       MATRIX *m;
+{
+       register VALUE *vp;
+       register long i;
+
+       vp = m->m_table;
+       i = m->m_size;
+       while (i-- > 0) {
+               if ((vp->v_type != V_NUM) || (!qiszero(vp->v_num)))
+                       return TRUE;
+               vp++;
+       }
+       return FALSE;
+}
+
+
+/*
+ * Test whether or not two matrices are equal.
+ * Equality is determined by the shape and values of the matrices,
+ * but not by their index bounds.  Returns TRUE if they differ.
+ */
+BOOL
+matcmp(m1, m2)
+       MATRIX *m1, *m2;
+{
+       VALUE *v1, *v2;
+       long i;
+
+       if (m1 == m2)
+               return FALSE;
+       if ((m1->m_dim != m2->m_dim) || (m1->m_size != m2->m_size))
+               return TRUE;
+       for (i = 0; i < m1->m_dim; i++) {
+               if ((m1->m_max[i] - m1->m_min[i]) != (m2->m_max[i] - m2->m_min[i]))
+               return TRUE;
+       }
+       v1 = m1->m_table;
+       v2 = m2->m_table;
+       i = m1->m_size;
+       while (i-- > 0) {
+               if (comparevalue(v1++, v2++))
+                       return TRUE;
+       }
+       return FALSE;
+}
+
+
+#if 0
+/*
+ * Test whether or not a matrix is the identity matrix.
+ * Returns TRUE if so.
+ */
+BOOL
+matisident(m)
+       MATRIX *m;
+{
+       register VALUE *val;    /* current value */
+       long row, col;          /* row and column numbers */
+
+       if ((m->m_dim != 2) ||
+               ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1])))
+                       return FALSE;
+       val = m->m_table;
+       for (row = 0; row < m->m_size; row++) {
+               for (col = 0; col < m->m_size; col++) {
+                       if (val->v_type != V_NUM)
+                               return FALSE;
+                       if (row == col) {
+                               if (!qisone(val->v_num))
+                                       return FALSE;
+                       } else {
+                               if (!qiszero(val->v_num))
+                                       return FALSE;
+                       }
+                       val++;
+               }
+       }
+       return TRUE;
+}
+#endif
+
+
+/*
+ * Return a trivial hash value for a matrix.
+ */
+HASH
+mathash(m)
+       MATRIX *m;
+{
+       HASH hash;
+       long fullsize;
+       long skip;
+       int i;
+       VALUE *vp;
+
+       hash = m->m_dim * 500009;
+       fullsize = 1;
+       for (i = m->m_dim - 1; i >= 0; i--) {
+               hash = hash * 500029 + m->m_max[i];
+               fullsize *= (m->m_max[i] - m->m_min[i] + 1);
+       }
+       hash = hash * 500041 + fullsize;
+       vp = m->m_table;
+       for (i = 0; ((i < fullsize) && (i < 16)); i++)
+               hash = hash * 500057 + hashvalue(vp++);
+       i = 16;
+       vp = &m->m_table[16];
+       skip = (fullsize / 11) + 1;
+       while (i < fullsize) {
+               hash = hash * 500069 + hashvalue(vp);
+               i += skip;
+               vp += skip;
+       }
+       return hash;
+}
+
+
+/*
+ * Print a matrix and possibly few of its elements.
+ * The argument supplied specifies how many elements to allow printing.
+ * If any elements are printed, they are printed in short form.
+ */
+void
+matprint(m, max_print)
+       MATRIX *m;
+       long max_print;
+{
+       VALUE *vp;
+       long fullsize, count, index, num;
+       int dim, i;
+       char *msg;
+       long sizes[MAXDIM];
+
+       dim = m->m_dim;
+       fullsize = 1;
+       for (i = dim - 1; i >= 0; i--) {
+               sizes[i] = fullsize;
+               fullsize *= (m->m_max[i] - m->m_min[i] + 1);
+       }
+       msg = ((max_print > 0) ? "\nmat [" : "mat [");
+       for (i = 0; i < dim; i++) {
+               if (m->m_min[i])
+                       math_fmt("%s%ld:%ld", msg, m->m_min[i], m->m_max[i]);
+               else
+                       math_fmt("%s%ld", msg, m->m_max[i] + 1);
+               msg = ",";
+       }
+       if (max_print > fullsize)
+               max_print = fullsize;
+       vp = m->m_table;
+       count = 0;
+       for (index = 0; index < fullsize; index++) {
+               if ((vp->v_type != V_NUM) || !qiszero(vp->v_num))
+                       count++;
+               vp++;
+       }
+       math_fmt("] (%ld element%s, %ld nonzero)",
+               fullsize, (fullsize == 1) ? "" : "s", count);
+       if (max_print <= 0)
+               return;
+
+       /*
+        * Now print the first few elements of the matrix in short
+        * and unambigous format.
+        */
+       math_str(":\n");
+       vp = m->m_table;
+       for (index = 0; index < max_print; index++) {
+               msg = "  [";
+               num = index;
+               for (i = 0; i < dim; i++) {
+                       math_fmt("%s%ld", msg, m->m_min[i] + (num / sizes[i]));
+                       num %= sizes[i];
+                       msg = ",";
+               }
+               math_str("] = ");
+               printvalue(vp++, PRINT_SHORT | PRINT_UNAMBIG);
+               math_str("\n");
+       }
+       if (max_print < fullsize)
+               math_str("  ...\n");
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/obj.c b/usr/src/contrib/calc-2.9.3t6/obj.c
new file mode 100644 (file)
index 0000000..ac4d459
--- /dev/null
@@ -0,0 +1,658 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * "Object" handling primatives.
+ * This simply means that user-specified routines are called to perform
+ * the indicated operations.
+ */
+
+#include "calc.h"
+#include "opcodes.h"
+#include "func.h"
+#include "symbol.h"
+#include "string.h"
+
+
+/*
+ * Types of values returned by calling object routines.
+ */
+#define A_VALUE        0       /* returns arbitrary value */
+#define A_INT  1       /* returns integer value */
+#define A_UNDEF        2       /* returns no value */
+
+/*
+ * Error handling actions for when the function is undefined.
+ */
+#define E_NONE 0       /* no special action */
+#define E_PRINT        1       /* print element */
+#define E_CMP  2       /* compare two values */
+#define E_TEST 3       /* test value for nonzero */
+#define E_POW  4       /* call generic power routine */
+#define E_ONE  5       /* return number 1 */
+#define E_INC  6       /* increment by one */
+#define E_DEC  7       /* decrement by one */
+#define E_SQUARE 8     /* square value */
+
+
+static struct objectinfo {
+       short args;     /* number of arguments */
+       short retval;   /* type of return value */
+       short error;    /* special action on errors */
+       char *name;     /* name of function to call */
+       char *comment;  /* useful comment if any */
+} objectinfo[] = {
+       1, A_UNDEF, E_PRINT, "print",   "print value, default prints elements",
+       1, A_VALUE, E_ONE,   "one",     "multiplicative identity, default is 1",
+       1, A_INT,   E_TEST,  "test",    "logical test (false,true => 0,1), default tests elements",
+       2, A_VALUE, E_NONE,  "add",     NULL,
+       2, A_VALUE, E_NONE,  "sub",     NULL,
+       1, A_VALUE, E_NONE,  "neg",     "negative",
+       2, A_VALUE, E_NONE,  "mul",     NULL,
+       2, A_VALUE, E_NONE,  "div",     "non-integral division",
+       1, A_VALUE, E_NONE,  "inv",     "multiplicative inverse",
+       2, A_VALUE, E_NONE,  "abs",     "absolute value within given error",
+       1, A_VALUE, E_NONE,  "norm",    "square of absolute value",
+       1, A_VALUE, E_NONE,  "conj",    "conjugate",
+       2, A_VALUE, E_POW,   "pow",     "integer power, default does multiply, square, inverse",
+       1, A_INT,   E_NONE,  "sgn",     "sign of value (-1, 0, 1)",
+       2, A_INT,   E_CMP,   "cmp",     "equality (equal,nonequal => 0,1), default tests elements",
+       2, A_INT,   E_NONE,  "rel",     "inequality (less,equal,greater => -1,0,1)",
+       2, A_VALUE, E_NONE,  "quo",     "integer quotient",
+       2, A_VALUE, E_NONE,  "mod",     "remainder of division",
+       1, A_VALUE, E_NONE,  "int",     "integer part",
+       1, A_VALUE, E_NONE,  "frac",    "fractional part",
+       1, A_VALUE, E_INC,   "inc",     "increment, default adds 1",
+       1, A_VALUE, E_DEC,   "dec",     "decrement, default subtracts 1",
+       1, A_VALUE, E_SQUARE,"square",  "default multiplies by itself",
+       2, A_VALUE, E_NONE,  "scale",   "multiply by power of 2",
+       2, A_VALUE, E_NONE,  "shift",   "shift left by n bits (right if negative)",
+       2, A_VALUE, E_NONE,  "round",   "round to given number of decimal places",
+       2, A_VALUE, E_NONE,  "bround",  "round to given number of binary places",
+       3, A_VALUE, E_NONE,  "root",    "root of value within given error",
+       2, A_VALUE, E_NONE,  "sqrt",    "square root within given error",
+       0, 0, 0, NULL
+};
+
+
+static STRINGHEAD objectnames; /* names of objects */
+static STRINGHEAD elements;    /* element names for parts of objects */
+static OBJECTACTIONS *objects[MAXOBJECTS]; /* table of actions for objects */
+
+
+/*
+ * Free list of usual small objects.
+ */
+static FREELIST        freelist = {
+       sizeof(OBJECT),         /* size of typical objects */
+       100                     /* number of free objects to keep */
+};
+
+
+static VALUE objpowi MATH_PROTO((VALUE *vp, NUMBER *q));
+static BOOL objtest MATH_PROTO((OBJECT *op));
+static BOOL objcmp MATH_PROTO((OBJECT *op1, OBJECT *op2));
+static void objprint MATH_PROTO((OBJECT *op));
+
+
+/*
+ * Show all the routine names available for objects.
+ */
+void
+showobjfuncs()
+{
+       register struct objectinfo *oip;
+
+       printf("\nThe following object routines are definable.\n");
+       printf("Note: xx represents the actual object type name.\n\n");
+       printf("Name    Args    Comments\n");
+       for (oip = objectinfo; oip->name; oip++) {
+               printf("xx_%-8s %d      %s\n", oip->name, oip->args,
+                       oip->comment ? oip->comment : "");
+       }
+       printf("\n");
+}
+
+
+/*
+ * Call the appropriate user-defined routine to handle an object action.
+ * Returns the value that the routine returned.
+ */
+VALUE
+objcall(action, v1, v2, v3)
+       int action;
+       VALUE *v1, *v2, *v3;
+{
+       FUNC *fp;               /* function to call */
+       static OBJECTACTIONS *oap; /* object to call for */
+       struct objectinfo *oip; /* information about action */
+       long index;             /* index of function (negative if undefined) */
+       VALUE val;              /* return value */
+       VALUE tmp;              /* temp value */
+       char name[SYMBOLSIZE+1];        /* full name of user routine to call */
+
+       if ((unsigned)action > OBJ_MAXFUNC)
+               math_error("Illegal action for object call");
+       oip = &objectinfo[action];
+       if (v1->v_type == V_OBJ)
+               oap = v1->v_obj->o_actions;
+       else if (v2->v_type == V_OBJ)
+               oap = v2->v_obj->o_actions;
+       else
+               math_error("Object routine called with non-object");
+       index = oap->actions[action];
+       if (index == 0) {
+               strcpy(name, oap->name);
+               strcat(name, "_");
+               strcat(name, oip->name);
+               index = adduserfunc(name);
+               oap->actions[action] = index;
+       }
+       fp = NULL;
+       if (index > 0)
+               fp = findfunc(index);
+       if (fp == NULL) {
+               switch (oip->error) {
+                       case E_PRINT:
+                               objprint(v1->v_obj);
+                               val.v_type = V_NULL;
+                               break;
+                       case E_CMP:
+                               val.v_type = V_INT;
+                               if (v1->v_type != v2->v_type) {
+                                       val.v_int = 1;
+                                       return val;
+                               }
+                               val.v_int = objcmp(v1->v_obj, v2->v_obj);
+                               break;
+                       case E_TEST:
+                               val.v_type = V_INT;
+                               val.v_int = objtest(v1->v_obj);
+                               break;
+                       case E_POW:
+                               if (v2->v_type != V_NUM)
+                                       math_error("Non-real power");
+                               val = objpowi(v1, v2->v_num);
+                               break;
+                       case E_ONE:
+                               val.v_type = V_NUM;
+                               val.v_num = qlink(&_qone_);
+                               break;
+                       case E_INC:
+                               tmp.v_type = V_NUM;
+                               tmp.v_num = &_qone_;
+                               val = objcall(OBJ_ADD, v1, &tmp, NULL_VALUE);
+                               break;
+                       case E_DEC:
+                               tmp.v_type = V_NUM;
+                               tmp.v_num = &_qone_;
+                               val = objcall(OBJ_SUB, v1, &tmp, NULL_VALUE);
+                               break;
+                       case E_SQUARE:
+                               val = objcall(OBJ_MUL, v1, v1, NULL_VALUE);
+                               break;
+                       default:
+                               math_error("Function \"%s\" is undefined", namefunc(index));
+               }
+               return val;
+       }
+       switch (oip->args) {
+               case 0:
+                       break;
+               case 1:
+                       ++stack;
+                       stack->v_addr = v1;
+                       stack->v_type = V_ADDR;
+                       break;
+               case 2:
+                       ++stack;
+                       stack->v_addr = v1;
+                       stack->v_type = V_ADDR;
+                       ++stack;
+                       stack->v_addr = v2;
+                       stack->v_type = V_ADDR;
+                       break;
+               case 3:
+                       ++stack;
+                       stack->v_addr = v1;
+                       stack->v_type = V_ADDR;
+                       ++stack;
+                       stack->v_addr = v2;
+                       stack->v_type = V_ADDR;
+                       ++stack;
+                       stack->v_addr = v3;
+                       stack->v_type = V_ADDR;
+                       break;
+               default:
+                       math_error("Bad number of args to calculate");
+       }
+       calculate(fp, oip->args);
+       switch (oip->retval) {
+               case A_VALUE:
+                       return *stack--;
+               case A_UNDEF:
+                       freevalue(stack--);
+                       val.v_type = V_NULL;
+                       break;
+               case A_INT:
+                       if ((stack->v_type != V_NUM) || qisfrac(stack->v_num))
+                               math_error("Integer return value required");
+                       index = qtoi(stack->v_num);
+                       qfree(stack->v_num);
+                       stack--;
+                       val.v_type = V_INT;
+                       val.v_int = index;
+                       break;
+               default:
+                       math_error("Bad object return");
+       }
+       return val;
+}
+
+
+/*
+ * Routine called to clear the cache of known undefined functions for
+ * the objects.  This changes negative indices back into positive ones
+ * so that they will all be checked for existence again.
+ */
+void
+objuncache()
+{
+       register int *ip;
+       int i, j;
+
+       i = objectnames.h_count;
+       while (--i >= 0) {
+               ip = objects[i]->actions;
+               for (j = OBJ_MAXFUNC; j-- >= 0; ip++)
+                       if (*ip < 0)
+                               *ip = -*ip;
+       }
+}
+
+
+/*
+ * Print the elements of an object in short and unambiguous format.
+ * This is the default routine if the user's is not defined.
+ */
+static void
+objprint(op)
+       OBJECT *op;             /* object being printed */
+{
+       int count;              /* number of elements */
+       int i;                  /* index */
+
+       count = op->o_actions->count;
+       math_fmt("obj %s {", op->o_actions->name);
+       for (i = 0; i < count; i++) {
+               if (i)
+                       math_str(", ");
+               printvalue(&op->o_table[i], PRINT_SHORT | PRINT_UNAMBIG);
+       }
+       math_chr('}');
+}
+
+
+/*
+ * Test an object for being "nonzero".
+ * This is the default routine if the user's is not defined.
+ * Returns TRUE if any of the elements are "nonzero".
+ */
+static BOOL
+objtest(op)
+       OBJECT *op;
+{
+       int i;                  /* loop counter */
+
+       i = op->o_actions->count;
+       while (--i >= 0) {
+               if (testvalue(&op->o_table[i]))
+                       return TRUE;
+       }
+       return FALSE;
+}
+
+
+/*
+ * Compare two objects for equality, returning TRUE if they differ.
+ * This is the default routine if the user's is not defined.
+ * For equality, all elements must be equal.
+ */
+static BOOL
+objcmp(op1, op2)
+       OBJECT *op1, *op2;
+{
+       int i;                  /* loop counter */
+
+       if (op1->o_actions != op2->o_actions)
+               return TRUE;
+       i = op1->o_actions->count;
+       while (--i >= 0) {
+               if (comparevalue(&op1->o_table[i], &op2->o_table[i]))
+                       return TRUE;
+       }
+       return FALSE;
+}
+
+
+/*
+ * Raise an object to an integral power.
+ * This is the default routine if the user's is not defined.
+ * Negative powers mean the positive power of the inverse.
+ * Zero means the multiplicative identity.
+ */
+static VALUE
+objpowi(vp, q)
+       VALUE *vp;              /* value to be powered */
+       NUMBER *q;              /* power to raise number to */
+{
+       VALUE res, tmp;
+       long power;             /* power to raise to */
+       unsigned long bit;      /* current bit value */
+
+       if (qisfrac(q))
+               math_error("Raising object to non-integral power");
+       if (zisbig(q->num))
+               math_error("Raising object to very large power");
+       power = (zistiny(q->num) ? z1tol(q->num) : z2tol(q->num));
+       if (qisneg(q))
+               power = -power;
+       /*
+        * Handle some low powers specially
+        */
+       if ((power <= 2) && (power >= -2)) {
+               switch ((int) power) {
+                       case 0:
+                               return objcall(OBJ_ONE, vp, NULL_VALUE, NULL_VALUE);
+                       case 1:
+                               res.v_obj = objcopy(vp->v_obj);
+                               res.v_type = V_OBJ;
+                               return res;
+                       case -1:
+                               return objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
+                       case 2:
+                               return objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
+               }
+       }
+       if (power < 0)
+               power = -power;
+       /*
+        * Compute the power by squaring and multiplying.
+        * This uses the left to right method of power raising.
+        */
+       bit = TOPFULL;
+       while ((bit & power) == 0)
+               bit >>= 1L;
+       bit >>= 1L;
+       res = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
+       if (bit & power) {
+               tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
+               objfree(res.v_obj);
+               res = tmp;
+       }
+       bit >>= 1L;
+       while (bit) {
+               tmp = objcall(OBJ_SQUARE, &res, NULL_VALUE, NULL_VALUE);
+               objfree(res.v_obj);
+               res = tmp;
+               if (bit & power) {
+                       tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
+                       objfree(res.v_obj);
+                       res = tmp;
+               }
+               bit >>= 1L;
+       }
+       if (qisneg(q)) {
+               tmp = objcall(OBJ_INV, &res, NULL_VALUE, NULL_VALUE);
+               objfree(res.v_obj);
+               return tmp;
+       }
+       return res;
+}
+
+
+/*
+ * Define a (possibly) new class of objects.
+ * The list of indexes for the element names is also specified here,
+ * and the number of elements defined for the object.
+ */
+void
+defineobject(name, indices, count)
+       char *name;             /* name of object type */
+       int indices[];          /* table of indices for elements */
+       int count;
+{
+       OBJECTACTIONS *oap;     /* object definition structure */
+       STRINGHEAD *hp;
+       int index;
+
+       hp = &objectnames;
+       if (hp->h_list == NULL)
+               initstr(hp);
+       index = findstr(hp, name);
+       if (index >= 0) {
+               /*
+                * Object is already defined.  Give an error unless this
+                * new definition is exactly the same as the old one.
+                */
+               oap = objects[index];
+               if (oap->count == count) {
+                       for (index = 0; ; index++) {
+                               if (index >= count)
+                                       return;
+                               if (oap->elements[index] != indices[index])
+                                       break;
+                       }
+               }
+               math_error("Object type \"%s\" is already defined", name);
+       }
+
+       if (hp->h_count >= MAXOBJECTS)
+               math_error("Too many object types in use");
+       oap = (OBJECTACTIONS *) malloc(objectactionsize(count));
+       if (oap)
+               name = addstr(hp, name);
+       if ((oap == NULL) || (name == NULL))
+               math_error("Cannot allocate object type");
+       oap->name = name;
+       oap->count = count;
+       for (index = OBJ_MAXFUNC; index >= 0; index--)
+               oap->actions[index] = 0;
+       for (index = 0; index < count; index++)
+               oap->elements[index] = indices[index];
+       index = findstr(hp, name);
+       objects[index] = oap;
+       return;
+}
+
+
+/*
+ * Check an object name to see if it is currently defined.
+ * If so, the index for the object type is returned.
+ * If the object name is currently unknown, then -1 is returned.
+ */
+int
+checkobject(name)
+       char *name;
+{
+       STRINGHEAD *hp;
+
+       hp = &objectnames;
+       if (hp->h_list == NULL)
+               return -1;
+       return findstr(hp, name);
+}
+
+
+/*
+ * Define a (possibly) new element name for an object.
+ * Returns an index which identifies the element name.
+ */
+int
+addelement(name)
+       char *name;
+{
+       STRINGHEAD *hp;
+       int index;
+
+       hp = &elements;
+       if (hp->h_list == NULL)
+               initstr(hp);
+       index = findstr(hp, name);
+       if (index >= 0)
+               return index;
+       if (addstr(hp, name) == NULL)
+               math_error("Cannot allocate element name");
+       return findstr(hp, name);
+}
+
+
+/*
+ * Return the index which identifies an element name.
+ * Returns minus one if the element name is unknown.
+ */
+int
+findelement(name)
+       char *name;             /* element name */
+{
+       if (elements.h_list == NULL)
+               return -1;
+       return findstr(&elements, name);
+}
+
+
+/*
+ * Return the value table offset to be used for an object element name.
+ * This converts the element index from the element table into an offset
+ * into the object value array.  Returns -1 if the element index is unknown.
+ */
+int
+objoffset(op, index)
+       OBJECT *op;
+       long index;
+{
+       register OBJECTACTIONS *oap;
+       int offset;                     /* offset into value array */
+
+       oap = op->o_actions;
+       for (offset = oap->count - 1; offset >= 0; offset--) {
+               if (oap->elements[offset] == index)
+                       return offset;
+       }
+       return -1;
+}
+
+
+/*
+ * Allocate a new object structure with the specified index.
+ */
+OBJECT *
+objalloc(index)
+       long index;
+{
+       OBJECTACTIONS *oap;
+       OBJECT *op;
+       VALUE *vp;
+       int i;
+
+       if ((unsigned) index >= MAXOBJECTS)
+               math_error("Allocating bad object index");
+       oap = objects[index];
+       if (oap == NULL)
+               math_error("Object type not defined");
+       i = oap->count;
+       if (i < USUAL_ELEMENTS)
+               i = USUAL_ELEMENTS;
+       if (i == USUAL_ELEMENTS)
+               op = (OBJECT *) allocitem(&freelist);
+       else
+               op = (OBJECT *) malloc(objectsize(i));
+       if (op == NULL)
+               math_error("Cannot allocate object");
+       op->o_actions = oap;
+       vp = op->o_table;
+       for (i = oap->count; i-- > 0; vp++) {
+               vp->v_num = qlink(&_qzero_);
+               vp->v_type = V_NUM;
+       }
+       return op;
+}
+
+
+/*
+ * Free an object structure.
+ */
+void
+objfree(op)
+       register OBJECT *op;
+{
+       VALUE *vp;
+       int i;
+
+       vp = op->o_table;
+       for (i = op->o_actions->count; i-- > 0; vp++) {
+               if (vp->v_type == V_NUM) {
+                       qfree(vp->v_num);
+               } else
+                       freevalue(vp);
+       }
+       if (op->o_actions->count <= USUAL_ELEMENTS)
+               freeitem(&freelist, (FREEITEM *) op);
+       else
+               free((char *) op);
+}
+
+
+/*
+ * Copy an object value
+ */
+OBJECT *
+objcopy(op)
+       OBJECT *op;
+{
+       VALUE *v1, *v2;
+       OBJECT *np;
+       int i;
+
+       i = op->o_actions->count;
+       if (i < USUAL_ELEMENTS)
+               i = USUAL_ELEMENTS;
+       if (i == USUAL_ELEMENTS)
+               np = (OBJECT *) allocitem(&freelist);
+       else
+               np = (OBJECT *) malloc(objectsize(i));
+       if (np == NULL)
+               math_error("Cannot allocate object");
+       np->o_actions = op->o_actions;
+       v1 = op->o_table;
+       v2 = np->o_table;
+       for (i = op->o_actions->count; i-- > 0; v1++, v2++) {
+               if (v1->v_type == V_NUM) {
+                       v2->v_num = qlink(v1->v_num);
+                       v2->v_type = V_NUM;
+               } else
+                       copyvalue(v1, v2);
+       }
+       return np;
+}
+
+
+/*
+ * Return a trivial hash value for an object.
+ */
+HASH
+objhash(op)
+       OBJECT *op;
+{
+       HASH hash;
+       int i;
+
+       hash = 0;
+       i = op->o_actions->count;
+       while (--i >= 0)
+               hash = hash * 4000037 + hashvalue(&op->o_table[i]);
+       return hash;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/opcodes.c b/usr/src/contrib/calc-2.9.3t6/opcodes.c
new file mode 100644 (file)
index 0000000..29635bb
--- /dev/null
@@ -0,0 +1,2651 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Opcode execution module
+ */
+
+#include "stdarg.h"
+#include "calc.h"
+#include "opcodes.h"
+#include "func.h"
+#include "symbol.h"
+#include "hist.h"
+
+#define        QUICKLOCALS     20              /* local vars to handle quickly */
+
+
+VALUE *stack;                          /* current location of top of stack */
+static VALUE stackarray[MAXSTACK];     /* storage for stack */
+static VALUE oldvalue;                 /* previous calculation value */
+static char *funcname;                 /* function being executed */
+static long funcline;                  /* function line being executed */
+
+FLAG traceflags;                       /* current trace flags */
+int tab_ok = TRUE;                     /* FALSE => don't print lading tabs */
+
+
+/*
+ * Routine definitions
+ */
+static void o_nop(), o_localaddr(), o_globaladdr(), o_paramaddr();
+static void o_globalvalue(), o_paramvalue(), o_number(), o_indexaddr();
+static void o_assign(), o_add(), o_sub(), o_mul(), o_div();
+static void o_mod(), o_save(), o_negate(), o_invert(), o_int(), o_frac();
+static void o_numerator(), o_denominator(), o_duplicate(), o_pop();
+static void o_jumpeq(), o_jumpne(), o_jump(), o_usercall(), o_getvalue();
+static void o_eq(), o_ne(), o_le(), o_ge(), o_lt(), o_gt(), o_preinc();
+static void o_postinc(), o_postdec(), o_debug(), o_print(), o_assignpop();
+static void o_zero(), o_one(), o_printeol(), o_printspace(), o_printstring();
+static void o_oldvalue(), o_quo(), o_power(), o_quit(), o_call(), o_swap();
+static void o_dupvalue(), o_getepsilon(), o_and(), o_or(), o_not();
+static void o_abs(), o_sgn(), o_isint(), o_condorjump(), o_condandjump();
+static void o_square(), o_string(), o_isnum(), o_undef(), o_isnull();
+static void o_matcreate(), o_ismat(), o_isstr(), o_getconfig(), o_predec();
+static void o_leftshift(), o_rightshift(), o_casejump();
+static void o_isodd(), o_iseven(), o_fiaddr(), o_fivalue(), o_argvalue();
+static void o_isreal(), o_imaginary(), o_re(), o_im(), o_conjugate();
+static void o_objcreate(), o_isobj(), o_norm(), o_elemaddr(), o_elemvalue();
+static void o_istype(), o_scale(), o_localvalue(), o_return(), o_islist();
+static void o_issimple(), o_cmp(), o_quomod(), o_setconfig(), o_setepsilon();
+static void o_printresult(), o_isfile(), o_isassoc(), o_eleminit();
+
+
+/*
+ * Types of opcodes (depends on arguments saved after the opcode).
+ */
+#define OPNUL  1       /* opcode has no arguments */
+#define OPONE  2       /* opcode has one integer argument */
+#define OPTWO  3       /* opcode has two integer arguments */
+#define OPJMP  4       /* opcode is a jump (with one pointer argument) */
+#define OPRET  5       /* opcode is a return (with no argument) */
+#define OPGLB  6       /* opcode has global symbol pointer argument */
+#define OPPAR  7       /* opcode has parameter index argument */
+#define OPLOC  8       /* opcode needs local variable pointer (with one arg) */
+#define OPSTR  9       /* opcode has a string constant arg */
+#define OPARG  10      /* opcode is given number of arguments */
+#define        OPSTI   11      /* opcode is static initialization */
+
+
+/*
+ * Information about each opcode.
+ */
+static struct opcode {
+       void (*o_func)();       /* routine to call for opcode */
+       int o_type;             /* type of opcode */
+       char *o_name;           /* name of opcode */
+} opcodes[MAX_OPCODE+1] = {
+       o_nop,          OPNUL,  "NOP",          /* no operation */
+       o_localaddr,    OPLOC,  "LOCALADDR",    /* address of local variable */
+       o_globaladdr,   OPGLB,  "GLOBALADDR",   /* address of global variable */
+       o_paramaddr,    OPPAR,  "PARAMADDR",    /* address of paramater variable */
+       o_localvalue,   OPLOC,  "LOCALVALUE",   /* value of local variable */
+       o_globalvalue,  OPGLB,  "GLOBALVALUE",  /* value of global variable */
+       o_paramvalue,   OPPAR,  "PARAMVALUE",   /* value of paramater variable */
+       o_number,       OPONE,  "NUMBER",       /* constant real numeric value */
+       o_indexaddr,    OPTWO,  "INDEXADDR",    /* array index address */
+       o_printresult,  OPNUL,  "PRINTRESULT",  /* print result of top-level expression */
+       o_assign,       OPNUL,  "ASSIGN",       /* assign value to variable */
+       o_add,          OPNUL,  "ADD",          /* add top two values */
+       o_sub,          OPNUL,  "SUB",          /* subtract top two values */
+       o_mul,          OPNUL,  "MUL",          /* multiply top two values */
+       o_div,          OPNUL,  "DIV",          /* divide top two values */
+       o_mod,          OPNUL,  "MOD",          /* take mod of top two values */
+       o_save,         OPNUL,  "SAVE",         /* save value for later use */
+       o_negate,       OPNUL,  "NEGATE",       /* negate top value */
+       o_invert,       OPNUL,  "INVERT",       /* invert top value */
+       o_int,          OPNUL,  "INT",          /* take integer part */
+       o_frac,         OPNUL,  "FRAC",         /* take fraction part */
+       o_numerator,    OPNUL,  "NUMERATOR",    /* take numerator */
+       o_denominator,  OPNUL,  "DENOMINATOR",  /* take denominator */
+       o_duplicate,    OPNUL,  "DUPLICATE",    /* duplicate top value */
+       o_pop,          OPNUL,  "POP",          /* pop top value */
+       o_return,       OPRET,  "RETURN",       /* return value of function */
+       o_jumpeq,       OPJMP,  "JUMPEQ",       /* jump if value zero */
+       o_jumpne,       OPJMP,  "JUMPNE",       /* jump if value nonzero */
+       o_jump,         OPJMP,  "JUMP",         /* jump unconditionally */
+       o_usercall,     OPTWO,  "USERCALL",     /* call a user function */
+       o_getvalue,     OPNUL,  "GETVALUE",     /* convert address to value */
+       o_eq,           OPNUL,  "EQ",           /* test elements for equality */
+       o_ne,           OPNUL,  "NE",           /* test elements for inequality */
+       o_le,           OPNUL,  "LE",           /* test elements for <= */
+       o_ge,           OPNUL,  "GE",           /* test elements for >= */
+       o_lt,           OPNUL,  "LT",           /* test elements for < */
+       o_gt,           OPNUL,  "GT",           /* test elements for > */
+       o_preinc,       OPNUL,  "PREINC",       /* add one to variable (++x) */
+       o_predec,       OPNUL,  "PREDEC",       /* subtract one from variable (--x) */
+       o_postinc,      OPNUL,  "POSTINC",      /* add one to variable (x++) */
+       o_postdec,      OPNUL,  "POSTDEC",      /* subtract one from variable (x--) */
+       o_debug,        OPONE,  "DEBUG",        /* debugging point */
+       o_print,        OPONE,  "PRINT",        /* print value */
+       o_assignpop,    OPNUL,  "ASSIGNPOP",    /* assign to variable and pop it */
+       o_zero,         OPNUL,  "ZERO",         /* put zero on the stack */
+       o_one,          OPNUL,  "ONE",          /* put one on the stack */
+       o_printeol,     OPNUL,  "PRINTEOL",     /* print end of line */
+       o_printspace,   OPNUL,  "PRINTSPACE",   /* print a space */
+       o_printstring,  OPSTR,  "PRINTSTR",     /* print constant string */
+       o_dupvalue,     OPNUL,  "DUPVALUE",     /* duplicate value of top value */
+       o_oldvalue,     OPNUL,  "OLDVALUE",     /* old value from previous calc */
+       o_quo,          OPNUL,  "QUO",          /* integer quotient of top values */
+       o_power,        OPNUL,  "POWER",        /* value raised to a power */
+       o_quit,         OPSTR,  "QUIT",         /* quit program */
+       o_call,         OPTWO,  "CALL",         /* call built-in routine */
+       o_getepsilon,   OPNUL,  "GETEPSILON",   /* get allowed error for calculations */
+       o_and,          OPNUL,  "AND",          /* arithmetic and or top two values */
+       o_or,           OPNUL,  "OR",           /* arithmetic or of top two values */
+       o_not,          OPNUL,  "NOT",          /* logical not or top value */
+       o_abs,          OPNUL,  "ABS",          /* absolute value of top value */
+       o_sgn,          OPNUL,  "SGN",          /* sign of number */
+       o_isint,        OPNUL,  "ISINT",        /* whether number is an integer */
+       o_condorjump,   OPJMP,  "CONDORJUMP",   /* conditional or jump */
+       o_condandjump,  OPJMP,  "CONDANDJUMP",  /* conditional and jump */
+       o_square,       OPNUL,  "SQUARE",       /* square top value */
+       o_string,       OPSTR,  "STRING",       /* string constant value */
+       o_isnum,        OPNUL,  "ISNUM",        /* whether value is a number */
+       o_undef,        OPNUL,  "UNDEF",        /* load undefined value on stack */
+       o_isnull,       OPNUL,  "ISNULL",       /* whether value is the null value */
+       o_argvalue,     OPARG,  "ARGVALUE",     /* load value of arg (parameter) n */
+       o_matcreate,    OPONE,  "MATCREATE",    /* create matrix */
+       o_ismat,        OPNUL,  "ISMAT",        /* whether value is a matrix */
+       o_isstr,        OPNUL,  "ISSTR",        /* whether value is a string */
+       o_getconfig,    OPNUL,  "GETCONFIG",    /* get value of configuration parameter */
+       o_leftshift,    OPNUL,  "LEFTSHIFT",    /* left shift of integer */
+       o_rightshift,   OPNUL,  "RIGHTSHIFT",   /* right shift of integer */
+       o_casejump,     OPJMP,  "CASEJUMP",     /* test case and jump if not matched */
+       o_isodd,        OPNUL,  "ISODD",        /* whether value is odd integer */
+       o_iseven,       OPNUL,  "ISEVEN",       /* whether value is even integer */
+       o_fiaddr,       OPNUL,  "FIADDR",       /* 'fast index' matrix address */
+       o_fivalue,      OPNUL,  "FIVALUE",      /* 'fast index' matrix value */
+       o_isreal,       OPNUL,  "ISREAL",       /* whether value is real number */
+       o_imaginary,    OPONE,  "IMAGINARY",    /* constant imaginary numeric value */
+       o_re,           OPNUL,  "RE",           /* real part of complex number */
+       o_im,           OPNUL,  "IM",           /* imaginary part of complex number */
+       o_conjugate,    OPNUL,  "CONJUGATE",    /* complex conjugate */
+       o_objcreate,    OPONE,  "OBJCREATE",    /* create object */
+       o_isobj,        OPNUL,  "ISOBJ",        /* whether value is an object */
+       o_norm,         OPNUL,  "NORM",         /* norm of value (square of abs) */
+       o_elemaddr,     OPONE,  "ELEMADDR",     /* address of element of object */
+       o_elemvalue,    OPONE,  "ELEMVALUE",    /* value of element of object */
+       o_istype,       OPNUL,  "ISTYPE",       /* whether types are the same */
+       o_scale,        OPNUL,  "SCALE",        /* scale value by a power of two */
+       o_islist,       OPNUL,  "ISLIST",       /* whether value is a list */
+       o_swap,         OPNUL,  "SWAP",         /* swap values of two variables */
+       o_issimple,     OPNUL,  "ISSIMPLE",     /* whether value is simple type */
+       o_cmp,          OPNUL,  "CMP",          /* compare values returning -1, 0, 1 */
+       o_quomod,       OPNUL,  "QUOMOD",       /* calculate quotient and remainder */
+       o_setconfig,    OPNUL,  "SETCONFIG",    /* set configuration parameter */
+       o_setepsilon,   OPNUL,  "SETEPSILON",   /* set allowed error for calculations */
+       o_isfile,       OPNUL,  "ISFILE",       /* whether value is a file */
+       o_isassoc,      OPNUL,  "ISASSOC",      /* whether value is an association */
+       o_nop,          OPSTI,  "INITSTATIC",   /* once only code for static init */
+       o_eleminit,     OPONE,  "ELEMINIT"      /* assign element of matrix or object */
+};
+
+
+
+/*
+ * Initialize the stack.
+ */
+void
+initstack()
+{
+       int i;
+
+       /* on first init, setup the stack array */
+       if (stack == NULL) {
+               for (i=0; i < sizeof(stackarray)/sizeof(stackarray[0]); ++i) {
+                       stackarray[i].v_type = V_NULL;
+                       stackarray[i].v_subtype = V_NOSUBTYPE;
+               }
+               stack = stackarray;
+
+       /* on subsequent inits, free the old stack */
+       } else {
+               while (stack > stackarray) {
+                       freevalue(stack--);
+               }
+       }
+}
+
+
+/*
+ * Compute the result of a function by interpreting opcodes.
+ * Arguments have just been pushed onto the evaluation stack.
+ */
+void
+calculate(fp, argcount)
+       register FUNC *fp;              /* function to calculate */
+       int argcount;                   /* number of arguments called with */
+{
+       register unsigned long pc;      /* current pc inside function */
+       register struct opcode *op;     /* current opcode pointer */
+       register VALUE *locals;         /* pointer to local variables */
+       long oldline;                   /* old value of line counter */
+       unsigned int opnum;             /* current opcode number */
+       int origargcount;               /* original number of arguments */
+       int i;                          /* loop counter */
+       BOOL dojump;                    /* TRUE if jump is to occur */
+       char *oldname;                  /* old function name being executed */
+       VALUE *beginstack;              /* beginning of stack frame */
+       VALUE *args;                    /* pointer to function arguments */
+       VALUE retval;                   /* function return value */
+       VALUE localtable[QUICKLOCALS];  /* some local variables */
+
+       oldname = funcname;
+       oldline = funcline;
+       funcname = fp->f_name;
+       funcline = 0;
+       origargcount = argcount;
+       while (argcount < fp->f_paramcount) {
+               stack++;
+               stack->v_type = V_NULL;
+               argcount++;
+       }
+       locals = localtable;
+       if (fp->f_localcount > QUICKLOCALS) {
+               locals = (VALUE *) malloc(sizeof(VALUE) * fp->f_localcount);
+               if (locals == NULL)
+                       math_error("No memory for local variables");
+       }
+       for (i = 0; i < fp->f_localcount; i++) {
+               locals[i].v_num = qlink(&_qzero_);
+               locals[i].v_type = V_NUM;
+               locals[i].v_subtype = V_NOSUBTYPE;
+       }
+       pc = 0;
+       beginstack = stack;
+       args = beginstack - (argcount - 1);
+       for (;;) {
+               if (abortlevel >= ABORT_OPCODE)
+                       math_error("Calculation aborted in opcode");
+               if (pc >= fp->f_opcodecount)
+                       math_error("Function pc out of range");
+               if (stack > &stackarray[MAXSTACK-3])
+                       math_error("Evaluation stack depth exceeded");
+               opnum = fp->f_opcodes[pc];
+               if (opnum > MAX_OPCODE)
+                       math_error("Function opcode out of range");
+               op = &opcodes[opnum];
+               if (traceflags & TRACE_OPCODES) {
+                       printf("%8s, pc %4ld:  ", fp->f_name, pc);
+                       (void)dumpop(&fp->f_opcodes[pc]);
+               }
+               /*
+                * Now call the opcode routine appropriately.
+                */
+               pc++;
+               switch (op->o_type) {
+               case OPNUL:     /* no extra arguments */
+                       (*op->o_func)(fp);
+                       break;
+
+               case OPONE:     /* one extra integer argument */
+                       (*op->o_func)(fp, fp->f_opcodes[pc++]);
+                       break;
+
+               case OPTWO:     /* two extra integer arguments */
+                       (*op->o_func)(fp, fp->f_opcodes[pc],
+                               fp->f_opcodes[pc+1]);
+                       pc += 2;
+                       break;
+
+               case OPJMP:     /* jump opcodes (one extra pointer arg) */
+                       dojump = FALSE;
+                       (*op->o_func)(fp, &dojump);
+                       if (dojump)
+                               pc = fp->f_opcodes[pc];
+                       else
+                               pc++;
+                       break;
+
+               case OPGLB:     /* global symbol reference (pointer arg) */
+               case OPSTR:     /* string constant address */
+                       (*op->o_func)(fp, *((char **) &fp->f_opcodes[pc]));
+                       pc += PTR_SIZE;
+                       break;
+
+               case OPLOC:     /* local variable reference */
+                       (*op->o_func)(fp, locals, fp->f_opcodes[pc++]);
+                       break;
+
+               case OPPAR:     /* parameter variable reference */
+                       (*op->o_func)(fp, argcount, args, fp->f_opcodes[pc++]);
+                       break;
+
+               case OPARG:     /* parameter variable reference */
+                       (*op->o_func)(fp, origargcount, args);
+                       break;
+
+               case OPRET:     /* return from function */
+                       if (stack->v_type == V_ADDR)
+                               copyvalue(stack->v_addr, stack);
+                       for (i = 0; i < fp->f_localcount; i++)
+                               freevalue(&locals[i]);
+                       if (locals != localtable)
+                               free(locals);
+                       if (stack != &beginstack[1])
+                               math_error("Misaligned stack");
+                       if (argcount <= 0) {
+                               funcname = oldname;
+                               funcline = oldline;
+                               return;
+                       }
+                       retval = *stack--;
+                       while (--argcount >= 0)
+                               freevalue(stack--);
+                       *++stack = retval;
+                       funcname = oldname;
+                       funcline = oldline;
+                       return;
+
+               case OPSTI:     /* static initialization code */
+                       fp->f_opcodes[pc++ - 1] = OP_JUMP;
+                       break;
+               
+               default:
+                       math_error("Unknown opcode type");
+               }
+       }
+}
+
+
+/*
+ * Dump an opcode at a particular address.
+ * Returns the size of the opcode so that it can easily be skipped over.
+ */
+int
+dumpop(pc)
+       long *pc;               /* location of the opcode */
+{
+       unsigned long op;       /* opcode number */
+
+       op = *pc++;
+       if (op <= MAX_OPCODE)
+               printf("%s", opcodes[op].o_name);
+       else
+               printf("OP%ld", op);
+       switch (op) {
+               case OP_LOCALADDR: case OP_LOCALVALUE:
+                       printf(" %s\n", localname(*pc));
+                       return 2;
+               case OP_GLOBALADDR: case OP_GLOBALVALUE:
+                       printf(" %s\n", globalname(*((GLOBAL **) pc)));
+                       return (1 + PTR_SIZE);
+               case OP_PARAMADDR: case OP_PARAMVALUE:
+                       printf(" %s\n", paramname(*pc));
+                       return 2;
+               case OP_PRINTSTRING: case OP_STRING:
+                       printf(" \"%s\"\n", *((char **) pc));
+                       return (1 + PTR_SIZE);
+               case OP_QUIT:
+                       if (*(char **) pc)
+                               printf(" \"%s\"\n", *((char **) pc));
+                       else
+                               printf("\n");
+                       return (1 + PTR_SIZE);
+               case OP_INDEXADDR:
+                       printf(" %ld %ld\n", pc[0], pc[1]);
+                       return 3;
+               case OP_PRINT: case OP_JUMPEQ: case OP_JUMPNE: case OP_JUMP:
+               case OP_CONDORJUMP: case OP_CONDANDJUMP: case OP_CASEJUMP:
+               case OP_INITSTATIC: case OP_MATCREATE: case OP_OBJCREATE:
+                       printf(" %ld\n", *pc);
+                       return 2;
+               case OP_NUMBER: case OP_IMAGINARY:
+                       qprintf(" %r\n", constvalue(*pc));
+                       return 2;
+               case OP_DEBUG:
+                       printf(" line %ld\n", *pc);
+                       return 2;
+               case OP_CALL:
+                       printf(" %s with %ld args\n", builtinname(pc[0]), pc[1]);
+                       return 3;
+               case OP_USERCALL:
+                       printf(" %s with %ld args\n", namefunc(pc[0]), pc[1]);
+                       return 3;
+               default:
+                       printf("\n");
+                       return 1;
+       }
+}
+
+
+/*
+ * The various opcodes
+ */
+
+static void
+o_nop()
+{
+}
+
+
+static void
+o_localaddr(fp, locals, index)
+       FUNC *fp;
+       VALUE *locals;
+       long index;
+{
+       if ((unsigned long)index >= fp->f_localcount)
+               math_error("Bad local variable index");
+       locals += index;
+       stack++;
+       stack->v_addr = locals;
+       stack->v_type = V_ADDR;
+}
+
+
+/*ARGSUSED*/
+static void
+o_globaladdr(fp, sp)
+       FUNC *fp;
+       GLOBAL *sp;
+{
+       if (sp == NULL)
+               math_error("Global variable \"%s\" not initialized", sp->g_name);
+       stack++;
+       stack->v_addr = &sp->g_value;
+       stack->v_type = V_ADDR;
+}
+
+
+/*ARGSUSED*/
+static void
+o_paramaddr(fp, argcount, args, index)
+       FUNC *fp;
+       int argcount;
+       VALUE *args;
+       long index;
+{
+       if ((unsigned long)index >= argcount)
+               math_error("Bad parameter index");
+       args += index;
+       stack++;
+       if (args->v_type == V_ADDR)
+               stack->v_addr = args->v_addr;
+       else
+               stack->v_addr = args;
+       stack->v_type = V_ADDR;
+}
+
+
+static void
+o_localvalue(fp, locals, index)
+       FUNC *fp;
+       VALUE *locals;
+       long index;
+{
+       if ((unsigned long)index >= fp->f_localcount)
+               math_error("Bad local variable index");
+       locals += index;
+       copyvalue(locals, ++stack);
+}
+
+
+/*ARGSUSED*/
+static void
+o_globalvalue(fp, sp)
+       FUNC *fp;
+       GLOBAL *sp;             /* global symbol */
+{
+       if (sp == NULL)
+               math_error("Global variable not defined");
+       copyvalue(&sp->g_value, ++stack);
+}
+
+
+/*ARGSUSED*/
+static void
+o_paramvalue(fp, argcount, args, index)
+       FUNC *fp;
+       int argcount;
+       VALUE *args;
+       long index;
+{
+       if ((unsigned long)index >= argcount)
+               math_error("Bad paramaeter index");
+       args += index;
+       if (args->v_type == V_ADDR)
+               args = args->v_addr;
+       copyvalue(args, ++stack);
+}
+
+
+static void
+o_argvalue(fp, argcount, args)
+       FUNC *fp;
+       int argcount;
+       VALUE *args;
+{
+       VALUE *vp;
+       long index;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if ((vp->v_type != V_NUM) || qisneg(vp->v_num) ||
+               qisfrac(vp->v_num))
+                       math_error("Illegal argument for arg function");
+       if (qiszero(vp->v_num)) {
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = itoq((long) argcount);
+               stack->v_type = V_NUM;
+               return;
+       }
+       index = qtoi(vp->v_num) - 1;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       (void) o_paramvalue(fp, argcount, args, index);
+}
+
+
+/*ARGSUSED*/
+static void
+o_number(fp, arg)
+       FUNC *fp;
+       long arg;
+{
+       NUMBER *q;
+
+       q = constvalue(arg);
+       if (q == NULL)
+               math_error("Numeric constant value not found");
+       stack++;
+       stack->v_num = qlink(q);
+       stack->v_type = V_NUM;
+}
+
+
+/*ARGSUSED*/
+static void
+o_imaginary(fp, arg)
+       FUNC *fp;
+       long arg;
+{
+       NUMBER *q;
+       COMPLEX *c;
+
+       q = constvalue(arg);
+       if (q == NULL)
+               math_error("Numeric constant value not found");
+       stack++;
+       if (qiszero(q)) {
+               stack->v_num = qlink(q);
+               stack->v_type = V_NUM;
+               return;
+       }
+       c = comalloc();
+       c->real = qlink(&_qzero_);
+       c->imag = qlink(q);
+       stack->v_com = c;
+       stack->v_type = V_COM;
+}
+
+
+/*ARGSUSED*/
+static void
+o_string(fp, cp)
+       FUNC *fp;
+       char *cp;
+{
+       stack++;
+       stack->v_str = cp;
+       stack->v_type = V_STR;
+       stack->v_subtype = V_STRLITERAL;
+}
+
+
+static void
+o_undef()
+{
+       stack++;
+       stack->v_type = V_NULL;
+}
+
+
+/*ARGSUSED*/
+static void
+o_matcreate(fp, dim)
+       FUNC *fp;
+       long dim;
+{
+       register MATRIX *mp;    /* matrix being defined */
+       NUMBER *num1;           /* first number from stack */
+       NUMBER *num2;           /* second number from stack */
+       VALUE *vp;              /* value being defined */
+       VALUE *v1, *v2;
+       long min[MAXDIM];       /* minimum range */
+       long max[MAXDIM];       /* maximum range */
+       long i;                 /* index */
+       long tmp;               /* temporary */
+       long size;              /* size of matrix */
+
+       if ((dim <= 0) || (dim > MAXDIM))
+               math_error("Bad dimension %ld for matrix", dim);
+       if (stack[-2*dim].v_type != V_ADDR)
+               math_error("Attempting to init matrix for non-address");
+       size = 1;
+       for (i = dim - 1; i >= 0; i--) {
+               v1 = &stack[-1];
+               v2 = &stack[0];
+               if (v1->v_type == V_ADDR)
+                       v1 = v1->v_addr;
+               if (v2->v_type == V_ADDR)
+                       v2 = v2->v_addr;
+               if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
+                       math_error("Non-numeric bounds for matrix");
+               num1 = v1->v_num;
+               num2 = v2->v_num;
+               if (qisfrac(num1) || qisfrac(num2))
+                       math_error("Non-integral bounds for matrix");
+               if (zisbig(num1->num) || zisbig(num2->num))
+                       math_error("Very large bounds for matrix");
+               min[i] = qtoi(num1);
+               max[i] = qtoi(num2);
+               if (min[i] > max[i]) {
+                       tmp = min[i];
+                       min[i] = max[i];
+                       max[i] = tmp;
+               }
+               size *= (max[i] - min[i] + 1);
+               if (size > 10000000)
+                       math_error("Very large size for matrix");
+               freevalue(stack--);
+               freevalue(stack--);
+       }
+       mp = matalloc(size);
+       mp->m_dim = dim;
+       for (i = 0; i < dim; i++) {
+               mp->m_min[i] = min[i];
+               mp->m_max[i] = max[i];
+       }
+       vp = mp->m_table;
+       for (i = 0; i < size; i++) {
+               vp->v_type = V_NUM;
+               vp->v_num = qlink(&_qzero_);
+               vp++;
+       }
+       vp = stack[0].v_addr;
+       vp->v_type = V_MAT;
+       vp->v_mat = mp;
+}
+
+
+/*ARGSUSED*/
+static void
+o_eleminit(fp, index)
+       FUNC *fp;
+       long index;
+{
+       VALUE *vp;
+       static VALUE *oldvp;
+       MATRIX *mp;
+       OBJECT *op;
+
+       vp = &stack[-1];
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       switch (vp->v_type) {
+               case V_MAT:
+                       mp = vp->v_mat;
+                       if ((index < 0) || (index >= mp->m_size))
+                               math_error("Too many initializer values");
+                       oldvp = &mp->m_table[index];
+                       break;
+               case V_OBJ:
+                       op = vp->v_obj;
+                       if ((index < 0) || (index >= op->o_actions->count))
+                               math_error("Too many initializer values");
+                       oldvp = &op->o_table[index];
+                       break;
+               default:
+                       math_error("Attempt to initialize non matrix or object");
+       }
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       freevalue(oldvp);
+       copyvalue(vp, oldvp);
+       stack--;
+}
+
+
+/*ARGSUSED*/
+static void
+o_indexaddr(fp, dim, writeflag)
+       FUNC *fp;
+       long dim;               /* dimension of matrix */
+       long writeflag;         /* nonzero if element will be written */
+{
+       int i;
+       BOOL flag;
+       VALUE *val;
+       VALUE *vp;
+       VALUE indices[MAXDIM];  /* index values */
+
+       flag = (writeflag != 0);
+       if ((dim <= 0) || (dim > MAXDIM))
+               math_error("Too many dimensions for indexing");
+       val = &stack[-dim];
+       if (val->v_type != V_ADDR)
+               math_error("Non-pointer for index operation");
+       val = val->v_addr;
+       vp = &stack[-dim + 1];
+       for (i = 0; i < dim; i++) {
+               if (vp->v_type == V_ADDR)
+                       indices[i] = vp->v_addr[0];
+               else
+                       indices[i] = vp[0];
+               vp++;
+       }
+       switch (val->v_type) {
+               case V_MAT:
+                       vp = matindex(val->v_mat, flag, dim, indices);
+                       break;
+               case V_ASSOC:
+                       vp = associndex(val->v_assoc, flag, dim, indices);
+                       break;
+               default:
+                       math_error("Illegal value for indexing");
+       }
+       while (dim-- > 0)
+               freevalue(stack--);
+       stack->v_type = V_ADDR;
+       stack->v_addr = vp;
+}
+
+
+/*ARGSUSED*/
+static void
+o_elemaddr(fp, index)
+       FUNC *fp;
+       long index;
+{
+       if (stack->v_type != V_ADDR)
+               math_error("Non-pointer for element reference");
+       if (stack->v_addr->v_type != V_OBJ)
+               math_error("Referencing element of non-object");
+       index = objoffset(stack->v_addr->v_obj, index);
+       if (index < 0)
+               math_error("Element does not exist for object");
+       stack->v_addr = &stack->v_addr->v_obj->o_table[index];
+}
+
+
+static void
+o_elemvalue(fp, index)
+       FUNC *fp;
+       long index;
+{
+       if (stack->v_type != V_OBJ) {
+               (void) o_elemaddr(fp, index);
+               (void) o_getvalue();
+               return;
+       }
+       index = objoffset(stack->v_obj, index);
+       if (index < 0)
+               math_error("Element does not exist for object");
+       copyvalue(&stack->v_obj->o_table[index], stack);
+}
+
+
+/*ARGSUSED*/
+static void
+o_objcreate(fp, arg)
+       FUNC *fp;
+       long arg;
+{
+       OBJECT *op;             /* object being created */
+       VALUE *vp;              /* value being defined */
+
+       if (stack->v_type != V_ADDR)
+               math_error("Attempting to init object for non-address");
+       op = objalloc(arg);
+       vp = stack->v_addr;
+       vp->v_type = V_OBJ;
+       vp->v_obj = op;
+}
+
+
+static void
+o_assign()
+{
+       VALUE *var;             /* variable value */
+       VALUE *vp;
+
+       var = &stack[-1];
+       if (var->v_type != V_ADDR)
+               math_error("Assignment into non-variable");
+       var = var->v_addr;
+       stack[-1] = stack[0];
+       stack--;
+       vp = stack;
+       if (vp->v_type == V_ADDR) {
+               vp = vp->v_addr;
+               if (vp == var)
+                       return;
+       }
+       freevalue(var);
+       copyvalue(vp, var);
+}
+
+
+static void
+o_assignpop()
+{
+       VALUE *var;             /* variable value */
+       VALUE *vp;
+
+       var = &stack[-1];
+       if (var->v_type != V_ADDR)
+               math_error("Assignment into non-variable");
+       var = var->v_addr;
+       vp = &stack[0];
+       if ((vp->v_type == V_ADDR) && (vp->v_addr == var)) {
+               stack -= 2;
+               return;
+       }
+       freevalue(var);
+       if (vp->v_type == V_ADDR)
+               copyvalue(vp->v_addr, var);
+       else
+               *var = *vp;
+       stack -= 2;
+}
+
+
+static void
+o_swap()
+{
+       VALUE *v1, *v2;         /* variables to be swapped */
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if ((v1->v_type != V_ADDR) || (v2->v_type != V_ADDR))
+               math_error("Swapping non-variables");
+       tmp = v1->v_addr[0];
+       v1->v_addr[0] = v2->v_addr[0];
+       v2->v_addr[0] = tmp;
+       stack--;
+       stack->v_type = V_NULL;
+}
+
+
+static void
+o_add()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
+               addvalue(v1, v2, &tmp);
+               freevalue(stack--);
+               freevalue(stack);
+               *stack = tmp;
+               return;
+       }
+       q = qadd(v1->v_num, v2->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_sub()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
+               subvalue(v1, v2, &tmp);
+               freevalue(stack--);
+               freevalue(stack);
+               *stack = tmp;
+               return;
+       }
+       q = qsub(v1->v_num, v2->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_mul()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
+               mulvalue(v1, v2, &tmp);
+               freevalue(stack--);
+               freevalue(stack);
+               *stack = tmp;
+               return;
+       }
+       q = qmul(v1->v_num, v2->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_power()
+{
+       VALUE *v1, *v2;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       powivalue(v1, v2, &tmp);
+       freevalue(stack--);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_div()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
+               divvalue(v1, v2, &tmp);
+               freevalue(stack--);
+               freevalue(stack);
+               *stack = tmp;
+               return;
+       }
+       q = qdiv(v1->v_num, v2->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_quo()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
+               quovalue(v1, v2, &tmp);
+               freevalue(stack--);
+               freevalue(stack);
+               *stack = tmp;
+               return;
+       }
+       q = qquo(v1->v_num, v2->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_mod()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
+               modvalue(v1, v2, &tmp);
+               freevalue(stack--);
+               freevalue(stack);
+               *stack = tmp;
+               return;
+       }
+       q = qmod(v1->v_num, v2->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_quomod()
+{
+       VALUE *v1, *v2, *v3, *v4;
+       VALUE valquo, valmod;
+       BOOL res;
+
+       v1 = &stack[-3];
+       v2 = &stack[-2];
+       v3 = &stack[-1];
+       v4 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v3->v_type != V_ADDR) || (v4->v_type != V_ADDR))
+               math_error("Non-variable for quomod");
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
+               math_error("Non-reals for quomod");
+       v3 = v3->v_addr;
+       v4 = v4->v_addr;
+       valquo.v_type = V_NUM;
+       valmod.v_type = V_NUM;
+       res = qquomod(v1->v_num, v2->v_num, &valquo.v_num, &valmod.v_num);
+       freevalue(stack--);
+       freevalue(stack--);
+       stack--;
+       stack->v_num = (res ? qlink(&_qone_) : qlink(&_qzero_));
+       stack->v_type = V_NUM;
+       freevalue(v3);
+       freevalue(v4);
+       *v3 = valquo;
+       *v4 = valmod;
+}
+
+
+static void
+o_and()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
+               math_error("Non-numerics for and");
+       q = qand(v1->v_num, v2->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_or()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM))
+               math_error("Non-numerics for or");
+       q = qor(v1->v_num, v2->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_not()
+{
+       VALUE *vp;
+       int r;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       r = testvalue(vp);
+       freevalue(stack);
+       stack->v_num = (r ? qlink(&_qzero_) : qlink(&_qone_));          
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_negate()
+{
+       VALUE *vp;
+       NUMBER *q;
+       VALUE tmp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               q = qneg(vp->v_num);
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = q;
+               stack->v_type = V_NUM;
+               return;
+       }
+       negvalue(vp, &tmp);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_invert()
+{
+       VALUE *vp;
+       NUMBER *q;
+       VALUE tmp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               q = qinv(vp->v_num);
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = q;
+               stack->v_type = V_NUM;
+               return;
+       }
+       invertvalue(vp, &tmp);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_scale()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       VALUE tmp;
+
+       v1 = &stack[0];
+       v2 = &stack[-1];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
+               scalevalue(v2, v1, &tmp);
+               freevalue(stack--);
+               freevalue(stack);
+               *stack = tmp;
+               return;
+       }
+       q = v1->v_num;
+       if (qisfrac(q))
+               math_error("Non-integral scaling factor");
+       if (zisbig(q->num))
+               math_error("Very large scaling factor");
+       q = qscale(v2->v_num, qtoi(q));
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_int()
+{
+       VALUE *vp;
+       NUMBER *q;
+       VALUE tmp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               if (qisint(vp->v_num) && (stack->v_type == V_NUM))
+                       return;
+               q = qint(vp->v_num);
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = q;
+               stack->v_type = V_NUM;
+               return;
+       }
+       intvalue(vp, &tmp);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_frac()
+{
+       VALUE *vp;
+       NUMBER *q;
+       VALUE tmp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               q = qfrac(vp->v_num);
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = q;
+               stack->v_type = V_NUM;
+               return;
+       }
+       fracvalue(vp, &tmp);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_abs()
+{
+       VALUE *v1, *v2;
+       NUMBER *q;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM) ||
+               !qispos(v2->v_num))
+       {
+               absvalue(v1, v2, &tmp);
+               freevalue(stack--);
+               freevalue(stack);
+               *stack = tmp;
+               return;
+       }
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack--;
+       if ((stack->v_type == V_NUM) && !qisneg(v1->v_num))
+               return;
+       q = qabs(v1->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_norm()
+{
+       VALUE *vp;
+       NUMBER *q;
+       VALUE tmp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               q = qsquare(vp->v_num);
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = q;
+               stack->v_type = V_NUM;
+               return;
+       }
+       normvalue(vp, &tmp);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_square()
+{
+       VALUE *vp;
+       NUMBER *q;
+       VALUE tmp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               q = qsquare(vp->v_num);
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = q;
+               stack->v_type = V_NUM;
+               return;
+       }
+       squarevalue(vp, &tmp);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_istype()
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if ((v1->v_type != V_OBJ) || (v2->v_type != V_OBJ))
+               r = (v1->v_type == v2->v_type);
+       else
+               r = (v1->v_obj->o_actions == v2->v_obj->o_actions);
+       freevalue(stack--);
+       freevalue(stack);
+       stack->v_num = itoq((long) r);
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isint()
+{
+       VALUE *vp;
+       NUMBER *q;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = stack->v_addr;
+       if (vp->v_type != V_NUM) {
+               freevalue(stack);
+               stack->v_num = qlink(&_qzero_);
+               stack->v_type = V_NUM;
+               return;
+       }
+       if (qisint(vp->v_num))
+               q = qlink(&_qone_);
+       else
+               q = qlink(&_qzero_);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isnum()
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       switch (vp->v_type) {
+               case V_NUM:
+                       if (stack->v_type == V_NUM)
+                               qfree(stack->v_num);
+                       break;
+               case V_COM:
+                       if (stack->v_type == V_COM)
+                               comfree(stack->v_com);
+                       break;
+               default:
+                       freevalue(stack);
+                       stack->v_num = qlink(&_qzero_);
+                       stack->v_type = V_NUM;
+                       return;
+       }
+       stack->v_num = qlink(&_qone_);
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_ismat()
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type != V_MAT) {
+               freevalue(stack);
+               stack->v_num = qlink(&_qzero_);
+               stack->v_type = V_NUM;
+               return;
+       }
+       freevalue(stack);
+       stack->v_type = V_NUM;
+       stack->v_num = qlink(&_qone_);
+}
+
+
+static void
+o_islist()
+{
+       VALUE *vp;
+       int r;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       r = (vp->v_type == V_LIST);
+       freevalue(stack);
+       stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isobj()
+{
+       VALUE *vp;
+       int r;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       r = (vp->v_type == V_OBJ);
+       freevalue(stack);
+       stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isstr()
+{
+       VALUE *vp;
+       int r;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       r = (vp->v_type == V_STR);
+       freevalue(stack);
+       stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isfile()
+{
+       VALUE *vp;
+       int r;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       r = (vp->v_type == V_FILE);
+       freevalue(stack);
+       stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isassoc()
+{
+       VALUE *vp;
+       int r;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       r = (vp->v_type == V_ASSOC);
+       freevalue(stack);
+       stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_issimple()
+{
+       VALUE *vp;
+       int r;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       r = 0;
+       switch (vp->v_type) {
+               case V_NULL:
+               case V_NUM:
+               case V_COM:
+               case V_STR:
+                       r = 1;
+       }
+       freevalue(stack);
+       stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isodd()
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if ((vp->v_type == V_NUM) && qisodd(vp->v_num)) {
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = qlink(&_qone_);
+               stack->v_type = V_NUM;
+               return;
+       }
+       freevalue(stack);
+       stack->v_num = qlink(&_qzero_);
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_iseven()
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if ((vp->v_type == V_NUM) && qiseven(vp->v_num)) {
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = qlink(&_qone_);
+               stack->v_type = V_NUM;
+               return;
+       }
+       freevalue(stack);
+       stack->v_num = qlink(&_qzero_);
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isreal()
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = qlink(&_qone_);
+               stack->v_type = V_NUM;
+               return;
+       }
+       freevalue(stack);
+       stack->v_num = qlink(&_qzero_);
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_isnull()
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type != V_NULL) {
+               freevalue(stack);
+               stack->v_num = qlink(&_qzero_);
+               stack->v_type = V_NUM;
+               return;
+       }
+       freevalue(stack);
+       stack->v_num = qlink(&_qone_);
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_re()
+{
+       VALUE *vp;
+       NUMBER *q;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               if (stack->v_type == V_ADDR) {
+                       stack->v_num = qlink(vp->v_num);
+                       stack->v_type = V_NUM;
+               }
+               return;
+       }
+       if (vp->v_type != V_COM)
+               math_error("Taking real part of non-number");
+       q = qlink(vp->v_com->real);
+       if (stack->v_type == V_COM)
+               comfree(stack->v_com);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_im()
+{
+       VALUE *vp;
+       NUMBER *q;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack->v_num = qlink(&_qzero_);
+               stack->v_type = V_NUM;
+               return;
+       }
+       if (vp->v_type != V_COM)
+               math_error("Taking imaginary part of non-number");
+       q = qlink(vp->v_com->imag);
+       if (stack->v_type == V_COM)
+               comfree(stack->v_com);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_conjugate()
+{
+       VALUE *vp;
+       VALUE tmp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               if (stack->v_type == V_ADDR) {
+                       stack->v_num = qlink(vp->v_num);
+                       stack->v_type = V_NUM;
+               }
+               return;
+       }
+       conjvalue(vp, &tmp);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_fiaddr()
+{
+       register MATRIX *m;     /* current matrix element */
+       NUMBER *q;              /* index value */
+       LIST *lp;               /* list header */
+       ASSOC *ap;              /* association header */
+       VALUE *vp;              /* stack value */
+       long index;             /* index value as an integer */
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type != V_NUM)
+               math_error("Fast indexing by non-number");
+       q = vp->v_num;
+       if (qisfrac(q))
+               math_error("Fast indexing by non-integer");
+       index = qtoi(q);
+       if (zisbig(q->num) || (index < 0))
+               math_error("Index out of range for fast indexing");
+       if (stack->v_type == V_NUM)
+               qfree(q);
+       stack--;
+       vp = stack;
+       if (vp->v_type != V_ADDR)
+               math_error("Bad value for fast indexing");
+       switch (vp->v_addr->v_type) {
+               case V_OBJ:
+                       if (index >= vp->v_addr->v_obj->o_actions->count)
+                               math_error("Index out of bounds for object");
+                       vp->v_addr = vp->v_addr->v_obj->o_table + index;
+                       break;
+               case V_MAT:
+                       m = vp->v_addr->v_mat;
+                       if (index >= m->m_size)
+                               math_error("Index out of bounds for matrix");
+                       vp->v_addr = m->m_table + index;
+                       break;
+               case V_LIST:
+                       lp = vp->v_addr->v_list;
+                       vp->v_addr = listfindex(lp, index);
+                       if (vp->v_addr == NULL)
+                               math_error("Index out of bounds for list");
+                       break;
+               case V_ASSOC:
+                       ap = vp->v_addr->v_assoc;
+                       vp->v_addr = assocfindex(ap, index);
+                       if (vp->v_addr == NULL)
+                               math_error("Index out of bounds for association");
+                       break;
+               default:
+                       math_error("Bad variable type for fast indexing");
+       }
+}
+
+
+static void
+o_fivalue()
+{
+       (void) o_fiaddr();
+       (void) o_getvalue();
+}
+
+
+static void
+o_sgn()
+{
+       VALUE *vp;
+       NUMBER *q;
+       VALUE val;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       switch (vp->v_type) {
+               case V_NUM:
+                       q = qsign(vp->v_num);
+                       if (stack->v_type == V_NUM)
+                               qfree(vp->v_num);
+                       stack->v_num = q;
+                       stack->v_type = V_NUM;
+                       break;
+               case V_OBJ:
+                       val = objcall(OBJ_SGN, vp, NULL_VALUE, NULL_VALUE);
+                       q = itoq(val.v_int);
+                       freevalue(stack);
+                       stack->v_num = q;
+                       stack->v_type = V_NUM;
+                       break;
+               default:
+                       math_error("Bad value for sgn");
+       }
+}
+
+
+static void
+o_numerator()
+{
+       VALUE *vp;
+       NUMBER *q;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type != V_NUM)
+               math_error("Numerator of non-number");
+       if ((stack->v_type == V_NUM) && qisint(vp->v_num))
+               return;
+       q = qnum(vp->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_denominator()
+{
+       VALUE *vp;
+       NUMBER *q;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type != V_NUM)
+               math_error("Denominator of non-number");
+       q = qden(vp->v_num);
+       if (stack->v_type == V_NUM)
+               qfree(stack->v_num);
+       stack->v_num = q;
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_duplicate()
+{
+       copyvalue(stack, stack + 1);
+       stack++;
+}
+
+
+static void
+o_dupvalue()
+{
+       if (stack->v_type == V_ADDR)
+               copyvalue(stack->v_addr, stack + 1);
+       else
+               copyvalue(stack, stack + 1);
+       stack++;
+}
+
+
+static void
+o_pop()
+{
+       freevalue(stack--);
+}
+
+
+static void
+o_return()
+{
+}
+
+
+/*ARGSUSED*/
+static void
+o_jumpeq(fp, dojump)
+       FUNC *fp;
+       BOOL *dojump;
+{
+       VALUE *vp;
+       int i;                  /* result of comparison */
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               i = !qiszero(vp->v_num);
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+       } else {
+               i = testvalue(vp);
+               freevalue(stack);
+       }
+       stack--;
+       if (!i)
+               *dojump = TRUE;
+}
+
+
+/*ARGSUSED*/
+static void
+o_jumpne(fp, dojump)
+       FUNC *fp;
+       BOOL *dojump;
+{
+       VALUE *vp;
+       int i;                  /* result of comparison */
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               i = !qiszero(vp->v_num);
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+       } else {
+               i = testvalue(vp);
+               freevalue(stack);
+       }
+       stack--;
+       if (i)
+               *dojump = TRUE;
+}
+
+
+/*ARGSUSED*/
+static void
+o_condorjump(fp, dojump)
+       FUNC *fp;
+       BOOL *dojump;
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               if (!qiszero(vp->v_num)) {
+                       *dojump = TRUE;
+                       return;
+               }
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack--;
+               return;
+       }
+       if (testvalue(vp))
+               *dojump = TRUE;
+       else
+               freevalue(stack--);
+}
+
+
+/*ARGSUSED*/
+static void
+o_condandjump(fp, dojump)
+       FUNC *fp;
+       BOOL *dojump;
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type == V_NUM) {
+               if (qiszero(vp->v_num)) {
+                       *dojump = TRUE;
+                       return;
+               }
+               if (stack->v_type == V_NUM)
+                       qfree(stack->v_num);
+               stack--;
+               return;
+       }
+       if (!testvalue(vp))
+               *dojump = TRUE;
+       else
+               freevalue(stack--);
+}
+
+
+/*
+ * Compare the top two values on the stack for equality and jump if they are
+ * different, popping off the top element, leaving the first one on the stack.
+ * If they are equal, pop both values and do not jump.
+ */
+/*ARGSUSED*/
+static void
+o_casejump(fp, dojump)
+       FUNC *fp;
+       BOOL *dojump;
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       r = comparevalue(v1, v2);
+       freevalue(stack--);
+       if (r)
+               *dojump = TRUE;
+       else
+               freevalue(stack--);
+}
+
+
+/*ARGSUSED*/
+static void
+o_jump(fp, dojump)
+       FUNC *fp;
+       BOOL *dojump;
+{
+       *dojump = TRUE;
+}
+
+
+static void
+o_usercall(fp, index, argcount)
+       FUNC *fp;
+       long index, argcount;
+{
+       fp = findfunc(index);
+       if (fp == NULL)
+               math_error("Function \"%s\" is undefined", namefunc(index));
+       calculate(fp, (int) argcount);
+}
+
+
+/*ARGSUSED*/
+static void
+o_call(fp, index, argcount)
+       FUNC *fp;
+       long index, argcount;
+{
+       VALUE result;
+
+       result = builtinfunc(index, (int) argcount, stack);
+       while (--argcount >= 0)
+               freevalue(stack--);
+       stack++;
+       *stack = result;
+}
+
+
+static void
+o_getvalue()
+{
+       if (stack->v_type == V_ADDR)
+               copyvalue(stack->v_addr, stack);
+}
+
+
+static void
+o_cmp()
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       r = relvalue(v1, v2);
+       freevalue(stack--);
+       freevalue(stack);
+       stack->v_num = itoq((long) r);
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_eq()
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       r = comparevalue(v1, v2);
+       freevalue(stack--);
+       freevalue(stack);
+       stack->v_num = itoq((long) (r == 0));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_ne()
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       r = comparevalue(v1, v2);
+       freevalue(stack--);
+       freevalue(stack);
+       stack->v_num = itoq((long) (r != 0));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_le()
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       r = relvalue(v1, v2);
+       freevalue(stack--);
+       freevalue(stack);
+       stack->v_num = itoq((long) (r <= 0));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_ge()
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       r = relvalue(v1, v2);
+       freevalue(stack--);
+       freevalue(stack);
+       stack->v_num = itoq((long) (r >= 0));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_lt()
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       r = relvalue(v1, v2);
+       freevalue(stack--);
+       freevalue(stack);
+       stack->v_num = itoq((long) (r < 0));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_gt()
+{
+       VALUE *v1, *v2;
+       int r;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       r = relvalue(v1, v2);
+       freevalue(stack--);
+       freevalue(stack);
+       stack->v_num = itoq((long) (r > 0));
+       stack->v_type = V_NUM;
+}
+
+
+static void
+o_preinc()
+{
+       NUMBER *q, **np;
+       VALUE *vp, tmp;
+
+       if (stack->v_type != V_ADDR)
+               math_error("Preincrementing non-variable");
+       if (stack->v_addr->v_type == V_NUM) {
+               np = &stack->v_addr->v_num;
+               q = qinc(*np);
+               qfree(*np);
+               *np = q;
+               stack->v_type = V_NUM;
+               stack->v_num = qlink(q);
+               return;
+       }
+       vp = stack->v_addr;
+       incvalue(vp, &tmp);
+       freevalue(vp);
+       *vp = tmp;
+       copyvalue(&tmp, stack);
+}
+
+
+static void
+o_predec()
+{
+       NUMBER *q, **np;
+       VALUE *vp, tmp;
+
+       if (stack->v_type != V_ADDR)
+               math_error("Predecrementing non-variable");
+       if (stack->v_addr->v_type == V_NUM) {
+               np = &stack->v_addr->v_num;
+               q = qdec(*np);
+               qfree(*np);
+               *np = q;
+               stack->v_type = V_NUM;
+               stack->v_num = qlink(q);
+               return;
+       }
+       vp = stack->v_addr;
+       decvalue(vp, &tmp);
+       freevalue(vp);
+       *vp = tmp;
+       copyvalue(&tmp, stack);
+}
+
+
+static void
+o_postinc()
+{
+       NUMBER *q, **np;
+       VALUE *vp, tmp;
+
+       if (stack->v_type != V_ADDR)
+               math_error("Postincrementing non-variable");
+       if (stack->v_addr->v_type == V_NUM) {
+               np = &stack->v_addr->v_num;
+               q = *np;
+               *np = qinc(q);
+               stack->v_type = V_NUM;
+               stack->v_num = q;
+               return;
+       }
+       vp = stack->v_addr;
+       tmp = *vp;
+       incvalue(&tmp, vp);
+       *stack = tmp;
+}
+
+
+static void
+o_postdec()
+{
+       NUMBER *q, **np;
+       VALUE *vp, tmp;
+
+       if (stack->v_type != V_ADDR)
+               math_error("Postdecrementing non-variable");
+       if (stack->v_addr->v_type == V_NUM) {
+               np = &stack->v_addr->v_num;
+               q = *np;
+               *np = qdec(q);
+               stack->v_type = V_NUM;
+               stack->v_num = q;
+               return;
+       }
+       vp = stack->v_addr;
+       tmp = *vp;
+       decvalue(&tmp, vp);
+       *stack = tmp;
+}
+
+
+static void
+o_leftshift()
+{
+       VALUE *v1, *v2;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       shiftvalue(v1, v2, FALSE, &tmp);
+       freevalue(stack--);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_rightshift()
+{
+       VALUE *v1, *v2;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       shiftvalue(v1, v2, TRUE, &tmp);
+       freevalue(stack--);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+/*ARGSUSED*/
+static void
+o_debug(fp, line)
+       FUNC *fp;
+       long line;
+{
+       funcline = line;
+       if (abortlevel >= ABORT_STATEMENT)
+               math_error("Calculation aborted at statement boundary");
+}
+
+
+static void
+o_printresult()
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type != V_NULL) {
+               if (tab_ok)
+                   math_chr('\t');
+               printvalue(vp, PRINT_UNAMBIG);
+               math_chr('\n');
+               math_flush();
+       }
+       freevalue(stack--);
+}
+
+
+/*ARGSUSED*/
+static void
+o_print(fp, flags)
+       FUNC *fp;
+       long flags;
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       printvalue(vp, (int) flags);
+       freevalue(stack--);
+       if (traceflags & TRACE_OPCODES)
+               printf("\n");
+       math_flush();
+}
+
+
+static void
+o_printeol()
+{
+       math_chr('\n');
+       math_flush();
+}
+
+
+static void
+o_printspace()
+{
+       math_chr(' ');
+       if (traceflags & TRACE_OPCODES)
+               printf("\n");
+}
+
+
+/*ARGSUSED*/
+static void
+o_printstring(fp, cp)
+       FUNC *fp;
+       char *cp;
+{
+       math_str(cp);
+       if (traceflags & TRACE_OPCODES)
+               printf("\n");
+       math_flush();
+}
+
+
+static void
+o_zero()
+{
+       stack++;
+       stack->v_type = V_NUM;
+       stack->v_num = qlink(&_qzero_);
+}
+
+
+static void
+o_one()
+{
+       stack++;
+       stack->v_type = V_NUM;
+       stack->v_num = qlink(&_qone_);
+}
+
+
+static void
+o_save(fp)
+       FUNC *fp;
+{
+       VALUE *vp;
+
+       vp = stack;
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       freevalue(&fp->f_savedvalue);
+       copyvalue(vp, &fp->f_savedvalue);
+}
+
+
+static void
+o_oldvalue()
+{
+       copyvalue(&oldvalue, ++stack);
+}
+
+
+static void
+o_quit(fp, cp)
+       FUNC *fp;
+       char *cp;
+{
+       if ((fp->f_name[0] == '*') && (fp->f_name[1] == '\0')) {
+               if (cp)
+                       printf("%s\n", cp);
+               hist_term();
+               while (stack > stackarray) {
+                       freevalue(stack--);
+               }
+               freevalue(stackarray);
+               exit(0);
+       }
+       if (cp)
+               math_error("%s", cp);
+       math_error("quit statement executed");
+}
+
+
+static void
+o_getepsilon()
+{
+       stack++;
+       stack->v_type = V_NUM;
+       stack->v_num = qlink(_epsilon_);
+}
+
+
+static void
+o_setepsilon()
+{
+       VALUE *vp;
+       NUMBER *newep;
+
+       vp = &stack[0];
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type != V_NUM)
+               math_error("Non-numeric for epsilon");
+       newep = vp->v_num;
+       stack->v_num = qlink(_epsilon_);
+       setepsilon(newep);
+       qfree(newep);
+}
+
+
+static void
+o_setconfig()
+{
+       int type;
+       VALUE *v1, *v2;
+       VALUE tmp;
+
+       v1 = &stack[-1];
+       v2 = &stack[0];
+       if (v1->v_type == V_ADDR)
+               v1 = v1->v_addr;
+       if (v2->v_type == V_ADDR)
+               v2 = v2->v_addr;
+       if (v1->v_type != V_STR)
+               math_error("Non-string for config");
+       type = configtype(v1->v_str);
+       if (type < 0)
+               math_error("Unknown config name \"%s\"", v1->v_str);
+       getconfig(type, &tmp);
+       setconfig(type, v2);
+       freevalue(stack--);
+       freevalue(stack);
+       *stack = tmp;
+}
+
+
+static void
+o_getconfig()
+{
+       int type;
+       VALUE *vp;
+
+       vp = &stack[0];
+       if (vp->v_type == V_ADDR)
+               vp = vp->v_addr;
+       if (vp->v_type != V_STR)
+               math_error("Non-string for config");
+       type = configtype(vp->v_str);
+       if (type < 0)
+               math_error("Unknown config name \"%s\"", vp->v_str);
+       freevalue(stack);
+       getconfig(type, stack);
+}
+
+
+/*
+ * Set the 'old' value to the last value saved during the calculation.
+ */
+void
+updateoldvalue(fp)
+       FUNC *fp;
+{
+       if (fp->f_savedvalue.v_type == V_NULL)
+               return;
+       freevalue(&oldvalue);
+       oldvalue = fp->f_savedvalue;
+       fp->f_savedvalue.v_type = V_NULL;
+}
+
+
+/*
+ * Routine called on any runtime error, to complain about it (with possible
+ * arguments), and then longjump back to the top level command scanner.
+ */
+#ifdef VARARGS
+# define VA_ALIST fmt, va_alist
+# define VA_DCL char *fmt; va_dcl
+#else
+# if defined(__STDC__) && __STDC__ == 1
+#  define VA_ALIST char *fmt, ...
+#  define VA_DCL
+# else
+#  define VA_ALIST fmt
+#  define VA_DCL char *fmt;
+# endif
+#endif
+/*VARARGS*/
+void
+math_error(VA_ALIST)
+       VA_DCL
+{
+       va_list ap;
+       char buf[MAXERROR+1];
+
+       if (funcname && (*funcname != '*'))
+               fprintf(stderr, "\"%s\": ", funcname);
+       if (funcline && ((funcname && (*funcname != '*')) || !inputisterminal()))
+               fprintf(stderr, "line %ld: ", funcline);
+#ifdef VARARGS
+       va_start(ap);
+#else
+       va_start(ap, fmt);
+#endif
+       vsprintf(buf, fmt, ap);
+       va_end(ap);
+       fprintf(stderr, "%s\n", buf);
+       funcname = NULL;
+       longjmp(jmpbuf, 1);
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/opcodes.h b/usr/src/contrib/calc-2.9.3t6/opcodes.h
new file mode 100644 (file)
index 0000000..103aa1b
--- /dev/null
@@ -0,0 +1,122 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ */
+
+#ifndef        OPCODES_H
+#define        OPCODES_H
+
+
+/*
+ * Opcodes
+ */
+#define OP_NOP         0L      /* no operation */
+#define OP_LOCALADDR   1L      /* load address of local variable */
+#define OP_GLOBALADDR  2L      /* load address of global variable */
+#define OP_PARAMADDR   3L      /* load address of paramater variable */
+#define OP_LOCALVALUE  4L      /* load value of local variable */
+#define OP_GLOBALVALUE 5L      /* load value of global variable */
+#define OP_PARAMVALUE  6L      /* load value of paramater variable */
+#define OP_NUMBER      7L      /* load constant real numeric value */
+#define OP_INDEXADDR   8L      /* load array index address */
+#define        OP_PRINTRESULT  9L      /* print result of top-level expression */
+#define OP_ASSIGN      10L     /* assign value to variable */
+#define OP_ADD         11L     /* add top two values */
+#define OP_SUB         12L     /* subtract top two values */
+#define OP_MUL         13L     /* multiply top two values */
+#define OP_DIV         14L     /* divide top two values */
+#define OP_MOD         15L     /* take mod of top two values */
+#define OP_SAVE                16L     /* save value for later use */
+#define OP_NEGATE      17L     /* negate top value */
+#define OP_INVERT      18L     /* invert top value */
+#define OP_INT         19L     /* take integer part of top value */
+#define OP_FRAC                20L     /* take fraction part of top value */
+#define OP_NUMERATOR   21L     /* take numerator of top value */
+#define OP_DENOMINATOR 22L     /* take denominator of top value */
+#define OP_DUPLICATE   23L     /* duplicate top value on stack */
+#define OP_POP         24L     /* pop top value from stack */
+#define OP_RETURN      25L     /* return value of function */
+#define OP_JUMPEQ      26L     /* jump if top value is zero */
+#define OP_JUMPNE      27L     /* jump if top value is nonzero */
+#define OP_JUMP                28L     /* jump unconditionally */
+#define OP_USERCALL    29L     /* call a user-defined function */
+#define OP_GETVALUE    30L     /* convert address to value */
+#define OP_EQ          31L     /* test top two elements for equality */
+#define OP_NE          32L     /* test top two elements for inequality */
+#define OP_LE          33L     /* test top two elements for <= */
+#define OP_GE          34L     /* test top two elements for >= */
+#define OP_LT          35L     /* test top two elements for < */
+#define OP_GT          36L     /* test top two elements for > */
+#define OP_PREINC      37L     /* add one to variable (++x) */
+#define OP_PREDEC      38L     /* subtract one from variable (--x) */
+#define OP_POSTINC     39L     /* add one to variable (x++) */
+#define OP_POSTDEC     40L     /* subtract one from variable (x--) */
+#define OP_DEBUG       41L     /* debugging point */
+#define OP_PRINT       42L     /* print value */
+#define OP_ASSIGNPOP   43L     /* assign to variable and remove it */
+#define OP_ZERO                44L     /* put zero on the stack */
+#define OP_ONE         45L     /* put one on the stack */
+#define OP_PRINTEOL    46L     /* print end of line */
+#define OP_PRINTSPACE  47L     /* print a space */
+#define OP_PRINTSTRING 48L     /* print constant string */
+#define OP_DUPVALUE    49L     /* duplicate value of top value */
+#define OP_OLDVALUE    50L     /* old calculation value */
+#define OP_QUO         51L     /* integer quotient of top two values */
+#define OP_POWER       52L     /* number raised to a power */
+#define OP_QUIT                53L     /* quit program */
+#define OP_CALL                54L     /* call built-in routine */
+#define OP_GETEPSILON  55L     /* get allowed error for calculations */
+#define OP_AND         56L     /* arithmetic and */
+#define OP_OR          57L     /* arithmetic or */
+#define OP_NOT         58L     /* logical not */
+#define OP_ABS         59L     /* absolute value */
+#define OP_SGN         60L     /* sign of number */
+#define OP_ISINT       61L     /* whether top value is integer */
+#define OP_CONDORJUMP  62L     /* conditional or jump */
+#define OP_CONDANDJUMP 63L     /* conditional and jump */
+#define OP_SQUARE      64L     /* square top value */
+#define OP_STRING      65L     /* load constant string value */
+#define OP_ISNUM       66L     /* whether top value is a number */
+#define OP_UNDEF       67L     /* load undefined value on stack */
+#define OP_ISNULL      68L     /* whether variable is the null value */
+#define OP_ARGVALUE    69L     /* load value of argument (parameter) n */
+#define OP_MATCREATE   70L     /* create matrix */
+#define OP_ISMAT       71L     /* whether variable is a matrix */
+#define OP_ISSTR       72L     /* whether variable is a string */
+#define OP_GETCONFIG   73L     /* get value of configuration parameter */
+#define OP_LEFTSHIFT   74L     /* left shift of integer */
+#define OP_RIGHTSHIFT  75L     /* right shift of integer */
+#define OP_CASEJUMP    76L     /* test case and jump if not matched */
+#define OP_ISODD       77L     /* whether value is an odd integer */
+#define OP_ISEVEN      78L     /* whether value is even integer */
+#define OP_FIADDR      79L     /* 'fast index' matrix value address */
+#define OP_FIVALUE     80L     /* 'fast index' matrix value */
+#define OP_ISREAL      81L     /* test value for real number */
+#define OP_IMAGINARY   82L     /* load imaginary numeric constant */
+#define OP_RE          83L     /* real part of complex number */
+#define OP_IM          84L     /* imaginary part of complex number */
+#define OP_CONJUGATE   85L     /* complex conjugate of complex number */
+#define OP_OBJCREATE   86L     /* create object */
+#define OP_ISOBJ       87L     /* whether value is an object */
+#define OP_NORM                88L     /* norm of value (square of abs) */
+#define OP_ELEMADDR    89L     /* address of element of object */
+#define OP_ELEMVALUE   90L     /* value of element of object */
+#define OP_ISTYPE      91L     /* whether two values are the same type */
+#define OP_SCALE       92L     /* scale value by a power of two */
+#define        OP_ISLIST       93L     /* whether value is a list */
+#define        OP_SWAP         94L     /* swap values of two variables */
+#define        OP_ISSIMPLE     95L     /* whether value is a simple type */
+#define        OP_CMP          96L     /* compare values returning -1, 0, or 1 */
+#define        OP_QUOMOD       97L     /* calculate quotient and remainder */
+#define        OP_SETCONFIG    98L     /* set configuration parameter */
+#define        OP_SETEPSILON   99L     /* set allowed error for calculations */
+#define        OP_ISFILE       100L    /* whether value is a file */
+#define        OP_ISASSOC      101L    /* whether value is an association */
+#define        OP_INITSTATIC   102L    /* once only code for static initialization */
+#define        OP_ELEMINIT     103L    /* assign element of matrix or object */
+#define MAX_OPCODE     103L    /* highest legal opcode */
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/qfunc.c b/usr/src/contrib/calc-2.9.3t6/qfunc.c
new file mode 100644 (file)
index 0000000..70c9ead
--- /dev/null
@@ -0,0 +1,1215 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Extended precision rational arithmetic non-primitive functions
+ */
+
+#include "qmath.h"
+
+
+NUMBER *_epsilon_;     /* default precision for real functions */
+long _epsilonprec_;    /* bits of precision for epsilon */
+
+
+/*
+ * Set the default precision for real calculations.
+ * The precision must be between zero and one.
+ */
+void
+setepsilon(q)
+       NUMBER *q;              /* number to be set as the new epsilon */
+{
+       NUMBER *old;
+
+       if (qisneg(q) || qiszero(q) || (qreli(q, 1L) >= 0))
+               math_error("Epsilon value must be between zero and one");
+       old = _epsilon_;
+       _epsilonprec_ = qprecision(q);
+       _epsilon_ = qlink(q);
+       if (old)
+               qfree(old);
+}
+
+
+/*
+ * Return the inverse of one number modulo another.
+ * That is, find x such that:
+ *     Ax = 1 (mod B)
+ * Returns zero if the numbers are not relatively prime (temporary hack).
+ */
+NUMBER *
+qminv(q1, q2)
+       NUMBER *q1, *q2;
+{
+       NUMBER *r;
+
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for minv");
+       r = qalloc();
+       if (zmodinv(q1->num, q2->num, &r->num)) {
+               qfree(r);
+               return qlink(&_qzero_);
+       }
+       return r;
+}
+
+
+/*
+ * Return the residue modulo an integer (q3) of an integer (q1) 
+ * raised to a positive integer (q2) power.  
+ */
+NUMBER *
+qpowermod(q1, q2, q3)
+       NUMBER *q1, *q2, *q3;
+{
+       NUMBER *r, *t;
+       BOOL s;
+
+       if (qisfrac(q1) || qisfrac(q2) || qisfrac(q3)) 
+               math_error("Non-integers for pmod");
+       if (qisneg(q2))
+               math_error("Negative power for pmod");
+       if (qiszero(q3)) return qpowi(q1, q2);
+       s = q3->num.sign;
+       q3->num.sign = 0;
+       r = qalloc();
+       zpowermod(q1->num, q2->num, q3->num, &r->num);
+       if (!s || qiszero(r)) return r;
+       q3->num.sign = 1;
+       t = qadd(r, q3);
+       qfree(r);
+       return t;
+}
+
+
+/*
+ * Return the power function of one number with another.
+ * The power must be integral.
+ *     q3 = qpowi(q1, q2);
+ */
+NUMBER *
+qpowi(q1, q2)
+       NUMBER *q1, *q2;
+{
+       register NUMBER *r;
+       BOOL invert, sign;
+       ZVALUE num, den, z2;
+
+       if (qisfrac(q2))
+               math_error("Raising number to fractional power");
+       num = q1->num;
+       den = q1->den;
+       z2 = q2->num;
+       sign = (num.sign && zisodd(z2));
+       invert = z2.sign;
+       num.sign = 0;
+       z2.sign = 0;
+       /*
+       * Check for trivial cases first.
+       */
+       if (ziszero(num) && !ziszero(z2)) {     /* zero raised to a power */
+               if (invert)
+                       math_error("Zero raised to negative power");
+               return qlink(&_qzero_);
+       }
+       if (zisunit(num) && zisunit(den)) {     /* 1 or -1 raised to a power */
+               r = (sign ? q1 : &_qone_);
+               r->links++;
+               return r;
+       }
+       if (ziszero(z2))        /* raising to zeroth power */
+               return qlink(&_qone_);
+       if (zisunit(z2)) {      /* raising to power 1 or -1 */
+               if (invert)
+                       return qinv(q1);
+               return qlink(q1);
+       }
+       /*
+        * Not a trivial case.  Do the real work.
+        */
+       r = qalloc();
+       if (!zisunit(num))
+               zpowi(num, z2, &r->num);
+       if (!zisunit(den))
+               zpowi(den, z2, &r->den);
+       if (invert) {
+               z2 = r->num;
+               r->num = r->den;
+               r->den = z2;
+       }
+       r->num.sign = sign;
+       return r;
+}
+
+
+/*
+ * Given the legs of a right triangle, compute its hypothenuse within
+ * the specified error.  This is sqrt(a^2 + b^2).
+ */
+NUMBER *
+qhypot(q1, q2, epsilon)
+       NUMBER *q1, *q2, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *tmp3;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Bad epsilon value for hypot");
+       if (qiszero(q1))
+               return qabs(q2);
+       if (qiszero(q2))
+               return qabs(q1);
+       tmp1 = qsquare(q1);
+       tmp2 = qsquare(q2);
+       tmp3 = qadd(tmp1, tmp2);
+       qfree(tmp1);
+       qfree(tmp2);
+       tmp1 = qsqrt(tmp3, epsilon);
+       qfree(tmp3);
+       return tmp1;
+}
+
+
+/*
+ * Given one leg of a right triangle with unit hypothenuse, calculate
+ * the other leg within the specified error.  This is sqrt(1 - a^2).
+ * If the wantneg flag is nonzero, then negative square root is returned.
+ */
+NUMBER *
+qlegtoleg(q, epsilon, wantneg)
+       NUMBER *q, *epsilon;
+       BOOL wantneg;
+{
+       NUMBER *res, *qtmp1, *qtmp2;
+       ZVALUE num;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Bad epsilon value for legtoleg");
+       if (qisunit(q))
+               return qlink(&_qzero_);
+       if (qiszero(q)) {
+               if (wantneg)
+                       return qlink(&_qnegone_);
+               return qlink(&_qone_);
+       }
+       num = q->num;
+       num.sign = 0;
+       if (zrel(num, q->den) >= 0)
+               math_error("Leg too large in legtoleg");
+       qtmp1 = qsquare(q);
+       qtmp2 = qsub(&_qone_, qtmp1);
+       qfree(qtmp1);
+       res = qsqrt(qtmp2, epsilon);
+       qfree(qtmp2);
+       if (wantneg) {
+               qtmp1 = qneg(res);
+               qfree(res);
+               res = qtmp1;
+       }
+       return res;
+}
+
+/*
+ * Compute the square root of a number to within the specified error.
+ * If the number is an exact square, the exact result is returned.
+ *     q3 = qsqrt(q1, q2);
+ */
+NUMBER *
+qsqrt(q1, epsilon)
+       register NUMBER *q1, *epsilon;
+{
+       long bits, bits2;       /* number of bits of precision */
+       int exact;
+       NUMBER *r;
+       ZVALUE t1, t2;
+
+       if (qisneg(q1))
+               math_error("Square root of negative number");
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Bad epsilon value for sqrt");
+       if (qiszero(q1))
+               return qlink(&_qzero_);
+       if (qisunit(q1))
+               return qlink(&_qone_);
+       if (qiszero(epsilon) && qisint(q1) && zistiny(q1->num) && (*q1->num.v <= 3))
+               return qlink(&_qone_);
+       bits = zhighbit(epsilon->den) - zhighbit(epsilon->num) + 1;
+       if (bits < 0)
+               bits = 0;
+       bits2 = zhighbit(q1->num) - zhighbit(q1->den) + 1;
+       if (bits2 > 0)
+               bits += bits2;
+       r = qalloc();
+       zshift(q1->num, bits * 2, &t2);
+       zmul(q1->den, t2, &t1);
+       zfree(t2);
+       exact = zsqrt(t1, &t2);
+       zfree(t1);
+       if (exact) {
+               zshift(q1->den, bits, &t1);
+               zreduce(t2, t1, &r->num, &r->den);
+       } else {
+               zquo(t2, q1->den, &t1);
+               zfree(t2);
+               zbitvalue(bits, &t2);
+               zreduce(t1, t2, &r->num, &r->den);
+       }
+       zfree(t1);
+       zfree(t2);
+       if (qiszero(r)) {
+               qfree(r);
+               r = qlink(&_qzero_);
+       }
+       return r;
+}
+
+
+/*
+ * Calculate the integral part of the square root of a number.
+ * Example:  qisqrt(13) = 3.
+ */
+NUMBER *
+qisqrt(q)
+       NUMBER *q;
+{
+       NUMBER *r;
+       ZVALUE tmp;
+
+       if (qisneg(q))
+               math_error("Square root of negative number");
+       if (qiszero(q))
+               return qlink(&_qzero_);
+       if (qisint(q) && zistiny(q->num) && (z1tol(q->num) < 4))
+               return qlink(&_qone_);
+       r = qalloc();
+       if (qisint(q)) {
+               (void) zsqrt(q->num, &r->num);
+               return r;
+       }
+       zquo(q->num, q->den, &tmp);
+       (void) zsqrt(tmp, &r->num);
+       zfree(tmp);
+       return r;
+}
+
+
+/*
+ * Return whether or not a number is an exact square.
+ */
+BOOL
+qissquare(q)
+       NUMBER *q;
+{
+       BOOL flag;
+
+       flag = zissquare(q->num);
+       if (qisint(q) || !flag)
+               return flag;
+       return zissquare(q->den);
+}
+
+
+/*
+ * Compute the greatest integer of the Kth root of a number.
+ * Example:  qiroot(85, 3) = 4.
+ */
+NUMBER *
+qiroot(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       NUMBER *r;
+       ZVALUE tmp;
+
+       if (qisneg(q2) || qiszero(q2) || qisfrac(q2))
+               math_error("Taking number to bad root value");
+       if (qiszero(q1))
+               return qlink(&_qzero_);
+       if (qisone(q1) || qisone(q2))
+               return qlink(q1);
+       if (qistwo(q2))
+               return qisqrt(q1);
+       r = qalloc();
+       if (qisint(q1)) {
+               zroot(q1->num, q2->num, &r->num);
+               return r;
+       }
+       zquo(q1->num, q1->den, &tmp);
+       zroot(tmp, q2->num, &r->num);
+       zfree(tmp);
+       return r;
+}
+
+
+/*
+ * Return the greatest integer of the base 2 log of a number.
+ * This is the number such that  1 <= x / log2(x) < 2.
+ * Examples:  qilog2(8) = 3, qilog2(1.3) = 1, qilog2(1/7) = -3.
+ */
+long
+qilog2(q)
+       NUMBER *q;              /* number to take log of */
+{
+       long n;                 /* power of two */
+       int c;                  /* result of comparison */
+       ZVALUE tmp;             /* temporary value */
+
+       if (qisneg(q) || qiszero(q))
+               math_error("Non-positive number for log2");
+       if (qisint(q))
+               return zhighbit(q->num);
+       n = zhighbit(q->num) - zhighbit(q->den);
+       if (n == 0)
+               c = zrel(q->num, q->den);
+       else if (n > 0) {
+               zshift(q->den, n, &tmp);
+               c = zrel(q->num, tmp);
+       } else {
+               zshift(q->num, n, &tmp);
+               c = zrel(tmp, q->den);
+       }
+       if (n)
+               zfree(tmp);
+       if (c < 0)
+               n--;
+       return n;
+}
+
+
+/*
+ * Return the greatest integer of the base 10 log of a number.
+ * This is the number such that  1 <= x / log10(x) < 10.
+ * Examples:  qilog10(100) = 2, qilog10(12.3) = 1, qilog10(.023) = -2.
+ */
+long
+qilog10(q)
+       NUMBER *q;              /* number to take log of */
+{
+       long n;                 /* log value */
+       ZVALUE temp;            /* temporary value */
+
+       if (qisneg(q) || qiszero(q))
+               math_error("Non-positive number for log10");
+       if (qisint(q))
+               return zlog10(q->num);
+       /*
+        * The number is not an integer.
+        * Compute the result if the number is greater than one.
+        */
+       if ((q->num.len > q->den.len) ||
+               ((q->num.len == q->den.len) && (zrel(q->num, q->den) > 0))) {
+                       zquo(q->num, q->den, &temp);
+                       n = zlog10(temp);
+                       zfree(temp);
+                       return n;
+       }
+       /*
+        * Here if the number is less than one.
+        * If the number is the inverse of a power of ten, then the obvious answer
+        * will be off by one.  Subtracting one if the number is the inverse of an
+        * integer will fix it.
+        */
+       if (zisunit(q->num))
+               zsub(q->den, _one_, &temp);
+       else
+               zquo(q->den, q->num, &temp);
+       n = -zlog10(temp) - 1;
+       zfree(temp);
+       return n;
+}
+
+
+/*
+ * Return the number of digits in a number, ignoring the sign.
+ * For fractions, this is the number of digits of its greatest integer.
+ * Examples: qdigits(3456) = 4, qdigits(-23.45) = 2, qdigits(.0120) = 1.
+ */
+long
+qdigits(q)
+       NUMBER *q;              /* number to count digits of */
+{
+       long n;                 /* number of digits */
+       ZVALUE temp;            /* temporary value */
+
+       if (qisint(q))
+               return zdigits(q->num);
+       zquo(q->num, q->den, &temp);
+       n = zdigits(temp);
+       zfree(temp);
+       return n;
+}
+
+
+/*
+ * Return the digit at the specified decimal place of a number represented
+ * in floating point.  The lowest digit of the integral part of a number
+ * is the zeroth decimal place.  Negative decimal places indicate digits
+ * to the right of the decimal point.  Examples: qdigit(1234.5678, 1) = 3,
+ * qdigit(1234.5678, -3) = 7.
+ */
+FLAG
+qdigit(q, n)
+       NUMBER *q;
+       long n;
+{
+       ZVALUE tenpow, tmp1, tmp2;
+       FLAG res;
+
+       /*
+        * Zero number or negative decimal place of integer is trivial.
+        */
+       if (qiszero(q) || (qisint(q) && (n < 0)))
+               return 0;
+       /*
+        * For non-negative decimal places, answer is easy.
+        */
+       if (n >= 0) {
+               if (qisint(q))
+                       return zdigit(q->num, n);
+               zquo(q->num, q->den, &tmp1);
+               res = zdigit(tmp1, n);
+               zfree(tmp1);
+               return res;
+       }
+       /*
+        * Fractional value and want negative digit, must work harder.
+        */
+       ztenpow(-n, &tenpow);
+       zmul(q->num, tenpow, &tmp1);
+       zfree(tenpow);
+       zquo(tmp1, q->den, &tmp2);
+       res = zmodi(tmp2, 10L);
+       zfree(tmp1);
+       zfree(tmp2);
+       return res;
+}
+
+
+/*
+ * Return whether or not a bit is set at the specified bit position in a
+ * number.  The lowest bit of the integral part of a number is the zeroth
+ * bit position.  Negative bit positions indicate bits to the right of the
+ * binary decimal point.  Examples: qdigit(17.1, 0) = 1, qdigit(17.1, -1) = 0.
+ */
+BOOL
+qisset(q, n)
+       NUMBER *q;
+       long n;
+{
+       NUMBER *qtmp1, *qtmp2;
+       ZVALUE ztmp;
+       BOOL res;
+
+       /*
+        * Zero number or negative bit position place of integer is trivial.
+        */
+       if (qiszero(q) || (qisint(q) && (n < 0)))
+               return FALSE;
+       /*
+        * For non-negative bit positions, answer is easy.
+        */
+       if (n >= 0) {
+               if (qisint(q))
+                       return zisset(q->num, n);
+               zquo(q->num, q->den, &ztmp);
+               res = zisset(ztmp, n);
+               zfree(ztmp);
+               return res;
+       }
+       /*
+        * Fractional value and want negative bit position, must work harder.
+        */
+       qtmp1 = qscale(q, -n);
+       qtmp2 = qint(qtmp1);
+       qfree(qtmp1);
+       res = ((qtmp2->num.v[0] & 0x01) != 0);
+       qfree(qtmp2);
+       return res;
+}
+
+
+/*
+ * Compute the factorial of an integer.
+ *     q2 = qfact(q1);
+ */
+NUMBER *
+qfact(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       if (qisfrac(q))
+               math_error("Non-integral factorial");
+       if (qiszero(q) || zisone(q->num))
+               return qlink(&_qone_);
+       r = qalloc();
+       zfact(q->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Compute the product of the primes less than or equal to a number.
+ *     q2 = qpfact(q1);
+ */
+NUMBER *
+qpfact(q)
+       register NUMBER *q;
+{
+       NUMBER *r;
+
+       if (qisfrac(q))
+               math_error("Non-integral factorial");
+       r = qalloc();
+       zpfact(q->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Compute the lcm of all the numbers less than or equal to a number.
+ *     q2 = qlcmfact(q1);
+ */
+NUMBER *
+qlcmfact(q)
+       register NUMBER *q;
+{
+       NUMBER *r;
+
+       if (qisfrac(q))
+               math_error("Non-integral lcmfact");
+       r = qalloc();
+       zlcmfact(q->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Compute the permutation function  M! / (M - N)!.
+ */
+NUMBER *
+qperm(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       register NUMBER *r;
+
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integral arguments for permutation");
+       r = qalloc();
+       zperm(q1->num, q2->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Compute the combinatorial function  M! / (N! * (M - N)!).
+ */
+NUMBER *
+qcomb(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       register NUMBER *r;
+
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integral arguments for combinatorial");
+       r = qalloc();
+       zcomb(q1->num, q2->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Compute the Jacobi function (a / b).
+ * -1 => a is not quadratic residue mod b
+ * 1 => b is composite, or a is quad residue of b
+ * 0 => b is even or b < 0
+ */
+NUMBER *
+qjacobi(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integral arguments for jacobi");
+       return itoq((long) zjacobi(q1->num, q2->num));
+}
+
+
+/*
+ * Compute the Fibonacci number F(n).
+ */
+NUMBER *
+qfib(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       if (qisfrac(q))
+               math_error("Non-integral Fibonacci number");
+       r = qalloc();
+       zfib(q->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Truncate a number to the specified number of decimal places.
+ * Specifying zero places makes the result identical to qint.
+ * Example: qtrunc(2/3, 3) = .666
+ */
+NUMBER *
+qtrunc(q1, q2)
+       NUMBER *q1, *q2;
+{
+       long places;
+       NUMBER *r;
+       ZVALUE tenpow, tmp1, tmp2;
+
+       if (qisfrac(q2) || qisneg(q2) || !zistiny(q2->num))
+               math_error("Bad number of places for qtrunc");
+       if (qisint(q1))
+               return qlink(q1);
+       r = qalloc();
+       places = z1tol(q2->num);
+       /*
+        * Ok, produce the result.
+        * First see if we want no places, in which case just take integer part.
+        */
+       if (places == 0) {
+               zquo(q1->num, q1->den, &r->num);
+               return r;
+       }
+       ztenpow(places, &tenpow);
+       zmul(q1->num, tenpow, &tmp1);
+       zquo(tmp1, q1->den, &tmp2);
+       zfree(tmp1);
+       if (ziszero(tmp2)) {
+               zfree(tmp2);
+               return qlink(&_qzero_);
+       }
+       /*
+        * Now reduce the result to the lowest common denominator.
+        */
+       zgcd(tmp2, tenpow, &tmp1);
+       if (zisunit(tmp1)) {
+               zfree(tmp1);
+               r->num = tmp2;
+               r->den = tenpow;
+               return r;
+       }
+       zquo(tmp2, tmp1, &r->num);
+       zquo(tenpow, tmp1, &r->den);
+       zfree(tmp1);
+       zfree(tmp2);
+       zfree(tenpow);
+       return r;
+}
+
+
+/*
+ * Round a number to the specified number of decimal places.
+ * Zero decimal places means round to the nearest integer.
+ * Example: qround(2/3, 3) = .667
+ */
+NUMBER *
+qround(q, places)
+       NUMBER *q;              /* number to be rounded */
+       long places;            /* number of decimal places to round to */
+{
+       NUMBER *r;
+       ZVALUE tenpow, roundval, tmp1, tmp2;
+
+       if (places < 0)
+               math_error("Negative places for qround");
+       if (qisint(q))
+               return qlink(q);
+       /*
+        * Calculate one half of the denominator, ignoring fractional results.
+        * This is the value we will add in order to cause rounding.
+        */
+       zshift(q->den, -1L, &roundval);
+       roundval.sign = q->num.sign;
+       /*
+        * Ok, now do the actual work to produce the result.
+        */
+       r = qalloc();
+       ztenpow(places, &tenpow);
+       zmul(q->num, tenpow, &tmp2);
+       zadd(tmp2, roundval, &tmp1);
+       zfree(tmp2);
+       zfree(roundval);
+       zquo(tmp1, q->den, &tmp2);
+       zfree(tmp1);
+       if (ziszero(tmp2)) {
+               zfree(tmp2);
+               return qlink(&_qzero_);
+       }
+       /*
+        * Now reduce the result to the lowest common denominator.
+        */
+       zgcd(tmp2, tenpow, &tmp1);
+       if (zisunit(tmp1)) {
+               zfree(tmp1);
+               r->num = tmp2;
+               r->den = tenpow;
+               return r;
+       }
+       zquo(tmp2, tmp1, &r->num);
+       zquo(tenpow, tmp1, &r->den);
+       zfree(tmp1);
+       zfree(tmp2);
+       zfree(tenpow);
+       return r;
+}
+
+
+/*
+ * Truncate a number to the specified number of binary places.
+ * Specifying zero places makes the result identical to qint.
+ */
+NUMBER *
+qbtrunc(q1, q2)
+       NUMBER *q1, *q2;
+{
+       long places, twopow;
+       NUMBER *r;
+       ZVALUE tmp1, tmp2;
+
+       if (qisfrac(q2) || qisneg(q2) || !zistiny(q2->num))
+               math_error("Bad number of places for qtrunc");
+       if (qisint(q1))
+               return qlink(q1);
+       r = qalloc();
+       places = z1tol(q2->num);
+       /*
+        * Ok, produce the result.
+        * First see if we want no places, in which case just take integer part.
+        */
+       if (places == 0) {
+               zquo(q1->num, q1->den, &r->num);
+               return r;
+       }
+       zshift(q1->num, places, &tmp1);
+       zquo(tmp1, q1->den, &tmp2);
+       zfree(tmp1);
+       if (ziszero(tmp2)) {
+               zfree(tmp2);
+               return qlink(&_qzero_);
+       }
+       /*
+        * Now reduce the result to the lowest common denominator.
+        */
+       if (zisodd(tmp2)) {
+               r->num = tmp2;
+               zbitvalue(places, &r->den);
+               return r;
+       }
+       twopow = zlowbit(tmp2);
+       if (twopow > places)
+               twopow = places;
+       places -= twopow;
+       zshift(tmp2, -twopow, &r->num);
+       zfree(tmp2);
+       zbitvalue(places, &r->den);
+       return r;
+}
+
+
+/*
+ * Round a number to the specified number of binary places.
+ * Zero binary places means round to the nearest integer.
+ */
+NUMBER *
+qbround(q, places)
+       NUMBER *q;              /* number to be rounded */
+       long places;            /* number of binary places to round to */
+{
+       long twopow;
+       NUMBER *r;
+       ZVALUE roundval, tmp1, tmp2;
+
+       if (places < 0)
+               math_error("Negative places for qbround");
+       if (qisint(q))
+               return qlink(q);
+       r = qalloc();
+       /*
+        * Calculate one half of the denominator, ignoring fractional results.
+        * This is the value we will add in order to cause rounding.
+        */
+       zshift(q->den, -1L, &roundval);
+       roundval.sign = q->num.sign;
+       /*
+        * Ok, produce the result.
+        */
+       zshift(q->num, places, &tmp1);
+       zadd(tmp1, roundval, &tmp2);
+       zfree(roundval);
+       zfree(tmp1);
+       zquo(tmp2, q->den, &tmp1);
+       zfree(tmp2);
+       if (ziszero(tmp1)) {
+               zfree(tmp1);
+               return qlink(&_qzero_);
+       }
+       /*
+        * Now reduce the result to the lowest common denominator.
+        */
+       if (zisodd(tmp1)) {
+               r->num = tmp1;
+               zbitvalue(places, &r->den);
+               return r;
+       }
+       twopow = zlowbit(tmp1);
+       if (twopow > places)
+               twopow = places;
+       places -= twopow;
+       zshift(tmp1, -twopow, &r->num);
+       zfree(tmp1);
+       zbitvalue(places, &r->den);
+       return r;
+}
+
+
+/*
+ * Approximate a number by using binary rounding with the minimum number
+ * of binary places so that the resulting number is within the specified
+ * epsilon of the original number.
+ */
+NUMBER *
+qbappr(q, e)
+       NUMBER *q, *e;
+{
+       long bits;
+
+       if (qisneg(e) || qiszero(e))
+               math_error("Bad epsilon value for qbappr");
+       if (e == _epsilon_)
+               bits = _epsilonprec_ + 1;
+       else
+               bits = qprecision(e) + 1;
+       return qbround(q, bits);
+}
+
+
+/*
+ * Approximate a number using continued fractions until the approximation
+ * error is less than the specified value.  If a NULL pointer is given
+ * for the error value, then the closest simpler fraction is returned.
+ */
+NUMBER *
+qcfappr(q, e)
+       NUMBER *q, *e;
+{
+       NUMBER qtest, *qtmp;
+       ZVALUE u1, u2, u3, v1, v2, v3, t1, t2, t3, qq, tt;
+       int i;
+       BOOL haveeps;
+
+       haveeps = TRUE;
+       if (e == NULL) {
+               haveeps = FALSE;
+               e = &_qzero_;
+       }
+       if (qisneg(e))
+               math_error("Negative epsilon for cfappr");
+       if (qisint(q) || zisunit(q->num) || (haveeps && qiszero(e)))
+               return qlink(q);
+       u1 = _one_;
+       u2 = _zero_;
+       u3 = q->num;
+       u3.sign = 0;
+       v1 = _zero_;
+       v2 = _one_;
+       v3 = q->den;
+       while (!ziszero(v3)) {
+               if (!ziszero(u2) && !ziszero(u1)) {
+                       qtest.num = u2;
+                       qtest.den = u1;
+                       qtest.den.sign = 0;
+                       qtest.num.sign = q->num.sign;
+                       qtmp = qsub(q, &qtest);
+                       qtest = *qtmp;
+                       qtest.num.sign = 0;
+                       i = qrel(&qtest, e);
+                       qfree(qtmp);
+                       if (i <= 0)
+                               break;
+               }
+               zquo(u3, v3, &qq);
+               zmul(qq, v1, &tt); zsub(u1, tt, &t1); zfree(tt);
+               zmul(qq, v2, &tt); zsub(u2, tt, &t2); zfree(tt);
+               zmul(qq, v3, &tt); zsub(u3, tt, &t3); zfree(tt);
+               zfree(qq); zfree(u1); zfree(u2);
+               if ((u3.v != q->num.v) && (u3.v != q->den.v))
+                       zfree(u3);
+               u1 = v1; u2 = v2; u3 = v3;
+               v1 = t1; v2 = t2; v3 = t3;
+       }
+       if (u3.v != q->den.v)
+               zfree(u3);
+       zfree(v1);
+       zfree(v2);
+       i = ziszero(v3);
+       zfree(v3);
+       if (i && haveeps) {
+               zfree(u1);
+               zfree(u2);
+               return qlink(q);
+       }
+       qtest.num = u2;
+       qtest.den = u1;
+       qtest.den.sign = 0;
+       qtest.num.sign = q->num.sign;
+       qtmp = qcopy(&qtest);
+       zfree(u1);
+       zfree(u2);
+       return qtmp;
+}
+
+
+/*
+ * Return an indication on whether or not two fractions are approximately
+ * equal within the specified epsilon. Returns negative if the absolute value
+ * of the difference between the two numbers is less than epsilon, zero if
+ * the difference is equal to epsilon, and positive if the difference is
+ * greater than epsilon.
+ */
+FLAG
+qnear(q1, q2, epsilon)
+       NUMBER *q1, *q2, *epsilon;
+{
+       int res;
+       NUMBER qtemp, *qq;
+
+       if (qisneg(epsilon))
+               math_error("Negative epsilon for near");
+       if (q1 == q2) {
+               if (qiszero(epsilon))
+                       return 0;
+               return -1;
+       }
+       if (qiszero(epsilon))
+               return qcmp(q1, q2);
+       if (qiszero(q2)) {
+               qtemp = *q1;
+               qtemp.num.sign = 0;
+               return qrel(&qtemp, epsilon);
+       }
+       if (qiszero(q1)) {
+               qtemp = *q2;
+               qtemp.num.sign = 0;
+               return qrel(&qtemp, epsilon);
+       }
+       qq = qsub(q1, q2);
+       qtemp = *qq;
+       qtemp.num.sign = 0;
+       res = qrel(&qtemp, epsilon);
+       qfree(qq);
+       return res;
+}
+
+
+/*
+ * Compute the gcd (greatest common divisor) of two numbers.
+ *     q3 = qgcd(q1, q2);
+ */
+NUMBER *
+qgcd(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       ZVALUE z;
+       NUMBER *q;
+
+       if (q1 == q2)
+               return qabs(q1);
+       if (qisfrac(q1) || qisfrac(q2)) {
+               q = qalloc();
+               zgcd(q1->num, q2->num, &q->num);
+               zlcm(q1->den, q2->den, &q->den);
+               return q;
+       }
+       if (qiszero(q1))
+               return qabs(q2);
+       if (qiszero(q2))
+               return qabs(q1);
+       if (qisunit(q1) || qisunit(q2))
+               return qlink(&_qone_);
+       zgcd(q1->num, q2->num, &z);
+       if (zisunit(z)) {
+               zfree(z);
+               return qlink(&_qone_);
+       }
+       q = qalloc();
+       q->num = z;
+       return q;
+}
+
+
+/*
+ * Compute the lcm (least common multiple) of two numbers.
+ *     q3 = qlcm(q1, q2);
+ */
+NUMBER *
+qlcm(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       NUMBER *q;
+
+       if (qiszero(q1) || qiszero(q2))
+               return qlink(&_qzero_);
+       if (q1 == q2)
+               return qabs(q1);
+       if (qisunit(q1))
+               return qabs(q2);
+       if (qisunit(q2))
+               return qabs(q1);
+       q = qalloc();
+       zlcm(q1->num, q2->num, &q->num);
+       if (qisfrac(q1) || qisfrac(q2))
+               zgcd(q1->den, q2->den, &q->den);
+       return q;
+}
+
+
+/*
+ * Remove all occurances of the specified factor from a number.
+ * Returned number is always positive.
+ */
+NUMBER *
+qfacrem(q1, q2)
+       NUMBER *q1, *q2;
+{
+       long count;
+       ZVALUE tmp;
+       NUMBER *r;
+
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for factor removal");
+       count = zfacrem(q1->num, q2->num, &tmp);
+       if (zisunit(tmp)) {
+               zfree(tmp);
+               return qlink(&_qone_);
+       }
+       if (count == 0) {
+               zfree(tmp);
+               return qlink(q1);
+       }
+       r = qalloc();
+       r->num = tmp;
+       return r;
+}
+
+
+/*
+ * Divide one number by the gcd of it with another number repeatedly until
+ * the number is relatively prime.
+ */
+NUMBER *
+qgcdrem(q1, q2)
+       NUMBER *q1, *q2;
+{
+       ZVALUE tmp;
+       NUMBER *r;
+
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for gcdrem");
+       zgcdrem(q1->num, q2->num, &tmp);
+       if (zisunit(tmp)) {
+               zfree(tmp);
+               return qlink(&_qone_);
+       }
+       if (zcmp(q1->num, tmp) == 0) {
+               zfree(tmp);
+               return qlink(q1);
+       }
+       r = qalloc();
+       r->num = tmp;
+       return r;
+}
+
+
+/*
+ * Return the lowest prime factor of a number.
+ * Search is conducted for the specified number of primes.
+ * Returns one if no factor was found.
+ */
+NUMBER *
+qlowfactor(q1, q2)
+       NUMBER *q1, *q2;
+{
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for lowfactor");
+       return itoq(zlowfactor(q1->num, ztoi(q2->num)));
+}
+
+
+/*
+ * Return the number of places after the decimal point needed to exactly
+ * represent the specified number as a real number.  Integers return zero,
+ * and non-terminating decimals return minus one.  Examples:
+ *     qplaces(1/7)=-1, qplaces(3/10)= 1, qplaces(1/8)=3, qplaces(4)=0.
+ */
+long
+qplaces(q)
+       NUMBER *q;
+{
+       long twopow, fivepow;
+       HALF fiveval[2];
+       ZVALUE five;
+       ZVALUE tmp;
+
+       if (qisint(q))  /* no decimal places if number is integer */
+               return 0;
+       /*
+        * The number of decimal places of a fraction in lowest terms is finite
+        * if an only if the denominator is of the form 2^A * 5^B, and then the
+        * number of decimal places is equal to MAX(A, B).
+        */
+       five.sign = 0;
+       five.len = 1;
+       five.v = fiveval;
+       fiveval[0] = 5;
+       fivepow = zfacrem(q->den, five, &tmp);
+       if (!zisonebit(tmp)) {
+               zfree(tmp);
+               return -1;
+       }
+       twopow = zlowbit(tmp);
+       zfree(tmp);
+       if (twopow < fivepow)
+               twopow = fivepow;
+       return twopow;
+}
+
+
+/*
+ * Perform a probabilistic primality test (algorithm P in Knuth).
+ * Returns FALSE if definitely not prime, or TRUE if probably prime.
+ * Second arg determines how many times to check for primality.
+ */
+BOOL
+qprimetest(q1, q2)
+       NUMBER *q1, *q2;
+{
+       if (qisfrac(q1) || qisfrac(q2) || qisneg(q2))
+               math_error("Bad arguments for qprimetest");
+       return zprimetest(q1->num, qtoi(q2));
+}
+
+
+/*
+ * Return a trivial hash value for a number.
+ */
+HASH
+qhash(q)
+       NUMBER *q;
+{
+       HASH hash;
+
+       hash = zhash(q->num);
+       if (qisfrac(q))
+               hash += zhash(q->den) * 2000003;
+       return hash;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/qio.c b/usr/src/contrib/calc-2.9.3t6/qio.c
new file mode 100644 (file)
index 0000000..41b720e
--- /dev/null
@@ -0,0 +1,671 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Scanf and printf routines for arbitrary precision rational numbers
+ */
+
+#include "stdarg.h"
+#include "qmath.h"
+
+
+#define        PUTCHAR(ch)             math_chr(ch)
+#define        PUTSTR(str)             math_str(str)
+#define        PRINTF1(fmt, a1)        math_fmt(fmt, a1)
+#define        PRINTF2(fmt, a1, a2)    math_fmt(fmt, a1, a2)
+
+int tilde_ok = TRUE;   /* FALSE => don't print '~' for rounded value */
+
+#if 0
+static long    etoalen;
+static char    *etoabuf = NULL;
+#endif
+
+static long    scalefactor;
+static ZVALUE  scalenumber = { 0, 0, 0 };
+
+
+/*
+ * Print a formatted string containing arbitrary numbers, similar to printf.
+ * ALL numeric arguments to this routine are rational NUMBERs.
+ * Various forms of printing such numbers are supplied, in addition
+ * to strings and characters.  Output can actually be to any FILE
+ * stream or a string.
+ */
+#ifdef VARARGS
+# define VA_ALIST1 fmt, va_alist
+# define VA_DCL1 char *fmt; va_dcl
+#else
+# if defined(__STDC__) && __STDC__ == 1
+#  define VA_ALIST1 char *fmt, ...
+#  define VA_DCL1
+# else
+#  define VA_ALIST1 fmt
+#  define VA_DCL1 char *fmt;
+# endif
+#endif
+/*VARARGS*/
+void
+qprintf(VA_ALIST1)
+       VA_DCL1
+{
+       va_list ap;
+       NUMBER *q;
+       int ch, sign;
+       long width, precision;
+
+#ifdef VARARGS
+       va_start(ap);
+#else
+       va_start(ap, fmt);
+#endif
+       while ((ch = *fmt++) != '\0') {
+               if (ch == '\\') {
+                       ch = *fmt++;
+                       switch (ch) {
+                               case 'n': ch = '\n'; break;
+                               case 'r': ch = '\r'; break;
+                               case 't': ch = '\t'; break;
+                               case 'f': ch = '\f'; break;
+                               case 'v': ch = '\v'; break;
+                               case 'b': ch = '\b'; break;
+                               case 0:
+                                       va_end(ap);
+                                       return;
+                       }
+                       PUTCHAR(ch);
+                       continue;
+               }
+               if (ch != '%') {
+                       PUTCHAR(ch);
+                       continue;
+               }
+               ch = *fmt++;
+               width = 0; precision = 8; sign = 1;
+percent:       ;
+               switch (ch) {
+                       case 'd':
+                               q = va_arg(ap, NUMBER *);
+                               qprintfd(q, width);
+                               break;
+                       case 'f':
+                               q = va_arg(ap, NUMBER *);
+                               qprintff(q, width, precision);
+                               break;
+                       case 'e':
+                               q = va_arg(ap, NUMBER *);
+                               qprintfe(q, width, precision);
+                               break;
+                       case 'r':
+                       case 'R':
+                               q = va_arg(ap, NUMBER *);
+                               qprintfr(q, width, (BOOL) (ch == 'R'));
+                               break;
+                       case 'N':
+                               q = va_arg(ap, NUMBER *);
+                               zprintval(q->num, 0L, width);
+                               break;
+                       case 'D':
+                               q = va_arg(ap, NUMBER *);
+                               zprintval(q->den, 0L, width);
+                               break;
+                       case 'o':
+                               q = va_arg(ap, NUMBER *);
+                               qprintfo(q, width);
+                               break;
+                       case 'x':
+                               q = va_arg(ap, NUMBER *);
+                               qprintfx(q, width);
+                               break;
+                       case 'b':
+                               q = va_arg(ap, NUMBER *);
+                               qprintfb(q, width);
+                               break;
+                       case 's':
+                               PUTSTR(va_arg(ap, char *));
+                               break;
+                       case 'c':
+                               PUTCHAR(va_arg(ap, int));
+                               break;
+                       case 0:
+                               va_end(ap);
+                               return;
+                       case '-':
+                               sign = -1;
+                               ch = *fmt++;
+                       default:
+               if (('0' <= ch && ch <= '9') || ch == '.' || ch == '*') {
+                       if (ch == '*') {
+                               q = va_arg(ap, NUMBER *);
+                               width = sign * qtoi(q);
+                               ch = *fmt++;
+                       } else if (ch != '.') {
+                               width = ch - '0';
+                               while ('0' <= (ch = *fmt++) && ch <= '9')
+                                       width = width * 10 + ch - '0';
+                               width *= sign;
+                       }
+                       if (ch == '.') {
+                               if ((ch = *fmt++) == '*') {
+                                       q = va_arg(ap, NUMBER *);
+                                       precision = qtoi(q);
+                                       ch = *fmt++;
+                               } else {
+                                       precision = 0;
+                                       while ('0' <= (ch = *fmt++) && ch <= '9')
+                                               precision = precision * 10 + ch - '0';
+                               }
+                       }
+                       goto percent;
+               }
+               }
+       }
+       va_end(ap);
+}
+
+
+#if 0
+/*
+ * Read a number from the specified FILE stream (NULL means stdin).
+ * The number can be an integer, a fraction, a real number, an
+ * exponential number, or a hex, octal or binary number.  Leading blanks
+ * are skipped.  Illegal numbers return NULL.  Unrecognized characters
+ * remain to be read on the line.
+ *     q = qreadval(fp);
+ */
+NUMBER *
+qreadval(fp)
+       FILE *fp;               /* file stream to read from (or NULL) */
+{
+       NUMBER *r;              /* returned number */
+       char *cp;               /* current buffer location */
+       long savecc;            /* characters saved in buffer */
+       long scancc;            /* characters parsed correctly */
+       int ch;                 /* current character */
+
+       if (fp == NULL)
+               fp = stdin;
+       if (etoabuf == NULL) {
+               etoabuf = (char *)malloc(OUTBUFSIZE + 2);
+               if (etoabuf == NULL)
+                       return NULL;
+               etoalen = OUTBUFSIZE;
+       }
+       cp = etoabuf;
+       ch = fgetc(fp);
+       while ((ch == ' ') || (ch == '\t'))
+               ch = fgetc(fp);
+       savecc = 0;
+       for (;;) {
+               if (ch == EOF)
+                       return NULL;
+               if (savecc >= etoalen)
+               {
+                       cp = (char *)realloc(etoabuf, etoalen + OUTBUFSIZE + 2);
+                       if (cp == NULL)
+                               return NULL;
+                       etoabuf = cp;
+                       etoalen += OUTBUFSIZE;
+                       cp += savecc;
+               }
+               *cp++ = (char)ch;
+               *cp = '\0';
+               scancc = qparse(etoabuf, QPF_SLASH);
+               if (scancc != ++savecc)
+                       break;
+               ch = fgetc(fp);
+       }
+       ungetc(ch, fp);
+       if (scancc < 0)
+               return NULL;
+       r = atoq(etoabuf);
+       if (ziszero(r->den)) {
+               qfree(r);
+               r = NULL;
+       }
+       return r;
+}
+#endif
+
+
+/*
+ * Print a number in the specified output mode.
+ * If MODE_DEFAULT is given, then the default output mode is used.
+ * Any approximate output is flagged with a leading tilde.
+ * Integers are always printed as themselves.
+ */
+void
+qprintnum(q, outmode)
+       int outmode;
+       NUMBER *q;
+{
+       NUMBER tmpval;
+       long prec, exp;
+
+       if (outmode == MODE_DEFAULT)
+               outmode = _outmode_;
+       if ((outmode == MODE_FRAC) || ((outmode == MODE_REAL) && qisint(q))) {
+               qprintfr(q, 0L, FALSE);
+               return;
+       }
+       switch (outmode) {
+               case MODE_INT:
+                       if (tilde_ok && qisfrac(q))
+                               PUTCHAR('~');
+                       qprintfd(q, 0L);
+                       break;
+
+               case MODE_REAL:
+                       prec = qplaces(q);
+                       if ((prec < 0) || (prec > _outdigits_)) {
+                               prec = _outdigits_;
+                               if (tilde_ok) {
+                                   PUTCHAR('~');
+                               }
+                       }
+                       qprintff(q, 0L, prec);
+                       break;
+
+               case MODE_EXP:
+                       if (qiszero(q)) {
+                               PUTCHAR('0');
+                               return;
+                       }
+                       tmpval = *q;
+                       tmpval.num.sign = 0;
+                       exp = qilog10(&tmpval);
+                       if (exp == 0) {         /* in range to output as real */
+                               qprintnum(q, MODE_REAL);
+                               return;
+                       }
+                       tmpval.num = _one_;
+                       tmpval.den = _one_;
+                       if (exp > 0)
+                               ztenpow(exp, &tmpval.den);
+                       else
+                               ztenpow(-exp, &tmpval.num);
+                       q = qmul(q, &tmpval);
+                       zfree(tmpval.num);
+                       zfree(tmpval.den);
+                       qprintnum(q, MODE_REAL);
+                       qfree(q);
+                       PRINTF1("e%ld", exp);
+                       break;
+
+               case MODE_HEX:
+                       qprintfx(q, 0L);
+                       break;
+
+               case MODE_OCTAL:
+                       qprintfo(q, 0L);
+                       break;
+
+               case MODE_BINARY:
+                       qprintfb(q, 0L);
+                       break;
+
+               default:
+                       math_error("Bad mode for print");
+       }
+}
+
+
+/*
+ * Print a number in floating point representation.
+ * Example:  193.784
+ */
+void
+qprintff(q, width, precision)
+       NUMBER *q;
+       long width;
+       long precision;
+{
+       ZVALUE z, z1;
+
+       if (precision != scalefactor) {
+               if (scalenumber.v)
+                       zfree(scalenumber);
+               ztenpow(precision, &scalenumber);
+               scalefactor = precision;
+       }
+       if (scalenumber.v)
+               zmul(q->num, scalenumber, &z);
+       else
+               z = q->num;
+       if (qisfrac(q)) {
+               zquo(z, q->den, &z1);
+               if (z.v != q->num.v)
+                       zfree(z);
+               z = z1;
+       }
+       if (qisneg(q) && ziszero(z))
+               PUTCHAR('-');
+       zprintval(z, precision, width);
+       if (z.v != q->num.v)
+               zfree(z);
+}
+
+
+/*
+ * Print a number in exponential notation.
+ * Example: 4.1856e34
+ */
+/*ARGSUSED*/
+void
+qprintfe(q, width, precision)
+       register NUMBER *q;
+       long width;
+       long precision;
+{
+       long exponent;
+       NUMBER q2;
+       ZVALUE num, den, tenpow, tmp;
+
+       if (qiszero(q)) {
+               PUTSTR("0.0");
+               return;
+       }
+       num = q->num;
+       den = q->den;
+       num.sign = 0;
+       exponent = zdigits(num) - zdigits(den);
+       if (exponent > 0) {
+               ztenpow(exponent, &tenpow);
+               zmul(den, tenpow, &tmp);
+               zfree(tenpow);
+               den = tmp;
+       }
+       if (exponent < 0) {
+               ztenpow(-exponent, &tenpow);
+               zmul(num, tenpow, &tmp);
+               zfree(tenpow);
+               num = tmp;
+       }
+       if (zrel(num, den) < 0) {
+               zmuli(num, 10L, &tmp);
+               if (num.v != q->num.v)
+                       zfree(num);
+               num = tmp;
+               exponent--;
+       }
+       q2.num = num;
+       q2.den = den;
+       q2.num.sign = q->num.sign;
+       qprintff(&q2, 0L, precision);
+       if (exponent)
+               PRINTF1("e%ld", exponent);
+       if (num.v != q->num.v)
+               zfree(num);
+       if (den.v != q->den.v)
+               zfree(den);
+}
+
+
+/*
+ * Print a number in rational representation.
+ * Example: 397/37
+ */
+void
+qprintfr(q, width, force)
+       NUMBER *q;
+       long width;
+       BOOL force;
+{
+       zprintval(q->num, 0L, width);
+       if (force || qisfrac(q)) {
+               PUTCHAR('/');
+               zprintval(q->den, 0L, width);
+       }
+}
+
+
+/*
+ * Print a number as an integer (truncating fractional part).
+ * Example: 958421
+ */
+void
+qprintfd(q, width)
+       NUMBER *q;
+       long width;
+{
+       ZVALUE z;
+
+       if (qisfrac(q)) {
+               zquo(q->num, q->den, &z);
+               zprintval(z, 0L, width);
+               zfree(z);
+       } else
+               zprintval(q->num, 0L, width);
+}
+
+
+/*
+ * Print a number in hex.
+ * This prints the numerator and denominator in hex.
+ */
+void
+qprintfx(q, width)
+       NUMBER *q;
+       long width;
+{
+       zprintx(q->num, width);
+       if (qisfrac(q)) {
+               PUTCHAR('/');
+               zprintx(q->den, 0L);
+       }
+}
+
+
+/*
+ * Print a number in binary.
+ * This prints the numerator and denominator in binary.
+ */
+void
+qprintfb(q, width)
+       NUMBER *q;
+       long width;
+{
+       zprintb(q->num, width);
+       if (qisfrac(q)) {
+               PUTCHAR('/');
+               zprintb(q->den, 0L);
+       }
+}
+
+
+/*
+ * Print a number in octal.
+ * This prints the numerator and denominator in octal.
+ */
+void
+qprintfo(q, width)
+       NUMBER *q;
+       long width;
+{
+       zprinto(q->num, width);
+       if (qisfrac(q)) {
+               PUTCHAR('/');
+               zprinto(q->den, 0L);
+       }
+}
+
+
+/*
+ * Convert a string to a number in rational, floating point,
+ * exponential notation, hex, or octal.
+ *     q = atoq(string);
+ */
+NUMBER *
+atoq(s)
+       register char *s;
+{
+       register NUMBER *q;
+       register char *t;
+       ZVALUE div, newnum, newden, tmp;
+       long decimals, exp;
+       BOOL hex, negexp;
+
+       q = qalloc();
+       decimals = 0;
+       exp = 0;
+       negexp = FALSE;
+       hex = FALSE;
+       t = s;
+       if ((*t == '+') || (*t == '-'))
+               t++;
+       if ((*t == '0') && ((t[1] == 'x') || (t[1] == 'X'))) {
+               hex = TRUE;
+               t += 2;
+       }
+       while (((*t >= '0') && (*t <= '9')) || (hex &&
+               (((*t >= 'a') && (*t <= 'f')) || ((*t >= 'A') && (*t <= 'F')))))
+                       t++;
+       if (*t == '/') {
+               t++;
+               atoz(t, &q->den);
+       } else if ((*t == '.') || (*t == 'e') || (*t == 'E')) {
+               if (*t == '.') {
+                       t++;
+                       while ((*t >= '0') && (*t <= '9')) {
+                               t++;
+                               decimals++;
+                       }
+               }
+               /*
+                * Parse exponent if any
+                */
+               if ((*t == 'e') || (*t == 'E')) {
+                       t++;
+                       if (*t == '+')
+                               t++;
+                       else if (*t == '-') {
+                               negexp = TRUE;
+                               t++;
+                       }
+                       while ((*t >= '0') && (*t <= '9')) {
+                               exp = (exp * 10) + *t++ - '0';
+                               if (exp > 1000000)
+                                       math_error("Exponent too large");
+                       }
+               }
+               ztenpow(decimals, &q->den);
+       }
+       atoz(s, &q->num);
+       if (qiszero(q)) {
+               qfree(q);
+               return qlink(&_qzero_);
+       }
+       /*
+        * Apply the exponential if any
+        */
+       if (exp) {
+               ztenpow(exp, &tmp);
+               if (negexp) {
+                       zmul(q->den, tmp, &newden);
+                       zfree(q->den);
+                       q->den = newden;
+               } else {
+                       zmul(q->num, tmp, &newnum);
+                       zfree(q->num);
+                       q->num = newnum;
+               }
+               zfree(tmp);
+       }
+       /*
+        * Reduce the fraction to lowest terms
+        */
+       if (zisunit(q->num) || zisunit(q->den))
+               return q;
+       zgcd(q->num, q->den, &div);
+       if (zisunit(div))
+               return q;
+       zquo(q->num, div, &newnum);
+       zfree(q->num);
+       zquo(q->den, div, &newden);
+       zfree(q->den);
+       q->num = newnum;
+       q->den = newden;
+       return q;
+}
+
+
+/*
+ * Parse a number in any of the various legal forms, and return the count
+ * of characters that are part of a legal number.  Numbers can be either a
+ * decimal integer, possibly two decimal integers separated with a slash, a
+ * floating point or exponential number, a hex number beginning with "0x",
+ * a binary number beginning with "0b", or an octal number beginning with "0".
+ * The flags argument modifies the end of number testing for ease in handling
+ * fractions or complex numbers.  Minus one is returned if the number format
+ * is definitely illegal.
+ */
+long
+qparse(cp, flags)
+       int flags;
+       register char *cp;
+{
+       char *oldcp;
+
+       oldcp = cp;
+       if ((*cp == '+') || (*cp == '-'))
+               cp++;
+       if ((*cp == '+') || (*cp == '-'))
+               return -1;
+       if ((*cp == '0') && ((cp[1] == 'x') || (cp[1] == 'X'))) {       /* hex */
+               cp += 2;
+               while (((*cp >= '0') && (*cp <= '9')) ||
+                       ((*cp >= 'a') && (*cp <= 'f')) ||
+                       ((*cp >= 'A') && (*cp <= 'F')))
+                               cp++;
+               goto done;
+       }
+       if ((*cp == '0') && ((cp[1] == 'b') || (cp[1] == 'B'))) {       /* binary */
+               cp += 2;
+               while ((*cp == '0') || (*cp == '1'))
+                       cp++;
+               goto done;
+       }
+       if ((*cp == '0') && (cp[1] >= '0') && (cp[1] <= '9')) { /* octal */
+               while ((*cp >= '0') && (*cp <= '7'))
+                       cp++;
+               goto done;
+       }
+       /*
+        * Number is decimal, but can still be a fraction or real or exponential.
+        */
+       while ((*cp >= '0') && (*cp <= '9'))
+               cp++;
+       if (*cp == '/' && flags & QPF_SLASH) {  /* fraction */
+               cp++;
+               while ((*cp >= '0') && (*cp <= '9'))
+                       cp++;
+               goto done;
+       }
+       if (*cp == '.') {       /* floating point */
+               cp++;
+               while ((*cp >= '0') && (*cp <= '9'))
+                       cp++;
+       }
+       if ((*cp == 'e') || (*cp == 'E')) {     /* exponential */
+               cp++;
+               if ((*cp == '+') || (*cp == '-'))
+                       cp++;
+               if ((*cp == '+') || (*cp == '-'))
+                       return -1;
+               while ((*cp >= '0') && (*cp <= '9'))
+                       cp++;
+       }
+
+done:
+       if (((*cp == 'i') || (*cp == 'I')) && (flags & QPF_IMAG))
+               cp++;
+       if ((*cp == '.') || ((*cp == '/') && (flags & QPF_SLASH)) ||
+               ((*cp >= '0') && (*cp <= '9')) ||
+               ((*cp >= 'a') && (*cp <= 'z')) ||
+               ((*cp >= 'A') && (*cp <= 'Z')))
+                       return -1;
+       return (cp - oldcp);
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/qmath.c b/usr/src/contrib/calc-2.9.3t6/qmath.c
new file mode 100644 (file)
index 0000000..4630c4e
--- /dev/null
@@ -0,0 +1,1211 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Extended precision rational arithmetic primitive routines
+ */
+
+#include "qmath.h"
+
+
+NUMBER _qzero_ =       { { _zeroval_, 1, 0 }, { _oneval_, 1, 0 }, 1 };
+NUMBER _qone_ =                { { _oneval_, 1, 0 }, { _oneval_, 1, 0 }, 1 };
+static NUMBER _qtwo_ = { { _twoval_, 1, 0 }, { _oneval_, 1, 0 }, 1 };
+static NUMBER _qten_ = { { _tenval_, 1, 0 }, { _oneval_, 1, 0 }, 1 };
+NUMBER _qnegone_ =     { { _oneval_, 1, 1 }, { _oneval_, 1, 0 }, 1 };
+NUMBER _qonehalf_ =    { { _oneval_, 1, 0 }, { _twoval_, 1, 0 }, 1 };
+
+
+/*
+ * Create another copy of a number.
+ *     q2 = qcopy(q1);
+ */
+NUMBER *
+qcopy(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       r = qalloc();
+       r->num.sign = q->num.sign;
+       if (!zisunit(q->num)) {
+               r->num.len = q->num.len;
+               r->num.v = alloc(r->num.len);
+               zcopyval(q->num, r->num);
+       }
+       if (!zisunit(q->den)) {
+               r->den.len = q->den.len;
+               r->den.v = alloc(r->den.len);
+               zcopyval(q->den, r->den);
+       }
+       return r;
+}
+
+
+/*
+ * Convert a number to a normal integer.
+ *     i = qtoi(q);
+ */
+long
+qtoi(q)
+       register NUMBER *q;
+{
+       long i;
+       ZVALUE res;
+
+       if (qisint(q))
+               return ztoi(q->num);
+       zquo(q->num, q->den, &res);
+       i = ztoi(res);
+       zfree(res);
+       return i;
+}
+
+
+/*
+ * Convert a normal integer into a number.
+ *     q = itoq(i);
+ */
+NUMBER *
+itoq(i)
+       long i;
+{
+       register NUMBER *q;
+
+       if ((i >= -1) && (i <= 10)) {
+               switch ((int) i) {
+                       case 0: q = &_qzero_; break;
+                       case 1: q = &_qone_; break;
+                       case 2: q = &_qtwo_; break;
+                       case 10: q = &_qten_; break;
+                       case -1: q = &_qnegone_; break;
+                       default: q = NULL;
+               }
+               if (q)
+                       return qlink(q);
+       }
+       q = qalloc();
+       itoz(i, &q->num);
+       return q;
+}
+
+
+/*
+ * Create a number from the given integral numerator and denominator.
+ *     q = iitoq(inum, iden);
+ */
+NUMBER *
+iitoq(inum, iden)
+       long inum, iden;
+{
+       register NUMBER *q;
+       long d;
+       BOOL sign;
+
+       if (iden == 0)
+               math_error("Division by zero");
+       if (inum == 0)
+               return qlink(&_qzero_);
+       sign = 0;
+       if (inum < 0) {
+               sign = 1;
+               inum = -inum;
+       }
+       if (iden < 0) {
+               sign = 1 - sign;
+               iden = -iden;
+       }
+       d = iigcd(inum, iden);
+       inum /= d;
+       iden /= d;
+       if (iden == 1)
+               return itoq(sign ? -inum : inum);
+       q = qalloc();
+       if (inum != 1)
+               itoz(inum, &q->num);
+       itoz(iden, &q->den);
+       q->num.sign = sign;
+       return q;
+}
+
+
+/*
+ * Add two numbers to each other.
+ *     q3 = qadd(q1, q2);
+ */
+NUMBER *
+qadd(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       NUMBER *r;
+       ZVALUE t1, t2, temp, d1, d2, vpd1, upd1;
+
+       if (qiszero(q1))
+               return qlink(q2);
+       if (qiszero(q2))
+               return qlink(q1);
+       r = qalloc();
+       /*
+        * If either number is an integer, then the result is easy.
+        */
+       if (qisint(q1) && qisint(q2)) {
+               zadd(q1->num, q2->num, &r->num);
+               return r;
+       }
+       if (qisint(q2)) {
+               zmul(q1->den, q2->num, &temp);
+               zadd(q1->num, temp, &r->num);
+               zfree(temp);
+               zcopy(q1->den, &r->den);
+               return r;
+       }
+       if (qisint(q1)) {
+               zmul(q2->den, q1->num, &temp);
+               zadd(q2->num, temp, &r->num);
+               zfree(temp);
+               zcopy(q2->den, &r->den);
+               return r;
+       }
+       /*
+        * Both arguments are true fractions, so we need more work.
+        * If the denominators are relatively prime, then the answer is the
+        * straightforward cross product result with no need for reduction.
+        */
+       zgcd(q1->den, q2->den, &d1);
+       if (zisunit(d1)) {
+               zfree(d1);
+               zmul(q1->num, q2->den, &t1);
+               zmul(q1->den, q2->num, &t2);
+               zadd(t1, t2, &r->num);
+               zfree(t1);
+               zfree(t2);
+               zmul(q1->den, q2->den, &r->den);
+               return r;
+       }
+       /*
+        * The calculation is now more complicated.
+        * See Knuth Vol 2 for details.
+        */
+       zquo(q2->den, d1, &vpd1);
+       zquo(q1->den, d1, &upd1);
+       zmul(q1->num, vpd1, &t1);
+       zmul(q2->num, upd1, &t2);
+       zadd(t1, t2, &temp);
+       zfree(t1);
+       zfree(t2);
+       zfree(vpd1);
+       zgcd(temp, d1, &d2);
+       zfree(d1);
+       if (zisunit(d2)) {
+               zfree(d2);
+               r->num = temp;
+               zmul(upd1, q2->den, &r->den);
+               zfree(upd1);
+               return r;
+       }
+       zquo(temp, d2, &r->num);
+       zfree(temp);
+       zquo(q2->den, d2, &temp);
+       zfree(d2);
+       zmul(temp, upd1, &r->den);
+       zfree(temp);
+       zfree(upd1);
+       return r;
+}
+
+
+/*
+ * Subtract one number from another.
+ *     q3 = qsub(q1, q2);
+ */
+NUMBER *
+qsub(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       NUMBER *r;
+
+       if (q1 == q2)
+               return qlink(&_qzero_);
+       if (qiszero(q2))
+               return qlink(q1);
+       if (qisint(q1) && qisint(q2)) {
+               r = qalloc();
+               zsub(q1->num, q2->num, &r->num);
+               return r;
+       }
+       q2 = qneg(q2);
+       if (qiszero(q1))
+               return q2;
+       r = qadd(q1, q2);
+       qfree(q2);
+       return r;
+}
+
+
+/*
+ * Increment a number by one.
+ */
+NUMBER *
+qinc(q)
+       NUMBER *q;
+{
+       NUMBER *r;
+
+       r = qalloc();
+       if (qisint(q)) {
+               zadd(q->num, _one_, &r->num);
+               return r;
+       }
+       zadd(q->num, q->den, &r->num);
+       zcopy(q->den, &r->den);
+       return r;
+}
+
+
+/*
+ * Decrement a number by one.
+ */
+NUMBER *
+qdec(q)
+       NUMBER *q;
+{
+       NUMBER *r;
+
+       r = qalloc();
+       if (qisint(q)) {
+               zsub(q->num, _one_, &r->num);
+               return r;
+       }
+       zsub(q->num, q->den, &r->num);
+       zcopy(q->den, &r->den);
+       return r;
+}
+
+
+/*
+ * Add a normal small integer value to an arbitrary number.
+ */
+NUMBER *
+qaddi(q1, n)
+       NUMBER *q1;
+       long n;
+{
+       NUMBER addnum;          /* temporary number */
+       HALF addval[2];         /* value of small number */
+       BOOL neg;               /* TRUE if number is neg */
+
+       if (n == 0)
+               return qlink(q1);
+       if (n == 1)
+               return qinc(q1);
+       if (n == -1)
+               return qdec(q1);
+       if (qiszero(q1))
+               return itoq(n);
+       addnum.num.sign = 0;
+       addnum.num.len = 1;
+       addnum.num.v = addval;
+       addnum.den = _one_;
+       neg = (n < 0);
+       if (neg)
+               n = -n;
+       addval[0] = (HALF) n;
+       n = (((FULL) n) >> BASEB);
+       if (n) {
+               addval[1] = (HALF) n;
+               addnum.num.len = 2;
+       }
+       if (neg)
+               return qsub(q1, &addnum);
+       else
+               return qadd(q1, &addnum);
+}
+
+
+/*
+ * Multiply two numbers.
+ *     q3 = qmul(q1, q2);
+ */
+NUMBER *
+qmul(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       NUMBER *r;                      /* returned value */
+       ZVALUE n1, n2, d1, d2;          /* numerators and denominators */
+       ZVALUE tmp;
+
+       if (qiszero(q1) || qiszero(q2))
+               return qlink(&_qzero_);
+       if (qisone(q1))
+               return qlink(q2);
+       if (qisone(q2))
+               return qlink(q1);
+       if (qisint(q1) && qisint(q2)) { /* easy results if integers */
+               r = qalloc();
+               zmul(q1->num, q2->num, &r->num);
+               return r;
+       }
+       n1 = q1->num;
+       n2 = q2->num;
+       d1 = q1->den;
+       d2 = q2->den;
+       if (ziszero(d1) || ziszero(d2))
+               math_error("Division by zero");
+       if (ziszero(n1) || ziszero(n2))
+               return qlink(&_qzero_);
+       if (!zisunit(n1) && !zisunit(d2)) {     /* possibly reduce */
+               zgcd(n1, d2, &tmp);
+               if (!zisunit(tmp)) {
+                       zquo(q1->num, tmp, &n1);
+                       zquo(q2->den, tmp, &d2);
+               }
+               zfree(tmp);
+       }
+       if (!zisunit(n2) && !zisunit(d1)) {     /* again possibly reduce */
+               zgcd(n2, d1, &tmp);
+               if (!zisunit(tmp)) {
+                       zquo(q2->num, tmp, &n2);
+                       zquo(q1->den, tmp, &d1);
+               }
+               zfree(tmp);
+       }
+       r = qalloc();
+       zmul(n1, n2, &r->num);
+       zmul(d1, d2, &r->den);
+       if (q1->num.v != n1.v)
+               zfree(n1);
+       if (q1->den.v != d1.v)
+               zfree(d1);
+       if (q2->num.v != n2.v)
+               zfree(n2);
+       if (q2->den.v != d2.v)
+               zfree(d2);
+       return r;
+}
+
+
+/*
+ * Multiply a number by a small integer.
+ *     q2 = qmuli(q1, n);
+ */
+NUMBER *
+qmuli(q, n)
+       NUMBER *q;
+       long n;
+{
+       NUMBER *r;
+       long d;                 /* gcd of multiplier and denominator */
+       int sign;
+
+       if ((n == 0) || qiszero(q))
+               return qlink(&_qzero_);
+       if (n == 1)
+               return qlink(q);
+       r = qalloc();
+       if (qisint(q)) {
+               zmuli(q->num, n, &r->num);
+               return r;
+       }
+       sign = 1;
+       if (n < 0) {
+               n = -n;
+               sign = -1;
+       }
+       d = zmodi(q->den, n);
+       d = iigcd(d, n);
+       zmuli(q->num, (n * sign) / d, &r->num);
+       (void) zdivi(q->den, d, &r->den);
+       return r;
+}
+
+
+/*
+ * Divide two numbers (as fractions).
+ *     q3 = qdiv(q1, q2);
+ */
+NUMBER *
+qdiv(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       NUMBER temp;
+
+       if (qiszero(q2))
+               math_error("Division by zero");
+       if ((q1 == q2) || !qcmp(q1, q2))
+               return qlink(&_qone_);
+       if (qisone(q1))
+               return qinv(q2);
+       temp.num = q2->den;
+       temp.den = q2->num;
+       temp.num.sign = temp.den.sign;
+       temp.den.sign = 0;
+       temp.links = 1;
+       return qmul(q1, &temp);
+}
+
+
+/*
+ * Divide a number by a small integer.
+ *     q2 = qdivi(q1, n);
+ */
+NUMBER *
+qdivi(q, n)
+       NUMBER *q;
+       long n;
+{
+       NUMBER *r;
+       long d;                 /* gcd of divisor and numerator */
+       int sign;
+
+       if (n == 0)
+               math_error("Division by zero");
+       if ((n == 1) || qiszero(q))
+               return qlink(q);
+       sign = 1;
+       if (n < 0) {
+               n = -n;
+               sign = -1;
+       }
+       r = qalloc();
+       d = zmodi(q->num, n);
+       d = iigcd(d, n);
+       (void) zdivi(q->num, d * sign, &r->num);
+       zmuli(q->den, n / d, &r->den);
+       return r;
+}
+
+
+/*
+ * Return the quotient when one number is divided by another.
+ * This works for fractional values also, and in all cases:
+ *     qquo(q1, q2) = int(q1 / q2).
+ */
+NUMBER *
+qquo(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       ZVALUE num, den, res;
+       NUMBER *q;
+
+       if (zisunit(q1->num))
+               num = q2->den;
+       else if (zisunit(q2->den))
+               num = q1->num;
+       else
+               zmul(q1->num, q2->den, &num);
+       if (zisunit(q1->den))
+               den = q2->num;
+       else if (zisunit(q2->num))
+               den = q1->den;
+       else
+               zmul(q1->den, q2->num, &den);
+       zquo(num, den, &res);
+       if ((num.v != q2->den.v) && (num.v != q1->num.v))
+               zfree(num);
+       if ((den.v != q2->num.v) && (den.v != q1->den.v))
+               zfree(den);
+       if (ziszero(res)) {
+               zfree(res);
+               return qlink(&_qzero_);
+       }
+       res.sign = (q1->num.sign != q2->num.sign);
+       if (zisunit(res)) {
+               q = (res.sign ? &_qnegone_ : &_qone_);
+               zfree(res);
+               return qlink(q);
+       }
+       q = qalloc();
+       q->num = res;
+       return q;
+}
+
+
+/*
+ * Return the absolute value of a number.
+ *     q2 = qabs(q1);
+ */
+NUMBER *
+qabs(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       if (q->num.sign == 0)
+               return qlink(q);
+       r = qalloc();
+       if (!zisunit(q->num))
+               zcopy(q->num, &r->num);
+       if (!zisunit(q->den))
+               zcopy(q->den, &r->den);
+       r->num.sign = 0;
+       return r;
+}
+
+
+/*
+ * Negate a number.
+ *     q2 = qneg(q1);
+ */
+NUMBER *
+qneg(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       if (qiszero(q))
+               return qlink(&_qzero_);
+       r = qalloc();
+       if (!zisunit(q->num))
+               zcopy(q->num, &r->num);
+       if (!zisunit(q->den))
+               zcopy(q->den, &r->den);
+       r->num.sign = !q->num.sign;
+       return r;
+}
+
+
+/*
+ * Return the sign of a number (-1, 0 or 1)
+ */
+NUMBER *
+qsign(q)
+       NUMBER *q;
+{
+       if (qiszero(q))
+               return qlink(&_qzero_);
+       if (qisneg(q))
+               return qlink(&_qnegone_);
+       return qlink(&_qone_);
+}
+
+
+/*
+ * Invert a number.
+ *     q2 = qinv(q1);
+ */
+NUMBER *
+qinv(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       if (qisunit(q)) {
+               r = (qisneg(q) ? &_qnegone_ : &_qone_);
+               return qlink(r);
+       }
+       if (qiszero(q))
+               math_error("Division by zero");
+       r = qalloc();
+       if (!zisunit(q->num))
+               zcopy(q->num, &r->den);
+       if (!zisunit(q->den))
+               zcopy(q->den, &r->num);
+       r->num.sign = q->num.sign;
+       r->den.sign = 0;
+       return r;
+}
+
+
+/*
+ * Return just the numerator of a number.
+ *     q2 = qnum(q1);
+ */
+NUMBER *
+qnum(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       if (qisint(q))
+               return qlink(q);
+       if (zisunit(q->num)) {
+               r = (qisneg(q) ? &_qnegone_ : &_qone_);
+               return qlink(r);
+       }
+       r = qalloc();
+       zcopy(q->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Return just the denominator of a number.
+ *     q2 = qden(q1);
+ */
+NUMBER *
+qden(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       if (qisint(q))
+               return qlink(&_qone_);
+       r = qalloc();
+       zcopy(q->den, &r->num);
+       return r;
+}
+
+
+/*
+ * Return the fractional part of a number.
+ *     q2 = qfrac(q1);
+ */
+NUMBER *
+qfrac(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+       ZVALUE z;
+
+       if (qisint(q))
+               return qlink(&_qzero_);
+       if ((q->num.len < q->den.len) || ((q->num.len == q->den.len) &&
+               (q->num.v[q->num.len - 1] < q->den.v[q->num.len - 1])))
+                       return qlink(q);
+       r = qalloc();
+       if (qisneg(q)) {
+               zmod(q->num, q->den, &z);
+               zsub(q->den, z, &r->num);
+               zfree(z);
+       } else {
+               zmod(q->num, q->den, &r->num);
+       }
+       zcopy(q->den, &r->den);
+       r->num.sign = q->num.sign;
+       return r;
+}
+
+
+/*
+ * Return the integral part of a number.
+ *     q2 = qint(q1);
+ */
+NUMBER *
+qint(q)
+       register NUMBER *q;
+{
+       register NUMBER *r;
+
+       if (qisint(q))
+               return qlink(q);
+       if ((q->num.len < q->den.len) || ((q->num.len == q->den.len) &&
+               (q->num.v[q->num.len - 1] < q->den.v[q->num.len - 1])))
+                       return qlink(&_qzero_);
+       r = qalloc();
+       zquo(q->num, q->den, &r->num);
+       return r;
+}
+
+
+/*
+ * Compute the square of a number.
+ */
+NUMBER *
+qsquare(q)
+       register NUMBER *q;
+{
+       ZVALUE num, den;
+
+       if (qiszero(q))
+               return qlink(&_qzero_);
+       if (qisunit(q))
+               return qlink(&_qone_);
+       num = q->num;
+       den = q->den;
+       q = qalloc();
+       if (!zisunit(num))
+               zsquare(num, &q->num);
+       if (!zisunit(den))
+               zsquare(den, &q->den);
+       return q;
+}
+
+
+/*
+ * Shift an integer by a given number of bits. This multiplies the number
+ * by the appropriate power of two.  Positive numbers shift left, negative
+ * ones shift right.  Low bits are truncated when shifting right.
+ */
+NUMBER *
+qshift(q, n)
+       NUMBER *q;
+       long n;
+{
+       register NUMBER *r;
+
+       if (qisfrac(q))
+               math_error("Shift of non-integer");
+       if (qiszero(q) || (n == 0))
+               return qlink(q);
+       if (n <= -(q->num.len * BASEB))
+               return qlink(&_qzero_);
+       r = qalloc();
+       zshift(q->num, n, &r->num);
+       return r;
+}
+
+
+/*
+ * Scale a number by a power of two, as in:
+ *     ans = q * 2^n.
+ * This is similar to shifting, except that fractions work.
+ */
+NUMBER *
+qscale(q, pow)
+       NUMBER *q;
+       long pow;
+{
+       long numshift, denshift, tmp;
+       NUMBER *r;
+
+       if (qiszero(q) || (pow == 0))
+               return qlink(q);
+       if ((pow > 1000000L) || (pow < -1000000L))
+               math_error("Very large scale value");
+       numshift = zisodd(q->num) ? 0 : zlowbit(q->num);
+       denshift = zisodd(q->den) ? 0 : zlowbit(q->den);
+       if (pow > 0) {
+               tmp = pow;
+               if (tmp > denshift)
+               tmp = denshift;
+               denshift = -tmp;
+               numshift = (pow - tmp);
+       } else {
+               pow = -pow;
+               tmp = pow;
+               if (tmp > numshift)
+                       tmp = numshift;
+               numshift = -tmp;
+               denshift = (pow - tmp);
+       }
+       r = qalloc();
+       if (numshift)
+               zshift(q->num, numshift, &r->num);
+       else
+               zcopy(q->num, &r->num);
+       if (denshift)
+               zshift(q->den, denshift, &r->den);
+       else
+               zcopy(q->den, &r->den);
+       return r;
+}
+
+
+/*
+ * Return the minimum of two numbers.
+ */
+NUMBER *
+qmin(q1, q2)
+       NUMBER *q1, *q2;
+{
+       if (q1 == q2)
+               return qlink(q1);
+       if (qrel(q1, q2) > 0)
+               q1 = q2;
+       return qlink(q1);
+}
+
+
+/*
+ * Return the maximum of two numbers.
+ */
+NUMBER *
+qmax(q1, q2)
+       NUMBER *q1, *q2;
+{
+       if (q1 == q2)
+               return qlink(q1);
+       if (qrel(q1, q2) < 0)
+               q1 = q2;
+       return qlink(q1);
+}
+
+
+/*
+ * Perform the logical OR of two integers.
+ */
+NUMBER *
+qor(q1, q2)
+       NUMBER *q1, *q2;
+{
+       register NUMBER *r;
+
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for logical or");
+       if ((q1 == q2) || qiszero(q2))
+               return qlink(q1);
+       if (qiszero(q1))
+               return qlink(q2);
+       r = qalloc();
+       zor(q1->num, q2->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Perform the logical AND of two integers.
+ */
+NUMBER *
+qand(q1, q2)
+       NUMBER *q1, *q2;
+{
+       register NUMBER *r;
+       ZVALUE res;
+
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for logical and");
+       if (q1 == q2)
+               return qlink(q1);
+       if (qiszero(q1) || qiszero(q2))
+               return qlink(&_qzero_);
+       zand(q1->num, q2->num, &res);
+       if (ziszero(res)) {
+               zfree(res);
+               return qlink(&_qzero_);
+       }
+       r = qalloc();
+       r->num = res;
+       return r;
+}
+
+
+/*
+ * Perform the logical XOR of two integers.
+ */
+NUMBER *
+qxor(q1, q2)
+       NUMBER *q1, *q2;
+{
+       register NUMBER *r;
+       ZVALUE res;
+
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for logical xor");
+       if (q1 == q2)
+               return qlink(&_qzero_);
+       if (qiszero(q1))
+               return qlink(q2);
+       if (qiszero(q2))
+               return qlink(q1);
+       zxor(q1->num, q2->num, &res);
+       if (ziszero(res)) {
+               zfree(res);
+               return qlink(&_qzero_);
+       }
+       r = qalloc();
+       r->num = res;
+       return r;
+}
+
+
+#if 0
+/*
+ * Return the number whose binary representation only has the specified
+ * bit set (counting from zero).  This thus produces a given power of two.
+ */
+NUMBER *
+qbitvalue(n)
+       long n;
+{
+       register NUMBER *r;
+
+       if (n <= 0)
+               return qlink(&_qone_);
+       r = qalloc();
+       zbitvalue(n, &r->num);
+       return r;
+}
+
+
+/*
+ * Test to see if the specified bit of a number is on (counted from zero).
+ * Returns TRUE if the bit is set, or FALSE if it is not.
+ *     i = qbittest(q, n);
+ */
+BOOL
+qbittest(q, n)
+       register NUMBER *q;
+       long n;
+{
+       int x, y;
+
+       if ((n < 0) || (n >= (q->num.len * BASEB)))
+               return FALSE;
+       x = q->num.v[n / BASEB];
+       y = (1 << (n % BASEB));
+       return ((x & y) != 0);
+}
+#endif
+
+
+/*
+ * Return the precision of a number (usually for examining an epsilon value).
+ * This is the largest power of two whose reciprocal is not smaller in absolute
+ * value than the specified number.  For example, qbitprec(1/100) = 6.
+ * Numbers larger than one have a precision of zero.
+ */
+long
+qprecision(q)
+       NUMBER *q;
+{
+       long r;
+
+       if (qisint(q))
+               return 0;
+       if (zisunit(q->num))
+               return zhighbit(q->den);
+       r = zhighbit(q->den) - zhighbit(q->num) - 1;
+       if (r < 0)
+               r = 0;
+       return r;
+}
+
+
+#if 0
+/*
+ * Return an integer indicating the sign of a number (-1, 0, or 1).
+ *     i = qtst(q);
+ */
+FLAG
+qtest(q)
+       register NUMBER *q;
+{
+       if (!ztest(q->num))
+               return 0;
+       if (q->num.sign)
+               return -1;
+       return 1;
+}
+#endif
+
+
+/*
+ * Determine whether or not one number exactly divides another one.
+ * Returns TRUE if the first number is an integer multiple of the second one.
+ */
+BOOL
+qdivides(q1, q2)
+       NUMBER *q1, *q2;
+{
+       if (qiszero(q1))
+               return TRUE;
+       if (qisint(q1) && qisint(q2)) {
+               if (qisunit(q2))
+                       return TRUE;
+               return zdivides(q1->num, q2->num);
+       }
+       return zdivides(q1->num, q2->num) && zdivides(q2->den, q1->den);
+}
+
+
+/*
+ * Compare two numbers and return an integer indicating their relative size.
+ *     i = qrel(q1, q2);
+ */
+FLAG
+qrel(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       ZVALUE z1, z2;
+       long wc1, wc2;
+       int sign;
+       int z1f = 0, z2f = 0;
+
+       if (q1 == q2)
+               return 0;
+       sign = q2->num.sign - q1->num.sign;
+       if (sign)
+               return sign;
+       if (qiszero(q2))
+               return !qiszero(q1);
+       if (qiszero(q1))
+               return -1;
+       /*
+        * Make a quick comparison by calculating the number of words resulting as
+        * if we multiplied through by the denominators, and then comparing the
+        * word counts.
+        */
+       sign = 1;
+       if (qisneg(q1))
+               sign = -1;
+       wc1 = q1->num.len + q2->den.len;
+       wc2 = q2->num.len + q1->den.len;
+       if (wc1 < wc2 - 1)
+               return -sign;
+       if (wc2 < wc1 - 1)
+               return sign;
+       /*
+        * Quick check failed, must actually do the full comparison.
+        */
+       if (zisunit(q2->den))
+               z1 = q1->num;
+       else if (zisone(q1->num))
+               z1 = q2->den;
+       else {
+               z1f = 1;
+               zmul(q1->num, q2->den, &z1);
+       }
+       if (zisunit(q1->den))
+               z2 = q2->num;
+       else if (zisone(q2->num))
+               z2 = q1->den;
+       else {
+               z2f = 1;
+               zmul(q2->num, q1->den, &z2);
+       }
+       sign = zrel(z1, z2);
+       if (z1f)
+               zfree(z1);
+       if (z2f)
+               zfree(z2);
+       return sign;
+}
+
+
+/*
+ * Compare two numbers to see if they are equal.
+ * This differs from qrel in that the numbers are not ordered.
+ * Returns TRUE if they differ.
+ */
+BOOL
+qcmp(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       if (q1 == q2)
+               return FALSE;
+       if ((q1->num.sign != q2->num.sign) || (q1->num.len != q2->num.len) ||
+               (q2->den.len != q2->den.len) || (*q1->num.v != *q2->num.v) ||
+               (*q1->den.v != *q2->den.v))
+                       return TRUE;
+       if (zcmp(q1->num, q2->num))
+               return TRUE;
+       if (qisint(q1))
+               return FALSE;
+       return zcmp(q1->den, q2->den);
+}
+
+
+/*
+ * Compare a number against a normal small integer.
+ * Returns 1, 0, or -1, according to whether the first number is greater,
+ * equal, or less than the second number.
+ *     n = qreli(q, n);
+ */
+FLAG
+qreli(q, n)
+       NUMBER *q;
+       long n;
+{
+       int sign;
+       ZVALUE num;
+       HALF h2[2];
+       NUMBER q2;
+
+       sign = ztest(q->num);           /* do trivial sign checks */
+       if (sign == 0) {
+               if (n > 0)
+                       return -1;
+               return (n < 0);
+       }
+       if ((sign < 0) && (n >= 0))
+               return -1;
+       if ((sign > 0) && (n <= 0))
+               return 1;
+       n *= sign;
+       if (n == 1) {                   /* quick check against 1 or -1 */
+               num = q->num;
+               num.sign = 0;
+               return (sign * zrel(num, q->den));
+       }
+       num.sign = (sign < 0);
+       num.len = 1 + (n >= BASE);
+       num.v = h2;
+       h2[0] = (n & BASE1);
+       h2[1] = (n >> BASEB);
+       if (zisunit(q->den))    /* integer compare if no denominator */
+               return zrel(q->num, num);
+       q2.num = num;
+       q2.den = _one_;
+       q2.links = 1;
+       return qrel(q, &q2);    /* full fractional compare */
+}
+
+
+/*
+ * Compare a number against a small integer to see if they are equal.
+ * Returns TRUE if they differ.
+ */
+BOOL
+qcmpi(q, n)
+       NUMBER *q;
+       long n;
+{
+       long len;
+
+       len = q->num.len;
+       if ((len > 2) || qisfrac(q) || (q->num.sign != (n < 0)))
+               return TRUE;
+       if (n < 0)
+               n = -n;
+       if (((HALF)(n)) != q->num.v[0])
+               return TRUE;
+       n = ((FULL) n) >> BASEB;
+       return (((n != 0) != (len == 2)) || (n != q->num.v[1]));
+}
+
+
+/*
+ * Number node allocation routines
+ */
+
+#define        NNALLOC 1000
+
+union allocNode {
+       NUMBER  num;
+       union allocNode *link;
+};
+
+static union allocNode *freeNum;
+
+
+NUMBER *
+qalloc()
+{
+       register union allocNode *temp;
+
+       if (freeNum == NULL) {
+               freeNum = (union allocNode *)
+               malloc(sizeof (NUMBER) * NNALLOC);
+               if (freeNum == NULL)
+                       math_error("Not enough memory");
+               freeNum[NNALLOC-1].link = NULL;
+               for (temp=freeNum+NNALLOC-2; temp >= freeNum; --temp) {
+                       temp->link = temp+1;
+               }
+       }
+       temp = freeNum;
+       freeNum = temp->link;
+       temp->num.links = 1;
+       temp->num.num = _one_;
+       temp->num.den = _one_;
+       return &temp->num;
+}
+
+
+void
+qfreenum(q)
+       register NUMBER *q;
+{
+       union allocNode *a;
+
+       if (q == NULL)
+               return;
+       zfree(q->num);
+       zfree(q->den);
+       a = (union allocNode *) q;
+       a->link = freeNum;
+       freeNum = a;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/qmath.h b/usr/src/contrib/calc-2.9.3t6/qmath.h
new file mode 100644 (file)
index 0000000..d8ffe79
--- /dev/null
@@ -0,0 +1,225 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Data structure declarations for extended precision rational arithmetic.
+ */
+
+#ifndef        QMATH_H
+#define        QMATH_H
+
+#include "zmath.h"
+
+
+/*
+ * Rational arithmetic definitions.
+ */
+typedef struct {
+       ZVALUE num;             /* numerator (containing sign) */
+       ZVALUE den;             /* denominator (always positive) */
+       long links;             /* number of links to this value */
+} NUMBER;
+
+
+/*
+ * Input. output, allocation, and conversion routines.
+ */
+extern NUMBER *qalloc MATH_PROTO((void));
+extern NUMBER *qcopy MATH_PROTO((NUMBER *q));
+extern NUMBER *iitoq MATH_PROTO((long i1, long i2));
+extern NUMBER *atoq MATH_PROTO((char *str));
+extern NUMBER *itoq MATH_PROTO((long i));
+extern long qtoi MATH_PROTO((NUMBER *q));
+extern long qparse MATH_PROTO((char *str, int flags));
+extern void qfreenum MATH_PROTO((NUMBER *q));
+extern void qprintnum MATH_PROTO((NUMBER *q, int mode));
+extern void qprintff MATH_PROTO((NUMBER *q, long width, long precision));
+extern void qprintfe MATH_PROTO((NUMBER *q, long width, long precision));
+extern void qprintfr MATH_PROTO((NUMBER *q, long width, BOOL force));
+extern void qprintfd MATH_PROTO((NUMBER *q, long width));
+extern void qprintfx MATH_PROTO((NUMBER *q, long width));
+extern void qprintfb MATH_PROTO((NUMBER *q, long width));
+extern void qprintfo MATH_PROTO((NUMBER *q, long width));
+extern int tilde_ok;
+extern int tab_ok;
+
+
+
+/*
+ * Basic numeric routines.
+ */
+extern NUMBER *qaddi MATH_PROTO((NUMBER *q, long i));
+extern NUMBER *qmuli MATH_PROTO((NUMBER *q, long i));
+extern NUMBER *qdivi MATH_PROTO((NUMBER *q, long i));
+extern NUMBER *qadd MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qsub MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qmul MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qdiv MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qquo MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qmod MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qmin MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qmax MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qand MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qor MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qxor MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qpowermod MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *q3));
+extern NUMBER *qpowi MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qsquare MATH_PROTO((NUMBER *q));
+extern NUMBER *qneg MATH_PROTO((NUMBER *q));
+extern NUMBER *qsign MATH_PROTO((NUMBER *q));
+extern NUMBER *qint MATH_PROTO((NUMBER *q));
+extern NUMBER *qfrac MATH_PROTO((NUMBER *q));
+extern NUMBER *qnum MATH_PROTO((NUMBER *q));
+extern NUMBER *qden MATH_PROTO((NUMBER *q));
+extern NUMBER *qinv MATH_PROTO((NUMBER *q));
+extern NUMBER *qabs MATH_PROTO((NUMBER *q));
+extern NUMBER *qinc MATH_PROTO((NUMBER *q));
+extern NUMBER *qdec MATH_PROTO((NUMBER *q));
+extern NUMBER *qshift MATH_PROTO((NUMBER *q, long n));
+extern NUMBER *qtrunc MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qround MATH_PROTO((NUMBER *q, long places));
+extern NUMBER *qbtrunc MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qbround MATH_PROTO((NUMBER *q, long places));
+extern NUMBER *qscale MATH_PROTO((NUMBER *q, long i));
+extern BOOL qdivides MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern BOOL qcmp MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern BOOL qcmpi MATH_PROTO((NUMBER *q, long i));
+extern FLAG qrel MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern FLAG qreli MATH_PROTO((NUMBER *q, long i));
+extern BOOL qisset MATH_PROTO((NUMBER *q, long i));
+
+
+/*
+ * More complicated numeric functions.
+ */
+extern NUMBER *qcomb MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qgcd MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qlcm MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qfact MATH_PROTO((NUMBER *q));
+extern NUMBER *qpfact MATH_PROTO((NUMBER *q));
+extern NUMBER *qminv MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qfacrem MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qperm MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qgcdrem MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qlowfactor MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qfib MATH_PROTO((NUMBER *q));
+extern NUMBER *qcfappr MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qisqrt MATH_PROTO((NUMBER *q));
+extern NUMBER *qjacobi MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qiroot MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qbappr MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qlcmfact MATH_PROTO((NUMBER *q));
+extern NUMBER *qminmod MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qredcin MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qredcout MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qredcmul MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *q3));
+extern NUMBER *qredcsquare MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qredcpower MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *q3));
+extern BOOL qprimetest MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern BOOL qissquare MATH_PROTO((NUMBER *q));
+extern long qilog2 MATH_PROTO((NUMBER *q));
+extern long qilog10 MATH_PROTO((NUMBER *q));
+extern BOOL qcmpmod MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *q3));
+extern BOOL qquomod MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER **retdiv,
+       NUMBER **retmod));
+extern FLAG qnear MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *epsilon));
+extern FLAG qdigit MATH_PROTO((NUMBER *q, long i));
+extern long qprecision MATH_PROTO((NUMBER *q));
+extern long qplaces MATH_PROTO((NUMBER *q));
+extern long qdigits MATH_PROTO((NUMBER *q));
+extern HASH qhash MATH_PROTO((NUMBER *q));
+extern void setepsilon MATH_PROTO((NUMBER *q));
+
+#if 0
+extern NUMBER *qbitvalue MATH_PROTO((long i));
+extern NUMBER *qmulmod MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *q3));
+extern NUMBER *qsquaremod MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern NUMBER *qaddmod MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *q3));
+extern NUMBER *qsubmod MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *q3));
+extern NUMBER *qreadval MATH_PROTO((FILE *fp));
+extern NUMBER *qnegmod MATH_PROTO((NUMBER *q1, NUMBER *q2));
+extern BOOL qbittest MATH_PROTO((NUMBER *q, long i));
+extern FLAG qtest MATH_PROTO((NUMBER *q));
+#endif
+
+
+/*
+ * Transcendental functions.  These all take an epsilon argument to
+ * specify the required accuracy of the calculation.
+ */
+extern NUMBER *qsqrt MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qpower MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *epsilon));
+extern NUMBER *qroot MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *epsilon));
+extern NUMBER *qcos MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qsin MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qexp MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qln MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qtan MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qacos MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qasin MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qatan MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qatan2 MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *epsilon));
+extern NUMBER *qhypot MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *epsilon));
+extern NUMBER *qcosh MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qsinh MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qtanh MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qacosh MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qasinh MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qatanh MATH_PROTO((NUMBER *q, NUMBER *epsilon));
+extern NUMBER *qlegtoleg MATH_PROTO((NUMBER *q, NUMBER *epsilon, BOOL wantneg));
+extern NUMBER *qpi MATH_PROTO((NUMBER *epsilon));
+
+
+/*
+ * macro expansions to speed this thing up
+ */
+#define qiszero(q)     (ziszero((q)->num))
+#define qisneg(q)      (zisneg((q)->num))
+#define qispos(q)      (zispos((q)->num))
+#define qisint(q)      (zisunit((q)->den))
+#define qisfrac(q)     (!zisunit((q)->den))
+#define qisunit(q)     (zisunit((q)->num) && zisunit((q)->den))
+#define qisone(q)      (zisone((q)->num) && zisunit((q)->den))
+#define qisnegone(q)   (zisnegone((q)->num) && zisunit((q)->den))
+#define qistwo(q)      (zistwo((q)->num) && zisunit((q)->den))
+#define qiseven(q)     (zisunit((q)->den) && ziseven((q)->num))
+#define qisodd(q)      (zisunit((q)->den) && zisodd((q)->num))
+#define qistwopower(q) (zisunit((q)->den) && zistwopower((q)->num))
+
+#define qhighbit(q)    (zhighbit((q)->num))
+#define qlowbit(q)     (zlowbit((q)->num))
+#define qdivcount(q1, q2)      (zdivcount((q1)->num, (q2)->num))
+#define qilog(q1, q2)  (zlog((q1)->num, (q2)->num))
+#define qlink(q)       ((q)->links++, (q))
+
+#define qfree(q)       {if (--((q)->links) <= 0) qfreenum(q);}
+
+
+/*
+ * Flags for qparse calls
+ */
+#define QPF_SLASH      0x1     /* allow slash for fractional number */
+#define QPF_IMAG       0x2     /* allow trailing 'i' for imaginary number */
+
+
+#ifdef VARARGS
+extern void qprintf();
+#else
+extern void qprintf MATH_PROTO((char *, ...));
+#endif
+
+
+/*
+ * constants used often by the arithmetic routines
+ */
+extern NUMBER _qzero_, _qone_, _qnegone_, _qonehalf_;
+extern BOOL _sinisneg_;                /* whether sin(x) < 0 (set by cos(x)) */
+extern long _epsilonprec_;     /* binary precision of epsilon */
+extern NUMBER *_epsilon_;      /* default error for real functions */
+extern long _outdigits_;       /* current output digits for float or exp */
+extern int _outmode_;          /* current output mode */
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/qmod.c b/usr/src/contrib/calc-2.9.3t6/qmod.c
new file mode 100644 (file)
index 0000000..2ebd09c
--- /dev/null
@@ -0,0 +1,483 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Modular arithmetic routines for normal numbers, and also using
+ * the faster REDC algorithm.
+ */
+
+#include "qmath.h"
+
+
+/*
+ * Structure used for caching REDC information.
+ */
+typedef struct {
+       NUMBER  *num;           /* modulus being cached */
+       REDC    *redc;          /* REDC information for modulus */
+       long    age;            /* age counter for reallocation */
+} REDC_CACHE;
+
+
+static long redc_age;                  /* current age counter */
+static REDC_CACHE redc_cache[MAXREDC]; /* cached REDC info */
+
+
+static REDC *qfindredc MATH_PROTO((NUMBER *q));
+
+
+/*
+ * Return the remainder when one number is divided by another.
+ * The second argument cannot be negative.  The result is normalized
+ * to lie in the range 0 to q2, and works for fractional values as:
+ *     qmod(q1, q2) = q1 - (int(q1 / q2) * q2).
+ */
+NUMBER *
+qmod(q1, q2)
+       register NUMBER *q1, *q2;
+{
+       ZVALUE res;
+       NUMBER *q, *tmp;
+
+       if (qisneg(q2) || qiszero(q2))
+               math_error("Non-positive modulus");
+       if (qisint(q1) && qisint(q2)) {         /* easy case */
+               zmod(q1->num, q2->num, &res);
+               if (ziszero(res)) {
+                       zfree(res);
+                       return qlink(&_qzero_);
+               }
+               if (zisone(res)) {
+                       zfree(res);
+                       return qlink(&_qone_);
+               }
+               q = qalloc();
+               q->num = res;
+               return q;
+       }
+       q = qquo(q1, q2);
+       tmp = qmul(q, q2);
+       qfree(q);
+       q = qsub(q1, tmp);
+       qfree(tmp);
+       if (qisneg(q)) {
+               tmp = qadd(q2, q);
+               qfree(q);
+               q = tmp;
+       }
+       return q;
+}
+
+
+/*
+ * Given two numbers (a and b), calculate the quotient (c) and remainder (d)
+ * when a is divided by b.  This is defined so 0 <= d < b, and c is integral,
+ * and a = b * c + d.  The results are returned indirectly through pointers.
+ * This works for integers or fractions.  Returns whether or not there is a
+ * remainder.  Examples:
+ *     qquomod(11, 4, &x, &y) sets x to 2, y to 3, and returns TRUE.
+ *     qquomod(-7, 3, &x, &y) sets x to -3, y to 2, and returns TRUE.
+ */
+BOOL
+qquomod(q1, q2, retqdiv, retqmod)
+       NUMBER *q1, *q2;                /* numbers to do quotient with */
+       NUMBER **retqdiv;               /* returned quotient */
+       NUMBER **retqmod;               /* returned modulo */
+{
+       NUMBER *qq, *qm, *tmp;
+
+       if (qisneg(q2) || qiszero(q2))
+               math_error("Non-positive modulus");
+
+       if (qisint(q1) && qisint(q2)) {         /* integer case */
+               qq = qalloc();
+               qm = qalloc();
+               zdiv(q1->num, q2->num, &qq->num, &qm->num);
+               if (!qisneg(q1) || qiszero(qm)) {
+                       *retqdiv = qq;
+                       *retqmod = qm;
+                       return !qiszero(qm);
+               }
+
+               /*
+                * Need to fix up negative results.
+                */
+               tmp = qdec(qq);
+               qfree(qq);
+               qq = tmp;
+               tmp = qsub(q2, qm);
+               qfree(qm);
+               qm = tmp;
+               *retqdiv = qq;
+               *retqmod = qm;
+               return TRUE;
+       }
+
+       /*
+        * Fractional case.
+        */
+       qq = qquo(q1, q2);
+       tmp = qmul(qq, q2);
+       qm = qsub(q1, tmp);
+       qfree(tmp);
+       if (qisneg(qm)) {
+               tmp = qadd(qm, q2);
+               qfree(qm);
+               qm = tmp;
+               tmp = qdec(qq);
+               qfree(qq);
+               qq = tmp;
+       }
+       *retqdiv = qq;
+       *retqmod = qm;
+       return !qiszero(qm);
+}
+
+
+#if 0
+/*
+ * Return the product of two integers modulo a third integer.
+ * The result is in the range 0 to q3 - 1 inclusive.
+ *     q4 = (q1 * q2) mod q3.
+ */
+NUMBER *
+qmulmod(q1, q2, q3)
+       NUMBER *q1, *q2, *q3;
+{
+       NUMBER *q;
+
+       if (qisneg(q3) || qiszero(q3))
+               math_error("Non-positive modulus");
+       if (qisfrac(q1) || qisfrac(q2) || qisfrac(q3))
+               math_error("Non-integers for qmulmod");
+       if (qiszero(q1) || qiszero(q2) || qisunit(q3))
+               return qlink(&_qzero_);
+       q = qalloc();
+       zmulmod(q1->num, q2->num, q3->num, &q->num);
+       return q;
+}
+
+
+/*
+ * Return the square of an integer modulo another integer.
+ * The result is in the range 0 to q2 - 1 inclusive.
+ *     q2 = (q1^2) mod q2.
+ */
+NUMBER *
+qsquaremod(q1, q2)
+       NUMBER *q1, *q2;
+{
+       NUMBER *q;
+
+       if (qisneg(q2) || qiszero(q2))
+               math_error("Non-positive modulus");
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for qsquaremod");
+       if (qiszero(q1) || qisunit(q2))
+               return qlink(&_qzero_);
+       if (qisunit(q1))
+               return qlink(&_qone_);
+       q = qalloc();
+       zsquaremod(q1->num, q2->num, &q->num);
+       return q;
+}
+
+
+/*
+ * Return the sum of two integers modulo a third integer.
+ * The result is in the range 0 to q3 - 1 inclusive.
+ *     q4 = (q1 + q2) mod q3.
+ */
+NUMBER *
+qaddmod(q1, q2, q3)
+       NUMBER *q1, *q2, *q3;
+{
+       NUMBER *q;
+
+       if (qisneg(q3) || qiszero(q3))
+               math_error("Non-positive modulus");
+       if (qisfrac(q1) || qisfrac(q2) || qisfrac(q3))
+               math_error("Non-integers for qaddmod");
+       q = qalloc();
+       zaddmod(q1->num, q2->num, q3->num, &q->num);
+       return q;
+}
+
+
+/*
+ * Return the difference of two integers modulo a third integer.
+ * The result is in the range 0 to q3 - 1 inclusive.
+ *     q4 = (q1 - q2) mod q3.
+ */
+NUMBER *
+qsubmod(q1, q2, q3)
+       NUMBER *q1, *q2, *q3;
+{
+       NUMBER *q;
+
+       if (qisneg(q3) || qiszero(q3))
+               math_error("Non-positive modulus");
+       if (qisfrac(q1) || qisfrac(q2) || qisfrac(q3))
+               math_error("Non-integers for qsubmod");
+       if (q1 == q2)
+               return qlink(&_qzero_);
+       q = qalloc();
+       zsubmod(q1->num, q2->num, q3->num, &q->num);
+       return q;
+}
+
+
+/*
+ * Return the negative of an integer modulo another integer.
+ * The result is in the range 0 to q2 - 1 inclusive.
+ *     q2 = (-q1) mod q2.
+ */
+NUMBER *
+qnegmod(q1, q2)
+       NUMBER *q1, *q2;
+{
+       NUMBER *q;
+
+       if (qisneg(q2) || qiszero(q2))
+               math_error("Non-positive modulus");
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for qnegmod");
+       if (qiszero(q1) || qisunit(q2))
+               return qlink(&_qzero_);
+       q = qalloc();
+       znegmod(q1->num, q2->num, &q->num);
+       return q;
+}
+#endif
+
+
+/*
+ * Return the integer congruent to an integer whose absolute value is smallest.
+ * This is a unique integer in the range int((q2-1)/2 to int(q2/2), inclusive.
+ * For example, for a modulus of 7, returned values are [-3, 3], and for a
+ * modulus of 8, returned values are [-3, 4].
+ */
+NUMBER *
+qminmod(q1, q2)
+       NUMBER *q1, *q2;
+{
+       NUMBER *q;
+
+       if (qisneg(q2) || qiszero(q2))
+               math_error("Non-positive modulus");
+       if (qisfrac(q1) || qisfrac(q2))
+               math_error("Non-integers for qminmod");
+       if (qiszero(q1) || (q1->num.len < q2->num.len - 1))
+               return qlink(q1);
+       q = qalloc();
+       zminmod(q1->num, q2->num, &q->num);
+       return q;
+}
+
+
+/*
+ * Return whether or not two integers are congruent modulo a third integer.
+ * Returns TRUE if the numbers are not congruent, and FALSE if they are.
+ */
+BOOL
+qcmpmod(q1, q2, q3)
+       NUMBER *q1, *q2, *q3;
+{
+       if (qisneg(q3) || qiszero(q3))
+               math_error("Non-positive modulus");
+       if (qisfrac(q1) || qisfrac(q2) || qisfrac(q3))
+               math_error("Non-integers for qcmpmod");
+       if (q1 == q2)
+               return FALSE;
+       return zcmpmod(q1->num, q2->num, q3->num);
+}
+
+
+/*
+ * Convert an integer into REDC format for use in faster modular arithmetic.
+ * The number can be negative or out of modulus range.
+ */
+NUMBER *
+qredcin(q1, q2)
+       NUMBER *q1;             /* number to convert into REDC format */
+       NUMBER *q2;             /* modulus */
+{
+       REDC *rp;               /* REDC information */
+       NUMBER *r;              /* result */
+
+       if (qisfrac(q1))
+               math_error("Non-integer for qredcin");
+       rp = qfindredc(q2);
+       if (qiszero(q1))
+               return qlink(&_qzero_);
+       r = qalloc();
+       zredcencode(rp, q1->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Convert a REDC format number back into a normal integer.
+ * The resulting number is in the range 0 to the modulus - 1.
+ */
+NUMBER *
+qredcout(q1, q2)
+       NUMBER *q1;             /* number to convert out of REDC format */
+       NUMBER *q2;             /* modulus */
+{
+       REDC *rp;               /* REDC information */
+       NUMBER *r;              /* result */
+
+       if (qisfrac(q1) || qisneg(q1))
+               math_error("Non-positive integer required for qredcout");
+       rp = qfindredc(q2);
+       if (qiszero(q1))
+               return qlink(&_qzero_);
+       r = qalloc();
+       zredcdecode(rp, q1->num, &r->num);
+       if (zisunit(r->num)) {
+               qfree(r);
+               r = qlink(&_qone_);
+       }
+       return r;
+}
+
+
+/*
+ * Multiply two REDC format numbers together producing a REDC format result.
+ * This multiplication is done modulo the specified modulus.
+ */
+NUMBER *
+qredcmul(q1, q2, q3)
+       NUMBER *q1, *q2;        /* REDC numbers to be multiplied */
+       NUMBER *q3;             /* modulus */
+{
+       REDC *rp;               /* REDC information */
+       NUMBER *r;              /* result */
+
+       if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2))
+               math_error("Non-positive integers required for qredcmul");
+       rp = qfindredc(q3);
+       if (qiszero(q1) || qiszero(q2))
+               return qlink(&_qzero_);
+       r = qalloc();
+       zredcmul(rp, q1->num, q2->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Square a REDC format number to produce a REDC format result.
+ * This squaring is done modulo the specified modulus.
+ */
+NUMBER *
+qredcsquare(q1, q2)
+       NUMBER *q1;             /* REDC number to be squared */
+       NUMBER *q2;             /* modulus */
+{
+       REDC *rp;               /* REDC information */
+       NUMBER *r;              /* result */
+
+       if (qisfrac(q1) || qisneg(q1))
+               math_error("Non-positive integer required for qredcsquare");
+       rp = qfindredc(q2);
+       if (qiszero(q1))
+               return qlink(&_qzero_);
+       r = qalloc();
+       zredcsquare(rp, q1->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Raise a REDC format number to the indicated power producing a REDC
+ * format result.  This is done modulo the specified modulus.  The
+ * power to be raised to is a normal number.
+ */
+NUMBER *
+qredcpower(q1, q2, q3)
+       NUMBER *q1;             /* REDC number to be raised */
+       NUMBER *q2;             /* power to be raised to */
+       NUMBER *q3;             /* modulus */
+{
+       REDC *rp;               /* REDC information */
+       NUMBER *r;              /* result */
+
+       if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2))
+               math_error("Non-positive integers required for qredcpower");
+       rp = qfindredc(q3);
+       if (qiszero(q1) || qisunit(q3))
+               return qlink(&_qzero_);
+       r = qalloc();
+       zredcpower(rp, q1->num, q2->num, &r->num);
+       return r;
+}
+
+
+/*
+ * Search for and return the REDC information for the specified number.
+ * The information is cached into a local table so that future calls
+ * for this information will be quick.  If the table fills up, then
+ * the oldest cached entry is reused.
+ */
+static REDC *
+qfindredc(q)
+       NUMBER *q;              /* modulus to find REDC information of */
+{
+       register REDC_CACHE *rcp;
+       REDC_CACHE *bestrcp;
+
+       /*
+        * First try for an exact pointer match in the table.
+        */
+       for (rcp = redc_cache; rcp < &redc_cache[MAXREDC]; rcp++) {
+               if (q == rcp->num) {
+                       rcp->age = ++redc_age;
+                       return rcp->redc;
+               }
+       }
+
+       /*
+        * Search the table again looking for a value which matches.
+        */
+       for (rcp = redc_cache; rcp < &redc_cache[MAXREDC]; rcp++) {
+               if (rcp->age && (qcmp(q, rcp->num) == 0)) {
+                       rcp->age = ++redc_age;
+                       return rcp->redc;
+               }
+       }
+
+       /*
+        * Must invalidate an existing entry in the table.
+        * Find the oldest (or first unused) entry.
+        * But first make sure the modulus will be reasonable.
+        */
+       if (qisfrac(q) || qiseven(q) || qisneg(q))
+               math_error("REDC modulus must be positive odd integer");
+
+       bestrcp = NULL;
+       for (rcp = redc_cache; rcp < &redc_cache[MAXREDC]; rcp++) {
+               if ((bestrcp == NULL) || (rcp->age < bestrcp->age))
+                       bestrcp = rcp;
+       }
+
+       /*
+        * Found the best entry.
+        * Free the old information for the entry if necessary,
+        * then initialize it.
+        */
+       rcp = bestrcp;
+       if (rcp->age) {
+               rcp->age = 0;
+               qfree(rcp->num);
+               zredcfree(rcp->redc);
+       }
+
+       rcp->redc = zredcalloc(q->num);
+       rcp->num = qlink(q);
+       rcp->age = ++redc_age;
+       return rcp->redc;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/qtrans.c b/usr/src/contrib/calc-2.9.3t6/qtrans.c
new file mode 100644 (file)
index 0000000..f56d39a
--- /dev/null
@@ -0,0 +1,958 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Transcendental functions for real numbers.
+ * These are sin, cos, exp, ln, power, cosh, sinh.
+ */
+
+#include "qmath.h"
+
+BOOL _sinisneg_;       /* whether sin(x) < 0 (set by cos(x)) */
+
+
+/*
+ * Calculate the cosine of a number with an accuracy within epsilon.
+ * This also saves the sign of the corresponding sin function.
+ */
+NUMBER *
+qcos(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *term, *sum, *qsq, *epsilon2, *tmp;
+       FULL n, i;
+       long scale, bits, bits2;
+
+       _sinisneg_ = qisneg(q);
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for cosine");
+       if (qiszero(q))
+               return qlink(&_qone_);
+       bits = qprecision(epsilon) + 1;
+       epsilon = qscale(epsilon, -4L);
+       /*
+        * If the argument is larger than one, then divide it by a power of two
+        * so that it is one or less.  This will make the series converge quickly.
+        * We will extrapolate the result for the original argument afterwards.
+        */
+       scale = zhighbit(q->num) - zhighbit(q->den) + 1;
+       if (scale < 0)
+               scale = 0;
+       if (scale > 0) {
+               q = qscale(q, -scale);
+               tmp = qscale(epsilon, -scale);
+               qfree(epsilon);
+               epsilon = tmp;
+       }
+       epsilon2 = qscale(epsilon, -4L);
+       qfree(epsilon);
+       bits2 = qprecision(epsilon2) + 10;
+       /*
+        * Now use the Taylor series expansion to calculate the cosine.
+        * Keep using approximations so that the fractions don't get too large.
+        */
+       qsq = qsquare(q);
+       if (scale > 0)
+               qfree(q);
+       term = qlink(&_qone_);
+       sum = qlink(&_qone_);
+       n = 0;
+       while (qrel(term, epsilon2) > 0) {
+               i = ++n;
+               i *= ++n;
+               tmp = qmul(term, qsq);
+               qfree(term);
+               term = qdivi(tmp, (long) i);
+               qfree(tmp);
+               tmp = qbround(term, bits2);
+               qfree(term);
+               term = tmp;
+               if (n & 2)
+                       tmp = qsub(sum, term);
+               else
+                       tmp = qadd(sum, term);
+               qfree(sum);
+               sum = qbround(tmp, bits2);
+               qfree(tmp);
+       }
+       qfree(term);
+       qfree(qsq);
+       qfree(epsilon2);
+       /*
+        * Now scale back up to the original value of x by using the formula:
+        *      cos(2 * x) = 2 * (cos(x) ^ 2) - 1.
+        */
+       while (--scale >= 0) {
+               if (qisneg(sum))
+                       _sinisneg_ = !_sinisneg_;
+               tmp = qsquare(sum);
+               qfree(sum);
+               sum = qscale(tmp, 1L);
+               qfree(tmp);
+               tmp = qdec(sum);
+               qfree(sum);
+               sum = qbround(tmp, bits2);
+               qfree(tmp);
+       }
+       tmp = qbround(sum, bits);
+       qfree(sum);
+       return tmp;
+}
+
+
+/*
+ * Calculate the sine of a number with an accuracy within epsilon.
+ * This is calculated using the formula:
+ *     sin(x)^2 + cos(x)^2 = 1.
+ * The only tricky bit is resolving the sign of the result.
+ * Future: Use sin(3*x) = 3*sin(x) - 4*sin(x)^3.
+ */
+NUMBER *
+qsin(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *epsilon2;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for sine");
+       if (qiszero(q))
+               return qlink(q);
+       epsilon2 = qsquare(epsilon);
+       tmp1 = qcos(q, epsilon2);
+       qfree(epsilon2);
+       tmp2 = qlegtoleg(tmp1, epsilon, _sinisneg_);
+       qfree(tmp1);
+       return tmp2;
+}
+
+
+/*
+ * Calculate the tangent function.
+ */
+NUMBER *
+qtan(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *cosval, *sinval, *epsilon2, *tmp, *res;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for tangent");
+       if (qiszero(q))
+               return qlink(q);
+       epsilon2 = qsquare(epsilon);
+       cosval = qcos(q, epsilon2);
+       sinval = qlegtoleg(cosval, epsilon2, _sinisneg_);
+       qfree(epsilon2);
+       tmp = qdiv(sinval, cosval);
+       qfree(cosval);
+       qfree(sinval);
+       res = qbround(tmp, qprecision(epsilon) + 1);
+       qfree(tmp);
+       return res;
+}
+
+
+/*
+ * Calculate the arcsine function.
+ * The result is in the range -pi/2 to pi/2.
+ */
+NUMBER *
+qasin(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *sum, *term, *epsilon2, *qsq, *tmp;
+       FULL n, i;
+       long bits, bits2;
+       int neg;
+       NUMBER mulnum;
+       HALF numval[2];
+       HALF denval[2];
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for arcsine");
+       if (qiszero(q))
+               return qlink(&_qzero_);
+       if ((qrel(q, &_qone_) > 0) || (qrel(q, &_qnegone_) < 0))
+               math_error("Argument too large for asin");
+       neg = qisneg(q);
+       q = qabs(q);
+       epsilon = qscale(epsilon, -4L);
+       epsilon2 = qscale(epsilon, -4L);
+       mulnum.num.sign = 0;
+       mulnum.num.len = 1;
+       mulnum.num.v = numval;
+       mulnum.den.sign = 0;
+       mulnum.den.len = 1;
+       mulnum.den.v = denval;
+       /*
+        * If the argument is too near one (we use .5) then reduce the
+        * argument to a more accurate range using the formula:
+        *      asin(x) = 2 * asin(sqrt((1 - sqrt(1 - x^2)) / 2)).
+        */
+       if (qrel(q, &_qonehalf_) > 0) {
+               sum = qlegtoleg(q, epsilon2, FALSE);
+               qfree(q);
+               tmp = qsub(&_qone_, sum);
+               qfree(sum);
+               sum = qscale(tmp, -1L);
+               qfree(tmp);
+               tmp = qsqrt(sum, epsilon2);
+               qfree(sum);
+               qfree(epsilon2);
+               sum = qasin(tmp, epsilon);
+               qfree(tmp);
+               qfree(epsilon);
+               tmp = qscale(sum, 1L);
+               qfree(sum);
+               if (neg) {
+                       sum = qneg(tmp);
+                       qfree(tmp);
+                       tmp = sum;
+               }
+               return tmp;
+       }
+       /*
+        * Argument is between zero and .5, so use the series.
+        */
+       epsilon = qscale(epsilon, -4L);
+       epsilon2 = qscale(epsilon, -4L);
+       bits = qprecision(epsilon) + 1;
+       bits2 = bits + 10;
+       sum = qlink(q);
+       term = qlink(q);
+       qsq = qsquare(q);
+       qfree(q);
+       n = 1;
+       while (qrel(term, epsilon2) > 0) {
+               i = n * n;
+               numval[0] = i & BASE1;
+               if (i >= BASE) {
+                       numval[1] = i / BASE;
+                       mulnum.den.len = 2;
+               }
+               i = (n + 1) * (n + 2);
+               denval[0] = i & BASE1;
+               if (i >= BASE) {
+                       denval[1] = i / BASE;
+                       mulnum.den.len = 2;
+               }
+               tmp = qmul(term, qsq);
+               qfree(term);
+               term = qmul(tmp, &mulnum);
+               qfree(tmp);
+               tmp = qbround(term, bits2);
+               qfree(term);
+               term = tmp;
+               tmp = qadd(sum, term);
+               qfree(sum);
+               sum = qbround(tmp, bits2);
+               qfree(tmp);
+               n += 2;
+       }
+       qfree(epsilon);
+       qfree(epsilon2);
+       qfree(term);
+       qfree(qsq);
+       tmp = qbround(sum, bits);
+       qfree(sum);
+       if (neg) {
+               term = qneg(tmp);
+               qfree(tmp);
+               tmp = term;
+       }
+       return tmp;
+}
+
+
+/*
+ * Calculate the acos function.
+ * The result is in the range 0 to pi.
+ */
+NUMBER *
+qacos(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *tmp3, *epsilon2;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for arccosine");
+       if (qisone(q))
+               return qlink(&_qzero_);
+       if ((qrel(q, &_qone_) > 0) || (qrel(q, &_qnegone_) < 0))
+               math_error("Argument too large for acos");
+       /*
+        * Calculate the result using the formula:
+        *      acos(x) = asin(sqrt(1 - x^2)).
+        * The formula is only good for positive x, so we must fix up the
+        * result for negative values.
+        */
+       epsilon2 = qscale(epsilon, -8L);
+       tmp1 = qlegtoleg(q, epsilon2, FALSE);
+       qfree(epsilon2);
+       tmp2 = qasin(tmp1, epsilon);
+       qfree(tmp1);
+       if (!qisneg(q))
+               return tmp2;
+       /*
+        * For negative values, we need to subtract the asin from pi.
+        */
+       tmp1 = qpi(epsilon);
+       tmp3 = qsub(tmp1, tmp2);
+       qfree(tmp1);
+       qfree(tmp2);
+       tmp1 = qbround(tmp3, qprecision(epsilon) + 1);
+       qfree(tmp3);
+       return tmp1;
+}
+
+
+/*
+ * Calculate the arctangent function with a accuracy less than epsilon.
+ * This uses the formula:
+ *     atan(x) = asin(sqrt(x^2 / (x^2 + 1))).
+ */
+NUMBER *
+qatan(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *tmp3, *epsilon2;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for arctangent");
+       if (qiszero(q))
+               return qlink(&_qzero_);
+       tmp1 = qsquare(q);
+       tmp2 = qinc(tmp1);
+       tmp3 = qdiv(tmp1, tmp2);
+       qfree(tmp1);
+       qfree(tmp2);
+       epsilon2 = qscale(epsilon, -8L);
+       tmp1 = qsqrt(tmp3, epsilon2);
+       qfree(epsilon2);
+       qfree(tmp3);
+       tmp2 = qasin(tmp1, epsilon);
+       qfree(tmp1);
+       if (qisneg(q)) {
+               tmp1 = qneg(tmp2);
+               qfree(tmp2);
+               tmp2 = tmp1;
+       }
+       return tmp2;
+}
+
+
+/*
+ * Calculate the angle which is determined by the point (x,y).
+ * This is the same as arctan for non-negative x, but gives the correct
+ * value for negative x.  By convention, y is the first argument.
+ * For example, qatan2(1, -1) = 3/4 * pi.
+ */
+NUMBER *
+qatan2(qy, qx, epsilon)
+       NUMBER *qy, *qx, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *epsilon2;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for atan2");
+       if (qiszero(qy) && qiszero(qx)) {
+               /* conform to 4.3BSD ANSI/IEEE 754-1985 math lib */
+               return qlink(&_qzero_);
+       }
+       /*
+        * If the point is on the negative real axis, then the answer is pi.
+        */
+       if (qiszero(qy) && qisneg(qx))
+               return qpi(epsilon);
+       /*
+        * If the point is in the right half plane, then use the normal atan.
+        */
+       if (!qisneg(qx) && !qiszero(qx)) {
+               if (qiszero(qy))
+                       return qlink(&_qzero_);
+               tmp1 = qdiv(qy, qx);
+               tmp2 = qatan(tmp1, epsilon);
+               qfree(tmp1);
+               return tmp2;
+       }
+       /*
+        * The point is in the left half plane.  Calculate the angle by finding
+        * the atan of half the angle using the formula:
+        *      atan2(y,x) = 2 * atan((sqrt(x^2 + y^2) - x) / y).
+        */
+       epsilon2 = qscale(epsilon, -4L);
+       tmp1 = qhypot(qx, qy, epsilon2);
+       tmp2 = qsub(tmp1, qx);
+       qfree(tmp1);
+       tmp1 = qdiv(tmp2, qy);
+       qfree(tmp2);
+       tmp2 = qatan(tmp1, epsilon2);
+       qfree(tmp1);
+       qfree(epsilon2);
+       tmp1 = qscale(tmp2, 1L);
+       qfree(tmp2);
+       return tmp1;
+}
+
+
+/*
+ * Calculate the value of pi to within the required epsilon.
+ * This uses the following formula which only needs integer calculations
+ * except for the final operation:
+ *     pi = 1 / SUMOF(comb(2 * N, N) ^ 3 * (42 * N + 5) / 2 ^ (12 * N + 4)),
+ * where the summation runs from N=0.  This formula gives about 6 bits of
+ * accuracy per term.  Since the denominator for each term is a power of two,
+ * we can simply use shifts to sum the terms.  The combinatorial numbers
+ * in the formula are calculated recursively using the formula:
+ *     comb(2*(N+1), N+1) = 2 * comb(2 * N, N) * (2 * N + 1) / N.
+ */
+NUMBER *
+qpi(epsilon)
+       NUMBER *epsilon;
+{
+       ZVALUE comb;                    /* current combinatorial value */
+       ZVALUE sum;                     /* current sum */
+       ZVALUE tmp1, tmp2;
+       NUMBER *r, *t1, qtmp;
+       long shift;                     /* current shift of result */
+       long N;                         /* current term number */
+       long bits;                      /* needed number of bits of precision */
+       long t;
+
+       if (qiszero(epsilon) || qisneg(epsilon))
+               math_error("Bad epsilon value for pi");
+       bits = qprecision(epsilon) + 4;
+       comb = _one_;
+       itoz(5L, &sum);
+       N = 0;
+       shift = 4;
+       do {
+               t = 1 + (++N & 0x1);
+               (void) zdivi(comb, N / (3 - t), &tmp1);
+               zfree(comb);
+               zmuli(tmp1, t * (2 * N - 1), &comb);
+               zfree(tmp1);
+               zsquare(comb, &tmp1);
+               zmul(comb, tmp1, &tmp2);
+               zfree(tmp1);
+               zmuli(tmp2, 42 * N + 5, &tmp1);
+               zfree(tmp2);
+               zshift(sum, 12L, &tmp2);
+               zfree(sum);
+               zadd(tmp1, tmp2, &sum);
+               t = zhighbit(tmp1);
+               zfree(tmp1);
+               zfree(tmp2);
+               shift += 12;
+       } while ((shift - t) < bits);
+       qtmp.num = _one_;
+       qtmp.den = sum;
+       t1 = qscale(&qtmp, shift);
+       zfree(sum);
+       r = qbround(t1, bits);
+       qfree(t1);
+       return r;
+}
+
+
+/*
+ * Calculate the exponential function with a relative accuracy less than
+ * epsilon.
+ */
+NUMBER *
+qexp(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       long scale;
+       FULL n;
+       long bits, bits2;
+       NUMBER *sum, *term, *qs, *epsilon2, *tmp;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for exp");
+       if (qiszero(q))
+               return qlink(&_qone_);
+       epsilon = qscale(epsilon, -4L);
+       /*
+        * If the argument is larger than one, then divide it by a power of two
+        * so that it is one or less.  This will make the series converge quickly.
+        * We will extrapolate the result for the original argument afterwards.
+        * Also make the argument non-negative.
+        */
+       qs = qabs(q);
+       scale = zhighbit(q->num) - zhighbit(q->den) + 1;
+       if (scale < 0)
+               scale = 0;
+       if (scale > 0) {
+               if (scale > 100000)
+                       math_error("Very large argument for exp");
+               tmp = qscale(qs, -scale);
+               qfree(qs);
+               qs = tmp;
+               tmp = qscale(epsilon, -scale);
+               qfree(epsilon);
+               epsilon = tmp;
+       }
+       epsilon2 = qscale(epsilon, -4L);
+       bits = qprecision(epsilon) + 1;
+       bits2 = bits + 10;
+       qfree(epsilon);
+       /*
+        * Now use the Taylor series expansion to calculate the exponential.
+        * Keep using approximations so that the fractions don't get too large.
+        */
+       sum = qlink(&_qone_);
+       term = qlink(&_qone_);
+       n = 0;
+       while (qrel(term, epsilon2) > 0) {
+               n++;
+               tmp = qmul(term, qs);
+               qfree(term);
+               term = qdivi(tmp, (long) n);
+               qfree(tmp);
+               tmp = qbround(term, bits2);
+               qfree(term);
+               term = tmp;
+               tmp = qadd(sum, term);
+               qfree(sum);
+               sum = qbround(tmp, bits2);
+               qfree(tmp);
+       }
+       qfree(term);
+       qfree(qs);
+       qfree(epsilon2);
+       /*
+        * Now repeatedly square the answer to get the final result.
+        * Then invert it if the original argument was negative.
+        */
+       while (--scale >= 0) {
+               tmp = qsquare(sum);
+               qfree(sum);
+               sum = qbround(tmp, bits2);
+               qfree(tmp);
+       }
+       tmp = qbround(sum, bits);
+       qfree(sum);
+       if (qisneg(q)) {
+               sum = qinv(tmp);
+               qfree(tmp);
+               tmp = sum;
+       }
+       return tmp;
+}
+
+
+/*
+ * Calculate the natural logarithm of a number accurate to the specified
+ * epsilon.
+ */
+NUMBER *
+qln(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *term, *term2, *sum, *epsilon2, *tmp1, *tmp2, *maxr;
+       long shift, bits, bits2;
+       int j, k;
+       FULL n;
+       BOOL neg;
+
+       if (qisneg(q) || qiszero(q))
+               math_error("log of non-positive number");
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon for ln");
+       if (qisone(q))
+               return qlink(&_qzero_);
+       /*
+        * If the number is less than one, invert it and remember that
+        * the result is to be negative.
+        */
+       neg = FALSE;
+       if (zrel(q->num, q->den) < 0) {
+               neg = TRUE;
+               q = qinv(q);
+       } else
+               q = qlink(q);
+       j = 16;
+       k = zhighbit(q->num) - zhighbit(q->den) + 1;
+       while (k >>= 1)
+               j++;
+       epsilon2 = qscale(epsilon, -j);
+       bits = qprecision(epsilon) + 1;
+       bits2 = qprecision(epsilon2) + 5;
+       /*
+        * By repeated square-roots scale number down to a value close
+        * to 1 so that Taylor series to be used will converge rapidly.
+        * The effect of scaling will be reversed by a later shift.
+        */
+       maxr = iitoq(BASE + 1, BASE);
+       shift = 1;
+       while (qrel(q, maxr) > 0) {
+               tmp1 = qsqrt(q, epsilon2);
+               qfree(q);
+               q = tmp1;
+               shift++;
+       }
+       qfree(maxr);
+       /*
+        * Calculate a value which will always converge using the formula:
+        *      ln((1+x)/(1-x)) = ln(1+x) - ln(1-x).
+        */
+       tmp1 = qdec(q);
+       tmp2 = qinc(q);
+       term = qdiv(tmp1, tmp2);
+       qfree(tmp1);
+       qfree(tmp2);
+       qfree(q);
+       /*
+        * Now use the Taylor series expansion to calculate the result.
+        */
+       n = 1;
+       term2 = qsquare(term);
+       sum = qlink(term);
+       while (qrel(term, epsilon2) > 0) {
+               n += 2;
+               tmp1 = qmul(term, term2);
+               qfree(term);
+               term = qbround(tmp1, bits2);
+               qfree(tmp1);
+               tmp1 = qdivi(term, (long) n);
+               tmp2 = qadd(sum, tmp1);
+               qfree(tmp1);
+               qfree(sum);
+               sum = qbround(tmp2, bits2);
+       }
+       qfree(epsilon2);
+       qfree(term);
+       qfree(term2);
+       /*
+        * Calculate the final result by multiplying by the proper power
+        * of two to undo the square roots done at the top, and possibly
+        * negating the result.
+        */
+       tmp1 = qscale(sum, shift);
+       qfree(sum);
+       sum = qbround(tmp1, bits);
+       qfree(tmp1);
+       if (neg) {
+               tmp1 = qneg(sum);
+               qfree(sum);
+               sum = tmp1;
+       }
+       return sum;
+}
+
+
+/*
+ * Calculate the result of raising one number to the power of another.
+ * The result is calculated to within the specified relative error.
+ */
+NUMBER *
+qpower(q1, q2, epsilon)
+       NUMBER *q1, *q2, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *epsilon2;
+
+       if (qisint(q2))
+               return qpowi(q1, q2);
+       epsilon2 = qscale(epsilon, -4L);
+       tmp1 = qln(q1, epsilon2);
+       tmp2 = qmul(tmp1, q2);
+       qfree(tmp1);
+       tmp1 = qexp(tmp2, epsilon);
+       qfree(tmp2);
+       qfree(epsilon2);
+       return tmp1;
+}
+
+
+/*
+ * Calculate the Kth root of a number to within the specified accuracy.
+ */
+NUMBER *
+qroot(q1, q2, epsilon)
+       NUMBER *q1, *q2, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *epsilon2;
+       int neg;
+
+       if (qisneg(q2) || qiszero(q2) || qisfrac(q2))
+               math_error("Taking bad root of number");
+       if (qiszero(q1) || qisone(q1) || qisone(q2))
+               return qlink(q1);
+       if (qistwo(q2))
+               return qsqrt(q1, epsilon);
+       neg = qisneg(q1);
+       if (neg) {
+               if (ziseven(q2->num))
+                       math_error("Taking even root of negative number");
+               q1 = qabs(q1);
+       }
+       epsilon2 = qscale(epsilon, -4L);
+       tmp1 = qln(q1, epsilon2);
+       tmp2 = qdiv(tmp1, q2);
+       qfree(tmp1);
+       tmp1 = qexp(tmp2, epsilon);
+       qfree(tmp2);
+       qfree(epsilon2);
+       if (neg) {
+               tmp2 = qneg(tmp1);
+               qfree(tmp1);
+               tmp1 = tmp2;
+       }
+       return tmp1;
+}
+
+
+/*
+ * Calculate the hyperbolic cosine function with a relative accuracy less
+ * than epsilon.  This is defined by:
+ *     cosh(x) = (exp(x) + exp(-x)) / 2.
+ */
+NUMBER *
+qcosh(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       long scale;
+       FULL n;
+       FULL m;
+       long bits, bits2;
+       NUMBER *sum, *term, *qs, *epsilon2, *tmp;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for exp");
+       if (qiszero(q))
+               return qlink(&_qone_);
+       epsilon = qscale(epsilon, -4L);
+       /*
+        * If the argument is larger than one, then divide it by a power of two
+        * so that it is one or less.  This will make the series converge quickly.
+        * We will extrapolate the result for the original argument afterwards.
+        */
+       qs = qabs(q);
+       scale = zhighbit(q->num) - zhighbit(q->den) + 1;
+       if (scale < 0)
+               scale = 0;
+       if (scale > 0) {
+               if (scale > 100000)
+                       math_error("Very large argument for exp");
+               tmp = qscale(qs, -scale);
+               qfree(qs);
+               qs = tmp;
+               tmp = qscale(epsilon, -scale);
+               qfree(epsilon);
+               epsilon = tmp;
+       }
+       epsilon2 = qscale(epsilon, -4L);
+       bits = qprecision(epsilon) + 1;
+       bits2 = bits + 10;
+       qfree(epsilon);
+       tmp = qsquare(qs);
+       qfree(qs);
+       qs = tmp;
+       /*
+        * Now use the Taylor series expansion to calculate the exponential.
+        * Keep using approximations so that the fractions don't get too large.
+        */
+       sum = qlink(&_qone_);
+       term = qlink(&_qone_);
+       n = 0;
+       while (qrel(term, epsilon2) > 0) {
+               m = ++n;
+               m *= ++n;
+               tmp = qmul(term, qs);
+               qfree(term);
+               term = qdivi(tmp, (long) m);
+               qfree(tmp);
+               tmp = qbround(term, bits2);
+               qfree(term);
+               term = tmp;
+               tmp = qadd(sum, term);
+               qfree(sum);
+               sum = qbround(tmp, bits2);
+               qfree(tmp);
+       }
+       qfree(term);
+       qfree(qs);
+       qfree(epsilon2);
+       /*
+        * Now bring the number back up into range to get the final result.
+        * This uses the formula:
+        *      cosh(2 * x) = 2 * cosh(x)^2 - 1.
+        */
+       while (--scale >= 0) {
+               tmp = qsquare(sum);
+               qfree(sum);
+               sum = qscale(tmp, 1L);
+               qfree(tmp);
+               tmp = qdec(sum);
+               qfree(sum);
+               sum = qbround(tmp, bits2);
+               qfree(tmp);
+       }
+       tmp = qbround(sum, bits);
+       qfree(sum);
+       return tmp;
+}
+
+
+/*
+ * Calculate the hyperbolic sine with an accurary less than epsilon.
+ * This is calculated using the formula:
+ *     cosh(x)^2 - sinh(x)^2 = 1.
+ */
+NUMBER *
+qsinh(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *tmp1, *tmp2;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for sinh");
+       if (qiszero(q))
+               return qlink(q);
+       epsilon = qscale(epsilon, -4L);
+       tmp1 = qcosh(q, epsilon);
+       tmp2 = qsquare(tmp1);
+       qfree(tmp1);
+       tmp1 = qdec(tmp2);
+       qfree(tmp2);
+       tmp2 = qsqrt(tmp1, epsilon);
+       qfree(tmp1);
+       if (qisneg(q)) {
+               tmp1 = qneg(tmp2);
+               qfree(tmp2);
+               tmp2 = tmp1;
+       }
+       qfree(epsilon);
+       return tmp2;
+}
+
+
+/*
+ * Calculate the hyperbolic tangent with an accurary less than epsilon.
+ * This is calculated using the formula:
+ *     tanh(x) = sinh(x) / cosh(x).
+ */
+NUMBER *
+qtanh(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *coshval;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for tanh");
+       if (qiszero(q))
+               return qlink(q);
+       epsilon = qscale(epsilon, -4L);
+       coshval = qcosh(q, epsilon);
+       tmp2 = qsquare(coshval);
+       tmp1 = qdec(tmp2);
+       qfree(tmp2);
+       tmp2 = qsqrt(tmp1, epsilon);
+       qfree(tmp1);
+       if (qisneg(q)) {
+               tmp1 = qneg(tmp2);
+               qfree(tmp2);
+               tmp2 = tmp1;
+       }
+       qfree(epsilon);
+       tmp1 = qdiv(tmp2, coshval);
+       qfree(tmp2);
+       qfree(coshval);
+       return tmp1;
+}
+
+
+/*
+ * Compute the hyperbolic arccosine within the specified accuracy.
+ * This is calculated using the formula:
+ *     acosh(x) = ln(x + sqrt(x^2 - 1)).
+ */
+NUMBER *
+qacosh(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *epsilon2;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for acosh");
+       if (qisone(q))
+               return qlink(&_qzero_);
+       if (qreli(q, 1L) < 0)
+               math_error("Argument less than one for acosh");
+       epsilon2 = qscale(epsilon, -8L);
+       tmp1 = qsquare(q);
+       tmp2 = qdec(tmp1);
+       qfree(tmp1);
+       tmp1 = qsqrt(tmp2, epsilon2);
+       qfree(tmp2);
+       tmp2 = qadd(tmp1, q);
+       qfree(tmp1);
+       tmp1 = qln(tmp2, epsilon);
+       qfree(tmp2);
+       qfree(epsilon2);
+       return tmp1;
+}
+
+
+/*
+ * Compute the hyperbolic arcsine within the specified accuracy.
+ * This is calculated using the formula:
+ *     asinh(x) = ln(x + sqrt(x^2 + 1)).
+ */
+NUMBER *
+qasinh(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *epsilon2;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for asinh");
+       if (qiszero(q))
+               return qlink(&_qzero_);
+       epsilon2 = qscale(epsilon, -8L);
+       tmp1 = qsquare(q);
+       tmp2 = qinc(tmp1);
+       qfree(tmp1);
+       tmp1 = qsqrt(tmp2, epsilon2);
+       qfree(tmp2);
+       tmp2 = qadd(tmp1, q);
+       qfree(tmp1);
+       tmp1 = qln(tmp2, epsilon);
+       qfree(tmp2);
+       qfree(epsilon2);
+       return tmp1;
+}
+
+
+/*
+ * Compute the hyperbolic arctangent within the specified accuracy.
+ * This is calculated using the formula:
+ *     atanh(x) = ln((1 + u) / (1 - u)) / 2.
+ */
+NUMBER *
+qatanh(q, epsilon)
+       NUMBER *q, *epsilon;
+{
+       NUMBER *tmp1, *tmp2, *tmp3;
+
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Illegal epsilon value for atanh");
+       if (qiszero(q))
+               return qlink(&_qzero_);
+       if ((qreli(q, 1L) > 0) || (qreli(q, -1L) < 0))
+               math_error("Argument not between -1 and 1 for atanh");
+       tmp1 = qinc(q);
+       tmp2 = qsub(&_qone_, q);
+       tmp3 = qdiv(tmp1, tmp2);
+       qfree(tmp1);
+       qfree(tmp2);
+       tmp1 = qln(tmp3, epsilon);
+       qfree(tmp3);
+       tmp2 = qscale(tmp1, -1L);
+       qfree(tmp1);
+       return tmp2;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/stdarg.h b/usr/src/contrib/calc-2.9.3t6/stdarg.h
new file mode 100644 (file)
index 0000000..729cc73
--- /dev/null
@@ -0,0 +1,43 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ */
+
+#include "args.h"
+
+#ifndef STDARG_H
+#define STDARG_H
+
+#ifdef VARARGS
+
+#include <varargs.h>
+
+#else /*VARARG*/
+
+#ifdef STDARG
+
+#include <stdarg.h>
+
+#else /*STDARG*/
+
+/*
+ * SIMULATE_STDARG
+ *
+ * WARNING: This type of stdarg makes assumptions about the stack
+ *         that may not be true on your system.  You may want to
+ *         define STDARG (if using ANSI C) or VARARGS.
+ */
+
+typedef char *va_list;
+#define va_start(ap,parmn) (void)((ap) = (char*)(&(parmn) + 1))
+#define va_end(ap) (void)((ap) = 0)
+#define va_arg(ap, type) \
+    (((type*)((ap) = ((ap) + sizeof(type))))[-1])
+
+#endif /*STDARG*/
+#endif /*VARARG*/
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/string.c b/usr/src/contrib/calc-2.9.3t6/string.c
new file mode 100644 (file)
index 0000000..67cbb57
--- /dev/null
@@ -0,0 +1,289 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * String list routines.
+ */
+
+#include "calc.h"
+#include "string.h"
+
+#define STR_TABLECHUNK 100     /* how often to reallocate string table */
+#define STR_CHUNK      2000    /* size of string storage allocation */
+#define STR_UNIQUE     100     /* size of string to allocate separately */
+
+
+static char *chartable;                /* single character string table */
+
+static struct {
+       long l_count;           /* count of strings in table */
+       long l_maxcount;        /* maximum strings storable in table */
+       long l_avail;           /* characters available in current string */
+       char *l_alloc;          /* next available string storage */
+       char **l_table;         /* current string table */
+} literals;
+
+
+/*
+ * Initialize or reinitialize a string header for use.
+ */
+void
+initstr(hp)
+       register STRINGHEAD *hp;        /* structure to be inited */
+{
+       if (hp->h_list == NULL) {
+               hp->h_list = (char *)malloc(2000);
+               hp->h_avail = 2000;
+               hp->h_used = 0;
+       }
+       hp->h_avail += hp->h_used;
+       hp->h_used = 0;
+       hp->h_count = 0;
+       hp->h_list[0] = '\0';
+       hp->h_list[1] = '\0';
+}
+
+
+/*
+ * Copy a string to the end of a list of strings, and return the address
+ * of the copied string.  Returns NULL if the string could not be copied.
+ * No checks are made to see if the string is already in the list.
+ * The string cannot be null or have imbedded nulls.
+ */
+char *
+addstr(hp, str)
+       register STRINGHEAD *hp;        /* header of string storage */
+       char *str;              /* string to be added */
+{
+       char *retstr;           /* returned string pointer */
+       char *list;             /* string list */
+       long newsize;           /* new size of string list */
+       long len;               /* length of current string */
+
+       if ((str == NULL) || (*str == '\0'))
+               return NULL;
+       len = strlen(str) + 1;
+       if (hp->h_avail <= len) {
+               newsize = len + 2000 + hp->h_used + hp->h_avail;
+               list = (char *)realloc(hp->h_list, newsize);
+               if (list == NULL)
+                       return NULL;
+               hp->h_list = list;
+               hp->h_avail = newsize - hp->h_used;
+       }
+       retstr = hp->h_list + hp->h_used;
+       hp->h_used += len;
+       hp->h_avail -= len;
+       hp->h_count++;
+       strcpy(retstr, str);
+       retstr[len] = '\0';
+       return retstr;
+}
+
+
+/*
+ * Return a null-terminated string which consists of a single character.
+ * The table is initialized on the first call.
+ */
+char *
+charstr(ch)
+       int ch;
+{
+       char *cp;
+       int i;
+
+       if (chartable == NULL) {
+               cp = (char *)malloc(512);
+               if (cp == NULL)
+                       math_error("Cannot allocate character table");
+               for (i = 0; i < 256; i++) {
+                       *cp++ = (char)i;
+                       *cp++ = '\0';
+               }
+               chartable = cp - 512;
+       }
+       return &chartable[(ch & 0xff) * 2];
+}
+
+
+/*
+ * Find a string with the specified name and return its number in the
+ * string list.  The first string is numbered zero.  Minus one is returned
+ * if the string is not found.
+ */
+long
+findstr(hp, str)
+       STRINGHEAD *hp;         /* header of string storage */
+       register char *str;     /* string to be added */
+{
+       register char *test;    /* string being tested */
+       long len;               /* length of string being found */
+       long testlen;           /* length of test string */
+       long index;             /* index of string */
+
+       if ((hp->h_count <= 0) || (str == NULL))
+               return -1;
+       len = strlen(str);
+       test = hp->h_list;
+       index = 0;
+       while (*test) {
+               testlen = strlen(test);
+               if ((testlen == len) && (*test == *str) && (strcmp(test, str) == 0))
+                       return index;
+               test += (testlen + 1);
+               index++;
+       }
+       return -1;
+}
+
+
+/*
+ * Return the name of a string with the given index.
+ * If the index is illegal, a pointer to an empty string is returned.
+ */
+char *
+namestr(hp, n)
+       STRINGHEAD *hp;         /* header of string storage */
+       long n;
+{
+       register char *str;     /* current string */
+
+       if ((unsigned long)n >= hp->h_count)
+               return "";
+       str = hp->h_list;
+       while (*str) {
+               if (--n < 0)
+                       return str;
+               str += (strlen(str) + 1);
+       }
+       return "";
+}
+
+
+/*
+ * Useful routine to return the index of one string within another one
+ * which has the format:  "str1\0str2\0str3\0...strn\0\0".  Index starts
+ * at one for the first string.  Returns zero if the string being checked
+ * is not contained in the formatted string.
+ */
+long
+stringindex(format, test)
+       register char *format;  /* string formatted into substrings */
+       char *test;             /* string to be found in formatted string */
+{
+       long index;             /* found index */
+       long len;               /* length of current piece of string */
+       long testlen;           /* length of test string */
+
+       testlen = strlen(test);
+       index = 1;
+       while (*format) {
+               len = strlen(format);
+               if ((len == testlen) && (*format == *test) &&
+                       (strcmp(format, test) == 0))
+                               return index;
+               format += (len + 1);
+               index++;
+       }
+       return 0;
+}
+
+
+/*
+ * Add a possibly new literal string to the literal string pool.
+ * Returns the new string address which is guaranteed to be always valid.
+ * Duplicate strings will repeatedly return the same address.
+ */
+char *
+addliteral(str)
+       char *str;
+{
+       register char **table;  /* table of strings */
+       char *newstr;           /* newly allocated string */
+       long count;             /* number of strings */
+       long len;               /* length of string to allocate */
+
+       len = strlen(str);
+       if (len <= 1)
+               return charstr(*str);
+       /*
+        * See if the string is already in the table.
+        */
+       table = literals.l_table;
+       count = literals.l_count;
+       while (count-- > 0) {
+               if ((str[0] == table[0][0]) && (str[1] == table[0][1]) &&
+                       (strcmp(str, table[0]) == 0))
+                               return table[0];
+               table++;
+       }
+       /*
+        * Make the table of string pointers larger if necessary.
+        */
+       if (literals.l_count >= literals.l_maxcount) {
+               count = literals.l_maxcount + STR_TABLECHUNK;
+               if (literals.l_maxcount)
+                       table = (char **) realloc(literals.l_table, count * sizeof(char *));
+               else
+                       table = (char **) malloc(count * sizeof(char *));
+               if (table == NULL)
+                       math_error("Cannot allocate string literal table");
+               literals.l_table = table;
+               literals.l_maxcount = count;
+       }
+       table = literals.l_table;
+       /*
+        * If the new string is very long, allocate it manually.
+        */
+       len = (len + 2) & ~1;   /* add room for null and round up to word */
+       if (len >= STR_UNIQUE) {
+               newstr = (char *)malloc(len);
+               if (newstr == NULL)
+                       math_error("Cannot allocate large literal string");
+               strcpy(newstr, str);
+               table[literals.l_count++] = newstr;
+               return newstr;
+       }
+       /*
+        * If the remaining space in the allocate string is too small,
+        * then allocate a new one.
+        */
+       if (literals.l_avail < len) {
+               newstr = (char *)malloc(STR_CHUNK);
+               if (newstr == NULL)
+                       math_error("Cannot allocate new literal string");
+               literals.l_alloc = newstr;
+               literals.l_avail = STR_CHUNK;
+       }
+       /*
+        * Allocate the new string from the allocate string.
+        */
+       newstr = literals.l_alloc;
+       literals.l_avail -= len;
+       literals.l_alloc += len;
+       table[literals.l_count++] = newstr;
+       strcpy(newstr, str);
+       return newstr;
+}
+
+
+/*
+ * Calculate a trivial hash value for a string.
+ */
+HASH
+hashstr(cp)
+       char *cp;
+{
+       int len;
+       HASH hash;
+
+       len = strlen(cp);
+       hash = len * 300007;
+       while (len-- > 0)
+               /* ignore Saber-C warning about Over/underflow */
+               hash = hash * 300017 + *cp++ + 300043;
+       return hash;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/string.h b/usr/src/contrib/calc-2.9.3t6/string.h
new file mode 100644 (file)
index 0000000..9a46ae7
--- /dev/null
@@ -0,0 +1,32 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ */
+
+#ifndef        CALCSTRING_H
+#define        CALCSTRING_H
+
+#include "zmath.h"
+
+
+typedef struct {
+       char *h_list;   /* list of strings separated by nulls */
+       long h_used;    /* characters used so far */
+       long h_avail;   /* characters available for use */
+       long h_count;   /* number of strings */
+} STRINGHEAD;
+
+
+extern void initstr MATH_PROTO((STRINGHEAD *hp));
+extern char *addstr MATH_PROTO((STRINGHEAD *hp, char *str));
+extern char *namestr MATH_PROTO((STRINGHEAD *hp, long n));
+extern long findstr MATH_PROTO((STRINGHEAD *hp, char *str));
+extern char *charstr MATH_PROTO((int ch));
+extern char *addliteral MATH_PROTO((char *str));
+extern long stringindex MATH_PROTO((char *str1, char *str2));
+extern HASH hashstr MATH_PROTO((char *cp));
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/symbol.c b/usr/src/contrib/calc-2.9.3t6/symbol.c
new file mode 100644 (file)
index 0000000..50888c7
--- /dev/null
@@ -0,0 +1,501 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Global and local symbol routines.
+ */
+
+#include "calc.h"
+#include "token.h"
+#include "symbol.h"
+#include "string.h"
+#include "opcodes.h"
+#include "func.h"
+
+#define HASHSIZE       37      /* size of hash table */
+
+
+static int filescope;          /* file scope level for static variables */
+static int funcscope;          /* function scope level for static variables */
+static STRINGHEAD localnames;  /* list of local variable names */
+static STRINGHEAD globalnames; /* list of global variable names */
+static STRINGHEAD paramnames;  /* list of parameter variable names */
+static GLOBAL *globalhash[HASHSIZE];   /* hash table for globals */
+
+static void fitprint MATH_PROTO((NUMBER *num, long digits, long width));
+static void unscope MATH_PROTO((void));
+
+
+/*
+ * Hash a symbol name so we can find it in the hash table.
+ * Args are the symbol name and the symbol name size.
+ */
+#define HASHSYM(n, s) ((unsigned)((n)[0]*123 + (n)[s-1]*135 + (s)*157) % HASHSIZE)
+
+
+/*
+ * Initialize the global symbol table.
+ */
+void
+initglobals()
+{
+       int i;          /* index counter */
+
+       for (i = 0; i < HASHSIZE; i++)
+               globalhash[i] = NULL;
+       initstr(&globalnames);
+       filescope = SCOPE_STATIC;
+       funcscope = 0;
+}
+
+
+/*
+ * Define a possibly new global variable which may or may not be static.
+ * If it did not already exist, it is created with a value of zero.
+ * The address of the global symbol structure is returned.
+ */
+GLOBAL *
+addglobal(name, isstatic)
+       char *name;             /* name of global variable */
+       BOOL isstatic;          /* TRUE if symbol is static */
+{
+       GLOBAL *sp;             /* current symbol pointer */
+       GLOBAL **hp;            /* hash table head address */
+       long len;               /* length of string */
+       int newfilescope;       /* file scope being looked for */
+       int newfuncscope;       /* function scope being looked for */
+
+       newfilescope = SCOPE_GLOBAL;
+       newfuncscope = 0;
+       if (isstatic) {
+               newfilescope = filescope;
+               newfuncscope = funcscope;
+       }
+       len = strlen(name);
+       if (len <= 0)
+               return NULL;
+       hp = &globalhash[HASHSYM(name, len)];
+       for (sp = *hp; sp; sp = sp->g_next) {
+               if ((sp->g_len == len) && (strcmp(sp->g_name, name) == 0)
+                       && (sp->g_filescope == newfilescope)
+                       && (sp->g_funcscope == newfuncscope))
+                               return sp;
+       }
+       sp = (GLOBAL *) malloc(sizeof(GLOBAL));
+       if (sp == NULL)
+               return sp;
+       sp->g_name = addstr(&globalnames, name);
+       sp->g_len = len;
+       sp->g_filescope = newfilescope;
+       sp->g_funcscope = newfuncscope;
+       sp->g_value.v_num = qlink(&_qzero_);
+       sp->g_value.v_type = V_NUM;
+       sp->g_next = *hp;
+       *hp = sp;
+       return sp;
+}
+
+
+/*
+ * Look up the name of a global variable and return its address.
+ * Since the same variable may appear in different scopes, we search
+ * for the one with the highest function scope value within the current
+ * file scope level (or which is global).  Returns NULL if the symbol
+ * was not found.
+ */
+GLOBAL *
+findglobal(name)
+       char *name;             /* name of global variable */
+{
+       GLOBAL *sp;             /* current symbol pointer */
+       GLOBAL *bestsp;         /* found symbol with highest scope */
+       long len;               /* length of string */
+
+       bestsp = NULL;
+       len = strlen(name);
+       for (sp = globalhash[HASHSYM(name, len)]; sp; sp = sp->g_next) {
+               if ((sp->g_len != len) || strcmp(sp->g_name, name))
+                       continue;
+               if (sp->g_filescope == SCOPE_GLOBAL) {
+                       if (bestsp == NULL)
+                               bestsp = sp;
+                       continue;
+               }
+               if (sp->g_filescope != filescope)
+                       continue;
+               if ((bestsp == NULL) || (sp->g_funcscope > bestsp->g_funcscope))
+                       bestsp = sp;
+       }
+       return bestsp;
+}
+
+
+/*
+ * Return the name of a global variable given its address.
+ */
+char *
+globalname(sp)
+       GLOBAL *sp;             /* address of global pointer */
+{
+       if (sp)
+               return sp->g_name;
+       return "";
+}
+
+
+/*
+ * Show the value of all global variables, typing only the head and
+ * tail of very large numbers.  Only truly global symbols are shown.
+ */
+void
+showglobals()
+{
+       GLOBAL **hp;                    /* hash table head address */
+       register GLOBAL *sp;            /* current global symbol pointer */
+       long count;                     /* number of global variables shown */
+       NUMBER *num, *den;
+       long digits;
+
+       count = 0;
+       for (hp = &globalhash[HASHSIZE-1]; hp >= globalhash; hp--) {
+               for (sp = *hp; sp; sp = sp->g_next) {
+                       if (sp->g_value.v_type != V_NUM)
+                               continue;
+                       if (sp->g_filescope != SCOPE_GLOBAL)
+                               continue;
+                       if (count++ == 0) {
+                               printf("\nName    Digits  Value\n");
+                               printf(  "----    ------  -----\n");
+                       }
+                       printf("%-8s ", sp->g_name);
+                       num = qnum(sp->g_value.v_num);
+                       digits = qdigits(num);
+                       printf("%-7ld ", digits);
+                       fitprint(num, digits, 60L);
+                       qfree(num);
+                       if (!qisint(sp->g_value.v_num)) {
+                               den = qden(sp->g_value.v_num);
+                               digits = qdigits(den);
+                               printf("\n      %-6ld /", digits);
+                               fitprint(den, digits, 60L);
+                               qfree(den);
+                       }
+                       printf("\n");
+               }
+       }
+       printf(count ? "\n" : "No global variables defined.\n");
+}
+
+
+/*
+ * Print an integer which is guaranteed to fit in the specified number
+ * of columns, using imbedded '...' characters if it is too large.
+ */
+static void
+fitprint(num, digits, width)
+       NUMBER *num;            /* number to print */
+       long digits, width;
+{
+       long show, used;
+       NUMBER *p, *t, *div, *val;
+
+       if (digits <= width) {
+               qprintf("%r", num);
+               return;
+       }
+       show = (width / 2) - 2;
+       t = itoq(10L);
+       p = itoq((long) (digits - show));
+       div = qpowi(t, p);
+       val = qquo(num, div);
+       qprintf("%r...", val);
+       qfree(p);
+       qfree(div);
+       qfree(val);
+       p = itoq(show);
+       div = qpowi(t, p);
+       val = qmod(num, div);
+       used = qdigits(val);
+       while (used++ < show) printf("0");
+       qprintf("%r", val);
+       qfree(p);
+       qfree(div);
+       qfree(val);
+       qfree(t);
+}
+
+
+/*
+ * Write all normal global variables to an output file.
+ * Note: Currently only simple types are saved.
+ * Returns nonzero on error.
+ */
+int
+writeglobals(name)
+       char *name;
+{
+       FILE *fp;
+       GLOBAL **hp;                    /* hash table head address */
+       register GLOBAL *sp;            /* current global symbol pointer */
+       int savemode;                   /* saved output mode */
+
+       fp = f_open(name, "w");
+       if (fp == NULL)
+               return 1;
+       math_setfp(fp);
+       for (hp = &globalhash[HASHSIZE-1]; hp >= globalhash; hp--) {
+               for (sp = *hp; sp; sp = sp->g_next) {
+                       switch (sp->g_value.v_type) {
+                               case V_NUM:
+                               case V_COM:
+                               case V_STR:
+                                       break;
+                               default:
+                                       continue;
+                       }
+                       math_fmt("%s = ", sp->g_name);
+                       savemode = math_setmode(MODE_HEX);
+                       printvalue(&sp->g_value, PRINT_UNAMBIG);
+                       math_setmode(savemode);
+                       math_str(";\n");
+               }
+       }
+       math_setfp(stdout);
+       if (fclose(fp))
+               return 1;
+       return 0;
+}
+
+
+/*
+ * Reset the file and function scope levels back to the original values.
+ * This is called on errors to forget any static variables which were being
+ * defined.
+ */
+void
+resetscopes()
+{
+       filescope = SCOPE_STATIC;
+       funcscope = 0;
+       unscope();
+}
+
+
+/*
+ * Enter a new file scope level so that newly defined static variables
+ * will have the appropriate scope, and so that previously defined static
+ * variables will temporarily be unaccessible.  This should only be called
+ * when the function scope level is zero.
+ */
+void
+enterfilescope()
+{
+       filescope++;
+       funcscope = 0;
+}
+
+
+/*
+ * Exit from a file scope level.  This deletes from the global symbol table
+ * all of the static variables that were defined within this file scope level.
+ * The function scope level is also reset to zero.
+ */
+void
+exitfilescope()
+{
+       if (filescope > SCOPE_STATIC)
+               filescope--;
+       funcscope = 0;
+       unscope();
+}
+
+
+/*
+ * Enter a new function scope level within the current file scope level.
+ * This allows newly defined static variables to override previously defined
+ * static variables in the same file scope level.
+ */
+void
+enterfuncscope()
+{
+       funcscope++;
+}
+
+
+/*
+ * Exit from a function scope level.  This deletes static symbols which were
+ * defined within the current function scope level, and makes previously
+ * defined symbols with the same name within the same file scope level
+ * accessible again.
+ */
+void
+exitfuncscope()
+{
+       if (funcscope > 0)
+               funcscope--;
+       unscope();
+}
+
+
+/*
+ * Remove all the symbols from the global symbol table which have file or
+ * function scopes larger than the current scope levels.  Their memory
+ * remains allocated since their values still actually exist.
+ */
+static void
+unscope()
+{
+       GLOBAL **hp;                    /* hash table head address */
+       register GLOBAL *sp;            /* current global symbol pointer */
+       GLOBAL *prevsp;                 /* previous kept symbol pointer */
+
+       for (hp = &globalhash[HASHSIZE-1]; hp >= globalhash; hp--) {
+               prevsp = NULL;
+               for (sp = *hp; sp; sp = sp->g_next) {
+                       if ((sp->g_filescope == SCOPE_GLOBAL) ||
+                               (sp->g_filescope < filescope) ||
+                               ((sp->g_filescope == filescope) &&
+                                       (sp->g_funcscope <= funcscope)))
+                       {
+                               prevsp = sp;
+                               continue;
+                       }
+
+                       /*
+                        * This symbol needs removing.
+                        */
+                       if (prevsp)
+                               prevsp->g_next = sp->g_next;
+                       else
+                               *hp = sp->g_next;
+               }
+       }
+}
+
+
+/*
+ * Initialize the local and parameter symbol table information.
+ */
+void
+initlocals()
+{
+       initstr(&localnames);
+       initstr(&paramnames);
+       curfunc->f_localcount = 0;
+       curfunc->f_paramcount = 0;
+}
+
+
+/*
+ * Add a possibly new local variable definition.
+ * Returns the index of the variable into the local symbol table.
+ * Minus one indicates the symbol could not be added.
+ */
+long
+addlocal(name)
+       char *name;             /* name of local variable */
+{
+       long index;             /* current symbol index */
+
+       index = findstr(&localnames, name);
+       if (index >= 0)
+               return index;
+       index = localnames.h_count;
+       (void) addstr(&localnames, name);
+       curfunc->f_localcount++;
+       return index;
+}
+
+
+/*
+ * Find a local variable name and return its index.
+ * Returns minus one if the variable name is not defined.
+ */
+long
+findlocal(name)
+       char *name;             /* name of local variable */
+{
+       return findstr(&localnames, name);
+}
+
+
+/*
+ * Return the name of a local variable.
+ */
+char *
+localname(n)
+       long n;
+{
+       return namestr(&localnames, n);
+}
+
+
+/*
+ * Add a possibly new parameter variable definition.
+ * Returns the index of the variable into the parameter symbol table.
+ * Minus one indicates the symbol could not be added.
+ */
+long
+addparam(name)
+       char *name;             /* name of parameter variable */
+{
+       long index;             /* current symbol index */
+
+       index = findstr(&paramnames, name);
+       if (index >= 0)
+               return index;
+       index = paramnames.h_count;
+       (void) addstr(&paramnames, name);
+       curfunc->f_paramcount++;
+       return index;
+}
+
+
+/*
+ * Find a parameter variable name and return its index.
+ * Returns minus one if the variable name is not defined.
+ */
+long
+findparam(name)
+       char *name;             /* name of parameter variable */
+{
+       return findstr(&paramnames, name);
+}
+
+
+/*
+ * Return the name of a parameter variable.
+ */
+char *
+paramname(n)
+       long n;
+{
+       return namestr(&paramnames, n);
+}
+
+
+/*
+ * Return the type of a variable name.
+ * This is either local, parameter, global, static, or undefined.
+ */
+int
+symboltype(name)
+       char *name;             /* variable name to find */
+{
+       GLOBAL *sp;
+
+       if (findlocal(name) >= 0)
+               return SYM_LOCAL;
+       if (findparam(name) >= 0)
+               return SYM_PARAM;
+       sp = findglobal(name);
+       if (sp) {
+               if (sp->g_filescope == SCOPE_GLOBAL)
+                       return SYM_GLOBAL;
+               return SYM_STATIC;
+       }
+       return SYM_UNDEFINED;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/symbol.h b/usr/src/contrib/calc-2.9.3t6/symbol.h
new file mode 100644 (file)
index 0000000..18d729f
--- /dev/null
@@ -0,0 +1,77 @@
+/*
+ * Copyright (c) 1993 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ */
+
+#ifndef        SYMBOL_H
+#define        SYMBOL_H
+
+#include "zmath.h"
+
+
+/*
+ * Symbol Declarations.
+ */
+#define SYM_UNDEFINED  0       /* undefined symbol */
+#define SYM_PARAM      1       /* parameter symbol */
+#define SYM_LOCAL      2       /* local symbol */
+#define SYM_GLOBAL     3       /* global symbol */
+#define        SYM_STATIC      4       /* static symbol */
+
+#define        SCOPE_GLOBAL    0       /* file scope level for global variables */
+#define        SCOPE_STATIC    1       /* lowest file scope for static variables */
+
+
+typedef struct global GLOBAL;
+struct global {
+       int g_len;              /* length of symbol name */
+       short g_filescope;      /* file scope level of symbol (0 if global) */
+       short g_funcscope;      /* function scope level of symbol */
+       char *g_name;           /* global symbol name */
+       VALUE g_value;          /* global symbol value */
+       GLOBAL *g_next;         /* next symbol in hash chain */
+};
+
+
+/*
+ * Routines to search for global symbols.
+ */
+extern GLOBAL *addglobal MATH_PROTO((char *name, BOOL isstatic));
+extern GLOBAL *findglobal MATH_PROTO((char *name));
+
+
+/*
+ * Routines to return names of variables.
+ */
+extern char *localname MATH_PROTO((long n));
+extern char *paramname MATH_PROTO((long n));
+extern char *globalname MATH_PROTO((GLOBAL *sp));
+
+
+/*
+ * Routines to handle entering and leaving of scope levels.
+ */
+extern void resetscopes MATH_PROTO((void));
+extern void enterfilescope MATH_PROTO((void));
+extern void exitfilescope MATH_PROTO((void));
+extern void enterfuncscope MATH_PROTO((void));
+extern void exitfuncscope MATH_PROTO((void));
+
+
+/*
+ * Other routines.
+ */
+extern long addlocal MATH_PROTO((char *name));
+extern long findlocal MATH_PROTO((char *name));
+extern long addparam MATH_PROTO((char *name));
+extern long findparam MATH_PROTO((char *name));
+extern void initlocals MATH_PROTO((void));
+extern void initglobals MATH_PROTO((void));
+extern int writeglobals MATH_PROTO((char *name));
+extern int symboltype MATH_PROTO((char *name));
+extern void showglobals MATH_PROTO((void));
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/token.c b/usr/src/contrib/calc-2.9.3t6/token.c
new file mode 100644 (file)
index 0000000..2bc0ce7
--- /dev/null
@@ -0,0 +1,603 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Read input file characters into tokens
+ */
+
+#include "stdarg.h"
+#include "calc.h"
+#include "token.h"
+#include "string.h"
+
+
+#define isletter(ch)   ((((ch) >= 'a') && ((ch) <= 'z')) || \
+                               (((ch) >= 'A') && ((ch) <= 'Z')))
+#define isdigit(ch)    (((ch) >= '0') && ((ch) <= '9'))
+#define issymbol(ch)   (isletter(ch) || isdigit(ch) || ((ch) == '_'))
+
+
+/*
+ * Current token.
+ */
+static struct {
+       short t_type;           /* type of token */
+       char *t_str;            /* string value or symbol name */
+       long t_numindex;        /* index of numeric value */
+} curtoken;
+
+
+static BOOL rescan;            /* TRUE to reread current token */
+static BOOL newlines;          /* TRUE to return newlines as tokens */
+static BOOL allsyms;           /* TRUE if always want a symbol token */
+static STRINGHEAD strings;     /* list of constant strings */
+static char *numbuf;           /* buffer for numeric tokens */
+static long numbufsize;                /* current size of numeric buffer */
+
+long errorcount;               /* number of compilation errors */
+
+
+/*
+ * Table of keywords
+ */
+struct keyword {
+       char *k_name;   /* keyword name */
+       int k_token;    /* token number */
+};
+
+static struct keyword keywords[] = {
+       "if",           T_IF,
+       "else",         T_ELSE,
+       "for",          T_FOR,
+       "while",        T_WHILE,
+       "do",           T_DO,
+       "continue",     T_CONTINUE,
+       "break",        T_BREAK,
+       "goto",         T_GOTO,
+       "return",       T_RETURN,
+       "local",        T_LOCAL,
+       "global",       T_GLOBAL,
+       "static",       T_STATIC,
+       "switch",       T_SWITCH,
+       "case",         T_CASE,
+       "default",      T_DEFAULT,
+       "quit",         T_QUIT,
+       "exit",         T_QUIT,
+       "define",       T_DEFINE,
+       "read",         T_READ,
+       "show",         T_SHOW,
+       "help",         T_HELP,
+       "write",        T_WRITE,
+       "mat",          T_MAT,
+       "obj",          T_OBJ,
+       "print",        T_PRINT,
+       NULL,           0
+};
+
+
+static void eatcomment MATH_PROTO((void));
+static void eatstring MATH_PROTO((int quotechar));
+static int eatsymbol MATH_PROTO((void));
+static int eatnumber MATH_PROTO((void));
+
+
+/*
+ * Initialize all token information.
+ */
+void
+inittokens()
+{
+       initstr(&strings);
+       newlines = FALSE;
+       allsyms = FALSE;
+       rescan = FALSE;
+       setprompt(PROMPT1);
+}
+
+
+/*
+ * Set the new token mode according to the specified flag, and return the
+ * previous value of the flag.
+ */
+int
+tokenmode(flag)
+       int flag;
+{
+       int     oldflag;
+
+       oldflag = TM_DEFAULT;
+       if (newlines)
+               oldflag |= TM_NEWLINES;
+       if (allsyms)
+               oldflag |= TM_ALLSYMS;
+       newlines = FALSE;
+       allsyms = FALSE;
+       if (flag & TM_NEWLINES)
+               newlines = TRUE;
+       if (flag & TM_ALLSYMS)
+               allsyms = TRUE;
+       setprompt(newlines ? PROMPT1 : PROMPT2);
+       return oldflag;
+}
+
+
+/*
+ * Routine to read in the next token from the input stream.
+ * The type of token is returned as a value.  If the token is a string or
+ * symbol name, information is saved so that the value can be retrieved.
+ */
+int
+gettoken()
+{
+       int ch;                 /* current input character */
+       int type;               /* token type */
+
+       if (rescan) {           /* rescanning */
+               rescan = FALSE;
+               return curtoken.t_type;
+       }
+       curtoken.t_str = NULL;
+       curtoken.t_numindex = 0;
+       type = T_NULL;
+       while (type == T_NULL) {
+               ch = nextchar();
+               if (allsyms && ((ch!=' ') && (ch!=';') && (ch!='"') && (ch!='\n'))) {
+                       reread();
+                       type = eatsymbol();
+                       break;
+               }
+               switch (ch) {
+               case ' ':
+               case '\t':
+               case '\0':
+                       break;
+               case '\n':
+                       if (newlines)
+                               type = T_NEWLINE;
+                       break;
+               case EOF: type = T_EOF; break;
+               case '{': type = T_LEFTBRACE; break;
+               case '}': type = T_RIGHTBRACE; break;
+               case '(': type = T_LEFTPAREN; break;
+               case ')': type = T_RIGHTPAREN; break;
+               case '[': type = T_LEFTBRACKET; break;
+               case ']': type = T_RIGHTBRACKET; break;
+               case ';': type = T_SEMICOLON; break;
+               case ':': type = T_COLON; break;
+               case ',': type = T_COMMA; break;
+               case '?': type = T_QUESTIONMARK; break;
+               case '"':
+               case '\'':
+                       type = T_STRING;
+                       eatstring(ch);
+                       break;
+               case '^':
+                       switch (nextchar()) {
+                               case '=': type = T_POWEREQUALS; break;
+                               default: type = T_POWER; reread();
+                       }
+                       break;
+               case '=':
+                       switch (nextchar()) {
+                               case '=': type = T_EQ; break;
+                               default: type = T_ASSIGN; reread();
+                       }
+                       break;
+               case '+':
+                       switch (nextchar()) {
+                               case '+': type = T_PLUSPLUS; break;
+                               case '=': type = T_PLUSEQUALS; break;
+                               default: type = T_PLUS; reread();
+                       }
+                       break;
+               case '-':
+                       switch (nextchar()) {
+                               case '-': type = T_MINUSMINUS; break;
+                               case '=': type = T_MINUSEQUALS; break;
+                               default: type = T_MINUS; reread();
+                       }
+                       break;
+               case '*':
+                       switch (nextchar()) {
+                               case '=': type = T_MULTEQUALS; break;
+                               case '*':
+                                       switch (nextchar()) {
+                                               case '=': type = T_POWEREQUALS; break;
+                                               default: type = T_POWER; reread();
+                                       }
+                                       break;
+                               default: type = T_MULT; reread();
+                       }
+                       break;
+               case '/':
+                       switch (nextchar()) {
+                               case '/':
+                                       switch (nextchar()) {
+                                               case '=': type = T_SLASHSLASHEQUALS; break;
+                                               default: reread(); type = T_SLASHSLASH; break;
+                                       }
+                                       break;
+                               case '=': type = T_DIVEQUALS; break;
+                               case '*': eatcomment(); break;
+                               default: type = T_DIV; reread();
+                       }
+                       break;
+               case '%':
+                       switch (nextchar()) {
+                               case '=': type = T_MODEQUALS; break;
+                               default: type = T_MOD; reread();
+                       }
+                       break;
+               case '<':
+                       switch (nextchar()) {
+                               case '=': type = T_LE; break;
+                               case '<':
+                                       switch (nextchar()) {
+                                               case '=': type = T_LSHIFTEQUALS; break;
+                                               default:  reread(); type = T_LEFTSHIFT; break;
+                                       }
+                                       break;
+                               default: type = T_LT; reread();
+                       }
+                       break;
+               case '>':
+                       switch (nextchar()) {
+                               case '=': type = T_GE; break;
+                               case '>':
+                                       switch (nextchar()) {
+                                               case '=': type = T_RSHIFTEQUALS; break;
+                                               default:  reread(); type = T_RIGHTSHIFT; break;
+                                       }
+                                       break;
+                               default: type = T_GT; reread();
+                       }
+                       break;
+               case '&':
+                       switch (nextchar()) {
+                               case '&': type = T_ANDAND; break;
+                               case '=': type = T_ANDEQUALS; break;
+                               default: type = T_AND; reread(); break;
+                       }
+                       break;
+               case '|':
+                       switch (nextchar()) {
+                               case '|': type = T_OROR; break;
+                               case '=': type = T_OREQUALS; break;
+                               default: type = T_OR; reread(); break;
+                       }
+                       break;
+               case '!':
+                       switch (nextchar()) {
+                               case '=': type = T_NE; break;
+                               default: type = T_NOT; reread(); break;
+                       }
+                       break;
+               case '\\':
+                       switch (nextchar()) {
+                               case '\n': setprompt(PROMPT2); break;
+                               default: scanerror(T_NULL, "Unknown token character '%c'", ch);
+                       }
+                       break;
+               default:
+                       if (isletter(ch)) {
+                               reread();
+                               type = eatsymbol();
+                               break;
+                       }
+                       if (isdigit(ch) || (ch == '.')) {
+                               reread();
+                               type = eatnumber();
+                               break;
+                       }
+                       scanerror(T_NULL, "Unknown token character '%c'", ch);
+               }
+       }
+       curtoken.t_type = (short)type;
+       return type;
+}
+
+
+/*
+ * Continue to eat up a comment string.
+ * The leading slash-asterisk has just been scanned at this point.
+ */
+static void
+eatcomment()
+{
+       int ch;
+
+       for (;;) {
+               ch = nextchar();
+               if (ch == '*') {
+                       ch = nextchar();
+                       if (ch == '/')
+                               return;
+                       reread();
+               }
+               if ((ch == EOF) || (ch == '\0') ||
+                       (newlines && (ch == '\n') && inputisterminal())) {
+                               reread();
+                               scanerror(T_NULL, "Unterminated comment");
+                               return;
+               }
+       }
+}
+
+
+/*
+ * Read in a string and add it to the literal string pool.
+ * The leading single or double quote has been read in at this point.
+ */
+static void
+eatstring(quotechar)
+       int quotechar;
+{
+       register char *cp;      /* current character address */
+       int ch;                 /* current character */
+       char buf[MAXSTRING+1];  /* buffer for string */
+
+       cp = buf;
+       for (;;) {
+               ch = nextchar();
+               switch (ch) {
+                       case '\0':
+                       case EOF:
+                       case '\n':
+                               reread();
+                               scanerror(T_NULL, "Unterminated string constant");
+                               *cp = '\0';
+                               curtoken.t_str = addliteral(buf);
+                               return;
+
+                       case '\\':
+                               ch = nextchar();
+                               switch (ch) {
+                                       case 'n': ch = '\n'; break;
+                                       case 'r': ch = '\r'; break;
+                                       case 't': ch = '\t'; break;
+                                       case 'b': ch = '\b'; break;
+                                       case 'f': ch = '\f'; break;
+                                       case '\n':
+                                               setprompt(PROMPT2);
+                                               continue;
+                                       case EOF:
+                                               reread();
+                                               continue;
+                               }
+                               *cp++ = (char)ch;
+                               break;
+
+                       case '"':
+                       case '\'':
+                               if (ch == quotechar) {
+                                       *cp = '\0';
+                                       curtoken.t_str = addliteral(buf);
+                                       return;
+                               }
+                               /* fall into default case */
+
+                       default:
+                               *cp++ = (char)ch;
+               }
+       }
+}
+
+
+/*
+ * Read in a symbol name which may or may not be a keyword.
+ * If allsyms is set, keywords are not looked up and almost all chars
+ * will be accepted for the symbol.  Returns the type of symbol found.
+ */
+static int
+eatsymbol()
+{
+       register struct keyword *kp;    /* pointer to current keyword */
+       register char *cp;              /* current character pointer */
+       int ch;                         /* current character */
+       int cc;                         /* character count */
+       static char buf[SYMBOLSIZE+1];  /* temporary buffer */
+
+       cp = buf;
+       cc = SYMBOLSIZE;
+       if (allsyms) {
+               for (;;) {
+                       ch = nextchar();
+                       if ((ch == ' ') || (ch == ';') || (ch == '\n'))
+                               break;
+                       if (cc-- > 0)
+                               *cp++ = (char)ch;
+               }
+               reread();
+               *cp = '\0';
+               if (cc < 0)
+                       scanerror(T_NULL, "Symbol too long");
+               curtoken.t_str = buf;
+               return T_SYMBOL;
+       }
+       for (;;) {
+               ch = nextchar();
+               if (!issymbol(ch))
+                       break;
+               if (cc-- > 0)
+                       *cp++ = (char)ch;
+       }
+       reread();
+       *cp = '\0';
+       if (cc < 0)
+               scanerror(T_NULL, "Symbol too long");
+       for (kp = keywords; kp->k_name; kp++)
+               if (strcmp(kp->k_name, buf) == 0)
+                       return kp->k_token;
+       curtoken.t_str = buf;
+       return T_SYMBOL;
+}
+
+
+/*
+ * Read in and remember a possibly numeric constant value.
+ * The constant is inserted into a constant table so further uses
+ * of the same constant will not take more memory.  This can also
+ * return just a period, which is used for element accesses and for
+ * the old numeric value.
+ */
+static int
+eatnumber()
+{
+       register char *cp;      /* current character pointer */
+       long len;               /* parsed size of number */
+       long res;               /* result of parsing number */
+
+       if (numbufsize == 0) {
+               numbuf = (char *)malloc(128+1);
+               if (numbuf == NULL)
+                       math_error("Cannot allocate number buffer");
+               numbufsize = 128;
+       }
+       cp = numbuf;
+       len = 0;
+       for (;;) {
+               if (len >= numbufsize) {
+                       cp = (char *)realloc(numbuf, numbufsize + 1001);
+                       if (cp == NULL)
+                               math_error("Cannot reallocate number buffer");
+                       numbuf = cp;
+                       numbufsize += 1000;
+                       cp = &numbuf[len];
+               }
+               *cp = nextchar();
+               *(++cp) = '\0';
+               if ((numbuf[0] == '.') && isletter(numbuf[1])) {
+                       reread();
+                       return T_PERIOD;
+               }
+               res = qparse(numbuf, QPF_IMAG);
+               if (res < 0) {
+                       reread();
+                       scanerror(T_NULL, "Badly formatted number");
+                       curtoken.t_numindex = addnumber("0");
+                       return T_NUMBER;
+               }
+               if (res != ++len)
+                       break;
+       }
+       cp[-1] = '\0';
+       reread();
+       if ((numbuf[0] == '.') && (numbuf[1] == '\0')) {
+               curtoken.t_numindex = 0;
+               return T_OLDVALUE;
+       }
+       cp -= 2;
+       res = T_NUMBER;
+       if ((*cp == 'i') || (*cp == 'I')) {
+               *cp = '\0';
+               res = T_IMAGINARY;
+       }
+       curtoken.t_numindex = addnumber(numbuf);
+       return res;
+}
+
+
+/*
+ * Return the string value of the current token.
+ */
+char *
+tokenstring()
+{
+       return curtoken.t_str;
+}
+
+
+/*
+ * Return the constant index of a numeric token.
+ */
+long
+tokennumber()
+{
+       return curtoken.t_numindex;
+}
+
+
+/*
+ * Push back the token just read so that it will be seen again.
+ */
+void
+rescantoken()
+{
+       rescan = TRUE;
+}
+
+
+/*
+ * Describe an error message.
+ * Then skip to the next specified token (or one more powerful).
+ */
+#ifdef VARARGS
+# define VA_ALIST skip, fmt, va_alist
+# define VA_DCL int skip; char *fmt; va_dcl
+#else
+# if defined(__STDC__) && __STDC__ == 1
+#  define VA_ALIST int skip, char *fmt, ...
+#  define VA_DCL
+# else
+#  define VA_ALIST skip, fmt
+#  define VA_DCL int skip; char *fmt;
+# endif
+#endif
+/*VARARGS*/
+void
+scanerror(VA_ALIST)
+       VA_DCL
+{
+       va_list ap;
+       char *name;             /* name of file with error */
+       char buf[MAXERROR+1];
+
+       errorcount++;
+       name = inputname();
+       if (name)
+               fprintf(stderr, "\"%s\", line %ld: ", name, linenumber());
+#ifdef VARARGS
+       va_start(ap);
+#else
+       va_start(ap, fmt);
+#endif
+       vsprintf(buf, fmt, ap);
+       va_end(ap);
+       fprintf(stderr, "%s\n", buf);
+       switch (skip) {
+               case T_NULL:
+                       return;
+               case T_COMMA:
+                       rescan = TRUE;
+                       for (;;) {
+                               switch (gettoken()) {
+                               case T_NEWLINE:
+                               case T_SEMICOLON:
+                               case T_LEFTBRACE:
+                               case T_RIGHTBRACE:
+                               case T_EOF:
+                               case T_COMMA:
+                                       rescan = TRUE;
+                                       return;
+                               }
+                       }
+               default:
+                       fprintf(stderr, "Unknown skip token for scanerror\n");
+                       /* fall into semicolon case */
+                       /*FALLTHRU*/
+               case T_SEMICOLON:
+                       rescan = TRUE;
+                       for (;;) switch (gettoken()) {
+                               case T_NEWLINE:
+                               case T_SEMICOLON:
+                               case T_LEFTBRACE:
+                               case T_RIGHTBRACE:
+                               case T_EOF:
+                                       rescan = TRUE;
+                                       return;
+                       }
+       }
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/token.h b/usr/src/contrib/calc-2.9.3t6/token.h
new file mode 100644 (file)
index 0000000..9c3088a
--- /dev/null
@@ -0,0 +1,143 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ */
+
+#ifndef        TOKEN_H
+#define        TOKEN_H
+
+#include "zmath.h"
+
+
+/*
+ * Token types
+ */
+#define T_NULL                 0       /* null token */
+#define T_LEFTPAREN            1       /* left parenthesis "(" */
+#define T_RIGHTPAREN           2       /* right parenthesis ")" */
+#define T_LEFTBRACE            3       /* left brace "{" */
+#define T_RIGHTBRACE           4       /* right brace "}" */
+#define T_SEMICOLON            5       /* end of statement ";" */
+#define T_EOF                  6       /* end of file */
+#define T_COLON                        7       /* label character ":" */
+#define T_ASSIGN               8       /* assignment "=" */
+#define T_PLUS                 9       /* plus sign "+" */
+#define T_MINUS                        10      /* minus sign "-" */
+#define T_MULT                 11      /* multiply sign "*" */
+#define T_DIV                  12      /* divide sign "/" */
+#define T_MOD                  13      /* modulo sign "%" */
+#define T_POWER                        14      /* power sign "^" or "**" */
+#define T_EQ                   15      /* equality "==" */
+#define T_NE                   16      /* notequal "!=" */
+#define T_LT                   17      /* less than "<" */
+#define T_GT                   18      /* greater than ">" */
+#define T_LE                   19      /* less than or equals "<=" */
+#define T_GE                   20      /* greater than or equals ">=" */
+#define T_LEFTBRACKET          21      /* left bracket "[" */
+#define T_RIGHTBRACKET         22      /* right bracket "]" */
+#define T_SYMBOL               23      /* symbol name */
+#define T_STRING               24      /* string value (double quotes) */
+#define T_NUMBER               25      /* numeric real constant */
+#define T_PLUSEQUALS           26      /* plus equals "+=" */
+#define T_MINUSEQUALS          27      /* minus equals "-=" */
+#define T_MULTEQUALS           28      /* multiply equals "*=" */
+#define T_DIVEQUALS            29      /* divide equals "/=" */
+#define T_MODEQUALS            30      /* modulo equals "%=" */
+#define T_PLUSPLUS             31      /* plusplus "++" */
+#define T_MINUSMINUS           32      /* minusminus "--" */
+#define T_COMMA                        33      /* comma "," */
+#define T_ANDAND               34      /* logical and "&&" */
+#define T_OROR                 35      /* logical or "||" */
+#define T_OLDVALUE             36      /* old value from previous calculation */
+#define T_SLASHSLASH           37      /* integer divide "//" */
+#define T_NEWLINE              38      /* newline character */
+#define T_SLASHSLASHEQUALS     39      /* integer divide equals "//=" */
+#define T_AND                  40      /* arithmetic and "&" */
+#define T_OR                   41      /* arithmetic or "|" */
+#define T_NOT                  42      /* logical not "!" */
+#define T_LEFTSHIFT            43      /* left shift "<<" */
+#define T_RIGHTSHIFT           44      /* right shift ">>" */
+#define T_ANDEQUALS            45      /* and equals "&=" */
+#define T_OREQUALS             46      /* or equals "|= */
+#define T_LSHIFTEQUALS         47      /* left shift equals "<<=" */
+#define T_RSHIFTEQUALS         48      /* right shift equals ">>= */
+#define T_POWEREQUALS          49      /* power equals "^=" or "**=" */
+#define T_PERIOD               50      /* period "." */
+#define T_IMAGINARY            51      /* numeric imaginary constant */
+#define        T_AMPERSAND             52      /* ampersand "&" */
+#define        T_QUESTIONMARK          53      /* question mark "?" */
+
+
+/*
+ * Keyword tokens
+ */
+#define T_IF                   101     /* if keyword */
+#define T_ELSE                 102     /* else keyword */
+#define T_WHILE                        103     /* while keyword */
+#define T_CONTINUE             104     /* continue keyword */
+#define T_BREAK                        105     /* break keyword */
+#define T_GOTO                 106     /* goto keyword */
+#define T_RETURN               107     /* return keyword */
+#define T_LOCAL                        108     /* local keyword */
+#define T_GLOBAL               109     /* global keyword */
+#define        T_STATIC                110     /* static keyword */
+#define T_DO                   111     /* do keyword */
+#define T_FOR                  112     /* for keyword */
+#define T_SWITCH               113     /* switch keyword */
+#define T_CASE                 114     /* case keyword */
+#define T_DEFAULT              115     /* default keyword */
+#define T_QUIT                 116     /* quit keyword */
+#define T_DEFINE               117     /* define keyword */
+#define T_READ                 118     /* read keyword */
+#define T_SHOW                 119     /* show keyword */
+#define T_HELP                 120     /* help keyword */
+#define T_WRITE                        121     /* write keyword */
+#define T_MAT                  122     /* mat keyword */
+#define T_OBJ                  123     /* obj keyword */
+#define T_PRINT                        124     /* print keyword */
+#define T_USE                  125     /* use keyword */
+
+
+#define iskeyword(n) ((n) > 100)       /* TRUE if token is a keyword */
+
+
+/*
+ * Flags returned describing results of expression parsing.
+ */
+#define EXPR_RVALUE    0x0001          /* result is an rvalue */
+#define EXPR_CONST     0x0002          /* result is constant */
+#define EXPR_ASSIGN    0x0004          /* result is an assignment */
+
+#define isrvalue(n)    ((n) & EXPR_RVALUE)     /* TRUE if expression is rvalue */
+#define islvalue(n)    (((n) & EXPR_RVALUE) == 0)      /* TRUE if expr is lvalue */
+#define isconst(n)     ((n) & EXPR_CONST)      /* TRUE if expr is constant */
+#define isassign(n)    ((n) & EXPR_ASSIGN)     /* TRUE if expr is an assignment */
+
+
+/*
+ * Flags for modes for tokenizing.
+ */
+#define TM_DEFAULT     0x0             /* normal mode */
+#define TM_NEWLINES    0x1             /* treat any newline as a token */
+#define TM_ALLSYMS     0x2             /* treat almost everything as a symbol */
+
+
+extern long errorcount;                /* number of errors found */
+
+extern char *tokenstring MATH_PROTO((void));
+extern long tokennumber MATH_PROTO((void));
+extern void inittokens MATH_PROTO((void));
+extern int tokenmode MATH_PROTO((int flag));
+extern int gettoken MATH_PROTO((void));
+extern void rescantoken MATH_PROTO((void));
+
+#ifdef VARARGS
+extern void scanerror();
+#else
+extern void scanerror MATH_PROTO((int, char *, ...));
+#endif
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/try_stdarg.c b/usr/src/contrib/calc-2.9.3t6/try_stdarg.c
new file mode 100644 (file)
index 0000000..886eeeb
--- /dev/null
@@ -0,0 +1,66 @@
+/*
+ * try_stdarg - try <stdarg.h> to see if it really works with vsprintf()
+ *
+ * On some systems that have both <stdarg.h> and <varargs.h>, vsprintf()
+ * does not work well under one type of include file.  For example, some
+ * System V based systems (such as UMIPS) have bugs in the <stdarg.h>
+ * implementation.
+ *
+ * This program exit 1 is vsprintf() produces unexpected results
+ * while using the <stdarg.h> include file.
+ */
+/*
+ * Copyright (c) 1994 by Landon Curt Noll.  All Rights Reserved.
+ *
+ * Permission to use, copy, modify, and distribute this software and
+ * its documentation for any purpose and without fee is hereby granted,
+ * provided that the above copyright, this permission notice and text
+ * this comment, and the disclaimer below appear in all of the following:
+ *
+ *     supporting documentation
+ *     source copies
+ *     source works derived from this source
+ *     binaries derived from this source or from derived source
+ *
+ * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
+ * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO
+ * EVENT SHALL LANDON CURT NOLL BE LIABLE FOR ANY SPECIAL, INDIRECT OR
+ * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF
+ * USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+ * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+ * PERFORMANCE OF THIS SOFTWARE.
+ *
+ * chongo was here     /\../\
+ */
+
+#include <stdarg.h>
+#include <stdio.h>
+
+char buf[BUFSIZ];
+
+#if defined(__STDC__) && __STDC__ == 1
+# define VA_ALIST char *fmt, ...
+# define VA_DCL
+#else
+# define VA_ALIST fmt
+# define VA_DCL char *fmt;
+#endif
+void
+try(VA_ALIST)
+    VA_DCL
+{
+    va_list ap;
+
+    va_start(ap, fmt);
+    vsprintf(buf, fmt, ap);
+    va_end(ap);
+}
+
+main()
+{
+    try("@%d:%s:%d@", 1, "hi", 2);
+    if (strcmp(buf, "@1:hi:2@") != 0) {
+       exit(1);
+    }
+    exit(0);
+}
diff --git a/usr/src/contrib/calc-2.9.3t6/value.c b/usr/src/contrib/calc-2.9.3t6/value.c
new file mode 100644 (file)
index 0000000..6019709
--- /dev/null
@@ -0,0 +1,1401 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Generic value manipulation routines.
+ */
+
+#include "value.h"
+#include "opcodes.h"
+#include "func.h"
+#include "symbol.h"
+#include "string.h"
+
+
+/*
+ * Free a value and set its type to undefined.
+ */
+void
+freevalue(vp)
+       register VALUE *vp;     /* value to be freed */
+{
+       int type;               /* type of value being freed */
+
+       type = vp->v_type;
+       vp->v_type = V_NULL;
+       switch (type) {
+               case V_NULL:
+               case V_ADDR:
+               case V_FILE:
+                       break;
+               case V_STR:
+                       if (vp->v_subtype == V_STRALLOC)
+                               free(vp->v_str);
+                       break;
+               case V_NUM:
+                       qfree(vp->v_num);
+                       break;
+               case V_COM:
+                       comfree(vp->v_com);
+                       break;
+               case V_MAT:
+                       matfree(vp->v_mat);
+                       break;
+               case V_LIST:
+                       listfree(vp->v_list);
+                       break;
+               case V_ASSOC:
+                       assocfree(vp->v_assoc);
+                       break;
+               case V_OBJ:
+                       objfree(vp->v_obj);
+                       break;
+               default:
+                       math_error("Freeing unknown value type");
+       }
+       vp->v_subtype = V_NOSUBTYPE;
+}
+
+
+/*
+ * Copy a value from one location to another.
+ * This overwrites the specified new value without checking it.
+ */
+void
+copyvalue(oldvp, newvp)
+       register VALUE *oldvp;          /* value to be copied from */
+       register VALUE *newvp;          /* value to be copied into */
+{
+       newvp->v_type = V_NULL;
+       switch (oldvp->v_type) {
+               case V_NULL:
+                       break;
+               case V_FILE:
+                       newvp->v_file = oldvp->v_file;
+                       break;
+               case V_NUM:
+                       newvp->v_num = qlink(oldvp->v_num);
+                       break;
+               case V_COM:
+                       newvp->v_com = clink(oldvp->v_com);
+                       break;
+               case V_STR:
+                       newvp->v_str = oldvp->v_str;
+                       if (oldvp->v_subtype == V_STRALLOC) {
+                               newvp->v_str = (char *)malloc(strlen(oldvp->v_str) + 1);
+                               if (newvp->v_str == NULL)
+                                       math_error("Cannot get memory for string copy");
+                               strcpy(newvp->v_str, oldvp->v_str);
+                       }
+                       break;
+               case V_MAT:
+                       newvp->v_mat = matcopy(oldvp->v_mat);
+                       break;
+               case V_LIST:
+                       newvp->v_list = listcopy(oldvp->v_list);
+                       break;
+               case V_ASSOC:
+                       newvp->v_assoc = assoccopy(oldvp->v_assoc);
+                       break;
+               case V_ADDR:
+                       newvp->v_addr = oldvp->v_addr;
+                       break;
+               case V_OBJ:
+                       newvp->v_obj = objcopy(oldvp->v_obj);
+                       break;
+               default:
+                       math_error("Copying unknown value type");
+       }
+       if (oldvp->v_type == V_STR) {
+               newvp->v_subtype = oldvp->v_subtype;
+       } else {
+               newvp->v_subtype = V_NOSUBTYPE;
+       }
+       newvp->v_type = oldvp->v_type;
+
+}
+
+
+/*
+ * Negate an arbitrary value.
+ * Result is placed in the indicated location.
+ */
+void
+negvalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       vres->v_type = V_NULL;
+       switch (vp->v_type) {
+               case V_NUM:
+                       vres->v_num = qneg(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       vres->v_com = cneg(vp->v_com);
+                       vres->v_type = V_COM;
+                       return;
+               case V_MAT:
+                       vres->v_mat = matneg(vp->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_NEG, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for negation");
+       }
+}
+
+
+/*
+ * Add two arbitrary values together.
+ * Result is placed in the indicated location.
+ */
+void
+addvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       COMPLEX *c;
+
+       vres->v_type = V_NULL;
+       switch (TWOVAL(v1->v_type, v2->v_type)) {
+               case TWOVAL(V_NUM, V_NUM):
+                       vres->v_num = qadd(v1->v_num, v2->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case TWOVAL(V_COM, V_NUM):
+                       vres->v_com = caddq(v1->v_com, v2->v_num);
+                       vres->v_type = V_COM;
+                       return;
+               case TWOVAL(V_NUM, V_COM):
+                       vres->v_com = caddq(v2->v_com, v1->v_num);
+                       vres->v_type = V_COM;
+                       return;
+               case TWOVAL(V_COM, V_COM):
+                       vres->v_com = cadd(v1->v_com, v2->v_com);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (!cisreal(c))
+                               return;
+                       vres->v_num = qlink(c->real);
+                       vres->v_type = V_NUM;
+                       comfree(c);
+                       return;
+               case TWOVAL(V_MAT, V_MAT):
+                       vres->v_mat = matadd(v1->v_mat, v2->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               default:
+                       if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
+                               math_error("Non-compatible values for add");
+                       *vres = objcall(OBJ_ADD, v1, v2, NULL_VALUE);
+                       return;
+       }
+}
+
+
+/*
+ * Subtract one arbitrary value from another one.
+ * Result is placed in the indicated location.
+ */
+void
+subvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       COMPLEX *c;
+
+       vres->v_type = V_NULL;
+       switch (TWOVAL(v1->v_type, v2->v_type)) {
+               case TWOVAL(V_NUM, V_NUM):
+                       vres->v_num = qsub(v1->v_num, v2->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case TWOVAL(V_COM, V_NUM):
+                       vres->v_com = csubq(v1->v_com, v2->v_num);
+                       vres->v_type = V_COM;
+                       return;
+               case TWOVAL(V_NUM, V_COM):
+                       c = csubq(v2->v_com, v1->v_num);
+                       vres->v_com = cneg(c);
+                       comfree(c);
+                       vres->v_type = V_COM;
+                       return;
+               case TWOVAL(V_COM, V_COM):
+                       vres->v_com = csub(v1->v_com, v2->v_com);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (!cisreal(c))
+                               return;
+                       vres->v_num = qlink(c->real);
+                       vres->v_type = V_NUM;
+                       comfree(c);
+                       return;
+               case TWOVAL(V_MAT, V_MAT):
+                       vres->v_mat = matsub(v1->v_mat, v2->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               default:
+                       if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
+                               math_error("Non-compatible values for subtract");
+                       *vres = objcall(OBJ_SUB, v1, v2, NULL_VALUE);
+                       return;
+       }
+}
+
+
+/*
+ * Multiply two arbitrary values together.
+ * Result is placed in the indicated location.
+ */
+void
+mulvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       COMPLEX *c;
+
+       vres->v_type = V_NULL;
+       switch (TWOVAL(v1->v_type, v2->v_type)) {
+               case TWOVAL(V_NUM, V_NUM):
+                       vres->v_num = qmul(v1->v_num, v2->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case TWOVAL(V_COM, V_NUM):
+                       vres->v_com = cmulq(v1->v_com, v2->v_num);
+                       vres->v_type = V_COM;
+                       break;
+               case TWOVAL(V_NUM, V_COM):
+                       vres->v_com = cmulq(v2->v_com, v1->v_num);
+                       vres->v_type = V_COM;
+                       break;
+               case TWOVAL(V_COM, V_COM):
+                       vres->v_com = cmul(v1->v_com, v2->v_com);
+                       vres->v_type = V_COM;
+                       break;
+               case TWOVAL(V_MAT, V_MAT):
+                       vres->v_mat = matmul(v1->v_mat, v2->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               case TWOVAL(V_MAT, V_NUM):
+               case TWOVAL(V_MAT, V_COM):
+                       vres->v_mat = matmulval(v1->v_mat, v2);
+                       vres->v_type = V_MAT;
+                       return;
+               case TWOVAL(V_NUM, V_MAT):
+               case TWOVAL(V_COM, V_MAT):
+                       vres->v_mat = matmulval(v2->v_mat, v1);
+                       vres->v_type = V_MAT;
+                       return;
+               default:
+                       if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
+                               math_error("Non-compatible values for multiply");
+                       *vres = objcall(OBJ_MUL, v1, v2, NULL_VALUE);
+                       return;
+       }
+       c = vres->v_com;
+       if (cisreal(c)) {
+               vres->v_num = qlink(c->real);
+               vres->v_type = V_NUM;
+               comfree(c);
+       }
+}
+
+
+/*
+ * Square an arbitrary value.
+ * Result is placed in the indicated location.
+ */
+void
+squarevalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       COMPLEX *c;
+
+       vres->v_type = V_NULL;
+       switch (vp->v_type) {
+               case V_NUM:
+                       vres->v_num = qsquare(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       vres->v_com = csquare(vp->v_com);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (!cisreal(c))
+                               return;
+                       vres->v_num = qlink(c->real);
+                       vres->v_type = V_NUM;
+                       comfree(c);
+                       return;
+               case V_MAT:
+                       vres->v_mat = matsquare(vp->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for squaring");
+       }
+}
+
+
+/*
+ * Invert an arbitrary value.
+ * Result is placed in the indicated location.
+ */
+void
+invertvalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       vres->v_type = V_NULL;
+       switch (vp->v_type) {
+               case V_NUM:
+                       vres->v_num = qinv(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       vres->v_com = cinv(vp->v_com);
+                       vres->v_type = V_COM;
+                       return;
+               case V_MAT:
+                       vres->v_mat = matinv(vp->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for inverting");
+       }
+}
+
+
+/*
+ * Round an arbitrary value to the specified number of decimal places.
+ * Result is placed in the indicated location.
+ */
+void
+roundvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       long places = -1;
+       NUMBER *q;
+       COMPLEX *c;
+
+       switch (v2->v_type) {
+               case V_NUM:
+                       q = v2->v_num;
+                       if (qisfrac(q) || zisbig(q->num))
+                               math_error("Bad number of places for round");
+                       places = qtoi(q);
+                       break;
+               case V_INT:
+                       places = v2->v_int;
+                       break;
+               default:
+                       math_error("Bad value type for places in round");
+       }
+       if (places < 0)
+               math_error("Negative number of places in round");
+       vres->v_type = V_NULL;
+       switch (v1->v_type) {
+               case V_NUM:
+                       if (qisint(v1->v_num))
+                               vres->v_num = qlink(v1->v_num);
+                       else
+                               vres->v_num = qround(v1->v_num, places);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       if (cisint(v1->v_com)) {
+                               vres->v_com = clink(v1->v_com);
+                               vres->v_type = V_COM;
+                               return;
+                       }
+                       vres->v_com = cround(v1->v_com, places);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (cisreal(c)) {
+                               vres->v_num = qlink(c->real);
+                               vres->v_type = V_NUM;
+                               comfree(c);
+                       }
+                       return;
+               case V_MAT:
+                       vres->v_mat = matround(v1->v_mat, places);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_ROUND, v1, v2, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for round");
+       }
+}
+
+
+/*
+ * Round an arbitrary value to the specified number of binary places.
+ * Result is placed in the indicated location.
+ */
+void
+broundvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       long places = -1;
+       NUMBER *q;
+       COMPLEX *c;
+
+       switch (v2->v_type) {
+               case V_NUM:
+                       q = v2->v_num;
+                       if (qisfrac(q) || zisbig(q->num))
+                               math_error("Bad number of places for bround");
+                       places = qtoi(q);
+                       break;
+               case V_INT:
+                       places = v2->v_int;
+                       break;
+               default:
+                       math_error("Bad value type for places in bround");
+       }
+       if (places < 0)
+               math_error("Negative number of places in bround");
+       vres->v_type = V_NULL;
+       switch (v1->v_type) {
+               case V_NUM:
+                       if (qisint(v1->v_num))
+                               vres->v_num = qlink(v1->v_num);
+                       else
+                               vres->v_num = qbround(v1->v_num, places);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       if (cisint(v1->v_com)) {
+                               vres->v_com = clink(v1->v_com);
+                               vres->v_type = V_COM;
+                               return;
+                       }
+                       vres->v_com = cbround(v1->v_com, places);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (cisreal(c)) {
+                               vres->v_num = qlink(c->real);
+                               vres->v_type = V_NUM;
+                               comfree(c);
+                       }
+                       return;
+               case V_MAT:
+                       vres->v_mat = matbround(v1->v_mat, places);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_BROUND, v1, v2, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for bround");
+       }
+}
+
+
+/*
+ * Take the integer part of an arbitrary value.
+ * Result is placed in the indicated location.
+ */
+void
+intvalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       COMPLEX *c;
+
+       vres->v_type = V_NULL;
+       switch (vp->v_type) {
+               case V_NUM:
+                       if (qisint(vp->v_num))
+                               vres->v_num = qlink(vp->v_num);
+                       else
+                               vres->v_num = qint(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       if (cisint(vp->v_com)) {
+                               vres->v_com = clink(vp->v_com);
+                               vres->v_type = V_COM;
+                               return;
+                       }
+                       vres->v_com = cint(vp->v_com);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (cisreal(c)) {
+                               vres->v_num = qlink(c->real);
+                               vres->v_type = V_NUM;
+                               comfree(c);
+                       }
+                       return;
+               case V_MAT:
+                       vres->v_mat = matint(vp->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_INT, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for int");
+       }
+}
+
+
+/*
+ * Take the fractional part of an arbitrary value.
+ * Result is placed in the indicated location.
+ */
+void
+fracvalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       vres->v_type = V_NULL;
+       switch (vp->v_type) {
+               case V_NUM:
+                       if (qisint(vp->v_num))
+                               vres->v_num = qlink(&_qzero_);
+                       else
+                               vres->v_num = qfrac(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       if (cisint(vp->v_com)) {
+                               vres->v_num = clink(&_qzero_);
+                               vres->v_type = V_NUM;
+                               return;
+                       }
+                       vres->v_com = cfrac(vp->v_com);
+                       vres->v_type = V_COM;
+                       return;
+               case V_MAT:
+                       vres->v_mat = matfrac(vp->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_FRAC, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for frac function");
+       }
+}
+
+
+/*
+ * Increment an arbitrary value by one.
+ * Result is placed in the indicated location.
+ */
+void
+incvalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       switch (vp->v_type) {
+               case V_NUM:
+                       vres->v_num = qinc(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       vres->v_com = caddq(vp->v_com, &_qone_);
+                       vres->v_type = V_COM;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_INC, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for incrementing");
+       }
+}
+
+
+/*
+ * Decrement an arbitrary value by one.
+ * Result is placed in the indicated location.
+ */
+void
+decvalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       switch (vp->v_type) {
+               case V_NUM:
+                       vres->v_num = qdec(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       vres->v_com = caddq(vp->v_com, &_qnegone_);
+                       vres->v_type = V_COM;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_DEC, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for decrementing");
+       }
+}
+
+
+/*
+ * Produce the 'conjugate' of an arbitrary value.
+ * Result is placed in the indicated location.
+ * (Example: complex conjugate.)
+ */
+void
+conjvalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       vres->v_type = V_NULL;
+       switch (vp->v_type) {
+               case V_NUM:
+                       vres->v_num = qlink(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       vres->v_com = comalloc();
+                       vres->v_com->real = qlink(vp->v_com->real);
+                       vres->v_com->imag = qneg(vp->v_com->imag);
+                       vres->v_type = V_COM;
+                       return;
+               case V_MAT:
+                       vres->v_mat = matconj(vp->v_mat);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_CONJ, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for conjugation");
+       }
+}
+
+
+/*
+ * Take the square root of an arbitrary value within the specified error.
+ * Result is placed in the indicated location.
+ */
+void
+sqrtvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       NUMBER *q, *tmp;
+       COMPLEX *c;
+
+       if (v2->v_type != V_NUM)
+               math_error("Non-real epsilon for sqrt");
+       q = v2->v_num;
+       if (qisneg(q) || qiszero(q))
+               math_error("Illegal epsilon value for sqrt");
+       switch (v1->v_type) {
+               case V_NUM:
+                       if (!qisneg(v1->v_num)) {
+                               vres->v_num = qsqrt(v1->v_num, q);
+                               vres->v_type = V_NUM;
+                               return;
+                       }
+                       tmp = qneg(v1->v_num);
+                       c = comalloc();
+                       c->imag = qsqrt(tmp, q);
+                       qfree(tmp);
+                       vres->v_com = c;
+                       vres->v_type = V_COM;
+                       break;
+               case V_COM:
+                       vres->v_com = csqrt(v1->v_com, q);
+                       vres->v_type = V_COM;
+                       break;
+               case V_OBJ:
+                       *vres = objcall(OBJ_SQRT, v1, v2, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Bad value for taking square root");
+       }
+       c = vres->v_com;
+       if (cisreal(c)) {
+               vres->v_num = qlink(c->real);
+               vres->v_type = V_NUM;
+               comfree(c);
+       }
+}
+
+
+/*
+ * Take the Nth root of an arbitrary value within the specified error.
+ * Result is placed in the indicated location.
+ */
+void
+rootvalue(v1, v2, v3, vres)
+       VALUE *v1;              /* value to take root of */
+       VALUE *v2;              /* value specifying root to take */
+       VALUE *v3;              /* value specifying error */
+       VALUE *vres;
+{
+       NUMBER *q1, *q2;
+       COMPLEX ctmp;
+
+       if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
+               math_error("Non-real arguments for root");
+       q1 = v2->v_num;
+       q2 = v3->v_num;
+       if (qisneg(q1) || qiszero(q1) || qisfrac(q1))
+               math_error("Non-positive or non-integral root");
+       if (qisneg(q2) || qiszero(q2))
+               math_error("Non-positive epsilon for root");
+       switch (v1->v_type) {
+               case V_NUM:
+                       if (!qisneg(v1->v_num) || zisodd(q1->num)) {
+                               vres->v_num = qroot(v1->v_num, q1, q2);
+                               vres->v_type = V_NUM;
+                               return;
+                       }
+                       ctmp.real = v1->v_num;
+                       ctmp.imag = &_qzero_;
+                       ctmp.links = 1;
+                       vres->v_com = croot(&ctmp, q1, q2);
+                       vres->v_type = V_COM;
+                       return;
+               case V_COM:
+                       vres->v_com = croot(v1->v_com, q1, q2);
+                       vres->v_type = V_COM;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_ROOT, v1, v2, v3);
+                       return;
+               default:
+                       math_error("Taking root of bad value");
+       }
+}
+
+
+/*
+ * Take the absolute value of an arbitrary value within the specified error.
+ * Result is placed in the indicated location.
+ */
+void
+absvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       static NUMBER *q;
+       NUMBER *epsilon;
+
+       if (v2->v_type != V_NUM)
+               math_error("Bad epsilon type for abs");
+       epsilon = v2->v_num;
+       if (qiszero(epsilon) || qisneg(epsilon))
+               math_error("Non-positive epsilon for abs");
+       switch (v1->v_type) {
+               case V_NUM:
+                       if (qisneg(v1->v_num))
+                               q = qneg(v1->v_num);
+                       else
+                               q = qlink(v1->v_num);
+                       break;
+               case V_COM:
+                       q = qhypot(v1->v_com->real, v1->v_com->imag, epsilon);
+                       break;
+               case V_OBJ:
+                       *vres = objcall(OBJ_ABS, v1, v2, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for absolute value");
+       }
+       vres->v_num = q;
+       vres->v_type = V_NUM;
+}
+
+
+/*
+ * Calculate the norm of an arbitrary value.
+ * Result is placed in the indicated location.
+ * The norm is the square of the absolute value.
+ */
+void
+normvalue(vp, vres)
+       VALUE *vp, *vres;
+{
+       NUMBER *q1, *q2;
+
+       vres->v_type = V_NULL;
+       switch (vp->v_type) {
+               case V_NUM:
+                       vres->v_num = qsquare(vp->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       q1 = qsquare(vp->v_com->real);
+                       q2 = qsquare(vp->v_com->imag);
+                       vres->v_num = qadd(q1, q2);
+                       vres->v_type = V_NUM;
+                       qfree(q1);
+                       qfree(q2);
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_NORM, vp, NULL_VALUE, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for norm");
+       }
+}
+
+
+/*
+ * Shift a value left or right by the specified number of bits.
+ * Negative shift value means shift the direction opposite the selected dir.
+ * Right shifts are defined to lose bits off the low end of the number.
+ * Result is placed in the indicated location.
+ */
+void
+shiftvalue(v1, v2, rightshift, vres)
+       VALUE *v1, *v2, *vres;
+       BOOL rightshift;        /* TRUE if shift right instead of left */
+{
+       COMPLEX *c;
+       long n = 0;
+       VALUE tmp;
+
+       if (v2->v_type != V_NUM)
+               math_error("Non-real shift value");
+       if (qisfrac(v2->v_num))
+               math_error("Non-integral shift value");
+       if (v1->v_type != V_OBJ) {
+               if (zisbig(v2->v_num->num))
+                       math_error("Very large shift value");
+               n = qtoi(v2->v_num);
+       }
+       if (rightshift)
+               n = -n;
+       switch (v1->v_type) {
+               case V_NUM:
+                       vres->v_num = qshift(v1->v_num, n);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       c = cshift(v1->v_com, n);
+                       if (!cisreal(c)) {
+                               vres->v_com = c;
+                               vres->v_type = V_COM;
+                               return;
+                       }
+                       vres->v_num = qlink(c->real);
+                       vres->v_type = V_NUM;
+                       comfree(c);
+                       return;
+               case V_MAT:
+                       vres->v_mat = matshift(v1->v_mat, n);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       if (!rightshift) {
+                               *vres = objcall(OBJ_SHIFT, v1, v2, NULL_VALUE);
+                               return;
+                       }
+                       tmp.v_num = qneg(v2->v_num);
+                       tmp.v_type = V_NUM;
+                       *vres = objcall(OBJ_SHIFT, v1, &tmp, NULL_VALUE);
+                       qfree(tmp.v_num);
+                       return;
+               default:
+                       math_error("Bad value for shifting");
+       }
+}
+
+
+/*
+ * Scale a value by a power of two.
+ * Result is placed in the indicated location.
+ */
+void
+scalevalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       long n = 0;
+
+       if (v2->v_type != V_NUM)
+               math_error("Non-real scaling factor");
+       if (qisfrac(v2->v_num))
+               math_error("Non-integral scaling factor");
+       if (v1->v_type != V_OBJ) {
+               if (zisbig(v2->v_num->num))
+                       math_error("Very large scaling factor");
+               n = qtoi(v2->v_num);
+       }
+       switch (v1->v_type) {
+               case V_NUM:
+                       vres->v_num = qscale(v1->v_num, n);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       vres->v_com = cscale(v1->v_com, n);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_MAT:
+                       vres->v_mat = matscale(v1->v_mat, n);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_SCALE, v1, v2, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Bad value for scaling");
+       }
+}
+
+
+/*
+ * Raise a value to an integral power.
+ * Result is placed in the indicated location.
+ */
+void
+powivalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       NUMBER *q;
+       COMPLEX *c;
+
+       vres->v_type = V_NULL;
+       if (v2->v_type != V_NUM)
+               math_error("Raising value to non-real power");
+       q = v2->v_num;
+       if (qisfrac(q))
+               math_error("Raising value to non-integral power");
+       switch (v1->v_type) {
+               case V_NUM:
+                       vres->v_num = qpowi(v1->v_num, q);
+                       vres->v_type = V_NUM;
+                       return;
+               case V_COM:
+                       vres->v_com = cpowi(v1->v_com, q);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (!cisreal(c))
+                               return;
+                       vres->v_num = qlink(c->real);
+                       vres->v_type = V_NUM;
+                       comfree(c);
+                       return;
+               case V_MAT:
+                       vres->v_mat = matpowi(v1->v_mat, q);
+                       vres->v_type = V_MAT;
+                       return;
+               case V_OBJ:
+                       *vres = objcall(OBJ_POW, v1, v2, NULL_VALUE);
+                       return;
+               default:
+                       math_error("Illegal value for raising to integer power");
+       }
+}
+
+
+/*
+ * Raise one value to another value's power, within the specified error.
+ * Result is placed in the indicated location.
+ */
+void
+powervalue(v1, v2, v3, vres)
+       VALUE *v1, *v2, *v3, *vres;
+{
+       NUMBER *epsilon;
+       COMPLEX *c, ctmp;
+
+       vres->v_type = V_NULL;
+       if (v3->v_type != V_NUM)
+               math_error("Non-real epsilon value for power");
+       epsilon = v3->v_num;
+       if (qisneg(epsilon) || qiszero(epsilon))
+               math_error("Non-positive epsilon value for power");
+       switch (TWOVAL(v1->v_type, v2->v_type)) {
+               case TWOVAL(V_NUM, V_NUM):
+                       vres->v_num = qpower(v1->v_num, v2->v_num, epsilon);
+                       vres->v_type = V_NUM;
+                       return;
+               case TWOVAL(V_NUM, V_COM):
+                       ctmp.real = v1->v_num;
+                       ctmp.imag = &_qzero_;
+                       ctmp.links = 1;
+                       vres->v_com = cpower(&ctmp, v2->v_com, epsilon);
+                       break;
+               case TWOVAL(V_COM, V_NUM):
+                       ctmp.real = v2->v_num;
+                       ctmp.imag = &_qzero_;
+                       ctmp.links = 1;
+                       vres->v_com = cpower(v1->v_com, &ctmp, epsilon);
+                       break;
+               case TWOVAL(V_COM, V_COM):
+                       vres->v_com = cpower(v1->v_com, v2->v_com, epsilon);
+                       break;
+               default:
+                       math_error("Illegal value for raising to power");
+       }
+       /*
+        * Here for any complex result.
+        */
+       vres->v_type = V_COM;
+       c = vres->v_com;
+       if (!cisreal(c))
+               return;
+       vres->v_num = qlink(c->real);
+       vres->v_type = V_NUM;
+       comfree(c);
+}
+
+
+/*
+ * Divide one arbitrary value by another one.
+ * Result is placed in the indicated location.
+ */
+void
+divvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       COMPLEX *c;
+       COMPLEX ctmp;
+       VALUE tmpval;
+
+       vres->v_type = V_NULL;
+       switch (TWOVAL(v1->v_type, v2->v_type)) {
+               case TWOVAL(V_NUM, V_NUM):
+                       vres->v_num = qdiv(v1->v_num, v2->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case TWOVAL(V_COM, V_NUM):
+                       vres->v_com = cdivq(v1->v_com, v2->v_num);
+                       vres->v_type = V_COM;
+                       return;
+               case TWOVAL(V_NUM, V_COM):
+                       if (qiszero(v1->v_num)) {
+                               vres->v_num = qlink(&_qzero_);
+                               vres->v_type = V_NUM;
+                               return;
+                       }
+                       ctmp.real = v1->v_num;
+                       ctmp.imag = &_qzero_;
+                       ctmp.links = 1;
+                       vres->v_com = cdiv(&ctmp, v2->v_com);
+                       vres->v_type = V_COM;
+                       return;
+               case TWOVAL(V_COM, V_COM):
+                       vres->v_com = cdiv(v1->v_com, v2->v_com);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (cisreal(c)) {
+                               vres->v_num = qlink(c->real);
+                               vres->v_type = V_NUM;
+                               comfree(c);
+                       }
+                       return;
+               case TWOVAL(V_MAT, V_NUM):
+               case TWOVAL(V_MAT, V_COM):
+                       invertvalue(v2, &tmpval);
+                       vres->v_mat = matmulval(v1->v_mat, &tmpval);
+                       vres->v_type = V_MAT;
+                       freevalue(&tmpval);
+                       return;
+               default:
+                       if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
+                               math_error("Non-compatible values for divide");
+                       *vres = objcall(OBJ_DIV, v1, v2, NULL_VALUE);
+                       return;
+       }
+}
+
+
+/*
+ * Divide one arbitrary value by another one keeping only the integer part.
+ * Result is placed in the indicated location.
+ */
+void
+quovalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       COMPLEX *c;
+
+       vres->v_type = V_NULL;
+       switch (TWOVAL(v1->v_type, v2->v_type)) {
+               case TWOVAL(V_NUM, V_NUM):
+                       vres->v_num = qquo(v1->v_num, v2->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case TWOVAL(V_COM, V_NUM):
+                       vres->v_com = cquoq(v1->v_com, v2->v_num);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (cisreal(c)) {
+                               vres->v_num = qlink(c->real);
+                               vres->v_type = V_NUM;
+                               comfree(c);
+                       }
+                       return;
+               case TWOVAL(V_MAT, V_NUM):
+               case TWOVAL(V_MAT, V_COM):
+                       vres->v_mat = matquoval(v1->v_mat, v2);
+                       vres->v_type = V_MAT;
+                       return;
+               default:
+                       if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
+                               math_error("Non-compatible values for quotient");
+                       *vres = objcall(OBJ_QUO, v1, v2, NULL_VALUE);
+                       return;
+       }
+}
+
+
+/*
+ * Divide one arbitrary value by another one keeping only the remainder.
+ * Result is placed in the indicated location.
+ */
+void
+modvalue(v1, v2, vres)
+       VALUE *v1, *v2, *vres;
+{
+       COMPLEX *c;
+
+       vres->v_type = V_NULL;
+       switch (TWOVAL(v1->v_type, v2->v_type)) {
+               case TWOVAL(V_NUM, V_NUM):
+                       vres->v_num = qmod(v1->v_num, v2->v_num);
+                       vres->v_type = V_NUM;
+                       return;
+               case TWOVAL(V_COM, V_NUM):
+                       vres->v_com = cmodq(v1->v_com, v2->v_num);
+                       vres->v_type = V_COM;
+                       c = vres->v_com;
+                       if (cisreal(c)) {
+                               vres->v_num = qlink(c->real);
+                               vres->v_type = V_NUM;
+                               comfree(c);
+                       }
+                       return;
+               case TWOVAL(V_MAT, V_NUM):
+               case TWOVAL(V_MAT, V_COM):
+                       vres->v_mat = matmodval(v1->v_mat, v2);
+                       vres->v_type = V_MAT;
+                       return;
+               default:
+                       if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
+                               math_error("Non-compatible values for mod");
+                       *vres = objcall(OBJ_MOD, v1, v2, NULL_VALUE);
+                       return;
+       }
+}
+
+
+/*
+ * Test an arbitrary value to see if it is equal to "zero".
+ * The definition of zero varies depending on the value type.  For example,
+ * the null string is "zero", and a matrix with zero values is "zero".
+ * Returns TRUE if value is not equal to zero.
+ */
+BOOL
+testvalue(vp)
+       VALUE *vp;
+{
+       VALUE val;
+
+       switch (vp->v_type) {
+               case V_NUM:
+                       return !qiszero(vp->v_num);
+               case V_COM:
+                       return !ciszero(vp->v_com);
+               case V_STR:
+                       return (vp->v_str[0] != '\0');
+               case V_MAT:
+                       return mattest(vp->v_mat);
+               case V_LIST:
+                       return (vp->v_list->l_count != 0);
+               case V_ASSOC:
+                       return (vp->v_assoc->a_count != 0);
+               case V_FILE:
+                       return validid(vp->v_file);
+               case V_NULL:
+                       return FALSE;
+               case V_OBJ:
+                       val = objcall(OBJ_TEST, vp, NULL_VALUE, NULL_VALUE);
+                       return (val.v_int != 0);
+               default:
+                       return TRUE;
+       }
+}
+
+
+/*
+ * Compare two values for equality.
+ * Returns TRUE if the two values differ.
+ */
+BOOL
+comparevalue(v1, v2)
+       VALUE *v1, *v2;
+{
+       int r = FALSE;
+       VALUE val;
+
+       if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
+               val = objcall(OBJ_CMP, v1, v2, NULL_VALUE);
+               return (val.v_int != 0);
+       }
+       if (v1 == v2)
+               return FALSE;
+       if (v1->v_type != v2->v_type)
+               return TRUE;
+       switch (v1->v_type) {
+               case V_NUM:
+                       r = qcmp(v1->v_num, v2->v_num);
+                       break;
+               case V_COM:
+                       r = ccmp(v1->v_com, v2->v_com);
+                       break;
+               case V_STR:
+                       r = ((v1->v_str != v2->v_str) &&
+                               ((v1->v_str[0] - v2->v_str[0]) ||
+                               strcmp(v1->v_str, v2->v_str)));
+                       break;
+               case V_MAT:
+                       r = matcmp(v1->v_mat, v2->v_mat);
+                       break;
+               case V_LIST:
+                       r = listcmp(v1->v_list, v2->v_list);
+                       break;
+               case V_ASSOC:
+                       r = assoccmp(v1->v_assoc, v2->v_assoc);
+                       break;
+               case V_NULL:
+                       break;
+               case V_FILE:
+                       r = (v1->v_file != v2->v_file);
+                       break;
+               default:
+                       math_error("Illegal values for comparevalue");
+       }
+       return (r != 0);
+}
+
+
+/*
+ * Compare two values for their relative values.
+ * Returns minus one if the first value is less than the second one,
+ * one if the first value is greater than the second one, and
+ * zero if they are equal.
+ */
+FLAG
+relvalue(v1, v2)
+       VALUE *v1, *v2;
+{
+       int r = 0;
+       VALUE val;
+
+       if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
+               val = objcall(OBJ_REL, v1, v2, NULL_VALUE);
+               return val.v_int;
+       }
+       if (v1 == v2)
+               return 0;
+       if (v1->v_type != v2->v_type)
+               math_error("Relative comparison of differing types");
+       switch (v1->v_type) {
+               case V_NUM:
+                       r = qrel(v1->v_num, v2->v_num);
+                       break;
+               case V_STR:
+                       r = strcmp(v1->v_str, v2->v_str);
+                       break;
+               case V_NULL:
+                       break;
+               default:
+                       math_error("Illegal value for relative comparison");
+       }
+       if (r < 0)
+               return -1;
+       return (r != 0);
+}
+
+
+/*
+ * Calculate a hash value for a value.
+ * The hash does not have to be a perfect one, it is only used for
+ * making associations faster.
+ */
+HASH
+hashvalue(vp)
+       VALUE *vp;
+{
+       switch (vp->v_type) {
+               case V_INT:
+                       return ((long) vp->v_int);
+               case V_NUM:
+                       return qhash(vp->v_num);
+               case V_COM:
+                       return chash(vp->v_com);
+               case V_STR:
+                       return hashstr(vp->v_str);
+               case V_NULL:
+                       return 0;
+               case V_OBJ:
+                       return objhash(vp->v_obj);
+               case V_LIST:
+                       return listhash(vp->v_list);
+               case V_ASSOC:
+                       return assochash(vp->v_assoc);
+               case V_MAT:
+                       return mathash(vp->v_mat);
+               case V_FILE:
+                       return ((long) vp->v_file);
+               default:
+                       math_error("Hashing unknown value");
+       }
+       return 0;
+}
+
+
+/*
+ * Print the value of a descriptor in one of several formats.
+ * If flags contains PRINT_SHORT, then elements of arrays and lists
+ * will not be printed.  If flags contains PRINT_UNAMBIG, then quotes
+ * are placed around strings and the null value is explicitly printed.
+ */
+void
+printvalue(vp, flags)
+       VALUE *vp;
+       int flags;
+{
+       switch (vp->v_type) {
+               case V_NUM:
+                       qprintnum(vp->v_num, MODE_DEFAULT);
+                       break;
+               case V_COM:
+                       comprint(vp->v_com);
+                       break;
+               case V_STR:
+                       if (flags & PRINT_UNAMBIG)
+                               math_chr('\"');
+                       math_str(vp->v_str);
+                       if (flags & PRINT_UNAMBIG)
+                               math_chr('\"');
+                       break;
+               case V_NULL:
+                       if (flags & PRINT_UNAMBIG)
+                               math_str("NULL");
+                       break;
+               case V_OBJ:
+                       (void) objcall(OBJ_PRINT, vp, NULL_VALUE, NULL_VALUE);
+                       break;
+               case V_LIST:
+                       listprint(vp->v_list,
+                               ((flags & PRINT_SHORT) ? 0L : maxprint));
+                       break;
+               case V_ASSOC:
+                       assocprint(vp->v_assoc,
+                               ((flags & PRINT_SHORT) ? 0L : maxprint));
+                       break;
+               case V_MAT:
+                       matprint(vp->v_mat,
+                               ((flags & PRINT_SHORT) ? 0L : maxprint));
+                       break;
+               case V_FILE:
+                       printid(vp->v_file, flags);
+                       break;
+               default:
+                       math_error("Printing unknown value");
+       }
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/value.h b/usr/src/contrib/calc-2.9.3t6/value.h
new file mode 100644 (file)
index 0000000..64aa985
--- /dev/null
@@ -0,0 +1,346 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Definitions of general values and related routines used by the calculator.
+ */
+
+#ifndef        VALUE_H
+#define        VALUE_H
+
+#include "cmath.h"
+
+
+#define MAXDIM         4       /* maximum number of dimensions in matrices */
+#define USUAL_ELEMENTS 4       /* usual number of elements for objects */
+
+
+/*
+ * Flags to modify results from the printvalue routine.
+ * These flags are OR'd together.
+ */
+#define        PRINT_NORMAL    0x00    /* print in normal manner */
+#define        PRINT_SHORT     0x01    /* print in short format (no elements) */
+#define        PRINT_UNAMBIG   0x02    /* print in non-ambiguous manner */
+
+
+/*
+ * Definition of values of various types.
+ */
+typedef struct value VALUE;
+typedef struct object OBJECT;
+typedef struct matrix MATRIX;
+typedef struct list LIST;
+typedef        struct assoc ASSOC;
+typedef        long FILEID;
+
+
+struct value {
+       short v_type;                   /* type of value */
+       short v_subtype;                /* other data related to some types */
+       union {
+               long vv_int;            /* small integer value */
+               FILEID vv_file;         /* id of opened file */
+               NUMBER *vv_num;         /* arbitrary sized numeric value */
+               COMPLEX *vv_com;        /* complex number */
+               VALUE *vv_addr;         /* address of variable value */
+               MATRIX *vv_mat;         /* address of matrix */
+               LIST *vv_list;          /* address of list */
+               ASSOC *vv_assoc;        /* address of association */
+               OBJECT *vv_obj;         /* address of object */
+               char *vv_str;           /* string value */
+       } v_union;
+};
+
+
+/*
+ * For ease in referencing
+ */
+#define v_int  v_union.vv_int
+#define        v_file  v_union.vv_file
+#define v_num  v_union.vv_num
+#define v_com  v_union.vv_com
+#define v_addr v_union.vv_addr
+#define v_str  v_union.vv_str
+#define v_mat  v_union.vv_mat
+#define        v_list  v_union.vv_list
+#define        v_assoc v_union.vv_assoc
+#define v_obj  v_union.vv_obj
+#define        v_valid v_union.vv_int
+
+
+/*
+ * Value types.
+ */
+#define V_NULL 0       /* null value */
+#define V_INT  1       /* normal integer */
+#define V_NUM  2       /* number */
+#define V_COM  3       /* complex number */
+#define V_ADDR 4       /* address of variable value */
+#define V_STR  5       /* address of string */
+#define V_MAT  6       /* address of matrix structure */
+#define        V_LIST  7       /* address of list structure */
+#define        V_ASSOC 8       /* address of association structure */
+#define V_OBJ  9       /* address of object structure */
+#define        V_FILE  10      /* opened file id */
+#define V_MAX  10      /* highest legal value */
+
+#define V_NOSUBTYPE    0       /* subtype has no meaning */
+#define V_STRLITERAL   1       /* string subtype for literal str */
+#define V_STRALLOC     2       /* string subtype for allocated str */
+
+#define TWOVAL(a,b) ((a) * (V_MAX+1) + (b))    /* for switch of two values */
+
+#define        NULL_VALUE      ((VALUE *) 0)
+
+
+extern void freevalue MATH_PROTO((VALUE *vp));
+extern void copyvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void negvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void addvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void subvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void mulvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void squarevalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void invertvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void roundvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void broundvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void intvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void fracvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void incvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void decvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void conjvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void sqrtvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void rootvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *v3,
+       VALUE *vres));
+extern void absvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void normvalue MATH_PROTO((VALUE *vp, VALUE *vres));
+extern void shiftvalue MATH_PROTO((VALUE *v1, VALUE *v2, BOOL rightshift,
+       VALUE *vres));
+extern void scalevalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void powivalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void powervalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *v3,
+       VALUE *vres));
+extern void divvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void quovalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern void modvalue MATH_PROTO((VALUE *v1, VALUE *v2, VALUE *vres));
+extern BOOL testvalue MATH_PROTO((VALUE *vp));
+extern BOOL comparevalue MATH_PROTO((VALUE *v1, VALUE *v2));
+extern FLAG relvalue MATH_PROTO((VALUE *v1, VALUE *v2));
+extern HASH hashvalue MATH_PROTO((VALUE *vp));
+extern void printvalue MATH_PROTO((VALUE *vp, int flags));
+
+
+
+/*
+ * Structure of a matrix.
+ */
+struct matrix {
+       long m_dim;             /* dimension of matrix */
+       long m_size;            /* total number of elements */
+       long m_min[MAXDIM];     /* minimum bound for indices */
+       long m_max[MAXDIM];     /* maximum bound for indices */
+       VALUE m_table[1];       /* actually varying length table */
+};
+
+#define matsize(n) (sizeof(MATRIX) - sizeof(VALUE) + ((n) * sizeof(VALUE)))
+
+
+extern MATRIX *matadd MATH_PROTO((MATRIX *m1, MATRIX *m2));
+extern MATRIX *matsub MATH_PROTO((MATRIX *m1, MATRIX *m2));
+extern MATRIX *matmul MATH_PROTO((MATRIX *m1, MATRIX *m2));
+extern MATRIX *matneg MATH_PROTO((MATRIX *m));
+extern MATRIX *matalloc MATH_PROTO((long size));
+extern MATRIX *matcopy MATH_PROTO((MATRIX *m));
+extern MATRIX *matsquare MATH_PROTO((MATRIX *m));
+extern MATRIX *matinv MATH_PROTO((MATRIX *m));
+extern MATRIX *matscale MATH_PROTO((MATRIX *m, long n));
+extern MATRIX *matshift MATH_PROTO((MATRIX *m, long n));
+extern MATRIX *matmulval MATH_PROTO((MATRIX *m, VALUE *vp));
+extern MATRIX *matpowi MATH_PROTO((MATRIX *m, NUMBER *q));
+extern MATRIX *matconj MATH_PROTO((MATRIX *m));
+extern MATRIX *matquoval MATH_PROTO((MATRIX *m, VALUE *vp));
+extern MATRIX *matmodval MATH_PROTO((MATRIX *m, VALUE *vp));
+extern MATRIX *matint MATH_PROTO((MATRIX *m));
+extern MATRIX *matfrac MATH_PROTO((MATRIX *m));
+extern MATRIX *matround MATH_PROTO((MATRIX *m, long places));
+extern MATRIX *matbround MATH_PROTO((MATRIX *m, long places));
+extern MATRIX *mattrans MATH_PROTO((MATRIX *m));
+extern MATRIX *matcross MATH_PROTO((MATRIX *m1, MATRIX *m2));
+extern BOOL mattest MATH_PROTO((MATRIX *m));
+extern BOOL matcmp MATH_PROTO((MATRIX *m1, MATRIX *m2));
+extern long matsearch MATH_PROTO((MATRIX *m, VALUE *vp, long index));
+extern long matrsearch MATH_PROTO((MATRIX *m, VALUE *vp, long index));
+extern HASH mathash MATH_PROTO((MATRIX *m));
+extern VALUE matdet MATH_PROTO((MATRIX *m));
+extern VALUE matdot MATH_PROTO((MATRIX *m1, MATRIX *m2));
+extern void matfill MATH_PROTO((MATRIX *m, VALUE *v1, VALUE *v2));
+extern void matfree MATH_PROTO((MATRIX *m));
+extern void matprint MATH_PROTO((MATRIX *m, long max_print));
+extern VALUE *matindex MATH_PROTO((MATRIX *mp, BOOL create, long dim,
+       VALUE *indices));
+
+
+#if 0
+extern BOOL matisident MATH_PROTO((MATRIX *m));
+#endif
+
+
+
+/*
+ * List definitions.
+ * An individual list element.
+ */
+typedef struct listelem LISTELEM;
+struct listelem {
+       LISTELEM *e_next;       /* next element in list (or NULL) */
+       LISTELEM *e_prev;       /* previous element in list (or NULL) */
+       VALUE e_value;          /* value of this element */
+};
+
+
+/*
+ * Structure for a list of elements.
+ */
+struct list {
+       LISTELEM *l_first;      /* first list element (or NULL) */
+       LISTELEM *l_last;       /* last list element (or NULL) */
+       LISTELEM *l_cache;      /* cached list element (or NULL) */
+       long l_cacheindex;      /* index of cached element (or undefined) */
+       long l_count;           /* total number of elements in the list */
+};
+
+
+extern void insertlistfirst MATH_PROTO((LIST *lp, VALUE *vp));
+extern void insertlistlast MATH_PROTO((LIST *lp, VALUE *vp));
+extern void insertlistmiddle MATH_PROTO((LIST *lp, long index, VALUE *vp));
+extern void removelistfirst MATH_PROTO((LIST *lp, VALUE *vp));
+extern void removelistlast MATH_PROTO((LIST *lp, VALUE *vp));
+extern void removelistmiddle MATH_PROTO((LIST *lp, long index, VALUE *vp));
+extern void listfree MATH_PROTO((LIST *lp));
+extern void listprint MATH_PROTO((LIST *lp, long max_print));
+extern long listsearch MATH_PROTO((LIST *lp, VALUE *vp, long index));
+extern long listrsearch MATH_PROTO((LIST *lp, VALUE *vp, long index));
+extern HASH listhash MATH_PROTO((LIST *lp));
+extern BOOL listcmp MATH_PROTO((LIST *lp1, LIST *lp2));
+extern VALUE *listfindex MATH_PROTO((LIST *lp, long index));
+extern LIST *listalloc MATH_PROTO((void));
+extern LIST *listcopy MATH_PROTO((LIST *lp));
+
+
+
+/*
+ * Structures for associations.
+ * Associations are "indexed" by one or more arbitrary values, and are
+ * stored in a hash table with their hash values for quick indexing.
+ */
+typedef        struct assocelem ASSOCELEM;
+struct assocelem {
+       ASSOCELEM *e_next;      /* next element in list (or NULL) */
+       long e_dim;             /* dimension of indexing for this element */
+       HASH e_hash;            /* hash value for this element */
+       VALUE e_value;          /* value of association */
+       VALUE e_indices[1];     /* index values (variable length) */
+};
+
+
+struct assoc {
+       long a_count;           /* number of elements in the association */
+       long a_size;            /* current size of association hash table */
+       ASSOCELEM **a_table;    /* current hash table for elements */
+};
+
+
+extern ASSOC *assocalloc MATH_PROTO((long initsize));
+extern ASSOC *assoccopy MATH_PROTO((ASSOC *ap));
+extern void assocfree MATH_PROTO((ASSOC *ap));
+extern void assocprint MATH_PROTO((ASSOC *ap, long max_print));
+extern long assocsearch MATH_PROTO((ASSOC *ap, VALUE *vp, long index));
+extern long assocrsearch MATH_PROTO((ASSOC *ap, VALUE *vp, long index));
+extern HASH assochash MATH_PROTO((ASSOC *ap));
+extern BOOL assoccmp MATH_PROTO((ASSOC *ap1, ASSOC *ap2));
+extern VALUE *assocfindex MATH_PROTO((ASSOC *ap, long index));
+extern VALUE *associndex MATH_PROTO((ASSOC *ap, BOOL create, long dim,
+       VALUE *indices));
+
+
+/*
+ * Object actions.
+ */
+#define OBJ_PRINT      0       /* print the value */
+#define OBJ_ONE                1       /* create the multiplicative identity */
+#define OBJ_TEST       2       /* test a value for "zero" */
+#define OBJ_ADD                3       /* add two values */
+#define OBJ_SUB                4       /* subtrace one value from another */
+#define OBJ_NEG                5       /* negate a value */
+#define OBJ_MUL                6       /* multiply two values */
+#define OBJ_DIV                7       /* divide one value by another */
+#define OBJ_INV                8       /* invert a value */
+#define OBJ_ABS                9       /* take absolute value of value */
+#define OBJ_NORM       10      /* take the norm of a value */
+#define OBJ_CONJ       11      /* take the conjugate of a value */
+#define OBJ_POW                12      /* take the power function */
+#define OBJ_SGN                13      /* return the sign of a value */
+#define OBJ_CMP                14      /* compare two values for equality */
+#define OBJ_REL                15      /* compare two values for inequality */
+#define OBJ_QUO                16      /* integer quotient of values */
+#define OBJ_MOD                17      /* remainder of division of values */
+#define OBJ_INT                18      /* integer part of */
+#define OBJ_FRAC       19      /* fractional part of */
+#define OBJ_INC                20      /* increment by one */
+#define OBJ_DEC                21      /* decrement by one */
+#define OBJ_SQUARE     22      /* square value */
+#define OBJ_SCALE      23      /* scale by power of two */
+#define OBJ_SHIFT      24      /* shift left (or right) by number of bits */
+#define OBJ_ROUND      25      /* round to specified decimal places */
+#define OBJ_BROUND     26      /* round to specified binary places */
+#define OBJ_ROOT       27      /* take nth root of value */
+#define OBJ_SQRT       28      /* take square root of value */
+#define OBJ_MAXFUNC    28      /* highest function */
+
+
+/*
+ * Definition of an object type.
+ * This is actually a varying sized structure.
+ */
+typedef struct {
+       char *name;                     /* name of object */
+       int count;                      /* number of elements defined */
+       int actions[OBJ_MAXFUNC+1];     /* function indices for actions */
+       int elements[1];                /* element indexes (MUST BE LAST) */
+} OBJECTACTIONS;
+
+#define objectactionsize(elements) \
+       (sizeof(OBJECTACTIONS) + ((elements) - 1) * sizeof(int))
+
+
+/*
+ * Structure of an object.
+ * This is actually a varying sized structure.
+ * However, there are always at least USUAL_ELEMENTS values in the object.
+ */
+struct object {
+       OBJECTACTIONS *o_actions;       /* action table for this object */
+       VALUE o_table[USUAL_ELEMENTS];  /* object values (MUST BE LAST) */
+};
+
+#define objectsize(elements) \
+       (sizeof(OBJECT) + ((elements) - USUAL_ELEMENTS) * sizeof(VALUE))
+
+
+extern OBJECT *objcopy MATH_PROTO((OBJECT *op));
+extern OBJECT *objalloc MATH_PROTO((long index));
+extern VALUE objcall MATH_PROTO((int action, VALUE *v1, VALUE *v2, VALUE *v3));
+extern void objfree MATH_PROTO((OBJECT *op));
+extern void objuncache MATH_PROTO((void));
+extern int addelement MATH_PROTO((char *name));
+extern void defineobject MATH_PROTO((char *name, int indices[], int count));
+extern int checkobject MATH_PROTO((char *name));
+extern void showobjfuncs MATH_PROTO((void));
+extern int findelement MATH_PROTO((char *name));
+extern int objoffset MATH_PROTO((OBJECT *op, long index));
+extern HASH objhash MATH_PROTO((OBJECT *op));
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/version.c b/usr/src/contrib/calc-2.9.3t6/version.c
new file mode 100644 (file)
index 0000000..7dc6c7a
--- /dev/null
@@ -0,0 +1,25 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * version - determine the version of calc
+ */
+
+#include "calc.h"
+
+#define MAJOR_VER      2       /* major version */
+#define MINOR_VER      9       /* minor version */
+#define PATCH_LEVEL    3       /* patch level */
+
+
+void
+version(stream)
+       FILE *stream;   /* stream to write version on */
+{
+       fprintf(stream,
+               "C-style arbitrary precision calculator (version %d.%d.%dt6)\n",
+               MAJOR_VER, MINOR_VER, PATCH_LEVEL);
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/zfunc.c b/usr/src/contrib/calc-2.9.3t6/zfunc.c
new file mode 100644 (file)
index 0000000..4091317
--- /dev/null
@@ -0,0 +1,1706 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Extended precision integral arithmetic non-primitive routines
+ */
+
+#include "zmath.h"
+
+static ZVALUE primeprod;               /* product of primes under 100 */
+ZVALUE _tenpowers_[2 * BASEB];         /* table of 10^2^n */
+
+
+/*
+ * Compute the factorial of a number.
+ */
+void
+zfact(z, dest)
+       ZVALUE z, *dest;
+{
+       long ptwo;              /* count of powers of two */
+       long n;                 /* current multiplication value */
+       long m;                 /* reduced multiplication value */
+       long mul;               /* collected value to multiply by */
+       ZVALUE res, temp;
+
+       if (zisneg(z))
+               math_error("Negative argument for factorial");
+       if (zisbig(z))
+               math_error("Very large factorial");
+       n = (zistiny(z) ? z1tol(z) : z2tol(z));
+       ptwo = 0;
+       mul = 1;
+       res = _one_;
+       /*
+        * Multiply numbers together, but squeeze out all powers of two.
+        * We will put them back in at the end.  Also collect multiple
+        * numbers together until there is a risk of overflow.
+        */
+       for (; n > 1; n--) {
+               for (m = n; ((m & 0x1) == 0); m >>= 1)
+                       ptwo++;
+               mul *= m;
+               if (mul < BASE1/2)
+                       continue;
+               zmuli(res, mul, &temp);
+               zfree(res);
+               res = temp;
+               mul = 1;
+       }
+       /*
+        * Multiply by the remaining value, then scale result by
+        * the proper power of two.
+        */
+       if (mul > 1) {
+               zmuli(res, mul, &temp);
+               zfree(res);
+               res = temp;
+       }
+       zshift(res, ptwo, &temp);
+       zfree(res);
+       *dest = temp;
+}
+
+
+/*
+ * Compute the product of the primes up to the specified number.
+ */
+void
+zpfact(z, dest)
+       ZVALUE z, *dest;
+{
+       long n;                 /* limiting number to multiply by */
+       long p;                 /* current prime */
+       long i;                 /* test value */
+       long mul;               /* collected value to multiply by */
+       ZVALUE res, temp;
+
+       if (zisneg(z))
+               math_error("Negative argument for factorial");
+       if (zisbig(z))
+               math_error("Very large factorial");
+       n = (zistiny(z) ? z1tol(z) : z2tol(z));
+       /*
+        * Multiply by the primes in order, collecting multiple numbers
+        * together until there is a chance of overflow.
+        */
+       mul = 1 + (n > 1);
+       res = _one_;
+       for (p = 3; p <= n; p += 2) {
+               for (i = 3; (i * i) <= p; i += 2) {
+                       if ((p % i) == 0)
+                               goto next;
+               }
+               mul *= p;
+               if (mul < BASE1/2)
+                       continue;
+               zmuli(res, mul, &temp);
+               zfree(res);
+               res = temp;
+               mul = 1;
+next: ;
+       }
+       /*
+        * Multiply by the final value if any.
+        */
+       if (mul > 1) {
+               zmuli(res, mul, &temp);
+               zfree(res);
+               res = temp;
+       }
+       *dest = res;
+}
+
+
+/*
+ * Compute the least common multiple of all the numbers up to the
+ * specified number.
+ */
+void
+zlcmfact(z, dest)
+       ZVALUE z, *dest;
+{
+       long n;                 /* limiting number to multiply by */
+       long p;                 /* current prime */
+       long pp = 0;            /* power of prime */
+       long i;                 /* test value */
+       ZVALUE res, temp;
+
+       if (zisneg(z) || ziszero(z))
+               math_error("Non-positive argument for lcmfact");
+       if (zisbig(z))
+               math_error("Very large lcmfact");
+       n = (zistiny(z) ? z1tol(z) : z2tol(z));
+       /*
+        * Multiply by powers of the necessary odd primes in order.
+        * The power for each prime is the highest one which is not
+        * more than the specified number.
+        */
+       res = _one_;
+       for (p = 3; p <= n; p += 2) {
+               for (i = 3; (i * i) <= p; i += 2) {
+                       if ((p % i) == 0)
+                               goto next;
+               }
+               i = p;
+               while (i <= n) {
+                       pp = i;
+                       i *= p;
+               }
+               zmuli(res, pp, &temp);
+               zfree(res);
+               res = temp;
+next: ;
+       }
+       /*
+        * Finish by scaling by the necessary power of two.
+        */
+       zshift(res, zhighbit(z), dest);
+       zfree(res);
+}
+
+
+/*
+ * Compute the permutation function  M! / (M - N)!.
+ */
+void
+zperm(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       long count;
+       ZVALUE cur, tmp, ans;
+
+       if (zisneg(z1) || zisneg(z2))
+               math_error("Negative argument for permutation");
+       if (zrel(z1, z2) < 0)
+               math_error("Second arg larger than first in permutation");
+       if (zisbig(z2))
+               math_error("Very large permutation");
+       count = (zistiny(z2) ? z1tol(z2) : z2tol(z2));
+       zcopy(z1, &ans);
+       zsub(z1, _one_, &cur);
+       while (--count > 0) {
+               zmul(ans, cur, &tmp);
+               zfree(ans);
+               ans = tmp;
+               zsub(cur, _one_, &tmp);
+               zfree(cur);
+               cur = tmp;
+       }
+       zfree(cur);
+       *res = ans;
+}
+
+
+/*
+ * Compute the combinatorial function  M! / ( N! * (M - N)! ).
+ */
+void
+zcomb(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       ZVALUE ans;
+       ZVALUE mul, div, temp;
+       FULL count, i;
+       HALF dh[2];
+
+       if (zisneg(z1) || zisneg(z2))
+               math_error("Negative argument for combinatorial");
+       zsub(z1, z2, &temp);
+       if (zisneg(temp)) {
+               zfree(temp);
+               math_error("Second arg larger than first for combinatorial");
+       }
+       if (zisbig(z2) && zisbig(temp)) {
+               zfree(temp);
+               math_error("Very large combinatorial");
+       }
+       count = (zistiny(z2) ? z1tol(z2) : z2tol(z2));
+       i = (zistiny(temp) ? z1tol(temp) : z2tol(temp));
+       if (zisbig(z2) || (!zisbig(temp) && (i < count)))
+               count = i;
+       zfree(temp);
+       mul = z1;
+       div.sign = 0;
+       div.v = dh;
+       ans = _one_;
+       for (i = 1; i <= count; i++) {
+               dh[0] = i & BASE1;
+               dh[1] = i / BASE;
+               div.len = 1 + (dh[1] != 0);
+               zmul(ans, mul, &temp);
+               zfree(ans);
+               zquo(temp, div, &ans);
+               zfree(temp);
+               zsub(mul, _one_, &temp);
+               if (mul.v != z1.v)
+                       zfree(mul);
+               mul = temp;
+       }
+       if (mul.v != z1.v)
+               zfree(mul);
+       *res = ans;
+}
+
+
+/*
+ * Perform a probabilistic primality test (algorithm P in Knuth).
+ * Returns FALSE if definitely not prime, or TRUE if probably prime.
+ * Count determines how many times to check for primality.
+ * The chance of a non-prime passing this test is less than (1/4)^count.
+ * For example, a count of 100 fails for only 1 in 10^60 numbers.
+ */
+BOOL
+zprimetest(z, count)
+       ZVALUE z;               /* number to test for primeness */
+       long count;
+{
+       long ij, ik, ix;
+       ZVALUE zm1, z1, z2, z3, ztmp;
+       HALF val[2];
+
+       z.sign = 0;
+       if (ziseven(z))         /* if even, not prime if not 2 */
+               return (zistwo(z) != 0);
+       /*
+        * See if the number is small, and is either a small prime,
+        * or is divisible by a small prime.
+        */
+       if (zistiny(z) && (*z.v <= (HALF)(101*101-1))) {
+               ix = *z.v;
+               for (ik = 3; (ik <= 97) && ((ik * ik) <= ix); ik += 2)
+                       if ((ix % ik) == 0)
+                               return FALSE;
+               return TRUE;
+       }
+       /*
+        * See if the number is divisible by one of the primes 3, 5,
+        * 7, 11, or 13.  This is a very easy check.
+        */
+       ij = zmodi(z, 15015L);
+       if (!(ij % 3) || !(ij % 5) || !(ij % 7) || !(ij % 11) || !(ij % 13))
+               return FALSE;
+       /*
+        * Check the gcd of the number and the product of more of the first
+        * few odd primes.  We must build the prime product on the first call.
+        */
+       ztmp.sign = 0;
+       ztmp.len = 1;
+       ztmp.v = val;
+       if (primeprod.len == 0) {
+               val[0] = 101;
+               zpfact(ztmp, &primeprod);
+       }
+       zgcd(z, primeprod, &z1);
+       if (!zisunit(z1)) {
+               zfree(z1);
+               return FALSE;
+       }
+       zfree(z1);
+       /*
+        * Not divisible by a small prime, so onward with the real test.
+        * Make sure the count is limited by the number of odd numbers between
+        * three and the number being tested.
+        */
+       ix = ((zistiny(z) ? z1tol(z) : z2tol(z) - 3) / 2);
+       if (count > ix) count = ix;
+       zsub(z, _one_, &zm1);
+       ik = zlowbit(zm1);
+       zshift(zm1, -ik, &z1);
+       /*
+        * Loop over various "random" numbers, testing each one.
+        * These numbers are the odd numbers starting from three.
+        */
+       for (ix = 0; ix < count; ix++) {
+               val[0] = (ix * 2) + 3;
+               ij = 0;
+               zpowermod(ztmp, z1, z, &z3);
+               for (;;) {
+                       if (zisone(z3)) {
+                               if (ij) /* number is definitely not prime */
+                                       goto notprime;
+                               break;
+                       }
+                       if (zcmp(z3, zm1) == 0)
+                               break;
+                       if (++ij >= ik)
+                               goto notprime;  /* number is definitely not prime */
+                       zsquare(z3, &z2);
+                       zfree(z3);
+                       zmod(z2, z, &z3);
+                       zfree(z2);
+               }
+               zfree(z3);
+       }
+       zfree(zm1);
+       zfree(z1);
+       return TRUE;    /* number might be prime */
+
+notprime:
+       zfree(z3);
+       zfree(zm1);
+       zfree(z1);
+       return FALSE;
+}
+
+
+/*
+ * Compute the Jacobi function (p / q) for odd q.
+ * If q is prime then the result is:
+ *     1 if p == x^2 (mod q) for some x.
+ *     -1 otherwise.
+ * If q is not prime, then the result is not meaningful if it is 1.
+ * This function returns 0 if q is even or q < 0.
+ */
+FLAG
+zjacobi(z1, z2)
+       ZVALUE z1, z2;
+{
+       ZVALUE p, q, tmp;
+       long lowbit;
+       int val;
+
+       if (ziseven(z2) || zisneg(z2))
+               return 0;
+       val = 1;
+       if (ziszero(z1) || zisone(z1))
+               return val;
+       if (zisunit(z1)) {
+               if ((*z2.v - 1) & 0x2)
+                       val = -val;
+               return val;
+       }
+       zcopy(z1, &p);
+       zcopy(z2, &q);
+       for (;;) {
+               zmod(p, q, &tmp);
+               zfree(p);
+               p = tmp;
+               if (ziszero(p)) {
+                       zfree(p);
+                       p = _one_;
+               }
+               if (ziseven(p)) {
+                       lowbit = zlowbit(p);
+                       zshift(p, -lowbit, &tmp);
+                       zfree(p);
+                       p = tmp;
+                       if ((lowbit & 1) && (((*q.v & 0x7) == 3) || ((*q.v & 0x7) == 5)))
+                               val = -val;
+               }
+               if (zisunit(p)) {
+                       zfree(p);
+                       zfree(q);
+                       return val;
+               }
+               if ((*p.v & *q.v & 0x3) == 3)
+                       val = -val;
+               tmp = q;
+               q = p;
+               p = tmp;
+       }
+}
+
+
+/*
+ * Return the Fibonacci number F(n).
+ * This is evaluated by recursively using the formulas:
+ *     F(2N+1) = F(N+1)^2 + F(N)^2
+ * and
+ *     F(2N) = F(N+1)^2 - F(N-1)^2
+ */
+void
+zfib(z, res)
+       ZVALUE z, *res;
+{
+       unsigned long i;
+       long n;
+       int sign;
+       ZVALUE fnm1, fn, fnp1;          /* consecutive fibonacci values */
+       ZVALUE t1, t2, t3;
+
+       if (zisbig(z))
+               math_error("Very large Fibonacci number");
+       n = (zistiny(z) ? z1tol(z) : z2tol(z));
+       if (n == 0) {
+               *res = _zero_;
+               return;
+       }
+       sign = z.sign && ((n & 0x1) == 0);
+       if (n <= 2) {
+               *res = _one_;
+               res->sign = (BOOL)sign;
+               return;
+       }
+       i = TOPFULL;
+       while ((i & n) == 0)
+               i >>= 1L;
+       i >>= 1L;
+       fnm1 = _zero_;
+       fn = _one_;
+       fnp1 = _one_;
+       while (i) {
+               zsquare(fnm1, &t1);
+               zsquare(fn, &t2);
+               zsquare(fnp1, &t3);
+               zfree(fnm1);
+               zfree(fn);
+               zfree(fnp1);
+               zadd(t2, t3, &fnp1);
+               zsub(t3, t1, &fn);
+               zfree(t1);
+               zfree(t2);
+               zfree(t3);
+               if (i & n) {
+                       fnm1 = fn;
+                       fn = fnp1;
+                       zadd(fnm1, fn, &fnp1);
+               } else
+                       zsub(fnp1, fn, &fnm1);
+               i >>= 1L;
+       }
+       zfree(fnm1);
+       zfree(fnp1);
+       *res = fn;
+       res->sign = (BOOL)sign;
+}
+
+
+/*
+ * Compute the result of raising one number to the power of another
+ * The second number is assumed to be non-negative.
+ * It cannot be too large except for trivial cases.
+ */
+void
+zpowi(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       int sign;               /* final sign of number */
+       unsigned long power;    /* power to raise to */
+       unsigned long bit;      /* current bit value */
+       long twos;              /* count of times 2 is in result */
+       ZVALUE ans, temp;
+
+       sign = (z1.sign && zisodd(z2));
+       z1.sign = 0;
+       z2.sign = 0;
+       if (ziszero(z2) && !ziszero(z1)) {      /* number raised to power 0 */
+               *res = _one_;
+               return;
+       }
+       if (zisleone(z1)) {     /* 0, 1, or -1 raised to a power */
+               ans = _one_;
+               ans.sign = (BOOL)sign;
+               if (*z1.v == 0)
+                       ans = _zero_;
+               *res = ans;
+               return;
+       }
+       if (zisbig(z2))
+               math_error("Raising to very large power");
+       power = (zistiny(z2) ? z1tol(z2) : z2tol(z2));
+       if (zistwo(z1)) {       /* two raised to a power */
+               zbitvalue((long) power, res);
+               return;
+       }
+       /*
+        * See if this is a power of ten
+        */
+       if (zistiny(z1) && (*z1.v == 10)) {
+               ztenpow((long) power, res);
+               res->sign = (BOOL)sign;
+               return;
+       }
+       /*
+        * Handle low powers specially
+        */
+       if (power <= 4) {
+               switch ((int) power) {
+                       case 1:
+                               ans.len = z1.len;
+                               ans.v = alloc(ans.len);
+                               zcopyval(z1, ans);
+                               ans.sign = (BOOL)sign;
+                               *res = ans;
+                               return;
+                       case 2:
+                               zsquare(z1, res);
+                               return;
+                       case 3:
+                               zsquare(z1, &temp);
+                               zmul(z1, temp, res);
+                               zfree(temp);
+                               res->sign = (BOOL)sign;
+                               return;
+                       case 4:
+                               zsquare(z1, &temp);
+                               zsquare(temp, res);
+                               zfree(temp);
+                               return;
+               }
+       }
+       /*
+        * Shift out all powers of twos so the multiplies are smaller.
+        * We will shift back the right amount when done.
+        */
+       twos = 0;
+       if (ziseven(z1)) {
+               twos = zlowbit(z1);
+               ans.v = alloc(z1.len);
+               ans.len = z1.len;
+               ans.sign = z1.sign;
+               zcopyval(z1, ans);
+               zshiftr(ans, twos);
+               ztrim(&ans);
+               z1 = ans;
+               twos *= power;
+       }
+       /*
+        * Compute the power by squaring and multiplying.
+        * This uses the left to right method of power raising.
+        */
+       bit = TOPFULL;
+       while ((bit & power) == 0)
+               bit >>= 1L;
+       bit >>= 1L;
+       zsquare(z1, &ans);
+       if (bit & power) {
+               zmul(ans, z1, &temp);
+               zfree(ans);
+               ans = temp;
+       }
+       bit >>= 1L;
+       while (bit) {
+               zsquare(ans, &temp);
+               zfree(ans);
+               ans = temp;
+               if (bit & power) {
+                       zmul(ans, z1, &temp);
+                       zfree(ans);
+                       ans = temp;
+               }
+               bit >>= 1L;
+       }
+       /*
+        * Scale back up by proper power of two
+        */
+       if (twos) {
+               zshift(ans, twos, &temp);
+               zfree(ans);
+               ans = temp;
+               zfree(z1);
+       }
+       ans.sign = (BOOL)sign;
+       *res = ans;
+}
+
+
+/*
+ * Compute ten to the specified power
+ * This saves some work since the squares of ten are saved.
+ */
+void
+ztenpow(power, res)
+       long power;
+       ZVALUE *res;
+{
+       long i;
+       ZVALUE ans;
+       ZVALUE temp;
+
+       if (power <= 0) {
+               *res = _one_;
+               return;
+       }
+       ans = _one_;
+       _tenpowers_[0] = _ten_;
+       for (i = 0; power; i++) {
+               if (_tenpowers_[i].len == 0)
+                       zsquare(_tenpowers_[i-1], &_tenpowers_[i]);
+               if (power & 0x1) {
+                       zmul(ans, _tenpowers_[i], &temp);
+                       zfree(ans);
+                       ans = temp;
+               }
+               power /= 2;
+       }
+       *res = ans;
+}
+
+
+/*
+ * Calculate modular inverse suppressing unnecessary divisions.
+ * This is based on the Euclidian algorithm for large numbers.
+ * (Algorithm X from Knuth Vol 2, section 4.5.2. and exercise 17)
+ * Returns TRUE if there is no solution because the numbers
+ * are not relatively prime.
+ */
+BOOL
+zmodinv(u, v, res)
+       ZVALUE u, v;
+       ZVALUE *res;
+{
+       FULL    q1, q2, ui3, vi3, uh, vh, A, B, C, D, T;
+       ZVALUE  u2, u3, v2, v3, qz, tmp1, tmp2, tmp3;
+
+       if (zisneg(u) || zisneg(v) || (zrel(u, v) >= 0))
+               zmod(u, v, &v3);
+       else
+               zcopy(u, &v3);
+       zcopy(v, &u3);
+       u2 = _zero_;
+       v2 = _one_;
+
+       /*
+        * Loop here while the size of the numbers remain above
+        * the size of a FULL.  Throughout this loop u3 >= v3.
+        */
+       while ((u3.len > 1) && !ziszero(v3)) {
+               uh = (((FULL) u3.v[u3.len - 1]) << BASEB) + u3.v[u3.len - 2];
+               vh = 0;
+               if ((v3.len + 1) >= u3.len)
+                       vh = v3.v[v3.len - 1];
+               if (v3.len == u3.len)
+                       vh = (vh << BASEB) + v3.v[v3.len - 2];
+               A = 1;
+               B = 0;
+               C = 0;
+               D = 1;
+
+               /*
+                * Calculate successive quotients of the continued fraction
+                * expansion using only single precision arithmetic until
+                * greater precision is required.
+                */
+               while ((vh + C) && (vh + D)) {
+                       q1 = (uh + A) / (vh + C);
+                       q2 = (uh + B) / (vh + D);
+                       if (q1 != q2)
+                               break;
+                       T = A - q1 * C;
+                       A = C;
+                       C = T;
+                       T = B - q1 * D;
+                       B = D;
+                       D = T;
+                       T = uh - q1 * vh;
+                       uh = vh;
+                       vh = T;
+               }
+       
+               /*
+                * If B is zero, then we made no progress because
+                * the calculation requires a very large quotient.
+                * So we must do this step of the calculation in
+                * full precision
+                */
+               if (B == 0) {
+                       zquo(u3, v3, &qz);
+                       zmul(qz, v2, &tmp1);
+                       zsub(u2, tmp1, &tmp2);
+                       zfree(tmp1);
+                       zfree(u2);
+                       u2 = v2;
+                       v2 = tmp2;
+                       zmul(qz, v3, &tmp1);
+                       zsub(u3, tmp1, &tmp2);
+                       zfree(tmp1);
+                       zfree(u3);
+                       u3 = v3;
+                       v3 = tmp2;
+                       zfree(qz);
+                       continue;
+               }
+               /*
+                * Apply the calculated A,B,C,D numbers to the current
+                * values to update them as if the full precision
+                * calculations had been carried out.
+                */
+               zmuli(u2, (long) A, &tmp1);
+               zmuli(v2, (long) B, &tmp2);
+               zadd(tmp1, tmp2, &tmp3);
+               zfree(tmp1);
+               zfree(tmp2);
+               zmuli(u2, (long) C, &tmp1);
+               zmuli(v2, (long) D, &tmp2);
+               zfree(u2);
+               zfree(v2);
+               u2 = tmp3;
+               zadd(tmp1, tmp2, &v2);
+               zfree(tmp1);
+               zfree(tmp2);
+               zmuli(u3, (long) A, &tmp1);
+               zmuli(v3, (long) B, &tmp2);
+               zadd(tmp1, tmp2, &tmp3);
+               zfree(tmp1);
+               zfree(tmp2);
+               zmuli(u3, (long) C, &tmp1);
+               zmuli(v3, (long) D, &tmp2);
+               zfree(u3);
+               zfree(v3);
+               u3 = tmp3;
+               zadd(tmp1, tmp2, &v3);
+               zfree(tmp1);
+               zfree(tmp2);
+       }
+
+       /*
+        * Here when the remaining numbers become single precision in size.
+        * Finish the procedure using single precision calculations.
+        */
+       if (ziszero(v3) && !zisone(u3)) {
+               zfree(u3);
+               zfree(v3);
+               zfree(u2);
+               zfree(v2);
+               return TRUE;
+       }
+       ui3 = (zistiny(u3) ? z1tol(u3) : z2tol(u3));
+       vi3 = (zistiny(v3) ? z1tol(v3) : z2tol(v3));
+       zfree(u3);
+       zfree(v3);
+       while (vi3) {
+               q1 = ui3 / vi3;
+               zmuli(v2, (long) q1, &tmp1);
+               zsub(u2, tmp1, &tmp2);
+               zfree(tmp1);
+               zfree(u2);
+               u2 = v2;
+               v2 = tmp2;
+               q2 = ui3 - q1 * vi3;
+               ui3 = vi3;
+               vi3 = q2;
+       }
+       zfree(v2);
+       if (ui3 != 1) {
+               zfree(u2);
+               return TRUE;
+       }
+       if (zisneg(u2)) {
+               zadd(v, u2, res);
+               zfree(u2);
+               return FALSE;
+       }
+       *res = u2;
+       return FALSE;
+}
+
+
+#if 0
+/*
+ * Approximate the quotient of two integers by another set of smaller
+ * integers.  This uses continued fractions to determine the smaller set.
+ */
+void
+zapprox(z1, z2, res1, res2)
+       ZVALUE z1, z2, *res1, *res2;
+{
+       int sign;
+       ZVALUE u1, v1, u3, v3, q, t1, t2, t3;
+
+       sign = ((z1.sign != 0) ^ (z2.sign != 0));
+       z1.sign = 0;
+       z2.sign = 0;
+       v3 = z2;
+       u3 = z1;
+       u1 = _one_;
+       v1 = _zero_;
+       while (!ziszero(v3)) {
+               zdiv(u3, v3, &q, &t1);
+               zmul(v1, q, &t2);
+               zsub(u1, t2, &t3);
+               zfree(q);
+               zfree(t2);
+               zfree(u1);
+               if ((u3.v != z1.v) && (u3.v != z2.v))
+                       zfree(u3);
+               u1 = v1;
+               u3 = v3;
+               v1 = t3;
+               v3 = t1;
+       }
+       if (!zisunit(u3))
+               math_error("Non-relativly prime numbers for approx");
+       if ((u3.v != z1.v) && (u3.v != z2.v))
+               zfree(u3);
+       if ((v3.v != z1.v) && (v3.v != z2.v))
+               zfree(v3);
+       zfree(v1);
+       zmul(u1, z1, &t1);
+       zsub(t1, _one_, &t2);
+       zfree(t1);
+       zquo(t2, z2, &t1);
+       zfree(t2);
+       u1.sign = (BOOL)sign;
+       t1.sign = 0;
+       *res1 = t1;
+       *res2 = u1;
+}
+#endif
+
+
+/*
+ * Binary gcd algorithm
+ * This algorithm taken from Knuth
+ */
+void
+zgcd(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       ZVALUE u, v, t;
+       register long j, k, olen, mask;
+       register HALF h;
+       HALF *oldv1, *oldv2;
+
+       z1.sign = 0;
+       z2.sign = 0;
+       if (ziszero(z1)) {
+               zcopy(z2, res);
+               return;
+       }
+       if (ziszero(z2)) {
+               zcopy(z1, res);
+               return;
+       }
+       if (zisunit(z1) || zisunit(z2)) {
+               *res = _one_;
+               return;
+       }
+       /*
+        * First see if one number is very much larger than the other.
+        * If so, then divide as necessary to get the numbers near each other.
+        */
+       oldv1 = z1.v;
+       oldv2 = z2.v;
+       if (z1.len < z2.len) {
+               t = z1;
+               z1 = z2;
+               z2 = t;
+       }
+       while ((z1.len > (z2.len + 5)) && !ziszero(z2)) {
+               zmod(z1, z2, &t);
+               if ((z1.v != oldv1) && (z1.v != oldv2))
+                       zfree(z1);
+               z1 = z2;
+               z2 = t;
+       }
+       /*
+        * Ok, now do the binary method proper
+        */
+       u.len = z1.len;
+       v.len = z2.len;
+       u.sign = 0;
+       v.sign = 0;
+       if (!ztest(z1)) {
+               v.v = alloc(v.len);
+               zcopyval(z2, v);
+               *res = v;
+               goto done;
+       }
+       if (!ztest(z2)) {
+               u.v = alloc(u.len);
+               zcopyval(z1, u);
+               *res = u;
+               goto done;
+       }
+       u.v = alloc(u.len);
+       v.v = alloc(v.len);
+       zcopyval(z1, u);
+       zcopyval(z2, v);
+       k = 0;
+       while (u.v[k] == 0 && v.v[k] == 0)
+               ++k;
+       mask = 01;
+       h = u.v[k] | v.v[k];
+       k *= BASEB;
+       while (!(h & mask)) {
+               mask <<= 1;
+               k++;
+       }
+       zshiftr(u, k);
+       zshiftr(v, k);
+       ztrim(&u);
+       ztrim(&v);
+       if (zisodd(u)) {
+               t.v = alloc(v.len);
+               t.len = v.len;
+               zcopyval(v, t);
+               t.sign = !v.sign;
+       } else {
+               t.v = alloc(u.len);
+               t.len = u.len;
+               zcopyval(u, t);
+               t.sign = u.sign;
+       }
+       while (ztest(t)) {
+               j = 0;
+               while (!t.v[j])
+                       ++j;
+               mask = 01;
+               h = t.v[j];
+               j *= BASEB;
+               while (!(h & mask)) {
+                       mask <<= 1;
+                       j++;
+               }
+               zshiftr(t, j);
+               ztrim(&t);
+               if (ztest(t) > 0) {
+                       zfree(u);
+                       u = t;
+               } else {
+                       zfree(v);
+                       v = t;
+                       v.sign = !t.sign;
+               }
+               zsub(u, v, &t);
+       }
+       zfree(t);
+       zfree(v);
+       if (k) {
+               olen = u.len;
+               u.len += k / BASEB + 1;
+               u.v = (HALF *) realloc(u.v, u.len * sizeof(HALF));
+               if (u.v == NULL) {
+                   math_error("Not enough memory to expand number");
+               }
+               while (olen != u.len)
+                       u.v[olen++] = 0;
+               zshiftl(u, k);
+       }
+       ztrim(&u);
+       *res = u;
+
+done:
+       if ((z1.v != oldv1) && (z1.v != oldv2))
+               zfree(z1);
+       if ((z2.v != oldv1) && (z2.v != oldv2))
+               zfree(z2);
+}
+
+
+/*
+ * Compute the lcm of two integers (least common multiple).
+ * This is done using the formula:  gcd(a,b) * lcm(a,b) = a * b.
+ */
+void
+zlcm(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       ZVALUE temp1, temp2;
+
+       zgcd(z1, z2, &temp1);
+       zquo(z1, temp1, &temp2);
+       zfree(temp1);
+       zmul(temp2, z2, res);
+       zfree(temp2);
+}
+
+
+/*
+ * Return whether or not two numbers are relatively prime to each other.
+ */
+BOOL
+zrelprime(z1, z2)
+       ZVALUE z1, z2;                  /* numbers to be tested */
+{
+       FULL rem1, rem2;                /* remainders */
+       ZVALUE rem;
+       BOOL result;
+
+       z1.sign = 0;
+       z2.sign = 0;
+       if (ziseven(z1) && ziseven(z2)) /* false if both even */
+               return FALSE;
+       if (zisunit(z1) || zisunit(z2)) /* true if either is a unit */
+               return TRUE;
+       if (ziszero(z1) || ziszero(z2)) /* false if either is zero */
+               return FALSE;
+       if (zistwo(z1) || zistwo(z2))   /* true if either is two */
+               return TRUE;
+       /*
+        * Try reducing each number by the product of the first few odd primes
+        * to see if any of them are a common factor.
+        */
+       rem1 = zmodi(z1, 3L * 5 * 7 * 11 * 13);
+       rem2 = zmodi(z2, 3L * 5 * 7 * 11 * 13);
+       if (((rem1 % 3) == 0) && ((rem2 % 3) == 0))
+               return FALSE;
+       if (((rem1 % 5) == 0) && ((rem2 % 5) == 0))
+               return FALSE;
+       if (((rem1 % 7) == 0) && ((rem2 % 7) == 0))
+               return FALSE;
+       if (((rem1 % 11) == 0) && ((rem2 % 11) == 0))
+               return FALSE;
+       if (((rem1 % 13) == 0) && ((rem2 % 13) == 0))
+               return FALSE;
+       /*
+        * Try a new batch of primes now
+        */
+       rem1 = zmodi(z1, 17L * 19 * 23);
+       rem2 = zmodi(z2, 17L * 19 * 23);
+       if (((rem1 % 17) == 0) && ((rem2 % 17) == 0))
+               return FALSE;
+       if (((rem1 % 19) == 0) && ((rem2 % 19) == 0))
+               return FALSE;
+       if (((rem1 % 23) == 0) && ((rem2 % 23) == 0))
+               return FALSE;
+       /*
+        * Yuk, we must actually compute the gcd to know the answer
+        */
+       zgcd(z1, z2, &rem);
+       result = zisunit(rem);
+       zfree(rem);
+       return result;
+}
+
+
+/*
+ * Compute the log of one number base another, to the closest integer.
+ * This is the largest integer which when the second number is raised to it,
+ * the resulting value is less than or equal to the first number.
+ * Example:  zlog(123456, 10) = 5.
+ */
+long
+zlog(z1, z2)
+       ZVALUE z1, z2;
+{
+       register ZVALUE *zp;            /* current square */
+       long power;                     /* current power */
+       long worth;                     /* worth of current square */
+       ZVALUE val;                     /* current value of power */
+       ZVALUE temp;                    /* temporary */
+       ZVALUE squares[32];             /* table of squares of base */
+
+       /*
+        * Make sure that the numbers are nonzero and the base is greater than one.
+        */
+       if (zisneg(z1) || ziszero(z1) || zisneg(z2) || zisleone(z2))
+               math_error("Bad arguments for log");
+       /*
+        * Reject trivial cases.
+        */
+       if (z1.len < z2.len)
+               return 0;
+       if ((z1.len == z2.len) && (z1.v[z1.len-1] < z2.v[z2.len-1]))
+               return 0;
+       power = zrel(z1, z2);
+       if (power <= 0)
+               return (power + 1);
+       /*
+        * Handle any power of two special.
+        */
+       if (zisonebit(z2))
+               return (zhighbit(z1) / zlowbit(z2));
+       /*
+        * Handle base 10 special
+        */
+       if ((z2.len == 1) && (*z2.v == 10))
+               return zlog10(z1);
+       /*
+        * Now loop by squaring the base each time, and see whether or
+        * not each successive square is still smaller than the number.
+        */
+       worth = 1;
+       zp = &squares[0];
+       *zp = z2;
+       while (((zp->len * 2) - 1) <= z1.len) { /* while square not too large */
+               zsquare(*zp, zp + 1);
+               zp++;
+               worth *= 2;
+       }
+       /*
+        * Now back down the squares, and multiply them together to see
+        * exactly how many times the base can be raised by.
+        */
+       val = _one_;
+       power = 0;
+       for (; zp >= squares; zp--, worth /= 2) {
+               if ((val.len + zp->len - 1) <= z1.len) {
+                       zmul(val, *zp, &temp);
+                       if (zrel(z1, temp) >= 0) {
+                               zfree(val);
+                               val = temp;
+                               power += worth;
+                       } else
+                               zfree(temp);
+               }
+               if (zp != squares)
+                       zfree(*zp);
+       }
+       return power;
+}
+
+
+/*
+ * Return the integral log base 10 of a number.
+ */
+long
+zlog10(z)
+       ZVALUE z;
+{
+       register ZVALUE *zp;            /* current square */
+       long power;                     /* current power */
+       long worth;                     /* worth of current square */
+       ZVALUE val;                     /* current value of power */
+       ZVALUE temp;                    /* temporary */
+
+       if (!zispos(z))
+               math_error("Non-positive number for log10");
+       /*
+        * Loop by squaring the base each time, and see whether or
+        * not each successive square is still smaller than the number.
+        */
+       worth = 1;
+       zp = &_tenpowers_[0];
+       *zp = _ten_;
+       while (((zp->len * 2) - 1) <= z.len) {  /* while square not too large */
+               if (zp[1].len == 0)
+                       zsquare(*zp, zp + 1);
+               zp++;
+               worth *= 2;
+       }
+       /*
+        * Now back down the squares, and multiply them together to see
+        * exactly how many times the base can be raised by.
+        */
+       val = _one_;
+       power = 0;
+       for (; zp >= _tenpowers_; zp--, worth /= 2) {
+               if ((val.len + zp->len - 1) <= z.len) {
+                       zmul(val, *zp, &temp);
+                       if (zrel(z, temp) >= 0) {
+                               zfree(val);
+                               val = temp;
+                               power += worth;
+                       } else
+                               zfree(temp);
+               }
+       }
+       return power;
+}
+
+
+/*
+ * Return the number of times that one number will divide another.
+ * This works similarly to zlog, except that divisions must be exact.
+ * For example, zdivcount(540, 3) = 3, since 3^3 divides 540 but 3^4 won't.
+ */
+long
+zdivcount(z1, z2)
+       ZVALUE z1, z2;
+{
+       long count;             /* number of factors removed */
+       ZVALUE tmp;             /* ignored return value */
+
+       count = zfacrem(z1, z2, &tmp);
+       zfree(tmp);
+       return count;
+}
+
+
+/*
+ * Remove all occurances of the specified factor from a number.
+ * Also returns the number of factors removed as a function return value.
+ * Example:  zfacrem(540, 3, &x) returns 3 and sets x to 20.
+ */
+long
+zfacrem(z1, z2, rem)
+       ZVALUE z1, z2, *rem;
+{
+       register ZVALUE *zp;            /* current square */
+       long count;                     /* total count of divisions */
+       long worth;                     /* worth of current square */
+       ZVALUE temp1, temp2, temp3;     /* temporaries */
+       ZVALUE squares[32];             /* table of squares of factor */
+
+       z1.sign = 0;
+       z2.sign = 0;
+       /*
+        * Make sure factor isn't 0 or 1.
+        */
+       if (zisleone(z2))
+               math_error("Bad argument for facrem");
+       /*
+        * Reject trivial cases.
+        */
+       if ((z1.len < z2.len) || (zisodd(z1) && ziseven(z2)) ||
+               ((z1.len == z2.len) && (z1.v[z1.len-1] < z2.v[z2.len-1]))) {
+               rem->v = alloc(z1.len);
+               rem->len = z1.len;
+               rem->sign = 0;
+               zcopyval(z1, *rem);
+               return 0;
+       }
+       /*
+        * Handle any power of two special.
+        */
+       if (zisonebit(z2)) {
+               count = zlowbit(z1) / zlowbit(z2);
+               rem->v = alloc(z1.len);
+               rem->len = z1.len;
+               rem->sign = 0;
+               zcopyval(z1, *rem);
+               zshiftr(*rem, count);
+               ztrim(rem);
+               return count;
+       }
+       /*
+        * See if the factor goes in even once.
+        */
+       zdiv(z1, z2, &temp1, &temp2);
+       if (!ziszero(temp2)) {
+               zfree(temp1);
+               zfree(temp2);
+               rem->v = alloc(z1.len);
+               rem->len = z1.len;
+               rem->sign = 0;
+               zcopyval(z1, *rem);
+               return 0;
+       }
+       zfree(temp2);
+       z1 = temp1;
+       /*
+        * Now loop by squaring the factor each time, and see whether
+        * or not each successive square will still divide the number.
+        */
+       count = 1;
+       worth = 1;
+       zp = &squares[0];
+       *zp = z2;
+       while (((zp->len * 2) - 1) <= z1.len) { /* while square not too large */
+               zsquare(*zp, &temp1);
+               zdiv(z1, temp1, &temp2, &temp3);
+               if (!ziszero(temp3)) {
+                       zfree(temp1);
+                       zfree(temp2);
+                       zfree(temp3);
+                       break;
+               }
+               zfree(temp3);
+               zfree(z1);
+               z1 = temp2;
+               *++zp = temp1;
+               worth *= 2;
+               count += worth;
+       }
+       /*
+        * Now back down the list of squares, and see if the lower powers
+        * will divide any more times.
+        */
+       for (; zp >= squares; zp--, worth /= 2) {
+               if (zp->len <= z1.len) {
+                       zdiv(z1, *zp, &temp1, &temp2);
+                       if (ziszero(temp2)) {
+                               temp3 = z1;
+                               z1 = temp1;
+                               temp1 = temp3;
+                               count += worth;
+                       }
+                       zfree(temp1);
+                       zfree(temp2);
+               }
+               if (zp != squares)
+                       zfree(*zp);
+       }
+       *rem = z1;
+       return count;
+}
+
+
+/*
+ * Keep dividing a number by the gcd of it with another number until the
+ * result is relatively prime to the second number.
+ */
+void
+zgcdrem(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       ZVALUE tmp1, tmp2;
+
+       /*
+        * Begin by taking the gcd for the first time.
+        * If the number is already relatively prime, then we are done.
+        */
+       zgcd(z1, z2, &tmp1);
+       if (zisunit(tmp1) || ziszero(tmp1)) {
+               res->len = z1.len;
+               res->v = alloc(z1.len);
+               res->sign = z1.sign;
+               zcopyval(z1, *res);
+               return;
+       }
+       zquo(z1, tmp1, &tmp2);
+       z1 = tmp2;
+       z2 = tmp1;
+       /*
+        * Now keep alternately taking the gcd and removing factors until
+        * the gcd becomes one.
+        */
+       while (!zisunit(z2)) {
+               (void) zfacrem(z1, z2, &tmp1);
+               zfree(z1);
+               z1 = tmp1;
+               zgcd(z1, z2, &tmp1);
+               zfree(z2);
+               z2 = tmp1;
+       }
+       *res = z1;
+}
+
+
+/*
+ * Find the lowest prime factor of a number if one can be found.
+ * Search is conducted for the first count primes.
+ * Returns 1 if no factor was found.
+ */
+long
+zlowfactor(z, count)
+       ZVALUE z;
+       long count;
+{
+       FULL p, d;
+       ZVALUE div, tmp;
+       HALF divval[2];
+
+       if ((--count < 0) || ziszero(z))
+               return 1;
+       if (ziseven(z))
+               return 2;
+       div.sign = 0;
+       div.v = divval;
+       for (p = 3; (count > 0); p += 2) {
+               for (d = 3; (d * d) <= p; d += 2)
+                       if ((p % d) == 0)
+                               goto next;
+               divval[0] = (p & BASE1);
+               divval[1] = (p / BASE);
+               div.len = 1 + (p >= BASE);
+               zmod(z, div, &tmp);
+               if (ziszero(tmp))
+                       return p;
+               zfree(tmp);
+               count--;
+next:;
+       }
+       return 1;
+}
+
+
+/*
+ * Return the number of digits (base 10) in a number, ignoring the sign.
+ */
+long
+zdigits(z1)
+       ZVALUE z1;
+{
+       long count, val;
+
+       z1.sign = 0;
+       if (zistiny(z1)) {      /* do small numbers ourself */
+               count = 1;
+               val = 10;
+               while (*z1.v >= (HALF)val) {
+                       count++;
+                       val *= 10;
+               }
+               return count;
+       }
+       return (zlog10(z1) + 1);
+}
+
+
+/*
+ * Return the single digit at the specified decimal place of a number,
+ * where 0 means the rightmost digit.  Example:  zdigit(1234, 1) = 3.
+ */
+FLAG
+zdigit(z1, n)
+       ZVALUE z1;
+       long n;
+{
+       ZVALUE tmp1, tmp2;
+       FLAG res;
+
+       z1.sign = 0;
+       if (ziszero(z1) || (n < 0) || (n / BASEDIG >= z1.len))
+               return 0;
+       if (n == 0)
+               return zmodi(z1, 10L);
+       if (n == 1)
+               return zmodi(z1, 100L) / 10;
+       if (n == 2)
+               return zmodi(z1, 1000L) / 100;
+       if (n == 3)
+               return zmodi(z1, 10000L) / 1000;
+       ztenpow(n, &tmp1);
+       zquo(z1, tmp1, &tmp2);
+       res = zmodi(tmp2, 10L);
+       zfree(tmp1);
+       zfree(tmp2);
+       return res;
+}
+
+
+/*
+ * Find the square root of a number.  This is the greatest integer whose
+ * square is less than or equal to the number. Returns TRUE if the
+ * square root is exact.
+ */
+BOOL
+zsqrt(z1, dest)
+       ZVALUE z1, *dest;
+{
+       ZVALUE try, quo, rem, old, temp;
+       FULL iquo, val;
+       long i,j;
+
+       if (z1.sign)
+               math_error("Square root of negative number");
+       if (ziszero(z1)) {
+               *dest = _zero_;
+               return TRUE;
+       }
+       if ((*z1.v < 4) && zistiny(z1)) {
+               *dest = _one_;
+               return (*z1.v == 1);
+       }
+       /*
+        * Pick the square root of the leading one or two digits as a first guess.
+        */
+       val = z1.v[z1.len-1];
+       if ((z1.len & 0x1) == 0)
+               val = (val * BASE) + z1.v[z1.len-2];
+
+       /*
+        * Find the largest power of 2 that when squared
+        * is <= val > 0.  Avoid multiply overflow by doing 
+        * a careful check at the BASE boundary.
+        */
+       j = 1L<<(BASEB+BASEB-2);
+       if (val > j) {
+               iquo = BASE;
+       } else {
+               i = BASEB-1;
+               while (j > val) {
+                       --i;
+                       j >>= 2;
+               }
+               iquo = bitmask[i];
+       }
+
+       for (i = 8; i > 0; i--)
+               iquo = (iquo + (val / iquo)) / 2;
+       if (iquo > BASE1)
+               iquo = BASE1;
+       /*
+        * Allocate the numbers to use for the main loop.
+        * The size and high bits of the final result are correctly set here.
+        * Notice that the remainder of the test value is rubbish, but this
+        * is unimportant.
+        */
+       try.sign = 0;
+       try.len = (z1.len + 1) / 2;
+       try.v = alloc(try.len);
+       zclearval(try);
+       try.v[try.len-1] = (HALF)iquo;
+       old.sign = 0;
+       old.v = alloc(try.len);
+       old.len = 1;
+       zclearval(old);
+       /*
+        * Main divide and average loop
+        */
+       for (;;) {
+               zdiv(z1, try, &quo, &rem);
+               i = zrel(try, quo);
+               if ((i == 0) && ziszero(rem)) { /* exact square root */
+                       zfree(rem);
+                       zfree(quo);
+                       zfree(old);
+                       *dest = try;
+                       return TRUE;
+               }
+               zfree(rem);
+               if (i <= 0) {
+                       /*
+                       * Current try is less than or equal to the square root since
+                       * it is less than the quotient.  If the quotient is equal to
+                       * the try, we are all done.  Also, if the try is equal to the
+                       * old try value, we are done since no improvement occurred.
+                       * If not, save the improved value and loop some more.
+                       */
+                       if ((i == 0) || (zcmp(old, try) == 0)) {
+                               zfree(quo);
+                               zfree(old);
+                               *dest = try;
+                               return FALSE;
+                       }
+                       old.len = try.len;
+                       zcopyval(try, old);
+               }
+               /* average current try and quotent for the new try */
+               zadd(try, quo, &temp);
+               zfree(quo);
+               zfree(try);
+               try = temp;
+               zshiftr(try, 1L);
+               zquicktrim(try);
+       }
+}
+
+
+/*
+ * Take an arbitrary root of a number (to the greatest integer).
+ * This uses the following iteration to get the Kth root of N:
+ *     x = ((K-1) * x + N / x^(K-1)) / K
+ */
+void
+zroot(z1, z2, dest)
+       ZVALUE z1, z2, *dest;
+{
+       ZVALUE try, quo, old, temp, temp2;
+       ZVALUE k1;                      /* holds k - 1 */
+       int sign;
+       long i, k, highbit;
+       SIUNION sival;
+
+       sign = z1.sign;
+       if (sign && ziseven(z2))
+               math_error("Even root of negative number");
+       if (ziszero(z2) || zisneg(z2))
+               math_error("Non-positive root");
+       if (ziszero(z1)) {      /* root of zero */
+               *dest = _zero_;
+               return;
+       }
+       if (zisunit(z2)) {      /* first root */
+               zcopy(z1, dest);
+               return;
+       }
+       if (zisbig(z2)) {       /* humongous root */
+               *dest = _one_;
+               dest->sign = (HALF)sign;
+               return;
+       }
+       k = (zistiny(z2) ? z1tol(z2) : z2tol(z2));
+       highbit = zhighbit(z1);
+       if (highbit < k) {      /* too high a root */
+               *dest = _one_;
+               dest->sign = (HALF)sign;
+               return;
+       }
+       sival.ivalue = k - 1;
+       k1.v = &sival.silow;
+       k1.len = 1 + (sival.sihigh != 0);
+       k1.sign = 0;
+       z1.sign = 0;
+       /*
+        * Allocate the numbers to use for the main loop.
+        * The size and high bits of the final result are correctly set here.
+        * Notice that the remainder of the test value is rubbish, but this
+        * is unimportant.
+        */
+       highbit = (highbit + k - 1) / k;
+       try.len = (highbit / BASEB) + 1;
+       try.v = alloc(try.len);
+       zclearval(try);
+       try.v[try.len-1] = ((HALF)1 << (highbit % BASEB));
+       try.sign = 0;
+       old.v = alloc(try.len);
+       old.len = 1;
+       zclearval(old);
+       old.sign = 0;
+       /*
+        * Main divide and average loop
+        */
+       for (;;) {
+               zpowi(try, k1, &temp);
+               zquo(z1, temp, &quo);
+               zfree(temp);
+               i = zrel(try, quo);
+               if (i <= 0) {
+                       /*
+                        * Current try is less than or equal to the root since it is
+                        * less than the quotient. If the quotient is equal to the try,
+                        * we are all done.  Also, if the try is equal to the old value,
+                        * we are done since no improvement occurred.
+                        * If not, save the improved value and loop some more.
+                        */
+                       if ((i == 0) || (zcmp(old, try) == 0)) {
+                               zfree(quo);
+                               zfree(old);
+                               try.sign = (HALF)sign;
+                               zquicktrim(try);
+                               *dest = try;
+                               return;
+                       }
+                       old.len = try.len;
+                       zcopyval(try, old);
+               }
+               /* average current try and quotent for the new try */
+               zmul(try, k1, &temp);
+               zfree(try);
+               zadd(quo, temp, &temp2);
+               zfree(temp);
+               zfree(quo);
+               zquo(temp2, z2, &try);
+               zfree(temp2);
+       }
+}
+
+
+/*
+ * Test to see if a number is an exact square or not.
+ */
+BOOL
+zissquare(z)
+       ZVALUE z;               /* number to be tested */
+{
+       long n, i;
+       ZVALUE tmp;
+
+       if (z.sign)             /* negative */
+               return FALSE;
+       while ((z.len > 1) && (*z.v == 0)) {    /* ignore trailing zero words */
+               z.len--;
+               z.v++;
+       }
+       if (zisleone(z))        /* zero or one */
+               return TRUE;
+       n = *z.v & 0xf;         /* check mod 16 values */
+       if ((n != 0) && (n != 1) && (n != 4) && (n != 9))
+               return FALSE;
+       n = *z.v & 0xff;        /* check mod 256 values */
+       i = 0x80;
+       while (((i * i) & 0xff) != n)
+               if (--i <= 0)
+                       return FALSE;
+       n = zsqrt(z, &tmp);     /* must do full square root test now */
+       zfree(tmp);
+       return n;
+}
+
+
+/*
+ * Return a trivial hash value for an integer.
+ */
+HASH
+zhash(z)
+       ZVALUE z;
+{
+       HASH hash;
+       int i;
+
+       hash = z.len * 1000003;
+       if (z.sign)
+               hash += 10000019;
+       for (i = z.len - 1; i >= 0; i--)
+               /* ignore Saber-C warning about Over/underflow */
+               hash = hash * 79372817 + z.v[i] + 10000079;
+       return hash;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/zio.c b/usr/src/contrib/calc-2.9.3t6/zio.c
new file mode 100644 (file)
index 0000000..464f87f
--- /dev/null
@@ -0,0 +1,660 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Scanf and printf routines for arbitrary precision integers.
+ */
+
+#include "stdarg.h"
+#include "zmath.h"
+
+
+#define        OUTBUFSIZE      200             /* realloc size for output buffers */
+
+#define        PUTCHAR(ch)             math_chr(ch)
+#define        PUTSTR(str)             math_str(str)
+#define        PRINTF1(fmt, a1)        math_fmt(fmt, a1)
+#define        PRINTF2(fmt, a1, a2)    math_fmt(fmt, a1, a2)
+
+
+long   _outdigits_ = 20;               /* default digits for output */
+int    _outmode_ = MODE_INITIAL;       /* default output mode */
+
+
+/*
+ * Output state that has been saved when diversions are done.
+ */
+typedef struct iostate IOSTATE;
+struct iostate {
+       IOSTATE *oldiostates;           /* previous saved state */
+       long outdigits;                 /* digits for output */
+       int outmode;                    /* output mode */
+       FILE *outfp;                    /* file unit for output (if any) */
+       char *outbuf;                   /* output string buffer (if any) */
+       long outbufsize;                /* current size of string buffer */
+       long outbufused;                /* space used in string buffer */
+       BOOL outputisstring;            /* TRUE if output is to string buffer */
+};
+
+
+static IOSTATE *oldiostates = NULL;    /* list of saved output states */
+static FILE    *outfp = NULL;          /* file unit for output */
+static char    *outbuf = NULL;         /* current diverted buffer */
+static BOOL    outputisstring = FALSE;
+static long    outbufsize;
+static long    outbufused;
+
+
+/*
+ * zio_init - perform needed initilization work
+ *
+ * On some systems, one cannot initialize a pointer to a FILE *.
+ * This routine, called once at startup is a work-a-round for
+ * systems with such bogons.
+ */
+void
+zio_init()
+{
+    static int done = 0;       /* 1 => routine already called */
+
+    if (!done) {
+       outfp = stdout;
+       done = 1;
+    }
+}
+
+
+/*
+ * Routine to output a character either to a FILE
+ * handle or into a string.
+ */
+void
+math_chr(ch)
+       int ch;
+{
+       char    *cp;
+
+       if (!outputisstring) {
+               fputc(ch, outfp);
+               return;
+       }
+       if (outbufused >= outbufsize) {
+               cp = (char *)realloc(outbuf, outbufsize + OUTBUFSIZE + 1);
+               if (cp == NULL)
+                       math_error("Cannot realloc output string");
+               outbuf = cp;
+               outbufsize += OUTBUFSIZE;
+       }
+       outbuf[outbufused++] = (char)ch;
+}
+
+
+/*
+ * Routine to output a null-terminated string either
+ * to a FILE handle or into a string.
+ */
+void
+math_str(str)
+       char    *str;
+{
+       char    *cp;
+       int     len;
+
+       if (!outputisstring) {
+               fputs(str, outfp);
+               return;
+       }
+       len = strlen(str);
+       if ((outbufused + len) > outbufsize) {
+               cp = (char *)realloc(outbuf, outbufsize + len + OUTBUFSIZE + 1);
+               if (cp == NULL)
+                       math_error("Cannot realloc output string");
+               outbuf = cp;
+               outbufsize += (len + OUTBUFSIZE);
+       }
+       memcpy(&outbuf[outbufused], str, len);
+       outbufused += len;
+}
+
+
+/*
+ * Output a null-terminated string either to a FILE handle or into a string,
+ * padded with spaces as needed so as to fit within the specified width.
+ * If width is positive, the spaces are added at the front of the string.
+ * If width is negative, the spaces are added at the end of the string.
+ * The complete string is always output, even if this overflows the width.
+ * No characters within the string are handled specially.
+ */
+void
+math_fill(str, width)
+       char *str;
+       long width;
+{
+       if (width > 0) {
+               width -= strlen(str);
+               while (width-- > 0)
+                       PUTCHAR(' ');
+               PUTSTR(str);
+       } else {
+               width += strlen(str);
+               PUTSTR(str);
+               while (width++ < 0)
+                       PUTCHAR(' ');
+       }
+}
+
+
+/*
+ * Routine to output a printf-style formatted string either
+ * to a FILE handle or into a string.
+ */
+#ifdef VARARGS
+# define VA_ALIST fmt, va_alist
+# define VA_DCL char *fmt; va_dcl
+#else
+# if defined(__STDC__) && __STDC__ == 1
+#  define VA_ALIST char *fmt, ...
+#  define VA_DCL
+# else
+#  define VA_ALIST fmt
+#  define VA_DCL char *fmt;
+# endif
+#endif
+/*VARARGS*/
+void
+math_fmt(VA_ALIST)
+       VA_DCL
+{
+       va_list ap;
+       char buf[200];
+
+#ifdef VARARGS
+       va_start(ap);
+#else
+       va_start(ap, fmt);
+#endif
+       vsprintf(buf, fmt, ap);
+       va_end(ap);
+       math_str(buf);
+}
+
+
+/*
+ * Flush the current output stream.
+ */
+void
+math_flush()
+{
+       if (!outputisstring)
+               fflush(outfp);
+}
+
+
+/*
+ * Divert further output so that it is saved into a string that will be
+ * returned later when the diversion is completed.  The current state of
+ * output is remembered for later restoration.  Diversions can be nested.
+ * Output diversion is only intended for saving output to "stdout".
+ */
+void
+math_divertio()
+{
+       register IOSTATE *sp;
+
+       sp = (IOSTATE *) malloc(sizeof(IOSTATE));
+       if (sp == NULL)
+               math_error("No memory for diverting output");
+       sp->oldiostates = oldiostates;
+       sp->outdigits = _outdigits_;
+       sp->outmode = _outmode_;
+       sp->outfp = outfp;
+       sp->outbuf = outbuf;
+       sp->outbufsize = outbufsize;
+       sp->outbufused = outbufused;
+       sp->outputisstring = outputisstring;
+
+       outbufused = 0;
+       outbufsize = 0;
+       outbuf = (char *) malloc(OUTBUFSIZE + 1);
+       if (outbuf == NULL)
+               math_error("Cannot allocate divert string");
+       outbufsize = OUTBUFSIZE;
+       outputisstring = TRUE;
+       oldiostates = sp;
+}
+
+
+/*
+ * Undivert output and return the saved output as a string.  This also
+ * restores the output state to what it was before the diversion began.
+ * The string needs freeing by the caller when it is no longer needed.
+ */
+char *
+math_getdivertedio()
+{
+       register IOSTATE *sp;
+       char *cp;
+
+       sp = oldiostates;
+       if (sp == NULL)
+               math_error("No diverted state to restore");
+       cp = outbuf;
+       cp[outbufused] = '\0';
+       oldiostates = sp->oldiostates;
+       _outdigits_ = sp->outdigits;
+       _outmode_ = sp->outmode;
+       outfp = sp->outfp;
+       outbuf = sp->outbuf;
+       outbufsize = sp->outbufsize;
+       outbufused = sp->outbufused;
+       outbuf = sp->outbuf;
+       outputisstring = sp->outputisstring;
+       return cp;
+}
+
+
+/*
+ * Clear all diversions and set output back to the original destination.
+ * This is called when resetting the global state of the program.
+ */
+void
+math_cleardiversions()
+{
+       while (oldiostates)
+               free(math_getdivertedio());
+}
+
+
+/*
+ * Set the output routines to output to the specified FILE stream.
+ * This interacts with output diversion in the following manner.
+ *     STDOUT  diversion       action
+ *     ----    ---------       ------
+ *     yes     yes             set output to diversion string again.
+ *     yes     no              set output to stdout.
+ *     no      yes             set output to specified file.
+ *     no      no              set output to specified file.
+ */
+void
+math_setfp(newfp)
+       FILE *newfp;
+{
+       outfp = newfp;
+       outputisstring = (oldiostates && (newfp == stdout));
+}
+
+
+/*
+ * Set the output mode for numeric output.
+ * This also returns the previous mode.
+ */
+int
+math_setmode(newmode)
+       int newmode;
+{
+       int oldmode;
+
+       if ((newmode <= MODE_DEFAULT) || (newmode > MODE_MAX))
+               math_error("Setting illegal output mode");
+       oldmode = _outmode_;
+       _outmode_ = newmode;
+       return oldmode;
+}
+
+
+/*
+ * Set the number of digits for float or exponential output.
+ * This also returns the previous number of digits.
+ */
+long
+math_setdigits(newdigits)
+       long newdigits;
+{
+       long olddigits;
+
+       if (newdigits < 0)
+               math_error("Setting illegal number of digits");
+       olddigits = _outdigits_;
+       _outdigits_ = newdigits;
+       return olddigits;
+}
+
+
+/*
+ * Print an integer value as a hex number.
+ * Width is the number of columns to print the number in, including the
+ * sign if required.  If zero, no extra output is done.  If positive,
+ * leading spaces are typed if necessary. If negative, trailing spaces are
+ * typed if necessary.  The special characters 0x appear to indicate the
+ * number is hex.
+ */
+/*ARGSUSED*/
+void
+zprintx(z, width)
+       ZVALUE z;
+       long width;
+{
+       register HALF *hp;      /* current word to print */
+       int len;                /* number of halfwords to type */
+       char *str;
+
+       if (width) {
+               math_divertio();
+               zprintx(z, 0L);
+               str = math_getdivertedio();
+               math_fill(str, width);
+               free(str);
+               return;
+       }
+       len = z.len - 1;
+       if (zisneg(z))
+               PUTCHAR('-');
+       if ((len == 0) && (*z.v <= (FULL) 9)) {
+               len = '0' + *z.v;
+               PUTCHAR(len);
+               return;
+       }
+       hp = z.v + len;
+       PRINTF1("0x%x", (FULL) *hp--);
+       while (--len >= 0)
+               PRINTF1("%04x", (FULL) *hp--);
+}
+
+
+/*
+ * Print an integer value as a binary number.
+ * The special characters 0b appear to indicate the number is binary.
+ */
+/*ARGSUSED*/
+void
+zprintb(z, width)
+       ZVALUE z;
+       long width;
+{
+       register HALF *hp;      /* current word to print */
+       int len;                /* number of halfwords to type */
+       HALF val;               /* current value */
+       HALF mask;              /* current mask */
+       int didprint;           /* nonzero if printed some digits */
+       int ch;                 /* current char */
+       char *str;
+
+       if (width) {
+               math_divertio();
+               zprintb(z, 0L);
+               str = math_getdivertedio();
+               math_fill(str, width);
+               free(str);
+               return;
+       }
+       len = z.len - 1;
+       if (zisneg(z))
+               PUTCHAR('-');
+       if ((len == 0) && (*z.v <= (FULL) 1)) {
+               len = '0' + *z.v;
+               PUTCHAR(len);
+               return;
+       }
+       hp = z.v + len;
+       didprint = 0;
+       PUTSTR("0b");
+       while (len-- >= 0) {
+               val = *hp--;
+               mask = (1 << (BASEB - 1));
+               while (mask) {
+                       ch = '0' + ((mask & val) != 0);
+                       if (didprint || (ch != '0')) {
+                               PUTCHAR(ch);
+                               didprint = 1;
+                       }
+                       mask >>= 1;
+               }
+       }
+}
+
+
+/*
+ * Print an integer value as an octal number.
+ * The number begins with a leading 0 to indicate that it is octal.
+ */
+/*ARGSUSED*/
+void
+zprinto(z, width)
+       ZVALUE z;
+       long width;
+{
+       register HALF *hp;      /* current word to print */
+       int len;                /* number of halfwords to type */
+       int num1='0', num2='0'; /* numbers to type */
+       int rem;                /* remainder number of halfwords */
+       char *str;
+
+       if (width) {
+               math_divertio();
+               zprinto(z, 0L);
+               str = math_getdivertedio();
+               math_fill(str, width);
+               free(str);
+               return;
+       }
+       if (zisneg(z))
+               PUTCHAR('-');
+       len = z.len;
+       if ((len == 1) && (*z.v <= (FULL) 7)) {
+               num1 = '0' + *z.v;
+               PUTCHAR(num1);
+               return;
+       }
+       hp = z.v + len - 1;
+       rem = len % 3;
+       switch (rem) {  /* handle odd amounts first */
+               case 0:
+                       num1 = (((FULL) hp[0]) << 8) + (((FULL) hp[-1]) >> 8);
+                       num2 = (((FULL) (hp[-1] & 0xff)) << 16) + ((FULL) hp[-2]);
+                       rem = 3;
+                       break;
+               case 1:
+                       num1 = 0;
+                       num2 = (FULL) hp[0];
+                       break;
+               case 2:
+                       num1 = (((FULL) hp[0]) >> 8);
+                       num2 = (((FULL) (hp[0] & 0xff)) << 16) + ((FULL) hp[-1]);
+                       break;
+       }
+       if (num1)
+               PRINTF2("0%o%08o", num1, num2);
+       else
+               PRINTF1("0%o", num2);
+       len -= rem;
+       hp -= rem;
+       while (len > 0) {       /* finish in groups of 3 halfwords */
+               num1 = (((FULL) hp[0]) << 8) + (((FULL) hp[-1]) >> 8);
+               num2 = (((FULL) (hp[-1] & 0xff)) << 16) + ((FULL) hp[-2]);
+               PRINTF2("%08o%08o", num1, num2);
+               hp -= 3;
+               len -= 3;
+       }
+}
+
+
+/*
+ * Print a decimal integer to the terminal.
+ * This works by dividing the number by 10^2^N for some N, and
+ * then doing this recursively on the quotient and remainder.
+ * Decimals supplies number of decimal places to print, with a decimal
+ * point at the right location, with zero meaning no decimal point.
+ * Width is the number of columns to print the number in, including the
+ * decimal point and sign if required.  If zero, no extra output is done.
+ * If positive, leading spaces are typed if necessary. If negative, trailing
+ * spaces are typed if necessary.  As examples of the effects of these values,
+ * (345,0,0) = "345", (345,2,0) = "3.45", (345,5,8) = "  .00345".
+ */
+void
+zprintval(z, decimals, width)
+       ZVALUE z;               /* number to be printed */
+       long decimals;          /* number of decimal places */
+       long width;             /* number of columns to print in */
+{
+       int depth;              /* maximum depth */
+       int n;                  /* current index into array */
+       int i;                  /* number to print */
+       long leadspaces;        /* number of leading spaces to print */
+       long putpoint;          /* digits until print decimal point */
+       long digits;            /* number of digits of raw number */
+       BOOL output;            /* TRUE if have output something */
+       BOOL neg;               /* TRUE if negative */
+       ZVALUE quo, rem;        /* quotient and remainder */
+       ZVALUE leftnums[32];    /* left parts of the number */
+       ZVALUE rightnums[32];   /* right parts of the number */
+
+       if (decimals < 0)
+               decimals = 0;
+       if (width < 0)
+               width = 0;
+       neg = (z.sign != 0);
+
+       leadspaces = width - neg - (decimals > 0);
+       z.sign = 0;
+       /*
+        * Find the 2^N power of ten which is greater than or equal
+        * to the number, calculating it the first time if necessary.
+        */
+       _tenpowers_[0] = _ten_;
+       depth = 0;
+       while ((_tenpowers_[depth].len < z.len) || (zrel(_tenpowers_[depth], z) <= 0)) {
+               depth++;
+               if (_tenpowers_[depth].len == 0)
+                       zsquare(_tenpowers_[depth-1], &_tenpowers_[depth]);
+       }
+       /*
+        * Divide by smaller 2^N powers of ten until the parts are small
+        * enough to output.  This algorithm walks through a binary tree
+        * where each node is a piece of the number to print, and such that
+        * we visit left nodes first.  We do the needed recursion in line.
+        */
+       digits = 1;
+       output = FALSE;
+       n = 0;
+       putpoint = 0;
+       rightnums[0].len = 0;
+       leftnums[0] = z;
+       for (;;) {
+               while (n < depth) {
+                       i = depth - n - 1;
+                       zdiv(leftnums[n], _tenpowers_[i], &quo, &rem);
+                       if (!ziszero(quo))
+                               digits += (1L << i);
+                       n++;
+                       leftnums[n] = quo;
+                       rightnums[n] = rem;
+               }
+               i = leftnums[n].v[0];
+               if (output || i || (n == 0)) {
+                       if (!output) {
+                               output = TRUE;
+                               if (decimals > digits)
+                                       leadspaces -= decimals;
+                               else
+                                       leadspaces -= digits;
+                               while (--leadspaces >= 0)
+                                       PUTCHAR(' ');
+                               if (neg)
+                                       PUTCHAR('-');
+                               if (decimals) {
+                                       putpoint = (digits - decimals);
+                                       if (putpoint <= 0) {
+                                               PUTCHAR('.');
+                                               while (++putpoint <= 0)
+                                                       PUTCHAR('0');
+                                               putpoint = 0;
+                                       }
+                               }
+                       }
+                       i += '0';
+                       PUTCHAR(i);
+                       if (--putpoint == 0)
+                               PUTCHAR('.');
+               }
+               while (rightnums[n].len == 0) {
+                       if (n <= 0)
+                               return;
+                       if (leftnums[n].len)
+                               zfree(leftnums[n]);
+                       n--;
+               }
+               zfree(leftnums[n]);
+               leftnums[n] = rightnums[n];
+               rightnums[n].len = 0;
+       }
+}
+
+
+/*
+ * Read an integer value in decimal, hex, octal, or binary.
+ * Hex numbers are indicated by a leading "0x", binary with a leading "0b",
+ * and octal by a leading "0".  Periods are skipped over, but any other
+ * extraneous character stops the scan.
+ */
+void
+atoz(s, res)
+       register char *s;
+       ZVALUE *res;
+{
+       ZVALUE z, ztmp, digit;
+       HALF digval;
+       BOOL minus;
+       long shift;
+
+       minus = FALSE;
+       shift = 0;
+       if (*s == '+')
+               s++;
+       else if (*s == '-') {
+               minus = TRUE;
+               s++;
+       }
+       if (*s == '0') {                /* possibly hex, octal, or binary */
+               s++;
+               if ((*s >= '0') && (*s <= '7')) {
+                       shift = 3;
+               } else if ((*s == 'x') || (*s == 'X')) {
+                       shift = 4;
+                       s++;
+               } else if ((*s == 'b') || (*s == 'B')) {
+                       shift = 1;
+                       s++;
+               }
+       }
+       digit.v = &digval;
+       digit.len = 1;
+       digit.sign = 0;
+       z = _zero_;
+       while (*s) {
+               digval = *s++;
+               if ((digval >= '0') && (digval <= '9'))
+                       digval -= '0';
+               else if ((digval >= 'a') && (digval <= 'f') && shift)
+                       digval -= ('a' - 10);
+               else if ((digval >= 'A') && (digval <= 'F') && shift)
+                       digval -= ('A' - 10);
+               else if (digval == '.')
+                       continue;
+               else
+                       break;
+               if (shift)
+                       zshift(z, shift, &ztmp);
+               else
+                       zmuli(z, 10L, &ztmp);
+               zfree(z);
+               zadd(ztmp, digit, &z);
+               zfree(ztmp);
+       }
+       ztrim(&z);
+       if (minus && !ziszero(z))
+               z.sign = 1;
+       *res = z;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/zmath.c b/usr/src/contrib/calc-2.9.3t6/zmath.c
new file mode 100644 (file)
index 0000000..4c58b0f
--- /dev/null
@@ -0,0 +1,1677 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Extended precision integral arithmetic primitives
+ */
+
+#include "zmath.h"
+
+
+HALF _twoval_[] = { 2 };
+HALF _zeroval_[] = { 0 };
+HALF _oneval_[] = { 1 };
+HALF _tenval_[] = { 10 };
+
+ZVALUE _zero_ = { _zeroval_, 1, 0};
+ZVALUE _one_ = { _oneval_, 1, 0 };
+ZVALUE _ten_ = { _tenval_, 1, 0 };
+
+
+/*
+ * mask of given bits, rotated thru all bit positions twice
+ *
+ * bitmask[i]   (1 << (i-1)),  for  -BASEB*4<=i<=BASEB*4
+ */
+static HALF *bmask;            /* actual rotation thru 8 cycles */
+static HALF **rmask;           /* actual rotation pointers thru 2 cycles */
+HALF *bitmask;                 /* bit rotation, norm 0 */
+
+BOOL _math_abort_;             /* nonzero to abort calculations */
+
+
+static void dadd MATH_PROTO((ZVALUE z1, ZVALUE z2, long y, long n));
+static BOOL dsub MATH_PROTO((ZVALUE z1, ZVALUE z2, long y, long n));
+static void dmul MATH_PROTO((ZVALUE z, FULL x, ZVALUE *dest));
+
+
+#ifdef ALLOCTEST
+static long nalloc = 0;
+static long nfree = 0;
+#endif
+
+
+HALF *
+alloc(len)
+       long len;
+{
+       HALF *hp;
+
+       if (_math_abort_)
+               math_error("Calculation aborted");
+       hp = (HALF *) malloc((len+1) * sizeof(HALF));
+       if (hp == 0)
+               math_error("Not enough memory");
+#ifdef ALLOCTEST
+       ++nalloc;
+#endif
+       return hp;
+}
+
+
+#ifdef ALLOCTEST
+void
+freeh(h)
+       HALF *h;
+{
+       if ((h != _zeroval_) && (h != _oneval_)) {
+               free(h);
+               ++nfree;
+       }
+}
+
+
+void
+allocStat()
+{
+       fprintf(stderr, "nalloc: %ld nfree: %ld kept: %ld\n",
+               nalloc, nfree, nalloc - nfree);
+}
+#endif
+
+
+/*
+ * Convert a normal integer to a number.
+ */
+void
+itoz(i, res)
+       long i;
+       ZVALUE *res;
+{
+       long diddle, len;
+
+       res->len = 1;
+       res->sign = 0;
+       diddle = 0;
+       if (i == 0) {
+               res->v = _zeroval_;
+               return;
+       }
+       if (i < 0) {
+               res->sign = 1;
+               i = -i;
+               if (i < 0) {    /* fix most negative number */
+                       diddle = 1;
+                       i--;
+               }
+       }
+       if (i == 1) {
+               res->v = _oneval_;
+               return;
+       }
+       len = 1 + (((FULL) i) >= BASE);
+       res->len = len;
+       res->v = alloc(len);
+       res->v[0] = (HALF) (i + diddle);
+       if (len == 2)
+               res->v[1] = (HALF) (i / BASE);
+}
+
+
+/*
+ * Convert a number to a normal integer, as far as possible.
+ * If the number is out of range, the largest number is returned.
+ */
+long
+ztoi(z)
+       ZVALUE z;
+{
+       long i;
+
+       if (zisbig(z)) {
+               i = MAXFULL;
+               return (z.sign ? -i : i);
+       }
+       i = (zistiny(z) ? z1tol(z) : z2tol(z));
+       return (z.sign ? -i : i);
+}
+
+
+/*
+ * Make a copy of an integer value
+ */
+void
+zcopy(z, res)
+       ZVALUE z, *res;
+{
+       res->sign = z.sign;
+       res->len = z.len;
+       if (zisleone(z)) {      /* zero or plus or minus one are easy */
+               res->v = (z.v[0] ? _oneval_ : _zeroval_);
+               return;
+       }
+       res->v = alloc(z.len);
+       zcopyval(z, *res);
+}
+
+
+/*
+ * Add together two integers.
+ */
+void
+zadd(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       ZVALUE dest;
+       HALF *p1, *p2, *pd;
+       long len;
+       FULL carry;
+       SIUNION sival;
+
+       if (z1.sign && !z2.sign) {
+               z1.sign = 0;
+               zsub(z2, z1, res);
+               return;
+       }
+       if (z2.sign && !z1.sign) {
+               z2.sign = 0;
+               zsub(z1, z2, res);
+               return;
+       }
+       if (z2.len > z1.len) {
+               pd = z1.v; z1.v = z2.v; z2.v = pd;
+               len = z1.len; z1.len = z2.len; z2.len = len;
+       }
+       dest.len = z1.len + 1;
+       dest.v = alloc(dest.len);
+       dest.sign = z1.sign;
+       carry = 0;
+       pd = dest.v;
+       p1 = z1.v;
+       p2 = z2.v;
+       len = z2.len;
+       while (len--) {
+               sival.ivalue = ((FULL) *p1++) + ((FULL) *p2++) + carry;
+               *pd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       len = z1.len - z2.len;
+       while (len--) {
+               sival.ivalue = ((FULL) *p1++) + carry;
+               *pd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       *pd = (HALF)carry;
+       zquicktrim(dest);
+       *res = dest;
+}
+
+
+/*
+ * Subtract two integers.
+ */
+void
+zsub(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       register HALF *h1, *h2, *hd;
+       long len1, len2;
+       FULL carry;
+       SIUNION sival;
+       ZVALUE dest;
+
+       if (z1.sign != z2.sign) {
+               z2.sign = z1.sign;
+               zadd(z1, z2, res);
+               return;
+       }
+       len1 = z1.len;
+       len2 = z2.len;
+       if (len1 == len2) {
+               h1 = z1.v + len1 - 1;
+               h2 = z2.v + len2 - 1;
+               while ((len1 > 0) && ((FULL)*h1 == (FULL)*h2)) {
+                       len1--;
+                       h1--;
+                       h2--;
+               }
+               if (len1 == 0) {
+                       *res = _zero_;
+                       return;
+               }
+               len2 = len1;
+               carry = ((FULL)*h1 < (FULL)*h2);
+       } else {
+               carry = (len1 < len2);
+       }
+       dest.sign = z1.sign;
+       h1 = z1.v;
+       h2 = z2.v;
+       if (carry) {
+               carry = len1;
+               len1 = len2;
+               len2 = carry;
+               h1 = z2.v;
+               h2 = z1.v;
+               dest.sign = !dest.sign;
+       }
+       hd = alloc(len1);
+       dest.v = hd;
+       dest.len = len1;
+       len1 -= len2;
+       carry = 0;
+       while (--len2 >= 0) {
+               sival.ivalue = (BASE1 - ((FULL) *h1++)) + *h2++ + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+       while (--len1 >= 0) {
+               sival.ivalue = (BASE1 - ((FULL) *h1++)) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+       if (hd[-1] == 0)
+               ztrim(&dest);
+       *res = dest;
+}
+
+
+/*
+ * Multiply an integer by a small number.
+ */
+void
+zmuli(z, n, res)
+       ZVALUE z;
+       long n;
+       ZVALUE *res;
+{
+       register HALF *h1, *sd;
+       FULL low;
+       FULL high;
+       FULL carry;
+       long len;
+       SIUNION sival;
+       ZVALUE dest;
+
+       if ((n == 0) || ziszero(z)) {
+               *res = _zero_;
+               return;
+       }
+       if (n < 0) {
+               n = -n;
+               z.sign = !z.sign;
+       }
+       if (n == 1) {
+               zcopy(z, res);
+               return;
+       }
+       low = ((FULL) n) & BASE1;
+       high = ((FULL) n) >> BASEB;
+       dest.len = z.len + 2;
+       dest.v = alloc(dest.len);
+       dest.sign = z.sign;
+       /*
+        * Multiply by the low digit.
+        */
+       h1 = z.v;
+       sd = dest.v;
+       len = z.len;
+       carry = 0;
+       while (len--) {
+               sival.ivalue = ((FULL) *h1++) * low + carry;
+               *sd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       *sd = (HALF)carry;
+       /*
+        * If there was only one digit, then we are all done except
+        * for trimming the number if there was no last carry.
+        */
+       if (high == 0) {
+               dest.len--;
+               if (carry == 0)
+                       dest.len--;
+               *res = dest;
+               return;
+       }
+       /*
+        * Need to multiply by the high digit and add it into the
+        * previous value.  Clear the final word of rubbish first.
+        */
+       *(++sd) = 0;
+       h1 = z.v;
+       sd = dest.v + 1;
+       len = z.len;
+       carry = 0;
+       while (len--) {
+               sival.ivalue = ((FULL) *h1++) * high + ((FULL) *sd) + carry;
+               *sd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       *sd = (HALF)carry;
+       zquicktrim(dest);
+       *res = dest;
+}
+
+
+/*
+ * Divide two numbers by their greatest common divisor.
+ * This is useful for reducing the numerator and denominator of
+ * a fraction to its lowest terms.
+ */
+void
+zreduce(z1, z2, z1res, z2res)
+       ZVALUE z1, z2, *z1res, *z2res;
+{
+       ZVALUE tmp;
+
+       if (zisleone(z1) || zisleone(z2))
+               tmp = _one_;
+       else
+               zgcd(z1, z2, &tmp);
+       if (zisunit(tmp)) {
+               zcopy(z1, z1res);
+               zcopy(z2, z2res);
+       } else {
+               zquo(z1, tmp, z1res);
+               zquo(z2, tmp, z2res);
+       }
+       zfree(tmp);
+}
+
+
+/*
+ * Divide two numbers to obtain a quotient and remainder.
+ * This algorithm is taken from
+ * Knuth, The Art of Computer Programming, vol 2: Seminumerical Algorithms.
+ * Slight modifications were made to speed this mess up.
+ */
+void
+zdiv(z1, z2, res, rem)
+       ZVALUE z1, z2, *res, *rem;
+{
+       long i, j, k;
+       register HALF *q, *pp;
+       SIUNION pair;           /* pair of halfword values */
+       HALF h2, v2;
+       long y;
+       FULL x;
+       ZVALUE ztmp1, ztmp2, ztmp3, quo;
+
+       if (ziszero(z2))
+               math_error("Division by zero");
+       if (ziszero(z1)) {
+               *res = _zero_;
+               *rem = _zero_;
+               return;
+       }
+       if (zisone(z2)) {
+               zcopy(z1, res);
+               *rem = _zero_;
+               return;
+       }
+       i = BASE / 2;
+       j = 0;
+       k = (long) z2.v[z2.len - 1];
+       while (! (k & i)) {
+               j ++;
+               i >>= 1;
+       }
+       ztmp1.v = alloc(z1.len + 1);
+       ztmp1.len = z1.len + 1;
+       zcopyval(z1, ztmp1);
+       ztmp1.v[z1.len] = 0;
+       ztmp1.sign = 0;
+       ztmp2.v = alloc(z2.len);
+       ztmp2.len = z2.len;
+       ztmp2.sign = 0;
+       zcopyval(z2, ztmp2);
+       if (zrel(ztmp1, ztmp2) < 0) {
+               rem->v = ztmp1.v;
+               rem->sign = z1.sign;
+               rem->len = z1.len;
+               zfree(ztmp2);
+               *res = _zero_;
+               return;
+       }
+       quo.len = z1.len - z2.len + 1;
+       quo.v = alloc(quo.len);
+       quo.sign = z1.sign != z2.sign;
+       zclearval(quo);
+
+       ztmp3.v = zalloctemp(z2.len + 1);
+
+       /*
+        * Normalize z1 and z2
+        */
+       zshiftl(ztmp1, j);
+       zshiftl(ztmp2, j);
+
+       k = ztmp1.len - ztmp2.len;
+       q = quo.v + quo.len;
+       y = ztmp1.len - 1;
+       h2 = ztmp2.v [ztmp2.len - 1];
+       v2 = 0;
+       if (ztmp2.len >= 2)
+               v2 = ztmp2.v [ztmp2.len - 2];
+       for (;k--; --y) {
+               pp = ztmp1.v + y - 1;
+               pair.silow = pp[0];
+               pair.sihigh = pp[1];
+               if (ztmp1.v[y] == h2)
+                       x = BASE1;
+               else
+                       x = pair.ivalue / h2;
+               if (x) {
+                       while (pair.ivalue - x * h2 < BASE && y > 1 &&
+                               v2 * x > (pair.ivalue - x * h2) * BASE + ztmp1.v [y-2]) {
+                                       --x;
+                       }
+                       dmul(ztmp2, x, &ztmp3);
+#ifdef divblab
+                       printf(" x: %ld\n", x);
+                       printf("ztmp1: ");
+                       printz(ztmp1);
+                       printf("ztmp2: ");
+                       printz(ztmp2);
+                       printf("ztmp3: ");
+                       printz(ztmp3);
+#endif
+                       if (dsub(ztmp1, ztmp3, y, ztmp2.len)) {
+                               --x;
+                               /*
+                               printf("adding back\n");
+                               */
+                               dadd(ztmp1, ztmp2, y, ztmp2.len);
+                       }
+               }
+               ztrim(&ztmp1);
+               *--q = (HALF)x;
+       }
+       zshiftr(ztmp1, j);
+       *rem = ztmp1;
+       ztrim(rem);
+       zfree(ztmp2);
+       ztrim(&quo);
+       *res = quo;
+}
+
+
+/*
+ * Return the quotient and remainder of an integer divided by a small
+ * number.  A nonzero remainder is only meaningful when both numbers
+ * are positive.
+ */
+long
+zdivi(z, n, res)
+       ZVALUE z, *res;
+       long n;
+{
+       register HALF *h1, *sd;
+       FULL val;
+       HALF divval[2];
+       ZVALUE div;
+       ZVALUE dest;
+       long len;
+
+       if (n == 0)
+               math_error("Division by zero");
+       if (ziszero(z)) {
+               *res = _zero_;
+               return 0;
+       }
+       if (n < 0) {
+               n = -n;
+               z.sign = !z.sign;
+       }
+       if (n == 1) {
+               zcopy(z, res);
+               return 0;
+       }
+       /*
+        * If the division is by a large number, then call the normal
+        * divide routine.
+        */
+       if (n & ~BASE1) {
+               div.sign = 0;
+               div.len = 2;
+               div.v = divval;
+               divval[0] = (HALF) n;
+               divval[1] = ((FULL) n) >> BASEB;
+               zdiv(z, div, res, &dest);
+               n = (zistiny(dest) ? z1tol(dest) : z2tol(dest));
+               zfree(dest);
+               return n;
+       }
+       /*
+        * Division is by a small number, so we can be quick about it.
+        */
+       len = z.len;
+       dest.sign = z.sign;
+       dest.len = len;
+       dest.v = alloc(len);
+       h1 = z.v + len - 1;
+       sd = dest.v + len - 1;
+       val = 0;
+       while (len--) {
+               val = ((val << BASEB) + ((FULL) *h1--));
+               *sd-- = val / n;
+               val %= n;
+       }
+       zquicktrim(dest);
+       *res = dest;
+       return val;
+}
+
+
+/*
+ * Return the quotient of two numbers.
+ * This works the same as zdiv, except that the remainer is not returned.
+ */
+void
+zquo(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       long i, j, k;
+       register HALF *q, *pp;
+       SIUNION pair;                   /* pair of halfword values */
+       HALF h2, v2;
+       long y;
+       FULL x;
+       ZVALUE ztmp1, ztmp2, ztmp3, quo;
+
+       if (ziszero(z2))
+               math_error("Division by zero");
+       if (ziszero(z1)) {
+               *res = _zero_;
+               return;
+       }
+       if (zisone(z2)) {
+               zcopy(z1, res);
+               return;
+       }
+       i = BASE / 2;
+       j = 0;
+       k = (long) z2.v[z2.len - 1];
+       while (! (k & i)) {
+               j ++;
+               i >>= 1;
+       }
+       ztmp1.v = alloc(z1.len + 1);
+       ztmp1.len = z1.len + 1;
+       zcopyval(z1, ztmp1);
+       ztmp1.v[z1.len] = 0;
+       ztmp1.sign = 0;
+       ztmp2.v = alloc(z2.len);
+       ztmp2.len = z2.len;
+       ztmp2.sign = 0;
+       zcopyval(z2, ztmp2);
+       if (zrel(ztmp1, ztmp2) < 0) {
+               zfree(ztmp1);
+               zfree(ztmp2);
+               *res = _zero_;
+               return;
+       }
+       quo.len = z1.len - z2.len + 1;
+       quo.v = alloc(quo.len);
+       quo.sign = z1.sign != z2.sign;
+       zclearval(quo);
+
+       ztmp3.v = zalloctemp(z2.len + 1);
+
+       /*
+        * Normalize z1 and z2
+        */
+       zshiftl(ztmp1, j);
+       zshiftl(ztmp2, j);
+
+       k = ztmp1.len - ztmp2.len;
+       q = quo.v + quo.len;
+       y = ztmp1.len - 1;
+       h2 = ztmp2.v [ztmp2.len - 1];
+       v2 = 0;
+       if (ztmp2.len >= 2)
+               v2 = ztmp2.v [ztmp2.len - 2];
+       for (;k--; --y) {
+               pp = ztmp1.v + y - 1;
+               pair.silow = pp[0];
+               pair.sihigh = pp[1];
+               if (ztmp1.v[y] == h2)
+                       x = BASE1;
+               else
+                       x = pair.ivalue / h2;
+               if (x) {
+                       while (pair.ivalue - x * h2 < BASE && y > 1 &&
+                               v2 * x > (pair.ivalue - x * h2) * BASE + ztmp1.v [y-2]) {
+                                       --x;
+                       }
+                       dmul(ztmp2, x, &ztmp3);
+                       if (dsub(ztmp1, ztmp3, y, ztmp2.len)) {
+                               --x;
+                               dadd(ztmp1, ztmp2, y, ztmp2.len);
+                       }
+               }
+               ztrim(&ztmp1);
+               *--q = (HALF)x;
+       }
+       zfree(ztmp1);
+       zfree(ztmp2);
+       ztrim(&quo);
+       *res = quo;
+}
+
+
+/*
+ * Compute the remainder after dividing one number by another.
+ * This is only defined for positive z2 values.
+ * The result is normalized to lie in the range 0 to z2-1.
+ */
+void
+zmod(z1, z2, rem)
+       ZVALUE z1, z2, *rem;
+{
+       long i, j, k, neg;
+       register HALF *pp;
+       SIUNION pair;                   /* pair of halfword values */
+       HALF h2, v2;
+       long y;
+       FULL x;
+       ZVALUE ztmp1, ztmp2, ztmp3;
+
+       if (ziszero(z2))
+               math_error("Division by zero");
+       if (zisneg(z2))
+               math_error("Non-positive modulus");
+       if (ziszero(z1) || zisunit(z2)) {
+               *rem = _zero_;
+               return;
+       }
+       if (zistwo(z2)) {
+               if (zisodd(z1))
+                       *rem = _one_;
+               else
+                       *rem = _zero_;
+               return;
+       }
+       neg = z1.sign;
+       z1.sign = 0;
+
+       /*
+        * Do a quick check to see if the absolute value of the number
+        * is less than the modulus.  If so, then the result is just a
+        * subtract or a copy.
+        */
+       h2 = z1.v[z1.len - 1];
+       v2 = z2.v[z2.len - 1];
+       if ((z1.len < z2.len) || ((z1.len == z2.len) && (h2 < v2))) {
+               if (neg)
+                       zsub(z2, z1, rem);
+               else
+                       zcopy(z1, rem);
+               return;
+       }
+
+       /*
+        * Do another quick check to see if the number is positive and
+        * between the size of the modulus and twice the modulus.
+        * If so, then the answer is just another subtract.
+        */
+       if (!neg && (z1.len == z2.len) && (h2 > v2) &&
+               (((FULL) h2) < 2 * ((FULL) v2)))
+       {
+               zsub(z1, z2, rem);
+               return;
+       }
+
+       /*
+        * If the modulus is an exact power of two, then the result
+        * can be obtained by ignoring the high bits of the number.
+        * This truncation assumes that the number of words for the
+        * number is at least as large as the number of words in the
+        * modulus, which is true at this point.
+        */
+       if (((v2 & -v2) == v2) && zisonebit(z2)) {      /* ASSUMES 2'S COMP */
+               i = zhighbit(z2);
+               z1.len = (i + BASEB - 1) / BASEB;
+               zcopy(z1, &ztmp1);
+               i %= BASEB;
+               if (i)
+                       ztmp1.v[ztmp1.len - 1] &= ((((HALF) 1) << i) - 1);
+               ztmp2.len = 0;
+               goto gotanswer;
+       }
+
+       /*
+        * If the modulus is one less than an exact power of two, then
+        * the result can be simplified similarly to "casting out 9's".
+        * Only do this simplification for large enough modulos.
+        */
+       if ((z2.len > 1) && (z2.v[0] == BASE1) && zisallbits(z2)) {
+               i = -(zhighbit(z2) + 1);
+               zcopy(z1, &ztmp1);
+               z1 = ztmp1;
+               while ((k = zrel(z1, z2)) > 0) {
+                       ztmp1 = _zero_;
+                       while (!ziszero(z1)) {
+                               zand(z1, z2, &ztmp2);
+                               zadd(ztmp2, ztmp1, &ztmp3);
+                               zfree(ztmp1);
+                               zfree(ztmp2);
+                               ztmp1 = ztmp3;
+                               zshift(z1, i, &ztmp2);
+                               zfree(z1);
+                               z1 = ztmp2;
+                       }
+                       zfree(z1);
+                       z1 = ztmp1;
+               }
+               if (k == 0) {
+                       zfree(ztmp1);
+                       *rem = _zero_;
+                       return;
+               }
+               ztmp2.len = 0;
+               goto gotanswer;
+       }
+
+       /*
+        * Must actually do the divide.
+        */
+       i = BASE / 2;
+       j = 0;
+       k = (long) z2.v[z2.len - 1];
+       while (! (k & i)) {
+               j ++;
+               i >>= 1;
+       }
+       ztmp1.v = alloc(z1.len + 1);
+       ztmp1.len = z1.len + 1;
+       zcopyval(z1, ztmp1);
+       ztmp1.v[z1.len] = 0;
+       ztmp1.sign = 0;
+       ztmp2.v = alloc(z2.len);
+       ztmp2.len = z2.len;
+       ztmp2.sign = 0;
+       zcopyval(z2, ztmp2);
+       if (zrel(ztmp1, ztmp2) < 0)
+               goto gotanswer;
+
+       ztmp3.v = zalloctemp(z2.len + 1);
+
+       /*
+        * Normalize z1 and z2
+        */
+       zshiftl(ztmp1, j);
+       zshiftl(ztmp2, j);
+
+       k = ztmp1.len - ztmp2.len;
+       y = ztmp1.len - 1;
+       h2 = ztmp2.v [ztmp2.len - 1];
+       v2 = 0;
+       if (ztmp2.len >= 2)
+               v2 = ztmp2.v [ztmp2.len - 2];
+       for (;k--; --y) {
+               pp = ztmp1.v + y - 1;
+               pair.silow = pp[0];
+               pair.sihigh = pp[1];
+               if (ztmp1.v[y] == h2)
+                       x = BASE1;
+               else
+                       x = pair.ivalue / h2;
+               if (x) {
+                       while (pair.ivalue - x * h2 < BASE && y > 1 &&
+                               v2 * x > (pair.ivalue - x * h2) * BASE + ztmp1.v [y-2]) {
+                                       --x;
+                       }
+                       dmul(ztmp2, x, &ztmp3);
+                       if (dsub(ztmp1, ztmp3, y, ztmp2.len))
+                               dadd(ztmp1, ztmp2, y, ztmp2.len);
+               }
+               ztrim(&ztmp1);
+       }
+       zshiftr(ztmp1, j);
+
+gotanswer:
+       ztrim(&ztmp1);
+       if (ztmp2.len)
+               zfree(ztmp2);
+       if (neg && !ziszero(ztmp1)) {
+               zsub(z2, ztmp1, rem);
+               zfree(ztmp1);
+       } else
+               *rem = ztmp1;
+}
+
+
+/*
+ * Calculate the mod of an integer by a small number.
+ * This is only defined for positive moduli.
+ */
+long
+zmodi(z, n)
+       ZVALUE z;
+       long n;
+{
+       register HALF *h1;
+       FULL val;
+       HALF divval[2];
+       ZVALUE div;
+       ZVALUE temp;
+       long len;
+
+       if (n == 0)
+               math_error("Division by zero");
+       if (n < 0)
+               math_error("Non-positive modulus");
+       if (ziszero(z) || (n == 1))
+               return 0;
+       if (zisone(z))
+               return 1;
+       /*
+        * If the modulus is by a large number, then call the normal
+        * modulo routine.
+        */
+       if (n & ~BASE1) {
+               div.sign = 0;
+               div.len = 2;
+               div.v = divval;
+               divval[0] = (HALF) n;
+               divval[1] = ((FULL) n) >> BASEB;
+               zmod(z, div, &temp);
+               n = (zistiny(temp) ? z1tol(temp) : z2tol(temp));
+               zfree(temp);
+               return n;
+       }
+       /*
+        * The modulus is by a small number, so we can do this quickly.
+        */
+       len = z.len;
+       h1 = z.v + len - 1;
+       val = 0;
+       while (len--)
+               val = ((val << BASEB) + ((FULL) *h1--)) % n;
+       if (z.sign)
+               val = n - val;
+       return val;
+}
+
+
+/*
+ * Return whether or not one number exactly divides another one.
+ * Returns TRUE if division occurs with no remainder.
+ * z1 is the number to be divided by z2.
+ */
+BOOL
+zdivides(z1, z2)
+       ZVALUE z1, z2;          /* numbers to test division into and by */
+{
+       ZVALUE temp;
+       long cv;
+
+       z1.sign = 0;
+       z2.sign = 0;
+       /*
+        * Take care of obvious cases first
+        */
+       if (zisleone(z2)) {     /* division by zero or one */
+               if (*z2.v == 0)
+                       math_error("Division by zero");
+               return TRUE;
+       }
+       if (ziszero(z1))        /* everything divides zero */
+               return TRUE;
+       if (z1.len < z2.len)    /* quick size comparison */
+               return FALSE;
+       if ((z1.len == z2.len) && (z1.v[z1.len-1] < z2.v[z2.len-1]))    /* more */
+               return FALSE;
+       if (zisodd(z1) && ziseven(z2))  /* can't divide odd by even */
+               return FALSE;
+       if (zlowbit(z1) < zlowbit(z2))  /* can't have smaller power of two */
+               return FALSE;
+       cv = zrel(z1, z2);      /* can't divide smaller number */
+       if (cv <= 0)
+               return (cv == 0);
+       /*
+        * Now do the real work.  Divisor divides dividend if the gcd of the
+        * two numbers equals the divisor.
+        */
+       zgcd(z1, z2, &temp);
+       cv = zcmp(z2, temp);
+       zfree(temp);
+       return (cv == 0);
+}
+
+
+/*
+ * Compute the logical OR of two numbers
+ */
+void
+zor(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       register HALF *sp, *dp;
+       long len;
+       ZVALUE bz, lz, dest;
+
+       if (z1.len >= z2.len) {
+               bz = z1;
+               lz = z2;
+       } else {
+               bz = z2;
+               lz = z1;
+       }
+       dest.len = bz.len;
+       dest.v = alloc(dest.len);
+       dest.sign = 0;
+       zcopyval(bz, dest);
+       len = lz.len;
+       sp = lz.v;
+       dp = dest.v;
+       while (len--)
+               *dp++ |= *sp++;
+       *res = dest;
+}
+
+
+/*
+ * Compute the logical AND of two numbers.
+ */
+void
+zand(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       register HALF *h1, *h2, *hd;
+       register long len;
+       ZVALUE dest;
+
+       len = ((z1.len <= z2.len) ? z1.len : z2.len);
+       h1 = &z1.v[len-1];
+       h2 = &z2.v[len-1];
+       while ((len > 1) && ((*h1 & *h2) == 0)) {
+               h1--;
+               h2--;
+               len--;
+       }
+       dest.len = len;
+       dest.v = alloc(len);
+       dest.sign = 0;
+       h1 = z1.v;
+       h2 = z2.v;
+       hd = dest.v;
+       while (len--)
+               *hd++ = (*h1++ & *h2++);
+       *res = dest;
+}
+
+
+/*
+ * Compute the logical XOR of two numbers.
+ */
+void
+zxor(z1, z2, res)
+       ZVALUE z1, z2, *res;
+{
+       register HALF *sp, *dp;
+       long len;
+       ZVALUE bz, lz, dest;
+
+       if (z1.len == z2.len) {
+               for (len = z1.len; ((len > 1) && (z1.v[len-1] == z2.v[len-1])); len--) ;
+               z1.len = len;
+               z2.len = len;
+       }
+       if (z1.len >= z2.len) {
+               bz = z1;
+               lz = z2;
+       } else {
+               bz = z2;
+               lz = z1;
+       }
+       dest.len = bz.len;
+       dest.v = alloc(dest.len);
+       dest.sign = 0;
+       zcopyval(bz, dest);
+       len = lz.len;
+       sp = lz.v;
+       dp = dest.v;
+       while (len--)
+               *dp++ ^= *sp++;
+       *res = dest;
+}
+
+
+/*
+ * Shift a number left (or right) by the specified number of bits.
+ * Positive shift means to the left.  When shifting right, rightmost
+ * bits are lost.  The sign of the number is preserved.
+ */
+void
+zshift(z, n, res)
+       ZVALUE z, *res;
+       long n;
+{
+       ZVALUE ans;
+       long hc;                /* number of halfwords shift is by */
+
+       if (ziszero(z)) {
+               *res = _zero_;
+               return;
+       }
+       if (n == 0) {
+               zcopy(z, res);
+               return;
+       }
+       /*
+        * If shift value is negative, then shift right.
+        * Check for large shifts, and handle word-sized shifts quickly.
+        */
+       if (n < 0) {
+               n = -n;
+               if ((n < 0) || (n >= (z.len * BASEB))) {
+                       *res = _zero_;
+                       return;
+               }
+               hc = n / BASEB;
+               n %= BASEB;
+               z.v += hc;
+               z.len -= hc;
+               ans.len = z.len;
+               ans.v = alloc(ans.len);
+               ans.sign = z.sign;
+               zcopyval(z, ans);
+               if (n > 0) {
+                       zshiftr(ans, n);
+                       ztrim(&ans);
+               }
+               if (ziszero(ans)) {
+                       zfree(ans);
+                       ans = _zero_;
+               }
+               *res = ans;
+               return;
+       }
+       /*
+        * Shift value is positive, so shift leftwards.
+        * Check specially for a shift of the value 1, since this is common.
+        * Also handle word-sized shifts quickly.
+        */
+       if (zisunit(z)) {
+               zbitvalue(n, res);
+               res->sign = z.sign;
+               return;
+       }
+       hc = n / BASEB;
+       n %= BASEB;
+       ans.len = z.len + hc + 1;
+       ans.v = alloc(ans.len);
+       ans.sign = z.sign;
+       if (hc > 0)
+               memset((char *) ans.v, 0, hc * sizeof(HALF));
+       memcpy((char *) (ans.v + hc), 
+           (char *) z.v, z.len * sizeof(HALF));
+       ans.v[ans.len - 1] = 0;
+       if (n > 0) {
+               ans.v += hc;
+               ans.len -= hc;
+               zshiftl(ans, n);
+               ans.v -= hc;
+               ans.len += hc;
+       }
+       ztrim(&ans);
+       *res = ans;
+}
+
+
+/*
+ * Return the position of the lowest bit which is set in the binary
+ * representation of a number (counting from zero).  This is the highest
+ * power of two which evenly divides the number.
+ */
+long
+zlowbit(z)
+       ZVALUE z;
+{
+       register HALF *zp;
+       long n;
+       HALF dataval;
+       HALF *bitval;
+
+       n = 0;
+       for (zp = z.v; *zp == 0; zp++)
+               if (++n >= z.len)
+                       return 0;
+       dataval = *zp;
+       bitval = bitmask;
+       while ((*(bitval++) & dataval) == 0) {
+       }
+       return (n*BASEB)+(bitval-bitmask-1);
+}
+
+
+/*
+ * Return the position of the highest bit which is set in the binary
+ * representation of a number (counting from zero).  This is the highest power
+ * of two which is less than or equal to the number (which is assumed nonzero).
+ */
+long
+zhighbit(z)
+       ZVALUE z;
+{
+       HALF dataval;
+       HALF *bitval;
+
+       dataval = z.v[z.len-1];
+       bitval = bitmask+BASEB;
+       if (dataval) {
+               while ((*(--bitval) & dataval) == 0) {
+               }
+       }
+       return (z.len*BASEB)+(bitval-bitmask-BASEB);
+}
+
+
+#if 0
+/*
+ * Reverse the bits of a particular range of bits of a number.
+ *
+ * This function returns an integer with bits a thru b swapped.
+ * That is, bit a is swapped with bit b, bit a+1 is swapped with b-1,
+ * and so on.
+ *
+ * As a special case, if the ending bit position is < 0, is it taken to 
+ * mean the highest bit set.  Thus zbitrev(0, -1, z, &res) will 
+ * perform a complete bit reverse of the number 'z'.
+ *
+ * As a special case, if the starting bit position is < 0, is it taken to 
+ * mean the lowest bit set.  Thus zbitrev(-1, -1, z, &res) is the
+ * same as zbitrev(lowbit(z), highbit(z), z, &res).
+ *
+ * Note that the low order bit number is taken to be 0.  Also, bitrev
+ * ignores the sign of the number.
+ *
+ * Bits beyond the highest bit are taken to be zero.  Thus the calling
+ * bitrev(0, 100, _one_, &res) will result in a value of 2^100.
+ */
+void
+zbitrev(low, high, z, res)
+       long low;       /* lowest bit to reverse, <0 => lowbit(z) */
+       long high;      /* highest bit to reverse, <0 => highbit(z) */
+       ZVALUE z;       /* value to bit reverse */
+       ZVALUE *res;    /* resulting bit reverse number */
+{
+}
+#endif
+
+
+/*
+ * Return whether or not the specifed bit number is set in a number.
+ * Rightmost bit of a number is bit 0.
+ */
+BOOL
+zisset(z, n)
+       ZVALUE z;
+       long n;
+{
+       if ((n < 0) || ((n / BASEB) >= z.len))
+               return FALSE;
+       return ((z.v[n / BASEB] & (((HALF) 1) << (n % BASEB))) != 0);
+}
+
+
+/*
+ * Check whether or not a number has exactly one bit set, and
+ * thus is an exact power of two.  Returns TRUE if so.
+ */
+BOOL
+zisonebit(z)
+       ZVALUE z;
+{
+       register HALF *hp;
+       register LEN len;
+
+       if (ziszero(z) || zisneg(z))
+               return FALSE;
+       hp = z.v;
+       len = z.len;
+       while (len > 4) {
+               len -= 4;
+               if (*hp++ || *hp++ || *hp++ || *hp++)
+                       return FALSE;
+       }
+       while (--len > 0) {
+               if (*hp++)
+                       return FALSE;
+       }
+       return ((*hp & -*hp) == *hp);           /* NEEDS 2'S COMPLEMENT */
+}
+
+
+/*
+ * Check whether or not a number has all of its bits set below some
+ * bit position, and thus is one less than an exact power of two.
+ * Returns TRUE if so.
+ */
+BOOL
+zisallbits(z)
+       ZVALUE z;
+{
+       register HALF *hp;
+       register LEN len;
+       HALF digit;
+
+       if (ziszero(z) || zisneg(z))
+               return FALSE;
+       hp = z.v;
+       len = z.len;
+       while (len > 4) {
+               len -= 4;
+               if ((*hp++ != BASE1) || (*hp++ != BASE1) ||
+                       (*hp++ != BASE1) || (*hp++ != BASE1))
+                               return FALSE;
+       }
+       while (--len > 0) {
+               if (*hp++ != BASE1)
+                       return FALSE;
+       }
+       digit = (HALF)(*hp + 1);
+       return ((digit & -digit) == digit);     /* NEEDS 2'S COMPLEMENT */
+}
+
+
+/*
+ * Return the number whose binary representation contains only one bit which
+ * is in the specified position (counting from zero).  This is equivilant
+ * to raising two to the given power.
+ */
+void
+zbitvalue(n, res)
+       long n;
+       ZVALUE *res;
+{
+       ZVALUE z;
+
+       if (n < 0) n = 0;
+       z.sign = 0;
+       z.len = (n / BASEB) + 1;
+       z.v = alloc(z.len);
+       zclearval(z);
+       z.v[z.len-1] = (((HALF) 1) << (n % BASEB));
+       *res = z;
+}
+
+
+/*
+ * Compare a number against zero.
+ * Returns the sgn function of the number (-1, 0, or 1).
+ */
+FLAG
+ztest(z)
+       ZVALUE z;
+{
+       register int sign;
+       register HALF *h;
+       register long len;
+
+       sign = 1;
+       if (z.sign)
+               sign = -sign;
+       h = z.v;
+       len = z.len;
+       while (len--)
+               if (*h++)
+                       return sign;
+       return 0;
+}
+
+
+/*
+ * Compare two numbers to see which is larger.
+ * Returns -1 if first number is smaller, 0 if they are equal, and 1 if
+ * first number is larger.  This is the same result as ztest(z2-z1).
+ */
+FLAG
+zrel(z1, z2)
+       ZVALUE z1, z2;
+{
+       register HALF *h1, *h2;
+       register long len1, len2;
+       int sign;
+
+       sign = 1;
+       if (z1.sign < z2.sign)
+               return 1;
+       if (z2.sign < z1.sign)
+               return -1;
+       if (z2.sign)
+               sign = -1;
+       len1 = z1.len;
+       len2 = z2.len;
+       h1 = z1.v + z1.len - 1;
+       h2 = z2.v + z2.len - 1;
+       while (len1 > len2) {
+               if (*h1--)
+                       return sign;
+               len1--;
+       }
+       while (len2 > len1) {
+               if (*h2--)
+                       return -sign;
+               len2--;
+       }
+       while (len1--) {
+               if (*h1-- != *h2--)
+                       break;
+       }
+       if ((len1 = *++h1) > (len2 = *++h2))
+               return sign;
+       if (len1 < len2)
+               return -sign;
+       return 0;
+}
+
+
+/*
+ * Compare two numbers to see if they are equal or not.
+ * Returns TRUE if they differ.
+ */
+BOOL
+zcmp(z1, z2)
+       ZVALUE z1, z2;
+{
+       register HALF *h1, *h2;
+       register long len;
+
+       if ((z1.sign != z2.sign) || (z1.len != z2.len) || (*z1.v != *z2.v))
+               return TRUE;
+       len = z1.len;
+       h1 = z1.v;
+       h2 = z2.v;
+       while (len-- > 0) {
+               if (*h1++ != *h2++)
+                       return TRUE;
+       }
+       return FALSE;
+}
+
+
+/*
+ * Internal utility subroutines
+ */
+static void
+dadd(z1, z2, y, n)
+       ZVALUE z1, z2;
+       long y, n;
+{
+       HALF *s1, *s2;
+       short carry;
+       long sum;
+
+       s1 = z1.v + y - n;
+       s2 = z2.v;
+       carry = 0;
+       while (n--) {
+               sum = (long)*s1 + (long)*s2 + carry;
+               carry = 0;
+               if (sum >= BASE) {
+                       sum -= BASE;
+                       carry = 1;
+               }
+               *s1 = (HALF)sum;
+               ++s1;
+               ++s2;
+       }
+       sum = (long)*s1 + carry;
+       *s1 = (HALF)sum;
+}
+
+
+/*
+ * Do subtract for divide, returning TRUE if subtraction went negative.
+ */
+static BOOL
+dsub(z1, z2, y, n)
+       ZVALUE z1, z2;
+       long y, n;
+{
+       HALF *s1, *s2, *s3;
+       FULL i1;
+       BOOL neg;
+
+       neg = FALSE;
+       s1 = z1.v + y - n;
+       s2 = z2.v;
+       if (++n > z2.len)
+               n = z2.len;
+       while (n--) {
+               i1 = (FULL) *s1;
+               if (i1 < (FULL) *s2) {
+                       s3 = s1 + 1;
+                       while (s3 < z1.v + z1.len && !(*s3)) {
+                               *s3 = BASE1;
+                               ++s3;
+                       }
+                       if (s3 >= z1.v + z1.len)
+                               neg = TRUE;
+                       else
+                               --(*s3);
+                       i1 += BASE;
+               }
+               *s1 = i1 - (FULL) *s2;
+               ++s1;
+               ++s2;
+       }
+       return neg;
+}
+
+
+/*
+ * Multiply a number by a single 'digit'.
+ * This is meant to be used only by the divide routine, and so the
+ * destination area must already be allocated and be large enough.
+ */
+static void
+dmul(z, mul, dest)
+       ZVALUE z;
+       FULL mul;
+       ZVALUE *dest;
+{
+       register HALF *zp, *dp;
+       SIUNION sival;
+       FULL carry;
+       long len;
+
+       dp = dest->v;
+       dest->sign = 0;
+       if (mul == 0) {
+               dest->len = 1;
+               *dp = 0;
+               return;
+       }
+       len = z.len;
+       zp = z.v + len - 1;
+       while ((*zp == 0) && (len > 1)) {
+               len--;
+               zp--;
+       }
+       dest->len = len;
+       zp = z.v;
+       carry = 0;
+       while (len >= 4) {
+               len -= 4;
+               sival.ivalue = (mul * ((FULL) *zp++)) + carry;
+               *dp++ = sival.silow;
+               sival.ivalue = (mul * ((FULL) *zp++)) + ((FULL) sival.sihigh);
+               *dp++ = sival.silow;
+               sival.ivalue = (mul * ((FULL) *zp++)) + ((FULL) sival.sihigh);
+               *dp++ = sival.silow;
+               sival.ivalue = (mul * ((FULL) *zp++)) + ((FULL) sival.sihigh);
+               *dp++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       while (--len >= 0) {
+               sival.ivalue = (mul * ((FULL) *zp++)) + carry;
+               *dp++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       if (carry) {
+               *dp = (HALF)carry;
+               dest->len++;
+       }
+}
+
+
+/*
+ * Utility to calculate the gcd of two small integers.
+ */
+long
+iigcd(i1, i2)
+       long i1, i2;
+{
+       FULL f1, f2, temp;
+
+       f1 = (FULL) ((i1 >= 0) ? i1 : -i1);
+       f2 = (FULL) ((i2 >= 0) ? i2 : -i2);
+       while (f1) {
+               temp = f2 % f1;
+               f2 = f1;
+               f1 = temp;
+       }
+       return (long) f2;
+}
+
+
+void
+ztrim(z)
+       ZVALUE *z;
+{
+       register HALF *h;
+       register long len;
+
+       h = z->v + z->len - 1;
+       len = z->len;
+       while (*h == 0 && len > 1) {
+               --h;
+               --len;
+       }
+       z->len = len;
+}
+
+
+/*
+ * Utility routine to shift right.
+ */
+void
+zshiftr(z, n)
+       ZVALUE z;
+       long n;
+{
+       register HALF *h, *lim;
+       FULL mask, maskt;
+       long len;
+
+       if (n >= BASEB) {
+               len = n / BASEB;
+               h = z.v;
+               lim = z.v + z.len - len;
+               while (h < lim) {
+                       h[0] = h[len];
+                       ++h;
+               }
+               n -= BASEB * len;
+               lim = z.v + z.len;
+               while (h < lim)
+                       *h++ = 0;
+       }
+       if (n) {
+               len = z.len;
+               h = z.v + len - 1;
+               mask = 0;
+               while (len--) {
+                       maskt = (((FULL) *h) << (BASEB - n)) & BASE1;
+                       *h = (*h >> n) | mask;
+                       mask = maskt;
+                       --h;
+               }
+       }
+}
+
+
+/*
+ * Utility routine to shift left.
+ */
+void
+zshiftl(z, n)
+       ZVALUE z;
+       long n;
+{
+       register HALF *h;
+       FULL mask, i;
+       long len;
+
+       if (n >= BASEB) {
+               len = n / BASEB;
+               h = z.v + z.len - 1;
+               while (!*h)
+                       --h;
+               while (h >= z.v) {
+                       h[len] = h[0];
+                       --h;
+               }
+               n -= BASEB * len;
+               while (len)
+                       h[len--] = 0;
+       }
+       if (n > 0) {
+               len = z.len;
+               h = z.v;
+               mask = 0;
+               while (len--) {
+                       i = (((FULL) *h) << n) | mask;
+                       if (i > BASE1) {
+                               mask = i >> BASEB;
+                               i &= BASE1;
+                       } else
+                               mask = 0;
+                       *h = (HALF) i;
+                       ++h;
+               }
+       }
+}
+
+/*
+ * initmasks - init the bitmask rotation arrays
+ *
+ * bitmask[i]   (1 << (i-1)),  for  -BASEB*4<=i<=BASEB*4
+ *
+ * The bmask array contains 8 cycles of rotations of a bit mask.
+ */
+void
+initmasks()
+{
+       int i;
+
+       /*
+        * setup the bmask array
+        */
+       bmask = alloc((long)((8*BASEB)+1));
+       for (i=0; i < (8*BASEB)+1; ++i) {
+               bmask[i] = 1 << (i%BASEB);
+       }
+
+       /*
+        * setup the rmask pointers
+        */
+       rmask = (HALF **)malloc(sizeof(HALF *)*((BASEB*4)+2));
+       for (i = 0; i <= (4*BASEB)+1; ++i) {
+               rmask[i] = &bmask[(2*BASEB)+i];
+       }
+
+       /*
+        * setup the bitmask array to allow -4*BASEB thru 4*BASEB indexing
+        */
+       bitmask = &bmask[4*BASEB];
+       return;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/zmath.h b/usr/src/contrib/calc-2.9.3t6/zmath.h
new file mode 100644 (file)
index 0000000..3556b7c
--- /dev/null
@@ -0,0 +1,365 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Data structure declarations for extended precision integer arithmetic.
+ * The assumption made is that a long is 32 bits and shorts are 16 bits,
+ * and longs must be addressible on word boundaries.
+ */
+
+#ifndef        ZMATH_H
+#define        ZMATH_H
+
+#include <stdio.h>
+#include "alloc.h"
+#include "endian.h"
+#include "longbits.h"
+
+#include "have_stdlib.h"
+#ifdef HAVE_STDLIB_H
+# include <stdlib.h>
+#endif
+
+
+#ifndef ALLOCTEST
+# if defined(CALC_MALLOC)
+#  define freeh(p) (((void *)p == (void *)_zeroval_) ||                        \
+                   ((void *)p == (void *)_oneval_) || free((void *)p))
+# else
+#  define freeh(p) { if (((void *)p != (void *)_zeroval_) &&           \
+                        ((void *)p != (void *)_oneval_)) free((void *)p); }
+# endif
+#endif
+
+
+typedef        int FLAG;                       /* small value (e.g. comparison) */
+typedef int BOOL;                      /* TRUE or FALSE value */
+typedef unsigned long HASH;            /* hash value */
+
+
+#if !defined(TRUE)
+#define        TRUE    ((BOOL) 1)                      /* booleans */
+#endif
+#if !defined(FALSE)
+#define        FALSE   ((BOOL) 0)
+#endif
+
+
+/*
+ * NOTE: FULL must be twice the storage size of a HALF
+ *      LEN storage size must be <= FULL storage size
+ */
+
+#if LONG_BITS == 64                    /* for 64-bit machines */
+typedef unsigned int HALF;             /* unit of number storage */
+typedef int SHALF;                     /* signed HALF */
+typedef unsigned long FULL;            /* double unit of number storage */
+typedef long LEN;                      /* unit of length storage */
+
+#define BASE   ((FULL) 4294967296)     /* base for calculations (2^32) */
+#define BASE1  ((FULL) (BASE - 1))     /* one less than base */
+#define BASEB  32                      /* number of bits in base */
+#define        BASEDIG 10                      /* number of digits in base */
+#define        MAXHALF ((FULL) 0x7fffffff)     /* largest positive half value */
+#define        MAXFULL ((FULL) 0x7fffffffffffffff) /* largest positive full value */
+#define        TOPHALF ((FULL) 0x80000000)     /* highest bit in half value */
+#define        TOPFULL ((FULL) 0x8000000000000000)     /* highest bit in full value */
+#define MAXLEN ((LEN)  0x7fffffffffffffff)     /* longest value allowed */
+
+#else                                  /* for 32-bit machines */
+typedef unsigned short HALF;           /* unit of number storage */
+typedef short SHALF;                   /* signed HALF */
+typedef unsigned long FULL;            /* double unit of number storage */
+typedef long LEN;                      /* unit of length storage */
+
+#define BASE   ((FULL) 65536)          /* base for calculations (2^16) */
+#define BASE1  ((FULL) (BASE - 1))     /* one less than base */
+#define BASEB  16                      /* number of bits in base */
+#define        BASEDIG 5                       /* number of digits in base */
+#define        MAXHALF ((FULL) 0x7fff)         /* largest positive half value */
+#define        MAXFULL ((FULL) 0x7fffffff)     /* largest positive full value */
+#define        TOPHALF ((FULL) 0x8000)         /* highest bit in half value */
+#define        TOPFULL ((FULL) 0x80000000)     /* highest bit in full value */
+#define MAXLEN ((LEN)  0x7fffffff)     /* longest value allowed */
+#endif
+
+#define        MAXREDC 5                       /* number of entries in REDC cache */
+#define        SQ_ALG2 20                      /* size for alternative squaring */
+#define        MUL_ALG2 20                     /* size for alternative multiply */
+#define        POW_ALG2 40                     /* size for using REDC for powers */
+#define        REDC_ALG2 50                    /* size for using alternative REDC */
+
+
+typedef union {
+       FULL    ivalue;
+       struct {
+               HALF Svalue1;
+               HALF Svalue2;
+       } sis;
+} SIUNION;
+
+
+#if !defined(BYTE_ORDER)
+#include <machine/endian.h>
+#endif
+
+#if !defined(LITTLE_ENDIAN)
+#define LITTLE_ENDIAN  1234    /* Least Significant Byte first */
+#endif
+#if !defined(BIG_ENDIAN)
+#define BIG_ENDIAN     4321    /* Most Significant Byte first */
+#endif
+/* PDP_ENDIAN - LSB in word, MSW in long is not supported */
+
+#if BYTE_ORDER == LITTLE_ENDIAN
+# define silow sis.Svalue1     /* low order half of full value */
+# define sihigh        sis.Svalue2     /* high order half of full value */
+#else
+# if BYTE_ORDER == BIG_ENDIAN
+#  define silow        sis.Svalue2     /* low order half of full value */
+#  define sihigh sis.Svalue1   /* high order half of full value */
+# else
+   :@</*/>@:    BYTE_ORDER must be BIG_ENDIAN or LITTLE_ENDIAN    :@</*/>@:
+# endif
+#endif
+
+
+typedef struct {
+       HALF    *v;             /* pointer to array of values */
+       LEN     len;            /* number of values in array */
+       BOOL    sign;           /* sign, nonzero is negative */
+} ZVALUE;
+
+
+
+/*
+ * Function prototypes for integer math routines.
+ */
+#if defined(__STDC__)
+#define MATH_PROTO(a) a
+#else
+#define MATH_PROTO(a) ()
+#endif
+
+extern HALF * alloc MATH_PROTO((LEN len));
+#ifdef ALLOCTEST
+extern void freeh MATH_PROTO((HALF *));
+#endif
+
+
+/*
+ * Input, output, and conversion routines.
+ */
+extern void zcopy MATH_PROTO((ZVALUE z, ZVALUE *res));
+extern void itoz MATH_PROTO((long i, ZVALUE *res));
+extern void atoz MATH_PROTO((char *s, ZVALUE *res));
+extern long ztoi MATH_PROTO((ZVALUE z));
+extern void zprintval MATH_PROTO((ZVALUE z, long decimals, long width));
+extern void zprintx MATH_PROTO((ZVALUE z, long width));
+extern void zprintb MATH_PROTO((ZVALUE z, long width));
+extern void zprinto MATH_PROTO((ZVALUE z, long width));
+
+
+/*
+ * Basic numeric routines.
+ */
+extern void zmuli MATH_PROTO((ZVALUE z, long n, ZVALUE *res));
+extern long zdivi MATH_PROTO((ZVALUE z, long n, ZVALUE *res));
+extern long zmodi MATH_PROTO((ZVALUE z, long n));
+extern void zadd MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zsub MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zmul MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zdiv MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res, ZVALUE *rem));
+extern void zquo MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zmod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *rem));
+extern BOOL zdivides MATH_PROTO((ZVALUE z1, ZVALUE z2));
+extern void zor MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zand MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zxor MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zshift MATH_PROTO((ZVALUE z, long n, ZVALUE *res));
+extern void zsquare MATH_PROTO((ZVALUE z, ZVALUE *res));
+extern long zlowbit MATH_PROTO((ZVALUE z));
+extern long zhighbit MATH_PROTO((ZVALUE z));
+extern void zbitvalue MATH_PROTO((long n, ZVALUE *res));
+extern BOOL zisset MATH_PROTO((ZVALUE z, long n));
+extern BOOL zisonebit MATH_PROTO((ZVALUE z));
+extern BOOL zisallbits MATH_PROTO((ZVALUE z));
+extern FLAG ztest MATH_PROTO((ZVALUE z));
+extern FLAG zrel MATH_PROTO((ZVALUE z1, ZVALUE z2));
+extern BOOL zcmp MATH_PROTO((ZVALUE z1, ZVALUE z2));
+
+
+/*
+ * More complicated numeric functions.
+ */
+extern long iigcd MATH_PROTO((long i1, long i2));
+extern void zgcd MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zlcm MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zreduce MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *z1res, ZVALUE *z2res));
+extern void zfact MATH_PROTO((ZVALUE z, ZVALUE *dest));
+extern void zpfact MATH_PROTO((ZVALUE z, ZVALUE *dest));
+extern void zlcmfact MATH_PROTO((ZVALUE z, ZVALUE *dest));
+extern void zperm MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zcomb MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern BOOL zprimetest MATH_PROTO((ZVALUE z, long count));
+extern FLAG zjacobi MATH_PROTO((ZVALUE z1, ZVALUE z2));
+extern void zfib MATH_PROTO((ZVALUE z, ZVALUE *res));
+extern void zpowi MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void ztenpow MATH_PROTO((long power, ZVALUE *res));
+extern void zpowermod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *res));
+extern BOOL zmodinv MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern BOOL zrelprime MATH_PROTO((ZVALUE z1, ZVALUE z2));
+extern long zlog MATH_PROTO((ZVALUE z1, ZVALUE z2));
+extern long zlog10 MATH_PROTO((ZVALUE z));
+extern long zdivcount MATH_PROTO((ZVALUE z1, ZVALUE z2));
+extern long zfacrem MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *rem));
+extern void zgcdrem MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern long zlowfactor MATH_PROTO((ZVALUE z, long count));
+extern long zdigits MATH_PROTO((ZVALUE z1));
+extern FLAG zdigit MATH_PROTO((ZVALUE z1, long n));
+extern BOOL zsqrt MATH_PROTO((ZVALUE z1, ZVALUE *dest));
+extern void zroot MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *dest));
+extern BOOL zissquare MATH_PROTO((ZVALUE z));
+extern HASH zhash MATH_PROTO((ZVALUE z));
+
+#if 0
+extern void zapprox MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res1, ZVALUE *res2));
+#endif
+
+
+#if 0
+extern void zmulmod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *res));
+extern void zsquaremod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zsubmod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *res));
+#endif
+extern void zminmod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern BOOL zcmpmod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE z3));
+
+
+/*
+ * These functions are for internal use only.
+ */
+extern void ztrim MATH_PROTO((ZVALUE *z));
+extern void zshiftr MATH_PROTO((ZVALUE z, long n));
+extern void zshiftl MATH_PROTO((ZVALUE z, long n));
+extern HALF *zalloctemp MATH_PROTO((LEN len));
+extern void initmasks MATH_PROTO((void));
+
+
+/*
+ * Modulo arithmetic definitions.
+ * Structure holding state of REDC initialization.
+ * Multiple instances of this structure can be used allowing
+ * calculations with more than one modulus at the same time.
+ * Len of zero means the structure is not initialized.
+ */
+typedef        struct {
+       LEN len;                /* number of words in binary modulus */
+       ZVALUE mod;             /* modulus REDC is computing with */
+       ZVALUE inv;             /* inverse of modulus in binary modulus */
+       ZVALUE one;             /* REDC format for the number 1 */
+} REDC;
+
+extern REDC *zredcalloc MATH_PROTO((ZVALUE z1));
+extern void zredcfree MATH_PROTO((REDC *rp));
+extern void zredcencode MATH_PROTO((REDC *rp, ZVALUE z1, ZVALUE *res));
+extern void zredcdecode MATH_PROTO((REDC *rp, ZVALUE z1, ZVALUE *res));
+extern void zredcmul MATH_PROTO((REDC *rp, ZVALUE z1, ZVALUE z2, ZVALUE *res));
+extern void zredcsquare MATH_PROTO((REDC *rp, ZVALUE z1, ZVALUE *res));
+extern void zredcpower MATH_PROTO((REDC *rp, ZVALUE z1, ZVALUE z2, ZVALUE *res));
+
+
+/*
+ * macro expansions to speed this thing up
+ */
+#define ziseven(z)     (!(*(z).v & 01))
+#define zisodd(z)      (*(z).v & 01)
+#define ziszero(z)     ((*(z).v == 0) && ((z).len == 1))
+#define zisneg(z)      ((z).sign)
+#define zispos(z)      (((z).sign == 0) && (*(z).v || ((z).len > 1)))
+#define zisunit(z)     ((*(z).v == 1) && ((z).len == 1))
+#define zisone(z)      ((*(z).v == 1) && ((z).len == 1) && !(z).sign)
+#define zisnegone(z)   ((*(z).v == 1) && ((z).len == 1) && (z).sign)
+#define zistwo(z)      ((*(z).v == 2) && ((z).len == 1) && !(z).sign)
+#define zisleone(z)    ((*(z).v <= 1) && ((z).len == 1))
+#define zistiny(z)     ((z).len == 1)
+#define zissmall(z)    (((z).len < 2) || (((z).len == 2) && (((SHALF)(z).v[1]) >= 0)))
+#define zisbig(z)      (((z).len > 2) || (((z).len == 2) && (((SHALF)(z).v[1]) < 0)))
+
+#define z1tol(z)       ((long)((z).v[0]))
+#define z2tol(z)       (((long)((z).v[0])) + \
+                               (((long)((z).v[1] & MAXHALF)) << BASEB))
+#define        zclearval(z)    memset((z).v, 0, (z).len * sizeof(HALF))
+#define        zcopyval(z1,z2) memcpy((z2).v, (z1).v, (z1).len * sizeof(HALF))
+#define zquicktrim(z)  {if (((z).len > 1) && ((z).v[(z).len-1] == 0)) \
+                               (z).len--;}
+#define        zfree(z)        freeh((z).v)
+
+
+/*
+ * Output modes for numeric displays.
+ */
+#define MODE_DEFAULT   0
+#define MODE_FRAC      1
+#define MODE_INT       2
+#define MODE_REAL      3
+#define MODE_EXP       4
+#define MODE_HEX       5
+#define MODE_OCTAL     6
+#define MODE_BINARY    7
+#define MODE_MAX       7
+
+#define MODE_INITIAL   MODE_REAL
+
+
+/*
+ * Output routines for either FILE handles or strings.
+ */
+extern void math_chr MATH_PROTO((int ch));
+extern void math_str MATH_PROTO((char *str));
+extern void math_fill MATH_PROTO((char *str, long width));
+extern void math_flush MATH_PROTO((void));
+extern void math_divertio MATH_PROTO((void));
+extern void math_cleardiversions MATH_PROTO((void));
+extern void math_setfp MATH_PROTO((FILE *fp));
+extern char *math_getdivertedio MATH_PROTO((void));
+extern int math_setmode MATH_PROTO((int mode));
+extern long math_setdigits MATH_PROTO((long digits));
+
+
+#ifdef VARARGS
+extern void math_fmt();
+#else
+extern void math_fmt MATH_PROTO((char *, ...));
+#endif
+
+
+/*
+ * The error routine.
+ */
+#ifdef VARARGS
+extern void math_error();
+#else
+extern void math_error MATH_PROTO((char *, ...));
+#endif
+
+
+/*
+ * constants used often by the arithmetic routines
+ */
+extern HALF _zeroval_[], _oneval_[], _twoval_[], _tenval_[];
+extern ZVALUE _zero_, _one_, _ten_;
+
+extern BOOL _math_abort_;      /* nonzero to abort calculations */
+extern ZVALUE _tenpowers_[2 * BASEB];  /* table of 10^2^n */
+extern int _outmode_;          /* current output mode */
+extern LEN _mul2_;             /* size of number to use multiply algorithm 2 */
+extern LEN _sq2_;              /* size of number to use square algorithm 2 */
+extern LEN _pow2_;             /* size of modulus to use REDC for powers */
+extern LEN _redc2_;            /* size of modulus to use REDC algorithm 2 */
+extern HALF *bitmask;          /* bit rotation, norm 0 */
+
+#endif
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/zmod.c b/usr/src/contrib/calc-2.9.3t6/zmod.c
new file mode 100644 (file)
index 0000000..c31827a
--- /dev/null
@@ -0,0 +1,1341 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Routines to do modulo arithmetic both normally and also using the REDC
+ * algorithm given by Peter L. Montgomery in Mathematics of Computation,
+ * volume 44, number 170 (April, 1985).  For multiple multiplies using
+ * the same large modulus, the REDC algorithm avoids the usual division
+ * by the modulus, instead replacing it with two multiplies or else a
+ * special algorithm.  When these two multiplies or the special algorithm
+ * are faster then the division, then the REDC algorithm is better.
+ */
+
+#include "zmath.h"
+
+
+#define        POWBITS 4               /* bits for power chunks (must divide BASEB) */
+#define        POWNUMS (1<<POWBITS)    /* number of powers needed in table */
+
+
+LEN _pow2_ = POW_ALG2;         /* modulo size to use REDC for powers */
+LEN _redc2_ = REDC_ALG2;       /* modulo size to use second REDC algorithm */
+
+static REDC *powermodredc = NULL;      /* REDC info for raising to power */
+
+#if 0
+extern void zaddmod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *res));
+extern void znegmod MATH_PROTO((ZVALUE z1, ZVALUE z2, ZVALUE *res));
+
+/*
+ * Multiply two numbers together and then mod the result with a third number.
+ * The two numbers to be multiplied can be negative or out of modulo range.
+ * The result will be in the range 0 to the modulus - 1.
+ */
+void
+zmulmod(z1, z2, z3, res)
+       ZVALUE z1;              /* first number to be multiplied */
+       ZVALUE z2;              /* second number to be multiplied */
+       ZVALUE z3;              /* number to take mod with */
+       ZVALUE *res;            /* result */
+{
+       ZVALUE tmp;
+       FULL prod;
+       FULL digit;
+       BOOL neg;
+
+       if (ziszero(z3) || zisneg(z3))
+               math_error("Mod of non-positive integer");
+       if (ziszero(z1) || ziszero(z2) || zisunit(z3)) {
+               *res = _zero_;
+               return;
+       }
+
+       /*
+        * If the modulus is a single digit number, then do the result
+        * cheaply.  Check especially for a small power of two.
+        */
+       if (zistiny(z3)) {
+               neg = (z1.sign != z2.sign);
+               digit = z3.v[0];
+               if ((digit & -digit) == digit) {        /* NEEDS 2'S COMP */
+                       prod = ((FULL) z1.v[0]) * ((FULL) z2.v[0]);
+                       prod &= (digit - 1);
+               } else {
+                       z1.sign = 0;
+                       z2.sign = 0;
+                       prod = (FULL) zmodi(z1, (long) digit);
+                       prod *= (FULL) zmodi(z2, (long) digit);
+                       prod %= digit;
+               }
+               if (neg && prod)
+                       prod = digit - prod;
+               itoz((long) prod, res);
+               return;
+       }
+
+       /*
+        * The modulus is more than one digit.
+        * Actually do the multiply and divide if necessary.
+        */
+       zmul(z1, z2, &tmp);
+       if (zispos(tmp) && ((tmp.len < z3.len) || ((tmp.len == z3.len) &&
+               (tmp.v[tmp.len-1] < z2.v[z3.len-1]))))
+       {
+               *res = tmp;
+               return;
+       }
+       zmod(tmp, z3, res);
+       zfree(tmp);
+}
+
+
+/*
+ * Square a number and then mod the result with a second number.
+ * The number to be squared can be negative or out of modulo range.
+ * The result will be in the range 0 to the modulus - 1.
+ */
+void
+zsquaremod(z1, z2, res)
+       ZVALUE z1;              /* number to be squared */
+       ZVALUE z2;              /* number to take mod with */
+       ZVALUE *res;            /* result */
+{
+       ZVALUE tmp;
+       FULL prod;
+       FULL digit;
+
+       if (ziszero(z2) || zisneg(z2))
+               math_error("Mod of non-positive integer");
+       if (ziszero(z1) || zisunit(z2)) {
+               *res = _zero_;
+               return;
+       }
+
+       /*
+        * If the modulus is a single digit number, then do the result
+        * cheaply.  Check especially for a small power of two.
+        */
+       if (zistiny(z2)) {
+               digit = z2.v[0];
+               if ((digit & -digit) == digit) {        /* NEEDS 2'S COMP */
+                       prod = (FULL) z1.v[0];
+                       prod = (prod * prod) & (digit - 1);
+               } else {
+                       z1.sign = 0;
+                       prod = (FULL) zmodi(z1, (long) digit);
+                       prod = (prod * prod) % digit;
+               }
+               itoz((long) prod, res);
+               return;
+       }
+
+       /*
+        * The modulus is more than one digit.
+        * Actually do the square and divide if necessary.
+        */
+       zsquare(z1, &tmp);
+       if ((tmp.len < z2.len) ||
+               ((tmp.len == z2.len) && (tmp.v[tmp.len-1] < z2.v[z2.len-1]))) {
+                       *res = tmp;
+                       return;
+       }
+       zmod(tmp, z2, res);
+       zfree(tmp);
+}
+
+
+/*
+ * Add two numbers together and then mod the result with a third number.
+ * The two numbers to be added can be negative or out of modulo range.
+ * The result will be in the range 0 to the modulus - 1.
+ */
+static void
+zaddmod(z1, z2, z3, res)
+       ZVALUE z1;              /* first number to be added */
+       ZVALUE z2;              /* second number to be added */
+       ZVALUE z3;              /* number to take mod with */
+       ZVALUE *res;            /* result */
+{
+       ZVALUE tmp;
+       FULL sumdigit;
+       FULL moddigit;
+
+       if (ziszero(z3) || zisneg(z3))
+               math_error("Mod of non-positive integer");
+       if ((ziszero(z1) && ziszero(z2)) || zisunit(z3)) {
+               *res = _zero_;
+               return;
+       }
+       if (zistwo(z2)) {
+               if ((z1.v[0] + z2.v[0]) & 0x1)
+                       *res = _one_;
+               else
+                       *res = _zero_;
+               return;
+       }
+       zadd(z1, z2, &tmp);
+       if (zisneg(tmp) || (tmp.len > z3.len)) {
+               zmod(tmp, z3, res);
+               zfree(tmp);
+               return;
+       }
+       sumdigit = tmp.v[tmp.len - 1];
+       moddigit = z3.v[z3.len - 1];
+       if ((tmp.len < z3.len) || (sumdigit < moddigit)) {
+               *res = tmp;
+               return;
+       }
+       if (sumdigit < 2 * moddigit) {
+               zsub(tmp, z3, res);
+               zfree(tmp);
+               return;
+       }
+       zmod(tmp, z2, res);
+       zfree(tmp);
+}
+
+
+/*
+ * Subtract two numbers together and then mod the result with a third number.
+ * The two numbers to be subtract can be negative or out of modulo range.
+ * The result will be in the range 0 to the modulus - 1.
+ */
+void
+zsubmod(z1, z2, z3, res)
+       ZVALUE z1;              /* number to be subtracted from */
+       ZVALUE z2;              /* number to be subtracted */
+       ZVALUE z3;              /* number to take mod with */
+       ZVALUE *res;            /* result */
+{
+       if (ziszero(z3) || zisneg(z3))
+               math_error("Mod of non-positive integer");
+       if (ziszero(z2)) {
+               zmod(z1, z3, res);
+               return;
+       }
+       if (ziszero(z1)) {
+               znegmod(z2, z3, res);
+               return;
+       }
+       if ((z1.sign == z2.sign) && (z1.len == z2.len) &&
+               (z1.v[0] == z2.v[0]) && (zcmp(z1, z2) == 0)) {
+                       *res = _zero_;
+                       return;
+       }
+       z2.sign = !z2.sign;
+       zaddmod(z1, z2, z3, res);
+}
+
+
+/*
+ * Calculate the negative of a number modulo another number.
+ * The number to be negated can be negative or out of modulo range.
+ * The result will be in the range 0 to the modulus - 1.
+ */
+static void
+znegmod(z1, z2, res)
+       ZVALUE z1;              /* number to take negative of */
+       ZVALUE z2;              /* number to take mod with */
+       ZVALUE *res;            /* result */
+{
+       int sign;
+       int cv;
+
+       if (ziszero(z2) || zisneg(z2))
+               math_error("Mod of non-positive integer");
+       if (ziszero(z1) || zisunit(z2)) {
+               *res = _zero_;
+               return;
+       }
+       if (zistwo(z2)) {
+               if (z1.v[0] & 0x1)
+                       *res = _one_;
+               else
+                       *res = _zero_;
+               return;
+       }
+
+       /*
+        * If the absolute value of the number is within the modulo range,
+        * then the result is just a copy or a subtraction.  Otherwise go
+        * ahead and negate and reduce the result.
+        */
+       sign = z1.sign;
+       z1.sign = 0;
+       cv = zrel(z1, z2);
+       if (cv == 0) {
+               *res = _zero_;
+               return;
+       }
+       if (cv < 0) {
+               if (sign)
+                       zcopy(z1, res);
+               else
+                       zsub(z2, z1, res);
+               return;
+       }
+       z1.sign = !sign;
+       zmod(z1, z2, res);
+}
+#endif
+
+
+/*
+ * Calculate the number congruent to the given number whose absolute
+ * value is minimal.  The number to be reduced can be negative or out of
+ * modulo range.  The result will be within the range -int((modulus-1)/2)
+ * to int(modulus/2) inclusive.  For example, for modulus 7, numbers are
+ * reduced to the range [-3, 3], and for modulus 8, numbers are reduced to
+ * the range [-3, 4].
+ */
+void
+zminmod(z1, z2, res)
+       ZVALUE z1;              /* number to find minimum congruence of */
+       ZVALUE z2;              /* number to take mod with */
+       ZVALUE *res;            /* result */
+{
+       ZVALUE tmp1, tmp2;
+       int sign;
+       int cv;
+
+       if (ziszero(z2) || zisneg(z2))
+               math_error("Mod of non-positive integer");
+       if (ziszero(z1) || zisunit(z2)) {
+               *res = _zero_;
+               return;
+       }
+       if (zistwo(z2)) {
+               if (zisodd(z1))
+                       *res = _one_;
+               else
+                       *res = _zero_;
+               return;
+       }
+
+       /*
+        * Do a quick check to see if the number is very small compared
+        * to the modulus.  If so, then the result is obvious.
+        */
+       if (z1.len < z2.len - 1) {
+               zcopy(z1, res);
+               return;
+       }
+
+       /*
+        * Now make sure the input number is within the modulo range.
+        * If not, then reduce it to be within range and make the
+        * quick check again.
+        */
+       sign = z1.sign;
+       z1.sign = 0;
+       cv = zrel(z1, z2);
+       if (cv == 0) {
+               *res = _zero_;
+               return;
+       }
+       tmp1 = z1;
+       if (cv > 0) {
+               z1.sign = (BOOL)sign;
+               zmod(z1, z2, &tmp1);
+               if (tmp1.len < z2.len - 1) {
+                       *res = tmp1;
+                       return;
+               }
+               sign = 0;
+       }
+
+       /*
+        * Now calculate the difference of the modulus and the absolute
+        * value of the original number.  Compare the original number with
+        * the difference, and return the one with the smallest absolute
+        * value, with the correct sign.  If the two values are equal, then
+        * return the positive result.
+        */
+       zsub(z2, tmp1, &tmp2);
+       cv = zrel(tmp1, tmp2);
+       if (cv < 0) {
+               zfree(tmp2);
+               tmp1.sign = (BOOL)sign;
+               if (tmp1.v == z1.v)
+                       zcopy(tmp1, res);
+               else
+                       *res = tmp1;
+       } else {
+               if (cv)
+                       tmp2.sign = !sign;
+               if (tmp1.v != z1.v)
+                       zfree(tmp1);
+               *res = tmp2;
+       }
+}
+
+
+/*
+ * Compare two numbers for equality modulo a third number.
+ * The two numbers to be compared can be negative or out of modulo range.
+ * Returns TRUE if the numbers are not congruent, and FALSE if they are
+ * congruent.
+ */
+BOOL
+zcmpmod(z1, z2, z3)
+       ZVALUE z1;              /* first number to be compared */
+       ZVALUE z2;              /* second number to be compared */
+       ZVALUE z3;              /* modulus */
+{
+       ZVALUE tmp1, tmp2, tmp3;
+       FULL digit;
+       LEN len;
+       int cv;
+
+       if (zisneg(z3) || ziszero(z3))
+               math_error("Non-positive modulus in zcmpmod");
+       if (zistwo(z3))
+               return (((z1.v[0] + z2.v[0]) & 0x1) != 0);
+
+       /*
+        * If the two numbers are equal, then their mods are equal.
+        */
+       if ((z1.sign == z2.sign) && (z1.len == z2.len) &&
+               (z1.v[0] == z2.v[0]) && (zcmp(z1, z2) == 0))
+                       return FALSE;
+
+       /*
+        * If both numbers are negative, then we can make them positive.
+        */
+       if (zisneg(z1) && zisneg(z2)) {
+               z1.sign = 0;
+               z2.sign = 0;
+       }
+
+       /*
+        * For small negative numbers, make them positive before comparing.
+        * In any case, the resulting numbers are in tmp1 and tmp2.
+        */
+       tmp1 = z1;
+       tmp2 = z2;
+       len = z3.len;
+       digit = z3.v[len - 1];
+
+       if (zisneg(z1) && ((z1.len < len) ||
+               ((z1.len == len) && (z1.v[z1.len - 1] < digit))))
+                       zadd(z1, z3, &tmp1);
+
+       if (zisneg(z2) && ((z2.len < len) ||
+               ((z2.len == len) && (z2.v[z2.len - 1] < digit))))
+                       zadd(z2, z3, &tmp2);
+
+       /*
+        * Now compare the two numbers for equality.
+        * If they are equal we are all done.
+        */
+       if (zcmp(tmp1, tmp2) == 0) {
+               if (tmp1.v != z1.v)
+                       zfree(tmp1);
+               if (tmp2.v != z2.v)
+                       zfree(tmp2);
+               return FALSE;
+       }
+
+       /*
+        * They are not identical.  Now if both numbers are positive
+        * and less than the modulus, then they are definitely not equal.
+        */
+       if ((tmp1.sign == tmp2.sign) &&
+               ((tmp1.len < len) || (zrel(tmp1, z3) < 0)) &&
+               ((tmp2.len < len) || (zrel(tmp2, z3) < 0)))
+       {
+               if (tmp1.v != z1.v)
+                       zfree(tmp1);
+               if (tmp2.v != z2.v)
+                       zfree(tmp2);
+               return TRUE;
+       }
+
+       /*
+        * Either one of the numbers is negative or is large.
+        * So do the standard thing and subtract the two numbers.
+        * Then they are equal if the result is 0 (mod z3).
+        */
+       zsub(tmp1, tmp2, &tmp3);
+       if (tmp1.v != z1.v)
+               zfree(tmp1);
+       if (tmp2.v != z2.v)
+               zfree(tmp2);
+
+       /*
+        * Compare the result with the modulus to see if it is equal to
+        * or less than the modulus.  If so, we know the mod result.
+        */
+       tmp3.sign = 0;
+       cv = zrel(tmp3, z3);
+       if (cv == 0) {
+               zfree(tmp3);
+               return FALSE;
+       }
+       if (cv < 0) {
+               zfree(tmp3);
+               return TRUE;
+       }
+
+       /*
+        * We are forced to actually do the division.
+        * The numbers are congruent if the result is zero.
+        */
+       zmod(tmp3, z3, &tmp1);
+       zfree(tmp3);
+       if (ziszero(tmp1)) {
+               zfree(tmp1);
+               return FALSE;
+       } else {
+               zfree(tmp1);
+               return TRUE;
+       }
+}
+
+
+/*
+ * Compute the result of raising one number to a power modulo another number.
+ * That is, this computes:  a^b (modulo c).
+ * This calculates the result by examining the power POWBITS bits at a time,
+ * using a small table of POWNUMS low powers to calculate powers for those bits,
+ * and repeated squaring and multiplying by the partial powers to generate
+ * the complete power.  If the power being raised to is high enough, then
+ * this uses the REDC algorithm to avoid doing many divisions.  When using
+ * REDC, multiple calls to this routine using the same modulus will be
+ * slightly faster.
+ */
+void
+zpowermod(z1, z2, z3, res)
+       ZVALUE z1, z2, z3, *res;
+{
+       HALF *hp;               /* pointer to current word of the power */
+       REDC *rp;               /* REDC information to be used */
+       ZVALUE *pp;             /* pointer to low power table */
+       ZVALUE ans, temp;       /* calculation values */
+       ZVALUE modpow;          /* current small power */
+       ZVALUE lowpowers[POWNUMS];      /* low powers */
+       int sign;               /* original sign of number */
+       int curshift;           /* shift value for word of power */
+       HALF curhalf;           /* current word of power */
+       unsigned int curpow;    /* current low power */
+       unsigned int curbit;    /* current bit of low power */
+       int i;
+
+       if (zisneg(z3) || ziszero(z3))
+               math_error("Non-positive modulus in zpowermod");
+       if (zisneg(z2))
+               math_error("Negative power in zpowermod");
+
+       sign = z1.sign;
+       z1.sign = 0;
+
+       /*
+        * Check easy cases first.
+        */
+       if ((ziszero(z1) && !ziszero(z2)) || zisunit(z3)) {
+               /* 0^(non_zero) or x^y mod 1 always produces zero */
+               *res = _zero_;
+               return;
+       }
+       if (ziszero(z2)) {                      /* x^0 == 1 */
+               *res = _one_;
+               return;
+       }
+       if (zistwo(z3)) {                       /* mod 2 */
+               if (zisodd(z1))
+                       *res = _one_;
+               else
+                       *res = _zero_;
+               return;
+       }
+       if (zisunit(z1) && (!sign || ziseven(z2))) {
+               /* 1^x or (-1)^(2x) */
+               *res = _one_;
+               return;
+       }
+
+       /*
+        * Normalize the number being raised to be non-negative and to lie
+        * within the modulo range.  Then check for zero or one specially.
+        */
+       zmod(z1, z3, &temp);
+       if (ziszero(temp)) {
+               zfree(temp);
+               *res = _zero_;
+               return;
+       }
+       z1 = temp;
+       if (sign) {
+               zsub(z3, z1, &temp);
+               zfree(z1);
+               z1 = temp;
+       }
+       if (zisunit(z1)) {
+               zfree(z1);
+               *res = _one_;
+               return;
+       }
+
+       /*
+        * If the modulus is odd, large enough, is not one less than an
+        * exact power of two, and if the power is large enough, then use
+        * the REDC algorithm.  The size where this is done is configurable.
+        */
+       if ((z2.len > 1) && (z3.len >= _pow2_) && zisodd(z3)
+               && !zisallbits(z3))
+       {
+               if (powermodredc && zcmp(powermodredc->mod, z3)) {
+                       zredcfree(powermodredc);
+                       powermodredc = NULL;
+               }
+               if (powermodredc == NULL)
+                       powermodredc = zredcalloc(z3);
+               rp = powermodredc;
+               zredcencode(rp, z1, &temp);
+               zredcpower(rp, temp, z2, &z1);
+               zfree(temp);
+               zredcdecode(rp, z1, res);
+               zfree(z1);
+               return;
+       }
+
+       /*
+        * Modulus or power is small enough to perform the power raising
+        * directly.  Initialize the table of powers.
+        */
+       for (pp = &lowpowers[2]; pp < &lowpowers[POWNUMS]; pp++)
+               pp->len = 0;
+       lowpowers[0] = _one_;
+       lowpowers[1] = z1;
+       ans = _one_;
+
+       hp = &z2.v[z2.len - 1];
+       curhalf = *hp;
+       curshift = BASEB - POWBITS;
+       while (curshift && ((curhalf >> curshift) == 0))
+               curshift -= POWBITS;
+
+       /*
+        * Calculate the result by examining the power POWBITS bits at a time,
+        * and use the table of low powers at each iteration.
+        */
+       for (;;) {
+               curpow = (curhalf >> curshift) & (POWNUMS - 1);
+               pp = &lowpowers[curpow];
+
+               /*
+                * If the small power is not yet saved in the table, then
+                * calculate it and remember it in the table for future use.
+                */
+               if (pp->len == 0) {
+                       if (curpow & 0x1)
+                               zcopy(z1, &modpow);
+                       else
+                               modpow = _one_;
+
+                       for (curbit = 0x2; curbit <= curpow; curbit *= 2) {
+                               pp = &lowpowers[curbit];
+                               if (pp->len == 0) {
+                                       zsquare(lowpowers[curbit/2], &temp);
+                                       zmod(temp, z3, pp);
+                                       zfree(temp);
+                               }
+                               if (curbit & curpow) {
+                                       zmul(*pp, modpow, &temp);
+                                       zfree(modpow);
+                                       zmod(temp, z3, &modpow);
+                                       zfree(temp);
+                               }
+                       }
+                       pp = &lowpowers[curpow];
+                       *pp = modpow;
+               }
+
+               /*
+                * If the power is nonzero, then accumulate the small power
+                * into the result.
+                */
+               if (curpow) {
+                       zmul(ans, *pp, &temp);
+                       zfree(ans);
+                       zmod(temp, z3, &ans);
+                       zfree(temp);
+               }
+
+               /*
+                * Select the next POWBITS bits of the power, if there is
+                * any more to generate.
+                */
+               curshift -= POWBITS;
+               if (curshift < 0) {
+                       if (hp-- == z2.v)
+                               break;
+                       curhalf = *hp;
+                       curshift = BASEB - POWBITS;
+               }
+
+               /*
+                * Square the result POWBITS times to make room for the next
+                * chunk of bits.
+                */
+               for (i = 0; i < POWBITS; i++) {
+                       zsquare(ans, &temp);
+                       zfree(ans);
+                       zmod(temp, z3, &ans);
+                       zfree(temp);
+               }
+       }
+
+       for (pp = &lowpowers[2]; pp < &lowpowers[POWNUMS]; pp++) {
+               if (pp->len)
+                       freeh(pp->v);
+       }
+       *res = ans;
+}
+
+
+/*
+ * Initialize the REDC algorithm for a particular modulus,
+ * returning a pointer to a structure that is used for other
+ * REDC calls.  An error is generated if the structure cannot
+ * be allocated.  The modulus must be odd and positive.
+ */
+REDC *
+zredcalloc(z1)
+       ZVALUE z1;              /* modulus to initialize for */
+{
+       REDC *rp;               /* REDC information */
+       ZVALUE tmp;
+       long bit;
+
+       if (ziseven(z1) || zisneg(z1))
+               math_error("REDC requires positive odd modulus");
+
+       rp = (REDC *) malloc(sizeof(REDC));
+       if (rp == NULL)
+               math_error("Cannot allocate REDC structure");
+
+       /*
+        * Round up the binary modulus to the next power of two
+        * which is at a word boundary.  Then the shift and modulo
+        * operations mod the binary modulus can be done very cheaply.
+        * Calculate the REDC format for the number 1 for future use.
+        */
+       bit = zhighbit(z1) + 1;
+       if (bit % BASEB)
+               bit += (BASEB - (bit % BASEB));
+       zcopy(z1, &rp->mod);
+       zbitvalue(bit, &tmp);
+       z1.sign = 1;
+       (void) zmodinv(z1, tmp, &rp->inv);
+       zmod(tmp, rp->mod, &rp->one);
+       zfree(tmp);
+       rp->len = bit / BASEB;
+       return rp;
+}
+
+
+/*
+ * Free any numbers associated with the specified REDC structure,
+ * and then the REDC structure itself.
+ */
+void
+zredcfree(rp)
+       REDC *rp;               /* REDC information to be cleared */
+{
+       zfree(rp->mod);
+       zfree(rp->inv);
+       zfree(rp->one);
+       free(rp);
+}
+
+
+/*
+ * Convert a normal number into the specified REDC format.
+ * The number to be converted can be negative or out of modulo range.
+ * The resulting number can be used for multiplying, adding, subtracting,
+ * or comparing with any other such converted numbers, as if the numbers
+ * were being calculated modulo the number which initialized the REDC
+ * information.  When the final value is unconverted, the result is the
+ * same as if the usual operations were done with the original numbers.
+ */
+void
+zredcencode(rp, z1, res)
+       REDC *rp;               /* REDC information */
+       ZVALUE z1;              /* number to be converted */
+       ZVALUE *res;            /* returned converted number */
+{
+       ZVALUE tmp1, tmp2;
+
+       /*
+        * Handle the cases 0, 1, -1, and 2 specially since these are
+        * easy to calculate.  Zero transforms to zero, and the others
+        * can be obtained from the precomputed REDC format for 1 since
+        * addition and subtraction act normally for REDC format numbers.
+        */
+       if (ziszero(z1)) {
+               *res = _zero_;
+               return;
+       }
+       if (zisone(z1)) {
+               zcopy(rp->one, res);
+               return;
+       }
+       if (zisunit(z1)) {
+               zsub(rp->mod, rp->one, res);
+               return;
+       }
+       if (zistwo(z1)) {
+               zadd(rp->one, rp->one, &tmp1);
+               if (zrel(tmp1, rp->mod) < 0) {
+                       *res = tmp1;
+                       return;
+               }
+               zsub(tmp1, rp->mod, res);
+               zfree(tmp1);
+               return;
+       }
+
+       /*
+        * Not a trivial number to convert, so do the full transformation.
+        * Convert negative numbers to positive numbers before converting.
+        */
+       tmp1.len = 0;
+       if (zisneg(z1)) {
+               zmod(z1, rp->mod, &tmp1);
+               z1 = tmp1;
+       }
+       zshift(z1, rp->len * BASEB, &tmp2);
+       if (tmp1.len)
+               zfree(tmp1);
+       zmod(tmp2, rp->mod, res);
+       zfree(tmp2);
+}
+
+
+/*
+ * The REDC algorithm used to convert numbers out of REDC format and also
+ * used after multiplication of two REDC numbers.  Using this routine
+ * avoids any divides, replacing the divide by two multiplications.
+ * If the numbers are very large, then these two multiplies will be
+ * quicker than the divide, since dividing is harder than multiplying.
+ */
+void
+zredcdecode(rp, z1, res)
+       REDC *rp;               /* REDC information */
+       ZVALUE z1;              /* number to be transformed */
+       ZVALUE *res;            /* returned transformed number */
+{
+       ZVALUE tmp1, tmp2;      /* temporaries */
+       HALF *hp;               /* saved pointer to tmp2 value */
+
+       if (zisneg(z1))
+               math_error("Negative number for zredc");
+
+       /*
+        * Check first for the special values for 0 and 1 that are easy.
+        */
+       if (ziszero(z1)) {
+               *res = _zero_;
+               return;
+       }
+       if ((z1.len == rp->one.len) && (z1.v[0] == rp->one.v[0]) &&
+               (zcmp(z1, rp->one) == 0)) {
+                       *res = _one_;
+                       return;
+       }
+
+       /*
+        * First calculate the following:
+        *      tmp2 = ((z1 % 2^bitnum) * inv) % 2^bitnum.
+        * The mod operations can be done with no work since the bit
+        * number was selected as a multiple of the word size.  Just
+        * reduce the sizes of the numbers as required.
+        */
+       tmp1 = z1;
+       if (tmp1.len > rp->len)
+               tmp1.len = rp->len;
+       zmul(tmp1, rp->inv, &tmp2);
+       if (tmp2.len > rp->len)
+               tmp2.len = rp->len;
+
+       /*
+        * Next calculate the following:
+        *      res = (z1 + tmp2 * modulus) / 2^bitnum
+        * The division by a power of 2 is always exact, and requires no
+        * work.  Just adjust the address and length of the number to do
+        * the divide, but save the original pointer for freeing later.
+        */
+       zmul(tmp2, rp->mod, &tmp1);
+       zfree(tmp2);
+       zadd(z1, tmp1, &tmp2);
+       zfree(tmp1);
+       hp = tmp2.v;
+       if (tmp2.len <= rp->len) {
+               freeh(hp);
+               *res = _zero_;
+               return;
+       }
+       tmp2.v += rp->len;
+       tmp2.len -= rp->len;
+
+       /*
+        * Finally do a final modulo by a simple subtraction if necessary.
+        * This is all that is needed because the previous calculation is
+        * guaranteed to always be less than twice the modulus.
+        */
+       if (zrel(tmp2, rp->mod) < 0)
+               zcopy(tmp2, res);
+       else
+               zsub(tmp2, rp->mod, res);
+       freeh(hp);
+}
+
+
+/*
+ * Multiply two numbers in REDC format together producing a result also
+ * in REDC format.  If the result is converted back to a normal number,
+ * then the result is the same as the modulo'd multiplication of the
+ * original numbers before they were converted to REDC format.  This
+ * calculation is done in one of two ways, depending on the size of the
+ * modulus.  For large numbers, the REDC definition is used directly
+ * which involves three multiplies overall.  For small numbers, a
+ * complicated routine is used which does the indicated multiplication
+ * and the REDC algorithm at the same time to produce the result.
+ */
+void
+zredcmul(rp, z1, z2, res)
+       REDC *rp;               /* REDC information */
+       ZVALUE z1;              /* first REDC number to be multiplied */
+       ZVALUE z2;              /* second REDC number to be multiplied */
+       ZVALUE *res;            /* resulting REDC number */
+{
+       FULL mulb;
+       FULL muln;
+       HALF *h1;
+       HALF *h2;
+       HALF *h3;
+       HALF *hd;
+       HALF Ninv;
+       HALF topdigit = 0;
+       LEN modlen;
+       LEN len;
+       LEN len2;
+       SIUNION sival1;
+       SIUNION sival2;
+       SIUNION sival3;
+       SIUNION carry;
+       ZVALUE tmp;
+
+       if (zisneg(z1) || (z1.len > rp->mod.len) ||
+               zisneg(z2) || (z2.len > rp->mod.len))
+                       math_error("Negative or too large number in zredcmul");
+
+       /*
+        * Check for special values which we easily know the answer.
+        */
+       if (ziszero(z1) || ziszero(z2)) {
+               *res = _zero_;
+               return;
+       }
+
+       if ((z1.len == rp->one.len) && (z1.v[0] == rp->one.v[0]) &&
+               (zcmp(z1, rp->one) == 0)) {
+                       zcopy(z2, res);
+                       return;
+       }
+
+       if ((z2.len == rp->one.len) && (z2.v[0] == rp->one.v[0]) &&
+               (zcmp(z2, rp->one) == 0)) {
+                       zcopy(z1, res);
+                       return;
+       }
+
+       /*
+        * If the size of the modulus is large, then just do the multiply,
+        * followed by the two multiplies contained in the REDC routine.
+        * This will be quicker than directly doing the REDC calculation
+        * because of the O(N^1.585) speed of the multiplies.  The size
+        * of the number which this is done is configurable.
+        */
+       if (rp->mod.len >= _redc2_) {
+               zmul(z1, z2, &tmp);
+               zredcdecode(rp, tmp, res);
+               zfree(tmp);
+               return;
+       }
+
+       /*
+        * The number is small enough to calculate by doing the O(N^2) REDC
+        * algorithm directly.  This algorithm performs the multiplication and
+        * the reduction at the same time.  Notice the obscure facts that
+        * only the lowest word of the inverse value is used, and that
+        * there is no shifting of the partial products as there is in a
+        * normal multiply.
+        */
+       modlen = rp->mod.len;
+       Ninv = rp->inv.v[0];
+
+       /*
+        * Allocate the result and clear it.
+        * The size of the result will be equal to or smaller than
+        * the modulus size.
+        */
+       res->sign = 0;
+       res->len = modlen;
+       res->v = alloc(modlen);
+
+       hd = res->v;
+       len = modlen;
+       zclearval(*res);
+
+       /*
+        * Do this outermost loop over all the digits of z1.
+        */
+       h1 = z1.v;
+       len = z1.len;
+       while (len--) {
+               /*
+                * Start off with the next digit of z1, the first
+                * digit of z2, and the first digit of the modulus.
+                */
+               mulb = (FULL) *h1++;
+               h2 = z2.v;
+               h3 = rp->mod.v;
+               hd = res->v;
+               sival1.ivalue = mulb * ((FULL) *h2++) + ((FULL) *hd++);
+               muln = ((HALF) (sival1.silow * Ninv));
+               sival2.ivalue = muln * ((FULL) *h3++);
+               sival3.ivalue = ((FULL) sival1.silow) + ((FULL) sival2.silow);
+               carry.ivalue = ((FULL) sival1.sihigh) + ((FULL) sival2.sihigh)
+                       + ((FULL) sival3.sihigh);
+
+               /*
+                * Do this innermost loop for each digit of z2, except
+                * for the first digit which was just done above.
+                */
+               len2 = z2.len;
+               while (--len2 > 0) {
+                       sival1.ivalue = mulb * ((FULL) *h2++);
+                       sival2.ivalue = muln * ((FULL) *h3++);
+                       sival3.ivalue = ((FULL) sival1.silow)
+                               + ((FULL) sival2.silow)
+                               + ((FULL) *hd)
+                               + ((FULL) carry.silow);
+                       carry.ivalue = ((FULL) sival1.sihigh)
+                               + ((FULL) sival2.sihigh)
+                               + ((FULL) sival3.sihigh)
+                               + ((FULL) carry.sihigh);
+
+                       hd[-1] = sival3.silow;
+                       hd++;
+               }
+
+               /*
+                * Now continue the loop as necessary so the total number
+                * of interations is equal to the size of the modulus.
+                * This acts as if the innermost loop was repeated for
+                * high digits of z2 that are zero.
+                */
+               len2 = modlen - z2.len;
+               while (len2--) {
+                       sival2.ivalue = muln * ((FULL) *h3++);
+                       sival3.ivalue = ((FULL) sival2.silow)
+                               + ((FULL) *hd)
+                               + ((FULL) carry.silow);
+                       carry.ivalue = ((FULL) sival2.sihigh)
+                               + ((FULL) sival3.sihigh)
+                               + ((FULL) carry.sihigh);
+
+                       hd[-1] = sival3.silow;
+                       hd++;
+               }
+
+               res->v[modlen - 1] = carry.silow;
+               topdigit = carry.sihigh;
+       }
+
+       /*
+        * Now continue the loop as necessary so the total number
+        * of interations is equal to the size of the modulus.
+        * This acts as if the outermost loop was repeated for high
+        * digits of z1 that are zero.
+        */
+       len = modlen - z1.len;
+       while (len--) {
+               /*
+                * Start off with the first digit of the modulus.
+                */
+               h3 = rp->mod.v;
+               hd = res->v;
+               muln = ((HALF) (*hd * Ninv));
+               sival2.ivalue = muln * ((FULL) *h3++);
+               sival3.ivalue = ((FULL) *hd++) + ((FULL) sival2.silow);
+               carry.ivalue = ((FULL) sival2.sihigh) + ((FULL) sival3.sihigh);
+
+               /*
+                * Do this innermost loop for each digit of the modulus,
+                * except for the first digit which was just done above.
+                */
+               len2 = modlen;
+               while (--len2 > 0) {
+                       sival2.ivalue = muln * ((FULL) *h3++);
+                       sival3.ivalue = ((FULL) sival2.silow)
+                               + ((FULL) *hd)
+                               + ((FULL) carry.silow);
+                       carry.ivalue = ((FULL) sival2.sihigh)
+                               + ((FULL) sival3.sihigh)
+                               + ((FULL) carry.sihigh);
+
+                       hd[-1] = sival3.silow;
+                       hd++;
+               }
+               res->v[modlen - 1] = carry.silow;
+               topdigit = carry.sihigh;
+       }
+
+       /*
+        * Determine the true size of the result, taking the top digit of
+        * the current result into account.  The top digit is not stored in
+        * the number because it is temporary and would become zero anyway
+        * after the final subtraction is done.
+        */
+       if (topdigit == 0) {
+               len = modlen;
+               hd = &res->v[len - 1];
+               while ((*hd == 0) && (len > 1)) {
+                       hd--;
+                       len--;
+               }
+               res->len = len;
+       }
+
+       /*
+        * Compare the result with the modulus.
+        * If it is less than the modulus, then the calculation is complete.
+        */
+       if ((topdigit == 0) && ((len < modlen)
+               || (res->v[len - 1] < rp->mod.v[len - 1])
+               || (zrel(*res, rp->mod) < 0)))
+                       return;
+
+       /*
+        * Do a subtraction to reduce the result to a value less than
+        * the modulus.  The REDC algorithm guarantees that a single subtract
+        * is all that is needed.  Ignore any borrowing from the possible
+        * highest word of the current result because that would affect
+        * only the top digit value that was not stored and would become
+        * zero anyway.
+        */
+       carry.ivalue = 0;
+       h1 = rp->mod.v;
+       hd = res->v;
+       len = modlen;
+       while (len--) {
+               carry.ivalue = BASE1 - ((FULL) *hd) + ((FULL) *h1++)
+                       + ((FULL) carry.silow);
+               *hd++ = BASE1 - carry.silow;
+               carry.silow = carry.sihigh;
+       }
+
+       /*
+        * Now finally recompute the size of the result.
+        */
+       len = modlen;
+       hd = &res->v[len - 1];
+       while ((*hd == 0) && (len > 1)) {
+               hd--;
+               len--;
+       }
+       res->len = len;
+}
+
+
+/*
+ * Square a number in REDC format producing a result also in REDC format.
+ */
+void
+zredcsquare(rp, z1, res)
+       REDC *rp;               /* REDC information */
+       ZVALUE z1;              /* REDC number to be squared */
+       ZVALUE *res;            /* resulting REDC number */
+{
+       ZVALUE tmp;
+
+       if (zisneg(z1))
+               math_error("Negative number in zredcsquare");
+       if (ziszero(z1)) {
+               *res = _zero_;
+               return;
+       }
+       if ((z1.len == rp->one.len) && (z1.v[0] == rp->one.v[0]) &&
+               (zcmp(z1, rp->one) == 0)) {
+                       zcopy(z1, res);
+                       return;
+       }
+
+       /*
+        * If the modulus is small enough, then call the multiply
+        * routine to produce the result.  Otherwise call the O(N^1.585)
+        * routines to get the answer.
+        */
+       if (rp->mod.len < _redc2_) {
+               zredcmul(rp, z1, z1, res);
+               return;
+       }
+       zsquare(z1, &tmp);
+       zredcdecode(rp, tmp, res);
+       zfree(tmp);
+}
+
+
+/*
+ * Compute the result of raising a REDC format number to a power.
+ * The result is within the range 0 to the modulus - 1.
+ * This calculates the result by examining the power POWBITS bits at a time,
+ * using a small table of POWNUMS low powers to calculate powers for those bits,
+ * and repeated squaring and multiplying by the partial powers to generate
+ * the complete power.
+ */
+void
+zredcpower(rp, z1, z2, res)
+       REDC *rp;               /* REDC information */
+       ZVALUE z1;              /* REDC number to be raised */
+       ZVALUE z2;              /* normal number to raise number to */
+       ZVALUE *res;            /* result */
+{
+       HALF *hp;               /* pointer to current word of the power */
+       ZVALUE *pp;             /* pointer to low power table */
+       ZVALUE ans, temp;       /* calculation values */
+       ZVALUE modpow;          /* current small power */
+       ZVALUE lowpowers[POWNUMS];      /* low powers */
+       int curshift;           /* shift value for word of power */
+       HALF curhalf;           /* current word of power */
+       unsigned int curpow;    /* current low power */
+       unsigned int curbit;    /* current bit of low power */
+       int i;
+
+       if (zisneg(z1))
+               math_error("Negative number in zredcpower");
+       if (zisneg(z2))
+               math_error("Negative power in zredcpower");
+
+       /*
+        * Check for zero or the REDC format for one.
+        */
+       if (ziszero(z1) || zisunit(rp->mod)) {
+               *res = _zero_;
+               return;
+       }
+       if (zcmp(z1, rp->one) == 0) {
+               zcopy(rp->one, res);
+               return;
+       }
+
+       /*
+        * See if the number being raised is the REDC format for -1.
+        * If so, then the answer is the REDC format for one or minus one.
+        * To do this check, calculate the REDC format for -1.
+        */
+       if (((HALF)(z1.v[0] + rp->one.v[0])) == rp->mod.v[0]) {
+               zsub(rp->mod, rp->one, &temp);
+               if (zcmp(z1, temp) == 0) {
+                       if (zisodd(z2)) {
+                               *res = temp;
+                               return;
+                       }
+                       zfree(temp);
+                       zcopy(rp->one, res);
+                       return;
+               }
+               zfree(temp);
+       }
+
+       for (pp = &lowpowers[2]; pp < &lowpowers[POWNUMS]; pp++)
+               pp->len = 0;
+       zcopy(rp->one, &lowpowers[0]);
+       zcopy(z1, &lowpowers[1]);
+       zcopy(rp->one, &ans);
+
+       hp = &z2.v[z2.len - 1];
+       curhalf = *hp;
+       curshift = BASEB - POWBITS;
+       while (curshift && ((curhalf >> curshift) == 0))
+               curshift -= POWBITS;
+
+       /*
+        * Calculate the result by examining the power POWBITS bits at a time,
+        * and use the table of low powers at each iteration.
+        */
+       for (;;) {
+               curpow = (curhalf >> curshift) & (POWNUMS - 1);
+               pp = &lowpowers[curpow];
+
+               /*
+                * If the small power is not yet saved in the table, then
+                * calculate it and remember it in the table for future use.
+                */
+               if (pp->len == 0) {
+                       if (curpow & 0x1)
+                               zcopy(z1, &modpow);
+                       else
+                               zcopy(rp->one, &modpow);
+
+                       for (curbit = 0x2; curbit <= curpow; curbit *= 2) {
+                               pp = &lowpowers[curbit];
+                               if (pp->len == 0)
+                                       zredcsquare(rp, lowpowers[curbit/2],
+                                               pp);
+                               if (curbit & curpow) {
+                                       zredcmul(rp, *pp, modpow, &temp);
+                                       zfree(modpow);
+                                       modpow = temp;
+                               }
+                       }
+                       pp = &lowpowers[curpow];
+                       *pp = modpow;
+               }
+
+               /*
+                * If the power is nonzero, then accumulate the small power
+                * into the result.
+                */
+               if (curpow) {
+                       zredcmul(rp, ans, *pp, &temp);
+                       zfree(ans);
+                       ans = temp;
+               }
+
+               /*
+                * Select the next POWBITS bits of the power, if there is
+                * any more to generate.
+                */
+               curshift -= POWBITS;
+               if (curshift < 0) {
+                       if (hp-- == z2.v)
+                               break;
+                       curhalf = *hp;
+                       curshift = BASEB - POWBITS;
+               }
+
+               /*
+                * Square the result POWBITS times to make room for the next
+                * chunk of bits.
+                */
+               for (i = 0; i < POWBITS; i++) {
+                       zredcsquare(rp, ans, &temp);
+                       zfree(ans);
+                       ans = temp;
+               }
+       }
+
+       for (pp = lowpowers; pp < &lowpowers[POWNUMS]; pp++) {
+               if (pp->len)
+                       freeh(pp->v);
+       }
+       *res = ans;
+}
+
+/* END CODE */
diff --git a/usr/src/contrib/calc-2.9.3t6/zmul.c b/usr/src/contrib/calc-2.9.3t6/zmul.c
new file mode 100644 (file)
index 0000000..b8986e8
--- /dev/null
@@ -0,0 +1,1105 @@
+/*
+ * Copyright (c) 1994 David I. Bell
+ * Permission is granted to use, distribute, or modify this source,
+ * provided that this copyright notice remains intact.
+ *
+ * Faster than usual multiplying and squaring routines.
+ * The algorithm used is the reasonably simple one from Knuth, volume 2,
+ * section 4.3.3.  These recursive routines are of speed O(N^1.585)
+ * instead of O(N^2).  The usual multiplication and (almost usual) squaring
+ * algorithms are used for small numbers.  On a 386 with its compiler, the
+ * two algorithms are equal in speed at about 100 decimal digits.
+ */
+
+#include "zmath.h"
+
+
+LEN _mul2_ = MUL_ALG2;         /* size of number to use multiply algorithm 2 */
+LEN _sq2_ = SQ_ALG2;           /* size of number to use square algorithm 2 */
+
+
+static HALF *tempbuf;          /* temporary buffer for multiply and square */
+
+static LEN domul MATH_PROTO((HALF *v1, LEN size1, HALF *v2, LEN size2, HALF *ans));
+static LEN dosquare MATH_PROTO((HALF *vp, LEN size, HALF *ans));
+
+
+/*
+ * Multiply two numbers using the following formula recursively:
+ *     (A*S+B)*(C*S+D) = (S^2+S)*A*C + S*(A-B)*(D-C) + (S+1)*B*D
+ * where S is a power of 2^16, and so multiplies by it are shifts, and
+ * A,B,C,D are the left and right halfs of the numbers to be multiplied.
+ */
+void
+zmul(z1, z2, res)
+       ZVALUE z1, z2;          /* numbers to multiply */
+       ZVALUE *res;            /* result of multiplication */
+{
+       LEN len;                /* size of array */
+
+       if (ziszero(z1) || ziszero(z2)) {
+               *res = _zero_;
+               return;
+       }
+       if (zisunit(z1)) {
+               zcopy(z2, res);
+               res->sign = (z1.sign != z2.sign);
+               return;
+       }
+       if (zisunit(z2)) {
+               zcopy(z1, res);
+               res->sign = (z1.sign != z2.sign);
+               return;
+       }
+
+       /*
+        * Allocate a temporary buffer for the recursion levels to use.
+        * An array needs to be allocated large enough for all of the
+        * temporary results to fit in.  This size is about twice the size
+        * of the largest original number, since each recursion level uses
+        * the size of its given number, and whose size is 1/2 the size of
+        * the previous level.  The sum of the infinite series is 2.
+        * Add some extra words because of rounding when dividing by 2
+        * and also because of the extra word that each multiply needs.
+        */
+       len = z1.len;
+       if (len < z2.len)
+               len = z2.len;
+       len = 2 * len + 64;
+       tempbuf = zalloctemp(len);
+
+       res->sign = (z1.sign != z2.sign);
+       res->v = alloc(z1.len + z2.len + 1);
+       res->len = domul(z1.v, z1.len, z2.v, z2.len, res->v);
+}
+
+
+/*
+ * Recursive routine to multiply two numbers by splitting them up into
+ * two numbers of half the size, and using the results of multiplying the
+ * subpieces.  The result is placed in the indicated array, which must be
+ * large enough for the result plus one extra word (size1 + size2 + 1).
+ * Returns the actual size of the result with leading zeroes stripped.
+ * This also uses a temporary array which must be twice as large as
+ * one more than the size of the number at the top level recursive call.
+ */
+static LEN
+domul(v1, size1, v2, size2, ans)
+       HALF *v1;               /* first number */
+       LEN size1;              /* size of first number */
+       HALF *v2;               /* second number */
+       LEN size2;              /* size of second number */
+       HALF *ans;              /* location for result */
+{
+       LEN shift;              /* amount numbers are shifted by */
+       LEN sizeA;              /* size of left half of first number */
+       LEN sizeB;              /* size of right half of first number */
+       LEN sizeC;              /* size of left half of second number */
+       LEN sizeD;              /* size of right half of second number */
+       LEN sizeAB;             /* size of subtraction of A and B */
+       LEN sizeDC;             /* size of subtraction of D and C */
+       LEN sizeABDC;           /* size of product of above two results */
+       LEN subsize;            /* size of difference of halfs */
+       LEN copysize;           /* size of number left to copy */
+       LEN sizetotal;          /* total size of product */
+       LEN len;                /* temporary length */
+       HALF *baseA;            /* base of left half of first number */
+       HALF *baseB;            /* base of right half of first number */
+       HALF *baseC;            /* base of left half of second number */
+       HALF *baseD;            /* base of right half of second number */
+       HALF *baseAB;           /* base of result of subtraction of A and B */
+       HALF *baseDC;           /* base of result of subtraction of D and C */
+       HALF *baseABDC;         /* base of product of above two results */
+       HALF *baseAC;           /* base of product of A and C */
+       HALF *baseBD;           /* base of product of B and D */
+       FULL carry;             /* carry digit for small multiplications */
+       FULL carryACBD;         /* carry from addition of A*C and B*D */
+       FULL digit;             /* single digit multiplying by */
+       HALF *temp;             /* base for temporary calculations */
+       BOOL neg;               /* whether imtermediate term is negative */
+       register HALF *hd, *h1=NULL, *h2=NULL;  /* for inner loops */
+       SIUNION sival;          /* for addition of digits */
+
+       /*
+        * Trim the numbers of leading zeroes and initialize the
+        * estimated size of the result.
+        */
+       hd = &v1[size1 - 1];
+       while ((*hd == 0) && (size1 > 1)) {
+               hd--;
+               size1--;
+       }
+       hd = &v2[size2 - 1];
+       while ((*hd == 0) && (size2 > 1)) {
+               hd--;
+               size2--;
+       }
+       sizetotal = size1 + size2;
+
+       /*
+        * First check for zero answer.
+        */
+       if (((size1 == 1) && (*v1 == 0)) || ((size2 == 1) && (*v2 == 0))) {
+               *ans = 0;
+               return 1;
+       }
+
+       /*
+        * Exchange the two numbers if necessary to make the number of
+        * digits of the first number be greater than or equal to the
+        * second number.
+        */
+       if (size1 < size2) {
+               len = size1; size1 = size2; size2 = len;
+               hd = v1; v1 = v2; v2 = hd;
+       }
+
+       /*
+        * If the smaller number has only a few digits, then calculate
+        * the result in the normal manner in order to avoid the overhead
+        * of the recursion for small numbers.  The number of digits where
+        * the algorithm changes is settable from 2 to maxint.
+        */
+       if (size2 < _mul2_) {
+               /*
+                * First clear the top part of the result, and then multiply
+                * by the lowest digit to get the first partial sum.  Later
+                * products will then add into this result.
+                */
+               hd = &ans[size1];
+               len = size2;
+               while (len--)
+                       *hd++ = 0;
+
+               digit = *v2++;
+               h1 = v1;
+               hd = ans;
+               carry = 0;
+               len = size1;
+               while (len >= 4) {      /* expand the loop some */
+                       len -= 4;
+                       sival.ivalue = ((FULL) *h1++) * digit + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+                       sival.ivalue = ((FULL) *h1++) * digit + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+                       sival.ivalue = ((FULL) *h1++) * digit + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+                       sival.ivalue = ((FULL) *h1++) * digit + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+               while (len--) {
+                       sival.ivalue = ((FULL) *h1++) * digit + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+               *hd = (HALF)carry;
+
+               /*
+                * Now multiply by the remaining digits of the second number,
+                * adding each product into the final result.
+                */
+               h2 = ans;
+               while (--size2 > 0) {
+                       digit = *v2++;
+                       h1 = v1;
+                       hd = ++h2;
+                       if (digit == 0)
+                               continue;
+                       carry = 0;
+                       len = size1;
+                       while (len >= 4) {      /* expand the loop some */
+                               len -= 4;
+                               sival.ivalue = ((FULL) *h1++) * digit
+                                       + ((FULL) *hd) + carry;
+                               *hd++ = sival.silow;
+                               carry = sival.sihigh;
+                               sival.ivalue = ((FULL) *h1++) * digit
+                                       + ((FULL) *hd) + carry;
+                               *hd++ = sival.silow;
+                               carry = sival.sihigh;
+                               sival.ivalue = ((FULL) *h1++) * digit
+                                       + ((FULL) *hd) + carry;
+                               *hd++ = sival.silow;
+                               carry = sival.sihigh;
+                               sival.ivalue = ((FULL) *h1++) * digit
+                                       + ((FULL) *hd) + carry;
+                               *hd++ = sival.silow;
+                               carry = sival.sihigh;
+                       }
+                       while (len--) {
+                               sival.ivalue = ((FULL) *h1++) * digit
+                                       + ((FULL) *hd) + carry;
+                               *hd++ = sival.silow;
+                               carry = sival.sihigh;
+                       }
+                       while (carry) {
+                               sival.ivalue = ((FULL) *hd) + carry;
+                               *hd++ = sival.silow;
+                               carry = sival.sihigh;
+                       }
+               }
+
+               /*
+                * Now return the true size of the number.
+                */
+               len = sizetotal;
+               hd = &ans[len - 1];
+               while ((*hd == 0) && (len > 1)) {
+                       hd--;
+                       len--;
+               }
+               return len;
+       }
+
+       /*
+        * Need to multiply by a large number.
+        * Allocate temporary space for calculations, and calculate the
+        * value for the shift.  The shift value is 1/2 the size of the
+        * larger (first) number (rounded up).  The amount of temporary
+        * space needed is twice the size of the shift, plus one more word
+        * for the multiply to use.
+        */
+       shift = (size1 + 1) / 2;
+       temp = tempbuf;
+       tempbuf += (2 * shift) + 1;
+
+       /*
+        * Determine the sizes and locations of all the numbers.
+        * The value of sizeC can be negative, and this is checked later.
+        * The value of sizeD is limited by the full size of the number.
+        */
+       baseA = v1 + shift;
+       baseB = v1;
+       /* 
+        * XXX - Saber-C Version 3.1 says:
+        *
+        *    W#26, Storing a bad pointer into auto variable dmul`baseC.
+        *
+        * This warning is issued during the regression test #026
+        * (read cryrand).
+        *
+        * Saver-C claims that v2+shift is past the end of allocated
+        * memory for v2.  When this warning is first issued, shift
+        * has the value 51.
+        *
+        * The call stack is:
+        *
+        *   domul(0x165ca0, 101, 0x160998, 40, 0x16d0a8) at "zmul.c":315 
+        *   zmul(0x2ddf88, 0x2ddf8c, 0x2ddc98) at "zmul.c":73 
+        *   qsqrt(0x38defc, 0x38ea94) at "qfunc.c":248 
+        *   qln(0x38defc, 0x38de70) at "qtrans.c":589 
+        *   qpower(0x38eacc, 0x38a398, 0x38a018) at "qtrans.c":657 
+        *   powervalue(0x1740f8,0x174118,0x195234,0x19523c) at "value.c":1009 
+        *   f_power(2, 0x533278) at "func.c":1188 
+        *   builtinfunc(117, 2, 0x174118) at "func.c":354 
+        *   o_call(0x5328d8, 117, 2) at "opcodes.c":2094 
+        *   calculate(0x5328d8, 1) at "opcodes.c":288 
+        *   o_usercall(0x5328d8, 54, 1) at "opcodes.c":2082 
+        *   calculate(0x48ffa8, 4) at "opcodes.c":288 
+        *   o_usercall(0x48ffa8, 53, 1) at "opcodes.c":2082 
+        *   calculate(0x1652a0, 1) at "opcodes.c":288 
+        *   o_usercall(0x1652a0, 57, 1) at "opcodes.c":2082 
+        *   calculate(0x16cca8, 0) at "opcodes.c":288 
+        *   evaluate(0) at "codegen.c":167 
+        *   getcommands(0) at "codegen.c":106 
+        *   getcommands(0) at "codegen.c":76 
+        *   getcommands(1) at "codegen.c":76 
+        *   main(-1, 0x181f8c) at "calc.c":155 
+        *
+        * Purify does not complain about this code.  Who is right?
+        */
+       baseC = v2 + shift;
+       baseD = v2;
+       baseAB = ans;
+       baseDC = ans + shift;
+       baseAC = ans + shift * 2;
+       baseBD = ans;
+
+       sizeA = size1 - shift;
+       sizeC = size2 - shift;
+
+       sizeB = shift;
+       hd = &baseB[shift - 1];
+       while ((*hd == 0) && (sizeB > 1)) {
+               hd--;
+               sizeB--;
+       }
+
+       sizeD = shift;
+       if (sizeD > size2)
+               sizeD = size2;
+       hd = &baseD[sizeD - 1];
+       while ((*hd == 0) && (sizeD > 1)) {
+               hd--;
+               sizeD--;
+       }
+
+       /*
+        * If the smaller number has a high half of zero, then calculate
+        * the result by breaking up the first number into two numbers
+        * and combining the results using the obvious formula:
+        *      (A*S+B) * D = (A*D)*S + B*D
+        */
+       if (sizeC <= 0) {
+               len = domul(baseB, sizeB, baseD, sizeD, ans);
+               hd = &ans[len];
+               len = sizetotal - len;
+               while (len--)
+                       *hd++ = 0;
+
+               /*
+                * Add the second number into the first number, shifted
+                * over at the correct position.
+                */
+               len = domul(baseA, sizeA, baseD, sizeD, temp);
+               h1 = temp;
+               hd = ans + shift;
+               carry = 0;
+               while (len--) {
+                       sival.ivalue = ((FULL) *h1++) + ((FULL) *hd) + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+               while (carry) {
+                       sival.ivalue = ((FULL) *hd) + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+
+               /*
+                * Determine the final size of the number and return it.
+                */
+               len = sizetotal;
+               hd = &ans[len - 1];
+               while ((*hd == 0) && (len > 1)) {
+                       hd--;
+                       len--;
+               }
+               tempbuf = temp;
+               return len;
+       }
+
+       /*
+        * Now we know that the high halfs of the numbers are nonzero,
+        * so we can use the complete formula.
+        *      (A*S+B)*(C*S+D) = (S^2+S)*A*C + S*(A-B)*(D-C) + (S+1)*B*D.
+        * The steps are done in the following order:
+        *      A-B
+        *      D-C
+        *      (A-B)*(D-C)
+        *      S^2*A*C + B*D
+        *      (S^2+S)*A*C + (S+1)*B*D                         (*)
+        *      (S^2+S)*A*C + S*(A-B)*(D-C) + (S+1)*B*D
+        *
+        * Note: step (*) above can produce a result which is larger than
+        * the final product will be, and this is where the extra word
+        * needed in the product comes from.  After the final subtraction is
+        * done, the result fits in the expected size.  Using the extra word
+        * is easier than suppressing the carries and borrows everywhere.
+        *
+        * Begin by forming the product (A-B)*(D-C) into a temporary
+        * location that we save until the final step.  Do each subtraction
+        * at positions 0 and S.  Be very careful about the relative sizes
+        * of the numbers since this result can be negative.  For the first
+        * step calculate the absolute difference of A and B into a temporary
+        * location at position 0 of the result.  Negate the sign if A is
+        * smaller than B.
+        */
+       neg = FALSE;
+       if (sizeA == sizeB) {
+               len = sizeA;
+               h1 = &baseA[len - 1];
+               h2 = &baseB[len - 1];
+               while ((len > 1) && (*h1 == *h2)) {
+                       len--;
+                       h1--;
+                       h2--;
+               }
+       }
+       if ((sizeA > sizeB) || ((sizeA == sizeB) && h1 && h2 && (*h1 > *h2))) {
+               h1 = baseA;
+               h2 = baseB;
+               sizeAB = sizeA;
+               subsize = sizeB;
+       } else {
+               neg = !neg;
+               h1 = baseB;
+               h2 = baseA;
+               sizeAB = sizeB;
+               subsize = sizeA;
+       }
+       copysize = sizeAB - subsize;
+
+       hd = baseAB;
+       carry = 0;
+       while (subsize--) {
+               sival.ivalue = BASE1 - ((FULL) *h1++) + ((FULL) *h2++) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+       while (copysize--) {
+               sival.ivalue = (BASE1 - ((FULL) *h1++)) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+
+       hd = &baseAB[sizeAB - 1];
+       while ((*hd == 0) && (sizeAB > 1)) {
+               hd--;
+               sizeAB--;
+       }
+
+       /*
+        * This completes the calculation of abs(A-B).  For the next step
+        * calculate the absolute difference of D and C into a temporary
+        * location at position S of the result.  Negate the sign if C is
+        * larger than D.
+        */
+       if (sizeC == sizeD) {
+               len = sizeC;
+               h1 = &baseC[len - 1];
+               h2 = &baseD[len - 1];
+               while ((len > 1) && (*h1 == *h2)) {
+                       len--;
+                       h1--;
+                       h2--;
+               }
+       }
+       if ((sizeC > sizeD) || ((sizeC == sizeD) && (*h1 > *h2)))
+       {
+               neg = !neg;
+               h1 = baseC;
+               h2 = baseD;
+               sizeDC = sizeC;
+               subsize = sizeD;
+       } else {
+               h1 = baseD;
+               h2 = baseC;
+               sizeDC = sizeD;
+               subsize = sizeC;
+       }
+       copysize = sizeDC - subsize;
+
+       hd = baseDC;
+       carry = 0;
+       while (subsize--) {
+               sival.ivalue = BASE1 - ((FULL) *h1++) + ((FULL) *h2++) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+       while (copysize--) {
+               sival.ivalue = (BASE1 - ((FULL) *h1++)) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+       hd = &baseDC[sizeDC - 1];
+       while ((*hd == 0) && (sizeDC > 1)) {
+               hd--;
+               sizeDC--;
+       }
+
+       /*
+        * This completes the calculation of abs(D-C).  Now multiply
+        * together abs(A-B) and abs(D-C) into a temporary location,
+        * which is preserved until the final steps.
+        */
+       baseABDC = temp;
+       sizeABDC = domul(baseAB, sizeAB, baseDC, sizeDC, baseABDC);
+
+       /*
+        * Now calculate B*D and A*C into one of their two final locations.
+        * Make sure the high order digits of the products are zeroed since
+        * this initializes the final result.  Be careful about this zeroing
+        * since the size of the high order words might be smaller than
+        * the shift size.  Do B*D first since the multiplies use one more
+        * word than the size of the product.  Also zero the final extra
+        * word in the result for possible carries to use.
+        */
+       len = domul(baseB, sizeB, baseD, sizeD, baseBD);
+       hd = &baseBD[len];
+       len = shift * 2 - len;
+       while (len--)
+               *hd++ = 0;
+
+       len = domul(baseA, sizeA, baseC, sizeC, baseAC);
+       hd = &baseAC[len];
+       len = sizetotal - shift * 2 - len + 1;
+       while (len--)
+               *hd++ = 0;
+
+       /*
+        * Now add in A*C and B*D into themselves at the other shifted
+        * position that they need.  This addition is tricky in order to
+        * make sure that the two additions cannot interfere with each other.
+        * Therefore we first add in the top half of B*D and the lower half
+        * of A*C.  The sources and destinations of these two additions
+        * overlap, and so the same answer results from the two additions,
+        * thus only two pointers suffice for both additions.  Keep the
+        * final carry from these additions for later use since we cannot
+        * afford to change the top half of A*C yet.
+        */
+       h1 = baseBD + shift;
+       h2 = baseAC;
+       carryACBD = 0;
+       len = shift;
+       while (len--) {
+               sival.ivalue = ((FULL) *h1) + ((FULL) *h2) + carryACBD;
+               *h1++ = sival.silow;
+               *h2++ = sival.silow;
+               carryACBD = sival.sihigh;
+       }
+
+       /*
+        * Now add in the bottom half of B*D and the top half of A*C.
+        * These additions are straightforward, except that A*C should
+        * be done first because of possible carries from B*D, and the
+        * top half of A*C might not exist.  Add in one of the carries
+        * from the previous addition while we are at it.
+        */
+       h1 = baseAC + shift;
+       hd = baseAC;
+       carry = carryACBD;
+       len = sizetotal - 3 * shift;
+       while (len--) {
+               sival.ivalue = ((FULL) *h1++) + ((FULL) *hd) + carry;
+               *hd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       while (carry) {
+               sival.ivalue = ((FULL) *hd) + carry;
+               *hd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+
+       h1 = baseBD;
+       hd = baseBD + shift;
+       carry = 0;
+       len = shift;
+       while (len--) {
+               sival.ivalue = ((FULL) *h1++) + ((FULL) *hd) + carry;
+               *hd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       while (carry) {
+               sival.ivalue = ((FULL) *hd) + carry;
+               *hd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+
+       /*
+        * Now finally add in the other delayed carry from the
+        * above addition.
+        */
+       hd = baseAC + shift;
+       while (carryACBD) {
+               sival.ivalue = ((FULL) *hd) + carryACBD;
+               *hd++ = sival.silow;
+               carryACBD = sival.sihigh;
+       }
+
+       /*
+        * Now finally add or subtract (A-B)*(D-C) into the final result at
+        * the correct position (S), according to whether it is positive or
+        * negative.  When subtracting, the answer cannot go negative.
+        */
+       h1 = baseABDC;
+       hd = ans + shift;
+       carry = 0;
+       len = sizeABDC;
+       if (neg) {
+               while (len--) {
+                       sival.ivalue = BASE1 - ((FULL) *hd) +
+                               ((FULL) *h1++) + carry;
+                       *hd++ = BASE1 - sival.silow;
+                       carry = sival.sihigh;
+               }
+               while (carry) {
+                       sival.ivalue = BASE1 - ((FULL) *hd) + carry;
+                       *hd++ = BASE1 - sival.silow;
+                       carry = sival.sihigh;
+               }
+       } else {
+               while (len--) {
+                       sival.ivalue = ((FULL) *h1++) + ((FULL) *hd) + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+               while (carry) {
+                       sival.ivalue = ((FULL) *hd) + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+       }
+
+       /*
+        * Finally determine the size of the final result and return that.
+        */
+       len = sizetotal;
+       hd = &ans[len - 1];
+       while ((*hd == 0) && (len > 1)) {
+               hd--;
+               len--;
+       }
+       tempbuf = temp;
+       return len;
+}
+
+
+/*
+ * Square a number by using the following formula recursively:
+ *     (A*S+B)^2 = (S^2+S)*A^2 + (S+1)*B^2 - S*(A-B)^2
+ * where S is a power of 2^16, and so multiplies by it are shifts,
+ * and A and B are the left and right halfs of the number to square.
+ */
+void
+zsquare(z, res)
+       ZVALUE z, *res;
+{
+       LEN len;
+
+       if (ziszero(z)) {
+               *res = _zero_;
+               return;
+       }
+       if (zisunit(z)) {
+               *res = _one_;
+               return;
+       }
+
+       /*
+        * Allocate a temporary array if necessary for the recursion to use.
+        * The array needs to be allocated large enough for all of the
+        * temporary results to fit in.  This size is about 3 times the
+        * size of the original number, since each recursion level uses 3/2
+        * of the size of its given number, and whose size is 1/2 the size
+        * of the previous level.  The sum of the infinite series is 3.
+        * Allocate some extra words for rounding up the sizes.
+        */
+       len = 3 * z.len + 32;
+       tempbuf = zalloctemp(len);
+
+       res->sign = 0;
+       res->v = alloc((z.len+1) * 2);
+       res->len = dosquare(z.v, z.len, res->v);
+}
+
+
+/*
+ * Recursive routine to square a number by splitting it up into two numbers
+ * of half the size, and using the results of squaring the subpieces.
+ * The result is placed in the indicated array, which must be large
+ * enough for the result (size * 2).  Returns the size of the result.
+ * This uses a temporary array which must be 3 times as large as the
+ * size of the number at the top level recursive call.
+ */
+static LEN
+dosquare(vp, size, ans)
+       HALF *vp;               /* value to be squared */
+       LEN size;               /* length of value to square */
+       HALF *ans;              /* location for result */
+{
+       LEN shift;              /* amount numbers are shifted by */
+       LEN sizeA;              /* size of left half of number to square */
+       LEN sizeB;              /* size of right half of number to square */
+       LEN sizeAA;             /* size of square of left half */
+       LEN sizeBB;             /* size of square of right half */
+       LEN sizeAABB;           /* size of sum of squares of A and B */
+       LEN sizeAB;             /* size of difference of A and B */
+       LEN sizeABAB;           /* size of square of difference of A and B */
+       LEN subsize;            /* size of difference of halfs */
+       LEN copysize;           /* size of number left to copy */
+       LEN sumsize;            /* size of sum */
+       LEN sizetotal;          /* total size of square */
+       LEN len;                /* temporary length */
+       LEN len1;               /* another temporary length */
+       FULL carry;             /* carry digit for small multiplications */
+       FULL digit;             /* single digit multiplying by */
+       HALF *temp;             /* base for temporary calculations */
+       HALF *baseA;            /* base of left half of number */
+       HALF *baseB;            /* base of right half of number */
+       HALF *baseAA;           /* base of square of left half of number */
+       HALF *baseBB;           /* base of square of right half of number */
+       HALF *baseAABB;         /* base of sum of squares of A and B */
+       HALF *baseAB;           /* base of difference of A and B */
+       HALF *baseABAB;         /* base of square of difference of A and B */
+       register HALF *hd, *h1, *h2, *h3;       /* for inner loops */
+       SIUNION sival;          /* for addition of digits */
+
+       /*
+        * First trim the number of leading zeroes.
+        */
+       hd = &vp[size - 1];
+       while ((*hd == 0) && (size > 1)) {
+               size--;
+               hd--;
+       }
+       sizetotal = size + size;
+
+       /*
+        * If the number has only a small number of digits, then use the
+        * (almost) normal multiplication method.  Multiply each halfword
+        * only by those halfwards further on in the number.  Missed terms
+        * will then be the same pairs of products repeated, and the squares
+        * of each halfword.  The first case is handled by doubling the
+        * result.  The second case is handled explicitly.  The number of
+        * digits where the algorithm changes is settable from 2 to maxint.
+        */
+       if (size < _sq2_) {
+               hd = ans;
+               len = sizetotal;
+               while (len--)
+                       *hd++ = 0;
+
+               h2 = vp;
+               hd = ans + 1;
+               for (len = size; len--; hd += 2) {
+                       digit = (FULL) *h2++;
+                       if (digit == 0)
+                               continue;
+                       h3 = h2;
+                       h1 = hd;
+                       carry = 0;
+                       len1 = len;
+                       while (len1 >= 4) {     /* expand the loop some */
+                               len1 -= 4;
+                               sival.ivalue = (digit * ((FULL) *h3++))
+                                       + ((FULL) *h1) + carry;
+                               *h1++ = sival.silow;
+                               sival.ivalue = (digit * ((FULL) *h3++))
+                                       + ((FULL) *h1) + ((FULL) sival.sihigh);
+                               *h1++ = sival.silow;
+                               sival.ivalue = (digit * ((FULL) *h3++))
+                                       + ((FULL) *h1) + ((FULL) sival.sihigh);
+                               *h1++ = sival.silow;
+                               sival.ivalue = (digit * ((FULL) *h3++))
+                                       + ((FULL) *h1) + ((FULL) sival.sihigh);
+                               *h1++ = sival.silow;
+                               carry = sival.sihigh;
+                       }
+                       while (len1--) {
+                               sival.ivalue = (digit * ((FULL) *h3++))
+                                       + ((FULL) *h1) + carry;
+                               *h1++ = sival.silow;
+                               carry = sival.sihigh;
+                       }
+                       while (carry) {
+                               sival.ivalue = ((FULL) *h1) + carry;
+                               *h1++ = sival.silow;
+                               carry = sival.sihigh;
+                       }
+               }
+
+               /*
+                * Now double the result.
+                * There is no final carry to worry about because we
+                * handle all digits of the result which must fit.
+                */
+               carry = 0;
+               hd = ans;
+               len = sizetotal;
+               while (len--) {
+                       digit = ((FULL) *hd);
+                       sival.ivalue = digit + digit + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+
+               /*
+                * Now add in the squares of each halfword.
+                */
+               carry = 0;
+               hd = ans;
+               h3 = vp;
+               len = size;
+               while (len--) {
+                       digit = ((FULL) *h3++);
+                       sival.ivalue = digit * digit + ((FULL) *hd) + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+                       sival.ivalue = ((FULL) *hd) + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+               while (carry) {
+                       sival.ivalue = ((FULL) *hd) + carry;
+                       *hd++ = sival.silow;
+                       carry = sival.sihigh;
+               }
+
+               /*
+                * Finally return the size of the result.
+                */
+               len = sizetotal;
+               hd = &ans[len - 1];
+               while ((*hd == 0) && (len > 1)) {
+                       len--;
+                       hd--;
+               }
+               return len;
+       }
+
+       /*
+        * The number to be squared is large.
+        * Allocate temporary space and determine the sizes and
+        * positions of the values to be calculated.
+        */
+       temp = tempbuf;
+       tempbuf += (3 * (size + 1) / 2);
+
+       sizeA = size / 2;
+       sizeB = size - sizeA;
+       shift = sizeB;
+       baseA = vp + sizeB;
+       baseB = vp;
+       baseAA = &ans[shift * 2];
+       baseBB = ans;
+       baseAABB = temp;
+       baseAB = temp;
+       baseABAB = &temp[shift];
+
+       /*
+        * Trim the second number of leading zeroes.
+        */
+       hd = &baseB[sizeB - 1];
+       while ((*hd == 0) && (sizeB > 1)) {
+               sizeB--;
+               hd--;
+       }
+
+       /*
+        * Now to proceed to calculate the result using the formula.
+        *      (A*S+B)^2 = (S^2+S)*A^2 + (S+1)*B^2 - S*(A-B)^2.
+        * The steps are done in the following order:
+        *      S^2*A^2 + B^2
+        *      A^2 + B^2
+        *      (S^2+S)*A^2 + (S+1)*B^2
+        *      (A-B)^2
+        *      (S^2+S)*A^2 + (S+1)*B^2 - S*(A-B)^2.
+        *
+        * Begin by forming the squares of two the halfs concatenated
+        * together in the final result location.  Make sure that the
+        * highest words of the results are zero.
+        */
+       sizeBB = dosquare(baseB, sizeB, baseBB);
+       hd = &baseBB[sizeBB];
+       len = shift * 2 - sizeBB;
+       while (len--)
+               *hd++ = 0;
+
+       sizeAA = dosquare(baseA, sizeA, baseAA);
+       hd = &baseAA[sizeAA];
+       len = sizetotal - shift * 2 - sizeAA;
+       while (len--)
+               *hd++ = 0;
+
+       /*
+        * Sum the two squares into a temporary location.
+        */
+       if (sizeAA >= sizeBB) {
+               h1 = baseAA;
+               h2 = baseBB;
+               sizeAABB = sizeAA;
+               sumsize = sizeBB;
+       } else {
+               h1 = baseBB;
+               h2 = baseAA;
+               sizeAABB = sizeBB;
+               sumsize = sizeAA;
+       }
+       copysize = sizeAABB - sumsize;
+
+       hd = baseAABB;
+       carry = 0;
+       while (sumsize--) {
+               sival.ivalue = ((FULL) *h1++) + ((FULL) *h2++) + carry;
+               *hd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       while (copysize--) {
+               sival.ivalue = ((FULL) *h1++) + carry;
+               *hd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       if (carry) {
+               *hd = (HALF)carry;
+               sizeAABB++;
+       }
+
+       /*
+        * Add the sum back into the previously calculated squares
+        * shifted over to the proper location.
+        */
+       h1 = baseAABB;
+       hd = ans + shift;
+       carry = 0;
+       len = sizeAABB;
+       while (len--) {
+               sival.ivalue = ((FULL) *hd) + ((FULL) *h1++) + carry;
+               *hd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+       while (carry) {
+               /*
+                * XXX - Saber-C Version 3.1 says:
+                *
+                *    W#113, Using allocated data what has not been set.
+                *
+                * This warning is issued during the regression test #622
+                * (algcheck 1).
+                *
+                * Saber-C claims that *hd has been allocated but not set.
+                * When this warning was first issued, hd == 0x19547c
+                * which is 12 bytes off from ans.  The value of carry
+                * was 1, the value of shift was 2, len was -1 and sizeAABB
+                * was 4, sizeBB as 4, sizeAA was 2.  The value stored
+                * in *hd was 0xbfbf.
+                *
+                * The call stack is:
+                *
+                *   dosquare(0x183e88, 3, 0x195470) at "zmul.c":981 
+                *   zsquare(0x1952b0, 0x4c1348) at "zmul.c":687 
+                *   zpowermod(0x5d1d58,0x5d1d5c,0x5d1d60,0x390218) at "zmod.c":679 
+                *   qpowermod(0x38a088, 0x3901a8, 0x38a964) at "qfunc.c":76 
+                *   builtinfunc(113, 3, 0x1740f0) at "func.c":386 
+                *   o_call(0x3b5de0, 113, 3) at "opcodes.c":2094 
+                *   calculate(0x3b5de0, 3) at "opcodes.c":288 
+                *   o_usercall(0x3b5de0, 13, 3) at "opcodes.c":2082 
+                *   calculate(0x47dfa8, 0) at "opcodes.c":288 
+                *   o_usercall(0x47dfa8, 14, 0) at "opcodes.c":2082 
+                *   calculate(0x16cca8, 0) at "opcodes.c":288 
+                *   evaluate(0) at "codegen.c":167 
+                *   getcommands(0) at "codegen.c":106 
+                *   getcommands(1) at "codegen.c":76 
+                *   main(-1, 0x181f8c) at "calc.c":155 
+                *
+                * Purify does not report this.  Who is right?
+                */
+               sival.ivalue = ((FULL) *hd) + carry;
+               *hd++ = sival.silow;
+               carry = sival.sihigh;
+       }
+
+       /*
+        * Calculate the absolute value of the difference of the two halfs
+        * into a temporary location.
+        */
+       if (sizeA == sizeB) {
+               len = sizeA;
+               h1 = &baseA[len - 1];
+               h2 = &baseB[len - 1];
+               while ((len > 1) && (*h1 == *h2)) {
+                       len--;
+                       h1--;
+                       h2--;
+               }
+       }
+       if ((sizeA > sizeB) || ((sizeA == sizeB) && (*h1 > *h2)))
+       {
+               h1 = baseA;
+               h2 = baseB;
+               sizeAB = sizeA;
+               subsize = sizeB;
+       } else {
+               h1 = baseB;
+               h2 = baseA;
+               sizeAB = sizeB;
+               subsize = sizeA;
+       }
+       copysize = sizeAB - subsize;
+
+       hd = baseAB;
+       carry = 0;
+       while (subsize--) {
+               sival.ivalue = BASE1 - ((FULL) *h1++) + ((FULL) *h2++) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+       while (copysize--) {
+               sival.ivalue = (BASE1 - ((FULL) *h1++)) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+
+       hd = &baseAB[sizeAB - 1];
+       while ((*hd == 0) && (sizeAB > 1)) {
+               sizeAB--;
+               hd--;
+       }
+
+       /*
+        * Now square the number into another temporary location,
+        * and subtract that from the final result.
+        */
+       sizeABAB = dosquare(baseAB, sizeAB, baseABAB);
+
+       h1 = baseABAB;
+       hd = ans + shift;
+       carry = 0;
+       while (sizeABAB--) {
+               sival.ivalue = BASE1 - ((FULL) *hd) + ((FULL) *h1++) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+       while (carry) {
+               sival.ivalue = BASE1 - ((FULL) *hd) + carry;
+               *hd++ = BASE1 - sival.silow;
+               carry = sival.sihigh;
+       }
+
+       /*
+        * Return the size of the result.
+        */
+       len = sizetotal;
+       hd = &ans[len - 1];
+       while ((*hd == 0) && (len > 1)) {
+               len--;
+               hd--;
+       }
+       tempbuf = temp;
+       return len;
+}
+
+
+/*
+ * Return a pointer to a buffer to be used for holding a temporary number.
+ * The buffer will be at least as large as the specified number of HALFs,
+ * and remains valid until the next call to this routine.  The buffer cannot
+ * be freed by the caller.  There is only one temporary buffer, and so as to
+ * avoid possible conflicts this is only used by the lowest level routines
+ * such as divide, multiply, and square.
+ */
+HALF *
+zalloctemp(len)
+       LEN len;                /* required number of HALFs in buffer */
+{
+       HALF *hp;
+       static LEN buflen;      /* current length of temp buffer */
+       static HALF *bufptr;    /* pointer to current temp buffer */
+
+       if (len <= buflen)
+               return bufptr;
+
+       /*
+        * We need to grow the temporary buffer.
+        * First free any existing buffer, and then allocate the new one.
+        * While we are at it, make the new buffer bigger than necessary
+        * in order to reduce the number of reallocations.
+        */
+       len += 100;
+       if (buflen) {
+               buflen = 0;
+               free(bufptr);
+       }
+       hp = (HALF *) malloc(len * sizeof(HALF));
+       if (hp == NULL)
+               math_error("No memory for temp buffer");
+       bufptr = hp;
+       buflen = len;
+       return hp;
+}
+
+/* END CODE */