From 4618313a82000c8d9adf4eab2da4ca4ec78aa6a1 Mon Sep 17 00:00:00 2001 From: Landon Curt Noll Date: Sat, 6 Jul 1996 04:17:00 -0700 Subject: [PATCH] Release calc version 2.10.2t30 --- BUGS | 95 + CHANGES | 1618 +++++++++++++++ LIBRARY | 436 ++++ Makefile | 2967 ++++++++++++++++++++++++++ README | 68 + README.FIRST | 52 + addop.c | 448 ++++ align32.c | 79 + alloc.h | 64 + assocfunc.c | 477 +++++ byteswap.c | 686 ++++++ byteswap.h | 166 ++ calc.c | 441 ++++ calc.h | 165 ++ calc.man | 423 ++++ calcerr.tbl | 193 ++ calcerr_c.awk | 17 + calcerr_c.sed | 4 + calcerr_h.awk | 22 + calcerr_h.sed | 4 + check.awk | 74 + cmath.h | 113 + codegen.c | 2115 +++++++++++++++++++ comfunc.c | 770 +++++++ commath.c | 555 +++++ config.c | 985 +++++++++ config.h | 143 ++ const.c | 113 + endian.c | 78 + file.c | 2308 +++++++++++++++++++++ file.h | 60 + fposval.c | 212 ++ func.c | 4819 +++++++++++++++++++++++++++++++++++++++++++ func.h | 80 + hash.c | 117 ++ hash.h | 50 + have_const.c | 58 + have_fpos.c | 53 + have_newstr.c | 60 + have_stdvs.c | 139 ++ have_uid_t.c | 62 + have_varvs.c | 131 ++ help/Makefile | 369 ++++ help/abs | 41 + help/access | 46 + help/acos | 32 + help/acosh | 32 + help/acot | 31 + help/acoth | 33 + help/acsc | 32 + help/acsch | 33 + help/append | 60 + help/appr | 146 ++ help/archive | 25 + help/arg | 33 + help/asec | 32 + help/asech | 33 + help/asin | 32 + help/asinh | 32 + help/assign | 29 + help/assoc | 79 + help/atan | 31 + help/atan2 | 36 + help/atanh | 32 + help/avg | 50 + help/base | 55 + help/bround | 123 ++ help/btrunc | 36 + help/builtin.end | 200 ++ help/builtin.top | 9 + help/ceil | 33 + help/cfappr | 89 + help/cfsim | 114 + help/char | 27 + help/cmdbuf | 26 + help/cmp | 90 + help/comb | 39 + help/command | 99 + help/config | 267 +++ help/conj | 35 + help/cos | 36 + help/cosh | 31 + help/cot | 30 + help/coth | 32 + help/count | 31 + help/cp | 37 + help/credit | 62 + help/csc | 29 + help/csch | 32 + help/ctime | 29 + help/define | 68 + help/delete | 44 + help/den | 38 + help/det | 74 + help/digit | 38 + help/digits | 27 + help/dp | 38 + help/environment | 86 + help/epsilon | 34 + help/errno | 38 + help/error | 28 + help/errorcodes.hdr | 2 + help/errorcodes.sed | 1 + help/eval | 61 + help/exp | 41 + help/expression | 35 + help/fact | 33 + help/factor | 41 + help/fclose | 52 + help/fcnt | 31 + help/feof | 44 + help/ferror | 33 + help/fflush | 28 + help/fgetc | 35 + help/fgetfield | 52 + help/fgetline | 51 + help/fgets | 40 + help/fgetstr | 48 + help/fib | 28 + help/file | 167 ++ help/files | 69 + help/floor | 33 + help/fopen | 75 + help/forall | 38 + help/fprintf | 55 + help/fputc | 32 + help/fputs | 32 + help/fputstr | 40 + help/frac | 42 + help/frem | 37 + help/freopen | 42 + help/fscan | 39 + help/fscanf | 130 ++ help/fseek | 67 + help/fsize | 30 + help/ftell | 47 + help/funclist.sed | 9 + help/gcd | 28 + help/gcdrem | 54 + help/getenv | 35 + help/hash | 26 + help/head | 49 + help/help | 69 + help/highbit | 29 + help/history | 61 + help/hmean | 38 + help/hypot | 28 + help/ilog | 28 + help/ilog10 | 26 + help/ilog2 | 26 + help/im | 26 + help/insert | 59 + help/int | 41 + help/interrupt | 28 + help/intro | 55 + help/inverse | 48 + help/iroot | 27 + help/isassoc | 29 + help/isatty | 30 + help/isconfig | 28 + help/iserror | 28 + help/iseven | 30 + help/isfile | 29 + help/ishash | 28 + help/isident | 26 + help/isint | 31 + help/islist | 29 + help/ismat | 29 + help/ismult | 36 + help/isnull | 29 + help/isnum | 31 + help/isobj | 29 + help/isodd | 30 + help/isprime | 48 + help/isqrt | 26 + help/isrand | 28 + help/israndom | 30 + help/isreal | 31 + help/isrel | 31 + help/isset | 43 + help/issimple | 39 + help/issq | 34 + help/isstr | 28 + help/istype | 39 + help/jacobi | 62 + help/join | 39 + help/lcm | 30 + help/lcmfact | 27 + help/lfactor | 34 + help/list | 77 + help/ln | 35 + help/lowbit | 29 + help/ltol | 29 + help/makelist | 33 + help/mat | 102 + help/matdim | 27 + help/matfill | 40 + help/matmax | 29 + help/matmin | 29 + help/matsum | 28 + help/mattrans | 34 + help/max | 26 + help/meq | 33 + help/min | 26 + help/minv | 47 + help/mmin | 37 + help/mne | 29 + help/mod | 112 + help/modify | 41 + help/near | 31 + help/newerror | 39 + help/nextcand | 76 + help/nextprime | 36 + help/norm | 37 + help/null | 49 + help/num | 38 + help/obj.file | 176 ++ help/operator | 185 ++ help/ord | 26 + help/overview | 125 ++ help/param | 39 + help/perm | 38 + help/pfact | 27 + help/pi | 27 + help/pix | 38 + help/places | 31 + help/pmod | 50 + help/polar | 35 + help/poly | 137 ++ help/pop | 46 + help/power | 56 + help/prevcand | 85 + help/prevprime | 39 + help/printf | 127 ++ help/prompt | 39 + help/ptest | 129 ++ help/push | 55 + help/putenv | 48 + help/quo | 78 + help/quomod | 42 + help/rand | 220 ++ help/randbit | 43 + help/randperm | 44 + help/rcin | 73 + help/rcmul | 62 + help/rcout | 64 + help/rcpow | 73 + help/rcsq | 67 + help/re | 26 + help/remove | 50 + help/reverse | 50 + help/rewind | 33 + help/rm | 26 + help/root | 53 + help/round | 123 ++ help/rsearch | 38 + help/runtime | 31 + help/scale | 38 + help/scan | 34 + help/scanf | 31 + help/search | 37 + help/sec | 29 + help/sech | 31 + help/segment | 46 + help/select | 38 + help/sgn | 40 + help/sin | 36 + help/sinh | 31 + help/size | 50 + help/sizeof | 74 + help/sort | 250 +++ help/sqrt | 132 ++ help/srand | 151 ++ help/ssq | 36 + help/statement | 271 +++ help/str | 44 + help/strcat | 30 + help/strerror | 35 + help/strlen | 26 + help/strpos | 40 + help/strprintf | 37 + help/strscan | 36 + help/strscanf | 115 ++ help/substr | 38 + help/swap | 39 + help/system | 45 + help/tail | 50 + help/tan | 29 + help/tanh | 31 + help/time | 27 + help/todo | 252 +++ help/trunc | 36 + help/types | 102 + help/usage | 92 + help/variable | 82 + help/xor | 39 + hist.c | 1428 +++++++++++++ hist.h | 50 + input.c | 840 ++++++++ jump.c | 159 ++ jump.h | 96 + label.c | 186 ++ label.h | 37 + lib/Makefile | 116 ++ lib/README | 489 +++++ lib/altbind | 45 + lib/bernoulli.cal | 67 + lib/bigprime.cal | 32 + lib/bindings | 45 + lib/chrem.cal | 181 ++ lib/cryrand.cal | 1645 +++++++++++++++ lib/deg.cal | 124 ++ lib/ellip.cal | 172 ++ lib/lucas.cal | 1033 ++++++++++ lib/lucas_chk.cal | 381 ++++ lib/lucas_tbl.cal | 158 ++ lib/mersenne.cal | 44 + lib/mfactor.cal | 157 ++ lib/mod.cal | 211 ++ lib/pell.cal | 74 + lib/pi.cal | 54 + lib/pollard.cal | 35 + lib/poly.cal | 728 +++++++ lib/prompt.cal | 102 + lib/psqrt.cal | 56 + lib/quat.cal | 216 ++ lib/randbitrun.cal | 119 ++ lib/randmprime.cal | 137 ++ lib/randrun.cal | 128 ++ lib/regress.cal | 3679 +++++++++++++++++++++++++++++++++ lib/seedrandom.cal | 136 ++ lib/solve.cal | 48 + lib/sumsq.cal | 44 + lib/surd.cal | 288 +++ lib/test1700.cal | 12 + lib/test2300.cal | 97 + lib/test2600.cal | 516 +++++ lib/test2700.cal | 331 +++ lib/test3100.cal | 31 + lib/test3300.cal | 134 ++ lib/test3400.cal | 315 +++ lib/test3500.cal | 286 +++ lib/test4000.cal | 485 +++++ lib/test4100.cal | 493 +++++ lib/test4600.cal | 311 +++ lib/unitfrac.cal | 35 + lib/varargs.cal | 29 + lib_calc.c | 68 + lint.sed | 37 + listfunc.c | 829 ++++++++ longbits.c | 238 +++ longlong.c | 104 + matfunc.c | 1583 ++++++++++++++ math_error.c | 104 + obj.c | 689 +++++++ opcodes.c | 2786 +++++++++++++++++++++++++ opcodes.h | 128 ++ pix.c | 1559 ++++++++++++++ poly.c | 144 ++ prime.c | 925 +++++++++ prime.h | 75 + qfunc.c | 1474 +++++++++++++ qio.c | 676 ++++++ qmath.c | 1282 ++++++++++++ qmath.h | 234 +++ qmod.c | 498 +++++ qtrans.c | 1526 ++++++++++++++ quickhash.c | 474 +++++ shs.c | 1247 +++++++++++ shs.h | 88 + string.c | 289 +++ string.h | 31 + symbol.c | 513 +++++ symbol.h | 77 + token.c | 657 ++++++ token.h | 138 ++ value.c | 2006 ++++++++++++++++++ value.h | 455 ++++ version.c | 25 + zfunc.c | 1820 ++++++++++++++++ zio.c | 713 +++++++ zmath.c | 1742 ++++++++++++++++ zmath.h | 547 +++++ zmod.c | 2039 ++++++++++++++++++ zmul.c | 1097 ++++++++++ zprime.c | 1616 +++++++++++++++ zrand.c | 3558 ++++++++++++++++++++++++++++++++ zrand.h | 330 +++ 388 files changed, 85904 insertions(+) create mode 100644 BUGS create mode 100644 CHANGES create mode 100644 LIBRARY create mode 100644 Makefile create mode 100644 README create mode 100644 README.FIRST create mode 100644 addop.c create mode 100644 align32.c create mode 100644 alloc.h create mode 100644 assocfunc.c create mode 100644 byteswap.c create mode 100644 byteswap.h create mode 100644 calc.c create mode 100644 calc.h create mode 100644 calc.man create mode 100644 calcerr.tbl create mode 100644 calcerr_c.awk create mode 100644 calcerr_c.sed create mode 100644 calcerr_h.awk create mode 100644 calcerr_h.sed create mode 100644 check.awk create mode 100644 cmath.h create mode 100644 codegen.c create mode 100644 comfunc.c create mode 100644 commath.c create mode 100644 config.c create mode 100644 config.h create mode 100644 const.c create mode 100644 endian.c create mode 100644 file.c create mode 100644 file.h create mode 100644 fposval.c create mode 100644 func.c create mode 100644 func.h create mode 100644 hash.c create mode 100644 hash.h create mode 100644 have_const.c create mode 100644 have_fpos.c create mode 100644 have_newstr.c create mode 100644 have_stdvs.c create mode 100644 have_uid_t.c create mode 100644 have_varvs.c create mode 100644 help/Makefile create mode 100644 help/abs create mode 100644 help/access create mode 100644 help/acos create mode 100644 help/acosh create mode 100644 help/acot create mode 100644 help/acoth create mode 100644 help/acsc create mode 100644 help/acsch create mode 100644 help/append create mode 100644 help/appr create mode 100644 help/archive create mode 100644 help/arg create mode 100644 help/asec create mode 100644 help/asech create mode 100644 help/asin create mode 100644 help/asinh create mode 100644 help/assign create mode 100644 help/assoc create mode 100644 help/atan create mode 100644 help/atan2 create mode 100644 help/atanh create mode 100644 help/avg create mode 100644 help/base create mode 100644 help/bround create mode 100644 help/btrunc create mode 100644 help/builtin.end create mode 100644 help/builtin.top create mode 100644 help/ceil create mode 100644 help/cfappr create mode 100644 help/cfsim create mode 100644 help/char create mode 100644 help/cmdbuf create mode 100644 help/cmp create mode 100644 help/comb create mode 100644 help/command create mode 100644 help/config create mode 100644 help/conj create mode 100644 help/cos create mode 100644 help/cosh create mode 100644 help/cot create mode 100644 help/coth create mode 100644 help/count create mode 100644 help/cp create mode 100644 help/credit create mode 100644 help/csc create mode 100644 help/csch create mode 100644 help/ctime create mode 100644 help/define create mode 100644 help/delete create mode 100644 help/den create mode 100644 help/det create mode 100644 help/digit create mode 100644 help/digits create mode 100644 help/dp create mode 100644 help/environment create mode 100644 help/epsilon create mode 100644 help/errno create mode 100644 help/error create mode 100644 help/errorcodes.hdr create mode 100644 help/errorcodes.sed create mode 100644 help/eval create mode 100644 help/exp create mode 100644 help/expression create mode 100644 help/fact create mode 100644 help/factor create mode 100644 help/fclose create mode 100644 help/fcnt create mode 100644 help/feof create mode 100644 help/ferror create mode 100644 help/fflush create mode 100644 help/fgetc create mode 100644 help/fgetfield create mode 100644 help/fgetline create mode 100644 help/fgets create mode 100644 help/fgetstr create mode 100644 help/fib create mode 100644 help/file create mode 100644 help/files create mode 100644 help/floor create mode 100644 help/fopen create mode 100644 help/forall create mode 100644 help/fprintf create mode 100644 help/fputc create mode 100644 help/fputs create mode 100644 help/fputstr create mode 100644 help/frac create mode 100644 help/frem create mode 100644 help/freopen create mode 100644 help/fscan create mode 100644 help/fscanf create mode 100644 help/fseek create mode 100644 help/fsize create mode 100644 help/ftell create mode 100644 help/funclist.sed create mode 100644 help/gcd create mode 100644 help/gcdrem create mode 100644 help/getenv create mode 100644 help/hash create mode 100644 help/head create mode 100644 help/help create mode 100644 help/highbit create mode 100644 help/history create mode 100644 help/hmean create mode 100644 help/hypot create mode 100644 help/ilog create mode 100644 help/ilog10 create mode 100644 help/ilog2 create mode 100644 help/im create mode 100644 help/insert create mode 100644 help/int create mode 100644 help/interrupt create mode 100644 help/intro create mode 100644 help/inverse create mode 100644 help/iroot create mode 100644 help/isassoc create mode 100644 help/isatty create mode 100644 help/isconfig create mode 100644 help/iserror create mode 100644 help/iseven create mode 100644 help/isfile create mode 100644 help/ishash create mode 100644 help/isident create mode 100644 help/isint create mode 100644 help/islist create mode 100644 help/ismat create mode 100644 help/ismult create mode 100644 help/isnull create mode 100644 help/isnum create mode 100644 help/isobj create mode 100644 help/isodd create mode 100644 help/isprime create mode 100644 help/isqrt create mode 100644 help/isrand create mode 100644 help/israndom create mode 100644 help/isreal create mode 100644 help/isrel create mode 100644 help/isset create mode 100644 help/issimple create mode 100644 help/issq create mode 100644 help/isstr create mode 100644 help/istype create mode 100644 help/jacobi create mode 100644 help/join create mode 100644 help/lcm create mode 100644 help/lcmfact create mode 100644 help/lfactor create mode 100644 help/list create mode 100644 help/ln create mode 100644 help/lowbit create mode 100644 help/ltol create mode 100644 help/makelist create mode 100644 help/mat create mode 100644 help/matdim create mode 100644 help/matfill create mode 100644 help/matmax create mode 100644 help/matmin create mode 100644 help/matsum create mode 100644 help/mattrans create mode 100644 help/max create mode 100644 help/meq create mode 100644 help/min create mode 100644 help/minv create mode 100644 help/mmin create mode 100644 help/mne create mode 100644 help/mod create mode 100644 help/modify create mode 100644 help/near create mode 100644 help/newerror create mode 100644 help/nextcand create mode 100644 help/nextprime create mode 100644 help/norm create mode 100644 help/null create mode 100644 help/num create mode 100644 help/obj.file create mode 100644 help/operator create mode 100644 help/ord create mode 100644 help/overview create mode 100644 help/param create mode 100644 help/perm create mode 100644 help/pfact create mode 100644 help/pi create mode 100644 help/pix create mode 100644 help/places create mode 100644 help/pmod create mode 100644 help/polar create mode 100644 help/poly create mode 100644 help/pop create mode 100644 help/power create mode 100644 help/prevcand create mode 100644 help/prevprime create mode 100644 help/printf create mode 100644 help/prompt create mode 100644 help/ptest create mode 100644 help/push create mode 100644 help/putenv create mode 100644 help/quo create mode 100644 help/quomod create mode 100644 help/rand create mode 100644 help/randbit create mode 100644 help/randperm create mode 100644 help/rcin create mode 100644 help/rcmul create mode 100644 help/rcout create mode 100644 help/rcpow create mode 100644 help/rcsq create mode 100644 help/re create mode 100644 help/remove create mode 100644 help/reverse create mode 100644 help/rewind create mode 100644 help/rm create mode 100644 help/root create mode 100644 help/round create mode 100644 help/rsearch create mode 100644 help/runtime create mode 100644 help/scale create mode 100644 help/scan create mode 100644 help/scanf create mode 100644 help/search create mode 100644 help/sec create mode 100644 help/sech create mode 100644 help/segment create mode 100644 help/select create mode 100644 help/sgn create mode 100644 help/sin create mode 100644 help/sinh create mode 100644 help/size create mode 100644 help/sizeof create mode 100644 help/sort create mode 100644 help/sqrt create mode 100644 help/srand create mode 100644 help/ssq create mode 100644 help/statement create mode 100644 help/str create mode 100644 help/strcat create mode 100644 help/strerror create mode 100644 help/strlen create mode 100644 help/strpos create mode 100644 help/strprintf create mode 100644 help/strscan create mode 100644 help/strscanf create mode 100644 help/substr create mode 100644 help/swap create mode 100644 help/system create mode 100644 help/tail create mode 100644 help/tan create mode 100644 help/tanh create mode 100644 help/time create mode 100644 help/todo create mode 100644 help/trunc create mode 100644 help/types create mode 100644 help/usage create mode 100644 help/variable create mode 100644 help/xor create mode 100644 hist.c create mode 100644 hist.h create mode 100644 input.c create mode 100644 jump.c create mode 100644 jump.h create mode 100644 label.c create mode 100644 label.h create mode 100644 lib/Makefile create mode 100644 lib/README create mode 100644 lib/altbind create mode 100644 lib/bernoulli.cal create mode 100644 lib/bigprime.cal create mode 100644 lib/bindings create mode 100644 lib/chrem.cal create mode 100644 lib/cryrand.cal create mode 100644 lib/deg.cal create mode 100644 lib/ellip.cal create mode 100644 lib/lucas.cal create mode 100644 lib/lucas_chk.cal create mode 100644 lib/lucas_tbl.cal create mode 100644 lib/mersenne.cal create mode 100644 lib/mfactor.cal create mode 100644 lib/mod.cal create mode 100644 lib/pell.cal create mode 100644 lib/pi.cal create mode 100644 lib/pollard.cal create mode 100644 lib/poly.cal create mode 100644 lib/prompt.cal create mode 100644 lib/psqrt.cal create mode 100644 lib/quat.cal create mode 100644 lib/randbitrun.cal create mode 100644 lib/randmprime.cal create mode 100644 lib/randrun.cal create mode 100644 lib/regress.cal create mode 100644 lib/seedrandom.cal create mode 100644 lib/solve.cal create mode 100644 lib/sumsq.cal create mode 100644 lib/surd.cal create mode 100644 lib/test1700.cal create mode 100644 lib/test2300.cal create mode 100644 lib/test2600.cal create mode 100644 lib/test2700.cal create mode 100644 lib/test3100.cal create mode 100644 lib/test3300.cal create mode 100644 lib/test3400.cal create mode 100644 lib/test3500.cal create mode 100644 lib/test4000.cal create mode 100644 lib/test4100.cal create mode 100644 lib/test4600.cal create mode 100644 lib/unitfrac.cal create mode 100644 lib/varargs.cal create mode 100644 lib_calc.c create mode 100644 lint.sed create mode 100644 listfunc.c create mode 100644 longbits.c create mode 100644 longlong.c create mode 100644 matfunc.c create mode 100644 math_error.c create mode 100644 obj.c create mode 100644 opcodes.c create mode 100644 opcodes.h create mode 100644 pix.c create mode 100644 poly.c create mode 100644 prime.c create mode 100644 prime.h create mode 100644 qfunc.c create mode 100644 qio.c create mode 100644 qmath.c create mode 100644 qmath.h create mode 100644 qmod.c create mode 100644 qtrans.c create mode 100644 quickhash.c create mode 100644 shs.c create mode 100644 shs.h create mode 100644 string.c create mode 100644 string.h create mode 100644 symbol.c create mode 100644 symbol.h create mode 100644 token.c create mode 100644 token.h create mode 100644 value.c create mode 100644 value.h create mode 100644 version.c create mode 100644 zfunc.c create mode 100644 zio.c create mode 100644 zmath.c create mode 100644 zmath.h create mode 100644 zmod.c create mode 100644 zmul.c create mode 100644 zprime.c create mode 100644 zrand.c create mode 100644 zrand.h diff --git a/BUGS b/BUGS new file mode 100644 index 0000000..f4d08f9 --- /dev/null +++ b/BUGS @@ -0,0 +1,95 @@ +If you notice something wrong, strange or broken, try rereading: + + README.FIRST + README + BUGS (in particular the bottom problems or mis-features section) + +If that does not help, cd to the calc source directory and try: + + make check + +Look at the end of the output, it should say something like: + + 9999: passed all tests /\../\ + +If it does not, then something is really broken! + +If you made and modifications to calc beyond the simple Makefile +configuration, try backing them out and see if things get better. + +Check to see if the version of calc you are using is current. Calc +distributions may be obtained from the official calc repository: + + ftp://ftp.uu.net/pub/calc + +If you are an alpha or beta tester, you may have a special pre-released +version that is more advanced than what is in the ftp archive. + +=-= + +If you have tried all of the above and things still are not right, +then it may be time to send in a bug report. You can send bug reports to: + + calc-tester@postofc.corp.sgi.com + +When you send your report, please include the following information: + + * a description of the problem + + * the version of calc you are using (if you cannot get calc + it to run, then send us the 4 #define lines from version.c) + + * if you modified calc from an official patch, send me the mods you made + + * the type of system you were using + + * the type of compiler you were using + + * cd to the calc source directory, and type: + + make debug > debug.out 2>&1 (sh, ksh, bash users) + make debug >& debug.out (csh, tcsh users) + + and send the contents of the 'debug.out' file. + +Stack traces from core dumps are useful to send as well. + +=-= + +The official calc repository is located in: + + ftp://ftp.uu.net/pub/calc + +If you don't have ftp access to that site, or if your version is more +recent than what has been released to the ftp archive, you may, as a +last resort, send EMail to: + + chongo@toad.com + +Indicate the version you have and that you would like a more up to date version. + +=-= + +Send any comments, suggestions and most importantly, fixes (in the form +of a context diff patch) to: + + calc-tester@postofc.corp.sgi.com + +=-= + +Known problems or mis-features: + + * In calc2.10.2t3, when scan() reads characters from stdin, they + are not echoed. This also happens with fgets(files(0)) and + fgetline(files(0)). Reports indicate that this did not happen in + calc.2.10.1t20 but did in 2.10.2t0. + + * Many of LIBRARY, LIMITS and SEE ALSO sections of help files + for builtins are either inconsistent or missing information. + + * The functions filepos2z() and z2filepos() do not work (or + worse do not compile) when FILEPOS is 64 bits long. + + * There is some places in the source with obscure variable names + and not much in the way of comments. We need some major cleanup + and documentation. diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..868310f --- /dev/null +++ b/CHANGES @@ -0,0 +1,1618 @@ +Following is the change from calc version 2.10.2t25 to date: + + Eliminated use of VARARG and . Calc supports only + . The VARARGS Makefile variable has been eliminated. + + Source is converted to ANSI C. In particular, functions + will now have ANSI C style args. Any comments from old K&R + style args have been moved to function comment section. + + Removed prototype.h. The PROTO() macro is no longer needed + or supported. + + Added mfactor.cal to find the smallest factor of a Mersenne number. + + The built .h file: have_times.h, determines if the system has + , , and . + + Because shs.c depends on HASHFUNC, which in turn depends on + VALUE, shs.o has been moved out of libcalc.a. For the same + reasons, hash.h and shs.h are not being installed into + the ${LIBDIR} for now. + + A number of the regression tests that need random numbers now + use different seeds. + + Fixes for compiling under BSDI's BSD/OS 2.0. Added a Makefile + section for BSD/OS. + + Added a Makefile compile section for Dec Alpha without gcc ... + provides a hack-a-round for Dec Alpha cc bug. + + +Following is the change from calc version 2.10.2t4 to 2.10.2t25: + + Added makefile debugging rules: + + make chk like a 'make check' (run the regression tests) + except that only a few lines around interesting + (and presumable error messages) are printed. + No output if no errors are found. + + make env print important makefile values + + make mkdebug 'make env' + version information and a + make with verbose output and printing of + constructed files + + make debug 'make mkdebug' with a 'make clobber' + so that the entire make is verbose and + a constructed files are printed + + Improved instuctions in 'BUGS' section on reporting problems. + In particular we made it easy for people to send in a full + diagnostic output by sending 'debug.out' which is made as follows: + + make debug > debug.out + + Added -v to calc command line to print the version and exit. + + Fixed declarations of memcpy(), strcpy() and memset() in the + case of them HAVE_NEWSTR is false. + + Fixed some compile time warnings. + + Attempting to rewind a file this is not open generates an error. + + Noted conversion problems in file.c in tripple X comments. + + Some extremely braindead shells cannot correctly deal with if + cluases that do not have a non-empty else statement. Their + exit bogosity results in make problems. As a work-a-round, + Makefile if clauses have 'else true;' clauses for if statements + that previously did not have an else cluause. + + Fixed problems where the input stack depth reached the 10 levels. + + The show keyword is now a statement instead of a command: + + > define demo() {local f = open("foo", "w"); show files; fclose(f);} + > demo() + + Added a new trace option for display of links to real and complex + numbers. This is activated by config("trace", 4). The printing + of a real number is immediately followed by "#" and the number of + links to that number; complex numbers are printed in the same + except for having "##" instead of "#". + + The number of links for a number value is essentially the number of value + locations at which it is either stored or deemed to be stored. Here a + number value is the result of a reading or evaluation; when the result + is assigned to lvalues, "linking" rather than copying occurs. Different + sets of mutually linked values may contain the same number. For example: + + a = b = 2 + 3; x, y = 2 + 3; + + a and b are linked, and x and y are linked, but a and x are not linked. + + Revised the credits help file and man page. Added archive help + file to indicate where recent versions of calc are available. + + The regression test suite output has been changed so that it will + output the same information regardless of CPU performance. In + particular, cpu times of certain tests are not printed. This allows + one to compare the regression output of two different systems easier. + + A matrix or object declaration is now considered an expression + and returns a matrix or object of the specified type. Thus one may + use assignments like: + + A = mat[2]; /* same as: mat A[2]; */ + P = obj point; /* same as: obj point P; */ + + The obj and mat keywords may be with "local", "global", "static" as in: + + local mat A[2]; + + Several matrices or objects may be assigned or declared in the one + statement, as in: + + mat A, B[2], C[3]; /* same as: mat A[2], B[2], C[3] */ + + except that only one matrix creation occurs and is copied as in: + + A = B = mat[2]; + + Initialization of matrices and objects now occur before assignments: + + mat A, B [2] = {1,2}; /* same as: A = B = (mat[2] = {1,2}); */ + + Missing arguments are considered as "no change" rather than + "assign null values". As in recent versions of calc, the default + value assigned to matrix elements is zero and the default for object + elements is a null value). Thus: + + mat A[2] = {1,2}; + A = { , 3}; + + will change the value of A to {1,3}. + + If the relevant operation exists for matrices or has been defined for + the type of object A is, the assignment = may be combined with +, -, *, + etc. as in: + + A += {3, 4}; /* same as: A[0] += 3; A[1] += 4; */ + A += { }; /* same as: A += A; */ + + In (non-local) declarations, the earlier value of a variable may be + used in the initialization list: + + mat A[3]={1,2,3}; mat A[3]={A[2],A[1],A[0]}; /* same as: A={3,2,1} */ + + Also: + + mat A[3] = {1,2,3}; + mat A[3] = {A, A, A}; + + produces a 3-element matrix, each of whose elements is a 3-element matrix. + + The notation A[i][j] requires A[i] to be a matrix, whereas B[i,j] + accesses an element in a 2-dimensional matrix. Thus: + + B == A[i] implies A[i][j] = B[j] + + There is requirement in the use of A[i][j] that the matrices A[i] + for i = 0, 1, ... all be of the same size. Thus: + + mat A[3] = {(mat[2]), (mat[3]), (mat[2])}; + + produces a matrix with a 7-element structure: + + A[0][0], A[0][1], A[1][0], A[1][1], A[1][2], A[2][0], A[2][1] + + One can initialize matrices and objects whose elements are matrices + and/or objects: + + obj point {x,y} + obj point P; + obj point A = {P,P}; + + or: + + obj point {x,y}; + obj point P; + mat A[2] = {P,P}; + A = {{1,2}, {3,4}}; + + The config("trace", 8) causes opcodes of newly defined functions + are displayed. Also show can now show the opcides for a function. + For example: + + config("trace", 8); + define f(x) = x^2; + show opcodes f; + define g(x,y) {static mat A[2]; A += {x,y}; return A;} + show opcodes g + g(2,3); + show opcodes g; + g(3,4); + + The two sequences displayed for f should show the different ways + the parameter is displayed. The third sequence for g should also + show the effects of the static declaration of A. + + Fixed a number of compiler warning and type cast problems. + + Added a number of new error codes. + + Misc bug fixes for gcc2 based Sparc systems. + + Fixed a bug in the SVAL() macro on systems with 'long long' + type and on systems with 16 bit HALFs. + + Reduced the Makefile CC set: + + CCOPT are flags given to ${CC} for optimization + CCWARN are flags given to ${CC} for warning message control + CCMISC are misc flags given to ${CC} + + CFLAGS are all flags given to ${CC} + [[often includes CCOPT, CCWARN, CCMISC]] + ICFLAGS are given to ${CC} for intermediate progs + + CCMAIN are flags for ${CC} when files with main() instead of CFLAGS + CCSHS are flags given to ${CC} for compiling shs.c instead of CFLAGS + + LCFLAGS are CC-style flags for ${LINT} + LDFLAGS are flags given to ${CC} for linking .o files + ILDFLAGS are flags given to ${CC} for linking .o files + for intermediate progs + + CC is how the the C compiler is invoked + + Added more tests to regress.cal. + + Port to HP-UX. + + Moved config_print() from config.c to value.c so prevent printvalue() + and freevalue() from being unresolved symbols for libcalc.a users. + + Calc will generate "maximum depth reached" messages or errors when + reading or eval() is attempted at maximum input depth. + + Now each invocation of make is done via ${MAKE} and includes: + + MAKE_FILE=${MAKE_FILE} + TOPDIR=${TOPDIR} + LIBDIR=${LIBDIR} + HELPDIR=${HELPDIR} + + Setting MAKE_FILE= will cause make to not re-make if the Makefile + is edited. + + Added libinit.c which contains the function libcalc_call_me_first(). + Users of libcalc.a MUST CALL libcalc_call_me_first BEFORE THEY USE + ANY OTHER libcalc.a functions! + + Added support for the SGI IRIX6.2 (or later) Mongoose 7.0 (or later) + C Compiler for the r4k, r8k and r10k. Added LD_NO_SHARED for + non-shared linker support. + + Re-ordered and expanded options for the DEBUG make variable. + + Make a few minor cosmetic comment changes/fixes in the main Makefile. + + Statements such as: + + mat A[2][3]; + + now to the same as: + + mat M[3]; + mat A[2] = {M, M}; + + To initialize such an A one can use a statement like + + A = {{1,2,3}, {4,5,6}}; + + or combine initialization with creation by: + + mat A[2][3] = {{1,2,3}, {4,5,6}}; + + One would then have, for example, A[1][0] = 4. Also, the inner braces + cannot be removed from the initialization for A: + + mat A[2][3] = {1,2}; + + results in exactly the same as: + + mat A[2] = {1,2}; + + Added rm("file") builtin to remove a file. + + The regress test sections that create files also use rm() to remove + them before and afterwards. + + Added 4400-4500 set to test new mat and obj initializaion rules. + + Added 4600 to test version file operations. + + Added CCZPRIME Makefile variable to the set for the short term + to work around a CC -O2 bug on some SGI machines. + + Added regression test of _ variables and function names. + + Added read of read and write, including read and write test for + long strings. + + Fixed bug associated with read of a long string variable. + + Renumbered some of the early regress.cal test numbers to make room + for more tests. Fixed all out of sequence test numbers. Fixed some + malformatted regression reports. + + +Following is the change from calc version 2.10.2t0 to 2.10.2t4: + + Fixed bug in the regression suite that made test3400 and test4100 + fail on correct computations. + + The randbit() builtin, when given to argument, returns 1 random bit. + + Fixed a bug in longlong.c which made is generate a syntax error + on systems such as the PowerPC where the make variable LONGLONG + was left empty. + + By default, the Makefile leaves LONGLONG_BITS empty to allow for + testing of 64 bit data types. A few hosts may have problems with + this, but hopefully not. Such hosts can revert back to LONGLONG_BITS=0. + + Improved SGI support. Understands SGI IRIX6.2 performance issues + for multiple architectures. + + Fixed a number of implicit conversion from unsigned long to long to avoid + unexpected rounding, sign extension, or loss of accuracy side effects. + + Added SHSCC because shs.c contains a large expression that some + systems need help in optimizing. + + Added "show files" to display information about all currently open files. + + Calc now prevents user-defined function having the same name as a + builtin function. + + A number of new error codes (more than 100) have been added. + + Added ctime() builtin for date and time as string value. + Added time() builtin for seconds since 00:00:00 1 Jan 1970 UTC. + Added strerror() builtin for string describing error type. + Added freopen() builtin to reopen a file. + Added frewind() builtin to rewind a file. + Added fputstr() builtin to write a null-terminated string to a file. + Added fgetstr() builtin to read a null-terminated string from a file. + Added fgetfield() builtin to read next field from file. + Added strscan() builtin to scan a string. + Added scan() builtin to scan of a file. + Added fscan() builtin to scan of a file. + Added fscanf() builtin to do a formatted scan of a file. + Added scanf() builtin to do a formatted scan of stdin. + Added strscanf() builtin to do a formatted scan of a string. + Added ungetc() builtin to unget character read from a file. + + As before, files opened with fopen() will have an id different from + earlier files. But instead of returning the id to the FILEIO slot + used to store information about it, calc simply uses consecutive + numbers starting with 3. A calc file retains its id, even when the + file has been closed. + + The builtin files(i) now returns the file opened with id == i + rather than the file with slot number i. For any i <= lastid, + files(i) has at some time been opened. Whether open or closed, it + may be "reopened" with the freopen() command. This write to a file + and then read it, use: + + f = fopen("junk", "w") + freopen(f, "r") + + To use the same stream f for a new file, one may use: + + freopen(f, mode, newfilename) + + which closes f (assuming it is open) and then opens newfilename on f. + + And as before: + + f = fopen("curds", "r") + g = fopen("curds", "r") + + results in two file ids (f and g) that refer to the same file + name but with different pointers. + + Calc now understands "w+", "a+" and "r+" file modes. + + If calc opens a file without a mode there is a "guess" that mode + "r+" will work for any files with small descriptors found to be + open. In case it doesn't (as apparently happens if the file had + not been opened for both reading and reading) the function now also + tries "w" and "r", and if none work, gives up. This avoids having + "open" files with null fp. + + The buildin rewind() calls the C rewind() function, but one may + now rewind several files at once by a call like rewind(f1, f2). + With no argument, rewind() rewinds all open files with id >= 3. + + The functions fputstr(), fgetstr() have been defined to include the + terminating '\0' when writing a string to a file. This can be done + at present with a sequence of instructions like: + + fputs(f, "Landon"); fputc(f, 0); + fputs(f, "Curt"); fputc(f, 0); + fputs(f, "Noll"); fputc(f, 0); + + One may now do: + + fputstr(f, "Landon", "Curt", "Noll"); + + and read them back by: + + rewind(f); + x = fgetstr(f); /* returns "Landon" */ + y = fgetstr(f); /* returns "Curt" */ + z = fgetstr(f); /* returns "Noll" */ + + The buildin fgetfield() returns the next field of non-whitepsace + characters. + + The builtins scan(), fscan(), strscan() read tokens (fields of + non-whitepsace characters) and evaluates them. Thus: + + global a,b,c; + strscan("2+3 4^2\n c=a+b", a, b, 0); + + results in a = 5, b = 16, c = 21 + + The functions scanf, fscanf, strscanf behave like the C functions + scanf, fscanf, sscanf. The conversion specifiers recognized are "%c", + "%s", "%[...]" as in C, with the options of *, width-specification, + and complementation (as in [^abc]), and "%n" for file-position, and + "%f", "%r", "%e", "%i" for numbers or simple number-expressions - any + width-specification is ignored; the expressions are not to include any + white space or characters other than decimal digits, +, -, *, /, e, and i. + E.g. expressions like 2e4i+7/8 are acceptable. + + The builtin size(x) now returns the size of x if x is an open file + or -1 if x is a file but not open. If s is a string, size(s) returns + characters in s. + + Added buildin access("foo", "w") returns the null value if a file + "foo" exists and is writeable. + + Some systems has a libc symbolc qadd() that conflicted with calc's + qadd function. To avoid this, qadd() has been renamed to qqadd(). + + The calc error codes are produced from the the calcerr.tbl file. + Instead of changing #defines in value.h, one can not edit calcerr.tbl. + The Makefile builds calcerr.h from this file. + + Calc error codes are now as follows: + + <0 invalid + 0 .. sys_nerr-1 system error ala C's errno values + sys_nerr .. E__BASE-1 reserved for future system errors + E__BASE .. E__HIGHEST calc internal errors + E__HIGHEST+1 .. E_USERDEF-1 invalid + E_USERDEF .. user defined errors + + Currently, E__BASE == 10000 and E_USERDEF == 20000. Of course, + sys_nerr is system defined however is likely to be < E__BASE. + + Renamed CONST_TYPE (as defined in have_const.h) to just CONST. + This symbol will either be 'const' or an empty string depending + on if your compiler understands const. + + CONST is beginning to be used with read-only tables and some + function arguments. This allows certain compilers to better + optimize the code as well as alerts one to when some value + is being changed inappropriately. Use of CONST as in: + + int foo(CONST int curds, char *CONST whey) + + while legal C is not as useful because the caller is protected + by the fact that args are passed by value. However, the + in the following: + + int bar(CONST char *fizbin, CONST HALF *data) + + is useful because it calls the compiler that the string pointed + at by 'fizbin' and the HALF array pointer at by 'data' should be + treated as read-only. + + +Following is the change from calc version 2.10.1t21 to 2.10.2t0: + + Bumped patch level 2.10.2t0 in honor of having help files for + all builtin functions. Beta release will happen at the end of + the 2.10.2 cycle!!! + + Fewer items listed in BUGS due to a number of bug fixes. + + Less todo in the help/todo file because more has already been done. :-) + + All builtin functions have help files! While a number need cleanup + and some of the LIMITS, LIBRARY and SEE ALSO sections need fixing + (or are missing), most of it is there. A Big round of thanks goes + to for his efforts in initial write-ups + for many of these files! + + The recognition of '\' as an escape character in the format argument + of printf() has been dropped. Thus: + + printf("\\n"); + + will print the two-character string "\n" rather than the a + one-character carriage return. + + Missing args to printf-like functions will be treated as null values. + + The scope of of config("fullzero") has been extended to integers, + so that for example, after config("mode","real"), config("display", 5), + config("fullzero", 1), both: + + print 0, 1, 2; + printf("%d %d %d\n", 0, 1, 2); + + print: + + .00000 1.00000, 2.00000 + + The bug which caused calc to exit on: + + b = "print 27+" + eval(b) + + has been fixed. + + Fixed bugs in zio.c which caused eval(str(x)) == x to fail + in non-real modes such as "oct". + + The following: + + for (i = 1; i < 10; i++) print i^2,; + + now prints the same as: + + for (i = 1; i < 10; i++) print i^2,; + + The show globals will print '...' in the middle of large values. + + + The param(n) builtin, then n > 0, returns the address rather than + the value of the n-th argument to save time and memory usage. This + is useful when a matrix with big number entries is passed as an arg. + + + The param(n) builtin, then n > 0, may be used as an lvalue: + + > define g() = (param(2) = param(1)); + > define h() = (param(1)++, param(2)--); + > u = 5 + > v = 10 + > print g(u, &v), u, v; + 5 5 5 + > print h(&u, &v), u, v; + 5 6 4 + + Missing args now evaluate to null as in: + + A = list(1,,3) + B = list(,,) + mat C[] = {,,} + mat D[] = { } + + +Following is the change from calc version 2.10.1t20 to 2.10.1t21: + + Changes made in preparation for Blum Blum Shub random number generator. + + REDC bug fixes: + + Fixed yet another bug in zdiv which occasionally caused the "top digit" + of a nonzero quotient to be zero. + + Fixed a bug in zredcmul() where a rarely required "topdigit" is + sometimes lost rather than added to the appropriate carry. + + A new function zredcmodinv(ZVALUE z, ZVALUE *res) has been defined for + evaluating rp->inv in zredcalloc(). + + New functions zmod5(ZVALUE *zp) and zmod6(ZVALUE z, ZVALUE *res) have + been defined to give O(N^1.585)-runtime evaluation of z % m for + large N-word m. These require m and BASE^(2*N) // m to have been + stored at named locations lastmod, lastmodinv. zmod5() is essentially + for internal use by zmod6() and zpowermod(). + + Changes to rcmul(x,y,m) so that the result is always in [0, m-1]. + + + Changes to some of the detail of zredcmul() so that it should run slightly + faster. Also changes to zredcsq() in the hope that it might achieve + something like the improvement in speed of x^2 compared with x * x. + + + A new "bignum" algorithm for evaluating pmod(x,k,m) when + N >= config("pow2"). For the multiplications and squarings + modulo m, or their equivalent, when N >= config("redc2"), + calc has used evaluations correponding to rcout(x * y, m), + for which the runtime is essentially that of three multiplications. + + + Yet more additions to the regress.cal test suite. + + Fixed some ANSI-C compile nits in shs.c and quickhash.c. + + Plugs some potential memory leaks in definitions in func.c. + Expressions such as qlink(vals[2]) in some circumstances are + neither qfreed nor returned as function values. + + + The nextcand() and prevcand() functions handle modval, modulus + and skip by using ZVALUE rather than ZVALUE * and dropping + the long modulus, etc. + + Changed a couple of occurrences of itoq(1) or itoq(0) to &_qone_ + and &_qzero_. + + In definition of f_primetest, changed ztolong(q2->num) to ztoi(q2->num) + so that the sign of count in ptest(n, count, skip) is not lost; and + ztolong(q3->num) to q3->num so that skip can be any integer. + + + In zprime.c, in definition of small_factor(), adds "&& *tp != 1" to + the exit condition in the for loop so that searching for a factor + will continue beyond the table of primes, as required for e.g. + factor(2^59 - 1). + + Changed zprimetest() so that skip in ptest(n, count, skip) + determines the way bases for the tests are selected. Neg values of + n are treated differently. When considering factorization, + primeness, etc. one is concerned with equivalence classes which for + the rational integers are {0}, {-1, 1}, {-2, 2}, etc. To refer to + an equivalence class users may use any of its elements but when + returning a value for a factor the computer normally gives the + non-negative member. The same sort of thing happens with integers + modulo an integer, with fractions, etc., etc. E.g. users may refer + to 3/4 as 6/8 or 9/12, etc. A simple summary of the way negative n + is treated is "the sign is ignored". E.g. isprime(-97) and + nextprime(-97) now return the same as isprime(97) and nextprime(97). + + + +Following is the change from calc version 2.10.1t11 to 2.10.1t20: + + Added many more regression tests to lib/regress.cal. Some + due to . + + Added many help files, most due to . + + Fixed exp() and ln() so that when they return a complex value with a + zero imaginary component, isreal() is true. + + Fixed cast problem in byteswap.c. + + Fixed memory leak problem where repeated assignments did not + free the previous value. + + Complex number ordering/comparison has been changed such that: + + a < b implies a + c < b + c + a < b and c > 0 implies a * c < b * c + a < b implies -a > -b + + To achieve a "natural" partial ordering of the complex numbers + with the above properties, cmp(a,b) for real or complex numbers + may be considered as follows: + + cmp(a,b) = sgn(re(a) - re(b)) + sgn(im(a) - im(b)) * 1i + + The cmp help file has been uptdated. + + Change HASH type to QCKHASH. The HASH type is a name better suited + for the upcoming one-way hash interface. + + Added the CONFIG type; a structure containing all of the configuration + values under the control of config(). Added V_CONFIG data type. + The call config("all") returns a V_CONFIG. One may now save/restore + the configuration state as follows: + + x = config("all") + ... + config("all",x) + + Added two configuration aliases, "oldstd" (for old backward compatible + standard configuration) and "newstd" (for new style configuration). + One may set the historic configuration state by: + + config("all", "oldstd") + + One may use what some people consider to be a better but not backward + compatible configuration state by: + + config("all", "newstd") + + Renamed config.h (configuration file built during the make) to conf.h. + Added a new config.h to contain info on thw V_CONFIG type. + + Fixed some ANSI C compile warnings. + + The show config output is not indented by only one tab, unless + config("tab",0) in which case it is not indented. + + The order of show config has been changed to reflect the config + type values. + + Changed declaration of sys_errlst in func.c to be char *. + + Added quo(x,y,rnd) and mod(x,y,rnd) to give function interfaces + to // and % with rounding mode arguments. Extended these functions + to work for list-values, complex numbers and matrices. + + + For integer x, cfsim(x,8) returns 0. + + Fixed config("leadzero"). + + Set config("cfsim",8) by default (in "oldstd"). Setup initial idea for + config("all", "newstd") to be the default with the following changes: + + display 10 + epsilon 1e-10 + quo 0 + outround 24 + leadzero 1 + fullzero 1 + prompt "; " (allows full line cut/paste) + more ";; " (allows full line cut/paste) + + The "newstd" is a (hopefully) more perferred configuration than the + historic default. + + The fposval.h file defines DEV_BITS and INODE_BITS giving the + bit size of the st_dev and st_ino stat elements. Also added + SWAP_HALF_IN_DEV and SWAP_HALF_IN_STSIZE. + + Added sec(), csc(), cot(), sech(), csch(), coth(), asec(), acsc(), + acot(), asech(), acsch() and acoth() builtins. + + The initmasks() call is no longer needed. The bitmask[] array + is a compiled into zmath.c directly. + + Added isconfig(), ishash(), isrand() and israndom() builtins to + test is something is a configuration state, hash state, RAND + state or RANDOM state. + + The lib/cryrand.cal library now no longer keeps the Blum prime + factors used to formt he Blum modulus. The default modulus has + been expanded to 1062 bits product of two Blum primes. + + Added shs hash code, though it is not currently used. - XXX + The function hash_init() is called to initialize the hash function + interface. + + Misc calc man page fixes and new command line updates. + + Fixed bug related to srand(1). + + Cleaned up some warning messages. + + All calls to math_error() now have a /*NOTREACHED*/ comment after + them. This allows lint and compiler flow progs to note the jumpjmp + nature of math_error(). Unfortunately some due to some systems + not dealing with /*NOTREACHED*/ comments correctly, calls of the form: + + if (foo) + math_error("bar"); + + must be turned into: + + if (foo) { + math_error("bar"); + /*NOTREACHED*/ + } + + The ploy() function can take a list of coefficients. See + the help/poly file. Added poly.c. + + Fixes and performance improvemtns to det(). + + Renamed atoq() and atoz() to str2q() and str2z() to avoid conflicts + with libc function names. + + Fixed use of ${NROFF_ARG} when ${CATDIR} and ${NROFF} are set. + + Fixed SWAP_HALF_IN_B64 macro use for Big Endian machines without + long long or with LONGLONG_BITS=0. + + Added error() and iserror() to generate a value of a given error type. + See help/error for details. + + Added singular forms of help files. For example one can now get + help for binding, bug, change, errorcode and type. + + The builtin mmin(x, md) has been changed to return the same as + mod(x, md, 16). The old mmin(x, md) required md to be a positive + integer and x to be an integer. Now md can be any real number; x + can be real, complex, or a matrix or list with real elements, etc. + + + The builtin avg(x_1, x_2, ...) has been changed to accept list-valued + arguments: a list x_i contributes its elements to the list of items to + be averaged. E.g. avg(list(1,2,list(3,4)),5) is treated as if it were + avg(1,2,3,4,5). If an error value is encountered in the items to be + averaged, the first such value is returned. If the number of items to be + averaged is zero, the null value is returned. + + The builtin hmean(x_1, x_2, ...) has been changed to admit types + other than real for x_1, x_2, ...; list arguments are treated in + the same way as in avg(). + + The builtin eval(str) has been changed so that when str has a + syntax error, instead of call to math_error(), an error value is + returned. + + The old frem(x,y) builtin returned the wrong value when y was a power of + 2 greater than 2, e.g. f(8,4) is returned as 4 when its value should be 2. + This has been fixed by a small change to the definition of zfacrem(). + Calc used to accept with no warning or error message, gcdrem(0,2) or + generally gcdrem(0,y) for any y with abs(y) > 1, but then went into an + infinite loop. This has been fixed by never calling zfacrem() with zero x. + Both frem(x,y) and gcdrem(x,y) now reject y = -1, 0 or 1 as errors. For + nonzero x, and y == -1 or 1, defining frem(x,y) and gcdrem(x,y) to equal + abs(x) is almost as natural as defining x^0 to be 1. Similarly, if x is + not zero then gcdrem(x,0) == 1. + + + Plugged some more memory leaks. + + Fixed bug related randbit(x) skip (where x < 0). + + Added seedrandom.cal to help users use the raw random() interface well. + + Made extensive additions and changes to the rand() and random() generator + comments in zrand.c. + + Fixed a bug in fposval.c that prevented calc from compiling on systems + with 16 bit device and/or inodes. Fixed error messages in fposval.c. + + Fixed bug that would put calc into an infinite loop if it is ran + with errors in startup files (calc/startup, .calcrc). + Ha Lam + + +Following is the change from calc version 2.10.0t13 to 2.10.1t11: + + Added SB8, USB8, SB16, USB16, SB32, USB32 typedefs, determined by + longbits and declared in longbits.h, to deal with 8, 16 and 32 bit + signed and unsigned values. + + The longbits.h will define HAVE_B64 with a 64 bit type (long or + longlong) is available. If one is, then SB64 abd US64 typedefs + are declared. + + The U(x) and L(x) macros only used to define 33 to 64 bit signed + and unsigned constants. Without HAVE_B64, these macros cannot + be used. + + Changed the way zmath.h declares types such as HALF and FULL. + + Changed the PRINT typedef. + + The only place where the long long type might be used is in longlong.c + and if HAVE_LONGLONG, in longbits.h if it is needed. The only place + were a long long constant might be used is in longlong.c. Any + long long constants, if HAVE_LONGLONG, are hidden under the U(x) and + L(x) macros on longbits.h. And of course, if you don't have long long, + then HAVE_LONGLONG will NOT be defined and long long's will not be used. + + The longlong.h file is no longer directly used by the main calc source. + It only comes into play when compiling the longbits tool. + + Added config("prompt") to change the default interactive prompt ("> ") + and config("more") to change the default continuation prompt (">> "). + + Makefile builds align32.h with determines if 32 bit values must always + be aligned on 32 bit boundaries. + + The CALCBINDINGS file is searched for along the CALCPATH. The Makefile + defines the default CALCBINDINGS is "bindings" (or "altbind") which + is now usualy found in ./lib or ${LIBDIR}. + + Per Ernest Bowen , an optional third argument + was added sqrt() so that in sqrt(x,y,z), y and z have essentially the + same role as in appr(x,y,z) except that of course what is being + approximated is the sqrt of x. Another difference is that two more + bits of z are used in sqrt: bit 5 gives the option of exact results + when they exist (the value of y is then ignored) and bit 6 returns + the nonprincipal root rather than the principal value. + + If commands are given on the command line, leading tabs are not + printed in output. Giving a command on the command line implies + that config("tab",0) was given. + + Pipe processing is enabled by use of -p. For example: + + echo "print 2^21701-1, 2^23209-1" | calc -p | fizzbin + + In pipe mode, calc does not prompt, does not print leading tabs + and does not print the initial version header. + + Calc will now form FILE objects for any open file descriptor > 2 + and < MAXFILES. Calc assumes they are available for reading + and writing. For example: + + $ echo "A line of text in the file on descriptor 5" > datafile + $ calc 5 files(5) + FILE 5 "descriptor[5]" (unknown_mode, pos 0) + > fgetline(files(5)) + "A line of text in the file on descriptor 5" + + The -m mode flag now controls calc's ability to open files + and execute programs. This mode flag is a single digit that + is processed in a similar way as the octal chmod values: + + 0 do not open any file, do not execute progs + 1 do not open any file + 2 do not open files for reading, do not execute progs + 3 do not open files for reading + 4 do not open files for writing, do not execute progs + 5 do not open files for writing + 6 do not execute any program + 7 allow everything (default mode) + + Thus if one wished to run calc from a privledged user, one might + want to use -m 0 in an effort to make calc more secure. + + The -m flags for reading and writing apply on open. + Files already open are not effected. Thus if one wanted to use + the -m 0 in an effort to make calc more secure, but still be + able to read and write a specific file, one might do: + + calc -m 0 3b.file + + NOTE: Files presented to calc in this way are opened in an unknown + mode. Calc will try to read or write them if directed. + + The maximum command line size it MAXCMD (16384) bytes. Calc objects to + command lines that are longer. + + The -u flag cause calc to unbuffer stdin and stdout. + + Added more help files. Improved other help files. + + Removed trailing blanks from files. + + Removed or rewrite the formally gross and disgusting hacks for + dealing with various sizes and byte sex FILEPOS and off_t types. + + Defined ilog2(x), ilog10(x), ilog(x,y) so that sign of x is ignored, + e.g. ilog2(x) = ilog2(abs(x)). + + The sixth bit of rnd in config("round", rnd) and config("bround", rnd) + is used to specify rounding to the given number of significant + digits or bits rather than places, e.g. round(.00238, 2, 32) + returns .0023, round(.00238, 2, 56) returns .0024. + +Following is the change from calc version 2.9.3t11 to 2.10.0t13: + + The default ${LIBDIR}/bindings CALCBINDINGS uses ^D for editing. + The alternate CALCBINDINGS ${LIBDIR}/altbind uses ^D for EOF. + + The Makefile CC flag system has been changed. The new CC flag system + includes: + + CCMAIN are flags for ${CC} when compiling only files with main() + CCOPT are flags given to ${CC} for optimization + CCWARN are flags given to ${CC} for warning message control + CCMISC are misc flags given to ${CC} + + CNOWARN are all flags given to ${CC} except ${CCWARN} flags + CFLAGS are all flags given to ${CC} + ICFLAGS are given to ${CC} for intermediate progs + + LCFLAGS are CC-style flags for ${LINT} + LDFLAGS are flags given to ${CC} for linking .o files + ILDFLAGS are given to ${CC} for linking .o's for intermediate progs + + CC is how the the C compiler is invoked + + The syntax error: + + print a[3][[4]] + + used to send calc into a loop printing 'missing expression'. This + has been fixed. + + Added config("maxerr") and config("maxerr",val) to control the + maximum number of errors before a computation is aborted. + + Removed regress.cal test #952 and #953 in case calc's stdout or + stderr is re-directed to a non-file by some test suite. + + Changed how , or simulate stdarg is determined. + Changed how vsprintf() vs sprintf() is determined. The args.h file + is created by Makefile to test which combination works. Setting + VARARG and/or HAVE_VSPRINTF in the Makefile will alter these tests + and direct a specific combination to be used. Removed have_vs.c, + std_arg.h and try_stdarg.c. Added have_stdvs.c and have_varvs.c. + + Added 3rd optional arg to round(), bround(), appr() to specify the type of + rounding to be used. + + Moved fnvhash.c to quickhash.c. + + Fixed a bug in appr rounding mode when >= 16. + + Added test2600.cal and test2700.cal. They are used by the regress.cal + to provide a more extensive test suite for some builtin numeric + functions. + +Following is the change from calc version 2.9.3t9.2+ to 2.9.3t11: + + Added many help files for builtin functions and some symbols. + More help files are needed, see help/todo. + + Removed the calc malloc code. Calc now uses malloc and free to + manage storage since these implementations are often written to + work best for the local system. Removed CALC_MALLOC code and + Makefile symbol. Removed alloc.c. + + Added getenv("name"), putenv("name=val") and putenv("name, "val") + builts for environment variable support thanks to "Dr." "D.J." Picton + . + + Added system("shell command") builtin to execute shell commands, + thanks to "Dr." "D.J." Picton . + + Added isatty(fd) builtin to determine if fd is attached to a tty + thanks to "Dr." "D.J." Picton . + + Added cmdbuf() builtin to return the command line executed by calc's + command line args thanks to "Dr." "D.J." Picton . + + Added strpos(str1,str2) builtin to determine the first position where + str2 is found in str1 thanks to "Dr." "D.J." Picton + . + + Fixed bug that caused: + + global a,b,c (newline with no semicolon) + read test.cal + + the read command to not be recognized. + + The show command looks at only the first 4 chars of the argument so + that: + + show globals + show global + show glob + + do the same thing. + + Added show config to print the config values and parameters thanks + to Ernest Bowen . + + Added show objtypes to print the defined objects thanks to Ernest Bowen + . + + Added more builtin function help files. + + Fixed the 3rd arg usage of the root builtin. + + Expanded the regress.cal regression test suite. + + Fixed -- and ++ with respect to objects and asignment (see the 2300 + series in regress.cal). + + Added isident(m) to determine if m is an identity matrix. + + The append(), insert() and push() builtins can now append between + 1 to 100 values to a list. + + Added reverse() and join() builtins to reverse and join lists + thanks to Ernest Bowen . + + Added sort() builtin to sort lists thanks to Ernest Bowen + . + + Added head(), segment() and tail() builtins to return the head, middle or + tail of lists thanks to Ernest Bowen . + + Added more and fixed some help files. + + The builtin help file is generated by the help makefile. Thus it will + reflect the actual calc builtin list instead of the last time someone + tried to update it correctly. :-) + + Fixed non-standard void pointer usage. + + Fixed base() bug with regards to the default base. + + Renamed MATH_PROTO() and HIST_PROTO() to PROTO(). Moved PROTO() + into prototype.h. + + Fixed many function prototypes. Calc does not declare functions + as static in one place and extern in another. Where reasonable + function prototypes were added. Several arg mismatch problems + were fixed. + + Added support for SGI MIPSpro C compiler. + + Changes the order that args are declared to match the order + of the function. Some source tools got confused when: + arg order did not match as in: + + void + funct(foo,bar) + int bar; /* this caused a problem */ + char *foo; /* even though it should not! */ + { + } + +Following is the change from calc version 2.9.3t8 to 2.9.3t9.2+: + + Use of the macro zisleone(z) has been clarified. The zisleone(z) macro + tests if z <= 1. The macro zisabsleone(z) tests of z is 1, 0 or -1. + Added zislezero(z) macro. Bugs are related to this confusion have + been fixed. + + Added zge64b(z) macro to zmath.h. + + Added the macro zgtmaxufull(z) to determine if z will fit into a FULL. + Added the macro zgtmaxlong(z) to determine if z will fit into a long. + Added the macro zgtmaxulong(z) to determine if z will fit into a unsigned + long. + + Added the macro ztoulong(z) to convert an absolute value of a ZVALUE to + an unsigned long, or to convert the low order bits of a ZVALUE. + Added the macro ztolong(z) to convert an absolute value of a ZVALUE to + an long, or to convert the low order bits of a ZVALUE. + + Some non-ANSI C compilers define __STDC__ to be 0, whereas all ANSI + C compiles define it as non-zero. Code that depends on ANSI C now + uses #if defined(__STDC__) && __STDC__ != 0. + + Fixed ptest(a,b) bug where (a mod 2^32) < b. Previously ptest() + incorrectly returned 1 in certain cases. + + The second ptest() argument, which is now optional, defaults to 1. + This ptest(x) is the same as ptest(x,1). + + Added an optional 3rd argument to ptest(). The 3rd arg tells how many + tests to skip. Thus ptest(a,10) performs the same probabilistic + tests as ptest(a,3) and ptest(a,7,3). + + The ptest() builtin by default will determine if a value is divisible + by a trivial prime. Thus, ptest(a,0) will only perform a quick trivial + factor check. If the test count is < 0, then this trivial factor check + is omitted. Thus ptest(a,10) performs the same amount of work as + ptest(a,3) and ptest(a,-7,3) and the same amount of work as + ptest(a,-3) and ptest(a,7,3). + + Added nextcand(a[,b[,c]]) and prevcand(a[,b[,c]]) to search for the + next/previous value v > a (or v < a) that passes ptest(v[,b[,c]]). + The nextcand() and prevcand() builtins take the same arguments + as ptest(). + + Added nextprime(x) and and prevprime(x) return the next and + previous primes with respect to x respectively. As of this + release, x must be < 2^32. With one argument, they will return + an error if x is out of range. With two arguments, they will + not generate an error but instead will return y. + + Fixed some memory leaks, particularly those related with pmod(). + + Fixed some of the array bounds reference problems in domult(). + + Added a hack-a-round fix for the uninitialized memory reference + problems in zsquare/dosquare. + + The LIBRARY file has been updated to include a note about calling + zio_init() first. Also some additional useful macros have been noted. + + The lfactor() function returns -1 when given a negative value. + It will not search for factors beyond 2^32 or 203280221 primes. + Performance of lfactor() has been improved. + + Added factor(x,y) to look for the smallest factor < min(sqrt(x),y). + + Added libcalcerr.a for a math_error() routine for the convince of + progs that make use of libcalc.a. This routine by default will + print an message on stderr and exit. It can also be made to + longjump instead. See the file LIBRARY under ERROR HANDING. + + Added isprime() to test if a value is prime. As of this release, + isprime() is limited to values < 2^32. With one argument, + isprime(x) will return an error if x is out of range. With + two arguments, isprime(x,y) will not generate an error but + instead will return y. + + Added pix(x) to return the number of primes <= x. As of this + release, x must be < 2^32. With one argument, pix(x) will + return an error if x is out of range. With two arguments, + pix(x,y) will not generate an error but instead will return y. + + Fixed the way *.h files are formed. Each file guards against + multiple inclusion. + + Fixed numeric I/O on 64 bit systems. Previously the print and + constant conversion routines assumed a base of 2^16. + + Added support for 'long long' type. If the Makefile is setup + with 'LONGLONG_BITS=', then it will attempt to detect support + for the 'long long' type. If the Makefile is setup with + 'LONGLONG_BITS=64', then a 64 bit 'long long' is assumed. + Currently, only 64 bit 'long long' type is supported. + Use of 'long long' allows one to double the size of the + internal base, making a number of computations much faster. + If the Makefile is setup with 'LONGLONG_BITS=0', then the + 'long long' type will not be used, even if the compiler + supports it. + + Fixed avg() so that it will correctly handle matrix arguments. + + Fixed btrunc() limit. + + The ord("string") function can now take a string of multiple + characters. However it still will only operate on the first + character. + + Renamed stdarg.h to std_arg.h and endian.h endian_calc.h to + avoid name conflicts with /usr/include on some systems that + have make utilities that are too smart for their own good. + + Added additive 55 shuffle generator functions rand(), randbits() + and its seed function srand(). Calling rand(a,b) produces a + random value over the open half interval [a,b). With one arg, + rand(a) is equivalent to rand(0,a). Calling rand() produces + 64 random bits and is equivalent to rand(0,2^64). + + Calling randbit(x>0) produces x random bits. Calling randbit(skip<0) + skips -skip bits and returns -skip. + + The srand() function will return the current state. The call + srand(0) returns the initial state. Calling srand(x), where + x > 0 will seed the generator to a different state. Calling + srand(mat55) (mat55 is a matrix of integers at least 55 elements long) + will seed the internal table with the matrix elements mod 2^64. + Finally calling srand(state) where state is a generator state + also sets/seeds the generator. + + The cryrand.cal library has been modified to use the builtin + rand() number generator. The output of this generator is + different from pervious versions of this generator because + the rand() builtin does not match the additive 55 / shuffle + generators from the old cryrand.cal file. + + Added Makfile support for building BSD/386 releases. + + The cmp() builtin can now compare complex values. + + Added the errno() builtin to return the meaning of errno numbers. + + Added fputc(), fputs(), fgets(), ftell(), fseek() builtins. + + Added fsize() builtin to determine the size of an open file. + + Supports systems where file positions and offsets are longer than 2^32 + byte, longer than long and/or are not a simple type. + + When a file file is printed, the file number is also printed: + + FILE 3 "/etc/motd" (reading, pos 127) + + Added matsum() to sum all numeric values in a matrix. + + The following code now works, thanks to a fix by ernie@neumann.une.edu.au + (Ernest Bowen): + + mat A[3] = {1, 2, 3}; + A[0] = A; + print A[0]; + + Also thanks to ernie, calc can process compound expressions + such as 1 ? 2 ? 3 : 4 : 5. + + Also^2 thanks to ernie, the = operator is more general: + + (a = 3) = 4 (same as a = 3; a = 4) + (a += 3) *= 4 (same as a += 3; a *= 4) + matfill(B = A, 4) (same as B = A; matfill(B, 4);) + + Also^3 thanks to ernie, the ++ and -- operators are more general. + + a = 3 + ++(b = a) (a == 3, b == 4) + ++++a (a == 5) + (++a)++ == 6 (a == 7) + (++a) *= b (a == 32, b == 4) + + Fixed a bug related to calling epsilon(variable) thanks to ernie. + + Removed trailing whitespace from source and help files. + + Some compilers do not support the const type. The file have_const.h, + which is built from have_const.c will determine if we can or should + use const. See the Makefile for details. + + Some systems do not have uid_t. The file have_uid_t.h, which is + built from have_uid_t.c will determine if we can or should depend + on uid_t being typefed by the system include files. See the Makefile + for details. + + Some systems do not have memcpy(), memset() and strchr(). The + file have_newstr.h, which is built from have_newstr.c will + determine if we can or should depend libc providing these + functions. See the Makefile for details. + + The Makefile symbol DONT_HAVE_VSPRINTF is now called HAVE_VSPRINTF. + The file have_vs.h, which is built from have_vs.c will determine if + we can or should depend libc providing vsprintf(). See the Makefile + for details. + + Removed UID_T and OLD_BSD symbols from the Makefile. + + A make all of the upper level Makefile will cause the all rule + of the lib and help subdirs to be made as well. + + Fixed bug where reserved keyword used as symbol name caused a core dump. + +Following is the change from calc version 2.9.3t7 to 2.9.3t8: + + WARNING: This patch is an beta test patch by chongo@toad.com + (Landon Curt Noll). + + The 'show' command by itself will issue an error message + that will remind one of the possible show arguments. + (thanks to Ha S. Lam ) + + Fixed an ANSI-C related problem with the use of stringindex() + by the show command. ANSI-C interprets "bar\0foo..." as if + it were "bar\017oo...". + + Added a cd command to change the current directory. + (thanks to Ha S. Lam ) + + Calc will not output the initial version string, startup + message and command prompt if stdin is not a tty. Thus + the shell command: + + echo "fact(100)" | calc + + only prints the result. (thanks to Ha S. Lam ) + + The zmath.h macro zisbig() macro was replaced with zlt16b(), + zge24b(), zge31b(), zge32b() and zgtmaxfull() which are + independent of word size. + + The 'too large' limit for factorial operations (e.g., fact, pfact, + lcmfact, perm and comb) is now 2^24. Previously it depended on the + word size which in the case of 64 bit systems was way too large. + + The 'too large' limit for exponentiation, bit position (isset, + digit, ), matrix operations (size, index, creation), scaling, + shifting, rounding and computing a Fibonacci number is 2^31. + For example, one cannot raise a number by a power >= 2^31. + One cannot test for a bit position >= 2^31. One cannot round + a value to 2^31 decimal digit places. One cannot compute + the Fibonacci number F(2^31). + + Andy Fingerhut (thanks!) supplied a fix to + a subtle bug in the code generation routines. The basic problem was + that addop() is sometimes used to add a label to the opcode table + of a function. The addop() function did some optimization tricks, + and if one of these labels happens to be an opcode that triggers + optimization, incorrect opcodes were generated. + + Added utoz(), ztou() to zmath.c, and utoq(), qtou() to qmath.c + in preparation for 2.9.3t9 mods. + +Following is the change from calc version 2.9.2 to 2.9.3t7: + + WARNING: This patch is an beta test patch by chongo@toad.com + (Landon Curt Noll). + + Calc can now compile on OSF/1, SGI and IBM RS6000 systems. + + A number of systems that have both and do + not correctly implement both types. On some System V, MIPS and DEC + systems, vsprintf() and 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. + + Fixed the ilog2() builtin. Previously ilog2(2^-20) returned + -21 instead of -20. + + The internal function qprecision() has been fixed. The changes + ensure that for any e for which 0 < e <= 1: + + 1/4 < sup(abs(appr(x,e) - x))/e <= 1/2. + + Here 'sup' denotes the supremum or least upper bound over values of x. + Previousld calc did: 1/4 <= sup(abs(appr(x,e) - x))/e < 1. + + 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. + + Fixed a bug involving ilog2(). + + Fixed quomod(a,b,c,d) to give correct value for d when a is between + 0 and -b. + + Fixed hmean() to perform the necessary multiplication by the number of + arguments. + + 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/LIBRARY b/LIBRARY new file mode 100644 index 0000000..951556d --- /dev/null +++ b/LIBRARY @@ -0,0 +1,436 @@ + 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 libcalc.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. + +------------------ +FIRST THINGS FIRST +------------------ + +******************************************************************************* +* You MUST call libcalc_call_me_first() prior to using libcalc lib functions! * +******************************************************************************* + +The function libcalc_call_me_first() takes no args and returns void. You +need call libcalc_call_me_first() only once. + +------------- +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 programs may want to compile with: + + -I${LIBDIR} -L${LIBDIR} -lcalc + +-------------- +ERROR HANDLING +-------------- + +Your 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. + +For convenience, the library libcalc.a contains a math_error routine. +By default, this routine simply prints a message to stderr and then exits. +By simply linking in this library, any calc errors will result in a +error message on stderr followed by an exit. + +External programs that wish to use this math_error may want to compile with: + + -I${LIBDIR} -L${LIBDIR} -lcalc + +If one sets up calc_jmp_buf, and then sets calc_jmp to non-zero then +this routine will longjmp back (with the value of calc_jmp) instead. +In addition, the last calc error message will be found in calc_error; +this error is not printed to stderr. The calc error message will +not have a trailing newline. + +For example: + + #include + + extern jmp_buf calc_jmp_buf; + extern int calc_jmp; + extern char *calc_error; + int error; + + ... + + if ((error = setjmp(calc_jmp_buf)) != 0) { + /* handle error */ + printf("Ouch: %s\n", calc_error); + } + calc_jmp = 1; + +--------------- +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) + zisnegone(z) (number is -1) + zistwo(z) (number is 2) + zisabstwo(z) (number is 2 or -2) + zisabsleone(z) (number is -1, 0 or 1) + zislezero(z) (number is <= 0) + zisleone(z) (number is <= 1) + zge16b(z) (number is >= 2^16) + zge24b(z) (number is >= 2^24) + zge31b(z) (number is >= 2^31) + zge32b(z) (number is >= 2^32) + zge64b(z) (number is >= 2^64) + +Typically the largest unsigned long is typedefed to FULL. The following +macros are useful in dealing with this data type: + + MAXFULL (largest positive FULL value) + MAXUFULL (largest unsigned FULL value) + zgtmaxfull(z) (number is > MAXFULL) + zgtmaxufull(z) (number is > MAXUFULL) + zgtmaxlong(z) (number is > MAXLONG, largest long value) + zgtmaxulong(z) (number is > MAXULONG, largest unsigned long value) + +If zgtmaxufull(z) is false, then one may quickly convert the absolute +value of number into a full with the macro: + + ztofull(z) (convert abs(number) to FULL) + ztoulong(z) (convert abs(number) to an unsigned long) + ztolong(z) (convert abs(number) to a long) + +If the value is too large for ztofull(), ztoulong() or ztolong(), only +the low order bits converted. + +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 = qqadd(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) + qisnegone(q) (number is -1) + qistwo(q) (number is 2) + qiseven(q) (number is an even integer) + qisodd(q) (number is an odd integer) + qistwopower(q) (number is a power of 2 >= 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) + cisnegone(c) (number is -1) + cisone(c) (number is 1) + cisrunit(c) (number is 1 or -1) + cisiunit(c) (number is i or -i) + cisunit(c) (number is 1, -1, i, or -i) + cistwo(c) (number is 2) + cisint(c) (number is has integer real and imaginary parts) + ciseven(c) (number is has even real and imaginary parts) + cisodd(c) (number is has odd real and imaginary parts) + +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/Makefile b/Makefile new file mode 100644 index 0000000..7f6cabd --- /dev/null +++ b/Makefile @@ -0,0 +1,2967 @@ +#!/bin/make +# +# (Gerneric calc makefile) +# +# Copyright (c) 1995 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 with help/mods from others +# Makefile by Landon Curt Noll + +############################################################################## +#-=-=-=-=-=-=-=-=- You may want to change some values below -=-=-=-=-=-=-=-=-# +############################################################################## + +# Determine the type of terminal controls that you want to use +# +# value meaning +# -------- ------- +# (nothing) let the makefile guess at what you need +# -DUSE_TERMIOS use struct termios from +# -DUSE_TERMIO use struct termios from +# -DUSE_SGTTY use struct sgttyb from +# +# If in doubt, leave TERMCONTROL empty. +# +TERMCONTROL= +#TERMCONTROL= -DUSE_TERMIOS +#TERMCONTROL= -DUSE_TERMIO +#TERMCONTROL= -DUSE_SGTTY + +# 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. Some old systems do not have vsprintf(). +# If you do not have vsprintf(), then calc will try sprintf() and hope +# for the best. +# +# If HAVE_VSPRINTF is empty, this makefile will run the have_stdvs.c and/or +# have_varvs.c program to determine if vsprintf() is supported. If +# HAVE_VSPRINTF is set to -DDONT_HAVE_VSPRINTF then calc will hope that +# sprintf() will work. +# +# If in doubt, leave HAVE_VSPRINTF empty. +# +HAVE_VSPRINTF= +#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 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 if your compiler supports the long long type and if so, its length +# +# If LONGLONG_BITS is set to nothing, the Makefile will run the longlong +# program to determine if it supports them and if so, their length. +# To disable the use of long longs, set LONGLONG_BITS to 0. +# One may hard code the length of a long long by setting LONGLONG_BITS +# to a non-zero value. +# +# On some machines, using long longs will make the cpu intensive +# jobs run faster. On others, using long longs make things slower. +# On some systems, the regression test runs slower while cpu bound +# jobs run faster. On others, the reverse is true. +# +# If in doubt, try to leave LONGLONG_BITS empty. Do a 'make check' +# and change to 'LONGLONG_BITS= 0' if you encounter problems. +# +#LONGLONG_BITS= 0 +LONGLONG_BITS= +#LONGLONG_BITS= 64 + +# Determine if we have the ANSI C fgetpos and fsetpos alternate interface +# to the ftell() and fseek() (with whence set to SEEK_SET) functions. +# +# If HAVE_FPOS is empty, this makefile will run the have_fpos program +# to determine if there is are fgetpos and fsetpos functions. If HAVE_FPOS +# is set to -DHAVE_NO_FPOS, then calc will use ftell() and fseek(). +# +# If in doubt, leave HAVE_FPOS empty. +# +HAVE_FPOS= +#HAVE_FPOS= -DHAVE_NO_FPOS + +# Determine if we have ANSI C const. +# +# If HAVE_CONST is empty, this makefile will run the have_const program +# to determine if const is supported. If HAVE_CONST is set to -DHAVE_NO_CONST, +# then calc will not use const. +# +# If in doubt, leave HAVE_CONST empty. +# +HAVE_CONST= +#HAVE_CONST= -DHAVE_NO_CONST + +# Determine if we have uid_t +# +# If HAVE_UID_T is empty, this makefile will run the have_uid_t program +# to determine if const is supported. If HAVE_UID_T is set to -DHAVE_NO_UID_T, +# then calc will treat uid_t as an unsigned short. This only matters if +# $HOME is not set and calc must look up the home directory in /etc/passwd. +# +# If in doubt, leave HAVE_UID_T empty. +# +HAVE_UID_T= +#HAVE_UID_T= -DHAVE_NO_UID_T + +# Determine if we have memcpy(), memset() and strchr() +# +# If HAVE_NEWSTR is empty, this makefile will run the have_newstr program +# to determine if memcpy(), memset() and strchr() are supported. If +# HAVE_NEWSTR is set to -DHAVE_NO_NEWSTR, then calc will use bcopy() instead +# of memcpy(), use bfill() instead of memset(), and use index() instead of +# strchr(). +# +# If in doubt, leave HAVE_NEWSTR empty. +# +HAVE_NEWSTR= +#HAVE_NEWSTR= -DHAVE_NO_NEWSTR + +# Some architectures such as Sparc do not allow one to access 32 bit values +# that are not alligned on a 32 bit boundary. +# +# The Dec Alpha running OSF/1 will produce alignment error messages when +# align32.c tries to figure out if alignment is needed. Use the +# ALIGN32= -DMUST_ALIGN32 to force alignment and avoid such error messages. +# +# ALIGN32= let align32.c figure out if alignment is needed +# ALIGN32= -DMUST_ALIGN32 force 32 bit alignment +# ALIGN32= -UMUST_ALIGN32 allow non-aligment of 32 bit accesses +# +# When in doubt, be safe and pick ALIGN32=-DMUST_ALIGN32. +# +#ALIGN32= +ALIGN32= -DMUST_ALIGN32 +#ALIGN32= -UMUST_ALIGN32 + +# The return value type of main() differs from platform to platform. +# In some cases, a compiler warning is issued because main() does +# or does not return a value. +# +# MAIN= -DMAIN=void main() is of type void +# MAIN= -DMAIN=int main() is of type int +# +# When in dobut, try MAIN= -DMAIN=void. If you get a warning try the other. +# +MAIN= -DMAIN=void +#MAIN= -DMAIN=int + +# where to install binary files +# +BINDIR= /usr/local/bin +#BINDIR= /usr/bin +#BINDIR= /usr/contrib/bin + +# where to install the *.cal, *.h and *.a files +# +# ${TOPDIR} is the directory under which the calc directory will be placed. +# ${LIBDIR} is where the *.cal, *.h, *.a, bindings and help dir are installed. +# ${HELPDIR} is where the help directory is installed. +# +TOPDIR= /usr/local/lib +#TOPDIR= /usr/lib +#TOPDIR= /usr/libdata +#TOPDIR= /usr/contrib/lib +# +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/local/catman/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 +# +# If CATDIR is non-empty, then +# If NROFF is non-empty, then +# ${NROFF} ${NROFF_ARG} calc.1 > ${CATDIR}/calc.${CATEXT} +# is used to built and install the cat page +# else (NROFF is empty) +# ${MANMAKE} calc.1 ${CATDIR} +# is used to built and install the cat page +# else +# The cat page is not built or installed +# +# If in doubt and you don't want to fool with man pages, set MANDIR +# and CATDIR to empty and ignore the lines below. +# +NROFF= nroff +#NROFF= +#NROFF= groff +NROFF_ARG= -man +#NROFF_ARG= -mandoc +MANMAKE= /usr/local/bin/manmake +#MANMAKE= manmake + +# 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. +# The $CALCPATH will be used to search for this file. +# +# ${LIBDIR}/bindings uses ^D for editing +# ${LIBDIR}/altbind uses ^D for EOF +# +CALCBINDINGS= bindings +#CALCBINDINGS= altbind + +# If $PAGER is not set, use this program to display a help file +# +CALCPAGER= more +#CALCPAGER= pg +#CALCPAGER= cat +#CALCPAGER= less + +# Debug/Optimize options for ${CC} +# +DEBUG= -O +#DEBUG= -O -g +#DEBUG= -O -g3 +#DEBUG= -O1 +#DEBUG= -O1 -g +#DEBUG= -O1 -g3 +#DEBUG= -O2 +#DEBUG= -O2 -g +#DEBUG= -O2 -g3 +#DEBUG= -O2 -ipa +#DEBUG= -O2 -g3 -ipa +#DEBUG= -O3 +#DEBUG= -O3 -g +#DEBUG= -O3 -g3 +#DEBUG= -O3 -ipa +#DEBUG= -O3 -g3 -ipa +#DEBUG= -g +#DEBUG= -g3 +#DEBUG= -gx +#DEBUG= -WM,-g +#DEBUG= + +# On systems that have dynamic shared libs, you may want want to disable them +# for faster calc startup. +# +# System type NO_SHARED recomendation +# +# BSD NO_SHARED= +# SYSV NO_SHARED= -dn +# IRIX NO_SHARED= -non_shared +# disable NO_SHARED= +# +# If in doubt, use NO_SHARED= +# +NO_SHARED= +#NO_SHARED= -dn +#NO_SHARED= -non_shared + +# On some systems where you are disabling dynamic shared libs, you may +# need to pass a special flag to ${CC} during linking stage. +# +# System type NO_SHARED recomendation +# +# IRIX with NO_SHARED= -non_shared LD_NO_SHARED= -Wl,-rdata_shared +# IRIX with NO_SHARED= LD_NO_SHARED= +# others LD_NO_SHARED= +# +# If in doubt, use LD_NO_SHARED= +# +LD_NO_SHARED= +#LD_NO_SHARED= -Wl,-rdata_shared + +# 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 : +# +# If in doubt and you don't care about lint, use LINTLIB= : +# +#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 +# +# If in doubt and you don't care about lint, set LINTFLAGS to empty. +# +#LINTFLAGS= -a -h -v -z +LINTFLAGS= + +# Normally certain files depend on the Makefile. If the Makefile is +# changed, then certain steps should be redone. If MAKE_FILE is +# set to Makefile, then these files will depend on Makefile. If +# MAKE_FILE is empty, they they wont. +# +# If in doubt, set MAKE_FILE to Makefile +# +MAKE_FILE= Makefile +#MAKE_FILE= + +# If you do not wish to use purify, leave PURIFY commented out. +# +# If in doubt, leave PURIFY commented out. +# +#PURIFY= purify -logfile=pure.out +#PURIFY= purify + +### +# +# Select your compiler type by commenting out one of the cc sets below: +# +# CCOPT are flags given to ${CC} for optimization +# CCWARN are flags given to ${CC} for warning message control +# CCMISC are misc flags given to ${CC} +# +# CFLAGS are all flags given to ${CC} [[often includes CCOPT, CCWARN, CCMISC]] +# ICFLAGS are given to ${CC} for intermediate progs +# +# CCMAIN are flags for ${CC} when files with main() instead of CFLAGS +# CCSHS are flags given to ${CC} for compiling shs.c instead of CFLAGS +# CCZPRIME are flags given to ${CC} for compiling zprime.c instead of CFLAGS +# +# LCFLAGS are CC-style flags for ${LINT} +# LDFLAGS are flags given to ${CC} for linking .o files +# ILDFLAGS are flags given to ${CC} for linking .o files for intermediate progs +# +# CC is how the the C compiler is invoked +# +### +# +# common cc set +# +CCWARN= +CCOPT= ${DEBUG} ${NO_SHARED} +CCMISC= +# +CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +ICFLAGS= ${CCWARN} ${CCMISC} +# +CCMAIN= ${ICFLAGS} ${MAIN} +CCSHS= ${CFLAGS} +CCZPRIME= ${CFLAGS} +# +LCFLAGS= +LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +ILDFLAGS= +# +CC= ${PURIFY} cc +# +### +# +# SGI IRIX5.3 (or earlier) C Compiler +# +# You must set above: +# RANLIB=: +# LONGLONG_BITS= 0 +# +# for better performance, set the following above: +# DEBUG= -O2 -g3 +# +# If you have the directory /usr/lib/nonshared, then set the following above: +# NO_SHARED= -non_shared +# LD_NO_SHARED= -Wl,-rdata_shared +# +#CCWARN= -fullwarn -woff 835 +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -use_readonly_const +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} cc +# +### +# +# SGI IRIX6.2 (or later) Mongoose 7.0 (or later) C Compiler for the R4k +# +# You must set above: +# RANLIB=: +# +# for better performance, set the following above: +# DEBUG= -O2 -g3 +# +# If you have the directory /usr/lib32/nonshared, then set the following above: +# NO_SHARED= -non_shared +# LD_NO_SHARED= -Wl,-rdata_shared +# +# woff 1209: cancel 'controlling expression is constant' warnings +# +#CCWARN= -fullwarn -woff 1209 +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -use_readonly_const +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CCWARN} ${NO_SHARED} ${CCMISC} -O1 +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} cc -n32 -r4000 +# +### +# +# SGI IRIX6.2 (or later) Mongoose 7.0 (or later) C Compiler for the R8k +# +# You must set above: +# RANLIB=: +# +# for better performance, set the following above: +# DEBUG= -O2 -g3 +# +# If you have the directory /usr/lib32/nonshared, then set the following above: +# NO_SHARED= -non_shared +# LD_NO_SHARED= -Wl,-rdata_shared +# +# woff 1209: cancel 'controlling expression is constant' warnings +# +#CCWARN= -fullwarn -woff 1209 +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -use_readonly_const +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CCWARN} ${NO_SHARED} ${CCMISC} -O1 +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} cc -n32 -r8000 +# +### +# +# SGI IRIX6.2 (or later) Mongoose 7.0 (or later) C Compiler for the R10k +# +# You must set above: +# RANLIB=: +# +# for better performance, set the following above: +# DEBUG= -O2 -g3 +# +# If you have the directory /usr/lib32/nonshared, then set the following above: +# NO_SHARED= -non_shared +# LD_NO_SHARED= -Wl,-rdata_shared +# +# woff 1209: cancel 'controlling expression is constant' warnings +# +#CCWARN= -fullwarn -woff 1209 +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -use_readonly_const +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CCWARN} ${NO_SHARED} ${CCMISC} -O1 +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} cc -n32 -r10000 +# +### +# +# HP-UX set +# +# for better performance, try set the following above: +# DEBUG= -O +# +# Warning: Some HP-UX optimizers are brain-damaged. If 'make check' fails use: +# DEBUG= -g +# +#CCWARN= +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} cc +# +### +# +# RS6000 set +# +#CCWARN= +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -qlanglvl=ansi +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} cc +# +### +# +# Dec Alpha without gcc set +# +#CCWARN= +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -DFUNCT_DECL_BUG +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} cc +# +### +# +# BSDI's BSD/OS 2.0 (or later) set +# +# for better performance, set the following above: +# DEBUG= -O2 +# +#CCWARN= -Wall -Wno-implicit -Wno-comment +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -ansi +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} shlicc2 +# +### +# +# Solaris 2.x Sun cc compiler +# +# for better performance, set the following above: +# DEBUG= -O +# +#CCWARN= +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC=-Xc +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} cc +# +### +# +# gcc set +# +# for better performance, set the following above: +# DEBUG= -O +# +#CCWARN= -Wall +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -ansi +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} gcc +# +### +# +# gcc1 set (some call it gcc1, some call it gcc) +# +# for better performance, set the following above: +# DEBUG= -O +# +#CCWARN= -Wall +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -ansi +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} gcc1 +#CC= ${PURIFY} gcc +# +### +# +# gcc2 set (some call it gcc2, some call it gcc) +# +# for better performance, set the following above: +# DEBUG= -O2 +# +#CCWARN= -Wall -Wno-implicit -Wno-comment +#CCOPT= ${DEBUG} ${NO_SHARED} +#CCMISC= -ansi +# +#CFLAGS= ${CCWARN} ${CCOPT} ${CCMISC} +#ICFLAGS= ${CCWARN} ${CCMISC} +# +#CCMAIN= ${ICFLAGS} ${MAIN} +#CCSHS= ${CFLAGS} +#CCZPRIME= ${CFLAGS} +# +#LCFLAGS= +#LDFLAGS= ${NO_SHARED} ${LD_NO_SHARED} +#ILDFLAGS= +# +#CC= ${PURIFY} gcc2 +#CC= ${PURIFY} gcc + +############################################################################## +#-=-=-=-=-=-=-=-=- Be careful if you change something below -=-=-=-=-=-=-=-=-# +############################################################################## + +# standard utilities used during make +# +SHELL= /bin/sh +MAKE= make +AWK= awk +SED= sed +SORT= sort +TEE= tee +LINT= lint +CTAGS= ctags +# assume the X11 makedepend tool for the depend rule +MAKEDEPEND= makedepend + +# Makefile debug +# +# Q=@ do not echo internal makefile actions (quiet mode) +# Q= echo internal makefile actions (debug / verbose mode) +# +# V=@: do not echo debug statements (quiet mode) +# V=@ do echo debug statements (debug / verbose mode) +# +#Q= +Q=@ +V=@: +#V=@ + +# the source files which are built into a math library +# +# There MUST be a .o for every .c in LIBOBJS. +# +# NOTE: calcerr.c is built by this Makefile so it is not a real source. +# +LIBSRC= byteswap.c comfunc.c commath.c config.c jump.c lib_calc.c \ + math_error.c pix.c poly.c prime.c qfunc.c qio.c qmath.c qmod.c \ + qtrans.c zfunc.c zio.c zmath.c zmod.c zmul.c zprime.c zrand.c + +# the object files which are built into a math library +# +# There MUST be a .o for every .c in LIBSRC. +# +# NOTE: calcerr.o comes from calcerr.c which is built +# +LIBOBJS= byteswap.o comfunc.o commath.o config.o jump.o lib_calc.o \ + math_error.o pix.o poly.o prime.o qfunc.o qio.o qmath.o qmod.o \ + qtrans.o zfunc.o zio.o zmath.o zmod.o zmul.o zprime.o zrand.o \ + calcerr.o + +# the calculator source files +# +# There MUST be a .c for every .o in CALCOBJS. +# +CALCSRC= addop.c assocfunc.c calc.c codegen.c const.c file.c hash.c \ + quickhash.c func.c hist.c input.c label.c listfunc.c matfunc.c obj.c \ + opcodes.c shs.c string.c symbol.c token.c value.c version.c + +# we build these .o files for calc +# +# There MUST be a .o for every .c in CALCSRC. +# +CALCOBJS= addop.o assocfunc.o calc.o codegen.o const.o file.o hash.o \ + quickhash.o func.o hist.o input.o label.o listfunc.o matfunc.o obj.o \ + opcodes.o shs.o string.o symbol.o token.o value.o version.o + +# we build these .h files during the make +# +BUILD_H_SRC= align32.h args.h calcerr.h conf.h endian_calc.h fposval.h \ + have_const.h have_fpos.h have_malloc.h have_newstr.h have_stdlib.h \ + have_string.h have_uid_t.h have_unistd.h longbits.h longlong.h \ + terminal.h have_times.h + +# we build these .c files during the make +# +BUILD_C_SRC= calcerr.c + +# these .c files may be used in the process of building BUILD_H_SRC +# +# There MUST be a .c for every .o in UTIL_OBJS. +# +UTIL_C_SRC= align32.c endian.c longbits.c have_newstr.c have_uid_t.c \ + have_const.c have_stdvs.c have_varvs.c fposval.c have_fpos.c longlong.c + +# these awk and sed tools are used in the process of building BUILD_H_SRC +# and BUILD_C_SRC +# +UTIL_MISC_SRC= calcerr_h.sed calcerr_h.awk calcerr_c.sed calcerr_c.awk \ + calcerr.tbl check.awk + +# these .o files may get built in the process of building BUILD_H_SRC +# +# There MUST be a .o for every .c in UTIL_C_SRC. +# +UTIL_OBJS= endian.o longbits.o have_newstr.o have_uid_t.o \ + have_const.o fposval.o have_fpos.o longlong.o try_strarg.o \ + have_stdvs.o have_varvs.o + +# these temp files may be created (and removed) during the build of BUILD_C_SRC +# +UTIL_TMP= ll_tmp fpos_tmp fposv_tmp const_tmp uid_tmp newstr_tmp vs_tmp + +# these utility progs may be used in the process of building BUILD_H_SRC +# +UTIL_PROGS= align32 fposval have_uid_t longlong have_const \ + endian longbits have_newstr have_stdvs have_varvs + +# these .h files are needed by programs that use libcalc.a +# +LIB_H_SRC= alloc.h byteswap.h cmath.h config.h jump.h \ + prime.h qmath.h zmath.h zrand.h + +# these .h files are neither built, nor required by libcalc.a +# +CALC_H_SRC= calc.h file.h func.h hash.h hist.h label.h opcodes.h \ + shs.h string.h symbol.h token.h value.h + +# complete list of .h files found (but not built) in the distribution +# +H_SRC= ${CALC_H_SRC} ${LIB_H_SRC} + +# complete list of .c files found (but not built) in the distribution +# +C_SRC= ${LIBSRC} ${CALCSRC} ${UTIL_C_SRC} + +# These files are found (but not built) in the distribution +# +DISTLIST= ${C_SRC} ${H_SRC} ${MAKE_FILE} BUGS CHANGES LIBRARY README \ + calc.man lint.sed README.FIRST ${UTIL_MISC_SRC} + +# complete list of .o files +# +OBJS= ${LIBOBJS} ${CALCOBJS} ${UTIL_OBJS} + +# complete list of progs built +# +PROGS= calc ${UTIL_PROGS} + +# complete list of targets +# +TARGETS= calc calc.1 lib/.all help/.all help/builtin + + +### +# +# The reason for this Makefile :-) +# +### + +all: ${TARGETS} + +calc: libcalc.a ${CALCOBJS} + ${CC} ${LDFLAGS} ${CALCOBJS} libcalc.a -o calc + +libcalc.a: ${LIBOBJS} ${MAKE_FILE} + -rm -f libcalc.a + ar qc libcalc.a ${LIBOBJS} + ${RANLIB} libcalc.a + +calc.1: calc.man ${MAKE_FILE} + -rm -f calc.1 + ${SED} -e 's:$${LIBDIR}:${LIBDIR}:g' < calc.man > calc.1 + +## +# +# Special .o files +# +## + +calc.o: calc.c ${MAKE_FILE} + ${CC} ${CCMAIN} ${CCOPT} -c calc.c + +hist.o: hist.c ${MAKE_FILE} + ${CC} ${CFLAGS} ${TERMCONTROL} -c hist.c + +shs.o: shs.c ${MAKE_FILE} + ${CC} ${CCSHS} -c shs.c + +zprime.o: zprime.c ${MAKE_FILE} + ${CC} ${CCZPRIME} -c zprime.c + + +## +# +# Doing a 'make check' will cause the regression test suite to be executed. +# This rule will try to build anything that needs to be built as well. +# +# Doing a 'make chk' will cause only the context around interesting +# (and error) messages to be printed. Unlike 'make check', this +# rule does not cause things to be built. I.e., the all rule is +# not invoked. +# +## + +check: all ./lib/regress.cal ./lib/lucas.cal ./lib/lucas_chk.cal \ + ./lib/test1700.cal ./lib/test2300.cal ./lib/test2600.cal \ + ./lib/test2700.cal ./lib/test3100.cal ./lib/test3300.cal \ + ./lib/test3400.cal ./lib/test3500.cal ./lib/test4000.cal \ + ./lib/test4100.cal ./lib/surd.cal + CALCPATH="./lib" ./calc -q read regress + +chk: ./lib/regress.cal ./lib/lucas.cal ./lib/lucas_chk.cal \ + ./lib/test1700.cal ./lib/test2300.cal ./lib/test2600.cal \ + ./lib/test2700.cal ./lib/test3100.cal ./lib/test3300.cal \ + ./lib/test3400.cal ./lib/test3500.cal ./lib/test4000.cal \ + ./lib/test4100.cal ./lib/surd.cal check.awk + ${V} echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + CALCPATH="./lib" ./calc -q read regress 2>&1 | ${AWK} -f check.awk + ${V} echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +## +# +# The next set of rules cause the .h files BUILD_H_SRC files to be built +# according tot he system and the Makefile variables above. The hsrc rule +# is a conveient rule to invoke to built all of the BUILD_H_SRC. +# +# We add in the BUILD_C_SRC files because they are similar to the +# BUILD_H_SRC files in terms of the build process. +# +# NOTE: Due to bogus shells found on one common system we must have +# an non-emoty else clause for every if condition. *sigh* +# We also place ; true at the end of some commands to avoid +# meaningless cosmetic messages by the same system. +# +## + +hsrc: ${BUILD_H_SRC} ${BUILD_C_SRC} + +conf.h: ${MAKE_FILE} + -${Q}rm -f conf.h + ${Q}echo 'forming conf.h' + ${Q}echo '/*' > conf.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> conf.h + ${Q}echo ' */' >> conf.h + ${Q}echo '' >> conf.h + ${Q}echo '#if !defined(_CONF_H_)' >> conf.h + ${Q}echo '#define _CONF_H_' >> conf.h + ${Q}echo '' >> conf.h + ${Q}echo '/* the default :-separated search path */' >> conf.h + ${Q}echo '#ifndef DEFAULTCALCPATH' >> conf.h + ${Q}echo '#define DEFAULTCALCPATH "${CALCPATH}"' >> conf.h + ${Q}echo '#endif /* DEFAULTCALCPATH */' >> conf.h + ${Q}echo '' >> conf.h + ${Q}echo '/* the default :-separated startup file list */' >> conf.h + ${Q}echo '#ifndef DEFAULTCALCRC' >> conf.h + ${Q}echo '#define DEFAULTCALCRC "${CALCRC}"' >> conf.h + ${Q}echo '#endif /* DEFAULTCALCRC */' >> conf.h + ${Q}echo '' >> conf.h + ${Q}echo '/* the default key bindings file */' >> conf.h + ${Q}echo '#ifndef DEFAULTCALCBINDINGS' >> conf.h + ${Q}echo '#define DEFAULTCALCBINDINGS "${CALCBINDINGS}"' >> conf.h + ${Q}echo '#endif /* DEFAULTCALCBINDINGS */' >> conf.h + ${Q}echo '' >> conf.h + ${Q}echo '/* the location of the help directory */' >> conf.h + ${Q}echo '#ifndef HELPDIR' >> conf.h + ${Q}echo '#define HELPDIR "${HELPDIR}"' >> conf.h + ${Q}echo '#endif /* HELPDIR */' >> conf.h + ${Q}echo '' >> conf.h + ${Q}echo '/* the default pager to use */' >> conf.h + ${Q}echo '#ifndef DEFAULTCALCPAGER' >> conf.h + ${Q}echo '#define DEFAULTCALCPAGER "${CALCPAGER}"' >> conf.h + ${Q}echo '#endif /* DEFAULTCALCPAGER */' >> conf.h + ${Q}echo '' >> conf.h + ${Q}echo '#endif /* _CONF_H_ */' >> conf.h + ${Q}echo 'conf.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +endian_calc.h: endian ${MAKE_FILE} + -${Q}rm -f endian_calc.h + ${Q}echo 'forming endian_calc.h' + ${Q}echo '/*' > endian_calc.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> endian_calc.h + ${Q}echo ' */' >> endian_calc.h + ${Q}echo '' >> endian_calc.h + ${Q}echo '#if !defined(_ENDIAN_CALC_H_)' >> endian_calc.h + ${Q}echo '#define _ENDIAN_CALC_H_' >> endian_calc.h + ${Q}echo '' >> endian_calc.h + ${Q}echo '/* what byte order are we? */' >> endian_calc.h + -${Q}if [ X"${BYTE_ORDER}" = X ]; then \ + if [ -f /usr/include/machine/endian.h ]; then \ + echo '#include ' >> endian_calc.h; \ + else \ + ./endian >> endian_calc.h; \ + fi; \ + else \ + echo "#define BYTE_ORDER ${BYTE_ORDER}" >> endian_calc.h; \ + fi + ${Q}echo '' >> endian_calc.h + ${Q}echo '#endif /* _ENDIAN_CALC_H_ */' >> endian_calc.h + ${Q}echo 'endian_calc.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +longbits.h: longbits ${MAKE_FILE} + -${Q}rm -f longbits.h + ${Q}echo 'forming longbits.h' + ${Q}echo '/*' > longbits.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> longbits.h + ${Q}echo ' */' >> longbits.h + ${Q}echo '' >> longbits.h + ${Q}echo '#if !defined(_LONGBITS_H_)' >> longbits.h + ${Q}echo '#define _LONGBITS_H_' >> longbits.h + ${Q}echo '' >> longbits.h + -${Q}if [ X"${LONG_BITS}" = X ]; then \ + ./longbits >> longbits.h; \ + else \ + echo "#define LONG_BITS ${LONG_BITS}" >> longbits.h; \ + fi + ${Q}echo '' >> longbits.h + ${Q}echo '#endif /* _LONGBITS_H_ */' >> longbits.h + ${Q}echo 'longbits.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_malloc.h: ${MAKE_FILE} + -${Q}rm -f have_malloc.h + ${Q}echo 'forming have_malloc.h' + ${Q}echo '/*' > have_malloc.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_malloc.h + ${Q}echo ' */' >> have_malloc.h + ${Q}echo '' >> have_malloc.h + ${Q}echo '#if !defined(_HAVE_MALLOC_H_)' >> have_malloc.h + ${Q}echo '#define _HAVE_MALLOC_H_' >> have_malloc.h + ${Q}echo '' >> have_malloc.h + ${Q}echo '/* do we have /usr/include/malloc.h? */' >> have_malloc.h + -${Q}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 + ${Q}echo '' >> have_malloc.h + ${Q}echo '#endif /* _HAVE_MALLOC_H_ */' >> have_malloc.h + ${Q}echo 'have_malloc.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_times.h: ${MAKE_FILE} + -${Q}rm -f have_times.h + ${Q}echo 'forming have_times.h' + ${Q}echo '/*' > have_times.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_times.h + ${Q}echo ' */' >> have_times.h + ${Q}echo '' >> have_times.h + ${Q}echo '#if !defined(_HAVE_TIMES_H_)' >> have_times.h + ${Q}echo '#define _HAVE_TIMES_H_' >> have_times.h + ${Q}echo '' >> have_times.h + ${Q}echo '/* do we have /usr/include/times.h? */' >> have_times.h + -${Q}if [ -f /usr/include/times.h ]; then \ + echo '#define HAVE_TIMES_H /* yes */' >> have_times.h; \ + else \ + echo '#undef HAVE_TIMES_H /* no */' >> have_times.h; \ + fi + -${Q}if [ -f /usr/include/sys/times.h ]; then \ + echo '#define HAVE_SYS_TIMES_H /* yes */' >> have_times.h; \ + else \ + echo '#undef HAVE_SYS_TIMES_H /* no */' >> have_times.h; \ + fi + -${Q}if [ -f /usr/include/time.h ]; then \ + echo '#define HAVE_TIME_H /* yes */' >> have_times.h; \ + else \ + echo '#undef HAVE_TIME_H /* no */' >> have_times.h; \ + fi + -${Q}if [ -f /usr/include/sys/time.h ]; then \ + echo '#define HAVE_SYS_TIME_H /* yes */' >> have_times.h; \ + else \ + echo '#undef HAVE_SYS_TIME_H /* no */' >> have_times.h; \ + fi + ${Q}echo '' >> have_times.h + ${Q}echo '#endif /* _HAVE_TIMES_H_ */' >> have_times.h + ${Q}echo 'have_times.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_stdlib.h: ${MAKE_FILE} + -${Q}rm -f have_stdlib.h + ${Q}echo 'forming have_stdlib.h' + ${Q}echo '/*' > have_stdlib.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_stdlib.h + ${Q}echo ' */' >> have_stdlib.h + ${Q}echo '' >> have_stdlib.h + ${Q}echo '#if !defined(_HAVE_STDLIB_H_)' >> have_stdlib.h + ${Q}echo '#define _HAVE_STDLIB_H_' >> have_stdlib.h + ${Q}echo '' >> have_stdlib.h + ${Q}echo '/* do we have /usr/include/stdlib.h? */' >> have_stdlib.h + -${Q}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 + ${Q}echo '' >> have_stdlib.h + ${Q}echo '#endif /* _HAVE_STDLIB_H_ */' >> have_stdlib.h + ${Q}echo 'have_stdlib.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_unistd.h: ${MAKE_FILE} + -${Q}rm -f have_unistd.h + ${Q}echo 'forming have_unistd.h' + ${Q}echo '/*' > have_unistd.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_unistd.h + ${Q}echo ' */' >> have_unistd.h + ${Q}echo '' >> have_unistd.h + ${Q}echo '#if !defined(_HAVE_UNISTD_H_)' >> have_unistd.h + ${Q}echo '#define _HAVE_UNISTD_H_' >> have_unistd.h + ${Q}echo '' >> have_unistd.h + ${Q}echo '/* do we have /usr/include/unistd.h? */' >> have_unistd.h + -${Q}if [ -f /usr/include/unistd.h ]; then \ + echo '#define HAVE_UNISTD_H /* yes */' >> have_unistd.h; \ + else \ + echo '#undef HAVE_UNISTD_H /* no */' >> have_unistd.h; \ + fi + ${Q}echo '' >> have_unistd.h + ${Q}echo '#endif /* _HAVE_UNISTD_H_ */' >> have_unistd.h + ${Q}echo 'have_unistd.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_string.h: ${MAKE_FILE} + -${Q}rm -f have_string.h + ${Q}echo 'forming have_string.h' + ${Q}echo '/*' > have_string.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_string.h + ${Q}echo ' */' >> have_string.h + ${Q}echo '' >> have_string.h + ${Q}echo '#if !defined(_HAVE_STRING_H_)' >> have_string.h + ${Q}echo '#define _HAVE_STRING_H_' >> have_string.h + ${Q}echo '' >> have_string.h + ${Q}echo '/* do we have /usr/include/string.h? */' >> have_string.h + -${Q}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 + ${Q}echo '' >> have_string.h + ${Q}echo '#endif /* _HAVE_STRING_H_ */' >> have_string.h + ${Q}echo 'have_string.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +terminal.h: ${MAKE_FILE} + -${Q}rm -f terminal.h + ${Q}echo 'forming terminal.h' + ${Q}echo '/*' > terminal.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> terminal.h + ${Q}echo ' */' >> terminal.h + ${Q}echo '' >> terminal.h + ${Q}echo '#if !defined(_TERMINAL_H_)' >> terminal.h + ${Q}echo '#define _TERMINAL_H_' >> terminal.h + ${Q}echo '' >> terminal.h + ${Q}echo '/* determine the type of terminal interface */' >> terminal.h + ${Q}echo '#if !defined(USE_TERMIOS)' >> terminal.h + ${Q}echo '#if !defined(USE_TERMIO)' >> terminal.h + ${Q}echo '#if !defined(USE_SGTTY)' >> terminal.h + -${Q}if [ -f /usr/include/termios.h ]; then \ + echo '#define USE_TERMIOS /* */' >> terminal.h; \ + echo '#undef USE_TERMIO /* */' >> terminal.h; \ + echo '#undef USE_SGTTY /* */' >> terminal.h; \ + elif [ -f /usr/include/termio.h ]; then \ + echo '#undef USE_TERMIOS /* */' >> terminal.h; \ + echo '#define USE_TERMIO /* */' >> terminal.h; \ + echo '#undef USE_SGTTY /* */' >> terminal.h; \ + else \ + echo '#undef USE_TERMIOS /* */' >> terminal.h; \ + echo '#undef USE_TERMIO /* */' >> terminal.h; \ + echo '#define USE_SGTTY /* */' >> terminal.h; \ + fi + ${Q}echo '#endif' >> terminal.h + ${Q}echo '#endif' >> terminal.h + ${Q}echo '#endif' >> terminal.h + ${Q}echo '' >> terminal.h + ${Q}echo '#endif /* _TERMINAL_H_ */' >> terminal.h + ${Q}echo 'terminal.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +longlong.h: longlong.c have_stdlib.h have_string.h ${MAKE_FILE} + -${Q}rm -f longlong longlong.o ll_tmp longlong.h + ${Q}echo 'forming longlong.h' + ${Q}echo '/*' > longlong.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> longlong.h + ${Q}echo ' */' >> longlong.h + ${Q}echo '' >> longlong.h + ${Q}echo '#if !defined(_LONGLONG_H_)' >> longlong.h + ${Q}echo '#define _LONGLONG_H_' >> longlong.h + ${Q}echo '' >> longlong.h + ${Q}echo '/* do we have/want to use a long long type? */' >> longlong.h + -${Q}rm -f longlong.o longlong + -${Q}${CC} ${CCMAIN} longlong.c -c 2>/dev/null; true + -${Q}${CC} ${ILDFLAGS} longlong.o -o longlong 2>/dev/null; true + -${Q}${SHELL} -c "./longlong ${LONGLONG_BITS} > ll_tmp 2>/dev/null" \ + >/dev/null 2>&1; true + -${Q}if [ -s ll_tmp ]; then \ + cat ll_tmp >> longlong.h; \ + else \ + echo '#undef HAVE_LONGLONG' >> longlong.h; \ + echo '#define LONGLONG_BITS 0 /* no */' >> longlong.h; \ + fi + ${Q}echo '' >> longlong.h + ${Q}echo '#endif /* _LONGLONG_H_ */' >> longlong.h + -${Q}rm -f longlong longlong.o ll_tmp + ${Q}echo 'longlong.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_fpos.h: have_fpos.c ${MAKE_FILE} + -${Q}rm -f have_fpos have_fpos.o fpos_tmp have_fpos.h + ${Q}echo 'forming have_fpos.h' + ${Q}echo '/*' > have_fpos.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_fpos.h + ${Q}echo ' */' >> have_fpos.h + ${Q}echo '' >> have_fpos.h + ${Q}echo '#if !defined(_HAVE_FPOS_H_)' >> have_fpos.h + ${Q}echo '#define _HAVE_FPOS_H_' >> have_fpos.h + ${Q}echo '' >> have_fpos.h + ${Q}echo '/* do we have fgetpos & fsetpos functions? */' >> have_fpos.h + -${Q}rm -f have_fpos.o have_fpos + -${Q}${CC} ${HAVE_FPOS} ${CCMAIN} have_fpos.c -c 2>/dev/null; true + -${Q}${CC} ${ILDFLAGS} have_fpos.o -o have_fpos 2>/dev/null; true + -${Q}${SHELL} -c "./have_fpos > fpos_tmp 2>/dev/null" \ + >/dev/null 2>&1; true + -${Q}if [ -s fpos_tmp ]; then \ + cat fpos_tmp >> have_fpos.h; \ + else \ + echo '#undef HAVE_FPOS /* no */' >> have_fpos.h; \ + echo '' >> have_fpos.h; \ + echo 'typedef long FILEPOS;' >> have_fpos.h; \ + fi + ${Q}echo '' >> have_fpos.h + ${Q}echo '#endif /* _HAVE_FPOS_H_ */' >> have_fpos.h + -${Q}rm -f have_fpos have_fpos.o fpos_tmp + ${Q}echo 'have_fpos.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +fposval.h: fposval.c have_fpos.h endian_calc.h ${MAKE_FILE} + -${Q}rm -f fposv_tmp fposval fposval.o fposval.h + ${Q}echo 'forming fposval.h' + ${Q}echo '/*' > fposval.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> fposval.h + ${Q}echo ' */' >> fposval.h + ${Q}echo '' >> fposval.h + ${Q}echo '#if !defined(_FPOSVAL_H_)' >> fposval.h + ${Q}echo '#define _FPOSVAL_H_' >> fposval.h + ${Q}echo '' >> fposval.h + ${Q}echo '/* what are our file position & size types? */' >> fposval.h + -${Q}rm -f fposval.o fposval + -${Q}${CC} ${CCMAIN} fposval.c -c 2>/dev/null; true + -${Q}${CC} ${ILDFLAGS} fposval.o -o fposval 2>/dev/null; true + ${Q}${SHELL} -c "./fposval fposv_tmp >> fposval.h 2>/dev/null" \ + >/dev/null 2>&1; true + ${Q}echo '' >> fposval.h + ${Q}echo '#endif /* _FPOSVAL_H_ */' >> fposval.h + -${Q}rm -f fposval fposval.o fposv_tmp + ${Q}echo 'fposval.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_const.h: have_const.c ${MAKE_FILE} + -${Q}rm -f have_const have_const.o const_tmp have_const.h + ${Q}echo 'forming have_const.h' + ${Q}echo '/*' > have_const.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_const.h + ${Q}echo ' */' >> have_const.h + ${Q}echo '' >> have_const.h + ${Q}echo '#if !defined(_HAVE_CONST_H_)' >> have_const.h + ${Q}echo '#define _HAVE_CONST_H_' >> have_const.h + ${Q}echo '' >> have_const.h + ${Q}echo '/* do we have or want const? */' >> have_const.h + -${Q}rm -f have_const.o have_const + -${Q}${CC} ${CCMAIN} ${HAVE_CONST} have_const.c -c 2>/dev/null; true + -${Q}${CC} ${ILDFLAGS} have_const.o -o have_const 2>/dev/null; true + -${Q}${SHELL} -c "./have_const > const_tmp 2>/dev/null" \ + >/dev/null 2>&1; true + -${Q}if [ -s const_tmp ]; then \ + cat const_tmp >> have_const.h; \ + else \ + echo '#undef HAVE_CONST /* no */' >> have_const.h; \ + echo '#undef CONST' >> have_const.h; \ + echo '#define CONST /* no */' >> have_const.h; \ + echo '' >> have_const.h; \ + fi + ${Q}echo '' >> have_const.h + ${Q}echo '#endif /* _HAVE_CONST_H_ */' >> have_const.h + -${Q}rm -f have_const have_const.o const_tmp + ${Q}echo 'have_const.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +align32.h: align32.c longbits.h have_unistd.h ${MAKE_FILE} + -${Q}rm -f align32 align32.o align32_tmp align32.h + ${Q}echo 'forming align32.h' + ${Q}echo '/*' > align32.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> align32.h + ${Q}echo ' */' >> align32.h + ${Q}echo '' >> align32.h + ${Q}echo '#if !defined(_MUST_ALIGN32_H_)' >> align32.h + ${Q}echo '#define _MUST_ALIGN32_H_' >> align32.h + ${Q}echo '' >> align32.h + ${Q}echo '/* must we always align 32 bit accesses? */' >> align32.h + -${Q}if [ X"-DMUST_ALIGN32" = X${ALIGN32} ]; then \ + echo '/* forced to align 32 bit values */' >> align32.h; \ + echo '#define MUST_ALIGN32' >> align32.h; \ + else \ + true; \ + fi + -${Q}if [ X"-UMUST_ALIGN32" = X${ALIGN32} ]; then \ + echo '/* forced to not require 32 bit alignment */' >> align32.h; \ + echo '#undef MUST_ALIGN32' >> align32.h; \ + else \ + true; \ + fi + -${Q}if [ X = X${ALIGN32} ]; then \ + rm -f align32.o align32; \ + ${CC} ${CCMAIN} ${ALIGN32} align32.c -c 2>/dev/null; \ + ${CC} ${ILDFLAGS} align32.o -o align32 2>/dev/null; \ + ${SHELL} -c "./align32 >align32_tmp 2>/dev/null" >/dev/null 2>&1; \ + if [ -s align32_tmp ]; then \ + cat align32_tmp >> align32.h; \ + else \ + echo '/* guess we must align 32 bit values */' >> align32.h; \ + echo '#define MUST_ALIGN32' >> align32.h; \ + fi; \ + rm -f align32 align32.o align32_tmp core; \ + else \ + true; \ + fi + ${Q}echo '' >> align32.h + ${Q}echo '#endif /* _MUST_ALIGN32_H_ */' >> align32.h + ${Q}echo 'align32.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_uid_t.h: have_uid_t.c have_unistd.h ${MAKE_FILE} + -${Q}rm -f have_uid_t have_uid_t.o uid_tmp have_uid_t.h + ${Q}echo 'forming have_uid_t.h' + ${Q}echo '/*' > have_uid_t.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_uid_t.h + ${Q}echo ' */' >> have_uid_t.h + ${Q}echo '' >> have_uid_t.h + ${Q}echo '#if !defined(_HAVE_UID_T_H_)' >> have_uid_t.h + ${Q}echo '#define _HAVE_UID_T_H_' >> have_uid_t.h + ${Q}echo '' >> have_uid_t.h + ${Q}echo '/* do we have or want uid_t? */' >> have_uid_t.h + -${Q}rm -f have_uid_t.o have_uid_t + -${Q}${CC} ${CCMAIN} ${HAVE_UID_T} have_uid_t.c -c 2>/dev/null; true + -${Q}${CC} ${ILDFLAGS} have_uid_t.o -o have_uid_t 2>/dev/null; true + -${Q}${SHELL} -c "./have_uid_t > uid_tmp 2>/dev/null" \ + >/dev/null 2>&1; true + -${Q}if [ -s uid_tmp ]; then \ + cat uid_tmp >> have_uid_t.h; \ + else \ + echo '#undef HAVE_UID_T /* no */' >> have_uid_t.h; \ + echo '' >> have_uid_t.h; \ + fi + ${Q}echo '' >> have_uid_t.h + ${Q}echo '#endif /* _HAVE_UID_T_H_ */' >> have_uid_t.h + -${Q}rm -f have_uid_t have_uid_t.o uid_tmp + ${Q}echo 'have_uid_t.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +have_newstr.h: have_newstr.c ${MAKE_FILE} + -${Q}rm -f have_newstr have_newstr.o newstr_tmp have_newstr.h + ${Q}echo 'forming have_newstr.h' + ${Q}echo '/*' > have_newstr.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> have_newstr.h + ${Q}echo ' */' >> have_newstr.h + ${Q}echo '' >> have_newstr.h + ${Q}echo '#if !defined(_HAVE_NEWSTR_H_)' >> have_newstr.h + ${Q}echo '#define _HAVE_NEWSTR_H_' >> have_newstr.h + ${Q}echo '' >> have_newstr.h + ${Q}echo '/* do we have or want memcpy(), memset() & strchr()? */' \ + >> have_newstr.h + -${Q}rm -f have_newstr.o have_newstr + -${Q}${CC} ${CCMAIN} ${HAVE_NEWSTR} have_newstr.c -c 2>/dev/null; true + -${Q}${CC} ${ILDFLAGS} have_newstr.o -o have_newstr 2>/dev/null; true + -${Q}${SHELL} -c "./have_newstr > newstr_tmp 2>/dev/null" \ + >/dev/null 2>&1; true + -${Q}if [ -s newstr_tmp ]; then \ + cat newstr_tmp >> have_newstr.h; \ + else \ + echo '#undef HAVE_NEWSTR /* no */' >> have_newstr.h; \ + echo '' >> have_newstr.h; \ + fi + ${Q}echo '' >> have_newstr.h + ${Q}echo '#endif /* _HAVE_NEWSTR_H_ */' >> have_newstr.h + -${Q}rm -f have_newstr have_newstr.o newstr_tmp + ${Q}echo 'have_newstr.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +args.h: have_stdvs.c have_varvs.c have_string.h have_unistd.h have_string.h + -${Q}rm -f args.h have_args + ${Q}echo 'forming args.h' + ${Q}echo '/*' > args.h + ${Q}echo ' * DO NOT EDIT -- generated by the Makefile' >> args.h + ${Q}echo ' */' >> args.h + ${Q}echo '' >> args.h + ${Q}echo '#if !defined(_ARGS_H_)' >> args.h + ${Q}echo '#define _ARGS_H_' >> args.h + ${Q}echo '' >> args.h + -${Q}rm -f have_stdvs.o have_stdvs + -${Q}${CC} ${CCMAIN} ${HAVE_VSPRINTF} have_stdvs.c -c 2>/dev/null; true + -${Q}${CC} ${ILDFLAGS} have_stdvs.o -o have_stdvs 2>/dev/null; true + -${Q}if ./have_stdvs >>args.h 2>/dev/null; then \ + touch have_args; \ + else \ + true; \ + fi + -${Q}if [ ! -f have_args ] && [ X"${HAVE_VSPRINTF}" = X ]; then \ + rm -f have_stdvs.o have_stdvs have_varvs.o have_varvs; \ + ${CC} ${CCMAIN} -DDONT_HAVE_VSPRINTF have_varvs.c -c 2>/dev/null; \ + ${CC} ${ILDFLAGS} have_varvs.o -o have_varvs 2>/dev/null; \ + if ./have_varvs >>args.h 2>/dev/null; then \ + touch have_args; \ + else \ + true; \ + fi; \ + else \ + true; \ + fi + -${Q}if [ -f have_args ]; then \ + echo 'exit 0' > have_args; \ + else \ + echo 'exit 1' > have_args; \ + echo "Unable to determine what type of variable args and"; \ + echo "what type of vsprintf() should be used. Set or change"; \ + echo "the Makefile variable HAVE_VSPRINTF."; \ + fi + ${Q}sh ./have_args + ${Q}echo '' >> args.h + ${Q}echo '#endif /* _ARGS_H_ */' >> args.h + -${Q}rm -f have_stdvs.o have_varvs.o have_stdvs + -${Q}rm -f have_varvs have_args core + ${Q}echo 'args.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +calcerr.h: calcerr.tbl calcerr_h.sed calcerr_h.awk ${MAKE_FILE} + -${Q}rm -f calerr.h + ${Q}echo 'forming calcerr.h' + ${Q}echo '/*' > calcerr.h + ${Q}echo ' * DO NOT EDIT' >> calcerr.h + ${Q}echo ' *' >> calcerr.h + ${Q}echo ' * generated by calcerr.tbl via Makefile' >> calcerr.h + ${Q}echo ' */' >> calcerr.h + ${Q}echo '' >> calcerr.h + ${Q}echo '#if !defined(_CALCERR_H_)' >> calcerr.h + ${Q}echo '#define _CALCERR_H_' >> calcerr.h + ${Q}echo '' >> calcerr.h + ${Q}${SED} -f calcerr_h.sed < calcerr.tbl | \ + ${AWK} -f calcerr_h.awk >> calcerr.h + ${Q}echo '' >> calcerr.h + ${Q}echo '#endif /* _CALCERR_H_ */' >> calcerr.h + ${Q}echo 'calcerr.h formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +calcerr.c: calcerr.tbl calcerr_c.sed calcerr_c.awk ${MAKE_FILE} + -${Q}rm -f calerr.c + ${Q}echo 'forming calcerr.c' + ${Q}echo '/*' > calcerr.c + ${Q}echo ' * DO NOT EDIT' >> calcerr.c + ${Q}echo ' *' >> calcerr.c + ${Q}echo ' * generated by calcerr.tbl via Makefile' >> calcerr.c + ${Q}echo ' */' >> calcerr.c + ${Q}echo '' >> calcerr.c + ${Q}${SED} -f calcerr_c.sed < calcerr.tbl | \ + ${AWK} -f calcerr_c.awk >> calcerr.c + ${Q}echo 'calcerr.c formed' + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= start of $@ =-=-='; \ + cat $@; \ + echo '=-=-= end of $@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +## +# +# These rules are used in the process of building the BUILD_H_SRC. +# +## + +endian.o: endian.c have_unistd.h + ${CC} ${CCMAIN} endian.c -c + +endian: endian.o + ${CC} ${ILDFLAGS} endian.o -o endian + +longbits.o: longbits.c longlong.h have_unistd.h + ${CC} ${CCMAIN} longbits.c -c + +longbits: longbits.o + ${CC} ${ILDFLAGS} longbits.o -o longbits + +## +# +# These two .all rules are used to determine of the lower level +# directory has had its all rule performed. +# +## + +lib/.all: + ${V} echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + ${V} echo '=-=-=-=-= Invoking all rule for lib =-=-=-=-=' + cd lib; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} all + ${V} echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + ${V} echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +help/.all: + ${V} echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + ${V} echo '=-=-=-=-= Invoking all rule for help =-=-=-=-=' + cd help; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} all + ${V} echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + ${V} echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +help/builtin: func.c help/builtin.top help/builtin.end help/funclist.sed + ${V} echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + ${V} echo '=-=-=-=-= Invoking builtin rule for help =-=-=-=-=' + cd help; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} builtin + ${V} echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + ${V} echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +## +# +# The BSDI cdrom makefile expects certain files to be pre-built in a sub-dir +# called gen_h. This rule creats this sub-directory so that the release can +# be shipped off to BSDI. You can ignore this rule. +# +## + +bsdi: ${LIB_H_SRC} ${BUILD_H_SRC} calc.1 + ${V} echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + -${Q}if [ ! -d gen_h ]; then \ + echo mkdir gen_h; \ + mkdir gen_h; \ + else \ + true; \ + fi + -${Q}for i in ${LIB_H_SRC} ${BUILD_H_SRC}; do \ + echo rm -f gen_h/$$i; \ + rm -f gen_h/$$i; \ + echo cp $$i gen_h; \ + cp $$i gen_h; \ + echo chmod 0444 gen_h/$$i; \ + chmod 0444 gen_h/$$i; \ + done + cd help; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} bsdi + ${V} echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +## +# +# These rules help with linting. Adjust ${LINT}, ${LINTLIB}, ${LINTFLAGS} +# and the lint.sed file as needed for your system. +# +## + +llib-lcalc.ln: ${BUILD_H_SRC} ${LIBSRC} ${MAKE_FILE} + -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 ${MAKE_FILE} + -rm -f lint.out + ${LINT} ${LINTFLAGS} ${LCFLAGS} llib-lcalc.ln ${CALCSRC} 2>&1 | \ + ${SED} -f lint.sed | ${TEE} lint.out + +## +# +# Home grown make dependency rules. Your system make not support +# or have the needed tools. You can ignore this section. +# +# We will form a skelaton tree of *.c files containing only #include "foo.h" +# lines and .h files containing the same lines surrounded by multiple include +# prevention lines. This allows us to build a static depend list that will +# satisfy all possible cpp symbol definition combinations. +# +## + +depend: hsrc + ${Q}if [ -f Makefile.bak ]; then \ + echo "Makefile.bak exists, remove or move it out of the way"; \ + exit 1; \ + else \ + true; \ + fi + ${Q}echo forming skel + -${Q}rm -rf skel + ${Q}mkdir skel + -${Q}for i in ${C_SRC} ${BUILD_C_SRC}; do \ + ${SED} -n '/^#[ ]*include[ ]*"/p' "$$i" > "skel/$$i"; \ + done + -${Q}for i in ${H_SRC} ${BUILD_H_SRC}; do \ + tag="`echo $$i | ${SED} 's/[\.+,:]/_/g'`"; \ + echo "#ifndef $$tag" > "skel/$$i"; \ + echo "#define $$tag" >> "skel/$$i"; \ + ${SED} -n '/^#[ ]*include[ ]*"/p' "$$i" >> "skel/$$i"; \ + echo '#endif /* '"$$tag"' */' >> "skel/$$i"; \ + done + -${Q}rm -f skel/makedep.out + ${Q}echo skel formed + ${Q}echo forming dependency list + ${Q}echo "# DO NOT DELETE THIS LINE -- make depend depends on it." > \ + skel/makedep.out + ${Q}cd skel; \ + ${MAKEDEPEND} -w 1 -m -f makedep.out ${C_SRC} ${BUILD_C_SRC} + -${Q}for i in ${C_SRC} ${BUILD_C_SRC}; do \ + echo "$$i" | \ + ${SED} 's/^\(.*\)\.c/\1.o: \1.c/' >> skel/makedep.out; \ + done + ${Q}echo dependency list formed + ${Q}echo forming new Makefile + -${Q}rm -f Makefile.bak + ${Q}mv Makefile Makefile.bak + ${Q}${SED} -n '1,/^# DO NOT DELETE THIS LINE/p' Makefile.bak > Makefile + ${Q}echo "" >> Makefile + ${Q}${SED} -n '3,$$p' skel/makedep.out | ${SORT} -u >> Makefile + -${Q}rm -rf skel + ${Q}echo new Makefile formed + +## +# +# File distribution list generation. You can ignore this section. +# +# We will form the names of source files as if they were in a +# sub-directory called calc. +# +## + +distlist: ${DISTLIST} + ${Q}(for i in ${DISTLIST}; do \ + echo calc/$$i; \ + done; \ + (cd help; ${MAKE} distlist \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} SORT=${SORT}); \ + (cd lib; ${MAKE} distlist \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} SORT=${SORT}) ) | ${SORT} + +# The bsdi distribution has generated files as well as distributed files. +# The the .h files are placed under calc/gen_h. +# +bsdilist: ${DISTLIST} ${BUILD_H_SRC} calc.1 + ${Q}(for i in ${DISTLIST}; do \ + echo calc/$$i; \ + done; \ + for i in ${BUILD_H_SRC}; do \ + echo calc/gen_h/$$i; \ + done; \ + echo calc/calc.1; \ + (cd help; ${MAKE} bsdilist \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} SORT=${SORT}); \ + (cd lib; ${MAKE} bsdilist \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} SORT=${SORT}) ) | ${SORT} + +## +# +# debug +# +# make env: +# * print major makefile variables +# +# make mkdebug: +# * print major makefile variables +# * build anything not yet built +# +# make debug: +# * remove everything that was previously built +# * print major makefile variables +# * make everything +# * run the regression tests +## + +env: + @echo '=-=-=-=-= dumping major make variables =-=-=-=-=' + @echo "TERMCONTROL=${TERMCONTROL}"; echo "" + @echo "HAVE_VSPRINTF=${HAVE_VSPRINTF}"; echo "" + @echo "BYTE_ORDER=${BYTE_ORDER}"; echo "" + @echo "LONG_BITS=${LONG_BITS}"; echo "" + @echo "LONGLONG_BITS=${LONGLONG_BITS}"; echo "" + @echo "HAVE_FPOS=${HAVE_FPOS}"; echo "" + @echo "HAVE_CONST=${HAVE_CONST}"; echo "" + @echo "HAVE_UID_T=${HAVE_UID_T}"; echo "" + @echo "HAVE_NEWSTR=${HAVE_NEWSTR}"; echo "" + @echo "ALIGN32=${ALIGN32}"; echo "" + @echo "BINDIR=${BINDIR}"; echo "" + @echo "TOPDIR=${TOPDIR}"; echo "" + @echo "LIBDIR=${LIBDIR}"; echo "" + @echo "HELPDIR=${HELPDIR}"; echo "" + @echo "MANDIR=${MANDIR}"; echo "" + @echo "CATDIR=${CATDIR}"; echo "" + @echo "MANEXT=${MANEXT}"; echo "" + @echo "CATEXT=${CATEXT}"; echo "" + @echo "NROFF=${NROFF}"; echo "" + @echo "NROFF_ARG=${NROFF_ARG}"; echo "" + @echo "MANMAKE=${MANMAKE}"; echo "" + @echo "CALCPATH=${CALCPATH}"; echo "" + @echo "CALCRC=${CALCRC}"; echo "" + @echo "CALCBINDINGS=${CALCBINDINGS}"; echo "" + @echo "CALCPAGER=${CALCPAGER}"; echo "" + @echo "DEBUG=${DEBUG}"; echo "" + @echo "NO_SHARED=${NO_SHARED}"; echo "" + @echo "LD_NO_SHARED=${LD_NO_SHARED}"; echo "" + @echo "RANLIB=${RANLIB}"; echo "" + @echo "LINTLIB=${LINTLIB}"; echo "" + @echo "LINTFLAGS=${LINTFLAGS}"; echo "" + @echo "MAKE_FILE=${MAKE_FILE}"; echo "" + @echo "CCMAIN=${CCMAIN}"; echo "" + @echo "CCWARN=${CCWARN}"; echo "" + @echo "CCOPT=${CCOPT}"; echo "" + @echo "CCMISC=${CCMISC}"; echo "" + @echo "CCSHS=${CCSHS}"; echo "" + @echo "CFLAGS=${CFLAGS}"; echo "" + @echo "CNOWARN=${CNOWARN}"; echo "" + @echo "ICFLAGS=${ICFLAGS}"; echo "" + @echo "LCFLAGS=${LCFLAGS}"; echo "" + @echo "LDFLAGS=${LDFLAGS}"; echo "" + @echo "ILDFLAGS=${ILDFLAGS}"; echo "" + @echo "CC=${CC}"; echo "" + @echo "SHELL=${SHELL}"; echo "" + @echo "MAKE=${MAKE}"; echo "" + @echo "AWK=${AWK}"; echo "" + @echo "SED=${SED}"; echo "" + @echo "SORT=${SORT}"; echo "" + @echo "TEE=${TEE}"; echo "" + @echo "LINT=${LINT}"; echo "" + @echo "CTAGS=${CTAGS}"; echo "" + @echo "MAKEDEPEND=${MAKEDEPEND}"; echo "" + @echo "Q=${Q}"; echo "" + @echo "V=${V}"; echo "" + @echo "LIBSRC=${LIBSRC}"; echo "" + @echo "LIBOBJS=${LIBOBJS}"; echo "" + @echo "CALCSRC=${CALCSRC}"; echo "" + @echo "CALCOBJS=${CALCOBJS}"; echo "" + @echo "BUILD_H_SRC=${BUILD_H_SRC}"; echo "" + @echo "BUILD_C_SRC=${BUILD_C_SRC}"; echo "" + @echo "UTIL_C_SRC=${UTIL_C_SRC}"; echo "" + @echo "UTIL_MISC_SRC=${UTIL_MISC_SRC}"; echo "" + @echo "UTIL_OBJS=${UTIL_OBJS}"; echo "" + @echo "UTIL_TMP=${UTIL_TMP}"; echo "" + @echo "UTIL_PROGS=${UTIL_PROGS}"; echo "" + @echo "LIB_H_SRC=${LIB_H_SRC}"; echo "" + @echo "CALC_H_SRC=${CALC_H_SRC}"; echo "" + @echo "H_SRC=${H_SRC}"; echo "" + @echo "C_SRC=${C_SRC}"; echo "" + @echo "DISTLIST=${DISTLIST}"; echo "" + @echo "OBJS=${OBJS}"; echo "" + @echo "PROGS=${PROGS}"; echo "" + @echo "TARGETS=${TARGETS}"; echo "" + @echo '=-=-=-=-= end of major make variable dump =-=-=-=-=' + +mkdebug: env version.c + @echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + @echo '=-=-=-=-= Determining the source version =-=-=-=-=' + @${SED} -n '/^#[ ]*define/p' version.c + @echo '=-=-=-=-= Invoking ${MAKE} -f Makefile Q= V=@ all =-=-=-=-=' + @${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} Q= V=@ all + @echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + @echo '=-=-=-=-= Determining the binary version =-=-=-=-=' + -@./calc -v + @echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + @echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +debug: env + @echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + @echo '=-=-=-=-= Invoking ${MAKE} -f Makefile Q= V=@ clobber =-=-=-=-=' + @${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} Q= V=@ clobber + @echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + @echo '=-=-=-=-= Determining the source version =-=-=-=-=' + @${SED} -n '/^#[ ]*define/p' version.c + @echo '=-=-=-=-= Invoking ${MAKE} -f Makefile Q= V=@ all =-=-=-=-=' + @${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} Q= V=@ all + @echo '=-=-=-=-= Determining the binary version =-=-=-=-=' + -@./calc -v + @echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + @echo '=-=-=-=-= Invoking ${MAKE} -f Makefile Q= V=@ chk =-=-=-=-=' + @echo '=-=-=-=-= this may take a while =-=-=-=-=' + @${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} Q= V=@ chk + @echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + @echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +## +# +# Utility rules +# +## + +tags: ${CALCSRC} ${LIBSRC} ${H_SRC} ${BUILD_H_SRC} ${MAKE_FILE} + ${CTAGS} ${CALCSRC} ${LIBSRC} ${H_SRC} ${BUILD_H_SRC} + +lintclean: + -rm -f llib-lcalc.ln llib.out lint.out + +clean: + ${V} echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + -rm -f ${LIBOBJS} + -rm -f ${CALCOBJS} + -rm -f ${UTIL_OBJS} + -rm -f ${UTIL_TMP} + -rm -f ${UTIL_PROGS} + ${Q}echo '=-=-=-=-= Invoking $@ rule for help =-=-=-=-=' + -cd help; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} clean + ${Q}echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + ${Q}echo '=-=-=-=-= Invoking $@ rule for lib =-=-=-=-=' + -cd lib; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} clean + ${Q}echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + -rm -f funclist.o funclist.c + ${Q}echo remove files that are obsolete + -rm -f endian.h stdarg.h libcalcerr.a lib/obj help/obj + -rm -f have_vs.c std_arg.h try_stdarg.c fnvhash.c + ${V} echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +clobber: lintclean + ${V} echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + -rm -f ${LIBOBJS} + -rm -f ${CALCOBJS} + -rm -f ${UTIL_OBJS} + -rm -f ${UTIL_TMP} + -rm -f ${UTIL_PROGS} + -rm -f tags + -rm -f ${BUILD_H_SRC} + -rm -f ${BUILD_C_SRC} + -rm -f calc *_pure_*.[oa] + -rm -f libcalc.a *.pure_hardlink + -rm -f calc.1 *.pure_linkinfo + -rm -f have_args *.u + -rm -f calc.pixie calc.rf calc.Counts calc.cord + -rm -rf gen_h skel Makefile.bak + ${V} echo '=-=-=-=-= Invoking $@ rule for help =-=-=-=-=' + -cd help;${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} clobber + ${V} echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + ${V} echo '=-=-=-=-= Invoking $@ rule for lib =-=-=-=-=' + -cd lib; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} clobber + ${V} echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + ${V} echo remove files that are obsolete + -rm -f endian.h stdarg.h libcalcerr.a lib/obj help/obj + -rm -f have_vs.c std_arg.h try_stdarg.c fnvhash.c + ${V} echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +install: calc libcalc.a ${LIB_H_SRC} ${BUILD_H_SRC} calc.1 + ${V} echo '=-=-=-=-= start of $@ rule =-=-=-=-=' + -${Q}if [ ! -d ${TOPDIR} ]; then \ + echo mkdir ${TOPDIR}; \ + mkdir ${TOPDIR}; \ + else \ + true; \ + fi + -chmod 0755 ${TOPDIR} + -${Q}if [ ! -d ${LIBDIR} ]; then \ + echo mkdir ${LIBDIR}; \ + mkdir ${LIBDIR}; \ + else \ + true; \ + fi + -chmod 0755 ${LIBDIR} + -${Q}if [ ! -d ${HELPDIR} ]; then \ + echo mkdir ${HELPDIR}; \ + mkdir ${HELPDIR}; \ + else \ + true; \ + fi + -chmod 0755 ${HELPDIR} + -${Q}if [ ! -d ${BINDIR} ]; then \ + echo mkdir ${BINDIR}; \ + mkdir ${BINDIR}; \ + else \ + true; \ + fi + -chmod 0755 ${BINDIR} + -rm -f ${BINDIR}/calc + cp calc ${BINDIR} + -chmod 0555 ${BINDIR}/calc + ${V} echo '=-=-=-=-= Invoking $@ rule for help =-=-=-=-=' + cd help; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} install + ${V} echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + ${V} echo '=-=-=-=-= Invoking $@ rule for lib =-=-=-=-=' + cd lib; ${MAKE} -f Makefile \ + MAKE_FILE=${MAKE_FILE} TOPDIR=${TOPDIR} LIBDIR=${LIBDIR} \ + HELPDIR=${HELPDIR} install + ${V} echo '=-=-=-=-= Back to the main Makefile for $@ rule =-=-=-=-=' + -rm -f ${LIBDIR}/libcalc.a + cp libcalc.a ${LIBDIR}/libcalc.a + -chmod 0644 ${LIBDIR}/libcalc.a + ${RANLIB} ${LIBDIR}/libcalc.a + -${Q}for i in ${LIB_H_SRC} ${BUILD_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 + ${Q}: If lint was made, install the lint library. + -${Q}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; \ + else \ + true; \ + fi + -${Q}if [ -z "${MANDIR}" ]; then \ + echo '$${MANDIR} is empty, calc man page will not be installed'; \ + 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 + -${Q}if [ -z "${CATDIR}" ]; then \ + echo '$${CATDIR} is empty, calc cat page will not be installed'; \ + else \ + if [ -z "${NROFF}" ]; then \ + echo "${MANMAKE} calc.1 ${CATDIR}"; \ + ${MANMAKE} calc.1 ${CATDIR}; \ + 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 ${MANMODE} ${MANDIR}/calc.${MANEXT}"; \ + chmod ${MANMODE} ${MANDIR}/calc.${MANEXT}; \ + fi; \ + fi + ${Q}echo remove files that are obsolete + -rm -f ${LIBDIR}/endian.h endian.h + -rm -f ${LIBDIR}/stdarg.h stdarg.h + -rm -f ${LIBDIR}/prototype.h prototype.h + -rm -f ${LIBDIR}/libcalcerr.a libcalcerr.a + ${V} echo '=-=-=-=-= end of $@ rule =-=-=-=-=' + +## +# +# make depend stuff +# +## + +# DO NOT DELETE THIS LINE -- make depend depends on it. + +addop.o: addop.c +addop.o: alloc.h +addop.o: byteswap.h +addop.o: calc.h +addop.o: calcerr.h +addop.o: cmath.h +addop.o: config.h +addop.o: endian_calc.h +addop.o: func.h +addop.o: hash.h +addop.o: have_malloc.h +addop.o: have_newstr.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: shs.h +addop.o: string.h +addop.o: symbol.h +addop.o: token.h +addop.o: value.h +addop.o: zmath.h +align32.o: align32.c +align32.o: have_unistd.h +align32.o: longbits.h +assocfunc.o: alloc.h +assocfunc.o: assocfunc.c +assocfunc.o: byteswap.h +assocfunc.o: calcerr.h +assocfunc.o: cmath.h +assocfunc.o: config.h +assocfunc.o: endian_calc.h +assocfunc.o: hash.h +assocfunc.o: have_malloc.h +assocfunc.o: have_newstr.h +assocfunc.o: have_stdlib.h +assocfunc.o: have_string.h +assocfunc.o: longbits.h +assocfunc.o: qmath.h +assocfunc.o: shs.h +assocfunc.o: value.h +assocfunc.o: zmath.h +byteswap.o: alloc.h +byteswap.o: byteswap.c +byteswap.o: byteswap.h +byteswap.o: cmath.h +byteswap.o: endian_calc.h +byteswap.o: have_malloc.h +byteswap.o: have_newstr.h +byteswap.o: have_stdlib.h +byteswap.o: have_string.h +byteswap.o: longbits.h +byteswap.o: qmath.h +byteswap.o: zmath.h +calc.o: alloc.h +calc.o: byteswap.h +calc.o: calc.c +calc.o: calc.h +calc.o: calcerr.h +calc.o: cmath.h +calc.o: conf.h +calc.o: config.h +calc.o: endian_calc.h +calc.o: func.h +calc.o: hash.h +calc.o: have_malloc.h +calc.o: have_newstr.h +calc.o: have_stdlib.h +calc.o: have_string.h +calc.o: have_uid_t.h +calc.o: have_unistd.h +calc.o: hist.h +calc.o: label.h +calc.o: longbits.h +calc.o: opcodes.h +calc.o: qmath.h +calc.o: shs.h +calc.o: symbol.h +calc.o: token.h +calc.o: value.h +calc.o: zmath.h +calcerr.o: calcerr.c +calcerr.o: calcerr.h +calcerr.o: have_const.h +codegen.o: alloc.h +codegen.o: byteswap.h +codegen.o: calc.h +codegen.o: calcerr.h +codegen.o: cmath.h +codegen.o: codegen.c +codegen.o: conf.h +codegen.o: config.h +codegen.o: endian_calc.h +codegen.o: func.h +codegen.o: hash.h +codegen.o: have_malloc.h +codegen.o: have_newstr.h +codegen.o: have_stdlib.h +codegen.o: have_string.h +codegen.o: have_unistd.h +codegen.o: label.h +codegen.o: longbits.h +codegen.o: opcodes.h +codegen.o: qmath.h +codegen.o: shs.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: byteswap.h +comfunc.o: cmath.h +comfunc.o: comfunc.c +comfunc.o: config.h +comfunc.o: endian_calc.h +comfunc.o: have_malloc.h +comfunc.o: have_newstr.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: byteswap.h +commath.o: cmath.h +commath.o: commath.c +commath.o: endian_calc.h +commath.o: have_malloc.h +commath.o: have_newstr.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: byteswap.h +config.o: calc.h +config.o: calcerr.h +config.o: cmath.h +config.o: config.c +config.o: config.h +config.o: endian_calc.h +config.o: hash.h +config.o: have_const.h +config.o: have_malloc.h +config.o: have_newstr.h +config.o: have_stdlib.h +config.o: have_string.h +config.o: longbits.h +config.o: qmath.h +config.o: shs.h +config.o: token.h +config.o: value.h +config.o: zmath.h +config.o: zrand.h +const.o: alloc.h +const.o: byteswap.h +const.o: calc.h +const.o: calcerr.h +const.o: cmath.h +const.o: config.h +const.o: const.c +const.o: endian_calc.h +const.o: hash.h +const.o: have_malloc.h +const.o: have_newstr.h +const.o: have_stdlib.h +const.o: have_string.h +const.o: longbits.h +const.o: qmath.h +const.o: shs.h +const.o: value.h +const.o: zmath.h +endian.o: endian.c +endian.o: have_unistd.h +file.o: alloc.h +file.o: byteswap.h +file.o: calc.h +file.o: calcerr.h +file.o: cmath.h +file.o: config.h +file.o: endian_calc.h +file.o: file.c +file.o: file.h +file.o: fposval.h +file.o: hash.h +file.o: have_fpos.h +file.o: have_malloc.h +file.o: have_newstr.h +file.o: have_stdlib.h +file.o: have_string.h +file.o: longbits.h +file.o: qmath.h +file.o: shs.h +file.o: value.h +file.o: zmath.h +fposval.o: endian_calc.h +fposval.o: fposval.c +fposval.o: have_fpos.h +func.o: alloc.h +func.o: byteswap.h +func.o: calc.h +func.o: calcerr.h +func.o: cmath.h +func.o: config.h +func.o: endian_calc.h +func.o: file.h +func.o: func.c +func.o: func.h +func.o: hash.h +func.o: have_const.h +func.o: have_fpos.h +func.o: have_malloc.h +func.o: have_newstr.h +func.o: have_stdlib.h +func.o: have_string.h +func.o: have_times.h +func.o: have_unistd.h +func.o: label.h +func.o: longbits.h +func.o: opcodes.h +func.o: prime.h +func.o: qmath.h +func.o: shs.h +func.o: string.h +func.o: symbol.h +func.o: token.h +func.o: value.h +func.o: zmath.h +func.o: zrand.h +hash.o: alloc.h +hash.o: byteswap.h +hash.o: calcerr.h +hash.o: cmath.h +hash.o: config.h +hash.o: endian_calc.h +hash.o: hash.c +hash.o: hash.h +hash.o: have_malloc.h +hash.o: have_newstr.h +hash.o: have_stdlib.h +hash.o: have_string.h +hash.o: longbits.h +hash.o: qmath.h +hash.o: shs.h +hash.o: value.h +hash.o: zmath.h +have_const.o: have_const.c +have_fpos.o: have_fpos.c +have_newstr.o: have_newstr.c +have_stdvs.o: have_stdvs.c +have_stdvs.o: have_string.h +have_stdvs.o: have_unistd.h +have_uid_t.o: have_uid_t.c +have_uid_t.o: have_unistd.h +have_varvs.o: have_string.h +have_varvs.o: have_unistd.h +have_varvs.o: have_varvs.c +hist.o: alloc.h +hist.o: byteswap.h +hist.o: calc.h +hist.o: calcerr.h +hist.o: cmath.h +hist.o: config.h +hist.o: endian_calc.h +hist.o: hash.h +hist.o: have_malloc.h +hist.o: have_newstr.h +hist.o: have_stdlib.h +hist.o: have_string.h +hist.o: have_unistd.h +hist.o: hist.c +hist.o: hist.h +hist.o: longbits.h +hist.o: qmath.h +hist.o: shs.h +hist.o: terminal.h +hist.o: value.h +hist.o: zmath.h +input.o: alloc.h +input.o: byteswap.h +input.o: calc.h +input.o: calcerr.h +input.o: cmath.h +input.o: conf.h +input.o: config.h +input.o: endian_calc.h +input.o: hash.h +input.o: have_malloc.h +input.o: have_newstr.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: shs.h +input.o: value.h +input.o: zmath.h +jump.o: have_const.h +jump.o: jump.c +jump.o: jump.h +label.o: alloc.h +label.o: byteswap.h +label.o: calc.h +label.o: calcerr.h +label.o: cmath.h +label.o: config.h +label.o: endian_calc.h +label.o: func.h +label.o: hash.h +label.o: have_malloc.h +label.o: have_newstr.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: shs.h +label.o: string.h +label.o: token.h +label.o: value.h +label.o: zmath.h +lib_calc.o: alloc.h +lib_calc.o: byteswap.h +lib_calc.o: calc.h +lib_calc.o: calcerr.h +lib_calc.o: cmath.h +lib_calc.o: config.h +lib_calc.o: endian_calc.h +lib_calc.o: hash.h +lib_calc.o: have_malloc.h +lib_calc.o: have_newstr.h +lib_calc.o: have_stdlib.h +lib_calc.o: have_string.h +lib_calc.o: lib_calc.c +lib_calc.o: longbits.h +lib_calc.o: qmath.h +lib_calc.o: shs.h +lib_calc.o: value.h +lib_calc.o: zmath.h +listfunc.o: alloc.h +listfunc.o: byteswap.h +listfunc.o: calcerr.h +listfunc.o: cmath.h +listfunc.o: config.h +listfunc.o: endian_calc.h +listfunc.o: hash.h +listfunc.o: have_const.h +listfunc.o: have_malloc.h +listfunc.o: have_newstr.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: shs.h +listfunc.o: value.h +listfunc.o: zmath.h +listfunc.o: zrand.h +longbits.o: have_unistd.h +longbits.o: longbits.c +longbits.o: longlong.h +longlong.o: have_stdlib.h +longlong.o: have_string.h +longlong.o: longlong.c +matfunc.o: alloc.h +matfunc.o: byteswap.h +matfunc.o: calcerr.h +matfunc.o: cmath.h +matfunc.o: config.h +matfunc.o: endian_calc.h +matfunc.o: hash.h +matfunc.o: have_const.h +matfunc.o: have_malloc.h +matfunc.o: have_newstr.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: shs.h +matfunc.o: value.h +matfunc.o: zmath.h +matfunc.o: zrand.h +math_error.o: alloc.h +math_error.o: args.h +math_error.o: byteswap.h +math_error.o: calc.h +math_error.o: calcerr.h +math_error.o: cmath.h +math_error.o: config.h +math_error.o: endian_calc.h +math_error.o: hash.h +math_error.o: have_malloc.h +math_error.o: have_newstr.h +math_error.o: have_stdlib.h +math_error.o: have_string.h +math_error.o: longbits.h +math_error.o: math_error.c +math_error.o: qmath.h +math_error.o: shs.h +math_error.o: value.h +math_error.o: zmath.h +obj.o: alloc.h +obj.o: byteswap.h +obj.o: calc.h +obj.o: calcerr.h +obj.o: cmath.h +obj.o: config.h +obj.o: endian_calc.h +obj.o: func.h +obj.o: hash.h +obj.o: have_malloc.h +obj.o: have_newstr.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: shs.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: byteswap.h +opcodes.o: calc.h +opcodes.o: calcerr.h +opcodes.o: cmath.h +opcodes.o: config.h +opcodes.o: endian_calc.h +opcodes.o: file.h +opcodes.o: func.h +opcodes.o: hash.h +opcodes.o: have_const.h +opcodes.o: have_fpos.h +opcodes.o: have_malloc.h +opcodes.o: have_newstr.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: shs.h +opcodes.o: symbol.h +opcodes.o: value.h +opcodes.o: zmath.h +opcodes.o: zrand.h +pix.o: alloc.h +pix.o: byteswap.h +pix.o: endian_calc.h +pix.o: have_const.h +pix.o: have_malloc.h +pix.o: have_newstr.h +pix.o: have_stdlib.h +pix.o: have_string.h +pix.o: longbits.h +pix.o: pix.c +pix.o: prime.h +pix.o: qmath.h +pix.o: zmath.h +poly.o: alloc.h +poly.o: byteswap.h +poly.o: calcerr.h +poly.o: cmath.h +poly.o: config.h +poly.o: endian_calc.h +poly.o: hash.h +poly.o: have_malloc.h +poly.o: have_newstr.h +poly.o: have_stdlib.h +poly.o: have_string.h +poly.o: longbits.h +poly.o: poly.c +poly.o: qmath.h +poly.o: shs.h +poly.o: value.h +poly.o: zmath.h +prime.o: alloc.h +prime.o: byteswap.h +prime.o: endian_calc.h +prime.o: have_const.h +prime.o: have_malloc.h +prime.o: have_newstr.h +prime.o: have_stdlib.h +prime.o: have_string.h +prime.o: jump.h +prime.o: longbits.h +prime.o: prime.c +prime.o: prime.h +prime.o: qmath.h +prime.o: zmath.h +qfunc.o: alloc.h +qfunc.o: byteswap.h +qfunc.o: config.h +qfunc.o: endian_calc.h +qfunc.o: have_const.h +qfunc.o: have_malloc.h +qfunc.o: have_newstr.h +qfunc.o: have_stdlib.h +qfunc.o: have_string.h +qfunc.o: longbits.h +qfunc.o: prime.h +qfunc.o: qfunc.c +qfunc.o: qmath.h +qfunc.o: zmath.h +qio.o: alloc.h +qio.o: args.h +qio.o: byteswap.h +qio.o: config.h +qio.o: endian_calc.h +qio.o: have_malloc.h +qio.o: have_newstr.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: zmath.h +qmath.o: alloc.h +qmath.o: byteswap.h +qmath.o: config.h +qmath.o: endian_calc.h +qmath.o: have_malloc.h +qmath.o: have_newstr.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: byteswap.h +qmod.o: config.h +qmod.o: endian_calc.h +qmod.o: have_malloc.h +qmod.o: have_newstr.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: byteswap.h +qtrans.o: endian_calc.h +qtrans.o: have_malloc.h +qtrans.o: have_newstr.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 +quickhash.o: alloc.h +quickhash.o: byteswap.h +quickhash.o: calcerr.h +quickhash.o: cmath.h +quickhash.o: config.h +quickhash.o: endian_calc.h +quickhash.o: hash.h +quickhash.o: have_const.h +quickhash.o: have_malloc.h +quickhash.o: have_newstr.h +quickhash.o: have_stdlib.h +quickhash.o: have_string.h +quickhash.o: longbits.h +quickhash.o: qmath.h +quickhash.o: quickhash.c +quickhash.o: shs.h +quickhash.o: value.h +quickhash.o: zmath.h +quickhash.o: zrand.h +shs.o: align32.h +shs.o: alloc.h +shs.o: byteswap.h +shs.o: calc.h +shs.o: calcerr.h +shs.o: cmath.h +shs.o: config.h +shs.o: endian_calc.h +shs.o: hash.h +shs.o: have_const.h +shs.o: have_malloc.h +shs.o: have_newstr.h +shs.o: have_stdlib.h +shs.o: have_string.h +shs.o: longbits.h +shs.o: qmath.h +shs.o: shs.c +shs.o: shs.h +shs.o: value.h +shs.o: zmath.h +shs.o: zrand.h +string.o: alloc.h +string.o: byteswap.h +string.o: calc.h +string.o: calcerr.h +string.o: cmath.h +string.o: config.h +string.o: endian_calc.h +string.o: hash.h +string.o: have_malloc.h +string.o: have_newstr.h +string.o: have_stdlib.h +string.o: have_string.h +string.o: longbits.h +string.o: qmath.h +string.o: shs.h +string.o: string.c +string.o: string.h +string.o: value.h +string.o: zmath.h +symbol.o: alloc.h +symbol.o: byteswap.h +symbol.o: calc.h +symbol.o: calcerr.h +symbol.o: cmath.h +symbol.o: config.h +symbol.o: endian_calc.h +symbol.o: func.h +symbol.o: hash.h +symbol.o: have_malloc.h +symbol.o: have_newstr.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: shs.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: byteswap.h +token.o: calc.h +token.o: calcerr.h +token.o: cmath.h +token.o: config.h +token.o: endian_calc.h +token.o: hash.h +token.o: have_malloc.h +token.o: have_newstr.h +token.o: have_stdlib.h +token.o: have_string.h +token.o: longbits.h +token.o: qmath.h +token.o: shs.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: byteswap.h +value.o: calc.h +value.o: calcerr.h +value.o: cmath.h +value.o: config.h +value.o: endian_calc.h +value.o: func.h +value.o: hash.h +value.o: have_const.h +value.o: have_malloc.h +value.o: have_newstr.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: shs.h +value.o: string.h +value.o: symbol.h +value.o: value.c +value.o: value.h +value.o: zmath.h +value.o: zrand.h +version.o: alloc.h +version.o: byteswap.h +version.o: calc.h +version.o: calcerr.h +version.o: cmath.h +version.o: config.h +version.o: endian_calc.h +version.o: hash.h +version.o: have_malloc.h +version.o: have_newstr.h +version.o: have_stdlib.h +version.o: have_string.h +version.o: longbits.h +version.o: qmath.h +version.o: shs.h +version.o: value.h +version.o: version.c +version.o: zmath.h +zfunc.o: alloc.h +zfunc.o: byteswap.h +zfunc.o: endian_calc.h +zfunc.o: have_malloc.h +zfunc.o: have_newstr.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: byteswap.h +zio.o: config.h +zio.o: endian_calc.h +zio.o: have_malloc.h +zio.o: have_newstr.h +zio.o: have_stdlib.h +zio.o: have_string.h +zio.o: longbits.h +zio.o: qmath.h +zio.o: zio.c +zio.o: zmath.h +zmath.o: alloc.h +zmath.o: byteswap.h +zmath.o: endian_calc.h +zmath.o: have_malloc.h +zmath.o: have_newstr.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: byteswap.h +zmod.o: config.h +zmod.o: endian_calc.h +zmod.o: have_malloc.h +zmod.o: have_newstr.h +zmod.o: have_stdlib.h +zmod.o: have_string.h +zmod.o: longbits.h +zmod.o: qmath.h +zmod.o: zmath.h +zmod.o: zmod.c +zmul.o: alloc.h +zmul.o: byteswap.h +zmul.o: config.h +zmul.o: endian_calc.h +zmul.o: have_malloc.h +zmul.o: have_newstr.h +zmul.o: have_stdlib.h +zmul.o: have_string.h +zmul.o: longbits.h +zmul.o: qmath.h +zmul.o: zmath.h +zmul.o: zmul.c +zprime.o: alloc.h +zprime.o: byteswap.h +zprime.o: calcerr.h +zprime.o: cmath.h +zprime.o: config.h +zprime.o: endian_calc.h +zprime.o: hash.h +zprime.o: have_const.h +zprime.o: have_malloc.h +zprime.o: have_newstr.h +zprime.o: have_stdlib.h +zprime.o: have_string.h +zprime.o: jump.h +zprime.o: longbits.h +zprime.o: prime.h +zprime.o: qmath.h +zprime.o: shs.h +zprime.o: value.h +zprime.o: zmath.h +zprime.o: zprime.c +zprime.o: zrand.h +zrand.o: alloc.h +zrand.o: byteswap.h +zrand.o: calcerr.h +zrand.o: cmath.h +zrand.o: config.h +zrand.o: endian_calc.h +zrand.o: hash.h +zrand.o: have_const.h +zrand.o: have_malloc.h +zrand.o: have_newstr.h +zrand.o: have_stdlib.h +zrand.o: have_string.h +zrand.o: longbits.h +zrand.o: qmath.h +zrand.o: shs.h +zrand.o: value.h +zrand.o: zmath.h +zrand.o: zrand.c +zrand.o: zrand.h diff --git a/README b/README new file mode 100644 index 0000000..91fc26d --- /dev/null +++ b/README @@ -0,0 +1,68 @@ +# 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 + + ==>>>If you run into problems, follow the instructions in the BUGS file<<<== + +=-= + +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, mis-features and how to report problems + + help/full + full set of calc documentation + +=-= + +David I. Bell dbell@auug.org.au +chongo@toad.com /\../\ diff --git a/README.FIRST b/README.FIRST new file mode 100644 index 0000000..b61ca18 --- /dev/null +++ b/README.FIRST @@ -0,0 +1,52 @@ +Dear alpha tester, + +Thanks for taking the time to try out this alpha version of calc! We are +interested in any/all feedback that you may have on this version. In +particular we would like to hear about: + + * compile problems + * regression test problems (try: make check) + * compiler warnings + * special compile flags/options that you needed + * Makefile problems + * help file problems + * misc nits and typos + +We would like to offer a clean compile across a wide verity of platforms, +so if you can test on several, so much the better! + +Calc distributions may be obtained from: + + ftp://ftp.uu.net/pub/calc + +If you don't have ftp access to that site, or if you do not find a more +recent version (you may have a special pre-released version that is +more advanced than what is in the ftp archive) send EMail to: + + chongo@toad.com + +Indicate the version you have and that you would like a more up +to date version. + +=-= + +Misc items TODO before Beta release: + + * improve the coverage in the 'SEE ALSO' help file lists + + * where reasonable, be sure that regress.cal tests builtin functions + + * add the Blum-Blum-Shub random() generator code + + * add code to allow of the reading, writing and processing of binary data + + * add shs, shs-1 and md5 hashing functions. Use align32.h. + + * add mod h*2^n+/-1 function for integers + + * be sure that CHANGES is up to date, + look over the help/todo file and update as needed, + revisit issues in the BUGS file and + change this file :-) + + * clean the source code and document it better diff --git a/addop.c b/addop.c new file mode 100644 index 0000000..6ea7a49 --- /dev/null +++ b/addop.c @@ -0,0 +1,448 @@ +/* + * Copyright (c) 1995 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 */ + + +/* + * Initialize the table of user defined functions. + */ +void +initfunctions(void) +{ + initstr(&funcnames); + maxopcodes = OPCODEALLOCSIZE; + functemplate = (FUNC *) malloc(funcsize(maxopcodes)); + if (functemplate == NULL) { + math_error("Cannot allocate function template"); + /*NOTREACHED*/ + } + functions = (FUNC **) malloc(sizeof(FUNC *) * FUNCALLOCSIZE); + if (functions == NULL) { + math_error("Cannot allocate function table"); + /*NOTREACHED*/ + } + funccount = 0; + funcavail = FUNCALLOCSIZE; +} + + +/* + * Show the list of user defined functions. + */ +void +showfunctions(void) +{ + 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. + * + * given: + * name name of function + * newflag TRUE if need new structure + */ +void +beginfunc(char *name, BOOL newflag) +{ + 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"); + /*NOTREACHED*/ + } + } + 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(void) +{ + register FUNC *fp; /* function just finished */ + unsigned 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"); + /*NOTREACHED*/ + } + memcpy((char *) fp, (char *) curfunc, size); + if (curfunc != functemplate) + free(curfunc); + if (conf->traceflags & TRACE_FNCODES) { + dumpnames = TRUE; + for (size = 0; size < fp->f_opcodecount; ) { + printf("%ld: ", (long)size); + size += dumpop(&fp->f_opcodes[size]); + } + } + if (functions[newindex]) { + free(functions[newindex]); + fprintf(stderr, "**** %s() has been redefined\n", fp->f_name); + } + 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. + * + * given: + * name name of function + */ +long +adduserfunc(char *name) +{ + 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"); + /*NOTREACHED*/ + } + funcavail += FUNCALLOCSIZE; + } + if (addstr(&funcnames, name) == NULL) { + math_error("Cannot save function name"); + /*NOTREACHED*/ + } + 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(void) +{ + oldop = OP_NOP; + debugline = 0; +} + + +/* + * Find a function structure given its index. + */ +FUNC * +findfunc(long index) +{ + if ((unsigned long) index >= funccount) { + math_error("Undefined function"); + /*NOTREACHED*/ + } + return functions[index]; +} + + +/* + * Return the name of a function given its index. + */ +char * +namefunc(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(void) +{ + 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(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"); + /*NOTREACHED*/ + } + 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(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 ((conf->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(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(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(long op, long index, int count) +{ + 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. + * + * given: + * label label to be added + */ +void +addoplabel(long op, LABEL *label) +{ + addop(op); + uselabel(label); +} + +/* END CODE */ diff --git a/align32.c b/align32.c new file mode 100644 index 0000000..36c3863 --- /dev/null +++ b/align32.c @@ -0,0 +1,79 @@ +/* + * align32 - determine if 32 bit accesses must be aligned + * + * This file was written by: + * + * Landon Curt Noll (chongo@toad.com) chongo /\../\ + * + * This code has been placed in the public domain. Please do not + * copyright this code. + * + * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO + * THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MER- + * CHANTABILITY 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. + */ + +#include +#include +#include "longbits.h" + +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif + +static void buserr(void); /* catch alignment errors */ + + +MAIN +main(void) +{ + char byte[2*sizeof(USB32)]; /* mis-alignment buffer */ + USB32 *p; /* mis-alignment pointer */ + int i; + +#if defined(MUST_ALIGN32) + /* force alignment */ + printf("#define MUST_ALIGN32\t%c* forced to align 32 bit values *%c\n", + '/', '/'); +#else + /* setup to catch alignment bus errors */ + signal(SIGBUS, buserr); + signal(SIGSEGV, buserr); /* some systems will generate SEGV instead! */ + + /* mis-align our long fetches */ + for (i=0; i < sizeof(USB32); ++i) { + p = (USB32 *)(byte+i); + *p = i; + *p += 1; + } + + /* if we got here, then we can mis-align longs */ + printf("#undef MUST_ALIGN32\t%c* can mis-align 32 bit values *%c\n", + '/', '/'); + +#endif + exit(0); +} + + +/* + * buserr - catch an alignment error + * + * given: + * arg to keep ANSI C happy + */ +/*ARGSUSED*/ +static void +buserr(int arg) +{ + /* alignment is required */ + printf("#define MUST_ALIGN32\t%c* must align 32 bit values *%c\n", + '/', '/'); + exit(0); +} diff --git a/alloc.h b/alloc.h new file mode 100644 index 0000000..a43e620 --- /dev/null +++ b/alloc.h @@ -0,0 +1,64 @@ +/* + * Copyright (c) 1995 David I. Bell + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + */ + + +#if !defined(ALLOC_H) +#define ALLOC_H + +#include "have_malloc.h" +#include "have_newstr.h" +#include "have_string.h" + +#ifdef HAVE_MALLOC_H +# include +#else +# if defined(__STDC__) && __STDC__ != 0 + extern void *malloc(); + extern void *realloc(); + extern void free(); +# else + extern char *malloc(); + extern char *realloc(); + extern void free(); +# endif +#endif + +#ifdef HAVE_STRING_H +# include + +#else + +# if defined(HAVE_NEWSTR) +extern void *memcpy(); +extern void *memset(); +# if defined(__STDC__) && __STDC__ != 0 +extern size_t strlen(); +# else +extern long strlen(); /* should be size_t, but old systems don't have it */ +# endif +# else /* HAVE_NEWSTR */ +extern void bcopy(); +extern void bfill(); +extern char *index(); +# endif /* HAVE_NEWSTR */ +extern char *strchr(); +extern char *strcpy(); +extern char *strncpy(); +extern char *strcat(); +extern int strcmp(); + +#endif + +#if !defined(HAVE_NEWSTR) +#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 /* HAVE_NEWSTR */ + +#endif /* !ALLOC_H */ diff --git a/assocfunc.c b/assocfunc.c new file mode 100644 index 0000000..d3d54ef --- /dev/null +++ b/assocfunc.c @@ -0,0 +1,477 @@ +/* + * Copyright (c) 1995 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(ASSOC *ap, long index); +static BOOL compareindices(VALUE *v1, VALUE *v2, long dim); +static void resize(ASSOC *ap, long newsize); +static void assoc_elemfree(ASSOCELEM *ep); + + +/* + * 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. + * + * given: + * ap association to index into + * create whether to create the index value + * dim dimension of the indexing + * indices table of values being indexed by + */ +VALUE * +associndex(ASSOC *ap, BOOL create, long dim, VALUE *indices) +{ + ASSOCELEM **listhead; + ASSOCELEM *ep; + static VALUE val; + QCKHASH hash; + int i; + + if (dim <= 0) { + math_error("No dimensions for indexing association"); + /*NOTREACHED*/ + } + + /* + * 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 = (QCKHASH)0; + for (i = 0; i < dim; i++) + hash = hashvalue(&indices[i], hash); + + /* + * 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"); + /*NOTREACHED*/ + } + 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(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(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. + * + * given: + * ap association to index into + * index index of desired element + */ +static ASSOCELEM * +elemindex(ASSOC *ap, long index) +{ + 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. + * + * given: + * ap association to index into + * index index of desired element + */ +VALUE * +assocfindex(ASSOC *ap, long index) +{ + 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(ASSOC *ap1, ASSOC *ap2) +{ + ASSOCELEM **table1; + ASSOCELEM *ep1; + ASSOCELEM *ep2; + long size1; + long size2; + QCKHASH 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(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"); + /*NOTREACHED*/ + } + 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(ASSOC *ap, long newsize) +{ + ASSOCELEM **oldtable; + ASSOCELEM **newtable; + ASSOCELEM **oldlist; + ASSOCELEM **newlist; + ASSOCELEM *ep; + int i; + + if (newsize < ap->a_size + GROWHASHSIZE) + return; + + newsize = (long) next_prime((FULL)newsize); + newtable = (ASSOCELEM **) malloc(sizeof(ASSOCELEM *) * newsize); + if (newtable == NULL) { + math_error("No memory to grow association"); + /*NOTREACHED*/ + } + 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(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(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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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(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(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"); +} + + +/* + * Compare two lists of index values to see if they are identical. + * Returns TRUE if they are the same. + */ +static BOOL +compareindices(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; +} + +/* END CODE */ diff --git a/byteswap.c b/byteswap.c new file mode 100644 index 0000000..e55ce70 --- /dev/null +++ b/byteswap.c @@ -0,0 +1,686 @@ +/* + * Copyright (c) 1995 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. + */ + +#include "cmath.h" +#include "byteswap.h" + + +/* + * swap_b8_in_HALFs - swap 8 and if needed, 16 bits in an array of HALFs + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a HALF array to swap + * len - length of the src HALF array + * + * returns: + * pointer to where the swapped src has been put + */ +HALF * +swap_b8_in_HALFs(HALF *dest, HALF *src, LEN len) +{ + LEN i; + + /* + * allocate storage if needed + */ + if (dest == NULL) { + dest = alloc(len); + } + + /* + * swap the array + */ + for (i=0; i < len; ++i, ++dest, ++src) { + SWAP_B8_IN_HALF(dest, src); + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_b8_in_ZVALUE - swap 8 and if needed, 16 bits in a ZVALUE + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a ZVALUE to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a ZVALUE. + */ +ZVALUE * +swap_b8_in_ZVALUE(ZVALUE *dest, ZVALUE *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(ZVALUE)); + if (dest == NULL) { + math_error("swap_b8_in_ZVALUE: swap_b8_in_ZVALUE: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * allocate (by forcing swap_b8_in_ZVALUE) and swap storage + */ + dest->v = swap_b8_in_HALFs(NULL, src->v, src->len); + + } else { + + /* + * swap storage + */ + if (dest->v != NULL) { + zfree(*dest); + } + dest->v = swap_b8_in_HALFs(NULL, src->v, src->len); + } + + /* + * swap or copy the rest of the ZVALUE elements + */ + if (all) { + dest->len = (LEN)SWAP_B8_IN_LEN(&dest->len, &src->len); + dest->sign = (BOOL)SWAP_B8_IN_BOOL(&dest->sign, &src->sign); + } else { + dest->len = src->len; + dest->sign = src->sign; + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_b8_in_NUMBER - swap 8 and if needed, 16 bits in a NUMBER + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a NUMBER to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a NUMBER. + */ +NUMBER * +swap_b8_in_NUMBER(NUMBER *dest, NUMBER *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(NUMBER)); + if (dest == NULL) { + math_error("swap_b8_in_NUMBER: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * allocate (by forcing swap_b8_in_ZVALUE) and swap storage + */ + dest->num = *swap_b8_in_ZVALUE(NULL, &src->num, all); + dest->den = *swap_b8_in_ZVALUE(NULL, &src->den, all); + + } else { + + /* + * swap storage + */ + dest->num = *swap_b8_in_ZVALUE(&dest->num, &src->num, all); + dest->den = *swap_b8_in_ZVALUE(&dest->den, &src->den, all); + } + + /* + * swap or copy the rest of the NUMBER elements + */ + if (all) { + dest->links = (long)SWAP_B8_IN_LONG(&dest->links, &src->links); + } else { + dest->links = src->links; + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_b8_in_COMPLEX - swap 8 and if needed, 16 bits in a COMPLEX + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a COMPLEX to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a COMPLEX. + */ +COMPLEX * +swap_b8_in_COMPLEX(COMPLEX *dest, COMPLEX *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(COMPLEX)); + if (dest == NULL) { + math_error("swap_b8_in_COMPLEX: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * allocate (by forcing swap_b8_in_ZVALUE) and swap storage + */ + dest->real = swap_b8_in_NUMBER(NULL, src->real, all); + dest->imag = swap_b8_in_NUMBER(NULL, src->imag, all); + + } else { + + /* + * swap storage + */ + dest->real = swap_b8_in_NUMBER(dest->real, src->real, all); + dest->imag = swap_b8_in_NUMBER(dest->imag, src->imag, all); + } + + /* + * swap or copy the rest of the NUMBER elements + */ + if (all) { + dest->links = (long)SWAP_B8_IN_LONG(&dest->links, &src->links); + } else { + dest->links = src->links; + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_b16_in_HALFs - swap 16 bits in an array of HALFs + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a HALF array to swap + * len - length of the src HALF array + * + * returns: + * pointer to where the swapped src has been put + */ +HALF * +swap_b16_in_HALFs(HALF *dest, HALF *src, LEN len) +{ + LEN i; + + /* + * allocate storage if needed + */ + if (dest == NULL) { + dest = alloc(len); + } + + /* + * swap the array + */ + for (i=0; i < len; ++i, ++dest, ++src) { + SWAP_B16_IN_HALF(dest, src); + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_b16_in_ZVALUE - swap 16 bits in a ZVALUE + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a ZVALUE to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a ZVALUE. + */ +ZVALUE * +swap_b16_in_ZVALUE(ZVALUE *dest, ZVALUE *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(ZVALUE)); + if (dest == NULL) { + math_error("swap_b16_in_ZVALUE: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * allocate (by forcing swap_b16_in_ZVALUE) and swap storage + */ + dest->v = swap_b16_in_HALFs(NULL, src->v, src->len); + + } else { + + /* + * swap storage + */ + if (dest->v != NULL) { + zfree(*dest); + } + dest->v = swap_b16_in_HALFs(NULL, src->v, src->len); + } + + /* + * swap or copy the rest of the ZVALUE elements + */ + if (all) { + dest->len = (LEN)SWAP_B16_IN_LEN(&dest->len, &src->len); + dest->sign = (BOOL)SWAP_B16_IN_BOOL(&dest->sign, &src->sign); + } else { + dest->len = src->len; + dest->sign = src->sign; + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_b16_in_NUMBER - swap 16 bits in a NUMBER + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a NUMBER to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a NUMBER. + */ +NUMBER * +swap_b16_in_NUMBER(NUMBER *dest, NUMBER *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(NUMBER)); + if (dest == NULL) { + math_error("swap_b16_in_NUMBER: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * allocate (by forcing swap_b16_in_ZVALUE) and swap storage + */ + dest->num = *swap_b16_in_ZVALUE(NULL, &src->num, all); + dest->den = *swap_b16_in_ZVALUE(NULL, &src->den, all); + + } else { + + /* + * swap storage + */ + dest->num = *swap_b16_in_ZVALUE(&dest->num, &src->num, all); + dest->den = *swap_b16_in_ZVALUE(&dest->den, &src->den, all); + } + + /* + * swap or copy the rest of the NUMBER elements + */ + if (all) { + dest->links = (long)SWAP_B16_IN_LONG(&dest->links, &src->links); + } else { + dest->links = src->links; + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_b16_in_COMPLEX - swap 16 bits in a COMPLEX + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a COMPLEX to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a COMPLEX. + */ +COMPLEX * +swap_b16_in_COMPLEX(COMPLEX *dest, COMPLEX *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(COMPLEX)); + if (dest == NULL) { + math_error("swap_b16_in_COMPLEX: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * allocate (by forcing swap_b16_in_ZVALUE) and swap storage + */ + dest->real = swap_b16_in_NUMBER(NULL, src->real, all); + dest->imag = swap_b16_in_NUMBER(NULL, src->imag, all); + + } else { + + /* + * swap storage + */ + dest->real = swap_b16_in_NUMBER(dest->real, src->real, all); + dest->imag = swap_b16_in_NUMBER(dest->imag, src->imag, all); + } + + /* + * swap or copy the rest of the NUMBER elements + */ + if (all) { + dest->links = (long)SWAP_B16_IN_LONG(&dest->links, &src->links); + } else { + dest->links = src->links; + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_HALF_in_ZVALUE - swap HALFs in a ZVALUE + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a ZVALUE to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a ZVALUE. + */ +ZVALUE * +swap_HALF_in_ZVALUE(ZVALUE *dest, ZVALUE *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(ZVALUE)); + if (dest == NULL) { + math_error("swap_HALF_in_ZVALUE: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * copy storage because we are dealing with HALFs + */ + dest->v = (HALF *) zcopyval(*src, *dest); + + } else { + + /* + * copy storage because we are dealing with HALFs + */ + if (dest->v != NULL) { + zfree(*dest); + dest->v = alloc(src->len); + } + zcopyval(*src, *dest); + } + + /* + * swap or copy the rest of the ZVALUE elements + */ + if (all) { + dest->len = (LEN)SWAP_HALF_IN_LEN(&dest->len, &src->len); + dest->sign = (BOOL)SWAP_HALF_IN_BOOL(&dest->sign, &src->sign); + } else { + dest->len = src->len; + dest->sign = src->sign; + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_HALF_in_NUMBER - swap HALFs in a NUMBER + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a NUMBER to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a NUMBER. + */ +NUMBER * +swap_HALF_in_NUMBER(NUMBER *dest, NUMBER *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(NUMBER)); + if (dest == NULL) { + math_error("swap_HALF_in_NUMBER: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * allocate (by forcing swap_HALF_in_ZVALUE) and swap storage + */ + dest->num = *swap_HALF_in_ZVALUE(NULL, &src->num, all); + dest->den = *swap_HALF_in_ZVALUE(NULL, &src->den, all); + + } else { + + /* + * swap storage + */ + dest->num = *swap_HALF_in_ZVALUE(&dest->num, &src->num, all); + dest->den = *swap_HALF_in_ZVALUE(&dest->den, &src->den, all); + } + + /* + * swap or copy the rest of the NUMBER elements + */ + if (all) { + dest->links = (long)SWAP_HALF_IN_LONG(&dest->links,&src->links); + } else { + dest->links = src->links; + } + + /* + * return the result + */ + return dest; +} + + +/* + * swap_HALF_in_COMPLEX - swap HALFs in a COMPLEX + * + * given: + * dest - pointer to where the swapped src wil be put or + * NULL to allocate the storage + * src - pointer to a COMPLEX to swap + * all - TRUE => swap every element, FALSE => swap only the + * multiprecision storage + * + * returns: + * pointer to where the swapped src has been put + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) the elements of a COMPLEX. + */ +COMPLEX * +swap_HALF_in_COMPLEX(COMPLEX *dest, COMPLEX *src, BOOL all) +{ + /* + * allocate storage if needed + */ + if (dest == NULL) { + + /* + * allocate the storage + */ + dest = malloc(sizeof(COMPLEX)); + if (dest == NULL) { + math_error("swap_HALF_in_COMPLEX: Not enough memory"); + /*NOTREACHED*/ + } + + /* + * allocate (by forcing swap_HALF_in_ZVALUE) and swap storage + */ + dest->real = swap_HALF_in_NUMBER(NULL, src->real, all); + dest->imag = swap_HALF_in_NUMBER(NULL, src->imag, all); + + } else { + + /* + * swap storage + */ + dest->real = swap_HALF_in_NUMBER(dest->real, src->real, all); + dest->imag = swap_HALF_in_NUMBER(dest->imag, src->imag, all); + } + + /* + * swap or copy the rest of the NUMBER elements + */ + if (all) { + dest->links = (long)SWAP_HALF_IN_LONG(&dest->links,&src->links); + } else { + dest->links = src->links; + } + + /* + * return the result + */ + return dest; +} diff --git a/byteswap.h b/byteswap.h new file mode 100644 index 0000000..fd31a83 --- /dev/null +++ b/byteswap.h @@ -0,0 +1,166 @@ +/* + * Copyright (c) 1995 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. + */ + +#if !defined(BYTESWAP_H) +#define BYTESWAP_H + +#include "longbits.h" + + +/* + * SWAP_B8_IN_B16 - swap 8 bits in 16 bits + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 16 bit value to swap + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) a 16 bit value. + */ +#define SWAP_B8_IN_B16(dest, src) ( \ + *((USB16*)(dest)) = \ + (((*((USB16*)(src))) << 8) | ((*((USB16*)(src))) >> 8)) \ +) + +/* + * SWAP_B16_IN_B32 - swap 16 bits in 32 bits + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 32 bit value to swap + */ +#define SWAP_B16_IN_B32(dest, src) ( \ + *((USB32*)(dest)) = \ + (((*((USB32*)(src))) << 16) | ((*((USB32*)(src))) >> 16)) \ +) + +/* + * SWAP_B8_IN_B32 - swap 8 & 16 bits in 32 bits + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 32 bit value to swap + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) a 32 bit value. + */ +#define SWAP_B8_IN_B32(dest, src) ( \ + SWAP_B16_IN_B32(dest, src), \ + (*((USB32*)(dest)) = \ + ((((*((USB32*)(dest))) & (USB32)0xff00ff00) >> 8) | \ + (((*((USB32*)(dest))) & (USB32)0x00ff00ff) << 8))) \ +) + +#if defined(HAVE_B64) + +/* + * SWAP_B32_IN_B64 - swap 32 bits in 64 bits + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 64 bit value to swap + */ +#define SWAP_B32_IN_B64(dest, src) ( \ + *((USB64*)(dest)) = \ + (((*((USB64*)(src))) << 32) | ((*((USB64*)(src))) >> 32)) \ +) + +/* + * SWAP_B16_IN_B64 - swap 16 & 32 bits in 64 bits + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 64 bit value to swap + */ +#define SWAP_B16_IN_B64(dest, src) ( \ + SWAP_B32_IN_B64(dest, src), \ + (*((USB64*)(dest)) = \ + ((((*((USB64*)(dest))) & (USB64)0xffff0000ffff0000) >> 16) | \ + (((*((USB64*)(dest))) & (USB64)0x0000ffff0000ffff) << 16))) \ +) + +/* + * SWAP_B8_IN_B64 - swap 16 & 32 bits in 64 bits + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 64 bit value to swap + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) a 64 bit value. + */ +#define SWAP_B8_IN_B64(dest, src) ( \ + SWAP_B16_IN_B64(dest, src), \ + (*((USB64*)(dest)) = \ + ((((*((USB64*)(dest))) & (USB64)0xff00ff00ff00ff00) >> 8) | \ + (((*((USB64*)(dest))) & (USB64)0x00ff00ff00ff00ff) << 8))) \ +) + +#else /* HAVE_B64 */ + +/* + * SWAP_B32_IN_B64 - swap 32 bits in 64 bits (simulated by 2 32 bit values) + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 64 bit value to swap + */ +#define SWAP_B32_IN_B64(dest, src) ( \ + ((USB32*)(dest))[1] = ((USB32*)(dest))[0], \ + ((USB32*)(dest))[0] = ((USB32*)(dest))[1] \ +) + +/* + * SWAP_B16_IN_B64 - swap 16 & 32 bits in 64 bits (simulated by 2 32 bit vals) + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 64 bit value to swap + */ +#define SWAP_B16_IN_B64(dest, src) ( \ + SWAP_B16_IN_B32(((USB32*)dest)+1, ((USB32*)src)), \ + SWAP_B16_IN_B32(((USB32*)dest), ((USB32*)src)+1) \ +) + +/* + * SWAP_B8_IN_B64 - swap 16 & 32 bits in 64 bits (simulated by 2 32 bit vals) + * + * dest - pointer to where the swapped src wil be put + * src - pointer to a 64 bit value to swap + * + * This macro will either switch to the opposite byte sex (Big Endian vs. + * Little Endian) a 64 bit value. + */ +#define SWAP_B8_IN_B64(dest, src) ( \ + SWAP_B8_IN_B32(((USB32*)dest)+1, ((USB32*)src)), \ + SWAP_B8_IN_B32(((USB32*)dest), ((USB32*)src)+1) \ +) + +#endif /* HAVE_B64 */ + +#if LONG_BITS == 64 + +#define SWAP_B32_IN_LONG(dest, src) SWAP_B32_IN_B64(dest, src) +#define SWAP_B16_IN_LONG(dest, src) SWAP_B16_IN_B64(dest, src) +#define SWAP_B8_IN_LONG(dest, src) SWAP_B8_IN_B64(dest, src) + +#else /* LONG_BITS == 64 */ + +#define SWAP_B32_IN_LONG(dest, src) SWAP_B32_IN_B32(dest, src) +#define SWAP_B16_IN_LONG(dest, src) SWAP_B16_IN_B32(dest, src) +#define SWAP_B8_IN_LONG(dest, src) SWAP_B8_IN_B32(dest, src) + +#endif /* LONG_BITS == 64 */ + +#endif /* !BYTESWAP_H */ diff --git a/calc.c b/calc.c new file mode 100644 index 0000000..00257fe --- /dev/null +++ b/calc.c @@ -0,0 +1,441 @@ +/* + * Copyright (c) 1995 David I. Bell + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * Arbitrary precision calculator. + */ + +#include +#include +#include + +#define CALC_C +#include "calc.h" +#include "hist.h" +#include "func.h" +#include "opcodes.h" +#include "conf.h" +#include "token.h" +#include "symbol.h" +#include "have_uid_t.h" + +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif + +#include "have_stdlib.h" +#if defined(HAVE_STDLIB_H) +#include +#endif + +/* + * in case we do not have certain .h files + */ +#if !defined(HAVE_STDLIB_H) && !defined(HAVE_UNISTD_H) +#if !defined(HAVE_UID_T) && !defined(_UID_T) +typedef unsigned short uid_t; +#endif +extern char *getenv(); +extern uid_t geteuid(); +#endif + +/* + * Common definitions + */ +int abortlevel; /* current level of aborts */ +BOOL inputwait; /* TRUE if in a terminal input wait */ +jmp_buf jmpbuf; /* for errors */ +int start_done = FALSE; /* TRUE => start up processing finished */ + +extern int isatty(int tty); /* TRUE if fd is a tty */ + +static int p_flag = FALSE; /* TRUE => pipe mode */ +static int q_flag = FALSE; /* TRUE => don't execute rc files */ +static int u_flag = FALSE; /* TRUE => unbuffer stdin and stdout */ + +/* + * global permissions + */ +int allow_read = TRUE; /* FALSE => may not open any files for reading */ +int allow_write = TRUE; /* FALSE => may not open any files for writing */ +int allow_exec = TRUE; /* FALSE => may not execute any commands */ + +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 */ +int stdin_tty = TRUE; /* TRUE if stdin is a tty */ +int post_init = FALSE; /* TRUE setjmp for math_error is readready */ + +/* + * some help topics are symbols, so we alias them to nice filenames + */ +static struct help_alias { + char *topic; + char *filename; +} halias[] = { + {"=", "assign"}, + {"%", "mod"}, + {"//", "quo"}, + {NULL, NULL} +}; + +NUMBER *epsilon_default; /* default allowed error for float calcs */ + +static void intint(int arg); /* interrupt routine */ +static void initenv(void); /* initialize environment vars */ + +extern void file_init(void); +extern void zio_init(void); + +char cmdbuf[MAXCMD+1]; /* command line expression */ + +/* + * Top level calculator routine. + */ +MAIN +main(int argc, char **argv) +{ + static char *str; /* current option string or expression */ + int want_defhelp = 0; /* 1=> we only want the default help */ + long i; + char *p; + + /* + * parse args + */ + argc--; + argv++; + while ((argc > 0) && (**argv == '-')) { + for (str = &argv[0][1]; *str; str++) switch (*str) { + case 'h': + want_defhelp = 1; + break; + case 'm': + if (argv[0][2]) { + p = &argv[0][2]; + } else if (argc > 1) { + p = argv[1]; + argc--; + argv++; + } else { + fprintf(stderr, "-m requires an arg\n"); + exit(1); + } + if (p[1] != '\0' || *p < '0' || *p > '7') { + fprintf(stderr, "unknown -m arg\n"); + exit(1); + } + allow_read = (((*p-'0') & 04) > 0); + allow_write = (((*p-'0') & 02) > 0); + allow_exec = (((*p-'0') & 01) > 0); + break; + case 'p': + p_flag = TRUE; + break; + case 'q': + q_flag = TRUE; + break; + case 'u': + u_flag = TRUE; + break; + case 'v': + version(stdout); + exit(0); + default: + fprintf(stderr, "Unknown option\n"); + exit(1); + } + argc--; + argv++; + } + str = cmdbuf; + *str = '\0'; + while (--argc >= 0) { + i = (long)strlen(*argv); + if (str+1+i+2 >= cmdbuf+MAXCMD) { + fprintf(stderr, "command in arg list too long\n"); + exit(1); + } + *str++ = ' '; + strcpy(str, *argv++); + str += i; + str[0] = '\n'; + str[1] = '\0'; + } + str = cmdbuf; + + /* + * unbuffered mode + */ + if (u_flag) { + setbuf(stdin, NULL); + setbuf(stdout, NULL); + } + + /* + * initialize + */ + libcalc_call_me_first(); + hash_init(); + file_init(); + initenv(); + resetinput(); + if (want_defhelp) { + givehelp(DEFAULTCALCHELP); + exit(0); + } + + /* + * if allowed or needed, print version and setup bindings + */ + if (*str == '\0') { + /* + * check for pipe mode and/or non-tty stdin + */ + if (p_flag) { + stdin_tty = FALSE; /* stdin not a tty in pipe mode */ + conf->tab_ok = FALSE; /* config("tab",0) if pipe mode */ + } else { + stdin_tty = isatty(0); /* assume stdin is on fd 0 */ + } + + /* + * empty string arg is no string + */ + str = NULL; + + /* + * if tty, setup bindings + */ + if (stdin_tty) { + version(stdout); + printf("[%s]\n\n", + "Type \"exit\" to exit, or \"help\" for help."); + } + if (stdin_tty) { + switch (hist_init(calcbindings)) { + case HIST_NOFILE: + fprintf(stderr, + "Cannot open bindings file \"%s\", %s.\n", + calcbindings, "fancy editing disabled"); + break; + + case HIST_NOTTY: + fprintf(stderr, + "Cannot set terminal modes, %s.\n", + "fancy editing disabled"); + break; + } + } + } else { + + /* + * process args, not stdin + */ + stdin_tty = FALSE; /* stdin not a tty in arg mode */ + conf->tab_ok = FALSE; /* config("tab",0) if pipe mode */ + } + + /* + * establish error longjump point with initial conditions + */ + if (setjmp(jmpbuf) == 0) { + + /* + * reset/initialize the computing environment + */ + post_init = TRUE; /* jmpbuf is ready for math_error() */ + inittokens(); + initglobals(); + initfunctions(); + initstack(); + resetinput(); + math_cleardiversions(); + math_setfp(stdout); + math_setmode(MODE_INITIAL); + math_setdigits((long)DISPLAY_DEFAULT); + conf->maxprint = MAXPRINT_DEFAULT; + + /* + * if arg mode or non-tty mode, just do the work and be gone + */ + if (str || !stdin_tty) { + if (q_flag == FALSE && allow_read) { + runrcfiles(); + q_flag = TRUE; + } + if (str) + (void) openstring(str); + else + (void) openterminal(); + start_done = TRUE; + getcommands(FALSE); + exit(0); + } + } + start_done = TRUE; + + /* + * if in arg mode, we should not get here + */ + if (str) + exit(1); + + /* + * process commands (from stdin, not the command line) + */ + abortlevel = 0; + _math_abort_ = FALSE; + inputwait = FALSE; + (void) signal(SIGINT, intint); + math_cleardiversions(); + math_setfp(stdout); + resetscopes(); + resetinput(); + if (q_flag == FALSE && allow_read) { + q_flag = TRUE; + runrcfiles(); + } + (void) openterminal(); + getcommands(TRUE); + + /* + * all done + */ + 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(void) +{ + 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 = (struct passwd *)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; +} + + +/* + * givehelp - display a help file + * + * given: + * type the type of help to give, NULL => index + */ +void +givehelp(char *type) +{ + struct help_alias *p; /* help alias being considered */ + char *helpcmd; /* what to execute to print help */ + + /* + * check permissions to see if we are allowed to help + */ + if (!allow_exec || !allow_read) { + fprintf(stderr, + "sorry, help is only allowed with -m mode 5 or 7\n"); + return; + } + + /* catch the case where we just print the index */ + if (type == NULL) { + type = DEFAULTCALCHELP; /* the help index file */ + } + + /* alias the type of help, if needed */ + for (p=halias; p->topic; ++p) { + if (strcmp(type, p->topic) == 0) { + type = p->filename; + break; + } + } + + /* 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. + * + * given: + * arg to keep ANSI C happy + */ +/*ARGSUSED*/ +static void +intint(int arg) +{ + (void) signal(SIGINT, intint); + if (inputwait || (++abortlevel >= ABORT_NOW)) { + math_error("\nABORT"); + /*NOTREACHED*/ + } + if (abortlevel >= ABORT_MATH) + _math_abort_ = TRUE; + printf("\n[Abort level %d]\n", abortlevel); +} + +/* END CODE */ diff --git a/calc.h b/calc.h new file mode 100644 index 0000000..e0e7f23 --- /dev/null +++ b/calc.h @@ -0,0 +1,165 @@ +/* + * Copyright (c) 1995 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 +#include +#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 16384 /* 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 "> " /* default normal prompt*/ +#define PROMPT2 ">> " /* default prompt 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_LINKS 0x04 /* display links for real and complex numbers */ +#define TRACE_FNCODES 0x08 /* display code for newly defined function */ +#define TRACE_MAX 0x0f /* maximum value for trace flag */ + +#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 */ + +/* + * 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(char *name, char *mode); +extern FILEID indexid(long index); +extern BOOL validid(FILEID id); +extern BOOL errorid(FILEID id); +extern BOOL eofid(FILEID id); +extern int closeid(FILEID id); +extern int getcharid(FILEID id); +extern int idprintf(FILEID id, char *fmt, int count, VALUE **vals); +extern int idfputc(FILEID id, int ch); +extern int idfputs(FILEID id, char *str); +extern int printid(FILEID id, int flags); +extern int flushid(FILEID id); +extern int readid(FILEID id, int flags, char **retptr); +extern int getloc(FILEID id, ZVALUE *loc); +extern int setloc(FILEID id, ZVALUE zpos); +extern int getsize(FILEID id, ZVALUE *size); +extern int get_device(FILEID id, ZVALUE *dev); +extern int get_inode(FILEID id, ZVALUE *ino); +extern FILEID reopenid(FILEID id, char *mode, char *name); +extern int closeall(void); +extern int flushall(void); +extern int idfputstr(FILEID id, char *str); +extern int rewindid(FILEID id); +extern void rewindall(void); +extern long filesize(FILEID id); +extern void showfiles(void); +extern int fscanfid(FILEID id, char *fmt, int count, VALUE **vals); +extern int scanfstr(char *str, char *fmt, int count, VALUE **vals); +extern long ftellid(FILEID id); +extern long fseekid(FILEID id, long offset, int whence); +extern int isattyid(FILEID id); +long fsearch(FILEID id, char *str, long pos); +long frsearch(FILEID id, char *str, long pos); + +/* + * Input routines. + */ +extern FILE *f_open(char *name, char *mode); +extern int openstring(char *str); +extern int openterminal(void); +extern int opensearchfile(char *name, char *pathlist, char *exten, int reopen_ok); +extern char *nextline(void); +extern int nextchar(void); +extern void reread(void); +extern void resetinput(void); +extern void setprompt(char *); +extern BOOL inputisterminal(void); +extern char *inputname(void); +extern long linenumber(void); +extern void runrcfiles(void); +extern void closeinput(void); +extern FILE *curstream(void); + + +/* + * Other routines. + */ +extern NUMBER *constvalue(unsigned long index); +extern long addnumber(char *str); +extern long addqconstant(NUMBER *q); +extern void initstack(void); +extern void version(FILE *stream); +extern void getcommands(BOOL toplevel); +extern void givehelp(char *type); +extern void hash_init(void); +extern void libcalc_call_me_first(void); + + +/* + * Global data definitions. + */ +extern int abortlevel; /* current level of aborts */ +extern BOOL inputwait; /* TRUE if in a terminal input wait */ +extern VALUE *stack; /* execution stack */ +extern jmp_buf jmpbuf; /* for errors */ +extern int start_done; /* TRUE => start up processing finished */ +extern int dumpnames; /* TRUE => dump names rather than indices */ + +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 */ + +extern int allow_read; /* FALSE => may not open any files for reading */ +extern int allow_write; /* FALSE => may not open any files for writing */ +extern int allow_exec; /* FALSE => may not execute any commands */ + +extern int post_init; /* TRUE => setjmp for math_error is ready */ + +#endif + +/* END CODE */ diff --git a/calc.man b/calc.man new file mode 100644 index 0000000..d1a1ebe --- /dev/null +++ b/calc.man @@ -0,0 +1,423 @@ +.\" +.\" 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 +calc \- arbitrary precision calculator +.SH SYNOPSIS +\fIcalc\fP +[\fI\-h\fP] +[\fI\-m mode\fP] +[\fI\-p\fP] +[\fI\-q\fP] +[\fI\-u\fP] +[\fI\-v\fP] +[\fIcalc_cmd \&.\|.\|.\fp] +.SH DESCRIPTION +\& +.br +CALC COMMAND LINE +.PP +.TP +\fI\-h\fP +Print a help message. +This option implies \fI \-q\fP. +This is equivalent to the calc command \fIhelp help\fP. +The help facility is disabled unless the \fImode\fP is 5 or 7. +See \fI\-m\fP below. +.sp +.TP +\fI\-m mode\fP +This flag sets the permission mode of calc. +It controls the ability for \fIcalc\fP to open files +and execute programs. +\fIMode\fP may be a number from 0 to 7. +.sp +The \fImode\fP value is interpreted in a way similar +to that of the \fRchmod(1)\fP octal mode: +.sp +.in +0.5i +.nf +0 do not open any file, do not execute progs +1 do not open any file +2 do not open files for reading, do not execute progs +3 do not open files for reading +4 do not open files for writing, do not execute progs +5 do not open files for writing +6 do not execute any program +7 allow everything (default mode) +.fi +.in -0.5i +.sp +If one wished to run calc from a privledged user, one might +want to use \fI\-m 0\fP in an effort to make calc more secure. +.sp +\fIMode\fP bits for reading and writing apply only on an open. +Files already open are not effected. +Thus if one wanted to use the \fI\-m 0\fP in an effort to make +\fIcalc\fP more secure, but still wanted to read and write a specific +file, one might want to do: +.sp +.in +0.5i +.nf +\fRcalc \-m 0 3> +E_SHIFT2 Bad second argument for << or >> +E_SCALE Bad first argument for scale +E_SCALE2 Bad second argument for scale +E_POWI Bad first argument for ^ +E_POWI2 Bad second argument for ^ +E_POWER Bad first argument for power +E_POWER2 Bad second argument for power +E_POWER3 Bad third argument for power +E_QUO Bad first argument for quo or // +E_QUO2 Bad second argument for quo or // +E_QUO3 Bad third argument for quo +E_MOD Bad first argument for mod or % +E_MOD2 Bad second argument for mod or % +E_MOD3 Bad third argument for mod +E_SGN Bad argument for sgn +E_ABS Bad first argument for abs +E_ABS2 Bad second argument for abs +E_EVAL Scan error in argument for eval +E_STR Non-simple type for str +E_EXP1 Non-real epsilon for exp +E_EXP2 Bad first argument for exp +E_FPUTC1 Non-file first argument for fputc +E_FPUTC2 Bad second argument for fputc +E_FPUTC3 File not open for writing for fputc +E_FGETC1 Non-file first argument for fgetc +E_FGETC2 File not open for reading for fgetc +E_FOPEN1 Non-string arguments for fopen +E_FOPEN2 Unrecognized mode for fopen +E_FREOPEN1 Non-file first argument for freopen +E_FREOPEN2 Non-string or unrecognized mode for freopen +E_FREOPEN3 Non-string third argument for freopen +E_FCLOSE1 Non-file argument for fclose +E_FFLUSH Non-file argument for fflush +E_FPUTS1 Non-file first argument for fputs +E_FPUTS2 Non-string argument after first for fputs +E_FPUTS3 File not open for writing for fputs +E_FGETS1 Non-file argument for fgets +E_FGETS2 File not open for reading for fgets +E_FPUTSTR1 Non-file first argument for fputstr +E_FPUTSTR2 Non-string argument after first for fputstr +E_FPUTSTR3 File not open for writing for fputstr +E_FGETSTR1 Non-file first argument for fgetstr +E_FGETSTR2 File not open for reading for fgetstr +E_FGETLINE1 Non-file argument for fgetline +E_FGETLINE2 File not open for reading for fgetline +E_FGETWORD1 Non-file argument for fgetword +E_FGETWORD2 File not open for reading for fgetword +E_REWIND1 Non-file argument for rewind +E_FILES Non-integer argument for files +E_PRINTF1 Non-string fmt argument for fprint +E_PRINTF2 Stdout not open for writing to ??? +E_FPRINTF1 Non-file first argument for fprintf +E_FPRINTF2 Non-string second (fmt) argument for fprintf +E_FPRINTF3 File not open for writing for fprintf +E_STRPRINTF1 Non-string first (fmt) argument for strprintf +E_STRPRINTF2 Error in attempting strprintf ??? +E_FSCAN1 Non-file first argument for fscan +E_FSCAN2 File not open for reading for fscan +E_STRSCAN Non-string first argument for strscan +E_FSCANF1 Non-file first argument for fscanf +E_FSCANF2 Non-string second (fmt) argument for fscanf +E_FSCANF3 Non-lvalue argument after second for fscanf +E_FSCANF4 File not open for reading or other error for fscanf +E_STRSCANF1 Non-string first argument for strscanf +E_STRSCANF2 Non-string second (fmt) argument for strscanf +E_STRSCANF3 Non-lvalue argument after second for strscanf +E_STRSCANF4 Some error in attempting strscanf ??? +E_SCANF1 Non-string first (fmt) argument for scanf +E_SCANF2 Non-lvalue argument after first for scanf +E_SCANF3 Some error in attempting scanf ??? +E_FTELL1 Non-file argument for ftell +E_FTELL2 File not open or other error for ftell +E_FSEEK1 Non-file first argument for fseek +E_FSEEK2 Non-integer or negative second argument for fseek +E_FSEEK3 File not open or other error for fseek +E_FSIZE1 Non-file argument for fsize +E_FSIZE2 File not open or other error for fsize +E_FEOF1 Non-file argument for feof +E_FEOF2 File not open or other error for feof +E_FERROR1 Non-file argument for ferror +E_FERROR2 File not open or other error for ferror +E_UNGETC1 Non-file argument for ungetc +E_UNGETC2 File not open for reading for ungetc +E_UNGETC3 Bad second argument or other error for ungetc +E_BIGEXP Exponent too big in scanning +E_ISATTY1 Non-file argument for isatty +E_ISATTY2 File not open for isatty +E_ACCESS1 Non-string first argument for access +E_ACCESS2 Bad second argument for access +E_SEARCH1 Bad first argument for search +E_SEARCH2 Bad second argument for search +E_SEARCH3 Bad third argument for search +E_RSEARCH1 Bad first argument for rsearch +E_RSEARCH2 Bad second argument for rsearch +E_RSEARCH3 Bad third argument for rsearch +E_FOPEN3 Too many open files +E_REWIND2 Attempt to rewind a file that is not open +E_STRERROR1 Bad argument type for strerror +E_STRERROR2 Index out of range for strerror +E_COS1 Bad epsilon for cos +E_COS2 Bad first argument for cos +E_SIN1 Bad epsilon for sin +E_SIN2 Bad first argument for sin +E_EVAL2 Non-string argument for eval +E_ARG1 Bad epsilon for arg +E_ARG2 Bad first argument for arg +E_POLAR1 Non-real argument for polar +E_POLAR2 Bad epsilon for polar +E_FCNT Non-integral argument for fcnt +E_MATFILL1 Non-variable first argument for matfill +E_MATFILL2 Non-matrix first argument-value for matfill +E_MATDIM Non-matrix argument for matdim +E_MATSUM Non-matrix argument for matsum +E_ISIDENT Non-matrix argument for isident +E_MATTRANS1 Non-matrix argument for mattrans +E_MATTRANS2 Non-two-dimensional matrix for mattrans +E_DET1 Non-matrix argument for det +E_DET2 Matrix for det not of dimension 2 +E_DET3 Non-square matrix for det +E_MATMIN1 Non-matrix first argument for matmin +E_MATMIN2 Non-positive-integer second argument for matmin +E_MATMIN3 Second argument for matmin exceeds dimension +E_MATMAX1 Non-matrix first argument for matmin +E_MATMAX2 Second argument for matmax not positive integer +E_MATMAX3 Second argument for matmax exceeds dimension +E_CP1 Non-matrix argument for cp +E_CP2 Non-one-dimensional matrix for cp +E_CP3 Matrix size not 3 for cp +E_DP1 Non-matrix argument for dp +E_DP2 Non-one-dimensional matrix for dp +E_DP3 Different-size matrices for dp +E_STRLEN Non-string argument for strlen +E_STRCAT Non-string argument for strcat +E_SUBSTR1 Non-string first argument for strcat +E_SUBSTR2 Non-non-negative integer second argument for strcat +E_CHAR Bad argument for char +E_ORD Non-string argument for ord +E_INSERT1 Non-list-variable first argument for insert +E_INSERT2 Non-integral second argument for insert +E_PUSH Non-list-variable first argument for push +E_APPEND Non-list-variable first argument for append +E_DELETE1 Non-list-variable first argument for delete +E_DELETE2 Non-integral second argument for delete +E_POP Non-list-variable argument for pop +E_REMOVE Non-list-variable argument for remove +E_LN1 Bad epsilon argument for ln +E_LN2 Non-numeric first argument for ln +E_ERROR1 Non-integer argument for error +E_ERROR2 Argument outside range for error +E_EVAL3 Attempt to eval at maximum input depth +E_EVAL4 Unable to open string for reading +E_RM1 First argument for rm is not a non-empty string +E_RM2 Unable to remove a file +E_RDPERM Operation allowed because calc mode disallows read operations +E_WRPERM Operation allowed because calc mode disallows write operations +E_EXPERM Operation allowed because calc mode disallows exec operations diff --git a/calcerr_c.awk b/calcerr_c.awk new file mode 100644 index 0000000..331acf8 --- /dev/null +++ b/calcerr_c.awk @@ -0,0 +1,17 @@ +BEGIN { + printf("#include \n"); + printf("#include \"calcerr.h\"\n\n"); + printf("#include \"have_const.h\"\n\n"); + printf("/*\n"); + printf(" * names of calc error values\n"); + printf(" */\n"); + printf("CONST char *error_table[E__COUNT+2] = {\n"); + printf(" \"No error\",\n"); +} +{ + print $0; +} +END { + printf(" NULL\n"); + printf("};\n"); +} diff --git a/calcerr_c.sed b/calcerr_c.sed new file mode 100644 index 0000000..1894e15 --- /dev/null +++ b/calcerr_c.sed @@ -0,0 +1,4 @@ +s/#.*// +s/[ ][ ]*$// +/^$/d +s/[^ ][^ ]*[ ][ ]*\(.*\)$/ "\1",/ diff --git a/calcerr_h.awk b/calcerr_h.awk new file mode 100644 index 0000000..88f8e5e --- /dev/null +++ b/calcerr_h.awk @@ -0,0 +1,22 @@ +BEGIN { + ebase = 10000; + printf("#define E__BASE %d\t/* calc errors start above here */\n\n", ebase); +} +NF > 1 { + if (length($1) > 7) { + printf("#define %s\t", $1, NR); + } else { + printf("#define %s\t\t", $1, NR); + } + printf("%d\t/* ", ebase+NR); + for (i=2; i < NF; ++i) { + printf("%s ", $i); + } + printf("%s */\n", $NF); +} +END { + printf("\n#define E__HIGHEST\t%d\t/* highest calc error */\n", NR+ebase); + printf("#define E__COUNT\t\t%d\t/* number of calc errors */\n", NR); + printf("#define E_USERDEF\t20000\t/* base of user defined errors */\n\n"); + printf("/* names of calc error values */\n"); +} diff --git a/calcerr_h.sed b/calcerr_h.sed new file mode 100644 index 0000000..58054f0 --- /dev/null +++ b/calcerr_h.sed @@ -0,0 +1,4 @@ +s/#.*// +s/[ ][ ]*$// +/^$/d +s/\([^ ][^ ]*\)[ ][ ]*\(.*\)$/\1 \2/ diff --git a/check.awk b/check.awk new file mode 100644 index 0000000..b321d16 --- /dev/null +++ b/check.awk @@ -0,0 +1,74 @@ +# This awk script will print 3 lines before and after any non-blank line that +# does not begin with a number. This allows the 'make debug' rule to remove +# all non-interest lines the the 'make check' regression output while providing +# 3 lines of context around unexpected output. +# +BEGIN { + havebuf0=0; + buf0=0; + havebuf1=0; + buf1=0; + havebuf2=0; + buf2=0; + error = 0; +} + +NF == 0 { + if (error > 0) { + if (havebuf2) { + print buf2; + } + --error; + } + buf2 = buf1; + havebuf2 = havebuf1; + buf1 = buf0; + havebuf1 = havebuf0; + buf0 = $0; + havebuf0 = 1; + next; +} + +$1 ~ /^[0-9]/ { + if (error > 0) { + if (havebuf2) { + print buf2; + } + --error; + } + buf2 = buf1; + havebuf2 = havebuf1; + buf1 = buf0; + havebuf1 = havebuf0; + buf0 = $0; + havebuf0 = 1; + next; +} + +{ + error = 6; + if (havebuf2) { + print buf2; + } + buf2 = buf1; + havebuf2 = havebuf1; + buf1 = buf0; + havebuf1 = havebuf0; + buf0 = $0; + havebuf0 = 1; + next; +} + +END { + if (error > 0 && havebuf2) { + print buf2; + --error; + } + if (error > 0 && havebuf1) { + print buf1; + --error; + } + if (error > 0 && havebuf0) { + print buf0; + } +} diff --git a/cmath.h b/cmath.h new file mode 100644 index 0000000..076e3d8 --- /dev/null +++ b/cmath.h @@ -0,0 +1,113 @@ +/* + * 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(void); +extern COMPLEX *qqtoc(NUMBER *q1, NUMBER *q2); +extern void comfree(COMPLEX *c); +extern void comprint(COMPLEX *c); +extern void cprintfr(COMPLEX *c); + + +/* + * Basic numeric routines. + */ +extern COMPLEX *cadd(COMPLEX *c1, COMPLEX *c2); +extern COMPLEX *csub(COMPLEX *c1, COMPLEX *c2); +extern COMPLEX *cmul(COMPLEX *c1, COMPLEX *c2); +extern COMPLEX *cdiv(COMPLEX *c1, COMPLEX *c2); +extern COMPLEX *caddq(COMPLEX *c, NUMBER *q); +extern COMPLEX *csubq(COMPLEX *c, NUMBER *q); +extern COMPLEX *cmulq(COMPLEX *c, NUMBER *q); +extern COMPLEX *cdivq(COMPLEX *c, NUMBER *q); +extern COMPLEX *cscale(COMPLEX *c, long i); +extern COMPLEX *cshift(COMPLEX *c, long i); +extern COMPLEX *csquare(COMPLEX *c); +extern COMPLEX *cconj(COMPLEX *c); +extern COMPLEX *creal(COMPLEX *c); +extern COMPLEX *cimag(COMPLEX *c); +extern COMPLEX *cneg(COMPLEX *c); +extern COMPLEX *cinv(COMPLEX *c); +extern COMPLEX *cint(COMPLEX *c); +extern COMPLEX *cfrac(COMPLEX *c); +extern BOOL ccmp(COMPLEX *c1, COMPLEX *c2); + + +/* + * More complicated functions. + */ +extern COMPLEX *cpowi(COMPLEX *c, NUMBER *q); + + +/* + * Transcendental routines. These all take an epsilon argument to + * specify how accurately these are to be calculated. + */ +extern COMPLEX *cpower(COMPLEX *c1, COMPLEX *c2, NUMBER *epsilon); +extern COMPLEX *csqrt(COMPLEX *c, NUMBER *epsilon, long R); +extern COMPLEX *croot(COMPLEX *c, NUMBER *q, NUMBER *epsilon); +extern COMPLEX *cexp(COMPLEX *c, NUMBER *epsilon); +extern COMPLEX *cln(COMPLEX *c, NUMBER *epsilon); +extern COMPLEX *ccos(COMPLEX *c, NUMBER *epsilon); +extern COMPLEX *csin(COMPLEX *c, NUMBER *epsilon); +extern COMPLEX *cpolar(NUMBER *q1, NUMBER *q2, NUMBER *epsilon); +extern COMPLEX *crel(COMPLEX *c1, COMPLEX *c2); + + +/* + * external functions + */ +extern COMPLEX *swap_b8_in_COMPLEX(COMPLEX *dest, COMPLEX *src, BOOL all); +extern COMPLEX *swap_b16_in_COMPLEX(COMPLEX *dest, COMPLEX *src, BOOL all); +extern COMPLEX *swap_HALF_in_COMPLEX(COMPLEX *dest, COMPLEX *src, BOOL all); + + +/* + * 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/codegen.c b/codegen.c new file mode 100644 index 0000000..e6da9eb --- /dev/null +++ b/codegen.c @@ -0,0 +1,2115 @@ +/* + * Copyright (c) 1996 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 "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif + +#include "calc.h" +#include "token.h" +#include "symbol.h" +#include "label.h" +#include "opcodes.h" +#include "string.h" +#include "func.h" +#include "conf.h" + +static BOOL rdonce; /* TRUE => do not reread this file */ + +FUNC *curfunc; + +static BOOL getfilename(char *name, BOOL msg_ok, BOOL *once); +static BOOL getid(char *buf); +static void getshowstatement(void); +static void getfunction(void); +static void getbody(LABEL *contlabel, LABEL *breaklabel, + LABEL *nextcaselabel, LABEL *defaultlabel, BOOL toplevel); +static void getdeclarations(void); +static void getstatement(LABEL *contlabel, LABEL *breaklabel, + LABEL *nextcaselabel, LABEL *defaultlabel); +static void getobjdeclaration(int symtype); +static void getoneobj(long index, int symtype); +static void getobjvars(char *name, int symtype); +static void getmatdeclaration(int symtype); +static void getonematrix(int symtype); +static void creatematrix(void); +static void getsimplebody(void); +static void getonedeclaration(int type); +static void getcondition(void); +static void getmatargs(void); +static void getelement(void); +static void usesymbol(char *name, BOOL autodef); +static void definesymbol(char *name, int symtype); +static void getcallargs(char *name); +static void do_changedir(void); +static int getexprlist(void); +static int getassignment(void); +static int getaltcond(void); +static int getorcond(void); +static int getandcond(void); +static int getrelation(void); +static int getsum(void); +static int getproduct(void); +static int getorexpr(void); +static int getandexpr(void); +static int getshiftexpr(void); +static int getterm(void); +static int getidexpr(BOOL okmat, BOOL autodef); +static long getinitlist(void); + + +/* + * 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(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; + if (!allow_read) { + scanerror(T_NULL, + "read command disallowed by -m mode\n"); + break; + } + switch (opensearchfile(name,calcpath,CALCEXT,rdonce)) { + case 0: + getcommands(FALSE); + break; + case 1: + /* previously read and -once was given */ + break; + case -2: + scanerror(T_NULL, "Maximum input depth reached"); + break; + default: + scanerror(T_NULL, "Cannot open \"%s\"\n", name); + break; + } + break; + + case T_WRITE: + if (!getfilename(name, TRUE, NULL)) + break; + if (!allow_write) { + scanerror(T_NULL, + "write command disallowed by -m mode\n"); + break; + } + if (writeglobals(name)) + scanerror(T_NULL, "Error writing \"%s\"\n", name); + break; + + case T_CD: + do_changedir(); + 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. + * + * given: + * nestflag TRUE if this is a nested evaluation + */ +BOOL +evaluate(BOOL nestflag) +{ + char *funcname; + BOOL gotstatement; + int loop = 1; /* 0 => end the main while loop */ + + funcname = (nestflag ? "**" : "*"); + beginfunc(funcname, nestflag); + gotstatement = FALSE; + if (nestflag) + (void) tokenmode(TM_DEFAULT); + while (loop) { + switch (gettoken()) { + case T_SEMICOLON: + break; + + case T_NEWLINE: + case T_EOF: + loop = 0; + break; + + 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; + } + } + 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(void) +{ + 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; + } + name = tokenstring(); + type = getbuiltinfunc(name); + if (type >= 0) { + scanerror(T_SEMICOLON, "Using builtin function name"); + return; + } + beginfunc(name, 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(void) +{ + 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(LABEL *contlabel, LABEL *breaklabel, LABEL *nextcaselabel, LABEL *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(void) +{ + 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: + rescantoken(); + 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(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); + addop(OP_POP); + if (symtype == SYM_STATIC) + setlabel(&label); + return; + + case T_OBJ: + addopone(OP_DEBUG, linenumber()); + getobjdeclaration(symtype); + addop(OP_POP); + 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 + * | ';'. + * + * given: + * contlabel label for continue statement + * breaklabel label for break statement + * nextcaselabel label for next case statement + * defaultlabel label for default case + */ +static void +getstatement(LABEL *contlabel, LABEL *breaklabel, LABEL *nextcaselabel, LABEL *defaultlabel) +{ + 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_SHOW: + getshowstatement(); + break; + + case T_PRINT: + printeol = TRUE; + for (;;) { + switch (gettoken()) { + case T_RIGHTBRACE: + case T_NEWLINE: + case T_EOF: + rescantoken(); + /*FALLTHRU*/ + case T_SEMICOLON: + if (printeol) + addop(OP_PRINTEOL); + return; + case T_COMMA: + addop(OP_PRINTSPACE); + /*FALLTHRU*/ + case T_COLON: + printeol = FALSE; + 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(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); + getobjvars(name, symtype); + return; + } + scanerror(T_SEMICOLON, "Error in object definition"); + case T_COMMA: + case T_SEMICOLON: + case T_NEWLINE: + break; + default: + scanerror(T_SEMICOLON, "Bad object element definition"); + return; + } + } +} + +static void +getoneobj(long index, int symtype) +{ + char *symname; + + if (gettoken() == T_SYMBOL) { + if (symtype == SYM_UNDEFINED) { + rescantoken(); + (void) getidexpr(FALSE, TRUE); + } + else { + symname = tokenstring(); + definesymbol(symname, symtype); + usesymbol(symname, FALSE); + } + while (gettoken() == T_COMMA); + rescantoken(); + getoneobj(index, symtype); + addop(OP_ASSIGN); + return; + } + rescantoken(); + addopone(OP_OBJCREATE, index); + if (gettoken() == T_ASSIGN) + (void) getinitlist(); + else + rescantoken(); +} + +/* + * 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. + * + * given: + * name object name + * symtype type of symbol to collect for + */ +static void +getobjvars(char *name, int symtype) +{ + long index; /* index for object */ + + index = checkobject(name); + if (index < 0) { + scanerror(T_SEMICOLON, "Object %s has not been defined yet", name); + return; + } + for (;;) { + getoneobj(index, symtype); + if (gettoken() != T_COMMA) { + rescantoken(); + return; + } + addop(OP_POP); + } +} + + +static void +getmatdeclaration(int symtype) +{ + + + for(;;) { + getonematrix(symtype); + if (gettoken() != T_COMMA) { + rescantoken(); + return; + } + addop(OP_POP); + } +} + +static +void getonematrix(int symtype) +{ + long dim; + long index; + long count; + unsigned long patchpc; + char *name; + + if (gettoken() == T_SYMBOL) { + if (symtype == SYM_UNDEFINED) { + rescantoken(); + (void) getidexpr(FALSE, TRUE); + } + else { + name = tokenstring(); + definesymbol(name, symtype); + usesymbol(name, FALSE); + } + while (gettoken() == T_COMMA); + rescantoken(); + getonematrix(symtype); + addop(OP_ASSIGN); + return; + } + rescantoken(); + + if (gettoken() != T_LEFTBRACKET) { + addopone(OP_MATCREATE, 0); + rescantoken(); + 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); + addop(OP_ZERO); + addop(OP_INITFILL); + count = 0; + if (gettoken() == T_ASSIGN) + count = getinitlist(); + else + rescantoken(); + index = addqconstant(itoq(count)); + 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(); + creatematrix(); + if (gettoken() == T_ASSIGN) + (void) getinitlist(); + else + rescantoken(); + return; +} + + +static void +creatematrix(void) +{ + long dim; + + dim = 1; + + 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: + addopone(OP_MATCREATE, dim); + if (gettoken() == T_LEFTBRACKET) + creatematrix(); + else { + rescantoken(); + addop(OP_ZERO); + } + addop(OP_INITFILL); + return; + 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. + * initlist = { assignment [ , assignment ] ... }. + */ +static long +getinitlist(void) +{ + long index; + int oldmode; + + 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++) { + switch(gettoken()) { + case T_COMMA: + continue; + case T_RIGHTBRACE: + (void) tokenmode(oldmode); + return index; + case T_LEFTBRACE: + rescantoken(); + addop(OP_DUPLICATE); + addopone(OP_ELEMADDR, index); + (void) getinitlist(); + break; + default: + rescantoken(); + getassignment(); + } + addopone(OP_ELEMINIT, index); + switch (gettoken()) { + case T_COMMA: + continue; + + case T_RIGHTBRACE: + (void) tokenmode(oldmode); + return index; + + default: + scanerror(T_SEMICOLON, "Bad initialization list"); + (void) tokenmode(oldmode); + return -1; + } + } +} + + +/* + * Get a condition. + * condition = '(' assignment ')'. + */ +static void +getcondition(void) +{ + 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(void) +{ + 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(void) +{ + 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); + if (gettoken() == T_LEFTBRACE) { + rescantoken(); + if (op) { + addop(OP_DUPVALUE); + getinitlist(); + addop(op); + addop(OP_ASSIGN); + } + else + getinitlist(); + return EXPR_ASSIGN; + } + rescantoken(); + (void) getassignment(); + if (op) { + addop(op); + } + addop(OP_ASSIGN); + return 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(void) +{ + 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) getaltcond(); + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + int type; /* type of value found */ + long op; /* opcode to generate */ + int tok; + + type = getterm(); + tok = gettoken(); + if (tok == T_PLUSPLUS || tok == T_MINUSMINUS) { + if (isrvalue(type)) + scanerror(T_NULL, "Bad ++ usage"); + writeindexop(); + if (tok == T_PLUSPLUS) + addop(OP_POSTINC); + else + addop(OP_POSTDEC); + for (;;) { + tok = gettoken(); + switch(tok) { + case T_PLUSPLUS: + addop(OP_PREINC); + continue; + case T_MINUSMINUS: + addop(OP_PREDEC); + continue; + default: + addop(OP_POP); + goto done; + } + } +done: type = EXPR_RVALUE | EXPR_ASSIGN; + } + if (tok == T_NOT) { + addopfunction(OP_CALL, getbuiltinfunc("fact"), 1); + tok = gettoken(); + type = EXPR_RVALUE; + } + switch (tok) { + 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(void) +{ + 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_ASSIGN; + break; + + case T_MINUSMINUS: + if (isrvalue(getterm())) + scanerror(T_NULL, "Bad -- usage"); + writeindexop(); + addop(OP_PREDEC); + type = 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_MAT: + getmatdeclaration(SYM_UNDEFINED); + type = EXPR_ASSIGN; + break; + + case T_OBJ: + getobjdeclaration(SYM_UNDEFINED); + type = EXPR_ASSIGN; + 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_COMMA, "Missing expression"); + type = 0; + } + 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(BOOL okmat, BOOL autodef) +{ + int type; + char name[SYMBOLSIZE+1]; /* symbol name */ + + type = 0; + if (!getid(name)) + return type; + switch (gettoken()) { + case T_LEFTPAREN: + getcallargs(name); + type = 0; + 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. + * + * given: + * name filename to read + * msg_ok TRUE => ok to print error messages + * once non-NULL => set to TRUE of -once read + */ +static BOOL +getfilename(char *name, BOOL msg_ok, BOOL *once) +{ + /* 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 to display useful information + */ +static void +getshowstatement(void) +{ + char name[5]; + long arg, index; + + switch (gettoken()) { + case T_SYMBOL: + strncpy(name, tokenstring(), 4); + name[4] = '\0'; + arg = stringindex("buil\000glob\000func\000objf\000conf\000objt\000file\000size\000opco\0", name); + if (arg == 9) { + if (gettoken() != T_SYMBOL) { + rescantoken(); + scanerror(T_SEMICOLON, "Function name expected"); + return; + } + index = adduserfunc(tokenstring()); + addopone(OP_SHOW, index + 9); + return; + } + if (arg > 0) + addopone(OP_SHOW, arg); + else + printf("Unknown SHOW parameter ignored"); + return; + default: + printf("SHOW command to be followed by at least "); + printf("four letters of one of:\n"); + printf("\tbuiltin, global, function, objfunc, "); + printf("config, objtype, files, sizes\n"); + rescantoken(); + return; + + } +} + + +/* + * Read in a set of matrix index arguments, surrounded with square brackets. + * This also handles double square brackets for 'fast indexing'. + */ +static void +getmatargs(void) +{ + 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: + addoptwo(OP_INDEXADDR, (long) dim, + (long) FALSE); + return; + case T_COMMA: + dim++; + 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(void) +{ + 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(char *buf) +{ + int type; + + type = gettoken(); + if (iskeyword(type)) { + scanerror(T_NULL, "Reserved keyword used as symbol name"); + type = T_SYMBOL; + *buf = '\0'; + return FALSE; + } + 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(char *name, int symtype) +{ + 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. + * + * given: + * name symbol name to be checked + * autodef TRUE => define is symbol is not known + */ +static void +usesymbol(char *name, 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] ] ')'. + * + * given: + * name name of function + */ +static void +getcallargs(char *name) +{ + 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++; + if (gettoken() == T_RIGHTPAREN) { + addop(OP_UNDEF); + if (op == OP_CALL) + builtincheck(index, argcount); + addopfunction(op, index, argcount); + return; + } + rescantoken(); + if (gettoken() == T_COMMA) { + addop(OP_UNDEF); + continue; + } + rescantoken(); + 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); + if (!strcmp(name, "quomod") && argcount > 2) + writeindexop(); + 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; + } + } +} + + +/* + * Change the current directory. If no directory is given, assume home. + */ +static void +do_changedir(void) +{ + char *p; + + /* look at the next token */ + (void) tokenmode(TM_NEWLINES | TM_ALLSYMS); + + /* determine the new directory */ + switch (gettoken()) { + case T_NULL: + case T_NEWLINE: + case T_SEMICOLON: + p = getenv("HOME"); + break; + default: + p = tokenstring(); + if (p == NULL) { + p = getenv("HOME"); + } + break; + } + if (p == NULL) { + fprintf(stderr, "Cannot determine HOME directory\n"); + } + + /* change to that directory */ + if (chdir(p)) { + perror(p); + } + return; +} + + +/* END CODE */ diff --git a/comfunc.c b/comfunc.c new file mode 100644 index 0000000..c61aed5 --- /dev/null +++ b/comfunc.c @@ -0,0 +1,770 @@ +/* + * 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 "config.h" +#include "cmath.h" + +/* + * Compute the result of raising a complex number to an integer power. + * + * given: + * c complex number to be raised + * q power to raise it to + */ +COMPLEX * +cpowi(COMPLEX *c, NUMBER *q) +{ + COMPLEX *tmp, *res; /* temporary values */ + long power; /* power to raise to */ + FULL bit; /* current bit value */ + int sign; + + if (qisfrac(q)) { + math_error("Raising number to non-integral power"); + /*NOTREACHED*/ + } + if (zge31b(q->num)) { + math_error("Raising number to very large power"); + /*NOTREACHED*/ + } + power = ztolong(q->num); + if (ciszero(c) && (power == 0)) { + math_error("Raising zero to zeroth power"); + /*NOTREACHED*/ + } + 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 to specified accuracy. + * Type of rounding of each component specified by R as for qsqrt(). + */ +COMPLEX * +csqrt(COMPLEX *c, NUMBER *epsilon, long R) +{ + COMPLEX *r; + NUMBER *es, *aes, *bes, *u, *v, qtemp; + NUMBER *ntmp; + ZVALUE g, a, b, d, aa, cc; + ZVALUE tmp1, tmp2, tmp3, mul1, mul2; + long s1, s2, s3, up1, up2; + int imsign, sign; + + if (ciszero(c)) + return clink(c); + if (cisreal(c)) { + r = comalloc(); + if (!qisneg(c->real)) { + r->real = qsqrt(c->real, epsilon, R); + return r; + } + ntmp = qneg(c->real); + r->imag = qsqrt(ntmp, epsilon, R); + qfree(ntmp); + return r; + } + + up1 = up2 = 0; + sign = (R & 64) != 0; +#if 0 + if (qiszero(epsilon)) { + aes = qsquare(c->real); + bes = qsquare(c->imag); + v = qqadd(aes, bes); + qfree(aes); + qfree(bes); + u = qsqrt(v, epsilon, 0); + qfree(v); + if (qiszero(u)) { + qfree(u); + return clink(&_czero_); + } + aes = qqadd(u, c->real); + qfree(u); + bes = qscale(aes, -1); + qfree(aes); + u = qsqrt(bes, epsilon, R); + qfree(bes); + if (qiszero(u)) { + qfree(u); + return clink(&_czero_); + } + aes = qscale(c->imag, -1); + v = qdiv(aes, u); + qfree(aes); + r = comalloc(); + r->real = u; + r->imag = v; + return r; + } +#endif + imsign = c->imag->num.sign; + es = qsquare(epsilon); + aes = qdiv(c->real, es); + bes = qdiv(c->imag, es); + qfree(es); + zgcd(aes->den, bes->den, &g); + zequo(bes->den, g, &tmp1); + zmul(aes->num, tmp1, &a); + zmul(aes->den, tmp1, &tmp2); + zshift(tmp2, 1, &d); + zfree(tmp1); + zfree(tmp2); + zequo(aes->den, g, &tmp1); + zmul(bes->num, tmp1, &b); + zfree(tmp1); + zfree(g); + qfree(aes); + qfree(bes); + zsquare(a, &tmp1); + zsquare(b, &tmp2); + zfree(b); + zadd(tmp1, tmp2, &tmp3); + zfree(tmp1); + zfree(tmp2); + if (R & 16) { + zshift(tmp3, 4, &tmp1); + zfree(tmp3); + zshift(a, 2, &aa); + zfree(a); + s1 = zsqrt(tmp1, &cc, 16); + zfree(tmp1); + zadd(cc, aa, &tmp1); + if (s1 == 0 && R & 32) { + zmul(tmp1, d, &tmp2); + zfree(tmp1); + s2 = zsqrt(tmp2, &tmp3, 16); + zfree(tmp2); + if (s2 == 0) { + aes = qalloc(); + zshift(d, 1, &tmp1); + zreduce(tmp3, tmp1, &aes->num, &aes->den); + zfree(tmp1); + zfree(tmp3); + zfree(aa); + zfree(cc); + zfree(d); + r = comalloc(); + qtemp = *aes; + qtemp.num.sign = sign; + r->real = qmul(&qtemp, epsilon); + qfree(aes); + bes = qscale(r->real, 1); + qtemp = *bes; + qtemp.num.sign = sign ^ imsign; + r->imag = qdiv(c->imag, &qtemp); + qfree(bes); + return r; + } + s3 = zquo(tmp3, d, &tmp1, s2 < 0); + } + else { + s2 = zquo(tmp1, d, &tmp3, s1 ? (s1 < 0) : 16); + zfree(tmp1); + s3 = zsqrt(tmp3,&tmp1,(s1||s2) ? (s1<0 || s2<0) : 16); + } + zfree(tmp3); + zshift(tmp1, -1, &mul1); + if (*tmp1.v & 1) + up1 = s1 + s2 + s3; + else + up1 = -1; + zfree(tmp1); + zsub(cc, aa, &tmp1); + s2 = zquo(tmp1, d, &tmp2, s1 ? (s1 < 0) : 16); + zfree(tmp1); + s3 = zsqrt(tmp2, &tmp1, (s1 || s2) ? (s1 < 0 || s2 < 0) : 16); + zfree(tmp2); + zshift(tmp1, -1, &mul2); + if (*tmp1.v & 1) + up2 = s1 + s2 + s3; + else + up2 = -1; + zfree(tmp1); + zfree(aa); + } + else { + s1 = zsqrt(tmp3, &cc, 0); + zfree(tmp3); + zadd(cc, a, &tmp1); + if (s1 == 0 && R & 32) { + zmul(tmp1, d, &tmp2); + zfree(tmp1); + s2 = zsqrt(tmp2, &tmp3, 0); + zfree(tmp2); + if (s2 == 0) { + aes = qalloc(); + zreduce(tmp3, d, &aes->num, &aes->den); + zfree(tmp3); + zfree(a); + zfree(cc); + zfree(d); + r = comalloc(); + qtemp = *aes; + qtemp.num.sign = sign; + r->real = qmul(&qtemp, epsilon); + qfree(aes); + bes = qscale(r->real, 1); + qtemp = *bes; + qtemp.num.sign = sign ^ imsign; + r->imag = qdiv(c->imag, &qtemp); + qfree(bes); + return r; + } + s3 = zquo(tmp3, d, &mul1, 0); + } + else { + s2 = zquo(tmp1, d, &tmp3, 0); + zfree(tmp1); + s3 = zsqrt(tmp3, &mul1, 0); + } + up1 = (s1 + s2 + s3) ? 0 : -1; + zfree(tmp3); + zsub(cc, a, &tmp1); + s2 = zquo(tmp1, d, &tmp2, 0); + zfree(tmp1); + s3 = zsqrt(tmp2, &mul2, 0); + up2 = (s1 + s2 + s3) ? 0 : -1; + zfree(tmp2); + zfree(a); + } + zfree(cc); zfree(d); + if (up1 == 0) { + if (R & 8) + up1 = (long)((R ^ *mul1.v) & 1); + else + up1 = (R ^ epsilon->num.sign ^ sign) & 1; + if (R & 2) + up1 ^= epsilon->num.sign ^ sign; + if (R & 4) + up1 ^= epsilon->num.sign; + } + if (up2 == 0) { + if (R & 8) + up2 = (long)((R ^ *mul2.v) & 1); + else + up2 = (R ^ epsilon->num.sign ^ sign ^ imsign) & 1; + if (R & 2) + up2 ^= epsilon->num.sign ^ imsign ^ sign; + if (R & 4) + up2 ^= epsilon->num.sign; + } + if (up1 > 0) { + zadd(mul1, _one_, &tmp1); + zfree(mul1); + mul1 = tmp1; + } + if (up2 > 0) { + zadd(mul2, _one_, &tmp2); + zfree(mul2); + mul2 = tmp2; + } + if (ziszero(mul1)) + u = qlink(&_qzero_); + else { + mul1.sign = sign ^ epsilon->num.sign; + u = qalloc(); + zreduce(mul1, epsilon->den, &tmp2, &u->den); + zmul(tmp2, epsilon->num, &u->num); + zfree(tmp2); + } + zfree(mul1); + if (ziszero(mul2)) + v = qlink(&_qzero_); + else { + mul2.sign = imsign ^ sign ^ epsilon->num.sign; + v = qalloc(); + zreduce(mul2, epsilon->den, &tmp2, &v->den); + zmul(tmp2, epsilon->num, &v->num); + zfree(tmp2); + } + zfree(mul2); + if (qiszero(u) && qiszero(v)) { + qfree(u); + qfree(v); + return clink(&_czero_); + } + r = comalloc(); + if (!qiszero(u)) + r->real = u; + if (!qiszero(v)) + r->imag = v; + 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(COMPLEX *c, NUMBER *q, NUMBER *epsilon) +{ + COMPLEX *r; + NUMBER *a2pb2, *root, *tmp1, *tmp2, *epsilon2; + long n, m; + + if (qisneg(q) || qiszero(q) || qisfrac(q)) { + math_error("Taking bad root of complex number"); + /*NOTREACHED*/ + } + if (cisone(c) || qisone(q)) + return clink(c); + if (qistwo(q)) + return csqrt(c, epsilon, 24L); + if (cisreal(c) && !qisneg(c->real)) { + r = comalloc(); + 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). + */ + n = qilog2(epsilon); + epsilon2 = qbitvalue(n - 4); + tmp1 = qsquare(c->real); + tmp2 = qsquare(c->imag); + a2pb2 = qqadd(tmp1, tmp2); + qfree(tmp1); + qfree(tmp2); + tmp1 = qscale(q, 1L); + root = qroot(a2pb2, tmp1, epsilon2); + qfree(a2pb2); + qfree(tmp1); + m = qilog2(root); + if (m < n) { + qfree(root); + return clink(&_czero_); + } + qfree(epsilon2); + epsilon2 = qbitvalue(n - m - 4); + 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(COMPLEX *c, NUMBER *epsilon) +{ + COMPLEX *r; + NUMBER *sin, *cos, *tmp1, *tmp2, *epsilon1; + long k, n; + + if (qiszero(epsilon)) { + math_error("Zero epsilon for cexp"); + /*NOTREACHED*/ + } + r = comalloc(); + if (cisreal(c)) { + r->real = qexp(c->real, epsilon); + return r; + } + n = qilog2(epsilon); + epsilon1 = qbitvalue(n - 2); + tmp1 = qexp(c->real, epsilon1); + qfree(epsilon1); + if (qiszero(tmp1)) { + qfree(tmp1); + return clink(&_czero_); + } + k = qilog2(tmp1) + 1; + if (k < n) { + qfree(tmp1); + return clink(&_czero_); + } + qsincos(c->imag, k - n + 2, &sin, &cos); + tmp2 = qmul(tmp1, cos); + qfree(cos); + r->real = qmappr(tmp2, epsilon, 24L); + qfree(tmp2); + tmp2 = qmul(tmp1, sin); + qfree(tmp1); + qfree(sin); + r->imag = qmappr(tmp2, epsilon, 24L); + qfree(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(COMPLEX *c, NUMBER *epsilon) +{ + COMPLEX *r; + NUMBER *a2b2, *tmp1, *tmp2, *epsilon1; + + if (ciszero(c)) { + math_error("Logarithm of zero"); + /*NOTREACHED*/ + } + 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 = qqadd(tmp1, tmp2); + qfree(tmp1); + qfree(tmp2); + epsilon1 = qscale(epsilon, 1L); + tmp1 = qln(a2b2, epsilon1); + qfree(a2b2); + qfree(epsilon1); + 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(x) = (exp(1i * x) + exp(-1i * x))/2; + */ +COMPLEX * +ccos(COMPLEX *c, NUMBER *epsilon) +{ + COMPLEX *r, *ctmp1, *ctmp2, *ctmp3; + NUMBER *epsilon1; + long n; + BOOL neg; + + if (qiszero(epsilon)) { + math_error("Zero epsilon for ccos"); + /*NOTREACHED*/ + } + n = qilog2(epsilon); + ctmp1 = comalloc(); + neg = qisneg(c->imag); + ctmp1->real = neg ? qneg(c->imag) : qlink(c->imag); + ctmp1->imag = neg ? qlink(c->real) : qneg(c->real); + epsilon1 = qbitvalue(n - 2); + ctmp2 = cexp(ctmp1, epsilon1); + comfree(ctmp1); + qfree(epsilon1); + if (ciszero(ctmp2)) { + comfree(ctmp2); + return clink(&_czero_); + } + ctmp1 = cinv(ctmp2); + ctmp3 = cadd(ctmp2, ctmp1); + comfree(ctmp1); + comfree(ctmp2); + ctmp1 = cscale(ctmp3, -1); + comfree(ctmp3); + r = comalloc(); + r->real = qmappr(ctmp1->real, epsilon, 24L); + r->imag = qmappr(ctmp1->imag, epsilon, 24L); + comfree(ctmp1); + return r; +} + + +/* + * Calculate the complex sine within the specified accuracy. + * This uses the formula: + * sin(x) = (exp(1i * x) - exp(-i1*x))/(2i). + */ +COMPLEX * +csin(COMPLEX *c, NUMBER *epsilon) +{ + COMPLEX *r, *ctmp1, *ctmp2, *ctmp3; + NUMBER *qtmp, *epsilon1; + long n; + BOOL neg; + + if (qiszero(epsilon)) { + math_error("Zero epsilon for csin"); + /*NOTREACHED*/ + } + if (ciszero(c)) + return clink(&_czero_); + n = qilog2(epsilon); + ctmp1 = comalloc(); + neg = qisneg(c->imag); + ctmp1->real = neg ? qneg(c->imag) : qlink(c->imag); + ctmp1->imag = neg ? qlink(c->real) : qneg(c->real); + epsilon1 = qbitvalue(n - 2); + ctmp2 = cexp(ctmp1, epsilon1); + comfree(ctmp1); + qfree(epsilon1); + if (ciszero(ctmp2)) { + comfree(ctmp2); + return clink(&_czero_); + } + ctmp1 = cinv(ctmp2); + ctmp3 = csub(ctmp2, ctmp1); + comfree(ctmp1); + comfree(ctmp2); + ctmp1 = cscale(ctmp3, -1); + comfree(ctmp3); + r = comalloc(); + qtmp = neg ? qlink(ctmp1->imag) : qneg(ctmp1->imag); + r->real = qmappr(qtmp, epsilon, 24L); + qfree(qtmp); + qtmp = neg ? qneg(ctmp1->real) : qlink(ctmp1->real); + r->imag = qmappr(qtmp, epsilon, 24L); + qfree(qtmp); + comfree(ctmp1); + 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(NUMBER *q1, NUMBER *q2, NUMBER *epsilon) +{ + COMPLEX *r; + NUMBER *tmp, *cos, *sin; + long m, n; + + if (qiszero(epsilon)) { + math_error("Zero epsilson for cpolar"); + /*NOTREACHED*/ + } + if (qiszero(q1)) + return qlink(&_czero_); + m = qilog2(q1) + 1; + n = qilog2(epsilon); + if (m < n) + return qlink(&_czero_); + r = comalloc(); + if (qiszero(q2)) { + r->real = qlink(q1); + return r; + } + qsincos(q2, m - n + 2, &sin, &cos); + tmp = qmul(q1, cos); + qfree(cos); + r->real = qmappr(tmp, epsilon, 24L); + qfree(tmp); + tmp = qmul(q1, sin); + qfree(sin); + r->imag = qmappr(tmp, epsilon, 24L); + qfree(tmp); + return r; +} + + +/* + * Raise one complex number to the power of another one to within the + * specified error. + */ +COMPLEX * +cpower(COMPLEX *c1, COMPLEX *c2, NUMBER *epsilon) +{ + COMPLEX *ctmp1, *ctmp2; + long k1, k2, k, m1, m2, m, n; + NUMBER *a2b2, *qtmp1, *qtmp2, *epsilon1; + + if (qiszero(epsilon)) { + math_error("Zero epsilon for cpower"); + /*NOTREACHED*/ + } + if (ciszero(c1)) { + if (qisneg(c2->real) || qiszero(c2->real)) { + math_error ("Non-positive exponent of zero"); + /*NOTREACHED*/ + } + return clink(&_czero_); + } + n = qilog2(epsilon); + m1 = m2 = -1000000; + k1 = k2 = 0; + qtmp1 = qsquare(c1->real); + qtmp2 = qsquare(c1->imag); + a2b2 = qqadd(qtmp1, qtmp2); + qfree(qtmp1); + qfree(qtmp2); + if (!qiszero(c2->real)) { + m1 = qilog2(c2->real); + epsilon1 = qbitvalue(-m1 - 1); + qtmp1 = qln(a2b2, epsilon1); + qfree(epsilon1); + qfree(a2b2); + qtmp2 = qmul(qtmp1, c2->real); + qfree(qtmp1); + qtmp1 = qmul(qtmp2, &_qlge_); + qfree(qtmp2); + k1 = qtoi(qtmp1); + qfree(qtmp1); + } + if (!qiszero(c2->imag)) { + m2 = qilog2(c2->imag); + epsilon1 = qbitvalue(-m2 - 1); + qtmp1 = qatan2(c1->imag, c1->real, epsilon1); + qfree(epsilon1); + qtmp2 = qmul(qtmp1, c2->imag); + qfree(qtmp1); + qtmp1 = qscale(qtmp2, -1); + qfree(qtmp2); + qtmp2 = qmul(qtmp1, &_qlge_); + qfree(qtmp1); + k2 = qtoi(qtmp2); + qfree(qtmp2); + } + m = (m2 > m1) ? m2 : m1; + k = k1 - k2 + 1; + if (k < n) + return clink(&_czero_); + epsilon1 = qbitvalue(n - k - m - 2); + ctmp1 = cln(c1, epsilon1); + qfree(epsilon1); + ctmp2 = cmul(ctmp1, c2); + comfree(ctmp1); + ctmp1 = cexp(ctmp2, epsilon); + comfree(ctmp2); + return ctmp1; +} + + +/* + * Print a complex number in the current output mode. + */ +void +comprint(COMPLEX *c) +{ + NUMBER qtmp; + + if (conf->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(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/commath.c b/commath.c new file mode 100644 index 0000000..a644a19 --- /dev/null +++ b/commath.c @@ -0,0 +1,555 @@ +/* + * 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 }; + + +/* + * Add two complex numbers. + */ +COMPLEX * +cadd(COMPLEX *c1, COMPLEX *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 = qqadd(c1->real, c2->real); + if (!qiszero(c1->imag) || !qiszero(c2->imag)) + r->imag = qqadd(c1->imag, c2->imag); + return r; +} + + +/* + * Subtract two complex numbers. + */ +COMPLEX * +csub(COMPLEX *c1, COMPLEX *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(COMPLEX *c1, COMPLEX *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 = qqadd(c1->real, c1->imag); + q3 = qqadd(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 = qqadd(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(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(COMPLEX *c1, COMPLEX *c2) +{ + COMPLEX *r; + NUMBER *q1, *q2, *q3, *den; + + if (ciszero(c2)) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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 = qqadd(q1, q2); + qfree(q1); + qfree(q2); + q1 = qmul(c1->real, c2->real); + q2 = qmul(c1->imag, c2->imag); + q3 = qqadd(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(COMPLEX *c) +{ + COMPLEX *r; + NUMBER *q1, *q2, *den; + + if (ciszero(c)) { + math_error("Inverting zero"); + /*NOTREACHED*/ + } + 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 = qqadd(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(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(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(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(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(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(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(COMPLEX *c, NUMBER *q) +{ + COMPLEX *r; + + if (qiszero(q)) + return clink(c); + r = comalloc(); + r->real = qqadd(c->real, q); + r->imag = qlink(c->imag); + return r; +} + + +/* + * Subtract a real number from a complex number. + */ +COMPLEX * +csubq(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(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(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(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(COMPLEX *c, NUMBER *q) +{ + COMPLEX *r; + + if (qiszero(q)) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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; +} + + + + +/* + * Construct a complex number given the real and imaginary components. + */ +COMPLEX * +qqtoc(NUMBER *q1, NUMBER *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(COMPLEX *c1, COMPLEX *c2) +{ + BOOL i; + + i = qcmp(c1->real, c2->real); + if (!i) + i = qcmp(c1->imag, c2->imag); + return i; +} + + +/* + * Compare two complex numbers and return a complex number with real and + * imaginary parts -1, 0 or 1 indicating relative values of the real and + * imaginary parts of the two numbers. + */ +COMPLEX * +crel(COMPLEX *c1, COMPLEX *c2) +{ + COMPLEX *c; + + c = comalloc(); + c->real = itoq((long) qrel(c1->real, c2->real)); + c->imag = itoq((long) qrel(c1->imag, c2->imag)); + + return c; +} + + +/* + * Allocate a new complex number. + */ +COMPLEX * +comalloc(void) +{ + COMPLEX *r; + + r = (COMPLEX *) malloc(sizeof(COMPLEX)); + if (r == NULL) { + math_error("Cannot allocate complex number"); + /*NOTREACHED*/ + } + r->links = 1; + r->real = qlink(&_qzero_); + r->imag = qlink(&_qzero_); + return r; +} + + +/* + * Free a complex number. + */ +void +comfree(COMPLEX *c) +{ + if (--(c->links) > 0) + return; + qfree(c->real); + qfree(c->imag); + free(c); +} + +/* END CODE */ diff --git a/config.c b/config.c new file mode 100644 index 0000000..382efbf --- /dev/null +++ b/config.c @@ -0,0 +1,985 @@ +/* + * Copyright (c) 1995 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" +#include "token.h" +#include "zrand.h" + + +/* + * Table of configuration types that can be set or read. + */ +NAMETYPE configs[] = { + {"all", CONFIG_ALL}, + {"mode", CONFIG_MODE}, + {"display", CONFIG_DISPLAY}, + {"epsilon", CONFIG_EPSILON}, + /*epsilonprec -- tied to epsilon not a configuration type*/ + {"trace", CONFIG_TRACE}, + {"maxprint", CONFIG_MAXPRINT}, + {"mul2", CONFIG_MUL2}, + {"sq2", CONFIG_SQ2}, + {"pow2", CONFIG_POW2}, + {"redc2", CONFIG_REDC2}, + {"tilde", CONFIG_TILDE}, + {"tab", CONFIG_TAB}, + {"quomod", CONFIG_QUOMOD}, + {"quo", CONFIG_QUO}, + {"mod", CONFIG_MOD}, + {"sqrt", CONFIG_SQRT}, + {"appr", CONFIG_APPR}, + {"cfappr", CONFIG_CFAPPR}, + {"cfsim", CONFIG_CFSIM}, + {"outround", CONFIG_OUTROUND}, + {"round", CONFIG_ROUND}, + {"leadzero", CONFIG_LEADZERO}, + {"fullzero", CONFIG_FULLZERO}, + {"maxerr", CONFIG_MAXERR}, + {"prompt", CONFIG_PROMPT}, + {"more", CONFIG_MORE}, + {"random", CONFIG_RANDOM}, + {NULL, 0} +}; + + +/* + * configurations + */ +CONFIG oldstd = { /* backward compatible standard configuration */ + MODE_INITIAL, /* current output mode */ + 20, /* current output digits for float or exp */ + NULL, /* loaded in at startup - default error for real functions */ + EPSILONPREC_DEFAULT, /* binary precision of epsilon */ + FALSE, /* tracing flags */ + MAXPRINT_DEFAULT, /* number of elements to print */ + MUL_ALG2, /* size of number to use multiply alg 2 */ + SQ_ALG2, /* size of number to use square alg 2 */ + POW_ALG2, /* size of modulus to use REDC for powers */ + REDC_ALG2, /* size of modulus to use REDC algorithm 2 */ + TRUE, /* ok to print a tilde on aproximations */ + TRUE, /* ok to print tab before numeric values */ + 0, /* quomod() default rounding mode */ + 2, /* quotent // default rounding mode */ + 0, /* mod % default rounding mode */ + 24, /* sqrt() default rounding mode */ + 24, /* appr() default rounding mode */ + 0, /* cfappr() default rounding mode */ + 8, /* cfsim() default rounding mode */ + 2, /* output default rounding mode */ + 24, /* round()/bround() default rounding mode */ + FALSE, /* ok to print leading 0 before decimal pt */ + 0, /* ok to print trailing 0's */ + MAXERRORCOUNT, /* max errors before abort */ + PROMPT1, /* normal prompt */ + PROMPT2, /* prompt when inside multi-line input */ + 3 /* require 1 mod 4 and to pass ptest(newn,1) */ +}; +CONFIG newstd = { /* new non-backward compatible configuration */ + MODE_INITIAL, /* current output mode */ + 10, /* current output digits for float or exp */ + NULL, /* loaded in at startup - default error for real functions */ + NEW_EPSILONPREC_DEFAULT, /* binary precision of epsilon */ + FALSE, /* tracing flags */ + MAXPRINT_DEFAULT, /* number of elements to print */ + MUL_ALG2, /* size of number to use multiply alg 2 */ + SQ_ALG2, /* size of number to use square alg 2 */ + POW_ALG2, /* size of modulus to use REDC for powers */ + REDC_ALG2, /* size of modulus to use REDC algorithm 2 */ + TRUE, /* ok to print a tilde on aproximations */ + TRUE, /* ok to print tab before numeric values */ + 0, /* quomod() default rounding mode */ + 0, /* quotent // default rounding mode */ + 0, /* mod % default rounding mode */ + 24, /* sqrt() default rounding mode */ + 24, /* appr() default rounding mode */ + 0, /* cfappr() default rounding mode */ + 8, /* cfsim() default rounding mode */ + 24, /* output default rounding mode */ + 24, /* round()/bround() default rounding mode */ + TRUE, /* ok to print leading 0 before decimal pt */ + 1, /* ok to print trailing 0's */ + MAXERRORCOUNT, /* max errors before abort */ + "; ", /* normal prompt */ + ";; ", /* prompt when inside multi-line input */ + 3 /* require 1 mod 4 and to pass ptest(newn,1) */ +}; +CONFIG *conf = NULL; /* loaded in at startup - current configuration */ + + +/* + * Possible output modes. + */ +static NAMETYPE 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 NAMETYPE 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} +}; + + +/* + * declate static functions + */ +static int modetype(char *name); +static int truthtype(char *name); +static char *modename(int type); + + +/* + * Given a string value which represents a configuration name, return + * the configuration type for that string. Returns negative type if + * the string is unknown. + * + * given: + * name configuration name + */ +int +configtype(char *name) +{ + NAMETYPE *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. + * + * given: + * name mode name + */ +static int +modetype(char *name) +{ + NAMETYPE *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. + * + * given: + * name mode name + */ +static int +truthtype(char *name) +{ + NAMETYPE *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(int type) +{ + NAMETYPE *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(int type, VALUE *vp) +{ + NUMBER *q; + CONFIG *newconf; /* new configuration to set */ + long temp; + char *p; + + switch (type) { + case CONFIG_ALL: + newconf = NULL; /* firewall */ + if (vp->v_type == V_STR) { + if (strcmp(vp->v_str, "oldstd") == 0) { + newconf = &oldstd; + } else if (strcmp(vp->v_str, "newstd") == 0) { + newconf = &newstd; + } else { + math_error("CONFIG alias not oldstd or newstd"); + /*NOTREACHED*/ + } + } else if (vp->v_type != V_CONFIG) { + math_error("non-CONFIG for all"); + /*NOTREACHED*/ + } else { + newconf = vp->v_config; + } + + /* free the current configuration */ + config_free(conf); + + /* set the new configuration */ + conf = config_copy(newconf); + break; + + case CONFIG_TRACE: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for trace"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || !zistiny(q->num) || + ((unsigned long) temp > TRACE_MAX)) { + math_error("Bad trace value"); + /*NOTREACHED*/ + } + conf->traceflags = (FLAG)temp; + break; + + case CONFIG_DISPLAY: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for display"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + temp = modetype(vp->v_str); + if (temp < 0) { + math_error("Unknown mode \"%s\"", vp->v_str); + /*NOTREACHED*/ + } + math_setmode((int) temp); + break; + + case CONFIG_EPSILON: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for epsilon"); + /*NOTREACHED*/ + } + setepsilon(vp->v_num); + break; + + case CONFIG_MAXPRINT: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for maxprint"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + conf->maxprint = temp; + break; + + case CONFIG_MUL2: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for mul2"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + conf->mul2 = (int)temp; + break; + + case CONFIG_SQ2: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for sq2"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + conf->sq2 = (int)temp; + break; + + case CONFIG_POW2: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for pow2"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + conf->pow2 = (int)temp; + break; + + case CONFIG_REDC2: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for redc2"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + conf->redc2 = (int)temp; + break; + + + case CONFIG_TILDE: + if (vp->v_type == V_NUM) { + q = vp->v_num; + conf->tilde_ok = !qiszero(q); + } else if (vp->v_type == V_STR) { + temp = truthtype(vp->v_str); + if (temp < 0) { + math_error("Illegal truth value"); + /*NOTREACHED*/ + } + conf->tilde_ok = (int)temp; + } + break; + + case CONFIG_TAB: + if (vp->v_type == V_NUM) { + q = vp->v_num; + conf->tab_ok = !qiszero(q); + } else if (vp->v_type == V_STR) { + temp = truthtype(vp->v_str); + if (temp < 0) { + math_error("Illegal truth value"); + /*NOTREACHED*/ + } + conf->tab_ok = (int)temp; + } + break; + + case CONFIG_QUOMOD: + if (vp->v_type != V_NUM) { + math_error("Non numeric for quomod"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal quomod parameter value"); + /*NOTREACHED*/ + } + conf->quomod = temp; + break; + + case CONFIG_QUO: + if (vp->v_type != V_NUM) { + math_error("Non numeric for quo"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal quo parameter value"); + /*NOTREACHED*/ + } + conf->quo = temp; + break; + + case CONFIG_MOD: + if (vp->v_type != V_NUM) { + math_error("Non numeric for mod"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal mod parameter value"); + /*NOTREACHED*/ + } + conf->mod = temp; + break; + + case CONFIG_SQRT: + if (vp->v_type != V_NUM) { + math_error("Non numeric for sqrt"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal sqrt parameter value"); + /*NOTREACHED*/ + } + conf->sqrt = temp; + break; + + case CONFIG_APPR: + if (vp->v_type != V_NUM) { + math_error("Non numeric for appr"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal appr parameter value"); + /*NOTREACHED*/ + } + conf->appr = temp; + break; + + case CONFIG_CFAPPR: + if (vp->v_type != V_NUM) { + math_error("Non numeric for cfappr"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal cfappr parameter value"); + /*NOTREACHED*/ + } + conf->cfappr = temp; + break; + + case CONFIG_CFSIM: + if (vp->v_type != V_NUM) { + math_error("Non numeric for cfsim"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal cfsim parameter value"); + /*NOTREACHED*/ + } + conf->cfsim = temp; + break; + + case CONFIG_OUTROUND: + if (vp->v_type != V_NUM) { + math_error("Non numeric for outround"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal output parameter value"); + /*NOTREACHED*/ + } + conf->outround = temp; + break; + + case CONFIG_ROUND: + if (vp->v_type != V_NUM) { + math_error("Non numeric for round"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) { + math_error("Illegal output parameter value"); + /*NOTREACHED*/ + } + conf->round = temp; + break; + + case CONFIG_LEADZERO: + if (vp->v_type == V_NUM) { + q = vp->v_num; + conf->leadzero = !qiszero(q); + } else if (vp->v_type == V_STR) { + temp = truthtype(vp->v_str); + if (temp < 0) { { + math_error("Illegal truth value"); + /*NOTREACHED*/ + } + } + conf->leadzero = (int)temp; + } + break; + + case CONFIG_FULLZERO: + if (vp->v_type == V_NUM) { + q = vp->v_num; + conf->fullzero = !qiszero(q); + } else if (vp->v_type == V_STR) { + temp = truthtype(vp->v_str); + if (temp < 0) { { + math_error("Illegal truth value"); + /*NOTREACHED*/ + } + } + conf->fullzero = (int)temp; + } + break; + + case CONFIG_MAXERR: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for maxerr"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) + temp = -1; + if (temp < 0) { + math_error("Maxerr value is out of range"); + /*NOTREACHED*/ + } + conf->maxerrorcount = temp; + break; + + case CONFIG_PROMPT: + if (vp->v_type != V_STR) { + math_error("Non-string for prompt"); + /*NOTREACHED*/ + } + p = (char *)malloc(strlen(vp->v_str) + 1); + if (p == NULL) { + math_error("Cannot duplicate new prompt"); + /*NOTREACHED*/ + } + strcpy(p, vp->v_str); + free(conf->prompt1); + conf->prompt1 = p; + break; + + case CONFIG_MORE: + if (vp->v_type != V_STR) { + math_error("Non-string for more prompt"); + /*NOTREACHED*/ + } + p = (char *)malloc(strlen(vp->v_str) + 1); + if (p == NULL) { + math_error("Cannot duplicate new more prompt"); + /*NOTREACHED*/ + } + strcpy(p, vp->v_str); + free(conf->prompt2); + conf->prompt2 = p; + break; + + case CONFIG_RANDOM: + if (vp->v_type != V_NUM) { + math_error("Non-numeric for random config value"); + /*NOTREACHED*/ + } + q = vp->v_num; + temp = qtoi(q); + if (qisfrac(q) || qisneg(q) || !zistiny(q->num)) + temp = -1; + if (temp < BLUM_CFG_MIN || temp > BLUM_CFG_MAX) { + math_error("Random config value is out of range"); + /*NOTREACHED*/ + } + conf->random = temp; + break; + + default: + math_error("Setting illegal config parameter"); + /*NOTREACHED*/ + } +} + + +/* + * config_copy - copy the configuration from one value to another + * + * given: + * src copy this configuration + * + * returns: + * prointer to the configuration copy + */ +CONFIG * +config_copy(CONFIG *src) +{ + CONFIG *dest; /* the new CONFIG to return */ + + /* + * firewall + */ + if (src == NULL || src->epsilon == NULL || src->prompt1 == NULL || + src->prompt2 == NULL) { + math_error("bad CONFIG value"); + /*NOTREACHED*/ + } + + /* + * malloc the storage + */ + dest = (CONFIG *)malloc(sizeof(CONFIG)); + if (dest == NULL) { + math_error("malloc of CONFIG failed"); + /*NOTREACHED*/ + } + + /* + * copy over the values + */ + *dest = *src; + + /* + * clone the pointer values + */ + dest->epsilon = qlink(src->epsilon); + dest->prompt1 = (char *)malloc(strlen(src->prompt1)+1); + if (dest->prompt1 == NULL) { + math_error("cannot dup prompt1 for new CONFIG value"); + /*NOTREACHED*/ + } + strcpy(dest->prompt1, src->prompt1); + dest->prompt2 = (char *)malloc(strlen(src->prompt2)+1); + if (dest->prompt2 == NULL) { + math_error("cannot dup prompt2 for new CONFIG value"); + /*NOTREACHED*/ + } + strcpy(dest->prompt2, src->prompt2); + + /* + * return the new value + */ + return dest; +} + + +/* + * config_free - free a CONFIG value + * + * given: + * cfg the CONFIG value to free + */ +void +config_free(CONFIG *cfg) +{ + /* + * firewall + */ + if (cfg == NULL) { + return; + } + + /* + * free prointer values + */ + if (cfg->epsilon != NULL) { + qfree(cfg->epsilon); + } + if (cfg->prompt1 != NULL) { + free(cfg->prompt1); + } + if (cfg->prompt2 != NULL) { + free(cfg->prompt2); + } + + /* + * free the CONFIG value itself + */ + free(cfg); + return; +} + + +/* + * config_value - return a CONFIG element as a value + * + * given: + * cfg CONFIG from which an element will be returned + * type the type of CONFIG element to print + * ret where to return the value + * + * returns: + * ret points to the VALUE returned + */ +void +config_value(CONFIG *cfg, int type, VALUE *vp) +{ + long i=0; + + /* + * firewall + */ + if (cfg == NULL || cfg->epsilon == NULL || cfg->prompt1 == NULL || + cfg->prompt2 == NULL) { + math_error("bad CONFIG value"); + /*NOTREACHED*/ + } + + /* + * convert element to value + */ + vp->v_type = V_NUM; + switch (type) { + case CONFIG_ALL: + vp->v_type = V_CONFIG; + vp->v_config = config_copy(conf); + return; + + case CONFIG_TRACE: + i = cfg->traceflags; + break; + + case CONFIG_DISPLAY: + i = cfg->outdigits; + break; + + case CONFIG_MODE: + vp->v_type = V_STR; + vp->v_subtype = V_STRLITERAL; + vp->v_str = modename(cfg->outmode); + return; + + case CONFIG_EPSILON: + vp->v_num = qlink(cfg->epsilon); + return; + + case CONFIG_MAXPRINT: + i = cfg->maxprint; + break; + + case CONFIG_MUL2: + i = cfg->mul2; + break; + + case CONFIG_SQ2: + i = cfg->sq2; + break; + + case CONFIG_POW2: + i = cfg->pow2; + break; + + case CONFIG_REDC2: + i = cfg->redc2; + break; + + case CONFIG_TILDE: + i = cfg->tilde_ok; + break; + + case CONFIG_TAB: + i = cfg->tab_ok; + break; + + case CONFIG_QUOMOD: + i = cfg->quomod; + break; + + case CONFIG_QUO: + i = cfg->quo; + break; + + case CONFIG_MOD: + i = cfg->mod; + break; + + case CONFIG_SQRT: + i = cfg->sqrt; + break; + + case CONFIG_APPR: + i = cfg->appr; + break; + + case CONFIG_CFAPPR: + i = cfg->cfappr; + break; + + case CONFIG_CFSIM: + i = cfg->cfsim; + break; + + case CONFIG_OUTROUND: + i = cfg->outround; + break; + + case CONFIG_ROUND: + i = cfg->round; + break; + + case CONFIG_LEADZERO: + i = cfg->leadzero; + break; + + case CONFIG_FULLZERO: + i = cfg->fullzero; + break; + + case CONFIG_MAXERR: + i = cfg->maxerrorcount; + break; + + case CONFIG_PROMPT: + vp->v_type = V_STR; + vp->v_subtype = V_STRLITERAL; + vp->v_str = cfg->prompt1; + return; + + case CONFIG_MORE: + vp->v_type = V_STR; + vp->v_subtype = V_STRLITERAL; + vp->v_str = cfg->prompt2; + return; + + case CONFIG_RANDOM: + i = cfg->random; + break; + + default: + math_error("Getting illegal CONFIG element"); + /*NOTREACHED*/ + } + + /* + * if we got this far, we have a V_NUM in i + */ + vp->v_num = itoq(i); + return; +} + + +/* + * config_cmp - compare two CONFIG states + * + * given: + * cfg1 - 1st CONFIG to compare + * cfg2 - 2nd CONFIG to compare + * + * return: + * TRUE if configurations differ + */ +BOOL +config_cmp(CONFIG *cfg1, CONFIG *cfg2) +{ + /* + * firewall + */ + if (cfg1 == NULL || cfg1->epsilon == NULL || cfg1->prompt1 == NULL || + cfg1->prompt2 == NULL) { + math_error("CONFIG #1 value is invaid"); + /*NOTREACHED*/ + } + if (cfg2 == NULL || cfg2->epsilon == NULL || cfg2->prompt1 == NULL || + cfg2->prompt2 == NULL) { + math_error("CONFIG #2 value is invaid"); + /*NOTREACHED*/ + } + + /* + * compare + */ + return cfg1->traceflags != cfg2->traceflags || + cfg1->outdigits != cfg2->outdigits || + cfg1->outmode != cfg2->outmode || + qcmp(cfg1->epsilon, cfg2->epsilon) || + cfg1->epsilonprec != cfg2->epsilonprec || + cfg1->maxprint != cfg2->maxprint || + cfg1->mul2 != cfg2->mul2 || + cfg1->sq2 != cfg2->sq2 || + cfg1->pow2 != cfg2->pow2 || + cfg1->redc2 != cfg2->redc2 || + cfg1->tilde_ok != cfg2->tilde_ok || + cfg1->tab_ok != cfg2->tab_ok || + cfg1->quomod != cfg2->quomod || + cfg1->quo != cfg2->quo || + cfg1->mod != cfg2->mod || + cfg1->sqrt != cfg2->sqrt || + cfg1->appr != cfg2->appr || + cfg1->cfappr != cfg2->cfappr || + cfg1->cfsim != cfg2->cfsim || + cfg1->outround != cfg2->outround || + cfg1->round != cfg2->round || + cfg1->leadzero != cfg2->leadzero || + cfg1->fullzero != cfg2->fullzero || + cfg1->maxerrorcount != cfg2->maxerrorcount || + strcmp(cfg1->prompt1, cfg2->prompt1) != 0 || + strcmp(cfg1->prompt2, cfg2->prompt2) != 0 || + cfg1->random != cfg2->random; +} diff --git a/config.h b/config.h new file mode 100644 index 0000000..c44be3c --- /dev/null +++ b/config.h @@ -0,0 +1,143 @@ +/* + * Copyright (c) 1995 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. + * + * Prior to calc 2.9.3t9, these routines existed as a calc library called + * cryrand.cal. They have been rewritten in C for performance as well + * as to make them available directly from libcalc.a. + * + * 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 + * + * chongo was here /\../\ + */ + +#if !defined(CONFIG_H) +#define CONFIG_H + +#include "qmath.h" + + +/* + * configuration element types + */ +#define CONFIG_ALL 0 /* not a real configuration parameter */ +#define CONFIG_MODE 1 /* types of configuration parameters */ +#define CONFIG_DISPLAY 2 +#define CONFIG_EPSILON 3 +#define CONFIG_EPSILONPREC 3 /* not a real type -- tied to CONFIG_EPSILON */ +#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 +#define CONFIG_QUOMOD 12 +#define CONFIG_QUO 13 +#define CONFIG_MOD 14 +#define CONFIG_SQRT 15 +#define CONFIG_APPR 16 +#define CONFIG_CFAPPR 17 +#define CONFIG_CFSIM 18 +#define CONFIG_OUTROUND 19 +#define CONFIG_ROUND 20 +#define CONFIG_LEADZERO 21 +#define CONFIG_FULLZERO 22 +#define CONFIG_MAXERR 23 +#define CONFIG_PROMPT 24 +#define CONFIG_MORE 25 +#define CONFIG_RANDOM 26 + + +/* + * config defult symbols + */ +#define DISPLAY_DEFAULT 20 /* default digits for float display */ +#define EPSILON_DEFAULT "1e-20" /* allowed error for float calculations */ +#define EPSILONPREC_DEFAULT 67 /* 67 ==> 2^-67 <= EPSILON_DEFAULT < 2^-66 */ +#define NEW_EPSILON_DEFAULT "1e-10" /* newstd EPSILON_DEFAULT */ +#define NEW_EPSILONPREC_DEFAULT 34 /* 34 ==> 2^-34 <= 1e-10 < 2^-33 */ +#define MAXPRINT_DEFAULT 16 /* default number of elements printed */ +#define MAXERRORCOUNT 20 /* default max errors before an abort */ + + +/* + * configuration object + */ +struct config { + int outmode; /* current output mode */ + long outdigits; /* current output digits for float or exp */ + NUMBER *epsilon; /* default error for real functions */ + long epsilonprec; /* epsilon binary precision (tied to epsilon) */ + FLAG traceflags; /* tracing flags */ + long maxprint; /* number of elements to print */ + LEN mul2; /* size of number to use multiply algorithm 2 */ + LEN sq2; /* size of number to use square algorithm 2 */ + LEN pow2; /* size of modulus to use REDC for powers */ + LEN redc2; /* size of modulus to use REDC algorithm 2 */ + int tilde_ok; /* ok to print a tilde on aproximations */ + int tab_ok; /* ok to print tab before numeric values */ + long quomod; /* quomod() default rounding mode */ + long quo; /* quotent // default rounding mode */ + long mod; /* mod % default rounding mode */ + long sqrt; /* sqrt() default rounding mode */ + long appr; /* appr() default rounding mode */ + long cfappr; /* cfappr() default rounding mode */ + long cfsim; /* cfsim() default rounding mode */ + long outround; /* output default rounding mode */ + long round; /* round()/bround() default rounding mode */ + int leadzero; /* ok to print leading 0 before decimal pt */ + int fullzero; /* ok to print trailing 0's -- XXX ??? */ + long maxerrorcount; /* max errors before abort */ + char *prompt1; /* normal prompt */ + char *prompt2; /* prompt when inside multi-line input */ + int random; /* random mode */ +}; +typedef struct config CONFIG; + + +/* + * global configuration states and aliases + */ +extern CONFIG *conf; /* current configuration */ +extern CONFIG oldstd; /* backward compatible standard configuration */ +extern CONFIG newstd; /* new non-backward compatible configuration */ + + +/* + * configuration functions + */ +extern CONFIG *config_copy(CONFIG *src); +extern void config_free(CONFIG *cfg); +extern void config_print(CONFIG *cfg); +extern BOOL config_cmp(CONFIG *cfg1, CONFIG *cfg2); +extern int configtype(char *name); + + +#endif diff --git a/const.c b/const.c new file mode 100644 index 0000000..dfa24ab --- /dev/null +++ b/const.c @@ -0,0 +1,113 @@ +/* + * 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. + * + * given: + * str string representation of number + */ +long +addnumber(char *str) +{ + NUMBER *q; + + q = str2q(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. + * + * XXX - we should hash the constant table + * + * given: + * q number to be added + */ +long +addqconstant(NUMBER *q) +{ + 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(unsigned long index) +{ + if ((index <= 0) || (index > constcount)) + return NULL; + return consttable[index]; +} + +/* END CODE */ diff --git a/endian.c b/endian.c new file mode 100644 index 0000000..a1ce342 --- /dev/null +++ b/endian.c @@ -0,0 +1,78 @@ +/* + * 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 + +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif + +/* byte order array */ +char byte[8] = { (char)0x12, (char)0x36, (char)0x48, (char)0x59, + (char)0x01, (char)0x23, (char)0x45, (char)0x67 }; + +MAIN +main(void) +{ + /* 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 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/file.c b/file.c new file mode 100644 index 0000000..d5b9104 --- /dev/null +++ b/file.c @@ -0,0 +1,2308 @@ +/* + * Copyright (c) 1996 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 +#include +#include +#include +#include +#include +#include "calc.h" +#include "longbits.h" +#include "have_fpos.h" +#include "fposval.h" +#include "file.h" + + +#define READSIZE 1024 /* buffer size for reading */ + + +/* + * XXX - the seek / tell stuff needs to deal with: + * + * files larger than 2^32 bytes (at least as large as 2^40 bytes) + * use Posix conventions + * use Posix file position types + * not assume that a 'long' can hold a file position + * + * Should use fgetpos and fsetpos functions. + */ + +/* + * 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, (dev_t)0, (ino_t)0, + "(stdin)", TRUE, FALSE, 'r', "r"}, + {FILEID_STDOUT, NULL, (dev_t)0, (ino_t)0, + "(stdout)", FALSE, TRUE, 'w', "w"}, + {FILEID_STDERR, NULL, (dev_t)0, (ino_t)0, + "(stderr)", FALSE, TRUE, 'w', "w"} +}; + + +static int ioindex[MAXFILES] = {0,1,2}; /* Indices for FILEIO table */ +static FILEID lastid = FILEID_STDERR; /* Last allocated file id */ +static int idnum = 3; /* Number of allocated file ids */ + + +/* forward static declarations */ +static ZVALUE filepos2z(FILEPOS pos); +static FILEPOS z2filepos(ZVALUE pos); +static int set_open_pos(FILE *fp, ZVALUE zpos); +static int get_open_pos(FILE *fp, ZVALUE *res); +static ZVALUE stsize2z(off_t siz); +static ZVALUE dev2z(dev_t dev); +static ZVALUE inode2z(ino_t inode); +static int get_open_siz(FILE *fp, ZVALUE *res); +static FILEIO *findid(FILEID id, int mode); +static void getscanfield(FILE *fp, BOOL skip, unsigned int width, + int scannum, char *scanptr, char **strptr); +static void getscanwhite(FILE *fp, BOOL skip, unsigned int width, + int scannum, char **strptr); +static int fscanfile(FILE *fp, char *fmt, int count, VALUE **vals); +static void freadnum(FILE *fp, VALUE *valptr); +static void freadsum(FILE *fp, VALUE *valptr); +static void freadprod(FILE *fp, VALUE *valptr); +static void fskipnum(FILE *fp); + + +/* + * 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. + * + * We will also probe for any open files beyond stderr and set them up. + */ +void +file_init(void) +{ + static int done = 0; /* 1 => routine already called */ + struct stat sbuf; /* file status */ + FILEIO *fiop; + FILE *fp; + int i; + + if (!done) { + /* + * setup the default set + */ + files[0].fp = stdin; + files[1].fp = stdout; + files[2].fp = stderr; + for (i = 0; i < 3; ++i) { + if (fstat(i, &sbuf) >= 0) { + files[i].dev = sbuf.st_dev; + files[i].inode = sbuf.st_ino; + } + } + + /* + * note any other files that we can find + */ + fiop = &files[3]; + for (i = 3; i < MAXFILES; fiop++, ++i) { + char *tname; + + fiop->name = NULL; + files[idnum].reading = TRUE; + files[idnum].writing = TRUE; + files[idnum].action = 0; + /* + * stat the descriptor to see what we have + */ + if (fstat(i, &sbuf) >= 0) { + fp = (FILE *) fdopen(i,"r+"); /*guess mode*/ + if (fp) + strcpy(files[idnum].mode, "r+"); + else { + fp = (FILE *) fdopen(i, "r"); + if (fp) { + strcpy(files[idnum].mode, "r"); + files[idnum].writing = FALSE; + } + else { + fp = (FILE *) fdopen(i, "w"); + if (fp) { + strcpy(files[idnum].mode, "w?"); + files[idnum].reading = FALSE; + } + else + continue; + } + } + tname = (char *)malloc(sizeof("descriptor[19]")); + if (tname == NULL) { + math_error("Out of memory for init_file"); + /*NOTREACHED*/ + } + sprintf(tname, "descriptor[%d]", i); + files[idnum].name = tname; + files[idnum].id = idnum; + files[idnum].fp = fp; + files[idnum].dev = sbuf.st_dev; + files[idnum].inode = sbuf.st_ino; + ioindex[idnum] = idnum; + idnum++; + lastid++; + } + } + + done = 1; + } +} + + +/* + * Open the specified file name for reading or writing; mode is assumed + * to be one of "r", "w", "a", "r+", "w+", "a+". + * Returns a file id which can be used to do I/O to the file, or else + * FILEID_NONE if the open failed. + * + * given: + * name file name + * mode open mode + */ +FILEID +openid(char *name, char *mode) +{ + FILEIO *fiop; /* file structure */ + FILEID id; /* new file id */ + FILE *fp; + struct stat sbuf; /* file status */ + int i; + + if (idnum >= MAXFILES) + return -77; + + fiop = &files[3]; + for (i = 3; i < MAXFILES; fiop++,i++) { + if (fiop->name == NULL) + break; + } + if (i == MAXFILES) + math_error("This should not happen in openid()!!!"); + + fp = f_open(name, mode); + + if (fp == NULL) { + return FILEID_NONE; + } + if (fstat(fileno(fp), &sbuf) < 0) { + math_error("bad fstat"); + /*NOTREACHED*/ + } + + fiop->name = (char *)malloc(strlen(name) + 1); + if (fiop->name == NULL) { + math_error("No memory for filename"); + /*NOTREACHED*/ + } + id = ++lastid; + ioindex[idnum++] = i; + + strcpy(fiop->name, name); + fiop->id = id; + fiop->fp = fp; + fiop->dev = sbuf.st_dev; + fiop->inode = sbuf.st_ino; + fiop->reading = TRUE; + fiop->writing = TRUE; + fiop->action = 0; + if (mode[1] == '\0') { + if (*mode == 'r') + fiop->writing = FALSE; + else + fiop->reading = FALSE; + } + strcpy(fiop->mode, mode); + return id; +} + + +/* + * reopenid - reopen a FILEID + * + * given: + * id FILEID to reopen + * mode new mode to open as + * name name of new file + */ +FILEID +reopenid(FILEID id, char *mode, char *name) +{ + FILEIO *fiop; /* file structure */ + FILE *fp; + char *newname; + struct stat sbuf; + int i; + + /* firewall */ + if ((id == FILEID_STDIN) || (id == FILEID_STDOUT) || + (id == FILEID_STDERR)) { + math_error("Cannot freopen stdin, stdout, or stderr"); + /*NOTREACHED*/ + } + + fiop = NULL; + + for (i = 3; i < idnum; i++) { + fiop = &files[ioindex[i]]; + if (fiop->id == id) + break; + } + if (i == idnum) { + if (name == NULL) { + fprintf(stderr, "File not open, need file name\n"); + return FILEID_NONE; + } + if (idnum >= MAXFILES) { + fprintf(stderr, "Too many open files\n"); + return FILEID_NONE; + } + for (fiop = &files[3], i = 3; i < MAXFILES; fiop++, i++) { + if (fiop->name == NULL) + break; + } + if (i >= MAXFILES) { + math_error("This should not happen in reopenid"); + /*NOTREACHED*/ + } + fp = f_open(name, mode); + if (fp == NULL) { + fprintf(stderr, "Cannot open file\n"); + return FILEID_NONE; + } + ioindex[idnum++] = i; + fiop->id = id; + } else { + if (name == NULL) + fp = freopen(fiop->name, mode, fiop->fp); + else + fp = freopen(name, mode, fiop->fp); + if (fp == NULL) { + free(fiop->name); + fiop->name = NULL; + idnum--; + for (; i < idnum; i++) + ioindex[i] = ioindex[i + 1]; + return FILEID_NONE; + } + } + + if (fstat(fileno(fp), &sbuf) < 0) { + math_error("bad fstat"); + /*NOTREACHED*/ + } + + if (name) { + newname = (char *)malloc(strlen(name) + 1); + if (newname == NULL) { + math_error("No memory for filename"); + /*NOTREACHED*/ + } + if (fiop->name) + free(fiop->name); + strcpy(newname, name); + fiop->name = newname; + } + fiop->fp = fp; + fiop->dev = sbuf.st_dev; + fiop->inode = sbuf.st_ino; + fiop->reading = TRUE; + fiop->writing = TRUE; + fiop->action = 0; + if (mode[1] == '\0') { + if (*mode == 'r') + fiop->writing = FALSE; + else + fiop->reading = FALSE; + } + strcpy(fiop->mode, mode); + 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(FILEID id, int mode) +{ + FILEIO *fiop; /* file structure */ + int i; + + fiop = NULL; + + if ((id < 0) || (id > lastid)) + return NULL; + + for (i = 0; i < idnum; i++) { + fiop = &files[ioindex[i]]; + if (fiop->id == id) + break; + } + + if (i == idnum) + return NULL; + + switch (mode) { + case 'r': + if (!fiop->reading) + return NULL; + break; + case 'w': + if (!fiop->writing) + return NULL; + break; + case 0: + break; + default: + /* This should not happen */ + math_error("Unknown findid mode"); + /*NOTREACHED*/ + } + return fiop; +} + + +/* + * Return whether or not a file id is valid. This is used for if tests. + */ +BOOL +validid(FILEID id) +{ + return (findid(id, 0) != NULL); +} + + +/* + * Return the file with id = index if this is the id of a file that has been + * opened (it may have since been closed). Otherwise returns FILEID_NONE. + */ +FILEID +indexid(long index) +{ + FILEID id; + + id = (FILEID) index; + + if ((index < 0) || (id > lastid)) + return FILEID_NONE; + return id; +} + + + +/* + * 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. + */ +int +closeid(FILEID id) +{ + FILEIO *fiop; /* file structure */ + int i; + int err; + + fiop = NULL; + + /* firewall */ + if ((id == FILEID_STDIN) || (id == FILEID_STDOUT) || + (id == FILEID_STDERR)) { + math_error("Cannot close stdin, stdout, or stderr"); + /*NOTREACHED*/ + } + + /* get file structure */ + for (i = 3; i < idnum; i++) { + fiop = &files[ioindex[i]]; + if (fiop->id == id) + break; + } + if (i == idnum) + return 1; /* File not open */ + idnum--; + for (; i < idnum; i++) + ioindex[i] = ioindex[i + 1]; + + free(fiop->name); + fiop->name = NULL; + + /* close file and note error state */ + err = ferror(fiop->fp); + err |= fclose(fiop->fp); + fiop->fp = NULL; + + /* return success or failure */ + return (err ? EOF : 0); +} + + +int +closeall(void) +{ + FILEIO *fiop; + int i; + int err; + + err = 0; + for (i = 3; i < idnum; i++) { + fiop = &files[ioindex[i]]; + if (fiop->fp) { + free(fiop->name); + fiop->name = NULL; + err |= fclose(fiop->fp); + } + } + idnum = 3; + return err; +} + + +/* + * Return whether or not an error occurred to a file. + */ +BOOL +errorid(FILEID id) +{ + FILEIO *fiop; /* file structure */ + + fiop = findid(id, 0); + if (fiop == NULL) + return EOF; + return (ferror(fiop->fp) != 0); +} + + +/* + * Return whether or not end of file occurred to a file. + */ +BOOL +eofid(FILEID id) +{ + FILEIO *fiop; /* file structure */ + + fiop = findid(id, 0); + if (fiop == NULL) + return EOF; + return (feof(fiop->fp) != 0); +} + + +/* + * Flush output to an opened file. + */ +int +flushid(FILEID id) +{ + FILEIO *fiop; /* file structure */ + + fiop = findid(id, 0); + if (fiop == NULL) + return 0; + if (!fiop->writing || fiop->action == 'r') + return 0; + return fflush(fiop->fp); +} + +int +flushall(void) +{ + FILEIO *fiop; + int i; + int err; + + err = 0; + for (i = 3; i < idnum; i++) { + fiop = &files[ioindex[i]]; + if (fiop->writing && fiop->action != 'r') + err |= fflush(fiop->fp); + } + return err; +} + + +/* + * Read the next line, string or word from an opened file. + * Returns a pointer to an allocated string holding a null-terminated + * or newline terminated string. Where reading stops is controlled by + * flags: + * + * bit 0: at newline + * bit 1: at null character + * bit 2: at white space (also skips leading white space) + * + * If neither '\n' nor '\0' is encountered reading continues until EOF. + * If bit 3 is set the stop character is removed. + * + * given: + * id file to read from + * flags read flags (see above) + * retptr returned pointer to string + */ +int +readid(FILEID id, int flags, char **retptr) +{ + FILEIO *fiop; /* file structure */ + FILE *fp; + char *str; /* current string */ + unsigned long n; /* current number characters read into buf */ + unsigned long totlen; /* total length of string copied from buf */ + char buf[READSIZE]; /* temporary buffer */ + char *b; + int c; + BOOL nlstop, nullstop, wsstop, rmstop, done; + long fpos; + + totlen = 0; + str = NULL; + + fiop = findid(id, 'r'); + if (fiop == NULL) + return 1; + nlstop = (flags & 1); + nullstop = (flags & 2); + wsstop = (flags & 4); + rmstop = (flags & 8); + + fp = fiop->fp; + + if (fiop->action == 'w') { + fpos = ftell(fp); + fflush(fp); + if (fseek(fp, fpos, 0) < 0) + return 3; + } + fiop->action = 'r'; + + if (wsstop) { + while (isspace(c = fgetc(fp))); + ungetc(c, fp); + } + + for (;;) { + b = buf; + n = 0; + do { + c = fgetc(fp); + if (c == EOF) + break; + n++; + if (nlstop && c == '\n') + break; + if (nullstop && c == '\0') + break; + if (wsstop && isspace(c)) + break; + *b++ = c; + } while (n < READSIZE); + done = ((nlstop && c == '\n') || (nullstop && c == '\0') || + (wsstop && isspace(c)) || c == EOF); + if (done && rmstop && c != EOF) + n--; + if (totlen) + str = (char *)realloc(str, totlen + n + 1); + else + str = (char *)malloc(n + 1); + if (str == NULL) { + math_error("Out of memory for readid"); + /*NOTREACHED*/ + } + if (n > 0) + memcpy(&str[totlen], buf, n); + totlen += n; + if (done) + break; + } + if (totlen == 0 && c == EOF) { + free(str); + return EOF; + } + if ((nlstop && c == '\n') && !rmstop) + str[totlen - 1] = '\n'; + if ((nullstop && c == '\0') && !rmstop) + str[totlen - 1] = '\0'; + str[totlen] = '\0'; + *retptr = str; + return 0; +} + + +/* + * Return the next character from an opened file. + * Returns EOF if there was an error or end of file. + */ +int +getcharid(FILEID id) +{ + FILEIO *fiop; + long fpos; + + fiop = findid(id, 'r'); + if (fiop == NULL) + return -2; + if (fiop->action == 'w') { + fpos = ftell(fiop->fp); + fflush(fiop->fp); + if (fseek(fiop->fp, fpos, SEEK_SET) < 0) + return -3; + } + fiop->action = 'r'; + + return fgetc(fiop->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. + */ +int +printid(FILEID id, int flags) +{ + FILEIO *fiop; /* file structure */ + FILE *fp; + ZVALUE pos; /* file position */ + + /* + * filewall - file is closed + */ + fiop = findid(id, 0); + if (fiop == NULL) { + if (flags & PRINT_UNAMBIG) + math_fmt("FILE %d closed", id); + else + math_str("\"\""); + return 1; + } + + /* + * print quoted filename and mode + */ + if ((flags & PRINT_UNAMBIG) == 0) { + math_chr('"'); + math_str(fiop->name); + math_chr('"'); + return 0; + } + math_fmt("FILE %d \"%s\" (%s, ", id, fiop->name, fiop->mode); + + /* + * print file position + */ + + fp = fiop->fp; + + if (get_open_pos(fp, &pos) < 0) { + math_str("Error while determining file position!)"); + return 0; + } + + math_str("pos "); + zprintval(pos, 0, 0); + zfree(pos); + + /* + * report special status + */ + if (ferror(fp)) + math_str(", error"); + if (feof(fp)) + math_str(", eof"); + math_chr(')'); + + printf(" fileno: %d ", fileno(fp)); + return 0; +} + + +/* + * 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. + * + * given: + * id file id to print to + * count print count + * fmt standard format string + * vals table of values to print + */ +int +idprintf(FILEID id, char *fmt, int count, VALUE **vals) +{ + FILEIO *fiop; + VALUE *vp; + char *str; + int ch; + unsigned long len; + int oldmode, newmode; + long olddigits, newdigits; + long width, precision; + BOOL didneg, didprecision; + long fpos; + + fiop = findid(id, 'w'); + if (fiop == NULL) + return 1; + if (fiop->action == 'r') { + fpos = ftell(fiop->fp); + if (fseek(fiop->fp, fpos, SEEK_SET) < 0) + return 3; + } + + fiop->action = 'w'; + + + math_setfp(fiop->fp); + + while ((ch = *fmt++) != '\0') { + 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 = conf->outmode; + newmode = oldmode; + olddigits = conf->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 0; + default: + math_chr(ch); + continue; + } + + if (--count < 0) { + while (width-- > 0) + math_chr(' '); + continue; + } + 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); + return 0; +} + + +/* + * Write a character to a file. + * + * given: + * id file id to print to + * ch character to write + */ +int +idfputc(FILEID id, int ch) +{ + FILEIO *fiop; + long fpos; + + /* get the file info pointer */ + fiop = findid(id, 'w'); + if (fiop == NULL) + return 1; + if (fiop->action == 'r') { + fpos = ftell(fiop->fp); + if (fseek(fiop->fp, fpos, SEEK_SET)) + return 2; + } + + fiop->action = 'w'; + + /* set output to file */ + math_setfp(fiop->fp); + + /* write char */ + math_chr(ch); + + /* restore output to stdout */ + math_setfp(stdout); + return 0; +} + + +/* + * Unget a character read from a file. + * + * given: + * id file id to print to + * ch character to write + */ +int +idungetc(FILEID id, int ch) +{ + FILEIO *fiop; + + fiop = findid(id, 'r'); + if (fiop == NULL) + return -2; + if (fiop->action != 'r') + return -2; + return ungetc(ch, fiop->fp); +} + + +/* + * Write a string to a file. + * + * given: + * id file id to print to + * str string to write + */ +int +idfputs(FILEID id, char *str) +{ + FILEIO *fiop; + long fpos; + + /* get the file info pointer */ + fiop = findid(id, 'w'); + if (fiop == NULL) + return 1; + + if (fiop->action == 'r') { + fpos = ftell(fiop->fp); + if (fseek(fiop->fp, fpos, SEEK_SET)) + return 2; + } + + fiop->action = 'w'; + + /* set output to file */ + math_setfp(fiop->fp); + + /* write the string */ + math_str(str); + + /* restore output to stdout */ + math_setfp(stdout); + return 0; +} + +/* + * Same as idfputs but writes a terminating null character + * + * given: + * id file id to print to + * str string to write + */ +int +idfputstr(FILEID id, char *str) +{ + FILEIO *fiop; + long fpos; + + /* get the file info pointer */ + fiop = findid(id, 'w'); + if (fiop == NULL) + return 1; + + if (fiop->action == 'r') { + fpos = ftell(fiop->fp); + if (fseek(fiop->fp, fpos, SEEK_SET)) + return 2; + } + + fiop->action = 'w'; + + /* set output to file */ + math_setfp(fiop->fp); + + /* write the string */ + math_str(str); + + math_chr('\0'); + + /* restore output to stdout */ + math_setfp(stdout); + return 0; +} + +int +rewindid(FILEID id) +{ + FILEIO *fiop; + fiop = findid(id, 0); + if (fiop == NULL) + return 1; + rewind(fiop->fp); + fiop->action = 0; + return 0; +} + +void +rewindall(void) +{ + FILEIO *fiop; + int i; + + for (i = 3; i < idnum; i++) { + fiop = &files[ioindex[i]]; + if (fiop != NULL) { + (void) rewind(fiop->fp); + fiop->action = 0; + } + } +} + + +/* + * filepos2z - convert a positive file position into a ZVALUE + * + * given: + * pos file position + * + * returns: + * file position as a ZVALUE + * + * NOTE: Does not support negative file positions. + */ +static ZVALUE +filepos2z(FILEPOS pos) +{ + ZVALUE ret; /* ZVALUE file position to return */ + + /* + * store FILEPOS in a ZVALUE as a positive value + */ + ret.len = FILEPOS_BITS/BASEB; + ret.v = alloc(ret.len); + zclearval(ret); + SWAP_HALF_IN_FILEPOS(ret.v, &pos); + ret.sign = 0; + ztrim(&ret); + + /* + * return our result + */ + return ret; +} + + +/* + * z2filepos - convert a positive ZVALUE file position to a FILEPOS + * + * given: + * zpos file position as a ZVALUE + * + * returns: + * file position as a FILEPOS + * + * NOTE: Does not support negative file positions. + */ +static FILEPOS +z2filepos(ZVALUE zpos) +{ +#if FILEPOS_BITS > FULL_BITS + FILEPOS tmp; /* temp file position as a FILEPOS */ +#endif + FILEPOS ret; /* file position as a FILEPOS */ + FULL pos; /* zpos as a FULL */ + + /* + * firewall + */ + zpos.sign = 0; /* deal only with the absolue value */ + + /* + * quick return if the position can fit into a long + */ +#if FILEPOS_BITS <= FULL_BITS + /* ztofull puts the value into native byte order */ + pos = ztofull(zpos); + /* on some hosts, FILEPOS is not a scalar */ + memset(&ret, 0, sizeof(FILEPOS)); + memcpy((void *)&ret, (void *)&pos, sizeof(FILEPOS)); + return ret; +#else /* FILEPOS_BITS <= FULL_BITS */ + if (!zgtmaxfull(zpos)) { + /* ztofull puts the value into native byte order */ + pos = ztofull(zpos); + ret = pos; + return ret; + } + + /* + * copy (and swap if needed) lower part of the ZVALUE as needed + */ + if (zpos.len >= FILEPOS_BITS/BASEB) { + /* copy the lower FILEPOS_BITS of the ZVALUE */ + memcpy(&tmp, zpos.v, sizeof(FILEPOS)); + } else { + /* copy what bits we can into the temp value */ + tmp = 0; + memcpy(&tmp, zpos.v, zpos.len*BASEB/8); + } + /* swap into native byte order */ + SWAP_HALF_IN_FILEPOS(&ret, &tmp); + + /* + * return our result + */ + return ret; +#endif /* FILEPOS_BITS <= FULL_BITS */ +} + + +/* + * get_open_pos - get a an open file position + * + * given: + * fp open file stream + * res where to place the file position (ZVALUE) + * + * returns: + * 0 res points to the file position + * -1 error + */ +static int +get_open_pos(FILE *fp, ZVALUE *res) +{ + FILEPOS pos; /* current file position */ + + /* + * get the file position + */ +#if defined(HAVE_FPOS) + if (fgetpos(fp, (FILEPOS *)&pos) < 0) { + /* cannot get file position, return -1 */ + return -1; + } +#else + pos = ftell(fp); + if (pos < 0) { + /* cannot get file position, return -1 */ + return -1; + } +#endif + + /* + * update file position and return success + */ + *res = filepos2z(pos); + return 0; +} + + +/* + * getloc - get the current position of the file + * + * given: + * id file id of the file + * loc pointer to result + * + * returns: + * 0 able to get file position + * -1 unable to get file position + */ +int +getloc(FILEID id, ZVALUE *res) +{ + FILEIO *fiop; /* file structure */ + FILE *fp; + + /* + * convert id to stream + */ + fiop = findid(id, 0); + if (fiop == NULL) { + /* file not open */ + return -1; + } + fp = fiop->fp; + if (fp == NULL) { + math_error("Bogus internal file pointer!"); + /*NOTREACHED*/ + } + + /* + * return result + */ + return get_open_pos(fp, res); +} + +long +ftellid(FILEID id) +{ + FILEIO *fiop; + + fiop = findid(id, 0); + if (fiop == NULL) + return -2L; + return ftell(fiop->fp); +} + + +long +fseekid(FILEID id, long offset, int whence) +{ + FILEIO *fiop; + long i = 0; + + fiop = findid(id, 0); + if (fiop == NULL) + return -2; + switch (whence) { + case 0: + i = fseek(fiop->fp, offset, SEEK_SET); + break; + case 1: + i = fseek(fiop->fp, offset, SEEK_CUR); + break; + case 2: + i = fseek(fiop->fp, offset, SEEK_END); + break; + default: + math_error("This should not happen in fseekid"); + /*NOTREACHED*/ + } + return i; +} + + +/* + * set_open_pos - set a an open file position + * + * given: + * fp open file stream + * zpos file position (ZVALUE) to set + * + * returns: + * 0 res points to the file position + * -1 error + * + * NOTE: Due to fsetpos limitation, position is set relative to only + * the beginning of the file. + */ +static int +set_open_pos(FILE *fp, ZVALUE zpos) +{ + FILEPOS pos; /* current file position */ + + /* + * convert ZVALUE to file position + */ + pos = z2filepos(zpos); + + /* + * set the file position + */ +#if defined(HAVE_FPOS) + if (fsetpos(fp, (FILEPOS *)&pos) < 0) { + /* cannot set file position, return -1 */ + return -1; + } +#else + if (fseek(fp, pos, 0) < 0) { + /* cannot set file position, return -1 */ + return -1; + } +#endif + + /* + * return sucess + */ + return 0; +} + + +/* + * setloc - set the current position of the file + * + * given: + * id file id of the file + * zpos file position (ZVALUE) to set + * + * returns: + * 0 able to set file position + * -1 unable to set file position + * + * NOTE: Due to fsetpos limitation, position is set relative to only + * the beginning of the file. + */ +int +setloc(FILEID id, ZVALUE zpos) +{ + FILEIO *fiop; /* file structure */ + FILE *fp; + + /* + * firewall + */ + if ((id == FILEID_STDIN) || (id == FILEID_STDOUT) || + (id == FILEID_STDERR)) { + math_error("Cannot fseek stdin, stdout, or stderr"); + /*NOTREACHED*/ + } + + /* + * convert id to stream + */ + fiop = findid(id, 0); + if (fiop == NULL) { + /* file not open */ + return -1; + } + fp = fiop->fp; + if (fp == NULL) { + math_error("Bogus internal file pointer!"); + /*NOTREACHED*/ + } + + fiop->action = 0; + + /* + * return result + */ + return set_open_pos(fp, zpos); +} + + +/* + * stsize2z - convert a file size into a ZVALUE + * + * given: + * siz file size + * + * returns: + * file size as a ZVALUE + */ +static ZVALUE +stsize2z(off_t siz) +{ + ZVALUE ret; /* ZVALUE file size to return */ + + /* + * store off_t in a ZVALUE as a positive value + */ + ret.len = STSIZE_BITS/BASEB; + ret.v = alloc(ret.len); + zclearval(ret); + SWAP_HALF_IN_STSIZE(ret.v, &siz); + ret.sign = 0; + ztrim(&ret); + + /* + * return our result + */ + return ret; +} + + +/* + * dev2z - convert a stat.st_dev into a ZVALUE + * + * given: + * dev device + * + * returns: + * file size as a ZVALUE + */ +static ZVALUE +dev2z(dev_t dev) +{ + ZVALUE ret; /* ZVALUE file size to return */ + + /* + * store off_t in a ZVALUE as a positive value + */ + ret.len = DEV_BITS/BASEB; + ret.v = alloc(ret.len); + zclearval(ret); + SWAP_HALF_IN_DEV(ret.v, &dev); + ret.sign = 0; + ztrim(&ret); + + /* + * return our result + */ + return ret; +} + + +/* + * inode2z - convert a stat.st_ino into a ZVALUE + * + * given: + * inode file size + * + * returns: + * file size as a ZVALUE + */ +static ZVALUE +inode2z(ino_t inode) +{ + ZVALUE ret; /* ZVALUE file size to return */ + + /* + * store off_t in a ZVALUE as a positive value + */ + ret.len = INODE_BITS/BASEB; + ret.v = alloc(ret.len); + zclearval(ret); + SWAP_HALF_IN_INODE(ret.v, &inode); + ret.sign = 0; + ztrim(&ret); + + /* + * return our result + */ + return ret; +} + + +/* + * get_open_siz - get a an open file size + * + * given: + * fp open file stream + * res where to place the file size (ZVALUE) + * + * returns: + * 0 res points to the file size + * -1 error + */ +static int +get_open_siz(FILE *fp, ZVALUE *res) +{ + struct stat buf; /* file status */ + + /* + * get the file size + */ + if (fstat(fileno(fp), &buf) < 0) { + /* stat error */ + return -1; + } + + /* + * update file size and return success + */ + *res = stsize2z(buf.st_size); + return 0; +} + + +/* + * getsize - get the current size of the file + * + * given: + * id file id of the file + * siz pointer to result + * + * returns: + * 0 able to get file size + * -1 unable to get file size + */ +int +getsize(FILEID id, ZVALUE *res) +{ + FILEIO *fiop; /* file structure */ + FILE *fp; + + /* + * convert id to stream + */ + fiop = findid(id, 0); + if (fiop == NULL) { + /* file not open */ + return -1; + } + fp = fiop->fp; + if (fp == NULL) { + return -2; + } + + /* + * return result + */ + return get_open_siz(fp, res); +} + + +/* + * getdevice - get the device of the file + * + * given: + * id file id of the file + * dev pointer to the result + * + * returns: + * 0 able to get device + * -1 unable to get device + */ +int +get_device(FILEID id, ZVALUE *dev) +{ + FILEIO *fiop; /* file structure */ + + /* + * convert id to stream + */ + fiop = findid(id, 0); + if (fiop == NULL) { + /* file not open */ + return -1; + } + + /* + * return result + */ + *dev = dev2z(fiop->dev); + return 0; +} + + +/* + * getinode - get the inode of the file + * + * given: + * id file id of the file + * inode pointer to the result + * + * returns: + * 0 able to get inode + * -1 unable to get inode + */ +int +get_inode(FILEID id, ZVALUE *inode) +{ + FILEIO *fiop; /* file structure */ + + /* + * convert id to stream + */ + fiop = findid(id, 0); + if (fiop == NULL) { + /* file not open */ + return -1; + } + + /* + * return result + */ + *inode = inode2z(fiop->inode); + return 0; +} + +/* deal with file sizes > long */ +long +filesize(FILEID id) +{ + FILEIO *fiop; + struct stat sbuf; + + fiop = findid(id, 0); + if (fiop == NULL) + return -1; + + if (fstat(fileno(fiop->fp), &sbuf) < 0) { + math_error("bad fstat"); + /*NOTREACHED*/ + } + + return (long) sbuf.st_size; +} + +void +showfiles(void) +{ + BOOL listed[MAXFILES]; + FILEIO *fiop; + FILE *fp; + struct stat sbuf; + ino_t inodes[MAXFILES]; + long sizes[MAXFILES]; + int i, j; + + for (i = 0; i < idnum; i++) { + listed[i] = FALSE; + fiop = &files[ioindex[i]]; + fp = fiop->fp; + if (fstat(fileno(fp), &sbuf) < 0) { + printf("Bad fstat for file %d\n", (int) fiop->id); + sizes[i] = -1; + } + else { + inodes[i] = sbuf.st_ino; + sizes[i] = (long) sbuf.st_size; + } + } + for (i = 0; i < idnum; i++) { + if (listed[i]) + continue; + fiop = &files[ioindex[i]]; + printf("\t"); + printid(fiop->id, PRINT_UNAMBIG); + if (sizes[i] == -1) { + math_chr('\n'); + continue; + } + printf(" size = %ld\n", sizes[i]); + for (j = i + 1; j < idnum; j++) { + if (listed[j] || sizes[j] == -1) + continue; + if (inodes[j] == inodes[i]) { + listed[j] = TRUE; + fiop = &files[ioindex[j]]; + printf("\t = "); + printid(fiop->id, PRINT_UNAMBIG); + printf("\n"); + } + } + } + printf("\tNumber open = %d\n", idnum); + printf("\tLastid = %d\n", (int) lastid); +} + + +/* + * getscanfield - scan a field separated by some characters + * + * given: + * fp FILEID to scan + * skip + * width max field width + * scannum Number of characters in scanset + * scanptr string of characters considered separators + * strptr pointer to where the new field pointer may be found + */ +static void +getscanfield(FILE *fp, BOOL skip, unsigned int width, int scannum, char *scanptr, char **strptr) +{ + char *str; /* current string */ + unsigned long len; /* current length of string */ + unsigned long totlen; /* total length of string */ + char buf[READSIZE]; /* temporary buffer */ + int c; + char *b; + BOOL comp; /* Use complement of scanset */ + unsigned int chnum; + + totlen = 0; + str = NULL; + + comp = (scannum < 0); + if (comp) + scannum = -scannum; + + chnum = 0; + + for (;;) { + len = 0; + b = buf; + for(;;) { + c = fgetc(fp); + if (c == EOF || c == '\0') + break; + chnum++; + if(scannum && (memchr(scanptr,c,scannum)==NULL) ^ comp) + break; + if (!skip) { + *b++ = c; + len++; + if (len >= READSIZE) + break; + } + if (chnum == width) + break; + } + if (!skip) { + if (totlen) + str = (char *) realloc(str, totlen + len + 1); + else + str = (char *) malloc(len + 1); + if (str == NULL) { + math_error("Out of memory for scanning"); + /*NOTREACHED*/ + } + if (len) + memcpy(&str[totlen], buf, len); + totlen += len; + } + if (len < READSIZE) + break; + } + + if (!(width && chnum == width) && c != '\0') + ungetc(c, fp); + + if (!skip) { + str[totlen] = '\0'; + *strptr = str; + } +} + + +/* + * getscanwhite - scan a field separated by whitespace + * + * given: + * fp FILEID to scan + * skip + * width max field width + * scannum Number of characters in scanset + * strptr pointer to where the new field pointer may be found + */ +static void +getscanwhite(FILE *fp, BOOL skip, unsigned int width, int scannum, char **strptr) +{ + char *str; /* current string */ + unsigned long len; /* current length of string */ + unsigned long totlen; /* total length of string */ + char buf[READSIZE]; /* temporary buffer */ + int c; + char *b; + BOOL comp; /* Use complement of scanset */ + unsigned int chnum; + + totlen = 0; + str = NULL; + + comp = (scannum < 0); + if (comp) + scannum = -scannum; + + chnum = 0; + + for (;;) { + len = 0; + b = buf; + for(;;) { + c = fgetc(fp); + if (c == EOF || c == '\0') + break; + chnum++; + if(scannum && !isspace(c) ^ comp) + break; + if (!skip) { + *b++ = c; + len++; + if (len >= READSIZE) + break; + } + if (chnum == width) + break; + } + if (!skip) { + if (totlen) + str = (char *) realloc(str, totlen + len + 1); + else + str = (char *) malloc(len + 1); + if (str == NULL) { + math_error("Out of memory for scanning"); + /*NOTREACHED*/ + } + if (len) + memcpy(&str[totlen], buf, len); + totlen += len; + } + if (len < READSIZE) + break; + } + + if (!(width && chnum == width) && c != '\0') + ungetc(c, fp); + + if (!skip) { + str[totlen] = '\0'; + *strptr = str; + } +} + +static int +fscanfile(FILE *fp, char *fmt, int count, VALUE **vals) +{ + int assnum; /* Number of assignments made */ + int c; /* Character read from file */ + char f; /* Character read from format string */ + int scannum; /* Number of characters in scanlist */ + char *scanptr; /* Start of scanlist */ + char *str; + BOOL comp; /* True scanset is complementary */ + BOOL skip; /* True if string to be skipped rather than read */ + int width; + VALUE *var; /* lvalue to be assigned to */ + + if (feof(fp)) + return EOF; + + assnum = 0; + + for (;;) { + for (;;) { + f = *fmt++; + if (isspace(f)) { + getscanwhite(fp,1,0,6,NULL); + do { + f = *fmt++; + } while (isspace(f)); + } + c = fgetc(fp); + if (c == EOF) + return assnum; + if (f == '%') { + f = *fmt++; + if (f != '%' && f != '\0') + break; + } + if (f != c || f == '\0') { + ungetc(c, fp); + return assnum; + } + } + ungetc(c, fp); + skip = (f == '*'); + if (!skip && count == 0) { + return assnum; + } + if (skip) + f = *fmt++; + width = 0; + while (f >= '0' && f <= '9') { + width = 10 * width + f - '0'; + f = *fmt++; + } + switch (f) { + case 'c': + if (width == 0) + width = 1; + getscanfield(fp,skip,width,0,NULL,&str); + break; + case 's': + getscanwhite(fp,1,0,6,NULL); + if (feof(fp)) + return assnum; + getscanwhite(fp,skip,width,-6,&str); + break; + case '[': + f = *fmt; + comp = (f == '^'); + if (comp) + f = *++fmt; + scanptr = fmt; + if (f == '\0') + return assnum; + fmt = strchr((f == ']' ? fmt + 1 : fmt), ']'); + if (fmt == NULL) + return assnum; + scannum = fmt - scanptr; + if (comp) + scannum = -scannum; + fmt++; + getscanfield(fp,skip, + width,scannum,scanptr,&str); + break; + case 'f': + case 'e': + case 'r': + case 'i': + getscanwhite(fp,1,0,6, NULL); + if (feof(fp)) + return assnum; + if (skip) { + fskipnum(fp); + continue; + } + assnum++; + var = *vals++; + if (var->v_type != V_ADDR) + math_error("This should not happen!!"); + var = var->v_addr; + count--; + freadsum(fp, var); + continue; + case 'n': + assnum++; + var = *vals++; + count--; + if (var->v_type != V_ADDR) + math_error("This should not happen!!"); + var = var->v_addr; + var->v_type = V_NUM; + var->v_num = itoq(ftell(fp)); + continue; + default: + fprintf(stderr, "Unsupported scan specifier"); + return assnum; + } + if (!skip) { + assnum++; + var = *vals++; + count--; + if (var->v_type != V_ADDR) + math_error("Assigning to nonvariable XXX"); + var = var->v_addr; + var->v_type = V_STR; + var->v_subtype = V_STRALLOC; + var->v_str = str; + } + } +} + +int +fscanfid(FILEID id, char *fmt, int count, VALUE **vals) +{ + FILEIO *fiop; + FILE *fp; + long fpos; + + fiop = findid(id, 'r'); + if (fiop == NULL) + return -2; + + fp = fiop->fp; + + if (fiop->action == 'w') { + fpos = ftell(fp); + fflush(fp); + if (fseek(fp, fpos, 0) < 0) + return -4; + } + fiop->action = 'r'; + + return fscanfile(fp, fmt, count, vals); +} + + +int +scanfstr(char *str, char *fmt, int count, VALUE **vals) +{ + FILE *fp; + int i; + + fp = tmpfile(); + if (fp == NULL) + return EOF; + fputs(str, fp); + rewind(fp); + i = fscanfile(fp, fmt, count, vals); + fclose(fp); + return i; +} + + +/* + * Read a number in floating-point format from a file. The first dot, + * if any, is considered as the decimal point; later dots are ignored. + * For example, -23.45..67. is interpreted as -23.4567 + * An optional 'e' or 'E' indicates multiplication by a power or 10, + * e.g. -23.45e-6 has the effect of -23.45 * 10^-6. The reading + * ceases when a character other than a digit, a leading sign, + * a sign immediately following 'e' or 'E', or a dot is encountered. + * Absence of digits is interpreted as zero. + */ +static void +freadnum(FILE *fp, VALUE *valptr) +{ + ZVALUE num, den, newnum, newden, div, tmp; + NUMBER *q; + COMPLEX *c; + VALUE val; + char ch; + LEN i; + HALF *a; + FULL f; + long decimals, exp; + BOOL sign, negexp, havedp, imag, exptoobig; + + decimals = 0; + exp = 0; + sign = FALSE; + negexp = FALSE; + havedp = FALSE; + imag = FALSE; + exptoobig = FALSE; + + ch = fgetc(fp); + if (ch == '+' || ch == '-') { + if (ch == '-') + sign = TRUE; + ch = fgetc(fp); + } + num.v = alloc(1); + *num.v = 0; + num.len = 1; + num.sign = sign; + for (;;) { + if (ch >= '0' && ch <= '9') { + f = (FULL) (ch - '0'); + a = num.v; + i = num.len; + while (i-- > 0) { + f = 10 * (FULL) *a + f; + *a++ = (HALF) f; + f >>= BASEB; + } + if (f) { + a = alloc(num.len + 1); + memcpy(a, num.v, num.len * sizeof(HALF)); + a[num.len] = (HALF) f; + num.len++; + freeh(num.v); + num.v = a; + } + if (havedp) + decimals++; + } + else if (ch == '.') + havedp = TRUE; + else + break; + ch = fgetc(fp); + } + if (ch == 'e' || ch == 'E') { + ch = fgetc(fp); + if (ch == '+' || ch == '-') { + if (ch == '-') + negexp = TRUE; + ch = fgetc(fp); + } + while (ch >= '0' && ch <= '9') { + if (!exptoobig) { + exp = (exp * 10) + ch - '0'; + if (exp > 1000000) + exptoobig = TRUE; + } + ch = fgetc(fp); + } + } + if (ch == 'i' || ch == 'I') + imag = TRUE; + else { + ungetc(ch, fp); + } + + if (ziszero(num)) { + zfree(num); + val.v_type = V_NUM; + val.v_num = qlink(&_qzero_); + *valptr = val; + return; + } + if (exptoobig) { + zfree(num); + *valptr = error_value(E_BIGEXP); + return; + } + ztenpow(decimals, &den); + if (exp) { + ztenpow(exp, &tmp); + if (negexp) { + zmul(den, tmp, &newden); + zfree(den); + den = newden; + } else { + zmul(num, tmp, &newnum); + zfree(num); + num = newnum; + } + zfree(tmp); + } + if (!zisunit(num) && !zisunit(den)) { + zgcd(num, den, &div); + if (!zisunit(div)) { + zequo(num, div, &newnum); + zfree(num); + zequo(den, div, &newden); + zfree(den); + num = newnum; + den = newden; + } + } + q = qalloc(); + q->num = num; + q->den = den; + if (imag) { + c = comalloc(); + c->imag = q; + val.v_type = V_COM; + val.v_com = c; + } + else { + val.v_type = V_NUM; + val.v_num = q; + } + *valptr = val; +} + +static void +freadsum(FILE *fp, VALUE *valptr) +{ + VALUE v1, v2, v3; + char ch; + + + freadprod(fp, &v1); + + ch = fgetc(fp); + while (ch == '+' || ch == '-') { + freadprod(fp, &v2); + if (ch == '+') + addvalue(&v1, &v2, &v3); + else + subvalue(&v1, &v2, &v3); + freevalue(&v1); + freevalue(&v2); + v1 = v3; + ch = fgetc(fp); + } + ungetc(ch, fp); + *valptr = v1; +} + + +static void +freadprod(FILE *fp, VALUE *valptr) +{ + VALUE v1, v2, v3; + char ch; + + freadnum(fp, &v1); + ch = fgetc(fp); + while (ch == '*' || ch == '/') { + freadnum(fp, &v2); + if (ch == '*') + mulvalue(&v1, &v2, &v3); + else + divvalue(&v1, &v2, &v3); + freevalue(&v1); + freevalue(&v2); + v1 = v3; + ch = fgetc(fp); + } + ungetc(ch, fp); + *valptr = v1; +} + +static void +fskipnum(FILE *fp) +{ + char ch; + + do { + ch = fgetc(fp); + if (ch == '+' || ch == '-') + ch = fgetc(fp); + while ((ch >= '0' && ch <= '9') || ch == '.') + ch = fgetc(fp); + if (ch == 'e' || ch == 'E') { + ch = fgetc(fp); + if (ch == '+' || ch == '-') + ch = fgetc(fp); + while (ch >= '0' && ch <= '9') + ch = fgetc(fp); + } + if (ch == 'i' || ch == 'I') + ch = fgetc(fp); + } while (ch == '/' || ch == '*' || ch == '+' || ch == '-'); + + ungetc(ch, fp); +} + +int +isattyid(FILEID id) +{ + FILEIO *fiop; + + fiop = findid(id, 0); + if (fiop == NULL) + return -2; + return isatty(fileno(fiop->fp)); +} + +long +fsearch(FILEID id, char *str, long pos) +{ + FILEIO *fiop; + FILE *fp; + long len, n, i; + char c; + char *s; + + fiop = findid(id, 'r'); + if (fiop == NULL) + return -2; + fp = fiop->fp; + if (pos < 0) + pos = ftell(fp); + if (fiop->action == 'w') + fflush(fp); + fseek(fp, pos, SEEK_SET); + len = (long)strlen(str); + if (len == 0) + return pos; + c = *str++; + n = filesize(id) - pos - len; + while (n-- >= 0) { + if ((char) fgetc(fp) == c) { + s = str; + i = len; + while (--i > 0 && (char) fgetc(fp) == *s++); + if (i == 0) + return pos; + fseek(fp, pos + 1, SEEK_SET); + } + pos++; + } + return -1; +} + + +long +frsearch(FILEID id, char *str, long pos) +{ + FILEIO *fiop; + FILE *fp; + long len, n, i; + char c; + char *s; + + fiop = findid(id, 'r'); + if (fiop == NULL) + return -2; + fp = fiop->fp; + if (pos < 0) + pos = ftell(fp); + if (fiop->action == 'w') + fflush(fp); + n = filesize(id); + if (pos > n) + pos = n; + len = (long)strlen(str); + if (pos < len) { + fseek(fp, pos, SEEK_SET); + return -1; + } + pos -= len; + if (len == 0) + return pos; + c = *str++; + while (pos >= 0) { + fseek(fp, pos, SEEK_SET); + if ((char) fgetc(fp) == c) { + s = str; + i = len; + while (--i > 0 && (char) fgetc(fp) == *s++); + if (i == 0) + return pos; + } + pos--; + } + fseek(fp, 0, SEEK_SET); + return -1; +} diff --git a/file.h b/file.h new file mode 100644 index 0000000..826e569 --- /dev/null +++ b/file.h @@ -0,0 +1,60 @@ +/* + * Copyright (c) 1996 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 "have_fpos.h" + + +/* + * Definition of opened files. + */ +typedef struct { + FILEID id; /* id to identify this file */ + FILE *fp; /* real file structure for I/O */ + dev_t dev; /* file device */ + ino_t inode; /* file inode */ + char *name; /* file name */ + BOOL reading; /* TRUE if opened for reading */ + BOOL writing; /* TRUE if opened for writing */ + char action; /* most recent use for 'r', 'w' or 0 */ + char mode[3]; /* open mode */ +} FILEIO; + + +/* + * fgetpos/fsetpos vs fseek/ftell interface + * + * f_seek_set(FILE *stream, FILEPOS *loc) + * Seek loc bytes from the beginning of the open file, stream. + * + * f_tell(FILE *stream, FILEPOS *loc) + * Set loc to bytes from the beinning of the open file, stream. + * + * We assume that if your system does not have fgetpos/fsetpos, + * then it will have a FILEPOS that is a scalar type (e.g., long). + * Some obscure systems without fgetpos/fsetpos may not have a simple + * scalar type. In these cases the f_tell macro below will fail. + */ +#if defined(HAVE_FPOS) + +#define f_seek_set(stream, loc) fsetpos((FILE*)(stream), (FILEPOS*)(loc)) +#define f_tell(stream, loc) fgetpos((FILE*)(stream), (FILEPOS*)(loc)) + +#else + +#define f_seek_set(stream, loc) \ + fseek((FILE*)(stream), *(FILEPOS*)(loc), SEEK_SET) +#define f_tell(stream, loc) (*((FILEPOS*)(loc)) = ftell((FILE*)(stream))) + +#endif + + +/* + * external functions + */ +extern int fgetposid(FILEID id, FILEPOS *ptr); +extern int fsetposid(FILEID id, FILEPOS *ptr); diff --git a/fposval.c b/fposval.c new file mode 100644 index 0000000..f1de9e4 --- /dev/null +++ b/fposval.c @@ -0,0 +1,212 @@ +/* + * fposval - Determine information about the file position type + * + * The include file have_pos.h, as built during the make process will + * define the type FILEPOS as the type used to describe file positions. + * We will print information regarding the size and byte order + * of this definition. + * + * The stat system call returns a stat structure. One of the elements + * of the stat structure is the st_size element. We will print information + * regarding the size and byte order of st_size. + * + * We will #define of 8 symbols: + * + * FILEPOS_BITS length in bits of the type FILEPOS + * SWAP_HALF_IN_FILEPOS will copy/swap FILEPOS into an HALF array + * STSIZE_BITS length in bits of the st_size stat element + * SWAP_HALF_IN_STSIZE will copy/swap st_size into an HALF array + * DEV_BITS length in bits of the st_dev stat element + * SWAP_HALF_IN_DEV will copy/swap st_dev into an HALF array + * INODE_BITS length in bits of the st_ino stat element + * SWAP_HALF_IN_INODE will copy/swap st_ino into an HALF array + * + * With regards to 'will copy/swap ... into an HALF array'. Such macros + * will either be a copy or a copy with HALFs swapped depending on the + * Endian order of the hardware. + */ +/* + * Copyright (c) 1996 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 +#include +#include +#include +#include "have_fpos.h" +#include "endian_calc.h" + +char *program; /* our name */ + +MAIN +main(int argc, char **argv) +{ + int stsizelen; /* bit length of st_size in buf */ + int fileposlen; /* bit length of FILEPOS */ + int devlen; /* bit length of st_dev in buf */ + int inodelen; /* bit length of st_ino in buf */ + struct stat buf; /* file status */ + + /* + * parse args + */ + program = argv[0]; + + /* + * print the file position information + */ + fileposlen = sizeof(FILEPOS)*8; + printf("#undef FILEPOS_BITS\n"); + printf("#define FILEPOS_BITS %d\n", fileposlen); +#if BYTE_ORDER == BIG_ENDIAN + /* + * Big Endian + */ + if (fileposlen == 64) { + printf("#define SWAP_HALF_IN_FILEPOS(dest, src)\t\t%s\n", + "SWAP_HALF_IN_B64(dest, src)"); + } else if (fileposlen == 32) { + printf("#define SWAP_HALF_IN_FILEPOS(dest, src)\t\t%s\n", + "SWAP_HALF_IN_B32(dest, src)"); + } else { + fprintf(stderr, "%s: unexpected FILEPOS bit size: %d\n", + program, fileposlen); + exit(1); + } +#else /* BYTE_ORDER == BIG_ENDIAN */ + /* + * Little Endian + * + * Normally a "(*(dest) = *(src))" would do, but on some + * systems, a FILEPOS is not a scalar hince we must memcpy. + */ + printf("#define SWAP_HALF_IN_FILEPOS(dest, src)\t%s%d%s\n", + "memcpy((void *)(dest), (void *)(src), sizeof(",fileposlen,"))"); +#endif /* BYTE_ORDER == BIG_ENDIAN */ + putchar('\n'); + + /* + * print the stat file size information + */ + stsizelen = sizeof(buf.st_size)*8; + printf("#undef STSIZE_BITS\n"); + printf("#define STSIZE_BITS %d\n", stsizelen); +#if BYTE_ORDER == BIG_ENDIAN + /* + * Big Endian + */ + if (stsizelen == 64) { + printf("#define SWAP_HALF_IN_STSIZE(dest, src)\t\t%s\n", + "SWAP_HALF_IN_B64(dest, src)"); + } else if (stsizelen == 32) { + printf("#define SWAP_HALF_IN_STSIZE(dest, src)\t\t%s\n", + "SWAP_HALF_IN_B32(dest, src)"); + } else { + fprintf(stderr, "%s: unexpected st_size bit size: %d\n", + program, stsizelen); + exit(2); + } +#else /* BYTE_ORDER == BIG_ENDIAN */ + /* + * Little Endian + * + * Normally a "(*(dest) = *(src))" would do, but on some + * systems, a STSIZE is not a scalar hince we must memcpy. + */ + printf("#define SWAP_HALF_IN_STSIZE(dest, src)\t%s%d%s\n", + "memcpy((void *)(dest), (void *)(src), sizeof(",stsizelen,"))"); +#endif /* BYTE_ORDER == BIG_ENDIAN */ + putchar('\n'); + + /* + * print the dev_t size + */ + devlen = sizeof(buf.st_dev)*8; + printf("#undef DEV_BITS\n"); + printf("#define DEV_BITS %d\n", devlen); +#if BYTE_ORDER == BIG_ENDIAN + /* + * Big Endian + */ + if (devlen == 64) { + printf("#define SWAP_HALF_IN_DEV(dest, src)\t\t%s\n", + "SWAP_HALF_IN_B64(dest, src)"); + } else if (devlen == 32) { + printf("#define SWAP_HALF_IN_DEV(dest, src)\t\t%s\n", + "SWAP_HALF_IN_B32(dest, src)"); + } else if (devlen == 16) { + printf("#define SWAP_HALF_IN_DEV(dest, src)\t\t%s\n", + "(*(dest) = *(src))"); + } else { + fprintf(stderr, "%s: unexpected st_dev bit size: %d\n", + program, devlen); + exit(3); + } +#else /* BYTE_ORDER == BIG_ENDIAN */ + /* + * Little Endian + * + * Normally a "(*(dest) = *(src))" would do, but on some + * systems, a DEV is not a scalar hince we must memcpy. + */ + printf("#define SWAP_HALF_IN_DEV(dest, src)\t%s%d%s\n", + "memcpy((void *)(dest), (void *)(src), sizeof(",devlen,"))"); +#endif /* BYTE_ORDER == BIG_ENDIAN */ + putchar('\n'); + + /* + * print the ino_t size + */ + inodelen = sizeof(buf.st_ino)*8; + printf("#undef INODE_BITS\n"); + printf("#define INODE_BITS %d\n", inodelen); +#if BYTE_ORDER == BIG_ENDIAN + /* + * Big Endian + */ + if (inodelen == 64) { + printf("#define SWAP_HALF_IN_INODE(dest, src)\t\t%s\n", + "SWAP_HALF_IN_B64(dest, src)"); + } else if (inodelen == 32) { + printf("#define SWAP_HALF_IN_INODE(dest, src)\t\t%s\n", + "SWAP_HALF_IN_B32(dest, src)"); + } else if (inodelen == 16) { + printf("#define SWAP_HALF_IN_INODE(dest, src)\t\t%s\n", + "(*(dest) = *(src))"); + } else { + fprintf(stderr, "%s: unexpected st_ino bit size: %d\n", + program, inodelen); + exit(4); + } +#else /* BYTE_ORDER == BIG_ENDIAN */ + /* + * Little Endian + * + * Normally a "(*(dest) = *(src))" would do, but on some + * systems, a INODE is not a scalar hince we must memcpy. + */ + printf("#define SWAP_HALF_IN_INODE(dest, src)\t%s%d%s\n", + "memcpy((void *)(dest), (void *)(src), sizeof(",inodelen,"))"); +#endif /* BYTE_ORDER == BIG_ENDIAN */ + exit(0); +} diff --git a/func.c b/func.c new file mode 100644 index 0000000..98abba6 --- /dev/null +++ b/func.c @@ -0,0 +1,4819 @@ +/* + * Copyright (c) 1996 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 +#include + +#if defined(FUNCLIST) + +#include +#define CONST /* disabled for FUNCLIST in case NATIVE_CC doesn't have it */ + +#else /* FUNCLIST */ + +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif + +#include "have_stdlib.h" +#if defined(HAVE_STDLIB_H) +#include +#endif + +#include "have_times.h" +#if defined(HAVE_TIME_H) +#include +#endif +#if defined(HAVE_TIMES_H) +#include +#endif +#if defined(HAVE_SYS_TIME_H) +#include +#endif +#if defined(HAVE_SYS_TIMES_H) +#include +#endif + +#include "have_const.h" +#include "calc.h" +#include "calcerr.h" +#include "opcodes.h" +#include "token.h" +#include "func.h" +#include "string.h" +#include "symbol.h" +#include "prime.h" +#include "file.h" +#include "zrand.h" + + +/* + * forward declarations + */ +static NUMBER *base_value(long mode); +static long zsize(ZVALUE z); +static long qsize(NUMBER *q); +static long lsizeof(VALUE *vp); +static int strscan(char *s, int count, VALUE **vals); +static int filescan(FILEID id, int count, VALUE **vals); +static VALUE f_eval(VALUE *vp); + + + +/* + * external declarations + */ +extern int errno; /* last system error */ +extern char *sys_errlist[]; /* system error messages */ +extern int sys_nerr; /* number of system errors */ +extern char cmdbuf[]; /* command line expression */ +extern CONST char *error_table[E__COUNT+2]; /* calc coded error messages */ +extern void matrandperm(MATRIX *M); +extern void listrandperm(LIST *lp); +extern int idungetc(FILEID id, int ch); + + +/* + * 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 + + +/* + * used defined error strings + */ +static short nexterrnum = E_USERDEF; +static STRINGHEAD newerrorstr; + +#endif /* !FUNCLIST */ + + +/* + * arg count definitons + */ +#define IN 100 /* maximum number of arguments */ +#define FE 0x01 /* flag to indicate default epsilon argument */ +#define FA 0x02 /* preserve addresses of variables */ + + +/* + * builtins - List of primitive built-in functions + */ +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 */ +}; + + +#if !defined(FUNCLIST) + +static VALUE +f_eval(VALUE *vp) +{ + FUNC *oldfunc; + FUNC *newfunc; + VALUE result; + + if (vp->v_type != V_STR) + return error_value(E_EVAL2); + switch (openstring(vp->v_str)) { + case -2: + return error_value(E_EVAL3); + case -1: + return error_value(E_EVAL4); + } + 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); + return error_value(E_EVAL); +} + + +static VALUE +f_prompt(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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + strcpy(newcp, cp); + result.v_str = newcp; + result.v_type = V_STR; + result.v_subtype = V_STRALLOC; + return result; +} + + +static VALUE +f_str(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: + return error_value(E_STR); + } + result.v_str = cp; + result.v_type = V_STR; + result.v_subtype = V_STRALLOC; + return result; +} + + +static VALUE +f_poly(int count, VALUE **vals) +{ + VALUE *x; + VALUE result, tmp; + LIST *clist, *lp; + + if (vals[0]->v_type == V_LIST) { + clist = vals[0]->v_list; + lp = listalloc(); + while (--count > 0) { + if ((*++vals)->v_type == V_LIST) + insertitems(lp, (*vals)->v_list); + else + insertlistlast(lp, *vals); + } + if (!evalpoly(clist, lp->l_first, &result)) { + result.v_type = V_NUM; + result.v_num = qlink(&_qzero_); + } + listfree(lp); + return result; + } + 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(NUMBER *val1, NUMBER *val2, NUMBER *val3) +{ + NUMBER *tmp, *res; + + tmp = qsub(val1, val2); + res = itoq((long) !qdivides(tmp, val3)); + qfree(tmp); + return res; +} + + +static NUMBER * +f_isrel(NUMBER *val1, NUMBER *val2) +{ + if (qisfrac(val1) || qisfrac(val2)) { + math_error("Non-integer for isrel"); + /*NOTREACHED*/ + } + return itoq((long) zrelprime(val1->num, val2->num)); +} + + +static NUMBER * +f_issquare(NUMBER *vp) +{ + return itoq((long) qissquare(vp)); +} + + +static NUMBER * +f_isprime(int count, NUMBER **vals) +{ + NUMBER *err; /* error return, NULL => use math_error */ + + /* determine the way we report problems */ + if (count == 2) { + if (qisfrac(vals[1])) { + math_error("2nd isprime arg must be an integer"); + /*NOTREACHED*/ + } + err = vals[1]; + } else { + err = NULL; + } + + /* firewall - must be an integer */ + if (qisfrac(vals[0])) { + if (err) { + return qlink(err); + } + math_error("non-integral arg for builtin function isprime"); + /*NOTREACHED*/ + } + + /* test the integer */ + switch (zisprime(vals[0]->num)) { + case 0: return qlink(&_qzero_); + case 1: return qlink(&_qone_); + } + + /* error return */ + if (!err) { + math_error("isprime argument is an odd value > 2^32"); + /*NOTREACHED*/ + } + return qlink(err); +} + + +static NUMBER * +f_nprime(int count, NUMBER **vals) +{ + NUMBER *err; /* error return, NULL => use math_error */ + FULL nxt_prime; /* next prime or 0 */ + + /* determine the way we report problems */ + if (count == 2) { + if (qisfrac(vals[1])) { + math_error("2nd nprime arg must be an integer"); + /*NOTREACHED*/ + } + err = vals[1]; + } else { + err = NULL; + } + + /* firewall - must be an integer */ + if (qisfrac(vals[0])) { + if (err) { + return qlink(err); + } + math_error("non-integral arg 1 for builtin function nprime"); + /*NOTREACHED*/ + } + + /* test the integer */ + nxt_prime = znprime(vals[0]->num); + if (nxt_prime > 1) { + return utoq(nxt_prime); + } else if (nxt_prime == 0) { + /* return 2^32+15 */ + return qlink(&_nxtprime_); + } + + /* error return */ + if (!err) { + math_error("nprime arg 1 is >= 2^32"); + /*NOTREACHED*/ + } + return qlink(err); +} + + +static NUMBER * +f_pprime(int count, NUMBER **vals) +{ + NUMBER *err; /* error return, NULL => use math_error */ + FULL prev_prime; /* previous prime or 0 */ + + /* determine the way we report problems */ + if (count == 2) { + if (qisfrac(vals[1])) { + math_error("2nd pprime arg must be an integer"); + /*NOTREACHED*/ + } + err = vals[1]; + } else { + err = NULL; + } + + /* firewall - must be an integer */ + if (qisfrac(vals[0])) { + if (err) { + return qlink(err); + } + math_error("non-integral arg 1 for builtin function pprime"); + /*NOTREACHED*/ + } + + /* test the integer */ + prev_prime = zpprime(vals[0]->num); + if (prev_prime > 1) { + return utoq(prev_prime); + } + if (prev_prime == 0) { + return qlink(&_qzero_); + } + /* error return */ + if (!err) { + if (prev_prime == 0) { + math_error("pprime arg 1 is <= 2"); + /*NOTREACHED*/ + } else { + math_error("pprime arg 1 is >= 2^32"); + /*NOTREACHED*/ + } + } + return qlink(err); +} + + +static NUMBER * +f_factor(int count, NUMBER **vals) +{ + NUMBER *err; /* error return, NULL => use math_error */ + ZVALUE limit; /* highest prime factor in search */ + ZVALUE n; /* number to factor */ + NUMBER *factor; /* the prime factor found */ + int res; /* -1 => error, 0 => not found, 1 => factor found */ + + /* + * parse args + */ + if (count == 3) { + if (qisfrac(vals[2])) { + math_error("3rd factor arg must be an integer"); + /*NOTREACHED*/ + } + err = vals[2]; + } else { + err = NULL; + } + if (count >= 2) { + if (qisfrac(vals[1])) { + if (err) { + return qlink(err); + } + math_error("non-integral arg 2 for builtin factor"); + /*NOTREACHED*/ + } + limit = vals[1]->num; + } else { + /* default limit is 2^32-1 */ + utoz((FULL)0xffffffff, &limit); + } + if (qisfrac(vals[0])) { + if (count < 2) + zfree(limit); + if (err) { + return qlink(err); + } + math_error("non-integral arg 1 for builtin pfactor"); + /*NOTREACHED*/ + } + n = vals[0]->num; + + /* + * find the smallest prime factor in the range + */ + factor = qalloc(); + res = zfactor(n, limit, &(factor->num)); + if (res < 0) { + /* error processing */ + if (err) { + return qlink(err); + } + math_error("limit >= 2^32 for builtin factor"); + /*NOTREACHED*/ + } else if (res == 0) { + if (count < 2) + zfree(limit); + /* no factor found - qalloc set factor to 1, return 1 */ + return factor; + } + + /* + * return the factor found + */ + if (count < 2) + zfree(limit); + return factor; +} + + +static NUMBER * +f_pix(int count, NUMBER **vals) +{ + NUMBER *err; /* error return, NULL => use math_error */ + long value; /* primes <= x, or 0 ==> error */ + + /* determine the way we report problems */ + if (count == 2) { + if (qisfrac(vals[1])) { + math_error("2nd pix arg must be an integer"); + /*NOTREACHED*/ + } + err = vals[1]; + } else { + err = NULL; + } + + /* firewall - must be an integer */ + if (qisfrac(vals[0])) { + if (err) { + return qlink(err); + } + math_error("non-integral arg 1 for builtin function pix"); + /*NOTREACHED*/ + } + + /* determine the number of primes <= x */ + value = zpix(vals[0]->num); + if (value >= 0) { + return utoq(value); + } + + /* error return */ + if (!err) { + math_error("pix arg 1 is >= 2^32"); + /*NOTREACHED*/ + } + return qlink(err); +} + + +static NUMBER * +f_prevcand(int count, NUMBER **vals) +{ + ZVALUE zmodulus; + ZVALUE zresidue; + ZVALUE zskip; + ZVALUE *zcount = NULL; /* ptest trial count */ + ZVALUE tmp; + NUMBER *ans; /* candidate for primality */ + + zmodulus = _one_; + zresidue = _zero_; + zskip = _one_; + /* + * check on the number of args passed and that args passed are ints + */ + switch (count) { + case 5: + if (!qisint(vals[4])) { + math_error( "prevcand 5th arg must both be integer"); + /*NOTREACHED*/ + } + zmodulus = vals[4]->num; + /*FALLTHRU*/ + case 4: + if (!qisint(vals[3])) { + math_error( "prevcand 4th arg must both be integer"); + /*NOTREACHED*/ + } + zresidue = vals[3]->num; + /*FALLTHRU*/ + case 3: + if (!qisint(vals[2])) { + math_error( + "prevcand skip arg (3rd) must be an integer or omitted"); + /*NOTREACHED*/ + } + zskip = vals[2]->num; + /*FALLTHRU*/ + case 2: + if (!qisint(vals[1])) { + math_error( + "prevcand count arg (2nd) must be an integer or omitted"); + /*NOTREACHED*/ + } + zcount = &vals[1]->num; + /*FALLTHRU*/ + case 1: + if (!qisint(vals[0])) { + math_error( + "prevcand search arg (1st) must be an integer"); + /*NOTREACHED*/ + } + break; + default: + math_error("invalid number of args passed to prevcand"); + /*NOTREACHED*/ + } + + if (zcount == NULL) { + count = 1; /* default is 1 ptest */ + } else { + if (zge24b(*zcount)) { + math_error("prevcand count arg (2nd) must be < 2^24"); + /*NOTREACHED*/ + } + count = ztoi(*zcount); + } + + /* + * find the candidate + */ + if (zprevcand(vals[0]->num, count, zskip, zresidue, zmodulus, &tmp)) { + ans = qalloc(); + ans->num = tmp; + return ans; + } + return qlink(&_qzero_); +} + + +static NUMBER * +f_nextcand(int count, NUMBER **vals) +{ + ZVALUE zmodulus; + ZVALUE zresidue; + ZVALUE zskip; + ZVALUE *zcount = NULL; /* ptest trial count */ + ZVALUE tmp; + NUMBER *ans; /* candidate for primality */ + + zmodulus = _one_; + zresidue = _zero_; + zskip = _one_; + /* + * check on the number of args passed and that args passed are ints + */ + switch (count) { + case 5: + if (!qisint(vals[4])) { + math_error( + "nextcand 5th args must be integer"); + /*NOTREACHED*/ + } + zmodulus = vals[4]->num; + /*FALLTHRU*/ + case 4: + if (!qisint(vals[3])) { + math_error( + "nextcand 5th args must be integer"); + /*NOTREACHED*/ + } + zresidue = vals[3]->num; + /*FALLTHRU*/ + case 3: + if (!qisint(vals[2])) { + math_error( + "nextcand skip arg (3rd) must be an integer or omitted"); + /*NOTREACHED*/ + } + zskip = vals[2]->num; + /*FALLTHRU*/ + case 2: + if (!qisint(vals[1])) { + math_error( + "nextcand count arg (2nd) must be an integer or omitted"); + /*NOTREACHED*/ + } + zcount = &vals[1]->num; + /*FALLTHRU*/ + case 1: + if (!qisint(vals[0])) { + math_error( + "nextcand search arg (1st) must be an integer"); + /*NOTREACHED*/ + } + break; + default: + math_error("invalid number of args passed to nextcand"); + /*NOTREACHED*/ + } + + /* + * check ranges on integers passed + */ + if (zcount == NULL) { + count = 1; /* default is 1 ptest */ + } else { + if (zge24b(*zcount)) { + math_error("prevcand count arg (2nd) must be < 2^24"); + /*NOTREACHED*/ + } + count = ztoi(*zcount); + } + + /* + * find the candidate + */ + if (znextcand(vals[0]->num, count, zskip, zresidue, zmodulus, &tmp)) { + ans = qalloc(); + ans->num = tmp; + return ans; + } + return qlink(&_qzero_);; +} + + +static NUMBER * +f_rand(int count, NUMBER **vals) +{ + NUMBER *ans; + + /* parse args */ + switch (count) { + case 0: /* rand() == rand(2^64) */ + /* generate a random number */ + ans = qalloc(); + zrand(SBITS, &ans->num); + break; + + case 1: /* rand(limit) */ + if (!qisint(vals[0])) { + math_error("rand limit must be an integer"); + /*NOTREACHED*/ + } + if (zislezero(vals[0]->num)) { + math_error("rand limit must > 0"); + /*NOTREACHED*/ + } + ans = qalloc(); + zrandrange(_zero_, vals[0]->num, &ans->num); + break; + + case 2: /* rand(low, limit) */ + /* firewall */ + if (!qisint(vals[0]) || !qisint(vals[1])) { + math_error("rand range must be integers"); + /*NOTREACHED*/ + } + ans = qalloc(); + zrandrange(vals[0]->num, vals[1]->num, &ans->num); + break; + + default: + math_error("invalid number of args passed to rand"); + /*NOTREACHED*/ + return NULL; + } + + /* return the random number */ + return ans; +} + + +static NUMBER * +f_randbit(int count, NUMBER **vals) +{ + NUMBER *ans; + ZVALUE ztmp; + long cnt; /* bits needed or skipped */ + + /* parse args */ + + if (count == 0) { + zrand(1, &ztmp); + ans = ziszero(ztmp) ? qlink(&_qzero_) : qlink(&_qone_); + zfree(ztmp); + return ans; + } + + /* + * firewall + */ + if (!qisint(vals[0])) { + math_error("rand bit count must be an integer"); + /*NOTREACHED*/ + } + if (zge31b(vals[0]->num)) { + math_error("huge rand bit count"); + /*NOTREACHED*/ + } + + /* + * generate a random number or skip random bits + */ + ans = qalloc(); + cnt = ztolong(vals[0]->num); + if (zisneg(vals[0]->num)) { + /* skip bits */ + zrandskip(cnt); + itoz(cnt, &ans->num); + } else { + /* generate bits */ + zrand(cnt, &ans->num); + } + + /* + * return the random number + */ + return ans; +} + + +static VALUE +f_srand(int count, VALUE **vals) +{ + VALUE result; + + /* parse args */ + switch (count) { + case 0: + /* get the current a55 state */ + result.v_rand = zsrand(NULL, NULL); + break; + + case 1: + switch (vals[0]->v_type) { + case V_NUM: /* srand(seed) */ + /* seed a55 and return previous state */ + if (!qisint(vals[0]->v_num)) { + math_error( + "srand number seed must be an integer"); + /*NOTREACHED*/ + } + result.v_rand = zsrand(&vals[0]->v_num->num, NULL); + break; + + case V_RAND: /* srand(state) */ + /* set a55 state and return previous state */ + result.v_rand = zsetrand(vals[0]->v_rand); + break; + + case V_MAT: + /* load additive 55 table and return previous state */ + result.v_rand = zsrand(NULL, vals[0]->v_mat); + break; + + default: + math_error("illegal type of arg passsed to srand()"); + /*NOTREACHED*/ + break; + } + break; + + default: + math_error("bad arg count to srand()"); + /*NOTREACHED*/ + break; + } + + /* return the current state */ + result.v_type = V_RAND; + return result; +} + + +static VALUE +f_srandom(int count, VALUE **vals) +{ + VALUE result; + + /* parse args */ + switch (count) { + case 0: + /* get the current random state */ + result.v_random = zsetrandom(NULL); + break; + + case 1: + switch (vals[0]->v_type) { + case V_NUM: /* srand(seed) */ + /* seed Blum and return previous state */ + if (!qisint(vals[0]->v_num)) { + math_error( + "srandom number seed must be an integer"); + /*NOTREACHED*/ + } + result.v_random = zsrandom(vals[0]->v_num->num, NULL); + break; + + case V_RANDOM: /* srandom(state) */ + /* set a55 state and return previous state */ + result.v_random = zsetrandom(vals[0]->v_random); + break; + + default: + math_error("illegal type of arg passsed to srandom()"); + /*NOTREACHED*/ + break; + } + break; + + default: + math_error("bad arg count to srandom()"); + /*NOTREACHED*/ + break; + } + + /* return the current state */ + result.v_type = V_RANDOM; + return result; +} + + +static NUMBER * +f_primetest(int count, NUMBER **vals) +{ + /* parse args */ + switch (count) { + case 1: return itoq((long) qprimetest(vals[0], &_qone_, &_qone_)); + case 2: return itoq((long) qprimetest(vals[0], vals[1], &_qone_)); + default: return itoq((long) qprimetest(vals[0], vals[1], vals[2])); + } +} + + +static NUMBER * +f_isset(NUMBER *val1, NUMBER *val2) +{ + if (qisfrac(val2)) { + math_error("Non-integral bit position"); + /*NOTREACHED*/ + } + if (qiszero(val1) || (qisint(val1) && qisneg(val2))) + return qlink(&_qzero_); + if (zge31b(val2->num)) { + math_error("Very large bit position"); + /*NOTREACHED*/ + } + return itoq((long) qisset(val1, qtoi(val2))); +} + + +static NUMBER * +f_digit(NUMBER *val1, NUMBER *val2) +{ + if (qisfrac(val2)) { + math_error("Non-integral digit position"); + /*NOTREACHED*/ + } + if (qiszero(val1) || (qisint(val1) && qisneg(val2))) + return qlink(&_qzero_); + if (zge31b(val2->num)) { + if (qisneg(val2)) { + math_error("Very large digit position"); + /*NOTREACHED*/ + } + return qlink(&_qzero_); + } + return itoq((long) qdigit(val1, qtoi(val2))); +} + + +static NUMBER * +f_digits(NUMBER *val) +{ + return itoq((long) qdigits(val)); +} + + +static NUMBER * +f_places(NUMBER *val) +{ + return itoq((long) qplaces(val)); +} + + +static NUMBER * +f_xor(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(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(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(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(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(int count, VALUE **vals) +{ + QCKHASH hash; + long lhash; + VALUE result; + + hash = (QCKHASH)0; + while (count-- > 0) + hash = hashvalue(*vals++, hash); + lhash = (long) hash; + if (lhash < 0) + lhash = -lhash; + result.v_num = itoq(lhash); + result.v_type = V_NUM; + return result; +} + + +static VALUE +f_avg(int count, VALUE **vals) +{ + VALUE tmp; + VALUE sum; + VALUE div; + long n; + + sum.v_type = V_NULL; + n = 0; + while (count-- > 0) { + if ((*vals)->v_type == V_LIST) { + addlistitems((*vals)->v_list, &sum); + n += countlistitems((*vals++)->v_list); + } + else { + addvalue(&sum, *vals++, &tmp); + freevalue(&sum); + sum = tmp; + n++; + } + if (sum.v_type < 0) + return sum; + } + if (n < 2) + return sum; + div.v_num = itoq(n); + div.v_type = V_NUM; + divvalue(&sum, &div, &tmp); + freevalue(&sum); + qfree(div.v_num); + return tmp; +} + + +static VALUE +f_hmean(int count, VALUE **vals) +{ + VALUE sum, tmp1, tmp2; + long n = 0; + + sum.v_type = V_NULL; + while (count-- > 0) { + if ((*vals)->v_type == V_LIST) { + addlistinv((*vals)->v_list, &sum); + n += countlistitems((*vals++)->v_list); + } + else { + invertvalue(*vals++, &tmp1); + addvalue(&sum, &tmp1, &tmp2); + freevalue(&tmp1); + freevalue(&sum); + sum = tmp2; + n++; + } + } + if (n == 0) + return sum; + tmp1.v_type = V_NUM; + tmp1.v_num = itoq(n); + divvalue(&tmp1, &sum, &tmp2); + qfree(tmp1.v_num); + freevalue(&sum); + return tmp2; +} + + +static VALUE +f_ssq(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(NUMBER *val1, NUMBER *val2) +{ + return itoq((long) qdivides(val1, val2)); +} + + +static NUMBER * +f_meq(NUMBER *val1, NUMBER *val2, NUMBER *val3) +{ + NUMBER *tmp, *res; + + tmp = qsub(val1, val2); + res = itoq((long) qdivides(tmp, val3)); + qfree(tmp); + return res; +} + + +static VALUE +f_exp(int count, VALUE **vals) +{ + VALUE result; + NUMBER *err; + COMPLEX *c; + + err = conf->epsilon; + if (count == 2) { + if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) + return error_value(E_EXP1); + 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: + c = cexp(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: + return error_value(E_EXP2); + } + return result; +} + + +static VALUE +f_ln(int count, VALUE **vals) +{ + VALUE result; + COMPLEX ctmp, *c; + NUMBER *err; + + err = conf->epsilon; + if (count == 2) { + if (vals[1]->v_type != V_NUM) + return error_value(E_LN1); + 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; + return result; + } + ctmp.real = vals[0]->v_num; + ctmp.imag = &_qzero_; + ctmp.links = 1; + c = cln(&ctmp, err); + break; + case V_COM: + c = cln(vals[0]->v_com, err); + break; + default: + return error_value(E_LN2); + } + result.v_type = V_COM; + result.v_com = c; + if (cisreal(c)) { + result.v_num = qlink(c->real); + result.v_type = V_NUM; + comfree(c); + } + return result; +} + + +static VALUE +f_cos(int count, VALUE **vals) +{ + VALUE result; + COMPLEX *c; + NUMBER *err; + + err = conf->epsilon; + if (count == 2) { + if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) + return error_value(E_COS1); + 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: + return error_value(E_COS2); + } + return result; +} + + +static VALUE +f_sin(int count, VALUE **vals) +{ + VALUE result; + COMPLEX *c; + NUMBER *err; + + err = conf->epsilon; + if (count == 2) { + if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) + return error_value(E_COS1); + 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: + return error_value(E_COS2); + } + return result; +} + + +static VALUE +f_arg(int count, VALUE **vals) +{ + VALUE result; + COMPLEX *c; + NUMBER *err; + + err = conf->epsilon; + if (count == 2) { + if (vals[1]->v_type != V_NUM || qiszero(vals[1]->v_num)) + return error_value(E_ARG1); + 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: + return error_value(E_ARG2); + } + return result; +} + + +static NUMBER * +f_legtoleg(NUMBER *val1, NUMBER *val2) +{ + return qlegtoleg(val1, val2, FALSE); +} + + +static NUMBER * +f_trunc(int count, NUMBER **vals) +{ + NUMBER *val; + + val = &_qzero_; + if (count == 2) + val = vals[1]; + return qtrunc(*vals, val); +} + + +static VALUE +f_bround(int count, VALUE **vals) +{ + VALUE tmp1, tmp2, res; + + if (count > 2) + tmp2 = *vals[2]; + else + tmp2.v_type = V_NULL; + if (count > 1) + tmp1 = *vals[1]; + else + tmp1.v_type = V_NULL; + broundvalue(vals[0], &tmp1, &tmp2, &res); + return res; +} + + +static VALUE +f_appr(int count, VALUE **vals) +{ + VALUE tmp1, tmp2, res; + + if (count > 2) + copyvalue(vals[2], &tmp2); + else + tmp2.v_type = V_NULL; + if (count > 1) + copyvalue(vals[1], &tmp1); + else + tmp1.v_type = V_NULL; + apprvalue(vals[0], &tmp1, &tmp2, &res); + freevalue(&tmp1); + freevalue(&tmp2); + return res; +} + +static VALUE +f_round(int count, VALUE **vals) +{ + VALUE tmp1, tmp2, res; + + if (count > 2) + tmp2 = *vals[2]; + else + tmp2.v_type = V_NULL; + if (count > 1) + tmp1 = *vals[1]; + else + tmp1.v_type = V_NULL; + roundvalue(vals[0], &tmp1, &tmp2, &res); + return res; +} + + +static NUMBER * +f_btrunc(int count, NUMBER **vals) +{ + NUMBER *val; + + val = &_qzero_; + if (count == 2) + val = vals[1]; + return qbtrunc(*vals, val); +} + + +static VALUE +f_quo(int count, VALUE **vals) +{ + VALUE tmp, res; + + if (count > 2) + tmp = *vals[2]; + else + tmp.v_type = V_NULL; + quovalue(vals[0], vals[1], &tmp, &res); + return res; +} + + +static VALUE +f_mod(int count, VALUE **vals) +{ + VALUE tmp, res; + + if (count > 2) + tmp = *vals[2]; + else + tmp.v_type = V_NULL; + modvalue(vals[0], vals[1], &tmp, &res); + return res; +} + + +static VALUE +f_mmin(VALUE *v1, VALUE *v2) +{ + VALUE sixteen, res; + + sixteen.v_type = V_NUM; + sixteen.v_num = itoq(16); + modvalue(v1, v2, &sixteen, &res); + qfree(sixteen.v_num); + return res; +} + + +static NUMBER * +f_near(int count, NUMBER **vals) +{ + NUMBER *val; + + val = conf->epsilon; + if (count == 3) + val = vals[2]; + return itoq((long) qnear(vals[0], vals[1], val)); +} + + +static NUMBER * +f_cfsim(int count, NUMBER **vals) +{ + long R; + + R = (count > 1) ? qtoi(vals[1]) : conf->cfsim; + return qcfsim(vals[0], R); +} + + +static NUMBER * +f_cfappr(int count, NUMBER **vals) +{ + long R; + NUMBER *q; + + R = (count > 2) ? qtoi(vals[2]) : conf->cfappr; + q = (count > 1) ? vals[1] : conf->epsilon; + + return qcfappr(vals[0], q, R); +} + + +static VALUE +f_ceil(VALUE *val) +{ + VALUE tmp, res; + + tmp.v_type = V_NUM; + tmp.v_num = qlink(&_qone_); + apprvalue(val, &tmp, &tmp, &res); + qfree(tmp.v_num); + return res; +} + + +static VALUE +f_floor(VALUE *val) +{ + VALUE tmp1, tmp2, res; + + tmp1.v_type = V_NUM; + tmp1.v_num = qlink(&_qone_); + tmp2.v_type = V_NUM; + tmp2.v_num = qlink(&_qzero_); + apprvalue(val, &tmp1, &tmp2, &res); + qfree(tmp1.v_num); + qfree(tmp2.v_num); + return res; +} + + +static NUMBER * +f_highbit(NUMBER *val) +{ + if (qiszero(val)) { + math_error("Highbit of zero"); + /*NOTREACHED*/ + } + if (qisfrac(val)) { + math_error("Highbit of non-integer"); + /*NOTREACHED*/ + } + return itoq(zhighbit(val->num)); +} + + +static NUMBER * +f_lowbit(NUMBER *val) +{ + if (qiszero(val)) { + math_error("Lowbit of zero"); + /*NOTREACHED*/ + } + if (qisfrac(val)) { + math_error("Lowbit of non-integer"); + /*NOTREACHED*/ + } + return itoq(zlowbit(val->num)); +} + + +static VALUE +f_sqrt(int count, VALUE **vals) +{ + VALUE tmp1, tmp2, result; + + if (count > 2) + tmp2 = *vals[2]; + else + tmp2.v_type = V_NULL; + if (count > 1) + tmp1 = *vals[1]; + else + tmp1.v_type = V_NULL; + sqrtvalue(vals[0], &tmp1, &tmp2, &result); + return result; +} + + +static VALUE +f_root(int count, VALUE **vals) +{ + VALUE *vp, err, result; + + if (count > 2) + vp = vals[2]; + else { + err.v_num = conf->epsilon; + err.v_type = V_NUM; + vp = &err; + } + rootvalue(vals[0], vals[1], vp, &result); + return result; +} + + +static VALUE +f_power(int count, VALUE **vals) +{ + VALUE *vp, err, result; + + if (count > 2) + vp = vals[2]; + else { + err.v_num = conf->epsilon; + err.v_type = V_NUM; + vp = &err; + } + powervalue(vals[0], vals[1], vp, &result); + return result; +} + + +static VALUE +f_polar(int count, VALUE **vals) +{ + VALUE *vp, err, result; + COMPLEX *c; + + if (count > 2) + vp = vals[2]; + else { + err.v_num = conf->epsilon; + err.v_type = V_NUM; + vp = &err; + } + if ((vals[0]->v_type != V_NUM) || (vals[1]->v_type != V_NUM)) + return error_value(E_POLAR1); + if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num)) + return error_value(E_POLAR2); + 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(NUMBER *val1, NUMBER *val2) +{ + return itoq(qilog(val1, val2)); +} + + +static NUMBER * +f_ilog2(NUMBER *val) +{ + return itoq(qilog2(val)); +} + + +static NUMBER * +f_ilog10(NUMBER *val) +{ + return itoq(qilog10(val)); +} + + +static NUMBER * +f_faccnt(NUMBER *val1, NUMBER *val2) +{ + if (qisfrac(val1) || qisfrac(val2)) + math_error("Non-integral argument for fcnt"); + return itoq(zdivcount(val1->num, val2->num)); +} + + +static VALUE +f_matfill(int count, VALUE **vals) +{ + VALUE *v1, *v2, *v3; + VALUE result; + + v1 = vals[0]; + v2 = vals[1]; + if (v1->v_type != V_ADDR) + return error_value(E_MATFILL1); + v1 = v1->v_addr; + if (v1->v_type != V_MAT) + return error_value(E_MATFILL2); + if (v2->v_type == V_ADDR) + v2 = v2->v_addr; + if (count == 3) { + v3 = vals[2]; + if (v3->v_type == V_ADDR) + v3 = v3->v_addr; + } + else + v3 = NULL; + matfill(v1->v_mat, v2, v3); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_matsum(VALUE *vp) +{ + VALUE result; + + /* firewall */ + if (vp->v_type != V_MAT) + return error_value(E_MATSUM); + + /* sum matrix */ + matsum(vp->v_mat, &result); + return result; +} + + +static VALUE +f_isident(VALUE *vp) +{ + VALUE result; + + if (vp->v_type != V_MAT) + return error_value(E_ISIDENT); + result.v_type = V_NUM; + result.v_num = itoq((long) matisident(vp->v_mat)); + return result; +} + + +static VALUE +f_mattrans(VALUE *vp) +{ + VALUE result; + + if (vp->v_type != V_MAT) + return error_value(E_MATTRANS1); + if (vp->v_mat->m_dim != 2) + return error_value(E_MATTRANS2); + result.v_type = V_MAT; + result.v_mat = mattrans(vp->v_mat); + return result; +} + + +static VALUE +f_det(VALUE *vp) +{ + MATRIX *m; + + if (vp->v_type != V_MAT) + return error_value(E_DET1); + m = vp->v_mat; + if (m->m_dim != 2) + return error_value(E_DET2); + if ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1])) + return error_value(E_DET3); + + return matdet(vp->v_mat); +} + + +static VALUE +f_matdim(VALUE *vp) +{ + VALUE result; + + if (vp->v_type != V_MAT) + return error_value(E_MATDIM); + result.v_type = V_NUM; + result.v_num = itoq((long) vp->v_mat->m_dim); + return result; +} + + +static VALUE +f_matmin(VALUE *v1, VALUE *v2) +{ + VALUE result; + NUMBER *q; + long i; + + if (v1->v_type != V_MAT) + return error_value(E_MATMIN1); + if (v2->v_type != V_NUM) + return error_value(E_MATMIN2); + q = v2->v_num; + if (qisfrac(q) || qisneg(q) || qiszero(q)) + return error_value(E_MATMIN2); + i = qtoi(q); + if (i > v1->v_mat->m_dim) + return error_value(E_MATMIN3); + result.v_type = V_NUM; + result.v_num = itoq(v1->v_mat->m_min[i - 1]); + return result; +} + + +static VALUE +f_matmax(VALUE *v1, VALUE *v2) +{ + VALUE result; + NUMBER *q; + long i; + + if (v1->v_type != V_MAT) + return error_value(E_MATMAX1); + if (v2->v_type != V_NUM) + return error_value(E_MATMAX2); + q = v2->v_num; + if (qisfrac(q) || qisneg(q) || qiszero(q)) + return error_value(E_MATMAX2); + i = qtoi(q); + if (i > v1->v_mat->m_dim) + return error_value(E_MATMAX3); + result.v_type = V_NUM; + result.v_num = itoq(v1->v_mat->m_max[i - 1]); + return result; +} + + +static VALUE +f_cp(VALUE *v1, VALUE *v2) +{ + MATRIX *m1, *m2; + VALUE result; + + if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT)) + return error_value(E_CP1); + m1 = v1->v_mat; + m2 = v2->v_mat; + if ((m1->m_dim != 1) || (m2->m_dim != 1)) + return error_value(E_CP2); + if ((m1->m_size != 3) || (m2->m_size != 3)) + return error_value(E_CP3); + result.v_type = V_MAT; + result.v_mat = matcross(m1, m2); + return result; +} + + +static VALUE +f_dp(VALUE *v1, VALUE *v2) +{ + MATRIX *m1, *m2; + + if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT)) + return error_value(E_DP1); + m1 = v1->v_mat; + m2 = v2->v_mat; + if ((m1->m_dim != 1) || (m2->m_dim != 1)) + return error_value(E_DP2); + if (m1->m_size != m2->m_size) + return error_value(E_DP3); + return matdot(m1, m2); +} + + +static VALUE +f_strlen(VALUE *vp) +{ + VALUE result; + + if (vp->v_type != V_STR) + return error_value(E_STRLEN); + result.v_type = V_NUM; + result.v_num = itoq((long) strlen(vp->v_str)); + return result; +} + + +static VALUE +f_strcat(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) + return error_value(E_STRCAT); + lengths[i] = (long)strlen((*vp)->v_str); + len += lengths[i]; + vp++; + } + cp = (char *)malloc(len); + if (cp == NULL) { + math_error("No memory for strcat"); + /*NOTREACHED*/ + } + 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(VALUE *v1, VALUE *v2, VALUE *v3) +{ + NUMBER *q1, *q2; + long i1, i2, len; + char *cp; + VALUE result; + + if (v1->v_type != V_STR) + return error_value(E_SUBSTR1); + if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM)) + return error_value(E_SUBSTR2); + q1 = v2->v_num; + q2 = v3->v_num; + if (qisfrac(q1) || qisneg(q1) || qisfrac(q2) || qisneg(q2)) + return error_value(E_SUBSTR2); + i1 = qtoi(q1); + i2 = qtoi(q2); + cp = v1->v_str; + len = (long)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"); + /*NOTREACHED*/ + } + strncpy(result.v_str, cp, len); + result.v_str[len] = '\0'; + return result; +} + + +static VALUE +f_char(VALUE *vp) +{ + long num; + NUMBER *q; + VALUE result; + + if (vp->v_type != V_NUM) + return error_value(E_CHAR); + q = vp->v_num; + num = qtoi(q); + if (qisneg(q) || qisfrac(q) || !zistiny(q->num) || (num > 255)) + return error_value(E_CHAR); + result.v_type = V_STR; + result.v_subtype = V_STRLITERAL; + result.v_str = charstr((int) num); + return result; +} + + +static VALUE +f_ord(VALUE *vp) +{ + char *str; + VALUE result; + + if (vp->v_type != V_STR) + return error_value(E_ORD); + str = vp->v_str; + result.v_type = V_NUM; + result.v_num = itoq((long) (*str & 0xff)); + return result; +} + + +static VALUE +f_size(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; + case V_FILE: count = filesize(vp->v_file); break; + case V_STR: count = (long)strlen(vp->v_str); break; + default: count = 1; break; + } + result.v_type = V_NUM; + result.v_num = itoq(count); + return result; +} + + +static long +zsize(ZVALUE z) +{ + return (long)sizeof(ZVALUE) + (long)z.len * (long)sizeof(HALF); +} + + +static long +qsize(NUMBER *q) +{ + return (long)sizeof(NUMBER) + (long)zsize(q->num) + (long)zsize(q->den); +} + + +static long +lsizeof(VALUE *vp) +{ + long s; + long i, j; + VALUE *p; + LISTELEM *ep; + OBJECTACTIONS *oap; + ASSOCELEM *aep; + ASSOCELEM **ept; + + i = j = 0; + s = (long) sizeof(VALUE); + if (vp->v_type > 0) { + switch(vp->v_type) { + case V_INT: + case V_ADDR: + break; + case V_NUM: + s += qsize(vp->v_num); + break; + case V_COM: + s += sizeof(COMPLEX) + + qsize(vp->v_com->real) + + qsize(vp->v_com->imag); + break; + case V_STR: + s += (long)strlen(vp->v_str) + 1; + break; + case V_MAT: + s += sizeof(MATRIX); + i = vp->v_mat->m_size; + p = vp->v_mat->m_table; + while (i-- > 0) + s += lsizeof(p++); + break; + case V_LIST: + s += sizeof(LIST); + for (ep = vp->v_list->l_first;ep;ep=ep->e_next) + s += sizeof(LISTELEM) - sizeof(VALUE) + + lsizeof(&ep->e_value); + break; + case V_OBJ: + s += sizeof(OBJECT); + oap = vp->v_obj->o_actions; + s += (long)strlen(oap->name) + 1; + i = oap->count; + s += (i + 2) * sizeof(int); + p = vp->v_obj->o_table; + while (i-- > 0) + s += lsizeof(p++); + break; + case V_FILE: + s += sizeof(vp->v_file); + break; + case V_RAND: + s += sizeof(RAND); + break; + case V_RANDOM: + s += sizeof(RANDOM); + break; + case V_ASSOC: + s += sizeof(ASSOC); + i = vp->v_assoc->a_size; + ept = vp->v_assoc->a_table; + while (i-- > 0) { + s += sizeof(ASSOCELEM *); + for (aep = *ept++;aep;aep=aep->e_next){ + s += sizeof(ASSOCELEM) - sizeof(VALUE); + s += lsizeof(&aep->e_value); + j = aep->e_dim; + p = aep->e_indices; + while (j-- > 0) + s += lsizeof(p++); + } + } + break; + default: + math_error("sizeof not defined for value type"); + /*NOTREACHED*/ + } + } + return s; +} + + +static VALUE +f_sizeof(VALUE *vp) +{ + VALUE result; + + result.v_type = V_NUM; + result.v_num = itoq(lsizeof(vp)); + return result; +} + + +static VALUE +f_search(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) + return error_value(E_SEARCH3); + q = (*vals)->v_num; + if (qisfrac(q) || qisneg(q)) + return error_value(E_SEARCH3); + 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; + case V_FILE: + if (v2->v_type != V_STR) + return error_value(E_SEARCH2); + if (count == 2) start = -1; + index = fsearch(v1->v_file, v2->v_str, start); + break; + default: + return error_value(E_SEARCH1); + } + result.v_type = V_NULL; + if (index >= 0) { + result.v_type = V_NUM; + result.v_num = itoq(index); + } + return result; +} + + +static VALUE +f_rsearch(int count, VALUE **vals) +{ + VALUE *v1, *v2; + NUMBER *q; + long start; + long index = -1; + VALUE result; + + v1 = *vals++; + v2 = *vals++; + start = MAXLONG; + if (count == 3) { + if ((*vals)->v_type != V_NUM) + return error_value(E_RSEARCH3); + q = (*vals)->v_num; + if (qisfrac(q) || qisneg(q)) + return error_value(E_RSEARCH3); + 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; + case V_FILE: + if (v2->v_type != V_STR) + return error_value(E_RSEARCH2); + if (count == 2) start = -1; + index = frsearch(v1->v_file, v2->v_str, start); + break; + default: + return error_value(E_RSEARCH1); + } + result.v_type = V_NULL; + if (index >= 0) { + result.v_type = V_NUM; + result.v_num = itoq(index); + } + return result; +} + + +static VALUE +f_list(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(int count, VALUE **vals) +{ + VALUE result; + + result.v_type = V_ASSOC; + result.v_assoc = assocalloc(0L); + return result; +} + + +static VALUE +f_listinsert(int count, VALUE **vals) +{ + VALUE *v1, *v2, *v3; + VALUE result; + long pos; + + v1 = *vals++; + if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST)) + return error_value(E_INSERT1); + v2 = *vals++; + if (v2->v_type == V_ADDR) + v2 = v2->v_addr; + if ((v2->v_type != V_NUM) || qisfrac(v2->v_num)) + return error_value(E_INSERT2); + pos = qtoi(v2->v_num); + count--; + while (--count > 0) { + v3 = *vals++; + if (v3->v_type == V_ADDR) + v3 = v3->v_addr; + insertlistmiddle(v1->v_addr->v_list, pos++, v3); + } + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_listpush(int count, VALUE **vals) +{ + VALUE result; + VALUE *v1, *v2; + + v1 = *vals++; + if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST)) + return error_value(E_PUSH); + while (--count > 0) { + v2 = *vals++; + 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(int count, VALUE **vals) +{ + VALUE *v1, *v2; + VALUE result; + + v1 = *vals++; + if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST)) + return error_value(E_APPEND); + while (--count > 0) { + v2 = *vals++; + 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(VALUE *v1, VALUE *v2) +{ + VALUE result; + + if ((v1->v_type != V_ADDR) || (v1->v_addr->v_type != V_LIST)) + return error_value(E_DELETE1); + if (v2->v_type == V_ADDR) + v2 = v2->v_addr; + if ((v2->v_type != V_NUM) || qisfrac(v2->v_num)) + return error_value(E_DELETE2); + removelistmiddle(v1->v_addr->v_list, qtoi(v2->v_num), &result); + return result; +} + + +static VALUE +f_listpop(VALUE *vp) +{ + VALUE result; + + if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST)) + return error_value(E_POP); + removelistfirst(vp->v_addr->v_list, &result); + return result; +} + + +static VALUE +f_listremove(VALUE *vp) +{ + VALUE result; + + if ((vp->v_type != V_ADDR) || (vp->v_addr->v_type != V_LIST)) + return error_value(E_REMOVE); + 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(void) +{ + struct tms buf; + + times(&buf); + return iitoq((long) buf.tms_utime, (long) CLK_TCK); +} + + +/* + * return the number of second since the Epoch (00:00:00 1 Jan 1970 UTC). + */ +static NUMBER * +f_time(void) +{ + return itoq((long) time(0)); +} + + +/* + * time in asctime()/ctime() format + */ +static VALUE +f_ctime(void) +{ + time_t systime; + char *str; + VALUE res; + + str = (char *) malloc(26); + if (str == NULL) { + math_error("No memory for ctime()"); + /*NOTREACHED*/ + } + systime = time(NULL); + strcpy(str, ctime(&systime)); + str[24] = '\0'; + res.v_str = str; + res.v_type = V_STR; + res.v_subtype = V_STRALLOC; + return res; +} + + +static VALUE +f_fopen(VALUE *v1, VALUE *v2) +{ + VALUE result; + FILEID id; + char *mode; + + if (v1->v_type != V_STR || v2->v_type != V_STR) + return error_value(E_FOPEN1); + mode = v2->v_str; + + if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a')) + return error_value(E_FOPEN2); + if (mode[1] != '\0') { + if (mode[1] != '+') + return error_value(E_FOPEN2); + if (mode[2] != '\0') + return error_value(E_FOPEN2); + } + errno = 0; + id = openid(v1->v_str, v2->v_str); + if (id == FILEID_NONE) + return error_value(errno); + if (id < 0) + return error_value(E_FOPEN3); + result.v_type = V_FILE; + result.v_file = id; + return result; +} + + +static VALUE +f_freopen(int count, VALUE **vals) +{ + VALUE result; + FILEID id; + char *mode; + + if (vals[0]->v_type != V_FILE) + return error_value(E_FREOPEN1); + if (vals[1]->v_type != V_STR) + return error_value(E_FREOPEN2); + + mode = vals[1]->v_str; + + if ((*mode != 'r') && (*mode != 'w') && (*mode != 'a')) + return error_value(E_FREOPEN2); + if (mode[1] != '\0') { + if (mode[1] != '+') + return error_value(E_FREOPEN2); + if (mode[2] != '\0') + return error_value(E_FREOPEN2); + } + errno = 0; + if (count == 2) + id = reopenid(vals[0]->v_file, mode, NULL); + else { + if (vals[2]->v_type != V_STR) + return error_value(E_FREOPEN3); + id = reopenid(vals[0]->v_file, mode, vals[2]->v_str); + } + + if (id == FILEID_NONE) + return error_value(errno); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_errno(VALUE *v1) +{ + long error; /* error number to look up */ + VALUE result; + + /* arg must be an integer */ + if (v1->v_type != V_NUM || qisfrac(v1->v_num)) { + math_error("errno argument must be an integer"); + /*NOTREACHED*/ + } + + /* return the error string */ + result.v_type = V_STR; + result.v_subtype = V_STRLITERAL; + error = z1tol(v1->v_num->num); + if (qisneg(v1->v_num) || zge16b(v1->v_num->num) || + error < 0 || error >= sys_nerr) { + result.v_str = "Unknown error number"; + } else { + result.v_str = (char *)sys_errlist[error]; + } + return result; +} + + +static VALUE +f_fclose(int count, VALUE **vals) +{ + VALUE result; + VALUE *vp; + int n, i=0; + + errno = 0; + if (count == 0) { + i = closeall(); + } else { + for (n = 0; n < count; n++) { + vp = vals[n]; + if (vp->v_type != V_FILE) + return error_value(E_FCLOSE1); + } + for (n = 0; n < count; n++) { + vp = vals[n]; + i = closeid(vp->v_file); + if (i < 0) + return error_value(E_REWIND2); + } + } + if (i < 0) + return error_value(errno); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_rm(VALUE *v1) +{ + VALUE result; + int i; + + /* + * firewall + */ + if (!allow_write) + return error_value(E_WRPERM); + + /* + * check on each arg + * + * For now we will do just one arg ... worry about + * rm flags such as -r or -f maybe someday later ... + */ + if (v1->v_type != V_STR) + return error_value(E_RM1); + if (v1->v_str[0] == '\0') + return error_value(E_RM1); + + /* + * unlink file(s) + */ + i = unlink(v1->v_str); + if (i < 0) + return error_value(E_RM2); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_newerror(int count, VALUE **vals) +{ + VALUE result; + char *str; + + str = NULL; + if (count > 0 && vals[0]->v_type == V_STR) { + str = vals[0]->v_str; + if (*str == '\0') + str = NULL; + } + if (nexterrnum == E_USERDEF) + initstr(&newerrorstr); + if (str) + addstr(&newerrorstr, str); + else + addstr(&newerrorstr, "???"); + result.v_type = - nexterrnum++; + return result; +} + + +static VALUE +f_strerror(VALUE *vp) +{ + VALUE result; + long i; + + /* firewall */ + if (vp->v_type < 0) + i = (long) -vp->v_type; + else { + if (vp->v_type != V_NUM || qisfrac(vp->v_num) || + qisneg(vp->v_num)) { + return error_value(E_STRERROR1); + } + i = qtoi(vp->v_num); + } + + /* process system error messages */ + if (i < E__BASE) { + if (i >= sys_nerr) { + return error_value(E_STRERROR2); + } + result.v_str = (char *) sys_errlist[i]; + result.v_type = V_STR; + result.v_subtype = V_STRLITERAL; + return result; + } + + /* more filewall */ + if (i <= 0 || i >= nexterrnum || (i > E__HIGHEST && i < E_USERDEF)) { + return error_value(E_STRERROR2); + } + + /* convert user or calc error */ + result.v_type = V_STR; + result.v_subtype = V_STRLITERAL; + if (i >= E_USERDEF) + result.v_str = namestr(&newerrorstr, i - E_USERDEF); + else + result.v_str = (char *)error_table[i - E__BASE]; + return result; +} + + +static VALUE +f_ferror(VALUE *vp) +{ + VALUE result; + int i; + + if (vp->v_type != V_FILE) + return error_value(E_FERROR1); + i = errorid(vp->v_file); + if (i < 0) + return error_value(E_FERROR2); + result.v_type = V_NUM; + result.v_num = itoq((long) i); + return result; +} + + +static VALUE +f_feof(VALUE *vp) +{ + VALUE result; + int i; + + if (vp->v_type != V_FILE) + return error_value(E_FEOF1); + i = eofid(vp->v_file); + if (i < 0) + return error_value(E_FEOF2); + result.v_type = V_NUM; + result.v_num = itoq((long) i); + return result; +} + + +static VALUE +f_fflush(int count, VALUE **vals) +{ + VALUE result; + int i, n; + + i = 0; + errno = 0; + if (count == 0) + i = flushall(); + else { + for (n = 0; n < count; n++) { + if (vals[n]->v_type != V_FILE) + return error_value(E_FFLUSH); + } + for (n = 0; n < count; n++) { + i |= flushid(vals[n]->v_file); + } + } + if (i == EOF) + return error_value(errno); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_error(VALUE *vp) +{ + VALUE res; + long r; + + if (vp->v_type != V_NUM || qisfrac(vp->v_num) || + qisneg(vp->v_num)) + return error_value(E_ERROR1); + r = qtoi(vp->v_num); + if (r < 0 || r >= 32768) + return error_value(E_ERROR2); + res.v_type = (short) -r; + return res; +} + + +static VALUE +f_iserror(VALUE *vp) +{ + VALUE res; + + res.v_type = V_NUM; + res.v_num = itoq((long)((vp->v_type < 0) ? - vp->v_type : 0)); + return res; +} + + +static VALUE +f_fsize(VALUE *vp) +{ + VALUE result; + long i; + + if (vp->v_type != V_FILE) + return error_value(E_FSIZE1); + i = filesize(vp->v_file); + if (i < 0) + return error_value(E_FSIZE2); + result.v_type = V_NUM; + result.v_num = itoq(i); + return result; +} + + +static VALUE +f_fseek(int count, VALUE **vals) +{ + VALUE result; + int whence; + long offset; + int i; + + /* firewalls */ + errno = 0; + if (vals[0]->v_type != V_FILE) + return error_value(E_FSEEK1); + if (vals[1]->v_type != V_NUM || qisfrac(vals[1]->v_num)) + return error_value(E_FSEEK2); + if (count == 2) + whence = 0; + else { + if (vals[2]->v_type != V_NUM || qisfrac(vals[2]->v_num) || + qisneg(vals[2]->v_num)) + return error_value(E_FSEEK2); + if (vals[2]->v_num->num.len > 1) + return error_value (E_FSEEK2); + whence = (int)(unsigned int)(vals[2]->v_num->num.v[0]); + if (whence > 2) + return error_value (E_FSEEK2); + } + offset = ztoi(vals[1]->v_num->num); + + i = fseekid(vals[0]->v_file, offset, whence); + result.v_type = V_NULL; + if (i == EOF) + return error_value(errno); + if (i < 0) + return error_value(E_FSEEK3); + return result; +} + + +static VALUE +f_ftell(VALUE *vp) +{ + VALUE result; + long i; + + errno = 0; + if (vp->v_type != V_FILE) + return error_value(E_FTELL1); + i = ftellid(vp->v_file); + if (i == EOF) + return error_value(errno); + if (i < 0) + return error_value(E_FTELL2); + + result.v_type = V_NUM; + result.v_num = itoq(i); + return result; +} + + +static VALUE +f_rewind(int count, VALUE **vals) +{ + VALUE result; + int n; + + if (count == 0) + rewindall(); + + else { + for (n = 0; n < count; n++) { + if (vals[n]->v_type != V_FILE) + return error_value(E_REWIND1); + } + for (n = 0; n < count; n++) { + if (rewindid(vals[n]->v_file) != 0) { + return error_value(E_REWIND2); + } + } + } + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_fprintf(int count, VALUE **vals) +{ + VALUE result; + int i; + + if (vals[0]->v_type != V_FILE) + return error_value(E_FPRINTF1); + if (vals[1]->v_type != V_STR) + return error_value(E_FPRINTF2); + i = idprintf(vals[0]->v_file, vals[1]->v_str, count - 2, vals + 2); + if (i > 0) + return error_value(E_FPRINTF3); + result.v_type = V_NULL; + return result; +} + + +static int +strscan(char *s, int count, VALUE **vals) +{ + char ch, chtmp; + char *s0; + int n = 0; + VALUE val, result; + VALUE *var; + + val.v_type = V_STR; + while (*s != '\0') { + s--; + while ((ch = *++s)) { + if (!isspace(ch)) + break; + } + if (ch == '\0' || count-- == 0) + return n; + s0 = s; + while ((ch = *++s)) { + if (isspace(ch)) + break; + } + chtmp = ch; + *s = '\0'; + n++; + val.v_str = s0; + result = f_eval(&val); + var = *vals++; + if (var->v_type == V_ADDR) { + var = var->v_addr; + freevalue(var); + *var = result; + } + *s = chtmp; + } + return n; +} + + +static int +filescan(FILEID id, int count, VALUE **vals) +{ + char *str; + int i; + int n = 0; + VALUE val; + VALUE result; + VALUE *var; + + val.v_type = V_STR; + + while (count-- > 0) { + + i = readid(id, 6, &str); + + if (i == EOF) + break; + if (i > 0) + return EOF; + n++; + val.v_str = str; + result = f_eval(&val); + var = *vals++; + if (var->v_type == V_ADDR) { + var = var->v_addr; + freevalue(var); + *var = result; + } + } + return n; +} + + +static VALUE +f_scan(int count, VALUE **vals) +{ + char *cp; + VALUE result; + int i; + + cp = nextline(); + if (cp == NULL) { + result.v_type = V_NULL; + return result; + } + + i = strscan(cp, count, vals); + + result.v_type = V_NUM; + result.v_num = itoq((long) i); + return result; +} + + +static VALUE +f_strscan(int count, VALUE **vals) +{ + VALUE *vp; + VALUE result; + int i; + + vp = *vals; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + if (vp->v_type != V_STR) + return error_value(E_STRSCAN); + + i = strscan(vp->v_str, count - 1, vals + 1); + + result.v_type = V_NUM; + result.v_num = itoq((long) i); + return result; +} + + +static VALUE +f_fscan(int count, VALUE **vals) +{ + VALUE *vp; + VALUE result; + int i; + + errno = 0; + vp = *vals; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + if (vp->v_type != V_FILE) + return error_value(E_FSCAN1); + + i = filescan(vp->v_file, count - 1, vals + 1); + + if (i == EOF) + return error_value(errno); + if (i < 0) + return error_value(E_FSCAN2); + + result.v_type = V_NUM; + result.v_num = itoq((long) i); + return result; +} + + +static VALUE +f_scanf(int count, VALUE **vals) +{ + VALUE *vp; + VALUE result; + int i; + + vp = *vals; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + if (vp->v_type != V_STR) + return error_value(E_SCANF1); + for (i = 1; i < count; i++) { + if (vals[i]->v_type != V_ADDR) + return error_value(E_SCANF2); + } + i = fscanfid(FILEID_STDIN, vp->v_str, count - 1, vals + 1); + if (i < 0) + return error_value(E_SCANF3); + result.v_type = V_NUM; + result.v_num = itoq((long) i); + return result; +} + + +static VALUE +f_strscanf(int count, VALUE **vals) +{ + VALUE *vp, *vq; + VALUE result; + int i; + + errno = 0; + vp = vals[0]; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + if (vp->v_type != V_STR) + return error_value(E_STRSCANF1); + vq = vals[1]; + if (vq->v_type == V_ADDR) + vq = vq->v_addr; + if (vq->v_type != V_STR) + return error_value(E_STRSCANF2); + for (i = 2; i < count; i++) { + if (vals[i]->v_type != V_ADDR) + return error_value(E_STRSCANF3); + } + i = scanfstr(vp->v_str, vq->v_str, count - 2, vals + 2); + if (i == EOF) + return error_value(errno); + if (i < 0) + return error_value(E_STRSCANF4); + result.v_type = V_NUM; + result.v_num = itoq((long) i); + return result; +} + + +static VALUE +f_fscanf(int count, VALUE **vals) +{ + VALUE *vp, *sp; + VALUE result; + int i; + + vp = *vals++; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + if (vp->v_type != V_FILE) + return error_value(E_FSCANF1); + sp = *vals++; + if (sp->v_type == V_ADDR) + sp = sp->v_addr; + if (sp->v_type != V_STR) + return error_value(E_FSCANF2); + for (i = 0; i < count - 2; i++) { + if (vals[i]->v_type != V_ADDR) + return error_value(E_FSCANF3); + } + i = fscanfid(vp->v_file, sp->v_str, count - 2, vals); + if (i == EOF) { + result.v_type = V_NULL; + return result; + } + if (i < 0) + return error_value(E_FSCANF4); + result.v_type = V_NUM; + result.v_num = itoq((long) i); + return result; +} + + +static VALUE +f_fputc(VALUE *v1, VALUE *v2) +{ + VALUE result; + NUMBER *q; + int ch; + int i; + + if (v1->v_type != V_FILE) + return error_value(E_FPUTC1); + switch (v2->v_type) { + case V_STR: + ch = v2->v_str[0]; + break; + case V_NUM: + q = v2->v_num; + if (!qisint(q)) + return error_value(E_FPUTC2); + + ch = qisneg(q) ? (int)(-q->num.v[0] & 0xff) : + (int)(q->num.v[0] & 0xff); + break; + case V_NULL: + ch = 0; + break; + default: + return error_value(E_FPUTC2); + } + i = idfputc(v1->v_file, ch); + if (i > 0) + return error_value(E_FPUTC3); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_fputs(int count, VALUE **vals) +{ + VALUE result; + int i, err; + + if (vals[0]->v_type != V_FILE) + return error_value(E_FPUTS1); + for (i = 1; i < count; i++) { + if (vals[i]->v_type != V_STR) + return error_value(E_FPUTS2); + } + for (i = 1; i < count; i++) { + err = idfputs(vals[0]->v_file, vals[i]->v_str); + if (err > 0) + return error_value(E_FPUTS3); + } + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_fputstr(int count, VALUE **vals) +{ + VALUE result; + int i, err; + + if (vals[0]->v_type != V_FILE) + return error_value(E_FPUTSTR1); + for (i = 1; i < count; i++) { + if (vals[i]->v_type != V_STR) + return error_value(E_FPUTSTR2); + } + for (i = 1; i < count; i++) { + err = idfputstr(vals[0]->v_file, vals[i]->v_str); + if (err > 0) + return error_value(E_FPUTSTR3); + } + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_printf(int count, VALUE **vals) +{ + VALUE result; + int i; + + if (vals[0]->v_type != V_STR) + return error_value(E_PRINTF1); + i = idprintf(FILEID_STDOUT, vals[0]->v_str, count - 1, vals + 1); + if (i) + return error_value(E_PRINTF2); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_strprintf(int count, VALUE **vals) +{ + VALUE result; + int i; + + if (vals[0]->v_type != V_STR) + return error_value(E_STRPRINTF1); + math_divertio(); + i = idprintf(FILEID_STDOUT, vals[0]->v_str, count - 1, vals + 1); + if (i) + return error_value(E_STRPRINTF2); + result.v_str = math_getdivertedio(); + result.v_type = V_STR; + result.v_subtype = V_STRALLOC; + return result; +} + + +static VALUE +f_fgetc(VALUE *vp) +{ + VALUE result; + int ch; + + if (vp->v_type != V_FILE) + return error_value(E_FGETC1); + ch = getcharid(vp->v_file); + if (ch == -2) + return error_value(E_FGETC2); + 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_ungetc(VALUE *v1, VALUE *v2) +{ + VALUE result; + NUMBER *q; + int ch; + int i; + + errno = 0; + if (v1->v_type != V_FILE) + return error_value(E_UNGETC1); + switch (v2->v_type) { + case V_STR: + ch = v2->v_str[0]; + break; + case V_NUM: + q = v2->v_num; + if (!qisint(q)) + return error_value(E_UNGETC2); + ch = qisneg(q) ? (int)(-q->num.v[0] & 0xff) : + (int)(q->num.v[0] & 0xff); + break; + default: + return error_value(E_UNGETC2); + } + i = idungetc(v1->v_file, ch); + if (i == EOF) + return error_value(errno); + if (i == -2) + return error_value(E_UNGETC3); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_fgetline(VALUE *vp) +{ + VALUE result; + char *str; + int i; + + if (vp->v_type != V_FILE) + return error_value(E_FGETLINE1); + i = readid(vp->v_file, 9, &str); + if (i > 0) + return error_value(E_FGETLINE2); + result.v_type = V_NULL; + if (i == 0) { + result.v_type = V_STR; + result.v_subtype = V_STRALLOC; + result.v_str = str; + } + return result; +} + + +static VALUE +f_fgets(VALUE *vp) +{ + VALUE result; + char *str; + int i; + + if (vp->v_type != V_FILE) + return error_value(E_FGETS1); + i = readid(vp->v_file, 1, &str); + if (i > 0) + return error_value(E_FGETS2); + result.v_type = V_NULL; + if (i == 0) { + result.v_type = V_STR; + result.v_subtype = V_STRALLOC; + result.v_str = str; + } + return result; +} + + +static VALUE +f_fgetstr(VALUE *vp) +{ + VALUE result; + char *str; + int i; + + if (vp->v_type != V_FILE) + return error_value(E_FGETSTR1); + i = readid(vp->v_file, 10, &str); + if (i > 0) + return error_value(E_FGETSTR2); + result.v_type = V_NULL; + if (i == 0) { + result.v_type = V_STR; + result.v_subtype = V_STRALLOC; + result.v_str = str; + } + return result; +} + + +static VALUE +f_fgetfield(VALUE *vp) +{ + VALUE result; + char *str; + int i; + + if (vp->v_type != V_FILE) + return error_value(E_FGETWORD1); + i = readid(vp->v_file, 14, &str); + if (i > 0) + return error_value(E_FGETWORD2); + result.v_type = V_NULL; + if (i == 0) { + result.v_type = V_STR; + result.v_subtype = V_STRALLOC; + result.v_str = str; + } + return result; +} + + +static VALUE +f_files(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)) + return error_value(E_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; +} + + +static VALUE +f_reverse(VALUE *val) +{ + VALUE res; + + res.v_type = val->v_type; + switch(val->v_type) { + case V_MAT: + res.v_mat = matcopy(val->v_mat); + matreverse(res.v_mat); + break; + case V_LIST: + res.v_list = listcopy(val->v_list); + listreverse(res.v_list); + break; + default: + math_error("Bad argument type for reverse"); + /*NOTREACHED*/ + } + return res; +} + + +static VALUE +f_sort(VALUE *val) +{ + VALUE res; + + res.v_type = val->v_type; + switch (val->v_type) { + case V_MAT: + res.v_mat = matcopy(val->v_mat); + matsort(res.v_mat); + break; + case V_LIST: + res.v_list = listcopy(val->v_list); + listsort(res.v_list); + break; + default: + math_error("Bad argument type for sort"); + /*NOTREACHED*/ + } + return res; +} + + +static VALUE +f_join(int count, VALUE **vals) +{ + LIST *lp; + LISTELEM *ep; + VALUE res; + + lp = listalloc(); + while (count-- > 0) { + if (vals[0]->v_type != V_LIST) { + listfree(lp); + printf("Non-list argument for join\n"); + res.v_type = V_NULL; + return res; + } + for (ep = vals[0]->v_list->l_first; ep; ep = ep->e_next) + insertlistlast(lp, &ep->e_value); + vals++; + } + res.v_type = V_LIST; + res.v_list = lp; + return res; +} + + +static VALUE +f_head(VALUE *v1, VALUE *v2) +{ + LIST *lp; + LISTELEM *ep; + long n; + VALUE res; + + if (v1->v_type != V_LIST) { + math_error("Non-list first argument for head"); + /*NOTREACHED*/ + } + if (v2->v_type != V_NUM || qisfrac(v2->v_num)) { + math_error("Non-integer second argument for head"); + /*NOTREACHED*/ + } + n = qtoi(v2->v_num); + if (n < 0) + n += v1->v_list->l_count; + lp = listalloc(); + for (ep = v1->v_list->l_first; n-- > 0 && ep; ep = ep->e_next) + insertlistlast(lp, &ep->e_value); + res.v_type = V_LIST; + res.v_list = lp; + return res; +} + + +static VALUE +f_tail(VALUE *v1, VALUE *v2) +{ + LIST *lp; + LISTELEM *ep; + long n; + VALUE res; + + if (v1->v_type != V_LIST) { + math_error("Non-list first argument for tail"); + /*NOTREACHED*/ + } + if (v2->v_type != V_NUM || qisfrac(v2->v_num)) { + math_error("Non-integer second argument for tail"); + /*NOTREACHED*/ + } + n = qtoi(v2->v_num); + if (n < 0) + n += v1->v_list->l_count; + lp = listalloc(); + for (ep = v1->v_list->l_last; n-- > 0 && ep; ep = ep->e_prev) + insertlistfirst(lp, &ep->e_value); + res.v_type = V_LIST; + res.v_list = lp; + return res; +} + + +static VALUE +f_segment(VALUE *v1, VALUE *v2, VALUE *v3) +{ + LIST *lp; + LISTELEM *ep; + long n1, n2, i; + VALUE res; + + if (v1->v_type != V_LIST) { + math_error("Non-list first argument for segment"); + /*NOTREACHED*/ + } + if (v2->v_type != V_NUM || qisfrac(v2->v_num)) { + math_error("Non-integer second argument for segment"); + /*NOTREACHED*/ + } + if (v3->v_type != V_NUM || qisfrac(v3->v_num)) { + math_error("Non-integer third argument for segment"); + /*NOTREACHED*/ + } + n1 = qtoi(v2->v_num); + n2 = qtoi(v3->v_num); + if (n1 < 0 || n1 >= v1->v_list->l_count) { + math_error("Second argument out of range for segment"); + /*NOTREACHED*/ + } + if (n2 < 0 || n2 >= v1->v_list->l_count) { + math_error("Third argument out of range for segment"); + /*NOTREACHED*/ + } + lp = listalloc(); + ep = v1->v_list->l_first; + if (n1 <= n2) { + i = n2 - n1 + 1; + while(n1-- > 0 && ep) + ep = ep->e_next; + while(i-- > 0 && ep) { + insertlistlast(lp, &ep->e_value); + ep = ep->e_next; + } + + } + else { + i = n1 - n2 + 1; + while(n2-- > 0 && ep) + ep = ep->e_next; + while(i-- > 0 && ep) { + insertlistfirst(lp, &ep->e_value); + ep = ep->e_next; + } + } + res.v_type = V_LIST; + res.v_list = lp; + return res; +} + + +static VALUE +f_modify(VALUE *v1, VALUE *v2) +{ + FUNC *fp; + LISTELEM *ep; + long s; + VALUE res; + VALUE *vp; + + if (v1->v_type != V_ADDR) { + math_error("Non-variable first argument for modify"); + /*NOTREACHED*/ + } + v1 = v1->v_addr; + if (v2->v_type == V_ADDR) + v2 = v2->v_addr; + if (v2->v_type != V_STR) { + math_error("Non-string second argument for modify"); + /*NOTREACHED*/ + } + fp = findfunc(adduserfunc(v2->v_str)); + if (!fp) { + math_error("Undefined function for modify"); + /*NOTREACHED*/ + } + switch (v1->v_type) { + case V_LIST: + for (ep = v1->v_list->l_first; ep; ep = ep->e_next) { + *++stack = ep->e_value; + calculate(fp, 1); + ep->e_value = *stack--; + } + break; + case V_MAT: + vp = v1->v_mat->m_table; + s = v1->v_mat->m_size; + while (s-- > 0) { + *++stack = *vp; + calculate(fp, 1); + *vp++ = *stack--; + } + break; + default: + math_error("Non list or matrix first argument for modify"); + /*NOTREACHED*/ + } + res.v_type = V_NULL; + return res; +} + + +static VALUE +f_forall(VALUE *v1, VALUE *v2) +{ + FUNC *fp; + LISTELEM *ep; + long s; + VALUE res; + VALUE *vp; + + if (v2->v_type != V_STR) { + math_error("Non-string second argument for forall"); + /*NOTREACHED*/ + } + fp = findfunc(adduserfunc(v2->v_str)); + if (!fp) { + math_error("Undefined function for forall"); + /*NOTREACHED*/ + } + switch (v1->v_type) { + case V_LIST: + for (ep = v1->v_list->l_first; ep; ep = ep->e_next) { + copyvalue(&ep->e_value, ++stack); + calculate(fp, 1); + stack--; + } + break; + case V_MAT: + vp = v1->v_mat->m_table; + s = v1->v_mat->m_size; + while (s-- > 0) { + copyvalue(vp++, ++stack); + calculate(fp, 1); + stack--; + } + break; + default: + math_error("Non list or matrix first argument for forall"); + /*NOTREACHED*/ + } + res.v_type = V_NULL; + return res; +} + + +static VALUE +f_select(VALUE *v1, VALUE *v2) +{ + LIST *lp; + LISTELEM *ep; + FUNC *fp; + VALUE res; + + if (v1->v_type != V_LIST) { + math_error("Non-list first argument for select"); + /*NOTREACHED*/ + } + if (v2->v_type != V_STR) { + math_error("Non-string second argument for select"); + /*NOTREACHED*/ + } + fp = findfunc(adduserfunc(v2->v_str)); + if (!fp) { + math_error("Undefined function for select"); + /*NOTREACHED*/ + } + lp = listalloc(); + for (ep = v1->v_list->l_first; ep; ep = ep->e_next) { + copyvalue(&ep->e_value, ++stack); + calculate(fp, 1); + if (testvalue(stack)) + insertlistlast(lp, &ep->e_value); + freevalue(stack--); + } + res.v_type = V_LIST; + res.v_list = lp; + return res; +} + + +static VALUE +f_count(VALUE *v1, VALUE *v2) +{ + LISTELEM *ep; + FUNC *fp; + long s; + long n = 0; + VALUE res; + VALUE *vp; + + if (v2->v_type != V_STR) { + math_error("Non-string second argument for select"); + /*NOTREACHED*/ + } + fp = findfunc(adduserfunc(v2->v_str)); + if (!fp) { + math_error("Undefined function for select"); + /*NOTREACHED*/ + } + switch (v1->v_type) { + case V_LIST: + for (ep = v1->v_list->l_first; ep; ep = ep->e_next) { + copyvalue(&ep->e_value, ++stack); + calculate(fp, 1); + if (testvalue(stack)) + n++; + freevalue(stack--); + } + break; + case V_MAT: + s = v1->v_mat->m_size; + vp = v1->v_mat->m_table; + while (s-- > 0) { + copyvalue(vp++, ++stack); + calculate(fp, 1); + if (testvalue(stack)) + n++; + freevalue(stack--); + } + break; + default: + math_error("Bad argument type for count"); + /*NOTREACHED*/ + } + res.v_type = V_NUM; + res.v_num = itoq(n); + return res; +} + + +static VALUE +f_makelist(VALUE *v1) +{ + LIST *lp; + VALUE res; + long n; + + if (v1->v_type != V_NUM || qisfrac(v1->v_num) || qisneg(v1->v_num)) { + math_error("Bad argument for makelist"); + /*NOTREACHED*/ + } + if (zge31b(v1->v_num->num)) { + math_error("makelist count >= 2^31"); + /*NOTREACHED*/ + } + n = qtoi(v1->v_num); + lp = listalloc(); + res.v_type = V_NULL; + while (n-- > 0) + insertlistlast(lp, &res); + res.v_type = V_LIST; + res.v_list = lp; + return res; +} + + +static VALUE +f_randperm(VALUE *val) +{ + VALUE res; + + res.v_type = val->v_type; + switch (val->v_type) { + case V_MAT: + res.v_mat = matcopy(val->v_mat); + matrandperm(res.v_mat); + break; + case V_LIST: + res.v_list = listcopy(val->v_list); + listrandperm(res.v_list); + break; + default: + math_error("Bad argument type for randperm"); + /*NOTREACHED*/ + } + return res; +} + + +static VALUE +f_cmdbuf(void) +{ + VALUE result; + char *newcp; + + newcp = (char *)malloc(strlen(cmdbuf) + 1); + strcpy(newcp, cmdbuf); + result.v_type = V_STR; + result.v_subtype = V_STRALLOC; + result.v_str = newcp; + return result; +} + + +static VALUE +f_getenv(VALUE *v1) +{ + VALUE result; + + if (v1->v_type != V_STR) { + math_error("Non-string argument for getenv"); + /*NOTREACHED*/ + } + result.v_type = V_STR; + result.v_subtype = V_STRLITERAL; + result.v_str = getenv(v1->v_str); + if(result.v_str == NULL) { + result.v_type = V_NULL; + } + return result; +} + + +static VALUE +f_isatty(VALUE *vp) +{ + VALUE result; + int i; + + if (vp->v_type != V_FILE) + return error_value(E_ISATTY1); + i = isattyid(vp->v_file); + if (i == -2) + return error_value(E_ISATTY2); + result.v_type = V_NUM; + result.v_num = i ? qlink(&_qone_) : qlink(&_qzero_); + return result; +} + + +static VALUE +f_access(int count, VALUE **vals) +{ + NUMBER *q; + int m; + char *s, *fname; + VALUE result; + long i; + + errno = 0; + if (vals[0]->v_type != V_STR) + return error_value(E_ACCESS1); + fname = vals[0]->v_str; + m = 0; + if (count == 2) { + switch (vals[1]->v_type) { + case V_NUM: + q = vals[1]->v_num; + if (qisfrac(q) || qisneg(q)) + return error_value(E_ACCESS2); + m = (int)(q->num.v[0] & 7); + break; + case V_STR: + s = vals[1]->v_str; + i = (long)strlen(s); + while (i-- > 0) { + switch (*s++) { + case 'r': m |= 4; break; + case 'w': m |= 2; break; + case 'x': m |= 1; break; + default: return error_value(E_ACCESS2); + } + } + break; + case V_NULL: + break; + default: + return error_value(E_ACCESS2); + } + } + i = access(fname, m); + if (i) + return error_value(errno); + result.v_type = V_NULL; + return result; +} + + +static VALUE +f_putenv(int count, VALUE **vals) +{ + VALUE result; + char *putenv_str; + + /* + * parse args + */ + if (count == 2) { + /* firewall */ + if (vals[0]->v_type != V_STR || vals[1]->v_type != V_STR) { + math_error("Non-string argument for putenv"); + /*NOTREACHED*/ + } + + /* convert putenv("foo","bar") into putenv("foo=bar") */ + putenv_str = (char *)malloc(strlen(vals[0]->v_str) + 1 + + strlen(vals[1]->v_str) + 1); + if (putenv_str == NULL) { + math_error("Cannot allocate string in putenv"); + /*NOTREACHED*/ + } + sprintf(putenv_str, "%s=%s", vals[0]->v_str, vals[1]->v_str); + + + } else { + /* firewall */ + if (vals[0]->v_type != V_STR) { + math_error("Non-string argument for putenv"); + /*NOTREACHED*/ + } + + /* putenv(arg) must be of the form "foo=bar" */ + if ((char *)strchr(vals[0]->v_str, '=') == NULL) { + math_error("putenv single arg string missing ="); + /*NOTREACHED*/ + } + + /* + * make a copy of the arg because subsequent changes + * would change the environment. + */ + putenv_str = (char *)malloc(strlen(vals[0]->v_str) + 1); + if (putenv_str == NULL) { + math_error("Cannot allocate string in putenv"); + /*NOTREACHED*/ + } + strcpy(putenv_str, vals[0]->v_str); + } + + /* return putenv result */ + result.v_type = V_NUM; + result.v_num = itoq((long) putenv(putenv_str)); + return result; +} + + +static VALUE +f_strpos(VALUE *haystack, VALUE *needle) +{ + VALUE result; + char *cpointer; + int cindex; + + if (haystack->v_type != V_STR || needle->v_type != V_STR) { + math_error("Non-string argument for index"); + /*NOTREACHED*/ + } + result.v_type = V_NUM; + cpointer = strstr(haystack->v_str,needle->v_str); + if(cpointer == NULL) cindex=0; + else cindex=cpointer - haystack->v_str + 1; + result.v_num = itoq((long) cindex); + return result; +} + + +static VALUE +f_system(VALUE *vp) +{ + VALUE result; + + if (vp->v_type != V_STR) { + math_error("Non-string argument for system"); + /*NOTREACHED*/ + } + if (!allow_exec) { + math_error("execution disallowed by -m"); + /*NOTREACHED*/ + } + result.v_type = V_NUM; + result.v_num = itoq((long) system(vp->v_str)); + return result; +} + + +/* + * set the default output base/mode + */ +static NUMBER * +f_base(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(conf->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"); + /*NOTREACHED*/ + break; + } + + /* return the old base */ + return base_value(oldbase); +} + + +/* + * return a numerical 'value' of the mode/base + */ +static NUMBER * +base_value(long mode) +{ + NUMBER *result; + + /* return the old base */ + switch (mode) { + case MODE_DEFAULT: + switch (conf->outmode) { + case MODE_DEFAULT: + result = itoq(10); + 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; + } + 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; +} + + +#endif /* !FUNCLIST */ + + +/* + * builtins - List of primitive built-in functions + * + * NOTE: This table is also used by the help/Makefile builtin rule to + * form the builtin help file. This rule will cause a sed script + * to strip this table down into a just the information needed + * to print builtin function list: b_name, b_minargs, b_maxargs + * and b_desc. All other struct elements will be converted to 0. + * The sed script expects to find entries of the form: + * + * {"...", number, number, stuff, stuff, stuff, stuff, + * "...."}, + * + * please keep this table in that form. + * + * For nice output, when the description of function (b_desc) + * gets too long (extends into col 79) you should chop the + * line and add "\n\t\t ", thats newline, 2 tabs a 4 spaces. + * For example the description: + * + * ... very long description that goes beyond col 79 + * + * should be written as: + * + * "... very long description that\n\t\t goes beyond col 79"}, + * + * fields: + * b_name name of built-in function + * b_minargs minimum number of arguments + * b_maxargs maximum number of arguments + * b_flags special handling flags + * b_opcode opcode which makes the call quick + * b_numfunc routine to calculate numeric function + * b_valfunc routine to calculate general values + * b_desc description of function + */ +static CONST struct builtin builtins[] = { + {"abs", 1, 2, 0, OP_ABS, 0, 0, + "absolute value within accuracy b"}, + {"access", 1, 2, 0, OP_NOP, 0, f_access, + "determine accessibility of file a for mode b"}, + {"acos", 1, 2, FE, OP_NOP, qacos, 0, + "arccosine of a within accuracy b"}, + {"acosh", 1, 2, FE, OP_NOP, qacosh, 0, + "inverse hyperbolic cosine of a within accuracy b"}, + {"acot", 1, 2, FE, OP_NOP, qacot, 0, + "arccotangent of a within accuracy b"}, + {"acoth", 1, 2, FE, OP_NOP, qacoth, 0, + "inverse hyperbolic cotangent of a within accuracy b"}, + {"acsc", 1, 2, FE, OP_NOP, qacsc, 0, + "arccosecant of a within accuracy b"}, + {"acsch", 1, 2, FE, OP_NOP, qacsch, 0, + "inverse csch of a within accuracy b"}, + {"append", 1, IN, FA, OP_NOP, 0, f_listappend, + "append values to end of list"}, + {"appr", 1, 3, 0, OP_NOP, 0, f_appr, + "approximate a by multiple of b using rounding c"}, + {"arg", 1, 2, 0, OP_NOP, 0, f_arg, + "argument (the angle) of complex number"}, + {"asec", 1, 2, FE, OP_NOP, qasec, 0, + "arcsecant of a within accuracy b"}, + {"asech", 1, 2, FE, OP_NOP, qasech, 0, + "inverse hyperbolic secant of a within accuracy b"}, + {"asin", 1, 2, FE, OP_NOP, qasin, 0, + "arcsine of a within accuracy b"}, + {"asinh", 1, 2, FE, OP_NOP, qasinh, 0, + "inverse hyperbolic sine 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, + "inverse hyperbolic tangent of a within accuracy b"}, + {"avg", 0, 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, 3, 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, 0, f_ceil, + "smallest integer greater than or equal to number"}, + {"cfappr", 1, 3, 0, OP_NOP, f_cfappr, 0, + "approximate a within accuracy b using\n\t\t continued fractions"}, + {"cfsim", 1, 2, 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"}, + {"cmdbuf", 0, 0, 0, OP_NOP, 0, f_cmdbuf, + "command buffer"}, + {"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"}, + {"cot", 1, 2, FE, OP_NOP, qcot, 0, + "cotangent of a within accuracy b"}, + {"coth", 1, 2, FE, OP_NOP, qcoth, 0, + "hyperbolic cotangent of a within accuracy b"}, + {"count", 2, 2, 0, OP_NOP, 0, f_count, + "count listr/matrix elements satisfying some condition"}, + {"cp", 2, 2, 0, OP_NOP, 0, f_cp, + "cross product of two vectors"}, + {"csc", 1, 2, FE, OP_NOP, qcsc, 0, + "cosecant of a within accuracy b"}, + {"csch", 1, 2, FE, OP_NOP, qcsch, 0, + "hyperbolic cosecant of a within accuracy b"}, + {"ctime", 0, 0, 0, OP_NOP, 0, f_ctime, + "date and time as string"}, + {"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"}, + {"errno", 1, 1, 0, OP_NOP, 0, f_errno, + "system error message"}, + {"error", 1, 1, 0, OP_NOP, 0, f_error, + "generate error value"}, + {"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"}, + {"factor", 1, 3, 0, OP_NOP, f_factor, 0, + "lowest prime factor < b of a, return c if error"}, + {"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)"}, + {"forall", 2, 2, 0, OP_NOP, 0, f_forall, + "do function for all elements of list or matrix"}, + {"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", 0, IN, 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", 0, IN, 0, OP_NOP, 0, f_fflush, + "flush output to file(s)"}, + {"fgetc", 1, 1, 0, OP_NOP, 0, f_fgetc, + "read next char from file"}, + {"fgetfield", 1, 1, 0, OP_NOP, 0, f_fgetfield, + "read next white-space delimited field from file"}, + {"fgetline", 1, 1, 0, OP_NOP, 0, f_fgetline, + "read next line from file, newline removed"}, + {"fgets", 1, 1, 0, OP_NOP, 0, f_fgets, + "read next line from file, newline is kept"}, + {"fgetstr", 1, 1, 0, OP_NOP, 0, f_fgetstr, + "read next null-terminated string from file, null character is kept"}, + {"files", 0, 1, 0, OP_NOP, 0, f_files, + "return opened file or max number of opened files"}, + {"floor", 1, 1, 0, OP_NOP, 0, f_floor, + "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"}, + {"fputc", 2, 2, 0, OP_NOP, 0, f_fputc, + "write a character to a file"}, + {"fputs", 2, IN, 0, OP_NOP, 0, f_fputs, + "write one or more strings to a file"}, + {"fputstr", 2, IN, 0, OP_NOP, 0, f_fputstr, + "write one or more null-terminated strings to a file"}, + {"freopen", 2, 3, 0, OP_NOP, 0, f_freopen, + "reopen a file stream to a named file"}, + {"fscan", 2, IN, FA, OP_NOP, 0, f_fscan, + "scan a file for assignments to one or more variables"}, + {"fscanf", 2, IN, FA, OP_NOP, 0, f_fscanf, + "formatted scan of a file for assignment to one or more variables"}, + {"fseek", 2, 3, 0, OP_NOP, 0, f_fseek, + "seek to position b (offset from c) in file a"}, + {"fsize", 1, 1, 0, OP_NOP, 0, f_fsize, + "return the size of the file"}, + {"ftell", 1, 1, 0, OP_NOP, 0, f_ftell, + "return the file position"}, + {"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"}, + {"getenv", 1, 1, 0, OP_NOP, 0, f_getenv, + "value of environment variable (or NULL)"}, + {"hash", 1, IN, 0, OP_NOP, 0, f_hash, + "return non-negative hash value for one or\n\t\t more values"}, + {"head", 2, 2, 0, OP_NOP, 0, f_head, + "return list of specified number at head of a list"}, + {"highbit", 1, 1, 0, OP_NOP, f_highbit, 0, + "high bit number in base 2 representation"}, + {"hmean", 0, IN, 0, OP_NOP, 0, f_hmean, + "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", 2, IN, FA, OP_NOP, 0, f_listinsert, + "insert values 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"}, + {"isatty", 1, 1, 0, OP_NOP, 0, f_isatty, + "whether a file is a tty"}, + {"isconfig", 1, 1, 0, OP_ISCONFIG, 0, 0, + "whether a value is a config state"}, + {"iserror", 1, 1, 0, OP_NOP, 0, f_iserror, + "where a value is an error"}, + {"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"}, + {"ishash", 1, 1, 0, OP_ISHASH, 0, 0, + "whether a value is a hash state"}, + {"isident", 1, 1, 0, OP_NOP, 0, f_isident, + "returns 1 if identity matrix"}, + {"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"}, + {"isprime", 1, 2, 0, OP_NOP, f_isprime, 0, + "whether a is a small prime, return b if error"}, + {"isqrt", 1, 1, 0, OP_NOP, qisqrt, 0, + "integer part of square root"}, + {"isrand", 1, 1, 0, OP_ISRAND, 0, 0, + "whether a value is a additive 55 state"}, + {"israndom", 1, 1, 0, OP_ISRANDOM, 0, 0, + "whether a value is a Blum state"}, + {"isreal", 1, 1, 0, OP_ISREAL, 0, 0, + "whether a value is a real number"}, + {"isrel", 2, 2, 0, OP_NOP, f_isrel, 0, + "whether two numbers are relatively prime"}, + {"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"}, + {"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"}, + {"join", 1, IN, 0, OP_NOP, 0, f_join, + "join one or more lists into one list"}, + {"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))"}, + {"makelist", 1, 1, 0, OP_NOP, 0, f_makelist, + "create a list with a null elements"}, + {"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"}, + {"matsum", 1, 1, 0, OP_NOP, 0, f_matsum, + "sum the numeric values in a matrix"}, + {"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, 0, f_mmin, + "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"}, + {"mod", 2, 3, 0, OP_NOP, 0, f_mod, + "residue of a modulo b, rounding type c"}, + {"modify", 2, 2, FA, OP_NOP, 0, f_modify, + "modify elements of a list or matrix"}, + {"near", 2, 3, 0, OP_NOP, f_near, 0, + "sign of (abs(a-b) - c)"}, + {"newerror", 0, 1, 0, OP_NOP, 0, f_newerror, + "create new error type with message a"}, + {"nextcand", 1, 5, 0, OP_NOP, f_nextcand, 0, + "smallest value == d mod e > a, ptest(a,b,c) true"}, + {"nextprime", 1, 2, 0, OP_NOP, f_nprime, 0, + "return next small prime, return b if err"}, + {"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)!"}, + {"prevcand", 1, 5, 0, OP_NOP, f_prevcand, 0, + "largest value == d mod e < a, ptest(a,b,c) true"}, + {"prevprime", 1, 2, 0, OP_NOP, f_pprime, 0, + "return previous small prime, return b if err"}, + {"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"}, + {"pix", 1, 2, 0, OP_NOP, f_pix, 0, + "number of primes <= a < 2^32, return b if error"}, + {"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", 1, IN, 0, OP_NOP, 0, f_poly, + "evaluates a polynomial given its coefficients or coefficient-list"}, + {"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", 1, 3, 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", 1, IN, FA, OP_NOP, 0, f_listpush, + "push values onto front of list"}, + {"putenv", 1, 2, 0, OP_NOP, 0, f_putenv, + "define an environment variable"}, + {"quo", 2, 3, 0, OP_NOP, 0, f_quo, + "integer quotient of a by b, rounding type c"}, + {"quomod", 4, 4, 0, OP_QUOMOD, 0, 0, + "set c and d to quotient and remainder of a\n\t\t divided by b"}, + {"rand", 0, 2, 0, OP_NOP, f_rand, 0, + "additive 55 random number [0,2^64), [0,a), or [a,b)"}, + {"randbit", 0, 1, 0, OP_NOP, f_randbit, 0, + "additive 55 random number [0,2^a)"}, + {"randperm", 1, 1, 0, OP_NOP, 0, f_randperm, + "random permutation of a list or matrix"}, + {"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"}, + {"reverse", 1, 1, 0, OP_NOP, 0, f_reverse, + "reverse a copy of a matrix or list"}, + {"rewind", 0, IN, 0, OP_NOP, 0, f_rewind, + "rewind file(s)"}, + {"rm", 1, 1, 0, OP_NOP, 0, f_rm, + "remove a file"}, + {"root", 2, 3, 0, OP_NOP, 0, f_root, + "value a taken to the b'th root within accuracy c"}, + {"round", 1, 3, 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"}, + {"scan", 1, IN, FA, OP_NOP, 0, f_scan, + "scan standard input for assignment to one or more variables"}, + {"scanf", 2, IN, FA, OP_NOP, 0, f_scanf, + "formatted scan of standard input for assignment to variables"}, + {"search", 2, 3, 0, OP_NOP, 0, f_search, + "search matrix or list for value b starting\n\t\t at index c"}, + {"sec", 1, 2, FE, OP_NOP, qsec, 0, + "sec of a within accuracy b"}, + {"sech", 1, 2, FE, OP_NOP, qsech, 0, + "hyperbolic secant of a within accuracy b"}, + {"segment", 3, 3, 0, OP_NOP, 0, f_segment, + "specified segment of specified list"}, + {"select", 2, 2, 0, OP_NOP, 0, f_select, + "form sublist of selected elements from list"}, + {"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"}, + {"sizeof", 1, 1, 0, OP_NOP, 0, f_sizeof, + "number of bytes in memory storage for value"}, + {"sort", 1, 1, 0, OP_NOP, 0, f_sort, + "sort a copy of a matrix or list"}, + {"sqrt", 1, 3, 0, OP_NOP, 0, f_sqrt, + "square root of value a within accuracy b"}, + {"srand", 0, 1, 0, OP_NOP, 0, f_srand, + "seed the rand() function"}, + {"srandom", 0, 1, 0, OP_NOP, 0, f_srandom, + "seed the random() function"}, + {"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"}, + {"strerror", 1, 1, 0, OP_NOP, 0, f_strerror, + "string describing error type"}, + {"strlen", 1, 1, 0, OP_NOP, 0, f_strlen, + "length of string"}, + {"strpos", 2, 2, 0, OP_NOP, 0, f_strpos, + "index of first occurrence of b in a"}, + {"strprintf", 1, IN, 0, OP_NOP, 0, f_strprintf, + "return formatted output as a string"}, + {"strscan", 2, IN, FA, OP_NOP, 0, f_strscan, + "scan a string for assignments to one or more variables"}, + {"strscanf", 2, IN, FA, OP_NOP, 0, f_strscanf, + "formatted scan of string for assignments to variables"}, + {"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)"}, + {"system", 1, 1, 0, OP_NOP, 0, f_system, + "call Unix command"}, + {"tail", 2, 2, 0, OP_NOP, 0, f_tail, + "retain list of specified number at tail of list"}, + {"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"}, + {"time", 0, 0, 0, OP_NOP, f_time, 0, + "number of seconds since 00:00:00 1 Jan 1970 UTC"}, + {"trunc", 1, 2, 0, OP_NOP, f_trunc, 0, + "truncate a to b number of decimal places"}, + {"ungetc", 2, 2, 0, OP_NOP, 0, f_ungetc, + "unget char read from file"}, + {"xor", 1, IN, 0, OP_NOP, f_xor, 0, + "logical xor"}, + + /* end of table */ + {NULL, 0, 0, 0, 0, 0, 0, + NULL} +}; + + +/* + * Show the list of primitive built-in functions + * + * When FUNCLIST is defined, we are being compiled by rules from the help + * sub-directory to form a program that will produce the main part of the + * buiiltin help file. These rules will convert the following function + * name into main and remove the 'sed me out' line. + * + * See the builtin rule in the help/Makefile for details. + */ +void /* sed me out */ +showbuiltins(void) +{ + CONST 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"); +} + + +#if !defined(FUNCLIST) + +/* + * 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. + * + * given: + * index index on where to scan in builtin table + * argcount number of args + * stck arguments on the stack + */ +VALUE +builtinfunc(long index, int argcount, VALUE *stck) +{ + VALUE *sp; /* pointer to stack entries */ + VALUE **vpp; /* pointer to current value address */ + CONST struct builtin *bp; /* builtin function to be called */ + NUMBER *numargs[IN]; /* numeric arguments for function */ + VALUE *valargs[IN]; /* addresses of actual arguments */ + VALUE result; /* general result of function */ + long i; + + if ((unsigned long)index >= + (sizeof(builtins) / sizeof(builtins[0])) - 1) { + math_error("Bad built-in function index"); + /*NOTREACHED*/ + } + bp = &builtins[index]; + if (argcount < bp->b_minargs) { + math_error("Too few arguments for builtin function \"%s\"", + bp->b_name); + /*NOTREACHED*/ + } + if ((argcount > bp->b_maxargs) || (argcount > IN)) { + math_error("Too many arguments for builtin function \"%s\"", + bp->b_name); + /*NOTREACHED*/ + } + /* + * 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); + /*NOTREACHED*/ + } + 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++] = conf->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"); + /*NOTREACHED*/ + } + return result; +} + + +/* + * Return the index of a built-in function given its name. + * Returns minus one if the name is not known. + */ +int +getbuiltinfunc(char *name) +{ + CONST 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(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(long index, int count) +{ + CONST struct builtin *bp; + + if ((unsigned long)index >= + (sizeof(builtins) / sizeof(builtins[0])) - 1) { + math_error("Unknown built in index"); + /*NOTREACHED*/ + } + 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(long index) +{ + if ((unsigned long)index >= + (sizeof(builtins) / sizeof(builtins[0])) - 1) + return OP_NOP; + return builtins[index].b_opcode; +} + + +#endif /* FUNCLIST */ diff --git a/func.h b/func.h new file mode 100644 index 0000000..7720575 --- /dev/null +++ b/func.h @@ -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 */ + unsigned 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(long index); +extern char *namefunc(long index); +extern BOOL evaluate(BOOL nestflag); +extern long adduserfunc(char *name); +extern void beginfunc(char *name, BOOL newflag); +extern int builtinopcode(long index); +extern char *builtinname(long index); +extern int dumpop(unsigned long *pc); +extern void addop(long op); +extern void endfunc(void); +extern void addopone(long op, long arg); +extern void addoptwo(long op, long arg1, long arg2); +extern void addoplabel(long op, LABEL *label); +extern void addopptr(long op, char *ptr); +extern void writeindexop(void); +extern void showbuiltins(void); +extern int getbuiltinfunc(char *name); +extern void builtincheck(long index, int count); +extern void addopfunction(long op, long index, int count); +extern void showfunctions(void); +extern void initfunctions(void); +extern void clearopt(void); +extern void updateoldvalue(FUNC *fp); +extern void calculate(FUNC *fp, int argcount); +extern VALUE builtinfunc(long index, int argcount, VALUE *stck); + +#endif + +/* END CODE */ diff --git a/hash.c b/hash.c new file mode 100644 index 0000000..49cb6da --- /dev/null +++ b/hash.c @@ -0,0 +1,117 @@ +/* XXX - this code is currently not really used, but it will be soon */ +/* + * Copyright (c) 1995 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. + */ + +#include "value.h" + + +/* + * hash function interface table + * + * htbl[i] is the interface for hash algorithm i + */ +static HASHFUNC htbl[HASH_TYPE_MAX+1]; + + +/* + * static functions + */ +static void load_htbl(void (*h_func)(HASHFUNC*), HASHFUNC*); + + +/* + * hash_init - initialize hash function interface table + * + * We will load the hash function interface table and ensure that it is + * completely filled. + * + * This function does not return if an error is encountered. + */ +void +hash_init(void) +{ + int i; + + /* + * setup + */ + for (i=0; i <= HASH_TYPE_MAX; ++i) { + htbl[i].type = -1; + } + + /* + * setup the hash function interface for all hashes + */ + load_htbl(shs_hashfunc, htbl); + + /* + * verify that our interface table is fully populated + */ + for (i=0; i <= HASH_TYPE_MAX; ++i) { + if (htbl[i].type != i) { + fprintf(stderr, "htbl[%d] is bad\n", i); + exit(1); + } + } +} + + +/* + * load_htbl - load a hash function interface table slot + * + * We will call the h_func function, sanity check the function type + * and check to be sure that the slot is unused. + * + * given: + * h_func - a function that returns a HASHFUNC entry + * h - a array of hash function interfaces + * + * This function does not return if an error is encountered. + */ +static void +load_htbl(void (*h_func)(HASHFUNC*), HASHFUNC *h) +{ + HASHFUNC hent; /* hash function interface entry */ + + /* + * call the HASHFUNC interface function + */ + h_func(&hent); + + /* + * sanity check the type + */ + if (hent.type < 0 || hent.type > HASH_TYPE_MAX) { + fprintf(stderr, "bad HASHFUNC type: %d\n", hent.type); + exit(1); + } + if (h[hent.type].type >= 0) { + fprintf(stderr, "h[%d].type: %d already in use\n", + hent.type, h[hent.type].type); + exit(1); + } + + /* + * load the entry + */ + h[hent.type] = hent; +} diff --git a/hash.h b/hash.h new file mode 100644 index 0000000..85f3169 --- /dev/null +++ b/hash.h @@ -0,0 +1,50 @@ +/* XXX - this code is currently not really used, but it will be soon */ +/* + * Copyright (c) 1995 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. + */ + +#if !defined(HASH_H) +#define HASH_H + +/* + * hashstate - state of a hash system + */ +struct hashstate { + int type; /* hash type (see XYZ_HASH_TYPE below) */ + BOOL prevstr; /* TRUE=>previous value hashed was a string */ + union { + SHS_INFO hh_shs; /* old Secure Hash Standard */ + } h_union; +}; +typedef struct hashstate HASH; +/* For ease in referencing */ +#define h_shs h_union.hh_shs + + +/* + * XYZ_HASH_TYPE - hash types + * + * we support these hash types - must start with 0 + */ +#define SHS_HASH_TYPE 0 +#define HASH_TYPE_MAX 0 /* must be number of XYZ_HASH_TYPE values */ + +#endif /* !HASH_H */ diff --git a/have_const.c b/have_const.c new file mode 100644 index 0000000..daeef6f --- /dev/null +++ b/have_const.c @@ -0,0 +1,58 @@ +/* + * have_const - Determine if we want or can support ansi const + * + * usage: + * have_const + * + * Not all compilers support const, so this may not compile on your system. + * + * This prog outputs several defines: + * + * HAVE_CONST + * defined ==> ok to use const + * undefined ==> do not use const + * + * CONST + * const ==> use const + * (nothing) ==> const not used + */ +/* + * Copyright (c) 1995 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 +main(void) +{ +#if defined(HAVE_NO_CONST) + printf("#undef HAVE_CONST /* no */\n"); + printf("#undef CONST\n"); + printf("#define CONST /* no */\n"); +#else /* HAVE_NO_CONST */ + const char * const str = "const"; + + printf("#define HAVE_CONST /* yes */\n"); + printf("#undef CONST\n"); + printf("#define CONST %s /* yes */\n", str); +#endif /* HAVE_NO_CONST */ + exit(0); +} diff --git a/have_fpos.c b/have_fpos.c new file mode 100644 index 0000000..46fcc9a --- /dev/null +++ b/have_fpos.c @@ -0,0 +1,53 @@ +/* + * have_fpos - Determine if have fgetpos and fsetpos functions + * + * If the symbol HAVE_NO_FPOS is defined, we will output nothing. + * If we are able to compile this program, then we must have the + * fgetpos and fsetpos functions and we will output the + * appropriate have_fpos.h file body. + */ +/* + * Copyright (c) 1995 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 + +MAIN +main(void) +{ +#if !defined(HAVE_NO_FPOS) + fpos_t pos; /* file position */ + + /* get the current position */ + (void) fgetpos(stdin, &pos); + + /* set the current position */ + (void) fsetpos(stdin, &pos); + + /* print a have_fpos.h body that says we have the functions */ + printf("#undef HAVE_FPOS\n"); + printf("#define HAVE_FPOS 1 /* yes */\n\n"); + printf("typedef fpos_t FILEPOS;\n"); +#endif + exit(0); +} diff --git a/have_newstr.c b/have_newstr.c new file mode 100644 index 0000000..382c354 --- /dev/null +++ b/have_newstr.c @@ -0,0 +1,60 @@ +/* + * have_newstr - Determine if we have a system without ANSI C string functions + * + * usage: + * have_newstr + * + * Not all systems support all ANSI C string functions, so this may not + * compile on your system. + * + * This prog outputs several defines: + * + * HAVE_NEWSTR + * defined ==> use memcpy(), memset(), strchr() + * undefined ==> use bcopy() instead of memcpy(), + * use bfill() instead of memset(), + * use index() instead of strchr() + */ +/* + * Copyright (c) 1995 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 /\../\ + */ + +#define MOVELEN 3 + +char src[] = "chongo was here"; +char dest[MOVELEN+1]; + +MAIN +main(void) +{ +#if defined(HAVE_NO_NEWSTR) + printf("#undef HAVE_NEWSTR /* no */\n"); +#else /* HAVE_NO_NEWSTR */ + (void) memcpy(dest, src, MOVELEN); + (void) memset(dest, 0, MOVELEN); + (void) strchr(src, 'e'); + + printf("#define HAVE_NEWSTR /* yes */\n"); +#endif /* HAVE_NO_NEWSTR */ + exit(0); +} diff --git a/have_stdvs.c b/have_stdvs.c new file mode 100644 index 0000000..551e0a6 --- /dev/null +++ b/have_stdvs.c @@ -0,0 +1,139 @@ +/* + * have_stdvs - try to see if it really works with vsprintf() + * + * On some systems that have both and , vsprintf() + * does not work well under one type of include file. + * + * Some systems (such as UMIPS) have bugs in the implementation + * that show up in vsprintf(), so we may have to try to use sprintf() + * as if it were vsprintf() and hope for the best. + * + * This program will output #defines and exits 0 if vsprintf() (or sprintf()) + * produces the results that we expect. This program exits 1 if vsprintf() + * (or sprintf()) produces unexpected results while using the + * include file. + */ +/* + * Copyright (c) 1995 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 + +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif +#include + +#include "have_string.h" +#ifdef HAVE_STRING_H +# include +#endif + +char buf[BUFSIZ]; + + +void +try(char *fmt, ...) +{ + va_list ap; + + va_start(ap, fmt); +#if !defined(DONT_HAVE_VSPRINTF) + vsprintf(buf, fmt, ap); +#else + sprintf(buf, fmt, ap); +#endif + va_end(ap); +} + + +MAIN +main(void) +{ + /* + * setup + */ + buf[0] = '\0'; + + /* + * test variable args and vsprintf/sprintf + */ + try("@%d:%s:%d@", 1, "hi", 2); + if (strcmp(buf, "@1:hi:2@") != 0) { +#if !defined(DONT_HAVE_VSPRINTF) + /* with vsprintf() didn't work */ +#else + /* with sprintf() simulating vsprintf() didn't work */ +#endif + exit(1); + } + try("%s %d%s%d%d %s", + "Landon Noll 1st proved that", 2, "^", 23209, -1, "was prime"); + if (strcmp(buf, "Landon Noll 1st proved that 2^23209-1 was prime") != 0) { +#if !defined(DONT_HAVE_VSPRINTF) + /* with vsprintf() didn't work */ +#else + /* with sprintf() simulating vsprintf() didn't work */ +#endif + exit(1); + } + + /* + * report the result + */ + puts("/* what type of variable args do we have? */"); +#if defined(DONT_HAVE_VSPRINTF) + puts("/*"); + puts(" * SIMULATE_STDARG"); + puts(" *"); + puts(" * WARNING: This type of stdarg makes assumptions about the stack"); + puts(" * that may not be true on your system. You may want to"); + puts(" * define STDARG (if using ANSI C) or VARARGS."); + puts(" */"); + puts("typedef char *va_list;"); + puts("#define va_start(ap,parmn) (void)((ap) = (char*)(&(parmn) + 1))"); + puts("#define va_end(ap) (void)((ap) = 0)"); + puts("#define va_arg(ap, type) \\"); + puts(" (((type*)((ap) = ((ap) + sizeof(type))))[-1])"); + puts("#define SIMULATE_STDARG /* use std_arg.h to simulate */"); +#else + puts("#define STDARG /* use */"); + puts("#include "); +#endif + puts("\n/* should we use vsprintf()? */"); +#if !defined(DONT_HAVE_VSPRINTF) + puts("#define HAVE_VS /* yes */"); +#else + puts("/*"); + puts(" * Hack aleart!!!"); + puts(" *"); + puts(" * Systems that do not have vsprintf() need something. In some"); + puts(" * cases the sprintf function will deal correctly with the"); + puts(" * va_alist 3rd arg. Hope for the best!"); + puts(" */"); + puts("#define vsprintf sprintf"); + puts("#undef HAVE_VS"); +#endif + exit(0); +} diff --git a/have_uid_t.c b/have_uid_t.c new file mode 100644 index 0000000..b7144b9 --- /dev/null +++ b/have_uid_t.c @@ -0,0 +1,62 @@ +/* + * have_uid_t - Determine if we want or can support uid_t + * + * usage: + * have_uid_t + * + * Not all compilers support uid_t, so this may not compile on your system. + * + * This prog outputs several defines: + * + * HAVE_UID_T + * defined ==> ok to use uid_t + * undefined ==> do not use uid_t + */ +/* + * Copyright (c) 1995 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 /\../\ + */ + +#if !defined(HAVE_NO_UID_T) +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif +#include +#include +#endif /* ! HAVE_NO_UID_T */ + +MAIN +main(void) +{ +#if defined(HAVE_NO_UID_T) + printf("#undef HAVE_UID_T /* no */\n"); +#else /* HAVE_NO_UID_T */ + uid_t curds; + extern uid_t geteuid(); + + curds = geteuid(); + + printf("#define HAVE_UID_T /* yes */\n"); +#endif /* HAVE_NO_UID_T */ + exit(0); +} diff --git a/have_varvs.c b/have_varvs.c new file mode 100644 index 0000000..58b8fb5 --- /dev/null +++ b/have_varvs.c @@ -0,0 +1,131 @@ +/* + * have_varvs - try to see if it really works with vsprintf() + * + * Some systems have bugs in the implementation that show up in + * vsprintf(), so we may have to try to use sprintf() as if it were vsprintf() + * and hope for the best. + * + * This program will output #defines and exits 0 if vsprintf() (or sprintf()) + * produces the results that we expect. This program exits 1 if vsprintf() + * (or sprintf()) produces unexpected results while using the + * include file. + */ +/* + * Copyright (c) 1995 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 + +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif + +#include "have_string.h" +#ifdef HAVE_STRING_H +# include +#endif + +char buf[BUFSIZ]; + +#if !defined(STDARG) && !defined(SIMULATE_STDARG) +#include + +void +try(char *fmt, ...) +{ + va_list ap; + + va_start(ap); +#if !defined(DONT_HAVE_VSPRINTF) + vsprintf(buf, fmt, ap); +#else + sprintf(buf, fmt, ap); +#endif + va_end(ap); +} + +#else + +void +try(char *a, int b, char *c, int d) +{ + return; +} + +#endif + + +MAIN +main(void) +{ + /* + * setup + */ + buf[0] = '\0'; + + /* + * test variable args and vsprintf/sprintf + */ + try("@%d:%s:%d@", 1, "hi", 2); + if (strcmp(buf, "@1:hi:2@") != 0) { +#if !defined(DONT_HAVE_VSPRINTF) + /* with vsprintf() didn't work */ +#else + /* with sprintf() simulating vsprintf() didn't work */ +#endif + exit(1); + } + try("%s %d%s%d%d %s", + "Landon Noll 1st proved that", 2, "^", 23209, -1, "was prime"); + if (strcmp(buf, "Landon Noll 1st proved that 2^23209-1 was prime") != 0) { +#if !defined(DONT_HAVE_VSPRINTF) + /* with vsprintf() didn't work */ +#else + /* with sprintf() simulating vsprintf() didn't work */ +#endif + exit(1); + } + + /* + * report the result + */ + puts("/* what type of variable args do we have? */"); + puts("#define VARARGS /* use */"); + puts("#include "); + puts("\n/* should we use vsprintf()? */"); +#if !defined(DONT_HAVE_VSPRINTF) + puts("#define HAVE_VS /* yes */"); +#else + puts("/*"); + puts(" * Hack aleart!!!"); + puts(" *"); + puts(" * Systems that do not have vsprintf() need something. In some"); + puts(" * cases the sprintf function will deal correctly with the"); + puts(" * va_alist 3rd arg. Hope for the best!"); + puts(" */"); + puts("#define vsprintf sprintf"); + puts("#undef HAVE_VS"); +#endif + exit(0); +} diff --git a/help/Makefile b/help/Makefile new file mode 100644 index 0000000..f5266a3 --- /dev/null +++ b/help/Makefile @@ -0,0 +1,369 @@ +# +# 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 + +# required vars +# +SHELL= /bin/sh +MAKE_FILE = Makefile + +# 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 + +# Makefile debug +# +# Q=@ do not echo internal makefile actions (quiet mode) +# Q= echo internal makefile actions (debug / verbose mode) +# +#Q= +Q=@ + +# standard tools +# +NATIVE_CC= cc +NATIVE_CFLAGS= +SED= sed +SORT= sort +FMT= fmt +CMP= cmp +CAT= cat + +# Standard help files +# +# The obj.file is special and is not listed here. +# +STD_HELP_FILES1= intro overview help command config \ + define environment expression file history interrupt 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} +SYMBOL_HELP= assign + +# These two lists are prodiced by the detaillist and missinglist rules +# when no WARNINGS are detected. +# +DETAIL_HELP= abs access acos acosh acot acoth acsc acsch append appr archive \ + arg asec asech asin asinh assoc atan atan2 atanh avg base bround \ + btrunc ceil cfappr cfsim char cmdbuf cmp comb conj cos cosh cot coth \ + count cp csc csch ctime delete den det digit digits dp epsilon errno \ + error eval exp fact factor fclose fcnt feof ferror fflush fgetc \ + fgetfield fgetline fgets fgetstr fib files floor fopen forall fprintf \ + fputc fputs fputstr frac frem freopen fscan fscanf fseek fsize ftell \ + gcd gcdrem getenv hash head highbit hmean hypot ilog ilog10 ilog2 im \ + insert int inverse iroot isassoc isatty isconfig iserror iseven \ + isfile ishash isident isint islist ismat ismult isnull isnum isobj \ + isodd isprime isqrt isrand israndom isreal isrel isset issimple issq \ + isstr istype jacobi join lcm lcmfact lfactor list ln lowbit ltol \ + makelist matdim matfill matmax matmin matsum mattrans max meq min \ + minv mmin mne mod modify near newerror nextcand nextprime norm null \ + num ord param perm pfact pi pix places pmod polar poly pop power \ + prevcand prevprime printf prompt ptest push putenv quo quomod rand \ + randbit randperm rcin rcmul rcout rcpow rcsq re rm remove reverse \ + rewind root round rsearch runtime scale scan scanf search sec sech \ + segment select sgn sin sinh size sizeof sort sqrt srand ssq str \ + strcat strerror strlen strpos strprintf strscan strscanf substr swap \ + system tail tan tanh time trunc xor + +# 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 errorcodes + +# Singular files +# +# These files are copies of their plural form. +# +PLURAL_FILES= bindings bugs changes errorcodes types +SINGULAR_FILES= binding bug change errorcode type + +# These files are found (but not built) in the distribution +# +DISTLIST= ${STD_HELP_FILES} ${DETAIL_HELP} ${SYMBOL_HELP} ${MAKE_FILE} \ + obj.file builtin.top builtin.end funclist.sed \ + errorcodes.hdr errorcodes.sed + +all: ${STD_HELP_FILES} obj.file ${BUILT_HELP_FILES} full \ + ${DETAIL_HELP} ${SINGULAR_FILES} builtin .all + +# used by the upper level Makefile to determine of we have done all +# +# NOTE: Due to bogus shells found on one common system we must have +# an non-emoty else clause for every if condition. *sigh* +# +.all: + rm -f .all + touch .all + +bindings: ../lib/bindings + rm -f bindings + cp ../lib/bindings bindings + chmod 0444 bindings + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +altbind: ../lib/altbind + rm -f altbind + cp ../lib/altbind altbind + chmod 0444 altbind + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +stdlib: ../lib/README + rm -f stdlib + cp ../lib/README stdlib + chmod 0444 stdlib + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +changes: ../CHANGES + rm -f changes + cp ../CHANGES changes + chmod 0444 changes + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +libcalc: ../LIBRARY + rm -f libcalc + ${SED} -e 's:$${LIBDIR}:${LIBDIR}:g' < ../LIBRARY > libcalc + chmod 0444 libcalc + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +bugs: ../BUGS + rm -f bugs + cp ../BUGS bugs + chmod 0444 bugs + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +errorcodes: ../calcerr.h errorcodes.hdr errorcodes.sed + rm -f errorcodes + ${CAT} errorcodes.hdr > errorcodes + ${SED} -n -f errorcodes.sed < ../calcerr.h >> errorcodes + chmod 0444 errorcodes + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +full: ${STD_HELP_FILES} ${BUILT_HELP_FILES} ${MAKE_FILE} + ${Q}echo "forming full" + -${Q}rm -f full + -${Q}for i in ${STD_HELP_FILES1} obj.file ${STD_HELP_FILES2} \ + ${BUILT_HELP_FILES} ${STD_HELP_FILES3}; do \ + if [ Xintro != X"$$i" ]; then \ + echo " "; \ + else \ + true; \ + fi; \ + if [ Xobj.file = X"$$i" ]; then \ + j=obj; \ + else \ + j=$$i; \ + fi; \ + echo "*************"; \ + echo "* $$j"; \ + echo "*************"; \ + echo ""; \ + cat $$i; \ + done > full + ${Q}echo "full formed" + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +# Singular files are the same files as their plural form. +# +${SINGULAR_FILES}: ${PLURAL_FILES} + ${Q}for i in ${SINGULAR_FILES}; do \ + echo "rm -f $${i}"; \ + rm -f $${i}; \ + echo "cp $${i}s $${i}"; \ + cp $${i}s $${i}; \ + done + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/SINGULAR_FILES =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +# Form the builtin file +# +# We ave a "chicken-and-egg" problem. We want the builtn help file to +# accurately reflect the function list. It would be nice if we could +# just execute calc show builtin, but calc may not have been built or +# buildable at this point. The hack-a-round used is to convert ../func.c +# into a standalone program that generates a suitable function list +# that is standwiched between the top and bottom builtin help text. +# +# We form funclist.c by sedding out unwanted stuff from builtins table, +# converting NUMBER* and VALUE into harmless types and converting +# the showbuiltins() function into main(). Combined with the -DFUNCLIST +# we will avoid all of the complex calc types, macros and defines and +# be left with just main() and a mininal builtins table. +# +# Building funclist.o a portable fashion is ugly because some systems +# do not treat -I.. correctly! +# +builtin: builtin.top builtin.end ../func.c funclist.sed + ${Q}echo "forming builtin help file" + -${Q}rm -f builtin + ${Q}cat builtin.top > builtin + -${Q}rm -f funclist.c + ${Q}${SED} -n -f funclist.sed ../func.c > funclist.c + + -${Q}rm -f ../funclist.c ../funclist.o ../funclist funclist + ${Q}cp funclist.c .. + -${Q}(cd ..; \ + ${NATIVE_CC} ${NATIVE_CFLAGS} -DFUNCLIST funclist.c -o funclist; \ + mv funclist help; \ + rm -f funclist.c funclist.o funclist) + ${Q}./funclist | \ + ${SED} -e 's/^/ /' -e 's/[ ][ ]*$$//' >> builtin + ${Q}cat builtin.end >> builtin + ${Q}echo "builtin help file formed" + -@if [ -z "${Q}" ]; then \ + echo ''; \ + echo '=-=-= skipping the cat of help/$@ =-=-='; \ + echo ''; \ + else \ + true; \ + fi + +## +# +# File list generation. You can ignore this section. +# +# +# We will form the names of source files as if they were in a +# sub-directory called calc/help. +# +## + +distlist: ${DISTLIST} + ${Q}for i in ${DISTLIST}; do \ + echo calc/help/$$i; \ + done | ${SORT} + +# The bsdi distribution has generated files as well as distributed files. +# +bsdilist: ${DISTLIST} ${BUILT_HELP_FILES} + ${Q}for i in ${DISTLIST} ${BUILT_HELP_FILES}; do \ + echo calc/help/$$i; \ + done | ${SORT} + +# The BSDI cdrom makefile expects all help files to be pre-built. This rule +# creats these fils so that the release can be shipped off to BSDI. You can +# ignore this rule. +# +bsdi: all + rm -f obj + cp obj.file obj + +# These next rule help me form the ${DETAIL_HELP} makefile variables above. +# +detaillist: + ${Q}-(echo "xxxxx"; \ + for i in ${DETAIL_HELP}; do \ + if [ ! -f SCCS/s.$$i ]; then \ + echo "WARNING: $$i not under SCCS control" 1>&2; \ + else \ + echo $$i; \ + fi; \ + done | ${SORT}) | ${FMT} -70 | \ + ${SED} -e '1s/xxxxx/DETAIL_HELP=/' -e '2,$$s/^/ /' \ + -e 's/$$/ \\/' -e '$$s/ \\$$//' + +clean: + rm -f obj mkbuiltin funclist.c funclist.o funclist + +clobber: + rm -f ${BUILT_HELP_FILES} full builtin .all + rm -f obj mkbuiltin funclist.c funclist.o funclist ${SINGULAR_FILES} + +install: all + -${Q}if [ ! -d ${TOPDIR} ]; then \ + echo mkdir ${TOPDIR}; \ + mkdir ${TOPDIR}; \ + else \ + true; \ + fi + -${Q}if [ ! -d ${LIBDIR} ]; then \ + echo mkdir ${LIBDIR}; \ + mkdir ${LIBDIR}; \ + else \ + true; \ + fi + -${Q}if [ ! -d ${HELPDIR} ]; then \ + echo mkdir ${HELPDIR}; \ + mkdir ${HELPDIR}; \ + else \ + true; \ + fi + ${Q}for i in ${STD_HELP_FILES} ${BUILT_HELP_FILES} builtin \ + full ${DETAIL_HELP} ${SINGULAR_FILES} ${SYMBOL_HELP}; 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/help/abs b/help/abs new file mode 100644 index 0000000..9ecf198 --- /dev/null +++ b/help/abs @@ -0,0 +1,41 @@ +NAME + abs - absolute value + +SYNOPSIS + abs(x [,eps]) + +TYPES + If x is an object of type xx, the function xx_abs has to have + been defined; this will determine the types for x, eps and + the returned value. + + For non-object x and eps: + + x number (real or complex) + eps ignored if x is real, nonzero real for complex x, + defaults to epsilon(). + + return real + +DESCRIPTION + If x is real, returns x if x is positive or zero, -x if x is negative. + + For complex x, returns the multiple of eps nearest or next to nearest + to the absolute value of x. The result usually has error less in + absolute value than abs(eps), but should not exceed 0.75 * abs(eps). + +EXAMPLE + > print abs(3.4), abs(-3.4) + 3.4 3.4 + + > print abs(3+4i, 1e-5), abs(4+5i, 1e-5), abs(4+5i, 1e-10) + 5 6.40312 6.4031242374 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + cmp, epsilon, hypot, norm, near, obj diff --git a/help/access b/help/access new file mode 100644 index 0000000..27fa9d5 --- /dev/null +++ b/help/access @@ -0,0 +1,46 @@ +NAME + access - determine existence or accessibility of named file + +SYNOPSIS + access(name [, mode]) + +TYPES + name string + mode integer or string containing only 'r', 'w', 'x' characters + + return null value or error + +DESCRIPTION + access(name) or access(name, 0) or access(name, "") returns the null + value if a file with this name exists. + + If non-null mode is specified, the null value is returned if there + is a file with the specified name and accessibility indicated by the + bits or characters of the mode argument: 'r' or bit 2 for reading, + 'w' or bit 1 for writing, 'x' or bit 0 for execution. + +EXAMPLE + > !rm -f junk + > access("junk") + Error 10002 XXX This number will probably be changed + > f = fopen("junk", "w") + > access("junk") + > fputs(f, "Now is the time"); + > freopen(f, "r"); + > !chmod u-w junk + > fgets(f) + "Now is the time" + > access("junk", "w") + Error 10013 XXX + > freopen(f, "w") + Error 10013 XXX + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/acos b/help/acos new file mode 100644 index 0000000..881061e --- /dev/null +++ b/help/acos @@ -0,0 +1,32 @@ +NAME + acos - inverse trigonometric cosine + +SYNOPSIS + acos(x [,eps]) + +TYPES + x real, -1 <= x <= 1 + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the acos of x to a multiple of eps with error less in + absolute value than .75 * eps. + + v = acos(x) is the number in [0, pi] for which cos(v) = x. + +EXAMPLE + > print acos(.5, 1e-5), acos(.5, 1e-10), acos(.5, 1e-15), acos(.5, 1e-20) + 1.0472 1.0471975512 1.047197551196598 1.04719755119659774615 + +LIMITS + unlike sin and cos, x must be real + abs(x) <= 1 + eps > 0 + +LIBRARY + NUMBER *qacos(NUMBER *x, NUMBER *eps) + +SEE ALSO + asin, atan, asec, acsc, acot, epsilon diff --git a/help/acosh b/help/acosh new file mode 100644 index 0000000..10c86c2 --- /dev/null +++ b/help/acosh @@ -0,0 +1,32 @@ +NAME + acosh - inverse hyperbolic cosine + +SYNOPSIS + acosh(x [,eps]) + +TYPES + x real, x >= 1 + eps nonzero real, defaults to epsilon() + + return nonnegative real + +DESCRIPTION + Returns the cosh of x to a multiple of eps with error less in + absolute value than .75 * eps. + + acosh(x) = ln(x + sqrt(x^2 - 1)) is the nonnegative real number v + for which cosh(v) = x. + +EXAMPLE + > print acosh(2, 1e-5), acosh(2, 1e-10), acosh(2, 1e-15), acosh(2, 1e-20) + 1.31696 1.3169578969 1.316957896924817 1.31695789692481670862 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qacosh(NUMBER *x, NUMBER *eps) + +SEE ALSO + asinh, atanh, asech, acsch, acoth, epsilon diff --git a/help/acot b/help/acot new file mode 100644 index 0000000..a573636 --- /dev/null +++ b/help/acot @@ -0,0 +1,31 @@ +NAME + acot - inverse trigonometric cotangent + +SYNOPSIS + acot(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the acot of x to a multiple of eps with error less in + absolute value than .75 * eps. + + v = acot(x) is the number in (0, pi) for which cot(v) = x. + +EXAMPLE + > print acot(2, 1e-5), acot(2, 1e-10), acot(2, 1e-15), acot(2, 1e-20) + .46365 .463647609 .463647609000806 .46364760900080611621 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qacot(NUMBER *x, NUMBER *eps) + +SEE ALSO + asin, acos, atan, asec, acsc, epsilon diff --git a/help/acoth b/help/acoth new file mode 100644 index 0000000..2fe77f1 --- /dev/null +++ b/help/acoth @@ -0,0 +1,33 @@ +NAME + acoth - inverse hyperbolic cotangent + +SYNOPSIS + acoth(x [,eps]) + +TYPES + x real, with abs(x) > 1 + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the acoth of x to a multiple of eps with error less in + absolute value than .75 * eps. + + acoth(x) = ln((x + 1)/(x - 1))/2 is the real number v for which + coth(v) = x. + +EXAMPLE + > print acoth(2, 1e-5), acoth(2, 1e-10), acoth(2, 1e-15), acoth(2, 1e-20) + .54931 .5493061443 .549306144334055 .5493061443340548457 + +LIMITS + unlike sin and cos, x must be real + abs(x) > 1 + eps > 0 + +LIBRARY + NUMBER *qacoth(NUMBER *x, NUMBER *eps) + +SEE ALSO + asinh, acosh, atanh, asech, acsch, epsilon diff --git a/help/acsc b/help/acsc new file mode 100644 index 0000000..7183166 --- /dev/null +++ b/help/acsc @@ -0,0 +1,32 @@ +NAME + acsc - inverse trigonometric cosecant + +SYNOPSIS + acsc(x [,eps]) + +TYPES + x real, with absolute value >= 1 + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the acsc of x to a multiple of eps with error less in + absolute value than .75 * eps. + + v = acsc(x) is the number in [-pi/2, pi/2] for which csc(v) = x. + +EXAMPLE + > print acsc(2, 1e-5), acsc(2, 1e-10), acsc(2, 1e-15), acsc(2, 1e-20) + .5236 .5235987756 .523598775598299 .52359877559829887308 + +LIMITS + unlike sin and cos, x must be real + abs(x) >= 1 + eps > 0 + +LIBRARY + NUMBER *qacsc(NUMBER *x, NUMBER *eps) + +SEE ALSO + asin, acos, atan, asec, acot, epsilon diff --git a/help/acsch b/help/acsch new file mode 100644 index 0000000..f6b127f --- /dev/null +++ b/help/acsch @@ -0,0 +1,33 @@ +NAME + acsch - inverse hyperbolic cosecant + +SYNOPSIS + acsch(x [,eps]) + +TYPES + x nonzero real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the acsch of x to a multiple of eps with error less in + absolute value than .75 * eps. + + acsch(x) = ln((1 + sqrt(1 + x^2))/x) is the real number v for + which csch(v) = x. + +EXAMPLE + > print acsch(2, 1e-5), acsch(2, 1e-10), acsch(2, 1e-15), acsch(2, 1e-20) + .48121 .4812118251 .481211825059603 .4812118250596034475 + +LIMITS + unlike sin and cos, x must be real + x != 0 + eps > 0 + +LIBRARY + NUMBER *qacsch(NUMBER *x, NUMBER *eps) + +SEE ALSO + asinh, acosh, atanh, asech, acoth, epsilon diff --git a/help/append b/help/append new file mode 100644 index 0000000..23b6827 --- /dev/null +++ b/help/append @@ -0,0 +1,60 @@ +NAME + append - append one or more values to end of list + +SYNOPSIS + append(x, y_0, y_1, ...) + +TYPES + x lvalue whose value is a list + y_0, ... any + + return null value + +DESCRIPTION + If after evaluation of y_0, y_1, ..., x is a list with contents + (x_0, x_1, ...), then after append(x, y_0, y_1, ...), x has + contents (x_0, x_1, ..., y_0, y_1, ...). + + If after evaluation of y_0, y_1, ..., x has size n, + append(x, y_0, y_1, ...) is equivalent to insert(x, n, y_0, y_1, ...). + +EXAMPLE + > x = list(2,3,4) + > append(x, 5, 6) + > print x + + list (5 elements, 5 nonzero): + [[0]] = 2 + [[1]] = 3 + [[2]] = 4 + [[3]] = 5 + [[4]] = 6 + + > append(x, pop(x), pop(x)) + > print x + + list (5 elements, 5 nonzero): + [[0]] = 4 + [[1]] = 5 + [[2]] = 6 + [[3]] = 2 + [[4]] = 3 + + > append(x, (remove(x), 7)) + > print x + + list (5 elements, 5 nonzero): + [[0]] = 4 + [[1]] = 5 + [[2]] = 6 + [[3]] = 2 + [[4]] = 7 + +LIMITS + append() can have at most 100 arguments + +LIBRARY + none + +SEE ALSO + delete, insert, islist, list, pop, push, remove, rsearch, search, size diff --git a/help/appr b/help/appr new file mode 100644 index 0000000..0475277 --- /dev/null +++ b/help/appr @@ -0,0 +1,146 @@ +NAME + appr - approximate numbers by multiples of a specified number + +SYNOPSIS + appr(x [,y [,z]]) + +TYPES + x real, complex, matrix, list + y real + z integer + + return same type as x except that complex x may return a real number + +DESCRIPTION + Return the approximate value of x as specified by a specific error + (epsilon) and config ("appr") value. + + The default value for y is epsilon(). The default value for z is + the current value of the "appr" configuration parameter. + + If y is zero or x is a multiple of y, appr(x,y,z) returns x. I.e., + there is no "approximation" - the result represents x exactly. + + In the following it is assumed y is nonzero and x is not a multiple of y. + For Real x: + + appr(x,y,z) is either the nearest multiple of y greater + than x or the nearest multiple of y less than x. Thus, if + we write a = appr(x,y,z) and r = x - a, then a/y is an integer + and abs(r) < abs(y). If r > 0, we say x has been "rounded down" + to a; if r < 0, the rounding is "up". For particular x and y, + whether the rounding is down or up is determined by z. + + Only the 5 lowest bits of z are used, so we may assume z has been + replaced by its value modulo 32. The type of rounding depends on + z as follows: + + z = 0 round down or up according as y is positive or negative, + sgn(r) = sgn(y) + + z = 1 round up or down according as y is positive or negative, + sgn(r) = -sgn(y) + + z = 2 round towards zero, sgn(r) = sgn(x) + + z = 3 round away from zero, sgn(r) = -sgn(x) + + z = 4 round down + + z = 5 round up + + z = 6 round towards or from zero according as y is positive or + negative, sgn(r) = sgn(x/y) + + z = 7 round from or towards zero according as y is positive or + negative, sgn(r) = -sgn(x/y) + + z = 8 a/y is even + + z = 9 a/y is odd + + z = 10 a/y is even or odd according as x/y is positive or negative + + z = 11 a/y is odd or even according as x/y is positive or negative + + z = 12 a/y is even or odd according as y is positive or negative + + z = 13 a/y is odd or even according as y is positive or negative + + z = 14 a/y is even or odd according as x is positive or negative + + z = 15 a/y is odd or even according as x is positive or negative + + z = 16 to 31 abs(r) <= abs(y)/2; if there is a unique multiple + of y that is nearest x, appr(x,y,z) is that multiple of y + and then abs(r) < abs(y)/2. If x is midway between + successive multiples of y, then abs(r) = abs(y)/2 and + the value of a is as given by appr(x, y, z-16). + + Matrix or List x: + + appr(x,y,z) returns the matrix or list indexed in the same way as x, + in which each element t has been replaced by appr(t,y,z). + + XXX - complex x needs to be documented + +PROPERTIES + If appr(x,y,z) != x, then abs(x - appr(x,y,z)) < abs(y). + + If appr(x,y,z) != x and 16 <= z <= 31, abs(x - appr(x,y,z)) <= abs(y)/2. + + For z = 0, 1, 4, 5, 16, 17, 20 or 21, and any integer n, + appr(x + n*y, y, z) = appr(x, y, z) + n * y. + + If y is nonzero, appr(x,y,8)/y = an odd integer n only if x = n * y. + +EXAMPLES + > print appr(-5.44,0.1,0), appr(5.44,0.1,0), appr(5.7,1,0), appr(-5.7,1,0) + -5.5 5.4 5 -6 + + > print appr(-5.44,-.1,0), appr(5.44,-.1,0), appr(5.7,-1,0), appr(-5.7,-1,0) + -5.4 5.5 6 -5 + + > print appr(-5.44,0.1,3), appr(5.44,0.1,3), appr(5.7,1,3), appr(-5.7,1,3) + -5.5 5.5 6 -6 + + > print appr(-5.44,0.1,4), appr(5.44,0.1,4), appr(5.7,1,4), appr(-5.7,1,4) + -5.5 5.4 5 -6 + + > print appr(-5.44,0.1,6), appr(5.44,0.1,6), appr(5.7,1,6), appr(-5.7,1,6) + -5.4 5.4 6 -5 + + > print appr(-5.44,-.1,6), appr(5.44,-.1,6), appr(5.7,-1,6), appr(-5.7,-1,6) + -5.5 5.5 6 -6 + + > print appr(-5.44,0.1,9), appr(5.44,0.1,9), appr(5.7,1,9), appr(-5.7,1,9) + -5.5 5.5 5 -5 + + > print appr(-.44,0.1,11), appr(.44,0.1,11), appr(5.7,1,11), appr(-5.7,1,11) + -.4 .5 5 -6 + + > print appr(-.44,-.1,11),appr(.44,-.1,11),appr(5.7,-1,11),appr(-5.7,-1,11) + -.5 .4 6 -5 + + > print appr(-.44,0.1,12), appr(.44,0.1,12), appr(5.7,1,12), appr(-5.7,1,12) + -.4 .5 5 -6 + + > print appr(-.44,-.1,12),appr(.44,-.1,12),appr(5.7,-1,12),appr(-5.7,-1,12) + -.5 .4 6 -5 + + > print appr(-.44,0.1,15), appr(.44,0.1,15), appr(5.7,1,15), appr(-5.7,1,15) + -.4 .5 5 -6 + + > print appr(-.44,-.1,15),appr(.44,-.1,15),appr(5.7,-1,15),appr(-5.7,-1,15) + -.4 .5 5 -6 + +LIMITS + none + +LIBRARY + NUMBER *qmappr(NUMBER *q, NUMBER *e, long R); + LIST *listappr(LIST *oldlp, VALUE *v2, VALUE *v3); + MATRIX *matappr(MATRIX *m, VALUE *v2, VALUE *v3); + +SEE ALSO + round, bround, cfappr, cfsim diff --git a/help/archive b/help/archive new file mode 100644 index 0000000..2547034 --- /dev/null +++ b/help/archive @@ -0,0 +1,25 @@ +Where to get the the latest versions of calc + + Landon Noll maintains the official calc ftp archive at: + + ftp://ftp.uu.net/pub/calc + + Alpha test versions, complete with bugs, untested code and + experimental features may be fetched (if you are brave) under: + + http://reality.sgi.com/chongo/calc/ + + One may join the calc testing group by sending a request to: + + calc-tester-request@postofc.corp.sgi.com + + Your message body (not the subject) should consist of: + + subscribe calc-tester address + end + name your_full_name + + where "address" is your EMail address and "your_full_name" + is your full name. + + Landon Curt Noll /\oo/\ diff --git a/help/arg b/help/arg new file mode 100644 index 0000000..f41f7dc --- /dev/null +++ b/help/arg @@ -0,0 +1,33 @@ +NAME + arg - argument (the angle or phase) of a complex number + +SYNOPSIS + arg(x [,eps]) + +TYPES + x number + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the argument of x to the nearest or next to nearest multiple of + eps; the error will be less in absolute value than 0.75 * abs(eps), + but usually less than 0.5 * abs(eps). By default, acc is epsilon(). + +EXAMPLE + > print arg(2), arg(2+3i, 1e-5), arg(2+3i, 1e-10), arg(2+3i, 1e-20) + 0 .98279 .9827937232 .98279372324732906799 + + > pi = pi(1e-10); deg = pi/180; eps = deg/10000 + > print arg(2+3i, eps)/deg, arg(-1 +1i, eps)/deg, arg(-1 - 1i,eps)/deg + 56.3099 135 -135 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + conj, im, polar, re diff --git a/help/asec b/help/asec new file mode 100644 index 0000000..ee17874 --- /dev/null +++ b/help/asec @@ -0,0 +1,32 @@ +NAME + asec - inverse trigonometric secant + +SYNOPSIS + asec(x [,eps]) + +TYPES + x real, with absolute value >= 1 + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the asec of x to a multiple of eps with error less in + absolute value than .75 * eps. + + v = asec(x) is the number in [0, pi] for which sec(v) = x. + +EXAMPLE + > print asec(2, 1e-5), asec(2, 1e-10), asec(2, 1e-15), asec(2, 1e-20) + 1.0472 1.0471975512 1.047197551196598 1.04719755119659774615 + +LIMITS + unlike sin and cos, x must be real + abs(x) >= 1 + eps > 0 + +LIBRARY + NUMBER *qasec(NUMBER *x, NUMBER *eps) + +SEE ALSO + asin, acos, atan, acsc, acot, epsilon diff --git a/help/asech b/help/asech new file mode 100644 index 0000000..e2c390a --- /dev/null +++ b/help/asech @@ -0,0 +1,33 @@ +NAME + asech - inverse hyperbolic secant + +SYNOPSIS + asech(x [,eps]) + +TYPES + x real, 0 < x <= 1 + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the asech of x to a multiple of eps with error less in + absolute value than .75 * eps. + + asech(x) = ln((1 + sqrt(1 - x^2))/x) is the real number v for which + sech(v) = x. + +EXAMPLE + > print asech(.5,1e-5), asech(.5,1e-10), asech(.5,1e-15), asech(.5,1e-20) + 1.31696 1.3169578969 1.316957896924817 1.31695789692481670862 + +LIMITS + unlike sin and cos, x must be real + 0 < x <= 1 + eps > 0 + +LIBRARY + NUMBER *qasech(NUMBER *x, NUMBER *eps) + +SEE ALSO + asinh, acosh, atanh, acsch, acoth, epsilon diff --git a/help/asin b/help/asin new file mode 100644 index 0000000..1aa766d --- /dev/null +++ b/help/asin @@ -0,0 +1,32 @@ +NAME + asin - inverse trigonometric sine + +SYNOPSIS + asin(x [,eps]) + +TYPES + x real, -1 <= x <= 1 + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the asin of x to a multiple of eps with error less in + absolute value than .75 * eps. + + v = asin(x) is the number in [-p1/2, pi/2] for which sin(v) = x. + +EXAMPLE + > print asin(.5, 1e-5), asin(.5, 1e-10), asin(.5, 1e-15), asin(.5, 1e-20) + .5236 .5235987756 .523598775598299 .52359877559829887308 + +LIMITS + unlike sin and cos, x must be real + abs(x) <= 1 + eps > 0 + +LIBRARY + NUMBER *qasin(NUMBER *q, NUMBER *epsilon) + +SEE ALSO + acos, atan, asec, acsc, acot, epsilon diff --git a/help/asinh b/help/asinh new file mode 100644 index 0000000..9e38b81 --- /dev/null +++ b/help/asinh @@ -0,0 +1,32 @@ +NAME + asinh - inverse hyperbolic sine + +SYNOPSIS + asinh(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the asinh of x to a multiple of eps with error less in + absolute value than .75 * eps. + + asinh(x) = ln(x + sqrt(1 + x^2)) is the real number v for which + sinh(v) = x. + +EXAMPLE + > print asinh(2, 1e-5), asinh(2, 1e-10), asinh(2, 1e-15), asinh(2, 1e-20) + 1.44363 1.4436354752 1.44363547517881 1.44363547517881034249 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qasinh(NUMBER *x, NUMBER *eps) + +SEE ALSO + acosh, atanh, asech, acsch, acoth, epsilon diff --git a/help/assign b/help/assign new file mode 100644 index 0000000..8c12f10 --- /dev/null +++ b/help/assign @@ -0,0 +1,29 @@ +NAME + = + +SYNOPSIS + a = b + +TYPES + a lvalue + b expression + + return lvalue + +DESCRIPTION + a = b evaluates b, assigns its value to a, and returns a. + +EXAMPLE + > b = 3+1 + > a = b + > print a, b + 4 4 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/assoc b/help/assoc new file mode 100644 index 0000000..4d8ca18 --- /dev/null +++ b/help/assoc @@ -0,0 +1,79 @@ +NAME + assoc - create a new association array + +SYNOPSIS + assoc() + +TYPES + return association + +DESCRIPTION + This functions returns an empty association array. + + 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. + +EXAMPLE + > print assoc() + + assoc (0 elements): + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, rsearch, search, size diff --git a/help/atan b/help/atan new file mode 100644 index 0000000..f35f18c --- /dev/null +++ b/help/atan @@ -0,0 +1,31 @@ +NAME + atan - inverse trigonometric tangent + +SYNOPSIS + atan(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the atan of x to a multiple of eps with error less in + absolute value than .75 * eps. + + v = atan(x) is the number in (-p1/2, pi/2) for which tan(v) = x. + +EXAMPLE + > print atan(2, 1e-5), atan(2, 1e-10), atan(2, 1e-15), atan(2, 1e-20) + 1.10715 1.1071487178 1.107148717794091 1.10714871779409050302 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qatan(NUMBER *x, NUMBER *eps) + +SEE ALSO + asin, acos, asec, acsc, acot, epsilon diff --git a/help/atan2 b/help/atan2 new file mode 100644 index 0000000..c495927 --- /dev/null +++ b/help/atan2 @@ -0,0 +1,36 @@ +NAME + atan2 - angle to point + +SYNOPSIS + atan2(y, x, [,acc]) + +TYPES + y real + x real + acc real + + return real + +DESCRIPTION + Return the angle which is determined by the point (x,y). This + function computes the arctangent of y/x in the range [-pi, pi]. + The value acc specifies the accuracy of the result. By default, acc + is epsilon(). + + Note that by convention, y is the first argument. + + To conform to the 4.3BSD ANSI/IEEE 754-1985 math lib, atan2(0,0) is + defined to return 0. + +EXAMPLE + > print atan2(0,0), atan2(1,sqrt(3)), atan2(17,53,1e-100) + 0 ~.52359877559829887307 ~.31038740713235146535 + +LIMITS + acc > 0 + +LIBRARY + NUMBER *qatan2(NUMBER *y, *x, *acc) + +SEE ALSO + acos, asin, atan, cos, epsilon, sin, tan diff --git a/help/atanh b/help/atanh new file mode 100644 index 0000000..ae26622 --- /dev/null +++ b/help/atanh @@ -0,0 +1,32 @@ +NAME + atanh - inverse hyperbolic tangent + +SYNOPSIS + atanh(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns the atanh of x to a multiple of eps with error less in + absolute value than .75 * eps. + + atanh(x) = ln((1 + x)/(1 - x))/2 is the real number v for whichi + tanh(v) = x. + +EXAMPLE + > print atanh(.5,1e-5), atanh(.5,1e-10), atanh(.5,1e-15), atanh(.5,1e-20) + .54931 .5493061443 .549306144334055 .5493061443340548457 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qatanh(NUMBER *x, NUMBER *eps) + +SEE ALSO + asinh, acosh, asech, acsch, acoth, epsilon diff --git a/help/avg b/help/avg new file mode 100644 index 0000000..9af5c50 --- /dev/null +++ b/help/avg @@ -0,0 +1,50 @@ +NAME + avg - average (arithmetic) mean of values + +SYNOPSIS + avg(x_1, x_2, ...) + +TYPES + x_1, ... arithmetic or list + + return as determined by types of items averaged + +DESCRIPTION + If there are n non-list arguments x_1, x_2, ..., x_n, + for which the required additions and division by n are defined, + avg(x_1, x_2, ..., x_n) returns the value of: + + (x_1 + x_2 + ... + x_n)/n. + + If the x_i are real, the result will be a real number; if the + x_i are real or complex numbers, the result will be a real or complex + number. If the x_i are summable matrices the result will be a matrix + of the same size (e.g. if the x_i are all 3 x 4 matrices with real + entries, the result will be a 3 x 4 matrix with real entries). + + If an argument x_i is list-valued, e.g. list(y_1, y_2, ...), this + is treated as contributing y_1, y_2, ... to the list of items to + be averaged. + +EXAMPLE + > print avg(1,2,3,4,5), avg(list(1,2,3,4,5)), avg(1,2,list(3,4,5)) + 3 3 3 + + > mat x[2,2] = {1,2,3,4} + > mat y[2,2] = {1,2,4,8} + > avg(x,y) + + mat [2,2] (4 elements, 4 nonzero): + [0,0] = 1 + [0,1] = 2 + [1,0] = 3.5 + [1,1] = 6 + +LIMITS + The number of arguments is not to exceed 100. + +LIBRARY + none + +SEE ALSO + hmean diff --git a/help/base b/help/base new file mode 100644 index 0000000..f6dbbf8 --- /dev/null +++ b/help/base @@ -0,0 +1,55 @@ +NAME + base - set default output base + +SYNOPSIS + base([mode]) + +TYPES + mode real + + return real + +DESCRIPTION + 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". + +EXAMPLE + > base() + 10 + + > base(8) + 012 + + > print 10 + 012 + +LIMITS + none + +LIBRARY + int math_setmode(int newmode) + + NOTE: newmode must be one of MODE_DEFAULT, MODE_FRAC, MODE_INT, + MODE_REAL, MODE_EXP, MODE_HEX, MODE_OCTAL, MODE_BINARY + +SEE ALSO + config diff --git a/help/bround b/help/bround new file mode 100644 index 0000000..61ae7aa --- /dev/null +++ b/help/bround @@ -0,0 +1,123 @@ +NAME + bround - round numbers to a specified number of binary digits + +SYNOPSIS + bround(x [,plcs [, rnd]]) + +TYPES + If x is a matrix or a list, bround(x[[i]], ...) is to return + a value for each element x[[i]] of x; the value returned will be + a matrix or list with the same structure as x. + + Otherwise, if x is an object of type tt, or if x is not an object or + number but y is an object of type tt, and the function tt_bround has + to be defined; the types for x, plcs, rnd, and the returned value, + if any, are as required for specified in tt_bround. For the object + case, plcs and rnd default to the null value. + + For other cases: + + x number (real or complex) + plcs integer, defaults to zero + rnd integer, defaults to config("round") + + return number + +DESCRIPTION + For real x, bround(x, plcs, rnd) returns x rounded to either + plcs significant binary digits (if rnd & 32 is nonzero) or to plcs + binary places (if rnd & 32 is zero). In the significant-figure + case the rounding is to plcs - ilog10(x) - 1 binary places. + If the number of binary places is n and eps = 10^-n, the + result is the same as for appr(x, eps, rnd). This will be + exactly x if x is a multiple of eps; otherwise rounding occurs + to one of the nearest multiples of eps on either side of x. Which + of these multiples is returned is determined by z = rnd & 31, i.e. + the five low order bits of rnd, as follows: + + z = 0 or 4: round down, i.e. towards minus infinity + z = 1 or 5: round up, i.e. towards plus infinity + z = 2 or 6: round towards zero + z = 3 or 7: round away from zero + z = 8 or 12: round to the nearest even multiple of eps + z = 9 or 13: round to the nearest odd multiple of eps + z = 10 or 14: round to nearest even or odd multiple of eps + according as x > or < 0 + z = 11 or 15: round to nearest odd or even multiple of eps + according as x > or < 0 + z = 16 to 31: round to the nearest multiple of eps when + this is uniquely determined. Otherwise + rounding is as if z is replaced by z - 16 + + For complex x: + + The real and imaginary parts are rounded as for real x; if the + imaginary part rounds to zero, the result is real. + + For matrix or list x: + + The returned values has element bround(x[[i]], plcs, rnd) in + the same position as x[[i]] in x. + + For object x or plcs: + + When bround(x, plcs, rnd) is called, x is passed by address so may be + changed by assignments; plcs and rnd are copied to temporary + variables, so their values are not changed by the call. + +EXAMPLES + > a = 7/32, b = -7/32 + + > print a, b + .21875 -.21875 + + > print round(a,3,0), round(a,3,1), round(a,3,2), print round(a,3,3) + .218, .219, .218, .219 + + > print round(b,3,0), round(b,3,1), round(b,3,2), print round(b,3,3) + -.219, -.218, -.218, -.219 + + > print round(a,3,16), round(a,3,17), round(a,3,18), print round(a,3,19) + .2188 .2188 .2188 .2188 + + > print round(a,4,16), round(a,4,17), round(a,4,18), print round(a,4,19) + .2187 .2188 .2187 .2188 + + > print round(a,2,8), round(a,3,8), round(a,4,8), round(a,5,8) + .22 .218 .2188 .21875 + + > print round(a,2,24), round(a,3,24), round(a,4,24), round(a,5,24) + .22 .219 .2188 .21875 + + > c = 21875 + > print round(c,-2,0), round(c,-2,1), round(c,-3,0), round(c,-3,16) + 21800 21900 21000 22000 + + > print round(c,2,32), round(c,2,33), round(c,2,56), round(c,4,56) + 21000 22000 22000 21880 + + > A = list(1/8, 2/8, 3/8, 4/8, 5/8, 6/8, 7/8) + > print round(A,2,24) + + list(7 elements, 7 nonzero): + [[0]] = .12 + [[1]] = .25 + [[3]] = .38 + [[4]] = .5 + [[5]] = .62 + [[6]] = .75 + [[7]] = .88 + +LIMITS + For non-object case: + 0 <= abs(plcs) < 2^31 + 0 <= abs(rnd) < 2^31 + +LIBRARY + void broundvalue(VALUE *x, VALUE *plcs, VALUE *rnd, VALUE *result) + MATRIX *matbround(MATRIX *m, VALUE *plcs, VALUE *rnd); + LIST *listbround(LIST *m, VALUE *plcs, VALUE *rnd); + NUMBER *qbround(NUMBER *m, long plcs, long rnd); + +SEE ALSO + round, trunc, btrunc, int, appr diff --git a/help/btrunc b/help/btrunc new file mode 100644 index 0000000..59d746d --- /dev/null +++ b/help/btrunc @@ -0,0 +1,36 @@ +NAME + btrunc - truncate a value to a number of binary places + +SYNOPSIS + btrunc(x [,j]) + +TYPES + x real + j int + + return real + +DESCRIPTION + Truncate x to j binary places. If j is omitted, 0 places is assumed. + Specifying zero places makes the result identical to int(). + + Truncation of a non-integer prodcues values nearer to zero. + +EXAMPLE + > print btrunc(pi()), btrunc(pi(), 10) + 3 3.140625 + + > print btrunc(3.3), btrunc(3.7), btrunc(3.3, 2), btrunc(3.7, 2) + 3 3 3.25 3.5 + + > print btrunc(-3.3), btrunc(-3.7), btrunc(-3.3, 2), btrunc(-3.7, 2) + -3 -3 -3.25 -3.5 + +LIMITS + 0 <= j < 2^31 + +LIBRARY + NUMBER *qbtrunc(NUMBER *x, *j) + +SEE ALSO + bround, int, round, trunc diff --git a/help/builtin.end b/help/builtin.end new file mode 100644 index 0000000..e791056 --- /dev/null +++ b/help/builtin.end @@ -0,0 +1,200 @@ + + 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 builtin is a primality testing function. The + 1st argument is the suspected prime to be tested. The + absolute value of the 2nd argument is an iteration count. + + If ptest is called with only 2 args, the 3rd argument is + assumed to be 0. If ptest is called with only 1 arg, the + 2nd argument is assumed to be 1. Thus, the following + calls are equivalent: + + ptest(a) + ptest(a,1) + ptest(a,1,0) + + Normally ptest performs a some checks to determine if the + value is divisable by some trivial prime. If the 2nd + argument is < 0, then the trivial check is omitted. + + For example, ptest(a,10) performs the same work as: + + ptest(a,-3) (7 tests without trivial check) + ptest(a,-7,3) (3 more tests without the trivial check) + + The ptest 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 first 3 args of nextcand and prevcand functions are the same + arguments as ptest. But unlike ptest, nextcand and prevcand return + the next and previous values for which ptest is true. + + For example, nextcand(2^1000) returns 2^1000+297 because + 2^1000+297 is the smallest value x > 2^1000 for which + ptest(x,1) is true. And for example, prevcand(2^31-1,10,5) + returns 2147483629 (2^31-19) because 2^31-19 is the largest + value y < 2^31-1 for which ptest(y,10,5) is true. + + The nextcand and prevcand functions also have a 5 argument form: + + nextcand(num, count, skip, modval, modulus) + prevcand(num, count, skip, modval, modulus) + + return the smallest (or largest) value ans > num (or < num) that + is also == modval % modulus for which ptest(ans,count,skip) is true. + + The builtins nextprime(x) and prevprime(x) return the + next and previous primes with respect to x respectively. + As of this release, x must be < 2^32. With one argument, they + will return an error if x is out of range. With two arguments, + they will not generate an error but instead will return y. + + The builtin function pix(x) returns the number of primes <= x. + As of this release, x must be < 2^32. With one argument, pix(x) + will return an error if x is out of range. With two arguments, + pix(x,y) will not generate an error but instead will return y. + + The builtin function factor may be used to search for the + smallest factor of a given number. The call factor(x,y) + will attempt to find the smallest factor of x < min(x,y). + As of this release, y must be < 2^32. If y is omitted, y + is assumed to be 2^32-1. + + If x < 0, factor(x,y) will return -1. If no factor < + min(x,y) is found, factor(x,y) will return 1. In all other + cases, factor(x,y) will return the smallest prime factor + of x. Note except for the case when abs(x) == 1, factor(x,y) + will not return x. + + If factor is called with y that is too large, or if x or y + is not an integer, calc will report an error. If a 3rd argument + is given, factor will return that value instead. For example, + factor(1/2,b,c) will return c instead of issuing an error. + + The builtin lfactor(x,y) searches a number of primes instead + of below a limit. As of this release, y must be <= 203280221 + (y <= pix(2^32-1)). In all other cases, lfactor is operates + in the same way as factor. + + If lfactor is called with y that is too large, or if x or y + is not an integer, calc will report an error. If a 3rd argument + is given, lfactor will return that value instead. For example, + lfactor(1/2,b,c) will return c instead of issuing an error. + + The lfactor function is slower than factor. If possible factor + should be used instead of lfactor. + + The builtin isprime(x) will attempt to determine if x is prime. + As of this release, x must be < 2^32. With one argument, isprime(x) + will return an error if x is out of range. With two arguments, + isprime(x,y) will not generate an error but instead will return y. + + 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/help/builtin.top b/help/builtin.top new file mode 100644 index 0000000..6fc4a5e --- /dev/null +++ b/help/builtin.top @@ -0,0 +1,9 @@ +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. + diff --git a/help/ceil b/help/ceil new file mode 100644 index 0000000..8647ed9 --- /dev/null +++ b/help/ceil @@ -0,0 +1,33 @@ +NAME + ceil - ceiling + +SYNOPSIS + ceil(x) + +TYPES + x real, complex, list, matrix + + return real or complex, list, matrix + +DESCRIPTION + For real x, ceil(x) is the least integer not less than x. + + For complex, ceil(x) returns the real or complex number v for + which re(v) = ceil(re(x)), im(v) = ceil(im(x)). + + For list or matrix x, ceil(x) returns the list or matrix of the + same structure as x for which each element t of x has been replaced + by ceil(t). + +EXAMPLE + > print ceil(27), ceil(1.23), ceil(-4.56), ceil(7.8 - 9.1i) + 27 2 -4 8-9i + +LIMITS + none + +LIBRARY + none + +SEE ALSO + floor, int diff --git a/help/cfappr b/help/cfappr new file mode 100644 index 0000000..3f7a645 --- /dev/null +++ b/help/cfappr @@ -0,0 +1,89 @@ +NAME + cfappr - approximate a real number using continued fractions + +SYNOPSIS + cfappr(x [,eps [,rnd]]) or cfappr(x, n [,rnd]) + +TYPES + x real + eps real with abs(eps) < 1, defaults to epsilon() + n real with n >= 1 + rnd integer, defaults to config("cfappr") + + return real + +DESCRIPTION + If x is an integer or eps is zero, either form returns x. + + If abs(eps) < 1, cfappr(x, eps) returns the smallest-denominator + number in one of the three intervals, [x, x + abs(eps)], + [x - abs(eps], x], [x - abs(eps)/2, x + abs(eps)/2]. + + If n >= 1 and den(x) > n, cfappr(x, n) returns the nearest above, + nearest below, or nearest, approximation to x with denominator less + than or equal to n. If den(x) <= n, cfappr(x,n) returns x. + + In either case when the result v is not x, how v relates to x is + determined by bits 0, 1, 2 and 4 of the argument rnd in the same way as + these bits are used in the functions round() and appr(). In the + following y is either eps or n. + + rnd sign of remainder x - v + + 0 sgn(y) + 1 -sgn(y + 2 sgn(x), "rounding to zero" + 3 -sgn(x), "rounding from zero" + 4 +, "rounding down" + 5 -, "rounding up" + 6 sgn(x/y) + 7 -sgn(x/y) + + If bit 4 of rnd is set, the other bits are irrelevant for the eps case; + thus for 16 <= rnd < 24, cfappr(x, eps, rnd) is the smallest-denominator + number differing from x by at most abs(eps)/2. + + If bit 4 of rnd is set and den(x) > 2, the other bits are irrelevant for + the bounded denominator case; in the case of two equally near nearest + approximations with denominator less than n, cfappr(x, n, rnd) + returns the number with smaller denominator. If den(x) = 2, bits + 0, 1 and 2 of rnd are used as described above. + + If -1 < eps < 1, cfappr(x, eps, 0) may be described as the smallest + denominator number in the closed interval with end-points x and x - eps. + It follows that if abs(a - b) < 1, cfappr(a, a - b, 0) gives the smallest + denominator number in the interval with end-points a and b; the same + result is returned by cfappr(b, b - a, 0) or cfappr(a, b - a, 1). + + If abs(eps) < 1 and v = cfappr(x, eps, rnd), then + cfappr(x, sgn(eps) * den(v), rnd) = v. + + If 1 <= n < den(x), u = cfappr(x, n, 0) and v = cfappr(x, n, 1), then + u < x < v, den(u) <= n, den(v) <= n, den(u) + den(v) > n, and + v - u = 1/(den(u) * den(v)). + + If x is not zero, the nearest approximation with numerator not + exceeding n is 1/cfappr(1/x, n, 16). + +EXAMPLE + > c = config("mode", "frac") + > x = 43/30; u = cfappr(x, 10, 0); v = cfappr(x, 10, 1); + > print u, v, x - u, v - x, v - u, cfappr(x, 10, 16) + 10/7 13/9 1/210 1/90 1/63 10/7 + + > pi = pi(1e-10) + > print cfappr(pi, 100, 16), cfappr(pi, .01, 16), cfappr(pi, 1e-6, 16) + 311/99 22/7 355/113 + + > x = 17/12; u = cfappr(x,4,0); v = cfappr(x,4,1); + > print u, v, x - u, v - x, cfappr(x,4,16) + 4/3 3/2 1/12 1/12 3/2 + +LIMITS + none + +LIBRARY + NUMBER *qcfappr(NUMBER *q, NUMBER *epsilon, long R) + +SEE ALSO + appr, cfsim diff --git a/help/cfsim b/help/cfsim new file mode 100644 index 0000000..7e0fc27 --- /dev/null +++ b/help/cfsim @@ -0,0 +1,114 @@ +NAME + cfsim - simplify a value using continued fractions + +SYNOPSIS + cfsim(x [,rnd]) + +TYPES + x real + rnd integer, defaults to config("cfsim") + + return real + +DESCRIPTION + If x is not an integer, cfsim(x, rnd) returns either the nearest + above x, or the nearest below x, number with denominator less than + den(x). If x is an integer, cfsim(x, rnd) returns x + 1, x - 1, or 0. + Which of the possible results is returned is controlled + by bits 0, 1, 3 and 4 of the parameter rnd. + + For 0 <= rnd < 4, the sign of the remainder x - cfsim(x, rnd) is + as follows: + + rnd sign of x - cfsim(x, rnd) + + 0 +, as if rounding down + 1 -. as if rounding up + 2 sgn(x), as if rounding to zero + 3 -sgn(x), as if rounding from zero + + This corresponds to the use of rnd for functions like round(x, n, rnd). + + If bit 3 or 4 of rnd is set, the lower order bits are ignored; bit 3 + is ignored if bit 4 is set. Thusi, for rnd > 3, it sufficient to + consider the two cases rnd = 8 and rnd = 16. + + If den(x) > 2, cfsim(x, 8) returns the value of the penultimate simple + continued-fraction approximant to x, i.e. if: + + x = a_0 + 1/(a_1 + 1/(a_2 + ... + 1/a_n) ...)), + + where a_0 is an integer, a_1, ..., a_n are positive integers, + and a_n >= 2, the value returned is that of the continued fraction + obtained by dropping the last quotient 1/a_n. + + If den(x) > 2, cfsim(x, 16) returns the nearest number to x with + denominator less than den(x). In the continued-fraction representation + of x described above, this is given by replacing a_n by a_n - 1. + + If den(x) = 2, the definition adopted is to round towards zero for the + approximant case (rnd = 8) and from zero for the "nearest" case (rnd = 16). + + For integral x, cfsim(x, 8) returns zero, cfsim(x,16) returns x - sgn(x). + + In summary, for cfsim(x, rnd) when rnd = 8 or 16, the results are: + + rnd integer x half-integer x den(x) > 2 + + 8 0 x - sgn(x)/2 approximant + 16 x - sgn(x) x + sgn(x)/2 nearest + + From either cfsim(x, 0) and cfsim(x, 1), the other is easily + determined: if one of them has value w, the other has value + (num(x) - num(w))/(den(x) - den(w)). From x and w one may find + other optimal rational numbers near x; for example, the smallest- + denominator number between x and w is (num(x) + num(w))/(den(x) + den(w)). + + If x = n/d and cfsim(x, 8) = u/v, then for k * v < d, the k-th member of + the sequence of nearest approximations to x with decreasing denominators + on the other side of x is (n - k * u)/(d - k * v). This is nearer + to or further from x than u/v according as 2 * k * v < or > d. + + Iteration of cfsim(x,8) until an integer is obtained gives a sequence of + "good" approximations to x with decreasing denominators and + correspondingly decreasing accuracy; each denominator is less than half + the preceding denominator. (Unlike the "forward" sequence of + continued-fraction approximants these are not necessarily alternately + greater than and less than x.) + + Some other properties: + + For rnd = 0 or 1 and any x, or rnd = 8 or 16 and x with den(x) > 2: + + cfsim(n + x, rnd) = n + cfsim(x, rnd). + + This equation also holds for the other values of rnd if n + x and x + have the same sign. + + For rnd = 2, 3, 8 or 16, and any x: + + cfsim(-x, rnd) = -cfsim(x, rnd). + + If rnd = 8 or 16, except for integer x or 1/x for rnd = 8, and + zero x for rnd = 16: + + cfsim(1/x, rnd) = 1/cfsim(x, rnd). + +EXAMPLE + > c = config("mode", "frac"); + + > print cfsim(43/30, 0), cfsim(43/30, 1), cfsim(43/30, 8), cfsim(43/30,16) + 10/7 33/23 10/7 33/23 + + > x = pi(1e-20); c = config("mode", "frac"); + > while (!isint(x)) {x = cfsim(x,8); if (den(x) < 1e6) print x,:;} + 1146408/364913 312689/99532 104348/33215 355/113 22/7 3 + +LIMITS + none + +LIBRARY + NUMBER *qcfsim(NUMBER *x, long rnd) + +SEE ALSO + cfappr diff --git a/help/char b/help/char new file mode 100644 index 0000000..0d7e71d --- /dev/null +++ b/help/char @@ -0,0 +1,27 @@ +NAME + char - character corresponding to a value + +SYNOPSIS + char(j) + +TYPES + j integer, 0 <= j < 256 + + return string + +DESCRIPTION + For j > 0, returns a string of length 1 with a character that has + the same value as j. For j = 0, returns the null string "". + +EXAMPLE + > print char(0102), char(0x6f), char(119), char(0145), char(0x6e) + B o w e n + +LIMITS + none + +LIBRARY + none + +SEE ALSO + ord diff --git a/help/cmdbuf b/help/cmdbuf new file mode 100644 index 0000000..2c5a260 --- /dev/null +++ b/help/cmdbuf @@ -0,0 +1,26 @@ +NAME + cmdbuf - print the command buffer + +SYNOPSIS + cmdbuf() + +TYPES + return str + +DESCRIPTION + This function returns the command string that was formed by calc based + on its command line arguments. If calc was invoked without arguments, + this function will return an empty string. + +EXAMPLE + > cmdbuf("") + "" + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/cmp b/help/cmp new file mode 100644 index 0000000..40dcabe --- /dev/null +++ b/help/cmp @@ -0,0 +1,90 @@ +NAME + cmp - compare two values + +SYNOPSIS + cmp(x, y) + +TYPES + If x is an object of type xx or x is not an object and y is an object + of type xx, the funcion xx_cmp has to have been defined; any + further conditions on x and y, and the type of the returned + value depends on the definition of xx_cmp. + + For non-object x and y: + + x number or string + y same as x + + return -1, 0, 1 (real & string) + -1, 0, 1, -1+1i, 1i, 1+1i, -1-1i, -1i or 1-1i (complex) + +DESCRIPTION + Compare two values and return a value based on their relationship. + Comparison by type is indicated below. Where more than one test is + indicated, tests are performed in the order listed. If the test is + inconclusive, the next test is performed. If all tests are + inconclusive, the values are considered equivalent. + + real (returns -1, 0, or 1) + the greater number is greater + + complex (returns -1, 0, 1, -1+1i, 1i, 1+1i, -1-1i, -1i or 1-1i) + sgn(re(x) - re(y)) + sgn(im(x) - im(y)) * 1i + + string (returns -1, 0, or 1) + the string with the greater first different character is greater + the longer string is greater + + object (depends on xx_cmp) + the greater object as defined by xx_cmp is greater + + String comparison is performed via the strcmp() libc function. + + Note that this function is not a substitution for equality. The == + operator always takes epsilon() into account when comparing numeric + values. For example: + + > cmp(1, 1+epsilon()/2) + -1 + > 1 == 1+epsilon()/2 + 0 + + It should be noted epsilon() is used when comparing complex values. + + Properties of cmp(a,b) for real or complex a and b are: + + cmp(a + c, b + c) = cmp(a,b) + + cmp(a, b) == 0 if and only if a == b + + cmp(b, a) = -cmp(a,b) + + if c is real or pure imaginary, cmp(c * a, c * b) = c * cmp(a,b) + + cmp(a,b) == cmp(b,c) if and only if b is "between" a and c + + The numbers between 2 + 3i and 4 + 5i are those with real part between + 2 and 4, imaginary part between 3 and 5; the numbers between 2 + 3i + and 4 + 3i are those with real part between 2 and 4, imaginary part = 3. + +EXAMPLE + > print cmp(3,4), cmp(4,3), cmp(4,4), cmp("a","b"), cmp("abcd","abc") + -1 1 0 -1 1 + + > print cmp(3,4i), cmp(4,4i), cmp(5,4i), cmp(-5,4i), cmp(-4i,5), cmp(-4i,-5) + 1-1i 1-1i 1-1i -1-1i -1-1i 1-1i + + > print cmp(3i,4i), cmp(4i,4i), cmp(5i,4i), cmp(3+4i,5), cmp(3+4i,-5) + -1i 0 1i -1+1i 1+1i + + > print cmp(3+4i,3+4i), cmp(3+4i,3-4i), cmp(3+4i,2+3i), cmp(3+4i,-4-5i) + 0 1i 1+1i 1+1i + +LIMITS + none + +LIBRARY + none + +SEE ALSO + abs, epsilon, sgn diff --git a/help/comb b/help/comb new file mode 100644 index 0000000..c94f17d --- /dev/null +++ b/help/comb @@ -0,0 +1,39 @@ +NAME + comb - combinatorial number + +SYNOPSIS + comb(x, y) + +TYPES + x int + y int + + return int + +DESCRIPTION + Return the combinatorial number C(x,y) which is defined as: + + x! + --------- + y!*(x-y)! + + This function computes the number of combinations in which y things + may be chosen from x items ignoring the order in which they are chosen. + +EXAMPLE + > print comb(7,3), comb(7,4), comb(7,5), comb(3,0), comb(0,0) + 35 35 21 1 1 + + > print comb(2^31+1,2^31-1) + 2305843010287435776 + +LIMITS + x >= y >= 0 + y < 2^24 + x-y < 2^24 + +LIBRARY + void zcomb(NUMBER x, y, *ret) + +SEE ALSO + fact, perm diff --git a/help/command b/help/command new file mode 100644 index 0000000..2ed9655 --- /dev/null +++ b/help/command @@ -0,0 +1,99 @@ +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. + + If the -m mode disallows opening of files for reading, + this command will be disabled. + + 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). + + If the -m mode disallows opening of files for reading, + this command will be disabled. + + 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. + + If the -m mode disallows opening of files for writing, + this command will be disabled. + + QUIT + This leaves the calculator, when given as a top-level + command. + + CD + Change the current directory to the home directory, if $HOME + is set in the environment. + + CD dir + Change the current directory to dir. + + + Also see the help topic: + + statement flow control and declaration statements + usage for -m modes diff --git a/help/config b/help/config new file mode 100644 index 0000000..3c2cda7 --- /dev/null +++ b/help/config @@ -0,0 +1,267 @@ +Configuration parameters + + Configuration parameters affect how the calculator performs certain + operations. Among features that are controlled by these parameters + are the accuracy of some calculations, the displayed format of results, + the choice from possible alternative algorithms, and whether or not + debugging information is displayed. The parameters are + read or set using the "config" built-in function; they remain in effect + until their values are changed by a config or equivalent instruction. + The following parameters can be specified: + + "all" all configuration values listed below + + "trace" turns tracing features on or off + "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 + "quomod" sets rounding mode for quomod + "quo" sets rounding mode for //, default for quo + "mod" sets "rounding" mode for %, default for mod + "sqrt" sets rounding mode for sqrt + "appr" sets rounding mode for appr + "cfappr" sets rounding mode for cfappr + "cfsim" sets rounding mode for cfsim + "round" sets rounding mode for round and bround + "outround" sets rounding mode for printing of numbers + "leadzero" enables/disables printing of 0 as in 0.5 + "fullzero" enables/disables padding zeros as in .5000 + "maxerr" maximum number of scan errors before abort + "prompt" default interactive prompt + "more" default interactive multi-line input prompt + + + The "all" config value allows one to save/restore the configuration + set of values. The return of: + + config("all") + + is a CONFIG type which may be used as the 2rd arg in a later call. + One may save, modify and restore the configuration state as follows: + + oldstate = config("all") + ... + config("tab", 0) + config("mod", 10) + ... + config("all", oldstate) + + This save/restore method is useful within functions. + It allows functions to control their configuration without impacting + the calling function. + + There are two configuration state aliases that may be set. To + set the backward compatible standard configuration: + + config("all", "oldstd") + + The "oldstd" will restore the configuration to the default at startup. + + A new configuration that some people prefer may be set by: + + config("all", "newstd") + + The "newstd" is not backward compatible with the historic + configuration. Even so, some people prefer this configuration + and place the config("all", "newstd") command in their CALCRC + startup files. + + When nonzero, the "trace" parameter activates one or more features + that may be useful for debugging. These features correspond to + powers of 2 which contribute additively to config("trace"): + + 1: opcodes are displayed as functions are evaluated + + 2: disables the inclusion of debug lines in opcodes for functions + whose definitions are introduced with a left-brace. + + 4: the number of links for real and complex numbers are displayed + when the numbers are printed; for real numbers "#" or for + complex numbers "##", followed by the number of links, are + printed immediately after the number. + + 8: the opcodes for a new functions are displayed when the function + is successfully defined. + + The "display" parameter specifies the maximum number of digits after + the decimal point to be printed in real or exponential mode in + normal unformatted printing (print, strprint, fprint) or in + formatted printing (printf, strprintf, fprintf) when precision is not + specified. The initial value is 20. This parameter does not change + the stored value of a number. Where rounding is necessary, the type + of rounding to be used is controlled by "outround". + + The "epsilon" parameter specifies the default accuracy for the + calculation of functions for which exact values are not possible or + not desired. For most functions, the + + remainder = exact value - calculated value + + has absolute value less than epsilon, but, except when the sign of + the remainder is controlled by an appropriate parameter, the + absolute value of the remainder usually does not exceed epsilon/2. + Functions which require an epsilon value accept an + optional argument which overrides this default epsilon value for + that single call. (The value v can be assigned to the "epsilon" + parameter by epsilon(v) as well as by config("epsilon", v), and the + current value obtained by epsilon() as well as by config("epsilon").) + For the transcendental functions and the functions sqrt() and + appr(), the calculated value is always a multiple of epsilon. + + The "mode" parameter is a string specifying the mode for printing of + numbers by the unformatted print functions, and the default + ("%d" specifier) for formatted print functions. The initial mode + is "real". The available modes are: + + "frac" decimal fractions + "int" decimal integer + "real" decimal floating point + "exp" decimal exponential + "hex" hex fractions + "oct" octal fractions + "bin" binary fractions + + + The "maxprint" parameter specifies the maximum number of elements to + be displayed when a matrix or list is printed. The initial value is 16. + + 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. + + Config("tilde") controls whether or not a leading tilde ('~') is + printed to indicate that a number has not been printed exactly + because the number of decimal digits required would exceed the + specified maximum number. The initial "tilde" value is 1. + + Config ("tab") controls the printing of a tab before results + automatically displayed when working interactively. It does not + affect the printing by the functions print, printf, etc. The inital + "tab" value is 1. + + The "quomod", "quo", "mod", "sqrt", "appr", "cfappr", "cfsim", and + "round" control the way in which any necessary rounding occurs. + Rounding occurs when for some reason, a calculated or displayed + value (the "approximation") has to differ from the "true value", + e.g. for quomod and quo, the quotient is to be an integer, for sqrt + and appr, the approximation is to be a multiple of an explicit or + implicit "epsilon", for round and bround (both controlled by + config("round")) the number of decimal places or fractional bits + in the approximation is limited. Zero value for any of these + parameters indicates that the true value is greater than the approximation, + i.e. the rounding is "down", or in the case of mod, that the + residue has the same sign as the divisor. If bit 4 of the + parameter is set, the rounding of to the nearest acceptable candidate + when this is uniquely determined; in the remaining ambiguous cases, + the type of rounding is determined by the lower bits of the parameter + value. If bit 3 is set, the rounding for quo, appr and sqrt, + is to the nearest even integer or the nearest even multiple of epsilon, + and for round to the nearest even "last decimal place". The effects + of the 3 lowest bits of the parameter value are as follows: + + Bit 0: Unconditional reversal (down to up, even to odd, etc.) + Bit 1: Reversal if the exact value is negative + Bit 2: Reversal if the divisor or epsilon is negative + + (Bit 2 is irrelevant for the functions round and bround since the + equivalent epsilon (a power of 1/10 or 1/2) is always positive.) + + For quomod, the quotient is rounded to an integer value as if + evaluating quo with config("quo") == config("quomod"). Similarly, + quomod and mod give the same residues if config("mod") == config("quomod"). + + For the sqrt function, if bit 5 of config("sqrt") is set, the exact + square-root is returned when this is possible; otherwise the + result is rounded to a multiple of epsilon as determined by the + five lower order bits. Bit 6 of config("sqrt") controls whether the + principal or non-principal square-root is returned. + + For the functions cfappr and cfsim, whether the "rounding" is down + or up, etc. is controlled by the appropriate bits of config("cfappr") + and config("cfsim") as for quomod, quo, etc. + + The "outround" parameter determines the type of rounding to be used + by the various kinds of printing to the output: bits 0, 1, 3 and 4 + are used in the same way as for the functions round and bround. + + The "leadzero" parameter controls whether or not a 0 is printed + before the decimal point in non-zero fractions with absolute value + less than 1, e.g. whether 1/2 is printed as 0.5 or .5. The + initial value is 0, corresponding to the printing .5. + + The "fullzero" parameter controls whether or not in decimal floating- + point printing, the digits are padded with zeros to reach the + number of digits specified by config("display") or by a precision + specification in formatted printing. The initial value for this + parameter is 0, so that, for example, if config("display") >= 2, + 5/4 will print in "real" mode as 1.25. + + The maxerr value controls how many scan errors are allowed + before the compiling phase of a computation is aborted. The initial + value of "maxerr" is 20. Setting maxerr to 0 disables this feature. + + The default prompt when in teractive mode is "> ". One may change + this prompt to a more cut-and-paste friendly prompt by: + + config("prompt", "; ") + + On windowing systems that support cut/paste of a line, one may + cut/copy an input line and paste it directly into input. The + leading ';' will be ignored. + + When inside multi-line input, the more prompt is used. One may + change it by: + + config("more", ";; ") + + 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/help/conj b/help/conj new file mode 100644 index 0000000..817752f --- /dev/null +++ b/help/conj @@ -0,0 +1,35 @@ +NAME + conj - complex conjugate + +SYNOPSIS + conj(x) + +TYPES + If x is an object of type xx, conj(x) calls xx_conj(x). + + For non-object x: + + x real, complex, or matrix + + return real, complex, or matrix + +DESCRIPTION + For real x, conj(x) returns x. + + For complex x, conj(x) returns re(x) - im(x) * 1i. + + For matrix x, conj(x) returns a matrix of the same structure as x + in which each element t of x has been replaced by conj(t). + +EXAMPLE + > print conj(3), conj(3 + 4i) + 3 3-4i + +LIMITS + none + +LIBRARY + void conjvalue(VALUE *x, *res) + +SEE ALSO + norm, abs, arg diff --git a/help/cos b/help/cos new file mode 100644 index 0000000..219706f --- /dev/null +++ b/help/cos @@ -0,0 +1,36 @@ +NAME + cos - cosine + +SYNOPSIS + cos(x [,eps]) + +TYPES + x number (real or complex) + eps nonzero real, defaults to epsilon() + + return number + +DESCRIPTION + Calculate the cosine of x to a multiple of eps with error less in + absolute value than .75 * eps. + +EXAMPLE + > print cos(1, 1e-5), cos(1, 1e-10), cos(1, 1e-15), cos(1, 1e-20) + .5403 .5403023059 .54030230586814 .5403023058681397174 + + > print cos(2 +3i, 1e-5), cos(2 + 3i, 1e-10) + -4.18963-9.10923i -4.189625691-9.1092278938i + + > pi = pi(1e-20) + > print cos(pi/3, 1e-10), cos(pi/2, 1e-10), cos(pi, 1e-10) + .5 0 -1 + +LIMITS + eps > 0 + +LIBRARY + NUMBER *qcos(NUMBER *x, NUMBER *eps) + COMPLEX *ccos(COMPLEX *x, NUMBER *eps) + +SEE ALSO + sin, tan, sec, csc, cot, epsilon diff --git a/help/cosh b/help/cosh new file mode 100644 index 0000000..e44b054 --- /dev/null +++ b/help/cosh @@ -0,0 +1,31 @@ +NAME + cosh - hyperbolic cosine + +SYNOPSIS + cosh(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the cosh of x to the nearest or next to nearest multiple of + epsilon, with absolute error less than .75 * abs(eps). + + cosh(x) = (exp(x) + exp(-x))/2 + +EXAMPLE + > print cosh(1, 1e-5), cosh(1, 1e-10), cosh(1, 1e-15), cosh(1, 1e-20) + 1.54308 1.5430806348 1.543080634815244 1.54308063481524377848 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qcosh(NUMBER *x, NUMBER *eps) + +SEE ALSO + sinh, tanh, sech, csch, coth, epsilon diff --git a/help/cot b/help/cot new file mode 100644 index 0000000..6bbc0b7 --- /dev/null +++ b/help/cot @@ -0,0 +1,30 @@ +NAME + cot - trigonometric cotangent + +SYNOPSIS + cot(x [,eps]) + +TYPES + x nonzero real + acc nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the cotangent of x to a multiple of eps, with error less + in absolute value than .75 * eps. + +EXAMPLE + > print cot(1, 1e-5), cot(1, 1e-10), cot(1, 1e-15), cot(1, 1e-20) + .64209 .6420926159 .642092615934331 .64209261593433070301 + +LIMITS + unlike sin and cos, x must be real + x != 0 + eps > 0 + +LIBRARY + NUMBER *qcot(NUMBER *x, *eps) + +SEE ALSO + sin, cos, tan, sec, csc, epsilon diff --git a/help/coth b/help/coth new file mode 100644 index 0000000..2154820 --- /dev/null +++ b/help/coth @@ -0,0 +1,32 @@ +NAME + coth - hyperbolic cotangent + +SYNOPSIS + coth(x [,eps]) + +TYPES + x nonzero real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the coth of x to a multiple of eps with error less in + absolute value than .75 * eps. + + coth(x) = (exp(2*x) + 1)/(exp(2*x) - 1) + +EXAMPLE + > print coth(1, 1e-5), coth(1, 1e-10), coth(1, 1e-15), coth(1, 1e-20) + 1.31304 1.3130352855 1.313035285499331 1.31303528549933130364 + +LIMITS + unlike sin and cos, x must be real + x != 0 + eps > 0 + +LIBRARY + NUMBER *qcoth(NUMBER *x, NUMBER *eps) + +SEE ALSO + sinh, cosh, tanh, sech, csch, epsilon diff --git a/help/count b/help/count new file mode 100644 index 0000000..3e07f3d --- /dev/null +++ b/help/count @@ -0,0 +1,31 @@ +NAME + count - count elements of list or matrix satisfying a stated condition + +SYNOPSIS + count(x, y) + +TYPES + x list or matrix + y string + + return int + +DESCRIPTION + For count(x, y), y is to be the name of a user-defined function; + count(x,y) then returns the number of elements of x for which y + tests as "true". + +EXAMPLE + > define f(a) = (a < 5) + > A = list(1,2,7,6,4,8) + > count(A, "f") + 3 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/cp b/help/cp new file mode 100644 index 0000000..bf2ac37 --- /dev/null +++ b/help/cp @@ -0,0 +1,37 @@ +NAME + cp - cross product of two 3 element vectors + +SYNOPSIS + cp(x, y) + +TYPES + x, y 1-dimensional matrices with 3 elements + + return 1-dimensional matrix with 3 elements + +DESCRIPTION + Calculate the product of two 3 1-dimensional matrices. + If x has elements (x0, x1, x2), and y has elements (y0, y1, y2), + cp(x,y) returns the matrix of type [0:2] with elements: + + {x1 * y2 - x2 * y1, x3 * y1 - x1 * y3, x1 * y2 - x2 * y1} + +EXAMPLE + > mat x[3] = {2,3,4} + > mat y[3] = {3,4,5} + > print cp(x,y) + + mat [3] (3 elements, 3 nonzero): + [0] = -1 + [1] = 2 + [2] = -1 + +LIMITS + x 1-dimensional matrix with 3 elements + y 1-dimensional matrix with 3 elements + +LIBRARY + MATRIX *matcross(MATRIX *x, MATRIX *y) + +SEE ALSO + dp diff --git a/help/credit b/help/credit new file mode 100644 index 0000000..8523ead --- /dev/null +++ b/help/credit @@ -0,0 +1,62 @@ +Credits + + The majority of calc was written by David I. Bell. + + Calc archives and calc-tester mailing list maintained by Landon Curt Noll. + + 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 many improvements in + accuracy and generality for some numeric functions. Much of + this was in terms of actual code which I gratefully accepted. + Ernest also supplied the original text for many of the help files. + + 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 has one of the following copyrights: + + Copyright (c) 19xx David I. Bell + Copyright (c) 19xx David I. Bell and Landon Curt Noll + Copyright (c) 19xx Landon Curt Noll + Copyright (c) 19xx Ernest Bowen and Landon Curt 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@auug.org.au + chongo@toad.com + + Landon Noll maintains the official calc ftp archive at: + + ftp://ftp.uu.net/pub/calc + + Alpha test versions, complete with bugs, untested code and + experimental features may be fetched (if you are brave) under: + + http://reality.sgi.com/chongo/calc/ + + One may join the calc testing group by sending a request to: + + calc-tester-request@postofc.corp.sgi.com + + Your message body (not the subject) should consist of: + + subscribe calc-tester address + end + name your_full_name + + where "address" is your EMail address and "your_full_name" + is your full name. + + Enjoy! diff --git a/help/csc b/help/csc new file mode 100644 index 0000000..c8ce2be --- /dev/null +++ b/help/csc @@ -0,0 +1,29 @@ +NAME + csc - trigonometric cosecant function + +SYNOPSIS + csc(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the cosecant of x to a multiple of eps, with error less + in absolute value than .75 * eps. + +EXAMPLE + > print csc(1, 1e-5), csc(1, 1e-10), csc(1, 1e-15), csc(1, 1e-20) + 1.1884 1.1883951058 1.188395105778121 1.18839510577812121626 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qcsc(NUMBER *x, NUMBER *eps) + +SEE ALSO + sin, cos, tan, sec, cot, epsilon diff --git a/help/csch b/help/csch new file mode 100644 index 0000000..fe79c37 --- /dev/null +++ b/help/csch @@ -0,0 +1,32 @@ +NAME + csch - hyperbolic cosecant + +SYNOPSIS + csch(x [,eps]) + +TYPES + x nonzero real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the csch of x to a multiple of epsilon, with error less in + absolute value than .75 * eps. + + csch(x) = 2/(exp(x) - exp(-x)) + +EXAMPLE + > print csch(1, 1e-5), csch(1, 1e-10), csch(1, 1e-15), csch(1, 1e-20) + .85092 .8509181282 .850918128239322 .85091812823932154513 + +LIMITS + unlike sin and cos, x must be real + x != 0 + eps > 0 + +LIBRARY + NUMBER *qcsch(NUMBER *x, NUMBER *eps) + +SEE ALSO + sinh, cosh, tanh, sech, coth, epsilon diff --git a/help/ctime b/help/ctime new file mode 100644 index 0000000..df3c942 --- /dev/null +++ b/help/ctime @@ -0,0 +1,29 @@ +NAME + ctime - current local time + +SYNOPSIS + ctime() + +TYPES + return string + +DESCRIPTION + The ctime() builtin returns the string formed by the first 24 + characters returned by the C library function, ctime(): + + "Mon Oct 28 00:47:00 1996" + + The 25th ctime() character, '\n' is removed. + +EXAMPLE + > printf("The time is now %s.\n", time()) + The time is now Mon Apr 15 12:41:44 1996. + +LIMITS + none + +LIBRARY + none + +SEE ALSO + runtime, time diff --git a/help/define b/help/define new file mode 100644 index 0000000..b2ccdaf --- /dev/null +++ b/help/define @@ -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/help/delete b/help/delete new file mode 100644 index 0000000..d8648b8 --- /dev/null +++ b/help/delete @@ -0,0 +1,44 @@ +NAME + delete - delete an element from a list at a given position + +SYNOPSIS + delete(lst, idx) + +TYPES + lst list, &list + idx int, &int + + return any + +DESCRIPTION + Delete element at index idx from list lst. + + The index must refer to an element in the list. That is, idx must + be in the range [0, size(lst)-1]. + +EXAMPLE + > lst = list(2,3,4,5) + + list (4 elements, 4 nonzero): + [[0]] = 2 + [[1]] = 3 + [[2]] = 4 + [[3]] = 5 + + > delete(lst, 2) + 4 + > print lst + + list (3 elements, 3 nonzero): + [[0]] = 2 + [[1]] = 3 + [[2]] = 5 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + append, insert, islist, list, pop, push, remove, rsearch, search, size diff --git a/help/den b/help/den new file mode 100644 index 0000000..47aedf1 --- /dev/null +++ b/help/den @@ -0,0 +1,38 @@ +NAME + den - denominator of a real number + +SYNOPSIS + den(x) + +TYPES + x real + + return integer + +DESCRIPTION + For real x, den(x) returns the denominator of x. In calc, + real values are actually rational values. Each calc real + value can be uniquely expressed as: + + n / d + + where: + + n and d are integers + gcd(n,d) == 1 + d > 0 + + If x = n/x, then den(x) == d. + +EXAMPLE + > print den(7), den(-1.25), den(121/33) + 1 4 3 + +LIMITS + none + +LIBRARY + NUMBER *qden(NUMBER *x) + +SEE ALSO + num diff --git a/help/det b/help/det new file mode 100644 index 0000000..9a5e10f --- /dev/null +++ b/help/det @@ -0,0 +1,74 @@ +NAME + det - determinant + +SYNOPSIS + det(m) + +TYPES + m square matrix with elements of suitable type + + return zero or value of type determined by types of elements + +DESCRIPTION + The matrix m has to be square, i.e. of dimension 2 with: + + matmax(m,1) - matmin(m,1) == matmax(m,2) - matmin(m,2). + + If the elements of m are numbers (real or complex), det(m) + returns the value of the determinant of m. + + If some or all of the elements of m are not numbers, the algorithm + used to evaluate det(m) assumes the definitions of *, unary -, binary -, + being zero or nonzero, are consistent with commutative ring structure, + and if the m is larger than 2 x 2, division by nonzero elements is + consistent with integral-domain structure. + + If m is a 2 x 2 matrix with elements a, b, c, d, where a tests as + nonzero, det(m) is evaluated by + + det(m) = (a * d) - (c * b). + + If a tests as zero, det(m) = - ((c * b) - (a * d)) is used. + + If m is 3 * 3 with elements a, b, c, d, e, f, g, h, i, where a and + a * e - d * b test as nonzero, det(m) is evaluated by + + det(m) = ((a * e - d * b) * (a * i - g * c) + - (a * h - g * b) * (a * f - d * c))/a. + +EXAMPLE + > mat A[3,3] = {2, 3, 5, 7, 11, 13, 17, 19, 23} + > c = config("mode", "frac") + > print det(A), det(A^2), det(A^3), det(A^-1) + -78 6084 -474552 -1/78 + + > obj res {r} + > global md + > define res_test(a) = !ismult(a.r, md) + > define res_sub(a,b) {local obj res v = {(a.r - b.r) % md}; return v;} + > define res_mul(a,b) {local obj res v = {(a.r * b.r) % md}; return v;} + > define res_neg(a) {local obj res v = {(-a.r) % md}; return v;} + > define res(x) {local obj res v = {x % md}; return v;} + > md = 0 + > mat A[2,2] = {res(2), res(3), res(5), res(7)} + > md = 5 + > print det(A) + obj res {4} + > md = 6 + > print det(A) + obj res {5} + + Note that if A had been a 3 x 3 or larger matrix, res_div(a,b) for + non-zero b would have had to be defined (assuming at least one + division is necessary); for consistent results when md is composite, + res_div(a,b) should be defined only when b and md are relatively + prime; there is no problem when md is prime. + +LIMITS + none + +LIBRARY + VALUE matdet(MATRIX *m) + +SEE ALSO + matdim, matmax, matmin, inverse diff --git a/help/digit b/help/digit new file mode 100644 index 0000000..49057c3 --- /dev/null +++ b/help/digit @@ -0,0 +1,38 @@ +NAME + digit - digit at specified position in a decimal representation + +SYNOPSIS + digit(x, y) + +TYPES + x real + y integer + + return integer + +DESCRIPTION + By extending the digits on the left, and if necessary, the digits + on the right, by infinite strings of zeros, abs(x) may be considered + to have the decimal representation: + + ... d_2 d_1 d_0.d_-1 d_-2 ... + + digit(x,y) then returns the digit d_y. + +EXAMPLE + > x = 12.34 + > print digit(x,2), digit(x,1), digit(x,0), digit(x,-1), digit(x,-2) + 0 1 2 3 4 + + > x = 10/7 + > print digit(x,1), digit(x,0), digit(x,-1), digit(x,-2), digit(x,-3) + 0 1 4 2 8 + +LIMITS + none + +LIBRARY + long qdigit(NUMBER *x, long y) + +SEE ALSO + bit diff --git a/help/digits b/help/digits new file mode 100644 index 0000000..8656a84 --- /dev/null +++ b/help/digits @@ -0,0 +1,27 @@ +NAME + digits - return number of digits in an integer or integer part + +SYNOPSIS + digits(x) + +TYPES + x real + + return integer + +DESCRIPTION + For real x, digits(x) returns the number of digits in the decimal + representation of int(abs(x)). + +EXAMPLE + > print digits(0), digits(0.0123), digits(3.7), digits(-27), digits(-99.7) + 1 1 1 2 2 + +LIMITS + none + +LIBRARY + long qdigits(NUMBER *x) + +SEE ALSO + places diff --git a/help/dp b/help/dp new file mode 100644 index 0000000..e184875 --- /dev/null +++ b/help/dp @@ -0,0 +1,38 @@ +NAME + dp - dot product of two vectors + +SYNOPSIS + dp(x, y) + +TYPES + x, y 1-dimensional matrices with the same number of elements + + return depends on the nature of the elements of x and y + +DESCRIPTION + Compute the dot product of two 1-dimensional matrices. + + Let: + + x = {x0, x1, ... xn} + y = {y0, y1, ... yn} + + Then dp(x,y) returns the result of the calculation: + + x0*y0 + x1*y1 + ... + xn*yn + +EXAMPLE + > mat x[3] = {2,3,4} + > mat y[3] = {3,4,5} + > print dp(x,y) + 38 + +LIMITS + x and y are 1-dimensional matrices + x and y have the same number of elements + +LIBRARY + VALUE matdot(MATRIX *x, MATRIX *y) + +SEE ALSO + cp diff --git a/help/environment b/help/environment new file mode 100644 index 0000000..d7b1fa2 --- /dev/null +++ b/help/environment @@ -0,0 +1,86 @@ +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. + + The CALCBINDINGS file searches the CALCPATH as well. + + + 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: + + bindings + or: + altbind (bindings where ^D means exit) + + The bindings file is searched along the CALCPATH. Unlike + the READ command, a .cal extension is not added. + + 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/help/epsilon b/help/epsilon new file mode 100644 index 0000000..2063d9c --- /dev/null +++ b/help/epsilon @@ -0,0 +1,34 @@ +NAME + epsilon - set or read the stored epsilon value + +SYNOPSIS + epsilon([eps]) + +TYPES + eps real number greater than 0 and less than 1 + + return real number greater than 0 and less than 1 + +DESCRIPTION + Without args, epsilon() returns the current epsilon value. + + With one arg, epsilon(eps) returns the current epsilon value + and sets the stored epsilon value to eps. + + The stored epsilon value is used as default value for eps in + the functions appr(x, eps, rnd), sqrt(x, eps, rnd), etc. + +EXAMPLE + > oldeps = epsilon(1e-6) + > print epsilon(), sqrt(2), epsilon(1e-4), sqrt(2), epsilon(oldeps) + > .000001 1.414214 .000001 1.4142 .0001 + +LIMITS + 0 < eps < 1 + +LIBRARY + void setepsilon(NUMBER *eps) + NUMBER *_epsilon_ + +SEE ALSO + XXX - fill in diff --git a/help/errno b/help/errno new file mode 100644 index 0000000..95de508 --- /dev/null +++ b/help/errno @@ -0,0 +1,38 @@ +NAME + errno - return a system error message + +SYNOPSIS + errno(errnum) + +TYPES + errnum int + + return string + +DESCRIPTION + If a file builtin function such as fopen() encounters an error, + it will return an errno number. This function will convert this + number into a somewhat more meaningful string. + + Note that errno() may return different strings on different systems. + +EXAMPLE + > badfile = fopen("not_a_file", "r") + > if (!isfile(badfile)) print "error #" : badfile : ":", errno(badfile); + error #2: No such file or directory + + > print errno(13) + Permission denied + + > errno(31) + "Too many links" + +LIMITS + none + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, files, fopen, + fprintf, isfile, printf, prompt diff --git a/help/error b/help/error new file mode 100644 index 0000000..912745a --- /dev/null +++ b/help/error @@ -0,0 +1,28 @@ +NAME + error - generate a value of an error type + +SYNOPSIS + error(n) + +TYPES + n integer less than 32768 + + return null value or error value + +DESCRIPTION + If n is zero or negative, error(n) returns the null value. + For positive n, error(n) returns a value of error type n. + +EXAMPLE + > a = error(10009) + a + Error 10009 + +LIMITS + 0 <= n < 32768 + +LIBRARY + none + +SEE ALSO + errorcodes, iserror diff --git a/help/errorcodes.hdr b/help/errorcodes.hdr new file mode 100644 index 0000000..83f2db0 --- /dev/null +++ b/help/errorcodes.hdr @@ -0,0 +1,2 @@ +Calc generated error codes (see the error help file): + diff --git a/help/errorcodes.sed b/help/errorcodes.sed new file mode 100644 index 0000000..5a6dabd --- /dev/null +++ b/help/errorcodes.sed @@ -0,0 +1 @@ +/^#define E_[^_].*[ ][1-9][0-9]*[ ]\/\* .* \*\//s/#define E_.*[ ]\([1-9][0-9]*\)[ ]*\/\* \(.*\)[ ][ ]*\*\// \1 \2/p diff --git a/help/eval b/help/eval new file mode 100644 index 0000000..5c7df80 --- /dev/null +++ b/help/eval @@ -0,0 +1,61 @@ +NAME + eval - evaluate a string + +SYNOPSIS + eval(str) + +TYPES + str string + + return any + +DESCRIPTION + For eval(str), the value of str is to be a string that could be the body + of the definition of a function f(). This string may declare local + variables and include keywords (while, for, ...) other than the + reserved keywords (define, show, help, read, write, show, cd) intended + for interactive use or for reading from a file. + + If str is the empty string "", eval(str) returns the null value. + + The call to eval(str) may return a value by explicit use of a return + statement: "return;" returns the null value, "return expr;" returns the + value of expr. If execution reaches the end of str and the + value on the execution stack is not null, eval(str) returns that value; + otherwise eval(str) returns the most recently saved value. + + Each time eval(str) is called, a temporary function is compiled from + the commands in str, and if there are no syntax errors, this function + is then evaluated. If str contains syntax errors, eval(str) displays + the scanerror messages and returns the value error(49). + +EXAMPLE + > str1 = "2 + 3"; print eval(str1); + 5 + + > i = 10; str2 = "local i = 0; 7; while (i++ < 5) print i^2,:;" + > print i, eval(str2), i + 10 1 4 9 16 25 7 10 + + (The print statements in str2 return the null value, so execution of + eval(str2) ends by returning the saved value 7. The global variable + i is unchanged.) + + > eval("2 + "); + Missing expression + 49 + +LIMITS + The string str in eval(str) should not include a call to itself as in + + str = "2 + eval(str)" + + For this str, eval(str) causes an "Evaluation stack depth exceeded" error. + Similarly, if str1 = "2 + eval(str2)", str2 should not include a call + to eval(str1), etc. + +LIBRARY + none + +SEE ALSO + XXX = fill in diff --git a/help/exp b/help/exp new file mode 100644 index 0000000..5931f2b --- /dev/null +++ b/help/exp @@ -0,0 +1,41 @@ +NAME + exp - exponential function + +SYNOPSIS + exp(x [,eps]) + +TYPES + x real or complex + eps nonzero real, defaults to epsilon() + + return real or complex + +DESCRIPTION + Approximate the exponential function of x by a multiple of epsilon, + the error having absolute value less than 0.75 * eps. + If n is a positive integer, exp(x, 10^-n) will usually be + correct to the n-th decimal place, which, for large positive x + will give many significant figures. + +EXAMPLE + > print exp(2, 1e-5), exp(2,1e-10), exp(2, 1e-15), exp(2, 1e-20) + 7.38906 7.3890560989 7.38905609893065 7.38905609893065022723 + + > print exp(30, 1e5), exp(30, 1), exp(30, 1e-10) + 10686474600000 10686474581524 10686474581524.4621469905 + + > print exp(-20, 1e-5), exp(-20, 1e-10), exp(-20, 1e-15), exp(-20, 1e-20) + 0 .0000000021 .000000002061154 .00000000206115362244 + + > print exp(1+2i, 1e-5), exp(1+2i, 1e-10) + -1.1312+2.47173i -1.1312043838+2.471726672i + +LIMITS + x < 100000 + +LIBRARY + NUMBER *qexp(NUMBER *x, NUMBER *eps) + COMPLEX *cexp(COMPLEX *x, NUMBER *eps) + +SEE ALSO + ln, cosh, sinh, tanh diff --git a/help/expression b/help/expression new file mode 100644 index 0000000..52a6d8e --- /dev/null +++ b/help/expression @@ -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/help/fact b/help/fact new file mode 100644 index 0000000..d1dff95 --- /dev/null +++ b/help/fact @@ -0,0 +1,33 @@ +NAME + fact - factorial + +SYNOPSIS + fact(x) + +TYPES + x int + + return int + +DESCRIPTION + Return the factorial of a number. Factorial is defined as: + + x! = 1 * 2 * 3 * ... * x-1 * x + 0! = 1 + +EXAMPLE + > print fact(10), fact(5), fact(2), fact(1), fact(0) + 3628800 120 2 1 1 + + > print fact(40) + 815915283247897734345611269596115894272000000000 + +LIMITS + 2^24 > x >= 0 + y < 2^24 + +LIBRARY + void zfact(NUMBER x, *ret) + +SEE ALSO + comb, perm diff --git a/help/factor b/help/factor new file mode 100644 index 0000000..30aff53 --- /dev/null +++ b/help/factor @@ -0,0 +1,41 @@ +NAME + factor - smallest prime factor not exceeding specified limit + +SYNOPSIS + factor(n [, limit [, err]]) + +TYPES + n integer + limit integer with abs(limit) < 2^32, defaults to 2^32 - 1 + err integer + + return positive integer, -1 or err + +DESCRIPTION + + If n >= 0 and n has a prime factor less than or equal to limit, + factor(n, limit) returns the smallest such factor. If n >= 0 + and the smallest prime factor of n exceeds limit, 1 is returned. + In particular, if n >= 0 and limit <= 1, factor(n, limit) + always returns 1; factor(n,2) returns 2 if and only if n is even. + + If n < 0, -1 is returned. + + If abs(limit) >= 2^32, factor(n, limit) causes an error, + factor(n, limit, err) returns the value of err. + +EXAMPLE + > print factor(35,4), factor(35,5), factor(35), factor(-35) + 1 5 5 -1 + + > print factor(2^32 + 1), factor(2^47 - 1), factor(2^59 - 1) + 641 2351 179951 + +LIMITS + none + +LIBRARY + FLAG zfactor(ZVALUE n, ZVALUE limit, ZVALUE *res) + +SEE ALSO + lfactor diff --git a/help/fclose b/help/fclose new file mode 100644 index 0000000..ebadb08 --- /dev/null +++ b/help/fclose @@ -0,0 +1,52 @@ +NAME + fclose - close a file + +SYNOPSIS + fclose(fd) + +TYPES + fd file + + return nul or int + +DESCRIPTION + This function closes the open file associated with the descriptor fd. + 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. + + Standard input, standard output and standard error are always opened + and cannot be closed. + + The truth value of an closed file is FALSE. + + 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. + + Closing a closed file is permitted. Fclose returns null in + this case. + +EXAMPLE + > fd = fopen("/etc/motd", "r") + > if (fd) print "file is open"; + file is open + + > err = fclose(fd); + > if (isnull(err)) print "close successful"; else errno(err); + close successful + + > if (!fd) print "file is closed"; + file is closed + +LIMITS + fd != files(0) && fd != files(1) && fd != files(2) + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fcnt b/help/fcnt new file mode 100644 index 0000000..4040666 --- /dev/null +++ b/help/fcnt @@ -0,0 +1,31 @@ +NAME + fcnt - count of number of times a specified integer divides an integer + +SYNOPSIS + fcnt(x,y) + +TYPES + x integer + y integer + + return non-negative integer + +DESCRIPTION + If x is nonzero and abs(y) > 1, fcnt(x,y) returns the greatest + non-negative n for which y^n is a divisor of x. In particular, + zero is returned if x is not divisible by y. + + If x is zero or if y = -1, 0 or 1, fcnt(x,y) is defined to be zero. + +EXAMPLE + > print fcnt(7,4), fcnt(24,4), fcnt(48,4) + 0 1 2 + +LIMITS + none + +LIBRARY + long zfacrem(ZVALUE x, ZVALUE y, ZVALUE *rem) + +SEE ALSO + frem, gcdrem diff --git a/help/feof b/help/feof new file mode 100644 index 0000000..37f3b2f --- /dev/null +++ b/help/feof @@ -0,0 +1,44 @@ +NAME + feof - determine if end-of-file flag is set + +SYNOPSIS + feof(fd) + +TYPES + fd file stream open for reading + + return 0 or 1 + +DESCRIPTION + The function feof(fd) returns 1 or 0 according as the end-of-file flag + is set or clear. + + The end-of-file flag for the stream fd is set if reading at the + end-of-file position is attempted. The flag is cleared by + positioning operations (fseek, rewind, fsetpos) and by freopen. + +EXAMPLE + > fd1 = fopen("/tmp/newfile", "w") + > fputs(fd1, "Chongo was here\n") + > fflush(fd1) + > fd2 = fopen("/tmp/newfile", "r") + > feof(fd2) + 0 + > fgetline(fd2) + "Chongo was here" + > feof(fd2) + 0 + > fgetline(fd2) + > feof(fd2) + 1 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt + diff --git a/help/ferror b/help/ferror new file mode 100644 index 0000000..de1b6cb --- /dev/null +++ b/help/ferror @@ -0,0 +1,33 @@ +NAME + ferror - determine if an error has occurred for file + +SYNOPSIS + ferror(fd) + +TYPES + fd file + + return int + +DESCRIPTION + This function determines whether the error condition was detected + while performing some operation on the file associated with fd. + The error need not have been the previous file operation. + + If an error was previously reported 1 will be returned, otherwise + 0 is returned. + +EXAMPLE + > fd = fopen("/etc/motd", "r") + > ferror(fd) + 0 + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fflush b/help/fflush new file mode 100644 index 0000000..985bcc7 --- /dev/null +++ b/help/fflush @@ -0,0 +1,28 @@ +NAME + fflush - flush output to file + +SYNOPSIS + fflush(fd) + +TYPES + fd file + + return nil + +DESCRIPTION + This function forces and buffered output to the file associated with fd. + +EXAMPLE + > fd = fopen("/tmp/file", "w") + > fputc(fd, "@"); + > fflush(fd) + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fgetc b/help/fgetc new file mode 100644 index 0000000..4b45ee1 --- /dev/null +++ b/help/fgetc @@ -0,0 +1,35 @@ +NAME + fgetc - read the next char from a file + +SYNOPSIS + fgetc(fd) + +TYPES + fd file + + return str or nil + +DESCRIPTION + This function reads the next character from the open file + associated with fd. + + If there is a next character, this function returns a 1 + character string containing that character. In the case + of EOF or error, nil is returned. + +EXAMPLE + > fd = fopen("/tmp/newfile", "w") + > fputs(fd, "chongo was here\n") + > fd2 = fopen("/tmp/newfile", "r") + > fgetc(fd2) + "c" + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fgetfield b/help/fgetfield new file mode 100644 index 0000000..d41fb73 --- /dev/null +++ b/help/fgetfield @@ -0,0 +1,52 @@ +NAME + fgetfield - read the next word from a file + +SYNOPSIS + fgetfield(fs) + +TYPES + fs file stream open for reading + + return string, null or error value + +DESCRIPTION + If characters cannot be read from the file, an error value is returned. + + Otherwise starting at the current file position, any whitespace + characters are skipped. If the reading reaches end-of-file, the + null value is returned. If non-whitespace is encountered, formation + of a string begins, continuing until whitespace of '\0' or end-of-file + is reached. The returned value is this string (terminated as usual + by a null character). After the operation, the file position will + be immediately after the first whitespace character of '\0' or at + end-of-file. + +EXAMPLE + + > f = fopen("/tmp/junk", "w") + > fputs(f, " Alpha Beta \n") + > freopen(f, "r") + > fgetfield(f) + "Alpha" + > fgetfield(f) + "Beta" + > fgetfield(f) + > + > freopen(f, "w") + > fputstr(f, " Alpha ", "Beta") + > freopen(f, "r") + > fgetfield(f) + "Alpha" + > fgetfield(f) + "" + > fgetfield(f) + "Beta" + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + fgetstr, fputstr, fgets, fputs, fopen, files, fprintf diff --git a/help/fgetline b/help/fgetline new file mode 100644 index 0000000..99c0163 --- /dev/null +++ b/help/fgetline @@ -0,0 +1,51 @@ +NAME + fgetline - read the next line from a file, newline is tossed + +SYNOPSIS + fgetline(fd) + +TYPES + fd file + + return str or nil + +DESCRIPTION + This function reads the next line, including any trailing newline from + the open file associated with fd. Unlike fgets, the trailing + newline is removed from the return string. + + 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. + + If a line is read, is returned minus the trailing newline, otherwise + (EOF or ERROR) nil is returned. + +EXAMPLE + > fd = fopen("/tmp/newfile", "w") + > fputs(fd, "chongo was here\n") + > fputs(fd, "123\n") + > fd2 = fopen("/tmp/newfile", "r") + > fgets(fd2) + "chongo was here + " + + > fclose(fd2) + > fd2 = fopen("/tmp/newfile", "r") + > fgetline(fd2) + "chongo was here" + > eval(fgetline(fd2)) + 123 + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fgets b/help/fgets new file mode 100644 index 0000000..bacad48 --- /dev/null +++ b/help/fgets @@ -0,0 +1,40 @@ +NAME + fgets - read the next line from a file, newline is kept + +SYNOPSIS + fgets(fd) + +TYPES + fd file + + return str or nil + +DESCRIPTION + This function reads the next line, including any trailing newline from + the open file associated with fd. Unlike fgetline, the trailing + newline is included in the return string. + + If a line is read, is returned, otherwise (EOF or ERROR) nil is returned. + +EXAMPLE + > fd = fopen("/tmp/newfile", "w") + > fputs(fd, "chongo was here\n") + > fd2 = fopen("/tmp/newfile", "r") + > fgets(fd2) + "chongo was here + " + + > fclose(fd2) + > fd2 = fopen("/tmp/newfile", "r") + > fgetline(fd2) + "chongo was here" + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fgetstr b/help/fgetstr new file mode 100644 index 0000000..b64bda3 --- /dev/null +++ b/help/fgetstr @@ -0,0 +1,48 @@ +NAME + fgetstr - read the next null-terminated string from a file + +SYNOPSIS + fgetstr(fs) + +TYPES + fs file stream open for reading + + return string, null or error value + +DESCRIPTION + If the stream is at end of file, the null value is returned. + + If the stream cannot be read, an error value is returned. + + Otherwise the function retrurns the string of characters from the + current file position to the first null character ('\0') (the file + position for further reading then being immediately after the '\0'), + or if no null character is encountered, the string of characters to + the end of file (the string as usual being terminated by '\0'). + + If the stream being read is from stdin (i.e. files(0)), the + characters entered are not displayed and reading ends when a '\0' is + entered (on many terminals this is by ctrl-@). + +EXAMPLE + > f = fopen("/tmp/junk", "w") + > fputstr(f, " Alpha Beta ", "", "Gamma\n\tDelta") + > freopen(f, "r") + > fgetstr(f) + " Alpha Beta " + > fgetstr(f) + "" + > fgetstr(f) + "Gamma + Delta" + > fgetstr(f) + > + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + fputstr, fgetword, fgets, fputs, fopen, files, fprintf diff --git a/help/fib b/help/fib new file mode 100644 index 0000000..8fb25c6 --- /dev/null +++ b/help/fib @@ -0,0 +1,28 @@ +NAME + fib - Fibonacci number + +SYNOPSIS + fib(n) + +TYPES + n integer + + return integer + +DESCRIPTION + For any integer n, fib(n) returns the Fibonacci number with index n. + This may be defined by fib(0) = 0, fib(1) = 1 and for any n (positive + or negative) fib(n) = fib(n-1) + fib(n-2). + +EXAMPLE + > print fib(-2), fib(-1), fib(0), fib(1), fib(2), fib(3), fib(4), fib(5) + -1 1 0 1 1 2 3 5 -8 + +LIMITS + none + +LIBRARY + NUMBER *qfib(NUMBER *n) + +SEE ALSO + XXX - fill in diff --git a/help/file b/help/file new file mode 100644 index 0000000..d4aec0c --- /dev/null +++ b/help/file @@ -0,0 +1,167 @@ +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. + + The builtin 'errno' can be use to convert an errno number into + a slightly more meaningful error message: + + badfile = fopen("not_a_file", "r"); + if (!isfile(badfile)) { + print "error #" : badfile : ":", errno(badfile); + } + + 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 functions 'fputc' and 'fputs' write a character and string to + a file respectively. + + 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/help/files b/help/files new file mode 100644 index 0000000..a626c7e --- /dev/null +++ b/help/files @@ -0,0 +1,69 @@ +NAME + files - return a file or the maximum number of open files + +SYNOPSIS + files([fnum]) + +TYPES + fnum int + + return files, int or null + +DESCRIPTION + This function, then given the argument fnum, will use it as an + index into an internal table of open file and return a file value. + If that entry in the table is not in use, then the null value is + returned instead. When no args are given, the maximum number of + open files is returned. + + 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. + + The first 3 file entries always refer to standard input, output + and error respectively. (see the example below) These three + files are already open by the calculator and cannot be closed. + + When calc starts up, it scans for open file descriptors above + stderr (2) and below MAXFILES (20). Any open descriptor found + is assumed to be an open file opened in an unknown mode. Calc + will try to read and write to this file when directed. + + Consider the following commands: + + $ echo "A line of text in the file on descriptor 5" > datafile + $ calc 5 files(5) + FILE 5 "descriptor[5]" (unknown_mode, pos 0) + > fgetline(files(5)) + "A line of text in the file on descriptor 5" + +EXAMPLE + > fd = fopen("/etc/motd", "r") + > fd + FILE 3 "/etc/motd" (reading, pos 0) + > files(3) + FILE 3 "/etc/motd" (reading, pos 0) + + > if (isnull(files(4))) print "not open" + not open + + > stdin = files(0) + > stdout = files(1) + > stderr = files(2) + + > print files() + 20 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/floor b/help/floor new file mode 100644 index 0000000..0b54e11 --- /dev/null +++ b/help/floor @@ -0,0 +1,33 @@ +NAME + floor - floor + +SYNOPSIS + floor(x) + +TYPES + x real, complex, list, matrix + + return real or complex, list, matrix + +DESCRIPTION + For real x, floor(x) is the greatest integer not greater than x. + + For complex, floor(x) returns the real or complex number v for + which re(v) = floor(re(x)), im(v) = floor(im(x)). + + For list or matrix x, floor(x) returns the list or matrix of the + same structure as x for which each element t of x has been replaced + by floor(t). + +EXAMPLE + > print floor(27), floor(1.23), floor(-4.56), floor(7.8 - 9.1i) + 27 1 -5 7-10i + +LIMITS + none + +LIBRARY + none + +SEE ALSO + ceil, int diff --git a/help/fopen b/help/fopen new file mode 100644 index 0000000..2880f58 --- /dev/null +++ b/help/fopen @@ -0,0 +1,75 @@ +NAME + fopen - open a file + +SYNOPSIS + fopen(filename, mode) + +TYPES + filename string + mode string + + return file + +DESCRIPTION + This function opens the file named filename. A file can be + opened for either reading, writing, or appending. The mode + is controlled by the mode flag as folllows: + + "r" reading + "w" writing + "a" appending + + Names of files are subject to ~ expansion just like the C or + Korn shell. For example, the file name: + + ~/lib/gleet + + refers to the file 'gleet' under the directory lib located + in your home directory. The file name: + + ~chongo/was_here + + refers to the a file 'was_here' under the home directory of + the user 'chongo'. + + 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. + + Standard input, standard output and standard error are always opened + and cannot be closed. + + The truth value of an opened file is TRUE. + + If the open is unsuccessful, the numeric value of errno is returned. + You can the errno() builtin to determine what the errno number means. + +EXAMPLE + > fd = fopen("/etc/motd", "r") + > print fd + "/etc/motd" + > fd + FILE 3 "/etc/motd" (reading, pos 0) + + > outfile = fopen("~/tmp/output", "w") + > print outfile + "~/tmp/output" + > outfile + FILE 4 "~/tmp/output" (writing, pos 0) + + > badfile = fopen("not_a_file", "r") + > if (!isfile(badfile)) print "error #" : badfile : ":", errno(badfile); + error #2: No such file or directory + +LIMITS + none + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/forall b/help/forall new file mode 100644 index 0000000..08fab1e --- /dev/null +++ b/help/forall @@ -0,0 +1,38 @@ +NAME + forall - to evaluate a function for all values of a list or matrix + +SYNOPSIS + forall(x, y) + +TYPES + x list or matrix + y string + + return null value + +DESCRIPTION + In forall(x,y), y is to the the name of a function; that function + is performed in succession for all elements of x. This is similar + to modify(x, y) but x is not changed. + +EXAMPLE + > global n = 0 + > define s(a) {n += a;} + > A = list(1,2,3,4) + > forall(A, "s") + > n + 10 + + > define e(a) {if (iseven(a)) print a;} + > forall(A, "e") + 2 + 4 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + modify diff --git a/help/fprintf b/help/fprintf new file mode 100644 index 0000000..5aec583 --- /dev/null +++ b/help/fprintf @@ -0,0 +1,55 @@ +NAME + fprintf - formatted print to a file + +SYNOPSIS + fprintf(fd, fmt, x_1, x_2, ...) + +TYPES + fd file + fmt string + x_1, x_2, ... any + + return null + +DESCRIPTION + This prints to the file fd exactly what would be printed to + the standard output by printf(fmt, x_1, x_2, ...). + +EXAMPLE + > fprintf(files(1), "h=%d, i=%d\n", 2, 3); + h=2, i=3 + + > c = config("epsilon", 1e-6); c = config("display", 6); + > c = config("tilde", 1); c = config("outround", 0); + > c = config("fullzero", 0); + > fmt = "%f,%10f,%-10f,%10.4f,%.4f,%.f.\n"; + > a = sqrt(3); + > fprintf(files(2), fmt,a,a,a,a,a,a); + 1.732051, 1.732051,1.732051 , ~1.7320,~1.7320,~1. + + > file = fopen("/tmp/foo", "w"); + > mat A[4] = {sqrt(2), 3/7, "undefined", null()}; + > fprintf(file, "%f%r",A,A); + > fclose(file); + > !cat /tmp/foo + + mat [4] (4 elements, 4 nonzero): + [0] = 1.4142135623730950488 + [1] = ~.42857142857142857142 + [2] = "undefined" + [3] = NULL + + mat [4] (4 elements, 4 nonzero): + [0] = 1767766952966368811/1250000000000000000 + [1] = 3/7 + [2] = "undefined" + [3] = NULL + +LIMITS + The number of arguments of fprintf() is not to exceed 100. + +LIBRARY + none + +SEE ALSO + printf, strprintf, print diff --git a/help/fputc b/help/fputc new file mode 100644 index 0000000..739498d --- /dev/null +++ b/help/fputc @@ -0,0 +1,32 @@ +NAME + fputc - write a character to a file + +SYNOPSIS + fputc(fd, data) + +TYPES + fd file + data str + + return nil + +DESCRIPTION + This function writes the first character in data to the file + associated with fd. + +EXAMPLE + > fd = fopen("/tmp/newfile", "w") + > fputc(fd, "c") + > fd2 = fopen("/tmp/newfile", "r") + > fgetc(fd2) + "c" + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fputs b/help/fputs new file mode 100644 index 0000000..5652982 --- /dev/null +++ b/help/fputs @@ -0,0 +1,32 @@ +NAME + fputs - write a string to a file + +SYNOPSIS + fputs(fd, data) + +TYPES + fd file + data str + + return nil + +DESCRIPTION + This function writes the string found in data to the file + associated with fd. + +EXAMPLE + > fd = fopen("/tmp/newfile", "w") + > fputs(fd, "chongo was here\n") + > fd2 = fopen("/tmp/newfile", "r") + > fgetline(fd2) + "chongo was here" + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fputstr b/help/fputstr new file mode 100644 index 0000000..1356b6b --- /dev/null +++ b/help/fputstr @@ -0,0 +1,40 @@ +NAME + fputstr - send one or more null-terminated strings to a file + +SYNOPSIS + fputstr(fs, s_1, s_2, ...) + +TYPES + fs file stream open for writing + s_1, ... string + + return null or error value + +DESCRIPTION + If the stream cannot be written to or an argument is of the wrong + type, an error value is returned. + + Otherwise the strings s_1, s_2, ..., including the terminating + null characters ('\0') are written to the file stream fs. + +EXAMPLE + > f = fopen("/tmp/junk", "w") + > fputstr(f, "Alpha", "Beta") + > freopen(f, "r") + > fgetstr(f) + "Alpha" + > fgetstr(f) + "Beta" + > fgetstr(f) + > + > fputstr(f, "Gamma") + Error 72 + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + fgetstr, fgetfield, fgets, fputs, fopen, files, fprintf diff --git a/help/frac b/help/frac new file mode 100644 index 0000000..ceffe4c --- /dev/null +++ b/help/frac @@ -0,0 +1,42 @@ +NAME + frac - return the fractional part of a number or of numbers in a value + +SYNOPSIS + frac(x) + +TYPES + If x is an object of type xx, frac(x) requires xx_frac to have been + defined; other conditions on x and the value returned depend on + the definition of xx_frac. + + For other x: + + x number (real or complex), matrix + + return number or matrix + +DESCRIPTION + If x is an integer, frac(x) returns zero. For other real values of x, + frac(x) returns the real number f for which x = i + f, where i is an + integer, sgn(f) = sgn(x), and abs(f) < 1. + + If x is complex, frac(x) returns frac(re(x)) + frac(im(x))*1i. + + If x is a matrix, frac(x) returns the matrix m with the same structure + as x in which m[[i]] = frac(x[[i]]). + +EXAMPLE + > c = config("mode", "frac") + > print frac(3), frac(22/7), frac(27/7), frac(-3.125), frac(2.15 - 3.25i) + 0 1/7 6/7 -1/8 3/20-1i/4 + +LIMITS + none + +LIBRARY + NUMBER *qfrac(NUMBER *x) + COMPLEX *cfrac(COMPLEX *x) + MATRIX *matfrac(MATRIX *x) + +SEE ALSO + int, ceil, floor diff --git a/help/frem b/help/frem new file mode 100644 index 0000000..d6b6764 --- /dev/null +++ b/help/frem @@ -0,0 +1,37 @@ +NAME + frem - remove specified integer factors from specified integer + +SYNOPSIS + frem(x,y) + +TYPES + x integer + y integer + + return non-negative integer + +DESCRIPTION + If x and y are not zero and n is the largest non-negative integer + for which y^n is a divisor of x, frem(x,y) returns abs(x/y^n). + In particular, abs(x) is returned if x is not divisible by + y or if abs(y) = 1. If abs(y) > 1, frem(x,y) is the greatest + divisor of x not divisible by y. + + For all x, frem(x,0) is defined to equal abs(x). + + For all y, frem(0,y) is defined to be zero. + + For all x and y, abs(x) = frem(x,y) * abs(y) ^ fcnt(x,y). + +EXAMPLE + > print frem(7,4), frem(24,4), frem(48,4), frem(-48,4) + 7 6 3 3 + +LIMITS + none + +LIBRARY + NUMBER *qfacrem(NUMBER *x, NUMBER *y); + +SEE ALSO + fcnt, gcdrem diff --git a/help/freopen b/help/freopen new file mode 100644 index 0000000..2269a7b --- /dev/null +++ b/help/freopen @@ -0,0 +1,42 @@ +NAME + freopen - close (if necessary) and reopen a filestream + +SYNOPSIS + freopen(fs, mode) or freopen(fs, mode, filename) + +TYPES + fs open or closed file stream + mode one of the strings "r", "w", "a", "r+", "w+, "a+" + filename string + + return null or error value + +DESCRIPTION + With two arguments, this function closes the file stream fs and + attempts to reopen it with the specified mode. A non-null value + is returned only if the attempt fails. + + With three arguments, fs, if open, is closed, and an attempt is made to + open the file with the specified name and assign it to the stream + fs. A non-null value is returned only if the attempt fails. + +EXAMPLE + + > f = fopen("/tmp/junk", "w") + > fputs(f, "Leonard Euler") + > freopen(f, "r") + > fgets(f) + "Leonard Euler" + > !chmod u-w /tmp/junk + > freopen(f, "w") + Error 10013 + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/fscan b/help/fscan new file mode 100644 index 0000000..d16125c --- /dev/null +++ b/help/fscan @@ -0,0 +1,39 @@ +NAME + fscan - scan a file for possible assignment to variables + +SYNOPSIS + fscan(fs, x_1, x_2, ..., x_n) + +TYPES + fs file stream open for reading + x_1, x_2, ... any + + return integer + +DESCRIPTION + Starting at the current position on fs and while values remain in the + x_i arguments, fields of non-whitespace characters are read and evaluated + in succession and if the corresponding x_i is an lvalue, the value of + the field is assigned to x_i. Scanning ceases when no x_i remain or + when the stream reaches end-of-file. + + The function returns the number of fields evaluated. + +EXAMPLE + > global a, b, c, d; + > f = fopen("/tmp/junk", "w+"); + > fputs(f, "\t3+4\t\ta-2i d=a^2 'word'") + > rewind(f) + > fscan(f, a, b, , c) + 4 + > print a, b, c, d + 7 a-2i word 49 + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + scan, strscan, fscanf, scanf, strscanf, printf, fprintf, strprintf diff --git a/help/fscanf b/help/fscanf new file mode 100644 index 0000000..5b0f197 --- /dev/null +++ b/help/fscanf @@ -0,0 +1,130 @@ +NAME + fscanf - formatted scan of a file stream + +SYNOPSIS + fscanf(fs, fmt, x_1, x_2, ...) + +TYPES + fs file stream open for reading + fmt string + x_1, x_2, ... lvalues + + return null, nonnegative integer, or error value + +DESCRIPTION + If the current position for fs is EOF, the null value is returned. + + Otherwise, until the terminating null character of fmt is encountered + or end-of-file for fs is reached, characters other than '%' and white + space are read from fmt and compared with the corresponding chracters + read from fs. If the characters match, the reading continues. If they + do not match, an integer value is returned and the file position for + fs is the position of the non-matching character. If white space + is encountered in fmt, any white space characters read from + fs are skipped until either end-of-file is reached or a non-white-space + character is read and comparisons continue under the control of the + next non-white character and following characters in fmt. + + When a '%' is encountered in fmt, if this is immediately followed by + another '%', the pair is considered as if just one '%' were read and + if reading from fmt and fs continues if and only if fs has a matching + '%'. A single '%' read from fmt is taken to indicate the beginning of + a conversion specification field consisting in succession of: + + an optional '*', + optional decimal digits, + one of 'c', 's', 'n', 'f', 'e', 'i' or a scanset specifier. + + A scanset specifier starts with '[' and an optional '^', then an optional + ']', then optional other characters, and ends with ']'. If any + other sequence of characters follows the '%', characters before the + first exceptional character (which could be the terminating null + character of the fmt string) are ignored, e.g. the sequence " %*3d " does + the same as " d ". If there is no '*' at the beginning of the specifier, + and the list x_1, x_2, ... has not been exhausted, + a value will be assigned to the next lvalue in the list; if no lvalue + remains, the reading of fs stops and the function returns the number + of assignments that have been made. + + Occurrence of '*' indicates that characters as specified are to be read + but no assignment will be made. + + The digits, if any, read at this stage in the specifier are taken to + be decimal digits of an integer which becomes the maximum "width" + (i.e. for string-type values, the number of characters to be read from + fs); absence of digits or all zero digits in the 'c' + case are taken to mean width = 1. Zero width for the other cases are + treated as if infinite. Fewer characters than the specifier width + may be read if end-of-file is reached or in the case of scanset + specification, an exceptional character is encountered. + + If the ending character is 'c', characters are read from fs to + form a string, which will be ignored or in the non-'*' case, assigned + to the next lvalue. + + In the 's' case, reading to form the string starts at the first non-white + character (if any) and ceases when end-of-file or further white space + is encountered or the specified width has been attained. + + The cases 'f', 'e', 'r', 'i' may be considered to indicate expectation of + floating-point, exponential, ratio, or integer representation of the + number to be read. For example, 'i' + might be taken to suggest a number like +2345; 'r' might suggest + a representation like -27/49; 'e' might suggest a representation like + 1.24e-7; 'f' might suggest a representation like 27.145. However, there + is no test that the the result conforms to the specifier. Whatever + the specifier in these cases, the result depends on the characters read + until a space or other exceptional character is read. The + characters read may include one or more occurrences of +, -, * as + well as /, interpreted in the usual way, with left-to-right associativity + for + and -, and for * and /. Also acceptable is a trailing i to + indicate an imaginary number. For example the expression + + 2+3/4*7i+3.15e7 + + would be interpreted as for an ordinary evaluation. A decimal fraction + may have more than one dot: dots after the first, which is taken to be + the decimal point, are ignored. Thus "12.3..45e6.7" is interpreted + as if it were "12.345e67". + + For the number specifiers 'f', 'e', 'r', 'i', any specified width is + ignored. + + For the specifier 'n', the current value of the file-position indicator + is assigned to the corresponding lvalue. (Any width or skip specification + is ignored.) + + +EXAMPLE + > global a, b, c + > f = fopen("/tmp/junk", "w+") + > fputs(f, "Alpha Beta Gamma") + > rewind(f) + > fscanf(f, "Alpha Gamma") + > fgets(f) + "Beta Gamma" + > rewind(f) + > fscanf(f, "%5c", a) + 1 + > a + "Alpha" + > fgets(f) + " Beta Gamma" + > rewind(f) + > fscanf(f, "%3c%s%[^m]", a, b, c) + 3 + > print a, b + Alp ha + > print c + Beta Ga + > fgets(f) + "mma" + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + scanf, strscanf, printf, fprintf, strprintf, fscan, scan, strscan diff --git a/help/fseek b/help/fseek new file mode 100644 index 0000000..94528a9 --- /dev/null +++ b/help/fseek @@ -0,0 +1,67 @@ +NAME + fseek - set a file position + +SYNOPSIS + fseek(fd, offset [, whence]) + +TYPES + fd open file stream + pos integer + whence 0, 1 or 2, defaulting to 0 + + return null or error value + +DESCRIPTION + This function sets the file position indicator for the stream by + adding offset to zero, the current value, or the size of the + file, according as whence is 0, 1 or 2. The effect is equivalent to + moving the signed distance offset from the beginning, the current + position, or the end of the file. + + The function also clears the end-of-file flag and flushes any + buffered data waiting to be output to the stream. + + An implementation-defined error occurs if the effect would be to + give a negative value to the position indicator; on some systems, the + file position will be set to end-of-file. + + The file position indicator may have a value greater than the file + size. If characters are then written to the file, the gap is + filled by null ('\0') characters. + +EXAMPLE + > fd = fopen("/tmp/curds", "w") + > fputs(fd, "0123456789abcdef") + > freopen(fd, "r") + > fsize(fd) + 16 + > fseek(fd, 5) + > fgets(fd) + "56789abcdef" + > fseek(fd, 0) + > fscanf(fd, "%*5c") + 0 + > fseek(fd, 5, 1) + > fgets(fd) + "abcdef" + > ftell(fd) + 16 + > fseek(fd, -5, 2) + > fgets(fd) + "bcdef" + > fseek(fd, -2) + System error 22 + > ftell(fd) + 16 + + The results for the last four lines may be different for different systems. + +LIMITS + Some details of the operation of this function may be implementation- + dependent, particularly for older systems. + +LIBRARY + none + +SEE ALSO + ftell, fgetpos, fsetpos, rewind, strerror diff --git a/help/fsize b/help/fsize new file mode 100644 index 0000000..4feb859 --- /dev/null +++ b/help/fsize @@ -0,0 +1,30 @@ +NAME + fsize - return the file size + +SYNOPSIS + fsize(fd) + +TYPES + fd file + + return int + +DESCRIPTION + This function returns the number of bytes in a file. When at + the end of file, ftell returns a value which is 1 greater than + the file size as reported by fsize. + +EXAMPLE + > fd = fopen("/etc/motd", "r") + > fsize(fd) + 784 + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/ftell b/help/ftell new file mode 100644 index 0000000..08bfcc9 --- /dev/null +++ b/help/ftell @@ -0,0 +1,47 @@ +NAME + ftell - return a file position + +SYNOPSIS + ftell(fd) + +TYPES + fd open file stream + + return non-negative integer or error value + +DESCRIPTION + This function attempts to return the current value of the file position + indicator for the stream. This is the number of characters (bytes) + between the beginning of the file and the position of the + next character for output in "w" or "w+" mode or for input. + + On failure, this returns an error value. + +EXAMPLE + > fd = fopen("/tmp/curds", "w") + > fputs(fd, "0123456789") + > ftell(fd) + 10 + > fputs(fd, "abcdef") + > ftell(fd) + 16 + > fseek(fd, 20, 0) + > ftell(fd) + 20 + > fputs(fd, "01234") + > ftell(fd) + 25 + > freopen(fd, "r") + > fscanf(fd, "%*5c") + 0 + > ftell(fd) + 5 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + fseek, fgetpos, fsetpos, rewind, strerror diff --git a/help/funclist.sed b/help/funclist.sed new file mode 100644 index 0000000..6e5c08a --- /dev/null +++ b/help/funclist.sed @@ -0,0 +1,9 @@ +s/VALUE/int/ +s/NUMBER[ ]*\*/int / +s/NUMBER/int/ +s/STRINGHEAD/int/ +s/\(".*",.*,.*\),.*,.*,.*,.*,/\1, 0, 0, 0, 0,/ +/sed me out/d +s/showbuiltins/main/ +s/[ ][ ]*$// +p diff --git a/help/gcd b/help/gcd new file mode 100644 index 0000000..c09cdcc --- /dev/null +++ b/help/gcd @@ -0,0 +1,28 @@ +NAME + gcd - greatest common divisor of a set of rational numbers + +SYNOPSIS + gcd(x1, x2, ...) + +TYPES + x1, x2, ... rational number + + return rational number + +DESCRIPTION + If at least one xi is nonzero, gcd(x1, x2, ...) is the + greatest positive number g for which each xi is a multiple of g. + If all xi are zero, the gcd is zero. + +EXAMPLE + > print gcd(12, -24, 30), gcd(9/10, 11/5, 4/25), gcd(0,0,0,0,0) + 6 .02 0 + +LIMITS + The number of arguments may not to exceed 100. + +LIBRARY + NUMBER *qgcd(NUMBER *x1, NUMBER *x2) + +SEE ALSO + lcm diff --git a/help/gcdrem b/help/gcdrem new file mode 100644 index 0000000..c38da66 --- /dev/null +++ b/help/gcdrem @@ -0,0 +1,54 @@ +NAME + gcdrem - result of removing factors of integer common to a specified integer + +SYNOPSIS + gcdrem(x, y) + +TYPES + x integer + y integer + + return non-negative integer + +DESCRIPTION + + If x and y are not zero, gcdrem(x, y) returns the greatest integer + divisor d of x relatively prime to y, i.e. for which gcd(d,y) = 1. + In particular, gcdrem(x,y) = abs(x) if x and y are relatively + prime. + + For all x, gcdrem(x, 0) = 1. + + For all nonzero y, gcdrem(0, y) = 0. + +PROPERTIES + gcdrem(x,y) = gcd(abs(x), abs(y)). + + If x is not zero, gcdrem(x,y) = gcdrem(x, gcd(x,y)) = gcdrem(x, y % x). + + For fixed nonzero x, gcdrem(x,y) is periodic with period abs(x). + + gcdrem(x,y) = 1 if and only if every prime divisor of x + is a divisor of y. + + If x is not zero, gcdrem(x,y) == abs(x) if and only if gcd(x,y) = 1. + + If y is not zero and p_1, p_2, ..., p_k are the prime divisors of y, + + gcdrem(x,y) = frem(...(frem(frem(x,p_1),p_2)...,p_k) + +EXAMPLE + > print gcdrem(6,15), gcdrem(15,6), gcdrem(72,6), gcdrem(6,72) + 2 5 1 1 + + > print gcdrem(630,6), gcdrem(6,630) + 35 1 + +LIMITS + none + +LIBRARY + NUMBER *qgcdrem(NUMBER *x, NUMBER *y) + +SEE ALSO + gcd, frem, isrel diff --git a/help/getenv b/help/getenv new file mode 100644 index 0000000..17243d4 --- /dev/null +++ b/help/getenv @@ -0,0 +1,35 @@ +NAME + getenv - get an environment variable + +SYNOPSIS + getenv(env) + +TYPES + env str + + return str or nil + +DESCRIPTION + This function returns the value of the environment variable named by + the string env. If no such environment variable exists, nil is returned. + +EXAMPLE + > putenv("name", "value") + 0 + > getenv("name") + "value" + > putenv("name=val2") + 0 + > getenv("name") + "val2" + > isnull(getenv("unknown")) + 1 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + putenv diff --git a/help/hash b/help/hash new file mode 100644 index 0000000..9376a34 --- /dev/null +++ b/help/hash @@ -0,0 +1,26 @@ +NAME + hash - hash value + +SYNOPSIS + hash(x_1 [, x_2, x_3, ...]) + +TYPES + x_1, x_1, ... any + + return integer v, 0 <= v < 2^32 + +DESCRIPTION + Returns a hash value for one or more values of arbitrary types. + +EXAMPLE + > a = isqrt(2e1000); s = "xyz"; + > hash(a,s) + 870000771 + +LIMITS + The number of arguments is not to exceed 100. + +LIBRARY + none + +SEE ALSO diff --git a/help/head b/help/head new file mode 100644 index 0000000..70f4e00 --- /dev/null +++ b/help/head @@ -0,0 +1,49 @@ +NAME + head - create a list of specified size from the head of a list + +SYNOPSIS + head(x, y) + +TYPES + x list + y int + + return list + +DESCRIPTION + If 0 <= y <= size(x), head(x,y) returns a list of size y whose + elements in succession have values x[[0]]. x[[1]], ..., x[[y - 1]]. + + If y > size(x), head(x,y) is a copy of x. + + If -size(x) < y < 0, head(x,y) returns a list of size (size(x) + y) + whose elements in succession have values x[[0]]. x[[1]], ..., + i.e. a copy of x from which the last -y members have been deleted. + + If y <= -size(x), head(x,y) returns a list with no members. + + For any integer y, x == join(head(x,y), tail(x,-y)). + +EXAMPLE + > A = list(2, 3, 5, 7, 11) + > head(A, 2) + + list (2 members, 2 nonzero): + [[0]] = 2 + [[1]] = 3 + + > head(A, -2) + + list (3 members, 3 nonzero): + [[0]] = 2 + [[1]] = 3 + [[2]] = 5 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + tail, segment diff --git a/help/help b/help/help new file mode 100644 index 0000000..85ed57a --- /dev/null +++ b/help/help @@ -0,0 +1,69 @@ +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 + errorcodes calc generated error codes + 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 + archive where to get the latest versions of calc + + full all of the above + +You can also ask for help on a particular function name. For example, + + help asinh + help round + +or on a particular symbol such as: + + help = + +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. + +If the -m mode disallows opening files for reading or execution of programs, +then the help facility will be disabled. See: + + help usage + +for details of the -m mode. diff --git a/help/highbit b/help/highbit new file mode 100644 index 0000000..1e3aa17 --- /dev/null +++ b/help/highbit @@ -0,0 +1,29 @@ +NAME + highbit - index of highest bit in binary representation of integer + +SYNOPSIS + highbit(x) + +TYPES + x nonzero integer + + return integer + +DESCRIPTION + If x is a nonzero integer, highbit(x) returns the index of the + highest bit in the binary representation of abs(x). Equivalently, + highbit(x) = n if 2^n <= abs(x) < 2^(n + 1); the binary + representation of x then has n + 1 digits. + +EXAMPLE + > print highbit(2), highbit(3), highbit(4), highbit(-15), highbit(2^27) + 1 1 2 3 27 + +LIMITS + none + +LIBRARY + LEN zhighbit(ZVALUE x); + +SEE ALSO + lowbit, digits diff --git a/help/history b/help/history new file mode 100644 index 0000000..f57e9d4 --- /dev/null +++ b/help/history @@ -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 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 g + will recall that numbered line. So that for example, 2g + 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 ([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/help/hmean b/help/hmean new file mode 100644 index 0000000..11f730a --- /dev/null +++ b/help/hmean @@ -0,0 +1,38 @@ +NAME + hmean - harmonic mean of a number of values + +SYNOPSIS + hmean(x_1, x_2, ...) + +TYPES + x_1, ... arithmetic or list + + return determined by types of arguments, or null + +DESCRIPTION + The null value is returned if there are no arguments. + + If there are n non-list arguments x_1, x_2, ... and the + required operations are defined, hmean(x_1, x_2, ...) returns the + value of: + + n/(inverse(x_1) + inverse(x_2) + ... + inverse(x_n)). + + If an argument x_i is a list as defined by list(y_1, ..., y_m) + this is treated as if in (x_1, x_2, ...), x_i is replaced by + y_1, ..., y_m. + + +EXAMPLE + > c = config("mode", "frac") + > print hmean(1), hmean(1,2), hmean(1,2,3), hmean(1,2,3,4), hmean(1,2,0,3) + 1 4/3 18/11 48/25 0 + +LIMITS + The number of arguments is not to exceed 100. + +LIBRARY + none + +SEE ALSO + avg diff --git a/help/hypot b/help/hypot new file mode 100644 index 0000000..398e64b --- /dev/null +++ b/help/hypot @@ -0,0 +1,28 @@ +NAME + hypot - hypotenuse of a right-angled triangle given the other sides + +SYNOPSIS + hypot(x, y [,eps]) + +TYPES + x, y real + eps nonzero real + + return real + +DESCRIPTION + Returns sqrt(x^2 + y^2) to the nearest multiple of eps. + The default value for eps is epsilon(). + +EXAMPLE + > print hypot(3, 4, 1e-6), hypot(2, -3, 1e-6) + 5 3.605551 + +LIMITS + none + +LIBRARY + NUMBER *qhypot(NUMBER *q1, *q2, *epsilon) + +SEE ALSO + ltol diff --git a/help/ilog b/help/ilog new file mode 100644 index 0000000..4885e78 --- /dev/null +++ b/help/ilog @@ -0,0 +1,28 @@ +NAME + ilog - floor of logarithm to specified integer base + +SYNOPSIS + ilog(x, b) + +TYPES + x nonzero real + b integer greater than 1 + + return integer + +DESCRIPTION + Returns the greatest integer n for which b^n <= abs(x). + +EXAMPLE + > print ilog(2, 3), ilog(8, 3), ilog(8.9, 3), ilog(1/8, 3) + 0 1 1 -2 + +LIMITS + x > 0 + b > 1 + +LIBRARY + long zlog(ZVALUE x, ZVALUE b) + +SEE ALSO + ilog2, ilog10 diff --git a/help/ilog10 b/help/ilog10 new file mode 100644 index 0000000..cc52e21 --- /dev/null +++ b/help/ilog10 @@ -0,0 +1,26 @@ +NAME + ilog10 - floor of logarithm to base 10 + +SYNOPSIS + ilog10(x) + +TYPES + x nonzero real + + return integer + +DESCRIPTION + Returns the greatest integer n for which 10^n <= x. + +EXAMPLE + > print ilog10(7), ilog10(77.7), ilog10(777), ilog10(.00777), ilog10(-1e27) + 0 1 2 -3 27 + +LIMITS + none + +LIBRARY + long qilog10(NUMBER *q) + +SEE ALSO + ilog2, ilog diff --git a/help/ilog2 b/help/ilog2 new file mode 100644 index 0000000..6f4af4f --- /dev/null +++ b/help/ilog2 @@ -0,0 +1,26 @@ +NAME + ilog2 - floor of logarithm to base 2 + +SYNOPSIS + ilog2(x) + +TYPES + x nonzero real + + return integer + +DESCRIPTION + Returns the greatest integer n for which 2^n <= abs(x). + +EXAMPLE + > print ilog2(1), ilog2(2), ilog2(3), ilog2(4), ilog(1/15) + 0 1 1 2 -4 + +LIMITS + none + +LIBRARY + long qilog2(NUMBER *q) + +SEE ALSO + ilog10, ilog diff --git a/help/im b/help/im new file mode 100644 index 0000000..c220207 --- /dev/null +++ b/help/im @@ -0,0 +1,26 @@ +NAME + im - imaginary part of a real or complex number + +SYNOPSIS + im(x) + +TYPES + x real or complex + + return real + +DESCRIPTION + If x = u + v * 1i where u and v are real, im(x) returns v. + +EXAMPLE + > print im(2), im(2 + 3i), im(-4.25 - 7i) + 0 3 -7 + +LIMITS + none + +LIBRARY + COMPLEX *cimag(COMPLEX *x) + +SEE ALSO + re diff --git a/help/insert b/help/insert new file mode 100644 index 0000000..35f0ea3 --- /dev/null +++ b/help/insert @@ -0,0 +1,59 @@ +NAME + insert - insert one or more elements into a list at a given position + +SYNOPSIS + insert(x, y, z_0, z_1, ...) + +TYPES + x lvalue whose value is a list + y int + z_0, ... any + + return null value + +DESCRIPTION + If after evaluation of z_0, z_1, ..., x is a list with contents + (x_0, x_1, ..., x_y-1, x_y, ..., x_n-1), then after insert(), + x has contents (x_0, x_1, ..., x_y-1, z_0, z_1, ..., x_y, ..., x_n-1), + i.e. z_0, z_1, ... are inserted in order immediately before the + element with index y (so that z_0 is now x[[y]]), or if y = n, + after the last element x_n-1. An error occurs if y > n. + +EXAMPLE + > A = list(2,3,4) + > print A + + list (3 elements, 3 nonzero): + [[0]] = 2 + [[1]] = 3 + [[2]] = 4 + + > insert(A, 1, 5, 6) + > print A + + list (5 elements, 5 nonzero): + [[0]] = 1 + [[1]] = 5 + [[2]] = 6 + [[3]] = 3 + [[4]] = 4 + + > insert(A, 2, remove(A)) + > print A + + list (5 elements, 5 nonzero): + [[0]] = 1 + [[1]] = 5 + [[2]] = 4 + [[3]] = 6 + [[4]] = 3 + +LIMITS + insert() can have at most 100 arguments + o <= y <= size(x) + +LIBRARY + none + +SEE ALSO + append, delete, islist, list, pop, push, remove, rsearch, search, size diff --git a/help/int b/help/int new file mode 100644 index 0000000..d8cd3d7 --- /dev/null +++ b/help/int @@ -0,0 +1,41 @@ +NAME + int - return the integer part of a number or of numbers in a value + +SYNOPSIS + int(x) + +TYPES + If x is an object of type xx, int(x) requires xx_int to have been + defined; other conditions on x and the value returned depend on + the definition of xx_int. + + For other x: + + x number (real or complex), matrix + + return number or matrix + +DESCRIPTION + If x is an integer, int(x) returns x. For other real values of x, + int(x) returns the value of i for which x = i + f, where i is an + integer, sgn(f) = sgn(x) and abs(f) < 1. + + If x is complex, int(x) returns int(re(x)) + int(im(x))*1i. + + If x is a matrix, int(x) returns the matrix m with the same structure + as x in which m[[i]] = int(x[[i]]). + +EXAMPLE + > print int(3), int(22/7), int(27/7), int(-3.125), int(2.15 - 3.25i) + 3 3 3 -3 2-3i + +LIMITS + none + +LIBRARY + NUMBER *qint(NUMBER *x) + COMPLEX *cint(COMPLEX *x) + MATRIX *matint(MATRIX *x) + +SEE ALSO + frac, ceil, floor, quo diff --git a/help/interrupt b/help/interrupt new file mode 100644 index 0000000..55dc7a4 --- /dev/null +++ b/help/interrupt @@ -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/help/intro b/help/intro new file mode 100644 index 0000000..be53f0c --- /dev/null +++ b/help/intro @@ -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/help/inverse b/help/inverse new file mode 100644 index 0000000..0d7b9b3 --- /dev/null +++ b/help/inverse @@ -0,0 +1,48 @@ +NAME + inverse - inverse of value + +SYNOPSIS + inverse(x) + +TYPES + If x is an object of type xx, the function xx_inv has to have + been defined; any conditions on x and the nature of the returned + value will depend on the definition of xx_inv. + + For non-object x: + + x nonzero number (real or complex) or nonsingular matrix + + return number or matrix + +DESCRIPTION + For real or complex x, inverse(x) returns the value of 1/x. + + If x is a nonsingular n x n matrix and its elements are numbers or + objects for which the required arithmetic operations are defined, + inverse(x) returns the matrix m for which m * x = x * m = the unit + n x n matrix. The inverse m will have the same index limits as x. + +EXAMPLE + > print inverse(5/4), inverse(-2/7), inverse(3 + 4i) + .8 -3.5 .12-.16i + + > mat A[2,2] = {2,3,5,7} + > print inverse(A) + + mat [2,2] (4 elements, 4 nonzero): + [0,0] = -7 + [0,1] = 3 + [1,0] = 5 + [1,1] = -2 + +LIMITS + none + +LIBRARY + void invertvalue(VALUE *x, VALUE *vres) + NUMBER *qinv(NUMBER *x) + COMPLEX *cinv(COMPLEX *x) + MATRIX *matinv(MATRIX *x) + +SEE ALSO diff --git a/help/iroot b/help/iroot new file mode 100644 index 0000000..85a0c93 --- /dev/null +++ b/help/iroot @@ -0,0 +1,27 @@ +NAME + iroot - integer part of specified root + +SYNOPSIS + iroot(x, n) + +TYPES + x nonnegative real + n positive integer + + return nonnegative real + +DESCRIPTION + Return the greatest integer v for which v^n <= x. + +EXAMPLE + > print iroot(100,3), iroot(274,3), iroot(1,9), iroot(pi()^8,5) + 4 6 1 6 + +LIMITS + n > 0 + +LIBRARY + NUMBER *qiroot(NUMBER *x, NUMBER* n) + +SEE ALSO + isqrt, sqrt diff --git a/help/isassoc b/help/isassoc new file mode 100644 index 0000000..8db1177 --- /dev/null +++ b/help/isassoc @@ -0,0 +1,29 @@ +NAME + isassoc - whether a value is an association. + +SYNOPSIS + isassoc(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is an association. This function will return 1 if x is + an association, 0 otherwise. + +EXAMPLE + > a = assoc() + > print isassoc(a), isassoc(1) + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isfile, isident, isint, islist, ismat, isnull, isnum, isobj, + isreal, isstr, issimple, istype diff --git a/help/isatty b/help/isatty new file mode 100644 index 0000000..99f3989 --- /dev/null +++ b/help/isatty @@ -0,0 +1,30 @@ +NAME + isatty - returns 1 if fd assocatied with a tty + +SYNOPSIS + isatty(fd) + +TYPES + fd file + + return int + +DESCRIPTION + This function returns 1 if fd is associated with a tty, 0 otherwise. + + +EXAMPLE + > print isatty(files(0)), isatty(files(1)), isatty(files(2)) + 1 1 1 + > fd = fopen("/dev/null", "r") + > isatty(fd) + 0 + +LIMITS + fd must be associaed with an open file + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/isconfig b/help/isconfig new file mode 100644 index 0000000..78a688b --- /dev/null +++ b/help/isconfig @@ -0,0 +1,28 @@ +NAME + isconfig - whether a value is a configuration state + +SYNOPSIS + isrand(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a configuration state. This function will return + 1 if x is a file, 0 otherwise. + +EXAMPLE + > a = config("all") + > print isconfig(a), isconfig(0); + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + config diff --git a/help/iserror b/help/iserror new file mode 100644 index 0000000..cf3c2b8 --- /dev/null +++ b/help/iserror @@ -0,0 +1,28 @@ +NAME + error - test whether a value is an error value + +SYNOPSIS + iserror(x) + +TYPES + x any + + return zero or positive integer < 32768 + +DESCRIPTION + If x is not an error value, zero is returned. + If x is an error value, iserror(x) returns its error type. + +EXAMPLE + > a = error(99) + print iserror(a), iserror(2 + a), iserror(2 + "a"), iserror(2 + 3) + 99 99 3 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + error, errorcodes diff --git a/help/iseven b/help/iseven new file mode 100644 index 0000000..6a9812c --- /dev/null +++ b/help/iseven @@ -0,0 +1,30 @@ +NAME + iseven - whether a value is an even integer + +SYNOPSIS + iseven(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is an even integer. This function will return 1 if x is + even integer, 0 otherwise. + +EXAMPLE + > print iseven(2.0), iseven(1), iseven("0") + 1 0 0 + + > print iseven(2i), iseven(1e20), iseven(1/3) + 0 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + iseven, isint, isnum, isodd, isreal diff --git a/help/isfile b/help/isfile new file mode 100644 index 0000000..42186c5 --- /dev/null +++ b/help/isfile @@ -0,0 +1,29 @@ +NAME + isfile - whether a value is a file + +SYNOPSIS + isfile(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a file. This function will return 1 if x is + a file, 0 otherwise. + +EXAMPLE + > a = files(0) + > print isfile(a), isfile(files(1)), isfile(1) + 1 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isident, isint, islist, ismat, isnull, isnum, isobj, + isreal, isstr, issimple, istype diff --git a/help/ishash b/help/ishash new file mode 100644 index 0000000..5f7200a --- /dev/null +++ b/help/ishash @@ -0,0 +1,28 @@ +NAME + ishash - whether a value is a hash state + +SYNOPSIS + ishash(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a hash state. This function will return 1 if x is + a file, 0 otherwise. + +EXAMPLE + > a = shs(0) + > print ishash(a), ishash(0); + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/isident b/help/isident new file mode 100644 index 0000000..d32b343 --- /dev/null +++ b/help/isident @@ -0,0 +1,26 @@ +NAME + isident - returns 1 if matrix is an identity matrix + +SYNOPSIS + isident(m) + +TYPES + m mat + + return int + +DESCRIPTION + This function returns 1 if m is an identity matrix, 0 otherwise. + +EXAMPLE + XXX - fill in + +LIMITS + m must be a 2 dimensional matrix + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isint, islist, ismat, isnull, isnum, isobj, + isreal, isstr, issimple, istype diff --git a/help/isint b/help/isint new file mode 100644 index 0000000..aeb9b01 --- /dev/null +++ b/help/isint @@ -0,0 +1,31 @@ +NAME + isint - whether a value is an integer + +SYNOPSIS + isint(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is an integer. This function will return 1 if x is + integer, 0 otherwise. + +EXAMPLE + > print isint(2.0), isint(1), isint("0") + 1 1 0 + + > print isint(2i), isint(1e20), isint(1/3) + 0 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, islist, ismat, isnull, isnum, isobj, + isreal, isstr, issimple, istype diff --git a/help/islist b/help/islist new file mode 100644 index 0000000..ca25ed4 --- /dev/null +++ b/help/islist @@ -0,0 +1,29 @@ +NAME + islist - whether a value is a list + +SYNOPSIS + islist(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a list. This function will return 1 if x is + a list, 0 otherwise. + +EXAMPLE + > lst = list(2,3,4) + > print islist(lst), islist(1) + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, ismat, isnull, isnum, isobj, + isreal, isstr, issimple, istype diff --git a/help/ismat b/help/ismat new file mode 100644 index 0000000..c7cf44a --- /dev/null +++ b/help/ismat @@ -0,0 +1,29 @@ +NAME + ismat - whether a value is a matrix + +SYNOPSIS + ismat(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a matrix. This function will return 1 if x is + a matrix, 0 otherwise. + +EXAMPLE + > mat a[2] + > print ismat(a), ismat(1) + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, islist, isnull, isnum, isobj, + isreal, isstr, issimple, istype diff --git a/help/ismult b/help/ismult new file mode 100644 index 0000000..7bb8bc1 --- /dev/null +++ b/help/ismult @@ -0,0 +1,36 @@ +NAME + ismult - whether a value is a multiple of another + +SYNOPSIS + ismult(x, y) + +TYPES + x real + y real + + return int + +DESCRIPTION + Determine if x exactly divides y. If there exists an integer k + such that: + + x == y * k + + then return 1, otherwise return 0. + +EXAMPLE + > print ismult(6, 2), ismult(2, 6), ismult(7.5, 2.5) + 1 0 1 + + > print ismult(4^67, 2^59), ismult(13, 4/67), ismult(13, 7/56) + 1 0 1 + +LIMITS + none + +LIBRARY + BOOL qdivides(NUMBER *x, *y) + BOOL zdivides(ZVALUE x, y) + +SEE ALSO + ismult, isprime, isrel, issq diff --git a/help/isnull b/help/isnull new file mode 100644 index 0000000..0d951cb --- /dev/null +++ b/help/isnull @@ -0,0 +1,29 @@ +NAME + isnull - whether a value is a null value + +SYNOPSIS + isnull(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a null value. This function will return 1 if x is + a null value, 0 otherwise. + +EXAMPLE + > mat a[2] + > print isnull(a), isnull(1) + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, islist, ismat, isnum, isobj, + isreal, isstr, issimple, istype diff --git a/help/isnum b/help/isnum new file mode 100644 index 0000000..e154e7f --- /dev/null +++ b/help/isnum @@ -0,0 +1,31 @@ +NAME + isnum - whether a value is a numeric value + +SYNOPSIS + isnum(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a numeric value. This function will return 1 if x + is a a numeric value, 0 otherwise. + +EXAMPLE + > print isnum(2.0), isnum(1), isnum("0") + 1 1 0 + + > print isnum(2i), isnum(1e20), isnum(1/3) + 1 1 1 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, islist, ismat, isnull, isobj, + isreal, isstr, issimple, istype diff --git a/help/isobj b/help/isobj new file mode 100644 index 0000000..f355a01 --- /dev/null +++ b/help/isobj @@ -0,0 +1,29 @@ +NAME + isobj - whether a value is an object + +SYNOPSIS + isobj(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is an object. This function will return 1 if x is + an object, 0 otherwise. + +EXAMPLE + > obj surd {a, b} a; + > print isobj(a), isobj(1) + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, islist, ismat, isnull, isnum, + isreal, isstr, issimple, istype diff --git a/help/isodd b/help/isodd new file mode 100644 index 0000000..a59ea79 --- /dev/null +++ b/help/isodd @@ -0,0 +1,30 @@ +NAME + isodd - whether a value is an odd integer + +SYNOPSIS + isodd(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is an odd integer. This function will return 1 if x is + odd integer, 0 otherwise. + +EXAMPLE + > print isodd(2.0), isodd(1), isodd("1") + 0 1 0 + + > print isodd(2i), isodd(1e20+1), isodd(1/3) + 0 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + iseven, isint, isnum, isodd, isreal diff --git a/help/isprime b/help/isprime new file mode 100644 index 0000000..bc23d59 --- /dev/null +++ b/help/isprime @@ -0,0 +1,48 @@ +NAME + isprime - whether a small integer is prime + +SYNOPSIS + isprime(x [,err]) + +TYPES + x int + err int + + return int + +DESCRIPTION + Determine if x is is a small prime. This function will return + 1 if x is a small prime. If x is even, this function will + return 0. If x is negative or a small composite (non-prime), + 0 will be returned. + + If x is a large positive odd value and the err argument is + given, this function return err. If x is a large positive odd + value and the err argument is not given, an error will be + generated. + + Note that normally this function returns the integer 0 or 1. + If err is given and x is a large positive odd value, then err + will be returned. + +EXAMPLE + > print isprime(-3), isprime(1), isprime(2) + 0 0 1 + + > print isprime(21701), isprime(1234577), isprime(1234579) + 1 1 0 + + > print isprime(2^31-9), isprime(2^31-1), isprime(2^31+11) + 0 1 1 + + > print isprime(2^32+1, -1), isprime(3^99, 2), isprime(4^99, 2) + -1 2 0 + +LIMITS + err not given and (y is even or y < 2^32) + +LIBRARY + FLAG zisprime(ZVALUE x) (return 1 if prime, 0 not prime, -1 if >= 2^32) + +SEE ALSO + factor, lfactor, nextprime, prevprime, pfact, pix diff --git a/help/isqrt b/help/isqrt new file mode 100644 index 0000000..014c88c --- /dev/null +++ b/help/isqrt @@ -0,0 +1,26 @@ +NAME + isqrt - integer part of square root + +SYNOPSIS + isqrt(x) + +TYPES + x nonnegative real + + return nonnegative real + +DESCRIPTION + Return the greatest integer n for which n^2 <= x. + +EXAMPLE + > print isqrt(8.5), isqrt(200), isqrt(2e6), isqrt(2e56) + 2 14 1414 14142135623730950488016887242 + +LIMITS + x > 0 + +LIBRARY + NUMBER *qisqrt(NUMBER *x) + +SEE ALSO + sqrt, iroot diff --git a/help/isrand b/help/isrand new file mode 100644 index 0000000..89e0fcb --- /dev/null +++ b/help/isrand @@ -0,0 +1,28 @@ +NAME + isrand - whether a value is an additive 55 state + +SYNOPSIS + isrand(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is an additive 55 pseudo-random number generator state. + This function will return 1 if x is a file, 0 otherwise. + +EXAMPLE + > a = srand(0) + > print isrand(a), isrand(0); + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + rand, srand diff --git a/help/israndom b/help/israndom new file mode 100644 index 0000000..8356e1d --- /dev/null +++ b/help/israndom @@ -0,0 +1,30 @@ +NAME + israndom - whether a value is a Blum generator state + +SYNOPSIS + israndom(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a Blum-Blum-Shub pseudo-random number generator state. + This function will return 1 if x is a file, 0 otherwise. + + XXX - the interface to the Blum generator has not been not written. + +EXAMPLE + > a = srandom(0) + > print israndom(a), israndom(0); + 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/isreal b/help/isreal new file mode 100644 index 0000000..abc1f29 --- /dev/null +++ b/help/isreal @@ -0,0 +1,31 @@ +NAME + isreal - whether a value is a real value + +SYNOPSIS + isreal(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a real value. This function will return 1 if x + is a real value, 0 otherwise. + +EXAMPLE + > print isreal(2.0), isreal(1), isreal("0") + 1 1 0 + + > print isreal(2i), isreal(1e20), isreal(1/3) + 0 1 1 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, islist, ismat, isnull, isnum, isobj, + isstr, issimple, istype diff --git a/help/isrel b/help/isrel new file mode 100644 index 0000000..9d035d7 --- /dev/null +++ b/help/isrel @@ -0,0 +1,31 @@ +NAME + isrel - whether two values are relatively prime + +SYNOPSIS + isrel(x, y) + +TYPES + x int + y int + + return int + +DESCRIPTION + Determine if x and y are relatively prime. If gcd(x,y) == 1, then + return 1, otherwise return 0. + +EXAMPLE + > print isrel(6, 5), isrel(5, 6), isrel(-5, 6) + 1 1 1 + + > print isrel(6, 2), isrel(2, 6), isrel(-2, 6) + 0 0 0 + +LIMITS + none + +LIBRARY + BOOL zrelprime(ZVALUE x, y) + +SEE ALSO + gcd, ismult, isprime, isrel, issq diff --git a/help/isset b/help/isset new file mode 100644 index 0000000..717dc82 --- /dev/null +++ b/help/isset @@ -0,0 +1,43 @@ +NAME + isset - whether a given binary bit is set in a value + +SYNOPSIS + isset(x, y) + +TYPES + x real + y int + + return int + +DESCRIPTION + Determine if the binary bit y is set in x. If: + + x + int(---) mod 2 == 1 + 2^y + + return 1, otherwise return 0. + +EXAMPLE + > print isset(9,0), isset(9,1), isset(9,2), isset(9,3) + 1 0 0 1 + + > print isset(9,4), isset(0,0), isset(9,-1) + 0 0 0 + + > print isset(1.25, -2), isset(1.25, -1), isset(1.25, 0) + 1 0 1 + + > p = pi() + > print isset(p, 1), isset(p, -2), isset(p, -3) + 1 0 1 + +LIMITS + -2^31 < y < 2^31 + +LIBRARY + BOOL qisset(NUMBER *x, long y) + +SEE ALSO + highbit, lowbit diff --git a/help/issimple b/help/issimple new file mode 100644 index 0000000..2f1fda1 --- /dev/null +++ b/help/issimple @@ -0,0 +1,39 @@ +NAME + issimple - whether a value is a simple type + +SYNOPSIS + issimple(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a simple type. This function will return 1 if x + is a simple type, 0 otherwise. Simple types are real numbers, + complex numbers, strings and null values. + +EXAMPLE + > print issimple(2.0), issimple(1), issimple("0") + 1 1 1 + + > print issimple(2i), issimple(1e20), issimple(1/3), issimple(null()) + 1 1 1 1 + + > mat a[2] + > b = list(1,2,3) + > c = assoc() + > obj chongo {was, here} d; + > print issimple(a), issimple(b), issimple(c), issimple(d) + 0 0 0 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, islist, ismat, isnull, isnum, isobj, + isreal, isstr, istype diff --git a/help/issq b/help/issq new file mode 100644 index 0000000..a44add7 --- /dev/null +++ b/help/issq @@ -0,0 +1,34 @@ +NAME + issq - whether a value is a square + +SYNOPSIS + issq(x) + +TYPES + x real + + return int + +DESCRIPTION + Determine if x is a square. If there exists integers a, b such that: + + x == a^2 / b^2 (b != 0) + + return 1, otherwise return 0. + +EXAMPLE + > print issq(25), issq(3), issq(0) + 1 0 1 + + > print issq(4/25), issq(-4/25), issq(pi()) + 1 0 0 + +LIMITS + none + +LIBRARY + BOOL qissquare(NUMBER *x) + BOOL zissquare(ZVALUE x) + +SEE ALSO + ismult, isprime, isrel, issq diff --git a/help/isstr b/help/isstr new file mode 100644 index 0000000..1f3ad5d --- /dev/null +++ b/help/isstr @@ -0,0 +1,28 @@ +NAME + isstr - whether a value is a string + +SYNOPSIS + isstr(x) + +TYPES + x any, &any + + return int + +DESCRIPTION + Determine if x is a string. This function will return 1 if x is + a string, 0 otherwise. + +EXAMPLE + > print isstr("1"), isstr(1), isstr("") + 1 0 1 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, islist, ismat, isnull, isnum, isobj, + isreal, issimple, istype diff --git a/help/istype b/help/istype new file mode 100644 index 0000000..933a34d --- /dev/null +++ b/help/istype @@ -0,0 +1,39 @@ +NAME + istype - whether the type of a value is the same as another + +SYNOPSIS + istype(x, y) + +TYPES + x any, &any + y any, &any + + return int + +DESCRIPTION + Determine if x has the same type as y. This function will return 1 + if x and y are of the same type, 0 otherwise. + +EXAMPLE + > print istype(2, 3), istype(2, 3.0), istype(2, 2.3) + 1 1 1 + + > print istype(2, 3i), istype(2, "2"), istype(2, null()) + 0 0 0 + + > mat a[2] + > b = list(1,2,3) + > c = assoc() + > obj chongo {was, here} d; + > print istype(a,b), istype(b,c), istype(c,d) + 0 0 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + isassoc, isfile, isident, isint, islist, ismat, isnull, isnum, isobj, + isreal, isstr, issimple diff --git a/help/jacobi b/help/jacobi new file mode 100644 index 0000000..3c1d378 --- /dev/null +++ b/help/jacobi @@ -0,0 +1,62 @@ +NAME + jacobi - Jacobi symbol function + +SYNOPSIS + jacobi(x, y) + +TYPES + x integer + y integer + + return 1, -1, or 0 + +DESCRIPTION + If y is a positive odd prime and x is an integer not divisible + by y, jacobi(x,y) returns the Legendre symbol function, usually + denoted by (x/y) as if x/y were a fraction; this has the value + 1 or -1 according as x is or is not a quadratic residue modulo y. + x is a quadratic residue modulo y if for some integer u, + x = u^2 (mod y); if for all integers u, x != u^2 (mod y), x + is said to be a quadratic nonresidue modulo y. + + If y is a positive odd prime and x is divisible by y, jacobi(x,y) + returns the value 1. (This differs from the zero value usually + given in number theory books for (x/y) when x and y + are not relatively prime.) + assigned to (x/y) O + + If y is an odd positive integer equal to p_1 * p_2 * ... * p_k, + where the p_i are primes, not necessarily distinct, the + jacobi symbol function is given by + + jacobi(x,y) = (x/p_1) * (x/p_2) * ... * (x/p_k). + + where the functions on the right are Legendre symbol functions. + + This is also often usually by (x/y). + + If jacobi(x,y) = -1, then x is a quadratic nonresidue modulo y. + Equivalently, if x is a quadratic residue modulo y, then + jacobi(x,y) = 1. + + If jacobi(x,y) = 1 and y is composite, x may be either a quadratic + residue or a quadratic nonresidue modulo y. + + If y is even or negative, jacobi(x,y) as defined by calc returns + the value 0. + +EXAMPLE + > print jacobi(2,3), jacobi(2,5), jacobi(2,15) + -1 -1 1 + + > print jacobi(80,199) + 1 + +LIMITS + none + +LIBRARY + NUMBER *qjacobi(NUMBER *x, NUMBER *y) + FLAG zjacobi(ZVALUE z1, ZVALUE z2) + +SEE ALSO diff --git a/help/join b/help/join new file mode 100644 index 0000000..93be7d9 --- /dev/null +++ b/help/join @@ -0,0 +1,39 @@ +NAME + join - form a list by concatenation of specified lists + +SYNOPSIS + join(x, y, ...) + +TYPES + x, y, ... lists + + return list or null + +DESCRIPTION + For lists x, y, ..., join(x, y, ...) returns the list whose length + is the sum of the lengths of x, y, ..., in which the members of each + argument immediately follow those of the preceding argument. + The lists x, y, ... are not changed. + + If any argument is not a list, a null value is returned. + +EXAMPLE + > A = list(1, 2, 3) + > B = list(4, 5) + > join(A, B) + + list (5 elements, 5 nonzero): + [[0]] = 1 + [[1]] = 2 + [[2]] = 3 + [[3]] = 4 + [[4]] = 5 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + reverse, sort diff --git a/help/lcm b/help/lcm new file mode 100644 index 0000000..6ef3ba3 --- /dev/null +++ b/help/lcm @@ -0,0 +1,30 @@ +NAME + lcm - least common multiple of a set of rational numbers + +SYNOPSIS + lcm(x1, x2, ...) + +TYPES + x1, x2, ... rational number + + return rational number + +DESCRIPTION + Compute the least common multiple of one or more rational numbers. + + If no xi is zero, lcm(x1, x2, ...) is the least positive number v + for which v is a multiple of each xi. If at least one xi is zero, + the lcm is zero. + +EXAMPLE + > print lcm(12, -24, 30), lcm(9/10, 11/5, 4/25), lcm(2) + -120 79.2 2 + +LIMITS + none + +LIBRARY + NUMBER *qlcm(NUMBER *x1, NUMBER *x2) + +SEE ALSO + gcd diff --git a/help/lcmfact b/help/lcmfact new file mode 100644 index 0000000..428cd18 --- /dev/null +++ b/help/lcmfact @@ -0,0 +1,27 @@ +NAME + lcmfact - lcm of positive integers up to specified integer + +SYNOPSIS + lcmfact(n) + +TYPES + n positive integer + + return positive integer + +DESCRIPTION + Returns the lcm of the integers 1, 2, ..., n. + +EXAMPLE + > for (i = 1; i <= 15; i++) print lcmfact(i),:; + 1 2 6 12 60 60 420 840 2520 2520 27720 27720 360360 360360 360360 + +LIMITS + n < 2^24 + +LIBRARY + NUMBER *qlcmfact(NUMBER *n) + void zlcmfact(ZVALUE z, ZVALUE *dest) + +SEE ALSO + lcm, fact diff --git a/help/lfactor b/help/lfactor new file mode 100644 index 0000000..6058021 --- /dev/null +++ b/help/lfactor @@ -0,0 +1,34 @@ +NAME + lfactor - smallest prime factor in first specified number of primes + +SYNOPSIS + lfactor(n, m) + +TYPES + n integer + m nonnegative integer <= 203280221 (= number of primes < 2^32) + + return positive integer + +DESCRIPTION + If n >= 0 and n has a prime factor in the first m primes, + lfactor(n, m) returns the smallest such factor. + + If n < 0, -1 is returned. + +EXAMPLE + > print lfactor(35,2), lfactor(35,3), lfactor(-35, 3) + 1 5 -1 + + > print lfactor(2^32+1,115), lfactor(2^32+1,116), lfactor(2^59-1,1e5) + 1 641 179951 + +LIMITS + none + +LIBRARY + NUMBER *qlowfactor(NUMBER *n, NUMBER *count) + FULL zlowfactor(ZVALUE z, long count) + +SEE ALSO + factor diff --git a/help/list b/help/list new file mode 100644 index 0000000..c6dfa04 --- /dev/null +++ b/help/list @@ -0,0 +1,77 @@ +NAME + list - create list of specified values + +SYNOPSIS + list([x, [x, ... ]]) + +TYPES + x any, &any + + return list + +DESCRIPTION + This function returns a list that is composed of the arguments x. + If no args are given, an empty list is returned. + + 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. + +EXAMPLE + > list(2,"three",4i) + + list (3 elements, 3 nonzero): + [[0]] = 2 + [[1]] = "three" + [[2]] = 4i + + > list() + list (0 elements, 0 nonzero) + +LIMITS + none + +LIBRARY + none + +SEE ALSO + append, delete, insert, islist, pop, push, remove, rsearch, search, size diff --git a/help/ln b/help/ln new file mode 100644 index 0000000..c85a3bb --- /dev/null +++ b/help/ln @@ -0,0 +1,35 @@ +NAME + ln - logarithm function + +SYNOPSIS + ln(x [,eps]) + +TYPES + x nonzero real or complex + eps nonzero real, defaults to epsilon() + + return real or complex + +DESCRIPTION + Approximate the natural logarithm function of x by a multiple of + epsilon, the error having absolute value less than 0.75 * eps. + If n is a positive integer, ln(x, 10^-n) will usually be correct + to the n-th decimal place. + +EXAMPLE + > print ln(10, 1e-5), ln(10, 1e-10), ln(10, 1e-15), ln(10, 1e-20) + 2.30259 2.302585093 2.302585092994046 2.30258509299404568402 + + > print ln(2+3i, 1e-5), ln(2+3i, 1e-10) + 1.28247+.98279i 1.2824746787+.9827937232i + +LIMITS + x != 0 + eps > 0 + +LIBRARY + NUMBER *qln(NUMBER *x, NUMBER *eps) + COMPLEX *cln(COMPLEX *x, NUMBER *eps) + +SEE ALSO + exp, acosh, asinh, atanh diff --git a/help/lowbit b/help/lowbit new file mode 100644 index 0000000..8e98e91 --- /dev/null +++ b/help/lowbit @@ -0,0 +1,29 @@ +NAME + lowbit - index of lowest nonzero bit in binary representation of integer + +SYNOPSIS + lowbit(x) + +TYPES + x nonzero integer + + return integer + +DESCRIPTION + If x is a nonzero integer, lowbit(x) returns the index of the + lowest nonzero bit in the binary representation of abs(x). Equivalently, + lowbit(x) is the greatest integer for which x/2^n is an integer; + the binary representation of x then ends with n zero bits. + +EXAMPLE + > print lowbit(2), lowbit(3), lowbit(4), lowbit(-15), lowbit(2^27) + 1 0 2 0 27 + +LIMITS + none + +LIBRARY + long zlowbit(ZVALUE x); + +SEE ALSO + highbit, digits diff --git a/help/ltol b/help/ltol new file mode 100644 index 0000000..605ddae --- /dev/null +++ b/help/ltol @@ -0,0 +1,29 @@ +NAME + ltol - "leg to leg", third side of a right-angled triangle with + unit hypotenuse, given one other side + +SYNOPSIS + ltol(x, [,eps]) + +TYPES + x real + eps nonzero real + + return real + +DESCRIPTION + Returns sqrt(1 - x^2) to the nearest multiple of eps. + The default value for eps is epsilon(). + +EXAMPLE + > print ltol(0.4, 1e-6), hypot(0.5, 1e-6) + .6 .866025 + +LIMITS + abs(x) <= 1 + +LIBRARY + NUMBER *qlegtoleg(NUMBER *q1, *epsilon, BOOL wantneg) + +SEE ALSO + hypot diff --git a/help/makelist b/help/makelist new file mode 100644 index 0000000..02bd24e --- /dev/null +++ b/help/makelist @@ -0,0 +1,33 @@ +NAME + makelist - create a list with a specified number of null members + +SYNOPSIS + makelist(x) + +TYPES + x int + + return list + +DESCRIPTION + For non-negative integer x, makelist(x) returns a list of size x + all members of which have null value. + +EXAMPLE + > A = makelist(4) + > A + + list (4 members, 4 nonzero): + [[0]] = NULL + [[1]] = NULL + [[2]] = NULL + [[3]] = NULL + +LIMITS + 0 <= x < 2^31 + +LIBRARY + none + +SEE ALSO + modify diff --git a/help/mat b/help/mat new file mode 100644 index 0000000..ea50a68 --- /dev/null +++ b/help/mat @@ -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/help/matdim b/help/matdim new file mode 100644 index 0000000..063f67c --- /dev/null +++ b/help/matdim @@ -0,0 +1,27 @@ +NAME + matdim - matrix dimension + +SYNOPSIS + matdim(m) + +TYPES + m matrix + + return 1, 2, 3, or 4 + +DESCRIPTION + Returns the number of indices required to specify elements of the matrix. + +EXAMPLE + > mat A[3]; mat B[2,3]; mat C[1, 2:3, 4]; mat D[2, 3, 4, 5] + > print matdim(A), matdim(B), matdim(C), matdim(D) + 1 2 3 4 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/matfill b/help/matfill new file mode 100644 index 0000000..a4c8700 --- /dev/null +++ b/help/matfill @@ -0,0 +1,40 @@ +NAME + matfill - fill a matrix with specified value or values + +SYNOPSIS + mat(m, x [, y]) + +TYPES + m matrix + x any + y any + + return null + +DESCRIPTION + For any matrix m, matfill(m, x) assigns to every element of m the + value x. For a square matrix m, matfill(m, x, y) assigns the value + x to the off-diagonal elements, y to the diagonal elements. + +EXAMPLE + > mat A[3]; matfill(A, 2); print A + mat [3] (3 elements, 3 nonzero): + [0] = 2 + [1] = 2 + [2] = 2 + + > mat B[2, 1:2]; matfill(B,3,4); print B + mat [2,1:2] (4 elements, 4 nonzero): + [0,1] = 4 + [0,2] = 3 + [1,1] = 3 + [1,2] = 4 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/matmax b/help/matmax new file mode 100644 index 0000000..94055ac --- /dev/null +++ b/help/matmax @@ -0,0 +1,29 @@ +NAME + matmax - maximum value for specified index of matrix + +SYNOPSIS + matmax(m, i) + +TYPES + m matrix + i 0, 1, 2, 3 + + return integer + +DESCRIPTION + Returns the maximum value for i-th index (i counting from zero) + for the matrix m. + +EXAMPLE + > mat A[3]; mat B[1:3, -4:4, 5] + > print matmax(A,0), matmax(B,0), matmax(B,1), matmax(B,2) + 2 3 4 4 + +LIMITS + i < matdim(m) + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/matmin b/help/matmin new file mode 100644 index 0000000..bb35b98 --- /dev/null +++ b/help/matmin @@ -0,0 +1,29 @@ +NAME + matmin - minimum value for specified index of matrix + +SYNOPSIS + matmin(m, i) + +TYPES + m matrix + i 0, 1, 2, 3 + + return integer + +DESCRIPTION + Returns the minimum value for i-th index (i counting from zero) + for the matrix m. + +EXAMPLE + > mat A[3]; mat B[1:3, -4:4, 5] + > print matmin(A,0), matmin(B,0), matmin(B,1), matmin(B,2) + 0 1 -4 0 + +LIMITS + i < matdim(m) + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/matsum b/help/matsum new file mode 100644 index 0000000..91f6fc6 --- /dev/null +++ b/help/matsum @@ -0,0 +1,28 @@ +NAME + matsum - sum the elements of a matrix + +SYNOPSIS + matsum(m) + +TYPES + m matrix with any types of elements + + return number + +DESCRIPTION + Returns the sum of the numeric (real or complex) elements of m. + Non-numeric elements are ignored. + +EXAMPLE + > mat A[2,2] = {1, 2, 3, list(1,2,3)} + print matsum(A) + 6 + +LIMITS + none + +LIBRARY + void matsum(MATRIX *m, VALUE *vres); + +SEE ALSO + XXX - fill in diff --git a/help/mattrans b/help/mattrans new file mode 100644 index 0000000..d50a4c8 --- /dev/null +++ b/help/mattrans @@ -0,0 +1,34 @@ +NAME + mattrans - matrix transpose + +SYNOPSIS + matdim(m) + +TYPES + m 2-dimensional matrix + + return 2-dimensional matrix + +DESCRIPTION + Returns the matrix whose [i,j] element is the [j,1] element of m. + +EXAMPLE + > mat A[2, 1:3] = {1,2,3,4,5,6} + > print mattrans(A) + + mat [1:3,2] (6 elements, 6 nonzero): + [1,0] = 1 + [1,1] = 4 + [2,0] = 2 + [2,1] = 5 + [3,0] = 3 + [3,1] = 6 + +LIMITS + none + +LIBRARY + MATRIX *mattrans(MATRIX *m) + +SEE ALSO + XXX - fill in diff --git a/help/max b/help/max new file mode 100644 index 0000000..4635455 --- /dev/null +++ b/help/max @@ -0,0 +1,26 @@ +NAME + max - maximum of a set of rational numbers + +SYNOPSIS + max(x1, x2, ...) + +TYPES + x1, x2, ... rational number + + return rational number + +DESCRIPTION + Compute the maximum value of a set of rational numbers. + +EXAMPLE + > print max(2), max(5, 3, 7, 2, 9), max(3.2, -0.5, 8.7, -1.2, 2.5) + 2 9 8.7 + +LIMITS + The number of arguments may not to exceed 100. + +LIBRARY + NUMBER *qmax(NUMBER *x1, NUMBER *x2) + +SEE ALSO + min diff --git a/help/meq b/help/meq new file mode 100644 index 0000000..29457e4 --- /dev/null +++ b/help/meq @@ -0,0 +1,33 @@ +NAME + meq - test for equality modulo a specifed number + +SYNOPSIS + meq(x, y, md) + +TYPES + x real + y real + md real + + return 0 or 1 + +DESCRIPTION + Returns 1 if and only if for some integer n, x - y = n * md, i.e. + x is congruent to y modulo md. + + If md = 0, this is equivalent to x == y. + + For any x, y, md, meq(x, y, md) = ismult(x - y, md). + +EXAMPLE + > print meq(5, 33, 7), meq(.05, .33, -.07), meq(5, 32, 7) + 1 1 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + mne, ismult diff --git a/help/min b/help/min new file mode 100644 index 0000000..1e7d6c7 --- /dev/null +++ b/help/min @@ -0,0 +1,26 @@ +NAME + min - minimum of a set of rational numbers + +SYNOPSIS + min(x1, x2, ...) + +TYPES + x1, x2, ... rational number + + return rational number + +DESCRIPTION + Compute the minimum value of a set of rational numbers. + +EXAMPLE + > print min(2), min(5, 3, 7, 2, 9), min(3.2, -0.5, 8.7, -1.2, 2.5) + 2 2 -1.2 + +LIMITS + The number of arguments may not to exceed 100. + +LIBRARY + NUMBER *qmin(NUMBER *x1, NUMBER *x2) + +SEE ALSO + max diff --git a/help/minv b/help/minv new file mode 100644 index 0000000..e5abe82 --- /dev/null +++ b/help/minv @@ -0,0 +1,47 @@ +NAME + minv - inverse of an integer modulo a specified integer + +SYNOPSIS + minv(x, md) + +TYPES + x integer + md integer + + return integer + +DESCRIPTION + If x and md are not relatively prime, zero is returned. + Otherwise v = minv(x, md) is the canonical residue v modulo md + for which v * x is congruent to 1 modulo md. The canonical + residues modulo md are determined as follows by md and bits 0, 2 + and 4 of config("mod") (other bits are ignored). + + config("mod") md > 0 md < 0 + + 0 0 < v < md md < v < 0 + 1 -md < v < 0 0 < v < -md + 4 0 < v < md 0 < v < -md + 5 -md < v < 0 md < v < 0 + 16 -md/2 < v <= md/2 md/2 <= v < -md/2 + 17 -md/2 <= v < md/2 md/2 < v <= -md/2 + 20 -md/2 < v <= md/2 md/2 < v <= -md/2 + 21 -md/2 <= v < md/2 md/2 <= v < -md/2 + +EXAMPLE + > c = config("mod", 0) + > print minv(3,10), minv(-3,10), minv(3,-10), minv(-3,-10), minv(4,10) + 7 3 -3 -7 0 + + > c = config("mod",16) + > print minv(3,10), minv(-3,10), minv(3,-10), minv(-3,-10), minv(4,10) + -3 3 -3 3 0 + +LIMITS + none + +LIBRARY + NUMBER *qminv(NUMBER *x, NUMBER *md) + +SEE ALSO + mod, pmod diff --git a/help/mmin b/help/mmin new file mode 100644 index 0000000..609b4bf --- /dev/null +++ b/help/mmin @@ -0,0 +1,37 @@ +NAME + mmin - least-absolute-value residues modulo a specified number + +SYNOPSIS + mmin(x, md) + +TYPES + x number (real or complex), matrix, list, object + md real + + return real + +DESCRIPTION + If x is real and md is nonzero, mmin(x, md) returns the real + number v congruent to x modulo md for which abs(v) <= md/2 + and if abs(v) = md/2, then v = md/2. + + If x is real and md is zero, mmin(x, md) returns x. + + For complex, matrix, list or object x, see the help file for mod: for + all x and md, mmin(x, md) returns the same as mod(x, md, 16). + +EXAMPLE + > print mmin(3,6), mmin(4,6), mmin(5,6), mmin(6,6), mmin(7,6) + 3 -2 -1 0 1 + + > print mmin(1.25, 2.5), mmin(-1.25,2.5), mmin(1.25, -2.5) + 1.25 1.25 -1.25 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + mod diff --git a/help/mne b/help/mne new file mode 100644 index 0000000..a4f9eca --- /dev/null +++ b/help/mne @@ -0,0 +1,29 @@ +NAME + mne - test for inequality of real numbers modulo a specifed number + +SYNOPSIS + mne(x, y, md) + +TYPES + x real number + y real number + md real number + + return 0 or 1 + +DESCRIPTION + Returns 1 if and only if x is not congruent to y modulo md, i.e. + for every integer n, x - y != n * md. + +EXAMPLE + print mne(5, 33, 7), mne(5, -23, 7), mne(5, 15, 7), mne(5, 7, 0) + 0 0 1 1 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + meq diff --git a/help/mod b/help/mod new file mode 100644 index 0000000..807b467 --- /dev/null +++ b/help/mod @@ -0,0 +1,112 @@ +NAME + mod - compute the remainder for an integer quotient + +SYNOPSIS + mod(x, y, rnd) + x % y + +TYPES + If x is a matrix or list, the returned value is a matrix or list v of + the same structure for which each element v[[i]] = mod(x[[i]], y, rnd). + + If x is an xx-object or x is not an object and y is an xx-object, + this function calls the user-defined function xx_mod(x, y, rnd); + the types of arguments and returned value are as required by the + definition of xx_mod(). + + If neither x nor y is an object, or x is not a matrix or list: + + x number (real or complex) + y real + rnd integer, defaults to config("mod") + + return number + +DESCRIPTION + If x is real or complex and y is zero, mod(x, y, rnd) returns x. + + If x is complex, mod(x, y, rnd) returns + mod(re(x), y, rnd) + mod(im(x), y, rnd) * 1i. + + In the following it is assumed x is real and y is nonzero. + + If x/y is an integer mod(x, y, rnd) returns zero. + + If x/y is not an integer, mod(x, y, rnd) returns one of the two numbers + r for which for some integer q, x = q * v + r and abs(r) < abs(y). + Which of the two numbers is returned is controlled by rnd. + + If bit 4 of rnd is set (e.g. if 16 <= rnd < 32) abs(r) <= abs(y)/2; + this uniquely determines r if abs(r) < abs(y)/2. If bit 4 of rnd is + set and abs(r) = abs(y)/2, or if bit 4 of r is not set, the result for + r depends on rnd as in the following table: + + (Blank entries indicate that the description would be complicated + and probably not of much interest.) + + rnd & 15 sign of r parity of q + + 0 sgn(y) + 1 -sgn(y) + 2 sgn(x) + 3 -sgn(x) + 4 + + 5 - + 6 sgn(x/y) + 7 -sgn(x/y) + 8 even + 9 odd + 10 even if x/y > 0, otherwise odd + 11 odd if x/y > 0, otherwise even + 12 even if y > 0, otherwise odd + 13 odd if y > 0, otherwise even + 14 even if x > 0, otherwise odd + 15 odd if x > 0, otherwise even + + This dependence on rnd is consistent with quo(x, y, rnd) and + appr(x, y, rnd) in that for any real x and y and any integer rnd, + + x = y * quo(x, y, rnd) + mod(x, y, rnd). + mod(x, y, rnd) = x - appr(x, y, rnd) + + If y and rnd are fixed and mod(x, y, rnd) is to be considered as + a canonical residue of x modulo y, bits 1 and 3 of rnd should be + zero: if 0 <= rnd < 32, it is only for rnd = 0, 1, 4, 5, 16, 17, + 20, or 21, that the set of possible values for mod(x, y, rnd) + form an interval of length y, and for any x1, x2, + + mod(x1, y, rnd) = mod(x2, y, rnd) + + is equivalent to: + + x1 is congruent to x2 modulo y. + + This is particularly relevant when working with the ring of + integers modulo an integer y. + +EXAMPLE + > print mod(11,5,0), mod(11,5,1), mod(-11,5,2), mod(-11,-5,3) + 1 -4 -1 4 + + > print mod(12.5,5,16), mod(12.5,5,17), mod(12.5,5,24), mod(-7.5,-5,24) + 2.5 -2.5 2.5 2.5 + + > A = list(11,13,17,23,29) + > print mod(A,10,0) + + list (5 elements, 5 nonzero): + [[0]] = 1 + [[1]] = 3 + [[2]] = 7 + [[3]] = 3 + [[4]] = 9 + +LIMITS + none + +LIBRARY + void modvalue(VALUE *x, VALUE *y, VALUE *rnd, VALUE *result) + NUMBER *qmod(NUMBER *y, NUMBER *y, long rnd) + +SEE ALSO + quo, quomod, //, % diff --git a/help/modify b/help/modify new file mode 100644 index 0000000..c00f980 --- /dev/null +++ b/help/modify @@ -0,0 +1,41 @@ +NAME + modify - modify a list or matrix by changing the values of its elements + +SYNOPSIS + modify(x, y) + +TYPES + x lvalue with list or matrix value + y string + + return null value + +DESCRIPTION + For modify(x, y), y is to be the name fname of a user-defined function. + The value of each element of x is replaced by the value of the + function at that value, i.e. if fname = "f", the value of x[[i]] + is changed to f(x[[i]]). + + As the name indicates, modify(x) usually changes x values of elements + in x. To obtain a modified copy of x without changing values in x, + one may xmod = x; modify(xmod, y) or more simply (xmod = x, y). + +EXAMPLE + > define f(x) = x^2 + > A = list(2,4,6) + > modify(A, "f") + > print A + + list (3 elements, 3 nonzero): + [[0]] = 4 + [[1]] = 16 + [[3]] = 36 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + makelist diff --git a/help/near b/help/near new file mode 100644 index 0000000..ef4faa0 --- /dev/null +++ b/help/near @@ -0,0 +1,31 @@ +NAME + near - compare nearness of two numbers with a standard + +SYNOPSIS + near(x, y [,eps]) + +TYPES + x real + y real + eps real, defaults to epsilon() + + return -1, 0 or 1 + +DESCRIPTION + Returns: + -1 if abs(x - y) < abs(eps) + 0 if abs(x - y) = abs(eps) + 1 if abs(x - y) > abs(eps) + +EXAMPLE + > print near(22/7, 3.15, .01), near(22/7, 3.15, .005) + -1 1 + +LIMITS + eps >= 0 + +LIBRARY + FLAG qnear(NUMBER *x, NUMBER *y, NUMBER *eps) + +SEE ALSO + epsilon, abs diff --git a/help/newerror b/help/newerror new file mode 100644 index 0000000..51212ba --- /dev/null +++ b/help/newerror @@ -0,0 +1,39 @@ +NAME + newerror - create a new error type + +SYNOPSIS + newerror([str]) + +TYPES + str non-null string + + return error-value + +DESCRIPTION + With or without an argument, newerror() creates an error-value + different from already existing error-values. With the argument + str, if x == newerror(str), strerror(iserror(x)) returns str. + +EXAMPLE + > e1 = newerror("Non-positive side") + > e2 = newerror("Non-triangle sides") + + > define area(a,b,c) {\ + > local s;\ + > if (!(a > 0) || !(b > 0) || !(c > 0)) return e1;\ + > s = (a + b + c)/2;\ + > if (s <= a || s <= b || s <= c) return e2;\ + > return sqrt(s * (s - a) * (s - b) * (s - c)); } + + > print strerror(iserror(area(8,2,5))) + + Non-triangle sides + +LIMITS + none - XXX - is this correct? + +LIBRARY + none + +SEE ALSO + errorcodes, iserror, error diff --git a/help/nextcand b/help/nextcand new file mode 100644 index 0000000..18395c0 --- /dev/null +++ b/help/nextcand @@ -0,0 +1,76 @@ +NAME + nextcand - next candidate for primeness + +SYNOPSIS + nextcand(n [,count [, skip [, residue [,modulus]]]]) + +TYPES + n integer + count integer with absolute value less than 2^24, defaults to 1 + skip integer. defaults to 1 + residue integer, defaults to 0 + modulus integer, defaults to 1 + + return integer + +DESCRIPTION + If modulus is nonzero, nextcand(n, count, skip, residue, modulus) + returns the least integer i greater than abs(n) expressible as + residue + k * modulus, where k is an integer, for which + ptest(i,count,skip) == 1, or if there is no such integer, zero. + + If abs(n) < 2^32, count >= 0, and the returned value i is not zero, then + i is definitely prime. If count is not zero and the returned + value i is greater than 2^32, then i is probably prime, particularly + if abs(count) > 1. + + If skip == 0, and abs(n) >= 2^32 or count < 0, the probabilistic test with + random bases is used so that if n is composite the + probability that it passes ptest() is less than 4^-abs(count). + In any case, if the integer returned by nextcand() is not zero, + all integers between abs(n) and that integer are composite. + + If skip == 1 (the default value), the bases used in the probabilistic + test are the first abs(count) primes 2, 3, 5, ... + + For other values of skip, the bases used in the probabilistic tests + are the abs(count) consecutive integers, skip, skip + 1, skip + 2, ... + + If modulus is zero, the value returned is that of residue if this is + greater than abs(n) and ptest(residue,count,skip) = 1. Otherwise + zero is returned. + +RUNTIME + The runtime for v = nextcand(n, ...) will depend strongly on the + number and nature of the integers between n and v. If this number + is reasonably large the size of count is largely irrelevant as the + compositeness of the numbers betweeen n and v will usually be + determined by the test for small prime factors or one pseudoprime + test with some base b. If N > 1, count should be positive so that + candidates divisible by small primes will be passed over quickly. + + On the average for random n with large word-count N, the runtime seems + to be roughly K/N^3 some constant K. + +EXAMPLE + > print nextcand(50), nextcand(112140,-2), nextcand(112140,-3) + 53 112141 112153 + + > print nextcand(100,1,1,1,6), nextcand(100,1,1,-1,6) + 103 101 + + > print nextcand(100,1,1,2,6), nextcand(100,1,1,303,202) + 1 101 + + > print nextcand(2e60, 1, 1, 31, 1e30) + 2000000000000000000000000000053000000000000000000000000000031 + +LIMITS + none + +LIBRARY + int znextcand(ZVALUE n, long count, long skip, ZVALUE res, ZVALUE mod, + ZVALUE *cand) + +SEE ALSO + prevcand, ptest diff --git a/help/nextprime b/help/nextprime new file mode 100644 index 0000000..99dbdeb --- /dev/null +++ b/help/nextprime @@ -0,0 +1,36 @@ +NAME + nextprime - nearest prime greater than specified number + +SYNOPSIS + nextprime(n [,err]) + +TYPES + n real + err integer + + return positive integer or err + +DESCRIPTION + If n is an integer less than 2^32, nextprime(n) returns the + first prime greater than n. + + If n <= 2 or >= 2^32 or n is fractional, prevprime(n, err) + returns the value of err. + + Other cases cause a runtime error. + +EXAMPLE + > print nextprime(10), nextprime(100), nextprime(1e6) + 11 101 1000003 + + > print nextprime(3/2,-99), nextprime(2^32-1,-99), nextprime(2^32,-99) + -99 4294967311 -99 + +LIMITS + none + +LIBRARY + FULL znprime(ZVALUE z) + +SEE ALSO + prevprime diff --git a/help/norm b/help/norm new file mode 100644 index 0000000..2060d4f --- /dev/null +++ b/help/norm @@ -0,0 +1,37 @@ +NAME + norm - calculate a norm of a value + +SYNOPSIS + norm(x) + +TYPES + If x is an object of type xx, the function xx_norm has to have been + defined; what this does will be determined by the definition. + + For non-object x: + + x number (real or complex) + + return real + +DESCRIPTION + For real x, norm(x) returns: + + x^2. + + For complex x, norm(x) returns: + + re(x)^2 + im(x)^2. + +EXAMPLE + > print norm(3.4), norm(-3.4), norm(3 + 4i), norm(4 - 5i) + 11.56 11.56 25 41 + +LIMITS + none + +LIBRARY + void normvalue(VALUE *x, VALUE *result) + +SEE ALSO + cmp, epsilon, hypot, abs, near, obj diff --git a/help/null b/help/null new file mode 100644 index 0000000..1c0d1ef --- /dev/null +++ b/help/null @@ -0,0 +1,49 @@ +NAME + null - null value + +SYNOPSIS + null() + +TYPES + return null + +DESCRIPTION + There is only one value of null type. After x = null(), isnull(x) + returns 1 but isreal(x). isnum(x), etc. all return zero, and + x == y is true if and only if y is also null. The null value + tests as false in conditions. + + The null value is the value returned by some functions, e.g. + x = printf("%d\n", 27) assigns to x the null value. If L is a + list with no elements (given by L = list()), then both pop(L) + and remove(L) return the null value. + + The null value may be used as an argument in some operations, e.g. + for any x, x + null() returns x. + +EXAMPLE + In a print statement like + + print 2, null(), 3; + + or + + printf("%d %d %d\n", 2, null(), 3); + + the null value produces no output. Both of these examples + print the same as both + + print 2, null(), 3; + + and + + print "2 3"; + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - missing diff --git a/help/num b/help/num new file mode 100644 index 0000000..1c5d887 --- /dev/null +++ b/help/num @@ -0,0 +1,38 @@ +NAME + num - numerator of a real number + +SYNOPSIS + num(x) + +TYPES + x real + + return integer + +DESCRIPTION + For real x, den(x) returns the denominator of x. In calc, + real values are actually rational values. Each calc real + value can be uniquely expressed as: + + n / d + + where: + + n and d are integers + gcd(n,d) == 1 + d > 0 + + If x = n/x, then den(x) == n. + +EXAMPLE + > print num(7), num(-1.25), num(121/33) + 7 -5 11 + +LIMITS + none + +LIBRARY + NUMBER *qnum(NUMBER *x) + +SEE ALSO + den diff --git a/help/obj.file b/help/obj.file new file mode 100644 index 0000000..82f8190 --- /dev/null +++ b/help/obj.file @@ -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/help/operator b/help/operator new file mode 100644 index 0000000..3503275 --- /dev/null +++ b/help/operator @@ -0,0 +1,185 @@ +operators + + The operators are similar to C, but there are some differences + in the associativity and precedence rules for some operators. + In addition, there several operators not in C, and some C operators + are missing. Below is a list giving the operators arranged in + order of precedence, from the least tightly binding to the most + tightly binding. + + Except where otherwise indicated, operators at the same level of + precedence associate from left to right. + + Unlike C, calc has a definite order for evaluation of terms (addends + in a sum, factors in a product, arguments for a function or a + matrix, etc.). This order is always from left to right. but + skipping of terms may occur for ||, && and ? : . For example, + an expression of the form: + + A * B + C * D + + is evaluated in the following order: + + A + B + A * B + C + D + C * D + A * B + C * D + + This order of evaluation is significant if evaluation of a + term changes a variable on which a later term depends. For example: + + x++ * x++ + x++ * x++ + + returns the value of: + + x * (x + 1) + (x + 2) * (x + 3) + + and increments x as if by x += 4. Similarly, for functions f, g, + the expression: + + f(x++, x++) + g(x++) + + evaluates to: + + f(x, x + 1) + g(x + 2) + + and increments x three times. + + In A || B, B is read only if A tests as false; in A && B, B is + read only if A tests as true. Thus if x is nonzero, + x++ || x++ returns x and increments x once; if x is zero, + it returns x + 1 and increments x twice. + + + , 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. + + = += -= *= /= %= //= &= |= <<= >>= ^= **= + Assignments. As in C, these associate from right to left. + + + ? : Conditional value. + a ? b : c returns b if a tests as true (i.e. nonzero if + a is a number), 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-true?" test is meaningful for a. + As in C, this operator associates from right to left, + i.e. a ? b : c ? d : e is evaluated as a ? b : (c ? d : e). + + || Logical OR. + Unlike C, the result for a || b is one of the operands + a, b rather than one of the numbers 0 and 1. + a || b is equivalent to a ? a : b, i.e. if a tests as + true, a is returned, otherwise b. The effect in a + test like "if (a || b) ... " is the same as in C. + + && Logical AND. + Unlike C, the result for a && b is one of the operands + a, b rather than one of the numbers 0 and 1. + a && b is equivalent to a ? b : a, i.e. if a tests as + true, b is returned, otherwise a. The effect in a + test like "if (a && b) ... " is the same as in C. + + == != <= >= < > + 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/help/ord b/help/ord new file mode 100644 index 0000000..74e741f --- /dev/null +++ b/help/ord @@ -0,0 +1,26 @@ +NAME + ord - return integer corresponding to character value + +SYNOPSIS + ord(c) + +TYPES + c string + + return int + +DESCRIPTION + Return the integer value of the first character of a string. + +EXAMPLE + > print ord("DBell"), ord("chongo"), ord("/\../\"), ord("!") + 68 99 47 33 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + char diff --git a/help/overview b/help/overview new file mode 100644 index 0000000..54c1a31 --- /dev/null +++ b/help/overview @@ -0,0 +1,125 @@ + 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. + + XXX - update this file and add in new major features diff --git a/help/param b/help/param new file mode 100644 index 0000000..ea90997 --- /dev/null +++ b/help/param @@ -0,0 +1,39 @@ +NAME + param - value of argument in a user-function call + +SYNOPSIS + param(n) + +TYPES + n nonnegative integer + + return any + +DESCRIPTION + The function param(n) can be used only within the body of the + definition of a function. If that function is f() (which may + have been defined with named arguments as in f(x,y,z)) and + either the number of arguments or the value of an argument + in an anticipated call to f() is to be used, the number of + arguments in that call will then be returned by param(0), and + the value of the n-th argument by param(n). + +EXAMPLE + > define f() { + >> local n, v = 0; + >> for (n = 1; n <= param(0); n++) + >> v += param(n)^2; + >> return v; + >> } + + > print f(), f(1), f(1,2), f(1,2,3) + 0 1 5 14 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - missing diff --git a/help/perm b/help/perm new file mode 100644 index 0000000..e6fe4fe --- /dev/null +++ b/help/perm @@ -0,0 +1,38 @@ +NAME + perm - permutation number + +SYNOPSIS + perm(x, y) + +TYPES + x int + y int + + return int + +DESCRIPTION + Return the permutation number P(x,y) which is defined as: + + x! + -------- + (x-y)! + + This function computes the number of permutations in which y things + may be chosen from x items where order in which they are chosen matters. + +EXAMPLE + > print perm(7,3), perm(7,4), perm(7,5), perm(3,0), perm(0,0) + 210 840 2520 3 0 + + > print perm(2^31+1,3) + 9903520314283042197045510144 + +LIMITS + x >= y >= 0 + y < 2^24 + +LIBRARY + void zperm(NUMBER x, y, *ret) + +SEE ALSO + comb, fact diff --git a/help/pfact b/help/pfact new file mode 100644 index 0000000..e8ca912 --- /dev/null +++ b/help/pfact @@ -0,0 +1,27 @@ +NAME + pfact - product of primes up to specified integer + +SYNOPSIS + pfact(n) + +TYPES + n nonnegative integer + + return positive integer + +DESCRIPTION + Returns the product of primes p_i for which p_i <= n. + +EXAMPLE + > for (i = 0; i <= 16; i++) print pfact(i),:; + 1 1 2 6 6 30 30 210 210 210 210 2310 2310 30030 30030 30030 30030 + +LIMITS + n < 2^24 + +LIBRARY + NUMBER *qpfact(NUMBER *n) + void zpfact(ZVALUE z, ZVALUE *dest) + +SEE ALSO + fact, lcmfact diff --git a/help/pi b/help/pi new file mode 100644 index 0000000..d5f9cb1 --- /dev/null +++ b/help/pi @@ -0,0 +1,27 @@ +NAME + pi - evaluate pi to specified accuracy + +SYNOPSIS + pi([eps]) + +TYPES + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Returns a multiple of eps differing from the true value of pi by + less than 0.75 eps, and in nearly all cases by less than 0.5 eps. + +EXAMPLE + > print pi(1e-5), pi(1e-10), pi(1e-15), pi(1e-20) + 3.14159 3.1415926536 3.141592653589793 3.14159265358979323846 + +LIMITS + eps > 0 + +LIBRARY + NUMBER *qpi(NUMBER *eps) + +SEE ALSO + XXX - fill in diff --git a/help/pix b/help/pix new file mode 100644 index 0000000..2d68058 --- /dev/null +++ b/help/pix @@ -0,0 +1,38 @@ +NAME + pix - number of primes not exceeding specified number + +SYNOPSIS + pix(n [,err]) + +TYPES + n real + err integer + + return nonnegative integer, or err + +DESCRIPTION + If n is fractional or n >= 2^32, pix(n) causes an error, + pix(n, err) returns the value of err. + + If n is an integer < 2^32, pix(n) returns the number of primes + (2, 3, 5, ...) less or equal to n. + +EXAMPLE + > for (i = 0; i <= 20; i++) print pix(i),:; + 0 0 1 2 2 3 3 4 4 4 4 5 5 6 6 6 6 7 7 8 8 + + > print pix(100), pix(1000), pix(1e4), pix(1e5), pix(1e6) + 25 168 1229 9592 78498 + + > print pix(2^32 - 1, -1), pix(2^32, -1) + 203280221 -1 + +LIMITS + none + +LIBRARY + long zpix(ZVALUE z) + FULL pix(FULL x) + +SEE ALSO + XXX - fill in diff --git a/help/places b/help/places new file mode 100644 index 0000000..8a63385 --- /dev/null +++ b/help/places @@ -0,0 +1,31 @@ +NAME + places - return number of decimal places + +SYNOPSIS + places(x) + +TYPES + x real + + return integer + +DESCRIPTION + If x has a finite decimal representation (with nonzero last digit), + places(x) returns the number of digits after the decimal point in this + representation; this is the least non-negative integer n for which + 10^n * x is an integer. + + If x does not have a finite decimal representation, places(x) returns -1. + +EXAMPLE + > print places(3), places(0.0123), places(3.70), places(1e-10), places(3/7) + 0 4 1 10 -1 + +LIMITS + none + +LIBRARY + long qplaces(NUMBER *x) + +SEE ALSO + digits diff --git a/help/pmod b/help/pmod new file mode 100644 index 0000000..739e10f --- /dev/null +++ b/help/pmod @@ -0,0 +1,50 @@ +NAME + pmod - integral power of an integer modulo a specified integer + +SYNOPSIS + pmod(x, n, md) + +TYPES + x integer + n nonnegative integer + md integer + + return integer + +DESCRIPTION + pmod(x, n, md) returns the integer value of the canonical residue + of x^n modulo md, where the set of canonical residues is determined + by md and bits 0, 2, and 4 of config("mod") (other bits are ignored). + + If md is zero, the value is simply x^n. + + For nonzero md, the canonical residues v modulo md are as follows: + + config("mod") md > 0 md < 0 + + 0 0 < v < md md < v < 0 + 1 -md < v < 0 0 < v < -md + 4 0 < v < md 0 < v < -md + 5 -md < v < 0 md < v < 0 + 16 -md/2 < v <= md/2 md/2 <= v < -md/2 + 17 -md/2 <= v < md/2 md/2 < v <= -md/2 + 20 -md/2 < v <= md/2 md/2 < v <= -md/2 + 21 -md/2 <= v < md/2 md/2 <= v < -md/2 + +EXAMPLE + > c = config("mod",0) + > print pmod(2,3,10), pmod(2,5,10), pmod(2,3,-10), pod(2,5,-10) + 8 2 -2 -8 + + > c = config("mod",16) + > print pmod(2,3,10), pmod(2,5,10), pmod(2,3,-10), pmod(2,5,-10) + -2 2 -2 2 + +LIMITS + none + +LIBRARY + NUMBER *qpowermod(NUMBER *x, NUMBER *n, NUMBER *md) + +SEE ALSO + mod, minv diff --git a/help/polar b/help/polar new file mode 100644 index 0000000..a435213 --- /dev/null +++ b/help/polar @@ -0,0 +1,35 @@ +NAME + polar - specify a complex number by modulus (radius) and argument (angle) + +SYNOPSIS + polar(r, t [, eps]) + +TYPES + r real + t real + eps nonzero real, defaults to epsilon() + + return number (real or complex) + +DESCRIPTION + Returns the real or complex number with real and imaginary parts + multiples of epps nearest or next to nearest to r * cos(t) and + r * sin(t) respectively. The error for each part will be less + than 0.75 * abs(eps), but usually less than 0.5 * abs(eps). + +EXAMPLE + > print polar(2, 0), polar(1, 2, 1e-5), polar(1, 2, 1e-10) + 2 -.41615+.9093i -.4161468365+.9092974268i + + > pi = pi(1e-10); eps = 1e-5 + > print polar(2, pi/4, eps), polar(2, pi/2, eps), polar(2, 3*pi/4, eps) + 1.41421+1.41421i 2i -1.414215+1.41421i + +LIMITS + none + +LIBRARY + COMPLEX * cpolar(NUMBER *r, NUMBER *t, NUMBER *eps); + +SEE ALSO + abs, arg, re, im diff --git a/help/poly b/help/poly new file mode 100644 index 0000000..1f6a087 --- /dev/null +++ b/help/poly @@ -0,0 +1,137 @@ +NAME + poly - evaluate a polynomial + +SYNOPSIS + poly(a, b, ..., x) + poly(clist, x, y, ...) + +TYPES + For first case: + + a, b, ... Arithmetic + + x Arithmetic + + return Depends on argument types + + For second case: + + clist List of coefficients + + x, y, ... Coefficients + + return Depends on argument types + + Here an arithmetic type is one for which the required + and * + operations are defined, e.g. real or complex numbers or square + matrices of the same size. A coefficient is either of arithmetic + type or a list of coefficients. + +DESCRIPTION + If the first argument is not a list, and the necessary operations are + defined: + + poly(a_0, a_1, ..., a_n, x) + + returns the value of: + + a_n + (a_n-1 + ... + (a_1 + a_0 * x) * x ...) * x + + If the coefficients a_0, a_1, ..., a_n and x are elements of a + commutative ring, e.g. if the coefficients and x are real or complex + numbers, this is the value of the polynomial: + + a_0 * x^n + a_1 * x^(n-1) + ... + a_(n-1) * x + a_n. + + For other structures (e.g. if addition is not commutative), + the order of operations may be relevant. + + In particular: + + poly(a, x) returns the value of a. + + poly(a, b, x) returns the value of b + a * x + + poly(a, b, c, x) returns the value of c + (b + a * x) * x + + + If the first argument is a list as if defined by: + + clist = list(a_0, a_1, ..., a_n) + + and the coefficients a_i and x are are of arithmetic type, + poly(clist, x) returns: + + a_0 + (a_1 + (a_2 + ... + a_n * x) * x) + + which for a commutative ring, expands to: + + a_0 + a_1 * x + ... + a_n * x^n. + + If clist is the empty list, the value returned is the number 0. + + Note that the order of the coefficients for the list case is the + reverse of that for the non-list case. + + If one or more elements of clist is a list and there are more than + one arithmetic arguments x, y, ..., the coefficient corresponding + to such an element is the value of poly for that list and the next + argument in x, y, ... For example: + + poly(list(list(a,b,c), list(d,e), f), x, y) + + returns: + + (a + b * y + c * y^2) + (d + e * y) * x + f * x^2. + + Arguments in excess of those required for clist are ignored, e.g.: + + poly(list(1,2,3), x, y) + + returns the same as poly(list(1,2,3), x). If the number of + arguments is less than greatest depth of lists in clist, the + "missing" arguments are deemed to be zero. E.g.: + + poly(list(list(1,2), list(3,4), 5), x) + + returns the same as: + + poly(list(1, 3, 5), x). + + If in the clist case, one or more of x, y, ... is a list, the + arguments to be applied to the polynomial are the successive + non-list values in the list or sublists. For example, if the x_i + are not lists: + + poly(clist, list(x_0, x_1), x_2, list(list(x_3, x_4), x_5)) + + returns the same as: + + poly(clist, x_0, x_1, x_2, x_3, x_4, x_5). + +EXAMPLE + > print poly(2, 3, 5, 7), poly(list(5, 3, 2), 7), 5 + 3 * 7 + 2 * 7^2 + 124 124 124 + + > mat A[2,2] = {1,2,3,4} + > mat I[2,2] = {1,0,0,1} + print poly(2 * I, 3 * I, 5 * I, A) + + mat [2,2] (4 elements, 4 nonzero) + [0,0] = 22 + [0,1] = 26 + [1,0] = 39 + [1,1] = 61 + + > P = list(list(0,0,1), list(0,2), 3); x = 4; y = 5 + > print poly(P,x,y), poly(P, list(x,y)), y^2 + 2 * y * x + 3 * x^2 + 113 113 113 + +LIMITS + The number of arguments is not to exceed 100 + +LIBRARY + BOOL evalpoly(LIST *clist, LISTELEM *x, VALUE *result); + +SEE ALSO + XXX - fill in diff --git a/help/pop b/help/pop new file mode 100644 index 0000000..16d1f20 --- /dev/null +++ b/help/pop @@ -0,0 +1,46 @@ +NAME + pop - pop a value from front of a list + +SYNOPSIS + pop(lst) + +TYPES + lst list, &list + + return any + +DESCRIPTION + This function removes index 0 and returns it. + + This function is equivalent to calling delete(lst, 0). + +EXAMPLE + > lst = list(2,"three") + + list (2 elements, 2 nonzero): + [[0]] = 2 + [[1]] = "three" + + > pop(lst) + 2 + > print lst + + list (1 elements, 1 nonzero): + [[0]] = "three" + + > pop(lst) + "three" + > print lst + list (0 elements, 0 nonzero) + > pop(lst) + > print lst + list (0 elements, 0 nonzero) + +LIMITS + none + +LIBRARY + none + +SEE ALSO + append, delete, insert, islist, list, push, remove, rsearch, search, size diff --git a/help/power b/help/power new file mode 100644 index 0000000..fdbb141 --- /dev/null +++ b/help/power @@ -0,0 +1,56 @@ +NAME + power - evaluate a numerical power to specified accuracy + +SYNOPSIS + power(x, y, [, eps]) + +TYPES + x number + x number + eps nonzero real, defaults to epsilon() + + return number + +DESCRIPTION + For real or complex x and y, power(x,y,eps) returns a real or + complex number for which the real and imaginary parts are multiples + of epsilon differing from the true real and imaginary parts of the + principal y-th power of x by less than 0.75 * abs(eps), usually by + less than 0.5 * abs(eps). If the principal y-th power of x is a + multiple of eps, it will be returned exactly. + + If y is a large integer but x^y is not large, and accuracy + represented by eps is all that is required, power(x,y,eps) may be + considerably faster than appr(x^y, eps, 24), the difference between + the two results being probably at most abs(eps). + +EXAMPLE + > print power(1.2345, 10, 1e-5), power(1.2345, 10, 1e-10) + 8.22074 8.2207405646 + + > print power(1+3i, 3, 1e-5), power(1 + 3i, 2+ 1i, 1e-5) + -26-18i -2.50593-1.39445i + + > print power(1+ 1e-30, 1e30, 1e-20) + 2.71828182845904523536 + + > print power(1i, 1i, 1e-20) + .20787957635076190855 + + > print power(exp(1, 1e-20), pi(1e-20) * 1i/2, 1e-20) + 1i + +LIMITS + If x = 0, y in power(x,y,eps) has to have positive real part, + except in the case of y = 0; power(0, 0, eps) is the multiple of + eps nearest 1. + + eps > 0 + +LIBRARY + void powervalue(VALUE *x, VALUE *y, VALUE *eps, VALUE *result) + NUMBER *qpower(NUMBER *x, NUMBER *y, NUMBER *eps) + COMPLEX *cpower(COMPLEX *x, COMPLEX *y, NUMBER *eps) + +SEE ALSO + root diff --git a/help/prevcand b/help/prevcand new file mode 100644 index 0000000..5b4ae1f --- /dev/null +++ b/help/prevcand @@ -0,0 +1,85 @@ +NAME + prevcand - previous candidate for primeness + +SYNOPSIS + prevcand(n [,count [, skip [, residue [, modulus]]]]) + +TYPES + n integer + count integer with absolute value less than 2^24, defaults to 1 + skip integer, defaults to 1 + residue integer, defaults to 0 + modulus integer, defaults to 1 + + return integer + +DESCRIPTION + The sign of n is ignored; in the following it is assumed that n >= 0. + + prevcand(n, count, skip, residue, modulus) returns the greatest + positive integer i less than abs(n) expressible as + residue + k * modulus, where k is an integer, for which + ptest(i,count,skip) == 1, or if there is no such integer i, zero. + + If n < 2^32, count >= 0, and the returned value i is not zero, i is + definitely prime. If n > 2^32, count != 0, and i is not zero, + i is probably prime, particularly if abs(count) is greater than 1. + + With the default argument values, if n > 2, prevcand(n) returns the a + probably prime integer i less than n such that every integer + between i and n is composite. + + If skip == 0, the bases used in the probabilistic test are random + and then the probability that the returned value is composite is + less than 1/4^abs(count). + + If skip == 1 (the default value) the bases used in the probabilistic + test are the first abs(count) primes 2, 3, 5, ... + + For other values of skip, the bases used are the abs(count) consecutive + integer skip, skip + 1, ... + + If modulus = 0, the only values that may be returned are zero and the + value of residue. The latter is returned if it is positive, less + than n, and is such that ptest(residue, count, skip) = 1. + +RUNTIME + The runtime for v = prevcand(n, ...) will depend strongly on the + number and nature of the integers between n and v. If this number + is reasonably large the size of count is largely irrelevant as the + compositeness of the numbers betweeen n and v will usually be + determined by the test for small prime factors or one pseudoprime + test with some base b. If N > 1, count should be positive so that + candidates divisible by small primes will be passed over quickly. + + On the average for random n with large word-count N, the runtime + seems to be between roughly K/N^3 some constant K. + +EXAMPLE + > print prevcand(50), prevcand(2), prevcand(125,-1), prevcand(125,-2) + 47 1 113 113 + + > print prevcand(100,1,1,1,6), prevcand(100,1,1,-1,6) + 97 89 + + > print prevcand(100,1,1,2,6), prevcand(100,1,1,4,6), + 2 0 + + > print prevcand(100,1,1,53,0), prevcand(100,1,1,53,106) + 53 53 + + > print prevcand(125,1,3), prevcand(125,-1,3), prevcand(125,-2,3) + 113 121 113 + + > print prevcand(2e60, 1, 1, 31, 1e30) + 1999999999999999999999999999914000000000000000000000000000031 + +LIMITS + none + +LIBRARY + int zprevcand(ZVALUE n, long count, long skip, ZVALUE res, ZVALUE mod, + ZVALUE *cand) + +SEE ALSO + nextcand, ptest diff --git a/help/prevprime b/help/prevprime new file mode 100644 index 0000000..c8ca5ce --- /dev/null +++ b/help/prevprime @@ -0,0 +1,39 @@ +NAME + prevprime - nearest prime less than specified number + +SYNOPSIS + prevprime(n [,err]) + +TYPES + n real + err integer + + return positive integer or err + +DESCRIPTION + If n is an integer and 2 < n < 2^32, prevprime(n) returns the + nearest prime less than n. + + If n <= 2 or >= 2^32 or n is fractional, prevprime(n, err) + returns the value of err. + + Other cases cause a runtime error. + +EXAMPLE + > print prevprime(10), prevprime(100), prevprime(1e6) + 7 97 999983 + + > print prevprime(2,-99), prevprime(2^32,-99) + -99 -99 + + > print prevprime(2) + pprime arg 1 is <= 2 + +LIMITS + none + +LIBRARY + FULL zpprime(ZVALUE z) + +SEE ALSO + nextprime diff --git a/help/printf b/help/printf new file mode 100644 index 0000000..de09a77 --- /dev/null +++ b/help/printf @@ -0,0 +1,127 @@ +NAME + printf - formatted print to standard output + +SYNOPSIS + printf(fmt, x_1, x_2, ...) + +TYPES + fmt string + x_1, x_2, ... any + + return null + +DESCRIPTION + The function printf() is similar to the C function with the same name. + The most significant difference is that there is no requirement + that the types of values of the arguments x_i match the + corresponding format specifier in fmt. Thus, whatver the + format specifier, a number is printed as a number, a string as + a string, a list as a list, a matrix as a matrix, an xx-object + as an xx-object, etc. + + Except when a '%' is encountered, characters of the string fmt are + printed in succession to the standard output. Occurrence of + a '%' indicates the intention to build a format specifier. + This is completed by a succession of characters as follows: + + an optional '-' + zero or more decimal digits + an optional '. followed by zero or more decimal deigits + an optional 'l' + one of the letters: d, s, c, f, e, r, o, x, b, + + If any other character is read, the '%' and any characters + between '%' and the character are ignored and no specifier is + formed. E.g. "%+f" prints as if only "f" were read; "% 10s" + prints as "10s", "%X" prints as "X", "%%" prints as "%". + + The characters in a format specifier are interpreted as follows: + + a minus sign sets the right-pad flag; + the first group of digits determines the width w; + w = 0 if there are no digits + a dot indicates the precision is to be read from the + following digits; if there is no dot, + precision = config("display"). + any digits following the . determines the precision p; + p = 0 if there are no digits + any 'l' before the final letter is ignored + the final letter determines the mode as follows: + + d, s, c current config("mode") + f real (decimal, floating point) + e exponential + r fractional + o octal + x hexadecimal + b binary + + If the number of arguments after fmt is less than the + number of format specifiers in fmt, the "missing" arguments + may be taken to be null values - these contribute nothing to the + output; if a positive width w has been specified, the effect is + to produce w spaces, e.g. printf("abc%6dxyz") prints "abc xyz". + + If i <= the number of specifiers in fmt, the value of argument x_i + is printed in the format specified by the i-th specifier. + If a positive width w has been specified and normal printing of x_i + does not include a '\n' character, what is printed will if necessary + be padded with spaces so that the length of the printed output + is at least the w. Note that control + characters like '\t', '\b' each count as one character. If + the 'right-pad' flag has been set, the padding is on the right; + otherwise it is on the left. + + If i > the number of specifiers in fmt, the value of argument x_i + does not contribute to the printing. However, as all arguments + are evaluated before printing occurs, side-effects of the + evaluation of x_i might affect the result. + + If the i-th specifier is of numerical type, any numbers in the + printing of x_i will be printed in the specified format, unless + this is modified by the printing procedure for x_i's type. Any + specified precision will be ignored except for floating-point + mode. + + In the case of floating-point (f) format the precision determines + the maximum number of decimal places to be + displayed. Other aspects of this printing may be affected by the + configuration parameters "outround", "tilde", "fullzero", "leadzero". + +EXAMPLE + > c = config("epsilon", 1e-6); c = config("display", 6); + > c = config("tilde", 1); c = config("outround", 0); + > c = config("fullzero", 0); + > fmt = "%f,%10f,%-10f,%10.4f,%.4f,%.f.\n"; + > a = sqrt(3); + > printf(fmt,a,a,a,a,a,a); + 1.732051, 1.732051,1.732051 , ~1.7320,~1.7320,~1. + + > c = config("tilde", 0); c = config("outround",24); + > c = config("fullzero", 1); + > printf(fmt,a,a,a,a,a,a); + 1.732051, 1.732051,1.732051 , 1.7321,1.7321,2. + + > mat A[4] = {sqrt(2), 3/7, "undefined", null()}; + > printf("%f%r",A,A); + mat [4] (4 elements, 4 nonzero): + [0] = 1.414214 + [1] = .428571 + [2] = "undefined" + [3] = NULL + + mat [4] (4 elements, 4 nonzero): + [0] = 707107/500000 + [1] = 3/7 + [2] = "undefined" + [3] = NULL + + +LIMITS + The number of arguments of printf() is not to exceed 100. + +LIBRARY + none + +SEE ALSO + fprintf, strprintf, print diff --git a/help/prompt b/help/prompt new file mode 100644 index 0000000..8cb6074 --- /dev/null +++ b/help/prompt @@ -0,0 +1,39 @@ +NAME + prompt - display a prompt and wait for input from terminal + +SYNOPSIS + prompt(str) + +TYPES + str string + + return string + +DESCRIPTION + When prompt(str) is called and input is from a terminal, the string + str is displayed and execution is halted until a newline ends a line + read from the input; the string formed by the characters in the line + (other than the newline) is returned as the value of prompt(). + +EXAMPLE + > x = prompt("? "); + ? 273 + > x + "273" + + > for (;;) {s = prompt("? "); if (s=="end") break; print "\t":eval(s)^2;} + ? 3 + 9 + ? 2 + 3 + 25 + ? end + > + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/ptest b/help/ptest new file mode 100644 index 0000000..f021fa4 --- /dev/null +++ b/help/ptest @@ -0,0 +1,129 @@ +NAME + ptest - probabilistic test of primality + +SYNOPSIS + ptest(n [,count [,skip]]) + +TYPES + n integer + count integer with absolute value less than 2^24, defaults to 1 + skip integer, defaults to 1 + + return 0 or 1 + +DESCRIPTION + In ptest(n, ...) the sign of n is ignored; here we assume n >= 0. + + ptest(n, count, skip) always returns 1 if n is prime; equivalently, + if 0 is returned then n is not prime. + + If n is even, 1 is returned only if n = 2. + + If count >= 0 and n < 2^32, ptest(n,...) essentially calls isprime(n) + and returns 1 only if n is prime. + + If count >= 0, n > 2^32, and n is divisible by a prime <= 101, then + ptest(n,...) returns 0. + + If count is zero, and none of the above cases have resulted in 0 being + returned, 1 is returned. + + In other cases (which includes all cases with count < 0), tests are + made for abs(count) bases b: if n - 1 = 2^s * m where m is odd, + the test for base b of possible primality is passed if b is a + multiple of n or b^m = 1 (mod n) or b^(2^j * m) = n - 1 (mod n) for + some j where 0 <= j < s; integers that pass the test are called + strong probable primes for the base b; composite integers that pass + the test are called strong pseudoprimes for the base b; ( XXX ) Since + the test for base b depends on b % n, and bases 0, 1 and n - 1 are + trivial (n is always a strong probable prime for these bases), it + is sufficient to consider 1 < b < n - 1. + + The bases for ptest(n, count, skip) are selected as follows: + + skip = 0: random in [2, n-2] + skip = 1: successive primes 2, 3, 5, ... + not exceeding min(n, 65536) + otherwise: successive integers skip, skip + 1, ..., + skip+abs(count)-1 + + In particular, if m > 0, ptest(n, -m, 2) == 1 shows that n is either + prime or a strong pseudoprime for all positive integer bases <= m + 1. + If 1 < b < n - 1, ptest(n, -1, b) == 1 if and only if n is + a strong pseudoprime for the base b. + + For the random case (skip = 0), the probability that any one test + with random base b will return 1 if n is composite is always + less than 1/4, so with count = k, the probability is less + than 1/4^k. For most values of n the probability is much + smaller, possible zero. + +RUNTIME + If n is composite, ptest(n, 1, skip) is usually faster than + ptest(n, -1, skip), much faster if n is divisible by a small + prime. If n is prime, ptest(n, -1, skip) is usually faster than + ptest(n, 1, skip), possibly much faster if n < 2^32, only slightly + faster if n > 2^32. + + If n is a large prime (say 50 or more decimal digits), the runtime + for ptest(n, count, skip) will usually be roughly K * abs(count) * + ln(n)^3 for some constant K. ( XXX ) For composite n with + highbit(n) = N, the compositeness is detected quickly if n is + divisible by a small prime and count >= 0; otherwise, if count is + not zero, usually only one test is required to establish + compositeness, so the runtime will probably be about K * N^3. For + some rare values of composite n, high values of count may be + required to establish the compositeness. + + If the word-count for n is less than conf("redc2"), REDC algorithms + are used in evaluating ptest(n, count, skip) when small-factor + cases have been eliminated. For small word-counts (say < 10) + this may more than double the speed of evaluation compared with + the standard algorithms. + +EXAMPLE + > print ptest(103^3 * 3931, 0), ptest(4294967291,0) + 1 1 + + In the first example, the first argument > 2^32; in the second the + first argument is the largest prime less than 2^32. + + > print ptest(121,-1,2), ptest(121,-1,3), ptest(121,-2,2) + 0 1 0 + + 121 is the smallest strong pseudoprime to the base 3. + + > x = 151 * 751 * 28351 + > print x, ptest(x,-4,1), ptest(x,-5,1) + 3215031751 1 0 + + The integer x in this example is the smallest positive integer that is + a strong pseudoprime to each of the first four primes 2, 3, 5, 7, but + not to base 11. The probability that ptest(x,-1,0) will return 1 is + about .23. + + > for (i = 0; i < 11; i++) print ptest(91,-1,0),:; print; + 0 0 0 1 0 0 0 0 0 0 1 + + The results for this example depend on the state of the + random number generator; the expectation is that 1 will occur twice. + + > a = 24444516448431392447461 * 48889032896862784894921; + > print ptest(a,11,1), ptest(a,12,1), ptest(a,20,2), ptest(a,21,2) + 1 0 1 0 + + These results show that a is a strong pseudoprime for all 11 prime + bases less than or equal to 31, and for all positive integer bases + less than or equal to 21, but not for the bases 37 and 22. The + probability that ptest(a,-1,0) (or ptest(a,1,0)) will return 1 is + about 0.19. + +LIMITS + none + +LIBRARY + BOOL qprimetest(NUMBER *n, NUMBER *count, NUMBER *skip) + BOOL zprimetest(ZVALUE n, long count, long skip) + +SEE ALSO + isprime, prevcand, nextcand diff --git a/help/push b/help/push new file mode 100644 index 0000000..e065e22 --- /dev/null +++ b/help/push @@ -0,0 +1,55 @@ +NAME + push - push one or more values into the front of a list + +SYNOPSIS + push(x, y_0, y_1, ...) + +TYPES + x lvalue whose value is a list + y_0, ... any + + return null value + +DESCRIPTION + If after evaluation of y_0, y_1, ..., x is a list with + contents (x_0, x_1, ...), then after push(x, y_0, y_1, ..., y_n-1), + x has contents (y_n-1, ..., y_1, y_0, x_0, x_1, ...), i.e. the + values of y_0, y_1, ... are inserted in succession at the beginning + of the list. + + This function is equivalent to insert(x, 0, y_n-1, ..., y_1, y_0). + +EXAMPLE + > A = list(2,"three") + > print A + + list (2 elements, 2 nonzero): + [[0]] = 2 + [[1]] = "three" + + > push(A, 4i, 7^2) + > print A + + list (4 elements, 4 nonzero): + [[0]] = 49 + [[1]] = 4i + [[2]] = 2 + [[3]] = "three" + + > push (A, pop(A), pop(A)) + > print A + + list (4 elements, 4 nonzero): + [[0]] = 4i + [[1]] = 49 + [[2]] = 2 + [[3]] = "three" + +LIMITS + push() can have at most 100 arguments + +LIBRARY + none + +SEE ALSO + append, delete, insert, islist, list, pop, remove, rsearch, search, size diff --git a/help/putenv b/help/putenv new file mode 100644 index 0000000..e8c9843 --- /dev/null +++ b/help/putenv @@ -0,0 +1,48 @@ +NAME + putenv - set the value of an environment variable + +SYNOPSIS + putenv(env [,val]) + +TYPES + env str + val str + + return int + +DESCRIPTION + This function will set or change the value of an environment variable. + Zero is returned if the environment variable was successfully set, + otherwise a non-zero result is returned. + + When called with 1 arg, env must be a string of the form: + + "envname=envval" + + This sets the environment variable "envname" to the value "envval". + + The 2 arg form is equivalent to: + + putenv(strcat(env, "=", val)) + + +EXAMPLE + > putenv("name", "value") + 0 + > getenv("name") + "value" + > putenv("name=val2") + 0 + > getenv("name") + "val2" + > isnull(getenv("unknown")) + 1 + +LIMITS + With 1 arg, env must contain at least 1 '=' character. + +LIBRARY + none + +SEE ALSO + getenv diff --git a/help/quo b/help/quo new file mode 100644 index 0000000..eb13182 --- /dev/null +++ b/help/quo @@ -0,0 +1,78 @@ +NAME + quo - compute integer quotient of a value by a real number + +SYNOPSIS + quo(x, y, rnd) or x // y + +TYPES + If x is a matrix or list, the returned value is a matrix or list v of + the same structure for which each element v[[i]] = quo(x[[i]], y, rnd). + + If x is an xx-object or x is not an object and y is an xx-object, + this function calls the user-defined function xx_quo(x, y, rnd); + the types of arguments and returned value are as required by the + definition of xx_quo(). + + If neither x nor y is an object, and x is not a matrix or list: + + x number (real or complex) + y real + rnd integer, defaults to config("quo") + + return number + +DESCRIPTION + If x is real or complex and y is zero, quo(x, y, rnd) returns zero. + + If x is complex, quo(x, y, rnd) returns + quo(re(x), y, rnd) + quo(im(x), y, rnd) * 1i. + + In the following it is assumed that x is real and y is nonzero. + + If x/y is an integer quo(x, y, rnd) returns x/y. + + If x is real, y nonzero and x/y is not an integer, x // y returns + one of the two integers v for which abs(x/y - v) < 1. Which + integer is returned is controlled by rnd as follows: + + rnd sign of x/y - v Description of rounding + + 0 + down, towards minus infinity + 1 - up, towards infinity + 2 sgn(x/y) towards zero + 3 -sgn(x/y) from zero + 4 sgn(y) + 5 -sgn(y) + 6 sgn(x) + 7 -sgn(x) + 8 to nearest even integer + 9 to nearest odd integer + 10 even if x/y > 0, otherwise odd + 11 odd if x/y > 0, otherwise even + 12 even if y > 0, otherwise odd + 13 odd if y > 0, otherwise even + 14 even if x > 0, otherwise odd + 15 odd if x > 0, otherwise even + + 16-31 to nearest integer when this + is uniquely determined; + otherwise, when x/y is a + half-integer, as if + rnd replaced by rnd & 15 + +EXAMPLE + print quo(11,5,0), quo(11,5,1), quo(-11,5,2), quo(-11,-5,3) + 2 3 -2 3 + + print quo(12.5,5,16), quo(12.5,5,17), quo(12.5,5,24), quo(-7.5,-5,24) + 2 3 2 2 + +LIMITS + none + +LIBRARY + void quovalue(VALUE *x, VALUE *y, VALUE *rnd, VALUE *result) + NUMBER *qquo(NUMBER *x, NUMBER *y, long rnd) + +SEE ALSO + mod, quomod, //, % diff --git a/help/quomod b/help/quomod new file mode 100644 index 0000000..290fada --- /dev/null +++ b/help/quomod @@ -0,0 +1,42 @@ +NAME + quomod - assign quotient and remainder to two variables + +SYNOPSIS + quomod(x, y, q, r) + +TYPES + x real + y real + q any + r any + + return real + +DESCRIPTION + Returns 0 or 1 according as x is or is not a multiple of y. + Let x = q * y + r where q is an integer and 0 <= r < y + This function assigns the values q and r to the variables + Q and R. If x >= 0, the results for Q and R are the same as + those given by Q = x // y, R = x % y. + + XXX - need to document relationship with "quomod" config value + +EXAMPLE + > global u, v; + > global mat M[2]; + > print quomod(13,5,u,v), u, v, quomod(15.6,5.2,M[0],M[1]), M[0], M[1]; + > 1 2 3 0 3 0 + > A = assoc(); + > print quomod(13, 5, A[1], A[2]), A[1], A[2] + > 1 2 3 + + XXX - need examples of how the "quomod" config file changes results + +LIMITS + y > 0 + +LIBRARY + BOOL qquomod(NUMBER *q1, NUMBER *q2, NUMBER **retqdiv, NUMBER **retqmod) + +SEE ALSO + //, % diff --git a/help/rand b/help/rand new file mode 100644 index 0000000..684620e --- /dev/null +++ b/help/rand @@ -0,0 +1,220 @@ +NAME + rand - additive 55 shuffle pseudo-random number generator + +SYNOPSIS + rand([[min, ] max]) + +TYPES + min integer + max integer + + return integer + +DESCRIPTION + Generate a pseudo-random number using an additive 55 shuffle generator. + We return a pseudo-random number over the half closed interval [min,max). + By default, min is 0 and max is 2^64. + + Other arg forms: + + rand() Same as rand(0, 2^64) + rand(max) Same as rand(0, max) + + The rand generator has two distinct parts, the additive 55 method + and the shuffle method. The additive 55 method is described in: + + "The Art of Computer Programming - Seminumerical Algorithms" + by Knuth, Vol 2, 2nd edition (1981), Section 3.2.2, page 27, + Algorithm A. + + The period and other properties of the additive 55 method + make it very useful to 'seed' other generators. + + The shuffle method is feed values by the additive 55 method. + The shuffle method is described in: + + "The Art of Computer Programming - Seminumerical Algorithms" + by Knuth, Vol 2, 2nd edition (1981), Section 3.2.2, page 32, + Algorithm B. + + The shuffle method is fast and serves as a fairly good standard + pseudo-random generator. If you need a fast generator and do not + need a cryptographically strong one, this generator is likely to do + the job. Casual direct use of the shuffle generator may be acceptable. + + The rand generator has a good period, and is fast. It is reasonable as + generators go, though there are better ones available. The shuffle + method has a very good period, and is fast. It is fairly good as + generators go, particularly when it is feed reasonably random + numbers. Because of this, we use feed values from the additive 55 + method into the shuffle method. + + The rand generator uses two internal tables: + + additive table - 55 entries of 64 bits used by the additive 55 method + + shuffle table - 256 entries of 64 bits used by the shuffle method + feed by the additive 55 method from the additive table + + The goals of this generator are: + + * all magic numbers are explained + + I (Landon Curt Noll) 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. + + Most of the magic constants used by this generator 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 the default additive + table. 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. + + The shuffle table size is longer than the 100 entries recommended + by Knuth. 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 low order bits. The value 256 is conveient + in that it is the size of a byte which allows for easy extraction. + + We use the upper byte of the additive 55 value to select the + shuffle table entry because it allows all of 64 bits to play a part + in the entry selection. If we were to select a lower 8 bits in the + 64 bit value, carries that proprogate above our 8 bits would not + impact the additive 55 generator output. + + 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. An internal + process called randreseed64 will effectively eliminate the human + perceptions that are noted above. + + It should be noted that the purpose of randreseed64 is 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 & perceptions + noted above. + + The randreseed64 process scrambles all 64 bit chunks 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) % m + + with the exception that: + + 0 ==> 0 (so that srand(0) acts as default) + + while maintaining a 1-to-1 and onto map. + + The randreseed64 constants 'a' and 'c' based on the linear + congruential generators found in: + + "The Art of Computer Programming - Seminumerical Algorithms" + by Knuth, Vol 2, 2nd edition (1981), Section 3.6, pages 170-171. + + We will select the randreseed64 multiplier '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 + a is prime (help keep the generators independent) + + The choice of the randreseed64 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 + gcd(a, c) == 1 (adders & multipliers will be more independent) + + The values 'a' and 'c for randreseed64 are taken 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 so that srand(0) does the + default thing. The randreseed64 would normally map as follows: + + 0 ==> 1363042948800878693 (0 ==> c) + + To overcome this, and preserve the 1-to-1 and onto map, we force: + + 0 ==> 0 + 10239951819489363767 ==> 1363042948800878693 + + One might object to the complexity of the seed scramble/mapping via + the randreseed64 process. But Calling srand(0) with the randreseed64 + process would be the same as calling srand(10239951819489363767) + 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). + + The randreseed64 process does not reduce the security of the rand + genertator. Every seed is converted into a different unique seed. + No seed is ignored or favored. + + 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 (Landon Curt Noll) 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. + + When using the a55 generator, one may select your own 55 additive + values by calling: + + srand(mat55) + + and avoid using my magic numbers. Of course, you must pick good + additive 55 values youself! + +EXAMPLE + > print srand(0), rand(), rand(), rand() + RAND state 14384206130809570460 10173010522823332484 5713611208311484212 + + > print rand(123), rand(123), rand(123), rand(123), rand(123), rand(123) + 17 104 74 47 48 46 + + > print rand(2,12), rand(2^50,3^50), rand(0,2), rand(-400000, 120000) + 11 170570393286648531699560 1 -96605 + +LIMITS + min < max + +LIBRARY + void zrand(long cnt, ZVALUE *res) + void zrandrange(ZVALUE low, ZVALUE high, ZVALUE *res) + long irand(long max) + +SEE ALSO + srand, randbit, isrand, random, srandom, israndom diff --git a/help/randbit b/help/randbit new file mode 100644 index 0000000..7175fb4 --- /dev/null +++ b/help/randbit @@ -0,0 +1,43 @@ +NAME + randbit - additive 55 shuffle pseudo-random number generator + +SYNOPSIS + randbit([x]) + +TYPES + x integer + + return integer + +DESCRIPTION + If x > 0, randbit(x) returns a pseudo-random integer in [0, 2^x), + i.e. the same as rand(2^x). If the integer returned is + + b_1 * 2^(x-1) + b_2 * 2^(x-2) + ... + b_n, + + where each b_i is 0 or 1, then b_1, b_2, ..., b_n may be + considered as a sequence of x random bits. + + If x <= 0, randbit(x) causes the random-number generator to skip + abs(x) bits, and returns abs(x). + + If x is omitted, it is assumed to have the value of 1. + + See the rand help page for details on the additive 55 shuffle + pseudo-random number generator. + +EXAMPLE + > print srand(0), randbit(20), randbit(20), randbit(20), randbit(20) + RAND state 817647 476130 944201 822573 + + > print srand(0), randbit(-20), randbit(20), randbit(-20), randbit(20) + RAND state 20 476130 20 822573 + +LIMITS + x != 0 + +LIBRARY + void zrand(long cnt, ZVALUE *res) + +SEE ALSO + srand, randbit, isrand, random, srandom, israndom diff --git a/help/randperm b/help/randperm new file mode 100644 index 0000000..0ebc4dc --- /dev/null +++ b/help/randperm @@ -0,0 +1,44 @@ +NAME + randperm - randomly permute a list or matrix + +SYNOPSIS + randperm(x) + +TYPES + x list or matrix + + return same as x + +DESCRIPTION + For a list or matrix x, randperm(x) returns a copy of x in which + the elements have been randomly permuted. The value of x is not + changed. + +EXAMPLE + > A = list(1,2,2,3,4) + > randperm(A) + + list (5 elements, 5 nonzero): + [[0]] = 4 + [[1]] = 1 + [[2]] = 2 + [[3]] = 3 + [[4]] = 2 + + > randperm(A) + + list (5 elements, 5 nonzero): + [[0]] = 2 + [[1]] = 1 + [[2]] = 4 + [[3]] = 2 + [[4]] = 3 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/rcin b/help/rcin new file mode 100644 index 0000000..56172f8 --- /dev/null +++ b/help/rcin @@ -0,0 +1,73 @@ +NAME + rcin - encode for REDC algorithms + +SYNOPSIS + rcin(x, m) + +TYPES + x integer + m odd positive integer + + return integer v, 0 <= v < m. + +DESCRIPTION + Let B be the base calc uses for representing integers internally + (B = 2^16 for 32-bit machines, 2^32 for 64-bit machines) and N the + number of words (base-B digits) in the representation of m. Then + rcin(x,m) returns the value of B^N * x % m, where the modulus + operator % here gives the least nonnegative residue. + + If y = rcin(x,m), x % m may be evaluated by x % m = rcout(y, m). + + The "encoding" method of using rcmul(), rcsq(), and rcpow() for + evaluating products, squares and powers modulo m correspond to the + formulae: + + rcin(x * y, m) = rcmul(rcin(x,m), rcin(y,m), m); + + rcin(x^2, m) = rcsq(rcin(x,m), m); + + rcin(x^k, m) = rcpow(rcin(x,m), k, m). + + Here k is any nonnegative integer. Using these formulae may be + faster than direct evaluation of x * y % m, x^2 % m, x^k % m. + Some encoding and decoding may be bypassed by formulae like: + + x * y % m = rcin(rcmul(x, y, m), m). + + If m is a divisor of B^N - h for some integer h, rcin(x,m) may be + computed by using rcin(x,m) = h * x % m. In particular, if + m is a divisor of B^N - 1 and 0 <= x < m, then rcin(x,m) = x. + For example if B = 2^16 or 2^32, this is so for m = (B^N - 1)/d + for the divisors d = 3, 5, 15, 17, ... + +RUNTIME + The first time a particular value for m is used in rcin(x, m), + the information required for the REDC algorithms is + calculated and stored for future use in a table covering up to + 5 (i.e. MAXREDC) values of m. The runtime required for this is about + two that required for multiplying two N-word integers. + + Two algorithms are available for evaluating rcin(x, m), the one + which is usually faster for small N is used when N < + config("pow2"); the other is usually faster for larger N. If + config("pow2") is set at about 200 and x has both been reduced + modulo m, the runtime required for rcin(x, m) is at most about f + times the runtime required for an N-word by N-word multiplication, + where f increases from about 1.3 for N = 1 to near 2 for N > 200. + More runtime may be required if x has to be reduced modulo m. + +EXAMPLE + Using a 64-bit machine with B = 2^32: + + > for (i = 0; i < 9; i++) print rcin(x, 9),:; print; + 0 4 8 3 7 2 6 1 5 + +LIMITS + none + +LIBRARY + void zredcencode(REDC *rp, ZVALUE z1, ZVALUE *res) + +SEE ALSO + rcout, rcmul, rcsq, rcpow diff --git a/help/rcmul b/help/rcmul new file mode 100644 index 0000000..e119c77 --- /dev/null +++ b/help/rcmul @@ -0,0 +1,62 @@ +NAME + rcmul - REDC multiplication + +SYNOPSIS + rcmul(x, y, m) + +TYPES + x integer + y integer + m odd positive integer + + return integer v, 0 <= v < m. + +DESCRIPTION + Let B be the base calc uses for representing integers internally + (B = 2^16 for 32-bit machines, 2^32 for 64-bit machines) + and N the number of words (base-B digits) in the representation + of m. Then rcmul(x,y,m) returns the value of B^-N * x * y % m, + where the inverse implicit in B^-N is modulo m + and the modulus operator % gives the least non-negative residue. + + The normal use of rcmul() may be said to be that of multiplying modulo m + values encoded by rcin() and REDC functions, as in: + + rcin(x * y, m) = rcmul(rcin(x,m), rcin(y,m), m), + + or with only one factor encoded: + + x * y % m = rcmul(rcin(x,m), y, m). + +RUNTIME + If the value of m in rcmul(x,y,m) is being used for the first time + in a REDC function, the information required for the REDC + algorithms is calculated and stored for future use, possibly + replacing an already stored valued, in a table covering up to 5 + (i.e. MAXREDC) values of m. The runtime required for this is about + two times that required for multiplying two N-word integers. + + Two algorithms are available for evaluating rcmul(x,y,m), the one + which is usually faster for small N is used when N < + config("redc2"); the other is usually faster for larger N. If + config("redc2") is set at about 90 and x and y have both been + reduced modulo m, the runtime required for rcmul(x,y,m) is at most + about f times the runtime required for an N-word by N-word + multiplication, where f increases from about 1.3 for N = 1 to near + 3 for N > 90. More runtime may be required if x and y have to be + reduced modulo m. + +EXAMPLE + Using a 64-bit machine with B = 2^32: + + > print rcin(4 * 5, 9), rcmul(rcin(4,9), rcin(5,9), 9), rcout(8, 9); + 8 8 2 + +LIMITS + none + +LIBRARY + void zredcmul(REDC *rp, ZVALUE z1, ZVALUE z2, ZVALUE *res) + +SEE ALSO + rcin, rcout, rcsq, rcpow diff --git a/help/rcout b/help/rcout new file mode 100644 index 0000000..fcd9e10 --- /dev/null +++ b/help/rcout @@ -0,0 +1,64 @@ +NAME + rcout - decode for REDC algorithms + +SYNOPSIS + rcout(x, m) + +TYPES + x integer + m odd positive integer + + return integer v, 0 <= v < m. + +DESCRIPTION + Let B be the base calc uses for representing integers internally + (B = 2^16 for 32-bit machines, 2^32 for 64-bit machines) and N the + number of words (base-B digits) in the representation of m. Then + rcout(x,m) returns the value of B^-N * x % m, where the inverse + implicit in B^-N is modulo m and the modulus operator % gives the + least non-negative residue. The functions rcin() and rcout() are + inverses of each other for all x: + + rcout(rcin(x,m), m) = rcin(rcout(x,m),m) = x % m. + + The normal use of rcout() may be said to be that of decoding + values encoded by rcin() and REDC functions, as in: + + x * y % m = rcout(rcmul(rcin(x,m),rcin(y,m),m),m), + + x^2 % m = rcout(rcsq(rcin(x,m),m),m), + + x ^ k % m = rcout(rcpow(rcin(x,m),k,m),m). + +RUNTIME + If the value of m in rcout(x,m) is being used for the first time in + a REDC function, the information required for the REDC algorithms + is calculated and stored for future use, possibly replacing an + already stored valued, in a table covering up to 5 (i.e. MAXREDC) + values of m. The runtime required for this is about two times that + required for multiplying two N-word integers. + + Two algorithms are available for evaluating rcout(x, m), the one + which is usually faster for small N is used when N < + config("pow2"); the other is usually faster for larger N. If + config("pow2") is set at about 200, and x has been reduced modulo + m, the runtime required for rcout(x, m) is at most about f times + the runtime required for an N-word by N-word multiplication, where + f increases from about 1 for N = 1 to near 2 for N > + config("pow2"). More runtime may be required if x has to be + reduced modulo m. + +EXAMPLE + Using a 64-bit machine with B = 2^32: + + > for (i = 0; i < 9; i++) print rcout(i,9),:; print; + 0 7 5 3 1 8 6 4 2 + +LIMITS + none + +LIBRARY + void zredcdecode(REDC *rp, ZVALUE z1, ZVALUE *res) + +SEE ALSO + rcout, rcmul, rcsq, rcpow diff --git a/help/rcpow b/help/rcpow new file mode 100644 index 0000000..53e7e4b --- /dev/null +++ b/help/rcpow @@ -0,0 +1,73 @@ +NAME + rcpow - REDC powers + +SYNOPSIS + rcpow(x, k, m) + +TYPES + x integer + k nonnegative integer + m odd positive integer + + return integer v, 0 <= v < m. + +DESCRIPTION + Let B be the base calc uses for representing integers internally + (B = 2^16 for 32-bit machines, 2^32 for 64-bit machines) and N the + number of words (base-B digits) in the representation of m. Then + rcpow(x,k,m) returns the value of B^-N * (B^N * x)^k % m, w here + the inverse implicit in B^-N is modulo m and the modulus operator % + gives the least nonnegative residue. Note that rcpow(x,0,m) = + rcin(1,m), rcpow(x,1,m) = x % m; rcpow(x,2,m) = rcsq(x,m). + + The normal use of rcpow() may be said to be that of finding the + encoded value of the k-th power of an integer modulo m: + + rcin(x^k, m) = rcpow(rcin(x,m), k, m), + + from which one gets: + + x^k % m = rcout(rcpow(rcin(x,m), k, m), m). + + If x^k % m is to be evaluated for the same k and m and several + values of x, it may be worth while to first evaluate: + + a = minv(rcpow(1, k, m), m); + + and use: + + x^k % m = a * rcpow(x, k, m) % m. + +RUNTIME + If the value of m in rcpow(x,k,m) is being used for the first time + in a REDC function, the information required for the REDC + algorithms is calculated and stored for future use, possibly + replacing an already stored valued, in a table covering up to 5 + (i.e. MAXREDC) values of m. The runtime required for this is about + two times that required for multiplying two N-word integers. + + Two algorithms are available for evaluating rcpow(x,k,m), the one + which is usually faster for small N is used when N < + config("redc2"); the other is usually faster for larger N. If + config("redc2") is set at about 90 and 0 <= x < m, the runtime + required for rcpow(x,k,m) is at most about f times the runtime + required for ilog2(k) N-word by N-word multiplications, where f + increases from about 1.3 for N = 1 to near 4 for N > 90. More + runtime may be required if x has to be reduced modulo m. + +EXAMPLE + Using a 64-bit machine with B = 2^32: + + > m = 1234567; + > x = 15; + > print rcout(rcpow((rcin(x,m), m - 1, m), m), pmod(x, m-1, m) + 783084 783084 + +LIMITS + none + +LIBRARY + void zredcpower(REDC *rp, ZVALUE z1, ZVALUE z2, ZVALUE *res) + +SEE ALSO + rcin, rcout, rcmul, rcsq diff --git a/help/rcsq b/help/rcsq new file mode 100644 index 0000000..866f9c0 --- /dev/null +++ b/help/rcsq @@ -0,0 +1,67 @@ +NAME + rcsq - REDC squaring + +SYNOPSIS + rcsq(x, m) + +TYPES + x integer + m odd positive integer + + return integer v, 0 <= v < m. + +DESCRIPTION + Let B be the base calc uses for representing integers internally + (B = 2^16 for 32-bit machines, 2^32 for 64-bit machines) + and N the number of words (base-B digits) in the representation + of m. Then rcsq(x,m) returns the value of B^-N * x^2 % m, + where the inverse implicit in B^-N is modulo m + and the modulus operator % gives the least non-negative residue. + + The normal use of rcsq() may be said to be that of squaring modulo m a + value encoded by rcin() and REDC functions, as in: + + rcin(x^2, m) = rcsq(rcin(x,m), m) + + from which we get: + + x^2 % m = rcout(rcsq(rcin(x,m), m), m) + + Alternatively, x^2 % m may be evaluated usually more quickly by: + + x^2 % m = rcin(rcsq(x,m), m). + +RUNTIME + If the value of m in rcsq(x,m) is being used for the first time in + a REDC function, the information required for the REDC algorithms + is calculated and stored for future use, possibly replacing an + already stored valued, in a table covering up to 5 (i.e. MAXREDC) + values of m. The runtime required for this is about two times that + required for multiplying two N-word integers. + + Two algorithms are available for evaluating rcsq(x, m), the one + which is usually faster for small N is used when N < + config("redc2"); the other is usually faster for larger N. If + config("redc2") is set at about 90 and 0 <= x < m, the runtime + required for rcsq(x, m)i is at most about f times the runtime + required for an N-word by N-word multiplication, where f increases + from about 1.1 for N = 1 to near 2.8 for N > 90. More runtime may + be required if x has to be reduced modulo m. + +EXAMPLE + Using a 64-bit machine with B = 2^32: + + > for (i = 0; i < 9; i++) print rcsq(i,9),:; print; + 0 7 1 0 4 4 0 1 7 + + > for (i = 0; i < 9; i++) print rcin((rcsq(i,9),:; print; + 0 1 4 0 7 7 0 4 1 + +LIMITS + none + +LIBRARY + void zredcsquare(REDC *rp, ZVALUE z1, ZVALUE *res) + +SEE ALSO + rcin, rcout, rcmul, rcpow diff --git a/help/re b/help/re new file mode 100644 index 0000000..a379c4d --- /dev/null +++ b/help/re @@ -0,0 +1,26 @@ +NAME + re - real part of a real or complex number + +SYNOPSIS + re(x) + +TYPES + x real or complex + + return real + +DESCRIPTION + If x = u + v * 1i where u and v are real, re(x) returns u. + +EXAMPLE + > print re(2), re(2 + 3i), re(-4.25 - 7i) + 2 2 -4.25 + +LIMITS + none + +LIBRARY + COMPLEX *cimag(COMPLEX *x) + +SEE ALSO + im diff --git a/help/remove b/help/remove new file mode 100644 index 0000000..3a5bdcf --- /dev/null +++ b/help/remove @@ -0,0 +1,50 @@ +NAME + remove - remove the last member of a list + +SYNOPSIS + remove(lst) + +TYPES + lst lvalue whose current value is a list + + return any + +DESCRIPTION + If lst has no members, remove(lst) returns the null value and does + not change lst. + + If lst has n members where n > 0, remove(lst) returns the value of + lst[[n-1]] and deletes this value from the end of the lst, so that + lst now has n - 1 members and for 0 <= i < n - 1, lst[[i]] returns + what it would have returned before the remove operation. + +EXAMPLE + > lst = list(2,"three") + + list (2 elements, 2 nonzero): + [[0]] = 2 + [[1]] = "three" + + > remove(lst) + "three" + > print lst + + list (1 elements, 1 nonzero): + [[0]] = 2 + + > remove(lst) + 2 + > print lst + list (0 elements, 0 nonzero) + > remove(lst) + > print lst + list (0 elements, 0 nonzero) + +LIMITS + none + +LIBRARY + none + +SEE ALSO + append, delete, insert, islist, list, push, pop, rsearch, search, size diff --git a/help/reverse b/help/reverse new file mode 100644 index 0000000..3883474 --- /dev/null +++ b/help/reverse @@ -0,0 +1,50 @@ +NAME + reverse - reverse a copy of a list or matrix + +SYNOPSIS + reverse(x) + +TYPES + x list or matrix + + return same type as x + +DESCRIPTION + For a list or matrix x, reverse(x) returns a list or matrix in + which the order of the elements has been reversed. The original + list or matrix x is unchanged. + + In the case of matrix x, the returned value is a matrix with + the same dimension and index limits, but the reversing is performed + as if the matrix were a linear array. + +EXAMPLE + > A = list(1, 7, 2, 4, 2) + > print reverse(A) + + list (5 elements, 5 nonzero): + [[0]] = 2 + [[1]] = 4 + [[2]] = 2 + [[3]] = 7 + [[4]] = 1 + + > mat B[2,3] = {1,2,3,4,5,6} + > print reverse(B) + + mat [2,3] (6 elements, 6 nonzero): + [0,0] = 6 + [0,1] = 5 + [0,2] = 4 + [1,0] = 3 + [1,1] = 2 + [1,2] = 1 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + join, sort diff --git a/help/rewind b/help/rewind new file mode 100644 index 0000000..b775b2f --- /dev/null +++ b/help/rewind @@ -0,0 +1,33 @@ +NAME + rewind - set position at the beginning of some or all files + +SYNOPSIS + rewind([f_1, f_2, ...]) + +TYPES + f_1, f_2, ... open file streams + + return null value or error + +DESCRIPTION + With one or more arguments f_1, ..., this function sets the + position for each f_i at the beginning. With no argument, + this operation is applied to all user-opened files. + +EXAMPLE + > f = fopen("curds","r"); + > x = fgetc(f); + > rewind(f); + > y = fgetc(f); + > print x == y + 1 + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + errno, fclose, feof, ferror, fflush, fgetc, fgetline, fgets, files, fopen, + fprintf, fputc, fputs, fseek, fsize, ftell, isfile, printf, prompt diff --git a/help/rm b/help/rm new file mode 100644 index 0000000..f005bf8 --- /dev/null +++ b/help/rm @@ -0,0 +1,26 @@ +NAME + rm - remove a file + +SYNOPSIS + rm(name) + +TYPES + name name of a file + + return nil + +DESCRIPTION + Removes a file. + +EXAMPLE + > rm("junk") + > rm("more/junk.cal") + +LIMITS + name must be a non-zero length string + +LIBRARY + none + +SEE ALSO + rmdir diff --git a/help/root b/help/root new file mode 100644 index 0000000..ce0b67c --- /dev/null +++ b/help/root @@ -0,0 +1,53 @@ +NAME + root - root of a number + +SYNOPSIS + root(x, n, [, eps]) + +TYPES + x number + n positive integer + eps nonzero real, defaults to epsilon() + + return real number + +DESCRIPTION + For real x and positive integer n, n being odd if x is negative, + root(x,n,eps) returns a multiple of eps differing from the + real n-th root of x (nonnegative if x is positive) by less than + 0.75 eps, usually by less than 0.5 eps. If the n-th root of + x is a multiple of eps, it will be returned exactly. + + For complex x and positive integer n, or negative x with positive even + n, root(x, n, eps) returns a real or complex numbers whose real + and imaginary parts are multiples of eps differing from the real + and imaginary parts of the principal n-th root of x by less than + 0.75 eps, usually by less than 0.5 eps. + + For negative x and odd n, the principal n-th root of x may be + obtained by using power(x, 1/n, eps). + +EXAMPLE + > print root(7, 4, 1e-5), root(7, 4, 1e-10), root(7, 4, 1e-15) + 1.62658 1.6265765617 1.626576561697786 + + > print root(1+3i, 3, 1e-5), root(1 + 3i, 3, 1e-10) + 1.34241+.59361i 1.3424077452+.5936127825i + + > print root(-8, 3, 1e-5), root(-8, 34, 1e-5) + -2 ~1.05853505050032399594+~.09807874962631613016i + + > print root(1i, 100, 1e-20) + .99987663248166059864+.01570731731182067575i + +LIMITS + n >= 0 + eps > 0 + +LIBRARY + void rootvalue(VALUE *x, VALUE *n, VALUE *eps, VALUE *result) + NUMBER *qroot(NUMBER *x, NUMBER *n, NUMBER *eps) + COMPLEX *qroot(COMPLEX *x, NUMBER *n, NUMBER *eps) + +SEE ALSO + power diff --git a/help/round b/help/round new file mode 100644 index 0000000..4f39200 --- /dev/null +++ b/help/round @@ -0,0 +1,123 @@ +NAME + round - round numbers to a specified number of decimal places + +SYNOPSIS + round(x [,plcs [, rnd]]) + +TYPES + If x is a matrix or a list, round(x[[i]], ...) is to return + a value for each element x[[i]] of x; the value returned will be + a matrix or list with the same structure as x. + + Otherwise, if x is an object of type tt, or if x is not an object or + number but y is an object of type tt, and the function tt_round has + to be defined; the types for x, plcs, rnd, and the returned value, if + any, are as required or specified in the definition of tt_round. + In this object case, plcs and rnd default to the null value. + + For other cases: + + x number (real or complex) + plcs integer, defaults to zero + rnd integer, defaults to config("round") + + return number + +DESCRIPTION + For real x, round(x, plcs, rnd) returns x rounded to either + plcs significant figures (if rnd & 32 is nonzero) or to plcs + decimal places (if rnd & 32 is zero). In the significant-figure + case the rounding is to plcs - ilog10(x) - 1 decimal places. + If the number of decimal places is n and eps = 10^-n, the + result is the same as for appr(x, eps, rnd). This will be + exactly x if x is a multiple of eps; otherwise rounding occurs + to one of the nearest multiples of eps on either side of x. Which + of these multiples is returned is determined by z = rnd & 31, i.e. + the five low order bits of rnd, as follows: + + z = 0 or 4: round down, i.e. towards minus infinity + z = 1 or 5: round up, i.e. towards plus infinity + z = 2 or 6: round towards zero + z = 3 or 7: round away from zero + z = 8 or 12: round to the nearest even multiple of eps + z = 9 or 13: round to the nearest odd multiple of eps + z = 10 or 14: round to nearest even or odd multiple of eps + according as x > or < 0 + z = 11 or 15: round to nearest odd or even multiple of eps + according as x > or < 0 + z = 16 to 31: round to the nearest multiple of eps when + this is uniquely determined. Otherwise + rounding is as if z is replaced by z - 16 + + For complex x: + + The real and imaginary parts are rounded as for real x; if the + imaginary part rounds to zero, the result is real. + + For matrix or list x: + + The returned values has element round(x[[i]], plcs, rnd) in + the same position as x[[i]] in x. + + For object x or plcs: + + When round(x, plcs, rnd) is called, x is passed by address so may be + changed by assignments; plcs and rnd are copied to temporary + variables, so their values are not changed by the call. + +EXAMPLES + > a = 7/32, b = -7/32 + + > print a, b + .21875 -.21875 + + > print round(a,3,0), round(a,3,1), round(a,3,2), print round(a,3,3) + .218, .219, .218, .219 + + > print round(b,3,0), round(b,3,1), round(b,3,2), print round(b,3,3) + -.219, -.218, -.218, -.219 + + > print round(a,3,16), round(a,3,17), round(a,3,18), print round(a,3,19) + .2188 .2188 .2188 .2188 + + > print round(a,4,16), round(a,4,17), round(a,4,18), print round(a,4,19) + .2187 .2188 .2187 .2188 + + > print round(a,2,8), round(a,3,8), round(a,4,8), round(a,5,8) + .22 .218 .2188 .21875 + + > print round(a,2,24), round(a,3,24), round(a,4,24), round(a,5,24) + .22 .219 .2188 .21875 + + > c = 21875 + > print round(c,-2,0), round(c,-2,1), round(c,-3,0), round(c,-3,16) + 21800 21900 21000 22000 + + > print round(c,2,32), round(c,2,33), round(c,2,56), round(c,4,56) + 21000 22000 22000 21880 + + > A = list(1/8, 2/8, 3/8, 4/8, 5/8, 6/8, 7/8) + > print round(A,2,24) + + list(7 elements, 7 nonzero): + [[0]] = .12 + [[1]] = .25 + [[3]] = .38 + [[4]] = .5 + [[5]] = .62 + [[6]] = .75 + [[7]] = .88 + +LIMITS + For non-object case: + 0 <= abs(plcs) < 2^31 + 0 <= abs(rnd) < 2^31 + +LIBRARY + void roundvalue(VALUE *x, VALUE *plcs, VALUE *rnd, VALUE *result) + MATRIX *matround(MATRIX *m, VALUE *plcs, VALUE *rnd); + LIST *listround(LIST *m, VALUE *plcs, VALUE *rnd); + NUMBER *qround(NUMBER *m, long plcs, long rnd); + +SEE ALSO + bround, btrunc, trunc, int, appr diff --git a/help/rsearch b/help/rsearch new file mode 100644 index 0000000..72934ce --- /dev/null +++ b/help/rsearch @@ -0,0 +1,38 @@ +NAME + rsearch - reverse search a matrix, list or association for a value + +SYNOPSIS + rsearch(x, val [,idx]) + +TYPES + x matrix, &matrix, list, &list, assoc, &assoc + val any, &any + idx int + + return any + +DESCRIPTION + Reverse search the matrix, list or association x for the value + val. By default, the search starts at the end. If idx is given, + the reverse search starts at index indx. + + If the value is not found, this function returns nil. + +EXAMPLE + > lst = list(2,"three",4i) + > rsearch(lst,"three") + 1 + > rsearch(lst,"threes") + > rsearch(lst, 4i, 4) + > rsearch(lst, 4i, 1) + > rsearch(lst, 4i, 3) + 2 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + assoc, list, mat, search diff --git a/help/runtime b/help/runtime new file mode 100644 index 0000000..ed3ebca --- /dev/null +++ b/help/runtime @@ -0,0 +1,31 @@ +NAME + runtime - user runtime + +SYNOPSIS + runtime() + +TYPES + return nonnegative real + +DESCRIPTION + Returns the current user mode cpu runtime in seconds. + +EXAMPLE + The result for this example will depend on the speed and number of + of clock-ticks per second for the computer being used. + The result is a multiple of 1/CLK_TCK, where CLK_TCK is + usually 60. The following is for a XXX machine. + + > t = runtime(); + > pi = pi(1e-1000); + > runtime() - t; + .2 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + ctime diff --git a/help/scale b/help/scale new file mode 100644 index 0000000..1d0690a --- /dev/null +++ b/help/scale @@ -0,0 +1,38 @@ +NAME + scale - scale a number or numbers in a value by a power of 2 + +SYNOPSIS + scale(x, n) + +TYPES + If x is an xx-object, scale(x, n) requires xx_scale() to have been + defined; conditions on x and n and the type of value returned are + determined by the definition of xx_scale(). + + For other x: + + x number (real or complex) or matrix + n integer + + return same type as x + +DESCRIPTION + Returns the value of 2^n * x. + + scale(x,n) returns the same as x << n and x >> -n if x is an integer + for which 2^n * x is an integer. + +EXAMPLE + > print scale(3, 2), scale(3,1), scale(3,0), scale(3,-1), scale(3,-2) + 12 6 3 1.5 .75 + +LIMITS + For non-object x, abs(n) < 2^31 + +LIBRARY + NUMBER *qscale(NUMBER *x, long n) + COMPLEX *cscale(COMPLEX *x, long n) + MATRIX *matscale(MATRIX *x, long n) + +SEE ALSO + XXX - fill in diff --git a/help/scan b/help/scan new file mode 100644 index 0000000..ed07822 --- /dev/null +++ b/help/scan @@ -0,0 +1,34 @@ +NAME + scan - scan standard input for possible assignment to variables + +SYNOPSIS + scan(x_1, x_2, ..., x_n) + +TYPES + x_1, x_2, ... any + + return integer + +DESCRIPTION + When input is from a terminal, execution is halted and input is read + until a newline is entered. Strings of non-whitespace characters + are evaluated in succession and if the corresponding x_i is an lvalue, + the resulting value is assigned to x_i. If the number of strings + read exceeds n, only the first n strings are evaluated. If the number + of strings is less than n, the later x_i are ignored. + +EXAMPLE + > global a, b, c, d; + > scan(a, 0, c, d) + > 2+3 b=a^2 3+4i 3+"a" + > print a,b,c,d + 5 25 3+4i Error 3 + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + fscan, strscan, fscanf, strscanf, scanf, printf, fprintf diff --git a/help/scanf b/help/scanf new file mode 100644 index 0000000..4204936 --- /dev/null +++ b/help/scanf @@ -0,0 +1,31 @@ +NAME + scanf - formatted scan of characters read from standard input + +SYNOPSIS + scanf(fmt, x_1, x_2, ...) + +TYPES + fmt string + x_1, x_2, ... lvalues + + return null, nonnegative integer, or error value + +DESCRIPTION + This does the same as fscanf(files(0), fmt, x_1, x_2, ...). + For details see fscanf. + +EXAMPLE + > global a, b, c + > scanf("%5c", a) + 1 + > a + "Alpha" + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + scan, strscan, fscanf, strscanf, scanf, printf, fprintf diff --git a/help/search b/help/search new file mode 100644 index 0000000..7965ae5 --- /dev/null +++ b/help/search @@ -0,0 +1,37 @@ +NAME + search - search a matrix, list or association for a value + +SYNOPSIS + search(x, val [,idx]) + +TYPES + x matrix, &matrix, list, &list, assoc, &assoc + val any, &any + idx int + + return any + +DESCRIPTION + Searchs the matrix, list or association x for the value val. By + default, the search starts at index 0. If idx is given, the search + starts at index indx. + + If the value is not found, this function returns nil. + +EXAMPLE + > lst = list(2,"three",4i) + > search(lst,"three") + 1 + > search(lst,"threes") + > search(lst, 4i, 4) + > search(lst, 4i, 1) + 2 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + assoc, list, mat, rsearch diff --git a/help/sec b/help/sec new file mode 100644 index 0000000..3fda9be --- /dev/null +++ b/help/sec @@ -0,0 +1,29 @@ +NAME + sec - trigonometric secant function + +SYNOPSIS + sec(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the secant of x to a multiple of eps, with error less + in absolute value than .75 * eps. + +EXAMPLE + > print sec(1, 1e-5), sec(1, 1e-10), sec(1, 1e-15), sec(1, 1e-20) + 1.85082 1.8508157177 1.850815717680926 1.85081571768092561791 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qsec(NUMBER *x, NUMBER *eps) + +SEE ALSO + sin, cos, tan, csc, cot, epsilon diff --git a/help/sech b/help/sech new file mode 100644 index 0000000..c2eb65c --- /dev/null +++ b/help/sech @@ -0,0 +1,31 @@ +NAME + sech - hyperbolic secant + +SYNOPSIS + sech(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the sech of x to the nearest or next to nearest multiple of + epsilon, with absolute error less than .75 * abs(eps). + + sech(x) = 2/(exp(x) + exp(-x)) + +EXAMPLE + > print sech(1, 1e-5), sech(1, 1e-10), sech(1, 1e-15), sech(1, 1e-20) + .64805 .6480542737 .648054273663885 .64805427366388539958 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qsech(NUMBER *x, NUMBER *eps) + +SEE ALSO + sinh, cosh, tanh, csch, coth, epsilon diff --git a/help/segment b/help/segment new file mode 100644 index 0000000..035e638 --- /dev/null +++ b/help/segment @@ -0,0 +1,46 @@ +NAME + segment - segment from and to specified elements of a list + +SYNOPSIS + segment(x, y, z) + +TYPES + x list + y, z int + + return list + +DESCRIPTION + For 0 <= y < size(x) and 0 <= z < size(x), segment(x, y, z) + returns a list for which the values of the elements are those + of the segment of x from x[[y]] to x[[z]]. If y < z, the + new list is in the same order as x; if y > z, the order is + reversed. + + If y < z, x == join(head(x,y), segment(x,y,z), tail(x, size(x) - z - 1)). + +EXAMPLE + > A = list(2, 3, 5, 7, 11) + > segment(A, 1, 3) + + list (3 members, 3 nonzero): + [[0]] = 3 + [[1]] = 5 + [[2]] = 7 + + > segment(A, 3, 1) + + list (3 members, 3 nonzero): + [[0]] = 7 + [[1]] = 5 + [[2]] = 3 + +LIMITS + 0 <= y < size(x) + 0 <= z < size(x) + +LIBRARY + none + +SEE ALSO + head, tail diff --git a/help/select b/help/select new file mode 100644 index 0000000..97156f2 --- /dev/null +++ b/help/select @@ -0,0 +1,38 @@ +NAME + select - form a list by selecting element-values from a given list + +SYNOPSIS + select(x, y) + +TYPES + x list + y string + + return list + +DESCRIPTION + If y is to be the name of a user-defined function, select(x, y) + returns a list whose members are the values z of elements of x + for which the function at z tests as nonzero. + The list x is not changed. The order of the returned list is + the same as in x. + + +EXAMPLE + > define f(x) = x > 5 + > A = list(2,4,6,8,2,7) + > print select(A, "f") + + list (3 elements, 3 nonzero): + [[0]] = 6 + [[1]] = 8 + [[2]] = 7 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/sgn b/help/sgn new file mode 100644 index 0000000..383efdb --- /dev/null +++ b/help/sgn @@ -0,0 +1,40 @@ +NAME + sign - indicator of sign of a real or complex number + +SYNOPSIS + sgn(x) + +TYPES + x real or complex + + return -1, 0, 1 (real) + -1, 0, 1, -1+1i, 1i, 1+1i, -1-1i, -1i or 1-1i (complex) + +DESCRIPTION + Return the value of cmp(a,0). + + For real x, sgn(x) returns: + -1 if x < 0 + 0 if x == 9 + 1 if x > 0 + + For complex, sgn(x) returns: + + sgn(re(x)) + sgn(im(x))*1i + + +EXAMPLE + > print sgn(27), sgn(1e-20), sgn(0), sgn(-45) + 1 1 0 -1 + + > print sgn(2+3i), sgn(6i), sgn(-7+4i), sgn(-6), sgn(-6-3i), sgn(-2i) + 1+1i 1i -1+1i -1 -1-1i -1i + +LIMITS + none + +LIBRARY + NUMBER *qsign(NUMBER *x) + +SEE ALSO + abs diff --git a/help/sin b/help/sin new file mode 100644 index 0000000..4246219 --- /dev/null +++ b/help/sin @@ -0,0 +1,36 @@ +NAME + sin - trigonometric sine + +SYNOPSIS + sin(x [,eps]) + +TYPES + x number (real or complex) + eps nonzero real, defaults to epsilon() + + return number + +DESCRIPTION + Calculate the sine of x to a multiple of eps with error less in + absolute value than .75 * eps. + +EXAMPLE + > print sin(1, 1e-5), sin(1, 1e-10), sin(1, 1e-15), sin(1, 1e-20) + .84147 .8414709848 .841470984807896 .84147098480789650665 + + > print sin(2 + 3i, 1e-5), sin(2 + 3i, 1e-10) + 9.1545-4.16891i 9.1544991469-4.16890696i + + > pi = pi(1e-20) + > print sin(pi/6, 1e-10), sin(pi/2, 1e-10), sin(pi, 1e-10) + .5 1 0 + +LIMITS + eps > 0 + +LIBRARY + NUMBER *qsin(NUMBER *x, NUMBER *eps) + COMPLEX *csin(COMPLEX *x, NUMBER *eps) + +SEE ALSO + cos, tan, sec, csc, cot, epsilon diff --git a/help/sinh b/help/sinh new file mode 100644 index 0000000..eb4e27f --- /dev/null +++ b/help/sinh @@ -0,0 +1,31 @@ +NAME + sinh - hyperbolic sine + +SYNOPSIS + sinh(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the sinh of x to the nearest or next to nearest multiple of + epsilon, with absolute error less than .75 * abs(eps). + + sinh(x) = (exp(x) - exp(-x))/2 + +EXAMPLE + > print sinh(1, 1e-5), sinh(1, 1e-10), sinh(1, 1e-15), sinh(1, 1e-20) + 1.1752 1.1752011936 1.175201193643801 1.17520119364380145688 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qsinh(NUMBER *x, NUMBER *eps) + +SEE ALSO + cosh, tanh, sech, csch, coth, epsilon diff --git a/help/size b/help/size new file mode 100644 index 0000000..8296fe2 --- /dev/null +++ b/help/size @@ -0,0 +1,50 @@ +NAME + size - number of elements in value + +SYNOPSIS + size(x) + +TYPES + x any + + return integer + +DESCRIPTION + For the different types of value x may have, size(x) is defined as follows: + + null 0 + real number 1 + complex number 1 + string 1 + matrix number of elements + list number of members + association number of (elements, value) pairs + object number of elements for the object-type of x + + +EXAMPLE + > print size(null()), size(3), size(2 - 7i), size("abc") + 0 1 1 1 + + > mat M[2,3] + > print size(M), size(list()), size(list(2,3,4)) + 6 0 3 + + > A = assoc() + > A[1] = 3, A[1,2] = 6, A["three"] = 5 + > print size(A) + 3 + + > obj point {x,y} + > obj point P = {4,5} + > print size(P) + 2 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + list, mat, assoc, obj diff --git a/help/sizeof b/help/sizeof new file mode 100644 index 0000000..516b16e --- /dev/null +++ b/help/sizeof @@ -0,0 +1,74 @@ +NAME + sizeof - number of bytes required for value + +SYNOPSIS + sizeof(x) + +TYPES + x any + + return integer + +DESCRIPTION + This is analogous to the C operator sizeof. It attempts to assess + the number of bytes in memory used to store a value and all its + components. + + The number returned by sizeof(x) may be less than the actual number + used because, for example, more memory may have been allocated for + a string than is used: only the characters up to and including the + first '\0' are counted in calculating the contribution of the + string to sizeof(x). + + The number returned by sizeof(x) may be greater (and indeed + substantially greater) than the number of bytes actually used. + For example, after: + + a = sqrt(2); + mat A[3] = {a, a, a}; + + the numerical information for a, A[0], A[1], A[2] are stored in the + same memory, so the memory used for A is the same as if + its 3 elements were null values. The value returned by + sizeof(A) is calculated as A were defined by: + + mat A[3] = {sqrt(2), sqrt(2), sqrt(2)}. + + Similar sharing of memory occurs with literal strings. + + The minimum value for sizeof(x) occurs for the null and error values. + +EXAMPLES + + The results for examples like these will depend to some extent on + the system being used. The following were for an SGI R4k machine + in 32-bit mode: + + > print sizeof(null()), sizeof(0), sizeof(3), sizeof(2^32 - 1), sizeof(2^32) + 8 68 68 68 72 + + > x = sqrt(2, 1e-100); print sizeof(x), sizeof(num(x)), sizeof(den(x)) + 148 108 108 + + > print sizeof(list()), sizeof(list(1)), sizeof(list(1,2)) + 28 104 180 + + > print sizeof(list()),sizeof(list(1)),sizeof(list(1,2)),sizeof(list(1,2,3)) + 28 104 180 256 + + > mat A[] = {1}; mat B[] = {1,2}; mat C[] = {1,2,3}; mat D[100,100]; + > print sizeof(A), sizeof(B), sizeof(C), sizeof(D) + 124 192 260 680056 + + > obj point {x,y,z} + > obj point P = {1,2,3}; print sizeof(P) + 274 + +LIMITS + It is assumed sizeof(x) will fit into a system long integer. + +LIBRARY + none + +SEE ALSO + size, fsize, strlen, digits diff --git a/help/sort b/help/sort new file mode 100644 index 0000000..514271f --- /dev/null +++ b/help/sort @@ -0,0 +1,250 @@ +NAME + sort - sort a copy of a list or matrix + +SYNOPSIS + sort(x) + +TYPES + x list or matrix + + return same type as x + +DESCRIPTION + For a list or matrix x, sort(x) returns a list or + matrix y of the same size as x in which the elements + have been sorted into order completely or partly determined by + a user-defined function precedes(a,b), or if this has not been + defined, by a default "precedes" function which for numbers or + strings is as equivalent to (a < b). More detail on this default + is given below. For most of the following discussion + it is assumed that calling the function precedes(a,b) does not + change the value of either a or b. + + If x is a matrix, the matrix returned by sort(x) has the same + dimension and index limits as x, but for the sorting, x is treated + as a one-dimensional array indexed only by the double- bracket + notation. Then for both lists and matrices, if x has size n, it + may be identified with the array: + + (x[[0]], x[[1]], ..., x[[n-1]]) + + which we will here display as: + + (x_0, x_1, ..., x_n-1). + + The value y = sort(x) will similarly be identified with: + + (y_0, y_1, ..., x_n-1), + + where, for some permutation p() of the integers (0, 1, ..., n-1): + + y_p(i) = x_i. + + In the following i1 and i2 will be taken to refer to different + indices for x, and j1 and j2 will denote p(i1) and p(i2). + + The algorithm for evaluating y = sort(x) first makes a copy of x; + x remains unchanged, but the copy may be considered as a first + version of y. Successive values a in this y are read and compared + with earlier values b using the integer-valued function precedes(); + if precedes(a,b) is nonzero, which we may consider as "true", + a is "moved" to just before b; if precedes(a,b) is zero, i.e. "false", + a remains after b. Until the sorting is completed, other similar + pairs (a,b) are compared and if and only if precedes(a,b) is true, + a is moved to before b or b is moved to after a. We may + say that the intention of precedes(a,b) being nonzero is that a should + precede b, while precedes(a,b) being zero intends that the order + of a and b is to be as in the original x. For any integer-valued + precedes() function, the algorithm will return a result for sort(x), + but to guarantee fulfilment of the intentions just described, + precedes() should satisfy the conditions: + + (1) For all a, b, c, precedes(a,b) implies precedes(a,c) || precedes (c,b), + + (2) For all a, b, precedes(a,b) implies !precedes(b,a). + + Condition (1) is equivalent to transitivity of !precedes(): + + (1)' For all a,b,c, !precedes(a,b) && !precedes(b,c) implies !precedes(a,c). + + (1) and (2) together imply transitivity of precedes(): + + (3) For all a,b,c, precedes(a,b) && precedes(b,c) implies precedes(a,c). + + Condition (2) expresses the obvious fact that if a and b are distinct + values in x, there is no permutation in which every occurrence of + a both precedes and follows every occurrence of b. + + Condition (1) indicates that if a, b, c occur + in the order b c a, moving a to before b or b to after a must change + the order of either a and c or c and b. + + Conditions (2) and (3) together are not sufficient to ensure a + result satisfying the intentions of nonzero and zero values of + precedes() as described above. For example, consider: + + precedes(a,b) = a is a proper divisor of b, + + and x = list(4, 3, 2). The only pair for which precedes(a,b) is + nonzero is (2,4), but x cannot be rearranged so that 2 is before + 4 without changing the order of one of the pairs (4,3) and (3,2). + + If precedes() does not satisfy the antisymmetry condition (2), + i.e. there exist a, b for which both precedes(a, b) + and precedes(b, a), and if x_i1 = a, x_i2 = b, whether or + not y_j1 precedes or follows y_j2 will be determined by the + sorting algorithm by methods that are difficult to describe; + such a situation may be acceptable to a user not concerned with + the order of occurrences of a and b in the result. To permit + this, we may now describe the role of precedes(a,b) by the rules: + + precedes(a,b) && !precedes(b,a): a is to precede b; + + !precedes(a,b) && !precedes(b,a): order of a and b not to be changed; + + precedes(a,b) && precedes(b,a): order of a and b may be changed. + + Under the condition (1), the result of sort(x) will accord with these rules. + + Default precedes(): + + If precedes(a,b) has not been defined by a define command, + the effect is as if precedes(a,b) were determined by: + + If a and b are are not of the same type, they are ordered by + + null values < numbers < strings < objects. + + If a and b are of the same type, this type being + null, numbers or strings, precedes(a,b) is given by (a < b). + (If a and b are both null, they are considered to be equal, so + a < b then returns zero.) For null values, numbers and + strings, this definition has the properties (1) and (2) + discussed above. + + If a and b are both xx-objects, a < b is defined to mean + xx_rel(a,b) < 0; such a definition does not + necessarily give < the properties usually expected - + transitivity and antisymmetry. In such cases, sort(x) + may not give the results expected by the "intentions" of + the comparisons expressed by "a < b". + + In many sorting applications, appropriate precedes() functions + have definitions equivalent to: + + define precedes(a,b) = (key(a) < key(b)) + + where key() maps possible values to a set totally ordered by <. + Such a precedes() function has the properties (1) and (2), + so the elements of the result returned by sort(x) will be in + nondecreasing order of their key-values, elements with equal keys + retaining the order they had in x. + + For two-stage sorting where elements are first to be sorted by + key1() and elements with equal key1-values then sorted by key2(), + an appropriate precedes() function is given by: + + define precedes(a,b) = (key(a) < key(b)) || + (key(a) == key(b)) && (key2(a) < key2(b)). + + When precedes(a.b) is called, the addresses of a and b rather + than their values are passed to the function. This permits + a and b to be changed when they are being compared, as in: + + define precedes(a,b) = ((a = round(a)) < (b = round(b))); + + (A more efficient way of achieving the same result would be to + use sort(round(x)).) + + Examples of effects of various precedes functions for sorting + lists of integers: + + a > b Sorts into nonincreasing order. + + abs(a) < abs(b) Sorts into nondecreasing order of + absolute values, numbers with the + same absolute value retaining + their order. + + abs(a) <= abs(b) Sorts into nondecreasing order of + absolute values, possibly + changing the order of numbers + with the same absolute value. + + abs(a) < abs(b) || abs(a) == abs(b) && a < b + Sorts into nondecreasing order of + absolute values, numbers with the + same absolute value being in + nondecreasing order. + + iseven(a) Even numbers in possibly changed order + before odd numbers in unchanged order. + + iseven(a) && isoddd(b) Even numbers in unchanged order before + odd numbers in unchanged order. + + iseven(a) ? iseven(b) ? a < b : 1 : 0 + Even numbers in nondecreasing order + before odd numbers in unchanged order. + + a < b && a < 10 Numbers less than 10 in nondecreasing + order before numbers not less than 10 + in unchanged order. + + !ismult(a,b) Divisors d of any integer i for which + i is not also a divisor of d will + precede occurrences of i; the order of + integers which divide each other will + remain the same; the order of pairs of + integers neither of which divides the + other may be changed. Thus occurrences + of 1 and -1 will precede all other + integers; 2 and -2 will precede all + even integers; the order of occurrences + of 2 and 3 may change; occurrences of 0 + will follow all other integers. + + 1 The order of the elements is reversed + +EXAMPLES + > A = list(1, 7, 2, 4, 2) + > print sort(A) + + list (5 elements, 5 nonzero): + [[0]] = 1 + [[1]] = 2 + [[2]] = 2 + [[3]] = 4 + [[4]] = 7 + + > B = list("pear", 2, null(), -3, "orange", null(), "apple", 0) + > print sort(B) + + list (8 elements, 7 nonzero): + [[0]] = NULL + [[1]] = NULL + [[2]] = -3 + [[3]] = 0 + [[4]] = 2 + [[5]] = "apple" + [[6]] = "orange" + [[7]] = "pear" + + > define precedes(a,b) = (iseven(a) && isodd(b)) + > print sort(A) + + list (5 elements, 5 nonzero): + [[0]] = 2 + [[1]] = 4 + [[2]] = 2 + [[3]] = 1 + [[4]] = 7 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + join, reverse diff --git a/help/sqrt b/help/sqrt new file mode 100644 index 0000000..b024935 --- /dev/null +++ b/help/sqrt @@ -0,0 +1,132 @@ +NAME + sqrt - evaluate exactly or approximate a square root + +SYNOPSIS + sqrt(x [, eps[, z]]) + +TYPES + If x is an object of type tt, or if x is not an object but y + is an object of type tt, and the user-defined function + tt_round has been defined, the types for x, y, z are as + required for tt_round, the value returned, if any, is as + specified in tt_round. For object x or y, z defaults to a + null value. + + For other argument types: + + x real or complex + eps nonzero real + z integer + + return real or complex + +DESCRIPTION + For real or complex x, sqrt(x, y, z) returns either the exact + value of a square root of x (which is possible only if this + square root is rational) or a number for which the real and + imaginary parts are either exact or the nearest below or nearest + above to the exact values. + + The argument, eps, specifies the epsilon/error value to be + used during calculations. By default, this value is epsilon(). + + The seven lowest bits of z are used to control the signs of the + result and the type of any rounding: + + z bit 6 ((z & 64) > 0) + + 0: principal square root + + 1: negative principal square root + + z bit 5 ((z & 32) > 0) + + 0: return aprox square root + + 1: return exact square root when real & imaginary are rational + + z bits 5-0 (z & 31) + + 0: round down or up according as y is positive or negative, + sgn(r) = sgn(y) + + 1: round up or down according as y is positive or negative, + sgn(r) = -sgn(y) + + 2: round towards zero, sgn(r) = sgn(x) + + 3: round away from zero, sgn(r) = -sgn(x) + + 4: round down + + 5: round up + + 6: round towards or from zero according as y is positive or + negative, sgn(r) = sgn(x/y) + + 7: round from or towards zero according as y is positive or + negative, sgn(r) = -sgn(x/y) + + 8: a/y is even + + 9: a/y is odd + + 10: a/y is even or odd according as x/y is positive or negative + + 11: a/y is odd or even according as x/y is positive or negative + + 12: a/y is even or odd according as y is positive or negative + + 13: a/y is odd or even according as y is positive or negative + + 14: a/y is even or odd according as x is positive or negative + + 15: a/y is odd or even according as x is positive or negative + + The value of y and lowest 5 bits of z are used in the same way as + y and z in appr(x, y, z): for either the real or imaginary part + of the square root, if this is a multiple of y, it is returned + exactly; otherwise the value returned for the part is the + multiple of y nearest below or nearest above the true value. + For z = 0, the remainder has the sign of y; changing bit 0 + changes to the other possibility; for z = 2, the remainder has the + sign of the true value, i.e. the rounding is towards zero; for + z = 4, the remainder is always positive, i.e. the rounding is down; + for z = 8, the rounding is to the nearest even multiple of y; + if 16 <= z < 32, the rounding is to the nearest multiple of y when + this is uniquely determined and otherwise is as if z were replaced + by z - 16. + + With the initial default values, 1e-20 for epsilon() and 24 for + config("sqrt"), sqrt(x) returns the principal square root with + real and imaginary parts rounded to 20 decimal places, the 20th + decimal digit being even when the part differs from a multiple + of 1e-20 by 1/2 * 1e-20. + + +EXAMPLE + > eps = 1e-4 + > print sqrt(4,eps,0), sqrt(4,eps,64), sqrt(8i,eps,0), sqrt(8i, eps, 64) + 2 -2 2+2i -2-2i + + > print sqrt(2,eps,0), sqrt(2,eps,1), sqrt(2,eps,24) + 1.4142 1.4143 1.4142 + + > x = 1.2345678^2 + > print sqrt(x,eps,24), sqrt(x,eps,32), sqrt(x,eps,96) + 1.2346 1.2345678 -1.2345678 + + > print sqrt(.00005^2, eps, 24), sqrt(.00015^2, eps, 24) + 0 .0002 + +LIMITS + none + +LIBRARY + COMPLEX *csqrt(COMPLEX *x, NUMBER *ep, long z) + NUMBER *qisqrt(NUMBER *q) + NUMBER *qsqrt(NUMBER *x, NUMBER *ep, long z) + FLAG zsqrt(ZVALUE x, ZVALUE *result, long z) + +SEE ALSO + appr, epsilon diff --git a/help/srand b/help/srand new file mode 100644 index 0000000..c3f6ec7 --- /dev/null +++ b/help/srand @@ -0,0 +1,151 @@ +NAME + srand - seed the additive 55 shuffle pseudo-random number generator + +SYNOPSIS + srand([seed]) + +TYPES + seed integer, matrix of integers or rand state + + return rand state + +DESCRIPTION + See the pseudo-random number using an additive 55 shuffle generator. + + For integer seed != 0: + + Any buffered rand generator bits are flushed. The additive table + for the rand generator is loaded with the default additive table. + The low order 64 bits of seed is xor-ed against each table value. + The additive table is shuffled according to seed/2^64. + + The following calc code produces the same effect on the internal + additive table: + + /* reload default additive table xored with low 64 seed bits */ + seed_xor = seed & ((1<<64)-1); + for (i=0; i < 55; ++i) { + additive[i] = xor(default_additive[i], seed_xor); + } + + /* shuffle the additive table */ + seed >>= 64; + for (i=55; seed > 0 && i > 0; --i) { + quomod(seed, i+1, seed, j); + swap(additive[i], additive[j]); + } + + Seed must be >= 0. All seed values < 0 are reserved for future use. + + The additive table pointers are reset to additive[23] and additive[54]. + Last the shuffle table is loaded with successive values from the + additive 55 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 * 55!) should be + sufficient for most purposes. An easy way to stay within this + range to to use seeds that are between 21 and 93 digits, or + 64 to 308 bits long. + + To help make the generator produced by seed S, significantly + different from S+1, seeds are scrambled prior to use. The + internal function randreseed64 maps [0,2^64) into [0,2^64) in a + 1-to-1 and onto fashion for every 64 bits of S. + + 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 + rand genertator. Every seed is converted into a different + unique seed. No seed is ignored or favored. See the rand + help file for details. + + For integer seed == 0: + + Restore the initial state and modulus of the rand generator. + After this call, the rand generator is restored to its initial + state after calc started. + + The additive 55 pointers are reset to additive[23] and additive[54]. + Last the shuffle table is loaded with successive values from the + additive 55 generator. + + The call: + + srand(0) + + restores the rand generator to the initial conditions at calc startup. + + For matrix arg: + + Any buffered random bits are flushed. The additive table with the + first 55 entries of the martix mod 2^64. + + The additive 55 pointers are reset to additive[23] and additive[54]. + Last the shuffle table is loaded with successive values from the + additive 55 generator. + + This form allows one to load the internal additive 55 generator + with user supplied values. + + The randreseed64 process is NOT applied to the matrix values. + + For rand state arg: + + Restore the rand state and return the previous state. Note that + the argument state is a rand state value (isrand(state) is true). + Any internally buffered random bits are restored. + + All calls to srand(seed) return the previous state or current + state in case of srand(). Their return value can be supplied + to srand in restore the generator to that previous state: + + state = srand(123456789); + newstate = srand(); /* save state */ + + x = rand(); + ... + srand(newstate); /* restore state to after srand(123456789) */ + x1 = rand(); /* produces the same value as x */ + ... + srand(state); /* restore original state */ + + For no arg given: + + Return current a55 generator state. This call does not alter + the generator state. + + This call allows one to take a snapshot of the current generator state. + + See the rand help file for details on the generator. + +EXAMPLE + > srand(0x8d2dcb2bed3212844f4ad31) + RAND state + > state = srand(); + > print rand(123), rand(123), rand(123), rand(123), rand(123), rand(123); + 32 60 67 71 1 77 + > print rand(123), rand(123), rand(123), rand(123), rand(123), rand(123); + 52 72 110 15 69 58 + > state2 = srand(state); + > print rand(123), rand(123), rand(123), rand(123), rand(123), rand(123); + 32 60 67 71 1 77 + > print rand(123), rand(123), rand(123), rand(123), rand(123), rand(123); + 52 72 110 15 69 58 + > state3 = srand(); + > print state3 == state2; + 1 + > print rand(); + 641407694185874626 + +LIMITS + for matrix arg, the matrix must have at least 55 integers + +LIBRARY + RAND *zsrand(ZVALUE *pseed, MATRIX *pmat55) + RAND *zsetrand(RAND *state) + +SEE ALSO + srand, randbit, isrand, random, srandom, israndom diff --git a/help/ssq b/help/ssq new file mode 100644 index 0000000..c353cbb --- /dev/null +++ b/help/ssq @@ -0,0 +1,36 @@ +NAME + ssq - sum of squares + +SYNOPSIS + ssq(x1, x2, ...) + +TYPES + x1, x2, ... any for which the required squaring and addition + operations are defined + + return as determined by the operations on x1, x2, ... + +DESCRIPTION + Returns the value of x1^2 + x2^2 + ... + +EXAMPLE + > print ssq(1,2,3), ssq(1+2i, 3-4i, 5 +6i) + 14 -21+40i + + > mat A[2,2] = {1,2,3,4}; mat B[2,2] = {5,6,7,8} + > print ssq(A, B, A + B) + + mat [2,2] (4 elements, 4 nonzero): + [0,0] = 190 + [0,1] = 232 + [1,0] = 286 + [1,1] = 352 + +LIMITS + The number of arguments is not to exceed 100. + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/statement b/help/statement new file mode 100644 index 0000000..1bfd7a2 --- /dev/null +++ b/help/statement @@ -0,0 +1,271 @@ +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. + + builtin built in functions + global global variables + function user-defined functions + objfunc possible object functions + config config parameters and values + objtype defined objects + + Only the first 4 characters of item are examined, so: + + show globals + show global + show glob + + do the same thing. + + + Also see the help topic: + + command top level commands diff --git a/help/str b/help/str new file mode 100644 index 0000000..104bde7 --- /dev/null +++ b/help/str @@ -0,0 +1,44 @@ +NAME + str - convert some types of values to strings + +SYNOPSIS + str(x) + +TYPES + x null, string, real or complex number + + return string + +DESCRIPTION + Convert a value into a string. + + If x is null, str(x) returns the string "". + + If x is a string, str(x) returns x. + + For real or complex x, str(x) returns the string representing x + in the current printing mode; configuration parameters affecting + this are "mode", "display", "outround", "tilde", "leadzero", + +EXAMPLE + > str("") + "" + > str(null()) + "" + > print str(123), str("+"), str(4i), str("is the same as"), str(123+4i) + 123 + 4i is the same as 3+4i + +LIMITS + none + +LIBRARY + void math_divertio(); + qprintnum(NUMBER *x, int outmode); + char *math_getdivertedio(); + + math_divertio(); + comprint(COMPLEX *x); + char *math_getdivertedio(); + +SEE ALSO + XXX - fill in diff --git a/help/strcat b/help/strcat new file mode 100644 index 0000000..d34d871 --- /dev/null +++ b/help/strcat @@ -0,0 +1,30 @@ +NAME + strcat - concatenate strings + +SYNOPSIS + strcat(x1, x2, ...) + +TYPES + x1, x2, ... strings + + return string + +DESCRIPTION + strcat(x1, x2, ...) forms a string starting with a copy of + x1, followed by the characters in order of x2, etc. The + length of the resulting string will be the sum of the lengths + of the component strings. + +EXAMPLE + > A = "abc"; B = "XY"; C = " "; + > print strcat(A, B, C, B, A) + abcXY XYabc + +LIMITS + The number of arguments may not to exceed 100. + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/strerror b/help/strerror new file mode 100644 index 0000000..984055b --- /dev/null +++ b/help/strerror @@ -0,0 +1,35 @@ +NAME + strerror - returns a string describing an error value + +SYNOPSIS + strerror(x) + +TYPES + x error-value or non-negative integer + + return string or error-value + +DESCRIPTION + If x is an error-value, strerror(x) returns a string describing that value. + + If x is an integer within the ranges for system, builtin, and user + defined error codes, the string describing error(x) is returned. + For integers outside these ranges, an "index out of range for + strerror" error is returned. + +EXAMPLE + > strerror(7) + "Bad argument for unary -" + + > x = 3 * ("a" + "b") + > print strerror(x) + Bad arguments for + + +LIMITS + none + +LIBRARY + none + +SEE ALSO + error, iserror, errno diff --git a/help/strlen b/help/strlen new file mode 100644 index 0000000..2beb05a --- /dev/null +++ b/help/strlen @@ -0,0 +1,26 @@ +NAME + strlen - number of characters in a string + +SYNOPSIS + strlen(x) + +TYPES + x string + + return integer + +DESCRIPTION + strlen(x) returns the number of characters in x + +EXAMPLE + > print strlen(""), strlen("abc"), strlen("a b\tc\\d") + 0 3 7 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/strpos b/help/strpos new file mode 100644 index 0000000..cfe2a47 --- /dev/null +++ b/help/strpos @@ -0,0 +1,40 @@ +NAME + strpos - print the first occurrence of a string in another string + +SYNOPSIS + strpos(s, t) + +TYPES + s str + t str + + return int + +DESCRIPTION + This function returns the location of the first occurance of the string t + in the string s. If t is not found within s, 0 is returned. If t is + found at the beginning of s, 1 is returned. + +EXAMPLE + > strpos("abcdefg", "c") + 3 + > strpos("abcdefg", "def") + 4 + > strpos("abcdefg", "defg") + 4 + > strpos("abcdefg", "defgh") + 0 + > strpos("abcdefg", "abc") + 1 + > strpos("abcdefg", "xyz") + 0 + + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/strprintf b/help/strprintf new file mode 100644 index 0000000..6d7faf1 --- /dev/null +++ b/help/strprintf @@ -0,0 +1,37 @@ +NAME + strprintf - formatted print to a string + +SYNOPSIS + strprintf(fmt, x_1, x_2, ...) + +TYPES + fmt string + x_1, x_2, ... any + + return string + +DESCRIPTION + This function returns the string formed from the characters that + would be printed to standard output by printf(fmt, x_1, x_2, ...). + +EXAMPLE + > strprintf("h=%d, i=%d", 2, 3); + "h=2, i=3" + + > c = config("epsilon", 1e-6); c = config("display", 6); + > c = config("tilde", 1); c = config("outround", 0); + > c = config("fullzero", 0); + > fmt = "%f,%10f,%-10f,%10.4f,%.4f,%.f.\n"; + > a = sqrt(3); + > strprintf(fmt,a,a,a,a,a,a); + "1.732051, 1.732051,1.732051 , ~1.7320,~1.7320,~1. + " + +LIMITS + The number of arguments of strprintf() is not to exceed 100. + +LIBRARY + none + +SEE ALSO + printf, fprintf, print diff --git a/help/strscan b/help/strscan new file mode 100644 index 0000000..f2d9c5e --- /dev/null +++ b/help/strscan @@ -0,0 +1,36 @@ +NAME + strscan - scan a string for possible assignment to variables + +SYNOPSIS + strscan(str, x_1, x_2, ..., x_n) + +TYPES + str string + x_1, x_2, ... any + + return integer + +DESCRIPTION + Successive fields of str separated by white space are read and + evaluated so long as values remain in the x_i arguments; when the + x_i corresponding to the field is an lvalue the value obtained for the + i-th field is assigned to x_i. + + The function returns the number of fields evaluated. + +EXAMPLE + global a,b + > strscan(" 2+3 a^2 print(b)", a, b, 0); + 25 + 3 + > print a,b + 5 25 + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + scan, fscan, fscanf, strscanf, scanf, printf, fprintf diff --git a/help/strscanf b/help/strscanf new file mode 100644 index 0000000..d065eac --- /dev/null +++ b/help/strscanf @@ -0,0 +1,115 @@ +NAME + strscanf - formatted scan of a string + +SYNOPSIS + strscanf(str, fmt, x_1, x_2, ...) + +TYPES + str string + fmt string + x_1, x_2, ... lvalues + + return null, nonnegative integer, or error value + +DESCRIPTION + If the str is "", the null value is returned. + + Otherwise, until the terminating null character of either fmt or str + is reached, characters other than '%' and whitespace are read from + fmt and compared with the corresponding characters read from str. + If the characters match, reading continues. If they do not match + an integer value is returned. If whitespace is encountered in fmt, + starting at the current positions in fmt and str, any whitespace + characters are skipped and reading and comparison begins as before + if neither fmt nor str has reached its end. + + When a '%' is encountered in fmt, if this is immediately followed by + another '%', the pair formed is considered as if one '%' were read and + reading from fmt and fs continues if and only if fs has a matching + '%'. A single '%' read from fmt is taken to indicate the beginning of + a conversion specification field consisting in succession of: + + an optional '*', + optional decimal digits, + one of 'c', 's', 'n', 'f', 'e', 'i' or a scanset specifier. + + A scanset specifier starts with '[' and an optional '^', then an optional + ']', then optional other characters, and ends with ']'. If any + other sequence of characters follows the '%', characters before the + first exceptional character (which could be the terminating null + character of the fmt string) are ignored, e.g. the sequence " %*3d " does + the same as " d ". If there is no '*' at the beginning of the specifier, + and the list x_1, x_2, ... has not been exhausted, + a value will be assigned to the next lvalue in the list; if no lvalue + remains, the reading of fs stops and the function returns the number + of assignments that have been made. + + Occurrence of '*' indicates that characters as specified are to be read + but no assignment will be made. + + The digits, if any, read in the specifier are taken to be decimal digits + of an integer which becomes the maximum "width" (number of characters + to be read from str for string-type assignments); absence of digits or + all zero digits in the 'c' case are taken to mean width = 1. Zero width + for the other cases are treated as if infinite. Fewer characters than + the specifier width may be read if end-of-file is reached or in the case + of scanset specification, an exceptional character is encountered. + + If the ending character is 'c', characters are read from fs to + form a string, which will be ignored or in the non-'*' case, assigned + to the next lvalue. + + In the 's' case, reading to form the string starts at the first non-white + character (if any) and ceases when end-of-file or further white space + is encountered or the specified width has been attained. + + The cases 'f', 'e', 'r', 'i' may be considered to indicate expectation of + floating-point, exponential, ratio, or integer representation of the + number to be read. For example, 'i' + might be taken to suggest a number like +2345; 'r' might suggest + a representation like -27/49; 'e' might suggest a representation like + 1.24e-7; 'f' might suggest a representation like 27.145. However, there + is no test that the the result conforms to the specifier. Whatever + the specifier in these cases, the result depends on the characters read + until a space or other exceptional character is read. The + characters read may include one or more occurrences of +, -, * as + well as /, interpreted in the usual way, with left-to-right associativity + for + and -, and for * and /. Also acceptable is a trailing i to + indicate an imaginary number. For example the expression + + 2+3/4*7i+3.15e7 + + would be interpreted as for an ordinary evaluation. A decimal fraction + may have more than one dot: dots after the first, which is taken to be + the decimal point, are ignored. Thus "12.3..45e6.7" is interpreted + as if it were "12.345e67". + + For the number specifiers 'f', 'e', 'r', 'i', any specified width is + ignored. + + For the specifier 'n', the index of the next character to b e read + is assigned to the corresponding lvalue. (Any width or skip specification + is ignored.) + + +EXAMPLE + > global a, b, c, d + > A = "abc xyz 234.6 alpha" + > strscanf(A, "%s%*[^0123456789]%f%n", a, b, c) + 3 + > print a, b, c + > abc 234.6 13 + + > strscanf(A, "%*13c%s", d); + 1 + > print d + > alpha + +LIMITS + none - XXX - is this correct? + +LIBRARY + none - XXX - is this correct? + +SEE ALSO + fscanf, scanf, fscan, strscan, scan, print, printf diff --git a/help/substr b/help/substr new file mode 100644 index 0000000..3086f59 --- /dev/null +++ b/help/substr @@ -0,0 +1,38 @@ +NAME + substr - extract a substring of given string + +SYNOPSIS + substr(str, pos, len) + +TYPES + str string + pos nonnegative integer + len nonnegative integer + + return string + +DESCRIPTION + If pos > length of str or len is zero, the null string "" is returned. + + If 1 <= pos <= strlen(str), substr(str, pos, len) returns the + string of length min(strlen(str) - pos + 1, len) formed by + consecutive characters of str starting at position pos, i.e. the + string has length len if this is possible, otherwise it ends with + the last character of str. (The first character has pos = 1, the + second pos = 2, etc.) + + If pos = 0, the result is the same as for pos = 1. + +EXAMPLE + > A = "abcde"; + > print substr(A,0,2), substr(A,1,2), substr(A,4,1), substr(A,3,5) + ab ab d cde + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/swap b/help/swap new file mode 100644 index 0000000..f8adf80 --- /dev/null +++ b/help/swap @@ -0,0 +1,39 @@ +NAME + swap - swap values of two variables + +SYNOPSIS + swap(x,y) + +TYPES + x, y lvalues, any type + + return null value + +DESCRIPTION + swap(x,y) assigns the value of x to a temporary location, temp say, + assigns the value of x to y, and then assigns the value at temp to y. + + swap(x,y) should not be used if the current value of one of the + variables is a component of the value of the other; for example, after: + + A = list(1,2,3); swap(A, A[[1]]); + + A will have the value 2, but a three-member list remains in memory + with no method within calc of recalling the list or freeing the + memory used. + +EXAMPLE + > x = 3/4; y = "abc"; print x, y, swap(x,y), x, y + .75 abc abc .75 + + > A = list(1,2,3); mat B[3] = {4,5,6}; swap(A[[1]], B[1]); print A[[1]], B[1] + 5 2 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + assign diff --git a/help/system b/help/system new file mode 100644 index 0000000..aa5fe01 --- /dev/null +++ b/help/system @@ -0,0 +1,45 @@ +NAME + system - issue a shell command + +SYNOPSIS + system(cmd) + +TYPES + cmd str + + return int + +DESCRIPTION + This function excutes the shell command found in the srtring, cmd. + The return value is system dependent. On POSIX P1003.1 compliant + systems the return value is defined by the waitpid system call. + Typically a shell command that returns with a 0 exit status will + cause this function to return a 0 value. On some systems, a shell + command that returns with an exit status of e will cause this + function to return e*256. Core dumps, termination due to signals + and other waitpid values will change the return value. + + On POSIX P1003.1 compliant systems, if cmd is empty then this function + will determine if the shell is executable. If the shell is executable, + 0 is returned otherwise non-zero is returned. + + +EXAMPLE + > system("") + 0 + > system("true") + 0 + > system("exit 2") + 512 + > system("date") + Sun Jul 9 03:21:48 PDT 1995 + 0 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + XXX - fill in diff --git a/help/tail b/help/tail new file mode 100644 index 0000000..465661c --- /dev/null +++ b/help/tail @@ -0,0 +1,50 @@ +NAME + tail - create a list of specified size from the tail of a list + +SYNOPSIS + tail(x, y) + +TYPES + x list + y int + + return list + +DESCRIPTION + If 0 <= y <= size(x) == n, tail(x,y) returns a list of size y whose + elements in succession have values x[[n - y]]. x[[1]], ..., x[[n - 1]]. + + If y > size(x), tail(x,y) is a copy of x. + + If -size(x) < y < 0, tail(x,y) returns a list of size (size(x) + y) + whose elements in succession have values x[[-y]]. x[[-y + 1]], ..., + x[[size(x) - 1]], i.e. a copy of x from which the first -y members + have been deleted. + + If y <= -size(x), tail(x,y) returns a list with no members. + + For any integer y, x == join(head(x,-y), tail(x,y)). + +EXAMPLE + > A = list(2, 3, 5, 7, 11) + > tail(A, 2) + + list (2 members, 2 nonzero): + [[0]] = 7 + [[1]] = 11 + + > tail(A, -2) + + list (3 members, 3 nonzero): + [[0]] = 5 + [[1]] = 7 + [[2]] = 11 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + head, segment diff --git a/help/tan b/help/tan new file mode 100644 index 0000000..a5360b0 --- /dev/null +++ b/help/tan @@ -0,0 +1,29 @@ +NAME + tan - trigonometric tangent + +SYNOPSIS + tan(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the tangent of x to a multiple of eps, with error less + in absolute value than .75 * eps. + +EXAMPLE + > print tan(1, 1e-5), tan(1, 1e-10), tan(1, 1e-15), tan(1, 1e-20) + 1.55741 1.5574077247 1.557407724654902 1.55740772465490223051 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qtan(NUMBER *x, NUMBER *eps) + +SEE ALSO + sin, cos, sec, csc, cot, epsilon diff --git a/help/tanh b/help/tanh new file mode 100644 index 0000000..cf6491a --- /dev/null +++ b/help/tanh @@ -0,0 +1,31 @@ +NAME + tanh - hyperbolic tangent + +SYNOPSIS + tanh(x [,eps]) + +TYPES + x real + eps nonzero real, defaults to epsilon() + + return real + +DESCRIPTION + Calculate the tanh of x to the nearest or next to nearest multiple of + epsilon, with absolute error less than .75 * abs(eps). + + tanh(x) = (exp(2*x) - 1)/(exp(2*x) + 1) + +EXAMPLE + > print tanh(1, 1e-5), tanh(1, 1e-10), tanh(1, 1e-15), tanh(1, 1e-20) + .76159 .761594156 .761594155955765 .76159415595576488812 + +LIMITS + unlike sin and cos, x must be real + eps > 0 + +LIBRARY + NUMBER *qtanh(NUMBER *x, NUMBER *eps) + +SEE ALSO + sinh, cosh, sech, csch, coth, epsilon diff --git a/help/time b/help/time new file mode 100644 index 0000000..3d85cd0 --- /dev/null +++ b/help/time @@ -0,0 +1,27 @@ +NAME + time - number of seconds since the Epoch + +SYNOPSIS + time() + +TYPES + return int + +DESCRIPTION + The time() builtin returns the number of seconds since the Epoch, + which according to Posix is: + + Thr Jan 1 00:00:00 UTC 1970 + +EXAMPLE + > print time(); + 831081380 + +LIMITS + none + +LIBRARY + none + +SEE ALSO + ctime, runtime diff --git a/help/todo b/help/todo new file mode 100644 index 0000000..90fd1b6 --- /dev/null +++ b/help/todo @@ -0,0 +1,252 @@ +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@auug.org.au + chongo@toad.com + + The following items are in the calc wish list. Programs like this + can be extended and improved forever. + + * In general use faster algorithms for large numbers when they + become known. In particular, look at better algorithms for + very large numbers -- multiply, square and mod in particular. + + * 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. + + * 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? + + * 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 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. + + * Remove or increase limits on factor(), lfactor(), isprime(), + nextprime(), and prevprime(). Currently these functions cannot + search for factors > 2^32. + + * Make the cryrand functions, or some useful subset builtin + functions. This is needed for speed reasons. + + The additive 55 / shuffle generators in cryrand.cal have + been turned into the rand() builtin function. The main + crypto / Blum-Blum-Shub generators still need to be + converted into builtin functions. + + * Add a builtin to generate random primes using methods suggested + by Ueli M. Maurer: "Fast Generation of Prime Numbers and + Secure Public-Key Cryptographic Parameters" 9 Sep 1991. + Such a builtin would be useful to generate large primes. + + * Be sure that regress.cal tests every builtin function. + + * Add read -once -try "filename" which would do nothing + if "filename" was not a readable file. + + * Complete the use of CONST where appropirate: + + CONST is beginning to be used with read-only tables and some + function arguments. This allows certain compilers to better + optimize the code as well as alerts one to when some value + is being changed inappropriately. Use of CONST as in: + + int foo(CONST int curds, char *CONST whey) + + while legal C is not as useful because the caller is protected + by the fact that args are passed by value. However, the + in the following: + + int bar(CONST char *fizbin, CONST HALF *data) + + is useful because it calls the compiler that the string pointed + at by 'fizbin' and the HALF array pointer at by 'data' should be + treated as read-only. + diff --git a/help/trunc b/help/trunc new file mode 100644 index 0000000..398a2af --- /dev/null +++ b/help/trunc @@ -0,0 +1,36 @@ +NAME + trunc - truncate a value to a number of decimal places + +SYNOPSIS + trunc(x [,j]) + +TYPES + x real + j int + + return real + +DESCRIPTION + Truncate x to j decimal places. If j is omitted, 0 places is assumed. + Specifying zero places makes the result identical to int(). + + Truncation of a non-integer prodcues values nearer to zero. + +EXAMPLE + > print trunc(pi()), trunc(pi(), 5) + 3 3.14159 + + > print trunc(3.333), trunc(3.789), trunc(3.333, 2), trunc(3.789, 2) + 3 3 3.33 3.78 + + > print trunc(-3.333), trunc(-3.789), trunc(-3.333, 2), trunc(-3.789, 2) + -3 -3 -3.33 -3.78 + +LIMITS + 0 <= j < 2^31 + +LIBRARY + NUMBER *qtrunc(NUMBER *x, *j) + +SEE ALSO + bround, btrunc, int, round diff --git a/help/types b/help/types new file mode 100644 index 0000000..996da73 --- /dev/null +++ b/help/types @@ -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/help/usage b/help/usage new file mode 100644 index 0000000..119d934 --- /dev/null +++ b/help/usage @@ -0,0 +1,92 @@ +Calc command line + + Calc has the following command line: + + calc [-h] [-m mode] [-p] [-q] [-u] [calc_command ...] + + -h Print a help message. This option implies -q. This + is equivalent to the calc command help help. The help + facility is disabled unless the mode is 5 or 7. See -m. + + -m mode + This flag sets the permission mode of calc. It + controls the ability for calc to open files and execute + programs. Mode may be a number from 0 to 7. + + The mode value is interpreted in a way similar to that + of the chmod(1) octal mode: + + 0 do not open any file, do not execute progs + 1 do not open any file + 2 do not open files for reading, do not execute progs + 3 do not open files for reading + 4 do not open files for writing, do not execute progs + 5 do not open files for writing + 6 do not execute any program + 7 allow everything (default mode) + + If one wished to run calc from a privledged user, one + might want to use -m 0 in an effort to make calc more + secure. + + Mode bits for reading and writing apply only on an + open. Files already open are not effected. Thus if one + wanted to use the -m 0 in an effort to make calc more + secure, but still wanted to read and write a specific + file, one might want to do: + + calc -m 0 3 print xor(2), xor(5, 3, -7, 2, 9) + 2 10 + +LIMITS + The number of arguments is not to exceed 100. + +LIBRARY + NUMBER *qxor(NUMBER *x1, NUMBER *x2) + +SEE ALSO + XXX - fill in diff --git a/hist.c b/hist.c new file mode 100644 index 0000000..6b4514a --- /dev/null +++ b/hist.c @@ -0,0 +1,1428 @@ +/* + * Copyright (c) 1995 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 +#include +#include + +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif + +#include "have_stdlib.h" +#if defined(HAVE_STDLIB_H) +#include +#endif + +#include "calc.h" +#include "hist.h" +#include "terminal.h" +#include "have_string.h" + + +#if defined(USE_TERMIOS) +# include +# define TTYSTRUCT struct termios +#else /* USE_SGTTY */ +# if defined(USE_TERMIO) +# include +# define TTYSTRUCT struct termio +# else /* USE_TERMIO */ + /* assume USE_SGTTY */ +# include +# define TTYSTRUCT struct sgttyb +# endif /* USE_TERMIO */ +#endif /* USE_SGTTY */ + +#ifdef HAVE_STRING_H +# include +#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; + +/* declare binding functions */ +static void flush_input(void); +static void start_of_line(void); +static void end_of_line(void); +static void forward_char(void); +static void backward_char(void); +static void forward_word(void); +static void backward_word(void); +static void delete_char(void); +static void forward_kill_char(void); +static void backward_kill_char(void); +static void forward_kill_word(void); +static void kill_line(void); +static void new_line(void); +static void save_line(void); +static void forward_history(void); +static void backward_history(void); +static void insert_char(int key); +static void goto_line(void); +static void list_history(void); +static void refresh_line(void); +static void swap_chars(void); +static void set_mark(void); +static void yank(void); +static void save_region(void); +static void kill_region(void); +static void reverse_search(void); +static void quote_char(void); +static void uppercase_word(void); +static void lowercase_word(void); +static void ignore_char(void); +static void arrow_key(void); +static void quit_calc(void); + + +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]; + +/* declare other static functions */ +static FUNCPTR find_func(char *name); +static HIST *get_event(int n); +static HIST *find_event(char *pat, int len); +static void read_key(void); +static void erasechar(void); +static void newline(void); +static void backspace(void); +static void beep(void); +static void echo_char(int ch); +static void echo_string(char *str, int len); +static void savetext(char *str, int len); +static void memrcpy(char *dest, char *src, int len); +static int read_bindings(FILE *fp); +static int in_word(int ch); +static KEY_MAP *find_map(char *map); +static void unbind_key(KEY_MAP *map, int key); +static void raw_bind_key(KEY_MAP *map, int key, + FUNCPTR func, KEY_MAP *next_map); +static KEY_MAP *do_map_line(char *line); +static void do_default_line(KEY_MAP *map, char *line); +static void do_bind_line(KEY_MAP *map, char *line); +static void back_over_char(int ch); +static void echo_rest_of_line(void); +static void goto_start_of_line(void); +static void goto_end_of_line(void); +static void remove_char(int ch); +static void decrement_end(int n); +static void insert_string(char *str, int len); + + +/* + * 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(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. + * We will search the CALCPATH for the file. + * + * 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(char *filename) +{ + TTYSTRUCT newtty; + + if (inited) + return HIST_INITED; + + inited = 1; + canedit = 0; + + /* + * open the bindings file + */ + if (filename == NULL) + filename = HIST_BINDING_FILE; + if (opensearchfile(filename, calcpath, NULL, FALSE) > 0) + return HIST_NOFILE; + + /* + * load the bindings + */ + if (read_bindings(curstream())) + return HIST_NOFILE; + + /* + * close the bindings + */ + closeinput(); + +#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(void) +{ + 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(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(KEY_MAP *map, int key) +{ + map->map[key] = NULL; +} + + +static void +raw_bind_key(KEY_MAP *map, int key, 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(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(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(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 open file. + * + * Returns nonzero on error. + */ +static int +read_bindings(FILE *fp) +{ + char *cp; + KEY_MAP *input_map; + char line[100]; + + base_map = find_map(base_map_name); + cur_map = base_map; + input_map = base_map; + + 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); + } + return 0; +} + + +static void +read_key(void) +{ + 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) + /* ignore Saber-C warning #65 - has 1 arg, expecting 0 */ + /* ok to ignore in proc read_key */ + (*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(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(char *pat, int len) +{ + 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(char *line, int len) +{ + 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(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(void) +{ + 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(int ch) +{ + backspace(); + if (!isprint(ch)) + backspace(); +} + + +static void +remove_char(int ch) +{ + erasechar(); + if (!isprint(ch)) + erasechar(); +} + + +static void +echo_rest_of_line(void) +{ + echo_string(HS.pos, HS.end - HS.pos); +} + + +static void +goto_start_of_line(void) +{ + while (HS.pos > HS.buf) + back_over_char((int)(*--HS.pos)); +} + + +static void +goto_end_of_line(void) +{ + echo_rest_of_line(); + HS.pos = HS.end; +} + + +static void +decrement_end(int n) +{ + HS.end -= n; + if (HS.mark && (HS.mark > HS.end)) + HS.mark = NULL; +} + + +static void +ignore_char(void) +{ +} + + +static void +flush_input(void) +{ + echo_rest_of_line(); + while (HS.end > HS.buf) + remove_char((int)(*--HS.end)); + HS.pos = HS.buf; + HS.mark = NULL; +} + + +static void +start_of_line(void) +{ + goto_start_of_line(); +} + + +static void +end_of_line(void) +{ + goto_end_of_line(); +} + + +static void +forward_char(void) +{ + if (HS.pos < HS.end) + echo_char(*HS.pos++); +} + + +static void +backward_char(void) +{ + if (HS.pos > HS.buf) + back_over_char((int)(*--HS.pos)); +} + + +static void +uppercase_word(void) +{ + while ((HS.pos < HS.end) && !in_word((int)(*HS.pos))) + echo_char(*HS.pos++); + while ((HS.pos < HS.end) && in_word((int)(*HS.pos))) { + if ((*HS.pos >= 'a') && (*HS.pos <= 'z')) + *HS.pos += 'A' - 'a'; + echo_char(*HS.pos++); + } +} + + +static void +lowercase_word(void) +{ + while ((HS.pos < HS.end) && !in_word((int)(*HS.pos))) + echo_char(*HS.pos++); + while ((HS.pos < HS.end) && in_word((int)(*HS.pos))) { + if ((*HS.pos >= 'A') && (*HS.pos <= 'Z')) + *HS.pos += 'a' - 'A'; + echo_char(*HS.pos++); + } +} + + +static void +forward_word(void) +{ + while ((HS.pos < HS.end) && !in_word((int)(*HS.pos))) + echo_char(*HS.pos++); + while ((HS.pos < HS.end) && in_word((int)(*HS.pos))) + echo_char(*HS.pos++); +} + + +static void +backward_word(void) +{ + if ((HS.pos > HS.buf) && in_word((int)(*HS.pos))) + back_over_char((int)(*--HS.pos)); + while ((HS.pos > HS.buf) && !in_word((int)(*HS.pos))) + back_over_char((int)(*--HS.pos)); + while ((HS.pos > HS.buf) && in_word((int)(*HS.pos))) + back_over_char((int)(*--HS.pos)); + if ((HS.pos < HS.end) && !in_word((int)(*HS.pos))) + echo_char(*HS.pos++); +} + + +static void +forward_kill_char(void) +{ + 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((int)ch); + decrement_end(1); + while (rest > 0) + back_over_char((int)(HS.pos[--rest])); +} + + +static void +delete_char(void) +{ + if (HS.end > HS.buf) + forward_kill_char(); +} + + +static void +backward_kill_char(void) +{ + if (HS.pos > HS.buf) { + HS.pos--; + back_over_char((int)(*HS.pos)); + forward_kill_char(); + } +} + + +static void +forward_kill_word(void) +{ + char *cp; + + if (HS.pos >= HS.end) + return; + echo_rest_of_line(); + for (cp = HS.end; cp > HS.pos;) + remove_char((int)(*--cp)); + cp = HS.pos; + while ((cp < HS.end) && !in_word((int)(*cp))) + cp++; + while ((cp < HS.end) && in_word((int)(*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((int)(*--cp)); +} + + +static void +kill_line(void) +{ + if (HS.end <= HS.pos) + return; + savetext(HS.pos, HS.end - HS.pos); + echo_rest_of_line(); + while (HS.end > HS.pos) + remove_char((int)(*--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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(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((int)(HS.pos[--rest])); +} + + +static void +insert_string(char *str, int len) +{ + 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((int)(HS.pos[--rest])); +} + + +static void +list_history(void) +{ + 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(void) +{ + 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((int)(*--cp)); + } +} + + +static void +swap_chars(void) +{ + 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((int)ch2); + echo_char(ch1); + echo_char(ch2); + back_over_char((int)ch2); +} + + +static void +set_mark(void) +{ + HS.mark = HS.pos; +} + + +static void +save_region(void) +{ + 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(void) +{ + 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((int)(*--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((int)(*--cp)); +} + + +static void +yank(void) +{ + insert_string(save_buffer, save_len); +} + + +static void +reverse_search(void) +{ + 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((int)(*--HS.pos)); +} + + +static void +quote_char(void) +{ + int ch; + + ch = fgetc(stdin); + if (ch != EOF) + insert_char(ch); +} + + +/* + * Save data in the save buffer. + */ +static void +savetext(char *str, int len) +{ + 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(int ch) +{ + return (isalnum(ch) || (ch == '_')); +} + + +static void +erasechar(void) +{ + fputs("\b \b", stdout); +} + + +static void +newline(void) +{ + fputc('\n', stdout); +} + + +static void +backspace(void) +{ + fputc('\b', stdout); +} + + +static void +beep(void) +{ + fputc('\007', stdout); +} + + +static void +echo_char(int ch) +{ + if (isprint(ch)) + putchar(ch); + else { + putchar('^'); + putchar((ch + '@') & 0x7f); + } +} + + +static void +echo_string(char *str, int len) +{ + while (len-- > 0) + echo_char(*str++); +} + + +static void +memrcpy(char *dest, char *src, int len) +{ + dest += len - 1; + src += len - 1; + while (len-- > 0) + *dest-- = *src--; +} + + +static void +quit_calc(void) +{ + hist_term(); + putchar('\n'); + exit(0); +} + + +#ifdef HIST_TEST + +/* + * Main routine to test history. + */ +void +main(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(); + exit(0); +} +#endif + +/* END CODE */ diff --git a/hist.h b/hist.h new file mode 100644 index 0000000..12a7604 --- /dev/null +++ b/hist.h @@ -0,0 +1,50 @@ +/* + * 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. + */ + +#if !defined(_HIST_H_) +#define _HIST_H_ + +/* + * 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(char *filename); +extern void hist_term(void); +extern int hist_getline(char *prompt, char *buf, int len); +extern void hist_saveline(char *line, int len); + +#endif /* _HIST_H_ */ diff --git a/input.c b/input.c new file mode 100644 index 0000000..56f2720 --- /dev/null +++ b/input.c @@ -0,0 +1,840 @@ +/* + * Copyright (c) 1995 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 +#include +#include +#include +#include "calc.h" +#include "conf.h" +#include "hist.h" + +extern int stdin_tty; /* TRUE if stdin is a tty */ + + +#define TTYSIZE 100 /* reallocation size for terminal buffers */ +#define MAXDEPTH 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[MAXDEPTH]; /* input sources */ + + +static int openfile(char *name); +static int ttychar(void); +static int isinoderead(struct stat *sbuf); +static int findfreeread(void); +static int addreadset(char *name, char *path, struct stat *sbuf); +static char *homeexpand(char *name); + + +/* + * Open an input file by possibly searching through a path list + * and also possibly applying the specified extension. For example: + * opensearchfile("barf", ".:/tmp", ".c", once) 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. + * + * given: + * name file name to be read + * pathlist list of colon separated paths (or NULL) + * extension extra extension to try (or NULL) + * rd_once TRUE => do not reread a file + */ +int +opensearchfile(char *name, char *pathlist, char *extension, int rd_once) +{ + 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) { + unsigned long namelen = strlen(name); + unsigned long extlen = strlen(extension); + + if (namelen >= extlen && + strcmp(&name[namelen-extlen], 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 != NULL && extension[0] != '\0')) { + strcat(path, extension); + i = openfile(path); + } + } while ((i < 0) && *pathlist); + + /* examine what our search produced */ + if (i < 0) + return i; + if (cip->i_fp == NULL) { + /* cannot find a file to open */ + return -3; + } + if (fstat(fileno(cip->i_fp), &statbuf) < 0) { + /* unable to fstat the open file */ + return -4; + } + + /* 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 allowed */ + 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. + * + * given: + * name a filename with a leading ~ + */ +static char * +homeexpand(char *name) +{ + 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 + * + * given: + * name the filename to open + 7 mode the fopen mode to use + */ +FILE * +f_open(char *name, char *mode) +{ + FILE *fp; /* open file descriptor */ + char *fullname; /* file name with HOMECHAR expansion */ + + /* + * be sore we are allowed to open a file in this mode + */ + if (!allow_read && !allow_write) { + /* no reads and no writes means no opens! */ + if (start_done) { + fprintf(stderr, + "open of %s mode %s - %s\n", name, mode, + "open for read or write disallowed by -m\n"); + } + return NULL; + } else if (!allow_read && strchr(mode, 'r') != NULL) { + /* reading new files disallowed */ + if (start_done) { + fprintf(stderr, + "open of %s mode %s - %s\n", name, mode, + "open for read disallowed by -m\n"); + } + return NULL; + } else if (!allow_write && + (strchr(mode, 'w') != NULL || + strchr(mode, 'a') != NULL || + strchr(mode, '+') != NULL)) { + /* writing new files disallowed */ + if (start_done) { + fprintf(stderr, + "open of %s mode %s - %s\n", name, mode, + "open for write disallowed by -m\n"); + } + return NULL; + } + + /* + * 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. + * + * given: + * name file name to be read + */ +static int +openfile(char *name) +{ + FILE *fp; /* open file descriptor */ + + if (depth >= MAXDEPTH) + return -2; + fp = f_open(name, "r"); + if (fp == NULL) + return -1; + cip = inputs + depth++; + 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); + return 0; +} + + +/* + * Return the current input file stream, or NULL if none. + */ +FILE * +curstream(void) +{ + if (depth <= 0 || depth > MAXDEPTH) + return NULL; + return cip->i_fp; +} + + +/* + * 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. + * + * given: + * str string to be opened + */ +int +openstring(char *str) +{ + char *cp; /* copied string */ + + if ((depth >= MAXDEPTH) || (str == NULL)) + return -2; + cp = (char *)malloc(strlen(str) + 1); + if (cp == NULL) + return -1; + strcpy(cp, str); + cip = inputs + depth++; + 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; + return 0; +} + + +/* + * Set to read input from the terminal. + * Returns -1 if there is no more depth for input. + */ +int +openterminal(void) +{ + if (depth >= MAXDEPTH) + return -2; + cip = inputs + depth++; + 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; + return 0; +} + + +/* + * Close the current input source. + */ +void +closeinput(void) +{ + 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); + depth--; + cip = depth ? &inputs[depth - 1] : NULL; +} + + +/* + * Reset the input sources back to the initial state. + */ +void +resetinput(void) +{ + while (depth > 0) + closeinput(); + noprompt = FALSE; +} + + +/* + * Set the prompt for terminal input. + */ +void +setprompt(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(void) +{ + 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 if (!stdin_tty) { /* from file */ + ch = fgetc(stdin); + } 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(void) +{ + 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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + int ch; /* current char */ + int len; /* length of current command */ + static char charbuf[1024]; + + /* + * 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; + if (allow_exec) { + system(cmd); + } else { + fprintf(stderr, "execution disallowed by -m flag\n"); + } + 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(void) +{ + 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(void) +{ + if (depth <= 0) + return NULL; + return cip->i_name; +} + + +/* + * Return the current line number. + */ +long +linenumber(void) +{ + if (depth > 0) + return cip->i_line; + return 1; +} + + +/* + * Restore the next character to be read again on the next nextchar call. + */ +void +reread(void) +{ + 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(void) +{ + 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. + * + * given: + * sbuf stat of the inode in question + */ +static int +isinoderead(struct stat *sbuf) +{ + 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(void) +{ + 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. + * + * given: + * name name given to read or include + * path full pathname of file + * sbuf stat of the path + */ +static int +addreadset(char *name, char *path, struct stat *sbuf) +{ + 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/jump.c b/jump.c new file mode 100644 index 0000000..d639c37 --- /dev/null +++ b/jump.c @@ -0,0 +1,159 @@ +/* + * Copyright (c) 1996 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 /\../\ + */ +/* + * jump - trivial prime jump table + * + * If x is divisible by a trivial prime (2,3,5,7,11), then: + * + * x + jmpindx[ (x>>1)%JMPMOD ] + * + * is the value of the smallest value > x that is not divisible by a + * trivial prime. JMPMOD is the product of the odd trivial primes. + * + * This table is useful for skipping values that are obviously not prime + * by skipping values that are a multiple of trivial prime. + * + * If x is not divisible by a trivial prime, then: + * + * x + jmp[ -jmpindx[(x>>1)%JMPMOD] ] + * + * is the value of the smallest value > x that is not divisible by a + * trivial prime. + * + * Instead of testing successive odd values, this system allows us to + * skip odd values divisible by trivial primes. This is process on the + * average reduces the values we need to test by a factor of at least 2.4. + */ + +#include "jump.h" + +/* + * jmpindx - how to find the next value not divisible by a trivial prime + * + * If jmpindx[y] > 0 (y = x mod JMPMOD*2), then it refers to an 'x' that + * is divisible by a trivial prime and jmpindx[y] is the offset to the next + * value that is not divisible. + * + * If jmpindx[y] <= 0, then 'x' is not divisible by a trivial prime and + * the negative of jmpindx[y] is the index into the jmp[] table. We use + * successive values from jmp[] (wrapping around to the beginning when + * we move off the end of jmp[]) to move to higher and higher values + * that are not divisible by trivial primes. + */ +CONST short jmpindx[JMPMOD] = { + 0, 10, 8, 6, 4, 2, -1, 2, -2, -3, 2, -4, 4, 2, -5, -6, 4, 2, -7, 2, -8, -9, + 2, -10, 4, 2, -11, 4, 2, -12, -13, 4, 2, -14, 2, -15, -16, 4, 2, -17, 2, + -18, 4, 2, -19, 6, 4, 2, -20, 2, -21, -22, 2, -23, -24, 2, -25, 12, 10, + 8, 6, 4, 2, -26, 2, -27, 4, 2, -28, -29, 8, 6, 4, 2, -30, -31, 4, 2, -32, + 4, 2, -33, 2, -34, -35, 2, -36, 4, 2, -37, -38, 8, 6, 4, 2, -39, -40, 2, + -41, -42, 10, 8, 6, 4, 2, -43, 8, 6, 4, 2, -44, -45, 2, -46, -47, 2, -48, + 4, 2, -49, -50, 4, 2, -51, 2, -52, 4, 2, -53, 4, 2, -54, 4, 2, -55, -56, + 4, 2, -57, 2, -58, -59, 4, 2, -60, 2, -61, 4, 2, -62, 6, 4, 2, -63, 2, + -64, -65, 2, -66, 4, 2, -67, 6, 4, 2, -68, 4, 2, -69, 8, 6, 4, 2, -70, + -71, 2, -72, 4, 2, -73, -74, 4, 2, -75, 4, 2, -76, 2, -77, -78, 2, -79, + 4, 2, -80, -81, 4, 2, -82, 2, -83, -84, 4, 2, -85, 8, 6, 4, 2, -86, -87, + 8, 6, 4, 2, -88, -89, 2, -90, -91, 2, -92, 4, 2, -93, 6, 4, 2, -94, 2, + -95, -96, 2, -97, 10, 8, 6, 4, 2, -98, -99, 4, 2, -100, 2, -101, -102, 4, + 2, -103, 2, -104, 4, 2, -105, 10, 8, 6, 4, 2, -106, -107, 2, -108, -109, + 2, -110, 6, 4, 2, -111, 4, 2, -112, 2, -113, 4, 2, -114, -115, 2, -116, + 4, 2, -117, -118, 4, 2, -119, 8, 6, 4, 2, -120, -121, 2, -122, 4, 2, -123, + -124, 4, 2, -125, 2, -126, -127, 2, -128, -129, 8, 6, 4, 2, -130, -131, + 8, 6, 4, 2, -132, -133, 2, -134, 4, 2, -135, 4, 2, -136, -137, 4, 2, -138, + 4, 2, -139, 2, -140, 4, 2, -141, 4, 2, -142, -143, 4, 2, -144, 2, -145, + -146, 4, 2, -147, 2, -148, 4, 2, -149, 6, 4, 2, -150, 2, -151, -152, 4, + 2, -153, 2, -154, 6, 4, 2, -155, 4, 2, -156, 2, -157, 4, 2, -158, -159, + 2, -160, 4, 2, -161, 6, 4, 2, -162, 4, 2, -163, 2, -164, -165, 8, 6, 4, + 2, -166, -167, 4, 2, -168, 2, -169, -170, 2, -171, -172, 8, 6, 4, 2, -173, + -174, 8, 6, 4, 2, -175, -176, 2, -177, -178, 2, -179, 6, 4, 2, -180, 4, + 2, -181, 2, -182, -183, 2, -184, 4, 2, -185, 4, 2, -186, -187, 4, 2, -188, + 2, -189, 6, 4, 2, -190, 2, -191, 4, 2, -192, 6, 4, 2, -193, 2, -194, -195, + 2, -196, -197, 2, -198, 6, 4, 2, -199, 4, 2, -200, 2, -201, 4, 2, -202, + 4, 2, -203, 4, 2, -204, -205, 4, 2, -206, 4, 2, -207, 2, -208, -209, 2, + -210, 4, 2, -211, -212, 4, 2, -213, 2, -214, -215, 2, -216, -217, 8, 6, + 4, 2, -218, -219, 8, 6, 4, 2, -220, -221, 4, 2, -222, 2, -223, 4, 2, -224, + -225, 4, 2, -226, 2, -227, -228, 2, -229, 4, 2, -230, 4, 2, -231, 6, 4, + 2, -232, 2, -233, -234, 4, 2, -235, 8, 6, 4, 2, -236, 6, 4, 2, -237, 2, + -238, -239, 2, -240, -241, 2, -242, 6, 4, 2, -243, 8, 6, 4, 2, -244, 4, + 2, -245, -246, 2, -247, 6, 4, 2, -248, 4, 2, -249, 4, 2, -250, 2, -251, + -252, 2, -253, 4, 2, -254, -255, 4, 2, -256, 2, -257, 4, 2, -258, -259, + 8, 6, 4, 2, -260, -261, 8, 6, 4, 2, -262, -263, 2, -264, -265, 2, -266, + 4, 2, -267, -268, 4, 2, -269, 2, -270, -271, 2, -272, 4, 2, -273, 4, 2, + -274, -275, 4, 2, -276, 4, 2, -277, 4, 2, -278, 2, -279, 4, 2, -280, 6, + 4, 2, -281, 2, -282, -283, 2, -284, -285, 2, -286, 6, 4, 2, -287, 4, 2, + -288, 2, -289, 6, 4, 2, -290, 2, -291, 4, 2, -292, -293, 4, 2, -294, 4, + 2, -295, 2, -296, -297, 2, -298, 4, 2, -299, 6, 4, 2, -300, 2, -301, -302, + 2, -303, -304, 8, 6, 4, 2, -305, -306, 8, 6, 4, 2, -307, -308, 2, -309, + -310, 2, -311, 4, 2, -312, -313, 8, 6, 4, 2, -314, -315, 2, -316, 4, 2, + -317, 6, 4, 2, -318, 4, 2, -319, 2, -320, -321, 4, 2, -322, 2, -323, 4, + 2, -324, 6, 4, 2, -325, 2, -326, 4, 2, -327, -328, 2, -329, 6, 4, 2, -330, + 4, 2, -331, 2, -332, 4, 2, -333, -334, 2, -335, 4, 2, -336, -337, 4, 2, + -338, 4, 2, -339, 2, -340, 4, 2, -341, 4, 2, -342, -343, 4, 2, -344, 4, + 2, -345, 2, -346, -347, 8, 6, 4, 2, -348, -349, 8, 6, 4, 2, -350, -351, + 2, -352, -353, 2, -354, 4, 2, -355, -356, 4, 2, -357, 2, -358, -359, 8, + 6, 4, 2, -360, 4, 2, -361, -362, 4, 2, -363, 2, -364, -365, 4, 2, -366, + 2, -367, 4, 2, -368, 6, 4, 2, -369, 2, -370, -371, 2, -372, -373, 10, 8, + 6, 4, 2, -374, 4, 2, -375, 2, -376, 4, 2, -377, -378, 2, -379, 4, 2, -380, + -381, 10, 8, 6, 4, 2, -382, 2, -383, -384, 2, -385, 6, 4, 2, -386, 4, + 2, -387, 2, -388, -389, 2, -390, -391, 8, 6, 4, 2, -392, -393, 8, 6, 4, + 2, -394, 4, 2, -395, -396, 2, -397, 4, 2, -398, -399, 4, 2, -400, 2, -401, + -402, 2, -403, 4, 2, -404, 4, 2, -405, -406, 4, 2, -407, 2, -408, -409, + 8, 6, 4, 2, -410, 4, 2, -411, 6, 4, 2, -412, 4, 2, -413, 2, -414, -415, + 2, -416, 6, 4, 2, -417, 4, 2, -418, 2, -419, 4, 2, -420, -421, 2, -422, + 4, 2, -423, -424, 4, 2, -425, 4, 2, -426, 4, 2, -427, 2, -428, 4, 2, -429, + -430, 4, 2, -431, 2, -432, -433, 2, -434, -435, 8, 6, 4, 2, -436, 10, 8, + 6, 4, 2, -437, -438, 2, -439, -440, 8, 6, 4, 2, -441, -442, 4, 2, -443, + 2, -444, -445, 2, -446, 4, 2, -447, 4, 2, -448, -449, 8, 6, 4, 2, -450, + -451, 4, 2, -452, 2, -453, 12, 10, 8, 6, 4, 2, -454, 2, -455, -456, 2, + -457, -458, 2, -459, 6, 4, 2, -460, 4, 2, -461, 2, -462, 4, 2, -463, -464, + 2, -465, 4, 2, -466, -467, 4, 2, -468, 4, 2, -469, 2, -470, -471, 2, -472, + 4, 2, -473, -474, 4, 2, -475, 2, -476, -477, 2, -478, 10, 8, 6, 4, 2, -479 +}; + +/* + * jmp - intervals between successive integers not divisible by trivial primes + */ +CONST unsigned char jmp[JMPSIZE] = { + 12, 4, 2, 4, 6, 2, 6, 4, 2, 4, 6, 6, 2, 6, 4, 2, 6, 4, 6, 8, 4, 2, 4, + 2, 4, 14, 4, 6, 2, 10, 2, 6, 6, 4, 2, 4, 6, 2, 10, 2, 4, 2, 12, 10, 2, + 4, 2, 4, 6, 2, 6, 4, 6, 6, 6, 2, 6, 4, 2, 6, 4, 6, 8, 4, 2, 4, 6, 8, 6, + 10, 2, 4, 6, 2, 6, 6, 4, 2, 4, 6, 2, 6, 4, 2, 6, 10, 2, 10, 2, 4, 2, 4, + 6, 8, 4, 2, 4, 12, 2, 6, 4, 2, 6, 4, 6, 12, 2, 4, 2, 4, 8, 6, 4, 6, 2, + 4, 6, 2, 6, 10, 2, 4, 6, 2, 6, 4, 2, 4, 2, 10, 2, 10, 2, 4, 6, 6, 2, 6, + 6, 4, 6, 6, 2, 6, 4, 2, 6, 4, 6, 8, 4, 2, 6, 4, 8, 6, 4, 6, 2, 4, 6, 8, + 6, 4, 2, 10, 2, 6, 4, 2, 4, 2, 10, 2, 10, 2, 4, 2, 4, 8, 6, 4, 2, 4, 6, + 6, 2, 6, 4, 8, 4, 6, 8, 4, 2, 4, 2, 4, 8, 6, 4, 6, 6, 6, 2, 6, 6, 4, 2, + 4, 6, 2, 6, 4, 2, 4, 2, 10, 2, 10, 2, 6, 4, 6, 2, 6, 4, 2, 4, 6, 6, 8, + 4, 2, 6, 10, 8, 4, 2, 4, 2, 4, 8, 10, 6, 2, 4, 8, 6, 6, 4, 2, 4, 6, 2, + 6, 4, 6, 2, 10, 2, 10, 2, 4, 2, 4, 6, 2, 6, 4, 2, 4, 6, 6, 2, 6, 6, 6, + 4, 6, 8, 4, 2, 4, 2, 4, 8, 6, 4, 8, 4, 6, 2, 6, 6, 4, 2, 4, 6, 8, 4, 2, + 4, 2, 10, 2, 10, 2, 4, 2, 4, 6, 2, 10, 2, 4, 6, 8, 6, 4, 2, 6, 4, 6, 8, + 4, 6, 2, 4, 8, 6, 4, 6, 2, 4, 6, 2, 6, 6, 4, 6, 6, 2, 6, 6, 4, 2, 10, 2, + 10, 2, 4, 2, 4, 6, 2, 6, 4, 2, 10, 6, 2, 6, 4, 2, 6, 4, 6, 8, 4, 2, 4, + 2, 12, 6, 4, 6, 2, 4, 6, 2, 12, 4, 2, 4, 8, 6, 4, 2, 4, 2, 10, 2, 10, 6, + 2, 4, 6, 2, 6, 4, 2, 4, 6, 6, 2, 6, 4, 2, 10, 6, 8, 6, 4, 2, 4, 8, 6, + 4, 6, 2, 4, 6, 2, 6, 6, 6, 4, 6, 2, 6, 4, 2, 4, 2, 10, 12, 2, 4, 2, 10, + 2, 6, 4, 2, 4, 6, 6, 2, 10, 2, 6, 4, 14, 4, 2, 4, 2, 4, 8, 6, 4, 6, 2, + 4, 6, 2, 6, 6, 4, 2, 4, 6, 2, 6, 4, 2, 4, 12, 2 +}; +CONST unsigned char *CONST lastjmp = (jmp+JMPSIZE-1); diff --git a/jump.h b/jump.h new file mode 100644 index 0000000..8340036 --- /dev/null +++ b/jump.h @@ -0,0 +1,96 @@ +/* + * Copyright (c) 1996 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 /\../\ + */ +/* + * jump - trivial prime jump table + * + * If x is divisible by a trivial prime (2,3,5,7,11), then: + * + * x + jmpindx[ (x>>1)%JMPMOD ] + * + * is the value of the smallest value > x that is not divisible by a + * trivial prime. JMPMOD is the product of the odd trivial primes. + * + * This table is useful for skipping values that are obviously not prime + * by skipping values that are a multiple of trivial prime. + * + * If x is not divisible by a trivial prime, then: + * + * x + jmp[ -jmpindx[(x>>1)%JMPMOD] ] + * + * is the value of the smallest value > x that is not divisible by a + * trivial prime. + * + * If jmpindx[y] > 0 (y = x mod JMPMOD*2), then it refers to an 'x' that + * is divisible by a trivial prime and jmpindx[y] is the offset to the next + * value that is not divisible. + * + * If jmpindx[y] <= 0, then 'x' is not divisible by a trivial prime and + * the negative of jmpindx[y] is the index into the jmp[] table. We use + * successive values from jmp[] (wrapping around to the beginning when + * we move off the end of jmp[]) to move to higher and higher values + * that are not divisible by trivial primes. + * + * Instead of testing successive odd values, this system allows us to + * skip odd values divisible by trivial primes. This is process on the + * average reduces the values we need to test by a factor of at least 2.4. + */ + +#if !defined(JUMP_H) +#define JUMP_H + +#include "have_const.h" + +/* + * trivial prime CONSTants + */ +#define JMPMOD (3*5*7*11) /* product of odd trivial primes */ +#define JMPSIZE (2*4*6*10) /* ints mod JMPMOD not div by trivial primes */ +#define JPRIME (prime+4) /* pointer to first non-trivial prime */ + +/* given x, return the index within jmpindx that applies */ +#define jmpmod(x) (((x)>>1)%JMPMOD) + +/* jmpindx table value */ +#define jmpindxval(x) (jmpindx[jmpmod(x)]) + +/* return the smallest value >= x not divisible by a trivial prime */ +#define firstjmp(x,tmp) ((tmp) = jmpindxval(x), ((tmp) > 0) ? ((x)+(tmp)) : (x)) + +/* given x not divisible by a trivial prime, return jmp[] index */ +#define jmpptr(x) (-jmpindxval(x)) + +/* given a jmp pointer, return current jump increment and bump the pointer */ +#define nxtjmp(p) ( *( ((p)jmp) ? (--(p)) : ((p)=lastjmp) ) ) + +/* + * external jump tables + */ +extern CONST short jmpindx[]; +extern CONST unsigned char jmp[]; +extern CONST unsigned char *CONST lastjmp; + +#endif /* !JUMP_H */ diff --git a/label.c b/label.c new file mode 100644 index 0000000..82ebb66 --- /dev/null +++ b/label.c @@ -0,0 +1,186 @@ +/* + * 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(void) +{ + labelcount = 0; + initstr(&labelnames); +} + + +/* + * Define a user named label to have the offset of the next opcode. + * + * given: + * name label name + */ +void +definelabel(char *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 = (long)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. + * + * given: + * name user symbol name + */ +void +addlabel(char *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 = 0; + lp->l_name = addstr(&labelnames, name); + uselabel(lp); +} + + +/* + * Check to make sure that all labels are defined. + */ +void +checklabels(void) +{ + 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. + * + * given: + * lp label being cleared + */ +void +clearlabel(LABEL *lp) +{ + 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. + * + * given: + * lp label being set + */ +void +setlabel(LABEL *lp) +{ + register FUNC *fp; /* current function */ + unsigned long curfix; /* offset of current location being fixed */ + unsigned long nextfix; /* offset of next location to fix up */ + unsigned 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 = (long)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. + * + * given: + * lp label being used + */ +void +uselabel(LABEL *lp) +{ + unsigned long offset; /* offset being added */ + + offset = curfunc->f_opcodecount; + if (lp->l_offset > 0) { + curfunc->f_opcodes[curfunc->f_opcodecount++] = lp->l_offset; + return; + } + curfunc->f_opcodes[curfunc->f_opcodecount++] = lp->l_chain; + lp->l_chain = (long)offset; +} + +/* END CODE */ diff --git a/label.h b/label.h new file mode 100644 index 0000000..e2cba65 --- /dev/null +++ b/label.h @@ -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(void); +extern void definelabel(char *name); +extern void addlabel(char *name); +extern void clearlabel(LABEL *lp); +extern void setlabel(LABEL *lp); +extern void uselabel(LABEL *lp); +extern void checklabels(void); + +#endif + +/* END CODE */ diff --git a/lib/Makefile b/lib/Makefile new file mode 100644 index 0000000..99007df --- /dev/null +++ b/lib/Makefile @@ -0,0 +1,116 @@ +# +# lib - makefile for calc library scripts +# +# Copyright (c) 1996 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 + +# required vars +# +SHELL = /bin/sh +MAKE_FILE = Makefile + +# 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 + +# Makefile debug +# +# Q=@ do not echo internal makefile actions (quiet mode) +# Q= echo internal makefile actions (debug / verbose mode) +# +#Q= +Q=@ + +# 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 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 mfactor.cal \ + bindings altbind randmprime.cal test1700.cal randrun.cal \ + randbitrun.cal cryrand.cal bernoulli.cal test2300.cal test2600.cal \ + test2700.cal test3100.cal test3300.cal test3400.cal prompt.cal \ + test3500.cal seedrandom.cal test4000.cal test4100.cal test4600.cal + +# These files are found (but not built) in the distribution +# +DISTLIST= ${CALC_FILES} ${MAKE_FILE} + +SHELL= /bin/sh + +all: ${CALC_FILES} ${MAKE_FILE} .all + +# used by the upper level Makefile to determine of we have done all +# +.all: + rm -f .all + touch .all + +## +# +# File list generation. You can ignore this section. +# +# +# We will form the names of source files as if they were in a +# sub-directory called calc/lib. +# +# NOTE: Due to bogus shells found on one common system we must have +# an non-emoty else clause for every if condition. *sigh* +# +## + +distlist: ${DISTLIST} + ${Q}for i in ${DISTLIST}; do \ + echo calc/lib/$$i; \ + done + +# The bsdi distribution has generated files as well as distributed files. +# +bsdilist: ${DISTLIST} + ${Q}for i in ${DISTLIST}; do \ + echo calc/lib/$$i; \ + done + +clean: + +clobber: + rm -f .all + +install: all + -${Q}if [ ! -d ${TOPDIR} ]; then \ + echo mkdir ${TOPDIR}; \ + mkdir ${TOPDIR}; \ + else \ + true; \ + fi + -${Q}if [ ! -d ${LIBDIR} ]; then \ + echo mkdir ${LIBDIR}; \ + mkdir ${LIBDIR}; \ + else \ + true; \ + fi + ${Q}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 + ${Q}echo remove files that are obsolete + -rm -f nextprime.cal nextprim.cal + -rm -f test1000.cal test2000.cal ${LIBDIR}/test2000.cal + -rm -f ${LIBDIR}/nextprime.cal ${LIBDIR}/nextprim.cal + -rm -f ${LIBDIR}/test1000.cal diff --git a/lib/README b/lib/README new file mode 100644 index 0000000..08369bd --- /dev/null +++ b/lib/README @@ -0,0 +1,489 @@ +# Copyright (c) 1996 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@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 "surd" + read -once "lucas" + +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 + + obj cryobj + cryrand(len) + scryrand([seed, [len1, len2]]) + scryrand(seed, ip, iq, ir) + random([a, [b]]) + srandom(seed) + randstate([cryobj | 0]) + + cryptographically strong pseudo-romandom number generator + + +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. + + Used by regress.cal during the 2100 test set. + + +lucas_tbl.cal + + Lucasian criteria for primality tables. + + +mersenne.cal + + mersenne(p) + + Perform a primality test of 2^p-1, for prime p>1. + + +mfactor.cal + + mfactor(n [, start_k [, rept_loop]) + + Return the lowest factor of 2^n-1, for n > 0. Starts looking for factors + at 2*start_k*n+1. By default, start_k == 1. + + Be default, mfactor() does not report the search progress. When + rept_loop > 0, then a report is given every 4*rept_loop loops. + + +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. + + +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. + + +prompt.cal + + adder() + showvalues(str) + + Demonstration of some uses of prompt() and eval(). + + +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. + + +randbitrun.cal + + randbitrun([run_cnt]) + + Using randbit(1) to generate a sequence of random bits, determine if + the number and kength of identical bits runs match what is expected. + By default, run_cnt is to test the next 65536 random values. + + +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. + + +randrun.cal + + randrun([run_cnt]) + + Perform the "G. Run test" (pp. 65-68) as found in Knuth's "Art of + Computer Programming - 2nd edition", Volume 2, Section 3.3.2 on + the builtin rand() function. This function will generate run_cnt + 64 bit values. By default, run_cnt is to test the next 65536 + random values. + + +regress.cal + + Test the correct execution of the calculator by reading this library file. + Errors are reported with '****' mssages, or worse. :-) + + +seedrandom.cal + + seedrandom(seed1, seed2, bitsize [,trials]) + + Given: + seed1 - a large random value (at least 10^20 and perhaps < 10^93) + seed2 - a large random value (at least 10^20 and perhaps < 10^93) + size - min Blum modulus as a power of 2 (at least 100, perhaps > 1024) + trials - number of ptest() trials (default 25) (optional arg) + + Returns: + the previous random state + + Seed the cryptographically strong Blum generator. This functions allows + one to use the raw srandom() without the burden of finding appropriate + Blum primes for the modulus. + + +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). + + +test1700.cal + + value + + This script is used by regress.cal to test the read and use keywords. + + +test2600.cal + + global defaultverbose + global err + testismult(str, n, verbose) + testsqrt(str, n, eps, verbose) + testexp(str, n, eps, verbose) + testln(str, n, eps, verbose) + testpower(str, n, b, eps, verbose) + testgcd(str, n, verbose) + cpow(x, n, eps) + cexp(x, eps) + cln(x, eps) + mkreal() + mkcomplex() + mkbigreal() + mksmallreal() + testappr(str, n, verbose) + checkappr(x, y, z, verbose) + checkresult(x, y, z, a) + test2600(verbose, tnum) + + This script is used by regress.cal to test some of builtin functions + in terms of accuracy and roundoff. + + +test2700.cal + + global defaultverbose + mknonnegreal() + mkposreal() + mkreal_2700() + mknonzeroreal() + mkposfrac() + mkfrac() + mksquarereal() + mknonsquarereal() + mkcomplex_2700() + testcsqrt(str, n, verbose) + checksqrt(x, y, z, v) + checkavrem(A, B, X, eps) + checkrounding(s, n, t, u, z) + iscomsq(x) + test2700(verbose, tnum) + + This script is used by regress.cal to test sqrt() for real and complex + values. + + +test3100.cal + + obj res + global md + res_test(a) + res_sub(a, b) + res_mul(a, b) + res_neg(a) + res_inv(a) + res(x) + + This script is used by regress.cal to test determinants of a matrix + + +test3300.cal + + global defaultverbose + global err + testi(str, n, N, verbose) + testr(str, n, N, verbose) + test3300(verbose, tnum) + + This script is used by regress.cal to provide for more determinant tests. + + +test3400.cal + + global defaultverbose + global err + test1(str, n, eps, verbose) + test2(str, n, eps, verbose) + test3(str, n, eps, verbose) + test4(str, n, eps, verbose) + test5(str, n, eps, verbose) + test6(str, n, eps, verbose) + test3400(verbose, tnum) + + This script is used by regress.cal to test trig functions. + containing objects. + +test4000.cal + + global defaultverbose + global err + global BASEB + global BASE + global COUNT + global SKIP + global RESIDUE + global MODULUS + global K1 + global H1 + global K2 + global H2 + global K3 + global H3 + plen(N) defined + rlen(N) defined + clen(N) defined + ptimes(str, N, n, count, skip, verbose) defined + ctimes(str, N, n, count, skip, verbose) defined + crtimes(str, a, b, n, count, skip, verbose) defined + ntimes(str, N, n, count, skip, residue, mod, verbose) defined + testnextcand(str, N, n, cnt, skip, res, mod, verbose) defined + testnext1(x, y, count, skip, residue, modulus) defined + testprevcand(str, N, n, cnt, skip, res, mod, verbose) defined + testprev1(x, y, count, skip, residue, modulus) defined + test4000(verbose, tnum) defined + + This script is used by regress.cal to test ptest, nextcand and + prevcand buildins. + +test4100.cal + + global defaultverbose + global err + global K1 + global K2 + global BASEB + global BASE + rlen_4100(N) defined + olen(N) defined + test1(x, y, m, k, z1, z2) defined + testall(str, n, N, M, verbose) defined + times(str, N, n, verbose) defined + powtimes(str, N1, N2, n, verbose) defined + inittimes(str, N, n, verbose) defined + test4100(verbose, tnum) defined + + This script is used by regress.cal to test REDC operations. + +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/lib/altbind b/lib/altbind new file mode 100644 index 0000000..583e1d3 --- /dev/null +++ b/lib/altbind @@ -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/lib/bernoulli.cal b/lib/bernoulli.cal new file mode 100644 index 0000000..a5b0ec1 --- /dev/null +++ b/lib/bernoulli.cal @@ -0,0 +1,67 @@ +/* + * Copyright (c) 1995 David I. Bell + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * 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/lib/bigprime.cal b/lib/bigprime.cal new file mode 100644 index 0000000..f11cb7a --- /dev/null +++ b/lib/bigprime.cal @@ -0,0 +1,32 @@ +/* + * Copyright (c) 1995 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/lib/bindings b/lib/bindings new file mode 100644 index 0000000..694ca38 --- /dev/null +++ b/lib/bindings @@ -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/lib/chrem.cal b/lib/chrem.cal new file mode 100644 index 0000000..458eed0 --- /dev/null +++ b/lib/chrem.cal @@ -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 + * Interface by: Landon Curt Noll + */ + +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/lib/cryrand.cal b/lib/cryrand.cal new file mode 100644 index 0000000..d96d778 --- /dev/null +++ b/lib/cryrand.cal @@ -0,0 +1,1645 @@ +/* + * cryrand - cryptographically strong pseudo-romandom number generator library + */ +/* + * Copyright (c) 1995 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 /\../\ + */ + +/* + * XXX - Be sure that lambda(n) = lcm(factors of p-1 & q-1) is large + * for the default case. + * + * XXX - discuss lambda(n) + * + * XXX - In a future version of calc, these functions will become builtins. + * Some cleanup and simplification will also occur. + */ + +/* + * 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 a sample implementation of the crypto generator: + * + * 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 sequences produced + * are random in an absolutely precise way. There is absolutely + * no better way to predict the next bit in the sequence than by + * tossing a coin (as with TRULY random numbers) EVEN IF YOU KNOW + * THE MODULUS AND A LARGE PART OF THE PREVIOUSLY GENERATED BITS! + * An adversary would be far better advised to try to factor the + * modulus. And if we make the modulus hard to factor + * (such as the product of two large well chosen primes) this + * too can be made intractable for todays computers and methods. + * + * 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 builtin + * rand() generator being seeded with the same seed. Calling + * scryrand() with 4 arguments, where the first argument + * is >= 0 will also result in the builtin rand() 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 builtin + * rand() generator will be seeded with the same seed. + * + * The generator comes 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 the generator with the initial state. + * In the case of scryrand(), lengths of -1 must also be supplied. + * + * 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, 0, in, ir) + * + * is fast because no checking is performed on the 'in', or 'ir' + * when seed is -1. NOTE: One must ensure that 'in' is the product of + * two Blum primes. To do this, one may use: + * + * nextcand(ip,cnt,0,3,4) * nextcand(ip+iq,cnt,0,3,4) + * + * where: + * + * ip is the initial search point for the 1st Blum prime + * iq is the initial search point for the 2nd Blum prime + * cnt is the pseudo test count (should be at least 1, + * this script uses 25) + * + * Note that the 4 arg call currently requires that the 2nd arg be 0. + * Non-zero 2nd arg values are reserved for future use. + * + * 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 builtin rand() generators. Only one + * major internal crypto generator value (a quadratic residue) is randomly + * selected via the builtin rand() generator. The other 2 major internal + * values (the 2 Blum primes) are preserved. In this form, the builtin + * rand() generator is not seeded. + * + * Calling scryrand(seed,[len1,len2]) (1 or 3 args), or calling + * srandom(seed) will leave the builtin rand() generator in a + * seeded state as if the builtin srand(seed) has been called. Calling + * scryrand(seed,0,in,ir) (4 args), with seed>0 will also leave + * the builtin rand() generator in the same scryrand(seed) state. + * + * Calling scryrand() (no args) will not seed the builtin rand() + * generator before or afterwards. The builtin rand() generator + * will be changed as a side effect of that call. + * + * Calling srandom(seed) produces the same results as calling scryrand(seed). + * + * The state of the crypto generator is 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: + * + * Instead of searching for a Blum prime, we actually search for a + * probable prime. We use the word 'probable' because of an extremely + * extremely small chance that a composite (a non-prime) may be returned. + * We use the builtin function nextcand in its 5 arg form: + * + * nextcand(p, 25, 0, 3, 4) + * + * The odds that a number returned by the above call is not prime is + * less than 1 in 4^25. 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 nextcand() to return a bogus result. + * In practive, the chance of the number returned by the above call is + * much much less than 1 in 4^25. The 1 in 4^n is a upper bound that + * has been shown to be much more pessimistic that observations suggest. + * + * 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 builtin rand() 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. + * + * 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 3 parts, the builtin rand() 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 504 and 541 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 the crypto generator may be of any size. Excessively + * large values of seed will result in increased memory usage as + * well as a larger seed time for the crypto generator. + * 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 the crypto generator + * will directly or indirectly affect the builtin rand() generator. + * Seeding the crypto generator seeds the builtin rand() 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. + * + * 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. + * + * 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 quadratic residue search performed by cryres() starts at + * a value that is in the interval [2^sqrpow,n/2), 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. We reject any residue that is within + * 2^sqrpow of its square (mod n). Finally, we reject any quadratic + * residue or square mod n of a quadratic residue that is within + * 2^sqrpow of a simple fraction of n (n/k for some integer k). + * + * 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 2^sqrpow 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. + * + * If we cannot find a good initial quadratic residue after + * 100 tries, we give up. The number '100' is somewhat arbitrary. + * For large 'n', a good quadratic residue is found after only + * a few tries. This value comes from the first 3 digits of the + * Rand book. Using a 4 digit count limit seemed excessive, + * and a 2 digit count (in this case 10) count be too small. + * + * Due to the initial quadratic residue selection process, + * the smallest of the larger Blum prime that is usable + * is 199. This is because 1393 = 7*199 is the smallest + * product of Blum primes that has a quadratic residue + * that is capable of passing the above restrictions. + * + * When searching for initial Blum primes, we do not know + * which initial search point will result in the larger + * Blum prime (due to possible random increments off of + * the search point). To be safe we will force both initial + * search points to be at lesast 199. This implies that the + * smallest usable n = p*q = 199*199 = 39601. + * + * Now since the lower bound for initial quadratic residues + * is '2^sqrpow', for the smallest n=39601 our lower bound + * is the value 2^12 or 4096. Thus we need not consider + * and initial starting quadratic value < 4096. + * + * The final magic numbers: '504' and '541' 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 '504' and + * '541' implies that the product n=p*q > 2^1024. 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^10)) produces 10 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 quality crypto generator. On the other hand, it does + * improve the security of it. + * + * As we stated above, there is absolutely no better way to predict the + * sequence than by tossing a coin (as with TRULY random numbers) EVEN + * IF YOU KNOW THE MODULUS AND WHERE YOU ARE IN THE SEQUENCE! An + * adversary would be far better advised to try to factor the modulus + * and break the sequence that way. Thus we want to make 'n' hard + * to factor. + * + * 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 '504' and + * '541', is '31', which is ~3.027% of '1024'. Now 3% of '1024' is + * '30.72', and the next largest whole number is '31'. + * + * The product n=p*q > 2^1024 implies a product if at least 309 digits. + * A product of two primes that is at least 309 digits is somewhat + * beyond Number Theory and computer power of Nov 1995, 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^1024 mainly because '1024 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 could take issue with my selection of the default sizes '504' + * and '541'. As far as I know, 309 digits (1024 bits) is beyond the + * state of the art of Number Theory and Computation as of 17 Nov 95. + * It will likely be true that 309 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 '504' + * and '541' will produce a product of two primes that is 202 digits. + * (the 2nd and 3rd args of scryrand > 504 & >541 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, 0, 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 */ + + +/* + * cryobj - cryptographic pseudo-random state object + */ +obj cryobj { \ + n, /* product of 2 Blum primes (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 */ \ + seed /* last seed set by srand() or 0 */ \ +} + + +/* + * 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,504,541) 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. + * + * NOTE: The primes that are used to compute the default value can + * be determined by examining this code. It is not intended that + * the default set of primes be hidden. If you want your product + * of two primes secret, then you need to seed the generator with + * an appropriate value. See the scryrand() function for details. + */ +/* product of 2 Blum primes (3 mod 4) */ +static cryrand_init_n = 0x1657a14d00510c5f704ec; +cryrand_init_n <<= 200; +cryrand_init_n |= 0xaad832b9295595c981ab6aa0cde87b12be032ee74f4c0b4007; +cryrand_init_n <<= 200; +cryrand_init_n |= 0x24191787d27b72b7b1b340fce7cf1158456e43a2940306046c; +cryrand_init_n <<= 200; +cryrand_init_n |= 0x6720979d12905a39dd12693b2ab52c8be109b791f71e66b069; +cryrand_init_n <<= 200; +cryrand_init_n |= 0x25aa8cf167c21650fc92716802722852601f3dc30bb2c1374e; +cryrand_init_n <<= 200; +cryrand_init_n |= 0x8bbb19c47c2bd12e3e43b93ba20e6047c07e29a89a34991309; +/* value to use as a quadratic residue of n=p*q */ +static cryrand_init_r = 0xc786ad03ebd254b3903f7e59d89b316d; +cryrand_init_r <<= 200; +cryrand_init_r |= 0x883ad980731281084d904323980830ec32ccb18af7faa070b7; +cryrand_init_r <<= 200; +cryrand_init_r |= 0x9a74dc95d0f61fc6ba3bc2599d952571bfb85081ffeec8995b; + +/* + * cryptographic pseudo-random values - used by cryrand() and scryrand() + */ +/* n = p*q */ +static cryrand_n = cryrand_init_n; +/* quad residue of n */ +static cryrand_r = pmod(cryrand_init_r, 2, cryrand_init_n); +/* 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; + + +/* + * 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, 0, in, ir) + * + * input: + * [seed pseudo-random seed + * [len1 len2] minimum bit length of the Blum primes 'p' and 'q' + * -1 => default lengths + * [0 in ir] Initial values for Blum prime products '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. + * + * 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 builtin rand() generator in a seeded state as if + * srand(seed) has been called. + * + * Calling scryrand() with no args will not seed the builtin rand() + * generator, before or afterwards, however the builtin rand() 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 builtin rand() 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 builtin rand() + * 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 (504 for len1, and 541 + * 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 R4400, the time to seed was: + * + * Approx value digits seed time + * of len1+len2 in n=p*q in sec + * ------------ -------- ------ + * 32 10 too small to measure + * 64 20 0.06 + * 128 39 0.19 + * 200 61 0.37 + * 256 78 0.59 + * 322 100 0.80 + * 464 140 3.28 + * 512 155 3.67 + * 664 200 8.90 + * 830 250 26.07 + * 996 300 14.11 (Faster mult/square methods kick in + * 1024 309 40.44 in certain cases. Type help config + * 1328 400 158.52 in calc for more details.) + * 1586 478 96.54 (The time is also dependent on how + * 1660 500 296.84 many numbers we discard in during + * 2048 617 612.97 the search.) + * + * 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, 0, in, ir) + * + * In the fourth form, 'in' must be a product of two Blum primes. + * The arg 'ir' is the search point for the quadratic residue 'r'. + * + * As of this version, the 2nd arg of this 4 arg form must be 0. + * All other values are reserved for future use. + * + * WARNING: Pseudo prime checks are performed on the 'in' arg. + * Passing improper primes will likely produce poor results, + * or worse! A good way to ensure a quality 'in arg is + * to use the expression: + * + * nextcand(ip,cnt,0,3,4) * nextcand(ip+iq,cnt,0,3,4) + * + * where: + * + * ip is the initial search point for the 1st Blum prime + * iq is the initial search point for the 2nd Blum prime + * cnt is the pseudo test count (should be at least 1, + * this script uses 25) + * + * The 'seed' value is interpreted as follows: + * + * If seed > 0: + * + * Seed and use the builtin rand() generator to generate a search + * for a quadratic residue in the range '[0,ir)'. + * + * If seed == 0: + * + * Start searching for quadratic residue is 'ir'. + * + * This form does not change/seed the other generators. + * + * If seed == -1: + * + * Use 'ir' as the quadratic residue, do not search. + * + * This form does not change/seed the other generators. + * + * + * It should be noted that calling scryrand() while using the default + * primes took less than 0.01 seconds. Calling scryrand(0,-1,-1) took + * about 40 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 in; /* Blum prime product */ + local ir; /* initial quadratic residue search value */ + local sqir; /* square of ir mod n */ + local minres; /* minimum residue allowed */ + local maxres; /* maximum residue allowed */ + local cryrand_p; /* First Blum prime (3 mod 4) */ + local cryrand_q; /* Second Blum prime (3 mod 4) */ + + /* + * 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 */ + if (len1 != 0) { + quit "bad arg: 4 arg scryrand() call requires 2nd arg to be 0"; + } + in = len2; + ir = arg4; + + /* + * Unless prohibited by a seed of -1, force minimum values on + * 'in', and 'ir'. + */ + if (seed >= 0) { + /* + * Due to the initial quadratic residue selection process, + * the smallest of the larger Blum prime that is usable + * is 199. This is because 1393 = 7*199 is the smallest + * product of Blum primes that has a quadratic residue + * that is capable of passing thru cryres(). To be safe + * since we don't know which value (p or q) will end up + * being the larger Blum prime (due to the possible random + * increment below) we will force both initial search + * values to be at lesast 199. + * + * Now cryres() selects quadratic residues >= 2^sqrpow. + * '2^sqrpow' is the smallest power of 2 >= 'n^(3/4)' where + * 'n=p*q' is the product of two Blum primes. Since we + * force both Blum primes to be at least 199, the 2^sqrpow + * for the smallest n=199*199 is the value 2^12 or 4096. + * Thus we force the initial quadratic residue to be at + * least 4096. + */ + if (!isint(in) || in < 1393) { + in = 1393; + } + if (!isint(ir) || ir < 4096) { + ir = 4096; + } + } + /* remember our Blum prime product */ + cryrand_n = in; + + /* + * 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); + } + + /* + * 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(); + } + } + + /* + * We will 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. + */ + if (seed >= 0) { + minres = 2^(highbit(floor(power(cryrand_n,0.75)))+1); + maxres = cryrand_n - 100; + sqir = pmod(ir, 2, cryrand_n); + while (sqir < minres || sqir > maxres || abs(sqir-ir) <= 100) { + /* consdier the next residue since we don't like this one */ + if (seed > 0) { + ir = sqir+rand()+1; + } else { + ir = sqir+1; + } + sqir = pmod(ir, 2, cryrand_n); + } + } + cryrand_r = pmod(ir, 2, cryrand_n); + + /* + * 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 builtin rand() + * generator. We however, restore the builtin rand() + * generator 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 builtin rand() + * 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 = 504; /* default len1 value */ + } + if (isint(len2) && len2 == -1) { + len2 = 541; /* 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 && len2 > 0) { + /* generate a pseudo-random prime ~len1 bits long */ + rval = rand(2^(len1-1), 2^((int(len1*1.03))+3)); + cryrand_p = nextcand(rval,25,0,3,4); + + /* generate a pseudo-random prime ~len2 bits long */ + rval = rand(2^(len2-1), 2^((int(len2*1.03))+3)); + cryrand_q = nextcand(rval,25,0,3,4); + + /* here is our blum modulus */ + cryrand_n = cryrand_p*cryrand_q; + cryrand_p = 0; /* clear value */ + cryrand_q = 0; /* clear value */ + + } else { + + /* use precomputed 'n' value */ + cryrand_n = cryrand_init_n; + } + + /* + * find the quadratic residue + */ + if (len1 == 504 && len2 == 541 && 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; + + /* + * ensure that r is a quadratic residue + */ + cryrand_r = pmod(cryrand_r, 2, cryrand_n); + cryrand_exp = cryrand_r; + + /* + * reseed the generator + * + * The crypto generator no longer needs the builtin rand() + * generator. We however, restore the builtin rand() generator + * back to its seeded state in order to be sure that it + * will be left in the same state. + */ + /* 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 random(x) into random(0,x-1) */ + if (isnull(b)) { + /* convert call into a closed interval */ + b = a-1; + a = 0; + /* firewall - random(0) should act like random(0,0) */ + if (b == -1) { + return(0); + } + } + /* determine the range and offset */ + if (a >= b) { + /* deal with the case of random(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= 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 builtin rand() 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 + * + * 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.n = cryrand_n; + prev.r = cryrand_r; + prev.exp = cryrand_exp; + prev.left = cryrand_left; + prev.bitcnt = cryrand_bitcnt; + prev.seed = cry_seed; + 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_n = cryrand_n; + cryrand_r = arg.r; + cryrand_exp = arg.exp; + cryrand_left = arg.left; + cryrand_bitcnt = arg.bitcnt; + cry_seed = arg.seed; + + /* + * deal with the 0 integer arg - set the default initial state + */ + } else if (isint(arg) && arg == 0) { + cryrand_n = cryrand_init_n; + cryrand_r = pmod(cryrand_init_r, 2, cryrand_init_n); + cryrand_exp = cryrand_r; + cryrand_left = 0; + cryrand_bitcnt = 0; + cry_seed = srand(0); + } + + /* + * return the previous state + */ + return (prev); +} + + +/* + * cryobj - how to initialize a cryobj object + * + * given: + * n product of Blum primes + * 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 + * seed last seed set by srand() or 0 + * + * return: + * an cryobj object + * + * NOTE: This function, by convention, returns an cryobj object. + */ +define +cryobj(n,r,exp,left,bitcnt,seed) +{ + /* declare our objects */ + local obj cryobj x; + + /* firewall */ + if (!isint(n) || !isint(r) || !isint(exp) || \ + !isint(left) || !isint(bitcnt) || !isint(seed)) { + quit "bad args: first 7 args must be integers"; + } + + /* initialize object with default startup values */ + x.n = n; + x.r = r; + x.exp = exp; + x.left = left; + x.bitcnt = bitcnt; + x.seed = seed; + + /* 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 */ + + /* 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"; + } + + /* compare values */ + if (a.n != b.n) { + print "a.n - b.n:", a.n - b.n; + } + 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.seed != b.seed) { + print "a.seed - b.seed:", a.seed - b.seed; + } +} + + +/* + * 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"; + } + + /* print the value */ + print "cryobj(" : a.n : "," : a.r : "," : a.exp : "," : \ + a.left : "," : a.bitcnt : "," : a.seed : ; +} + + +/* + * 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 n is a product of Blum primes. + */ +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 frac; /* n/frac that quadres is nearest */ + local sqfrac; /* n/sqfrac that sqquadres is nearest */ + local near; /* within +/- sqrt(n) is considered near */ + local j; + + /* + * firewall + */ + if (!isint(n)) { + quit "bad arg: must an integer"; + } + if (n < 39601) { + /* see 'SOURCE OF MAGIC NUMBERS' for why we reject 39601=199*199 */ + quit "bad arg: n < 199*199"; + } + + /* + * 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/2), + * 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/2) range, or whose square mod n + * is within sqrt(n) of itself. + * + * Finally, we reject any quadratic residue or square mod n of a + * quadratic residue that is within sqrt(n) of a simple fraction + * of n (n/k for some integer k). + */ + minres = 2^(highbit(floor(power(n,0.75)))+1); + maxres = (n//3)-1; + near = isqrt(n); + if (maxres-near <= minres) { + quit "bad arg: arg is too small"; + } + j = 0; + do { + /* form a quadratic residue */ + quadres = pmod(rand(minres,maxres+1), 2, n); + sqquadres = pmod(quadres, 2, n); + } while (++j < 100 && \ + (quadres < minres || quadres > maxres || \ + sqquadres < minres || sqquadres > maxres || \ + abs((n//round(n/quadres)) - quadres) <= near || \ + abs((n//round(n/sqquadres)) - sqquadres) <= near || \ + abs(sqquadres-quadres) <= near)); + if (j >= 100) { + quit "could not find a good quadradic residue after 100 tries"; + } + + /* + * return the quadratic residue of n + */ + return (quadres); +} + + +/* + * Initial read execution code + */ +cry_seed = srand(0); /* pre-initialize the tables */ +global cryrand_ver = "25.3 95/11/17 05:33:31"; +/* XXX - Don't forget update version number when all changes are checked in */ + +global lib_debug; +if (lib_debug >= 0) { + print "cryrand_ver:", cryrand_ver; + print "cryrand(len) defined"; + print "scryrand([seed, [len1, len2]]) defined"; + print "scryrand(seed, 0, in, ir) defined"; + print "random([a, [b]]) defined"; + print "srandom(seed) defined"; + print "obj cryobj defined"; + print "randstate([cryobj | 0]) defined"; +} diff --git a/lib/deg.cal b/lib/deg.cal new file mode 100644 index 0000000..4f710df --- /dev/null +++ b/lib/deg.cal @@ -0,0 +1,124 @@ +/* + * Copyright (c) 1995 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/lib/ellip.cal b/lib/ellip.cal new file mode 100644 index 0000000..d2e1f16 --- /dev/null +++ b/lib/ellip.cal @@ -0,0 +1,172 @@ +/* + * Copyright (c) 1995 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/lib/lucas.cal b/lib/lucas.cal new file mode 100644 index 0000000..3ae1ebf --- /dev/null +++ b/lib/lucas.cal @@ -0,0 +1,1033 @@ +/* + * Copyright (c) 1995 Landon Curt Noll + * + * 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 + */ +/* + * 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 + * + * At the time of discovery, this was the largest known twin prime pair. + * + * NOTE: Both largest known and largest known twin prime records have been + * broken. Rather than update this file each time, I'll just + * congratulate the finders and encourage others to try for + * larger finds. Records were made to be broken afterall! + * + * 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 0 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/lib/lucas_chk.cal b/lib/lucas_chk.cal new file mode 100644 index 0000000..c21ccc1 --- /dev/null +++ b/lib/lucas_chk.cal @@ -0,0 +1,381 @@ +/* + * Copyright (c) 1995 Landon Curt Noll + * + * 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 + */ +/* + * 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/lib/lucas_tbl.cal b/lib/lucas_tbl.cal new file mode 100644 index 0000000..dfbddd7 --- /dev/null +++ b/lib/lucas_tbl.cal @@ -0,0 +1,158 @@ +/* + * Copyright (c) 1995 Landon Curt Noll + * + * 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 + */ +/* + * 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/lib/mersenne.cal b/lib/mersenne.cal new file mode 100644 index 0000000..1be9860 --- /dev/null +++ b/lib/mersenne.cal @@ -0,0 +1,44 @@ +/* + * Copyright (c) 1995 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/lib/mfactor.cal b/lib/mfactor.cal new file mode 100644 index 0000000..eda8f6d --- /dev/null +++ b/lib/mfactor.cal @@ -0,0 +1,157 @@ +/* + * Copyright (c) 1996 Landon Curt Noll + * + * 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 + */ + + +/* + * mfactor - find a factor of a Mersenne Number + * + * Mersenne numbers are numbers of the form: + * + * 2^n-1 for integer n > 0 + * + * We know that factors of a Mersenne number are of the form: + * + * 2*k*n+1 and +/- 1 mod 8 + * + * given: + * n attempt to factor M(n) = 2^n-1 + * start_k the value k in 2*k*n+1 to start the search + * rept_loop loop cycle reporting, 0 => none + * + * returns: + * factor of M(n) + */ +define mfactor(n, start_k, rept_loop) +{ + local q; /* test factor 2*k*n+1 */ + local k; /* k in 2*k*n+1 */ + local step2; /* 2*n */ + local step6; /* 6*n */ + local mod8; /* q mod 8 */ + local loop; /* report loop count */ + + /* + * firewall + */ + if (!isint(n) || n <= 0) { + quit "n must be an integer > 0"; + } + if (isnull(start_k)) { + start_k = 1; + } else if (!isint(start_k) || start_k <= 0) { + quit "start_k must be an integer > 0"; + } + if (!isint(rept_loop)) { + rept_loop = 0; + } + + /* + * setup + */ + step2 = 2*n; + step6 = 6*n; + k = start_k - 1; + q = 2*k*n+1; + /* step2 to the first factor candidate */ + do { + q += step2; + mod8 = mod(q,8); + ++k; + } while (mod8 != 1 && mod8 != 7); + + /* + * At this point we are at either at the first or second + * of two consequtive factor candidates depending on if + * the next to k values are 1 and 7 mod 8. + * + * The loops below assume that we will test, bump k by 1 + * (move to the 2nd consequtive factor candidate), test and + * bump k by 3 (move to the first of the next consequtive + * factor candidate pair). + * + * In order to prepair, we need to move to the first of + * a consequtive factor candidate pair. If we happen to + * be on a the 2nd of a pair, we will test it outside + * of the loop and bump to the first of the next pair. + */ + mod8 = mod(q+step2,8); + if (mod8 != 1 && mod8 != 7) { + /* + * q is the 2nd of a consequtive factor candidate pair + * so we test q now and bump k by 3. + */ + if (pmod(2,n,q) == 1) { + /* q was a factor afterall, no need to do more! */ + return q; + } + q += step6; + k += 3; + } + + /* + * look for a factor + */ + loop = k; + while (pmod(2,n,q) != 1) { + + /* + * determine if we need to report + */ + if (rept_loop > 0) { + if (rept_loop <= ++loop) { + /* report this loop */ + printf("at 2*%d*%d+1, cpu: %f\n", + k, n, runtime()); + fflush(files(1)); + loop = 0; + } + k += 4; + } + + /* + * 1st of a consequtive factor candidate pair is not + * a factor, try the 2nd of that pair + */ + q += step2; + if (pmod(2,n,q) == 1) { + break; /* factor found */ + } + + /* + * 2nd of a consequtive factor candidate pair is not + * a factor, try the next pair + */ + q += step6; + } + + /* + * return the factor found + */ + return q; +} + +global lib_debug; +if (lib_debug >= 0) { + print "mfactor(n [, start_k [, rept_loop]])" +} diff --git a/lib/mod.cal b/lib/mod.cal new file mode 100644 index 0000000..db42138 --- /dev/null +++ b/lib/mod.cal @@ -0,0 +1,211 @@ +/* + * Copyright (c) 1995 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/lib/pell.cal b/lib/pell.cal new file mode 100644 index 0000000..e0ec90d --- /dev/null +++ b/lib/pell.cal @@ -0,0 +1,74 @@ +/* + * Copyright (c) 1995 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/lib/pi.cal b/lib/pi.cal new file mode 100644 index 0000000..8269cdf --- /dev/null +++ b/lib/pi.cal @@ -0,0 +1,54 @@ +/* + * Copyright (c) 1995 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/lib/pollard.cal b/lib/pollard.cal new file mode 100644 index 0000000..0d26d35 --- /dev/null +++ b/lib/pollard.cal @@ -0,0 +1,35 @@ +/* + * Copyright (c) 1995 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/lib/poly.cal b/lib/poly.cal new file mode 100644 index 0000000..4a25a70 --- /dev/null +++ b/lib/poly.cal @@ -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) { 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 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/lib/prompt.cal b/lib/prompt.cal new file mode 100644 index 0000000..199d5cb --- /dev/null +++ b/lib/prompt.cal @@ -0,0 +1,102 @@ +/* + * Copyright (c) 1995 Ernest Bowen + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen + */ +/* + * Demonstration of some uses of prompt() and eval(). + * + * adder() simulates a simple adding machine: starting with sum = 0, + * each number entered in response to the ? prompt is added to sum + * and the result displayed. Operation of adder() is ended by + * entering "end", "exit" or "quit"; "end" returns to the level from + * which adder() is called, e.g. with: + * + * for (;;) adder() + * + * entering "end" would start a new edition with sum = 0; "quit" and + * "exit" return to the top level. + * + * Each response to ? is read as + * a string terminated by a newline; the statements and expressions + * in this string are compiled and evaluated as in function evaluation; + * thus the string may include variables, assignments, functions, etc. + * as in: + * + * 2 + 3 + * x = 2 + 3, x^3 + * x^2 + * local x = 2; while (x < 100) x *= 2; x % 100 + * x + * exp(2, 1e-5) + * sum + * print sum^2; + * 3; print sum^2; + * + * (Here the second line creates x as a global variable; the local + * variable x in the fourth line has no effect on the global x. In + * the last three lines, sum is the sum of numbers already entered, so + * the third last line doubles the value of sum. The value returned + * by "print sum^2;" is the null value, so the second last line adds + * nothing to sum. The last line returns the value 3, i.e. the last + * non-null value found for the expressions separated by semicolons, + * so sum will be increased by 3 after the "print sum^2;" command + * is executed. xxx The terminating semicolon is essential in the + * last two lines. A command like eval("print 7;") is acceptable to + * calc but eval("print 7") causes an exit from calc. xxx) + * + * If the value returned is not a number (e.g. the name of a list or matrix, + * or if the string has syntax errors as in "2 + ", in which case the + * value returned is an error value), the compile error messages and a + * request for another number are displayed. + * + * Calling showvalues(str) assumes str defines a function of x as in: + * + * "sin(x)", "x^2 + 3*x", "exp(x, 1e-5)". + * + * Values of the function so defined are returned for values of x + * entered in reponse to the ? prompt. Operation is terminated by + * entering "end", "exit" or "quit". + */ + +define adder() { + global sum = 0; + local s, t; + for (;;) { + s = prompt("? "); + if (s == "end") + break; + t = eval(s); + if (!isnum(t)) { + print "Please enter a number"; + continue; + } + sum += t; + print "\t":sum; + } +} + +global x; + +define showvalues(str) { + local s; + for (;;) { + s = prompt("? "); + if (s == "end") + break; + x = eval(s); + if (!isnum(x)) { + print "Please enter a number"; + continue; + } + print "\t":eval(str); + } +} + +global lib_debug; +if (lib_debug >= 0) { + print "adder() defined"; + print "showvalues(str) defined"; +} diff --git a/lib/psqrt.cal b/lib/psqrt.cal new file mode 100644 index 0000000..0ff1991 --- /dev/null +++ b/lib/psqrt.cal @@ -0,0 +1,56 @@ +/* + * Copyright (c) 1995 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/lib/quat.cal b/lib/quat.cal new file mode 100644 index 0000000..7198481 --- /dev/null +++ b/lib/quat.cal @@ -0,0 +1,216 @@ +/* + * Copyright (c) 1995 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/lib/randbitrun.cal b/lib/randbitrun.cal new file mode 100644 index 0000000..4da1be1 --- /dev/null +++ b/lib/randbitrun.cal @@ -0,0 +1,119 @@ +/* + * randbitrun - check rand bit run lengths + * + * We will use randbit(1) to generate a stream if single bits. + * The odds that we will have n bits the same in a row is 1/2^n. + */ +/* + * Copyright 1995 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 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. + */ + +define randbitrun(run_cnt) +{ + local i; /* index */ + local max_run; /* longest run */ + local long_run_cnt; /* number of runs longer than MAX_RUN */ + local run; /* current run length */ + local tally_sum; /* sum of all tally values */ + local last; /* last random number */ + local current; /* current random number */ + local MAX_RUN = 18; /* max run we will keep track of */ + local mat tally[1:MAX_RUN]; /* tally of length of a rise run of 'x' */ + local mat prob[1:MAX_RUN]; /* prob[x] = probability of 'x' length run */ + + /* + * parse args + */ + if (param(0) == 0) { + run_cnt = 65536; + } + + /* + * run setup + */ + max_run = 0; /* no runs yet */ + long_run_cnt = 0; /* no long runs set */ + current = randbit(1); /* our first number */ + run = 1; + + /* + * compute the run length probabilities + * + * A bit run length of 'r' occurs with a probability of: + * + * 1/2^n; + */ + for (i=1; i <= MAX_RUN; ++i) { + prob[i] = 1.0/(1< max_run) { + max_run = run; + } + if (run > MAX_RUN) { + ++long_run_cnt; + } else { + ++tally[run]; + } + + /* start a new run */ + current = randbit(1); + run = 1; + + /* note the continuing run */ + } else { + ++run; + } + } + /* determine the number of runs found */ + tally_sum = matsum(tally) + long_run_cnt; + + /* + * print the stats + */ + printf("rand runbit test used %d values to produce %d runs\n", + run_cnt, tally_sum); + for (i=1; i <= MAX_RUN; ++i) { + printf("length=%d\tprob=%9.7f\texpect=%d \tcount=%d \terr=%9.7f\n", + i, prob[i], round(tally_sum*prob[i]), tally[i], + (tally[i] - round(tally_sum*prob[i]))/tally_sum); + } + printf("length>%d\t\t\t\t\tcount=%d\n", MAX_RUN, long_run_cnt); + printf("max length=%d\n", max_run); +} + +global lib_debug; +if (lib_debug >= 0) { + print "randbitrun([run_length]) defined"; +} diff --git a/lib/randmprime.cal b/lib/randmprime.cal new file mode 100644 index 0000000..3d2620e --- /dev/null +++ b/lib/randmprime.cal @@ -0,0 +1,137 @@ +/* + * randmprime - generate a random prime of the form h*2^n-1 + * + * Copyright (c) 1995 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/lib/randrun.cal b/lib/randrun.cal new file mode 100644 index 0000000..4fe78db --- /dev/null +++ b/lib/randrun.cal @@ -0,0 +1,128 @@ +/* + * randrun - perform a run test on rand() + * + * If X(j) < X(j+1) < ... X(j+k) >= X(j+k+1), then we have a run of 'k'. + * We ignore the run breaker, X(j+k+1), and start with X(j+k+2) when + * considering a new run in order to make our runs chi independent. + * + * See Knuth's "Art of Computer Programming - 2nd edition", + * Volume 2 ("Seminumerical Algorithms"), Section 3.3.2. + * "G. Run test", pp. 65-68, + * "problem #14", pp. 74, 536. + * + * We use the suggestion in problem #14 to allow an application of the + * chi-square test and to make estimating the run length probs easy. + */ +/* + * Copyright 1995 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 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. + */ + +define randrun(run_cnt) +{ + local i; /* index */ + local max_run; /* longest run */ + local long_run_cnt; /* number of runs longer than MAX_RUN */ + local run; /* current run length */ + local tally_sum; /* sum of all tally values */ + local last; /* last random number */ + local current; /* current random number */ + local MAX_RUN = 9; /* max run we will keep track of */ + local mat tally[1:MAX_RUN]; /* tally of length of a rise run of 'x' */ + local mat prob[1:MAX_RUN]; /* prob[x] = probability of 'x' length run */ + + /* + * parse args + */ + if (param(0) == 0) { + run_cnt = 65536; + } + + /* + * run setup + */ + max_run = 0; /* no runs yet */ + long_run_cnt = 0; /* no long runs set */ + current = rand(); /* our first number */ + run = 1; + + /* + * compute the run length probabilities + * + * A run length of 'r' occurs with a probability of: + * + * 1/r! - 1/(r+1)! + */ + for (i=1; i <= MAX_RUN; ++i) { + prob[i] = 1.0/fact(i) - 1.0/fact(i+1); + } + + /* + * look at a number of random number trials + */ + for (i=0; i < run_cnt; ++i) { + + /* get our current number */ + last = current; + current = rand(); + + /* look for a run break */ + if (current < last) { + + /* record the stats */ + if (run > max_run) { + max_run = run; + } + if (run > MAX_RUN) { + ++long_run_cnt; + } else { + ++tally[run]; + } + + /* start a new run */ + current = rand(); + run = 1; + + /* note the continuing run */ + } else { + ++run; + } + } + /* determine the number of runs found */ + tally_sum = matsum(tally) + long_run_cnt; + + /* + * print the stats + */ + printf("rand run test used %d values to produce %d runs\n", + run_cnt, tally_sum); + for (i=1; i <= MAX_RUN; ++i) { + printf("length=%d\tprob=%9.7f\texpect=%d \tcount=%d \terr=%9.7f\n", + i, prob[i], round(tally_sum*prob[i]), tally[i], + (tally[i] - round(tally_sum*prob[i]))/tally_sum); + } + printf("length>%d\t\t\t\t\tcount=%d\n", MAX_RUN, long_run_cnt); + printf("max length=%d\n", max_run); +} + +global lib_debug; +if (lib_debug >= 0) { + print "randrun([run_length]) defined"; +} diff --git a/lib/regress.cal b/lib/regress.cal new file mode 100644 index 0000000..a5ca9ad --- /dev/null +++ b/lib/regress.cal @@ -0,0 +1,3679 @@ +/* + * Copyright (c) 1996 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: Some of these tests may take a while ...'; +print '002: Within each section, output should be numbered sequentially'; + + +global err; +lib_debug = -1; /* disable lib startup messages */ +initcfg = config("all", "oldstd"); /* set config to startup default */ +print '003: parsed global definitions'; + + +/* + * vrfy - vrfy that a test is true + * + * Counts and reports errors or prints test string if successful. + */ +define vrfy(test, str) +{ + if (test != 1) { + print '**** Non-true result (' : test : '): ' : str; + ++err; + return; + } + print str; +} +print '004: parsed vrfy()'; + + +/* + * err - alternate error notification and count + */ +define err(str) +{ + print '****' , str; + ++err; +} +print '005: parsed err(str)'; + + +/* + * getglobalvar - used to return a global value + */ +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 '200: Beginning test_booleans'; + + if (0) + print '**** if (0)'; + if (0) + err = err + 1; + + if (1) + print '201: if (1)'; + + if (2) + print '202: if (2)'; + + if (1) + print '203: if (1) else'; + else + print '**** if (1) else'; + if (1) + print '204: if (1) else'; + else + err = err + 1; + + if (0) + print '**** if (0) else'; + else + print '205: if (0) else'; + if (0) + err = err + 1; + else + print '206: if (0) else'; + + if (1 == 1) + print '207: if 1 == 1'; + else + print '**** if 1 == 1'; + if (1 == 1) + print '208: if 1 == 1'; + else + err = err + 1; + + if (1 != 2) + print '209: if 1 != 2'; + else + print '**** if 1 != 2'; + if (1 != 2) + print '210: if 1 != 2'; + else + err = err + 1; + + vrfy(1, '211: vrfy 1'); + vrfy(2 == 2, '212: vrfy 2 == 2'); + vrfy(2 != 3, '213: vrfy 2 != 3'); + vrfy(2 < 3, '214: vrfy 2 < 3'); + vrfy(2 <= 2, '215: vrfy 2 <= 2'); + vrfy(2 <= 3, '216: vrfy 2 <= 3'); + vrfy(3 > 2, '217: vrfy 3 > 2'); + vrfy(2 >= 2, '218: vrfy 2 >= 2'); + vrfy(3 >= 2, '219: vrfy 3 >= 2'); + vrfy(!0, '220: vrfy !0'); + vrfy(!1 == 0,'221: vrfy !1 == 0'); + vrfy((1 ? 2 ? 3 : 4 : 5) == 3, '222: (1 ? 2 ? 3 : 4 : 5) == 3'); + + print '223: Ending test_booleans'; +} +print '007: parsed test_booleans()'; + + +/* + * Test variables, simple assignments, AND and OR operators, short-circuit eval + */ +define test_variables() +{ + local x1, x2, x3; + global g1, g2; + local t; + global globalvar; + local x; + + print '300: Beginning test_variables'; + + x1 = 5; + x3 = 7 * 2; + x2 = 9 + 1; + globalvar = 22; + g1 = 19 - 3; + g2 = 79; + vrfy(x1 == 5, '301: x1 == 5'); + vrfy(x2 == 10, '302: x2 == 10'); + vrfy(x3 == 14, '303: x3 == 14'); + vrfy(g1 == 16, '304: g1 == 16'); + vrfy(g2 == 79, '305: g2 == 79'); + vrfy(globalvar == 22, '306: globalvar == 22'); + vrfy(getglobalvar() == 22, '307: getglobalvar() == 22'); + x1 = x2 + x3 + g1; + vrfy(x1 == 40, '308: x1 == 40'); + g1 = x3 + g2; + vrfy(g1 == 93, '309: g1 == 207'); + x1 = 5; + vrfy(x1++ == 5, '310: x1++ == 5'); + vrfy(x1 == 6, '311: x1 == 6'); + vrfy(++x1 == 7, '312: ++x1 == 7'); + x1 += 3; + vrfy(x1 == 10, '313: x1 == 10'); + x1 -= 6; + vrfy(x1 == 4, '314: x1 == 4'); + x1 *= 3; + vrfy(x1 == 12, '315: x1 == 12'); + x1 /= 4; + vrfy(x1 == 3, '316: x1 == 3'); + x1 = x2 = x3; + vrfy(x2 == 14, '317: x2 == 14'); + vrfy(x1 == 14, '318: x1 == 14'); + + if (2 && 3) { + print '319: if (2 && 3)'; + } else { + print '**** if (2 && 3)'; + ++err; + } + + if (2 && 0) { + print '**** if (2 && 0)'; + ++err; + } else { + print '320: if (2 && 0)'; + } + + if (0 && 2) { + print '**** if (0 && 2)'; + ++err; + } else { + print '321: if (0 && 2)'; + } + + if (0 && 0) { + print '**** if (0 && 0)'; + ++err; + } else { + print '322: if (0 && 0)'; + } + + if (2 || 0) { + print '323: if (2 || 0)'; + } else { + print '**** if (2 || 0)'; + ++err; + } + + if (0 || 2) { + print '324: if (0 || 2)'; + } else { + print '**** if (0 || 2)'; + ++err; + } + + if (0 || 0) { + print '**** if (0 || 0)'; + ++err; + } else { + print '325: if (0 || 0)'; + } + + x = 2 || 3; vrfy(x == 2, '326: (2 || 3) == 2'); + x = 2 || 0; vrfy(x == 2, '327: (2 || 0) == 2'); + x = 0 || 3; vrfy(x == 3, '328: (0 || 3) == 3'); + x = 0 || 0; vrfy(x == 0, '329: (0 || 0) == 0'); + x = 2 && 3; vrfy(x == 3, '330: (2 && 3) == 3'); + x = 2 && 0; vrfy(x == 0, '331: (2 && 0) == 0'); + x = 0 && 3; vrfy(x == 0, '332: (0 && 3) == 0'); + x = 2 || err('2 || err()'); + print "333: x = 2 || err('2 || err()'"; + x = 0 && err('0 && err()'); + print "334: x = 0 && err('0 && err()'"; + + print '335: Ending test_variables'; +} +print '008: parsed test_variables()'; + + +/* + * Test simple arithmetic operations and expressions. + */ +define test_arithmetic() +{ + print '400: Beginning test_arithmetic'; + + vrfy(3+4==7, '401: 3 + 4 == 7'); + vrfy(4-1==3, '402: 4 - 1 == 3'); + vrfy(2*3==6, '403: 2 * 3 == 6'); + vrfy(8/4==2, '404: 8 / 4 == 2'); + vrfy(2^3==8, '405: 2 ^ 3 == 8'); + vrfy(9-4-2==3, '406: 9-4-2 == 3'); + vrfy(9-4+2==7, '407: 9-4+2 == 6'); + vrfy(-5+2==-3, '408: -5+2 == -3'); + vrfy(2*3+1==7, '409: 2*3+1 == 7'); + vrfy(1+2*3==7, '410: 1+2*3 == 7'); + vrfy((1+2)*3==9, '411: (1+2)*3 == 9'); + vrfy(2*(3+1)==8, '412: 2*(3+1) == 8'); + vrfy(9-(2+3)==4, '413: 9-(2+3) == 4'); + vrfy(9+(2-3)==8, '414: 9+(2-3) == 8'); + vrfy((2+3)*(4+5)==45, '415: (2+3)*(4+5) == 45'); + vrfy(10/(2+3)==2, '416: 10/(2+3) == 2'); + vrfy(12/3+4==8, '417: 12/3+4 == 8'); + vrfy(6+12/3==10, '418: 6+12/3 == 10'); + vrfy(2+3==1+4, '419: 2+3 == 1+4'); + vrfy(-(2+3)==-5, '420: -(2+3) == -5'); + vrfy(7&18==2, '421: 7&18 == 2'); + vrfy(3|17==19, '422: 3|17 == 19'); + vrfy(2&3|1==3, '423: 2&3|1 == 3'); + vrfy(2&(3|1)==2, '424: 2&(3|1) == 2'); + vrfy(3<<4==48, '425: 3<<4 == 48'); + vrfy(5>>1==2, '426: 5>>1 == 2'); + vrfy(3<<-1==1, '427: 3<<-1 == 1'); + vrfy(5>>-2==20, '428: 5>>-2 == 20'); + vrfy(1<<2<<3==65536, '429: 1<<2<<3 == 65536'); + vrfy((1<<2)<<3==32, '430: (1<<2)<<3 == 32'); + vrfy(2^3^2==512, '431: 2^3^2 == 512'); + vrfy((2^3)^2==64, '432: (2^3)^2 == 64'); + vrfy(4//3==1, '433: 4//3==1'); + vrfy(4//-3==-1, '434: 4//-3==-1'); + vrfy(0.75//-0.51==-1, '435: 0.75//-0.51==-1'); + vrfy(0.75//-0.50==-1, '436: 0.75//-0.50==-1'); + vrfy(0.75//-0.49==-1, '437: 0.75//-0.49==-1'); + vrfy((3/4)//(-1/4)==-3, '438: (3/4)//(-1/4)==-3'); + vrfy(7%3==1, '439: 7%3==1'); + vrfy(0-.5==-.5, '440: 0-.5==-.5'); + vrfy(0^0 == 1, '441: 0^0 == 1'); + vrfy(0^1 == 0, '442: 0^1 == 0'); + vrfy(1^0 == 1, '443: 1^0 == 1'); + vrfy(1^1 == 1, '444: 1^1 == 1'); + vrfy(1/(.8+.8i)==.625-.625i, '445: 1/(.8+.8i)==.625-.625i'); + vrfy((.6+.8i)*(3.6-4.8i)==6, '446: (.6+.8i)*(3.6-4.8i)==6'); + + print '447: Ending test_arithmetic'; +} +print '009: parsed test_arithmetic()'; + + +/* + * test_config - test config control + */ +define test_config() +{ + local callcfg; /* caller configuration value */ + local oldcfg; /* caller configuration value */ + local newcfg; /* caller configuration value */ + + print '500: Beginning test_config'; + + /* check the set and return of all config */ + callcfg = config("all"); + print '501: callcfg = config("all")'; + callcfg = config("all", "oldstd"); + print '502: callcfg = config("all","oldstd")'; + oldcfg = config("all", "newstd"); + print '503: oldcfg = config("all","newstd")'; + vrfy(callcfg == oldcfg, '504: callcfg == oldcfg'); + newcfg = config("all"); + print '505: newcfg = config("all")'; + vrfy(config("all") == newcfg, '506: config("all") == newcfg'); + vrfy(config("all", oldcfg) == newcfg, + '507: config("all", oldcfg) == newcfg'); + + /* vrfy the state of the default config */ + vrfy(config("all") == oldcfg, '508: config("all") == oldcfg'); + vrfy(config("mode") == "real", + '509: config("mode") == "real"'); + vrfy(config("display") == 20, + '510: config("display") == 20'); + vrfy(config("epsilon") == 1e-20, + '511: config("epsilon") == 1e-20'); + vrfy(config("trace") == 0, + '512: config("trace") == 0'); + vrfy(config("maxprint") == 16, + '513: config("maxprint") == 16'); + vrfy(config("mul2") == 20, + '514: config("mul2") == 20'); + vrfy(config("sq2") == 20, + '515: config("sq2") == 20'); + vrfy(config("pow2") == 40, + '516: config("pow2") == 40'); + vrfy(config("redc2") == 50, + '517: config("redc2") == 50'); + vrfy(config("tilde") == 1, + '518: config("tilde") == 1'); + vrfy(config("tab") == 1, + '519: config("tab") == 1'); + vrfy(config("quomod") == 0, + '520: config("quomod") == 0'); + vrfy(config("quo") == 2, + '521: config("quo") == 2'); + vrfy(config("mod") == 0, + '522: config("mod") == 0'); + vrfy(config("sqrt") == 24, + '523: config("sqrt") == 24'); + vrfy(config("appr") == 24, + '524: config("appr") == 24'); + vrfy(config("cfappr") == 0, + '525: config("cfappr") == 0'); + vrfy(config("cfsim") == 8, + '526: config("cfsim") == 8'); + vrfy(config("outround") == 2, + '527: config("outround") == 2'); + vrfy(config("round") == 24, + '528: config("round") == 24'); + vrfy(config("leadzero") == 0, + '529: config("leadzero") == 0'); + vrfy(config("fullzero") == 0, + '530: config("fullzero") == 0'); + vrfy(config("maxerr") == 20, + '531: config("maxerr") == 20'); + vrfy(config("prompt") == "> ", + '532: config("prompt") == "> "'); + vrfy(config("more") == ">> ", + '533: config("more") == ">> "'); + + /* convert to "newstd" config by individual changes */ + vrfy(config("display", 10) == 20, + '534: config("display") == 20'); + vrfy(config("epsilon",1e-10)==1e-20, + '535: config("epsilon",1e-10)==1e-20'); + vrfy(config("quo", 0) == 2, '536: config("quo", 0) == 2'); + vrfy(config("outround", 24) == 2, + '537: config("outround", 24) == 2'); + vrfy(config("leadzero", "y") == 0, + '538: config("leadzero", "y") == 0'); + vrfy(config("fullzero", 1) == 0, + '539: config("fullzero", 1) == 0'); + vrfy(config("prompt", "; ") == "> ", + '540: config("prompt", "; ") == "> "'); + vrfy(config("more", ";; ") == ">> ", + '541: config("more", ";; ") == ">> "'); + vrfy(config("all") == newcfg, '542: config("all") == newcfg'); + + /* check on the new config("fullzero") effect */ + vrfy(config("all","oldstd") == newcfg, + '543: config("all",callcfg) == newcfg'); + vrfy(config("display",2) == 20, + '544: config("display",2) == 20'); + vrfy(config("fullzero",1) == 0, + '545: config("fullzero",1) == 0'); + vrfy(strprintf("%d %d %d", 0, 1, 2) == ".00 1.00 2.00", + '546: strprintf("%d %d %d", 0, 1, 2) == ".00 1.00 2.00"'); + vrfy(config("display",20) == 2, + '547: config("display",20) == 2'); + vrfy(config("fullzero",0) == 1, + '548: config("fullzero",0) == 1'); + vrfy(strprintf("%d %d %d", 0, 1, 2) == "0 1 2", + '549: strprintf("%d %d %d", 0, 1, 2) == "0 1 2"'); + + /* restore calling config */ + vrfy(config("all",callcfg) == oldcfg, + '550: config("all",callcfg) == oldcfg'); + vrfy(config("all") == callcfg, '551: config("all") == callcfg'); + vrfy(config("all") == oldcfg, '552: config("all") == oldcfg'); + + print '553: Ending test_config'; +} +print '010: parsed test_config()'; + + + +/* + * Do multiplication and division on three numbers in various ways + * and vrfy 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 '011: 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 '012: 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 '013: 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 '014: 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 '015: 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; + vrfy(ptest(a, 20), '612: primetest R19'); + a = (10^23-1) / 9; + vrfy(ptest(a, 20), '613: primetest R23'); + a = 2^127 - 1; + vrfy(ptest(a, 1), '614: primetest M127'); + a = 2^521 - 1; + vrfy(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'); + + print '632: Ending test_bignums'; +} +print '016: parsed test_bignums()'; + + +/* + * Test many of the built-in functions. + */ +define test_functions() +{ + local a, b; + local pi; + + print '700: Beginning test_functions'; + + vrfy(abs(3) == 3, '701: abs(3) == 3'); + vrfy(abs(-4) == 4, '702: abs(-4) == 4'); + vrfy(avg(7) == 7, '703: avg(7) == 7'); + vrfy(avg(3,5) == 4, '704: avg(3,5) == 4'); + vrfy(cmp(2,3) == -1, '705: cmp(2,3) == -1'); + vrfy(cmp(6,6) == 0, '706: cmp(6,6) == 0'); + vrfy(cmp(7,4) == 1, '707: cmp(7,4) == 1'); + vrfy(comb(9,9) == 1, '708: comb(9,9) == 1'); + vrfy(comb(5,2) == 10, '709: comb(5,2) == 10'); + vrfy(conj(4) == 4, '710: conj(4) == 4'); + vrfy(conj(2-3i) == 2+3i, '711: conj(2-3i) == 2+3i'); + vrfy(den(17) == 1, '712: den(17) == 1'); + vrfy(den(3/7) == 7, '713: den(3/7) == 7'); + vrfy(den(-2/3) == 3, '714: den(-2/3) == 3'); + vrfy(digits(0) == 1, '715: digits(0) == 1'); + vrfy(digits(9) == 1, '716: digits(9) == 1'); + vrfy(digits(10) == 2, '717: digits(10) == 2'); + vrfy(digits(-691) == 3, '718: digits(-691) == 3'); + vrfy(eval('2+3') == 5, "719: eval('2+3') == 5"); + vrfy(fcnt(11,3) == 0, '720: fcnt(11,3) == 0'); + vrfy(fcnt(18,3) == 2, '721: fcnt(18,3) == 2'); + vrfy(fib(0) == 0, '722: fib(0) == 0'); + vrfy(fib(1) == 1, '723: fib(1) == 1'); + vrfy(fib(9) == 34, '724: fib(9) == 34'); + vrfy(frem(12,5) == 12, '725: frem(12,5) == 12'); + vrfy(frem(45,3) == 5, '726: frem(45,3) == 5'); + vrfy(fact(0) == 1, '727: fact(0) == 1'); + vrfy(fact(1) == 1, '728: fact(1) == 1'); + vrfy(fact(5) == 120, '729: fact(5) == 120'); + vrfy(frac(3) == 0, '730: frac(3) == 0'); + vrfy(frac(2/3) == 2/3, '731: frac(2/3) == 2/3'); + vrfy(frac(17/3) == 2/3, '732: frac(17/3) == 2/3'); + vrfy(gcd(0,3) == 3, '733: gcd(0,3) == 3'); + vrfy(gcd(1,12) == 1, '734: gcd(1,12) == 1'); + vrfy(gcd(11,7) == 1, '735: gcd(11,7) == 1'); + vrfy(gcd(20,65) == 5, '736: gcd(20,65) == 5'); + vrfy(gcdrem(20,3) == 20, '737: gcdrem(20,3) == 20'); + vrfy(gcdrem(100,6) == 25, '738: gcdrem(100,6) == 25'); + vrfy(highbit(1) == 0, '739: highbit(1) == 0'); + vrfy(highbit(15) == 3, '740: highbit(15) == 3'); + vrfy(hypot(3,4) == 5, '741: hypot(3,4) == 5'); + vrfy(ilog(90,3) == 4, '742: ilog(90,3) == 4'); + vrfy(ilog10(123) == 2, '743: ilog10(123) == 2'); + vrfy(ilog2(17) == 4, '744: ilog2(17) == 4'); + vrfy(im(3) == 0, '745: im(3) == 0'); + vrfy(im(2+3i) == 3, '746: im(2+3i) == 3'); + print '747: test unused'; + print '748: test unused'; + print '749: test unused'; + print '750: test unused'; + print '751: test unused'; + print '752: test unused'; + print '753: test unused'; + print '754: test unused'; + print '755: test unused'; + print '756: test unused'; + vrfy(int(5) == 5, '757: int(5) == 5'); + vrfy(int(19/3) == 6, '758: int(19/3) == 6'); + vrfy(inverse(3/2) == 2/3, '759: inverse(3/2) == 2/3'); + vrfy(iroot(18,2) == 4, '760: iroot(18,2) == 4'); + vrfy(iroot(100,3) == 4, '761: iroot(100,3) == 4'); + vrfy(iseven(10) == 1, '762: iseven(10) == 1'); + vrfy(iseven(13) == 0, '763: iseven(13) == 0'); + vrfy(iseven('a') == 0, "764: iseven('a') == 0"); + vrfy(isint(7) == 1, '765: isint(7) == 1'); + vrfy(isint(19/2) == 0, '766: isint(19/2) == 0'); + vrfy(isint('a') == 0, "767: isint('a') == 0"); + vrfy(islist(3) == 0, '768: islist(3) == 0'); + vrfy(islist(list(2,3)) == 1, '769: islist(list(2,3)) == 1'); + vrfy(ismat(3) == 0, '770: ismat(3) == 0'); + vrfy(ismult(7,3) == 0, '771: ismult(7,3) == 0'); + vrfy(ismult(15,5) == 1, '772: ismult(15,5) == 1'); + vrfy(isnull(3) == 0, '773: isnull(3) == 0'); + vrfy(isnull(null()) == 1, '774: isnull(null()) == 1'); + vrfy(isnum(2/3) == 1, '775: isnum(2/3) == 1'); + vrfy(isnum('xx') == 0, "776: isnum('xx') == 0"); + vrfy(isobj(3) == 0, '777: isobj(3) == 0'); + vrfy(isodd(7) == 1, '778: isodd(7) == 1'); + vrfy(isodd(8) == 0, '779: isodd(8) == 0'); + vrfy(isodd('x') == 0, "780: isodd('a') == 0"); + vrfy(isqrt(27) == 5, '781: isqrt(27) == 5'); + vrfy(isreal(3) == 1, '782: isreal(3) == 1'); + vrfy(isreal('x') == 0, "783: isreal('x') == 0"); + vrfy(isreal(2+3i) == 0, '784: isreal(2+3i) == 0'); + vrfy(isstr(5) == 0, '785: isstr(5) == 0'); + vrfy(isstr('foo') == 1, "786: isstr('foo') == 1"); + vrfy(isrel(10,14) == 0, '787: isrel(10,14) == 0'); + vrfy(isrel(15,22) == 1, '788: isrel(15,22) == 1'); + vrfy(issimple(6) == 1, '789: issimple(6) == 1'); + vrfy(issimple(3-2i) == 1, '790: issimple(3-2i) == 1'); + vrfy(issimple(list(5)) == 0, '791: issimple(list(5)) == 0'); + vrfy(issq(26) == 0, '792: issq(26) == 0'); + vrfy(issq(9/4) == 1, '793: issq(9/4) == 1'); + print '794: test unused'; + vrfy(istype(9,4) == 1, '795: istype(9,4) == 1'); + vrfy(istype(3,'xx') == 0, "796: istype(3,'xx') == 0"); + vrfy(jacobi(5,11) == 1, '797: jacobi(2,7) == 1'); + vrfy(jacobi(6,13) == -1, '798: jacobi(6,13) == -1'); + vrfy(lcm(3,4,5,6) == 60, '799: lcm(3,4,5,6) == 60'); + vrfy(lcmfact(8) == 840, '800: lcmfact(8) == 840'); + vrfy(lfactor(21,5) == 3, '801: lfactor(21,5) == 3'); + vrfy(lfactor(97,20) == 1, '802: lfactor(97,20) == 1'); + vrfy(lowbit(12) == 2, '803: lowbit(12) == 2'); + vrfy(lowbit(17) == 0, '804: lowbit(17) == 0'); + vrfy(ltol(1) == 0, '805: ltol(1) == 0'); + vrfy(max(3,-9,7,4) == 7, '806: max(3,-9,7,4) == 7'); + vrfy(meq(13,33,10) == 1, '807: meq(13,33,10) == 1'); + vrfy(meq(7,19,11) == 0, '808: meq(7,19,11) == 0'); + vrfy(min(9,5,12) == 5, '809: min(9,5,12) == 5'); + vrfy(minv(13,97) == 15, '810: minv(13,97) == 15'); + vrfy(mne(16,37,10) == 1, '811: mne(16,37,10) == 1'); + vrfy(mne(46,79,11) == 0, '812: mne(46,79,11) == 0'); + vrfy(norm(4) == 16, '813: norm(4) == 16'); + vrfy(norm(2-3i) == 13, '814: norm(2-3i) == 13'); + vrfy(num(7) == 7, '815: num(7) == 7'); + vrfy(num(11/4) == 11, '816: num(11/4) == 11'); + vrfy(num(-9/5) == -9, '817: num(-9/5) == -9'); + vrfy(char(ord('a')+2) == 'c', "818: char(ord('a')+2) == 'c'"); + vrfy(perm(7,3) == 210, '819: perm(7,3) == 210'); + vrfy(pfact(10) == 210, '820: pfact(10) == 210'); + vrfy(places(3/7) == -1, '821: places(3/7) == -1'); + vrfy(places(.347) == 3, '822: places(.347) == 3'); + vrfy(places(17) == 0, '823: places(17) == 0'); + vrfy(pmod(3,36,37) == 1, '824: pmod(3,36,37) == 1'); + vrfy(poly(2,3,5,2) == 19, '825: poly(2,3,5,2) == 19'); + vrfy(ptest(101,10) == 1, '826: ptest(101,10) == 1'); + vrfy(ptest(221,30) == 0, '827: ptest(221,30) == 0'); + vrfy(re(9) == 9, '828: re(9) == 9'); + vrfy(re(-7+3i) == -7, '829: re(-7+3i) == -7'); + vrfy(scale(3,4) == 48, '830: scale(3,4) == 48'); + vrfy(sgn(-4) == -1, '831: sgn(-4) == -1'); + vrfy(sgn(0) == 0, '832: sgn(0) == 0'); + vrfy(sgn(3) == 1, '833: sgn(3) == 1'); + vrfy(size(7) == 1, '834: size(7) == 1'); + vrfy(sqrt(121) == 11, '835: sqrt(121) == 11'); + vrfy(ssq(2,3,4) == 29, '836: ssq(2,3,4) == 29'); + vrfy(str(45) == '45', "837: str(45) == '45'"); + vrfy(strcat('a','bc','def')=='abcdef', + "838: strcat('a','bc','def')=='abcdef'"); + vrfy(strlen('') == 0, "839: strlen('') == 0"); + vrfy(strlen('abcd') == 4, "840: strlen('abcd') == 4"); + vrfy(substr('abcd',2,1) == 'b', "841: substr('abcd',2,1) == 'b'"); + vrfy(substr('abcd',3,4) == 'cd', "842: substr('abcd',3,4) == 'cd'"); + vrfy(substr('abcd',1,3) == 'abc', "843: substr('abcd',1,3) == 'abc'"); + vrfy(xor(17,17) == 0, '844: xor(17,17) == 0'); + vrfy(xor(12,5) == 9, '845: xor(12,5) == 9'); + vrfy(mmin(3,7) == 3, '846: mmin(3,7) == 3'); + vrfy(mmin(4,7) == -3, '847: mmin(4,7) == -3'); + vrfy(digit(123,2) == 1, '848: digit(123,2) == 1'); + vrfy(ismult(3/4, 1/7) == 0, '849: ismult(3/4, 1/7) == 0'); + vrfy(gcd(3/4, 1/7) == 1/28, '850: gcd(3/4,1/7) == 1/28'); + vrfy(gcd(2,3,1/2) == 1/2, '851: gcd(2,3,1/2) == 1/2'); + vrfy(gcd(17,7,1/7) == 1/7, '852: gcd(17,7,1/7) == 1/7'); + vrfy(gcd(2) == 2, '853: gcd(2) == 2'); + vrfy(gcd(-2) == 2, '854: gcd(-2) == 2'); + vrfy(floor(1.5) == 1, '855: floor(1.5) == 1'); + vrfy(floor(.5) == 0, '856: floor(.5) == 0'); + vrfy(floor(-.5) == -1, '857: floor(-.5) == -1'); + vrfy(floor(-1.5) == -2, '858: floor(-1.5) == -2'); + vrfy(ceil(1.5) == 2, '859: ceil(1.5) == 2'); + vrfy(ceil(.5) == 1, '860: ceil(.5) == 1'); + vrfy(ceil(-.5) == 0, '861: ceil(-.5) == 0'); + vrfy(ceil(-1.5) == -1, '862: ceil(-1.5) == -1'); + vrfy(frac(-7.2) == -.2, '863: frac(-7.2) == -.2'); + vrfy(gcd(4, 5, 1/3) == 1/3, '864: gcd(4, 5, 1/3) == 1/3'); + vrfy(ltol(7/25) == 24/25, '865: ltol(7/25) == 24/25'); + vrfy(hmean(1,2,3) == 18/11, '866: hmean(1,2,3) == 18/11'); + vrfy(ilog2(2^-20) == -20, '867: ilog2(2^-20) == -20'); + vrfy(ord("DBell") == 68, '868: ord("DBell") == 68'); + vrfy(cmp("a","b") == -1, '869: cmp("a","b") == -1'); + vrfy(cmp("abcd","abc") == 1, '870: cmp("abcd","abc") == 1'); + vrfy(cmp(3,4i) == 1-1i, '871: cmp(3,4i) == 1-1i'); + vrfy(cmp(4,4i) == 1-1i, '872: cmp(4,4i) == 1-1i'); + vrfy(cmp(5,4i) == 1-1i, '873: cmp(5,4i) == 1-1i'); + vrfy(cmp(-5,4i) == -1-1i, '874: cmp(-5,4i) == -1-1i'); + vrfy(cmp(-4i,5) == -1-1i, '875: cmp(-4i,5) == -1-1i'); + vrfy(cmp(-4i,-5) == 1-1i, '876: cmp(-4i,-5) == 1-1i'); + vrfy(cmp(3i,4i) == -1i, '877: cmp(3i,4i) == -1i'); + vrfy(cmp(4i,4i) == 0, '878: cmp(4i,4i) == 0'); + vrfy(cmp(5i,4i) == 1i, '879: cmp(5i,4i) == 1i'); + vrfy(cmp(3+4i,5) == -1+1i, '880: cmp(3+4i,5) == -1+1i'); + vrfy(cmp(3+4i,-5) == 1+1i, '881: cmp(3+4i,-5) == 1+1i'); + vrfy(cmp(3+4i,3+4i) == 0, '882: cmp(3+4i,3+4i) == 0'); + vrfy(cmp(3+4i,3-4i) == 1i, '883: cmp(3+4i,3-4i) == 1i'); + vrfy(cmp(3+4i,2+3i) == 1+1i, '884: cmp(3+4i,2+3i) == 1+1i'); + vrfy(cmp(3+4i,-4-5i) == 1+1i, '885: cmp(3+4i,-4-5i) == 1+1i'); + vrfy(comb(7,0) == 1, '886: comb(7,0) == 1'); + vrfy(comb(0,0) == 1, '887: comb(0,0) == 1'); + vrfy(perm(7,0) == 7, '888: perm(7,0) == 7'); + vrfy(perm(0,0) == 0, '889: perm(0,0) == 0'); + vrfy(isfile(files(0)) == 1, '890: isfile(files(0)) == 1'); + vrfy(isfile(0) == 0, '891: isfile(0) == 0'); + vrfy(ismult(4^67, 2^59) == 1, '892: ismult(4^67, 2^59) == 1'); + vrfy(ismult(13, 4/67) == 0, '893: ismult(13, 4/67) == 0'); + vrfy(ismult(13, 7/56) == 1, '894: ismult(13, 7/56) == 1'); + vrfy(isnum(2i) == 1, '895: isnum(2i) == 1'); + vrfy(iseven(1/3) == 0, '896: iseven(1/3) == 0'); + vrfy(isodd(1/3) == 0, '897: isodd(1/3) == 0'); + vrfy(isrel(-5, 6) == 1, '898: isrel(-5, 6) == 1'); + vrfy(isrel(-2, 6) == 0, '899: isrel(-2, 6) == 0'); + vrfy(isset(9,0) == 1, '900: isset(9,0) == 1'); + vrfy(isset(9,1) == 0, '901: isset(9,1) == 0'); + vrfy(isset(9,2) == 0, '902: isset(9,2) == 0'); + vrfy(isset(9,3) == 1, '903: isset(9,3) == 1'); + vrfy(isset(1.25, -2) == 1, '904: isset(1.25, -2) == 1'); + vrfy(isset(1.25, -1) == 0, '905: isset(1.25, -1) == 0'); + vrfy(isset(1.25, 0) == 1, '906: isset(1.25, 0) == 1'); + vrfy(isset(pi(), 1) == 1, '907: isset(pi(), 1) == 1'); + vrfy(isset(pi(), -2) == 0, '908: isset(pi(), -2) == 0'); + vrfy(isset(pi(), -3) == 1, '909: isset(pi(), -3) == 1'); + vrfy(istype(2, 3.0) == 1, '910: istype(2, 3.0) == 1'); + vrfy(istype(2, "2") == 0, '911: istype(2, "2") == 0'); + vrfy(istype(2, 3i) == 0, '912: istype(2, 3i) == 0'); + vrfy(istype(2i+2, 3i) == 1, '913: istype(2i+2, 3i) == 1'); + a = epsilon(); + print '914: a = epsilon()'; + vrfy(epsilon(a) == epsilon(), '915: epsilon(a) == epsilon()'); + vrfy(epsilon(a) == epsilon(), '916: epsilon(a) == epsilon()'); + vrfy(epsilon(a) == epsilon(), '917: epsilon(a) == epsilon()'); + vrfy(epsilon() == a, '918: epsilon() == a'); + b = 1e-6; + print '919: b = 1e-6'; + vrfy(epsilon(b) == a, '920: epsilon(b) == a'); + vrfy(epsilon(b) == epsilon(), '921: epsilon(b) == epsilon()'); + vrfy(epsilon(b) == epsilon(), '922: epsilon(b) == epsilon()'); + vrfy(epsilon(b) == epsilon(), '923: epsilon(b) == epsilon()'); + vrfy(epsilon() == 1e-6, '924: epsilon() == 1e-6'); + vrfy(epsilon(a) == b, '925: epsilon(a) == b'); + vrfy(epsilon(a) == epsilon(), '926: epsilon(a) == epsilon()'); + vrfy(epsilon(a) == epsilon(), '927: epsilon(a) == epsilon()'); + vrfy(epsilon(a) == epsilon(), '928: epsilon(a) == epsilon()'); + vrfy(epsilon(a) == a, '929: epsilon(a) == a'); + vrfy(quomod(13,5,a,b) == 1, '930: quomod(13,5,a,b) == 1'); + vrfy(a == 2, '931: a == 2'); + vrfy(b == 3, '932: b == 3'); + vrfy(quomod(15.6,5.2,a,b) == 0, '933: quomod(15.6,5.2,a,b) == 0'); + vrfy(a == 3, '934: a == 3'); + vrfy(b == 0, '935: b == 0'); + vrfy(putenv("abcd=efg") == 0, '936: putenv("abcd=efg")'); + vrfy(getenv("abcd") == "efg", '937: getenv("abcd") == "efg"'); + vrfy(putenv("abcd","123")==0, '938: putenv("abcd","123")'); + vrfy(getenv("abcd") == "123", '939: getenv("abcd") == "123"'); + vrfy(isnull(getenv("notavar")) == 1, + '940: isnull(getenv("notavar")) == 1'); + a = "abcdefg"; + print '941: a = "abcdefg"'; + vrfy(strpos(a, "c") == 3, '942: strpos(a, "c") == 3'); + vrfy(strpos(a, "def") == 4, '943: strpos(a, "def") == 4'); + vrfy(strpos(a, "defg") == 4, '944: strpos(a, "defg") == 4'); + vrfy(strpos(a, "defgh") == 0, '945: strpos(a, "defgh") == 0'); + vrfy(strpos(a, "abc") == 1, '946: strpos(a, "abc") == 1'); + vrfy(strpos(a, "xyz") == 0, '947: strpos(a, "xyz") == 0'); + vrfy(strpos(a, a) == 1, '948: strpos(a, a) == 1'); + vrfy(system("") == 0, '949: system("") == 0'); + vrfy(system("true") == 0, '950: system("true") == 0'); + vrfy(isatty(files(0)) == 1, '951: isatty(files(0)) == 1'); + print '952: test removed'; + print '953: test removed'; + vrfy(isstr(cmdbuf()) == 1, '954: isstr(cmdbuf()) == 1'); + vrfy(abs(root(4,3,0.1)-1.5874) < 0.1, + '955: abs(root(4,3,0.1)-1.5874) < 0.1'); + print '956: a = 2^300 + 69962309754533779525365054067'; + a = 2^300 + 69962309754533779525365054067; + a /= 2^211; + print '957: a /= 2^211'; + vrfy(appr(a, 1e-20) == 2^89, '958: appr(a, 1e-20) == 2^89'); + vrfy(digits(5e149) == 150, '959: digits(5e149) == 150'); + vrfy(highbit(2) == 1, '960: highbit(2) == 1'); + vrfy(highbit(3) == 1, '961: highbit(3) == 1'); + vrfy(highbit(4) == 2, '962: highbit(4) == 2'); + vrfy(highbit(-15) == 3, '963: highbit(-15) == 3'); + vrfy(highbit(2^27) == 27, '964: highbit(2^27) == 27'); + a = 12.34; + print '965: a = 12.34'; + vrfy(digit(a,2) == 0, '966: digit(a,2) == 0'); + vrfy(digit(a,1) == 1, '967: digit(a,1) == 1'); + vrfy(digit(a,0) == 2, '968: digit(a,0) == 2'); + vrfy(digit(a,-1) == 3, '969: digit(a,-1) == 3'); + vrfy(digit(a,-2) == 4, '970: digit(a,-2) == 4'); + a = 10/7; + print '971: a = 10/7'; + vrfy(digit(a,1) == 0, '972: digit(a,1) == 0'); + vrfy(digit(a,0) == 1, '973: digit(a,0) == 1'); + vrfy(digit(a,-1) == 4, '974: digit(a,-1) == 4'); + vrfy(digit(a,-2) == 2, '975: digit(a,-2) == 2'); + vrfy(digit(a,-3) == 8, '976: digit(a,-3) == 8'); + vrfy(digits(0) == 1, '977: digits(0) == 1'); + vrfy(digits(0.0123) == 1, '978: digits(0.0123) == 1'); + vrfy(digits(3.7) == 1, '979: digits(3.7) == 1'); + vrfy(digits(-27) == 2, '980: digits(-27) == 2'); + vrfy(digits(-99.7) == 2, '981: digits(-99.7) == 2'); + vrfy(ilog2(1) == 0, '982: ilog2(1) == 0'); + vrfy(ilog2(2) == 1, '983: ilog2(2) == 1'); + vrfy(ilog2(3) == 1, '984: ilog2(3) == 1'); + vrfy(ilog2(4) == 2, '985: ilog2(4) == 2'); + vrfy(ilog2(1/15) == -4, '986: ilog2(1/15) == -4'); + vrfy(places(3) == 0, '987: places(3) == 0'); + vrfy(places(0.0123) == 4, '988: places(0.0123) == 4'); + vrfy(places(3.70) == 1, '989: places(3.70) == 1'); + vrfy(places(1e-10) == 10, '990: places(1e-10) == 10'); + vrfy(places(3/7) == -1, '991: places(/37) == -1'); + vrfy(ilog10(7.7) == 0, '992: ilog10(7.7) == 0'); + vrfy(ilog10(77.7) == 1, '993: ilog10(77.7) == 1'); + vrfy(ilog10(777) == 2, '994: ilog10(777) == 2'); + vrfy(ilog10(.00777) == -3, '995: ilog10(.00777) == -3'); + vrfy(ilog10(1e27) == 27, '996: ilog10(1e27) == 27'); + vrfy(lowbit(2) == 1, '997: lowbit(2) == 1'); + vrfy(lowbit(3) == 0, '998: lowbit(3) == 0'); + vrfy(lowbit(4) == 2, '999: lowbit(4) == 2'); + vrfy(lowbit(-15) == 0, '1000: lowbit(-15) == 0'); + vrfy(lowbit(2^27) == 27, '1001: lowbit(2^27) == 27'); + vrfy(char(0102) == 'B', '1002: char(0102) == \'B\''); + vrfy(char(0x6f) == 'o', '1003: char(0x6f) == \'o\''); + vrfy(char(119) == 'w', '1004: char(119) == \'w\''); + vrfy(char(0145) == 'e', '1005: char(0145) == \'e\''); + vrfy(char(0x6e) == 'n', '1006: char(0x6e) == \'n\''); + vrfy(den(-1.25) == 4, '1007: den(-1.25) == 4'); + vrfy(den(121/33) == 3, '1008: den(121/33) == 3'); + vrfy(gcd(9/10, 11/5, 4/25) == 0.02, + '1009: gcd(9/10, 11/5, 4/25) == 0.02'); + vrfy(gcd(0,0,0,0,0) == 0, '1010: gcd(0,0,0,0,0) == 0'); + vrfy(hypot(3, 4, 1e-6) == 5, '1011: hypot(3, 4, 1e-6) == 5'); + vrfy(hypot(2,-3,1e-6) == 3605551/1e6, + '1012: hypot(2,-3,1e-6) == 3605551/1e6'); + vrfy(im(-4.25 - 7i) == -7, '1013: im(-4.25 - 7i) == -7'); + vrfy(lcm(12, -24, 30) == -120,'1014: lcm(12, -24, 30) == -120'); + vrfy(lcm(9/10, 11/5, 4/25) == 79.2, + '1015: lcm(9/10, 11/5, 4/25) == 79.2'); + vrfy(lcm(2) == 2, '1016: lcm(2) == 2'); + vrfy(max(2) == 2, '1017: max(2) == 2'); + vrfy(min(2) == 2, '1018: min(2) == 2'); + vrfy(re(-4.25 - 7i) == -4.25, '1019: re(-4.25 - 7i) == -4.25'); + vrfy(size("abc") == 3, '1020: size("abc") == 3'); + vrfy(str("") == "", '1021: str("") == ""'); + vrfy(str(null()) == "", '1022: str(null()) == ""'); + vrfy(str("Ernest Bowen") == "Ernest Bowen", + '1023: str("Ernest Bowen") == "Ernest Bowen"'); + vrfy(strlen("a b\tc\\d") == 7, + '1024: strlen("a b\tc\\d") == 7'); + vrfy(xor(2) == 2, '1025: xor(2) == 2'); + vrfy(xor(5, 3, -7, 2, 9) == 10, + '1026: xor(5, 3, -7, 2, 9) == 10'); + vrfy(xor(0,0) == 0, '1027: xor(0,0) == 0'); + vrfy(xor(0,1) == 1, '1028: xor(0,1) == 1'); + vrfy(xor(1,0) == 1, '1029: xor(1,0) == 1'); + vrfy(xor(1,1) == 0, '1030: xor(1,1) == 0'); + vrfy(xor(5,3,-7,2,9) == 10, '1031: xor(5,3,-7,2,9) == 10'); + vrfy(fib(-2) == -1, '1032: fib(-2) == -1'); + vrfy(fib(-1) == 1, '1033: fib(-1) == 1'); + vrfy(fib(-10) == -55, '1034: fib(-10) == -55'); + vrfy(ilog(1/8, 3) == -2, '1035: ilog(1/8, 3) == -2'); + vrfy(ilog(8.9, 3) == 1, '1036: ilog(8.9, 3) == 1'); + vrfy(iroot(1,9) == 1, '1037: iroot(1,9) == 1'); + vrfy(iroot(pi()^8,5) == 6, '1038: iroot(pi()^8,5)'); + vrfy(isqrt(8.5) == 2, '1039: isqrt(8.5) == 2'); + vrfy(isqrt(2e56) == 14142135623730950488016887242, + '1040: isqrt(2e56) == 14142135623730950488016887242'); + vrfy(near(22/7, 3.15, .01) == -1, + '1041: near(22/7, 3.15, .01) == -1'); + vrfy(near(22/7, 3.15, .005) == 1, + '1042: near(22/7, 3.15, .005) == 1'); + vrfy(norm(3.4) == 11.56, '1043: isqrt(3.4) == 11.56'); + vrfy(pi(1e-5) == 3.14159, '1044: pi(1e-5) == 3.14159'); + pi = pi(1e-10); + print '1045: pi = pi(1e-10)'; + vrfy(pi == 3.1415926536, '1046: pi == 3.1415926536'); + vrfy(polar(2,pi/2,1e-5)==2i, '1047: polar(2,pi/2,1e-5)==2i'); + vrfy(power(exp(1,1e-20),pi(1e-20)*1i/2,1e-20) == 1i, + '1048: power(exp(1,1e-20),pi(1e-20)*1i/2,1e-20) == i1'); + vrfy(ssq(1+2i, 3-4i, 5 +6i) == -21+40i, + '1049: ssq(1+2i, 3-4i, 5 +6i) == -21+40i'); + vrfy(isreal(ln(1 + 1e-10i, 1e-5)), + '1050: isreal(ln(1 + 1e-10i, 1e-5))'); + vrfy(isreal(exp(pi(1e-10)*1i, 1e-5)), + '1051: isreal(exp(pi(1e-10)*1i, 1e-5))'); + vrfy(cfappr(43/30, 10, 0) == 10/7, + '1052: cfappr(43/30, 10, 0) == 10/7'); + vrfy(cfappr(43/30, 10, 1) == 13/9, + '1053: cfappr(43/30, 10, 1) == 13/9'); + vrfy(cfappr(43/30, 10, 16) == 10/7, + '1054: cfappr(43/30, 10, 16) == 10/7'); + vrfy(cfappr(6/5, 1/2, 16) == 1, + '1055: cfappr(6/5, 1/2, 16) == 1'); + vrfy(cfsim(13,8) == 0, '1056: cfsim(13,8) == 0'); + vrfy(cfsim(1057,8) == 0, '1057: cfsim(1057,8) == 0'); + vrfy(mod(11,5,0) == 1, '1058: mod(11,5,0) == 1'); + vrfy(mod(11,5,1) == -4, '1059: mod(11,5,1) == -4'); + vrfy(mod(-11,5,2) == -1, '1060: mod(-11,5,2) == -1'); + vrfy(mod(-11,-5,3) == 4, '1061: mod(-11,-5,3) == 4'); + vrfy(mod(12.5,5,16) == 2.5, '1062: mod(12.5,5,16) == 2.5'); + vrfy(mod(12.5,5,17) == -2.5, '1063: mod(12.5,5,17) == -2.5'); + vrfy(mod(12.5,5,24) == 2.5, '1064: mod(12.5,5,24) == 2.5'); + vrfy(mod(-7.5,-5,24) == 2.5, '1065: mod(-7.5,-5,24) == 2.5'); + vrfy(quo(11,5,0) == 2, '1066: quo(11,5,0) == 2'); + vrfy(quo(11,5,1) == 3, '1067: quo(11,5,1) == 3'); + vrfy(quo(-11,5,2) == -2, '1068: quo(-11,5,2) == -2'); + vrfy(quo(-11,-5,3) == 3, '1069: quo(-11,-5,3) == 3'); + vrfy(quo(12.5,5,16) == 2, '1070: quo(12.5,5,16) == 2'); + vrfy(quo(12.5,5,17) == 3, '1071: quo(12.5,5,17) == 3'); + vrfy(quo(12.5,5,24) == 2, '1072: quo(12.5,5,24) == 2'); + vrfy(quo(-7.5,-5,24) == 2, '1073: quo(-7.5,-5,24) == 2'); + vrfy(frac(2.5 + 3i) == .5, '1074: frac(2.5 + 3i) == .5'); + vrfy(root(1i,1000,1e-2)==1, '1075: root(1i,1000,1e-2) == 1'); + vrfy(scale(2+3i,2)==8+12i, '1076: scale(2+3i,2) == 8+12i'); + vrfy(frem(8,4) == 2, '1077: frem(8,4) == 2'); + vrfy(jacobi(80,199) == 1, '1078: jacobi(80,199) == 1'); + + print '1079: Ending test_functions'; + + print; + print '1100: reserved for future expansion of test_functions'; +} +print '017: parsed test_functions()'; + + +/* + * _test_underscore - test use of _'s in identifiers + */ +_ = 49; +print '018: _ = 49'; +__ = 63; +print "019: __ = 63"; +define _test_underscore() +{ + local _a = 27; + local __a = 23209; + + print "1200: Beginning _test_underscore"; + + vrfy(_a == 27, '1201: _a == 27'); + vrfy(_ == 49, '1202: _ == 49'); + vrfy(__ == 63, '1203: __ == 63'); + vrfy(__a == 23209, '1204: __a == 23209'); + + print "1205: Ending _test_underscore"; +} +print '020: parsed _test_underscore'; + + +/* + * place holder for any print items + */ +print "021:", "reserved for future use"; +print "022:": " reserved for future use"; + + +/* + * Test associations + */ +define test_assoc() +{ + static a; + static b; + local A; + + print '1300: Beginning associations test'; + + a = assoc(); + vrfy(size(a) == 0, '1301: size(a) == 0'); + a["curds"] = 13; + print '1302: a["curds"] = 13'; + vrfy(a["curds"] == 13, '1303: a["curds"] == 13'); + a[13] = 17; + print '1304: a[13] = 17'; + vrfy(a[13] == 17, '1305: a[13] == 17'); + vrfy(a[a["curds"]] == 17, '1306: a[a["curds"]] == 17'); + a[17] = 19; + print '1307: a[17] = 19'; + vrfy(a[17] == 19, '1308: a[17] == 19'); + vrfy(a[a["curds"]+4] == 19, '1309: a[a["curds"]+4] == 19'); + vrfy(size(a) == 3, '1310: size(a) == 3'); + vrfy(a[[search(a,17)]] == 17, '1311: (a[[search(a,17)]] == 17'); + vrfy(isnull(search(a,16)), '1312: isnull(search(a,16))'); + a["curds","whey"] = "spider"; + print '1313: a["curds","whey"] = "spider"'; + vrfy(a["curds","whey"] == "spider", '1314: a["curds","whey"] == "spider"'); + vrfy(a[[rsearch(a,"spider")]] == "spider", '1315: a[[search(a,"spider")]] == "spider"'); + b = a; + print '1316: b = a'; + vrfy(b[17] == 19, '1317: b[17] == 19'); + vrfy(a == b, '1318: a == b'); + vrfy(isassoc(a) == 1, '1319: isassoc(a) == 1'); + vrfy(isassoc(1) == 0, '1320: isassoc(1) == 0'); + A = assoc(); + vrfy(quomod(13, 5, A[1], A[2]) == 1, + '1321: quomod(13, 5, A[1], A[2]) == 1'); + vrfy(A[1] == 2, '1322: A[1] == 2'); + vrfy(A[2] == 3, '1323: A[2] == 3'); + + print '1324: Ending associations test'; +} +print '023: parsed test_assoc()'; + + +/* + * Test lists + */ +define test_list() +{ + static a; + static b; + static x = list(11,13,17,23,29); + static y0 = list(1,3,7,3,9); + static y1 = list(-9,-7,-3,-7,-1); + static y2 = list(-9,-7,-3,3,9); + static y3 = list(1,3,7,-7,-1); + static y4 = list(1,3,-3,3,-1); + local A,B,C,D,E; + local y,z; + local list1, list2; + + print '1400: Beginning list test'; + + a = list(2,3,5); + vrfy(a == list(2,3,5), '1401: a == list(2,3,5)'); + vrfy(a[[0]] == 2, '1402: a[[0]] == 2'); + vrfy(a[[1]] == 3, '1403: a[[1]] == 3'); + vrfy(a[[2]] == 5, '1404: a[[2]] == 5'); + vrfy(size(a) == 3, '1405: size(a) == 3'); + vrfy(search(a,3) == 1, '1406: search(a,3) == 1'); + vrfy(isnull(search(a,3,2)), '1407: isnull(search(a,3,2))'); + vrfy(rsearch(a,3,2) == 1, '1408: rsearch(a,3,2) == 1'); + push(a,7); + print '1409: push(a,7)'; + vrfy(search(a,7) == 0, '1410: search(a,7) == 0'); + vrfy(pop(a) == 7, '1411: pop(a) == 7'); + vrfy(size(a) == 3, '1412: size(a) == 3'); + append(a,7); + print '1413: append(a,7)'; + vrfy(search(a,7) == 3, '1414: search(a,7) == 3'); + vrfy(size(a) == 4, '1415: size(a) == 4'); + vrfy(remove(a) == 7, '1416: remove(a) == 7'); + vrfy(size(a) == 3, '1417: size(a) == 3'); + b = a; + print '1418: b = a'; + insert(a,1,7); + print '1419: insert(a,1,7)'; + vrfy(search(a,2) == 0, '1420: search(a,2) == 0'); + vrfy(search(a,7) == 1, '1421: search(a,7) == 1'); + vrfy(search(a,3) == 2, '1422: search(a,3) == 2'); + vrfy(search(a,5) == 3, '1423: search(a,5) == 3'); + vrfy(size(a) == 4, '1424: size(a) == 4'); + vrfy(delete(a,1) == 7, '1425: remove(a) == 7'); + vrfy(search(a,2) == 0, '1426: search(a,2) == 0'); + vrfy(search(a,3) == 1, '1427: search(a,3) == 1'); + vrfy(search(a,5) == 2, '1428: search(a,5) == 2'); + vrfy(size(a) == 3, '1429: size(a) == 3'); + vrfy(a == b, '1430: a == b'); + A = list(1,2,3); + print '1431: A = list(1,2,3)'; + B = list(4,5); + print '1432: B = list(4,5)'; + C = join(A,B); + print '1433: C = join(A,B)'; + D = list(1,2,3,4,5); + print '1434: D = list(1,2,3,4,5)'; + vrfy(C == D, '1435: C == D'); + E = list(5,4,3,2,1); + print '1436: E = list(5,4,3,2,1)'; + vrfy(reverse(D) == E, '1437: reverse(D) == E'); + vrfy(sort(list(1,3,5,2,4))==D,'1438: sort(list(1,3,5,2,4))==D'); + vrfy(head(D,2) == list(1,2), '1439: head(D,2) == list(1,2)'); + vrfy(head(D,-2)==list(1,2,3), '1440: head(D,-2)==list(1,2,3)'); + vrfy(head(D,5) == D, '1441: head(D,5) == D'); + vrfy(head(D,6) == D, '1442: head(D,6) == D'); + vrfy(head(D,-5) == list(), '1443: head(D,-5) == list()'); + vrfy(head(D,-6) == list(), '1444: head(D,-6) == list()'); + vrfy(tail(E,2) == list(2,1), '1445: tail(E,2) == list(2,1)'); + vrfy(tail(E,-2)==list(3,2,1), '1446: tail(E,-2)==list(3,2,1)'); + vrfy(tail(E,5) == E, '1447: tail(E,5) == E'); + vrfy(tail(E,6) == E, '1448: tail(E,6) == E'); + vrfy(tail(E,-5) == list(), '1449: tail(E,-5) == list()'); + vrfy(tail(E,-6) == list(), '1450: tail(E,-6) == list()'); + vrfy(segment(D,1,3) == list(2,3,4), + '1451: segment(D,1,3) == list(2,3,4)'); + vrfy(segment(D,3,1) == list(4,3,2), + '1452: segment(D,3,1) == list(4,3,2)'); + vrfy(segment(D,0,2) == head(D,3), + '1453: segment(D,0,2) == head(D,3)'); + vrfy(segment(D,2,0) == tail(E,3), + '1454: segment(D,2,0) == tail(E,3)'); + vrfy(segment(D,0,4) == head(D,5), + '1455: segment(D,0,4) == head(D,5)'); + vrfy(segment(D,4,0) == head(E,5), + '1456: segment(D,4,0) == head(E,5)'); + vrfy(segment(D,3,4) == tail(D,2), + '1457: segment(D,3,4) == tail(D,2)'); + vrfy(segment(D,4,3) == head(E,2), + '1458: segment(D,4,3) == head(E,2)'); + for (y=0; y < size(D); ++y) { + for (z=y; z < size(D); ++z) { + if (D != join(head(D,y), segment(D,y,z), tail(D,size(D)-z-1))) { + err(strcat("join loop failed at y=",str(y)," z=",str(z))); + } + } + } + print '1459: join loop test'; + vrfy(mod(x,10,0) == y0, '1460: mod(x,10,0) == y0'); + vrfy(mod(x,10,1) == y1, '1461: mod(x,10,1) == y1'); + vrfy(mod(x,10,2) == y0, '1462: mod(x,10,2) == y0'); + vrfy(mod(x,10,3) == y1, '1463: mod(x,10,3) == y1'); + vrfy(mod(x,10,4) == y0, '1464: mod(x,10,4) == y0'); + vrfy(mod(x,10,5) == y1, '1465: mod(x,10,5) == y1'); + vrfy(mod(x,10,6) == y0, '1466: mod(x,10,6) == y0'); + vrfy(mod(x,10,7) == y1, '1467: mod(x,10,7) == y1'); + vrfy(mod(x,10,8) == y2, '1468: mod(x,10,8) == y2'); + vrfy(mod(x,10,9) == y3, '1469: mod(x,10,9) == y3'); + vrfy(mod(x,10,10) == y2, '1470: mod(x,10,10) == y2'); + vrfy(mod(x,10,11) == y3, '1471: mod(x,10,11) == y3'); + vrfy(mod(x,10,12) == y2, '1472: mod(x,10,12) == y2'); + vrfy(mod(x,10,13) == y3, '1473: mod(x,10,13) == y3'); + vrfy(mod(x,10,14) == y2, '1474: mod(x,10,14) == y2'); + vrfy(mod(x,10,15) == y3, '1475: mod(x,10,15) == y3'); + vrfy(mod(x,10,16) == y4, '1476: mod(x,10,16) == y4'); + vrfy(mod(x,10,16) == y4, '1477: mod(x,10,16) == y4'); + vrfy(mod(x,10,18) == y4, '1478: mod(x,10,18) == y4'); + vrfy(mod(x,10,19) == y4, '1479: mod(x,10,18) == y4'); + vrfy(mod(x,10,20) == y4, '1480: mod(x,10,20) == y4'); + vrfy(mod(x,10,21) == y4, '1481: mod(x,10,21) == y4'); + vrfy(mod(x,10,22) == y4, '1482: mod(x,10,22) == y4'); + vrfy(mod(x,10,23) == y4, '1483: mod(x,10,23) == y4'); + vrfy(mod(x,10,24) == y4, '1484: mod(x,10,24) == y4'); + vrfy(mod(x,10,25) == y4, '1485: mod(x,10,25) == y4'); + vrfy(mod(x,10,26) == y4, '1486: mod(x,10,26) == y4'); + vrfy(mod(x,10,27) == y4, '1487: mod(x,10,27) == y4'); + vrfy(mod(x,10,28) == y4, '1488: mod(x,10,28) == y4'); + vrfy(mod(x,10,29) == y4, '1489: mod(x,10,29) == y4'); + vrfy(mod(x,10,30) == y4, '1490: mod(x,10,30) == y4'); + vrfy(mod(x,10,31) == y4, '1491: mod(x,10,31) == y4'); + list1 = list(3,1,"x",2,null()); + print '1492: list1 = list(3,1,"x",2,null())'; + list2 = list(null(),1,2,3,"x"); + print '1493: list2 = list(null(),1,2,3,"x")'; + vrfy(sort(list1) == list2, '1494: sort(list1) == list2'); + + print '1495: Ending list test'; +} +print '024: parsed test_list()'; + + +/* + * Test rand + */ +define test_rand() +{ + local init; /* initial generator state */ + local state0; /* a generator state */ + local state1; /* a generator state */ + local state2; /* a generator state */ + local tmp; + local n; + + print '1500: Beginning rand test'; + + /* test save and restore of the initial state */ + tmp = srand(0); + print '1501: tmp = srand(0)'; + init = srand(); + print '1502: init = srand()'; + state0 = srand(0); + print '1503: state0 = srand(0)'; + vrfy(state0 == init, '1504: state0 == init'); + + /* test the additive 55 shuffle generator */ + tmp = srand(0); + print '1505: tmp = srand(0)'; + vrfy(rand() == 0xc79ef743e2e6849c, \ + '1506: rand() == 0xc79ef743e2e6849c'); + vrfy(rand() == 0x8d2dcb2bed321284, \ + '1507: rand() == 0x8d2dcb2bed321284'); + tmp = srand(init); + print '1508: tmp = srand(init)'; + vrfy(rand() == 0xc79ef743e2e6849c, \ + '1509: rand() == 0xc79ef743e2e6849c'); + vrfy(rand() == 0x8d2dcb2bed321284, \ + '1510: rand() == 0x8d2dcb2bed321284'); + + /* test range interface */ + tmp = srand(0); + print '1511: tmp = srand(0)'; + vrfy(rand(12345678901234567890) == 0x8d2dcb2bed321284, \ + '1512: rand(12345678901234567890) == 0x8d2dcb2bed321284'); + vrfy(rand(216091) == 0x13d2b, '1513: rand(216091) == 0x13d2b'); + vrfy(rand(100) == 0x26, '1514: rand(100) == 0x26'); + vrfy(rand(-46,46) == -0xf, '1515: rand(-46,46) == -0xf'); + tmp = srand(0); + print '1516: tmp = srand(0)'; + vrfy(rand(2^64) == 0xc79ef743e2e6849c, \ + '1517: rand(2^64) == 0xc79ef743e2e6849c'); + vrfy(rand(0,2^64) == 0x8d2dcb2bed321284, \ + '1518: rand(0,2^64) == 0x8d2dcb2bed321284'); + + /* test different forms of seeding the initial state */ + tmp = srand(0); + print '1519: tmp = srand(0)'; + vrfy(srand() == init, '1520: srand() == init'); + tmp = srand(0x87e6ec938ff55aa5<<64); + print '1521: tmp = srand(0x87e6ec938ff55aa5<<64)'; + vrfy(srand() == init, '1522: srand() == init'); + tmp = srand(state0); + print '1523: tmp = srand(state0)'; + vrfy(srand() == init, '1524: srand() == init'); + tmp = srand(init); + print '1525: tmp = srand(init)'; + vrfy(srand() == init, '1526: srand() == init'); + vrfy(tmp == init, '1527: tmp == init'); + + /* test the bit length interface */ + tmp = srand(0); + print '1528: tmp = srand(0)'; + vrfy(randbit(64) == 0xc79ef743e2e6849c, \ + '1529: randbit(64) == 0xc79ef743e2e6849c'); + vrfy(randbit(128) == 0x8d2dcb2bed3212844f4ad31f3818af34, \ + '1530: randbit(128) == 0x8d2dcb2bed3212844f4ad31f3818af34'); + vrfy(randbit(64) == 0x23a252f60bae4907, \ + '1531: randbit(64) == 0x23a252f60bae4907'); + vrfy(randbit(128) == 0xa8ed5b6203e2b1da32848cd9b3f1e3fa, \ + '1532: randbit(128) == 0xa8ed5b6203e2b1da32848cd9b3f1e3fa'); + tmp = srand(0); + print '1533: tmp = srand(0)'; + vrfy(randbit(32) == 0xc79ef743, '1534: randbit(64) == 0xc79ef743'); + vrfy(randbit(32) == 0xe2e6849c, '1535: randbit(64) == 0xe2e6849c'); + vrfy(randbit(1) == 0x1, '1536: randbit(1) == 0x1'); + vrfy(randbit(5) == 0x3, '1537: randbit(5) == 0x3'); + vrfy(randbit(33) == 0x96e595f6, '1538: randbit(33) == 0x96e595f6'); + vrfy(randbit(25) == 0x1321284, '1539: randbit(25) == 0x1321284'); + vrfy(randbit(2) == 0x1, '1540: randbit(2) == 0x1'); + vrfy(randbit(13) == 0x7a5, '1541: randbit(13) == 0x7a5'); + vrfy(randbit(18) == 0x1a63e, '1542: randbit(19) == 0x1a63e'); + vrfy(randbit(8) == 0x70, '1543: randbit(8) == 0x70'); + vrfy(randbit(9) == 0x62, '1544: randbit(9) == 0x62'); + vrfy(randbit(70) == 0x2f3423a252f60bae49, \ + '1545: randbit(70) == 0x2f3423a252f60bae49'); + print '1546: test unused'; + vrfy(randbit(8) == 0x7, '1547: randbit(8) == 0x7'); + vrfy(randbit(65) == 0x151dab6c407c563b4, \ + '1548: randbit(65) == 0x151dab6c407c563b4'); + vrfy(randbit(63) == 0x32848cd9b3f1e3fa, \ + '1549: randbit(63) == 0x32848cd9b3f1e3fa'); + + /* check to be sure that the srand(1) bug was fixed */ + tmp = srand(1); + print '1550: tmp = srand(1)'; + n = 1; + print '1551: n = 1'; + vrfy(num(n), '1552: num(n)'); + vrfy(den(n), '1553: den(n)'); + vrfy(randbit(64) == 0x4280429f8069cb27, \ + '1554: randbit(64) == 0x4280429f8069cb27'); + + /* test randbit skip interface */ + tmp = srand(0); + print '1555: tmp = srand(0)'; + vrfy(randbit(20) == 817647, '1556: randbit(20) == 817647'); + vrfy(randbit(20) == 476130, '1557: randbit(20) == 476130'); + vrfy(randbit(20) == 944201, '1558: randbit(20) == 944201'); + vrfy(randbit(20) == 822573, '1559: randbit(20) == 822573'); + tmp = srand(0); + print '1560: tmp = srand(0)'; + vrfy(randbit(-20) == 20, '1561: randbit(-20) == 20'); + vrfy(randbit(20) == 476130, '1562: randbit(20) == 476130'); + vrfy(randbit(-20) == 20, '1563: randbit(-20) == 20'); + vrfy(randbit(20) == 822573, '1564: randbit(20) == 822573'); + + /* test randbit without and arg */ + tmp = srand(0); + print '1565: tmp = srand(0)'; + vrfy(randbit() == 1, '1566: randbit() == 1'); + vrfy(randbit() == 1, '1567: randbit() == 1'); + vrfy(randbit() == 0, '1568: randbit() == 0'); + + print '1569: Ending rand test'; +} +print '025: parsed test_rand()'; + + +/* + * Config mode/base testing + */ +define test_mode() +{ + local tmp; + + print '1600: Beginning mode/base test'; + + tmp = config("mode", "frac"); + print '1601: tmp = config("mode", "frac")'; + tmp = config("mode", "frac"); + print '1602: tmp = config("mode", "frac")'; + vrfy(base() == 1/3, '1603: base() == 1/3'); + + tmp = config("mode", "int"); + print '1604: tmp = config("mode", "int")'; + vrfy(tmp == "frac", '1605: tmp == "frac"'); + vrfy(base() == -10, '1606: base() == -10'); + + tmp = config("mode", "real"); + print '1607: tmp = config("mode", "real")'; + vrfy(tmp == "int", '1608: tmp == "int"'); + vrfy(base() == 10, '1609: base() == 10'); + + tmp = config("mode", "exp"); + print '1610: tmp = config("mode", "exp")'; + vrfy(tmp == "real", '1611: tmp == "real"'); + vrfy(base() == 1e20, '1612: base() == 1e20'); + + tmp = config("mode", "hex"); + print '1613: tmp = config("mode", "hex")'; + vrfy(tmp == "exp", '1614: tmp == "exp"'); + vrfy(base() == 16, '1615: base() == 16'); + + tmp = config("mode", "oct"); + print '1616: tmp = config("mode", "oct")'; + vrfy(tmp == "hexadecimal", '1617: tmp == "hexadecimal"'); + vrfy(base() == 8, '1618: base() == 8'); + + tmp = config("mode", "bin"); + print '1619: tmp = config("mode", "bin")'; + vrfy(tmp == "octal", '1620: tmp == "octal"'); + vrfy(base() == 2, '1621: base() == 2'); + + tmp = config("mode", "real"); + print '1622: tmp = config("mode", "real")'; + vrfy(tmp == "binary", '1623: tmp == "binary"'); + + tmp = base(1/3); + print '1624: tmp = base(1/3)'; + vrfy(config("mode") == "frac", '1625: config("mode") == "frac"'); + + tmp = base(-10); + print '1626: tmp = base(-10)'; + vrfy(config("mode") == "int", '1627: config("mode") == "int"'); + + tmp = base(10); + print '1628: tmp = base(10)'; + vrfy(config("mode") == "real", '1629: config("mode") == "real"'); + + tmp = base(1e20); + print '1630: tmp = base(1e20)'; + vrfy(config("mode") == "exp", '1631: config("mode") == "exp"'); + + tmp = base(16); + print '1632: tmp = base(16)'; + vrfy(config("mode") == "hexadecimal", \ + '1633: config("mode") == "hexadecimal"'); + + tmp = base(8); + print '1634: tmp = base(8)'; + vrfy(config("mode") == "octal", '1635: config("mode") == "octal"'); + + tmp = base(2); + print '1636: tmp = base(2)'; + vrfy(config("mode") == "binary",'1637: config("mode") == "binary"'); + + tmp = base(8); + print '1638: tmp = base(8)'; + vrfy(str(0x80000000) == "020000000000", \ + '1639: str(0x8000000) == \"020000000000\"'); + vrfy(str(0xffffffff) == "037777777777", \ + '1640: str(0xffffffff) == \"037777777777\"'); + vrfy(str(3e9) == "026264057000", \ + '1641: str(3e9) == \"026264057000\"'); + + tmp = base(16); + print '1642: tmp = base(16)'; + vrfy(str(0x80000000) == "0x80000000", \ + '1643: str(0x8000000) == \"0x80000000\"'); + vrfy(str(0xffffffff) == "0xffffffff", \ + '1644: str(0xffffffff) == \"0xffffffff\"'); + vrfy(str(3e9) == "0xb2d05e00", \ + '1645: str(3e9) == \"0xb2d05e00\"'); + + tmp = base(10); + print '1646: tmp = base(10)'; + vrfy(config("mode") == "real", \ + '1647: config("mode") == "real"'); + + vrfy(str(0x80000000) == "2147483648", \ + '1648: str(0x80000000) == \"2147483648\"'); + vrfy(str(0xffffffff) == "4294967295", \ + '1649: str(0xffffffff) == \"4294967295\"'); + vrfy(str(3e9) == "3000000000", \ + '1650: str(3e9) == \"3000000000\"'); + + print '1651: Ending mode/base test'; +} +print '026: parsed test_mode()'; + + +/* + * The 1700's contain tests for reading scripts. These tests are + * done inline near the bottom. + */ + + +/* + * Test objects + */ +read -once "surd"; +print '027: read -once surd'; +/**/ +define test_obj() +{ + static obj surd a; + static obj surd b; + + print '1800: Beginning object test'; + + surd_type = -1; + vrfy(surd_type == -1, '1801: surd_type == -1'); + a = surd(2,3); + print '1802: a = surd(2,3)'; + vrfy(a == surd(2,3), '1803: a == surd(2,3)'); + vrfy(surd_value(a) == 2+3i, '1804: surd_value(a) == 2+3i'); + vrfy(conj(a) == surd(2,-3), '1805: conj(a) == surd(2,-3)'); + vrfy(norm(a) == 13, '1806: norm(a) == 13'); + vrfy(a+1 == surd(3,3), '1807: a+1 == surd(3,3)'); + b = surd(3,4); + print '1808: b = surd(3,4)'; + vrfy(a+b == surd(5,7), '1809: a+b == surd(5,7)'); + vrfy(a-b == surd(-1,-1), '1810: a-b == surd(-1,-1)'); + vrfy(++a == surd(3,3), '1811: ++a == surd(3,3)'); + vrfy(--a == surd(2,3), '1812: --a == surd(2,3)'); + vrfy(-a == surd(-2,-3), '1813: -a == surd(-2,-3)'); + vrfy(a*2 == surd(4,6), '1814: a*2 == surd(4,6)'); + vrfy(a*b == surd(-6,17), '1815: a*b == surd(-6,17)'); + vrfy(a^2 == surd(-5,12), '1816: a^2 == surd(-5,12)'); + vrfy(scale(a,2) == surd(8,12), '1817: scale(a,2) == surd(8,12)'); + vrfy(a<<3 == surd(16,24), '1818: a<<3 == surd(16,24)'); + vrfy(a/2 == surd(1,1.5), '1819: a/2 == surd(1,1.5)'); + vrfy(a/b == surd(0.72,0.04), '1820: a/b == surd(0.72,0.04)'); + vrfy(1/b == surd(0.12,-0.16), '1821: 1/b == surd(0.12,-0.16)'); + vrfy(inverse(b) == 1/b, '1822: inverse(b) == 1/b'); + vrfy(a != b, '1823: a != b'); + surd_type = 2; + print '1824: surd_type = 2'; + vrfy(surd_type == 2, '1825: surd_type == 2'); + vrfy(sgn(a) == 1, '1826: sgn(a) == 1'); + vrfy(a < b, '1827: a < b'); + vrfy(a <= a, '1828: a < a'); + vrfy(isobj(a) == 1, '1829: isobj(a) == 1'); + + print '1830: Ending object test'; +} +print '028: parsed test_obj()'; + + +/* + * Prime builtin function testing + */ +define test_prime() +{ + print '1900: Beginning prime builtins test'; + + vrfy(isprime(-3) == 1, '1901: isprime(-3) == 1'); + vrfy(isprime(-1) == 0, '1902: isprime(-1) == 0'); + vrfy(isprime(0) == 0, '1903: isprime(0) == 0'); + vrfy(isprime(1) == 0, '1904: isprime(1) == 0'); + vrfy(isprime(2) == 1, '1905: isprime(2) == 1'); + vrfy(isprime(3) == 1, '1906: isprime(3) == 1'); + vrfy(isprime(4) == 0, '1907: isprime(4) == 0'); + vrfy(isprime(5) == 1, '1908: isprime(5) == 1'); + vrfy(isprime(17) == 1, '1909: isprime(17) == 1'); + vrfy(isprime(100) == 0, '1910: isprime(100) == 0'); + vrfy(isprime(21701,-1) == 1, '1911: isprime(21701,-1) == 1'); + vrfy(isprime(65521,-1) == 1, '1912: isprime(65521,-1) == 1'); + vrfy(isprime(65535,-1) == 0, '1913: isprime(65535,-1) == 0'); + vrfy(isprime(65536,-1) == 0, '1914: isprime(65536,-1) == 0'); + vrfy(isprime(1234577) == 1, '1915: isprime(1234577) == 1'); + vrfy(isprime(1234579) == 0, '1916: isprime(1234579) == 0'); + vrfy(isprime(2^31-9) == 0, '1917: isprime(2^31-9) == 0'); + vrfy(isprime(2^31-1) == 1, '1918: isprime(2^31-1) == 1'); + vrfy(isprime(2^31+9) == 0, '1919: isprime(2^31+11) == 0'); + vrfy(isprime(2^31+11) == 1, '1920: isprime(2^31+11) == 1'); + vrfy(isprime(3e9) == 0, '1921: isprime(3e9) == 0'); + vrfy(isprime(3e9+19) == 1, '1922: isprime(3e9+19) == 1'); + vrfy(isprime(2^32-7) == 0, '1923: isprime(2^32-7) == 0'); + vrfy(isprime(2^32-5) == 1, '1924: isprime(2^32-5) == 1'); + vrfy(isprime(2^32,-1) == 0, '1925: isprime(2^32,-1) == 0'); + vrfy(isprime(2^32+1,-1) == -1, '1926: isprime(2^32+1,-1) == -1'); + vrfy(isprime(3^99,2) == 2, '1927: isprime(3^99,2) == 2'); + vrfy(isprime(4^99,2) == 0, '1928: isprime(3^99,2) == 0'); + vrfy(nextprime(-3) == 5, '1929: nextprime(-3) == 5'); + vrfy(nextprime(0) == 2, '1930: nextprime(0) == 2'); + vrfy(nextprime(1) == 2, '1931: nextprime(1) == 2'); + vrfy(nextprime(2) == 3, '1932: nextprime(2) == 3'); + vrfy(nextprime(3) == 5, '1933: nextprime(3) == 5'); + vrfy(nextprime(4) == 5, '1934: nextprime(4) == 5'); + vrfy(nextprime(5) == 7, '1935: nextprime(5) == 7'); + vrfy(nextprime(17) == 19, '1936: nextprime(17) == 19'); + vrfy(nextprime(100) == 101, '1937: nextprime(100) == 101'); + vrfy(nextprime(21701,-1) == 21713, + '1938: nextprime(21701,-1) == 21713'); + vrfy(nextprime(65519) == 65521, + '1939: nextprime(65519) == 65521'); + vrfy(nextprime(65520) == 65521, + '1940: nextprime(65520) == 65521'); + vrfy(nextprime(65521,-1) == 65537, + '1941: nextprime(65521,-1) == 65537'); + vrfy(nextprime(65531) == 65537, + '1942: nextprime(65531) == 65537'); + vrfy(nextprime(65535,-1) == 65537, + '1943: nextprime(65535,-1) == 65537'); + vrfy(nextprime(65536) == 65537, + '1944: nextprime(65536) == 65537'); + vrfy(nextprime(1234576,2)==1234577, + '1945: nextprime(1234576,2)==1234577'); + vrfy(nextprime(2^31-9) == 2^31-1, + '1946: nextprime(2^31-9) == 2^31-1'); + vrfy(nextprime(2^31-1) == 2^31+11, + '1947: nextprime(2^31-1) == 2^31+11'); + vrfy(nextprime(3e9) == 3e9+19,'1948: nextprime(3e9) == 3e9+19'); + vrfy(nextprime(2^32-7) == 2^32-5, + '1949: nextprime(2^32-7) == 2^32-5'); + vrfy(nextprime(2^32,-1) == -1, '1950: nextprime(2^32,-1) == -1'); + vrfy(nextprime(2^32+5,-1) == -1,'1951: nextprime(2^32+5,-1) == -1'); + vrfy(nextprime(3^99,-1) == -1, '1952: nextprime(3^99,-1) == -1'); + vrfy(nextprime(3^99,2) == 2, '1953: nextprime(3^99,2) == 2'); + vrfy(prevprime(-3,-1) == 2, '1954: prevprime(-3,-1) == 2'); + vrfy(prevprime(0,-1) == 0, '1955: prevprime(0,-1) == 0'); + vrfy(prevprime(1,-1) == 0, '1956: prevprime(1,-1) == 0'); + vrfy(prevprime(2,-2) == 0, '1957: prevprime(2,-2) == 0'); + vrfy(prevprime(5) == 3, '1958: prevprime(5) == 3'); + vrfy(prevprime(4) == 3, '1959: prevprime(4) == 3'); + vrfy(prevprime(7) == 5, '1960: prevprime(7) == 5'); + vrfy(prevprime(19) == 17, '1961: prevprime(19) == 17'); + vrfy(prevprime(100) == 97, '1962: prevprime(100) == 97'); + vrfy(prevprime(21713,-1) == 21701, + '1963: prevprime(21713,-1) == 21701'); + vrfy(prevprime(65520) == 65519, + '1964: prevprime(65520) == 65519'); + vrfy(prevprime(65521) == 65519, + '1965: prevprime(65521) == 65519'); + vrfy(prevprime(65522) == 65521, + '1966: prevprime(65520) == 65521'); + vrfy(prevprime(65523) == 65521, + '1967: prevprime(65523) == 65521'); + vrfy(prevprime(65531) == 65521, + '1968: prevprime(65531) == 65521'); + vrfy(prevprime(65535) == 65521, + '1969: prevprime(65535) == 65521'); + vrfy(prevprime(65536) == 65521, + '1970: prevprime(65536) == 65521'); + vrfy(prevprime(65537) == 65521, + '1971: prevprime(65537) == 65521'); + vrfy(prevprime(65539) == 65537, + '1972: prevprime(65539) == 65537'); + vrfy(prevprime(1234578,2)==1234577, + '1973: prevprime(1234578,2)==1234577'); + vrfy(prevprime(2^31-1) == 2^31-19, + '1974: prevprime(2^31-1) == 2^31-19'); + vrfy(prevprime(2^31+11) == 2^31-1, + '1975: prevprime(2^31+11) == 2^31-1'); + vrfy(prevprime(3e9) == 3e9-71,'1976: prevprime(3e9) == 3e9-17'); + vrfy(prevprime(2^32-3) == 2^32-5, + '1977: prevprime(2^32-3) == 2^32-5'); + vrfy(prevprime(2^32-1) == 2^32-5, + '1978: prevprime(2^32-1) == 2^32-5'); + vrfy(prevprime(2^32,-1) == -1, '1979: prevprime(2^32,-1) == -1'); + vrfy(prevprime(3^99,-1) == -1, '1980: prevprime(3^99,-1) == -1'); + vrfy(prevprime(3^99,2) == 2, '1981: prevprime(3^99,2) == 2'); + vrfy(pix(-1) == 0, '1982: pix(-1) == 0'); + vrfy(pix(1) == 0, '1983: pix(1) == 0'); + vrfy(pix(2) == 1, '1984: pix(2) == 1'); + vrfy(pix(3) == 2, '1985: pix(3) == 2'); + vrfy(pix(100) == 25, '1986: pix(100) == 25'); + vrfy(pix(1000) == 168, '1987: pix(1000) == 168'); + vrfy(pix(10000) == 1229, '1988: pix(10000) == 1229'); + vrfy(pix(100000) == 9592, '1989: pix(100000) == 9592'); + vrfy(pix(2^19+59) == 43393, '1990: pix(2^19+59) == 43393'); + vrfy(pix(1000000) == 78498, '1991: pix(1000000) == 78498'); + vrfy(pix(10000000) == 664579, '1992: pix(10000000) == 664579'); + vrfy(pix(2^32-6) == 203280220, '1993: pix(2^32-6) == 203280220'); + vrfy(pix(2^32-5) == 203280221, '1994: pix(2^32-5) == 203280221'); + vrfy(pix(2^32-1) == 203280221, '1995: pix(2^32-1) == 203280221'); + vrfy(pfact(40) == 7420738134810,'1996: pfact(40) == 7420738134810'); + vrfy(pfact(200)/pfact(198)==199,'1997: pfact(200)/pfact(198)==199'); + vrfy(nextprime(3e9)==nextcand(3e9), + '1998: nextprime(3e9)==nextcand(3e9)'); + vrfy(prevprime(3e9)==prevcand(3e9), + '1999: prevprime(3e9)==prevcand(3e9)'); + vrfy(nextcand(2^100,0)-2^100 == 3, + '2000: nextcand(2^100,0)-2^100 == 3'); + vrfy(nextcand(2^100)-2^100 == 277, + '2001: nextcand(2^100)-2^100 == 277'); + vrfy(2^100-prevcand(2^100,0) == 5, + '2002: 2^100-prevcand(2^100,0) == 5'); + vrfy(2^100-prevcand(2^100) == 15, + '2003: 2^100-prevcand(2^100) == 15'); + vrfy(nextcand(2^50,4,5)-2^50 == 55, + '2004: nextcand(2^50,4,5)-2^50 == 55'); + vrfy(2^50-prevcand(2^50,4,5) == 27, + '2005: 2^50-prevcand(2^50,4,5) == 27'); + vrfy(nextprime(2^32-6) == 2^32-5, + '2006: nextprime(2^32-6) == 2^32-5'); + vrfy(nextprime(2^32-5) == 2^32+15, + '2007: nextprime(2^32-5) == 2^32+15'); + vrfy(prevprime(2^32-1) == 2^32-5, + '2008: prevprime(2^32-1) == 2^32-5'); + vrfy(prevcand(2^50,4,5,0,4) == 0, + '2009: prevcand(2^50,4,5,0,4) == 0'); + vrfy(2^50-prevcand(2^50,4,5,1,4) == 27, + '2010: 2^50-prevcand(2^50,4,5,1,4) == 27'); + vrfy(prevcand(2^50,4,5,2,4) == 2, + '2011: prevcand(2^50,4,5,2,4) == 2'); + vrfy(2^50-prevcand(2^50,4,5,3,4) == 113, + '2012: 2^50-prevcand(2^50,4,5,3,4) == 113'); + vrfy(2^50-prevcand(2^50,4,5,7,17) == 813, + '2013: 2^50-prevcand(2^50,4,5,7,17) == 813'); + vrfy(nextcand(2^50,4,5,0,4) == 0, + '2014: nextcand(2^50,4,5,0,4) == 0'); + vrfy(nextcand(2^50,4,5,1,4)-2^50 == 145, + '2015: nextcand(2^50,4,5,1,4)-2^50 == 145'); + vrfy(nextcand(2^50,4,5,2,4) == 0, + '2016: nextcand(2^50,4,5,2,4) == 0'); + vrfy(nextcand(2^50,4,5,3,4)-2^50 == 55, + '2017: nextcand(2^50,4,5,3,4)-2^50 == 55'); + vrfy(nextcand(2^50,4,5,7,17)-2^50 == 853, + '2018: nextcand(2^50,4,5,7,17)-2^50 == 853'); + vrfy(ptest(2^100+277) == 1, '2019: ptest(2^100+277) == 1'); + vrfy(ptest(2^50-27,4,5) == 1, '2020: ptest(2^50-27,4,5) == 1'); + vrfy(ptest(2^50+55,4,5) == 1, '2021: ptest(2^50+55,4,5) == 1'); + vrfy(ptest(2^32+1,10) == 0, '2022: ptest(2^32+1,10) == 0'); + vrfy(lfactor(1001,100) == 7, '2023: lfactor(1001,100) == 7'); + vrfy(lfactor(1001,4) == 7, '2024: lfactor(1001,4) == 7'); + vrfy(lfactor(1001,3) == 1, '2025: lfactor(1001,3) == 1'); + vrfy(lfactor(127,10000) == 1, '2026: lfactor(127,10000) == 1'); + vrfy(lfactor(2^19-1,10000) == 1,'2027: lfactor(2^19-1,10000) == 1'); + vrfy(lfactor(2^31-1,10000) == 1,'2028: lfactor(2^31-1,10000) == 1'); + vrfy(lfactor(2^32-5,10000) == 1,'2029: lfactor(2^32-5,10000) == 1'); + vrfy(lfactor(2^38+7,50000) == 1,'2030: lfactor(2^38+7,50000) == 1'); + vrfy(lfactor(1009^2,pix(1009)) == 1009, + '2031: lfactor(1009^2,pix(1009)) == 1009'); + vrfy(lfactor(1009^2,pix(1009)-1) == 1, + '2032: lfactor(1009^2,pix(1009)-1) == 1'); + vrfy(lfactor(65519*65521,7000) == 65519, + '2033: lfactor(65519*65521,7000) == 65519'); + vrfy(lfactor(65521^2,pix(65521)) == 65521, + '2034: lfactor(65521^2,pix(65521)) == 65521'); + vrfy(lfactor(65521^2,pix(65521)-1) == 1, + '2035: lfactor(65521^2,pix(65521)-1) == 1'); + vrfy(lfactor(524309^6,100000) == 524309, + '2036: lfactor(524309^6,100000) == 524309'); + + print '2037: Ending prime builtins test'; +} +print '029: parsed test_prime()'; + + +/* + * Test the Lucas primality test library + */ +read -once "lucas_chk"; /* obtain our needed Lucas library */ +print '030: read lucas_chk'; +/**/ +define test_lucas() +{ + print '2100: Beginning lucas check test'; + + vrfy(lucas_chk(100,1) == 1, '2101: lucas_chk(100,1) == 1'); + + print '2102: Ending lucas check test'; +} +print '031: parsed test_lucas()'; + + +/* + * Test new operator functionality + */ +define test_newop() +{ + static mat A[3] = {1,2,3}; + static mat A2[3] = {1,2,3}; + local B; + local v; + local a; + local b; + + print '2200: Beginning new operator functionality test'; + + (v = 3) = 4; + print '2201: (v = 3) = 4'; + vrfy(v == 4, '2202: v == 4'); + (v += 3) *= 4; + print '2203: (v += 3) *= 4'; + vrfy(v == 28, '2204: v == 28'); + vrfy(A == A2, '2205: A == A2'); + matfill(B = A, 4); + print '2206: matfill(B = A, 4)'; + vrfy(A == A2, '2207: A == A2'); + vrfy(size(B) == 3, '2208: size(B) == 3'); + vrfy(B[0] == 4, '2209: B[0] == 4'); + vrfy(B[1] == 4, '2210: B[1] == 4'); + vrfy(B[2] == 4, '2211: B[2] == 4'); + a = 3; + print '2212: a = 3'; + ++(b = a); + print '2213: ++(b = a)'; + vrfy(a == 3, '2214: a == 3'); + vrfy(b == 4, '2215: b == 4'); + ++++a; + print '2216: ++++a'; + vrfy(a == 5, '2217: a == 5'); + vrfy((++a)++ == 6, '2218: (++a)++ == 6'); + vrfy(a == 7, '2219: a == 7'); + (++a) *= b; + print '2220: (++a) *= b'; + vrfy(a == 32, '2221: a == 32'); + vrfy(b == 4, '2222: b == 4'); + vrfy(++(a*=b) == 129, '2223: ++(a*=b) == 129'); + vrfy(a == 129, '2224: a == 129'); + vrfy(b == 4, '2225: b == 4'); + vrfy((a = (--a / b++))-- == 32, + '2226: (a = (--a / b++))-- == 32'); + vrfy(a == 31, '2227: a == 31'); + vrfy(b == 5, '2228: b == 5'); + vrfy((++++a / ----b) == 11, + '2229: (++++a / ----b) == 11'); + vrfy(a == 33, '2230: a == 33'); + vrfy(b == 3, '2231: b == 3'); + vrfy((a/=(--a/++b))-- == 4, + '2232: (a/=(--a/++b))-- == 4'); + vrfy(a == 3, '2233: a == 3'); + vrfy(b == 4, '2234: b == 4'); + v = a----; + print '2235: v = a----'; + vrfy(v == 3, '2236: v == 3'); + vrfy(a == 1, '2237: a == 1'); + a = ----v; + print '2238: a = ----v'; + vrfy(a == 1, '2239: a == 1'); + vrfy(v == 1, '2240: v == 1'); + v = a++++; + print '2241: v = a++++'; + vrfy(a == 3, '2242: a == 3'); + vrfy(v == 1, '2243: v == 1'); + a = ++++v; + print '2244: a = ++++v'; + vrfy(a == 3, '2245: a == 3'); + vrfy(v == 3, '2246: v == 3'); + a = ----v----; + print '2247: a = ----v----'; + vrfy(a == 1, '2248: a == 1'); + vrfy(v == -1, '2249: v == -1'); + v = ++++a++++; + print '2250: v = ++++a++++'; + vrfy(a == 5, '2251: a == 5'); + vrfy(v == 3, '2252: v == 3'); + a = ++++v----; + print '2253: a = ++++v----'; + vrfy(a == 5, '2254: a == 5'); + vrfy(v == 3, '2255: v == 3'); + v = --++a--++; + print '2256: v = --++a--++'; + vrfy(a == 5, '2257: a == 5'); + vrfy(v == 5, '2258: v == 5'); + a = -++v; + print '2259: a = -++v'; + vrfy(a == -6, '2260: a == -6'); + vrfy(v == 6, '2261: v == 6'); + + print '2262: Ending new operator functionality test'; +} +print '032: parsed test_newop()'; + + +/* + * Test object increment/decrement + */ +read -once "test2300"; +print '033: read -once test2300'; +/**/ +define test_xx_incdec() +{ + local A, B; + + print '2300: Beginning object increment/decrement test'; + + A = mkmat(1,2,3); + print '2301: A = mkmat(1,2,3)'; + vrfy(ckmat(A,1,2,3) == 1, + '2302: ckmat(A,1,2,3) == 1'); + B = A++; + print '2303: B = A++'; + vrfy(ckmat(B,1,2,3) == 1, + '2304: ckmat(B,1,2,3) == 1'); + vrfy(ckmat(A,2,3,4) == 1, + '2305: ckmat(A,2,3,4) == 1'); + B = A--; + print '2306: B = A--'; + vrfy(ckmat(A,1,2,3) == 1, + '2307: ckmat(A,1,2,3) == 1'); + vrfy(ckmat(B,2,3,4) == 1, + '2308: ckmat(B,2,3,4) == 1'); + B = ++A; + print '2309: B = ++A'; + vrfy(ckmat(A,2,3,4) == 1, + '2310: ckmat(A,2,3,4) == 1'); + vrfy(ckmat(B,2,3,4) == 1, + '2311: ckmat(B,2,3,4) == 1'); + B = --A; + print '2312: B = --A'; + vrfy(ckmat(A,1,2,3) == 1, + '2313: ckmat(A,1,2,3) == 1'); + vrfy(ckmat(B,1,2,3) == 1, + '2314: ckmat(B,1,2,3) == 1'); + + print '2315: Ending object increment/decrement test'; +} +print '034: parsed test_xx_incdec()'; + + +/* + * testing rounding config modes + */ +define test_round() +{ + local mode; + + print '2400: Beginning config rounding mode test'; + + /* appr mode 0 */ + mode = 0; + print '2401: mode = 0'; + vrfy(appr(-5.44,0.1,mode) == -5.5, + '2402: appr(-5.44,0.1,mode) == -5.5'); + vrfy(appr(5.44,0.1,mode) == 5.4, + '2403: appr(5.44,0.1,mode) == 5.4'); + vrfy(appr(5.7,1,mode) == 5, + '2404: appr(5.7,1,mode) == 5'); + vrfy(appr(-5.7,1,mode) == -6, + '2405: appr(-5.7,1,mode) == -6'); + vrfy(appr(-5.44,-0.1,mode) == -5.4, + '2406: appr(-5.44,-0.1,mode) == -5.4'); + vrfy(appr(5.44,-0.1,mode) == 5.5, + '2407: appr(5.44,-0.1,mode) == 5.5'); + vrfy(appr(5.7,-1,mode) == 6, + '2408: appr(5.7,-1,mode) == 6'); + vrfy(appr(-5.7,-1,mode) == -5, + '2409: appr(-5.7,-1,mode) == -5'); + + /* appr mode 1 */ + mode = 1; + print '2410: mode = 1'; + vrfy(appr(-5.44,0.1,mode) == -5.4, + '2411: appr(-5.44,0.1,mode) == -5.4'); + vrfy(appr(5.44,0.1,mode) == 5.5, + '2412: appr(5.44,0.1,mode) == 5.5'); + vrfy(appr(5.7,1,mode) == 6, + '2413: appr(5.7,1,mode) == 6'); + vrfy(appr(-5.7,1,mode) == -5, + '2414: appr(-5.7,1,mode) == -5'); + vrfy(appr(-5.44,-0.1,mode) == -5.5, + '2415: appr(-5.44,-0.1,mode) == -5.5'); + vrfy(appr(5.44,-0.1,mode) == 5.4, + '2416: appr(5.44,-0.1,mode) == 5.4'); + vrfy(appr(5.7,-1,mode) == 5, + '2417: appr(5.7,-1,mode) == 5'); + vrfy(appr(-5.7,-1,mode) == -6, + '2418: appr(-5.7,-1,mode) == -6'); + + /* appr mode 2 */ + mode = 2; + print '2419: mode = 2'; + vrfy(appr(-5.44,0.1,mode) == -5.4, + '2420: appr(-5.44,0.1,mode) == -5.4'); + vrfy(appr(5.44,0.1,mode) == 5.4, + '2421: appr(5.44,0.1,mode) == 5.4'); + vrfy(appr(5.7,1,mode) == 5, + '2422: appr(5.7,1,mode) == 5'); + vrfy(appr(-5.7,1,mode) == -5, + '2423: appr(-5.7,1,mode) == -5'); + + /* appr mode 3 */ + mode = 3; + print '2424: mode = 3'; + vrfy(appr(-5.44,0.1,mode) == -5.5, + '2425: appr(-5.44,0.1,mode) == -5.5'); + vrfy(appr(5.44,0.1,mode) == 5.5, + '2426: appr(5.44,0.1,mode) == 5.5'); + vrfy(appr(5.7,1,mode) == 6, + '2427: appr(5.7,1,mode) == 6'); + vrfy(appr(-5.7,1,mode) == -6, + '2428: appr(-5.7,1,mode) == -6'); + + /* appr mode 4 */ + mode = 4; + print '2429: mode = 4'; + vrfy(appr(-5.44,0.1,mode) == -5.5, + '2430: appr(-5.44,0.1,mode) == -5.5'); + vrfy(appr(5.44,0.1,mode) == 5.4, + '2431: appr(5.44,0.1,mode) == 5.4'); + vrfy(appr(5.7,1,mode) == 5, + '2432: appr(5.7,1,mode) == 5'); + vrfy(appr(-5.7,1,mode) == -6, + '2433: appr(-5.7,1,mode) == -6'); + + /* appr mode 5 */ + mode = 5; + print '2434: mode = 5'; + vrfy(appr(-5.44,0.1,mode) == -5.4, + '2435: appr(-5.44,0.1,mode) == -5.4'); + vrfy(appr(5.44,0.1,mode) == 5.5, + '2436: appr(5.44,0.1,mode) == 5.5'); + vrfy(appr(5.7,1,mode) == 6, + '2437: appr(5.7,1,mode) == 6'); + vrfy(appr(-5.7,1,mode) == -5, + '2438: appr(-5.7,1,mode) == -5'); + + /* appr mode 6 */ + mode = 6; + print '2439: mode = 6'; + vrfy(appr(-5.44,0.1,mode) == -5.4, + '2440: appr(-5.44,0.1,mode) == -5.4'); + vrfy(appr(5.44,0.1,mode) == 5.4, + '2441: appr(5.44,0.1,mode) == 5.4'); + vrfy(appr(5.7,1,mode) == 5, + '2442: appr(5.7,1,mode) == 5'); + vrfy(appr(-5.7,1,mode) == -5, + '2443: appr(-5.7,1,mode) == -5'); + vrfy(appr(-5.44,-0.1,mode) == -5.5, + '2444: appr(-5.44,-0.1,mode) == -5.5'); + vrfy(appr(5.44,-0.1,mode) == 5.5, + '2445: appr(5.44,-0.1,mode) == 5.5'); + vrfy(appr(5.7,-1,mode) == 6, + '2446: appr(5.7,-1,mode) == 6'); + vrfy(appr(-5.7,-1,mode) == -6, + '2447: appr(-5.7,-1,mode) == -6'); + + /* appr mode 7 */ + mode = 7; + print '2448: mode = 7'; + vrfy(appr(-5.44,0.1,mode) == -5.5, + '2449: appr(-5.44,0.1,mode) == -5.5'); + vrfy(appr(5.44,0.1,mode) == 5.5, + '2450: appr(5.44,0.1,mode) == 5.5'); + vrfy(appr(5.7,1,mode) == 6, + '2451: appr(5.7,1,mode) == 6'); + vrfy(appr(-5.7,1,mode) == -6, + '2452: appr(-5.7,1,mode) == -6'); + vrfy(appr(-5.44,-0.1,mode) == -5.4, + '2453: appr(-5.44,-0.1,mode) == -5.4'); + vrfy(appr(5.44,-0.1,mode) == 5.4, + '2454: appr(5.44,-0.1,mode) == 5.4'); + vrfy(appr(5.7,-1,mode) == 5, + '2455: appr(5.7,-1,mode) == 5'); + vrfy(appr(-5.7,-1,mode) == -5, + '2456: appr(-5.7,-1,mode) == -5'); + + /* appr mode 8 */ + mode = 8; + print '2457: mode = 8'; + vrfy(appr(-5.44,0.1,mode) == -5.4, + '2458: appr(-5.44,0.1,mode) == -5.4'); + vrfy(appr(5.44,0.1,mode) == 5.4, + '2459: appr(5.44,0.1,mode) == 5.4'); + vrfy(appr(5.7,1,mode) == 6, + '2460: appr(5.7,1,mode) == 6'); + vrfy(appr(-5.7,1,mode) == -6, + '2461: appr(-5.7,1,mode) == -6'); + + /* appr mode 9 */ + mode = 9; + print '2462: mode = 9'; + vrfy(appr(-5.44,0.1,mode) == -5.5, + '2463: appr(-5.44,0.1,mode) == -5.5'); + vrfy(appr(5.44,0.1,mode) == 5.5, + '2464: appr(5.44,0.1,mode) == 5.5'); + vrfy(appr(5.7,1,mode) == 5, + '2465: appr(5.7,1,mode) == 5'); + vrfy(appr(-5.7,1,mode) == -5, + '2466: appr(-5.7,1,mode) == -5'); + + /* appr mode 10 */ + mode = 10; + print '2467: mode = 10'; + vrfy(appr(-5.44,0.1,mode) == -5.5, + '2468: appr(-5.44,0.1,mode) == -5.5'); + vrfy(appr(5.44,0.1,mode) == 5.4, + '2469: appr(5.44,0.1,mode) == 5.4'); + vrfy(appr(5.7,1,mode) == 6, + '2470: appr(5.7,1,mode) == 6'); + vrfy(appr(-5.7,1,mode) == -5, + '2471: appr(-5.7,1,mode) == -5'); + vrfy(appr(-5.44,-0.1,mode) == -5.4, + '2472: appr(-5.44,-0.1,mode) == -5.4'); + vrfy(appr(5.44,-0.1,mode) == 5.5, + '2473: appr(5.44,-0.1,mode) == 5.5'); + vrfy(appr(5.7,-1,mode) == 5, + '2474: appr(5.7,-1,mode) == 5'); + vrfy(appr(-5.7,-1,mode) == -6, + '2475: appr(-5.7,-1,mode) == -6'); + + /* appr mode 11 */ + mode = 11; + print '2476: mode = 11'; + vrfy(appr(-5.44,0.1,mode) == -5.4, + '2477: appr(-5.44,0.1,mode) == -5.4'); + vrfy(appr(5.44,0.1,mode) == 5.5, + '2478: appr(5.44,0.1,mode) == 5.5'); + vrfy(appr(5.7,1,mode) == 5, + '2479: appr(5.7,1,mode) == 5'); + vrfy(appr(-5.7,1,mode) == -6, + '2480: appr(-5.7,1,mode) == -6'); + vrfy(appr(-5.44,-0.1,mode) == -5.5, + '2481: appr(-5.44,-0.1,mode) == -5.5'); + vrfy(appr(5.44,-0.1,mode) == 5.4, + '2482: appr(5.44,-0.1,mode) == 5.4'); + vrfy(appr(5.7,-1,mode) == 6, + '2483: appr(5.7,-1,mode) == 6'); + vrfy(appr(-5.7,-1,mode) == -5, + '2484: appr(-5.7,-1,mode) == -5'); + + /* appr mode 12 */ + mode = 12; + print '2485: mode = 12'; + vrfy(appr(-5.44,0.1,mode) == -5.4, + '2486: appr(-5.44,0.1,mode) == -5.4'); + vrfy(appr(5.44,0.1,mode) == 5.4, + '2487: appr(5.44,0.1,mode) == 5.4'); + vrfy(appr(5.7,1,mode) == 6, + '2488: appr(5.7,1,mode) == 6'); + vrfy(appr(-5.7,1,mode) == -6, + '2489: appr(-5.7,1,mode) == -6'); + vrfy(appr(-5.44,-0.1,mode) == -5.5, + '2490: appr(-5.44,-0.1,mode) == -5.5'); + vrfy(appr(5.44,-0.1,mode) == 5.5, + '2491: appr(5.44,-0.1,mode) == 5.5'); + vrfy(appr(5.7,-1,mode) == 5, + '2492: appr(5.7,-1,mode) == 5'); + vrfy(appr(-5.7,-1,mode) == -5, + '2493: appr(-5.7,-1,mode) == -5'); + + /* appr mode 13 */ + mode = 13; + print '2494: mode = 13'; + vrfy(appr(-5.44,0.1,mode) == -5.5, + '2495: appr(-5.44,0.1,mode) == -5.5'); + vrfy(appr(5.44,0.1,mode) == 5.5, + '2496: appr(5.44,0.1,mode) == 5.5'); + vrfy(appr(5.7,1,mode) == 5, + '2497: appr(5.7,1,mode) == 5'); + vrfy(appr(-5.7,1,mode) == -5, + '2498: appr(-5.7,1,mode) == -5'); + vrfy(appr(-5.44,-0.1,mode) == -5.4, + '2499: appr(-5.44,-0.1,mode) == -5.4'); + vrfy(appr(5.44,-0.1,mode) == 5.4, + '2500: appr(5.44,-0.1,mode) == 5.4'); + vrfy(appr(5.7,-1,mode) == 6, + '2501: appr(5.7,-1,mode) == 6'); + vrfy(appr(-5.7,-1,mode) == -6, + '2502: appr(-5.7,-1,mode) == -6'); + + /* appr mode 14 */ + mode = 14; + print '2503: mode = 14'; + vrfy(appr(-5.44,0.1,mode) == -5.5, + '2504: appr(-5.44,0.1,mode) == -5.5'); + vrfy(appr(5.44,0.1,mode) == 5.4, + '2505: appr(5.44,0.1,mode) == 5.4'); + vrfy(appr(5.7,1,mode) == 6, + '2506: appr(5.7,1,mode) == 6'); + vrfy(appr(-5.7,1,mode) == -5, + '2507: appr(-5.7,1,mode) == -5'); + vrfy(appr(-5.44,-0.1,mode) == -5.5, + '2508: appr(-5.44,-0.1,mode) == -5.5'); + vrfy(appr(5.44,-0.1,mode) == 5.4, + '2509: appr(5.44,-0.1,mode) == 5.4'); + vrfy(appr(5.7,-1,mode) == 6, + '2510: appr(5.7,-1,mode) == 6'); + vrfy(appr(-5.7,-1,mode) == -5, + '2511: appr(-5.7,-1,mode) == -5'); + + /* appr mode 15 */ + mode = 15; + print '2512: mode = 15'; + vrfy(appr(-5.44,0.1,mode) == -5.4, + '2513: appr(-5.44,0.1,mode) == -5.4'); + vrfy(appr(5.44,0.1,mode) == 5.5, + '2514: appr(5.44,0.1,mode) == 5.5'); + vrfy(appr(5.7,1,mode) == 5, + '2515: appr(5.7,1,mode) == 5'); + vrfy(appr(-5.7,1,mode) == -6, + '2516: appr(-5.7,1,mode) == -6'); + vrfy(appr(-5.44,-0.1,mode) == -5.4, + '2517: appr(-5.44,-0.1,mode) == -5.4'); + vrfy(appr(5.44,-0.1,mode) == 5.5, + '2518: appr(5.44,-0.1,mode) == 5.5'); + vrfy(appr(5.7,-1,mode) == 5, + '2519: appr(5.7,-1,mode) == 5'); + vrfy(appr(-5.7,-1,mode) == -6, + '2520: appr(-5.7,-1,mode) == -6'); + + print '2521: Ending config rounding mode test'; +} +print '035: parsed test_round()'; + + +/* + * Test certain numeric functions extensively + * + * Test multiplication, sqrt(), exp(), ln(), power(), gcd(), complex + * power, complex exp, complex log. + */ +read -once "test2600"; +print '036: read -once test2600'; +define test_2600() +{ + local tnum; /* test number */ + local i; + + print '2600: Beginning extensive numeric function test'; + + i = config("sqrt"); + print '2601: i = config("sqrt")'; + + tnum = test2600(1, 2602); + + i = config("sqrt", i); + print tnum++: ': i = config("sqrt", i)'; + + print tnum: ': Ending extensive numeric function test'; +} +print '037: parsed test_2600()'; + + +/* + * Test complex sqrt + */ +read -once "test2700"; +print '038: read -once test2700'; +define test_2700() +{ + local tnum; /* test number */ + + print '2700: Beginning complex sqrt test'; + + tnum = test2700(1, 2701); + + print tnum: ': Ending complex sqrt test'; +} +print '039: parsed test_2700()'; + + +/* + * Test matrix operations + */ +mat mat_C[2] = {1,2}; +print '040: mat mat_C[2] = {1,2}'; +mat_C[0] = mat_C; +print '041: C[0] = mat_C'; +global mat_D; +print '042: global mat_D'; +/**/ +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 + }; + static mat c[] = { 1, 2+3i, -5+4i, 5i+6, -7i }; + static mat d[-1:1, -2:2, -3:3, -4:4]; + static mat A[2] = {1,2}; + static mat id0[2,2] = {1,0,0,1}; + static mat id1[0:2,-1:1] = {1,0,0,0,1,0,0,0,1}; + static mat noid0[2,2] = {1,2,0,1}; + static mat noid1[2,3] = {1,0,0,1,0,0}; + static mat noid2[4] = {1,0,0,1}; + static mat xp[3] = {2,3,4}; + static mat yp[3] = {3,4,5}; + static mat zp[3] = {-1,2,-1}; + static mat X[2,2] = {1,2,3,4}; + static mat Y[2,2] = {5,6,7,8}; + static mat Z[2,2] = {190,232,286,352}; + static mat x[] = {11,13,17,23,29}; + static mat y0[] = {1,3,7,3,9}; + static mat y1[] = {-9,-7,-3,-7,-1}; + static mat y2[] = {-9,-7,-3,3,9}; + static mat y3[] = {1,3,7,-7,-1}; + static mat y4[] = {1,3,-3,3,-1}; + local B; + local mat e[5,5]; + local mat M[2]; + local mat zero3[3]; + + print '2800: Beginning test_matrix'; + + b[0,0] = 0; + vrfy(b[0,0] == 0, '2801: b[0,0] == 0'); + b[0,1] = 0; + vrfy(b[0,1] == 0, '2802: b[0,1] == 0'); + b[0,2] = 0; + vrfy(b[0,2] == 0, '2803: b[0,2] == 0'); + b[0,3] = 1; + vrfy(b[0,3] == 1, '2804: b[0,3] == 1'); + b[1,0] = 1; + vrfy(b[1,0] == 1, '2805: b[1,0] == 1'); + b[1,1] = 0; + vrfy(b[1,1] == 0, '2806: b[1,1] == 0'); + b[1,2] = 0; + vrfy(b[1,2] == 0, '2807: b[1,2] == 0'); + b[1,3] = 0; + vrfy(b[1,3] == 0, '2808: b[1,3] == 0'); + b[2,0] = 1; + vrfy(b[2,0] == 1, '2809: b[2,0] == 1'); + b[2,1] = 1; + vrfy(b[2,1] == 1, '2810: b[2,1] == 1'); + b[2,2] = 1; + vrfy(b[2,2] == 1, '2811: b[2,2] == 1'); + b[2,3] = 1; + vrfy(b[2,3] == 1, '2812: b[2,3] == 1'); + b[3,0] = 1; + vrfy(b[3,0] == 1, '2813: b[3,0] == 1'); + b[3,1] = 2; + vrfy(b[3,1] == 2, '2814: b[3,1] == 2'); + b[3,2] = 4; + vrfy(b[3,2] == 4, '2815: b[3,2] == 4'); + b[3,3] = 8; + vrfy(b[3,3] == 8, '2816: b[3,3] == 8'); + vrfy(det(b) == -2, '2817: det(b) == -2'); + vrfy(binv[0,0] == 0, '2818: binv[0,0] == 0'); + vrfy(binv[0,1] == 1, '2819: binv[0,1] == 1'); + vrfy(binv[0,2] == 0, '2820: binv[0,2] == 0'); + vrfy(binv[0,3] == 0, '2821: binv[0,3] == 0'); + vrfy(binv[1,0] == 2, '2822: binv[1,0] == 2'); + vrfy(binv[1,1] == -3/2, '2823: binv[1,1] == -3/2'); + vrfy(binv[1,2] == 2, '2824: binv[1,2] == 2'); + vrfy(binv[1,3] == -1/2, '2825: binv[1,3] == -1/2'); + vrfy(binv[2,0] == -3, '2826: binv[2,0] == -3'); + vrfy(binv[2,1] == 1/2, '2827: binv[2,1] == 1/2'); + vrfy(binv[2,2] == -1, '2828: binv[2,2] == -1'); + vrfy(binv[2,3] == 1/2, '2829: binv[2,3] == 1/2'); + vrfy(binv[3,0] == 1, '2830: binv[3,0] == 1'); + vrfy(binv[3,1] == 0, '2831: binv[3,1] == 0'); + vrfy(binv[3,2] == 0, '2832: binv[3,2] == 0'); + vrfy(binv[3,3] == 0, '2833: binv[3,3] == 0'); + vrfy(inverse(b) == binv, '2834: inverse(b) == binv'); + vrfy(avg(b) == b, '2835: avg(b) == b'); + vrfy(avg(binv) == binv, '2836: avg(binv) == binv'); + vrfy((b+binv)/2 == avg(b,binv), '2837: (b+binv)/2 == avg(b,binv)'); + vrfy(ismat(b) == 1, '2838: ismat(b) == 1'); + vrfy(matsum(b) == 21, '2839: matsum(b) == 21'); + vrfy(matsum(binv) == 1, '2840: matsum(binv) == 1'); + vrfy(c[0] == 1, '2841: c[0] == 1'); + vrfy(c[1] == 2+3i, '2842: c[1] == 2+3i'); + vrfy(c[2] == -5+4i, '2843: c[2] == -5+4i'); + vrfy(c[3] == 6+5i, '2844: c[3] == 6+5i'); + vrfy(c[4] == -7i, '2845: c[4] == -7i'); + vrfy(matsum(c) == 4+5i, '2846: matsum(c) == 4+5i'); + vrfy(matdim(b) == 2, '2847: matdim(b) == 2'); + vrfy(matdim(c) == 1, '2848: matdim(c) == 1'); + vrfy(matdim(d) == 4, '2849: matdim(c) == 4'); + vrfy(matmax(c,1) == 4, '2850: matmax(c,1) == 4'); + vrfy(matmin(c,1) == 0, '2851: matmin(c,1) == 0'); + vrfy(matmin(d,1) == -1, '2852: matmin(d,1) == -1'); + vrfy(matmin(d,3) == -3, '2853: matmin(d,3) == -3'); + vrfy(matmax(d,1) == 1, '2854: matmin(d,1) == 1'); + vrfy(matmax(d,3) == 3, '2855: matmin(d,3) == 3'); + vrfy(size(binv) == 16, '2856: size(binv) == 16'); + vrfy(size(c) == 5, '2857: size(c) == 5'); + vrfy(size(d) == 945, '2858: size(d) == 945'); + vrfy(size(e) == 25, '2859: size(e) == 25'); + matfill(d,1); + print '2860: matfill(d,1)'; + vrfy(matsum(d) == 945, '2861: matsum(d) == 945'); + matfill(e,1,0); + print '2862: matfill(e,1,0)'; + vrfy(matsum(d) == 945, '2863: matsum(d) == 945'); + vrfy(matsum(e) == 20, '2864: matsum(e) == 20'); + vrfy(search(binv,1) == 1, '2865: search(binv,1) == 1'); + vrfy(search(binv,2) == 4, '2866: search(binv,2) == 4'); + vrfy(search(binv,2,4) == 4, '2867: search(binv,2,4) == 4'); + vrfy(search(binv,2,5) == 6, '2868: search(binv,2,5) == 6'); + vrfy(rsearch(binv,2) == 6, '2869: rsearch(binv,2) == 6'); + vrfy(rsearch(binv,2,6) == 6, '2870: rsearch(binv,2,6) == 6'); + vrfy(rsearch(binv,2,5) == 4, '2871: rsearch(binv,2,5) == 4'); + vrfy(A[0] == 1, '2872: A[0] == 1'); + vrfy(A[1] == 2, '2873: A[1] == 2'); + A[0] = A; + print '2874: A[0] = A'; + B = A[0]; + print '2875: B = A[0]'; + vrfy(B[0] == 1, '2876: B[0] == 1'); + vrfy(B[1] == 2, '2877: B[1] == 2'); + mat_D = mat_C[0]; + print '2878: mat_D = mat_C[0]'; + vrfy(mat_D[0] == 1, '2879: mat_D[0] == 1'); + vrfy(mat_D[1] == 2, '2880: mat_D[1] == 2'); + vrfy(quomod(15.6,5.2,M[0],M[1]) == 0, + '2881: quomod(15.6,5.2,M[0],M[1]) == 0'); + vrfy(M[0] == 3, '2882: M[0] == 3'); + vrfy(M[1] == 0, '2883: M[1] == 0'); + vrfy(isident(id0) == 1, '2884: isident(id0) == 1'); + vrfy(isident(id1) == 1, '2885: isident(id1) == 1'); + vrfy(isident(noid0) == 0, '2886: isident(noid0) == 0'); + vrfy(isident(noid1) == 0, '2887: isident(noid1) == 0'); + vrfy(isident(noid2) == 0, '2888: isident(noid2) == 0'); + vrfy(xp[0] == 2, '2889: xp[0] == 2'); + vrfy(xp[1] == 3, '2890: xp[1] == 3'); + vrfy(xp[2] == 4, '2891: xp[2] == 4'); + vrfy(yp[0] == 3, '2892: yp[0] == 3'); + vrfy(yp[1] == 4, '2893: yp[1] == 4'); + vrfy(yp[2] == 5, '2894: yp[2] == 5'); + vrfy(zp[0] == -1, '2895: zp[0] == -1'); + vrfy(zp[1] == 2, '2896: zp[1] == 2'); + vrfy(zp[2] == -1, '2897: zp[2] == -1'); + vrfy(cp(xp,yp) == zp, '2898: cp(xp,yp) == zp'); + vrfy(cp(yp,xp) == -zp, '2899: cp(yp,xp) == -zp'); + matfill(zero3,0); + print '2900: matfill(zero3,0)'; + vrfy(cp(xp,xp) == zero3, '2901: cp(xp,xp) == zero3'); + vrfy(dp(xp,yp) == 38, '2902: dp(xp,yp) == 38'); + vrfy(dp(yp,xp) == 38, '2903: dp(yp,xp) == 38'); + vrfy(dp(zp,dp(xp,yp)*zp) == 228,'2904: dp(zp,dp(xp,yp)*zp) == 228'); + vrfy(ssq(X, Y, X + Y) == Z, '2905: ssq(X, Y, X + Y) == Z'); + vrfy(mod(x,10,0) == y0, '2906: mod(x,10,0) == y0'); + vrfy(mod(x,10,1) == y1, '2907: mod(x,10,1) == y1'); + vrfy(mod(x,10,2) == y0, '2908: mod(x,10,2) == y0'); + vrfy(mod(x,10,3) == y1, '2909: mod(x,10,3) == y1'); + vrfy(mod(x,10,4) == y0, '2910: mod(x,10,4) == y0'); + vrfy(mod(x,10,5) == y1, '2911: mod(x,10,5) == y1'); + vrfy(mod(x,10,6) == y0, '2912: mod(x,10,6) == y0'); + vrfy(mod(x,10,7) == y1, '2913: mod(x,10,7) == y1'); + vrfy(mod(x,10,8) == y2, '2914: mod(x,10,8) == y2'); + vrfy(mod(x,10,9) == y3, '2915: mod(x,10,9) == y3'); + vrfy(mod(x,10,10) == y2, '2916: mod(x,10,10) == y2'); + vrfy(mod(x,10,11) == y3, '2917: mod(x,10,11) == y3'); + vrfy(mod(x,10,12) == y2, '2918: mod(x,10,12) == y2'); + vrfy(mod(x,10,13) == y3, '2919: mod(x,10,13) == y3'); + vrfy(mod(x,10,14) == y2, '2920: mod(x,10,14) == y2'); + vrfy(mod(x,10,15) == y3, '2921: mod(x,10,15) == y3'); + vrfy(mod(x,10,16) == y4, '2922: mod(x,10,16) == y4'); + vrfy(mod(x,10,16) == y4, '2923: mod(x,10,16) == y4'); + vrfy(mod(x,10,18) == y4, '2924: mod(x,10,18) == y4'); + vrfy(mod(x,10,19) == y4, '2925: mod(x,10,18) == y4'); + vrfy(mod(x,10,20) == y4, '2926: mod(x,10,20) == y4'); + vrfy(mod(x,10,21) == y4, '2927: mod(x,10,21) == y4'); + vrfy(mod(x,10,22) == y4, '2928: mod(x,10,22) == y4'); + vrfy(mod(x,10,23) == y4, '2929: mod(x,10,23) == y4'); + vrfy(mod(x,10,24) == y4, '2930: mod(x,10,24) == y4'); + vrfy(mod(x,10,25) == y4, '2931: mod(x,10,25) == y4'); + vrfy(mod(x,10,26) == y4, '2932: mod(x,10,26) == y4'); + vrfy(mod(x,10,27) == y4, '2933: mod(x,10,27) == y4'); + vrfy(mod(x,10,28) == y4, '2934: mod(x,10,28) == y4'); + vrfy(mod(x,10,29) == y4, '2935: mod(x,10,29) == y4'); + vrfy(mod(x,10,30) == y4, '2936: mod(x,10,30) == y4'); + vrfy(mod(x,10,31) == y4, '2937: mod(x,10,31) == y4'); + + print '2938: Ending mat_functions'; +} +print '043: parsed test_matrix()'; + + +/* + * Test string constants and comparisons + */ +define test_strings() +{ + local x, y, z; + + print '3000: Beginning test_strings'; + + x = 'string'; + print "3001: x = 'string'"; + y = "string"; + print '3002: y = "string"'; + z = x; + print '3003: z = x'; + vrfy(z == "string", '3004: z == "string"'); + vrfy(z != "foo", '3005: z != "foo"'); + vrfy(z != 3, '3006: z != 3'); + vrfy('' == "", '3007: \'\' == ""'); + vrfy("a" == "a", '3008: "a" == "a"'); + vrfy("c" != "d", '3009: "c" != "d"'); + vrfy("" != "a", '3010: "" != "a"'); + vrfy("rs" < "rt", '3011: "rs" < "rt"'); + vrfy("rs" < "ss", '3012: "rs < "ss"'); + vrfy("rs" <= "rs", '3013: "rs" <= "rs"'); + vrfy("rs" <= "tu", '3014: "rs" <= "tu"'); + vrfy("rs" > "cd", '3015: "rs" > "cd"'); + vrfy("rs" >= "rs", '3016: "rs" >= "rs"'); + vrfy("rs" >= "cd", '3017: "rs" >= "cd"'); + vrfy("abc" > "ab", '3018: "abc" > "ab"'); + + print '3019: Ending test_strings'; +} +print '044: parsed test_strings()'; + + +/* + * test_matobj - test determinants of a matrix containing objects + */ +read -once "test3100"; +print '045: read -once test3100'; +/**/ +define test_matobj() +{ + local mat A[3,3] = {2, 3, 5, 7, 11, 13, 17, 19, 23}; + local mat B[2,2]; + + print '3100: Beginning test_matobj'; + + vrfy(det(A) == -78, '3101: det(A) == -78'); + vrfy(det(A^2) == 6084, '3102: det(A^2) == 6084'); + vrfy(det(A^3) == -474552, '3103: det(A^3) == -474552'); + vrfy(det(A^-1) == -1/78, '3104: det(A^-1) == -1/78'); + md = 0; + print '3105: md = 0'; + B[0,0] = res(2); + print '3106: B[0,0] = res(2)'; + B[0,1] = res(3); + print '3107: B[0,1] = res(2)'; + B[1,0] = res(5); + print '3108: B[1,0] = res(2)'; + B[1,1] = res(7); + print '3109: B[1,1] = res(2)'; + print '3110: md = 0'; + md = 0; + vrfy(det(B) == res(-1), '3111: det(B) == res(-1)'); + md = 1; + print '3112: md = 1'; + vrfy(det(B) == 0, '3113: det(B) == 0'); + md = 2; + print '3114: md = 2'; + vrfy(det(B) == res(1), '3115: det(B) == res(1)'); + md = 3; + print '3116: md = 3'; + vrfy(det(B) == res(2), '3117: det(B) == res(2)'); + md = 4; + print '3118: md = 4'; + vrfy(det(B) == res(3), '3119: det(B) == res(3)'); + md = 5; + print '3120: md = 5'; + vrfy(det(B) == res(4), '3121: det(B) == res(4)'); + md = 6; + print '3122: md = 6'; + vrfy(det(B) == res(5), '3123: det(B) == res(5)'); + md = 7; + print '3124: md = 7'; + vrfy(det(B) == res(6), '3125: det(B) == res(6)'); + md = 8; + print '3126: md = 8'; + vrfy(det(B) == res(7), '3127: det(B) == res(7)'); + md = 9; + print '3128: md = 9'; + vrfy(det(B) == res(8), '3129: det(B) == res(8)'); + md = 10; + print '3130: md = 10'; + vrfy(det(B) == res(9), '3131: det(B) == res(9)'); + md = 11; + print '3132: md = 11'; + vrfy(det(B) == res(10), '3133: det(B) == res(10)'); + md = 12; + print '3134: md = 12'; + vrfy(det(B) == res(11), '3135: det(B) == res(11)'); + md = 13; + print '3136: md = 13'; + vrfy(det(B) == res(12), '3137: det(B) == res(12)'); + md = 14; + print '3138: md = 14'; + vrfy(det(B) == res(13), '3139: det(B) == res(13)'); + md = 15; + print '3140: md = 15'; + vrfy(det(B) == res(14), '3141: det(B) == res(14)'); + + print '3142: Ending test_matobj'; +} +print '046: parsed test_matobj()'; + + +/* + * test_poly - test the polynomial function + */ +define test_poly() +{ + print '3200: Beginning test_matobj'; + + vrfy(poly(2,3,5,2) == 19, '3201: vrfy poly(2,3,5,2) == 19'); + vrfy(poly(list(5,3,2),2) == 19,\ + '3202: vrfy poly(list(5,3,2),2) == 19'); + vrfy(poly(list(5,3,2)) == 5, '3203: vrfy poly(list(5,3,2)) == 5'); + vrfy(poly(2) == 2, '3204: vrfy poly(2) == 2'); + vrfy(poly(list(5,3,2),2,3) == 19,\ + '3205: vrfy poly(list(5,3,2),2,3) == 19'); + vrfy(poly(list()) == 0, '3206: vrfy poly(list()) == 0'); + vrfy(poly(list(),2,3) == 0, '3207: vrfy poly(list(),2,3) == 0'); + vrfy(poly(list(list(5,3,2)),7,2) == 19,\ + '3208: vrfy poly(list(list(5,3,2)),7,2) == 19'); + vrfy(poly(list(list(1,2,3),list(4,5),6),7) == 323,\ + '3209: vrfy poly(list(list(1,2,3),list(4,5),6),7) == 323'); + vrfy(poly(list(list(1,2,3),list(4,5),6),7,8) == 811,\ + '3210: vrfy poly(list(list(1,2,3),list(4,5),6),7,8) == 811'); + vrfy(poly(list(list(1,2,3),list(4,5),6),7,8,9) == 811,\ + '3211: vrfy poly(list(list(1,2,3),list(4,5),6),7,8,9)==811'); + vrfy(poly(list(5,3,2), list()) == 5,\ + '3212: vrfy poly(list(5,3,2), list() == 5'); + vrfy(poly(list(5,3,2), list(2)) == 19,\ + '3213: vrfy poly(list(5,3,2), list(2)) == 19'); + vrfy(poly(list(5,3,2), list(2,3)) == 19,\ + '3214: vrfy poly(list(5,3,2), list(2,3)) == 19'); + vrfy(poly(list(list(list(0,0,0,0,0,1))),2,3,4) == 4^5,\ + '3215: vrfy poly(list(list(list(0,0,0,0,0,1))),2,3,4)==4^5'); + vrfy(poly(list(list(list(0,0,0,0,0,1))),2,list(3,4)) == 4^5,\ + '3216: vrfy poly(list(list(list(0,0,0,0,0,1))),2,list(3,4))==4^5'); + + print '3217: Ending test_poly'; +} +print '047: parsed test_poly()'; + + +/* + * test_det - more determinent testing + */ +read -once "test3300"; +print '048: read -once test3300'; +/**/ +define test_det() +{ + local tnum; /* test number */ + local i; + + print '3300: Beginning test_det'; + + tnum = test3300(1, 3301); + + print tnum: ': Ending test_det'; +} +print '049: parsed test_det()'; + + +/* + * test_trig - trig function testing + */ +read -once "test3400"; +print '050: read -once test3400'; +/**/ +define test_trig() +{ + local tnum; /* test number */ + local i; + + print '3400: Beginning test_trig'; + + tnum = test3400(1, 3401); + + print tnum: ': Ending test_trig'; +} +print '051: parsed test_trig()'; + + +/* + * test_frem - tests of the functions frem, fcnt, gcdrem + */ +read -once "test3500"; +print '052: read -once test3500'; +/**/ +define test_frem() +{ + local tnum; /* test number */ + + print '3500: Beginning test_frem'; + + tnum = test3500(1, 3501, 200, 61); + + print tnum: ': Ending test_frem'; +} +print '053: parsed test_frem()'; + + +/* + * test_error - test the error() builtin + */ +define test_error() +{ + local strx, e99, list1; + + print '3600: Beginning test_error'; + + strx = "x"; + print '3601: strx = "x"'; + e99 = error(99); + print '3602: e99 = error(99)'; + vrfy(1/0 == error(10001), '3603: 1/0 == error(10001)'); + vrfy(0/0 == error(10002), '3604: 0/0 == error(10002)'); + vrfy(2 + "x" == error(10003), '3605: 2 + "x" == error(10003)'); + vrfy("x" - 2 == error(10004), '3606: "x" - 2 == error(10004)'); + vrfy("x" * 2 == error(10005), '3607: "x" * 2 == error(10005)'); + vrfy("x" / 2 == error(10006), '3608: "x" / 2 == error(10006)'); + vrfy(-"x" == error(10007), '3609: -"x" == error(10007)'); + vrfy("x"^2 == error(10008), '3610: "x"^2 == error(10008)'); + vrfy(inverse("x")==error(10009),'3611: inverse("x") == error(10009)'); + vrfy(++strx == error(10010), '3612: ++strx == error(10010)'); + vrfy(strx == error(10010), '3613: strx == error(10010)'); + strx = "x"; + print '3614: strx = "x"'; + vrfy(strx++ == "x", '3615: strx++ == "x"'); + vrfy(strx == error(10010), '3616: strx == error(10010)'); + strx = "x"; + print '3617: strx = "x"'; + vrfy(--strx == error(10011), '3618: strx == error(10011)'); + vrfy(int("x") == error(10012), '3619: int("x") == error(10012)'); + vrfy(frac("x") == error(10013), '3620: frac("x") == error(10013)'); + vrfy(conj("x") == error(10014), '3621: conj("x") == error(10014)'); + vrfy(appr("x",.1) == error(10015), + '3622: appr("x",.1) == error(10015)'); + vrfy(appr(1.27,.1i) == error(10016), + '3623: appr(1.27,.1i) == error(10016)'); + vrfy(appr(1.27,.1,.1) == error(10017), + '3624: appr(1.27,.1,.1) == error(10017)'); + vrfy(round("x") == error(10018), '3625: round("x") == error(10018)'); + vrfy(round(1.25,.1) == error(10019), + '3626: round(1.25,.1) == error(10019)'); + vrfy(round(1.25,"x") == error(10019), + '3627: round(1.25,"x") == error(10019)'); + vrfy(round(1.25,1,.1) == error(10020), + '3628: round(1.25,1,.1) == error(10020)'); + vrfy(bround("x") == error(10021), '3629: bround("x") == error(10021)'); + vrfy(bround(1.25,.1) == error(10022), + '3630: bround(1.25,.1) == error(10022)'); + vrfy(bround(1.25,"x") == error(10022), + '3631: bround(1.25,"x") == error(10022)'); + vrfy(bround(1.25,1,.1) == error(10023), + '3632: bround(1.25,1,.1) == error(10023)'); + vrfy(sqrt("x") == error(10024), '3633: sqrt("x") == error(10024)'); + vrfy(sqrt(2,"x") == error(10025), + '3634: sqrt(2,"x") == error(10025)'); + vrfy(sqrt(2,0) == error(10025), '3635: sqrt(2,0) == error(10025)'); + vrfy(sqrt(2,.1,.1) == error(10026), + '3636: sqrt(2,.1,.1) == error(10026)'); + vrfy(root("x",3) == error(10027), + '3637: root("x",3) == error(10027)'); + vrfy(root(3,"x") == error(10028), + '3638: root(3,"x") == error(10028)'); + vrfy(root(3,-2) == error(10028), + '3639: root(3,-2) == error(10028)'); + vrfy(root(3,0) == error(10028), '3640: root(3,0) == error(10028)'); + vrfy(root(3,.1) == error(10028), + '3641: root(3,.1) == error(10028)'); + vrfy(root(3,2,"x") == error(10029), + '3642: root(3,2,"x") == error(10029)'); + vrfy(root(3,2,0) == error(10029), + '3643: root(3,2,0) == error(10029)'); + vrfy(norm("x") == error(10030), '3644: norm("x") == error(10030)'); + vrfy("x" << 2 == error(10031), '3645: "x" << 2 == error(10031)'); + vrfy(1.5 << 2 == error(10031), '3646: 1.5 << 2 == error(10031)'); + vrfy(3 << "x" == error(10032), '3647: 3 << "x" == error(10032)'); + vrfy(3 << 1.5 == error(10032), '3648: 3 << 1.5 == error(10032)'); + vrfy(3 << 2^31 == error(10032), '3649: 3 << 2^31 == error(10032)'); + vrfy(scale("x",2) == error(10033), + '3650: scale("x",2) == error(10033)'); + vrfy(scale(3,"x") == error(10034), + '3651: scale(3,"x") == error(10034)'); + vrfy(scale(3,1.5) == error(10034), + '3652: scale(3,1.5) == error(10034)'); + vrfy(scale(3,2^31) == error(10034), + '3653: scale(3,2^31) == error(10034)'); + vrfy("x" ^ 3 == error(10035), '3654: "x" ^ 3 == error(10035)'); + vrfy(2 ^ "x" == error(10036), '3655: 2 ^ "x" == error(10036)'); + vrfy(2 ^ 2.5 == error(10036), '3656: 2 ^ 2.5 == error(10036)'); + vrfy(power("x",2.1) == error(10037), + '3657: power("x",2.1) == error(10037)'); + vrfy(power(2,"x") == error(10038), + '3658: power(2,"x") == error(10038)'); + vrfy(power(2,2.1,"x") == error(10039), + '3659: power(2,2.1,"x") == error(10039)'); + vrfy(quo("x",3) == error(10040), '3660: quo("x",3) == error(10040)'); + vrfy(quo(8,"x") == error(10041), '3661: quo(8,"x") == error(10041)'); + vrfy(quo(8,3,"x") == error(10042), + '3662: quo(8,3,"x") == error(10042)'); + vrfy(quo(8,3,2.1) == error(10042), + '3663: quo(8,3,2.1) == error(10042)'); + vrfy(mod("x",3) == error(10043), '3664: mod("x",3) == error(10043)'); + vrfy(mod(8,"x") == error(10044), '3665: mod(8,"x") == error(10044)'); + vrfy(mod(8,3,"x") == error(10045), + '3666: mod(8,3,"x") == error(10045)'); + vrfy(mod(8,3,2.1) == error(10045), + '3667: mod(8,3,2.1) == error(10045)'); + vrfy(sgn("x") == error(10046), '3668: sgn("x") == error(10046)'); + vrfy(abs("x") == error(10047), '3669: abs("x") == error(10047)'); + vrfy(abs(2+3i,"x") == error(10048), + '3670: abs(2+3i,"x") == error(10048)'); + vrfy(abs(2+3i,0) == error(10048), + '3671: abs(2+3i,0) == error(10048)'); + list1 = list(2,3,"x",4,5); + print '3672: list1 = list(2,3,"x",4,5)'; + vrfy(avg(list1) == error(10003), + '3673: avg(list1) == error(10003)'); + + vrfy(iserror(e99)==99, '3674: iserror(e99) == 99'); + vrfy(e99 + 2 == e99, '3675: e99 + 2 == e99'); + vrfy(e99 - 2 == e99, '3676: e99 - 2 == e99'); + vrfy(e99 * 2 == e99, '3677: e99 * 2 == e99'); + vrfy(e99 / 2 == e99, '3678: e99 / 2 == e99'); + vrfy(e99 // 2 == e99, '3679: e99 // 2 == e99'); + vrfy(e99 % 2 == e99, '3680: e99 % 2 == e99'); + vrfy(e99 ^ 2 == e99, '3681: e99 ^ 2 == e99'); + vrfy(2 + e99 == e99, '3682: 2 + e99 == e99'); + vrfy(2 - e99 == e99, '3683: 2 - e99 == e99'); + vrfy(2 * e99 == e99, '3684: 2 * e99 == e99'); + vrfy(2 / e99 == e99, '3685: 2 / e99 == e99'); + vrfy(2 // e99 == e99, '3686: 2 // e99 == e99'); + vrfy(2 % e99 == e99, '3687: 2 % e99 == e99'); + vrfy(2 ^ e99 == e99, '3688: 2 ^ e99 == e99'); + vrfy(- e99 == e99, '3689: -e99 == e99'); + vrfy(inverse(e99) == e99, '3690: inverse(e99) == e99'); + vrfy(++e99 == e99, '3691: ++e99 == e99'); + vrfy(--e99 == e99, '3692: --e99 == e99'); + vrfy(int(e99) == e99, '3693: int(e99) == e99'); + vrfy(frac(e99) == e99, '3694: frac(e99) == e99'); + vrfy(conj(e99) == e99, '3695: conj(e99) == e99'); + vrfy(norm(e99) == e99, '3696: norm(e99) == e99'); + vrfy(sgn(e99) == e99, '3697: sgn(e99) == e99'); + vrfy(appr(e99,1,0) == e99, '3698: appr(e99,1,0) == e99'); + vrfy(round(e99) == e99, '3699: round(e99) == e99'); + vrfy(bround(e99) == e99, '3700: bround(e99) == e99'); + vrfy(sqrt(e99) == e99, '3701: sqrt(e99) == e99'); + + print '3702: Ending test_error'; +} +print '054: parsed test_error()'; + + +/* + * test_param - test new param() functionality. + */ +define g_param() = (param(2) = param(1)); +print '055: define g_param() = (param(2) = param(1))'; +define h_param() = (param(1)++, param(2)--); +print '056: define h_param() = (param(1)++, param(2)--)'; +/**/ +global u_glob = 5; +print '057: global u_glob = 5'; +global v_glob = 10; +print '058: global v_glob = 10'; +vrfy(g_param(u_glob, &v_glob) == 5, '059: g_param(u_glob, &v_glob) == 5'); +vrfy(u_glob == 5, '060: u_glob == 5'); +vrfy(v_glob == 5, '061: v_glob == 5'); +vrfy(h_param(&u_glob, &v_glob) == 5, '062: h_param(&u_glob, &v_glob) == 5'); +vrfy(u_glob == 6, '063: u_glob == 6'); +vrfy(v_glob == 4, '064: v_glob == 4'); +/**/ +define test_param() +{ + local u, v; + + print '3800: Beginning test_param'; + + u = 5; + print '3801: u = 5'; + v = 10; + print '3802: v = 10'; + vrfy(g_param(u, &v) == 5, '3803: g_param(u, &v) == 5'); + vrfy(u == 5, '3804: u == 5'); + vrfy(v == 5, '3805: v == 5'); + vrfy(h_param(&u, &v) == 5, '3806: h_param(&u, &v) == 5'); + vrfy(u == 6, '3807: u == 6'); + vrfy(v == 4, '3808: v == 4'); + + print '3809: Ending test_param'; +} +print '065: parsed test_param()'; + + +/* + * test_noarg - test missing argment functionality + */ +define test_noarg() +{ + local A,B,C,D; + + print '3900: Beginning test_noarg'; + + A = list(1,,3); + print '3901: A = list(1,,3)'; + vrfy(A[[0]] == 1, '3902: A[[0]] == 1'); + vrfy(isnull(A[[1]]), '3903: isnull(A[[1]])'); + vrfy(A[[2]] == 3, '3904: A[[2]] == 3'); + vrfy(size(A) == 3, '3905: size(A) == 3'); + + B = list(,,); + print '3906: B = list(,,)'; + vrfy(isnull(B[[0]]), '3907: isnull(B[[0]])'); + vrfy(isnull(B[[1]]), '3908: isnull(B[[1]])'); + vrfy(isnull(B[[2]]), '3909: isnull(B[[2]])'); + vrfy(size(B) == 3, '3910: size(B) == 3'); + + mat C[] = {,,}; + print '3911: mat C[] = {,,}'; + vrfy(C[0] == 0, '3912: C[0] == 0'); + vrfy(C[1] == 0, '3913: C[1] == 0'); + vrfy(C[2] == 0, '3914: C[2] == 0'); + vrfy(size(C) == 3, '3915: size(C) == 3'); + + mat D[] = { }; + print '3916: mat D[] = { }'; + vrfy(D[0] == 0, '3917: D[0] == 0'); + vrfy(size(D) == 1, '3918: size(D) == 1'); + print '3919: Ending test_noarg'; +} +print '066: parsed test_noarg'; + + +/* + * test_ptest - more tests of the functions ptest, nextcand, prevcand + */ +read -once "test4000"; +print '067: read -once test4000'; +/**/ +define test_ptest() +{ + local tnum; /* test number */ + + print '4000: Beginning test_ptest'; + + tnum = test4000(1, 4001); + + print tnum: ': Ending test_ptest'; +} +print '068: parsed test_ptest()'; + + +/* + * test_redc - REDC operation tests + */ +read -once "test4100"; +print '069: read -once test4100'; +/**/ +define test_redc() +{ + local tnum; /* test number */ + + print '4100: Beginning test_redc'; + + tnum = test4100(1, 4101); + + print tnum: ': Ending test_redc'; +} +print '070: parsed test_redc()'; + + +/* + * test_fileops - test various file operations + */ +define test_fileops() +{ + local a, b, c, f, m, n, x, y, z; + local L = "Landon"; + local C = "Curt"; + local N = "Noll"; + local LCN = "Landon\nCurt\nNoll\n"; + + print '4200: Beginning test_fileops'; + + /* + * fputs tests + */ + print '4201: x = rm("junk4200")'; + x = rm("junk4200"); + vrfy(!iserror(f = fopen("junk4200", "w+")), + '4202: !iserror(f = fopen("junk4200", "w+"))'); + vrfy(!iserror(fputs(f, LCN)), '4203: !iserror(fputs(f, LCN))'); + vrfy(isnull(rewind(f)), '4204: isnull(rewind(f))'); + vrfy(fgetfield(f) == L, '4205: fgetfield(f) == L'); + vrfy(fgetfield(f) == C, '4206: fgetfield(f) == C'); + vrfy(fgetfield(f) == N, '4207: fgetfield(f) == N'); + vrfy(isnull(fgetfield(f)), '4208: isnull(fgetfield(f))'); + vrfy(isnull(rewind(f)), '4209: isnull(rewind(f))'); + vrfy(fgetline(f) == L, '4210: fgetline(f) == L'); + vrfy(fgetline(f) == C, '4211: fgetline(f) == C'); + vrfy(fgetline(f) == N, '4212: fgetline(f) == N'); + vrfy(isnull(fgetline(f)), '4213: isnull(fgetline(f))'); + vrfy(isnull(rewind(f)), '4214: isnull(rewind(f))'); + vrfy(fgets(f) == strcat(L,"\n"),'4215: fgets(f) == strcat(L,"\\n")'); + vrfy(fgets(f) == strcat(C,"\n"),'4216: fgets(f) == strcat(C,"\\n")'); + vrfy(fgets(f) == strcat(N,"\n"),'4217: fgets(f) == strcat(N,"\\n")'); + vrfy(isnull(fgets(f)), '4218: isnull(fgets(f))'); + vrfy(isnull(rewind(f)), '4219: isnull(rewind(f))'); + vrfy(fgetstr(f) == LCN, '4220: fgetstr(f) == LCN'); + vrfy(isnull(fclose(f)), '4221: isnull(fclose(f))'); + vrfy(isnull(fclose(f)), '4222: isnull(fclose(f))'); + + /* + * fgetstr tests + */ + vrfy(!iserror(f = fopen("junk4200", "w+")), + '4223: !iserror(f)'); + + vrfy(isnull(fputstr(f, L, C, N)), + '4224: isnulll(fputstr(f, L, C, N))'); + vrfy(isnull(rewind(f)), '4225: isnull(rewind(f))'); + vrfy(fgetstr(f) == L, '4226: fgetstr(f) == L'); + vrfy(fgetstr(f) == C, '4227: fgetstr(f) == C'); + vrfy(fgetstr(f) == N, '4228: fgetstr(f) == N'); + vrfy(isnull(fgetstr(f)), '4229: isnull(fgetstr(f))'); + n = ftell(f); + print '4230: n = ftell(f)'; + vrfy(isnull(fputs(f,L,"\n",C,"\n",N,"\n")), + '4231: isnull(fputs(f,L,"\\n",C,"\\n",N,"\\n"))'); + fseek(f, n); + print '4232: fseek(f, n)'; + vrfy(fgetstr(f) == LCN, '4233: fgetstr(f) == LCN'); + vrfy(isnull(fclose(f)), '4234: isnull(fclose(f))'); + + /* + * fscanf tests + */ + a = exp(27, 1e-1000); + print '4235: a = exp(27, 1e-1000)'; + b = sqrt(7 + 5i, 1e-2000); + print '4236: b = sqrt(7 + 5i, 1e-2000)'; + c = config("display", 1000); + print '4237: c = config("display", 1000)'; + vrfy(!iserror(f=fopen("junk4200","w+")), + '4238: !iserror(f=fopen("junk4200","w+"))'); + vrfy(!iserror(fprintf(f, "%f\n\tand\n\t%r",a,b)), + '4239: !iserror(fprintf(f, "%f\\n\\tand\\n\\t%r",a,b))'); + vrfy(isnull(rewind(f)), '4240: isnull(rewind(f))'); + vrfy(fscanf(f,"%f and %r",x,y) == 2, + '4241: fscanf(f,"%f and %r",x,y) == 2'); + vrfy(x == a && y == b, '4242: x == a && y == b'); + vrfy(!iserror(freopen(f, "w+")),'4243: !iserror(freopen(f, "w+"))'); + L = "Landon\n"; + print '4244: L = "Landon\\n"'; + C = "\tCurt\n"; + print '4245: C = "\tCurt\\n"'; + N = "\t\tNoll\n"; + print '4246: N = "\\t\\tNoll\\n"'; + vrfy(isnull(fputs(f, L, "|", C, "[", N, "]" )), + '4247: isnull(fputs(f, L, "|", C, "[", N, "]" ))'); + vrfy(isnull(rewind(f)), '4248: isnull(rewind(f))'); + vrfy(fscanf(f, "%[^|]%*c%[^[]%*c%[^]]", x,y,z) == 3, + '4249: fscanf(f, "%[^|]%*c%[^[]%*c%[^]]", x,y,z) == 3'); + vrfy(x == L && y == C && z == N, + '4250: x == L && y == C && z == N'); + vrfy(isnull(rewind(f)), '4251: isnull(rewind(f))'); + vrfy(fscanf(f, "%*[^|]%*c%n%*[^[]%*c%n", m, n) == 2, + '4252: fscanf(f, "%*[^|]%*c%n%*[^[]%*c%n", m, n) == 2'); + fseek(f, m); + print '4253: fseek(f, m)'; + vrfy(fscanf(f, "%3c", x) == 1, '4254: fscanf(f, "%3c", x) == 1'); + vrfy(x == "\tCu", '4255: x == "\tCu"'); + fseek(f, n); + print '4256: fseek(f, n)'; + vrfy(fscanf(f, "%s", y) == 1, '4257: fscanf(f, "%s", y) == 1'); + vrfy(y == "Noll", '4258: y == "Noll"'); + vrfy(isnull(fclose(f)), '4259: isnull(fclose(f))'); + + /* + * cleanup + */ + print '4260: x = rm("junk4200")'; + x = rm("junk4200"); + + print '4261: Ending test_fileops'; +} +print '071: parsed test_redc()'; + + +/* + * test_matdcl - test new matrix declaration syntax + */ +mat_X0 = mat[4]; +print '072: mat_X = mat[4]'; +mat mat_X1, mat_X2[2], mat_X3[3]; +print '073: mat mat_X1, mat_X2[2], mat_X3[3]'; +mat mat_Z0, mat_Z1 [2] = {1,2}; +print '074: mat mat_Z0, mat_Z1 [2] = {1,2}'; +define test_matdcl() +{ + local mat_Y0; + local mat mat_Y1, mat_Y2[2], mat_Y3[3]; + local mat M0, M1, M2[2,2]; + local i; + + print '4300: Beginning test_matdcl'; + + vrfy(size(mat_X0) == 4, '4301: size(mat_X0) == 4'); + vrfy(size(mat_X1) == 2, '4302: size(mat_X1) == 2'); + vrfy(size(mat_X2) == 2, '4303: size(mat_X2) == 2'); + vrfy(size(mat_X3) == 3, '4304: size(mat_X3) == 3'); + vrfy(ismat(mat_X0), '4305: ismat(mat_X0)'); + vrfy(ismat(mat_X1), '4306: ismat(mat_X1)'); + vrfy(ismat(mat_X2), '4307: ismat(mat_X2)'); + vrfy(ismat(mat_X3), '4308: ismat(mat_X3)'); + mat_Y0 = mat[4]; + print '4309: mat_Y0 = mat[4]'; + vrfy(size(mat_Y0) == 4, '4310: size(mat_Y0) == 4'); + vrfy(size(mat_Y1) == 2, '4311: size(mat_Y1) == 2'); + vrfy(size(mat_Y2) == 2, '4312: size(mat_Y2) == 2'); + vrfy(size(mat_Y3) == 3, '4313: size(mat_Y3) == 3'); + vrfy(ismat(mat_Y0), '4314: ismat(mat_Y0)'); + vrfy(ismat(mat_Y1), '4315: ismat(mat_Y1)'); + vrfy(ismat(mat_Y2), '4316: ismat(mat_Y2)'); + vrfy(ismat(mat_Y3), '4317: ismat(mat_Y3)'); + vrfy(size(mat_Z0) == 2, '4318: size(mat_Z0) == 2'); + vrfy(size(mat_Z1) == 2, '4319: size(mat_Z1) == 2'); + vrfy(ismat(mat_Z0), '4320: ismat(mat_Z0)'); + vrfy(ismat(mat_Z1), '4321: ismat(mat_Z1)'); + vrfy(mat_Z0 == mat_Z1, '4322: mat_Z0 == mat_Z1'); + vrfy(mat_Z0 == (mat[2] = {1,2}), '4323: mat_Z0 == (mat[2] = {1,2})'); + vrfy(mat_Z0[0] == 1, '4324: mat_Z0[0] == 1'); + vrfy(mat_Z0[1] == 2, '4325: mat_Z0[1] == 2'); + mat_Z1 = {,3}; + print '4326: mat_Z1 = {,3}'; + vrfy(mat_Z0 != mat_Z1, '4327: mat_Z0 != mat_Z1'); + vrfy(mat_Z1[0] == 1, '4328: mat_Z1[0] == 1'); + vrfy(mat_Z1[1] == 3, '4329: mat_Z1[1] == 3'); + mat_X3 = {2,3,5}; + print '4330: mat_X3 = {2,3,5}'; + mat_X3 += {3,4,5}; + print '4331: mat_X3 += {3,4,5}'; + vrfy(mat_X3[0] == 5, '4332: mat_X3[0] == 5'); + vrfy(mat_X3[1] == 7, '4333: mat_X3[1] == 7'); + vrfy(mat_X3[2] == 10, '4334: mat_X3[2] == 10'); + mat_Y3 = mat_X3; + print '4335: mat_Y3 = mat_X3'; + mat_Y3 -= {,1,2}; + print '4336: mat_Y3 -= {0,1,}'; + vrfy(mat_Y3[0] == 0, '4337: mat_Y3[0] == 0'); + vrfy(mat_Y3[1] == 6, '4338: mat_Y3[1] == 6'); + vrfy(mat_Y3[2] == 8, '4339: mat_Y3[2] == 8'); + mat_Y3 += 2; + print '4340: mat_Y3 += 2'; + vrfy(mat_Y3 == error(10003), '4341: mat_Y3 == error(10003)'); + mat_Z0 += { }; + print '4342: mat_Z0 += { }'; + vrfy(mat_Z0[0] == 2, '4343: mat_Z0[0] == 2'); + vrfy(mat_Z0[1] == 4, '4344: mat_Z0[1] == 4'); + mat_Y0 = {mat_Z0, ,mat_Z1, mat_X3}; + print '4345: mat_Y0 = {mat_Z0, ,mat_Z1, mat_X3}'; + vrfy(size(mat_Y0) == 4, '4346: size(mat_Y0) == 4'); + for (i=0; i < 4; ++i) mat_X0[i] = size(mat_Y0[i]); + print '4347: for (i=0; i < 4; ++i) mat_X0[i] = size(mat_Y0[i])'; + mat_X0==(mat[4]={2,1,2,3}); + print '4348: mat_X0==(mat[4]={2,1,2,3})'; + vrfy(mat_Y0[0] == mat_Z0, '4349: mat_Y0[0] == mat_Z0'); + vrfy(mat_Y0[1] == 0, '4350: mat_Y0[1] == 0'); + vrfy(mat_Y0[2] == mat_Z1, '4351: mat_Y0[2] == mat_Z1'); + vrfy(mat_Y0[3] == mat_X3, '4352: mat_Y0[3] == mat_X3'); + vrfy(mat_Y0[0][0] == 2, '4353: mat_Y0[0][0] == 2'); + vrfy(mat_Y0[0][1] == 4, '4354: mat_Y0[0][1] == 4'); + vrfy(mat_Y0[2][0] == 1, '4355: mat_Y0[2][0] == 1'); + vrfy(mat_Y0[2][1] == 3, '4356: mat_Y0[2][1] == 3'); + vrfy(mat_Y0[3][0] == 5, '4357: mat_Y0[3][0] == 5'); + vrfy(mat_Y0[3][1] == 7, '4358: mat_Y0[3][1] == 7'); + vrfy(mat_Y0[3][2] == 10, '4359: mat_Y0[3][2] == 10'); + + M0 = {(mat[2]={5,17}),(mat[2]={3,4}),(mat[2]={2,3}),(mat[2]={1,2})}; + print '4360: M0 = {(mat[2]={5,17}), ...}'; + M1 = {(mat[2]={5,3}),(mat[2]={2,5}),(mat[2]={1,5}),(mat[2]={3,2})}; + print '4361: M1 = {(mat[2]={5,3}), ...}'; + M2 = M0+M1; + print '4362: M2 = M0+M1'; + vrfy(M2[0,0]==(mat[2]={10,20}), '4363: M2[0,0]==(mat[2]={10,20})'); + vrfy(M2[0,1]==(mat[2]={5,9}), '4364: M2[0,1]==(mat[2]={5,9})'); + vrfy(M2[1,0]==(mat[2]={3,8}), '4365: M2[1,0]==(mat[2]={3,20})'); + vrfy(M2[1,1]==(mat[2]={4,4}), '4366: M2[1,1]==(mat[2]={4,4})'); + + print '4367: Ending test_matdcl'; +} +print '075: parsed test_matdcl()'; + + +/* + * test_objmat - test combined obj and mat operations + */ +define test_objmat() +{ + static obj surd P, R, S, T, U; + local mat M0[2] = {5,17}; + local mat M1[2] = {3,4}; + local mat M2[2,2] = {1,2,3,5}; + local mat M3[2,2] = {3,5,7,11}; + local mat M4[2,2] = {51,82,116,187}; + local Q; + local V; + local A,B,C,M; + + print '4400: Beginning test_objmat'; + + surd_type = -1; + print '4401: surd_type == -1'; + P = {M0,M1}; + print '4402: P = {M0,M1}'; + vrfy(P == surd(M0,M1), '4403: P == surd(M0,M1)'); + vrfy(P != surd(M1,M0), '4404: P == surd(M1,M0)'); + vrfy(conj(P)==surd(M0,-M1), '4405: conj(P)==surd(M0,-M1)'); + Q = surd_value(P); + print '4406: Q = surd_value(P)'; + vrfy(ismat(Q), '4407: ismat(Q)'); + vrfy(Q == (mat[2]={5+3i,17+4i}), '4408: Q == (mat[2]={5+3i,17+4i})'); + R = {M2,M3}; + print '4409: R = {M2,M3}'; + vrfy(norm(R) == M4, '4410: norm(R) == M4'); + vrfy(det(surd_value(R^2)) == -23-6i, \ + '4411: det(surd_value(R^2)) == -23-6i'); + vrfy(det(norm(R^5))==268107761663283843865, \ + '4412: det(norm(R^5))==268107761663283843865'); + S = {M2+M3, M2-M3}; + print '4413: S = {M2+M3, M2-M3}'; + T = {M2+3*M3, 5*M2-M3}; + print '4414: T = {M2+3*M3, 5*M2-M3}'; + U = {(M4 -= {50,80,110,180}), M4+M2}; + print '4415: U = {(M4 -= {50,80,110,180}), M4+M2}'; + vrfy(det(surd_value(R*S*T*U)) == 480-15040i, + '4416: det(surd_value(R*S*T*U)) == 480-15040i'); + vrfy(det(surd_value(R*S+T*U)) == 78+514i, + '4417: det(surd_value(R*S+T*U)) == 78+514i'); + V = norm(det(surd_value(R^5+S^5+T^5+U^5))); + print '4418: V = norm(det(surd_value(R^5+S^5+T^5+U^5)))'; + vrfy(V == 41952632964892462488299378, \ + '4419: V == 41952632964892462488299378'); + V = norm(det(surd_value(R^5-S^5+T^5-U^5))); + print '4420: V = norm(det(surd_value(R^5-S^5+T^5-U^5)))'; + vrfy(V == 40891924356202870926321650, \ + '4421: V == 40891924356202870926321650'); + + + vrfy((mat [3] = {2,3,5})+(mat[3] = {7,11,13}) == (mat[3]={9,14,18}),\ + '4422: (mat [3] = {2,3,5})+(mat[3] = {7,11,13}) == (mat[3]={9,14,18})'); + + vrfy((mat [2,2] = {2,3,5,7})^2 == (mat[2,2] = {19, 27, 45, 64}),\ + '4423: (mat [2,2] = {2,3,5,7})^2 == (mat[2,2] = {19, 27, 45, 64})'); + + vrfy((mat [] = {1,2,3}) == (mat[3] = {1,2,3}), + '4424: (mat [] = {1,2,3}) == (mat[3] = {1,2,3})'); + + mat A[3] = {2,3,5}; + print '4425: mat A[3] = {2,3,5}'; + mat A[3] = {A[0], A[2], A[1]}; + print '4426: mat A[3] = {A[0], A[2], A[1]}'; + vrfy(A == (mat[3] = {2, 5, 3}), '4427: A == (mat[3] = {2, 5, 3})'); + + B = mat[3] = {2,5,3}; + print '4428: B = mat[3] = {2,5,3}'; + vrfy(A == B, '4429: A == B'); + + mat A[2] = {A[1], A[2]}; + print '4430: mat A[2] = {A[1], A[2]}'; + vrfy(A == (mat[2] = {5, 3}), '4431: A == (mat[2] = {5, 3})'); + + A = B; + print '4432: A = B'; + A = {A[0], A[2], A[1]}; + print '4433: A = {A[0], A[2], A[1]}'; + vrfy(A == (mat[3] = {2, 3, 3}), '4434: A == (mat[3] = {2, 3, 3})'); + + A = mat[3] = {1,2} = {,3,4}; + print '4435: A = mat[3] = {1,2} = {,3,4}'; + vrfy(A == (mat[3] = {1,3,4}), '4436: A == (mat[3] = {1,3,4})'); + + mat A[4] = {1,2,3,4}; + print '4437: mat A[4] = {1,2,3,4}'; + A = {,5,,6}; + print '4438: A = {,5,,6}'; + vrfy(A == (mat[4] = {1,5,3,6}), '4439: A == (mat[4] = {1,5,3,6})'); + + A = {7}; + print '4440: A = {7}'; + vrfy(A == (mat[4] = {7,5,3,6}), '4441: A == (mat[4] = {7,5,3,6})'); + + mat M[2]; + print '4442: mat M[2]'; + mat A, B, C [3] = {M, M, M}; + print '4443: mat A, B, C [3] = {M, M, M}'; + + A = {{2, 3}, {5, 7}, {11, 13}}; + print '4444: A = {{2, 3}, {5, 7}, {11, 13}}'; + B = {{1, 2}, {3, 4}, {5, 6}}; + print '4445: B = {{1, 2}, {3, 4}, {5, 6}}'; + C = {{3, 5}, {8, 11}, {16, 19}}; + print '4446: C = {{3, 5}, {8, 11}, {16, 19}}'; + + vrfy(A + B == C, '4447: A + B == C'); + + mat A[2][3]; + print '4448: mat A[2][3]'; + A = {{1, 2, 3}, {4, 5, 6}}; + print '4449: A = {{1, 2, 3}, {4, 5, 6}}'; + vrfy(A[0][1] == 2, '4450: A[0][1] == 2'); + + vrfy(A[1,0] == 4, '4451: A[1,0] == 4'); + + B = mat[2][3] = {{1, 2, 3}, {4, 5, 6}}; + print '4452: B = mat[2][3] = {{1, 2, 3}, {4, 5, 6}}'; + vrfy(A == B, '4453: A == B'); + + mat A[2][3] = {{1, 2, 3}, {4, 5, 6}}; + print '4454: mat A[2][3] = {{1, 2, 3}, {4, 5, 6}}'; + vrfy(A == B, '4455: A == B'); + + mat A[2][3] = {{1,2,3},4}; + print '4456: mat A[2][3] = {{1,2,3},4}'; + vrfy(A[0] == (mat[3] = {1,2,3}), '4457: A[0] == (mat[3] = {1,2,3})'); + + vrfy(A[1] == 4, '4458: A[1] == 4'); + + A += {{3,5,7}, 11}; + print '4459: A += {{3,5,7}, 11}'; + + vrfy(A[0] == (mat[3]={4,7,10}), '4460: A[0] == (mat[3]={4,7,10})'); + + vrfy(A[1] == 15, '4461: A[1] == 15'); + + mat A[2,2][2,2]={{1,2,3,4},{5,6,7,8},{9,10,11,12},{13,14,15,16}}; + print '4462: mat A[2,2][2,2]={{1,2,3,4},{5,6,7,8},{9,10,11,12},{13,14,15,16}}'; + B = A^2; + print '4463: B = A^2'; + + vrfy(B[0,0] == (mat[2,2] = {118, 132, 166, 188}), \ + '4464: B[0,0] == (mat[2,2] = {118, 132, 166, 188})'); + + print '4465: Ending test_objmat'; + print; + print '4500: reserved for future expansion of test_objmat'; +} +print '076: parsed test_objmat()'; + + +/* + * test_fileop - test file operations + */ +read -once "test4600"; +print '077: read -once test4600'; +/**/ +define test_fileop() +{ + local tnum; /* test number */ + + print '4600: Beginning test_fileop'; + + tnum = test4600(1, 4601); + + print tnum: ': Ending test_fileop'; +} +print '078: parsed test_fileop()'; + + +/* + * test write/read + */ +x_081 = isqrt(2e5000); +print '079: x_081 = isqrt(2e5000)' +s_x_081 = str(x_081); +print '080: s_x_081 = str(x_081)'; +d_081 = rm("test082.cal"); +print '081: d_081 = rm("test082.cal")'; +write test082.cal; +print '082: write test082.cal'; +read "./test082.cal"; +print '083: read "./test082.cal"'; +d_081 = rm("test082.cal"); +print '084: d081 = rm("test082.cal")'; +vrfy(__ == 63, '085: __ == 63'); +vrfy(x_081 == isqrt(2e5000), '086: x_081 == isqrt(2e5000)'); + + +/* + * test_charset - test the ASCII character set and \'s + */ +define test_charset() +{ + print '4700: Beginning test_charset'; + + vrfy("\a" == char(7), '4701: "\\a" == char(7)'); + vrfy("\v" == char(11), '4702: "\\v" == char(11)'); + vrfy("\e" == char(27), '4703: "\\e" == char(27)'); + vrfy("\\" == char(92), '4704: "\\\\" == char(92)'); + vrfy("\101" == "A", '4705: "\\101" == "A"'); + vrfy("\123" == char(0123), '4706: "\\123" == char(0123)'); + vrfy("\123\124" == "ST", '4707: "\\123\\124" == "ST"'); + vrfy("\311" == char(201), '4708: "\\311" == char(201)'); + vrfy("\119" == "\t9", '4709: "\\119" == "\t9"'); + vrfy("\765" == "\365", '4710: "\\765" == "\365"'); + vrfy("\x61" == "a", '4711: "\\x61" == "a"'); + vrfy("\x73" == "s", '4712: "\\x73" == "s"'); + vrfy("\xea" == char(234), '4713: "\\xea" == char(234)'); + vrfy("\x61\x62\x63" == "abc", '4714: "\\x61\\x62\\x63" == "abc"'); + vrfy("\x8g" == "\bg", '4715: "\\x8g" == "\bg"'); + vrfy(eval('"\\\\"') == "\\", + '4716: eval(\'"\\\\\\\\"\') == "\\\\"'); + + print '4717: Ending test_charset'; +} +print '087: parsed test_fileop()'; + + +/* + * test_strprintf - test strprintf calls + */ +define test_strprintf() +{ + local callcfg; /* caller configuration value */ + local c; /* modified configuration */ + + print '4800: Beginning test_strprintf'; + + /* setup */ + callcfg = config("all"); + print '4801: callcfg = config("all")'; + c = config("mode", "frac"); + print '4802: c = config("mode", "frac")'; + c = config("outround", 24); + print '4803: c = config("outround", 24)'; + c = config("display", 2); + print '4804: c = config("display", 2)'; + c = config("tilde", 0); + print '4805: c = config("tilde", 0)'; + c = config("leadzero", 0); + print '4806: c = config("leadzero", 0)'; + c = config("fullzero", 0); + print '4807: c = config("fullzero", 0)'; + + /* tests with tilde == 0 */ + vrfy(strprintf("%d%d", 27, 29) == "2729", + '4808: strprintf("%d%d", 27, 29) == "2729"'); + vrfy(strprintf("%5d%3d", 27, 29) == " 27 29", + '4809: strprintf("%5d%3d", 27, 29) == " 27 29"; '); + vrfy(strprintf("%-5d%-3d", 27, 29) == "27 29 ", + '4810: strprintf("%-5d%-3d", 27, 29) == "27 29 "'); + vrfy(strprintf("%f", 1.375) == "1.38", + '4811: strprintf("%f", 1.375) == "1.38"'); + vrfy(strprintf("%f", 1.385) == "1.38", + '4812: strprintf("%f", 1.385) == "1.38"'); + vrfy(strprintf("%f", .375) == ".38", + '4813: strprintf("%f", .375) == ".38"'); + vrfy(strprintf("%f", .385) == ".38", + '4814: strprintf("%f", .385) == ".38"'); + + /* tests with tilde == 1 */ + c = config("tilde", 1); + print '4815: c = config("tilde", 1)'; + vrfy(strprintf("%f", 1.375) == "~1.38", + '4816: strprintf("%f", 1.375) == "~1.38"'); + vrfy(strprintf("%f", 27/29) == "~.93", + '4817: strprintf("%f", 27/29) == "~.93"'); + vrfy(strprintf("%r", 27/29) == "27/29", + '4818: strprintf("%r", 27/29) == "27/29"'); + vrfy(strprintf("%o", 27/29) == "033/035", + '4819: strprintf("%o", 27/29) == "033/035"'); + vrfy(strprintf("%x", 27/29) == "0x1b/0x1d", + '4820: strprintf("%x", 27/29) == "0x1b/0x1d"'); + vrfy(strprintf("%b", 27/29) == "0b11011/0b11101", + '4821: strprintf("%b", 27/29) == "0b11011/0b11101"'); + vrfy(strprintf("%e", 12345) == "~1.23e4", + '4822: strprintf("%e", 12345) == "~1.23e4"'); + + /* mode tests with tilde == 0 */ + c = config("tilde", 0); + print '4823: c = config("tilde", 0)'; + vrfy(strprintf("%e", 12345) == "1.23e4", + '4824: strprintf("%e", 12345) == "1.23e4"'); + vrfy(strprintf("%.3e", 12345) == "1.234e4", + '4825: strprintf("%.3e", 12345) == "1.234e4"'); + vrfy(strprintf("%e", .00012345) == "1.23e-4", + '4826: strprintf("%e", .00012345) == "1.23e-4"'); + vrfy(strprintf("%d %d", 27) == "27 ", + '4827: strprintf("%d %d", 27) == "27 "'); + vrfy(strprintf("%d", 27, 29) == "27", + '4828: strprintf("%d", 27, 29) == "27"'); + vrfy(strprintf("%r = %f", 27/29, 27/29) == "27/29 = .93", + '4829: strprintf("%r = %f", 27/29, 27/29) == "27/29 = .93"'); + vrfy(strprintf("%s", "abc") == "abc", + '4830: strprintf("%s", "abc") == "abc"'); + vrfy(strprintf("%f", "abc") == "abc", + '4831: strprintf("%f", "abc") == "abc"'); + vrfy(strprintf("%e", "abc") == "abc", + '4832: strprintf("%e", "abc") == "abc"'); + vrfy(strprintf("%5s", "abc") == " abc", + '4833: strprintf("%5s", "abc") == " abc"'); + vrfy(strprintf("%-5s", "abc") == "abc ", + '4834: strprintf("%-5s", "abc") == "abc "'); + + /* restore config */ + c = config("all", callcfg); + print '4835: c = config("all", callcfg)'; + + print '4836: Ending test_strprintf'; +} +print '088: parsed test_fileop()'; + + +/* + * place holder for any print items + */ +print '100: reserved for future use'; + + +/* + * Report the number of errors found. + */ +define count_errors() +{ + if (err == 0) { + print "9998: passed all tests /\\../\\"; + } else { + print "****", err, "error(s) found \\/++\\/"; + } +} +print '198: parsed count_errors()'; + + +print '199: Ending main part of regression test suite read'; + + +print; +return test_booleans(); +print; +return test_variables(); +print; +return test_arithmetic(); +print; +return test_config(); +print; +return test_bignums(); +print; +return test_functions(); +print; +return _test_underscore(); +print; +return test_assoc(); +print; +return test_list(); +print; +return test_rand(); +print; +return test_mode(); +print; +print '1700: Beginning read test'; +value = 0; +vrfy(value == 0, '1701: value == 0'); +read "test1700"; +vrfy(value == 1, '1702: value == 1'); +read -once "test1700"; +vrfy(value == 1, '1703: value == 1'); +read "test1700.cal"; +vrfy(value == 2, '1704: value == 2'); +read -once "test1700.cal"; +vrfy(value == 2, '1705: value == 2'); +read "test1700.cal"; +vrfy(value == 3, '1706: value == 3'); +print '1707: Ending read test'; +print; +return test_obj(); +print; +return test_prime(); +print; +return test_lucas(); +print; +return test_newop(); +print; +return test_xx_incdec(); +print; +return test_round(); +print; +return test_2600(); +print; +return test_2700(); +print; +return test_matrix(); +print; +return test_strings(); +print; +return test_matobj(); +print; +return test_poly(); +print; +return test_det(); +print; +return test_trig(); +print; +return test_frem(); +print; +return test_error(); +print; +return test_param(); +print; +return test_noarg(); +print; +return test_ptest(); +print; +return test_redc(); +print; +return test_fileops(); +print; +return test_matdcl(); +print; +return test_objmat(); +print; +return test_fileop(); +print; +return test_charset(); +print; +return test_strprintf(); +print; +return count_errors(); +print '9999: Ending regression tests'; diff --git a/lib/seedrandom.cal b/lib/seedrandom.cal new file mode 100644 index 0000000..88affec --- /dev/null +++ b/lib/seedrandom.cal @@ -0,0 +1,136 @@ +/* + * Copyright (c) 1996 Landon Curt Noll + * + * 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 + */ + +global lib_debug; /* 1 => print debug statements */ + +/* + * seedrandom - seed the cryptographically strong Blum generator + * + * This function will seed the random() generator using a method + * similar to method suggested for the paranoid in the zrand.c source + * file and random help file. + * + * given: + * seed1 - a large random value (at least 10^20 and perhaps < 10^93) + * seed2 - a large random value (at least 10^20 and perhaps < 10^93) + * size - min Blum modulus as a power of 2 (at least 100, perhaps > 1024) + * trials - number of ptest() trials (default 25) + * + * returns: + * the previous random state + * + * NOTE: The [10^20, 10^93) range comes from [2^64, 2^64*fact(55)) range + * where seeds are effective for srand(). All we really need to + * do is to insist that a seed is > 2^64, which the 10^20 limit does. + */ +define seedrandom(seed1, seed2, size, trials) +{ + local p; /* first Blum prime */ + local fp; /* prime co-factor of p-1 */ + local sp; /* min bit size of p */ + local q; /* second Blum prime */ + local fq; /* prime co-factor of q-1 */ + local sq; /* min bit size of q */ + local n; /* Blum modulus */ + local binsize; /* smallest power of 2 > n=p*q */ + local r; /* initial quadratic residue */ + local rand_state; /* the initial rand state */ + local rand_junk; /* rand state that is not needed */ + local old_state; /* old random state to return */ + local random_cfg; /* old srandom configuration value */ + + /* + * firewall + */ + if (!isint(seed1)) { + quit "1st arg (seed1) is not an int"; + } + if (!isint(seed2)) { + quit "2nd arg (seed2) is not an int"; + } + if (!isint(size)) { + quit "3rd arg (size) is not an int"; + } + if (!isint(trials)) { + trials = 25; + } + if (digits(seed1) <= 20) { + quit "1st arg (seed1) must be > 10^20 and perhaps < 10^93"; + } + if (digits(seed2) <= 20) { + quit "2nd arg (seed2) must be > 10^20 and perhaps < 10^93"; + } + if (size < 100) { + /* 3% of 100 is 2.97 < 3 whereas 3% of 100 is 3 */ + quit "3rd arg (size) needs to be > 66 (perhaps >= 1024)"; + } + if (trials < 1) { + quit "4th arg (trials) must be > 0"; + } + + /* + * determine the search parameters + */ + ++size; /* convert power of 2 to bit length */ + sp = int((size/2)-(size*0.03)+1); + sq = size - sp; + + /* + * find the first Blum prime + */ + rand_state = srand(seed1); + do { + fp = nextcand(2^sp+randbit(sp), trials, 0, 3, 4); + p = 2*fp+1; + } while (ptest(p,trials) == 0); + + /* + * find the 2nd Blum prime + */ + rand_junk = srand(seed2); + do { + fq = nextcand(2^sq+randbit(sq), trials, 0, 3, 4); + q = 2*fq+1; + } while (ptest(q,trials) == 0); + + /* + * seed the Blum generator + */ + n = p*q; /* the Blum modulus */ + binsize = higbbit(n)+1; /* smallest power of 2 > p*q */ + r = pmod(rand(1<= 0) { + print "solve(low, high, epsilon) defined"; +} diff --git a/lib/sumsq.cal b/lib/sumsq.cal new file mode 100644 index 0000000..92754f6 --- /dev/null +++ b/lib/sumsq.cal @@ -0,0 +1,44 @@ +/* + * Copyright (c) 1995 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/lib/surd.cal b/lib/surd.cal new file mode 100644 index 0000000..d1e5056 --- /dev/null +++ b/lib/surd.cal @@ -0,0 +1,288 @@ +/* + * Copyright (c) 1995 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/lib/test1700.cal b/lib/test1700.cal new file mode 100644 index 0000000..081d8b3 --- /dev/null +++ b/lib/test1700.cal @@ -0,0 +1,12 @@ +/* + * Copyright (c) 1995 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 1700 series of the regress.cal test suite. + */ + +++value; diff --git a/lib/test2300.cal b/lib/test2300.cal new file mode 100644 index 0000000..d288339 --- /dev/null +++ b/lib/test2300.cal @@ -0,0 +1,97 @@ +/* + * Copyright (c) 1995 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 2300 series of the regress.cal test suite. + */ + + +obj matrix {m} + + +/* + * matrix_inc - increment the matrix inside the object + */ +define matrix_inc(a) +{ + local i; + + /* increment each matrix member */ + for (i= 0; i < size(a.m); i++) + ++a.m[[i]]; + return a; +} + +/* + * matrix_dec - decrement the matrix inside the object + */ +define matrix_dec(a) +{ + local i; + + /* decrement each matrix member */ + for (i= 0; i < size(a.m); i++) + --a.m[[i]]; + return a; +} + +/* + * mkmat - load the matrix inside the object + */ +define mkmat() +{ + local s, M, i, v; + + /* firewall */ + s = param(0); + if (s == 0) + quit "Need at least one argument"; + + /* create the matrix */ + mat M[s]; + + /* load the matrix with the args */ + for (i = 0; i < s; i++) + M[i] = param(i + 1); + + /* create the object with the matrix */ + obj matrix v; + v.m = M; + return v; +} + +/* + * ckmat - check if the matrix inside an object has a set of given values + */ +define ckmat() +{ + local s, a, i; + + /* firewall */ + s = param(0); + if (s < 2) + quit "Need at least two arguments"; + + /* get the object to test */ + a = param(1); + + /* verify the matrix in the object is the right size */ + if (size(a.m) != s-1) { + return 0; + } + + /* check each matrix element with the args passed */ + for (i = 2; i <= s; i++) { + if (a.m[i-2] != param(i)) { + /* args do not match */ + return 0; + } + } + + /* args match the matrix in the object */ + return 1; +} diff --git a/lib/test2600.cal b/lib/test2600.cal new file mode 100644 index 0000000..f3abc2e --- /dev/null +++ b/lib/test2600.cal @@ -0,0 +1,516 @@ +/* + * Copyright (c) 1996 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 2600 series of the regress.cal test suite. + */ +/* + * Stringent tests of some of calc's builtin functions. + * Most of the tests are concerned with the accuracy of the value + * returned for a function; usually it is expected that + * remainder (true value - calculated value) will be less in + * absolute value than "epsilon", where this is either a specified + * argument eps, or if this is omitted, the current value of epsilon(). + * In some cases the remainder is to have a particular sign, or to + * have absolute value not exceeding eps/2, or in some cases 3 * eps/4. + * + * Typical of these tests is testpower("power", n, b, eps, verbose). + * Here n is the number of numbers a for which power(a, b, eps) is to + * be evaluated; the ratio c = (true value - calculated value)/eps + * is calculated and if this is not less in absolute value than + * 0.75, a "failure" is recorded and the value of a displayed. + * On completion of the tests, the minimum and maximum values of + * c are displayed. + * + * The numbers a are usually large "random" integers or sometimes + * ratios of such integers. In some cases the formulae used to + * calculate c assume eps is small compared with the value of the + * function. If eps is very small, say 1e-1000, or if the denominator + * of b in power(a, b, eps) is large, the computation required for + * a test may be very heavy. + * + * Test funcations are called as: + * + * testabc(str, ..., verbose) + * + * where str is a string that names the test. This string is printed + * without a newline (if verbose > 0), near the beginning of the function. + * The verbose parameter controls how verbose the test will be: + * + * 0 - print nothing + * 1 - print str and the error count + * 2 - print min and max errors as well + * 3 - print everything including individual loop counts + * + * All functions return the number of errors that they detected. + */ + +global defaultverbose = 1; /* default verbose value */ +global err; + +define testismult(str, n, verbose) +{ + local a, b, c, i, m; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + for (i = 0; i < n; i++) { + if (verbose > 2) print i,:; + a = scale(rand(1,1e1000), rand(100)); + b = scale(rand(1,1e1000), rand(100)); + c = a * b; + if (!ismult(c,a)) { + m++; + if (verbose > 1) { + printf("*** Failure with:\na = %d\nb = %d\n", a,b); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +define testsqrt(str, n, eps, verbose) +{ + local a, c, i, x, m, min, max; + + if (isnull(verbose)) verbose = 2; + if (verbose > 0) { + print str:":",:; + } + m = 0; + min = 1000; + max = -1000; + if (isnull(eps)) + eps = epsilon(); + for (i = 1; i <= n; i++) { + if (verbose > 2) print i,:; + a = scale(rand(1,1000), rand(100)); + x = sqrt(a, eps); + if (x) + c = (a/x - x)/2/eps; + else + c = a/eps; /* ??? */ + if (c < min) + min = c; + if (c > max) + max = c; + if (abs(c) > 1) { + m++; + if (verbose > 1) { + printf("*** Failure with:\na = %d\neps = %d\n", a,eps); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + printf(" %s: rem/eps min=%d, max=%d\n", + str, min, max); + } else { + printf("no errors\n"); + } + } + if (verbose > 1) { + printf(" %s: rem/eps min=%0.4d, max=%0.4d\n", str, min, max); + } + return m; +} + + +define testexp(str, n, eps, verbose) +{ + local i, a, c, m, min, max; + + if (isnull(verbose)) verbose = 2; + if (verbose > 0) { + print str:":",:; + } + if (isnull(eps)) + eps = epsilon(); + min = 1000; + max = -1000; + for (i = 1; i <= n; i++) { + if (verbose > 2) print i,:; + a = rand(1,1e20)/rand(1,1e20) + rand(50); + if (rand(1)) + a = -a; + c = cexp(a, eps); + if (c < min) + min = c; + if (c > max) + max = c; + if (abs(c) > 0.02) { + m++; + if (verbose > 1) { + printf("*** Failure with:\na = %d\neps = %d\n", a,eps); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + printf(" %s: rem/eps min=%d, max=%d\n", + str, min, max); + } else { + printf("no errors\n"); + } + } + if (verbose > 1) { + printf(" %s: rem/eps min=%0.4d, max=%0.4d\n", str, min, max); + } + return m; +} + + +define cexp(x,eps) /* Find relative rem/eps for exp(x, eps) */ +{ + local eps1, v, v1, c; + + if (isnull(eps)) + eps = epsilon(); + eps1 = eps * 1e-6; + v = exp(x, eps); + v1 = exp(x, eps1); + c = round((v1 - v)/v1/eps, 6, 24); + return c; +} + + +define testln(str, n, eps, verbose) +{ + local i, a, c, m, min, max; + + if (isnull(verbose)) verbose = 2; + if (verbose > 0) { + print str:":",:; + } + if (isnull(eps)) + eps = epsilon(); + min = 1000; + max = -1000; + for (i = 1; i <= n; i++) { + if (verbose > 2) print i,:; + a = rand(1,1e20)/rand(1,1e20) + rand(50); + c = cln(a, eps); + if (c < min) + min = c; + if (c > max) + max = c; + if (abs(c) > 0.5) { + m++; + if (verbose > 1) { + printf("*** Failure with:\na = %d\neps = %d\n", a,eps); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + printf(" %s: rem/eps min=%d, max=%d\n", + str, min, max); + } else { + printf("no errors\n"); + } + } + if (verbose > 1) { + printf(" %s: rem/eps min=%0.4d, max=%0.4d\n", str, min, max); + } + return m; +} + +define cln(a, eps) +{ + local eps1, v, v1, c; + + if (isnull(eps)) + eps = epsilon(); + eps1 = eps/1e6; + v = ln(a, eps); + v1 = ln(a, eps1); + c = round((v1 - v)/eps, 6, 24); + return c; +} + + +define testpower(str, n, b, eps, verbose) +{ + local i, a, c, m, min, max; + + if (isnull(verbose)) verbose = 2; + if (verbose > 0) { + print str:":",:; + } + if (isnull(eps)) + eps = epsilon(); + if (!isnum(b)) + quit "Second argument (exponent) to be a number"; + min = 1000; + max = -1000; + for (i = 1; i <= n; i++) { + if (verbose > 2) print i,:; + a = rand(1,1e20)/rand(1,1e20); + c = cpow(a, b, eps); + if (abs(c) > .75) { + m++; + if (verbose > 1) { + printf("*** Failure for a = %d\n", a); + } + } + if (c < min) + min = c; + if (c > max) + max = c; + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + printf(" %s: rem/eps min=%d, max=%d\n", + str, min, max); + } else { + printf("no errors\n"); + } + } + if (verbose > 1) { + printf(" %s: rem/eps min=%0.4d, max=%0.4d\n", str, min, max); + } + return m; +} + + +define cpow(a, b, eps) /* Find rem/eps for power(a,b,eps) */ +{ + local v, v1, c, n, d, h; + + if (isnull(eps)) + eps = epsilon(); + n = num(b); + d = den(b); + + v = power(a, b, eps); + h = (a^n/v^d - 1) * v/d; + c = round(h/eps, 6, 24); + return c; +} + +define testgcd(str, n, verbose) +{ + local i, a, b, g, m; + + if (isnull(verbose)) verbose = 2; + if (verbose > 0) { + print str:":",:; + } + m = 0; + for (i = 1; i <= n; i++) { + if (verbose > 2) print i,:; + a = rand(1,1e1000); + b = rand(1,1e1000); + g = gcd(a,b); + if (!ismult(a,g) || !ismult(b,g) || !g || !isrel(a/g, b/g)) { + m++; + printf("*** Failure for a = %d, b = %d\n", a, b); + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +define mkreal() = scale(rand(-1000,1001)/rand(1,1000), rand(-100, 101)); + +define mkcomplex() = mkreal() + 1i * mkreal(); + +define mkbigreal() +{ + local x; + + x = rand(100, 1000)/rand(1,10); + if (rand(2)) + x = -x; + return x; +} + +define mksmallreal() = rand(-10, 11)/rand(100,1000); + +define testappr(str, n, verbose) +{ + local x, y, z, m, i, p; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + for (i = 1; i <= n; i++) { + x = rand(3) ? mkreal(): mkcomplex(); + y = mkreal(); + if (verbose > 2) + printf(" %d: x = %d, y = %d\n", i, x, y); + + for (z = 0; z < 32; z++) { + p = checkappr(x,y,z,verbose); + if (p) { + printf("*** Failure for x=%d, y=%d, z=%d\n", + x, y, z); + m++; + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + + +define checkappr(x,y,z,verbose) /* Returns 1 if an error is detected */ +{ + local a; + + a = appr(x,y,z); + if (verbose > 1) + printf("\ta = %d\n", a); + if (isreal(x)) + return checkresult(x,y,z,a); + if (isnum(x)) + return checkresult(re(x), y, z, re(a)) + | checkresult(im(x), y, z, im(a)); + + quit "Bad first argument for checkappr()"; +} + +define checkresult(x,y,z,a) /* tests correctness of a = appr(x,y,z) */ +{ + local r, n, s, v; + + if (y == 0) + return (a != x); + r = x - a; + n = a/y; + + if (!isint(n)) + return 1; + if (abs(r) >= abs(y)) + return 1; + if (r == 0) + return 0; + if (z & 16) { + if (abs(r) > abs(y)/2) + return 1; + if (abs(r) < abs(y)/2) + return 0; + z &= 15; + } + s = sgn(r); + switch (z) { + case 0: v = (s == sgn(y)); break; + case 1: v = (s == -sgn(y)); break; + case 2: v = (s == sgn(x)); break; + case 3: v = (s == -sgn(x)); break; + case 4: v = (s > 0); break; + case 5: v = (s < 0); break; + case 6: v = (s == sgn(x/y)); break; + case 7: v = (s == -sgn(x/y)); break; + case 8: v = iseven(n); break; + case 9: v = isodd(n); break; + case 10: v = (x/y > 0) ? iseven(n) : isodd(n); break; + case 11: v = (x/y > 0) ? isodd(n) : iseven(n); break; + case 12: v = (y > 0) ? iseven(n) : isodd(n); break; + case 13: v = (y > 0) ? isodd(n) : iseven(n); break; + case 14: v = (x > 0) ? iseven(n) : isodd(n); break; + case 15: v = (x > 0) ? isodd(n) : iseven(n); break; + } + return !v; +} + +/* + * test2600 - perform all of the above tests a bunch of times + */ +define test2600(verbose, tnum) +{ + local n; /* test parameter */ + local ep; /* test parameter */ + local i; + + /* set test parameters */ + n = 5; /* internal test loop count */ + if (isnull(verbose)) { + verbose = defaultverbose; + } + if (isnull(tnum)) { + tnum = 1; /* initial test number */ + } + + /* + * test a lot of stuff + */ + srand(2600e2600); + ep = 1e-250; + err += testismult(strcat(str(tnum++), ": mult"), n*20, verbose); + err += testappr(strcat(str(tnum++), ": appr"), n*40, verbose); + err += testexp(strcat(str(tnum++),": exp"), n, ep, verbose); + err += testln(strcat(str(tnum++),": ln"), n, ep, verbose); + err += testpower(strcat(str(tnum++),": power"), n, + rand(2,10), ep, verbose); + err += testgcd(strcat(str(tnum++),": gcd"), n, ep, verbose); + for (i=0; i < 32; ++i) { + config("sqrt", i); + err += testsqrt(strcat(str(tnum++),": sqrt",str(i)), n*10, + ep, verbose); + } + if (verbose > 1) { + if (err) { + print "***", err, "error(s) found in test2600"; + } else { + print "no errors in test2600"; + } + } + return tnum; +} + +global lib_debug; +if (lib_debug >= 0) { + print "global defaultverbose defined"; + print "global err defined"; + print "testismult(str,n,verbose) defined"; + print "testsqrt(str,n,eps,verbose) defined"; + print "testexp(str,n,eps,verbose) defined"; + print "testln(str,n,eps,verbose) defined"; + print "testpower(str,n,b,eps,verbose) defined"; + print "testgcd(str,n,verbose) defined"; + print "cpow(x,n,eps) defined"; + print "cexp(x,eps) defined"; + print "cln(x,eps) defined"; + print "mkreal() defined"; + print "mkcomplex() defined"; + print "mkbigreal() defined"; + print "mksmallreal() defined"; + print "testappr(str,n,verbose) defined"; + print "checkappr(x,y,z,verbose) defined"; + print "checkresult(x,y,z,a) defined"; + print "test2600(verbose,tnum) defined"; +} diff --git a/lib/test2700.cal b/lib/test2700.cal new file mode 100644 index 0000000..18aa2b4 --- /dev/null +++ b/lib/test2700.cal @@ -0,0 +1,331 @@ +/* + * Copyright (c) 1996 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 2700 series of the regress.cal test suite. + */ +/* + * The following script gives a severe test of sqrt(x,y,z) for + * all 128 values of z, randomly produced real and complex x, and randomly + * produced nonzero values for y. After loading it, testcsqrt(n) will + * test n combinations of x and y; testcsqrt(str,n,2) will print 1 2 3 ... + * indicating work in process; testcsqrt(str,n,3) will give information about + * errors detected and will print values of x and y used. The + * number generators are essentially as in the script I sent yesterday. + * I've also defined a function iscomsq(x) which does for complex as well + * as real x what issq(x) currently does for real x. + */ + +global defaultverbose = 1; +global err; + +define mknonnegreal() { + switch(rand(8)) { + case 0: return rand(20); + case 1: return rand(20,1000); + case 2: return rand(1,10000)/rand(1,100); + case 3: return scale(mkposreal(), rand(1,100)); + case 4: return scale(mkposreal(), -rand(1,100)); + case 5: return rand(1, 1000) + scale(mkfrac(),-rand(1,100)); + case 6: return mkposreal()^2; + case 7: return mkposreal() * (1+scale(mkfrac(),-rand(1,100))); + } +} + +define mkposreal() { + local x; + + x = mknonnegreal(); + while (x == 0) + x = mknonnegreal(); + return x; +} + +define mkreal_2700() = rand(2) ? mknonnegreal() : -mknonnegreal(); + +define mknonzeroreal() = rand(2) ? mkposreal() : -mkposreal(); + +/* Number > 0 and < 1, almost uniformly distributed */ +define mkposfrac() { + local x,y; + + x = rand(1,1000); + do + y = rand(1,1000); + while (y == x); + if (x > y) + swap(x,y); + return x/y; +} + +/* Nonzero > -1 and < 1 */ +define mkfrac() = rand(2) ? mkposfrac() : -mkposfrac(); + +define mksquarereal() = mknonnegreal()^2; + +/* + * XXX - Should be able to do better than the following. For nonsquare + * positive integer less than 1e6, could use + * x = rand(1, 1000); + * return rand(x^2 + 1, (x + 1)^2); + * Maybe could do + * do + * x = mkreal_2700(); + * while + * (issq(x)); + * This would of course not be satisfactory for testing issq(). + */ + +define mknonsquarereal() = 22 * mkposreal()^2/7; + +define mkcomplex_2700() = mkreal_2700() + 1i * mkreal_2700(); + +define testcsqrt(str, n, verbose) +{ + local x, y, z, m, i, p, v; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + for (i = 1; i <= n; i++) { + if (verbose > 1) print i,:; + x = rand(3) ? mkreal_2700(): mkcomplex_2700(); + y = scale(mknonzeroreal(), -100); + if (verbose > 2) + printf("%d: x = %d, y = %d\n", i, x, y); + + for (z = 0; z < 128; z++) { + v = sqrt(x,y,z); + p = checksqrt(x,y,z,v); + if (p) { + if (verbose > 0) + printf( + "*** Type %d failure for x = %r, y = %r, z = %d\n", + p, x, y, z); + m++; + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + + +define checksqrt(x,y,z,v) /* Returns >0 if an error is detected */ +{ + local A, B, X, Y, t1, t2, eps, u, n, f, s; + + A = re(x); + B = im(x); + X = re(v); + Y = im(v); + + /* checking signs of X and Y */ + + if (B == 0 && A <= 0) /* t1 = sgn(re(tvsqrt)) */ + t1 = 0; + else + t1 = (z & 64) ? -1 : 1; + + t2 = B ? sgn(B) : (A < 0); /* t2 = sgn(im(tvsqrt)) */ + if (z & 64) + t2 = -t2; + + if (t1 == 0 && X != 0) + return 1; + + if (t2 == 0 && Y != 0) { + printf("x = %d, Y = %d, t2 = %d\n", x, Y, t2); + return 2; + } + + if (X && sgn(X) != t1) + return 3; + + if (Y && sgn(Y) != t2) + return 4; + + if (z & 32 && iscomsq(x)) + return 5 * (x != v^2); + + eps = (z & 16) ? abs(y)/2 : abs(y); + u = sgn(y); + + /* Checking X */ + + n = X/y; + if (!isint(n)) + return 6; + + if (t1) { + f = checkavrem(A, B, abs(X), eps); + + if (z & 16 && f < 0) + return 7; + if (!(z & 16) && f <= 0) + return 8; + + if (!(z & 16) || f == 0) { + s = X ? t1 * sgn(A - X^2 + B^2/4/X^2) : t1; + if (s && !checkrounding(s,n,t1,u,z)) + return 9; + } + } + + /* Checking Y */ + + n = Y/y; + if (!isint(n)) + return 10; + + if (t2) { + f = checkavrem(-A, B, abs(Y), eps); + + if (z & 16 && f < 0) + return 11; + if (!(z & 16) && f <= 0) + return 12; + + if (!(z & 16) || f == 0) { + s = Y ? t2 * sgn(-A - Y^2 + B^2/4/Y^2) : t2; + if (s && !checkrounding(s,n,t2,u,z)) + return 13; + } + } + return 0; +} + +/* + * Check that the calculated absolute value X of the real part of + * sqrt(A + Bi) is between (true value - eps) and (true value + eps). + * Returns -1 if it is outside, 0 if on boundary, 1 if between. + */ + +define checkavrem(A, B, X, eps) +{ + local f; + + f = sgn(A - (X + eps)^2 + B^2/4/(X + eps)^2); + if (f > 0) + return -1; /* X < tv - eps */ + if (f == 0) + return 0; /* X = tv - eps */ + + if (X > eps) { + f = sgn(A - (X - eps)^2 + B^2/4/(X - eps)^2); + + if (f < 0) + return -1; /* X > tv + eps */ + if (f == 0) + return 0; /* X = tv + eps */ + } + return 1; /* tv - eps < X < tv + eps */ +} + + +define checkrounding(s,n,t,u,z) +{ + local w; + + switch (z & 15) { + case 0: w = (s == u); break; + case 1: w = (s == -u); break; + case 2: w = (s == t); break; + case 3: w = (s == -t); break; + case 4: w = (s > 0); break; + case 5: w = (s < 0); break; + case 6: w = (s == u/t); break; + case 7: w = (s == -u/t); break; + case 8: w = iseven(n); break; + case 9: w = isodd(n); break; + case 10: w = (u/t > 0) ? iseven(n) : isodd(n); break; + case 11: w = (u/t > 0) ? isodd(n) : iseven(n); break; + case 12: w = (u > 0) ? iseven(n) : isodd(n); break; + case 13: w = (u > 0) ? isodd(n) : iseven(n); break; + case 14: w = (t > 0) ? iseven(n) : isodd(n); break; + case 15: w = (t > 0) ? isodd(n) : iseven(n); break; + } + return w; +} + +define iscomsq(x) +{ + local c; + + if (isreal(x)) + return issq(abs(x)); + c = norm(x); + if (!issq(c)) + return 0; + return issq((re(x) + sqrt(c,1,32))/2); +} + +/* + * test2700 - perform all of the above tests a bunch of times + */ +define test2700(verbose, tnum) +{ + local n; /* test parameter */ + local ep; /* test parameter */ + local i; + + /* set test parameters */ + n = 32; /* internal test loop count */ + if (isnull(verbose)) { + verbose = defaultverbose; + } + if (isnull(tnum)) { + tnum = 1; /* initial test number */ + } + + /* + * test a lot of stuff + */ + srand(2700e2700); + for (i=0; i < n; ++i) { + err += testcsqrt(strcat(str(tnum++),": complex sqrt",str(i)), + 1, verbose); + } + if (verbose > 1) { + if (err) { + print "***", err, "error(s) found in testall"; + } else { + print "no errors in testall"; + } + } + return tnum; +} + +global lib_debug; +if (lib_debug >= 0) { + print "global defaultverbose defined"; + print "global err defined"; + print "mknonnegreal() defined"; + print "mkposreal() defined"; + print "mkreal_2700() defined"; + print "mknonzeroreal() defined"; + print "mkposfrac() defined"; + print "mkfrac() defined"; + print "mksquarereal() defined"; + print "mknonsquarereal() defined"; + print "mkcomplex_2700() defined"; + print "testcsqrt(str,n,verbose) defined"; + print "checksqrt(x,y,z,v) defined"; + print "checkavrem(A,B,X,eps) defined"; + print "checkrounding(s,n,t,u,z) defined"; + print "iscomsq(x) defined"; + print "test2700(verbose,tnum) defined"; +} diff --git a/lib/test3100.cal b/lib/test3100.cal new file mode 100644 index 0000000..7068fc8 --- /dev/null +++ b/lib/test3100.cal @@ -0,0 +1,31 @@ +/* + * Copyright (c) 1995 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 3100 series of the regress.cal test suite. + */ + +obj res {r}; +global md; +define res_test(a) = !ismult(a.r, md); +define res_sub(a,b) {local obj res v = {(a.r - b.r) % md}; return v;}; +define res_mul(a,b) {local obj res v = {(a.r * b.r) % md}; return v;}; +define res_neg(a) {local obj res v = {(-a.r) % md}; return v;}; +define res_inv(a) {local obj res v = {minv(a.r, md)}; return v;}; +define res(x) {local obj res v = {x % md}; return v;}; + +global lib_debug; +if (lib_debug >= 0) { + print "obj res defined"; + print "global md defined"; + print "res_test(a) defined"; + print "res_sub(a, b) defined"; + print "res_mul(a, b) defined"; + print "res_neg(a) defined"; + print "res_inv(a) defined"; + print "res(x) defined"; +} diff --git a/lib/test3300.cal b/lib/test3300.cal new file mode 100644 index 0000000..9078a27 --- /dev/null +++ b/lib/test3300.cal @@ -0,0 +1,134 @@ +/* + * Copyright (c) 1995 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 3300 series of the regress.cal test suite. + */ + +global defaultverbose = 1; /* default verbose value */ +global err; + +define testi(str, n, N, verbose) +{ + local A, t, i, j, d1, d2; + local m; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(N)) + N = 1e6; + mat A[n,n]; + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) + A[i,j] = rand(-N, N); + t = runtime(); + d1 = det(A); + t = runtime() - t; + d2 = det(A^2); + if (d2 != d1^2) { + if (verbose > 0) { + printf("*** Failure for n=%d, N=%d, d1=%d\n", n, N, d1); + } + return 1; /* error */ + } else { + if (verbose > 0) { + printf("no errors\n"); + } + if (verbose > 1) { + printf("ok: n=%d, N=%d, d1=%d, t=%d\n", n, N, d1, t); + } + } + return 0; /* ok */ +} + +define testr(str, n, N, verbose) +{ + local A, t, i, j, d1, d2; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(N)) + N = 1e6; + mat A[n,n]; + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) + A[i,j] = rand(-(N^2), N^2)/rand(1, N); + t = runtime(); + d1 = det(A); + t = runtime() - t; + d2 = det(A^2); + if (d2 != d1^2) { + if (verbose > 0) { + printf("*** Failure for n=%d, N=%d, d1=%d\n", n, N, d1); + } + return 1; /* error */ + } else { + if (verbose > 0) { + printf("no errors\n"); + } + if (verbose > 1) { + printf("ok: n=%d, N=%d, d1=%d, t=%d\n", n, N, d1, t); + } + } + return 0; /* ok */ +} + +/* + * test3300 - perform all of the above tests a bunch of times + */ +define test3300(verbose, tnum) +{ + local N; /* test parameter */ + local i; + + /* + * set test parameters + */ + if (isnull(verbose)) { + verbose = defaultverbose; + } + N = 1e6; + srand(3300e3300); + + /* + * test a lot of stuff + */ + for (i=0; i < 19; ++i) { + err += testi(strcat(str(tnum++), ": testi(", str(i), ")"), \ + i, N, verbose); + } + for (i=0; i < 9; ++i) { + err += testr(strcat(str(tnum++), ": testr(", str(i), ")"), \ + i, N, verbose); + } + + /* + * test results + */ + if (verbose > 1) { + if (err) { + print "***", err, "error(s) found in testall"; + } else { + print "no errors in testall"; + } + } + return tnum; +} + +global lib_debug; + +if (lib_debug >= 0) { + print "global defaultverbose defined"; + print "global err defined"; + print "testi(str, n, N, verbose) defined"; + print "testr(str, n, N, verbose) defined"; + print "test3300(verbose, tnum) defined"; +} diff --git a/lib/test3400.cal b/lib/test3400.cal new file mode 100644 index 0000000..233cf63 --- /dev/null +++ b/lib/test3400.cal @@ -0,0 +1,315 @@ +/* + * Copyright (c) 1996 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 3400 series of the regress.cal test suite. + */ +/* + * tests of performance of some trigonometric functions + * + * test3401 tests abs(acot(cot(x)) - x) <= eps for x = k * eps < pi + * test3402 tests abs(tan(x/2) - csc(x) + cot(x)) <= eps + * test3403 tests abs(tan(x) - cot(x) + 2 * cot(2 * x)) <= eps + * test3404 tests abs(cot(x/2) - csc(x) - cot(x)) <= eps + * test3405 tests atan(tan(x)) == x for x = k * eps, abs(x) <= pi/2 + * test3406 tests abs(sec(x) - sec(x + 2 * N * pi)) <= eps + * + * To run say, test1 n times give instruction test1(n, eps); eps + * defaults to epsilon(). + * + * Here pi1k is pi to 1000 decimal places; x is a random real number + * except when x is described as k * eps, in which case k is a random + * integer such that x is in the specified range. + * + * In the last test N is a large random integer, but it is assumed + * that eps is large compared with N * 1e-1000. + * + * I am surprised that test3406 seems to give no errors - I had expected + * that the two sides might differ by eps. [[test changed to test eps error]] + */ + +global defaultverbose = 1; /* default verbose value */ +global err; + +global pi1k = pi(1e-1000); + +define test3401(str, n, eps, verbose) +{ + local i, m, x, y, N; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(n)) n = 250; + if (isnull(eps)) eps = epsilon(); + + m = 0; + N = pi(eps)/eps; + for (i = 0; i < n; i++) { + x = rand(1, N) * eps; + y = cot(x, eps); + if (verbose > 1) + printf("%r\n", x); + if (abs(acot(y, eps) - x) > eps) { + if (verbose > 1) { + printf("*** Failure for x = %r\n", x); + } + m++; + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +define test3402(str, n, eps, verbose) +{ + local i, m, x, y, N; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(n)) n = 250; + if (isnull(eps)) eps = epsilon(); + + eps = abs(eps); + m = 0; + N = 1e10; + for (i = 0; i < n; i++) { + x = rand(-N, N)/rand(1, N); + y = tan(x/2, eps) - csc(x,eps) + cot(x,eps); + if (verbose > 1) + printf("%r\n", x); + if (abs(y) > eps) { + if (verbose > 1) { + printf("*** Failure for x = %r\n", x); + } + m++; + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +define test3403(str, n, eps, verbose) +{ + local i, m, x, y, N; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(n)) n = 250; + if (isnull(eps)) eps = epsilon(); + + eps = abs(eps); + m = 0; + N = 1e10; + for (i = 0; i < n; i++) { + x = rand(-N, N)/rand(1, N); + y = tan(x, eps) - cot(x,eps) + 2 * cot(2 * x,eps); + if (verbose > 1) + printf("%r\n", x); + if (abs(y) > eps) { + m++; + if (verbose > 1) { + printf("*** Failure for x = %r\n", x); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +define test3404(str, n, eps, verbose) +{ + local i, m, x, y, N; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(n)) n = 250; + if (isnull(eps)) eps = epsilon(); + + eps = abs(eps); + m = 0; + N = 1e10; + for (i = 0; i < n; i++) { + x = rand(-N, N)/rand(1, N); + y = cot(x/2, eps) - csc(x,eps) - cot(x,eps); + if (verbose > 1) + printf("%r\n", x); + if (abs(y) > eps) { + m++; + if (verbose > 1) { + printf("*** Failure for x = %r\n", x); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +define test3405(str, n, eps, verbose) +{ + local i, m, x, y, N; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(n)) n = 250; + if (isnull(eps)) eps = epsilon(); + + m = 0; + N = pi(eps)/eps; + N = quo(N, 2, 0); + for (i = 0; i < n; i++) { + x = rand(-N, N) * eps; + y = tan(x, eps); + if (verbose > 1) + printf("%r\n", x); + if (atan(y, eps) != x) { + m++; + if (verbose > 1) { + printf("*** Failure for x = %r\n", x); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +define test3406(str, n, eps, verbose) +{ + local i, m, x, y, z, N; + + if (isnull(verbose)) verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(n)) n = 250; + if (isnull(eps)) eps = epsilon(); + + m = 0; + for (i = 0; i < n; i++) { + x = rand(-1e10, 1e10)/rand(1, 1e10); + N = rand(-1e10, 1e10); + y = sec(x, eps); + z = sec(x + 2 * N * pi1k, eps); + if (verbose > 1) + printf("%r, %d\n", x, N); + if (abs(y-z) > eps) { + m++; + if (verbose > 1) { + printf("*** Failure for x = %r\n", x); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +/* + * test3400 - perform all of the above tests + */ +define test3400(verbose, tnum) +{ + local n; /* test parameter */ + local eps; /* test parameter */ + local i; + + /* + * set test parameters + */ + if (isnull(verbose)) { + verbose = defaultverbose; + } + n = 250; + eps = epsilon(); + srand(3400e3400); + + /* + * test a lot of stuff + */ + err += test3401(strcat(str(tnum++), \ + ": acot(cot(x))"), n, eps, verbose); + err += test3402(strcat(str(tnum++), \ + ": tan(x/2)-csc(x)+cot(x)"), n, eps, verbose); + err += test3403(strcat(str(tnum++), \ + ": tan(x)-cot(x)+2*cot(2*x)"), n, eps, verbose); + err += test3404(strcat(str(tnum++), \ + ": cot(x/2)-csc(x)-cot(x)"), n, eps, verbose); + err += test3405(strcat(str(tnum++), \ + ": atan(tan(x))"), n, eps, verbose); + err += test3406(strcat(str(tnum++), \ + ": sec(x)-sec(x+2*N*pi)"), n, eps, verbose); + + /* + * test results + */ + if (verbose > 1) { + if (err) { + print "***", err, "error(s) found in test3400"; + } else { + print "no errors in test3400"; + } + } + return tnum; +} + +global lib_debug; + +if (lib_debug >= 0) { + print "global defaultverbose defined"; + print "global err defined"; + print "test3401(str, n, eps, verbose) defined"; + print "test3402(str, n, eps, verbose) defined"; + print "test3403(str, n, eps, verbose) defined"; + print "test3404(str, n, eps, verbose) defined"; + print "test3405(str, n, eps, verbose) defined"; + print "test3406(str, n, eps, verbose) defined"; + print "test3400(verbose, tnum) defined"; +} diff --git a/lib/test3500.cal b/lib/test3500.cal new file mode 100644 index 0000000..65dcbcc --- /dev/null +++ b/lib/test3500.cal @@ -0,0 +1,286 @@ +/* + * Copyright (c) 1996 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 3500 series of the regress.cal test suite. + */ +/* + * Stringent tests of the functions frem, fcnt, gcdrem. + * + * testf(n) gives n tests of frem(x,y) and fcnt(x,y) with randomly + * integers x and y generated so that x = f * y^k where f, y and + * k are randomly generated. + * + * testg(n) gives n tests of gcdrem(x,y) with x and y generated as for + * testf(n). + * + * testh(n,N) gives n tests of g = gcdrem(x,y) where x and y are products of + * powers of small primes some of which are common to both x and y. + * This test uses f = abs(x) and iteratively f = frem(f,p) where + * p varies over the prime divisors of y; the final value for f + * should equal g. For both x and y the primes are raised to the + * power rand(N); N defaults to 10. + * + * If verbose is > 1, the numbers x, y and values for some of the + * functions will be displayed. Numbers used in testf() + * and testg() occasionally have thousands of digits. + * + */ + +global defaultverbose = 1; /* default verbose value */ +global err; + +define testfrem(x,y,verbose) +{ + local f, n; + + if (isnull(verbose)) verbose = defaultverbose; + + f = frem(x,y); + n = fcnt(x,y); + if (verbose > 1) + printf("frem = %d, fcnt = %d\n\n", f, n); + if (abs(x) != f * abs(y)^n) + return 1; + if (!ismult(x,y) || abs(y) <= 1) { + if (f != abs(x)) + return 2; + if (n != 0) + return 3; + return 0; + } + if (x == 0) { + if (f != 0 || n != 0) + return 4; + return 0; + } + if (f < 0 || !isint(f) || n <= 0) + return 5; + if (ismult(f, y)) + return 6; + if (!ismult(x, y^n)) + return 7; + if (ismult(x, y^(n+1))) + return 8; + return 0; +} + +define testgcdrem(x,y,verbose) +{ + local d, q; + + if (isnull(verbose)) verbose = defaultverbose; + + d = gcdrem(x,y); + if (verbose > 1) + printf("gcdrem = %d\n\n", d); + if (y == 0) { + if (d != 1) + return 1; + return 0; + } + if (x == 0) { + if (d != 0) + return 2; + return 0; + } + if (d <= 0) + return 3; + q = x/d; + if (!isint(q)) + return 4; + if (!isrel(d, y)) + return 5; + if (!isrel(d, q)) + return 6; + return 0; +} + +define testf(str,n,verbose) +{ + local m, x, y, i, k, y1, f1, f, fail; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + for (i = 0; i < n; i++) { + y1 = rand(2^rand(1,6)); + y = rand(-(2^y1), 1 + 2^y1); + f1 = rand(2^rand(1,11)); + f = rand(-(2^f1), 1+2^f1); + k = rand(1,1+2^10); + x = f * y^k; + if (verbose > 1) { + printf("x = %d\n", x); + printf("y = %d\n", y); + } + fail = testfrem(x,y,verbose); + if (fail != 0) { + printf("*** Failure %d on loop %d\n", fail, i); + if (verbose > 1) { + printf(" x = %d\n", x); + printf(" y = %d\n", y); + } + m++; + } + } + + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + + +define testg(str,n,verbose) +{ + local m, x, y, i, k, y1, f1, f, fail; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + for (i = 0; i < n; i++) { + y1 = rand(2^rand(1,6)); + y = rand(-(2^y1), 1 + 2^y1); + f1 = rand(2^rand(1,11)); + f = rand(-(2^f1), 1+2^f1); + k = rand(1,1+2^10); + x = f * y^k; + if (verbose > 1) { + printf("x = %d\n", x); + printf("y = %d\n", y); + } + fail = testgcdrem(x,y,verbose); + if (fail != 0) { + printf("*** Failure %d on loop %d\n", fail, i); + if (verbose > 1) { + printf(" x = %d\n", x); + printf(" y = %d\n", y); + } + m++; + } + } + + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +define testh(str,n,N,verbose) +{ + local m, i, x, y, f, g; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + if (isnull(N)) + N = 61; + for (i = 0; i < n; i ++) { + x = 2^rand(N)*3^rand(N) * 7^rand(N) * 11^rand(N) * 101^rand(N); + y = 2^rand(N) * 3^rand(N) * 5^rand(N) * 11^rand(N) * 53^rand(N); + if (rand(2)) x = -x; + if (rand(2)) y = -y; + + if (verbose > 1) { + printf("x = %d\n", x); + printf("y = %d\n", y); + } + f = abs(x); + g = gcdrem(x,y); + if (ismult(y,2)) f = frem(f,2); + if (ismult(y,3)) f = frem(f,3); + if (ismult(y,5)) f = frem(f,5); + if (ismult(y,11)) f = frem(f,11); + if (ismult(y,53)) f = frem(f,53); + + if (f != g) { + printf("*** Failure on loop %d\n", i); + if (verbose > 1) { + printf(" x = %d\n", x); + printf(" y = %d\n", y); + printf(" f = %d\n", f); + printf(" g = %d\n", g); + } + m++; + } + } + + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("no errors\n"); + } + } + return m; +} + +/* + * test3500 - perform all of the above tests a bunch of times + */ +define test3500(verbose, tnum, n, N) +{ + /* set test parameters */ + if (isnull(verbose)) { + verbose = defaultverbose; + } + if (isnull(tnum)) { + tnum = 3501; /* default test number */ + } + if (isnull(n)) { + n = 200; + } + if (isnull(N)) { + N = 61; + } + + /* + * test a lot of stuff + */ + srand(3500e3500); + err += testf(strcat(str(tnum++), ": frem/fcnt"), n, verbose); + err += testg(strcat(str(tnum++), ": gcdrem"), n, verbose); + err += testh(strcat(str(tnum++),": gcdrem #2"), n, N, verbose); + if (verbose > 1) { + if (err) { + print "***", err, "error(s) found in testall"; + } else { + print "no errors in testall"; + } + } + return tnum; +} + +global lib_debug; +if (lib_debug >= 0) { + print "global defaultverbose defined"; + print "global err defined"; + print "testfrem(x, y, verbose) defined"; + print "testgcdrem(x, y, verbose) defined"; + print "testf(str, n, verbose) defined"; + print "testg(str, n, verbose) defined"; + print "testh(str, n, N, verbose) defined"; + print "test3500(verbose, n, N) defined"; +} diff --git a/lib/test4000.cal b/lib/test4000.cal new file mode 100644 index 0000000..6bc452f --- /dev/null +++ b/lib/test4000.cal @@ -0,0 +1,485 @@ +/* + * Copyright (c) 1996 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 4000 series of the regress.cal test suite. + */ +/* + * Functions for testing and timing ptest, nextcand, prevcand. + * + * rlen(N) for N > 0 generates a random N-word positive integer. + * + * plen(N) for N > 0 generates an almost certainly prime positive + * integer whose word-count is about N. + * + * clen(N) for N > 0 generates a composite odd N-word integer. + * + * ptimes(str, N [, n [, count [, skip, [, verbose]]]]) + * tests, and finds the runtime, for + * ptest(x, count, skip) for n random almost certainly prime integers x + * with word-count about N; n defaults to ceil(K1/abs(count)/(H1 + N^3)), + * count to COUNT, skip to SKIP. + * + * ctimes(str, N [, n [, count [, skip, [, verbose]]]]) + * tests, and finds the runtime, for + * ptest(x, count, skip) for n random composite integers x with word-count + * about N; n defaults to ceil(K2/(H2 + N^3)), count to COUNT, skip + * to SKIP. + * + * crtimes(str,a,b,n, [,count [, skip, [, verbose]]]) + * tests, and finds the runtime, + * for ptest(x, count, skip) for n random integers x between a and b; + * count defaults to COUNT, skip to SKIP. + * + * ntimes (str, N [,n, [, count [, skip [, residue [, modulus[,verb]]]]]]) tests + * and finds the runtime for nextcand(...) and prevcand (...) for + * n integers x with word-count about N, etc. n defaults to + * ceil(K3/(H3 + N^3)); + * + * testnextcand(str, N [, n [, count [, skip [, residue [, modulus [, verb]]]]]) + * performs tests of nextcand(x, count, skip, residue, modulus) + * for n values of x with word-count N; n defaults to + * ceil(K3/(H3 + N^3)), count to COUNT, skip to SKIP, residue to 0, + * modulus to 1. + * + * testprevcand(str, N [, n [, count [, skip [, residue [, modulus [, verb]]]]]) + * performs tests of prevcand(x, count, skip, residue, modulus) + * for n values of x with word-count N; n defaults to + * ceil(K3/(H3 + N^3)), count to COUNT, skip to SKIP, residue to 0, + * modulus to 1. + */ + +global defaultverbose = 1; /* default verbose value */ +global err; + +/* + * test defaults + */ +global BASEB = 32; +global BASE = 2^BASEB; +global COUNT = 5; +global SKIP = 0; +global RESIDUE = 0; +global MODULUS = 1; + +/* + * internal test constants + */ +global K1 = 2^15; +global H1 = 40; +global K2 = 2^17; +global H2 = 40; +global K3 = 2^10; +global H3 = 10; + + +define rlen(N) +{ + + if (!isint(N) || N <= 0) + quit "Bad argument for rlen"; + return rand(BASE^(N-1), BASE^N); +} + +define plen(N) = nextcand(rlen(N), 10, 0); + +define clen(N) +{ + local n, v; + + do { + v = rlen(N); + if (iseven(v)) + v++; + } + while + (ptest(v, 10, 0)); + return v; +} + +define ptimes(str, N, n, count, skip, verbose) +{ + local A, i, t, p, m; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + if (isnull(count)) + count = COUNT; + if (isnull(n)) { + n = ceil(K1/abs(count)/(H1 + N^3)); + if (verbose > 1) { + print "n =",n; + } + } + if (isnull(skip)) + skip = SKIP; + mat A[n]; + for (i = 0; i < n; i++) + A[i] = plen(N); + t = runtime(); + for (i = 0; i < n; i++) { + p = ptest(A[i], count, skip); + if (!p) { + if (verbose > 0) { + printf("*** Error for x = %d\n", A[i]); + m++; + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + t = round(runtime() - t, 4); + if (verbose > 1) { + printf("%d probable primes: time = %d\n", n, t); + } else { + printf("%d probable primes: passed\n", n); + } + } + } + return m; +} + +define ctimes(str, N, n, count, skip, verbose) +{ + local A, i, r, t, p, m; + + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + if (isnull(count)) + count = COUNT; + if (isnull(n)) { + n = ceil(K2/(H2 + N^3)); + if (verbose > 1) { + print "n =",n; + } + } + if (isnull(skip)) + skip = SKIP; + mat A[n]; + for (i = 0; i < n; i++) + A[i] = clen(N); + t = runtime(); + for (i = 0; i < n; i++) { + p = ptest(A[i], count, skip); + if (p) { + if (verbose > 0) { + printf("*** Error, what should be rare has occurred for x = %d \n", A[i]); + m++; + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + t = round(runtime() - t, 4); + if (verbose > 1) { + printf("%d probable primes: time = %d\n", n, t); + } else { + printf("%d probable primes: passed\n", n); + } + } + } + return m; +} + +define crtimes(str, a, b, n, count, skip, verbose) +{ + local A, P, i, t, p, m; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + if (b < a) + swap(a,b); + b++; + if (isnull(count)) + count = COUNT; + if (isnull(skip)) + skip = SKIP; + mat A[n]; + mat P[n]; + for (i = 0; i < n; i++) { + A[i] = rand(a,b); + P[i] = ptest(A[i], 20, 0); + } + t = runtime(); + for (i = 0; i < n; i++) { + p = ptest(A[i], count, skip); + if (p != P[i]) { + if (verbose > 0) { + printf("*** Apparent error for %s x = %d\n", + P[i] ? "prime" : "composite", A[i]); + ++m; + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)?\n", m); + } else { + t = round(runtime() - t, 4); + if (verbose > 1) { + printf("%d probable primes: time = %d\n", n, t); + } else { + printf("%d probable primes: passed\n", n); + } + } + } + return m; +} + +define ntimes(str, N, n, count, skip, residue, modulus, verbose) +{ + local A, i, t, p, tnext, tprev; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + if (isnull(count)) + count = COUNT; + if (isnull(n)) { + n = ceil(K3/(H3 + N^3)); + if (verbose > 1) { + print "n =",n; + } + } + if (isnull(skip)) + skip = SKIP; + if (isnull(residue)) + residue = RESIDUE; + if (isnull(modulus)) + modulus = MODULUS; + + mat A[n]; + for (i = 0; i < n; i++) + A[i] = rlen(N); + t = runtime(); + for (i = 0; i < n; i++) { + p = nextcand(A[i], count, skip, residue, modulus); + } + tnext = round(runtime() - t, 4); + t = runtime(); + for (i = 0; i < n; i++) { + p = prevcand(A[i], count, skip, residue, modulus); + } + tprev = round(runtime() - t, 4); + if (verbose > 0) { + printf("%d evaluations, nextcand: %d, prevcand: %d\n", n, tnext, tprev); + } +} + +define testnextcand(str, N, n, count, skip, residue, modulus, verbose) +{ + local p, x, y, i, m; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + if (isnull(count)) + count = COUNT; + if (isnull(n)) { + n = ceil(K3/(H3 + N^3)); + print "n =",n; + } + if (isnull(skip)) + skip = SKIP; + if (isnull(residue)) + residue = RESIDUE; + if (isnull(modulus)) + modulus = MODULUS; + for (i = 0; i < n; i++) { + x = rlen(N); + y = nextcand(x, count, skip, residue, modulus); + p = testnext1(x, y, count, skip, residue, modulus); + if (p) { + m++; + if (verbose > 1) { + printf("*** Failure %d for x = %d\n", p, x); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)?\n", m); + } else { + printf("%d successful tests\n", n); + } + } + return m; +} + +define testnext1(x, y, count, skip, residue, modulus) +{ + if (y <= x) + return 1; + if (!ptest(y, count, skip)) + return 2; + if (mne(y, residue, modulus)) + return 3; + return 0; +} + +define testprevcand(str, N, n, count, skip, residue, modulus, verbose) +{ + local p, x, y, i, m; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + if (isnull(count)) + count = COUNT; + if (isnull(n)) { + n = ceil(K3/(H3 + N^3)); + print "n =",n; + } + if (isnull(skip)) + skip = SKIP; + if (isnull(residue)) + residue = RESIDUE; + if (isnull(modulus)) + modulus = MODULUS; + for (i = 0; i < n; i++) { + x = rlen(N); + y = prevcand(x, count, skip, residue, modulus); + p = testprev1(x, y, count, skip, residue, modulus); + if (p) { + m++; + if (verbose > 1) { + printf("*** Failure %d for x = %d\n", p, x); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)?\n", m); + } else { + printf("%d successful tests\n", n); + } + } + return m; +} + + +define testprev1(x, y, count, skip, residue, modulus) +{ + if (y >= x) + return 1; + if (!ptest(y, count, skip)) + return 2; + if (mne(y, residue, modulus)) + return 3; + return 0; +} + +/* + * test4000 - perform all of the above tests a bunch of times + */ +define test4000(v, tnum) +{ + local n; /* test parameter */ + + /* + * set test parameters + */ + srand(4000e4000); + + /* + * test a lot of stuff + */ + err += ptimes(strcat(str(tnum++),": ptimes(1,250)"), 1, 250,,,v); + err += ptimes(strcat(str(tnum++),": ptimes(3,50)"), 3, 50,,,v); + err += ptimes(strcat(str(tnum++),": ptimes(5,20)"), 5, 20,,,v); + + err += ctimes(strcat(str(tnum++),": ctimes(1,7500)"), 1, 7500,,,v); + err += ctimes(strcat(str(tnum++),": ctimes(3,500)"), 3, 500,,,v); + err += ctimes(strcat(str(tnum++),": ctimes(5,200)"), 5, 200,,,v); + + err += crtimes(strcat(str(tnum++),": crtimes(2^30,2^31,2500)"), + 2^30, 2^31, 2500,,,v); + err += crtimes(strcat(str(tnum++),": crtimes(2^300,2^301,75)"), + 2^300, 2^301, 75,,,v); + + err += testprevcand(strcat(str(tnum++),": testprevcand(1,250)"), + 1, 250, ,,,,v); + err += testprevcand(strcat(str(tnum++),": testprevcand(3,25)"), + 3, 25, ,,,,v); + err += testprevcand(strcat(str(tnum++),": testprevcand(5,10)"), + 5, 10, ,,,,v); + + err += testnextcand(strcat(str(tnum++),": testnextcand(1,250)"), + 1, 250, ,,,,v); + err += testnextcand(strcat(str(tnum++),": testnextcand(3,25)"), + 3, 25, ,,,,v); + err += testnextcand(strcat(str(tnum++),": testnextcand(5,10)"), + 5, 10, ,,,,v); + + /* + * report results + */ + if (v > 1) { + if (err) { + print "***", err, "error(s) found in testall"; + } else { + print "no errors in testall"; + } + } + return tnum; +} + + +global lib_debug; + +if (lib_debug >= 0) { + print "global defaultverbose"; + print "global err"; + print "global BASEB"; + print "global BASE"; + print "global COUNT"; + print "global SKIP"; + print "global RESIDUE"; + print "global MODULUS"; + print "global K1"; + print "global H1"; + print "global K2"; + print "global H2"; + print "global K3"; + print "global H3"; + print "plen(N) defined"; + print "clen(N) defined"; + print "ptimes(str, N, n, count, skip, verbose) defined"; + print "ctimes(str, N, n, count, skip, verbose) defined"; + print "crtimes(str, a, b, n, count, skip, verbose) defined"; + print "ntimes(str, N, n, count, skip, residue, mod, verbose) defined"; + print "testnextcand(str, N, n, cnt, skip, res, mod, verbose) defined"; + print "testnext1(x, y, count, skip, residue, modulus) defined";; + print "testprevcand(str, N, n, cnt, skip, res, mod, verbose) defined"; + print "testprev1(x, y, count, skip, residue, modulus) defined"; + print "test4000(verbose, tnum) defined"; +} diff --git a/lib/test4100.cal b/lib/test4100.cal new file mode 100644 index 0000000..a855ccb --- /dev/null +++ b/lib/test4100.cal @@ -0,0 +1,493 @@ +/* + * Copyright (c) 1996 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 4100 series of the regress.cal test suite. + */ +/* + * Some severe tests and timing functions for REDC functions and pmod. + * + * testall(str,n,N,M,verbose) + * performs n tests using arguments x, y, ... + * randomly selected from [-N, N) or when nonnegative values are + * required, [0, N), and m an odd positive integer in [1,N], + * and where a "small" (say less than 10000) exponent k is to be + * used (when computing x^k % m directly) k is random in [0,M). + * Default values for N and M are 1e20 and 100. + * + * times(str,N,n,verbose) + * gives times for n evaluations of rcin, etc. with + * N-word arguments; default n is ceil(K1/power(N,1.585). + * + * powtimes(str, N1,N2,n, verbose) + * gives times for n evaluations of pmod(x,k,m) + * for the three algorithms "small", "normal", "bignum" that + * pmod may use, and equivalent functions rcpow(xr,k,m) for + * "small" or "bignum" cases, where xr = rcin(x,m). The + * modulus m is a random positive odd N1-word number; x has + * random integer values in [0, m-1]; k has random N2-word values. + * N2 defaults to 1; n defaults to ceil(K2/power(N1,1.585)/N2). + * + * inittimes(str, N, n, verbose) + * displays the times and tests n evaluations of rcin(x,m) + * and rcout(x,m) where m is a random positive odd N-word integer, + * x is a random integer in [0, m-1]; n defaults to ceil(K1/N^2). + * + * rlen_4100(N) + * generates a random positive N-word integer. The global + * BASEB should be set to the word-size for the computer being + * used. The parameters K1, K2 which control the default n + * should be adjusted to give reasonable runtimes. + * + * olen(N) + * generates a random odd positive N-word number. + * + */ + +global defaultverbose = 1; /* default verbose value */ +global err; + +/* + * test defaults + */ +global K1 = 2^17; +global K2 = 2^12; +global BASEB = 16; +global BASE = 2^BASEB; + +define rlen_4100(N) = rand(BASE^(N-1), BASE^N); + +define olen(N) +{ + local v; + + v = rlen_4100(N); + if (iseven(v)) + v++; + return v; +} + +define test4101(x,y,m,k,z1,z2,verbose) +{ + local xr, yr, v, w, oneone; + + if (isnull(verbose)) + verbose = defaultverbose; + xr = rcin(x,m); + yr = rcin(y,m); + oneone = rcin(rcin(1,m),m); + + if (xr >= m || xr < 0) { + if (verbose > 1) + printf("Failure 1 for x = %d, m = %d\n", x, m); + return 1; + } + if (rcin(x * y, m) != mod(xr * y, m, 0)) { + if (verbose > 1) { + printf("Failure 2 for x = %d, y = %d, m = %d\n", + x, y, m); + } + return 2; + } + if (rcout(xr, m) != x % m) { + if (verbose > 1) + printf("Failure 3 for x = %d, m = %d\n", x, m); + return 3; + } + if (rcout(rcmul(xr,yr,m),m) != mod(x * y, m, 0)) { + if (verbose > 1) + printf("Failure 4 for x = %d, y = %d, m = %d\n", + x, y, m); + return 4; + } + if (rcmul(x,yr,m) != mod(x * y, m, 0)) { + if (verbose > 1) + printf("Failure 5 for x = %d, y = %d, m = %d\n", + x, y, m); + return 5; + } + if (rcin(rcmul(x,y,m),m) != mod(x * y, m, 0)) { + if (verbose > 1) + printf("Failure 6 for x = %d, y = %d, m = %d\n", + x, y, m); + return 6; + } + if (rcout(rcsq(xr,m),m) != mod(x^2, m, 0)) { + if (verbose > 1) + printf("Failure 7 for x = %d, m = %d\n", x, m); + return 7; + } + if (rcin(rcsq(x,m),m) != mod(x^2, m, 0)) { + if (verbose > 1) + printf("Failure 8 for x = %d, m = %d\n", + x, y, m); + return 8; + } + if (rcout(rcpow(xr,k,m),m) != mod(x^k, m, 0)) { + if (verbose > 1) + printf("Failure 9 for x = %d, m = %d, k = %d\n", + x, m, k); + return 9; + } + if (rcpow(x,k,m) != rcin(rcout(x,m)^k, m)) { + if (verbose > 1) + printf("Failure 10: x = %d, k = %d, m = %d\n", + x, k, m); + return 10; + } + if (rcpow(x, z1 * z2, m) != rcpow(rcpow(x,z1,m), z2, m)) { + if (verbose > 1) + printf("Failure 11: x = %d, z1 = %d, z2 = %d, m = %d\n", + x, z1, z2, m); + return 11; + } + if (xr != rcmul(oneone, x, m)) { + if (verbose > 1) + printf("Failure 12: x = %d, m = %d\n", x, m); + return 12; + } + + return 0; +} + +define testall(str,n,N,M,verbose) +{ + local i, p, x, y, z1, z2, c, k, m; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + if (isnull(N)) + N = 1e20; + if (isnull(M)) + M = 100; + c = 0; + for (i = 0; i < n; i++) { + x = rand(-N, N); + y = rand(-N, N); + z1 = rand(N); + z2 = rand(N); + c = rand(N); + if (iseven(c)) + c++; + k = rand(M); + if (verbose > 1) + printf("x = %d, y = %d, c = %d, k = %d\n", x, y, c, k); + p = test4101(x,y,c,k,z1,z2); + if (p) { + m++; + if (verbose > 0) { + printf("*** Failure %d in test %d\n", p, i); + } + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("passed %d tests\n", n); + } + } + return m; +} + +define times(str,N,n,verbose) +{ + local m, m2, A, B, C, x, y, t, i, z; + local trcin, trcout, trcmul, trcsq; + local tmul, tsq, tmod, tquomod; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = olen(N); + m2 = m^2; + if (isnull(n)) { + n = ceil(K1/power(N,1.585)); + if (verbose > 1) + printf("n = %d\n", n); + } + mat A[n]; + mat B[n]; + mat C[n]; + for (i = 0; i < n; i++) { + A[i] = rand(m); + B[i] = rand(m); + C[i] = rand(m2); + } + z = rcin(0,m); /* to initialize redc and maybe lastmod information */ + t = runtime(); + for (i = 0; i < n; i++) + z = rcin(A[i],m); + trcin = round(runtime() - t, 3); + t = runtime(); + for (i = 0; i < n; i++) + z = rcout(A[i],m); + trcout = round(runtime() - t, 3); + t = runtime(); + for (i = 0; i < n; i++) + z = rcmul(A[i],B[i],m); + trcmul = round(runtime() - t, 3); + t = runtime(); + for (i = 0; i < n; i++) + z = rcsq(A[i],m); + trcsq = round(runtime() - t, 3); + t = runtime(); + for (i = 0; i < n; i++) + z = A[i] * B[i]; + tmul = round(runtime() - t, 3); + t = runtime(); + for (i = 0; i < n; i++) + z = A[i]^2; + tsq = round(runtime() - t, 3); + t = runtime(); + for (i = 0; i < n; i++) + z = C[i] % A[i]; + tmod = round(runtime() - t, 3); + t = runtime(); + for (i = 0; i < n; i++) + quomod(C[i], A[i], x, y); + tquomod = round(runtime() - t,3); + + if (verbose > 1) { + printf("rcin: %d, rcout: %d, rcmul: %d, rcsq: %d\n", + trcin, trcout, trcmul, trcsq); + printf("%s: mul: %d, sq: %d, mod: %d, quomod: %d\n", + str, tmul, tsq, tmod, tquomod); + } else if (verbose > 0) { + printf("no error(s)\n"); + } + return 0; +} + + +define powtimes(str, N1, N2, n, verbose) +{ + local A, Ar, B, v, i, t, z1, z2, z3, z4, z5, cp, crc; + local tsmall, tnormal, tbignum, trcsmall, trcbig, m; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + + if (isnull(N2)) + N2 = 1; + + if (isnull(n)) { + n = ceil(K2/power(N1, 1.585)/N2); + printf ("n = %d\n", n); + } + mat A[n]; + mat Ar[n]; + mat B[n]; + v = olen(N1); + + cp = config("pow2", 1); + crc = config("redc2", 1); + + /* initialize redc and lastmod info */ + + z1 = z2 = z3 = z4 = z5 = rcin(0,v); + + for (i = 0; i < n; i++) { + A[i] = rand(v); + Ar[i] = rcin(A[i], v); + B[i] = rlen_4100(N2); + } + t = runtime(); + for (i = 0; i < n; i++) + z1 += pmod(A[i], B[i], v); + tbignum = round(runtime() - t, 4); + config("pow2", 1e6); + t = runtime(); + for (i = 0; i < n; i++) + z2 += pmod(A[i], B[i], v); + tnormal = round(runtime() - t, 4); + config("redc2",1e6); + t = runtime(); + for (i = 0; i < n; i++) + z3 += pmod(A[i], B[i], v); + tsmall = round(runtime() - t, 4); + t = runtime(); + for (i = 0; i < n; i++) + z4 += rcpow(Ar[i], B[i], v); + trcsmall = round(runtime() - t, 4); + config("redc2", 1); + t = runtime(); + for (i = 0; i < n; i++) + z5 += rcpow(Ar[i], B[i], v); + trcbig = round(runtime() - t, 4); + + if (z1 != z2) { + ++m; + if (verbose > 0) { + print "*** z1 != z2"; + } + } else if (z1 != z3) { + ++m; + if (verbose > 0) { + print "*** z1 != z3"; + } + } else if (z2 != z3) { + ++m; + if (verbose > 0) { + print "*** z2 != z3"; + } + } else if (rcout(z4, v) != z1 % v) { + ++m; + if (verbose > 0) { + print "*** z4 != z1"; + } + } else if (z4 != z5) { + ++m; + if (verbose > 0) { + print "*** z4 != z5"; + } + } + config("pow2", cp); + config("redc2", crc); + if (verbose > 1) { + } + if (verbose > 1) { + printf("Small: %d, normal: %d, bignum: %d\n", + tsmall, tnormal, tbignum); + printf("%s: rcsmall: %d, rcbig: %d\n", + str, trcsmall, trcbig); + } else if (verbose > 0) { + if (m) { + printf("*** %d error(s)\n", m); + } else { + printf("passed\n"); + } + } + return 0; +} + +define inittimes(str,N,n,verbose) +{ + local A, M, B, R, i, t, trcin, trcout, m; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + m = 0; + if (isnull(n)) { + n = ceil(K1/N^2); + if (verbose > 1) { + printf ("n = %d\n", n); + } + } + mat A[n]; + mat M[n]; + mat B[n]; + mat R[n]; + for (i = 0; i < n; i++) { + M[i] = olen(N); + A[i] = rand(M[i]); + } + t = runtime(); + for (i = 0; i < n; i++) + R[i] = rcin(A[i], M[i]); + trcin = round(runtime() - t, 4); + for (i = 0; i < n; i++) + B[i] = rcout(R[i], M[i]); + trcout = round(runtime() - t, 4); + for (i = 0; i < n; i++) { + if (B[i] != A[i]) { + ++m; + if (verbose > 0) { + print "*** Error!!!"; + } + break; + } + } + if (verbose > 0) { + if (m) { + printf("*** %d error(s)?\n", m); + } else { + if (verbose > 1) { + printf("%d successful tests: rcin: %d, rcout: %d\n", + n, trcin, trcout); + } else { + printf("%d successful tests: passed\n", n); + } + } + } + return m; +} + +/* + * test4100 - perform all of the above tests a bunch of times + */ +define test4100(v, tnum) +{ + local n; /* test parameter */ + + /* + * set test parameters + */ + srand(4100e4100); + + /* + * test a lot of stuff + */ + err += testall(strcat(str(tnum++),": testall(10,,500)"), 10,, 500, v); + err += testall(strcat(str(tnum++),": testall(200)"), 200,,, v); + + err += times(strcat(str(tnum++),": times(3,3000)"), 3, 3000, v); + err += times(strcat(str(tnum++),": times(30,300)"), 30, 300, v); + err += times(strcat(str(tnum++),": times(300,30)"), 300, 30, v); + err += times(strcat(str(tnum++),": times(1000,3)"), 1000, 3, v); + + err += powtimes(strcat(str(tnum++),": powtimes(100)"),100,,v); + err += powtimes(strcat(str(tnum++),": powtimes(250)"),250,,v); + + err += inittimes(strcat(str(tnum++),": inittimes(10)"),10,,v); + err += inittimes(strcat(str(tnum++),": inittimes(100,70)"),100,70,v); + err += inittimes(strcat(str(tnum++),": inittimes(1000,4)"),1000,4,v); + + /* + * report results + */ + if (v > 1) { + if (err) { + print "***", err, "error(s) found in testall"; + } else { + print "no errors in testall"; + } + } + return tnum; +} + +global lib_debug; + +if (lib_debug >= 0) { + print "global defaultverbose"; + print "global err"; + print "global K1"; + print "global K2"; + print "global BASEB"; + print "global BASE"; + print "rlen_4100(N) defined"; + print "olen(N) defined"; + print "test4101(x, y, m, k, z1, z2) defined"; + print "testall(str, n, N, M, verbose) defined"; + print "times(str, N, n, verbose) defined"; + print "powtimes(str, N1, N2, n, verbose) defined"; + print "inittimes(str, N, n, verbose) defined"; + print "test4100(verbose, tnum) defined"; +} diff --git a/lib/test4600.cal b/lib/test4600.cal new file mode 100644 index 0000000..1af31c9 --- /dev/null +++ b/lib/test4600.cal @@ -0,0 +1,311 @@ +/* + * Copyright (c) 1996 Ernest Bowen and Landon Curt Noll + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * By: Ernest Bowen and Landon Curt Noll + * ernie@neumann.une.edu.au and chongo@toad.com + * + * This library is used by the 4600 series of the regress.cal test suite. + */ + + +global defaultverbose = 1 /* default verbose value */ +global err; + +/* + * test globals + */ +global A, f, pos; + +define stest(str, verbose) +{ + local x; + + /* setup */ + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + x = rm("junk4600"); + + /* + * do file operations + */ + f = fopen("junk4600", "w"); + if (iserror(f)) { + print 'failed'; + print '**** fopen("junk4600", "w") failed'; + return 1; + } + if (iserror(fputs(f, + "Fourscore and seven years ago our fathers brought forth\n", + "on this continent a new nation, conceived in liberty and dedicated\n", + "to the proposition that all men are created equal.\n"))) { + print 'failed'; + print '**** fputs(f, "Fourscore ... failed'; + return 1; + } + if (iserror(freopen(f, "r"))) { + print 'failed'; + print '**** iserror(freopen(f, "r")) failed'; + return 1; + } + if (iserror(rewind(f))) { + print 'failed'; + print '**** iserror(rewind(f)) failed'; + return 1; + } + if (search(f, "and") != 10) { + print 'failed'; + print '**** search(f, "and") != 10 failed'; + return 1; + } + if (ftell(f) != 13) { + print 'failed'; + print '**** ftell(f) != 13 failed'; + return 1; + } + if (search(f, "and") != 109) { + print 'failed'; + print '**** search(f, "and") != 109 failed'; + return 1; + } + if (ftell(f) != 112) { + print 'failed'; + print '**** ftell(f) != 112 failed'; + return 1; + } + if (!isnull(search(f, "and"))) { + print 'failed'; + print '**** !isnull(search(f, "and")) failed'; + return 1; + } + if (ftell(f) != 172) { + print 'failed'; + print '**** ftell(f) != 172 failed'; + return 1; + } + if (rsearch(f, "and") != 109) { + print 'failed'; + print '**** rsearch(f, "and") != 109 failed'; + return 1; + } + if (ftell(f) != 112) { + print 'failed'; + print '**** ftell(f) != 112 failed'; + return 1; + } + if (iserror(fseek(f, -1, 1))) { + print 'failed'; + print '**** iserror(fseek(f, -1, 1)) failed'; + return 1; + } + if (rsearch(f, "and") != 10) { + print 'failed'; + print '**** rsearch(f, "and") != 10 failed'; + return 1; + } + if (ftell(f) != 13) { + print 'failed'; + print '**** ftell(f) != 13 failed'; + return 1; + } + if (iserror(fseek(f, -1, 1))) { + print 'failed'; + print '**** iserror(fseek(f, -1, 1)) failed'; + return 1; + } + if (!isnull(rsearch(f, "and"))) { + print 'failed'; + print '**** !isnull(rsearch(f, "and")) failed'; + return 1; + } + if (ftell(f) != 0) { + print 'failed'; + print '**** ftell(f) != 0 failed'; + return 1; + } + if (iserror(fclose(f))) { + print 'failed'; + print '**** iserror(fclose(f)) failed'; + return 1; + } + + /* + * cleanup + */ + x = rm("junk4600"); + if (verbose > 0) { + printf("passed\n"); + } + return 0; +} + +define ttest(str, m, n, verbose) +{ + local a, s, i, j; + + if (isnull(verbose)) + verbose = defaultverbose; + if (verbose > 0) { + print str:":",:; + } + i = rm("junk4600"); + f = fopen("junk4600", "w"); + + if (isnull(n)) + n = 4; + if (isnull(m)) + m = 4; + + mat A[m]; + mat pos[m + 1]; + + pos[0] = 0; + for (i = 0; i < m; i++) { + j = 1 + randbit(n); + a = ""; + while (j-- > 0) + a = strcat(a, char(rand(1, 256))); + A[i] = a; + fputs(f, a); + pos[i+1] = ftell(f); + if (verbose > 1) + printf("A[%d] has length %d\n", i, strlen(a)); + } + if (verbose > 1) + printf("File has size %d\n", pos[i]); + freopen(f, "r"); + if (size(f) != pos[i]) { + print 'failed'; + printf("**** Failure 1 for file size\n"); + return 1; + } + for (i = 0; i < m; i++) { + rewind(f); + for (;;) { + j = search(f, A[i]); + if (isnull(j) || j > pos[i]) { + print 'failed'; + printf("**** Failure 2 for i = %d\n", i); + return 1; + } + if (j == pos[i]) + break; + fseek(f, j + 1, 0); + + } + if (ftell(f) != pos[i + 1]) { + print 'failed'; + printf("**** Failure 3 for i = %d\n", i); + return 1; + } + } + for (i = m - 1; i >= 0; i--) { + fseek(f, 0, 2); + for (;;) { + j = rsearch(f, A[i]); + if (isnull(j) || j < pos[i]) { + print 'failed'; + printf("**** Failure 4 for i = %d\n", i); + return 1; + } + if (j == pos[i]) + break; + fseek(f, -1, 1); + } + if (ftell(f) != pos[i + 1]) { + print 'failed'; + printf("**** Failure 5 for i = %d\n", i); + return 1; + } + } + i = rm("junk4600"); + if (verbose > 0) { + printf("passed\n"); + } + return 0; +} + +define sprint(x) +{ + local i, n; + + n = strlen(x); + for (i = 1; i <= n; i++) print ord(substr(x, i, 1)),; + print; +} + +define findline(f,s) +{ + + if (!isfile(f)) + quit "First argument to be a file"; + if (!isstr(s)) + quit "Second argument to be a string"; + if (!isnull(search(f,s))) { + rsearch(f, "\n"); + print fgetline(f); + } +} + +define findlineold(f,s) +{ + local str; + + if (!isfile(f)) + quit "First argument to be a file"; + if (!isstr(s)) + quit "Second argument to be a string"; + + while (!isnull(str = fgetline(f)) && strpos(str, s) == 0); + print str; +} + +/* + * test4600 - perform all of the above tests a bunch of times + */ +define test4600(v, tnum) +{ + local n; /* test parameter */ + local i; + + /* + * set test parameters + */ + srand(4600e4600); + + /* + * test a lot of stuff + */ + for (i=0; i < 10; ++i) { + err += ttest(strcat(str(tnum++), + ": ttest(",str(i),",",str(i),")"), i, i, v); + err += stest(strcat(str(tnum++), ": stest()"), v); + } + + /* + * report results + */ + if (v > 1) { + if (err) { + print "****", err, "error(s) found in testall"; + } else { + print "no errors in testall"; + } + } + return tnum; +} + +global lib_debug; + +if (lib_debug >= 0) { + print "stest(str [, verbose]) defined"; + print "ttest([m, [n [,verbose]]]) defined"; + print "sprint(x) defined"; + print "findline(f,s) defined"; + print "findlineold(f,s) defined"; + print "test4600(verbose, tnum) defined"; +} diff --git a/lib/unitfrac.cal b/lib/unitfrac.cal new file mode 100644 index 0000000..f98d2a5 --- /dev/null +++ b/lib/unitfrac.cal @@ -0,0 +1,35 @@ +/* + * Copyright (c) 1995 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/lib/varargs.cal b/lib/varargs.cal new file mode 100644 index 0000000..52d27e4 --- /dev/null +++ b/lib/varargs.cal @@ -0,0 +1,29 @@ +/* + * Copyright (c) 1995 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/lib_calc.c b/lib_calc.c new file mode 100644 index 0000000..d5a5ae0 --- /dev/null +++ b/lib_calc.c @@ -0,0 +1,68 @@ +/* + * Copyright (c) 1996 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 "calc.h" +#include "zmath.h" + +static int init_done = 0; /* 1 => we already initialized */ + + +/* + * libcalc_call_me_first - users of libcalc.a must call this function + */ +void +libcalc_call_me_first(void) +{ + /* + * do nothing if we are initialized already + */ + if (init_done) { + return; + } + + /* + * setup configuration values + */ + oldstd.epsilon = &_qonesqbase_; /* magic to fake early str2q() */ + conf = config_copy(&oldstd); /* more magic to fake early str2q() */ + oldstd.epsilon = str2q(EPSILON_DEFAULT); + newstd.epsilon = str2q(NEW_EPSILON_DEFAULT); + + /* + * make oldstd our default config + */ + conf = config_copy(&oldstd); + + /* + * ZVALUE io initialization + */ + zio_init(); + + /* + * ready to rock & roll .. + */ + init_done = 1; + return; +} diff --git a/lint.sed b/lint.sed new file mode 100644 index 0000000..35eb60e --- /dev/null +++ b/lint.sed @@ -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/listfunc.c b/listfunc.c new file mode 100644 index 0000000..5c1f2ce --- /dev/null +++ b/listfunc.c @@ -0,0 +1,829 @@ +/* + * 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" +#include "zrand.h" + +extern long irand(long s); + +static LISTELEM *elemalloc(void); +static LISTELEM *listelement(LIST *lp, long index); +static void elemfree(LISTELEM *ep); +static void removelistelement(LIST *lp, LISTELEM *ep); + + +/* + * Insert an element before the first element of a list. + * + * given: + * lp list to put element onto + * vp value to be inserted + */ +void +insertlistfirst(LIST *lp, VALUE *vp) +{ + 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. + * + * given: + * lp list to put element onto + * vp value to be inserted + */ +void +insertlistlast(LIST *lp, VALUE *vp) +{ + 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. + * + * given: + * lp list to put element onto + * index element number to insert in front of + * vp value to be inserted + */ +void +insertlistmiddle(LIST *lp, long index, VALUE *vp) +{ + 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"); + /*NOTREACHED*/ + } + 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. + * + * given: + * lp list to have element removed + * vp location of the value + */ +void +removelistfirst(LIST *lp, VALUE *vp) +{ + 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. + * + * given: + * lp list to have element removed + * vp location of the value + */ +void +removelistlast(LIST *lp, VALUE *vp) +{ + 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. + * + * given: + * lp list to have element removed + * index list element to be removed + * vp location of the value + */ +void +removelistmiddle(LIST *lp, long index, VALUE *vp) +{ + 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"); + /*NOTREACHED*/ + } + *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. + * + * given: + * lp list header + * ep list element to remove + */ +static void +removelistelement(LIST *lp, LISTELEM *ep) +{ + 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(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(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. + * + * given: + * lp list to index into + * index index of desired element + */ +VALUE * +listfindex(LIST *lp, long index) +{ + 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. + * + * given: + * lp list to index into + * index index of desired element + */ +static LISTELEM * +listelement(LIST *lp, long index) +{ + 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(LIST *lp1, LIST *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(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; +} + + +/* + * Round elements of a list to a specified number of decimal digits + */ +LIST * +listround(LIST *oldlp, VALUE *v2, VALUE *v3) +{ + LIST *lp; + LISTELEM *oldep, *ep, *eq; + + lp = listalloc(); + oldep = oldlp->l_first; + lp->l_count = oldlp->l_count; + if (oldep) { + ep = elemalloc(); + lp->l_first = ep; + for (;;) { + roundvalue(&oldep->e_value, v2, v3, &ep->e_value); + oldep = oldep->e_next; + if (!oldep) + break; + eq = elemalloc(); + ep->e_next = eq; + eq->e_prev = ep; + ep = eq; + } + lp->l_last = ep; + } + return lp; +} + + +/* + * Round elements of a list to a specified number of binary digits + */ +LIST * +listbround(LIST *oldlp, VALUE *v2, VALUE *v3) +{ + LIST *lp; + LISTELEM *oldep, *ep, *eq; + + lp = listalloc(); + oldep = oldlp->l_first; + lp->l_count = oldlp->l_count; + if (oldep) { + ep = elemalloc(); + lp->l_first = ep; + for (;;) { + broundvalue(&oldep->e_value, v2, v3, &ep->e_value); + oldep = oldep->e_next; + if (!oldep) + break; + eq = elemalloc(); + ep->e_next = eq; + eq->e_prev = ep; + ep = eq; + } + lp->l_last = ep; + } + return lp; +} + + +/* + * Approximate a list by approximating elements by multiples of v2, + * type of rounding determined by v3. + */ +LIST * +listappr(LIST *oldlp, VALUE *v2, VALUE *v3) +{ + LIST *lp; + LISTELEM *oldep, *ep, *eq; + + lp = listalloc(); + oldep = oldlp->l_first; + lp->l_count = oldlp->l_count; + if (oldep) { + ep = elemalloc(); + lp->l_first = ep; + for (;;) { + apprvalue(&oldep->e_value, v2, v3, &ep->e_value); + oldep = oldep->e_next; + if (!oldep) + break; + eq = elemalloc(); + ep->e_next = eq; + eq->e_prev = ep; + ep = eq; + } + lp->l_last = ep; + } + return lp; +} + + +/* + * Construct a list whose elements are integer quotients of the elements + * of a specified list by a specified number. + */ +LIST * +listquo(LIST *oldlp, VALUE *v2, VALUE *v3) +{ + LIST *lp; + LISTELEM *oldep, *ep, *eq; + + lp = listalloc(); + oldep = oldlp->l_first; + lp->l_count = oldlp->l_count; + if (oldep) { + ep = elemalloc(); + lp->l_first = ep; + for (;;) { + quovalue(&oldep->e_value, v2, v3, &ep->e_value); + oldep = oldep->e_next; + if (!oldep) + break; + eq = elemalloc(); + ep->e_next = eq; + eq->e_prev = ep; + ep = eq; + } + lp->l_last = ep; + } + return lp; +} + + +/* + * Construct a list whose elements are the remainders after integral + * division of the elements of a specified list by a specified number. + */ +LIST * +listmod(LIST *oldlp, VALUE *v2, VALUE *v3) +{ + LIST *lp; + LISTELEM *oldep, *ep, *eq; + + lp = listalloc(); + oldep = oldlp->l_first; + lp->l_count = oldlp->l_count; + if (oldep) { + ep = elemalloc(); + lp->l_first = ep; + for (;;) { + modvalue(&oldep->e_value, v2, v3, &ep->e_value); + oldep = oldep->e_next; + if (!oldep) + break; + eq = elemalloc(); + ep->e_next = eq; + eq->e_prev = ep; + ep = eq; + } + lp->l_last = ep; + } + return lp; +} + + +void +listreverse(LIST *lp) +{ + LISTELEM *e1, *e2; + VALUE tmp; + long s; + + s = lp->l_count/2; + e1 = lp->l_first; + e2 = lp->l_last; + lp->l_cache = NULL; + while (s-- > 0) { + tmp = e1->e_value; + e1->e_value = e2->e_value; + e2->e_value = tmp; + e1 = e1->e_next; + e2 = e2->e_prev; + } +} + + + +void +listsort(LIST *lp) +{ + LISTELEM *start; + LISTELEM *last, *a, *a1, *b, *next; + LISTELEM *S[32]; + long len[32]; + long i, j, k; + + if (lp->l_count < 2) + return; + lp->l_cache = NULL; + start = elemalloc(); + next = lp->l_first; + last = start; + start->e_next = next; + for (k = 0; next; k++) { + next->e_prev = last; + last = next; + S[k] = next; + next = next->e_next; + len[k] = 1; + while (k > 0 && (!next || len[k] >= len[k - 1])) {/* merging */ + j = len[k]; + b = S[k--]; + i = len[k]; + a = S[k]; + a1 = b->e_prev; + len[k] = i + j; + if (precvalue(&b->e_value, &a->e_value)) { + S[k] = b; + a->e_prev->e_next = b; + b->e_prev = a->e_prev; + j--; + while (j > 0) { + b = b->e_next; + if (!precvalue(&b->e_value, + &a->e_value)) + break; + j--; + } + if (j == 0) { + b->e_next = a; + a->e_prev = b; + last = a1; + continue; + } + b->e_prev->e_next = a; + a->e_prev = b->e_prev; + } + + do { + i--; + while (i > 0) { + a = a->e_next; + if (precvalue(&b->e_value, + &a->e_value)) + break; + i--; + } + if (i == 0) + break; + a->e_prev->e_next = b; + b->e_prev = a->e_prev; + j--; + while (j > 0) { + b = b->e_next; + if (!precvalue(&b->e_value, + &a->e_value)) + break; + j--; + } + if (j != 0) { + b->e_prev->e_next = a; + a->e_prev = b->e_prev; + } + } while (j != 0); + + if (i == 0) { + a->e_next = b; + b->e_prev = a; + } else if (j == 0) { + b->e_next = a; + a->e_prev = b; + last = a1; + } + } + } + lp->l_first = start->e_next; + lp->l_first->e_prev = NULL; + lp->l_last = last; + lp->l_last->e_next = NULL; + elemfree(start); +} + +void +listrandperm(LIST *lp) +{ + LISTELEM *ep, *eq; + long i, s; + VALUE val; + + s = lp->l_count; + for (ep = lp->l_last; s > 1; ep = ep->e_prev) { + i = irand(s--); + if (i < s) { + eq = listelement(lp, i); + val = eq->e_value; + eq->e_value = ep->e_value; + ep->e_value = val; + } + } +} + + + +/* + * Allocate an element for a list. + */ +static LISTELEM * +elemalloc(void) +{ + LISTELEM *ep; + + ep = (LISTELEM *) malloc(sizeof(LISTELEM)); + if (ep == NULL) { + math_error("Cannot allocate list element"); + /*NOTREACHED*/ + } + 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(LISTELEM *ep) +{ + if (ep->e_value.v_type != V_NULL) + freevalue(&ep->e_value); + free(ep); +} + + +/* + * Allocate a new list header. + */ +LIST * +listalloc(void) +{ + register LIST *lp; + + lp = (LIST *) malloc(sizeof(LIST)); + if (lp == NULL) { + math_error("Cannot allocate list header"); + /*NOTREACHED*/ + } + 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(LIST *lp) +{ + register LISTELEM *ep; + + while (lp->l_count-- > 0) { + ep = lp->l_first; + lp->l_first = ep->e_next; + elemfree(ep); + } + free(lp); +} + + +/* + * Print out a list along with the specified number of its elements. + * The elements are printed out in shortened form. + */ +void +listprint(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("\t[[%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"); +} + +/* END CODE */ diff --git a/longbits.c b/longbits.c new file mode 100644 index 0000000..c6b3dc2 --- /dev/null +++ b/longbits.c @@ -0,0 +1,238 @@ +/* + * longbits - Determine the number if bits in a char, short, int or long + * + * usage: + * longbits + * + * 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. + * + * This prog outputs several defines and typedefs: + * + * LONG_BITS + * Numbre of bits in a long. Not all (in fact very few) C + * pre-processors can do #if sizeof(long) == 8. + * + * USB8 unsigned 8 bit value + * SB8 signed 8 bit value + * + * USB16 unsigned 16 bit value + * SB16 signed 16 bit value + * + * USB32 unsigned 32 bit value + * SB32 signed 32 bit value + * + * HAVE_B64 + * defined ==> ok to use USB64 (unsigned 64 bit value) + * and SB64 (signed 64 bit value) + * undefined ==> do not use USB64 nor SB64 + * + * USB64 unsigned 64 bit value if HAVE_B64 is defined + * SB64 signed 64 bit value if HAVE_B64 is defined + * + * L(x) form a 33 to 64 bit signed constant + * U(x) form a 33 to 64 bit unsigned constant + * + * We will also note if we have a standard 64 bit type (i.e., long). If we + * do, we will typedef it and define HAVE_B64. If we do not then if longlong.h + * says we can use long long types, we will use that. If we cannot use a + * long long type, then HAVE_B64 will not be defined. + * + * We hide the comments within strings to avoid complaints from some snitty + * compilers. We also hide 3 X's which is the calc symbol for "something bogus + * this way comes". In such error cases, we add -=*#*=- to force a syntax + * error in the resulting .h file. + * + * We will exit 0 if all is well, non-zero with an error to stderr otherwise. + */ +/* + * Copyright (c) 1995 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 + +#include "have_unistd.h" +#if defined(HAVE_UNISTD_H) +#include +#endif + +#include "longlong.h" + +char *program; /* our name */ + +MAIN +main(int argc, char **argv) +{ + int exitcode = 0; /* how we will exit */ + char value; /* signed or maybe unsigned character */ + + /* + * parse args + */ + program = argv[0]; + if (argc != 1) { + fprintf(stderr, "usage: %s\n", program); + exit(1); + } + + /* + * report size of long + */ + printf("#undef LONG_BITS\n"); + printf("#define LONG_BITS %d\t\t%c%s%c\n", + (int)(sizeof(long)*8), '/', "* bit length of a long *", '/'); + putchar('\n'); + + /* + * look for 8 bit values + */ + value = (char)-1; + if (sizeof(char) != 1) { + fprintf(stderr, + "%s: OUCH!!! - char is not a single byte!\n", program); + fprintf(stderr, + "%s: fix the USB8 typedef by hand\n", program); + printf("typedef unsigned char USB8;\t%c* XX%s%c -=*#*=-\n", + '/', "X - should be 8 unsigned bits but is not *", '/'); + if (value < 1) { + printf("typedef char SB8;\t%c* XX%s%c -=*#*=-\n", + '/', "X - should be 8 signed bits but is not *", '/'); + } else { + printf("typedef signed char SB8;\t%c* XX%s%c -=*#*=-\n", + '/', "X - should be 8 signed bits but is not *", '/'); + } + exitcode = 2; + } else { + printf("typedef unsigned char USB8;\t%c%s%c\n", + '/', "* unsigned 8 bits *", '/'); + if (value < 1) { + printf("typedef char SB8;\t%c%s%c\n", + '/', "* signed 8 bits *", '/'); + } else { + printf("typedef signed char SB8;\t%c%s%c\n", + '/', "* signed 8 bits *", '/'); + } + } + putchar('\n'); + + /* + * look for 16 bit values + */ + if (sizeof(short) != 2) { + fprintf(stderr, + "%s: OUCH!!! - short is not a 2 bytes!\n", program); + fprintf(stderr, + "%s: fix the USB16 typedef by hand\n", program); + printf("typedef unsigned short USB16;\t%c* XX%s%c -=*#*=-\n", + '/', "X - should be 16 unsigned bits but is not *", '/'); + printf("typedef signed char SB16;\t%c* XX%s%c -=*#*=-\n", + '/', "X - should be 16 signed bits but is not *", '/'); + exitcode = 3; + } else { + printf("typedef unsigned short USB16;\t%c%s%c\n", + '/', "* unsigned 16 bits *", '/'); + printf("typedef short SB16;\t\t%c%s%c\n", + '/', "* signed 16 bits *", '/'); + } + putchar('\n'); + + /* + * look for 32 bit values + */ + if (sizeof(long) == 4) { + printf("typedef unsigned long USB32;\t%c%s%c\n", + '/', "* unsigned 32 bits *", '/'); + printf("typedef long SB32;\t\t%c%s%c\n", + '/', "* signed 32 bits *", '/'); + } else if (sizeof(int) == 4) { + printf("typedef unsigned int USB32;\t%c%s%c\n", + '/', "* unsigned 32 bits *", '/'); + printf("typedef int SB32;\t\t%c%s%c\n", + '/', "* signed 32 bits *", '/'); + } else { + fprintf(stderr, + "%s: OUCH!!! - neither int nor long are 4 bytes!\n", program); + printf("typedef unsigned int USB32;\t%c* XX%s%c -=*#*=-\n", + '/', "X - should be 32 unsigned bits but is not *", '/'); + printf("typedef signed int SB32;\t%c* XX%s%c -=*#*=-\n", + '/', "X - should be 32 signed bits but is not *", '/'); + exitcode = 4; + } + putchar('\n'); + + /* + * look for 64 bit values + */ + if (sizeof(long) == 8) { + printf("#undef HAVE_B64\n"); + printf("#define HAVE_B64\t\t%c%s%c\n", + '/', "* have USB64 and SB64 types *", '/'); + printf("typedef unsigned long USB64;\t%c%s%c\n", + '/', "* unsigned 64 bits *", '/'); + printf("typedef long SB64;\t\t%c%s%c\n", + '/', "* signed 64 bits *", '/'); + putchar('\n'); + printf("%c%s%c\n", '/',"* how to form 64 bit constants *",'/'); +#if defined(__STDC__) && __STDC__ != 0 + printf("#define U(x) x ## UL\n"); + printf("#define L(x) x ## L\n"); +#else + printf("#define U(x) ((unsigned long)x)\n"); + printf("#define L(x) ((long)x)\n"); +#endif + } else { +#if defined(HAVE_LONGLONG) && LONGLONG_BITS == 64 + printf("#undef HAVE_B64\n"); + printf("#define HAVE_B64\t\t%c%s%c\n", + '/', "* have USB64 and SB64 types *", '/'); + printf("typedef unsigned long long USB64;\t%c%s%c\n", + '/', "* unsigned 64 bits *", '/'); + printf("typedef long long SB64;\t\t%c%s%c\n", + '/', "* signed 64 bits *", '/'); + putchar('\n'); + printf("%c%s%c\n", '/',"* how to form 64 bit constants *",'/'); +#if defined(__STDC__) && __STDC__ != 0 + printf("#define U(x) x ## ULL\n"); + printf("#define L(x) x ## LL\n"); +#else + printf("#define U(x) ((unsigned long long)x)\n"); + printf("#define L(x) ((long long)x)\n"); +#endif +#else + printf("#undef HAVE_B64\t\t\t%c%s%c\n", + '/', "* we have no USB64 and no SB64 types *", '/'); + putchar('\n'); + printf("%c%s%c\n", '/', "* no 64 bit constants *", '/'); + printf("#define U(x) no 33 to 64 bit constants %s\n", + "- do not use this macro!"); + printf("#define L(x) no 33 to 64 bit constants %s\n", + "- do not use this macro!"); +#endif + } + + /* all done */ + exit(exitcode); +} diff --git a/longlong.c b/longlong.c new file mode 100644 index 0000000..98522eb --- /dev/null +++ b/longlong.c @@ -0,0 +1,104 @@ +/* + * longlong - Determine the number if bits in a long long, if is exists + * + * usage: + * longlong [bits] + * + * bits if empty or missing causes this prog to compute its length, + * if 0, this prog will output nothing + * otherwise this prog will assume it is the long long bit length + * + * Not all compilers support the long long type, so this may not compile + * on your system. + * + * This prog outputs several defines: + * + * HAVE_LONGLONG + * defined ==> ok to use long long + * undefined ==> do not use long long, even if they exist + * + * LONGLONG_BITS + * 0 ==> do not use long long, even if they exist + * != 0 ==> bits in an unsigned long long + */ +/* + * Copyright (c) 1995 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 + +#include "have_stdlib.h" +#ifdef HAVE_STDLIB_H +# include +#endif + +#include "have_string.h" +#if defined(HAVE_STRING_H) +#include +#endif + + +/* + * have the compiler try its hand with unsigned and signed long longs + */ +unsigned long long val = 4294967297ULL; +long long val2 = -4294967297LL; + + +MAIN +main(int argc, char **argv) +{ + int longlong_bits; /* bits in a long long, or <=0 => dont use */ + + /* + * parse args + */ + if (argc < 2) { + /* no arg means compute the length */ + longlong_bits = sizeof(unsigned long long)*8; + } else if (strcmp(argv[1], "") == 0) { + /* empty arg means compute the length */ + longlong_bits = sizeof(unsigned long long)*8; + } else { + longlong_bits = atoi(argv[1]); + } + + /* + * length is preset, or 0 ==> do not use + */ + if (longlong_bits > 0) { + + /* + * if size is longer than an unsigned long, use it + */ + if (longlong_bits > sizeof(unsigned long)*8) { + + /* use long long length */ + printf("#define HAVE_LONGLONG\n"); + printf("#define LONGLONG_BITS %d /* yes */\n", + longlong_bits); + } + } + exit(0); +} diff --git a/matfunc.c b/matfunc.c new file mode 100644 index 0000000..ac70919 --- /dev/null +++ b/matfunc.c @@ -0,0 +1,1583 @@ +/* + * Copyright (c) 1995 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" +#include "zrand.h" + +extern long irand(long s); + +static void matswaprow(MATRIX *m, long r1, long r2); +static void matsubrow(MATRIX *m, long oprow, long baserow, VALUE *mulval); +static void matmulrow(MATRIX *m, long row, VALUE *mulval); +static MATRIX *matident(MATRIX *m); + + + +/* + * Add two compatible matrices. + */ +MATRIX * +matadd(MATRIX *m1, MATRIX *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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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(MATRIX *m1, MATRIX *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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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(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(MATRIX *m1, MATRIX *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"); + /*NOTREACHED*/ + } + if ((m1->m_max[1] - m1->m_min[1]) != (m2->m_max[0] - m2->m_min[0])) { + math_error("Incompatible bounds for matrix mul"); + /*NOTREACHED*/ + } + 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_type = V_NULL; + 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(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"); + /*NOTREACHED*/ + } + if ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1])) { + math_error("Squaring non-square matrix"); + /*NOTREACHED*/ + } + 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_type = V_NULL; + 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. + * + * given: + * m matrix to be raised + * q power to raise it to + */ +MATRIX * +matpowi(MATRIX *m, NUMBER *q) +{ + MATRIX *res, *tmp; + long power; /* power to raise to */ + FULL bit; /* current bit value */ + + if (m->m_dim != 2) { + math_error("Matrix dimension must be two for power"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + if (qisfrac(q)) { + math_error("Raising matrix to non-integral power"); + /*NOTREACHED*/ + } + if (zge31b(q->num)) { + math_error("Raising matrix to very large power"); + /*NOTREACHED*/ + } + power = ztolong(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(MATRIX *m1, MATRIX *m2) +{ + MATRIX *res; + VALUE *v1, *v2, *vr; + VALUE tmp1, tmp2; + + 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(MATRIX *m1, MATRIX *m2) +{ + VALUE *v1, *v2; + VALUE result, tmp1, tmp2; + long len; + + 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. + * + * given: + * m matrix to be scaled + * n scale factor + */ +MATRIX * +matscale(MATRIX *m, 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. + * + * given: + * m matrix to be shifted + * n shift count + */ +MATRIX * +matshift(MATRIX *m, 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. + * + * given: + * m matrix to be multiplied + * vp value to multiply by + */ +MATRIX * +matmulval(MATRIX *m, VALUE *vp) +{ + 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. + * + * given: + * m matrix to be divided + * vp value to divide by + * v3 rounding type parameter + */ +MATRIX * +matquoval(MATRIX *m, VALUE *vp, VALUE *v3) +{ + register VALUE *val, *vres; + long index; + MATRIX *res; + + if ((vp->v_type == V_NUM) && qiszero(vp->v_num)) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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, v3, vres++); + return res; +} + + +/* + * Divide the elements of a matrix by a specified value, keeping + * only the remainder of the division. + * + * given: + * m matrix to be divided + * vp value to divide by + * v3 rounding type parameter + */ +MATRIX * +matmodval(MATRIX *m, VALUE *vp, VALUE *v3) +{ + register VALUE *val, *vres; + long index; + MATRIX *res; + + if ((vp->v_type == V_NUM) && qiszero(vp->v_num)) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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, v3, vres++); + return res; +} + + +/* + * Transpose a 2-dimensional matrix + */ +MATRIX * +mattrans(MATRIX *m) +{ + register VALUE *v1, *v2; /* current values */ + long rows, cols; /* rows and columns in new matrix */ + long row, col; /* current row and column */ + MATRIX *res; + + 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(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; +} + + +/* + * Round elements of a matrix to specified number of decimal digits + */ +MATRIX * +matround(MATRIX *m, VALUE *v2, VALUE *v3) +{ + VALUE *p, *q; + long s; + MATRIX *res; + + s = m->m_size; + res = matalloc(s); + *res = *m; + p = m->m_table; + q = res->m_table; + while (s-- > 0) + roundvalue(p++, v2, v3, q++); + return res; +} + + +/* + * Round elements of a matrix to specified number of binary digits + */ +MATRIX * +matbround(MATRIX *m, VALUE *v2, VALUE *v3) +{ + VALUE *p, *q; + long s; + MATRIX *res; + + s = m->m_size; + res = matalloc(s); + *res = *m; + p = m->m_table; + q = res->m_table; + while (s-- > 0) + broundvalue(p++, v2, v3, q++); + return res; +} + +/* + * Approximate a matrix by approximating elemenbs to be multiples of + * v2, rounding type determined by v3. + */ +MATRIX * +matappr(MATRIX *m, VALUE *v2, VALUE *v3) +{ + VALUE *p, *q; + long s; + MATRIX *res; + + s = m->m_size; + res = matalloc(s); + *res = *m; + p = m->m_table; + q = res->m_table; + while (s-- > 0) + apprvalue(p++, v2, v3, q++); + return res; +} + + + + +/* + * Produce a matrix with values all of which have been truncated to integers. + */ +MATRIX * +matint(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(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. + * + * given: + * mp matrix to operate on + * create TRUE => create if element does not exist + * dim dimension of the indexing + * indices table of values being indexed by + */ +/*ARGSUSED*/ +VALUE * +matindex(MATRIX *mp, BOOL create, long dim, VALUE *indices) +{ + NUMBER *q; /* index value */ + VALUE *vp; + long index; /* index value as an integer */ + long offset; /* current offset into array */ + int i; /* loop counter */ + + if (dim <= 0) { + math_error("Bad dimension %ld for matrix", dim); + /*NOTREACHED*/ + } + for (;;) { + if (dim < mp->m_dim) { + math_error("Indexing a %ldd matrix as a %ldd matrix", mp->m_dim, dim); + /*NOTREACHED*/ + } + offset = 0; + for (i = 0; i < mp->m_dim; i++) { + if (indices->v_type != V_NUM) { + math_error("Non-numeric index for matrix"); + /*NOTREACHED*/ + } + q = indices->v_num; + if (qisfrac(q)) { + math_error("Non-integral index for matrix"); + /*NOTREACHED*/ + } + index = qtoi(q); + if (zge31b(q->num) || (index < mp->m_min[i]) || (index > mp->m_max[i])) { + math_error("Index out of bounds for matrix"); + /*NOTREACHED*/ + } + offset *= (mp->m_max[i] - mp->m_min[i] + 1); + offset += (index - mp->m_min[i]); + indices++; + } + vp = mp->m_table + offset; + dim -= mp->m_dim; + if (dim == 0) + break; + if (vp->v_type != V_MAT) { + math_error("Non-matrix argument for matindex"); + /*NOTREACHED*/ + } + mp = vp->v_mat; + } + return vp; +} + + +/* + * 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(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(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 w-dimensional 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. + * + * given: + * m matrix to be filled + * v1 value to fill most of matrix with + * v2 value for diagonal entries or null + */ +void +matfill(MATRIX *m, VALUE *v1, VALUE *v2) +{ + register VALUE *val; + VALUE temp1, temp2; + long rows, cols; + long i, j; + + copyvalue(v1, &temp1); + + val = m->m_table; + if (m->m_dim != 2 || v2 == NULL) { + for (i = m->m_size; i > 0; i--) { + freevalue(val); + copyvalue(&temp1, val++); + } + freevalue(&temp1); + return; + } + + copyvalue(v2, &temp2); + rows = m->m_max[0] - m->m_min[0] + 1; + cols = m->m_max[1] - m->m_min[1] + 1; + + for (i = 0; i < rows; i++) { + for (j = 0; j < cols; j++) { + freevalue(val); + if (i == j) + copyvalue(&temp2, val++); + else + copyvalue(&temp1, val++); + } + } + freevalue(&temp1); + freevalue(&temp2); +} + + + +/* + * Set a copy of a square matrix to the identity matrix. + */ +static MATRIX * +matident(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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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(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"); + /*NOTREACHED*/ + } + if ((m->m_max[0] - m->m_min[0]) != (m->m_max[1] - m->m_min[1])) { + math_error("Inverting non-square matrix"); + /*NOTREACHED*/ + } + /* + * 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"); + /*NOTREACHED*/ + } + 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 #26 - storing bad pointer in val */ + /* ok to ignore on name matinv`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); + } + val += (rows + 1); + } + matfree(m); + return res; +} + + +/* + * Calculate the determinant of a square matrix. + * This uses the fraction-free Gauss-Bareiss algorithm. + */ +VALUE +matdet(MATRIX *m) +{ + long n; /* original matrix is n x n */ + long k; /* working submatrix is k x k */ + long i, j; + VALUE *pivot, *div, *val; + VALUE *vp, *vv; + VALUE tmp1, tmp2, tmp3; + BOOL neg; /* whether to negate 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 = FALSE; + m = matcopy(m); + n = (m->m_max[0] - m->m_min[0] + 1); + pivot = div = m->m_table; + for (k = n; k > 0; k--) { + /* + * Find the first nonzero value in the rest of the column + * downwards from pivot. If there is no such value, then + * the determinant is zero. If the first nonzero entry is not + * the pivot, then swap rows in the k * k submatrix, and + * remember that the determinant changes sign. + */ + val = pivot; + i = k; + while (!testvalue(val)) { + if (--i <= 0) { + tmp1.v_type = V_NUM; + tmp1.v_num = qlink(&_qzero_); + return tmp1; + } + val += n; + } + if (i < k) { + vp = pivot; + vv = val; + j = k; + while (j-- > 0) { + tmp1 = *vp; + *vp++ = *vv; + *vv++ = tmp1; + } + neg = !neg; + } + /* + * Now for every val below the pivot, for each entry to + * the right of val, calculate the 2 x 2 determinant + * with corners at the pivot and the entry. If + * k < n, divide by div (the previous pivot value). + */ + val = pivot; + i = k; + while (--i > 0) { + val += n; + vp = pivot; + vv = val; + j = k; + while (--j > 0) { + mulvalue(pivot, ++vv, &tmp1); + mulvalue(val, ++vp, &tmp2); + subvalue(&tmp1, &tmp2, &tmp3); + freevalue(&tmp1); + freevalue(&tmp2); + freevalue(vv); + if (k < n) { + divvalue(&tmp3, div, vv); + freevalue(&tmp3); + } + else + *vv = tmp3; + } + } + div = pivot; + pivot += n + 1; + } + if (neg) + negvalue(div, &tmp1); + else + copyvalue(div, &tmp1); + matfree(m); + return tmp1; +} + + +/* + * 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(MATRIX *m, long r1, long 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(MATRIX *m, long oprow, long 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(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(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; +} + + +/* + * Make a matrix the same size as another and filled with a fixed value. + * + * given: + * m matrix to initialize + * v1 value to fill most of matrix with + * v2 value for diagonal entries (or NULL) + */ +MATRIX * +matinit(MATRIX *m, VALUE *v1, VALUE *v2) +{ + MATRIX *res; + register VALUE *v; + register long i; + long row; + long rows; + + /* + * clone matrix size + */ + res = matalloc(m->m_size); + *res = *m; + + /* + * firewall + */ + if (v2 && ((res->m_dim != 2) || + ((res->m_max[0] - res->m_min[0]) != + (res->m_max[1] - res->m_min[1])))) { + math_error("Filling diagonals of non-square matrix"); + /*NOTREACHED*/ + } + + /* + * fill the bulk of the matrix + */ + v = res->m_table; + if (v2 == NULL) { + i = m->m_size; + while (i-- > 0) { + copyvalue(v1, v++); + } + return res; + } + + /* + * fill the diaginal of a square matrix if requested + */ + rows = res->m_max[0] - res->m_min[0] + 1; + v = res->m_table; + for (row = 0; row < rows; row++) { + copyvalue(v2, v+row); + v += rows; + } + return res; +} + + +/* + * Allocate a matrix with the specified number of elements. + */ +MATRIX * +matalloc(long size) +{ + MATRIX *m; + + m = (MATRIX *) malloc(matsize(size)); + if (m == NULL) { + math_error("Cannot get memory to allocate matrix of size %d", size); + /*NOTREACHED*/ + } + m->m_size = size; + return m; +} + + +/* + * Free a matrix, along with all of its element values. + */ +void +matfree(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(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; +} + +/* + * Sum the numeric values in a matrix. + */ +void +matsum(MATRIX *m, VALUE *vres) +{ + VALUE *vp; + VALUE tmp; /* first sum value */ + VALUE sum; /* second sum value */ + long i; + + /* + * sum setup + */ + vp = m->m_table; + i = m->m_size; + sum.v_type = V_NUM; + sum.v_subtype = V_NOSUBTYPE; + sum.v_num = qlink(&_qzero_); + + /* + * sum values + */ + while (i-- > 0) { + /* tmp = sum */ + copyvalue(&sum, &tmp); + freevalue(&sum); + + /* add next matrix value */ + (void) addnumeric(vp++, &tmp, &sum); + } + + /* + * return sum + */ + copyvalue(&sum, vres); + freevalue(&sum); +} + + +/* + * 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(MATRIX *m1, MATRIX *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; +} + + +void +matreverse(MATRIX *m) +{ + VALUE *p, *q; + VALUE tmp; + + p = m->m_table; + q = m->m_table + m->m_size - 1; + while (q > p) { + tmp = *p; + *p++ = *q; + *q-- = tmp; + } +} + + +void +matsort(MATRIX *m) +{ + VALUE *a, *b, *next, *end; + VALUE *buf, *p; + VALUE *S[32]; + long len[32]; + long i, j, k; + + buf = (VALUE *) malloc(m->m_size * sizeof(VALUE)); + if (buf == NULL) { + math_error("Not enough memory for matsort"); + /*NOTREACHED*/ + } + next = m->m_table; + end = next + m->m_size; + for (k = 0; next; k++) { + S[k] = next++; /* S[k] is start of a run */ + len[k] = 1; + if (next == end) + next = NULL; + while (k > 0 && (!next || len[k] >= len[k - 1])) {/* merging */ + j = len[k]; + b = S[k--]; + i = len[k]; + a = S[k]; + len[k] += j; + p = buf; + if (precvalue(b, a)) { + do { + *p++ = *b++; + j--; + } while (j > 0 && precvalue(b,a)); + if (j == 0) { + memcpy(p, a, i * sizeof(VALUE)); + memcpy(S[k], buf, + len[k] * sizeof(VALUE)); + continue; + } + } + + do { + do { + *p++ = *a++; + i--; + } while (i > 0 && !precvalue(b,a)); + if (i == 0) { + break; + } + do { + *p++ = *b++; + j--; + } while (j > 0 && precvalue(b,a)); + } while (j != 0); + + if (i == 0) { + memcpy(S[k], buf, (p - buf) * sizeof(VALUE)); + } else if (j == 0) { + memcpy(p, a, i * sizeof(VALUE)); + memcpy(S[k], buf, len[k] * sizeof(VALUE)); + } + } + } + free(buf); +} + +void +matrandperm(MATRIX *m) +{ + VALUE *vp; + long s, i; + VALUE val; + + s = m->m_size; + for (vp = m->m_table; s > 1; vp++, s--) { + i = irand(s); + if (i > 0) { + val = *vp; + *vp = vp[i]; + vp[i] = val; + } + } +} + + +/* + * Test whether or not a matrix is the identity matrix. + * Returns TRUE if so. + */ +BOOL +matisident(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 = m->m_min[0]; row <= m->m_max[0]; row++) { + /* + * We could use col = m->m_min[1]; col < m->m_max[1] + * but if m->m_min[0] != m->m_min[1] this won't work. + * We know that we have a square 2-dimensional matrix + * so we will pretend that m->m_min[0] == m->m_min[1]. + */ + for (col = m->m_min[0]; col <= m->m_max[0]; 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; +} + + +/* + * 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(MATRIX *m, long max_print) +{ + VALUE *vp; + long fullsize, count, index, num; + long 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/math_error.c b/math_error.c new file mode 100644 index 0000000..e6db8a5 --- /dev/null +++ b/math_error.c @@ -0,0 +1,104 @@ +/* + * math_error - a simple libcalc math error routine + */ +/* + * Copyright (c) 1995 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 /\../\ + */ +/* + * Your 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. + * + * By default, this routine simply prints a message to stderr and then exits. + * + * If one sets up calc_jmp_buf, and then sets calc_jmp to non-zero then + * this routine will longjmp back (with the value of calc_jmp) instead. + * In addition, the last calc error message will be found in calc_error; + * this error is not printed to sttderr. + * + * For example: + * + * #include + * + * extern jmp_buf calc_jmp_buf; + * extern int calc_jmp; + * extern char *calc_error; + * int error; + * + * ... + * + * if ((error = setjmp(calc_jmp_buf)) != 0) { + * printf("Ouch: %s\n", calc_error); + * } + * calc_jmp = 1; + */ + +#include +#include +#include "args.h" +#include "calc.h" + +/* + * error jump point we will longjmp to this jmp_buf if calc_jmp is non-zero + */ +jmp_buf calc_jmp_buf; +int calc_jmp = 0; /* non-zero => use calc_jmp_buf */ +char calc_error[MAXERROR+1]; /* last calc error message */ + + +/* + * math_error - print a math error and exit + */ +void +math_error(char *fmt, ...) +{ + va_list ap; + + /* + * format the error + */ +#ifdef VARARGS + va_start(ap); +#else + va_start(ap, fmt); +#endif + vsprintf(calc_error, fmt, ap); + va_end(ap); + + /* + * if we should longjmp, so do + */ + if (calc_jmp != 0) { + longjmp(calc_jmp_buf, calc_jmp); + } + + /* + * print error message and edit + */ + (void) fflush(stdout); + (void) fflush(stderr); + fprintf(stderr, "%s\n", calc_error); + fputc('\n', stderr); + exit(1); +} diff --git a/obj.c b/obj.c new file mode 100644 index 0000000..6b27909 --- /dev/null +++ b/obj.c @@ -0,0 +1,689 @@ +/* + * Copyright (c) 1995 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 ERR_NONE 0 /* no special action */ +#define ERR_PRINT 1 /* print element */ +#define ERR_CMP 2 /* compare two values */ +#define ERR_TEST 3 /* test value for nonzero */ +#define ERR_POW 4 /* call generic power routine */ +#define ERR_ONE 5 /* return number 1 */ +#define ERR_INC 6 /* increment by one */ +#define ERR_DEC 7 /* decrement by one */ +#define ERR_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, ERR_PRINT, "print", "print value, default prints elements"}, + {1, A_VALUE, ERR_ONE, "one", "multiplicative identity, default is 1"}, + {1, A_INT, ERR_TEST, "test", "logical test (false,true => 0,1), default tests elements"}, + {2, A_VALUE, ERR_NONE, "add", NULL}, + {2, A_VALUE, ERR_NONE, "sub", NULL}, + {1, A_VALUE, ERR_NONE, "neg", "negative"}, + {2, A_VALUE, ERR_NONE, "mul", NULL}, + {2, A_VALUE, ERR_NONE, "div", "non-integral division"}, + {1, A_VALUE, ERR_NONE, "inv", "multiplicative inverse"}, + {2, A_VALUE, ERR_NONE, "abs", "absolute value within given error"}, + {1, A_VALUE, ERR_NONE, "norm", "square of absolute value"}, + {1, A_VALUE, ERR_NONE, "conj", "conjugate"}, + {2, A_VALUE, ERR_POW, "pow", "integer power, default does multiply, square, inverse"}, + {1, A_VALUE, ERR_NONE, "sgn", "sign of value (-1, 0, 1)"}, + {2, A_INT, ERR_CMP, "cmp", "equality (equal,nonequal => 0,1), default tests elements"}, + {2, A_VALUE, ERR_NONE, "rel", "relative order, positive for >, etc."}, + {3, A_VALUE, ERR_NONE, "quo", "integer quotient"}, + {3, A_VALUE, ERR_NONE, "mod", "remainder of division"}, + {1, A_VALUE, ERR_NONE, "int", "integer part"}, + {1, A_VALUE, ERR_NONE, "frac", "fractional part"}, + {1, A_VALUE, ERR_INC, "inc", "increment, default adds 1"}, + {1, A_VALUE, ERR_DEC, "dec", "decrement, default subtracts 1"}, + {1, A_VALUE, ERR_SQUARE,"square", "default multiplies by itself"}, + {2, A_VALUE, ERR_NONE, "scale", "multiply by power of 2"}, + {2, A_VALUE, ERR_NONE, "shift", "shift left by n bits (right if negative)"}, + {3, A_VALUE, ERR_NONE, "round", "round to given number of decimal places"}, + {3, A_VALUE, ERR_NONE, "bround", "round to given number of binary places"}, + {3, A_VALUE, ERR_NONE, "root", "root of value within given error"}, + {3, A_VALUE, ERR_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 */ + + +static VALUE objpowi(VALUE *vp, NUMBER *q); +static BOOL objtest(OBJECT *op); +static BOOL objcmp(OBJECT *op1, OBJECT *op2); +static void objprint(OBJECT *op); + + +/* + * Show all the routine names available for objects. + */ +void +showobjfuncs(void) +{ + 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(int action, VALUE *v1, VALUE *v2, VALUE *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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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 ERR_PRINT: + objprint(v1->v_obj); + val.v_type = V_NULL; + break; + case ERR_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 ERR_TEST: + val.v_type = V_INT; + val.v_int = objtest(v1->v_obj); + break; + case ERR_POW: + if (v2->v_type != V_NUM) { + math_error("Non-real power"); + /*NOTREACHED*/ + } + val = objpowi(v1, v2->v_num); + break; + case ERR_ONE: + val.v_type = V_NUM; + val.v_num = qlink(&_qone_); + break; + case ERR_INC: + tmp.v_type = V_NUM; + tmp.v_num = &_qone_; + val = objcall(OBJ_ADD, v1, &tmp, NULL_VALUE); + break; + case ERR_DEC: + tmp.v_type = V_NUM; + tmp.v_num = &_qone_; + val = objcall(OBJ_SUB, v1, &tmp, NULL_VALUE); + break; + case ERR_SQUARE: + val = objcall(OBJ_MUL, v1, v1, NULL_VALUE); + break; + default: + math_error("Function \"%s\" is undefined", namefunc(index)); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + register long *ip; + long 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. + * + * given: + * op object being printed + */ +static void +objprint(OBJECT *op) +{ + 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(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(OBJECT *op1, OBJECT *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. + * + * given: + * vp value to be powered + * q power to raise number to + */ +static VALUE +objpowi(VALUE *vp, NUMBER *q) +{ + VALUE res, tmp; + long power; /* power to raise to */ + FULL bit; /* current bit value */ + + if (qisfrac(q)) { + math_error("Raising object to non-integral power"); + /*NOTREACHED*/ + } + if (zge31b(q->num)) { + math_error("Raising object to very large power"); + /*NOTREACHED*/ + } + power = ztolong(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. + * + * given: + * name name of object type + * indices table of indices for elements + * count number of elements defined for the object + */ +void +defineobject(char *name, int indices[], 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); + /*NOTREACHED*/ + } + + if (hp->h_count >= MAXOBJECTS) { + math_error("Too many object types in use"); + /*NOTREACHED*/ + } + oap = (OBJECTACTIONS *) malloc(objectactionsize(count)); + if (oap) + name = addstr(hp, name); + if ((oap == NULL) || (name == NULL)) { + math_error("Cannot allocate object type"); + /*NOTREACHED*/ + } + 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(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(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"); + /*NOTREACHED*/ + } + return findstr(hp, name); +} + + +/* + * Return the index which identifies an element name. + * Returns minus one if the element name is unknown. + * + * given: + * name element name + */ +int +findelement(char *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(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(long index) +{ + OBJECTACTIONS *oap; + OBJECT *op; + VALUE *vp; + int i; + + if ((unsigned) index >= MAXOBJECTS) { + math_error("Allocating bad object index"); + /*NOTREACHED*/ + } + oap = objects[index]; + if (oap == NULL) { + math_error("Object type not defined"); + /*NOTREACHED*/ + } + i = oap->count; + if (i < USUAL_ELEMENTS) + i = USUAL_ELEMENTS; + if (i == USUAL_ELEMENTS) + op = (OBJECT *) malloc(sizeof(OBJECT)); + else + op = (OBJECT *) malloc(objectsize(i)); + if (op == NULL) { + math_error("Cannot allocate object"); + /*NOTREACHED*/ + } + 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(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) + free(op); + else + free((char *) op); +} + + +/* + * Copy an object value + */ +OBJECT * +objcopy(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 *) malloc(sizeof(OBJECT)); + else + np = (OBJECT *) malloc(objectsize(i)); + if (np == NULL) { + math_error("Cannot allocate object"); + /*NOTREACHED*/ + } + 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; +} + + +/* + * Show object types that have been defined. + */ +void +showobjtypes(void) +{ + STRINGHEAD *hp; + OBJECTACTIONS *oap; + STRINGHEAD *ep; + int index, i; + + hp = &objectnames; + ep = &elements; + if (hp->h_count == 0) { + printf("No object types defined\n"); + return; + } + for (index = 0; index < hp->h_count; index++) { + oap = objects[index]; + printf("\t%s\t{", oap->name); + for (i = 0; i < oap->count; i++) { + if (i) printf(","); + printf("%s", namestr(ep, oap->elements[i])); + } + printf("}\n"); + } + +} + + +/* END CODE */ diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 0000000..506b490 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,2786 @@ +/* + * Copyright (c) 1996 David I. Bell + * Permission is granted to use, distribute, or modify this source, + * provided that this copyright notice remains intact. + * + * Opcode execution module + */ + +#include "calc.h" +#include "opcodes.h" +#include "func.h" +#include "symbol.h" +#include "hist.h" +#include "args.h" +#include "file.h" +#include "zrand.h" +#include "have_fpos.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 */ +int dumpnames; /* names if TRUE, otherwise indices */ + + +/* + * forward declarations + */ +static void showsizes(void); +static void o_paramaddr(FUNC *fp, int argcnt, VALUE *args, long index); +static void o_getvalue(void); + + +/* + * 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 */ + + +/* + * opcode - info about each opcode + */ +struct opcode { + void (*o_func)(); /* routine to call for opcode */ + int o_type; /* type of opcode */ + char *o_name; /* name of opcode */ +}; + + +/* + * external configuration functions + */ +extern void config_value(CONFIG *cfg, int type, VALUE *ret); +extern void setconfig(int type, VALUE *vp); + + +/* + * Initialize the stack. + */ +void +initstack(void) +{ + 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--); + } + } +} + + +/* + * The various opcodes + */ +static void +o_nop(void) +{ +} + + +static void +o_localaddr(FUNC *fp, VALUE *locals, long index) +{ + if ((unsigned long)index >= fp->f_localcount) { + math_error("Bad local variable index"); + /*NOTREACHED*/ + } + locals += index; + stack++; + stack->v_addr = locals; + stack->v_type = V_ADDR; +} + + +/*ARGSUSED*/ +static void +o_globaladdr(FUNC *fp, GLOBAL *sp) +{ + if (sp == NULL) { + math_error("Global variable \"%s\" not initialized", sp->g_name); + /*NOTREACHED*/ + } + stack++; + stack->v_addr = &sp->g_value; + stack->v_type = V_ADDR; +} + + +/*ARGSUSED*/ +static void +o_paramaddr(FUNC *fp, int argcount, VALUE *args, long index) +{ + if ((unsigned long)index >= argcount) { + math_error("Bad parameter index"); + /*NOTREACHED*/ + } + 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(FUNC *fp, VALUE *locals, long index) +{ + if ((unsigned long)index >= fp->f_localcount) { + math_error("Bad local variable index"); + /*NOTREACHED*/ + } + locals += index; + copyvalue(locals, ++stack); +} + + +/*ARGSUSED*/ +static void +o_globalvalue(FUNC *fp, GLOBAL *sp) +{ + if (sp == NULL) { + math_error("Global variable not defined"); + /*NOTREACHED*/ + } + copyvalue(&sp->g_value, ++stack); +} + + +/*ARGSUSED*/ +static void +o_paramvalue(FUNC *fp, int argcount, VALUE *args, long index) +{ + if ((unsigned long)index >= argcount) { + math_error("Bad paramaeter index"); + /*NOTREACHED*/ + } + args += index; + if (args->v_type == V_ADDR) + args = args->v_addr; + copyvalue(args, ++stack); +} + + +static void +o_argvalue(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"); + /*NOTREACHED*/ + } + 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_paramaddr(fp, argcount, args, index); +} + + +/*ARGSUSED*/ +static void +o_number(FUNC *fp, long arg) +{ + NUMBER *q; + + q = constvalue(arg); + if (q == NULL) { + math_error("Numeric constant value not found"); + /*NOTREACHED*/ + } + stack++; + stack->v_num = qlink(q); + stack->v_type = V_NUM; +} + + +/*ARGSUSED*/ +static void +o_imaginary(FUNC *fp, long arg) +{ + NUMBER *q; + COMPLEX *c; + + q = constvalue(arg); + if (q == NULL) { + math_error("Numeric constant value not found"); + /*NOTREACHED*/ + } + 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(FUNC *fp, char *cp) +{ + stack++; + stack->v_str = cp; + stack->v_type = V_STR; + stack->v_subtype = V_STRLITERAL; +} + + +static void +o_undef(void) +{ + stack++; + stack->v_type = V_NULL; +} + + +/*ARGSUSED*/ +static void +o_matcreate(FUNC *fp, long dim) +{ + register MATRIX *mp; /* matrix being defined */ + NUMBER *num1; /* first number from stack */ + NUMBER *num2; /* second number from stack */ + 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); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + num1 = v1->v_num; + num2 = v2->v_num; + if (qisfrac(num1) || qisfrac(num2)) { + math_error("Non-integral bounds for matrix"); + /*NOTREACHED*/ + } + if (zge31b(num1->num) || zge31b(num2->num)) { + math_error("Very large bounds for matrix"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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]; + } + stack++; + stack->v_type = V_MAT; + stack->v_mat = mp; +} + + +/*ARGSUSED*/ +static void +o_eleminit(FUNC *fp, long index) +{ + VALUE *vp; + static VALUE *oldvp; + MATRIX *mp; + OBJECT *op; + VALUE tmp; + + 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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + oldvp = &op->o_table[index]; + break; + default: + math_error("Attempt to initialize non matrix or object"); + /*NOTREACHED*/ + } + vp = stack--; + if (vp->v_type == V_ADDR) { + vp = vp->v_addr; + if (vp == oldvp) + return; + copyvalue(vp, &tmp); + } + else + tmp = *vp; + freevalue(oldvp); + *oldvp = tmp; +} + + +/* + * o_indexaddr + * + * given: + * fp function to calculate + * dim dimension of matrix + * writeflag nonzero if element will be written + */ +/*ARGSUSED*/ +static void +o_indexaddr(FUNC *fp, long dim, long writeflag) +{ + int i; + BOOL flag; + VALUE *val; + VALUE *vp; + VALUE indices[MAXDIM]; /* index values */ + + flag = (writeflag != 0); + if (dim <= 0) { + math_error("Zero or negative dimensions for indexing"); + /*NOTREACHED*/ + } + val = &stack[-dim]; + if (val->v_type != V_ADDR) { + math_error("Non-pointer for indexaddr"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + while (dim-- > 0) + freevalue(stack--); + stack->v_type = V_ADDR; + stack->v_addr = vp; +} + + +/*ARGSUSED*/ +static void +o_elemaddr(FUNC *fp, long index) +{ + VALUE *vp; + MATRIX *mp; + OBJECT *op; + int offset; + + vp = stack; + if (vp->v_type == V_ADDR) + vp = stack->v_addr; + switch (vp->v_type) { + case V_MAT: + mp = vp->v_mat; + if ((index < 0) || (index >= mp->m_size)) { + math_error("Non-existent element for matrix"); + /*NOTREACHED*/ + } + stack->v_type = V_ADDR; + stack->v_addr = &mp->m_table[index]; + return; + case V_OBJ: + op = vp->v_obj; + offset = objoffset(op, index); + if (offset < 0) { + math_error("Non-existent element for object"); + /*NOTREACHED*/ + } + stack->v_type = V_ADDR; + stack->v_addr = &op->o_table[offset]; + return; + default: + math_error("Not indexing matrix or object"); + /*NOTREACHED*/ + } + +} + + +static void +o_elemvalue(FUNC *fp, long index) +{ + o_elemaddr(fp, index); + copyvalue(stack->v_addr, stack); +} + + +/*ARGSUSED*/ +static void +o_objcreate(FUNC *fp, long arg) +{ + stack++; + stack->v_type = V_OBJ; + stack->v_obj = objalloc(arg); +} + + +static void +o_assign(void) +{ + VALUE *var; /* variable value */ + VALUE *vp; + VALUE tmp; + + var = &stack[-1]; + if (var->v_type != V_ADDR) { + math_error("Assignment into non-variable"); + /*NOTREACHED*/ + } + var = var->v_addr; + vp = stack--; + if (vp->v_type == V_ADDR) { + vp = vp->v_addr; + if (vp == var) + return; + copyvalue(vp, &tmp); + } + else + tmp = *vp; + freevalue(var); + *var = tmp; +} + + +static void +o_assignpop(void) +{ + VALUE *var; /* variable value */ + VALUE *vp; + VALUE tmp; + + var = &stack[-1]; + if (var->v_type != V_ADDR) { + math_error("Assignment into non-variable"); + /*NOTREACHED*/ + } + var = var->v_addr; + vp = &stack[0]; + stack -= 2; + if (vp->v_type == V_ADDR) { + vp = vp->v_addr; + if (vp == var) + return; + copyvalue(vp, &tmp); + } + else + tmp = *vp; + freevalue(var); + *var = tmp; +} + + +static void +o_swap(void) +{ + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + 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; + addvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_sub(void) +{ + 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; + subvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_mul(void) +{ + 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; + mulvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_power(void) +{ + 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(void) +{ + 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; + divvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_quo(void) +{ + VALUE *v1, *v2; + VALUE tmp, null; + + 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; + null.v_type = V_NULL; + quovalue(v1, v2, &null, &tmp); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_mod(void) +{ + VALUE *v1, *v2; + VALUE tmp, null; + + 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; + null.v_type = V_NULL; + modvalue(v1, v2, &null, &tmp); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_quomod(void) +{ + 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"); + /*NOTREACHED*/ + } + if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) { + math_error("Non-reals for quomod"); + /*NOTREACHED*/ + } + 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); + stack -= 2; + if (stack->v_type == V_NUM) + qfree(stack->v_num); + stack--; + if (stack->v_type == V_NUM) + qfree(stack->v_num); + 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(void) +{ + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + VALUE *v1, *v2; + 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; + scalevalue(v2, v1, &tmp); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_int(void) +{ + VALUE *vp; + VALUE tmp; + + vp = stack; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + intvalue(vp, &tmp); + freevalue(stack); + *stack = tmp; +} + + +static void +o_frac(void) +{ + VALUE *vp; + VALUE tmp; + + vp = stack; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + fracvalue(vp, &tmp); + freevalue(stack); + *stack = tmp; +} + + +static void +o_abs(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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_isrand(void) +{ + VALUE *vp; + int r; + + vp = stack; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + r = (vp->v_type == V_RAND); + freevalue(stack); + stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_)); + stack->v_type = V_NUM; +} + + +static void +o_israndom(void) +{ + VALUE *vp; + int r; + + vp = stack; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + r = (vp->v_type == V_RANDOM); + freevalue(stack); + stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_)); + stack->v_type = V_NUM; +} + + +static void +o_isconfig(void) +{ + VALUE *vp; + int r; + + vp = stack; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + r = (vp->v_type == V_CONFIG); + freevalue(stack); + stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_)); + stack->v_type = V_NUM; +} + + +static void +o_ishash(void) +{ + VALUE *vp; + int r; + + vp = stack; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + r = (vp->v_type == V_HASH); + freevalue(stack); + stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_)); + stack->v_type = V_NUM; +} + + +static void +o_isassoc(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + 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(void) +{ + 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"); + /*NOTREACHED*/ + } + q = vp->v_num; + if (qisfrac(q)) { + math_error("Fast indexing by non-integer"); + /*NOTREACHED*/ + } + index = qtoi(q); + if (zge31b(q->num) || (index < 0)) { + math_error("Index out of range for fast indexing"); + /*NOTREACHED*/ + } + if (stack->v_type == V_NUM) + qfree(q); + stack--; + vp = stack; + if (vp->v_type != V_ADDR) { + math_error("Bad value for fast indexing"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + break; + default: + math_error("Bad variable type for fast indexing"); + /*NOTREACHED*/ + } +} + + +static void +o_fivalue(void) +{ + (void) o_fiaddr(); + (void) o_getvalue(); +} + + +static void +o_sgn(void) +{ + 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 = qsign(vp->v_num); + if (stack->v_type == V_NUM) + qfree(vp->v_num); + stack->v_num = q; + stack->v_type = V_NUM; + return; + } + sgnvalue(vp, &tmp); + freevalue(stack); + *stack = tmp; +} + + +static void +o_numerator(void) +{ + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + 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"); + /*NOTREACHED*/ + } + 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(void) +{ + VALUE *vp; + + vp = stack++; + *stack = *vp; +} + + +static void +o_dupvalue(void) +{ + if (stack->v_type == V_ADDR) + copyvalue(stack->v_addr, stack + 1); + else + copyvalue(stack, stack + 1); + stack++; +} + + +static void +o_pop(void) +{ + freevalue(stack--); +} + + +static void +o_return(void) +{ +} + + +/*ARGSUSED*/ +static void +o_jumpeq(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(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(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(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(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(FUNC *fp, BOOL *dojump) +{ + *dojump = TRUE; +} + + +static void +o_usercall(FUNC *fp, long index, long argcount) +{ + fp = findfunc(index); + if (fp == NULL) { + math_error("Function \"%s\" is undefined", namefunc(index)); + /*NOTREACHED*/ + } + calculate(fp, (int) argcount); +} + + +/*ARGSUSED*/ +static void +o_call(FUNC *fp, long index, long argcount) +{ + VALUE result; + + result = builtinfunc(index, (int) argcount, stack); + while (--argcount >= 0) + freevalue(stack--); + stack++; + *stack = result; +} + + +static void +o_getvalue(void) +{ + if (stack->v_type == V_ADDR) + copyvalue(stack->v_addr, stack); +} + + +static void +o_cmp(void) +{ + 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; + relvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_eq(void) +{ + 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(void) +{ + 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(void) +{ + 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; + relvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + if (tmp.v_type == V_NUM && !qispos(tmp.v_num)) + stack->v_num = qlink(&_qone_); + else + stack->v_num = qlink(&_qzero_); + freevalue(&tmp); + stack->v_type = V_NUM; +} + + +static void +o_ge(void) +{ + 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; + relvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + if (tmp.v_type == V_NUM && !qisneg(tmp.v_num)) + stack->v_num = qlink(&_qone_); + else + stack->v_num = qlink(&_qzero_); + freevalue(&tmp); + stack->v_type = V_NUM; +} + + +static void +o_lt(void) +{ + 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; + relvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + if (tmp.v_type == V_NUM && qisneg(tmp.v_num)) + stack->v_num = qlink(&_qone_); + else + stack->v_num = qlink(&_qzero_); + freevalue(&tmp); + stack->v_type = V_NUM; +} + + +static void +o_gt(void) +{ + 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; + relvalue(v1, v2, &tmp); + freevalue(stack--); + freevalue(stack); + if (tmp.v_type == V_NUM && qispos(tmp.v_num)) + stack->v_num = qlink(&_qone_); + else + stack->v_num = qlink(&_qzero_); + freevalue(&tmp); + stack->v_type = V_NUM; +} + + +static void +o_preinc(void) +{ + NUMBER *q, **np; + VALUE *vp, tmp; + + if (stack->v_type != V_ADDR) { + math_error("Preincrementing non-variable"); + /*NOTREACHED*/ + } + if (stack->v_addr->v_type == V_NUM) { + np = &stack->v_addr->v_num; + q = qinc(*np); + qfree(*np); + *np = q; + return; + } + vp = stack->v_addr; + incvalue(vp, &tmp); + freevalue(vp); + *vp = tmp; +} + + +static void +o_predec(void) +{ + NUMBER *q, **np; + VALUE *vp, tmp; + + if (stack->v_type != V_ADDR) { + math_error("Predecrementing non-variable"); + /*NOTREACHED*/ + } + if (stack->v_addr->v_type == V_NUM) { + np = &stack->v_addr->v_num; + q = qdec(*np); + qfree(*np); + *np = q; + return; + } + vp = stack->v_addr; + decvalue(vp, &tmp); + freevalue(vp); + *vp = tmp; +} + + +static void +o_postinc(void) +{ + VALUE *vp; + VALUE tmp; + + if (stack->v_type != V_ADDR) { + math_error("Postincrementing non-variable"); + /*NOTREACHED*/ + } + vp = stack->v_addr; + copyvalue(vp, stack++); + incvalue(vp, &tmp); + freevalue(vp); + *vp = tmp; + stack->v_type = V_ADDR; + stack->v_addr = vp; +} + + +static void +o_postdec(void) +{ + VALUE *vp; + VALUE tmp; + + if (stack->v_type != V_ADDR) { + math_error("Postdecrementing non-variable"); + /*NOTREACHED*/ + } + vp = stack->v_addr; + copyvalue(vp, stack++); + decvalue(vp, &tmp); + freevalue(vp); + *vp = tmp; + stack->v_type = V_ADDR; + stack->v_addr = vp; +} + + +static void +o_leftshift(void) +{ + 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(void) +{ + 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(FUNC *fp, long line) +{ + funcline = line; + if (abortlevel >= ABORT_STATEMENT) { + math_error("Calculation aborted at statement boundary"); + /*NOTREACHED*/ + } +} + + +static void +o_printresult(void) +{ + VALUE *vp; + + vp = stack; + if (vp->v_type == V_ADDR) + vp = vp->v_addr; + if (vp->v_type != V_NULL) { + if (conf->tab_ok) + math_chr('\t'); + printvalue(vp, PRINT_UNAMBIG); + math_chr('\n'); + math_flush(); + } + freevalue(stack--); +} + + +/*ARGSUSED*/ +static void +o_print(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 (conf->traceflags & TRACE_OPCODES) + printf("\n"); + math_flush(); +} + + +static void +o_printeol(void) +{ + math_chr('\n'); + math_flush(); +} + + +static void +o_printspace(void) +{ + math_chr(' '); + if (conf->traceflags & TRACE_OPCODES) + printf("\n"); +} + + +/*ARGSUSED*/ +static void +o_printstring(FUNC *fp, char *cp) +{ + math_str(cp); + if (conf->traceflags & TRACE_OPCODES) + printf("\n"); + math_flush(); +} + + +static void +o_zero(void) +{ + stack++; + stack->v_type = V_NUM; + stack->v_num = qlink(&_qzero_); +} + + +static void +o_one(void) +{ + stack++; + stack->v_type = V_NUM; + stack->v_num = qlink(&_qone_); +} + + +static void +o_save(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(void) +{ + copyvalue(&oldvalue, ++stack); +} + + +static void +o_quit(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); + /*NOTREACHED*/ + } + math_error("quit statement executed"); + /*NOTREACHED*/ +} + + +static void +o_getepsilon(void) +{ + stack++; + stack->v_type = V_NUM; + stack->v_num = qlink(conf->epsilon); +} + + +static void +o_setepsilon(void) +{ + 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"); + /*NOTREACHED*/ + } + newep = vp->v_num; + stack->v_num = qlink(conf->epsilon); + setepsilon(newep); + if (stack->v_type == V_NUM) + qfree(newep); + stack->v_type = V_NUM; +} + + +static void +o_setconfig(void) +{ + 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"); + /*NOTREACHED*/ + } + type = configtype(v1->v_str); + if (type < 0) { + math_error("Unknown config name \"%s\"", v1->v_str); + /*NOTREACHED*/ + } + config_value(conf, type, &tmp); + setconfig(type, v2); + freevalue(stack--); + freevalue(stack); + *stack = tmp; +} + + +static void +o_getconfig(void) +{ + 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"); + /*NOTREACHED*/ + } + type = configtype(vp->v_str); + if (type < 0) { + math_error("Unknown config name \"%s\"", vp->v_str); + /*NOTREACHED*/ + } + freevalue(stack); + config_value(conf, type, stack); +} + + +/* + * Set the 'old' value to the last value saved during the calculation. + */ +void +updateoldvalue(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. + */ +void +math_error(char *fmt, ...) +{ + va_list ap; + char buf[MAXERROR+1]; + + if (funcname && (*funcname != '*')) + fprintf(stderr, "\"%s\": ", funcname); + if (funcline && ((funcname && (*funcname != '*')) || !inputisterminal())) + fprintf(stderr, "line %ld: ", funcline); + va_start(ap, fmt); + vsprintf(buf, fmt, ap); + va_end(ap); + fprintf(stderr, "%s\n", buf); + funcname = NULL; + if (post_init) { + longjmp(jmpbuf, 1); + } else { + fprintf(stderr, "no jmpbuf jumpback point - ABORTING!!!\n"); + exit(3); + } +} + + +/* + * error_value - return error as a value + */ +VALUE +error_value(int e) +{ + VALUE res; + + if (-e > 0) + e = 0; + res.v_type = -e; + return res; +} + + +/* + * Fill a newly created matrix at v1 with copies of value at v2. + */ + +static void +o_initfill(void) +{ + VALUE *v1, *v2; + int s; + VALUE *vp; + + 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_MAT) { + math_error("Non-matrix argument for o_initfill"); + /*NOTREACHED*/ + } + s = v1->v_mat->m_size; + vp = v1->v_mat->m_table; + while (s-- > 0) + copyvalue(v2, vp++); + freevalue(stack--); +} + + +/*ARGSUSED*/ +static void +o_show(FUNC *fp, long arg) +{ + int size; + + switch((int) arg) { + case 1: showbuiltins(); return; + case 2: showglobals(); return; + case 3: showfunctions(); return; + case 4: showobjfuncs(); return; + case 5: config_print(conf); putchar('\n'); return; + case 6: showobjtypes(); return; + case 7: showfiles(); return; + case 8: showsizes(); return; + } + fp = findfunc(arg - 9); + if (fp == NULL) { + printf("Function not defined\n"); + return; + } + dumpnames = FALSE; + for (size = 0; size < fp->f_opcodecount; ) { + printf("%ld: ", (long)size); + size += dumpop(&fp->f_opcodes[size]); + } +} + + +static void +showsizes(void) +{ + printf("\tchar\t\t%4ld\n", (long)sizeof(char)); + printf("\tshort\t\t%4ld\n", (long)sizeof(short)); + printf("\tint\t\t%4ld\n", (long)sizeof(int)); + printf("\tlong\t\t%4ld\n", (long)sizeof(long)); + printf("\tpointer\t\t%4ld\n", (long)sizeof(void *)); + printf("\tFILEPOS\t\t%4ld\n", (long)sizeof(FILEPOS)); + printf("\toff_t\t\t%4ld\n", (long)sizeof(off_t)); + printf("\tHALF\t\t%4ld\n", (long)sizeof(HALF)); + printf("\tFULL\t\t%4ld\n", (long)sizeof(FULL)); + printf("\tVALUE\t\t%4ld\n", (long)sizeof(VALUE)); + printf("\tNUMBER\t\t%4ld\n", (long)sizeof(NUMBER)); + printf("\tZVALUE\t\t%4ld\n", (long)sizeof(ZVALUE)); + printf("\tCOMPLEX\t\t%4ld\n", (long)sizeof(COMPLEX)); + printf("\tMATRIX\t\t%4ld\n", (long)sizeof(MATRIX)); + printf("\tLIST\t\t%4ld\n", (long)sizeof(LIST)); + printf("\tLISTELEM\t%4ld\n", (long)sizeof(LISTELEM)); + printf("\tOBJECT\t\t%4ld\n", (long)sizeof(OBJECT)); + printf("\tOBJECTACTIONS\t%4ld\n", (long)sizeof(OBJECTACTIONS)); + printf("\tASSOC\t\t%4ld\n", (long)sizeof(ASSOC)); + printf("\tASSOCELEM\t%4ld\n", (long)sizeof(ASSOCELEM)); + printf("\tCONFIG\t\t%4ld\n", (long)sizeof(CONFIG)); + printf("\tFILEIO\t\t%4ld\n", (long)sizeof(FILEIO)); + printf("\tRAND\t\t%4ld\n", (long)sizeof(RAND)); + printf("\tRANDOM\t\t%4ld\n", (long)sizeof(RANDOM)); +} + + +/* + * Information about each opcode. + */ +static struct 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 */ + {o_isconfig, OPNUL, "ISCONFIG"}, /* whether value is a configuration state */ + {o_ishash, OPNUL, "ISHASH"}, /* whether value is a hash state */ + {o_isrand, OPNUL, "ISRAND"}, /* whether value is a rand element */ + {o_israndom, OPNUL, "ISRANDOM"}, /* whether value is a random element */ + {o_show, OPONE, "SHOW"}, /* show current state data */ + {o_initfill, OPNUL, "INITFILL"} /* initially fill matrix */ +}; + + +/* + * Compute the result of a function by interpreting opcodes. + * Arguments have just been pushed onto the evaluation stack. + * + * given: + * fp function to calculate + * argcount number of arguments called with + */ +void +calculate(FUNC *fp, int argcount) +{ + 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"); + /*NOTREACHED*/ + } + } + 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"); + /*NOTREACHED*/ + } + if (pc >= fp->f_opcodecount) { + math_error("Function pc out of range"); + /*NOTREACHED*/ + } + if (stack > &stackarray[MAXSTACK-3]) { + math_error("Evaluation stack depth exceeded"); + /*NOTREACHED*/ + } + opnum = fp->f_opcodes[pc]; + if (opnum > MAX_OPCODE) { + math_error("Function opcode out of range"); + /*NOTREACHED*/ + } + op = &opcodes[opnum]; + if (conf->traceflags & TRACE_OPCODES) { + dumpnames = FALSE; + 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 */ + /* ignore Saber-C warning #65 - has 1 arg, expected 0 */ + /* ok to ignore in proc calculate */ + (*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 */ + /* ignore Saber-C warning #68 - benign type mismatch */ + /* ok to ignore in proc calculate */ + (*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"); + /*NOTREACHED*/ + } + 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: %d", op->o_type); + /*NOTREACHED*/ + } + } +} + + +/* + * Dump an opcode at a particular address. + * Returns the size of the opcode so that it can easily be skipped over. + * + * given: + * pc location of the opcode + */ +int +dumpop(unsigned long *pc) +{ + 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: + if (dumpnames) + printf(" %s\n", localname((long)*pc)); + else + printf(" %ld\n", *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: + if (dumpnames) + printf(" %s\n", paramname((long)*pc)); + else + printf(" %ld\n", *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: + case OP_SHOW: case OP_ELEMINIT: case OP_ELEMADDR: + case OP_ELEMVALUE: + printf(" %ld\n", *pc); + return 2; + case OP_NUMBER: case OP_IMAGINARY: + qprintf(" %r", constvalue(*pc)); + printf("\n"); + return 2; + case OP_DEBUG: + printf(" line %ld\n", *pc); + return 2; + case OP_CALL: + printf(" %s with %ld args\n", + builtinname((long)pc[0]), (long)pc[1]); + return 3; + case OP_USERCALL: + printf(" %s with %ld args\n", + namefunc((long)pc[0]), (long)pc[1]); + return 3; + default: + printf("\n"); + return 1; + } +} diff --git a/opcodes.h b/opcodes.h new file mode 100644 index 0000000..8a624e4 --- /dev/null +++ b/opcodes.h @@ -0,0 +1,128 @@ +/* + * 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 OP_ISCONFIG 104L /* whether value is a configuration state */ +#define OP_ISHASH 105L /* whether value is a hash state */ +#define OP_ISRAND 106L /* whether value is additive 55 random state */ +#define OP_ISRANDOM 107L /* whether value is a Blum random state */ +#define OP_SHOW 108L /* show data about current state */ +#define OP_INITFILL 109L /* fill new matrix with copies of a value */ +#define MAX_OPCODE 109L /* highest legal opcode */ + +#endif + +/* END CODE */ diff --git a/pix.c b/pix.c new file mode 100644 index 0000000..d3fa237 --- /dev/null +++ b/pix.c @@ -0,0 +1,1559 @@ +/* + * Copyright (c) 1995 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 "zmath.h" +#include "prime.h" +#include "have_const.h" + + +/* + * pi10b - number of primes <= 2^18 in multiples of 2^10 + * + * pi10b[x] == pi(x*1024) for 0 <= x <= 256 + */ +CONST unsigned short pi10b[(MAX_PI10B/1024)+1+1] = { + 0, 172, 309, 439, 564, 685, 801, 916, 1028, 1142, 1254, 1362, 1469, 1580, + 1681, 1794, 1900, 2002, 2110, 2205, 2312, 2413, 2517, 2618, 2725, 2818, + 2918, 3016, 3124, 3221, 3314, 3414, 3512, 3619, 3716, 3808, 3908, 4006, + 4098, 4197, 4288, 4391, 4495, 4583, 4678, 4767, 4858, 4956, 5051, 5152, + 5239, 5339, 5432, 5520, 5616, 5711, 5814, 5908, 6003, 6094, 6179, 6270, + 6363, 6453, 6542, 6636, 6734, 6820, 6906, 6999, 7095, 7190, 7281, 7371, + 7465, 7550, 7649, 7733, 7824, 7915, 8009, 8103, 8187, 8277, 8363, 8453, + 8548, 8630, 8727, 8812, 8899, 9000, 9087, 9180, 9271, 9357, 9439, 9533, + 9618, 9708, 9805, 9886, 9971, 10062, 10151, 10236, 10324, 10416, 10499, + 10585, 10674, 10761, 10846, 10930, 11021, 11110, 11196, 11282, 11371, 11462, + 11554, 11641, 11729, 11816, 11900, 11987, 12079, 12163, 12251, 12333, 12425, + 12507, 12589, 12680, 12777, 12861, 12941, 13032, 13125, 13212, 13289, 13372, + 13452, 13546, 13631, 13712, 13807, 13894, 13982, 14072, 14159, 14242, 14327, + 14407, 14497, 14577, 14662, 14750, 14835, 14915, 14999, 15086, 15167, 15247, + 15334, 15408, 15495, 15585, 15670, 15758, 15843, 15925, 16003, 16097, 16173, + 16264, 16357, 16433, 16519, 16601, 16690, 16775, 16869, 16954, 17032, 17119, + 17200, 17282, 17369, 17457, 17536, 17623, 17704, 17789, 17877, 17957, 18038, + 18118, 18205, 18285, 18367, 18450, 18535, 18624, 18710, 18798, 18889, 18974, + 19045, 19130, 19213, 19290, 19370, 19453, 19541, 19628, 19709, 19797, 19876, + 19960, 20043, 20126, 20206, 20288, 20379, 20476, 20552, 20632, 20709, 20787, + 20870, 20946, 21022, 21109, 21191, 21272, 21359, 21446, 21527, 21613, 21695, + 21776, 21859, 21950, 22031, 22106, 22196, 22276, 22358, 22435, 22525, 22599, + 22678, 22765, 22845, 22925, 23000 +}; + +/* + * pi18b - primes found in a given 2^18 interval + * + * ie_value, &tmp1); + freevalue(vres); + *vres = tmp1; + } + v = cp->e_value; + if (v.v_type == V_LIST) { + if (evalpoly(v.v_list, x->e_next, &tmp1)) { + if (s) { + addvalue(&tmp1, vres, &tmp2); + freevalue(&tmp1); + freevalue(vres); + *vres = tmp2; + } + else { + s = TRUE; + *vres = tmp1; + } + } + } + else { + if (s) { + addvalue(&v, vres, &tmp1); + freevalue(vres); + *vres = tmp1; + } + else { + s = TRUE; + copyvalue(&v, vres); + } + } + cp = cp->e_prev; + } + return s; +} + + +BOOL +evalpoly(LIST *clist, LISTELEM *x, VALUE *vres) +{ + LISTELEM *cp; + VALUE v; + + cp = clist->l_first; + if (cp == NULL) + return FALSE; + if (x == NULL) { + v = cp->e_value; + if (v.v_type == V_LIST) + return evalpoly(v.v_list, x->e_next, vres); + copyvalue(&v, vres); + return TRUE; + } + return evp(clist->l_last, x, vres); +} + +void +insertitems(LIST *lp1, LIST *lp2) +{ + LISTELEM *ep; + + for (ep = lp2->l_first; ep; ep = ep->e_next) { + if (ep->e_value.v_type == V_LIST) + insertitems(lp1, ep->e_value.v_list); + else + insertlistlast(lp1, &ep->e_value); + } +} + + +long +countlistitems(LIST *lp) +{ + LISTELEM *ep; + + long n = 0; + for (ep = lp->l_first; ep; ep = ep->e_next) { + if (ep->e_value.v_type == V_LIST) + n += countlistitems(ep->e_value.v_list); + else + n++; + } + return n; +} + + +void +addlistitems(LIST *lp, VALUE *vres) +{ + LISTELEM *ep; + VALUE tmp; + + for (ep = lp->l_first; ep; ep = ep->e_next) { + addvalue(vres, &ep->e_value, &tmp); + freevalue(vres); + *vres = tmp; + if (vres->v_type < 0) + return; + } +} + +void +addlistinv(LIST *lp, VALUE *vres) +{ + LISTELEM *ep; + VALUE tmp1, tmp2; + + for (ep = lp->l_first; ep; ep = ep->e_next) { + if (ep->e_value.v_type == V_LIST) + addlistinv(ep->e_value.v_list, vres); + else { + invertvalue(&ep->e_value, &tmp1); + addvalue(vres, &tmp1, &tmp2); + freevalue(&tmp1); + freevalue(vres); + *vres = tmp2; + } + if (vres->v_type < 0) + return; + } +} + + +/* END CODE */ diff --git a/prime.c b/prime.c new file mode 100644 index 0000000..6d05335 --- /dev/null +++ b/prime.c @@ -0,0 +1,925 @@ +/* + * Copyright (c) 1995 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 "qmath.h" +#include "prime.h" +#include "jump.h" +#include "have_const.h" + + +/* + * odd prime bitmap for odd values < 2^16 + * + * pr_map[i] & (1< i*16 + j*2 + 1 is prime + * 0 ==> i*16 + j*2 + 1 is not prime + * + * This table is useful to quickly determining if a 16 bit odd number + * is prime. Use the prime[] array to quickly walk thru the 16 bit + * off primes. + */ +CONST unsigned char pr_map[(MAX_MAP_VAL/8)+1] = { + 110,203,180,100,154, 18,109,129, 50, 76, 74,134, 13,130,150, 33, + 201, 52, 4, 90, 32, 97,137,164, 68, 17,134, 41,209,130, 40, 74, + 48, 64, 66, 50, 33,153, 52, 8, 75, 6, 37, 66,132, 72,138, 20, + 5, 66, 48,108, 8,180, 64, 11,160, 8, 81, 18, 40,137, 4,101, + 152, 48, 76,128,150, 68, 18,128, 33, 66, 18, 65,201, 4, 33,192, + 50, 45,152, 0, 0, 73, 4, 8,129,150,104,130,176, 37, 8, 34, + 72,137,162, 64, 89, 38, 4,144, 6, 64, 67, 48, 68,146, 0,105, + 16,130, 8, 8,164, 13, 65, 18, 96,192, 0, 36,210, 34, 97, 8, + 132, 4, 27,130, 1,211, 16, 1, 2,160, 68,192, 34, 96,145, 20, + 12, 64,166, 4,210,148, 32, 9,148, 32, 82, 0, 8, 16,162, 76, + 0,130, 1, 81, 16, 8,139,164, 37,154, 48, 68,129, 16, 76, 3, + 2, 37, 82,128, 8, 73,132, 32, 80, 50, 0, 24,162, 64, 17, 36, + 40, 1,132, 1, 1,160, 65, 10, 18, 69, 0, 54, 8, 0, 38, 41, + 131,130, 97,192,128, 4, 16, 16,109, 0, 34, 72, 88, 38, 12,194, + 16, 72,137, 36, 32, 88, 32, 69,136, 36, 0, 25, 2, 37,192, 16, + 104, 8, 20, 1,202, 50, 40,128, 0, 4, 75, 38, 0, 19,144, 96, + 130,128, 37,208, 0, 1, 16, 50, 12, 67,134, 33, 17, 0, 8, 67, + 36, 4, 72, 16, 12,144,146, 0, 67, 32, 45, 0, 6, 9,136, 36, + 64,192, 50, 9, 9,130, 0, 83,128, 8,128,150, 65,129, 0, 64, + 72, 16, 72, 8,150, 72, 88, 32, 41,195,128, 32, 2,148, 96,146, + 0, 32,129, 34, 68, 16,160, 5, 64,144, 1, 73, 32, 4, 10, 0, + 36,137, 52, 72, 19,128, 44,192,130, 41, 0, 36, 69, 8, 0, 8, + 152, 54, 4, 82,132, 4,208, 4, 0,138,144, 68,130, 50,101, 24, + 144, 0, 10, 2, 1, 64, 2, 40, 64,164, 4,146, 48, 4, 17,134, + 8, 66, 0, 44, 82, 4, 8,201,132, 96, 72, 18, 9,153, 36, 68, + 0, 36, 0, 3, 20, 33, 0, 16, 1, 26, 50, 5,136, 32, 64, 64, + 6, 9,195,132, 64, 1, 48, 96, 24, 2,104, 17,144, 12, 2,162, + 4, 0,134, 41,137, 20, 36,130, 2, 65, 8,128, 4, 25,128, 8, + 16, 18,104, 66,164, 4, 0, 2, 97, 16, 6, 12, 16, 0, 1, 18, + 16, 32, 3,148, 33, 66, 18,101, 24,148, 12, 10, 4, 40, 1, 20, + 41, 10,164, 64,208, 0, 64, 1,144, 4, 65, 32, 45, 64,130, 72, + 193, 32, 0, 16, 48, 1, 8, 36, 4, 89,132, 36, 0, 2, 41,130, + 0, 97, 88, 2, 72,129, 22, 72, 16, 0, 33, 17, 6, 0,202,160, + 64, 2, 0, 4,145,176, 0, 66, 4, 12,129, 6, 9, 72, 20, 37, + 146, 32, 37, 17,160, 0, 10,134, 12,193, 2, 72, 0, 32, 69, 8, + 50, 0,152, 6, 4, 19, 34, 0,130, 4, 72,129, 20, 68,130, 18, + 36, 24, 16, 64, 67,128, 40,208, 4, 32,129, 36,100,216, 0, 44, + 9, 18, 8, 65,162, 0, 0, 2, 65,202, 32, 65,192, 16, 1, 24, + 164, 4, 24,164, 32, 18,148, 32,131,160, 64, 2, 50, 68,128, 4, + 0, 24, 0, 12, 64,134, 96,138, 0,100,136, 18, 5, 1,130, 0, + 74,162, 1,193, 16, 97, 9, 4, 1,136, 0, 96, 1,180, 64, 8, + 6, 1, 3,128, 8, 64,148, 4,138, 32, 41,128, 2, 12, 82, 2, + 1, 66,132, 0,128,132,100, 2, 50, 72, 0, 48, 68, 64, 34, 33, + 0, 2, 8,195,160, 4,208, 32, 64, 24, 22, 64, 64, 0, 40, 82, + 144, 8,130, 20, 1, 24, 16, 8, 9,130, 64, 10,160, 32,147,128, + 8,192, 0, 32, 82, 0, 5, 1, 16, 64, 17, 6, 12,130, 0, 0, + 75,144, 68,154, 0, 40,128,144, 4, 74, 6, 9, 67, 2, 40, 0, + 52, 1, 24, 0,101, 9,128, 68, 3, 0, 36, 2,130, 97, 72, 20, + 65, 0, 18, 40, 0, 52, 8, 81, 4, 5, 18,144, 40,137,132, 96, + 18, 16, 73, 16, 38, 64, 73,130, 0,145, 16, 1, 10, 36, 64,136, + 16, 76, 16, 4, 0, 80,162, 44, 64,144, 72, 10,176, 1, 80, 18, + 8, 0,164, 4, 9,160, 40,146, 2, 0, 67, 16, 33, 2, 32, 65, + 129, 50, 0, 8, 4, 12, 82, 0, 33, 73,132, 32, 16, 2, 1,129, + 16, 72, 64, 34, 1, 1,132,105,193, 48, 1,200, 2, 68,136, 0, + 12, 1, 2, 45,192, 18, 97, 0,160, 0,192, 48, 64, 1, 18, 8, + 11, 32, 0,128,148, 64, 1,132, 64, 0, 50, 0, 16,132, 0, 11, + 36, 0, 1, 6, 41,138,132, 65,128, 16, 8, 8,148, 76, 3,128, + 1, 64,150, 64, 65, 32, 32, 80, 34, 37,137,162, 64, 64,164, 32, + 2,134, 40, 1, 32, 33, 74, 16, 8, 0, 20, 8, 64, 4, 37, 66, + 2, 33, 67, 16, 4,146, 0, 33, 17,160, 76, 24, 34, 9, 3,132, + 65,137, 16, 4,130, 34, 36, 1, 20, 8, 8,132, 8,193, 0, 9, + 66,176, 65,138, 2, 0,128, 54, 4, 73,160, 36,145, 0, 0, 2, + 148, 65,146, 2, 1, 8, 6, 8, 9, 0, 1,208, 22, 40,137,128, + 96, 0, 0,104, 1,144, 12, 80, 32, 1, 64,128, 64, 66, 48, 65, + 0, 32, 37,129, 6, 64, 73, 0, 8, 1, 18, 73, 0,160, 32, 24, + 48, 5, 1,166, 0, 16, 36, 40, 0, 2, 32,200, 32, 0,136, 18, + 12,144,146, 0, 2, 38, 1, 66, 22, 73, 0, 4, 36, 66, 2, 1, + 136,128, 12, 26,128, 8, 16, 0, 96, 2,148, 68,136, 0,105, 17, + 48, 8, 18,160, 36, 19,132, 0,130, 0,101,192, 16, 40, 0, 48, + 4, 3, 32, 1, 17, 6, 1,200,128, 0,194, 32, 8, 16,130, 12, + 19, 2, 12, 82, 6, 64, 0,176, 97, 64, 16, 1,152,134, 4, 16, + 132, 8,146, 20, 96, 65,128, 65, 26, 16, 4,129, 34, 64, 65, 32, + 41, 82, 0, 65, 8, 52, 96, 16, 0, 40, 1, 16, 64, 0,132, 8, + 66,144, 32, 72, 4, 4, 82, 2, 0, 8, 32, 4, 0,130, 13, 0, + 130, 64, 2, 16, 5, 72, 32, 64,153, 0, 0, 1, 6, 36,192, 0, + 104,130, 4, 33, 18, 16, 68, 8, 4, 0, 64,166, 32,208, 22, 9, + 201, 36, 65, 2, 32, 12, 9,146, 64, 18, 0, 0, 64, 0, 9, 67, + 132, 32,152, 2, 1, 17, 36, 0, 67, 36, 0, 3,144, 8, 65, 48, + 36, 88, 32, 76,128,130, 8, 16, 36, 37,129, 6, 65, 9, 16, 32, + 24, 16, 68,128, 16, 0, 74, 36, 13, 1,148, 40,128, 48, 0,192, + 2, 96, 16,132, 12, 2, 0, 9, 2,130, 1, 8, 16, 4,194, 32, + 104, 9, 6, 4, 24, 0, 0, 17,144, 8, 11, 16, 33,130, 2, 12, + 16,182, 8, 0, 38, 0, 65, 2, 1, 74, 36, 33, 26, 32, 36,128, + 0, 68, 2, 0, 45, 64, 2, 0,139,148, 32, 16, 0, 32,144,166, + 64, 19, 0, 44, 17,134, 97, 1,128, 65, 16, 2, 4,129, 48, 72, + 72, 32, 40, 80,128, 33,138, 16, 4, 8, 16, 9, 16, 16, 72, 66, + 160, 12,130,146, 96,192, 32, 5,210, 32, 64, 1, 0, 4, 8,130, + 45,130, 2, 0, 72,128, 65, 72, 16, 0,145, 4, 4, 3,132, 0, + 194, 4,104, 0, 0,100,192, 34, 64, 8, 50, 68, 9,134, 0,145, + 2, 40, 1, 0,100, 72, 0, 36, 16,144, 0, 67, 0, 33, 82,134, + 65,139,144, 32, 64, 32, 8,136, 4, 68, 19, 32, 0, 2,132, 96, + 129,144, 36, 64, 48, 0, 8, 16, 8, 8, 2, 1, 16, 4, 32, 67, + 180, 64,144, 18,104, 1,128, 76, 24, 0, 8,192, 18, 73, 64, 16, + 36, 26, 0, 65,137, 36, 76, 16, 0, 4, 82, 16, 9, 74, 32, 65, + 72, 34,105, 17, 20, 8, 16, 6, 36,128,132, 40, 0, 16, 0, 64, + 16, 1, 8, 38, 8, 72, 6, 40, 0, 20, 1, 66,132, 4, 10, 32, + 0, 1,130, 8, 0,130, 36, 18, 4, 64, 64,160, 64,144, 16, 4, + 144, 34, 64, 16, 32, 44,128, 16, 40, 67, 0, 4, 88, 0, 1,129, + 16, 72, 9, 32, 33,131, 4, 0, 66,164, 68, 0, 0,108, 16,160, + 68, 72,128, 0,131,128, 72,201, 0, 0, 0, 2, 5, 16,176, 4, + 19, 4, 41, 16,146, 64, 8, 4, 68,130, 34, 0, 25, 32, 0, 25, + 32, 1,129,144, 96,138, 0, 65,192, 2, 69, 16, 4, 0, 2,162, + 9, 64, 16, 33, 73, 32, 1, 66, 48, 44, 0, 20, 68, 1, 34, 4, + 2,146, 8,137, 4, 33,128, 16, 5, 1, 32, 64, 65,128, 4, 0, + 18, 9, 64,176,100, 88, 50, 1, 8,144, 0, 65, 4, 9,193,128, + 97, 8,144, 0,154, 0, 36, 1, 18, 8, 2, 38, 5,130, 6, 8, + 8, 0, 32, 72, 32, 0, 24, 36, 72, 3, 2, 0, 17, 0, 9, 0, + 132, 1, 74, 16, 1,152, 0, 4, 24,134, 0,192, 0, 32,129,128, + 4, 16, 48, 5, 0,180, 12, 74,130, 41,145, 2, 40, 0, 32, 68, + 192, 0, 44,145,128, 64, 1,162, 0, 18, 4, 9,195, 32, 0, 8, + 2, 12, 16, 34, 4, 0, 0, 44, 17,134, 0,192, 0, 0, 18, 50, + 64,137,128, 64, 64, 2, 5, 80,134, 96,130,164, 96, 10, 18, 77, + 128,144, 8, 18,128, 9, 2, 20, 72, 1, 36, 32,138, 0, 68,144, + 4, 4, 1, 2, 0,209, 18, 0, 10, 4, 64, 0, 50, 33,129, 36, + 8, 25,132, 32, 2, 4, 8,137,128, 36, 2, 2,104, 24,130, 68, + 66, 0, 33, 64, 0, 40, 1,128, 69,130, 32, 64, 17,128, 12, 2, + 0, 36, 64,144, 1, 64, 32, 32, 80, 32, 40, 25, 0, 64, 9, 32, + 8,128, 4, 96, 64,128, 32, 8, 48, 73, 9, 52, 0, 17, 36, 36, + 130, 0, 65,194, 0, 4,146, 2, 36,128, 0, 12, 2,160, 0, 1, + 6, 96, 65, 4, 33,208, 0, 1, 1, 0, 72, 18,132, 4,145, 18, + 8, 0, 36, 68, 0, 18, 65, 24, 38, 12, 65,128, 0, 82, 4, 32, + 9, 0, 36,144, 32, 72, 24, 2, 0, 3,162, 9,208, 20, 0,138, + 132, 37, 74, 0, 32,152, 20, 64, 0,162, 5, 0, 0, 0, 64, 20, + 1, 88, 32, 44,128,132, 0, 9, 32, 32,145, 2, 8, 2,176, 65, + 8, 48, 0, 9, 16, 0, 24, 2, 33, 2, 2, 0, 0, 36, 68, 8, + 18, 96, 0,178, 68, 18, 2, 12,192,128, 64,200, 32, 4, 80, 32, + 5, 0,176, 4, 11, 4, 41, 83, 0, 97, 72, 48, 0,130, 32, 41, + 0, 22, 0, 83, 34, 32, 67, 16, 72, 0,128, 4,210, 0, 64, 0, + 162, 68, 3,128, 41, 0, 4, 8,192, 4,100, 64, 48, 40, 9,132, + 68, 80,128, 33, 2,146, 0,192, 16, 96,136, 34, 8,128, 0, 0, + 24,132, 4,131,150, 0,129, 32, 5, 2, 0, 69,136,132, 0, 81, + 32, 32, 81,134, 65, 75,148, 0,128, 0, 8, 17, 32, 76, 88,128, + 4, 3, 6, 32,137, 0, 5, 8, 34, 5,144, 0, 64, 0,130, 9, + 80, 0, 0, 0,160, 65,194, 32, 8, 0, 22, 8, 64, 38, 33,208, + 144, 8,129,144, 65, 0, 2, 68, 8, 16, 12, 10,134, 9,144, 4, + 0,200,160, 4, 8, 48, 32,137,132, 0, 17, 34, 44, 64, 0, 8, + 2,176, 1, 72, 2, 1, 9, 32, 4, 3, 4, 0,128, 2, 96, 66, + 48, 33, 74, 16, 68, 9, 2, 0, 1, 36, 0, 18,130, 33,128,164, + 32, 16, 2, 4,145,160, 64, 24, 4, 0, 2, 6,105, 9, 0, 5, + 88, 2, 1, 0, 0, 72, 0, 0, 0, 3,146, 32, 0, 52, 1,200, + 32, 72, 8, 48, 8, 66,128, 32,145,144,104, 1, 4, 64, 18, 2, + 97, 0, 18, 8, 1,160, 0, 17, 4, 33, 72, 4, 36,146, 0, 12, + 1,132, 4, 0, 0, 1, 18,150, 64, 1,160, 65,136, 34, 40,136, + 0, 68, 66,128, 36, 18, 20, 1, 66,144, 96, 26, 16, 4,129, 16, + 72, 8, 6, 41,131, 2, 64, 2, 36,100,128, 16, 5,128, 16, 64, + 2, 2, 8, 66,132, 1, 9, 32, 4, 80, 0, 96, 17, 48, 64, 19, + 2, 4,129, 0, 9, 8, 32, 69, 74, 16, 97,144, 38, 12, 8, 2, + 33,145, 0, 96, 2, 4, 0, 2, 0, 12, 8, 6, 8, 72,132, 8, + 17, 2, 0,128,164, 0, 90, 32, 0,136, 4, 4, 2, 0, 9, 0, + 20, 8, 73, 20, 32,200, 0, 4,145,160, 64, 89,128, 0, 18, 16, + 0,128,128,101, 0, 0, 4, 0,128, 64, 25, 0, 33, 3,132, 96, + 192, 4, 36, 26, 18, 97,128,128, 8, 2, 4, 9, 66, 18, 32, 8, + 52, 4,144, 32, 1, 1,160, 0, 11, 0, 8,145,146, 64, 2, 52, + 64,136, 16, 97, 25, 2, 0, 64, 4, 37,192,128,104, 8, 4, 33, + 128, 34, 4, 0,160, 12, 1,132, 32, 65, 0, 8,138, 0, 32,138, + 0, 72,136, 4, 4, 17,130, 8, 64,134, 9, 73,164, 64, 0, 16, + 1, 1,162, 4, 80,128, 12,128, 0, 72,130,160, 1, 24, 18, 65, + 1, 4, 72, 65, 0, 36, 1, 0, 0,136, 20, 0, 2, 0,104, 1, + 32, 8, 74, 34, 8,131,128, 0,137, 4, 1,194, 0, 0, 0, 52, + 4, 0,130, 40, 2, 2, 65, 74,144, 5,130, 2, 9,128, 36, 4, + 65, 0, 1,146,128, 40, 1, 20, 0, 80, 32, 76, 16,176, 4, 67, + 164, 33,144, 4, 1, 2, 0, 68, 72, 0,100, 8, 6, 0, 66, 32, + 8, 2,146, 1, 74, 0, 32, 80, 50, 37,144, 34, 4, 9, 0, 8, + 17,128, 33, 1, 16, 5, 0, 50, 8,136,148, 8, 8, 36, 13,193, + 128, 64, 11, 32, 64, 24, 18, 4, 0, 34, 64, 16, 38, 5,193,130, + 0, 1, 48, 36, 2, 34, 65, 8, 36, 72, 26, 0, 37,210, 18, 40, + 66, 0, 4, 64, 48, 65, 0, 2, 0, 19, 32, 36,209,132, 8,137, + 128, 4, 82, 0, 68, 24,164, 0, 0, 6, 32,145, 16, 9, 66, 32, + 36, 64, 48, 40, 0,132, 64, 64,128, 8, 16, 4, 9, 8, 4, 64, + 8, 34, 0, 25, 2, 0, 0,128, 44, 2, 2, 33, 1,144, 32, 64, + 0, 12, 0, 52, 72, 88, 32, 1, 67, 4, 32,128, 20, 0,144, 0, + 109, 17, 0, 0, 64, 32, 0, 3, 16, 64,136, 48, 5, 74, 0,101, + 16, 36, 8, 24,132, 40, 3,128, 32, 66,176, 64, 0, 16,105, 25, + 4, 0, 0,128, 4,194, 4, 0, 1, 0, 5, 0, 34, 37, 8,150, + 4, 2, 34, 0,208, 16, 41, 1,160, 96, 8, 16, 4, 1, 22, 68, + 16, 2, 40, 2,130, 72, 64,132, 32,144, 34, 40,128, 4, 0, 64, + 4, 36, 0,128, 41, 3, 16, 96, 72, 0, 0,129,160, 0, 81, 32, + 12,209, 0, 1, 65, 32, 4,146, 0, 0, 16,146, 0, 66, 4, 5, + 1,134, 64,128, 16, 32, 82, 32, 33, 0, 16, 72, 10, 2, 0,208, + 18, 65, 72,128, 4, 0, 0, 72, 9, 34, 4, 0, 36, 0, 67, 16, + 96, 10, 0, 68, 18, 32, 44, 8, 32, 68, 0,132, 9, 64, 6, 8, + 193, 0, 64,128, 32, 0,152, 18, 72, 16,162, 32, 0,132, 72,192, + 16, 32,144, 18, 8,152,130, 0, 10,160, 4, 3, 0, 40,195, 0, + 68, 66, 16, 4, 8, 4, 64, 0, 0, 5, 16, 0, 33, 3,128, 4, + 136, 18,105, 16, 0, 4, 8, 4, 4, 2,132, 72, 73, 4, 32, 24, + 2,100,128, 48, 8, 1, 2, 0, 82, 18, 73, 8, 32, 65,136, 16, + 72, 8, 52, 0, 1,134, 5,208, 0, 0,131,132, 33, 64, 2, 65, + 16,128, 72, 64,162, 32, 81, 0, 0, 73, 0, 1,144, 32, 64, 24, + 2, 64, 2, 34, 5, 64,128, 8,130, 16, 32, 24, 0, 5, 1,130, + 64, 88, 0, 4,129,144, 41, 1,160,100, 0, 34, 64, 1,162, 0, + 24, 4, 13, 0, 0, 96,128,148, 96,130, 16, 13,128, 48, 12, 18, + 32, 0, 0, 18, 64,192, 32, 33, 88, 2, 65, 16,128, 68, 3, 2, + 4, 19,144, 41, 8, 0, 68,192, 0, 33, 0, 38, 0, 26,128, 1, + 19, 20, 32, 10, 20, 32, 0, 50, 97, 8, 0, 64, 66, 32, 9,128, + 6, 1,129,128, 96, 66, 0,104,144,130, 8, 66,128, 4, 2,128, + 9, 11, 4, 0,152, 0, 12,129, 6, 68, 72,132, 40, 3,146, 0, + 1,128, 64, 10, 0, 12,129, 2, 8, 81, 4, 40,144, 2, 32, 9, + 16, 96, 0, 0, 9,129,160, 12, 0,164, 9, 0, 2, 40,128, 32, + 0, 2, 2, 4,129, 20, 4, 0, 4, 9, 17, 18, 96, 64, 32, 1, + 72, 48, 64, 17, 0, 8, 10,134, 0, 0, 4, 96,129, 4, 1,208, + 2, 65, 24,144, 0, 10, 32, 0,193, 6, 1, 8,128,100,202, 16, + 4,153,128, 72, 1,130, 32, 80,144, 72,128,132, 32,144, 34, 0, + 25, 0, 4, 24, 32, 36, 16,134, 64,194, 0, 36, 18, 16, 68, 0, + 22, 8, 16, 36, 0, 18, 6, 1, 8,144, 0, 18, 2, 77, 16,128, + 64, 80, 34, 0, 67, 16, 1, 0, 48, 33, 10, 0, 0, 1, 20, 0, + 16,132, 4,193, 16, 41, 10, 0, 1,138, 0, 32, 1, 18, 12, 73, + 32, 4,129, 0, 72, 1, 4, 96,128, 18, 12, 8, 16, 72, 74, 4, + 40, 16, 0, 40, 64,132, 69, 80, 16, 96, 16, 6, 68, 1,128, 9, + 0,134, 1, 66,160, 0,144, 0, 5,144, 34, 64, 65, 0, 8,128, + 2, 8,192, 0, 1, 88, 48, 73, 9, 20, 0, 65, 2, 12, 2,128, + 64,137, 0, 36, 8, 16, 5,144, 50, 64, 10,130, 8, 0, 18, 97, + 0, 4, 33, 0, 34, 4, 16, 36, 8, 10, 4, 1, 16, 0, 32, 64, + 132, 4,136, 34, 32,144, 18, 0, 83, 6, 36, 1, 4, 64, 11, 20, + 96,130, 2, 13, 16,144, 12, 8, 32, 9, 0, 20, 9,128,128, 36, + 130, 0, 64, 1, 2, 68, 1, 32, 12, 64,132, 64, 10, 16, 65, 0, + 48, 5, 9,128, 68, 8, 32, 32, 2, 0, 73, 67, 32, 33, 0, 32, + 0, 1,182, 8, 64, 4, 8, 2,128, 1, 65,128, 64, 8, 16, 36, + 0, 32, 4, 18,134, 9,192, 18, 33,129, 20, 4, 0, 2, 32,137, + 180, 68, 18,128, 0,209, 0,105, 64,128, 0, 66, 18, 0, 24, 4, + 0, 73, 6, 33, 2, 4, 40, 2,132, 1,192, 16,104, 0, 32, 8, + 64, 0, 8,145, 16, 1,129, 36, 4,210, 16, 76,136,134, 0, 16, + 128, 12, 2, 20, 0,138,144, 64, 24, 32, 33,128,164, 0, 88, 36, + 32, 16, 16, 96,193, 48, 65, 72, 2, 72, 9, 0, 64, 9, 2, 5, + 17,130, 32, 74, 32, 36, 24, 2, 12, 16, 34, 12, 10, 4, 0, 3, + 6, 72, 72, 4, 4, 2, 0, 33,128,132, 0, 24, 0, 12, 2, 18, + 1, 0, 20, 5,130, 16, 65,137, 18, 8, 64,164, 33, 1,132, 72, + 2, 16, 96, 64, 2, 40, 0, 20, 8, 64,160, 32, 81, 18, 0,194, + 0, 1, 26, 48, 64,137, 18, 76, 2,128, 0, 0, 20, 1, 1,160, + 33, 24, 34, 33, 24, 6, 64, 1,128, 0,144, 4, 72, 2, 48, 4, + 8, 0, 5,136, 36, 8, 72, 4, 36, 2, 6, 0,128, 0, 0, 0, + 16,101, 17,144, 0, 10,130, 4,195, 4, 96, 72, 36, 4,146, 2, + 68,136,128, 64, 24, 6, 41,128, 16, 1, 0, 0, 68,200, 16, 33, + 137, 48, 0, 75,160, 1, 16, 20, 0, 2,148, 64, 0, 32,101, 0, + 162, 12, 64, 34, 32,129, 18, 32,130, 4, 1, 16, 0, 8,136, 0, + 0, 17,128, 4, 66,128, 64, 65, 20, 0, 64, 50, 44,128, 36, 4, + 25, 0, 0,145, 0, 32,131, 0, 5, 64, 32, 9, 1,132, 64, 64, + 32, 32, 17, 0, 64, 65,144, 32, 0, 0, 64,144,146, 72, 24, 6, + 8,129,128, 72, 1, 52, 36, 16, 32, 4, 0, 32, 4, 24, 6, 45, + 144, 16, 1, 0,144, 0, 10, 34, 1, 0, 34, 0, 17,132, 1, 1, + 0, 32,136, 0, 68, 0, 34, 1, 0,166, 64, 2, 6, 32, 17, 0, + 1,200,160, 4,138, 0, 40, 25,128, 0, 82,160, 36, 18, 18, 9, + 8, 36, 1, 72, 0, 4, 0, 36, 64, 2,132, 8, 0, 4, 72, 64, + 144, 96, 10, 34, 1,136, 20, 8, 1, 2, 8,211, 0, 32,192,144, + 36, 16, 0, 0, 1,176, 8, 10,160, 0,128, 0, 1, 9, 0, 32, + 82, 2, 37, 0, 36, 4, 2,132, 36, 16,146, 64, 2,160, 64, 0, + 34, 8, 17, 4, 8, 1, 34, 0, 66, 20, 0, 9,144, 33, 0, 48, + 108, 0, 0, 12, 0, 34, 9,144, 16, 40, 64, 0, 32,192, 32, 0, + 144, 0, 64, 1,130, 5, 18, 18, 9,193, 4, 97,128, 2, 40,129, + 36, 0, 73, 4, 8, 16,134, 41, 65,128, 33, 10, 48, 73,136,144, + 0, 65, 4, 41,129,128, 65, 9, 0, 64, 18, 16, 64, 0, 16, 64, + 72, 2, 5,128, 2, 33, 64, 32, 0, 88, 32, 96, 0,144, 72, 0, + 128, 40,192,128, 72, 0, 0, 68,128, 2, 0, 9, 6, 0, 18, 2, + 1, 0, 16, 8,131, 16, 69, 18, 0, 44, 8, 4, 68, 0, 32, 32, + 192, 16, 32, 1, 0, 5,200, 32, 4,152, 16, 8, 16, 0, 36, 2, + 22, 64,136, 0, 97,136, 18, 36,128,166, 0, 66, 0, 8, 16, 6, + 72, 64,160, 0, 80, 32, 4,129,164, 64, 24, 0, 8, 16,128, 1 +}; + +/* + * odd primes < 2^16 + * + * This table is useful to walk thru 16 bit odd primes to factor a 32 bit + * value. Use the pr_map[] array to quickly determine if a 16 bit odd + * value is prime. + * + * We end the list with the value 1. Thus, loops of the form: + * + * FULL isqr, n; + * unsigned short *tp; + * + * for (isqr=fsqrt(n), tp=prime; (*tp <= isqr) && (n % *tp); ++tp) { + * } + * + * will terminate because *tp == 1 and thus (n % *tp) == 0. To determine if + * a factor was found, one must: + * + * if (*tp <= isqr && *tp != 1) { + * *tp is a factor of n + * } + */ +CONST unsigned short prime[MAP_POPCNT+1] = { + 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, + 79, 83, 89, 97, 101, 103, 107, 109, 113, 127, 131, 137, 139, 149, 151, 157, + 163, 167, 173, 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, 233, 239, + 241, 251, 257, 263, 269, 271, 277, 281, 283, 293, 307, 311, 313, 317, 331, + 337, 347, 349, 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, 419, 421, + 431, 433, 439, 443, 449, 457, 461, 463, 467, 479, 487, 491, 499, 503, 509, + 521, 523, 541, 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, 607, 613, + 617, 619, 631, 641, 643, 647, 653, 659, 661, 673, 677, 683, 691, 701, 709, + 719, 727, 733, 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, 811, 821, + 823, 827, 829, 839, 853, 857, 859, 863, 877, 881, 883, 887, 907, 911, 919, + 929, 937, 941, 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, 1019, + 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, 1087, 1091, 1093, + 1097, 1103, 1109, 1117, 1123, 1129, 1151, 1153, 1163, 1171, 1181, 1187, + 1193, 1201, 1213, 1217, 1223, 1229, 1231, 1237, 1249, 1259, 1277, 1279, + 1283, 1289, 1291, 1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, + 1373, 1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, 1453, + 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, 1523, 1531, 1543, + 1549, 1553, 1559, 1567, 1571, 1579, 1583, 1597, 1601, 1607, 1609, 1613, + 1619, 1621, 1627, 1637, 1657, 1663, 1667, 1669, 1693, 1697, 1699, 1709, + 1721, 1723, 1733, 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, + 1811, 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, 1901, + 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, 1993, 1997, 1999, + 2003, 2011, 2017, 2027, 2029, 2039, 2053, 2063, 2069, 2081, 2083, 2087, + 2089, 2099, 2111, 2113, 2129, 2131, 2137, 2141, 2143, 2153, 2161, 2179, + 2203, 2207, 2213, 2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, + 2287, 2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, 2371, + 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, 2437, 2441, 2447, + 2459, 2467, 2473, 2477, 2503, 2521, 2531, 2539, 2543, 2549, 2551, 2557, + 2579, 2591, 2593, 2609, 2617, 2621, 2633, 2647, 2657, 2659, 2663, 2671, + 2677, 2683, 2687, 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, + 2741, 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, 2833, + 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, 2909, 2917, 2927, + 2939, 2953, 2957, 2963, 2969, 2971, 2999, 3001, 3011, 3019, 3023, 3037, + 3041, 3049, 3061, 3067, 3079, 3083, 3089, 3109, 3119, 3121, 3137, 3163, + 3167, 3169, 3181, 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, + 3257, 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, 3343, + 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, 3433, 3449, 3457, + 3461, 3463, 3467, 3469, 3491, 3499, 3511, 3517, 3527, 3529, 3533, 3539, + 3541, 3547, 3557, 3559, 3571, 3581, 3583, 3593, 3607, 3613, 3617, 3623, + 3631, 3637, 3643, 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, + 3727, 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, 3823, + 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, 3911, 3917, 3919, + 3923, 3929, 3931, 3943, 3947, 3967, 3989, 4001, 4003, 4007, 4013, 4019, + 4021, 4027, 4049, 4051, 4057, 4073, 4079, 4091, 4093, 4099, 4111, 4127, + 4129, 4133, 4139, 4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, + 4231, 4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, 4327, + 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409, 4421, 4423, 4441, + 4447, 4451, 4457, 4463, 4481, 4483, 4493, 4507, 4513, 4517, 4519, 4523, + 4547, 4549, 4561, 4567, 4583, 4591, 4597, 4603, 4621, 4637, 4639, 4643, + 4649, 4651, 4657, 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, + 4751, 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, 4861, + 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, 4943, 4951, 4957, + 4967, 4969, 4973, 4987, 4993, 4999, 5003, 5009, 5011, 5021, 5023, 5039, + 5051, 5059, 5077, 5081, 5087, 5099, 5101, 5107, 5113, 5119, 5147, 5153, + 5167, 5171, 5179, 5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, + 5279, 5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, 5393, + 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, 5449, 5471, 5477, + 5479, 5483, 5501, 5503, 5507, 5519, 5521, 5527, 5531, 5557, 5563, 5569, + 5573, 5581, 5591, 5623, 5639, 5641, 5647, 5651, 5653, 5657, 5659, 5669, + 5683, 5689, 5693, 5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, + 5791, 5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, 5861, + 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, 5953, 5981, 5987, + 6007, 6011, 6029, 6037, 6043, 6047, 6053, 6067, 6073, 6079, 6089, 6091, + 6101, 6113, 6121, 6131, 6133, 6143, 6151, 6163, 6173, 6197, 6199, 6203, + 6211, 6217, 6221, 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, + 6301, 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, 6373, + 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, 6481, 6491, 6521, + 6529, 6547, 6551, 6553, 6563, 6569, 6571, 6577, 6581, 6599, 6607, 6619, + 6637, 6653, 6659, 6661, 6673, 6679, 6689, 6691, 6701, 6703, 6709, 6719, + 6733, 6737, 6761, 6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, + 6833, 6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, 6947, + 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997, 7001, 7013, 7019, + 7027, 7039, 7043, 7057, 7069, 7079, 7103, 7109, 7121, 7127, 7129, 7151, + 7159, 7177, 7187, 7193, 7207, 7211, 7213, 7219, 7229, 7237, 7243, 7247, + 7253, 7283, 7297, 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, + 7411, 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, 7507, + 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, 7573, 7577, 7583, + 7589, 7591, 7603, 7607, 7621, 7639, 7643, 7649, 7669, 7673, 7681, 7687, + 7691, 7699, 7703, 7717, 7723, 7727, 7741, 7753, 7757, 7759, 7789, 7793, + 7817, 7823, 7829, 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, + 7919, 7927, 7933, 7937, 7949, 7951, 7963, 7993, 8009, 8011, 8017, 8039, + 8053, 8059, 8069, 8081, 8087, 8089, 8093, 8101, 8111, 8117, 8123, 8147, + 8161, 8167, 8171, 8179, 8191, 8209, 8219, 8221, 8231, 8233, 8237, 8243, + 8263, 8269, 8273, 8287, 8291, 8293, 8297, 8311, 8317, 8329, 8353, 8363, + 8369, 8377, 8387, 8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, + 8501, 8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, 8599, + 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, 8681, 8689, 8693, + 8699, 8707, 8713, 8719, 8731, 8737, 8741, 8747, 8753, 8761, 8779, 8783, + 8803, 8807, 8819, 8821, 8831, 8837, 8839, 8849, 8861, 8863, 8867, 8887, + 8893, 8923, 8929, 8933, 8941, 8951, 8963, 8969, 8971, 8999, 9001, 9007, + 9011, 9013, 9029, 9041, 9043, 9049, 9059, 9067, 9091, 9103, 9109, 9127, + 9133, 9137, 9151, 9157, 9161, 9173, 9181, 9187, 9199, 9203, 9209, 9221, + 9227, 9239, 9241, 9257, 9277, 9281, 9283, 9293, 9311, 9319, 9323, 9337, + 9341, 9343, 9349, 9371, 9377, 9391, 9397, 9403, 9413, 9419, 9421, 9431, + 9433, 9437, 9439, 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, + 9533, 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, 9643, + 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733, 9739, 9743, 9749, + 9767, 9769, 9781, 9787, 9791, 9803, 9811, 9817, 9829, 9833, 9839, 9851, + 9857, 9859, 9871, 9883, 9887, 9901, 9907, 9923, 9929, 9931, 9941, 9949, + 9967, 9973, 10007, 10009, 10037, 10039, 10061, 10067, 10069, 10079, 10091, + 10093, 10099, 10103, 10111, 10133, 10139, 10141, 10151, 10159, 10163, 10169, + 10177, 10181, 10193, 10211, 10223, 10243, 10247, 10253, 10259, 10267, 10271, + 10273, 10289, 10301, 10303, 10313, 10321, 10331, 10333, 10337, 10343, 10357, + 10369, 10391, 10399, 10427, 10429, 10433, 10453, 10457, 10459, 10463, 10477, + 10487, 10499, 10501, 10513, 10529, 10531, 10559, 10567, 10589, 10597, 10601, + 10607, 10613, 10627, 10631, 10639, 10651, 10657, 10663, 10667, 10687, 10691, + 10709, 10711, 10723, 10729, 10733, 10739, 10753, 10771, 10781, 10789, 10799, + 10831, 10837, 10847, 10853, 10859, 10861, 10867, 10883, 10889, 10891, 10903, + 10909, 10937, 10939, 10949, 10957, 10973, 10979, 10987, 10993, 11003, 11027, + 11047, 11057, 11059, 11069, 11071, 11083, 11087, 11093, 11113, 11117, 11119, + 11131, 11149, 11159, 11161, 11171, 11173, 11177, 11197, 11213, 11239, 11243, + 11251, 11257, 11261, 11273, 11279, 11287, 11299, 11311, 11317, 11321, 11329, + 11351, 11353, 11369, 11383, 11393, 11399, 11411, 11423, 11437, 11443, 11447, + 11467, 11471, 11483, 11489, 11491, 11497, 11503, 11519, 11527, 11549, 11551, + 11579, 11587, 11593, 11597, 11617, 11621, 11633, 11657, 11677, 11681, 11689, + 11699, 11701, 11717, 11719, 11731, 11743, 11777, 11779, 11783, 11789, 11801, + 11807, 11813, 11821, 11827, 11831, 11833, 11839, 11863, 11867, 11887, 11897, + 11903, 11909, 11923, 11927, 11933, 11939, 11941, 11953, 11959, 11969, 11971, + 11981, 11987, 12007, 12011, 12037, 12041, 12043, 12049, 12071, 12073, 12097, + 12101, 12107, 12109, 12113, 12119, 12143, 12149, 12157, 12161, 12163, 12197, + 12203, 12211, 12227, 12239, 12241, 12251, 12253, 12263, 12269, 12277, 12281, + 12289, 12301, 12323, 12329, 12343, 12347, 12373, 12377, 12379, 12391, 12401, + 12409, 12413, 12421, 12433, 12437, 12451, 12457, 12473, 12479, 12487, 12491, + 12497, 12503, 12511, 12517, 12527, 12539, 12541, 12547, 12553, 12569, 12577, + 12583, 12589, 12601, 12611, 12613, 12619, 12637, 12641, 12647, 12653, 12659, + 12671, 12689, 12697, 12703, 12713, 12721, 12739, 12743, 12757, 12763, 12781, + 12791, 12799, 12809, 12821, 12823, 12829, 12841, 12853, 12889, 12893, 12899, + 12907, 12911, 12917, 12919, 12923, 12941, 12953, 12959, 12967, 12973, 12979, + 12983, 13001, 13003, 13007, 13009, 13033, 13037, 13043, 13049, 13063, 13093, + 13099, 13103, 13109, 13121, 13127, 13147, 13151, 13159, 13163, 13171, 13177, + 13183, 13187, 13217, 13219, 13229, 13241, 13249, 13259, 13267, 13291, 13297, + 13309, 13313, 13327, 13331, 13337, 13339, 13367, 13381, 13397, 13399, 13411, + 13417, 13421, 13441, 13451, 13457, 13463, 13469, 13477, 13487, 13499, 13513, + 13523, 13537, 13553, 13567, 13577, 13591, 13597, 13613, 13619, 13627, 13633, + 13649, 13669, 13679, 13681, 13687, 13691, 13693, 13697, 13709, 13711, 13721, + 13723, 13729, 13751, 13757, 13759, 13763, 13781, 13789, 13799, 13807, 13829, + 13831, 13841, 13859, 13873, 13877, 13879, 13883, 13901, 13903, 13907, 13913, + 13921, 13931, 13933, 13963, 13967, 13997, 13999, 14009, 14011, 14029, 14033, + 14051, 14057, 14071, 14081, 14083, 14087, 14107, 14143, 14149, 14153, 14159, + 14173, 14177, 14197, 14207, 14221, 14243, 14249, 14251, 14281, 14293, 14303, + 14321, 14323, 14327, 14341, 14347, 14369, 14387, 14389, 14401, 14407, 14411, + 14419, 14423, 14431, 14437, 14447, 14449, 14461, 14479, 14489, 14503, 14519, + 14533, 14537, 14543, 14549, 14551, 14557, 14561, 14563, 14591, 14593, 14621, + 14627, 14629, 14633, 14639, 14653, 14657, 14669, 14683, 14699, 14713, 14717, + 14723, 14731, 14737, 14741, 14747, 14753, 14759, 14767, 14771, 14779, 14783, + 14797, 14813, 14821, 14827, 14831, 14843, 14851, 14867, 14869, 14879, 14887, + 14891, 14897, 14923, 14929, 14939, 14947, 14951, 14957, 14969, 14983, 15013, + 15017, 15031, 15053, 15061, 15073, 15077, 15083, 15091, 15101, 15107, 15121, + 15131, 15137, 15139, 15149, 15161, 15173, 15187, 15193, 15199, 15217, 15227, + 15233, 15241, 15259, 15263, 15269, 15271, 15277, 15287, 15289, 15299, 15307, + 15313, 15319, 15329, 15331, 15349, 15359, 15361, 15373, 15377, 15383, 15391, + 15401, 15413, 15427, 15439, 15443, 15451, 15461, 15467, 15473, 15493, 15497, + 15511, 15527, 15541, 15551, 15559, 15569, 15581, 15583, 15601, 15607, 15619, + 15629, 15641, 15643, 15647, 15649, 15661, 15667, 15671, 15679, 15683, 15727, + 15731, 15733, 15737, 15739, 15749, 15761, 15767, 15773, 15787, 15791, 15797, + 15803, 15809, 15817, 15823, 15859, 15877, 15881, 15887, 15889, 15901, 15907, + 15913, 15919, 15923, 15937, 15959, 15971, 15973, 15991, 16001, 16007, 16033, + 16057, 16061, 16063, 16067, 16069, 16073, 16087, 16091, 16097, 16103, 16111, + 16127, 16139, 16141, 16183, 16187, 16189, 16193, 16217, 16223, 16229, 16231, + 16249, 16253, 16267, 16273, 16301, 16319, 16333, 16339, 16349, 16361, 16363, + 16369, 16381, 16411, 16417, 16421, 16427, 16433, 16447, 16451, 16453, 16477, + 16481, 16487, 16493, 16519, 16529, 16547, 16553, 16561, 16567, 16573, 16603, + 16607, 16619, 16631, 16633, 16649, 16651, 16657, 16661, 16673, 16691, 16693, + 16699, 16703, 16729, 16741, 16747, 16759, 16763, 16787, 16811, 16823, 16829, + 16831, 16843, 16871, 16879, 16883, 16889, 16901, 16903, 16921, 16927, 16931, + 16937, 16943, 16963, 16979, 16981, 16987, 16993, 17011, 17021, 17027, 17029, + 17033, 17041, 17047, 17053, 17077, 17093, 17099, 17107, 17117, 17123, 17137, + 17159, 17167, 17183, 17189, 17191, 17203, 17207, 17209, 17231, 17239, 17257, + 17291, 17293, 17299, 17317, 17321, 17327, 17333, 17341, 17351, 17359, 17377, + 17383, 17387, 17389, 17393, 17401, 17417, 17419, 17431, 17443, 17449, 17467, + 17471, 17477, 17483, 17489, 17491, 17497, 17509, 17519, 17539, 17551, 17569, + 17573, 17579, 17581, 17597, 17599, 17609, 17623, 17627, 17657, 17659, 17669, + 17681, 17683, 17707, 17713, 17729, 17737, 17747, 17749, 17761, 17783, 17789, + 17791, 17807, 17827, 17837, 17839, 17851, 17863, 17881, 17891, 17903, 17909, + 17911, 17921, 17923, 17929, 17939, 17957, 17959, 17971, 17977, 17981, 17987, + 17989, 18013, 18041, 18043, 18047, 18049, 18059, 18061, 18077, 18089, 18097, + 18119, 18121, 18127, 18131, 18133, 18143, 18149, 18169, 18181, 18191, 18199, + 18211, 18217, 18223, 18229, 18233, 18251, 18253, 18257, 18269, 18287, 18289, + 18301, 18307, 18311, 18313, 18329, 18341, 18353, 18367, 18371, 18379, 18397, + 18401, 18413, 18427, 18433, 18439, 18443, 18451, 18457, 18461, 18481, 18493, + 18503, 18517, 18521, 18523, 18539, 18541, 18553, 18583, 18587, 18593, 18617, + 18637, 18661, 18671, 18679, 18691, 18701, 18713, 18719, 18731, 18743, 18749, + 18757, 18773, 18787, 18793, 18797, 18803, 18839, 18859, 18869, 18899, 18911, + 18913, 18917, 18919, 18947, 18959, 18973, 18979, 19001, 19009, 19013, 19031, + 19037, 19051, 19069, 19073, 19079, 19081, 19087, 19121, 19139, 19141, 19157, + 19163, 19181, 19183, 19207, 19211, 19213, 19219, 19231, 19237, 19249, 19259, + 19267, 19273, 19289, 19301, 19309, 19319, 19333, 19373, 19379, 19381, 19387, + 19391, 19403, 19417, 19421, 19423, 19427, 19429, 19433, 19441, 19447, 19457, + 19463, 19469, 19471, 19477, 19483, 19489, 19501, 19507, 19531, 19541, 19543, + 19553, 19559, 19571, 19577, 19583, 19597, 19603, 19609, 19661, 19681, 19687, + 19697, 19699, 19709, 19717, 19727, 19739, 19751, 19753, 19759, 19763, 19777, + 19793, 19801, 19813, 19819, 19841, 19843, 19853, 19861, 19867, 19889, 19891, + 19913, 19919, 19927, 19937, 19949, 19961, 19963, 19973, 19979, 19991, 19993, + 19997, 20011, 20021, 20023, 20029, 20047, 20051, 20063, 20071, 20089, 20101, + 20107, 20113, 20117, 20123, 20129, 20143, 20147, 20149, 20161, 20173, 20177, + 20183, 20201, 20219, 20231, 20233, 20249, 20261, 20269, 20287, 20297, 20323, + 20327, 20333, 20341, 20347, 20353, 20357, 20359, 20369, 20389, 20393, 20399, + 20407, 20411, 20431, 20441, 20443, 20477, 20479, 20483, 20507, 20509, 20521, + 20533, 20543, 20549, 20551, 20563, 20593, 20599, 20611, 20627, 20639, 20641, + 20663, 20681, 20693, 20707, 20717, 20719, 20731, 20743, 20747, 20749, 20753, + 20759, 20771, 20773, 20789, 20807, 20809, 20849, 20857, 20873, 20879, 20887, + 20897, 20899, 20903, 20921, 20929, 20939, 20947, 20959, 20963, 20981, 20983, + 21001, 21011, 21013, 21017, 21019, 21023, 21031, 21059, 21061, 21067, 21089, + 21101, 21107, 21121, 21139, 21143, 21149, 21157, 21163, 21169, 21179, 21187, + 21191, 21193, 21211, 21221, 21227, 21247, 21269, 21277, 21283, 21313, 21317, + 21319, 21323, 21341, 21347, 21377, 21379, 21383, 21391, 21397, 21401, 21407, + 21419, 21433, 21467, 21481, 21487, 21491, 21493, 21499, 21503, 21517, 21521, + 21523, 21529, 21557, 21559, 21563, 21569, 21577, 21587, 21589, 21599, 21601, + 21611, 21613, 21617, 21647, 21649, 21661, 21673, 21683, 21701, 21713, 21727, + 21737, 21739, 21751, 21757, 21767, 21773, 21787, 21799, 21803, 21817, 21821, + 21839, 21841, 21851, 21859, 21863, 21871, 21881, 21893, 21911, 21929, 21937, + 21943, 21961, 21977, 21991, 21997, 22003, 22013, 22027, 22031, 22037, 22039, + 22051, 22063, 22067, 22073, 22079, 22091, 22093, 22109, 22111, 22123, 22129, + 22133, 22147, 22153, 22157, 22159, 22171, 22189, 22193, 22229, 22247, 22259, + 22271, 22273, 22277, 22279, 22283, 22291, 22303, 22307, 22343, 22349, 22367, + 22369, 22381, 22391, 22397, 22409, 22433, 22441, 22447, 22453, 22469, 22481, + 22483, 22501, 22511, 22531, 22541, 22543, 22549, 22567, 22571, 22573, 22613, + 22619, 22621, 22637, 22639, 22643, 22651, 22669, 22679, 22691, 22697, 22699, + 22709, 22717, 22721, 22727, 22739, 22741, 22751, 22769, 22777, 22783, 22787, + 22807, 22811, 22817, 22853, 22859, 22861, 22871, 22877, 22901, 22907, 22921, + 22937, 22943, 22961, 22963, 22973, 22993, 23003, 23011, 23017, 23021, 23027, + 23029, 23039, 23041, 23053, 23057, 23059, 23063, 23071, 23081, 23087, 23099, + 23117, 23131, 23143, 23159, 23167, 23173, 23189, 23197, 23201, 23203, 23209, + 23227, 23251, 23269, 23279, 23291, 23293, 23297, 23311, 23321, 23327, 23333, + 23339, 23357, 23369, 23371, 23399, 23417, 23431, 23447, 23459, 23473, 23497, + 23509, 23531, 23537, 23539, 23549, 23557, 23561, 23563, 23567, 23581, 23593, + 23599, 23603, 23609, 23623, 23627, 23629, 23633, 23663, 23669, 23671, 23677, + 23687, 23689, 23719, 23741, 23743, 23747, 23753, 23761, 23767, 23773, 23789, + 23801, 23813, 23819, 23827, 23831, 23833, 23857, 23869, 23873, 23879, 23887, + 23893, 23899, 23909, 23911, 23917, 23929, 23957, 23971, 23977, 23981, 23993, + 24001, 24007, 24019, 24023, 24029, 24043, 24049, 24061, 24071, 24077, 24083, + 24091, 24097, 24103, 24107, 24109, 24113, 24121, 24133, 24137, 24151, 24169, + 24179, 24181, 24197, 24203, 24223, 24229, 24239, 24247, 24251, 24281, 24317, + 24329, 24337, 24359, 24371, 24373, 24379, 24391, 24407, 24413, 24419, 24421, + 24439, 24443, 24469, 24473, 24481, 24499, 24509, 24517, 24527, 24533, 24547, + 24551, 24571, 24593, 24611, 24623, 24631, 24659, 24671, 24677, 24683, 24691, + 24697, 24709, 24733, 24749, 24763, 24767, 24781, 24793, 24799, 24809, 24821, + 24841, 24847, 24851, 24859, 24877, 24889, 24907, 24917, 24919, 24923, 24943, + 24953, 24967, 24971, 24977, 24979, 24989, 25013, 25031, 25033, 25037, 25057, + 25073, 25087, 25097, 25111, 25117, 25121, 25127, 25147, 25153, 25163, 25169, + 25171, 25183, 25189, 25219, 25229, 25237, 25243, 25247, 25253, 25261, 25301, + 25303, 25307, 25309, 25321, 25339, 25343, 25349, 25357, 25367, 25373, 25391, + 25409, 25411, 25423, 25439, 25447, 25453, 25457, 25463, 25469, 25471, 25523, + 25537, 25541, 25561, 25577, 25579, 25583, 25589, 25601, 25603, 25609, 25621, + 25633, 25639, 25643, 25657, 25667, 25673, 25679, 25693, 25703, 25717, 25733, + 25741, 25747, 25759, 25763, 25771, 25793, 25799, 25801, 25819, 25841, 25847, + 25849, 25867, 25873, 25889, 25903, 25913, 25919, 25931, 25933, 25939, 25943, + 25951, 25969, 25981, 25997, 25999, 26003, 26017, 26021, 26029, 26041, 26053, + 26083, 26099, 26107, 26111, 26113, 26119, 26141, 26153, 26161, 26171, 26177, + 26183, 26189, 26203, 26209, 26227, 26237, 26249, 26251, 26261, 26263, 26267, + 26293, 26297, 26309, 26317, 26321, 26339, 26347, 26357, 26371, 26387, 26393, + 26399, 26407, 26417, 26423, 26431, 26437, 26449, 26459, 26479, 26489, 26497, + 26501, 26513, 26539, 26557, 26561, 26573, 26591, 26597, 26627, 26633, 26641, + 26647, 26669, 26681, 26683, 26687, 26693, 26699, 26701, 26711, 26713, 26717, + 26723, 26729, 26731, 26737, 26759, 26777, 26783, 26801, 26813, 26821, 26833, + 26839, 26849, 26861, 26863, 26879, 26881, 26891, 26893, 26903, 26921, 26927, + 26947, 26951, 26953, 26959, 26981, 26987, 26993, 27011, 27017, 27031, 27043, + 27059, 27061, 27067, 27073, 27077, 27091, 27103, 27107, 27109, 27127, 27143, + 27179, 27191, 27197, 27211, 27239, 27241, 27253, 27259, 27271, 27277, 27281, + 27283, 27299, 27329, 27337, 27361, 27367, 27397, 27407, 27409, 27427, 27431, + 27437, 27449, 27457, 27479, 27481, 27487, 27509, 27527, 27529, 27539, 27541, + 27551, 27581, 27583, 27611, 27617, 27631, 27647, 27653, 27673, 27689, 27691, + 27697, 27701, 27733, 27737, 27739, 27743, 27749, 27751, 27763, 27767, 27773, + 27779, 27791, 27793, 27799, 27803, 27809, 27817, 27823, 27827, 27847, 27851, + 27883, 27893, 27901, 27917, 27919, 27941, 27943, 27947, 27953, 27961, 27967, + 27983, 27997, 28001, 28019, 28027, 28031, 28051, 28057, 28069, 28081, 28087, + 28097, 28099, 28109, 28111, 28123, 28151, 28163, 28181, 28183, 28201, 28211, + 28219, 28229, 28277, 28279, 28283, 28289, 28297, 28307, 28309, 28319, 28349, + 28351, 28387, 28393, 28403, 28409, 28411, 28429, 28433, 28439, 28447, 28463, + 28477, 28493, 28499, 28513, 28517, 28537, 28541, 28547, 28549, 28559, 28571, + 28573, 28579, 28591, 28597, 28603, 28607, 28619, 28621, 28627, 28631, 28643, + 28649, 28657, 28661, 28663, 28669, 28687, 28697, 28703, 28711, 28723, 28729, + 28751, 28753, 28759, 28771, 28789, 28793, 28807, 28813, 28817, 28837, 28843, + 28859, 28867, 28871, 28879, 28901, 28909, 28921, 28927, 28933, 28949, 28961, + 28979, 29009, 29017, 29021, 29023, 29027, 29033, 29059, 29063, 29077, 29101, + 29123, 29129, 29131, 29137, 29147, 29153, 29167, 29173, 29179, 29191, 29201, + 29207, 29209, 29221, 29231, 29243, 29251, 29269, 29287, 29297, 29303, 29311, + 29327, 29333, 29339, 29347, 29363, 29383, 29387, 29389, 29399, 29401, 29411, + 29423, 29429, 29437, 29443, 29453, 29473, 29483, 29501, 29527, 29531, 29537, + 29567, 29569, 29573, 29581, 29587, 29599, 29611, 29629, 29633, 29641, 29663, + 29669, 29671, 29683, 29717, 29723, 29741, 29753, 29759, 29761, 29789, 29803, + 29819, 29833, 29837, 29851, 29863, 29867, 29873, 29879, 29881, 29917, 29921, + 29927, 29947, 29959, 29983, 29989, 30011, 30013, 30029, 30047, 30059, 30071, + 30089, 30091, 30097, 30103, 30109, 30113, 30119, 30133, 30137, 30139, 30161, + 30169, 30181, 30187, 30197, 30203, 30211, 30223, 30241, 30253, 30259, 30269, + 30271, 30293, 30307, 30313, 30319, 30323, 30341, 30347, 30367, 30389, 30391, + 30403, 30427, 30431, 30449, 30467, 30469, 30491, 30493, 30497, 30509, 30517, + 30529, 30539, 30553, 30557, 30559, 30577, 30593, 30631, 30637, 30643, 30649, + 30661, 30671, 30677, 30689, 30697, 30703, 30707, 30713, 30727, 30757, 30763, + 30773, 30781, 30803, 30809, 30817, 30829, 30839, 30841, 30851, 30853, 30859, + 30869, 30871, 30881, 30893, 30911, 30931, 30937, 30941, 30949, 30971, 30977, + 30983, 31013, 31019, 31033, 31039, 31051, 31063, 31069, 31079, 31081, 31091, + 31121, 31123, 31139, 31147, 31151, 31153, 31159, 31177, 31181, 31183, 31189, + 31193, 31219, 31223, 31231, 31237, 31247, 31249, 31253, 31259, 31267, 31271, + 31277, 31307, 31319, 31321, 31327, 31333, 31337, 31357, 31379, 31387, 31391, + 31393, 31397, 31469, 31477, 31481, 31489, 31511, 31513, 31517, 31531, 31541, + 31543, 31547, 31567, 31573, 31583, 31601, 31607, 31627, 31643, 31649, 31657, + 31663, 31667, 31687, 31699, 31721, 31723, 31727, 31729, 31741, 31751, 31769, + 31771, 31793, 31799, 31817, 31847, 31849, 31859, 31873, 31883, 31891, 31907, + 31957, 31963, 31973, 31981, 31991, 32003, 32009, 32027, 32029, 32051, 32057, + 32059, 32063, 32069, 32077, 32083, 32089, 32099, 32117, 32119, 32141, 32143, + 32159, 32173, 32183, 32189, 32191, 32203, 32213, 32233, 32237, 32251, 32257, + 32261, 32297, 32299, 32303, 32309, 32321, 32323, 32327, 32341, 32353, 32359, + 32363, 32369, 32371, 32377, 32381, 32401, 32411, 32413, 32423, 32429, 32441, + 32443, 32467, 32479, 32491, 32497, 32503, 32507, 32531, 32533, 32537, 32561, + 32563, 32569, 32573, 32579, 32587, 32603, 32609, 32611, 32621, 32633, 32647, + 32653, 32687, 32693, 32707, 32713, 32717, 32719, 32749, 32771, 32779, 32783, + 32789, 32797, 32801, 32803, 32831, 32833, 32839, 32843, 32869, 32887, 32909, + 32911, 32917, 32933, 32939, 32941, 32957, 32969, 32971, 32983, 32987, 32993, + 32999, 33013, 33023, 33029, 33037, 33049, 33053, 33071, 33073, 33083, 33091, + 33107, 33113, 33119, 33149, 33151, 33161, 33179, 33181, 33191, 33199, 33203, + 33211, 33223, 33247, 33287, 33289, 33301, 33311, 33317, 33329, 33331, 33343, + 33347, 33349, 33353, 33359, 33377, 33391, 33403, 33409, 33413, 33427, 33457, + 33461, 33469, 33479, 33487, 33493, 33503, 33521, 33529, 33533, 33547, 33563, + 33569, 33577, 33581, 33587, 33589, 33599, 33601, 33613, 33617, 33619, 33623, + 33629, 33637, 33641, 33647, 33679, 33703, 33713, 33721, 33739, 33749, 33751, + 33757, 33767, 33769, 33773, 33791, 33797, 33809, 33811, 33827, 33829, 33851, + 33857, 33863, 33871, 33889, 33893, 33911, 33923, 33931, 33937, 33941, 33961, + 33967, 33997, 34019, 34031, 34033, 34039, 34057, 34061, 34123, 34127, 34129, + 34141, 34147, 34157, 34159, 34171, 34183, 34211, 34213, 34217, 34231, 34253, + 34259, 34261, 34267, 34273, 34283, 34297, 34301, 34303, 34313, 34319, 34327, + 34337, 34351, 34361, 34367, 34369, 34381, 34403, 34421, 34429, 34439, 34457, + 34469, 34471, 34483, 34487, 34499, 34501, 34511, 34513, 34519, 34537, 34543, + 34549, 34583, 34589, 34591, 34603, 34607, 34613, 34631, 34649, 34651, 34667, + 34673, 34679, 34687, 34693, 34703, 34721, 34729, 34739, 34747, 34757, 34759, + 34763, 34781, 34807, 34819, 34841, 34843, 34847, 34849, 34871, 34877, 34883, + 34897, 34913, 34919, 34939, 34949, 34961, 34963, 34981, 35023, 35027, 35051, + 35053, 35059, 35069, 35081, 35083, 35089, 35099, 35107, 35111, 35117, 35129, + 35141, 35149, 35153, 35159, 35171, 35201, 35221, 35227, 35251, 35257, 35267, + 35279, 35281, 35291, 35311, 35317, 35323, 35327, 35339, 35353, 35363, 35381, + 35393, 35401, 35407, 35419, 35423, 35437, 35447, 35449, 35461, 35491, 35507, + 35509, 35521, 35527, 35531, 35533, 35537, 35543, 35569, 35573, 35591, 35593, + 35597, 35603, 35617, 35671, 35677, 35729, 35731, 35747, 35753, 35759, 35771, + 35797, 35801, 35803, 35809, 35831, 35837, 35839, 35851, 35863, 35869, 35879, + 35897, 35899, 35911, 35923, 35933, 35951, 35963, 35969, 35977, 35983, 35993, + 35999, 36007, 36011, 36013, 36017, 36037, 36061, 36067, 36073, 36083, 36097, + 36107, 36109, 36131, 36137, 36151, 36161, 36187, 36191, 36209, 36217, 36229, + 36241, 36251, 36263, 36269, 36277, 36293, 36299, 36307, 36313, 36319, 36341, + 36343, 36353, 36373, 36383, 36389, 36433, 36451, 36457, 36467, 36469, 36473, + 36479, 36493, 36497, 36523, 36527, 36529, 36541, 36551, 36559, 36563, 36571, + 36583, 36587, 36599, 36607, 36629, 36637, 36643, 36653, 36671, 36677, 36683, + 36691, 36697, 36709, 36713, 36721, 36739, 36749, 36761, 36767, 36779, 36781, + 36787, 36791, 36793, 36809, 36821, 36833, 36847, 36857, 36871, 36877, 36887, + 36899, 36901, 36913, 36919, 36923, 36929, 36931, 36943, 36947, 36973, 36979, + 36997, 37003, 37013, 37019, 37021, 37039, 37049, 37057, 37061, 37087, 37097, + 37117, 37123, 37139, 37159, 37171, 37181, 37189, 37199, 37201, 37217, 37223, + 37243, 37253, 37273, 37277, 37307, 37309, 37313, 37321, 37337, 37339, 37357, + 37361, 37363, 37369, 37379, 37397, 37409, 37423, 37441, 37447, 37463, 37483, + 37489, 37493, 37501, 37507, 37511, 37517, 37529, 37537, 37547, 37549, 37561, + 37567, 37571, 37573, 37579, 37589, 37591, 37607, 37619, 37633, 37643, 37649, + 37657, 37663, 37691, 37693, 37699, 37717, 37747, 37781, 37783, 37799, 37811, + 37813, 37831, 37847, 37853, 37861, 37871, 37879, 37889, 37897, 37907, 37951, + 37957, 37963, 37967, 37987, 37991, 37993, 37997, 38011, 38039, 38047, 38053, + 38069, 38083, 38113, 38119, 38149, 38153, 38167, 38177, 38183, 38189, 38197, + 38201, 38219, 38231, 38237, 38239, 38261, 38273, 38281, 38287, 38299, 38303, + 38317, 38321, 38327, 38329, 38333, 38351, 38371, 38377, 38393, 38431, 38447, + 38449, 38453, 38459, 38461, 38501, 38543, 38557, 38561, 38567, 38569, 38593, + 38603, 38609, 38611, 38629, 38639, 38651, 38653, 38669, 38671, 38677, 38693, + 38699, 38707, 38711, 38713, 38723, 38729, 38737, 38747, 38749, 38767, 38783, + 38791, 38803, 38821, 38833, 38839, 38851, 38861, 38867, 38873, 38891, 38903, + 38917, 38921, 38923, 38933, 38953, 38959, 38971, 38977, 38993, 39019, 39023, + 39041, 39043, 39047, 39079, 39089, 39097, 39103, 39107, 39113, 39119, 39133, + 39139, 39157, 39161, 39163, 39181, 39191, 39199, 39209, 39217, 39227, 39229, + 39233, 39239, 39241, 39251, 39293, 39301, 39313, 39317, 39323, 39341, 39343, + 39359, 39367, 39371, 39373, 39383, 39397, 39409, 39419, 39439, 39443, 39451, + 39461, 39499, 39503, 39509, 39511, 39521, 39541, 39551, 39563, 39569, 39581, + 39607, 39619, 39623, 39631, 39659, 39667, 39671, 39679, 39703, 39709, 39719, + 39727, 39733, 39749, 39761, 39769, 39779, 39791, 39799, 39821, 39827, 39829, + 39839, 39841, 39847, 39857, 39863, 39869, 39877, 39883, 39887, 39901, 39929, + 39937, 39953, 39971, 39979, 39983, 39989, 40009, 40013, 40031, 40037, 40039, + 40063, 40087, 40093, 40099, 40111, 40123, 40127, 40129, 40151, 40153, 40163, + 40169, 40177, 40189, 40193, 40213, 40231, 40237, 40241, 40253, 40277, 40283, + 40289, 40343, 40351, 40357, 40361, 40387, 40423, 40427, 40429, 40433, 40459, + 40471, 40483, 40487, 40493, 40499, 40507, 40519, 40529, 40531, 40543, 40559, + 40577, 40583, 40591, 40597, 40609, 40627, 40637, 40639, 40693, 40697, 40699, + 40709, 40739, 40751, 40759, 40763, 40771, 40787, 40801, 40813, 40819, 40823, + 40829, 40841, 40847, 40849, 40853, 40867, 40879, 40883, 40897, 40903, 40927, + 40933, 40939, 40949, 40961, 40973, 40993, 41011, 41017, 41023, 41039, 41047, + 41051, 41057, 41077, 41081, 41113, 41117, 41131, 41141, 41143, 41149, 41161, + 41177, 41179, 41183, 41189, 41201, 41203, 41213, 41221, 41227, 41231, 41233, + 41243, 41257, 41263, 41269, 41281, 41299, 41333, 41341, 41351, 41357, 41381, + 41387, 41389, 41399, 41411, 41413, 41443, 41453, 41467, 41479, 41491, 41507, + 41513, 41519, 41521, 41539, 41543, 41549, 41579, 41593, 41597, 41603, 41609, + 41611, 41617, 41621, 41627, 41641, 41647, 41651, 41659, 41669, 41681, 41687, + 41719, 41729, 41737, 41759, 41761, 41771, 41777, 41801, 41809, 41813, 41843, + 41849, 41851, 41863, 41879, 41887, 41893, 41897, 41903, 41911, 41927, 41941, + 41947, 41953, 41957, 41959, 41969, 41981, 41983, 41999, 42013, 42017, 42019, + 42023, 42043, 42061, 42071, 42073, 42083, 42089, 42101, 42131, 42139, 42157, + 42169, 42179, 42181, 42187, 42193, 42197, 42209, 42221, 42223, 42227, 42239, + 42257, 42281, 42283, 42293, 42299, 42307, 42323, 42331, 42337, 42349, 42359, + 42373, 42379, 42391, 42397, 42403, 42407, 42409, 42433, 42437, 42443, 42451, + 42457, 42461, 42463, 42467, 42473, 42487, 42491, 42499, 42509, 42533, 42557, + 42569, 42571, 42577, 42589, 42611, 42641, 42643, 42649, 42667, 42677, 42683, + 42689, 42697, 42701, 42703, 42709, 42719, 42727, 42737, 42743, 42751, 42767, + 42773, 42787, 42793, 42797, 42821, 42829, 42839, 42841, 42853, 42859, 42863, + 42899, 42901, 42923, 42929, 42937, 42943, 42953, 42961, 42967, 42979, 42989, + 43003, 43013, 43019, 43037, 43049, 43051, 43063, 43067, 43093, 43103, 43117, + 43133, 43151, 43159, 43177, 43189, 43201, 43207, 43223, 43237, 43261, 43271, + 43283, 43291, 43313, 43319, 43321, 43331, 43391, 43397, 43399, 43403, 43411, + 43427, 43441, 43451, 43457, 43481, 43487, 43499, 43517, 43541, 43543, 43573, + 43577, 43579, 43591, 43597, 43607, 43609, 43613, 43627, 43633, 43649, 43651, + 43661, 43669, 43691, 43711, 43717, 43721, 43753, 43759, 43777, 43781, 43783, + 43787, 43789, 43793, 43801, 43853, 43867, 43889, 43891, 43913, 43933, 43943, + 43951, 43961, 43963, 43969, 43973, 43987, 43991, 43997, 44017, 44021, 44027, + 44029, 44041, 44053, 44059, 44071, 44087, 44089, 44101, 44111, 44119, 44123, + 44129, 44131, 44159, 44171, 44179, 44189, 44201, 44203, 44207, 44221, 44249, + 44257, 44263, 44267, 44269, 44273, 44279, 44281, 44293, 44351, 44357, 44371, + 44381, 44383, 44389, 44417, 44449, 44453, 44483, 44491, 44497, 44501, 44507, + 44519, 44531, 44533, 44537, 44543, 44549, 44563, 44579, 44587, 44617, 44621, + 44623, 44633, 44641, 44647, 44651, 44657, 44683, 44687, 44699, 44701, 44711, + 44729, 44741, 44753, 44771, 44773, 44777, 44789, 44797, 44809, 44819, 44839, + 44843, 44851, 44867, 44879, 44887, 44893, 44909, 44917, 44927, 44939, 44953, + 44959, 44963, 44971, 44983, 44987, 45007, 45013, 45053, 45061, 45077, 45083, + 45119, 45121, 45127, 45131, 45137, 45139, 45161, 45179, 45181, 45191, 45197, + 45233, 45247, 45259, 45263, 45281, 45289, 45293, 45307, 45317, 45319, 45329, + 45337, 45341, 45343, 45361, 45377, 45389, 45403, 45413, 45427, 45433, 45439, + 45481, 45491, 45497, 45503, 45523, 45533, 45541, 45553, 45557, 45569, 45587, + 45589, 45599, 45613, 45631, 45641, 45659, 45667, 45673, 45677, 45691, 45697, + 45707, 45737, 45751, 45757, 45763, 45767, 45779, 45817, 45821, 45823, 45827, + 45833, 45841, 45853, 45863, 45869, 45887, 45893, 45943, 45949, 45953, 45959, + 45971, 45979, 45989, 46021, 46027, 46049, 46051, 46061, 46073, 46091, 46093, + 46099, 46103, 46133, 46141, 46147, 46153, 46171, 46181, 46183, 46187, 46199, + 46219, 46229, 46237, 46261, 46271, 46273, 46279, 46301, 46307, 46309, 46327, + 46337, 46349, 46351, 46381, 46399, 46411, 46439, 46441, 46447, 46451, 46457, + 46471, 46477, 46489, 46499, 46507, 46511, 46523, 46549, 46559, 46567, 46573, + 46589, 46591, 46601, 46619, 46633, 46639, 46643, 46649, 46663, 46679, 46681, + 46687, 46691, 46703, 46723, 46727, 46747, 46751, 46757, 46769, 46771, 46807, + 46811, 46817, 46819, 46829, 46831, 46853, 46861, 46867, 46877, 46889, 46901, + 46919, 46933, 46957, 46993, 46997, 47017, 47041, 47051, 47057, 47059, 47087, + 47093, 47111, 47119, 47123, 47129, 47137, 47143, 47147, 47149, 47161, 47189, + 47207, 47221, 47237, 47251, 47269, 47279, 47287, 47293, 47297, 47303, 47309, + 47317, 47339, 47351, 47353, 47363, 47381, 47387, 47389, 47407, 47417, 47419, + 47431, 47441, 47459, 47491, 47497, 47501, 47507, 47513, 47521, 47527, 47533, + 47543, 47563, 47569, 47581, 47591, 47599, 47609, 47623, 47629, 47639, 47653, + 47657, 47659, 47681, 47699, 47701, 47711, 47713, 47717, 47737, 47741, 47743, + 47777, 47779, 47791, 47797, 47807, 47809, 47819, 47837, 47843, 47857, 47869, + 47881, 47903, 47911, 47917, 47933, 47939, 47947, 47951, 47963, 47969, 47977, + 47981, 48017, 48023, 48029, 48049, 48073, 48079, 48091, 48109, 48119, 48121, + 48131, 48157, 48163, 48179, 48187, 48193, 48197, 48221, 48239, 48247, 48259, + 48271, 48281, 48299, 48311, 48313, 48337, 48341, 48353, 48371, 48383, 48397, + 48407, 48409, 48413, 48437, 48449, 48463, 48473, 48479, 48481, 48487, 48491, + 48497, 48523, 48527, 48533, 48539, 48541, 48563, 48571, 48589, 48593, 48611, + 48619, 48623, 48647, 48649, 48661, 48673, 48677, 48679, 48731, 48733, 48751, + 48757, 48761, 48767, 48779, 48781, 48787, 48799, 48809, 48817, 48821, 48823, + 48847, 48857, 48859, 48869, 48871, 48883, 48889, 48907, 48947, 48953, 48973, + 48989, 48991, 49003, 49009, 49019, 49031, 49033, 49037, 49043, 49057, 49069, + 49081, 49103, 49109, 49117, 49121, 49123, 49139, 49157, 49169, 49171, 49177, + 49193, 49199, 49201, 49207, 49211, 49223, 49253, 49261, 49277, 49279, 49297, + 49307, 49331, 49333, 49339, 49363, 49367, 49369, 49391, 49393, 49409, 49411, + 49417, 49429, 49433, 49451, 49459, 49463, 49477, 49481, 49499, 49523, 49529, + 49531, 49537, 49547, 49549, 49559, 49597, 49603, 49613, 49627, 49633, 49639, + 49663, 49667, 49669, 49681, 49697, 49711, 49727, 49739, 49741, 49747, 49757, + 49783, 49787, 49789, 49801, 49807, 49811, 49823, 49831, 49843, 49853, 49871, + 49877, 49891, 49919, 49921, 49927, 49937, 49939, 49943, 49957, 49991, 49993, + 49999, 50021, 50023, 50033, 50047, 50051, 50053, 50069, 50077, 50087, 50093, + 50101, 50111, 50119, 50123, 50129, 50131, 50147, 50153, 50159, 50177, 50207, + 50221, 50227, 50231, 50261, 50263, 50273, 50287, 50291, 50311, 50321, 50329, + 50333, 50341, 50359, 50363, 50377, 50383, 50387, 50411, 50417, 50423, 50441, + 50459, 50461, 50497, 50503, 50513, 50527, 50539, 50543, 50549, 50551, 50581, + 50587, 50591, 50593, 50599, 50627, 50647, 50651, 50671, 50683, 50707, 50723, + 50741, 50753, 50767, 50773, 50777, 50789, 50821, 50833, 50839, 50849, 50857, + 50867, 50873, 50891, 50893, 50909, 50923, 50929, 50951, 50957, 50969, 50971, + 50989, 50993, 51001, 51031, 51043, 51047, 51059, 51061, 51071, 51109, 51131, + 51133, 51137, 51151, 51157, 51169, 51193, 51197, 51199, 51203, 51217, 51229, + 51239, 51241, 51257, 51263, 51283, 51287, 51307, 51329, 51341, 51343, 51347, + 51349, 51361, 51383, 51407, 51413, 51419, 51421, 51427, 51431, 51437, 51439, + 51449, 51461, 51473, 51479, 51481, 51487, 51503, 51511, 51517, 51521, 51539, + 51551, 51563, 51577, 51581, 51593, 51599, 51607, 51613, 51631, 51637, 51647, + 51659, 51673, 51679, 51683, 51691, 51713, 51719, 51721, 51749, 51767, 51769, + 51787, 51797, 51803, 51817, 51827, 51829, 51839, 51853, 51859, 51869, 51871, + 51893, 51899, 51907, 51913, 51929, 51941, 51949, 51971, 51973, 51977, 51991, + 52009, 52021, 52027, 52051, 52057, 52067, 52069, 52081, 52103, 52121, 52127, + 52147, 52153, 52163, 52177, 52181, 52183, 52189, 52201, 52223, 52237, 52249, + 52253, 52259, 52267, 52289, 52291, 52301, 52313, 52321, 52361, 52363, 52369, + 52379, 52387, 52391, 52433, 52453, 52457, 52489, 52501, 52511, 52517, 52529, + 52541, 52543, 52553, 52561, 52567, 52571, 52579, 52583, 52609, 52627, 52631, + 52639, 52667, 52673, 52691, 52697, 52709, 52711, 52721, 52727, 52733, 52747, + 52757, 52769, 52783, 52807, 52813, 52817, 52837, 52859, 52861, 52879, 52883, + 52889, 52901, 52903, 52919, 52937, 52951, 52957, 52963, 52967, 52973, 52981, + 52999, 53003, 53017, 53047, 53051, 53069, 53077, 53087, 53089, 53093, 53101, + 53113, 53117, 53129, 53147, 53149, 53161, 53171, 53173, 53189, 53197, 53201, + 53231, 53233, 53239, 53267, 53269, 53279, 53281, 53299, 53309, 53323, 53327, + 53353, 53359, 53377, 53381, 53401, 53407, 53411, 53419, 53437, 53441, 53453, + 53479, 53503, 53507, 53527, 53549, 53551, 53569, 53591, 53593, 53597, 53609, + 53611, 53617, 53623, 53629, 53633, 53639, 53653, 53657, 53681, 53693, 53699, + 53717, 53719, 53731, 53759, 53773, 53777, 53783, 53791, 53813, 53819, 53831, + 53849, 53857, 53861, 53881, 53887, 53891, 53897, 53899, 53917, 53923, 53927, + 53939, 53951, 53959, 53987, 53993, 54001, 54011, 54013, 54037, 54049, 54059, + 54083, 54091, 54101, 54121, 54133, 54139, 54151, 54163, 54167, 54181, 54193, + 54217, 54251, 54269, 54277, 54287, 54293, 54311, 54319, 54323, 54331, 54347, + 54361, 54367, 54371, 54377, 54401, 54403, 54409, 54413, 54419, 54421, 54437, + 54443, 54449, 54469, 54493, 54497, 54499, 54503, 54517, 54521, 54539, 54541, + 54547, 54559, 54563, 54577, 54581, 54583, 54601, 54617, 54623, 54629, 54631, + 54647, 54667, 54673, 54679, 54709, 54713, 54721, 54727, 54751, 54767, 54773, + 54779, 54787, 54799, 54829, 54833, 54851, 54869, 54877, 54881, 54907, 54917, + 54919, 54941, 54949, 54959, 54973, 54979, 54983, 55001, 55009, 55021, 55049, + 55051, 55057, 55061, 55073, 55079, 55103, 55109, 55117, 55127, 55147, 55163, + 55171, 55201, 55207, 55213, 55217, 55219, 55229, 55243, 55249, 55259, 55291, + 55313, 55331, 55333, 55337, 55339, 55343, 55351, 55373, 55381, 55399, 55411, + 55439, 55441, 55457, 55469, 55487, 55501, 55511, 55529, 55541, 55547, 55579, + 55589, 55603, 55609, 55619, 55621, 55631, 55633, 55639, 55661, 55663, 55667, + 55673, 55681, 55691, 55697, 55711, 55717, 55721, 55733, 55763, 55787, 55793, + 55799, 55807, 55813, 55817, 55819, 55823, 55829, 55837, 55843, 55849, 55871, + 55889, 55897, 55901, 55903, 55921, 55927, 55931, 55933, 55949, 55967, 55987, + 55997, 56003, 56009, 56039, 56041, 56053, 56081, 56087, 56093, 56099, 56101, + 56113, 56123, 56131, 56149, 56167, 56171, 56179, 56197, 56207, 56209, 56237, + 56239, 56249, 56263, 56267, 56269, 56299, 56311, 56333, 56359, 56369, 56377, + 56383, 56393, 56401, 56417, 56431, 56437, 56443, 56453, 56467, 56473, 56477, + 56479, 56489, 56501, 56503, 56509, 56519, 56527, 56531, 56533, 56543, 56569, + 56591, 56597, 56599, 56611, 56629, 56633, 56659, 56663, 56671, 56681, 56687, + 56701, 56711, 56713, 56731, 56737, 56747, 56767, 56773, 56779, 56783, 56807, + 56809, 56813, 56821, 56827, 56843, 56857, 56873, 56891, 56893, 56897, 56909, + 56911, 56921, 56923, 56929, 56941, 56951, 56957, 56963, 56983, 56989, 56993, + 56999, 57037, 57041, 57047, 57059, 57073, 57077, 57089, 57097, 57107, 57119, + 57131, 57139, 57143, 57149, 57163, 57173, 57179, 57191, 57193, 57203, 57221, + 57223, 57241, 57251, 57259, 57269, 57271, 57283, 57287, 57301, 57329, 57331, + 57347, 57349, 57367, 57373, 57383, 57389, 57397, 57413, 57427, 57457, 57467, + 57487, 57493, 57503, 57527, 57529, 57557, 57559, 57571, 57587, 57593, 57601, + 57637, 57641, 57649, 57653, 57667, 57679, 57689, 57697, 57709, 57713, 57719, + 57727, 57731, 57737, 57751, 57773, 57781, 57787, 57791, 57793, 57803, 57809, + 57829, 57839, 57847, 57853, 57859, 57881, 57899, 57901, 57917, 57923, 57943, + 57947, 57973, 57977, 57991, 58013, 58027, 58031, 58043, 58049, 58057, 58061, + 58067, 58073, 58099, 58109, 58111, 58129, 58147, 58151, 58153, 58169, 58171, + 58189, 58193, 58199, 58207, 58211, 58217, 58229, 58231, 58237, 58243, 58271, + 58309, 58313, 58321, 58337, 58363, 58367, 58369, 58379, 58391, 58393, 58403, + 58411, 58417, 58427, 58439, 58441, 58451, 58453, 58477, 58481, 58511, 58537, + 58543, 58549, 58567, 58573, 58579, 58601, 58603, 58613, 58631, 58657, 58661, + 58679, 58687, 58693, 58699, 58711, 58727, 58733, 58741, 58757, 58763, 58771, + 58787, 58789, 58831, 58889, 58897, 58901, 58907, 58909, 58913, 58921, 58937, + 58943, 58963, 58967, 58979, 58991, 58997, 59009, 59011, 59021, 59023, 59029, + 59051, 59053, 59063, 59069, 59077, 59083, 59093, 59107, 59113, 59119, 59123, + 59141, 59149, 59159, 59167, 59183, 59197, 59207, 59209, 59219, 59221, 59233, + 59239, 59243, 59263, 59273, 59281, 59333, 59341, 59351, 59357, 59359, 59369, + 59377, 59387, 59393, 59399, 59407, 59417, 59419, 59441, 59443, 59447, 59453, + 59467, 59471, 59473, 59497, 59509, 59513, 59539, 59557, 59561, 59567, 59581, + 59611, 59617, 59621, 59627, 59629, 59651, 59659, 59663, 59669, 59671, 59693, + 59699, 59707, 59723, 59729, 59743, 59747, 59753, 59771, 59779, 59791, 59797, + 59809, 59833, 59863, 59879, 59887, 59921, 59929, 59951, 59957, 59971, 59981, + 59999, 60013, 60017, 60029, 60037, 60041, 60077, 60083, 60089, 60091, 60101, + 60103, 60107, 60127, 60133, 60139, 60149, 60161, 60167, 60169, 60209, 60217, + 60223, 60251, 60257, 60259, 60271, 60289, 60293, 60317, 60331, 60337, 60343, + 60353, 60373, 60383, 60397, 60413, 60427, 60443, 60449, 60457, 60493, 60497, + 60509, 60521, 60527, 60539, 60589, 60601, 60607, 60611, 60617, 60623, 60631, + 60637, 60647, 60649, 60659, 60661, 60679, 60689, 60703, 60719, 60727, 60733, + 60737, 60757, 60761, 60763, 60773, 60779, 60793, 60811, 60821, 60859, 60869, + 60887, 60889, 60899, 60901, 60913, 60917, 60919, 60923, 60937, 60943, 60953, + 60961, 61001, 61007, 61027, 61031, 61043, 61051, 61057, 61091, 61099, 61121, + 61129, 61141, 61151, 61153, 61169, 61211, 61223, 61231, 61253, 61261, 61283, + 61291, 61297, 61331, 61333, 61339, 61343, 61357, 61363, 61379, 61381, 61403, + 61409, 61417, 61441, 61463, 61469, 61471, 61483, 61487, 61493, 61507, 61511, + 61519, 61543, 61547, 61553, 61559, 61561, 61583, 61603, 61609, 61613, 61627, + 61631, 61637, 61643, 61651, 61657, 61667, 61673, 61681, 61687, 61703, 61717, + 61723, 61729, 61751, 61757, 61781, 61813, 61819, 61837, 61843, 61861, 61871, + 61879, 61909, 61927, 61933, 61949, 61961, 61967, 61979, 61981, 61987, 61991, + 62003, 62011, 62017, 62039, 62047, 62053, 62057, 62071, 62081, 62099, 62119, + 62129, 62131, 62137, 62141, 62143, 62171, 62189, 62191, 62201, 62207, 62213, + 62219, 62233, 62273, 62297, 62299, 62303, 62311, 62323, 62327, 62347, 62351, + 62383, 62401, 62417, 62423, 62459, 62467, 62473, 62477, 62483, 62497, 62501, + 62507, 62533, 62539, 62549, 62563, 62581, 62591, 62597, 62603, 62617, 62627, + 62633, 62639, 62653, 62659, 62683, 62687, 62701, 62723, 62731, 62743, 62753, + 62761, 62773, 62791, 62801, 62819, 62827, 62851, 62861, 62869, 62873, 62897, + 62903, 62921, 62927, 62929, 62939, 62969, 62971, 62981, 62983, 62987, 62989, + 63029, 63031, 63059, 63067, 63073, 63079, 63097, 63103, 63113, 63127, 63131, + 63149, 63179, 63197, 63199, 63211, 63241, 63247, 63277, 63281, 63299, 63311, + 63313, 63317, 63331, 63337, 63347, 63353, 63361, 63367, 63377, 63389, 63391, + 63397, 63409, 63419, 63421, 63439, 63443, 63463, 63467, 63473, 63487, 63493, + 63499, 63521, 63527, 63533, 63541, 63559, 63577, 63587, 63589, 63599, 63601, + 63607, 63611, 63617, 63629, 63647, 63649, 63659, 63667, 63671, 63689, 63691, + 63697, 63703, 63709, 63719, 63727, 63737, 63743, 63761, 63773, 63781, 63793, + 63799, 63803, 63809, 63823, 63839, 63841, 63853, 63857, 63863, 63901, 63907, + 63913, 63929, 63949, 63977, 63997, 64007, 64013, 64019, 64033, 64037, 64063, + 64067, 64081, 64091, 64109, 64123, 64151, 64153, 64157, 64171, 64187, 64189, + 64217, 64223, 64231, 64237, 64271, 64279, 64283, 64301, 64303, 64319, 64327, + 64333, 64373, 64381, 64399, 64403, 64433, 64439, 64451, 64453, 64483, 64489, + 64499, 64513, 64553, 64567, 64577, 64579, 64591, 64601, 64609, 64613, 64621, + 64627, 64633, 64661, 64663, 64667, 64679, 64693, 64709, 64717, 64747, 64763, + 64781, 64783, 64793, 64811, 64817, 64849, 64853, 64871, 64877, 64879, 64891, + 64901, 64919, 64921, 64927, 64937, 64951, 64969, 64997, 65003, 65011, 65027, + 65029, 65033, 65053, 65063, 65071, 65089, 65099, 65101, 65111, 65119, 65123, + 65129, 65141, 65147, 65167, 65171, 65173, 65179, 65183, 65203, 65213, 65239, + 65257, 65267, 65269, 65287, 65293, 65309, 65323, 65327, 65353, 65357, 65371, + 65381, 65393, 65407, 65413, 65419, 65423, 65437, 65447, 65449, 65479, 65497, + 65519, 65521, 1 +}; + +/* + * smallest prime > MAX_SM_PRIME (2^32-5) == 2^32+15 + */ +#if BASEB == 32 +static CONST HALF _nxt_prime_val_[] = { 0xf, 0x1 }; +ZVALUE CONST _nxt_prime_ = { (HALF *)_nxt_prime_val_, 2, 0 }; +NUMBER _nxtprime_ = { { (HALF *)_nxt_prime_val_, 2, 0}, { _oneval_, 1, 0 }, 1 }; +#else +static CONST HALF _nxt_prime_val_[] = { 0xf, 0x0, 0x1 }; +ZVALUE CONST _nxt_prime_ = { (HALF *)_nxt_prime_val_, 3, 0 }; +NUMBER _nxtprime_ = { { (HALF *)_nxt_prime_val_, 3, 0}, { _oneval_, 1, 0 }, 1 }; +#endif + +/* + * JMPMOD*2 as a ZVALUE + */ +static CONST HALF _jmpmod2_val_[] = { JMPMOD*2 }; +CONST ZVALUE _jmpmod2_ = { (HALF *)_jmpmod2_val_, 1, 0 }; diff --git a/prime.h b/prime.h new file mode 100644 index 0000000..f6516a7 --- /dev/null +++ b/prime.h @@ -0,0 +1,75 @@ +/* + * Copyright (c) 1995 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 "qmath.h" +#include "have_const.h" + + +#define MAX_MAP_PRIME ((FULL)65521) /* (2^16-15) larest prime in prmap */ +#define MAX_MAP_VAL ((FULL)65535) /* (2^16-1) larest bit in pr_map */ +#define MAX_SM_PRIME ((FULL)0xfffffffb) /* (2^32-5) larest 32 bit prime */ +#define MAX_SM_VAL ((FULL)0xffffffff) /* (2^32-1) larest 32 bit value */ + +#define MAP_POPCNT 6541 /* number of odd primes in pr_map */ + +#define NXT_MAP_PRIME ((FULL)65537) /* (2^16+1) smallest prime > 2^16 */ + +#define PIX_32B ((FULL)203280221) /* pix(2^32-1) - max pix() value */ + +/* + * product of primes that fit into a long + */ +#if BASEB == 32 +#define MAX_PFACT_VAL 52 /* max x, for which pfact(x) is a long */ +#define NXT_PFACT_VAL 14 /* next prime for higher pfact values */ +#else +#define MAX_PFACT_VAL 28 /* max x, for which pfact(x) is a long */ +#define NXT_PFACT_VAL 8 /* next prime for higher pfact values */ +#endif + +/* + * If n is odd and 1 <= n <= MAX_MAP_VAL, then: + * + * pr_map_bit(n) != 0 ==> n is prime + * pr_map_bit(n) == 0 ==> n is NOT prime + */ +#define pr_map_bit(n) (pr_map[(HALF)(n)>>4] & (1 << (((HALF)(n)>>1)&0x7))) + +/* + * Limits for piXb tables. Do not test about this value using the + * given table, even though the table has a higher sentinal value. + */ +#define MAX_PI10B ((1024*256)-1) /* largest pi10b value to test */ +#define MAX_PI18B ((FULL)(0xFFFFFFFF)) /* largest pi18b value to test */ + +/* + * Prime related external arrays. + */ +extern CONST unsigned short prime[]; +extern CONST unsigned char pr_map[]; +extern CONST unsigned short pi10b[]; +extern CONST unsigned short pi18b[]; +extern NUMBER _nxtprime_; /* 2^32+15 - smallest prime > 2^32 */ +extern CONST ZVALUE _nxt_prime_; /* 2^32+15 - smallest prime > 2^32 */ +extern CONST ZVALUE _jmpmod2_; /* JMPMOD*2 as a ZVALUE */ diff --git a/qfunc.c b/qfunc.c new file mode 100644 index 0000000..4584722 --- /dev/null +++ b/qfunc.c @@ -0,0 +1,1474 @@ +/* + * Copyright (c) 1996 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" +#include "config.h" +#include "prime.h" + + +/* + * Set the default precision for real calculations. + * The precision must be between zero and one. + * + * given: + * q number to be set as the new epsilon + */ +void +setepsilon(NUMBER *q) +{ + NUMBER *old; + + if (qisneg(q) || qiszero(q) || (qreli(q, 1L) >= 0)) { + math_error("Epsilon value must be between zero and one"); + /*NOTREACHED*/ + } + old = conf->epsilon; + conf->epsilonprec = qprecision(q); + conf->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(NUMBER *q1, NUMBER *q2) +{ + NUMBER *r; + ZVALUE z1, z2, tmp; + int s, t; + long rnd; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integers for minv"); + /*NOTREACHED*/ + } + if (qiszero(q2)) { + if (qisunit(q1)) + return qlink(q1); + return qlink(&_qzero_); + } + if (qisunit(q2)) + return qlink(&_qzero_); + rnd = conf->mod; + s = (rnd & 4) ? 0 : q2->num.sign; + if (rnd & 1) + s^= 1; + + tmp = q2->num; + tmp.sign = 0; + if (zmodinv(q1->num, tmp, &z1)) + return qlink(&_qzero_); + zsub(tmp, z1, &z2); + if (rnd & 16) { + t = zrel(z1, z2); + if (t < 0) + s = 0; + else if (t > 0) + s = 1; + } + r = qalloc(); + if (s) { + zfree(z1); + z2.sign = TRUE; + r->num = z2; + return r; + } + zfree(z2); + r->num = z1; + return r; +} + + +/* + * Return the residue modulo an integer (q3) of an integer (q1) + * raised to a positive integer (q2) power. + */ +NUMBER * +qpowermod(NUMBER *q1, NUMBER *q2, NUMBER *q3) +{ + NUMBER *r; + ZVALUE z1, z2, tmp; + int s, t; + long rnd; + + if (qisfrac(q1) || qisfrac(q2) || qisfrac(q3)) { + math_error("Non-integers for pmod"); + /*NOTREACHED*/ + } + if (qisneg(q2)) { + math_error("Negative power for pmod"); + /*NOTREACHED*/ + } + if (qiszero(q3)) + return qpowi(q1, q2); + if (qisunit(q3)) + return qlink(&_qzero_); + rnd = conf->mod; + s = (rnd & 4) ? 0 : q3->num.sign; + if (rnd & 1) + s^= 1; + tmp = q3->num; + tmp.sign = 0; + zpowermod(q1->num, q2->num, tmp, &z1); + if (ziszero(z1)) { + zfree(z1); + return qlink(&_qzero_); + } + zsub(tmp, z1, &z2); + if (rnd & 16) { + t = zrel(z1, z2); + if (t < 0) + s = 0; + else if (t > 0) + s = 1; + } + r = qalloc(); + if (s) { + zfree(z1); + z2.sign = TRUE; + r->num = z2; + return r; + } + zfree(z2); + r->num = z1; + return r; +} + + +/* + * Return the power function of one number with another. + * The power must be integral. + * q3 = qpowi(q1, q2); + */ +NUMBER * +qpowi(NUMBER *q1, NUMBER *q2) +{ + register NUMBER *r; + BOOL invert, sign; + ZVALUE num, den, z2; + + if (qisfrac(q2)) { + math_error("Raising number to fractional power"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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(NUMBER *q1, NUMBER *q2, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for hypot"); + /*NOTREACHED*/ + } + if (qiszero(q1)) + return qabs(q2); + if (qiszero(q2)) + return qabs(q1); + tmp1 = qsquare(q1); + tmp2 = qsquare(q2); + tmp3 = qqadd(tmp1, tmp2); + qfree(tmp1); + qfree(tmp2); + tmp1 = qsqrt(tmp3, epsilon, 24L); + 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(NUMBER *q, NUMBER *epsilon, BOOL wantneg) +{ + NUMBER *res, *qtmp1, *qtmp2; + ZVALUE num; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for legtoleg"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + qtmp1 = qsquare(q); + qtmp2 = qsub(&_qone_, qtmp1); + qfree(qtmp1); + res = qsqrt(qtmp2, epsilon, 24L); + qfree(qtmp2); + if (wantneg) { + qtmp1 = qneg(res); + qfree(res); + res = qtmp1; + } + return res; +} + + +/* + * Compute the square root of a real number. + * Type of rounding if any depends on rnd. + * If rnd & 32 is nonzero, result is exact for square numbers; + * If rnd & 64 is nonzero, the negative square root is returned; + * If rnd < 32, result is rounded to a multiple of epsilon + * up, down, etc. depending on bits 0, 2, 4 of v. + */ + +NUMBER * +qsqrt(NUMBER *q1, NUMBER *epsilon, long rnd) +{ + NUMBER *r, etemp; + ZVALUE tmp1, tmp2, quo, mul, divisor; + long s1, s2, up, RR, RS; + int sign; + + if (qisneg(q1)) { + math_error("Square root of negative number"); + /*NOTREACHED*/ + } + if (qiszero(q1)) + return qlink(&_qzero_); + sign = (rnd & 64) != 0; +#if 0 + if (qiszero(epsilon)) { + s1 = zesqrt(q1->num, &tmp1); + if (s1) { + if (qisint(q1)) { + r = qalloc(); + tmp1.sign = sign; + r->num = tmp1; + return r; + } + s2 = zesqrt(q1->den, &tmp2); + if (s2) { + r = qalloc(); + tmp1.sign = sign; + r->num = tmp1; + r->den = tmp2; + return r; + } + zfree(tmp2); + } + zfree(tmp1); + return qlink(&_qzero_); + } +#else + if (qiszero(epsilon)) { + math_error("Zero epsilon for qsqrt"); + /*NOTREACHED*/ + } +#endif + + etemp = *epsilon; + etemp.num.sign = 0; + RS = rnd & 25; + if (!(RS & 8)) + RS ^= epsilon->num.sign; + if (rnd & 2) + RS ^= sign ^ epsilon->num.sign; + if (rnd & 4) + RS ^= epsilon->num.sign; + RR = zisunit(q1->den) && qisunit(epsilon); + if (rnd & 32 || RR) { + s1 = zsqrt(q1->num, &tmp1, RS); + if (RR) { + if (ziszero(tmp1)) { + zfree(tmp1); + return qlink(&_qzero_); + } + r = qalloc(); + tmp1.sign = sign; + r->num = tmp1; + return r; + } + if (!s1) { + s2 = zsqrt(q1->den, &tmp2, 0); + if (!s2) { + r = qalloc(); + tmp1.sign = sign; + r->num = tmp1; + r->den = tmp2; + return r; + } + zfree(tmp2); + } + zfree(tmp1); + } + up = 0; + zsquare(epsilon->den, &tmp1); + zmul(tmp1, q1->num, &tmp2); + zfree(tmp1); + zsquare(epsilon->num, &tmp1); + zmul(tmp1, q1->den, &divisor); + zfree(tmp1); + if (rnd & 16) { + zshift(tmp2, 2, &tmp1); + zfree(tmp2); + s1 = zquo(tmp1, divisor, &quo, 16); + zfree(tmp1); + s2 = zsqrt(quo, &tmp1, s1 ? s1 < 0 : 16); + zshift(tmp1, -1, &mul); + up = (*tmp1.v & 1) ? s1 + s2 : -1; + zfree(tmp1); + } + else { + s1 = zquo(tmp2, divisor, &quo, 0); + zfree(tmp2); + s2 = zsqrt(quo, &mul, 0); + up = (s1 + s2) ? 0 : -1; + } + if (up == 0) { + if (rnd & 8) + up = (long)((RS ^ *mul.v) & 1); + else + up = RS ^ sign; + } + if (up > 0) { + zadd(mul, _one_, &tmp2); + zfree(mul); + mul = tmp2; + } + zfree(divisor); + zfree(quo); + if (ziszero(mul)) { + zfree(mul); + return qlink(&_qzero_); + } + r = qalloc(); + zreduce(mul, etemp.den, &tmp1, &r->den); + zfree(mul); + tmp1.sign = sign; + zmul(tmp1, etemp.num, &r->num); + zfree(tmp1); + return r; +} + + +/* + * Calculate the integral part of the square root of a number. + * Example: qisqrt(13) = 3. + */ +NUMBER * +qisqrt(NUMBER *q) +{ + NUMBER *r; + ZVALUE tmp; + + if (qisneg(q)) { + math_error("Square root of negative number"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qlink(&_qzero_); + r = qalloc(); + if (qisint(q)) { + (void) zsqrt(q->num, &r->num,0); + return r; + } + zquo(q->num, q->den, &tmp, 0); + (void) zsqrt(tmp, &r->num,0); + freeh(tmp.v); + return r; +} + +/* + * Return whether or not a number is an exact square. + */ +BOOL +qissquare(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(NUMBER *q1, NUMBER *q2) +{ + NUMBER *r; + ZVALUE tmp; + + if (qisneg(q2) || qiszero(q2) || qisfrac(q2)) { + math_error("Taking number to bad root value"); + /*NOTREACHED*/ + } + 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, 0); + 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. + * + * given: + * q number to take log of + */ +long +qilog2(NUMBER *q) +{ + long n; /* power of two */ + int c; /* result of comparison */ + ZVALUE tmp1, tmp2; /* temporary values */ + + if (qiszero(q)) { + math_error("Zero argument for ilog2"); + /*NOTREACHED*/ + } + if (qisint(q)) + return zhighbit(q->num); + tmp1 = q->num; + tmp1.sign = 0; + n = zhighbit(tmp1) - zhighbit(q->den); + if (n == 0) + c = zrel(tmp1, q->den); + else if (n > 0) { + zshift(q->den, n, &tmp2); + c = zrel(tmp1, tmp2); + } else { + zshift(tmp1, -n, &tmp2); + c = zrel(tmp2, q->den); + } + if (n) + zfree(tmp2); + 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. + * + * given: + * q number to take log of + */ +long +qilog10(NUMBER *q) +{ + long n; /* log value */ + ZVALUE tmp1, tmp2; /* temporary values */ + + if (qiszero(q)) { + math_error("Zero argument for ilog10"); + /*NOTREACHED*/ + } + tmp1 = q->num; + tmp1.sign = 0; + if (qisint(q)) + return zlog10(tmp1); + /* + * 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(tmp1, q->den) > 0))) { + zquo(tmp1, q->den, &tmp2, 0); + n = zlog10(tmp2); + zfree(tmp2); + 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(tmp1)) + zsub(q->den, _one_, &tmp2); + else + zquo(q->den, tmp1, &tmp2, 0); + n = -zlog10(tmp2) - 1; + zfree(tmp2); + return n; +} + +/* + * Return the integer floor of the logarithm of a number relative to + * a specified integral base. + */ +long +qilog(NUMBER *q1, NUMBER *q2) +{ + long n; + ZVALUE tmp1, tmp2; + + if (qiszero(q1)) { + math_error("Zero argument for ilog"); + /*NOTREACHED*/ + } + if (qisfrac(q2) || zrel(q2->num, _one_) <= 0) { + math_error("Base for ilog non-integral or less than 2"); + /*NOTREACHED*/ + } + if (qisunit(q1)) + return 0; + tmp1 = q1->num; + tmp1.sign = 0; + if (qisint(q1)) + return zlog(tmp1, q2->num); + if (zrel(tmp1, q1->den) > 0) { + zquo(tmp1, q1->den, &tmp2, 0); + n = zlog(tmp2, q2->num); + zfree(tmp2); + return n; + } + if (zisunit(tmp1)) + zsub(q1->den, _one_, &tmp2); + else + zquo(q1->den, tmp1, &tmp2, 0); + n = -zlog(tmp2, q2->num) - 1; + zfree(tmp2); + 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. + * + * given: + * q number to count digits of + */ +long +qdigits(NUMBER *q) +{ + long n; /* number of digits */ + ZVALUE temp; /* temporary value */ + + if (qisint(q)) + return zdigits(q->num); + zquo(q->num, q->den, &temp, 2); + 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. + */ +long +qdigit(NUMBER *q, long n) +{ + ZVALUE tenpow, tmp1, tmp2; + long 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, 2); + 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, 2); + tmp2.sign = 0; + 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(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, 2); + 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(NUMBER *q) +{ + register NUMBER *r; + + if (qisfrac(q)) { + math_error("Non-integral factorial"); + /*NOTREACHED*/ + } + 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(NUMBER *q) +{ + NUMBER *r; + + if (qisfrac(q)) { + math_error("Non-integral factorial"); + /*NOTREACHED*/ + } + 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(NUMBER *q) +{ + NUMBER *r; + + if (qisfrac(q)) { + math_error("Non-integral lcmfact"); + /*NOTREACHED*/ + } + r = qalloc(); + zlcmfact(q->num, &r->num); + return r; +} + + +/* + * Compute the permutation function M! / (M - N)!. + */ +NUMBER * +qperm(NUMBER *q1, NUMBER *q2) +{ + register NUMBER *r; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integral arguments for permutation"); + /*NOTREACHED*/ + } + r = qalloc(); + zperm(q1->num, q2->num, &r->num); + return r; +} + + +/* + * Compute the combinatorial function M! / (N! * (M - N)!). + */ +NUMBER * +qcomb(NUMBER *q1, NUMBER *q2) +{ + register NUMBER *r; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integral arguments for combinatorial"); + /*NOTREACHED*/ + } + 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(NUMBER *q1, NUMBER *q2) +{ + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integral arguments for jacobi"); + /*NOTREACHED*/ + } + return itoq((long) zjacobi(q1->num, q2->num)); +} + + +/* + * Compute the Fibonacci number F(n). + */ +NUMBER * +qfib(NUMBER *q) +{ + register NUMBER *r; + + if (qisfrac(q)) { + math_error("Non-integral Fibonacci number"); + /*NOTREACHED*/ + } + r = qalloc(); + zfib(q->num, &r->num); + return r; +} + + +/* + * Truncate a number to the specified number of decimal places. + */ +NUMBER * +qtrunc(NUMBER *q1, NUMBER *q2) +{ + long places; + NUMBER *r, *e; + + if (qisfrac(q2) || !zistiny(q2->num)) { + math_error("Bad number of places for qtrunc"); + /*NOTREACHED*/ + } + places = z1tol(q2->num); + e = qtenpow(-places); + r = qmappr(q1, e, 2); + qfree(e); + return r; +} + + + + +/* + * Truncate a number to the specified number of binary places. + * Specifying zero places makes the result identical to qint. + */ +NUMBER * +qbtrunc(NUMBER *q1, NUMBER *q2) +{ + long places; + NUMBER *r, *e; + + if (qisfrac(q2) || !zistiny(q2->num)) { + math_error("Bad number of places for qtrunc"); + /*NOTREACHED*/ + } + places = z1tol(q2->num); + e = qbitvalue(-places); + r = qmappr(q1, e, 2); + qfree(e); + return r; +} + + +/* + * Round a number to a specified number of binary places. + */ +NUMBER * +qbround(NUMBER *q, long places, long rnd) +{ + NUMBER *e, *r; + + if (qiszero(q)) + return qlink(&_qzero_); + if (rnd & 32) + places -= qilog2(q) + 1; + e = qbitvalue(-places); + r = qmappr(q, e, rnd & 31); + qfree(e); + return r; +} + +/* + * Round a number to a specified number of decimal digits. + */ +NUMBER * +qround(NUMBER *q, long places, long rnd) +{ + NUMBER *e, *r; + + if (qiszero(q)) + return qlink(&_qzero_); + if (rnd & 32) + places -= qilog10(q) + 1; + e = qtenpow(-places); + r = qmappr(q, e, rnd & 31); + qfree(e); + return r; +} + +/* + * Approximate a number to nearest multiple of a given number. Whether + * rounding is down, up, etc. is determined by rnd. + */ +NUMBER * +qmappr(NUMBER *q, NUMBER *e, long rnd) +{ + NUMBER *r; + ZVALUE tmp1, tmp2, mul; + + if (qiszero(e)) + return qlink(q); + if (qiszero(q)) + return qlink(&_qzero_); + zmul(q->num, e->den, &tmp1); + zmul(q->den, e->num, &tmp2); + zquo(tmp1, tmp2, &mul, rnd); + zfree(tmp1); + zfree(tmp2); + if (ziszero(mul)) { + zfree(mul); + return qlink(&_qzero_); + } + r = qalloc(); + zreduce(mul, e->den, &tmp1, &r->den); + zmul(tmp1, e->num, &r->num); + zfree(tmp1); + zfree(mul); + return r; +} + + +/* + * Determine the smallest-denominator rational number in the interval of + * length abs(epsilon) (< 1) with centre or one end at q, or to determine + * the number nearest above or nearest below q with denominator + * not exceeding abs(epsilon). + * Whether the approximation is nearest above or nearest below is + * determined by rnd and the signs of epsilon and q. + */ + +NUMBER * +qcfappr(NUMBER *q, NUMBER *epsilon, long rnd) +{ + NUMBER *res, etemp, *epsilon1; + ZVALUE num, den, oldnum, oldden; + ZVALUE rem, oldrem, quot; + ZVALUE tmp1, tmp2, tmp3, tmp4; + ZVALUE denbnd; + ZVALUE f, g, k; + BOOL esign; + int s; + BOOL bnddencase; + BOOL useold = FALSE; + + if (qiszero(epsilon) || qisint(q)) + return qlink(q); + + esign = epsilon->num.sign; + etemp = *epsilon; + etemp.num.sign = 0; + bnddencase = (zrel(etemp.num, etemp.den) >= 0); + if (bnddencase) { + zquo(etemp.num, etemp.den, &denbnd, 0); + if (zrel(q->den, denbnd) <= 0) { + zfree(denbnd); + return qlink(q); + } + } + else { + if (rnd & 16) + epsilon1 = qscale(epsilon, -1); + else + epsilon1 = qlink(epsilon); + zreduce(q->den, epsilon1->den, &tmp1, &g); + zmul(epsilon1->num, tmp1, &f); + f.sign = 0; + zfree(tmp1); + qfree(epsilon1); + } + if (rnd & 16 && !zistwo(q->den)) + s = 0; + else { + s = esign ? -1 : 1; + if (rnd & 1) + s = -s; + if (rnd & 2 && q->num.sign ^ esign) + s = -s; + if (rnd & 4 && esign) + s = -s; + } + oldnum = _one_; + oldden = _zero_; + zcopy(q->den, &oldrem); + zdiv(q->num, q->den, &num, &rem, 0); + den = _one_; + for (;;) { + if (!bnddencase) { + zmul(f, den, &tmp1); + zmul(g, rem, &tmp2); + if (ziszero(rem) || (s >= 0 && zrel(tmp1,tmp2) >= 0)) + break; + zfree(tmp1); + zfree(tmp2); + } + zdiv(oldrem, rem, ", &tmp1, 0); + zfree(oldrem); + oldrem = rem; + rem = tmp1; + zmul(quot, den, &tmp1); + zadd(tmp1, oldden, &tmp2); + zfree(tmp1); + zfree(oldden); + oldden = den; + den = tmp2; + zmul(quot, num, &tmp1); + zadd(tmp1, oldnum, &tmp2); + zfree(tmp1); + zfree(oldnum); + oldnum = num; + num = tmp2; + zfree(quot); + if (bnddencase) { + if (zrel(den, denbnd) >= 0) + break; + } + s = -s; + } + if (bnddencase) { + if (s > 0) + useold = TRUE; + else { + zsub(den, denbnd, &tmp1); + zquo(tmp1, oldden, &k, 1); + zfree(tmp1); + } + zfree(denbnd); + } + else { + if (s < 0) { + zfree(tmp1); + zfree(tmp2); + zfree(f); + zfree(g); + zfree(oldnum); + zfree(oldden); + zfree(num); + zfree(den); + zfree(oldrem); + zfree(rem); + return qlink(q); + } + zsub(tmp1, tmp2, &tmp3); + zfree(tmp1); + zfree(tmp2); + zmul(f, oldden, &tmp1); + zmul(g, oldrem, &tmp2); + zfree(f); + zfree(g); + zadd(tmp1, tmp2, &tmp4); + zfree(tmp1); + zfree(tmp2); + zquo(tmp3, tmp4, &k, 0); + zfree(tmp3); + zfree(tmp4); + } + if (!useold && !ziszero(k)) { + zmul(k, oldnum, &tmp1); + zsub(num, tmp1, &tmp2); + zfree(tmp1); + zfree(num); + num = tmp2; + zmul(k, oldden, &tmp1); + zsub(den, tmp1, &tmp2); + zfree(tmp1); + zfree(den); + den = tmp2; + } + if (bnddencase && s == 0) { + zmul(k, oldrem, &tmp1); + zadd(rem, tmp1, &tmp2); + zfree(tmp1); + zfree(rem); + rem = tmp2; + zmul(rem, oldden, &tmp1); + zmul(den, oldrem, &tmp2); + useold = (zrel(tmp1, tmp2) >= 0); + zfree(tmp1); + zfree(tmp2); + } + if (!bnddencase || s <= 0) + zfree(k); + zfree(rem); + zfree(oldrem); + res = qalloc(); + if (useold) { + zfree(num); + zfree(den); + res->num = oldnum; + res->den = oldden; + return res; + } + zfree(oldnum); + zfree(oldden); + res->num = num; + res->den = den; + return res; +} + + +/* + * Calculate the nearest-above, or nearest-below, or nearest, number + * with denominator less than the given number, the choice between + * possibilities being dertermined by the parameter rnd. + */ +NUMBER * +qcfsim(NUMBER *q, long rnd) +{ + NUMBER *res; + ZVALUE tmp1, tmp2, den1, den2; + int s; + + if (qiszero(q) && rnd & 26) + return qlink(&_qzero_); + if (rnd & 24) + s = q->num.sign; + else { + s = rnd & 1; + if (rnd & 2) + s ^= q->num.sign; + } + if (qisint(q)) { + if ((rnd & 8) && !(rnd & 16)) + return qlink(&_qzero_); + if (s) + return qinc(q); + return qdec(q); + } + if (zistwo(q->den)) { + if (rnd & 16) + s ^= 1; + if (s) + zadd(q->num, _one_, &tmp1); + else + zsub(q->num, _one_, &tmp1); + res = qalloc(); + zshift(tmp1, -1, &res->num); + zfree(tmp1); + return res; + } + s = s ? 1 : -1; + if (rnd & 24) + s = 0; + res = qalloc(); + zmodinv(q->num, q->den, &den1); + if (s >= 0) { + zsub(q->den, den1, &den2); + if (s > 0 || ((zrel(den1, den2) < 0) ^ !(rnd & 16))) { + zfree(den1); + res->den = den2; + zmul(den2, q->num, &tmp1); + zadd(tmp1, _one_, &tmp2); + zfree(tmp1); + zequo(tmp2, q->den, &res->num); + zfree(tmp2); + return res; + } + zfree(den2); + } + res->den = den1; + zmul(den1, q->num, &tmp1); + zsub(tmp1, _one_, &tmp2); + zfree(tmp1); + zequo(tmp2, q->den, &res->num); + zfree(tmp2); + return res; +} + + + +/* + * 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(NUMBER *q1, NUMBER *q2, NUMBER *epsilon) +{ + int res; + NUMBER qtemp, etemp, *qq; + + etemp = *epsilon; + etemp.num.sign = 0; + 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, &etemp); + } + if (qiszero(q1)) { + qtemp = *q2; + qtemp.num.sign = 0; + return qrel(&qtemp, &etemp); + } + qq = qsub(q1, q2); + qtemp = *qq; + qtemp.num.sign = 0; + res = qrel(&qtemp, &etemp); + qfree(qq); + return res; +} + + +/* + * Compute the gcd (greatest common divisor) of two numbers. + * q3 = qgcd(q1, q2); + */ +NUMBER * +qgcd(NUMBER *q1, NUMBER *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(NUMBER *q1, NUMBER *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 occurences of the specified factor from a number. + * Returned number is always positive or zero. + */ +NUMBER * +qfacrem(NUMBER *q1, NUMBER *q2) +{ + long count; + ZVALUE tmp; + NUMBER *r; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integers for factor removal"); + /*NOTREACHED*/ + } + if (qiszero(q2)) + return qabs(q1); + if (qiszero(q1)) + return qlink(&_qzero_); + count = zfacrem(q1->num, q2->num, &tmp); + if (zisunit(tmp)) { + zfree(tmp); + return qlink(&_qone_); + } + if (count == 0 && !qisneg(q1)) { + 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(NUMBER *q1, NUMBER *q2) +{ + ZVALUE tmp; + NUMBER *r; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integers for gcdrem"); + /*NOTREACHED*/ + } + if (qiszero(q2)) + return qlink(&_qone_); + if (qiszero(q1)) + return qlink(&_qzero_); + 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(NUMBER *q1, NUMBER *q2) +{ + long count; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integers for lowfactor"); + /*NOTREACHED*/ + } + count = ztoi(q2->num); + if (count > PIX_32B) { + math_error("lowfactor count is too large"); + /*NOTREACHED*/ + } + return utoq(zlowfactor(q1->num, count)); +} + + +/* + * 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(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. + * + * The absolute value of the 2nd arg determines how many times + * to check for primality. If 2nd arg < 0, then the trivial + * check is omitted. The 3rd arg determines how tests to + * initially skip. + */ +BOOL +qprimetest(NUMBER *q1, NUMBER *q2, NUMBER *q3) +{ + if (qisfrac(q1) || qisfrac(q2) || qisfrac(q3)) { + math_error("Bad arguments for ptest"); + /*NOTREACHED*/ + } + if (zge24b(q2->num)) { + math_error("ptest count >= 2^24"); + /*NOTREACHED*/ + } + return zprimetest(q1->num, ztoi(q2->num), q3->num); +} + +/* END CODE */ diff --git a/qio.c b/qio.c new file mode 100644 index 0000000..17a1e2f --- /dev/null +++ b/qio.c @@ -0,0 +1,676 @@ +/* + * Copyright (c) 1996 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 "qmath.h" +#include "config.h" +#include "args.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) + +#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. + */ +void +qprintf(char *fmt, ...) +{ + va_list ap; + NUMBER *q; + int ch, sign = 1; + long width = 0, precision = 0; + int trigger = 0; + + va_start(ap, fmt); + while ((ch = *fmt++) != '\0') { + if (trigger == 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; + trigger = 1; + } + + 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 *= 10+ch-'0'; + } + } + } + } + } + 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); + * + * given: + * fp file stream to read from (or NULL) + */ +NUMBER * +qreadval(FILE *fp) +{ + 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 = str2q(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(NUMBER *q, int outmode) +{ + NUMBER tmpval; + long prec, exp; + + if (outmode == MODE_DEFAULT) + outmode = conf->outmode; + switch (outmode) { + case MODE_INT: + if (conf->tilde_ok && qisfrac(q)) + PUTCHAR('~'); + qprintfd(q, 0L); + break; + + case MODE_REAL: + prec = qplaces(q); + if ((prec < 0) || (prec > conf->outdigits)) { + if (conf->tilde_ok) + PUTCHAR('~'); + } + if (conf->fullzero || (prec < 0) || + (prec > conf->outdigits)) + prec = conf->outdigits; + qprintff(q, 0L, prec); + break; + + case MODE_FRAC: + qprintfr(q, 0L, FALSE); + 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"); + /*NOTREACHED*/ + } +} + + +/* + * Print a number in floating point representation. + * Example: 193.784 + */ +void +qprintff(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, conf->outround); + 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(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(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(NUMBER *q, long width) +{ + ZVALUE z; + + if (qisfrac(q)) { + zquo(q->num, q->den, &z, conf->outround); + 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(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(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(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 = str2q(string); + */ +NUMBER * +str2q(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++; + str2z(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"); + /*NOTREACHED*/ + } + } + } + ztenpow(decimals, &q->den); + } + str2z(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; + zequo(q->num, div, &newnum); + zfree(q->num); + zequo(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(char *cp, int flags) +{ + char *oldcp; + + oldcp = cp; + if ((*cp == '+') || (*cp == '-')) + cp++; + if ((*cp == '+') || (*cp == '-')) + return -1; + + /* hex */ + if ((*cp == '0') && ((cp[1] == 'x') || (cp[1] == 'X'))) { + cp += 2; + while (((*cp >= '0') && (*cp <= '9')) || + ((*cp >= 'a') && (*cp <= 'f')) || + ((*cp >= 'A') && (*cp <= 'F'))) + cp++; + 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); + } + + /* binary */ + if ((*cp == '0') && ((cp[1] == 'b') || (cp[1] == 'B'))) { + cp += 2; + while ((*cp == '0') || (*cp == '1')) + cp++; + 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); + } + + /* octal */ + if ((*cp == '0') && (cp[1] >= '0') && (cp[1] <= '9')) { + while ((*cp >= '0') && (*cp <= '7')) + cp++; + 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); + } + + /* + * 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++; + 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); + } + 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++; + } + + 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/qmath.c b/qmath.c new file mode 100644 index 0000000..a9427eb --- /dev/null +++ b/qmath.c @@ -0,0 +1,1282 @@ +/* + * Copyright (c) 1995 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" +#include "config.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 }; +NUMBER _qonesqbase_ = { { _oneval_, 1, 0 }, { _sqbaseval_, 2, 0 }, 1 }; + + +/* + * Create another copy of a number. + * q2 = qcopy(q1); + */ +NUMBER * +qcopy(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(NUMBER *q) +{ + long i; + ZVALUE res; + + if (qisint(q)) + return ztoi(q->num); + zquo(q->num, q->den, &res, 0); + i = ztoi(res); + zfree(res); + return i; +} + + +/* + * Convert a normal integer into a number. + * q = itoq(i); + */ +NUMBER * +itoq(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; +} + + +/* + * Convert a number to a normal unsigned integer. + * u = qtou(q); + */ +FULL +qtou(NUMBER *q) +{ + FULL i; + ZVALUE res; + + if (qisint(q)) + return ztou(q->num); + zquo(q->num, q->den, &res, 0); + i = ztou(res); + zfree(res); + return i; +} + + +/* + * Convert a normal unsigned integer into a number. + * q = utoq(i); + */ +NUMBER * +utoq(FULL i) +{ + register NUMBER *q; + + if (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; + default: q = NULL; + } + if (q) + return qlink(q); + } + q = qalloc(); + utoz(i, &q->num); + return q; +} + + +/* + * Create a number from the given FULL numerator and denominator. + * q = uutoq(inum, iden); + */ +NUMBER * +uutoq(FULL inum, FULL iden) +{ + register NUMBER *q; + FULL d; + BOOL sign; + + if (iden == 0) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + if (inum == 0) + return qlink(&_qzero_); + sign = 0; + d = uugcd(inum, iden); + inum /= d; + iden /= d; + if (iden == 1) + return utoq(inum); + q = qalloc(); + if (inum != 1) + utoz(inum, &q->num); + utoz(iden, &q->den); + q->num.sign = sign; + return q; +} + + +/* + * Create a number from the given integral numerator and denominator. + * q = iitoq(inum, iden); + */ +NUMBER * +iitoq(long inum, long iden) +{ + register NUMBER *q; + long d; + BOOL sign; + + if (iden == 0) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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 = qqadd(q1, q2); + */ +NUMBER * +qqadd(NUMBER *q1, NUMBER *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, 0); + zquo(q1->den, d1, &upd1, 0); + 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, 0); + zfree(temp); + zquo(q2->den, d2, &temp, 0); + zfree(d2); + zmul(temp, upd1, &r->den); + zfree(temp); + zfree(upd1); + return r; +} + + +/* + * Subtract one number from another. + * q3 = qsub(q1, q2); + */ +NUMBER * +qsub(NUMBER *q1, NUMBER *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 = qqadd(q1, q2); + qfree(q2); + return r; +} + + +/* + * Increment a number by one. + */ +NUMBER * +qinc(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(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(NUMBER *q1, long n) +{ + NUMBER addnum; /* temporary number */ + HALF addval[2]; /* value of small number */ + BOOL neg; /* TRUE if number is neg */ +#if LONG_BITS > BASEB + FULL nf; +#endif + + 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.v = addval; + addnum.den = _one_; + neg = (n < 0); + if (neg) + n = -n; + addval[0] = (HALF) n; +#if LONG_BITS > BASEB + nf = (((FULL) n) >> BASEB); + if (nf) { + addval[1] = (HALF) nf; + addnum.num.len = 2; + } +#else + addnum.num.len = 1; +#endif + if (neg) + return qsub(q1, &addnum); + else + return qqadd(q1, &addnum); +} + + +/* + * Multiply two numbers. + * q3 = qmul(q1, q2); + */ +NUMBER * +qmul(NUMBER *q1, NUMBER *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"); + /*NOTREACHED*/ + } + if (ziszero(n1) || ziszero(n2)) + return qlink(&_qzero_); + if (!zisunit(n1) && !zisunit(d2)) { /* possibly reduce */ + zgcd(n1, d2, &tmp); + if (!zisunit(tmp)) { + zequo(q1->num, tmp, &n1); + zequo(q2->den, tmp, &d2); + } + zfree(tmp); + } + if (!zisunit(n2) && !zisunit(d1)) { /* again possibly reduce */ + zgcd(n2, d1, &tmp); + if (!zisunit(tmp)) { + zequo(q2->num, tmp, &n2); + zequo(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(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(NUMBER *q1, NUMBER *q2) +{ + NUMBER temp; + + if (qiszero(q2)) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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(NUMBER *q, long n) +{ + NUMBER *r; + long d; /* gcd of divisor and numerator */ + int sign; + + if (n == 0) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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 integer quotient of a pair of numbers + * If q1/q2 is an integer qquo(q1, q2) returns this integer + * If q2 is zero, zero is returned + * In other cases whether rounding is down, up, towards zero, etc. + * is determined by rnd. + */ +NUMBER * +qquo(NUMBER *q1, NUMBER *q2, long rnd) +{ + ZVALUE tmp, tmp1, tmp2; + NUMBER *q; + + if (qiszero(q1) || qiszero(q2)) + return qlink(&_qzero_); + if (qisint(q1) && qisint(q2)) + zquo(q1->num, q2->num, &tmp, rnd); + else { + zmul(q1->num, q2->den, &tmp1); + zmul(q2->num, q1->den, &tmp2); + zquo(tmp1, tmp2, &tmp, rnd); + zfree(tmp1); + zfree(tmp2); + } + if (ziszero(tmp)) { + zfree(tmp); + return qlink(&_qzero_); + } + q = qalloc(); + q->num = tmp; + return q; +} + + +/* + * Return the absolute value of a number. + * q2 = qabs(q1); + */ +NUMBER * +qabs(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(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(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(NUMBER *q) +{ + register NUMBER *r; + + if (qisunit(q)) { + r = (qisneg(q) ? &_qnegone_ : &_qone_); + return qlink(r); + } + if (qiszero(q)) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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(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(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(NUMBER *q) +{ + register NUMBER *r; + + 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(); + zmod(q->num, q->den, &r->num, 2); + zcopy(q->den, &r->den); + return r; +} + + +/* + * Return the integral part of a number. + * q2 = qint(q1); + */ +NUMBER * +qint(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, 2); + return r; +} + + +/* + * Compute the square of a number. + */ +NUMBER * +qsquare(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(NUMBER *q, long n) +{ + register NUMBER *r; + + if (qisfrac(q)) { + math_error("Shift of non-integer"); + /*NOTREACHED*/ + } + 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(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"); + /*NOTREACHED*/ + } + 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(NUMBER *q1, NUMBER *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(NUMBER *q1, NUMBER *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(NUMBER *q1, NUMBER *q2) +{ + register NUMBER *r; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integers for logical or"); + /*NOTREACHED*/ + } + 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(NUMBER *q1, NUMBER *q2) +{ + register NUMBER *r; + ZVALUE res; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integers for logical and"); + /*NOTREACHED*/ + } + 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(NUMBER *q1, NUMBER *q2) +{ + register NUMBER *r; + ZVALUE res; + + if (qisfrac(q1) || qisfrac(q2)) { + math_error("Non-integers for logical xor"); + /*NOTREACHED*/ + } + 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; +} + + +/* + * 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(long n) +{ + register NUMBER *r; + + if (n == 0) + return qlink(&_qone_); + r = qalloc(); + if (n > 0) + zbitvalue(n, &r->num); + else + zbitvalue(-n, &r->den); + return r; +} + +/* + * Return 10^n + */ +NUMBER * +qtenpow(long n) +{ + register NUMBER *r; + + if (n == 0) + return qlink(&_qone_); + r = qalloc(); + if (n > 0) + ztenpow(n, &r->num); + else + ztenpow(-n, &r->den); + return r; +} + + +#if 0 +/* + * 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(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). + * The precision of a number e less than 1 is the positive + * integer p for which e = 2^-p * f, where 1 <= f < 2. + * Numbers greater than or equal to one have a precision of zero. + * For example, the precision of e is 6 if 1/64 <= e < 1/32. + */ +long +qprecision(NUMBER *q) +{ + long r; + + if (qiszero(q) || qisneg(q)) { + math_error("Non-positive number for precision"); + /*NOTREACHED*/ + } + r = - qilog2(q); + return (r < 0 ? 0 : r); +} + + +#if 0 +/* + * Return an integer indicating the sign of a number (-1, 0, or 1). + * i = qtst(q); + */ +FLAG +qtest(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(NUMBER *q1, NUMBER *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(NUMBER *q1, NUMBER *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(NUMBER *q1, NUMBER *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(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); +#if LONG_BITS > BASEB + num.len = 1 + (n >= BASE); + h2[0] = (HALF)(n & BASE1); + h2[1] = (HALF)(n >> BASEB); +#else + num.len = 1; + h2[0] = n; +#endif + num.v = h2; + 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(NUMBER *q, long n) +{ + FULL nf; + 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; +#if LONG_BITS > BASEB + nf = ((FULL) n) >> BASEB; +#else + nf = 0; +#endif + return (((nf != 0) != (len == 2)) || (nf != q->num.v[1])); +} + + +/* + * Number node allocation routines + */ + +#define NNALLOC 1000 + +union allocNode { + NUMBER num; + union allocNode *link; +}; + +static union allocNode *freeNum; + + +NUMBER * +qalloc(void) +{ + register union allocNode *temp; + + if (freeNum == NULL) { + freeNum = (union allocNode *) + malloc(sizeof (NUMBER) * NNALLOC); + if (freeNum == NULL) { + math_error("Not enough memory"); + /*NOTREACHED*/ + } + 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(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/qmath.h b/qmath.h new file mode 100644 index 0000000..82140e7 --- /dev/null +++ b/qmath.h @@ -0,0 +1,234 @@ +/* + * Copyright (c) 1995 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; + +extern NUMBER _qlge_; + +/* + * Input. output, allocation, and conversion routines. + */ +extern NUMBER *qalloc(void); +extern NUMBER *qcopy(NUMBER *q); +extern NUMBER *uutoq(FULL i1, FULL i2); +extern NUMBER *iitoq(long i1, long i2); +extern NUMBER *str2q(char *str); +extern NUMBER *itoq(long i); +extern NUMBER *utoq(FULL i); +extern long qtoi(NUMBER *q); +extern FULL qtou(NUMBER *q); +extern long qparse(char *str, int flags); +extern void qfreenum(NUMBER *q); +extern void qprintnum(NUMBER *q, int mode); +extern void qprintff(NUMBER *q, long width, long precision); +extern void qprintfe(NUMBER *q, long width, long precision); +extern void qprintfr(NUMBER *q, long width, BOOL force); +extern void qprintfd(NUMBER *q, long width); +extern void qprintfx(NUMBER *q, long width); +extern void qprintfb(NUMBER *q, long width); +extern void qprintfo(NUMBER *q, long width); +extern void qprintf(char *, ...); + + + +/* + * Basic numeric routines. + */ +extern NUMBER *qaddi(NUMBER *q, long i); +extern NUMBER *qmuli(NUMBER *q, long i); +extern NUMBER *qdivi(NUMBER *q, long i); +extern NUMBER *qqadd(NUMBER *q1, NUMBER *q2); +extern NUMBER *qsub(NUMBER *q1, NUMBER *q2); +extern NUMBER *qmul(NUMBER *q1, NUMBER *q2); +extern NUMBER *qdiv(NUMBER *q1, NUMBER *q2); +extern NUMBER *qquo(NUMBER *q1, NUMBER *q2, long rnd); +extern NUMBER *qmod(NUMBER *q1, NUMBER *q2, long rnd); +extern NUMBER *qmin(NUMBER *q1, NUMBER *q2); +extern NUMBER *qmax(NUMBER *q1, NUMBER *q2); +extern NUMBER *qand(NUMBER *q1, NUMBER *q2); +extern NUMBER *qor(NUMBER *q1, NUMBER *q2); +extern NUMBER *qxor(NUMBER *q1, NUMBER *q2); +extern NUMBER *qpowermod(NUMBER *q1, NUMBER *q2, NUMBER *q3); +extern NUMBER *qpowi(NUMBER *q1, NUMBER *q2); +extern NUMBER *qsquare(NUMBER *q); +extern NUMBER *qneg(NUMBER *q); +extern NUMBER *qsign(NUMBER *q); +extern NUMBER *qint(NUMBER *q); +extern NUMBER *qfrac(NUMBER *q); +extern NUMBER *qnum(NUMBER *q); +extern NUMBER *qden(NUMBER *q); +extern NUMBER *qinv(NUMBER *q); +extern NUMBER *qabs(NUMBER *q); +extern NUMBER *qinc(NUMBER *q); +extern NUMBER *qdec(NUMBER *q); +extern NUMBER *qshift(NUMBER *q, long n); +extern NUMBER *qtrunc(NUMBER *q1, NUMBER *q2); +extern NUMBER *qround(NUMBER *q, long places, long rnd); +extern NUMBER *qbtrunc(NUMBER *q1, NUMBER *q2); +extern NUMBER *qbround(NUMBER *q, long places, long rnd); +extern NUMBER *qscale(NUMBER *q, long i); +extern BOOL qdivides(NUMBER *q1, NUMBER *q2); +extern BOOL qcmp(NUMBER *q1, NUMBER *q2); +extern BOOL qcmpi(NUMBER *q, long i); +extern FLAG qrel(NUMBER *q1, NUMBER *q2); +extern FLAG qreli(NUMBER *q, long i); +extern BOOL qisset(NUMBER *q, long i); + + +/* + * More complicated numeric functions. + */ +extern NUMBER *qcomb(NUMBER *q1, NUMBER *q2); +extern NUMBER *qgcd(NUMBER *q1, NUMBER *q2); +extern NUMBER *qlcm(NUMBER *q1, NUMBER *q2); +extern NUMBER *qfact(NUMBER *q); +extern NUMBER *qpfact(NUMBER *q); +extern NUMBER *qminv(NUMBER *q1, NUMBER *q2); +extern NUMBER *qfacrem(NUMBER *q1, NUMBER *q2); +extern NUMBER *qperm(NUMBER *q1, NUMBER *q2); +extern NUMBER *qgcdrem(NUMBER *q1, NUMBER *q2); +extern NUMBER *qlowfactor(NUMBER *q1, NUMBER *q2); +extern NUMBER *qfib(NUMBER *q); +extern NUMBER *qcfappr(NUMBER *q, NUMBER *epsilon, long R); +extern NUMBER *qcfsim(NUMBER *q, long R); +extern NUMBER *qisqrt(NUMBER *q); +extern NUMBER *qjacobi(NUMBER *q1, NUMBER *q2); +extern NUMBER *qiroot(NUMBER *q1, NUMBER *q2); +extern NUMBER *qmappr(NUMBER *q, NUMBER *e, long R); +extern NUMBER *qlcmfact(NUMBER *q); +extern NUMBER *qredcin(NUMBER *q1, NUMBER *q2); +extern NUMBER *qredcout(NUMBER *q1, NUMBER *q2); +extern NUMBER *qredcmul(NUMBER *q1, NUMBER *q2, NUMBER *q3); +extern NUMBER *qredcsquare(NUMBER *q1, NUMBER *q2); +extern NUMBER *qredcpower(NUMBER *q1, NUMBER *q2, NUMBER *q3); +extern BOOL qprimetest(NUMBER *q1, NUMBER *q2, NUMBER *q3); +extern BOOL qissquare(NUMBER *q); +extern long qilog2(NUMBER *q); +extern long qilog10(NUMBER *q); +extern long qilog(NUMBER *q1, NUMBER *q2); +extern BOOL qcmpmod(NUMBER *q1, NUMBER *q2, NUMBER *q3); +extern BOOL qquomod(NUMBER *q1, NUMBER *q2, NUMBER **retdiv, NUMBER **retmod); +extern FLAG qnear(NUMBER *q1, NUMBER *q2, NUMBER *epsilon); +extern long qdigit(NUMBER *q, long i); +extern long qprecision(NUMBER *q); +extern long qplaces(NUMBER *q); +extern long qdigits(NUMBER *q); +extern void setepsilon(NUMBER *q); +extern NUMBER *qbitvalue(long i); +extern NUMBER *qtenpow(long i); + +#if 0 +extern NUMBER *qmulmod(NUMBER *q1, NUMBER *q2, NUMBER *q3); +extern NUMBER *qsquaremod(NUMBER *q1, NUMBER *q2); +extern NUMBER *qaddmod(NUMBER *q1, NUMBER *q2, NUMBER *q3); +extern NUMBER *qsubmod(NUMBER *q1, NUMBER *q2, NUMBER *q3); +extern NUMBER *qreadval(FILE *fp); +extern NUMBER *qnegmod(NUMBER *q1, NUMBER *q2); +extern BOOL qbittest(NUMBER *q, long i); +extern FLAG qtest(NUMBER *q); +#endif + + +/* + * Transcendental functions. These all take an epsilon argument to + * specify the required accuracy of the calculation. + */ +extern void qsincos(NUMBER *q, long bitnum, NUMBER **vs, NUMBER **vc); +extern NUMBER *qsqrt(NUMBER *q, NUMBER *epsilon, long R); +extern NUMBER *qpower(NUMBER *q1, NUMBER *q2, NUMBER *epsilon); +extern NUMBER *qroot(NUMBER *q1, NUMBER *q2, NUMBER *epsilon); +extern NUMBER *qcos(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qsin(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qexp(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qln(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qtan(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qsec(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qcot(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qcsc(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qacos(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qasin(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qatan(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qasec(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qacsc(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qacot(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qatan2(NUMBER *q1, NUMBER *q2, NUMBER *epsilon); +extern NUMBER *qhypot(NUMBER *q1, NUMBER *q2, NUMBER *epsilon); +extern NUMBER *qcosh(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qsinh(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qtanh(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qcoth(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qsech(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qcsch(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qacosh(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qasinh(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qatanh(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qasech(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qacsch(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qacoth(NUMBER *q, NUMBER *epsilon); +extern NUMBER *qlegtoleg(NUMBER *q, NUMBER *epsilon, BOOL wantneg); +extern NUMBER *qpi(NUMBER *epsilon); + + +/* + * external swap functions + */ +extern NUMBER *swap_b8_in_NUMBER(NUMBER *dest, NUMBER *src, BOOL all); +extern NUMBER *swap_b16_in_NUMBER(NUMBER *dest, NUMBER *src, BOOL all); +extern NUMBER *swap_HALF_in_NUMBER(NUMBER *dest, NUMBER *src, BOOL all); + + +/* + * 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 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 */ + + +/* + * constants used often by the arithmetic routines + */ +extern NUMBER _qzero_, _qone_, _qnegone_, _qonehalf_, _qonesqbase_; + +#endif diff --git a/qmod.c b/qmod.c new file mode 100644 index 0000000..1a0b5b6 --- /dev/null +++ b/qmod.c @@ -0,0 +1,498 @@ +/* + * Copyright (c) 1995 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" +#include "config.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(NUMBER *q); + + +/* + * qmod(q1, q2, rnd) returns zero if q1 is a multiple of q2; it + * q1 if q2 is zero. For other q1 and q2, it returns one of + * the two remainders with absolute value less than abs(q2) + * when q1 is divided by q2; which remainder is returned is + * determined by rnd and the signs and relative sizes of q1 and q2. + */ +NUMBER * +qmod(NUMBER *q1, NUMBER *q2, long rnd) +{ + ZVALUE tmp, tmp1, tmp2; + NUMBER *q; + + if (qiszero(q2)) return qlink(q1); + if (qiszero(q1)) return qlink(&_qzero_); + if (qisint(q1) && qisint(q2)) { /* easy case */ + zmod(q1->num, q2->num, &tmp, rnd); + if (ziszero(tmp)) { + zfree(tmp); + return qlink(&_qzero_); + } + if(zisone(tmp)) { + zfree(tmp); + return qlink(&_qone_); + } + q = qalloc(); + q->num = tmp; + return q; + } + zmul(q1->num, q2->den, &tmp1); + zmul(q2->num, q1->den, &tmp2); + zmod(tmp1, tmp2, &tmp, rnd); + zfree(tmp1); + zfree(tmp2); + if (ziszero(tmp)) { + zfree(tmp); + return qlink(&_qzero_); + } + zmul(q1->den, q2->den, &tmp1); + q = qalloc(); + zreduce(tmp, tmp1, &q->num, &q->den); + zfree(tmp1); + zfree(tmp); + return q; +} + + +/* + * Given two numbers q1, q2, qquomod(q1, q2, retqdiv, retqmod) + * calculates an integral quotient and numerical remainder such that + * q1 = q2 * quotient + remainder. The remainder is zero if + * q1 is a multiple of q2; the quotient is zero if q2 is zero. + * In other cases, the remainder always has absolute value less than + * abs(q2). Which of the two possible quotient-remainder pairs is returned + * is determined by the conf->quomod configuration parameter. + * If the quomod parameter is zero, the remainder has the sign of q2 + * and the qotient is rounded towards zero. + * The results are returned indirectly through pointers. + * The function returns FALSE or + * TRUE according as the remainder is or is not zero. For + * example, if conf->quomod = 0, + * qquomod(11, 4, &x, &y) sets x to 2, y to 3, and returns TRUE. + * qquomod(-7, -3, &x, &y) sets x to 2, y to -1, and returns TRUE. + * + * given: + * q1 numbers to do quotient with + * q2 numbers to do quotient with + * retqdiv returned quotient + * retqmod returned modulo + */ +BOOL +qquomod(NUMBER *q1, NUMBER *q2, NUMBER **retqdiv, NUMBER **retqmod) +{ + NUMBER *qq, *qm; + ZVALUE tmp1, tmp2, tmp3, tmp4; + + if (qiszero(q2)) { /* zero modulus case */ + qq = qlink(&_qzero_); + qm = qlink(q1); + } + else if (qisint(q1) && qisint(q2)) { /* integer case */ + zdiv(q1->num, q2->num, &tmp1, &tmp2, conf->quomod); + if (ziszero(tmp1)) { + zfree(tmp1); + zfree(tmp2); + qq = qlink(&_qzero_); + qm = qlink(q1); + } + else { + qq = qalloc(); + qq->num = tmp1; + if (ziszero(tmp2)) { + zfree(tmp2); + qm = qlink(&_qzero_); + } + else { + qm = qalloc(); + qm->num = tmp2; + } + } + } + else { /* fractional case */ + zmul(q1->num, q2->den, &tmp1); + zmul(q2->num, q1->den, &tmp2); + zdiv(tmp1, tmp2, &tmp3, &tmp4, conf->quomod); + zfree(tmp1); + zfree(tmp2); + if (ziszero(tmp3)) { + zfree(tmp3); + zfree(tmp4); + qq = qlink(&_qzero_); + qm = qlink(q1); + } + else { + qq = qalloc(); + qq->num = tmp3; + if (ziszero(tmp4)) { + zfree(tmp4); + qm = qlink(&_qzero_); + } + else { + qm = qalloc(); + zmul(q1->den, q2->den, &tmp1); + zreduce(tmp4, tmp1, &qm->num, &qm->den); + zfree(tmp1); + zfree(tmp4); + } + } + } + *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(NUMBER *q1, NUMBER *q2, NUMBER *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(NUMBER *q1, NUMBER *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(NUMBER *q1, NUMBER *q2, NUMBER *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(NUMBER *q1, NUMBER *q2, NUMBER *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(NUMBER *q1, NUMBER *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 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(NUMBER *q1, NUMBER *q2, NUMBER *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. + * + * given: + * q1 number to convert into REDC format + * q2 modulus + */ +NUMBER * +qredcin(NUMBER *q1, NUMBER *q2) +{ + REDC *rp; /* REDC information */ + NUMBER *r; /* result */ + + if (qisfrac(q1)) + math_error("Non-integer for qredcin"); + rp = qfindredc(q2); + r = qalloc(); + zredcencode(rp, q1->num, &r->num); + if (qiszero(r)) { + qfree(r); + return qlink(&_qzero_); + } + return r; +} + + +/* + * Convert a REDC format number back into a normal integer. + * The resulting number is in the range 0 to the modulus - 1. + * + * given: + * q1 number to convert into REDC format + * q2 modulus + */ +NUMBER * +qredcout(NUMBER *q1, NUMBER *q2) +{ + REDC *rp; /* REDC information */ + NUMBER *r; /* result */ + + if (qisfrac(q1)) + math_error("Non-integer argument for rcout"); + rp = qfindredc(q2); + if (qiszero(q1) || qisunit(q2)) + 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. + * + * given: + * q1 REDC numbers to be multiplied + * q2 REDC numbers to be multiplied + * q3 modulus + */ +NUMBER * +qredcmul(NUMBER *q1, NUMBER *q2, NUMBER *q3) +{ + REDC *rp; /* REDC information */ + NUMBER *r; /* result */ + + if (qisfrac(q1) || qisfrac(q2)) + math_error("Non-integer argument for rcmul"); + rp = qfindredc(q3); + if (qiszero(q1) || qiszero(q2) || qisunit(q3)) + 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. + * + * given: + * q1 REDC numbers to be squared + * q2 modulus + */ +NUMBER * +qredcsquare(NUMBER *q1, NUMBER *q2) +{ + REDC *rp; /* REDC information */ + NUMBER *r; /* result */ + + if (qisfrac(q1)) + math_error("Non-integer argument for rcsq"); + rp = qfindredc(q2); + if (qiszero(q1) || qisunit(q2)) + 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. + * + * given: + * q1 REDC number to be raised + * q2 power to be raised to + * q3 modulus + */ +NUMBER * +qredcpower(NUMBER *q1, NUMBER *q2, NUMBER *q3) +{ + REDC *rp; /* REDC information */ + NUMBER *r; /* result */ + + if (qisfrac(q1) || qisfrac(q2) || qisfrac(q2)) + math_error("Non-integer argument for rcpow"); + if (qisneg(q2)) + math_error("Negative exponent argument for rcpow"); + rp = qfindredc(q3); + 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. + * + * given: + * q modulus to find REDC information of + */ +static REDC * +qfindredc(NUMBER *q) +{ + 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) || qisneg(q)) { + math_error("REDC modulus must be positive odd integer"); + /*NOTREACHED*/ + } + + 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/qtrans.c b/qtrans.c new file mode 100644 index 0000000..f38b33e --- /dev/null +++ b/qtrans.c @@ -0,0 +1,1526 @@ +/* + * Copyright (c) 1995 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" + +HALF _qlgenum_[] = { 36744 }; +HALF _qlgeden_[] = { 25469 }; +NUMBER _qlge_ = { { _qlgenum_, 1, 0 }, { _qlgeden_, 1, 0 }, 1 }; + +NUMBER *qmappr(NUMBER *q, NUMBER *e, long R); +static NUMBER *qexprel(NUMBER *q, long bitnum); + +/* + * Evaluate and store in specified locations the sin and cos of a given + * number to accuracy corresponding to a specified number of binary digits. + */ +void +qsincos(NUMBER *q, long bitnum, NUMBER **vs, NUMBER **vc) +{ + long n, m, k, h, s, t, d; + NUMBER *qtmp1, *qtmp2; + ZVALUE X, cossum, sinsum, mul, ztmp1, ztmp2, ztmp3; + + qtmp1 = qabs(q); + h = qilog2(qtmp1); + qfree(qtmp1); + k = bitnum + h + 1; + if (k < 0) { + *vs = qlink(&_qzero_); + *vc = qlink(&_qone_); + return; + } + s = k; + if (k) { + do { + t = s; + s = (s + k/s)/2; + } + while (t > s); + } /* s is int(sqrt(k)) */ + s++; + if (s < -h) + s = -h; + n = h + s; /* n is number of squarings that will be required */ + m = bitnum + n; + while (s > 0) { /* increasing m by ilog2(s) */ + s >>= 1; + m++; + } /* m is working number of bits */ + qtmp1 = qscale(q, m - n); + zquo(qtmp1->num, qtmp1->den, &X, 24); + qfree(qtmp1); + if (ziszero(X)) { + zfree(X); + *vs = qlink(&_qzero_); + *vc = qlink(&_qone_); + return; + } + zbitvalue(m, &cossum); + zcopy(X, &sinsum); + zcopy(X, &mul); + d = 1; + for (;;) { + X.sign = !X.sign; + zmul(X, mul, &ztmp1); + zfree(X); + zshift(ztmp1, -m, &ztmp2); + zfree(ztmp1); + zdivi(ztmp2, ++d, &X); + zfree(ztmp2); + if (ziszero(X)) + break; + zadd(cossum, X, &ztmp1); + zfree(cossum); + cossum = ztmp1; + zmul(X, mul, &ztmp1); + zfree(X); + zshift(ztmp1, -m, &ztmp2); + zfree(ztmp1); + zdivi(ztmp2, ++d, &X); + zfree(ztmp2); + if (ziszero(X)) + break; + zadd(sinsum, X, &ztmp1); + zfree(sinsum); + sinsum = ztmp1; + } + zfree(X); + zfree(mul); + while (n-- > 0) { + zsquare(cossum, &ztmp1); + zsquare(sinsum, &ztmp2); + zsub(ztmp1, ztmp2, &ztmp3); + zfree(ztmp1); + zfree(ztmp2); + zmul(cossum, sinsum, &ztmp1); + zfree(cossum); + zfree(sinsum); + zshift(ztmp3, -m, &cossum); + zfree(ztmp3); + zshift(ztmp1, 1 - m, &sinsum); + zfree(ztmp1); + } + h = zlowbit(cossum); + qtmp1 = qalloc(); + if (m > h) { + zshift(cossum, -h, &qtmp1->num); + zbitvalue(m - h, &qtmp1->den); + } + else + zshift(cossum, - m, &qtmp1->num); + zfree(cossum); + *vc = qtmp1; + h = zlowbit(sinsum); + qtmp2 = qalloc(); + if (m > h) { + zshift(sinsum, -h, &qtmp2->num); + zbitvalue(m - h, &qtmp2->den); + } + else + zshift(sinsum, -m, &qtmp2->num); + zfree(sinsum); + *vs = qtmp2; + return; +} + +/* + * Calculate the cosine of a number to a near multiple of epsilon. + * This calls qsincos() and discards the value of sin. + */ +NUMBER * +qcos(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *sin, *cos, *res; + long n; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for cosine"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qmappr(&_qone_, epsilon, 24); + n = -qilog2(epsilon); + if (n < 0) + return qlink(&_qzero_); + qsincos(q, n + 2, &sin, &cos); + qfree(sin); + res = qmappr(cos, epsilon, 24); + qfree(cos); + return res; +} + + + +/* + * This calls qsincos() and discards the value of cos. + */ +NUMBER * +qsin(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *sin, *cos, *res; + long n; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for sine"); + /*NOTREACHED*/ + } + n = -qilog2(epsilon); + if (qiszero(q) || n < 0) + return qlink(&_qzero_); + qsincos(q, n + 2, &sin, &cos); + qfree(cos); + res = qmappr(sin, epsilon, 24); + qfree(sin); + return res; +} + + +/* + * Calculate the tangent function. + */ +NUMBER * +qtan(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *sin, *cos, *tan, *res; + long n, k, m; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for tangent"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qlink(q); + n = qilog2(epsilon); + k = (n > 0) ? 4 + n/2 : 4; + for (;;) { + qsincos(q, 2 * k - n, &sin, &cos); + if (qiszero(cos)) { + qfree(sin); + qfree(cos); + k = 2 * k - n + 4; + continue; + } + m = -qilog2(cos); + if (m < k) + break; + qfree(sin); + qfree(cos); + k = m + 1; + } + tan = qdiv(sin, cos); + qfree(sin); + qfree(cos); + res = qmappr(tan, epsilon, 24); + qfree(tan); + return res; +} + + +/* + * Calculate the cotangent function. + */ +NUMBER * +qcot(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *sin, *cos, *cot, *res; + long n, k, m; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for cotangent"); + /*NOTREACHED*/ + } + if (qiszero(q)) { + math_error("Zero argument for cotangent"); + /*NOTREACHED*/ + } + k = -qilog2(q); + n = qilog2(epsilon); + if (k < 0) + k = (n > 0) ? n/2 : 0; + k += 4; + for (;;) { + qsincos(q, 2 * k - n, &sin, &cos); + if (qiszero(sin)) { + qfree(sin); + qfree(cos); + k = 2 * k - n + 4; + continue; + } + m = -qilog2(sin); + if (m < k) + break; + qfree(sin); + qfree(cos); + k = m + 1; + } + cot = qdiv(cos, sin); + qfree(sin); + qfree(cos); + res = qmappr(cot, epsilon, 24); + qfree(cot); + return res; +} + + +/* + * Calculate the secant function. + */ +NUMBER * +qsec(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *sin, *cos, *sec, *res; + long n, k, m; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for secant"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qmappr(&_qone_, epsilon, 24); + n = qilog2(epsilon); + k = (n > 0) ? 4 + n/2 : 4; + for (;;) { + qsincos(q, 2 * k - n, &sin, &cos); + qfree(sin); + if (qiszero(cos)) { + qfree(cos); + k = 2 * k - n + 4; + continue; + } + m = -qilog2(cos); + if (m < k) + break; + qfree(cos); + k = m + 1; + } + sec = qinv(cos); + qfree(cos); + res = qmappr(sec, epsilon, 24); + qfree(sec); + return res; +} + + +/* + * Calculate the cosecant function. + */ +NUMBER * +qcsc(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *sin, *cos, *csc, *res; + long n, k, m; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for cosecant"); + /*NOTREACHED*/ + } + if (qiszero(q)) { + math_error("Zero argument for cosecant"); + /*NOTREACHED*/ + } + k = -qilog2(q); + n = qilog2(epsilon); + if (k < 0) + k = (n > 0) ? n/2 : 0; + k += 4; + for (;;) { + qsincos(q, 2 * k - n, &sin, &cos); + qfree(cos); + if (qiszero(sin)) { + qfree(sin); + k = 2 * k - n + 4; + continue; + } + m = -qilog2(sin); + if (m < k) + break; + qfree(sin); + k = m + 1; + } + csc = qinv(sin); + qfree(sin); + res = qmappr(csc, epsilon, 24); + qfree(csc); + return res; +} +/* + * Calculate the arcsine function. + * The result is in the range -pi/2 to pi/2. + */ +NUMBER * +qasin(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *qtmp1, *qtmp2, *epsilon1; + ZVALUE ztmp; + BOOL neg; + FLAG r; + + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for asin"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qlink(&_qzero_); + ztmp = q->num; + neg = ztmp.sign; + ztmp.sign = 0; + r = zrel(ztmp, q->den); + if (r > 0) { + math_error("Argument out of range for asin"); + /*NOTREACHED*/ + } + if (r == 0) { + epsilon1 = qscale(epsilon, 1L); + qtmp2 = qpi(epsilon1); + qtmp1 = qscale(qtmp2, -1L); + } + else { + epsilon1 = qscale(epsilon, -2L); + qtmp1 = qalloc(); + zsquare(q->num, &qtmp1->num); + zsquare(q->den, &ztmp); + zsub(ztmp, qtmp1->num, &qtmp1->den); + zfree(ztmp); + qtmp2 = qsqrt(qtmp1, epsilon1, 24); + qfree(qtmp1); + qtmp1 = qatan(qtmp2, epsilon); + } + qfree(qtmp2); + qfree(epsilon1); + if (neg) { + qtmp2 = qneg(qtmp1); + qfree(qtmp1); + return(qtmp2); + } + return qtmp1; +} + + + +/* + * Calculate the acos function. + * The result is in the range 0 to pi. + */ +NUMBER * +qacos(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *q1, *q2, *epsilon1; + ZVALUE z; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for acos"); + /*NOTREACHED*/ + } + if (qisone(q)) + return qlink(&_qzero_); + if (qisnegone(q)) + return qpi(epsilon); + + z = q->num; + z.sign = 0; + if (zrel(z, q->den) > 0) { + math_error("Argument out of range for acos"); + /*NOTREACHED*/ + } + epsilon1 = qscale(epsilon, -3L); /* ??? */ + q1 = qalloc(); + zsub(q->den, q->num, &q1->num); + zadd(q->den, q->num, &q1->den); + q2 = qsqrt(q1, epsilon1, 24L); + qfree(q1); + qfree(epsilon1); + epsilon1 = qscale(epsilon, -1L); + q1 = qatan(q2, epsilon1); + qfree(epsilon1); + qfree(q2); + q2 = qscale(q1, 1L); + qfree(q1) + return q2; +} + + +/* + * Calculate the arctangent function to the nearest or next to nearest + * multiple of epsilon. Algorithm uses + * atan(x) = 2 * atan(x/(1 + sqrt(1+x^2))) + * to reduce x to a small value and then + * atan(x) = x - x^3/3 + ... + */ +NUMBER * +qatan(NUMBER *q, NUMBER *epsilon) +{ + long m, k, i, d; + ZVALUE X, D, DD, sum, mul, term, ztmp1, ztmp2; + NUMBER *qtmp, *res; + BOOL sign; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for arctangent"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qlink(&_qzero_); + m = 12 - qilog2(epsilon); + /* 4 bits for 4 doublings; 8 for rounding */ + if (m < 8) + m = 8; /* m is number of working binary digits */ + qtmp = qscale(q, m); + zquo(qtmp->num, qtmp->den, &X, 24); + qfree(qtmp); + zbitvalue(m, &D); /* q has become X/D */ + zsquare(D, &DD); + i = 4; /* maybe this should be larger */ + while (i-- > 0 && !ziszero(X)) { + zsquare(X, &ztmp1); + zadd(ztmp1, DD, &ztmp2); + zfree(ztmp1); + zsqrt(ztmp2, &ztmp1, 24L); + zfree(ztmp2); + zadd(ztmp1, D, &ztmp2); + zshift(X, m, &ztmp1); + zfree(X); + zquo(ztmp1, ztmp2, &X, 24L); + zfree(ztmp1); + zfree(ztmp2); + } + zfree(DD); + zfree(D); + if (ziszero(X)) { + zfree(X); + return qlink(&_qzero_); + } + zcopy(X, &sum); + zsquare(X, &ztmp1); + zshift(ztmp1, -m, &mul); + zfree(ztmp1); + d = 3; + sign = !X.sign; + for (;;) { + if (d > BASE) { + math_error("Too many terms required for atan"); + /*NOTREACHED*/ + } + zmul(X, mul, &ztmp1); + zfree(X); + zshift(ztmp1, -m, &X); /* X now (original X)^d */ + zfree(ztmp1); + zdivi(X, d, &term); + if (ziszero(term)) { + zfree(term); + break; + } + term.sign = sign; + zadd(sum, term, &ztmp1); + zfree(sum); + zfree(term); + sum = ztmp1; + sign = !sign; + d += 2; + } + zfree(mul); + zfree(X); + qtmp = qalloc(); + k = zlowbit(sum); + if (k) { + zshift(sum, -k, &qtmp->num); + zfree(sum); + } + else + qtmp->num = sum; + zbitvalue(m - 4 - k, &qtmp->den); + res = qmappr(qtmp, epsilon, 24L); + qfree(qtmp); + return res; +} + +/* + * Inverse secant function + */ +NUMBER * +qasec(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp, *res; + + tmp = qinv(q); + res = qacos(tmp, epsilon); + qfree(tmp); + return res; +} + + +/* + * Inverse cosecant function + */ +NUMBER * +qacsc(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp, *res; + + tmp = qinv(q); + res = qasin(tmp, epsilon); + qfree(tmp); + return res; +} + + +/* + * Inverse cotangent function + */ +NUMBER * +qacot(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3, *epsilon1; + + if (qiszero(epsilon)) { + math_error("Zero epsilon for acot"); + /*NOTREACHED*/ + } + if (qiszero(q)) { + epsilon1 = qscale(epsilon, 1L); + tmp1 = qpi(epsilon1); + qfree(epsilon1); + tmp2 = qscale(tmp1, -1L); + qfree(tmp1); + return tmp2; + } + tmp1 = qinv(q); + if (!qisneg(q)) { + tmp2 = qatan(tmp1, epsilon); + qfree(tmp1); + return tmp2; + } + epsilon1 = qscale(epsilon, -2L); + tmp2 = qatan(tmp1, epsilon1); + qfree(tmp1); + tmp1 = qpi(epsilon1); + qfree(epsilon1); + tmp3 = qqadd(tmp1, tmp2); + qfree(tmp1); + qfree(tmp2); + tmp1 = qmappr(tmp3, epsilon, 24L); + qfree(tmp3); + return tmp1; +} + + +/* + * Calculate the angle which is determined by the point (x,y). + * This is the same as atan(y/x) for positive x, but is continuous + * except for y = 0, x <= 0. By convention, y is the first argument. + * For all x, y, -pi < atan2 <= pi. For example, qatan2(1, -1) = 3/4 * pi. + */ +NUMBER * +qatan2(NUMBER *qy, NUMBER *qx, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3, *epsilon2; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for atan2"); + /*NOTREACHED*/ + } + 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 (x <= 0) with nonzero y. + * Calculate the angle by using the formula: + * atan2(y,x) = 2 * atan(sgn(y) * sqrt((x/y)^2 + 1) - x/y). + */ + epsilon2 = qscale(epsilon, -4L); + tmp1 = qdiv(qx, qy); + tmp2 = qsquare(tmp1); + tmp3 = qqadd(tmp2, &_qone_); + qfree(tmp2); + tmp2 = qsqrt(tmp3, epsilon2, 24L | (qy->num.sign * 64)); + qfree(tmp3); + tmp3 = qsub(tmp2, tmp1); + qfree(tmp2); + qfree(tmp1); + qfree(epsilon2); + epsilon2 = qscale(epsilon, -1L); + tmp1 = qatan(tmp3, epsilon2); + qfree(epsilon2); + qfree(tmp3); + tmp2 = qscale(tmp1, 1L); + qfree(tmp1); + return tmp2; +} + + +/* + * 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(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)) { + math_error("zero epsilon value for pi"); + /*NOTREACHED*/ + } + bits = -qilog2(epsilon) + 4; + if (bits < 4) + bits = 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 = qmappr(t1, epsilon, 24L); + qfree(t1); + return r; +} + +/* + * Calculate the exponential function to the nearest or next to nearest + * multiple of the positive number epsilon. + */ +NUMBER * +qexp(NUMBER *q, NUMBER *epsilon) +{ + long m, n; + NUMBER *tmp1, *tmp2; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for exp"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qmappr(&_qone_, epsilon, 24); + tmp1 = qmul(q, &_qlge_); + m = qtoi(tmp1) + 1; /* exp(q) < 2^m */ + qfree(tmp1); + + n = qilog2(epsilon); /* 2^n <= epsilon < 2^(n+1) */ + if (m < n) + return qlink(&_qzero_); + tmp1 = qabs(q); + tmp2 = qexprel(tmp1, m - n + 2); + qfree(tmp1); + if (qisneg(q)) { + tmp1 = qinv(tmp2); + qfree(tmp2); + tmp2 = tmp1; + } + tmp1 = qmappr(tmp2, epsilon, 24L); + qfree(tmp2); + return tmp1; +} + + +/* + * Calculate the exponential function with relative error corresponding + * to a specified number of significant bits + * Requires *q >= 0, bitnum >= 0. + */ +static NUMBER * +qexprel(NUMBER *q, long bitnum) +{ + long n, m, k, h, s, t, d; + NUMBER *qtmp1; + ZVALUE X, B, sum, term, ztmp1, ztmp2; + + h = qilog2(q); + k = bitnum + h + 1; + if (k < 0) + return qlink(&_qone_); + s = k; + if (k) { + do { + t = s; + s = (s + k/s)/2; + } + while (t > s); + } /* s is int(sqrt(k)) */ + s++; + if (s < -h) + s = -h; + n = h + s; /* n is number of squarings that will be required */ + m = bitnum + n; + while (s > 0) { /* increasing m by ilog2(s) */ + s >>= 1; + m++; + } /* m is working number of bits */ + qtmp1 = qscale(q, m - n); + zquo(qtmp1->num, qtmp1->den, &X, 24); + qfree(qtmp1); + if (ziszero(X)) { + zfree(X); + return qlink(&_qone_); + } + zbitvalue(m, &sum); + zcopy(X, &term); + d = 1; + do { + zadd(sum, term, &ztmp1); + zfree(sum); + sum = ztmp1; + zmul(term, X, &ztmp1); + zfree(term); + zshift(ztmp1, -m, &ztmp2); + zfree(ztmp1); + zdivi(ztmp2, ++d, &term); + zfree(ztmp2); + } + while (!ziszero(term)); + zfree(term); + zfree(X); + k = 0; + zbitvalue(2 * m + 1, &B); + while (n-- > 0) { + k *= 2; + zsquare(sum, &ztmp1); + zfree(sum); + if (zrel(ztmp1, B) >= 0) { + zshift(ztmp1, -m - 1, &sum); + k++; + } + else + zshift(ztmp1, -m, &sum); + zfree(ztmp1); + } + zfree(B); + h = zlowbit(sum); + qtmp1 = qalloc(); + if (m > h + k) { + zshift(sum, -h, &qtmp1->num); + zbitvalue(m - h - k, &qtmp1->den); + } + else + zshift(sum, k - m, &qtmp1->num); + zfree(sum); + return qtmp1; +} + + +/* + * Calculate the natural logarithm of a number accurate to the specified + * positive epsilon. + */ +NUMBER * +qln(NUMBER *q, NUMBER *epsilon) +{ + long m, n, k, h, d; + ZVALUE term, sum, mul, pow, X, D, B, ztmp; + NUMBER *qtmp, *res; + BOOL neg; + + if (qiszero(q) || qiszero(epsilon)) { + math_error("Zero argument for qln"); + /*NOTREACHED*/ + } + if (qisunit(q)) + return qlink(&_qzero_); + q = qabs(q); /* Ignore sign of q */ + neg = (zrel(q->num, q->den) < 0); + if (neg) { + qtmp = qinv(q); + qfree(q); + q = qtmp; + } + k = qilog2(q); + m = -qilog2(epsilon); /* m will be number of working bits */ + if (m < 0) + m = 0; + h = k; + while (h > 0) { + h /= 2; + m++; /* Add 1 for each sqrt until X < 2 */ + } + m += 18; /* 8 more sqrts, 8 for rounding, 2 for epsilon/4 */ + qtmp = qscale(q, m - k); + zquo(qtmp->num, qtmp->den, &X, 24L); + qfree(q); + qfree(qtmp); + + zbitvalue(m, &D); /* Now "q" = X/D */ + zbitvalue(m - 8, &ztmp); + zadd(D, ztmp, &B); /* Will take sqrts until X <= B */ + zfree(ztmp); + + n = 1; /* n is to count 1 + number of sqrts */ + + while (k > 0 || zrel(X, B) > 0) { + n++; + zshift(X, m + (k & 1), &ztmp); + zfree(X); + zsqrt(ztmp, &X, 24); + zfree(ztmp) + k /= 2; + } + zfree(B); + zsub(X, D, &pow); /* pow, mul used as tmps */ + zadd(X, D, &mul); + zfree(X); + zfree(D); + zshift(pow, m, &ztmp); + zfree(pow); + zquo(ztmp, mul, &pow, 24); /* pow now (X - D)/(X + D) */ + zfree(ztmp); + zfree(mul); + + zcopy(pow, &sum); /* pow is first term of sum */ + zsquare(pow, &ztmp); + zshift(ztmp, -m, &mul); /* mul is now multiplier for powers */ + zfree(ztmp); + + d = 1; + for (;;) { + zmul(pow, mul, &ztmp); + zfree(pow); + zshift(ztmp, -m, &pow); + zfree(ztmp); + d += 2; + zdivi(pow, d, &term); /* Round down div should be round off */ + if (ziszero(term)) { + zfree(term); + break; + } + zadd(sum, term, &ztmp); + zfree(term); + zfree(sum); + sum = ztmp; + } + zfree(pow); + zfree(mul); + k = zlowbit(sum); + qtmp = qalloc(); + sum.sign = neg; + if (k) { + zshift(sum, -k, &qtmp->num); + zfree(sum); + } + else { + qtmp->num = sum; + } + zbitvalue(m - k - n, &qtmp->den); + res = qmappr(qtmp, epsilon, 24L); + qfree(qtmp); + return res; +} + + +/* + * Calculate the result of raising one number to the power of another. + * The result is calculated to the nearest or next to nearest multiple of + * epsilon. + */ +NUMBER * +qpower(NUMBER *q1, NUMBER *q2, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *epsilon2; + NUMBER *q1tmp, *q2tmp; + long m, n; + + if (qiszero(epsilon)) { + math_error("Zero epsilon for power"); + /*NOTREACHED*/ + } + if (qiszero(q1) && qisneg(q2)) { + math_error("Negative power of zero"); + /*NOTREACHED*/ + } + if (qiszero(q2) || qisone(q1)) { + tmp1 = qlink(&_qone_); + tmp2 = qmappr(tmp1, epsilon, 24L); + qfree(tmp1); + return tmp2; + } + if (qiszero(q1)) + return qlink(&_qzero_); + if (qisneg(q1)) { + math_error("Negative base for qpower"); + /*NOTREACHED*/ + } + if (qisone(q2)) { + return qmappr(q1, epsilon, 24L); + } + if (zrel(q1->num, q1->den) < 0) { + q1tmp = qinv(q1); + q2tmp = qneg(q2); + } + else { + q1tmp = qlink(q1); + q2tmp = qlink(q2); + } + if (qisone(q2tmp)) { + tmp1 = q1tmp; + qfree(q2tmp); + tmp2 = qmappr(tmp1, epsilon, 24L); + qfree(tmp1); + return tmp2; + } + m = qilog2(q1tmp); + n = qilog2(epsilon); + if (qisneg(q2tmp)) { + if (m > 0) { + tmp1 = itoq(m); + tmp2 = qmul(tmp1, q2tmp); + m = qtoi(tmp2); + } + else { + tmp1 = qdec(q1tmp); + tmp2 = qdiv(tmp1, q1tmp); + qfree(tmp1); + tmp1 = qmul(tmp2, q2tmp); + qfree(tmp2); + tmp2 = qmul(tmp1, &_qlge_); + m = qtoi(tmp2); + } + } + else { + if (m > 0) { + tmp1 = itoq(m + 1); + tmp2 = qmul(tmp1, q2tmp); + m = qtoi(tmp2); + } + else { + tmp1 = qdec(q1tmp); + tmp2 = qmul(tmp1, q2tmp); + qfree(tmp1); + tmp1 = qmul(tmp2, &_qlge_); + m = qtoi(tmp1); + } + } + qfree(tmp1); + qfree(tmp2); + m += 1; + if (m < n) { + qfree(q1tmp); + qfree(q2tmp); + return qlink(&_qzero_); + } + tmp1 = qdiv(epsilon, q2tmp); + tmp2 = qscale(tmp1, -m - 4); + epsilon2 = qabs(tmp2); + qfree(tmp1); + qfree(tmp2); + tmp1 = qln(q1tmp, epsilon2); + qfree(epsilon2); + tmp2 = qmul(tmp1, q2tmp); + qfree(tmp1); + qfree(q1tmp); + qfree(q2tmp); + if (qisneg(tmp2)) { + tmp1 = qneg(tmp2); + qfree(tmp2); + tmp2 = qexprel(tmp1, m - n + 3); + qfree(tmp1); + tmp1 = qinv(tmp2); + } + else + tmp1 = qexprel(tmp2, m - n + 3) ; + qfree(tmp2); + tmp2 = qmappr(tmp1, epsilon, 24L); + qfree(tmp1); + return tmp2; +} + + +/* + * Calculate the Kth root of a number to within the specified accuracy. + */ +NUMBER * +qroot(NUMBER *q1, NUMBER *q2, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2; + int neg; + + if (qiszero(epsilon)) { + math_error("Zero epsilon for root"); + /*NOTREACHED*/ + } + if (qisneg(q2) || qiszero(q2) || qisfrac(q2)) { + math_error("Taking bad root of number"); + /*NOTREACHED*/ + } + if (qiszero(q1) || qisone(q1) || qisone(q2)) + return qlink(q1); + if (qistwo(q2)) + return qsqrt(q1, epsilon, 24L); + neg = qisneg(q1); + if (neg) { + if (ziseven(q2->num)) { + math_error("Taking even root of negative number"); + /*NOTREACHED*/ + } + q1 = qabs(q1); + } + tmp2 = qinv(q2); + tmp1 = qpower(q1, tmp2, epsilon); + qfree(tmp2); + if (neg) { + tmp2 = qneg(tmp1); + qfree(tmp1); + tmp1 = tmp2; + } + return tmp1; +} + + +/* Calculate the hyperbolic cosine function to the nearest or next to + * nearest multiple of epsilon. + * This is calculated using cosh(x) = (exp(x) + 1/exp(x))/2; + */ +NUMBER * +qcosh(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3, *epsilon1; + + epsilon1 = qscale(epsilon, -2); + tmp1 = qabs(q); + tmp2 = qexp(tmp1, epsilon1); + qfree(tmp1); + qfree(epsilon1); + tmp1 = qinv(tmp2); + tmp3 = qqadd(tmp1, tmp2); + qfree(tmp1) + qfree(tmp2) + tmp1 = qscale(tmp3, -1); + qfree(tmp3); + tmp2 = qmappr(tmp1, epsilon, 24L); + qfree(tmp1); + return tmp2; +} + + +/* + * Calculate the hyperbolic sine to the nearest or next to nearest + * multiple of epsilon. + * This is calculated using sinh(x) = (exp(x) - 1/exp(x))/2. + */ +NUMBER * +qsinh(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3, *epsilon1; + + if (qiszero(q)) + return qlink(&_qzero_); + epsilon1 = qscale(epsilon, -3); + tmp1 = qabs(q); + tmp2 = qexp(tmp1, epsilon1); + qfree(tmp1); + qfree(epsilon1); + tmp1 = qinv(tmp2); + tmp3 = qispos(q) ? qsub(tmp2, tmp1) : qsub(tmp1, tmp2); + qfree(tmp1) + qfree(tmp2) + tmp1 = qscale(tmp3, -1); + qfree(tmp3); + tmp2 = qmappr(tmp1, epsilon, 24L); + qfree(tmp1); + return tmp2; +} + + +/* + * Calculate the hyperbolic tangent to the nearest or next to nearest + * multiple of epsilon. + * This is calculated using the formula: + * tanh(x) = (exp(2*x) - 1)/(exp(2*x) + 1). + */ +NUMBER * +qtanh(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3; + long n; + + n = qilog2(epsilon); + if (n > 0 || qiszero(q)) + return qlink(&_qzero_); + tmp1 = qabs(q); + tmp2 = qscale(tmp1, 1); + qfree(tmp1); + tmp1 = qexprel(tmp2, 2 - n); + qfree(tmp2); + tmp2 = qdec(tmp1); + tmp3 = qinc(tmp1); + qfree(tmp1); + tmp1 = qdiv(tmp2, tmp3); + qfree(tmp2); + qfree(tmp3); + tmp2 = qmappr(tmp1, epsilon, 24L); + qfree(tmp1); + if (qisneg(q)) { + tmp1 = qneg(tmp2); + qfree(tmp2); + return tmp1; + } + return tmp2; +} + + +/* + * Hyperbolic cotangent. + * Calculated using coth(x) = 1 + 2/(exp(2*x) - 1) + */ +NUMBER * +qcoth(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *res; + long n, k; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for coth"); + /*NOTREACHED*/ + } + if (qiszero(q)) { + math_error("Zero argument for coth"); + /*NOTREACHED*/ + } + tmp1 = qscale(q, 1); + tmp2 = qabs(tmp1); + qfree(tmp1); + k = -qilog2(tmp2); + if (k < 0) { + tmp1 = qmul(&_qlge_, tmp2); + k = -qtoi(tmp1); + qfree(tmp1); + } + n = qilog2(epsilon); + if (k + n > 1) { + qfree(tmp2); + return qlink(&_qzero_); + } + tmp1 = qexprel(tmp2, 4 - k - n); + qfree(tmp2); + tmp2 = qdec(tmp1); + qfree(tmp1); + if (qiszero(tmp2)) { + math_error("This should not happen ????"); + /*NOTREACHED*/ + } + tmp1 = qinv(tmp2); + qfree(tmp2); + tmp2 = qscale(tmp1, 1); + qfree(tmp1); + tmp1 = qinc(tmp2); + qfree(tmp2); + if (qisneg(q)) { + tmp2 = qneg(tmp1); + qfree(tmp1); + tmp1 = tmp2; + } + res = qmappr(tmp1, epsilon, 24L); + qfree(tmp1); + return res; +} + + +NUMBER * +qsech(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3, *res; + long n, k; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for sech"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qmappr(&_qone_, epsilon, 24L); + + tmp1 = qabs(q); + k = 0; + if (zrel(tmp1->num, tmp1->den) >= 0) { + tmp2 = qmul(&_qlge_, tmp1); + k = qtoi(tmp2); + qfree(tmp2); + } + n = qilog2(epsilon); + if (k + n > 1) { + qfree(tmp1); + return qlink(&_qzero_); + } + tmp2 = qexprel(tmp1, 4 - k - n); + qfree(tmp1); + tmp1 = qinv(tmp2); + tmp3 = qqadd(tmp1, tmp2); + qfree(tmp1); + qfree(tmp2); + tmp1 = qinv(tmp3); + qfree(tmp3); + tmp2 = qscale(tmp1, 1); + qfree(tmp1); + res = qmappr(tmp2, epsilon, 24L); + qfree(tmp2); + return res; +} + + +NUMBER * +qcsch(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3, *res; + long n, k; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for csch"); + /*NOTREACHED*/ + } + if (qiszero(q)) { + math_error("Zero argument for csch"); + /*NOTREACHED*/ + } + + n = qilog2(epsilon); + tmp1 = qabs(q); + if (zrel(tmp1->num, tmp1->den) >= 0) { + tmp2 = qmul(&_qlge_, tmp1); + k = qtoi(tmp2); + qfree(tmp2); + } + else + k = 2 * qilog2(tmp1); + if (k + n >= 1) { + qfree(tmp1); + return qlink(&_qzero_); + } + tmp2 = qexprel(tmp1, 4 - k - n); + qfree(tmp1); + tmp1 = qinv(tmp2); + if (qisneg(q)) + tmp3 = qsub(tmp1, tmp2); + else + tmp3 = qsub(tmp2, tmp1); + qfree(tmp1); + qfree(tmp2); + tmp1 = qinv(tmp3); + qfree(tmp3) + tmp2 = qscale(tmp1, 1); + qfree(tmp1); + res = qmappr(tmp2, epsilon, 24L); + qfree(tmp2); + return res; +} + + +/* + * Compute the hyperbolic arccosine within the specified accuracy. + * This is calculated using the formula: + * acosh(x) = ln(x + sqrt(x^2 - 1)). + */ +NUMBER * +qacosh(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *epsilon1; + long n; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for acosh"); + /*NOTREACHED*/ + } + if (qisone(q)) + return qlink(&_qzero_); + if (zrel(q->num, q->den) < 0) { + math_error("Argument less than one for acosh"); + /*NOTREACHED*/ + } + n = qilog2(epsilon); + epsilon1 = qbitvalue(n - 3); + tmp1 = qsquare(q); + tmp2 = qdec(tmp1); + qfree(tmp1); + tmp1 = qsqrt(tmp2, epsilon1, 24L); + qfree(tmp2); + tmp2 = qqadd(tmp1, q); + qfree(tmp1); + tmp1 = qln(tmp2, epsilon1); + qfree(tmp2); + qfree(epsilon1); + tmp2 = qmappr(tmp1, epsilon, 24L); + qfree(tmp1); + return tmp2; +} + + +/* + * Compute the hyperbolic arcsine within the specified accuracy. + * This is calculated using the formula: + * asinh(x) = ln(x + sqrt(x^2 + 1)). + */ +NUMBER * +qasinh(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *epsilon1; + long n; + BOOL neg; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for asinh"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qlink(&_qzero_); + neg = qisneg(q); + q = qabs(q); + n = qilog2(epsilon); + epsilon1 = qbitvalue(n - 3); + tmp1 = qsquare(q); + tmp2 = qinc(tmp1); + qfree(tmp1); + tmp1 = qsqrt(tmp2, epsilon1, 24L); + qfree(tmp2); + tmp2 = qqadd(tmp1, q); + qfree(tmp1); + tmp1 = qln(tmp2, epsilon1); + qfree(tmp2); + qfree(q); + qfree(epsilon1); + tmp2 = qmappr(tmp1, epsilon, 24L); + if (neg) { + tmp1 = qneg(tmp2); + qfree(tmp2); + return tmp1; + } + return tmp2; +} + + +/* + * Compute the hyperbolic arctangent within the specified accuracy. + * This is calculated using the formula: + * atanh(x) = ln((1 + x) / (1 - x)) / 2. + */ +NUMBER * +qatanh(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp1, *tmp2, *tmp3, *epsilon1; + ZVALUE z; + + if (qiszero(epsilon)) { + math_error("Zero epsilon value for atanh"); + /*NOTREACHED*/ + } + if (qiszero(q)) + return qlink(&_qzero_); + z = q->num; + z.sign = 0; + if (zrel(z, q->den) >= 0) { + math_error("Argument not between -1 and 1 for atanh"); + /*NOTREACHED*/ + } + tmp1 = qinc(q); + tmp2 = qsub(&_qone_, q); + tmp3 = qdiv(tmp1, tmp2); + qfree(tmp1); + qfree(tmp2); + epsilon1 = qscale(epsilon, 1L); + tmp1 = qln(tmp3, epsilon1); + qfree(tmp3); + tmp2 = qscale(tmp1, -1L); + qfree(tmp1); + qfree(epsilon1); + return tmp2; +} + + +/* + * Inverse hyperbolic secant function + */ +NUMBER * +qasech(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp, *res; + + tmp = qinv(q); + res = qacosh(tmp, epsilon); + qfree(tmp); + return res; +} + + +/* + * Inverse hyperbolic cosecant function + */ +NUMBER * +qacsch(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp, *res; + + tmp = qinv(q); + res = qasinh(tmp, epsilon); + qfree(tmp); + return res; +} + + +/* + * Inverse hyperbolic cotangent function + */ +NUMBER * +qacoth(NUMBER *q, NUMBER *epsilon) +{ + NUMBER *tmp, *res; + + tmp = qinv(q); + res = qatanh(tmp, epsilon); + qfree(tmp); + return res; +} + + +/* END CODE */ diff --git a/quickhash.c b/quickhash.c new file mode 100644 index 0000000..f1b4a01 --- /dev/null +++ b/quickhash.c @@ -0,0 +1,474 @@ +/* + * Copyright (c) 1996 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 /\../\ + */ + +/* + * quickhash - qickly hash a calc value using a partial Fowler/Noll/Vo hash + * + * NOTE: This file does not contain a hash interface. It is used by + * associative arrays and other internal processes. + * + * We will compute a hash value for any type of calc value + * for use in associative arrays and the hash() builtin. + * Hash speed is of primary importance to make associative + * arrays work at a reasonable speed. For this reason, we + * cut corners by hashing only a small part of a calc value. + * + * The Fowler/Noll/Vo hash does a very good job in producing + * a 32 bit hash from ASCII strings in a short amount of time. + * It is not bad for hashing calc data as well. So doing a + * quick and dirty job of hashing on a part of a calc value, + * combined with using a reasonable hash function will result + * acceptable associative array performance. + */ + +#include "value.h" +#include "zrand.h" + +#define ZMOST 2 /* most significant HALFs to hash */ +#define ZLEAST 2 /* least significant HALFs to hash */ +#define ZMIDDLE 4 /* HALFs in the middle to hash */ + + +/* + * forward declarations + */ +static QCKHASH assochash(ASSOC *ap, QCKHASH val); +static QCKHASH listhash(LIST *lp, QCKHASH val); +static QCKHASH mathash(MATRIX *m, QCKHASH val); +static QCKHASH objhash(OBJECT *op, QCKHASH val); +static QCKHASH randhash(RAND *r, QCKHASH val); +static QCKHASH randomhash(RANDOM *state, QCKHASH val); +static QCKHASH config_hash(CONFIG *cfg, QCKHASH val); +static QCKHASH fnv_strhash(char *str, QCKHASH val); +static QCKHASH fnv_fullhash(FULL *v, LEN len, QCKHASH val); +static QCKHASH fnv_zhash(ZVALUE z, QCKHASH val); + + +/* + * fnv - compute the next Fowler/Noll/Vo hash given a variable + * + * The basis of the hash algorithm was taken from an idea + * sent by Email to the IEEE Posix P1003.2 mailing list from + * Phong Vo (kpv@research.att.com) and Glenn Fowler (gsf@research.att.com). + * Landon Curt Noll (chongo@toad.com) later improved on there + * algorithm to come up with Fowler/Noll/Vo hash. + * + * The magic lies in the constant 16777619, which for 32 bit hashing + * is able to process 234936 words from the web2 dictionary without + * any collisions. + * + * given: + * x the value to hash (must not be longer than 32 bits) + * val previous QCKHASH value + * + * returns: + * the next 32 bit QCKHASH + */ +#define fnv(x,val) (((QCKHASH)(val)*(QCKHASH)16777619) ^ ((QCKHASH)(x))) + + +/* + * fnv_qhash - compute the next Fowler/Noll/Vo hash given a NUMBER + * + * given: + * q pointer to a NUMBER + * val previous QCKHASH value + * + * returns: + * the next 32 bit QCKHASH + */ +#define fnv_qhash(q,val) \ + (qisint(q) ? fnv_zhash((q)->num, (val)) : \ + fnv_zhash((q)->num, fnv_zhash((q)->den, (val)))) + + +/* + * fnv_chash - compute the next Fowler/Noll/Vo hash given a COMPLEX + * + * given: + * c pointer to a COMPLEX + * val previous QCKHASH value + * + * returns: + * the next 32 bit QCKHASH + */ +#define fnv_chash(c,val) \ + (cisreal(c) ? fnv_qhash((c)->real, (val)) : \ + fnv_qhash((c)->real, fnv_qhash((c)->imag, (val)))) + + +/* + * hashvalue - 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. + * + * given: + * vp pointer to a VALUE + * val previous QCKHASH value + * + * returns: + * next QCKHASH value + */ +QCKHASH +hashvalue(VALUE *vp, QCKHASH val) +{ + switch (vp->v_type) { + case V_INT: + return fnv(vp->v_int, V_NUM+val); + case V_NUM: + return fnv_qhash(vp->v_num, val); + case V_COM: + return fnv_chash(vp->v_com, val); + case V_STR: + return fnv_strhash(vp->v_str, val); + case V_NULL: + return val; + case V_OBJ: + return objhash(vp->v_obj, val); + case V_LIST: + return listhash(vp->v_list, val); + case V_ASSOC: + return assochash(vp->v_assoc, val); + case V_MAT: + return mathash(vp->v_mat, val); + case V_FILE: + return fnv(vp->v_file, V_FILE+val); + case V_RAND: + return randhash(vp->v_rand, val); + case V_RANDOM: + return randomhash(vp->v_random, val); + case V_CONFIG: + return config_hash(vp->v_config, val); + default: + math_error("Hashing unknown value"); + /*NOTREACHED*/ + } + return (QCKHASH)0; +} + + +/* + * Return a trivial hash value for an association. + */ +static QCKHASH +assochash(ASSOC *ap, QCKHASH val) +{ + /* XXX - hash the first and last values??? */ + return fnv(ap->a_count, V_ASSOC+val); +} + + +/* + * Return a trivial hash value for a list. + */ +static QCKHASH +listhash(LIST *lp, QCKHASH val) +{ + /* + * hash small lists + */ + switch (lp->l_count) { + case 0: + /* empty list hashes to just V_LIST */ + return V_LIST+val; + case 1: + /* single element list hashes just that element */ + return hashvalue(&lp->l_first->e_value, V_LIST+val); + } + + /* + * multi element list hashes the first and last elements + */ + return hashvalue(&lp->l_first->e_value, + hashvalue(&lp->l_last->e_value, V_LIST+val)); +} + + +/* + * Return a trivial hash value for a matrix. + */ +static QCKHASH +mathash(MATRIX *m, QCKHASH val) +{ + long skip; + long i; + VALUE *vp; + + /* + * hash size parts of the matrix + */ + val = fnv(m->m_dim, V_MAT+val); + val = fnv(m->m_size, val); + + /* + * hash the matrix index bounds + */ + for (i = m->m_dim - 1; i >= 0; i--) { + val = fnv(m->m_min[i], val); + val = fnv(m->m_max[i], val); + } + + /* + * hash the first 16 elements + */ + vp = m->m_table; + for (i = 0; ((i < m->m_size) && (i < 16)); i++) { + val = hashvalue(vp++, val); + } + + /* + * hash 10 more elements if they exist + */ + i = 16; + vp = &m->m_table[16]; + skip = (m->m_size / 11) + 1; + while (i < m->m_size) { + val = hashvalue(vp, val); + i += skip; + vp += skip; + } + return val; +} + + +/* + * Return a trivial hash value for an object. + */ +static QCKHASH +objhash(OBJECT *op, QCKHASH val) +{ + int i; + + i = op->o_actions->count; + while (--i >= 0) + val = hashvalue(&op->o_table[i], val); + return val; +} + + +/* + * randhash - return a trivial hash for an a55 state + * + * given: + * state - state to hash + * + * returns: + * trivial hash integer + */ +static QCKHASH +randhash(RAND *r, QCKHASH val) +{ + /* + * hash the RAND state + */ + if (!r->seeded) { + /* unseeded state hashes to V_RAND */ + return V_RAND+val; + } else { + /* hash control values */ + val = fnv(r->j, V_RAND+val); + val = fnv(r->k, val); + val = fnv(r->bits, val); + + /* hash the state arrays */ + return fnv_fullhash(&r->buffer[0], SLEN+SCNT+SHUFLEN, val); + } +} + + +/* + * randomhash - return a trivial hash for a Blum state + * + * given: + * state - state to hash + * + * returns: + * trivial hash integer + */ +static QCKHASH +randomhash(RANDOM *state, QCKHASH val) +{ + /* + * unseeded RANDOM state hashes to V_RANDOM + */ + if (!state->seeded) { + return V_RANDOM+val; + } + + /* + * hash a seeded RANDOM state + */ + val = fnv(state->buffer+state->bits, V_RANDOM+val); + if (state->r != NULL && state->r->v != NULL) { + val = fnv_zhash(*(state->r), val); + } + if (state->n != NULL && state->n->v != NULL) { + val = fnv_zhash(*(state->n), val); + } + return val; +} + + +/* + * config_hash - return a trivial hash for a configuration state + */ +static QCKHASH +config_hash(CONFIG *cfg, QCKHASH val) +{ + /* + * hash scalar values + */ + val = fnv(cfg->traceflags + cfg->outdigits + cfg->outmode + + cfg->epsilonprec + cfg->maxprint + cfg->mul2 + + cfg->sq2 + cfg->pow2 + cfg->redc2 + cfg->tilde_ok + + cfg->tab_ok + cfg->quomod + cfg->quo + cfg->mod + + cfg->sqrt + cfg->appr + cfg->cfappr + cfg->cfsim + + cfg->outround + cfg->round + cfg->leadzero + + cfg->fullzero + cfg->maxerrorcount, V_CONFIG+val); + + /* + * hash the strings if possible + */ + if (cfg->prompt1) { + val = fnv_strhash(cfg->prompt1, val); + } + if (cfg->prompt2) { + val = fnv_strhash(cfg->prompt2, val); + } + + /* + * hash the epsilon if possible + */ + if (cfg->epsilon) { + val = fnv_qhash(cfg->epsilon, val); + } + return val; +} + + +/* + * fnv_strhash - Fowler/Noll/Vo 32 bit hash of a string + * + * given: + * str the string to hash + * val initial hash value + * + * returns: + * a 32 bit QCKHASH value + */ +static QCKHASH +fnv_strhash(char *str, QCKHASH val) +{ + /* + * hash each character in the string + */ + while (*str) { + val = fnv(*str++, val); + } + return val; +} + + +/* + * fnv_fullhash - Fowler/Noll/Vo 32 bit hash of an array of HALFs + * + * given: + * v an array of FULLs + * len length of buffer FULLs + * val initial hash value + * + * returns: + * a 32 bit QCKHASH value + */ +static QCKHASH +fnv_fullhash(FULL *v, LEN len, QCKHASH val) +{ + /* + * hash each character in the string + */ + while (len-- > 0) { + val = fnv(*v++, val); + } + return val; +} + + +/* + * fnv_zhash - Fowler/Noll/Vo 32 bit hash of ZVALUE + * + * given: + * z a ZVALUE + * val initial hash value + * + * returns: + * a 32 bit QCKHASH value + */ +static QCKHASH +fnv_zhash(ZVALUE z, QCKHASH val) +{ + int skip; /* HALFs to skip in the middle */ + int i; + + /* + * hash the sign and length + */ + if (zisneg(z)) { + val = fnv(-(z.len), val+V_NUM); + } else { + val = fnv(z.len, val+V_NUM); + } + + /* + * if a ZVALUE is short enough, hash it all + */ + if (z.len <= ZMOST+ZLEAST+ZMIDDLE) { + /* hash all HALFs of a short ZVALUE */ + for (i=0; i < z.len; ++i) { + val = fnv(z.v[i], val); + } + + /* + * otherwise hash the ZLEAST significant HALFs followed by + * ZMIDDLE HALFs followed by the ZMOST significant HALFs. + */ + } else { + /* hash the ZLEAST significant HALFs */ + for (i=0; i < ZLEAST; ++i) { + val = fnv(z.v[i], val); + } + + /* hash ZMIDDLE HALFs in the middle */ + skip = (z.len-ZLEAST-ZMOST)/(ZMIDDLE + 1); + for (i=ZLEAST-1+skip; i < ZLEAST-1+skip*(ZMIDDLE+1); i+=skip) { + val = fnv(z.v[i], val); + } + + /* hash the ZMOST significant HALFs */ + for (i=z.len-1-ZMOST; i < z.len; ++i) { + val = fnv(z.v[i], val); + } + } + return val; +} diff --git a/shs.c b/shs.c new file mode 100644 index 0000000..eb10607 --- /dev/null +++ b/shs.c @@ -0,0 +1,1247 @@ +/* XXX - this code is currently not really used, but it will be soon */ +/* + * shs - old Secure Hash Standard + * + ************************************************************************** + * This version implements the old Secure Hash Algorithm specified by * + * (FIPS Pub 180). This version is kept for backward compatibility with * + * shs version 2.10.1. See the shs utility for the new standard. * + ************************************************************************** + * + * Written 2 September 1992, Peter C. Gutmann. + * + * This file was Modified/Re-written by: + * + * Landon Curt Noll (chongo@toad.com) chongo /\../\ + * + * This code has been placed in the public domain. Please do not + * copyright this code. + * + * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO + * THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MER- + * CHANTABILITY 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. + * + * Based on Version 2.11 (09 Mar 1995) from Landon Curt Noll's + * (chongo@toad.com) shs hash program. + * + **** + * + * The SHS algorithm hashes 32 bit unsigned values, 16 at a time. + * It further specifies that strings are to be converted into + * 32 bit values in BIG ENDIAN order. That is on little endian + * machines, strings are byte swaped into BIG ENDIAN order before + * they are taken 32 bit at a time. Even so, when hashing 32 bit + * numeric values the byte order DOES NOT MATTER because the + * algorithm works off of their numeric value, not their byte order. + * + * In calc, we want to hash equal values to the same hash value. + * For the most part, we will be hashing arrays of HALF's instead + * of strings. For this reason, the functions below do not byte + * swap on little endian machines automatically. Instead it is + * the responsibility of the caller of the internal SHS function + * to ensure that the values are already in the canonical 32 bit + * numeric value form. + */ + +#include +#include +#include +#include +#include "calc.h" +#include "zrand.h" +#include "longbits.h" +#include "align32.h" +#include "endian_calc.h" +#include "shs.h" +#include "value.h" + + +/* + * The SHS f()-functions. The f1 and f3 functions can be optimized + * to save one boolean operation each - thanks to Rich Schroeppel, + * rcs@cs.arizona.edu for discovering this. + * + * f1: ((x&y) | (~x&z)) == (z ^ (x&(y^z))) + * f3: ((x&y) | (x&z) | (y&z)) == ((x&y) | (z&(x|y))) + */ +#define f1(x,y,z) (z ^ (x&(y^z))) /* Rounds 0-19 */ +#define f2(x,y,z) (x^y^z) /* Rounds 20-39 */ +#define f3(x,y,z) ((x&y) | (z&(x|y))) /* Rounds 40-59 */ +#define f4(x,y,z) (x^y^z) /* Rounds 60-79 */ + +/* The SHS Mysterious Constants */ +#define K1 0x5A827999L /* Rounds 0-19 */ +#define K2 0x6ED9EBA1L /* Rounds 20-39 */ +#define K3 0x8F1BBCDCL /* Rounds 40-59 */ +#define K4 0xCA62C1D6L /* Rounds 60-79 */ + +/* SHS initial values */ +#define h0init 0x67452301L +#define h1init 0xEFCDAB89L +#define h2init 0x98BADCFEL +#define h3init 0x10325476L +#define h4init 0xC3D2E1F0L + +/* 32-bit rotate left - kludged with shifts */ +#define LEFT_ROT(X,n) (((X)<<(n)) | ((X)>>(32-(n)))) + +/* + * The initial expanding function. The hash function is defined over an + * 80-word expanded input array W, where the first 16 are copies of the input + * data, and the remaining 64 are defined by + * + * W[i] = W[i-16] ^ W[i-14] ^ W[i-8] ^ W[i-3] + * + * This implementation generates these values on the fly in a circular + * buffer - thanks to Colin Plumb (colin@nyx10.cs.du.edu) for this + * optimization. + */ +#define exor(W,i) (W[i&15] ^= (W[(i-14)&15] ^ W[(i-8)&15] ^ W[(i-3)&15])) + +/* + * The prototype SHS sub-round. The fundamental sub-round is: + * + * a' = e + LEFT_ROT(a,5) + f(b,c,d) + k + data; + * b' = a; + * c' = LEFT_ROT(b,30); + * d' = c; + * e' = d; + * + * but this is implemented by unrolling the loop 5 times and renaming the + * variables ( e, a, b, c, d ) = ( a', b', c', d', e' ) each iteration. + * This code is then replicated 20 times for each of the 4 functions, using + * the next 20 values from the W[] array each time. + */ +#define subRound(a, b, c, d, e, f, k, data) \ + (e += LEFT_ROT(a,5) + f(b,c,d) + k + data, b = LEFT_ROT(b,30)) + + +/* forward declarations */ +#if defined(MUST_ALIGN32) +static USB32 in[SHS_CHUNKWORDS]; +#endif +static void shsInit(SHS_INFO*); +static void shsTransform(USB32*, USB32*); +static void shsUpdate(SHS_INFO*, USB8*, USB32); +static void shsfullUpdate(SHS_INFO*, USB8*, USB32); +static void shsFinal(SHS_INFO*); +static void shs_chkpt(HASH*); +static void shs_note(HASH*, int); +static void shs_type(HASH*, int); +static HASH *shs_init(HASH*); +static HASH *shs_long(HASH*, long); +static HASH *shs_zvalue(HASH*, ZVALUE); +static HASH *shs_number(HASH*, NUMBER*); +static HASH *shs_complex(HASH*, COMPLEX*); +static HASH *shs_str(HASH*, char*); +static HASH *shs_value(HASH*, VALUE*); +static ZVALUE shs_final(HASH*); + + +/* + * shsInit - initialize the SHS state + */ +static void +shsInit(SHS_INFO *dig) +{ + /* Set the h-vars to their initial values */ + dig->digest[0] = h0init; + dig->digest[1] = h1init; + dig->digest[2] = h2init; + dig->digest[3] = h3init; + dig->digest[4] = h4init; + + /* Initialise bit count */ + dig->countLo = 0; + dig->countHi = 0; + dig->datalen = 0; +} + + +/* + * shsTransform - perform the SHS transformatio + * + * Note that this code, like MD5, seems to break some optimizing compilers. + * It may be necessary to split it into sections, eg based on the four + * subrounds. One may also want to roll each subround into a loop. + */ +static void +shsTransform(USB32 *digest, USB32 *W) +{ + USB32 A, B, C, D, E; /* Local vars */ + + /* Set up first buffer and local data buffer */ + A = digest[0]; + B = digest[1]; + C = digest[2]; + D = digest[3]; + E = digest[4]; + + /* Heavy mangling, in 4 sub-rounds of 20 interations each. */ + subRound(A, B, C, D, E, f1, K1, W[ 0]); + subRound(E, A, B, C, D, f1, K1, W[ 1]); + subRound(D, E, A, B, C, f1, K1, W[ 2]); + subRound(C, D, E, A, B, f1, K1, W[ 3]); + subRound(B, C, D, E, A, f1, K1, W[ 4]); + subRound(A, B, C, D, E, f1, K1, W[ 5]); + subRound(E, A, B, C, D, f1, K1, W[ 6]); + subRound(D, E, A, B, C, f1, K1, W[ 7]); + subRound(C, D, E, A, B, f1, K1, W[ 8]); + subRound(B, C, D, E, A, f1, K1, W[ 9]); + subRound(A, B, C, D, E, f1, K1, W[10]); + subRound(E, A, B, C, D, f1, K1, W[11]); + subRound(D, E, A, B, C, f1, K1, W[12]); + subRound(C, D, E, A, B, f1, K1, W[13]); + subRound(B, C, D, E, A, f1, K1, W[14]); + subRound(A, B, C, D, E, f1, K1, W[15]); + subRound(E, A, B, C, D, f1, K1, exor(W,16)); + subRound(D, E, A, B, C, f1, K1, exor(W,17)); + subRound(C, D, E, A, B, f1, K1, exor(W,18)); + subRound(B, C, D, E, A, f1, K1, exor(W,19)); + + subRound(A, B, C, D, E, f2, K2, exor(W,20)); + subRound(E, A, B, C, D, f2, K2, exor(W,21)); + subRound(D, E, A, B, C, f2, K2, exor(W,22)); + subRound(C, D, E, A, B, f2, K2, exor(W,23)); + subRound(B, C, D, E, A, f2, K2, exor(W,24)); + subRound(A, B, C, D, E, f2, K2, exor(W,25)); + subRound(E, A, B, C, D, f2, K2, exor(W,26)); + subRound(D, E, A, B, C, f2, K2, exor(W,27)); + subRound(C, D, E, A, B, f2, K2, exor(W,28)); + subRound(B, C, D, E, A, f2, K2, exor(W,29)); + subRound(A, B, C, D, E, f2, K2, exor(W,30)); + subRound(E, A, B, C, D, f2, K2, exor(W,31)); + subRound(D, E, A, B, C, f2, K2, exor(W,32)); + subRound(C, D, E, A, B, f2, K2, exor(W,33)); + subRound(B, C, D, E, A, f2, K2, exor(W,34)); + subRound(A, B, C, D, E, f2, K2, exor(W,35)); + subRound(E, A, B, C, D, f2, K2, exor(W,36)); + subRound(D, E, A, B, C, f2, K2, exor(W,37)); + subRound(C, D, E, A, B, f2, K2, exor(W,38)); + subRound(B, C, D, E, A, f2, K2, exor(W,39)); + + subRound(A, B, C, D, E, f3, K3, exor(W,40)); + subRound(E, A, B, C, D, f3, K3, exor(W,41)); + subRound(D, E, A, B, C, f3, K3, exor(W,42)); + subRound(C, D, E, A, B, f3, K3, exor(W,43)); + subRound(B, C, D, E, A, f3, K3, exor(W,44)); + subRound(A, B, C, D, E, f3, K3, exor(W,45)); + subRound(E, A, B, C, D, f3, K3, exor(W,46)); + subRound(D, E, A, B, C, f3, K3, exor(W,47)); + subRound(C, D, E, A, B, f3, K3, exor(W,48)); + subRound(B, C, D, E, A, f3, K3, exor(W,49)); + subRound(A, B, C, D, E, f3, K3, exor(W,50)); + subRound(E, A, B, C, D, f3, K3, exor(W,51)); + subRound(D, E, A, B, C, f3, K3, exor(W,52)); + subRound(C, D, E, A, B, f3, K3, exor(W,53)); + subRound(B, C, D, E, A, f3, K3, exor(W,54)); + subRound(A, B, C, D, E, f3, K3, exor(W,55)); + subRound(E, A, B, C, D, f3, K3, exor(W,56)); + subRound(D, E, A, B, C, f3, K3, exor(W,57)); + subRound(C, D, E, A, B, f3, K3, exor(W,58)); + subRound(B, C, D, E, A, f3, K3, exor(W,59)); + + subRound(A, B, C, D, E, f4, K4, exor(W,60)); + subRound(E, A, B, C, D, f4, K4, exor(W,61)); + subRound(D, E, A, B, C, f4, K4, exor(W,62)); + subRound(C, D, E, A, B, f4, K4, exor(W,63)); + subRound(B, C, D, E, A, f4, K4, exor(W,64)); + subRound(A, B, C, D, E, f4, K4, exor(W,65)); + subRound(E, A, B, C, D, f4, K4, exor(W,66)); + subRound(D, E, A, B, C, f4, K4, exor(W,67)); + subRound(C, D, E, A, B, f4, K4, exor(W,68)); + subRound(B, C, D, E, A, f4, K4, exor(W,69)); + subRound(A, B, C, D, E, f4, K4, exor(W,70)); + subRound(E, A, B, C, D, f4, K4, exor(W,71)); + subRound(D, E, A, B, C, f4, K4, exor(W,72)); + subRound(C, D, E, A, B, f4, K4, exor(W,73)); + subRound(B, C, D, E, A, f4, K4, exor(W,74)); + subRound(A, B, C, D, E, f4, K4, exor(W,75)); + subRound(E, A, B, C, D, f4, K4, exor(W,76)); + subRound(D, E, A, B, C, f4, K4, exor(W,77)); + subRound(C, D, E, A, B, f4, K4, exor(W,78)); + subRound(B, C, D, E, A, f4, K4, exor(W,79)); + + /* Build message digest */ + digest[0] += A; + digest[1] += B; + digest[2] += C; + digest[3] += D; + digest[4] += E; +} + + +/* + * shsUpdate - update SHS with arbitrary length data + * + * This code does not assume that the buffer size is a multiple of + * SHS_CHUNKSIZE bytes long. This code handles partial chunk between + * calls to shsUpdate(). + */ +static void +shsUpdate(SHS_INFO *dig, USB8 *buffer, USB32 count) +{ + USB32 datalen = dig->datalen; + + /* + * Catch the case of a non-empty data buffer + */ + if (datalen > 0) { + + /* determine the size we need to copy */ + USB32 cpylen = SHS_CHUNKSIZE - datalen; + + /* case: new data will not fill the buffer */ + if (cpylen > count) { + memcpy((char *)dig->data+datalen, + (char *)buffer, count); + dig->datalen = datalen+count; + return; + + /* case: buffer will be filled */ + } else { + memcpy((char *)dig->data+datalen, + (char *)buffer, cpylen); + shsTransform(dig->digest, dig->data); + buffer += cpylen; + count -= cpylen; + dig->datalen = 0; + } + } + + /* + * Process data in SHS_CHUNKSIZE chunks + */ + if (count >= SHS_CHUNKSIZE) { + shsfullUpdate(dig, buffer, count); + buffer += (count/SHS_CHUNKSIZE)*SHS_CHUNKSIZE; + count %= SHS_CHUNKSIZE; + } + + /* + * Handle any remaining bytes of data. + * This should only happen once on the final lot of data + */ + if (count > 0) { + memcpy((char *)dig->data, (char *)buffer, count); + } + dig->datalen = count; +} + + +/* + * shsfullUpdate - update SHS with chunk multiple length data + * + * This function assumes that count is a multiple of SHS_CHUNKSIZE and that + * no partial chunk is left over from a previous call. + */ +static void +shsfullUpdate(SHS_INFO *dig, USB8 *buffer, USB32 count) +{ + /* + * Process data in SHS_CHUNKSIZE chunks + */ + while (count >= SHS_CHUNKSIZE) { +#if defined(MUST_ALIGN32) + if ((long)buffer & (sizeof(USB32)-1)) { + memcpy((char *)in, (char *)buffer, SHS_CHUNKSIZE); + shsTransform(dig->digest, in); + } else { + shsTransform(dig->digest, (USB32 *)buffer); + } +#else + shsTransform(dig->digest, (USB32 *)buffer); +#endif + buffer += SHS_CHUNKSIZE; + count -= SHS_CHUNKSIZE; + } +} + + +/* + * shsFinal - perform final SHS transforms + * + * At this point we have less than a full chunk of data remaining + * (and possibly no data) in the shs state data buffer. + * + * First we append a final 0x80 byte. + * + * Next if we have more than 56 bytes, we will zero fill the remainder + * of the chunk, transform and then zero fill the first 56 bytes. + * If we have 56 or fewer bytes, we will zero fill out to the 56th + * chunk byte. Regardless, we wind up with 56 bytes data. + * + * Finally we append the 64 bit length on to the 56 bytes of data + * remaining. This final chunk is transformed. + */ +static void +shsFinal(SHS_INFO *dig) +{ + long count = (long)(dig->datalen); + USB32 lowBitcount = dig->countLo; + USB32 highBitcount = dig->countHi; +#if BYTE_ORDER == LITTLE_ENDIAN + int i; +#endif + + /* + * Set the first char of padding to 0x80. + * This is safe since there is always at least one byte free + */ + ((USB8 *)dig->data)[count++] = 0x80; + + /* Pad out to 56 mod SHS_CHUNKSIZE */ + if (count > SHS_CHUNKSIZE-8) { + /* Pad the first chunk to SHS_CHUNKSIZE bytes */ + memset((USB8 *)dig->data + count, 0, SHS_CHUNKSIZE - count); + shsTransform(dig->digest, dig->data); + + /* Now fill the next chunk with 56 bytes */ + memset(dig->data, 0, SHS_CHUNKSIZE-8); + } else { + /* Pad chunk to 56 bytes */ + memset((USB8 *)dig->data + count, 0, SHS_CHUNKSIZE-8 - count); + } +#if BYTE_ORDER == LITTLE_ENDIAN + for (i=0; i < SHS_CHUNKWORDS; ++i) { + SWAP_B8_IN_B32(dig->data+i, dig->data+i); + } +#endif + + /* + * Append length in bits and transform + * + * We assume that bit count is a multiple of 8 because we have + * only processed full bytes. + */ + dig->data[SHS_HIGH] = (highBitcount << 3) | (lowBitcount >> 29); + dig->data[SHS_LOW] = (lowBitcount << 3); + shsTransform(dig->digest, dig->data); + dig->datalen = 0; +} + + +/* + * shs_chkpt - checkpoint a SHS state + * + * given: + * state the state to checkpoint + * + * This function will ensure that the the hash chunk buffer is empty. + * Any partially hashed data will be padded out with 0's and hashed. + */ +static void +shs_chkpt(HASH *state) +{ + SHS_INFO *dig = &state->h_shs; /* digest state */ + + /* + * checkpoint if partial buffer exists + */ + if (dig->datalen > 0) { + + /* pad to the end of the chunk */ + memset((USB8 *)dig->data + dig->datalen, 0, + SHS_CHUNKSIZE-dig->datalen); + + /* transform padded chunk */ + shsTransform(dig->digest, dig->data); + SHSCOUNT(dig, SHS_CHUNKSIZE-dig->datalen); + + /* empty buffer */ + dig->datalen = 0; + + /* previous value is now not a string */ + state->prevstr = FALSE; + } + return; +} + + +/* + * shs_note - note a special value + * + * given: + * state the state to hash + * special a special value (SHS_HASH_XYZ) to note + * + * This function will note that a special value is about to be hashed. + * Types include negative values, complex values, division, zero numeric + * and array of HALFs. + */ +static void +shs_note(HASH *state, int special) +{ + SHS_INFO *dig = &state->h_shs; /* digest state */ + int i; + + /* + * change state to reflect a special value + */ + dig->digest[0] ^= special; + for (i=1; i < SHS_DIGESTWORDS; ++i) { + dig->digest[i] ^= (special + dig->digest[i-1] + i); + } + state->prevstr = FALSE; /* it is as we just hashed a non-string */ + return; +} + + +/* + * shs_type - note a VALUE type + * + * given: + * state the state to hash + * type the VALUE type to note + * + * This function will note that a type of value is about to be hashed. + * The type of a VALUE will be noted. For purposes of hash comparison, + * we will do nothing with V_NUM and V_COM so that the other functions + * can hash to the same value reguardless of if shs_value() is called + * or not. We also do nothing with V_STR so that a hash of a string + * will produce the same value as the standard hash function. + */ +static void +shs_type(HASH *state, int type) +{ + SHS_INFO *dig = &state->h_shs; /* digest state */ + int i; + + /* + * ignore NUMBER and COMPLEX + */ + if (type == V_NUM || type == V_COM || type == V_STR) { + return; + } + + /* + * change state to reflect a VALUE type + */ + dig->digest[0] += type; + for (i=1; i < SHS_DIGESTWORDS; ++i) { + dig->digest[i] += ((type+i) ^ dig->digest[i-1]); + } + state->prevstr = FALSE; /* it is as if we just hashed a non-string */ + return; +} + + +/* + * shs_init - initialize SHS hash state + * + * given: + * state the state to initialize, or NULL to malloc it + * + * returns: + * initialized state + */ +static HASH * +shs_init(HASH *state) +{ + /* + * malloc if needed + */ + if (state == NULL) { + state = (HASH *)malloc(sizeof(HASH)); + if (state == NULL) { + math_error("cannot malloc HASH"); + /*NOTREACHED*/ + } + } + + /* + * initialize + */ + shsInit((SHS_INFO *)state); + state->prevstr = FALSE; + + /* + * return state + */ + return (HASH *)state; +} + + +/* + * shs_long - note a long value + * + * given: + * state the state to hash + * longval a long value + * + * returns: + * the new state + * + * This function will hash a long value as if it were a 64 bit value. + * The input is a long. If a long is smaller than 64 bits, we will + * hash a final 32 bits of zeros. + */ +static HASH * +shs_long(HASH *state, long longval) +{ + SHS_INFO *dig; /* digest state */ + long lval[64/LONG_BITS]; /* 64 bits of longs */ + + /* + * initialize if state is NULL + */ + if (state == NULL) { + state = shs_init(state); + } + + /* + * setup for the long value hash + */ + shs_chkpt(state); + + /* + * catch the zero numeric value special case + */ + if (longval == 0) { + /* note a zero numeric value and return */ + shs_note(state, SHS_HASH_ZERO); + state->prevstr = FALSE; /* we just hashed a non-string */ + return state; + } + + /* + * prep for a long value hash + */ + shs_note(state, SHS_BASE); + dig = &state->h_shs; + + /* + * hash as if we have a 64 bit value + */ + memset((char *)lval, 0, sizeof(lval)); + lval[0] = longval; + shsUpdate(dig, (USB8 *)lval, sizeof(lval)); + SHSCOUNT(dig, 64/8); + + /* + * all done + */ + state->prevstr = FALSE; /* we just hashed a non-string */ + return state; +} + + +/* + * shs_zvalue - hash a ZVALUE + * + * given: + * state the state to hash or NULL + * zval the ZVALUE + * + * returns: + * the new state + */ +static HASH * +shs_zvalue(HASH *state, ZVALUE zval) +{ + SHS_INFO *dig; /* digest state */ +#if BYTE_ORDER == BIG_ENDIAN && BASEB == 16 + HALF half[SHS_CHUNKHALFS]; /* SHS chunk buffer as HALFs */ + int full_lim; /* HALFs in whole chunks in zval */ + int i; + int j; +#endif + + /* + * initialize if state is NULL + */ + if (state == NULL) { + state = shs_init(state); + } + + /* + * setup for the ZVALUE hash + */ + shs_chkpt(state); + + /* + * catch the zero numeric value special case + */ + if (ziszero(zval)) { + /* note a zero numeric value and return */ + shs_note(state, SHS_HASH_ZERO); + state->prevstr = FALSE; /* we just hashed a non-string */ + return state; + } + + /* + * prep for a ZVALUE hash + */ + shs_note(state, SHS_HASH_ZVALUE); + /* note if we have a negative value */ + if (zisneg(zval)) { + shs_note(state, SHS_HASH_NEG); + } + dig = &state->h_shs; + +#if BYTE_ORDER == BIG_ENDIAN && BASEB == 16 + + /* + * hash full chunks + * + * We need to convert the array of HALFs into canonical architectural + * independent form -- 32 bit arrays. Because we have 16 bit values + * in Big Endian form, we need to swap 16 bit values so that they + * appear as 32 bit Big Endian values. + */ + full_lim = (zval.len / SHS_CHUNKHALFS) * SHS_CHUNKHALFS; + for (i=0; i < full_lim; i += SHS_CHUNKHALFS) { + /* HALF swap copy a chunk into a data buffer */ + for (j=0; j < SHS_CHUNKHALFS; j += 2) { + half[j] = zval.v[i+j+1]; + half[j+1] = zval.v[i+j]; + } + shsfullUpdate(dig, (USB8 *)half, SHS_CHUNKSIZE); + } + + /* + * hash the final partial chunk (if any) + * + * We need to convert the array of HALFs into canonical architectural + * independent form -- 32 bit arrays. Because we have 16 bit values + * in Big Endian form, we need to swap 16 bit values so that they + * appear as 32 bit Big Endian values. + */ + if (zval.len > full_lim) { + for (j=0; j < zval.len-full_lim-1; j += 2) { + half[j] = zval.v[full_lim+i+1]; + half[j+1] = zval.v[full_lim+i]; + } + if (j < zval.len-full_lim) { + half[j] = (HALF)0; + half[j+1] = zval.v[zval.len-1]; + --full_lim; + SHSCOUNT(dig, sizeof(HALF)); + } + shsUpdate(dig, (USB8 *)half, + (zval.len-full_lim)*sizeof(HALF)); + } + SHSCOUNT(dig, zval.len*sizeof(HALF)); + +#else + + /* + * hash the array of HALFs + * + * The array of HALFs is equivalent to the canonical architectural + * independent form. We either have 32 bit HALFs (in which case + * we do not case the byte order) or we have 16 bit HALFs in Little + * Endian order (which happens to be laid out in the same order as + * 32 bit values). + */ + shsUpdate(dig, (USB8 *)zval.v, zval.len*sizeof(HALF)); + SHSCOUNT(dig, zval.len*sizeof(HALF)); + +#endif + + /* + * all done + */ + state->prevstr = FALSE; /* we just hashed a non-string */ + return state; +} + + +/* + * shs_number - hash a NUMBER + * + * given: + * state the state to hash or NULL + * number the NUMBER + * + * returns: + * the new state + */ +static HASH * +shs_number(HASH *state, NUMBER *number) +{ + BOOL sign; /* sign of the denominator */ + + /* + * initialize if state is NULL + */ + if (state == NULL) { + state = shs_init(state); + } + + /* + * setup for the ZVALUE hash + */ + shs_chkpt(state); + + /* + * process the numerator + */ + state = shs_zvalue(state, number->num); + + /* + * if the NUMBER is not an integer, process the denominator + */ + if (qisfrac(number)) { + + /* note the division */ + shs_note(state, SHS_HASH_DIV); + + /* hash denominator as positive -- just in case */ + sign = number->den.sign; + number->den.sign = 0; + + /* hash the denominator */ + state = shs_zvalue(state, number->den); + + /* restore the sign */ + number->den.sign = sign; + } + + /* + * all done + */ + state->prevstr = FALSE; /* we just hashed a non-string */ + return state; +} + + +/* + * shs_complex - hash a COMPLEX + * + * given: + * state the state to hash or NULL + * complex the COMPLEX + * + * returns: + * the new state + */ +static HASH * +shs_complex(HASH *state, COMPLEX *complex) +{ + /* + * initialize if state is NULL + */ + if (state == NULL) { + state = shs_init(state); + } + + /* + * setup for the COMPLEX hash + */ + shs_chkpt(state); + + /* + * catch the zero special case + */ + if (ciszero(complex)) { + /* note a zero numeric value and return */ + shs_note(state, SHS_HASH_ZERO); + state->prevstr = FALSE; /* we just hashed a non-string */ + return state; + } + + /* + * process the real value if not pure imaginary + * + * We will ignore the real part if the value is of the form 0+xi. + */ + if (!qiszero(complex->real)) { + state = shs_number(state, complex->real); + } + + /* + * if the NUMBER is not real, process the imaginary value + * + * We will ignore the imaginary part of the value is of the form x+0i. + */ + if (!cisreal(complex)) { + + /* note the sqrt(-1) */ + shs_note(state, SHS_HASH_COMPLEX); + + /* hash the imaginary value */ + state = shs_number(state, complex->imag); + } + + /* + * all done + */ + state->prevstr = FALSE; /* we just hashed a non-string */ + return state; +} + + +/* + * shs_str - hash a string + * + * given: + * state the state to hash or NULL + * str the string + * + * returns: + * the new state + */ +static HASH * +shs_str(HASH *state, char *str) +{ + SHS_INFO *dig; /* digest state */ +#if BYTE_ORDER == LITTLE_ENDIAN + char *newstr; /* Big Endian version of str */ + USB32 newlen; /* newstr string length */ + int i; +#endif + USB32 len; /* string length */ + + /* + * initialize if state is NULL + */ + if (state == NULL) { + state = shs_init(state); + } + + /* + * setup for the string hash + */ + if (!state->prevstr) { + shs_chkpt(state); + } + len = strlen(str); + dig = &state->h_shs; + +#if BYTE_ORDER == BIG_ENDIAN + /* + * shs hashes in Big Endian form directly + */ + shsUpdate(dig, (USB8*)str, len); +#else + /* + * we must convert from Little Endian string to Big Endian string + */ + newlen = ((len+3)/4)*4; + newstr = (char *)malloc(newlen+1); + if (newstr) { + math_error("hash of string malloc failed"); + /*NOTREACHED*/ + } + strcpy(newstr, str); + newstr[len+1] = 0; + newstr[len+2] = 0; + newstr[len+3] = 0; + for (i=0; i < newlen; i += 4) { + SWAP_B8_IN_B32(newstr+i, newstr+i); + } + shsUpdate(dig, (USB8*)newstr, newlen); +#endif + SHSCOUNT((SHS_INFO *)dig, len); + + /* + * all done + */ + state->prevstr = TRUE; /* we just hashed a string */ + return state; +} + + +/* + * shs_value - hash a value + * + * given: + * state the state to hash or NULL + * value the value + * + * returns: + * the new state + */ +static HASH * +shs_value(HASH *state, VALUE *value) +{ + SHS_INFO *dig; /* digest state */ + LISTELEM *ep; /* list element pointer */ + ASSOCELEM **assochead; /* association chain head */ + ASSOCELEM *aep; /* current association value */ + ASSOCELEM *nextaep; /* next association value */ + VALUE *vp; /* pointer to next OBJ table value */ + ZVALUE fileval; /* size, position, dev, inode of a file */ + int i; + + /* + * initialize if state is NULL + */ + if (state == NULL) { + state = shs_init(state); + } + + /* + * setup for the next type of value + */ + shs_chkpt(state); + shs_type(state, value->v_type); + dig = &state->h_shs; + + /* + * process the value type + */ + switch (value->v_type) { + case V_INT: + /* hash as if we have a 64 bit value */ + state = shs_long(state, (long)value->v_int); + break; + case V_NUM: + state = shs_number(state, value->v_num); + break; + case V_COM: + state = shs_complex(state, value->v_com); + break; + case V_ADDR: + state = shs_value(state, value->v_addr); + break; + case V_STR: + state = shs_str(state, value->v_str); + break; + case V_MAT: + /* hash all the elements of the matrix */ + for (i=0; i < value->v_mat->m_size; ++i) { + /* force strings to not be concatinated */ + state->prevstr = FALSE; + /* hash the next matrix value */ + state = shs_value(state, value->v_mat->m_table+i); + } + /* don't allow the next string to concatinate to the matrix */ + state->prevstr = FALSE; + break; + case V_LIST: + /* hash all the elements of the list */ + for (i=0, ep = value->v_list->l_first; + ep != NULL && i < value->v_list->l_count; + ++i, ep = ep->e_next) { + /* force strings to not be concatinated */ + state->prevstr = FALSE; + /* hash the next list value */ + state = shs_value(state, &ep->e_value); + } + /* don't allow the next string to concatinate to the list */ + state->prevstr = FALSE; + break; + case V_ASSOC: + assochead = value->v_assoc->a_table; + for (i = 0; i < value->v_assoc->a_size; i++) { + nextaep = *assochead; + while (nextaep) { + aep = nextaep; + nextaep = aep->e_next; + /* force strings to not be concatinated */ + state->prevstr = FALSE; + /* hash the next association value */ + state = shs_value(state, &aep->e_value); + } + assochead++; + } + /* don't allow the next string to concatinate to the assoc */ + state->prevstr = FALSE; + break; + case V_OBJ: + for (i=value->v_obj->o_actions->count, vp=value->v_obj->o_table; + i-- > 0; + vp++) { + /* force strings to not be concatinated */ + state->prevstr = FALSE; + /* hash the next object value */ + shs_value(state, vp); + } + /* don't allow the next string to concatinate to the object */ + state->prevstr = FALSE; + break; + case V_FILE: + /* hash file length if possible */ + if (getsize(value->v_file, &fileval) == 0) { + state = shs_zvalue(state, fileval); + zfree(fileval); + } else { + /* hash -1 for invalid length */ + state = shs_long(state, (long)-1); + } + /* hash the file position if possible */ + if (getloc(value->v_file, &fileval) == 0) { + state = shs_zvalue(state, fileval); + zfree(fileval); + } else { + /* hash -1 for invalid location */ + state = shs_long(state, (long)-1); + } + /* hash the file device if possible */ + if (get_device(value->v_file, &fileval) == 0) { + state = shs_zvalue(state, fileval); + zfree(fileval); + } else { + /* hash -1 for invalid device */ + state = shs_long(state, (long)-1); + } + /* hash the file inode if possible */ + if (get_inode(value->v_file, &fileval) == 0) { + state = shs_zvalue(state, fileval); + zfree(fileval); + } else { + /* hash -1 for invalid inode */ + state = shs_long(state, (long)-1); + } + break; + case V_RAND: + state = shs_long(state, (long)value->v_rand->seeded); + state = shs_long(state, (long)value->v_rand->bits); + shsUpdate(dig, (USB8 *)value->v_rand->buffer, SLEN*FULL_BITS/8); + SHSCOUNT(dig, SLEN*FULL_BITS/8); + state = shs_long(state, (long)value->v_rand->j); + state = shs_long(state, (long)value->v_rand->k); + shsUpdate(dig, (USB8 *)value->v_rand->slot, SCNT*FULL_BITS/8); + SHSCOUNT(dig, SCNT*FULL_BITS/8); + shsUpdate(dig, (USB8*)value->v_rand->shuf, SHUFLEN*FULL_BITS/8); + SHSCOUNT(dig, SHUFLEN*FULL_BITS/8); + /* don't allow the next string to concatinate to the list */ + state->prevstr = FALSE; + break; + case V_RANDOM: + state = shs_long(state, (long)value->v_random->seeded); + state = shs_long(state, (long)value->v_random->bits); + shsUpdate(dig, (USB8 *)&(value->v_random->buffer), BASEB/8); + SHSCOUNT(dig, SLEN*FULL_BITS/8); + state = shs_zvalue(state, *(value->v_random->r)); + state = shs_zvalue(state, *(value->v_random->n)); + /* don't allow the next string to concatinate to the list */ + state->prevstr = FALSE; + break; + case V_CONFIG: + state = shs_long(state, (long)value->v_config->outmode); + state = shs_long(state, (long)value->v_config->outdigits); + state = shs_number(state, value->v_config->epsilon); + state = shs_long(state, (long)value->v_config->epsilonprec); + state = shs_long(state, (long)value->v_config->traceflags); + state = shs_long(state, (long)value->v_config->maxprint); + state = shs_long(state, (long)value->v_config->mul2); + state = shs_long(state, (long)value->v_config->sq2); + state = shs_long(state, (long)value->v_config->pow2); + state = shs_long(state, (long)value->v_config->redc2); + state = shs_long(state, (long)value->v_config->tilde_ok); + state = shs_long(state, (long)value->v_config->tab_ok); + state = shs_long(state, (long)value->v_config->quomod); + state = shs_long(state, (long)value->v_config->quo); + state = shs_long(state, (long)value->v_config->mod); + state = shs_long(state, (long)value->v_config->sqrt); + state = shs_long(state, (long)value->v_config->appr); + state = shs_long(state, (long)value->v_config->cfappr); + state = shs_long(state, (long)value->v_config->cfsim); + state = shs_long(state, (long)value->v_config->outround); + state = shs_long(state, (long)value->v_config->round); + state = shs_long(state, (long)value->v_config->leadzero); + state = shs_long(state, (long)value->v_config->fullzero); + state = shs_long(state, (long)value->v_config->maxerrorcount); + state = shs_str(state, value->v_config->prompt1); + state = shs_str(state, value->v_config->prompt2); + /* don't allow the next string to concatinate to the list */ + state->prevstr = FALSE; + break; + case V_HASH: + if (value->v_hash->type == SHS_HASH_TYPE) { + shsUpdate(dig, (USB8 *)&value->v_hash->h_shs, + sizeof(SHS_INFO)); + SHSCOUNT(dig, sizeof(SHS_INFO)); + } else { + math_error("SHS hashing a non-SHS hash state"); + /*NOTREACHED*/ + } + /* don't allow the next string to concatinate to the list */ + state->prevstr = FALSE; + break; + default: + math_error("hashing an unknown value"); + /*NOTREACHED*/ + } + return state; +} + + +/* + * shs_final - complete hash state and return a ZVALUE + * + * given: + * state the state to complete and convert + * + * returns: + * a ZVALUE representing the state + */ +static ZVALUE +shs_final(HASH *state) +{ + SHS_INFO *dig; /* digest state */ + ZVALUE ret; /* return ZVALUE of completed hash state */ +#if BTYE_ORDER == BIG_ENDIAN && BASEB == 16 + int i; +#endif + + /* + * initialize if state is NULL + */ + if (state == NULL) { + state = shs_init(state); + } + + /* + * complete the hash state + */ + dig = &state->h_shs; + shsFinal(dig); + + /* + * allocate storage for ZVALUE + */ + ret.len = SHS_DIGESTSIZE/sizeof(HALF); + ret.sign = 0; + ret.v = alloc(ret.len); + + /* + * load ZVALUE + */ +#if BTYE_ORDER == BIG_ENDIAN && BASEB == 16 + for (i=0; i < ret.len; i+=2) { + rev.v[i+1] = ((HALF*)dig->digest)[i]; + rev.v[i] = ((HALF*)dig->digest)[i+1]; + } +#else + memcpy(ret.v, dig->digest, SHS_DIGESTSIZE); +#endif + + /* + * return ZVALUE + */ + return ret; +} + + +/* + * shs_hashfunc - initialize a hashfunc for an interface for this hash + * + * given: + * hfunc - pointer to the hfunction element to initialize + */ +void +shs_hashfunc(HASHFUNC *hfunc) +{ + /* + * initalize + */ + hfunc->type = SHS_HASH_TYPE; + hfunc->init = shs_init; + hfunc->longval = shs_long; + hfunc->str = shs_str; + hfunc->value = shs_value; + hfunc->complex = shs_complex; + hfunc->number = shs_number; + hfunc->zvalue = shs_zvalue; + hfunc->final = shs_final; + return; +} diff --git a/shs.h b/shs.h new file mode 100644 index 0000000..65fa555 --- /dev/null +++ b/shs.h @@ -0,0 +1,88 @@ +/* XXX - this code is currently not really used, but it will be soon */ +/* + * shs - old Secure Hash Standard + * + ************************************************************************** + * This version implements the old Secure Hash Algorithm specified by * + * (FIPS Pub 180). This version is kept for backward compatibility with * + * shs version 2.10.1. See the shs utility for the new standard. * + ************************************************************************** + * + * Written 2 September 1992, Peter C. Gutmann. + * + * This file was Modified by: + * + * Landon Curt Noll (chongo@toad.com) chongo /\../\ + * + * This code has been placed in the public domain. Please do not + * copyright this code. + * + * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO + * THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MER- + * CHANTABILITY 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. + * + * See shsdrvr.c for version and modification history. + */ + +#if !defined(SHS_H) +#define SHS_H + +#include +#include + +/* SHS_CHUNKSIZE must be a power of 2 - fixed value defined by the algorithm */ +#define SHS_CHUNKSIZE (1<<6) +#define SHS_CHUNKWORDS (SHS_CHUNKSIZE/sizeof(USB32)) +#define SHS_CHUNKHALFS (SHS_CHUNKSIZE/sizeof(HALF)) + +/* SHS_DIGESTSIZE is a the length of the digest as defined by the algorithm */ +#define SHS_DIGESTSIZE (20) +#define SHS_DIGESTWORDS (SHS_DIGESTSIZE/sizeof(USB32)) + +/* SHS_LOW - where low 32 bits of 64 bit count is stored during final */ +#define SHS_LOW 15 + +/* SHS_HIGH - where high 32 bits of 64 bit count is stored during final */ +#define SHS_HIGH 14 + +/* what to xor to digest value when hashing special values */ +#define SHS_BASE 0x1234face /* base special hash value */ +#define SHS_HASH_NEG (1+SHS_BASE) /* note a negative value */ +#define SHS_HASH_COMPLEX (2+SHS_BASE) /* note a complex value */ +#define SHS_HASH_DIV (4+SHS_BASE) /* note a division by a value */ +#define SHS_HASH_ZERO (8+SHS_BASE) /* note a zero numeric value */ +#define SHS_HASH_ZVALUE (16+SHS_BASE) /* note a ZVALUE */ + +/* + * The structure for storing SHS info + * + * We will assume that bit count is a multiple of 8. + */ +typedef struct { + USB32 digest[SHS_DIGESTWORDS]; /* message digest */ + USB32 countLo; /* 64 bit count: bits 3-34 */ + USB32 countHi; /* 64 bit count: bits 35-63 */ + USB32 datalen; /* length of data in data */ + USB32 data[SHS_CHUNKWORDS]; /* SHS chunk buffer */ +} SHS_INFO; + +/* + * SHSCOUNT(SHS_INFO*, USB32) - update the 64 bit count in an SHS_INFO + * + * We will count bytes and convert to bit count during the final + * transform. This assumes that the count is < 2^32. + */ +#define SHSCOUNT(shsinfo, count) { \ + USB32 tmp_countLo; \ + tmp_countLo = (shsinfo)->countLo; \ + if (((shsinfo)->countLo += (count)) < tmp_countLo) { \ + (shsinfo)->countHi++; \ + } \ +} + +#endif diff --git a/string.c b/string.c new file mode 100644 index 0000000..b6d2c67 --- /dev/null +++ b/string.c @@ -0,0 +1,289 @@ +/* + * Copyright (c) 1995 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. + * + * given: + * hp structure to be inited + */ +void +initstr(STRINGHEAD *hp) +{ + 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. + * + * given: + * hp header of string storage + * str string to be added + */ +char * +addstr(STRINGHEAD *hp, char *str) +{ + 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 = (long)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(int ch) +{ + char *cp; + int i; + + if (chartable == NULL) { + cp = (char *)malloc(512); + if (cp == NULL) { + math_error("Cannot allocate character table"); + /*NOTREACHED*/ + } + 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. + * + * given: + * hp header of string storage + * str string to be added + */ +int +findstr(STRINGHEAD *hp, char *str) +{ + register char *test; /* string being tested */ + long len; /* length of string being found */ + long testlen; /* length of test string */ + int index; /* index of string */ + + if ((hp->h_count <= 0) || (str == NULL)) + return -1; + len = (long)strlen(str); + test = hp->h_list; + index = 0; + while (*test) { + testlen = (long)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. + * + * given: + * hp header of string storage + * n + */ +char * +namestr(STRINGHEAD *hp, 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\000str2\000str3\000...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. + * + * Be sure to use \000 instead of \0. ANSI-C compilers interpret "foo\0foo..." + * as "foo\017oo...". + * + * given: + * format string formatted into substrings + * test string to be found in formatted string + */ +long +stringindex(char *format, char *test) +{ + long index; /* found index */ + long len; /* length of current piece of string */ + long testlen; /* length of test string */ + + testlen = (long)strlen(test); + index = 1; + while (*format) { + len = (long)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(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 = (long)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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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"); + /*NOTREACHED*/ + } + 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; +} + +/* END CODE */ diff --git a/string.h b/string.h new file mode 100644 index 0000000..3ebebe4 --- /dev/null +++ b/string.h @@ -0,0 +1,31 @@ +/* + * 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(STRINGHEAD *hp); +extern char *addstr(STRINGHEAD *hp, char *str); +extern char *namestr(STRINGHEAD *hp, long n); +extern int findstr(STRINGHEAD *hp, char *str); +extern char *charstr(int ch); +extern char *addliteral(char *str); +extern long stringindex(char *str1, char *str2); + +#endif + +/* END CODE */ diff --git a/symbol.c b/symbol.c new file mode 100644 index 0000000..ea12148 --- /dev/null +++ b/symbol.c @@ -0,0 +1,513 @@ +/* + * Copyright (c) 1996 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(NUMBER *num, long digits, long width); +static void unscope(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(void) +{ + 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. + * + * given: + * name name of global variable + * isstatic TRUE if symbol is static + */ +GLOBAL * +addglobal(char *name, BOOL isstatic) +{ + GLOBAL *sp; /* current symbol pointer */ + GLOBAL **hp; /* hash table head address */ + int 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 = (int)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. + * + * given: + * name name of global variable + */ +GLOBAL * +findglobal(char *name) +{ + GLOBAL *sp; /* current symbol pointer */ + GLOBAL *bestsp; /* found symbol with highest scope */ + long len; /* length of string */ + + bestsp = NULL; + len = (long)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. + * + * given: + * sp address of global pointer + */ +char * +globalname(GLOBAL *sp) +{ + 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(void) +{ + 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(NUMBER *num, long digits, long 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, 0); + qprintf("%r", val); + printf("..."); + qfree(p); + qfree(div); + qfree(val); + p = itoq(show); + div = qpowi(t, p); + val = qmod(num, div, 0); + 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(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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + 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(void) +{ + initstr(&localnames); + initstr(¶mnames); + 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. + * + * given: + * name name of local variable + */ +long +addlocal(char *name) +{ + 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. + * + * given: + * name name of local variable + */ +long +findlocal(char *name) +{ + return findstr(&localnames, name); +} + + +/* + * Return the name of a local variable. + */ +char * +localname(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. + * + * given: + * name name of parameter variable + */ +long +addparam(char *name) +{ + long index; /* current symbol index */ + + index = findstr(¶mnames, name); + if (index >= 0) + return index; + index = paramnames.h_count; + (void) addstr(¶mnames, 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. + * + * given: + * name name of parameter variable + */ +long +findparam(char *name) +{ + return findstr(¶mnames, name); +} + + +/* + * Return the name of a parameter variable. + */ +char * +paramname(long n) +{ + return namestr(¶mnames, n); +} + + +/* + * Return the type of a variable name. + * This is either local, parameter, global, static, or undefined. + * + * given: + * name variable name to find + */ +int +symboltype(char *name) +{ + 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/symbol.h b/symbol.h new file mode 100644 index 0000000..9cb01b0 --- /dev/null +++ b/symbol.h @@ -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(char *name, BOOL isstatic); +extern GLOBAL *findglobal(char *name); + + +/* + * Routines to return names of variables. + */ +extern char *localname(long n); +extern char *paramname(long n); +extern char *globalname(GLOBAL *sp); + + +/* + * Routines to handle entering and leaving of scope levels. + */ +extern void resetscopes(void); +extern void enterfilescope(void); +extern void exitfilescope(void); +extern void enterfuncscope(void); +extern void exitfuncscope(void); + + +/* + * Other routines. + */ +extern long addlocal(char *name); +extern long findlocal(char *name); +extern long addparam(char *name); +extern long findparam(char *name); +extern void initlocals(void); +extern void initglobals(void); +extern int writeglobals(char *name); +extern int symboltype(char *name); +extern void showglobals(void); + +#endif + +/* END CODE */ diff --git a/token.c b/token.c new file mode 100644 index 0000000..820420a --- /dev/null +++ b/token.c @@ -0,0 +1,657 @@ +/* + * Copyright (c) 1995 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 "calc.h" +#include "token.h" +#include "string.h" +#include "args.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) == '_')) +#define isoctal(ch) (((ch) >= '0') && ((ch) <= '7')) + +#define STRBUFSIZE 1024 + + +/* + * 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 = 0; /* 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}, + {"cd", T_CD}, + {NULL, 0} +}; + + +static void eatcomment(void); +static void eatstring(int quotechar); +static int eatsymbol(void); +static int eatnumber(void); + + +/* + * Initialize all token information. + */ +void +inittokens(void) +{ + initstr(&strings); + newlines = FALSE; + allsyms = FALSE; + rescan = FALSE; + setprompt(conf->prompt1); +} + + +/* + * Set the new token mode according to the specified flag, and return the + * previous value of the flag. + */ +int +tokenmode(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 ? conf->prompt1 : conf->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(void) +{ + 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(conf->prompt2); break; + default: scanerror(T_NULL, "Unknown token character '%c'", ch); + } + break; + default: + if (isletter(ch) || 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(void) +{ + 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(int quotechar) +{ + register char *cp; /* current character address */ + int ch, cch; /* current character */ + int i; /* index */ + char buf[STRBUFSIZE]; /* buffer for string */ + long len; /* length in buffer */ + long totlen; /* total length, including '\0' */ + char *str; + BOOL done; + + str = buf; + totlen = 0; + done = FALSE; + + while (!done) { + cp = buf; + len = 0; + while (!done && len < STRBUFSIZE) { + ch = nextchar(); + switch (ch) { + case '\n': + if (!newlines) + break; + case '\0': + case EOF: + reread(); + scanerror(T_NULL, "Unterminated string constant"); + done = TRUE; + ch = '\0'; + break; + + case '\\': + ch = nextchar(); + if (isoctal(ch)) { + ch = ch - '0'; + for (i = 2; i > 0; i--) { + cch = nextchar(); + if (!isoctal(cch)) + break; + ch = 8 * ch + cch - '0'; + } + ch &= 0xff; + if (i > 0) + reread(); + break; + } + 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 'v': ch = '\v'; break; + case 'a': ch = '\007'; break; + case 'e': ch = '\033'; break; + case '\n': + setprompt(conf->prompt2); + continue; + case EOF: + reread(); + continue; + case 'x': + ch = 0; + for (i = 2; i > 0; i--) { + cch = nextchar(); + if (isdigit(cch)) + ch = 16 * ch + cch - '0'; + else if (cch >= 'a' && cch <= 'f') + ch = 16 * ch + 10 + cch - 'a'; + else if (cch >= 'A' && cch <= 'F') + ch = 16 * ch + 10 + cch - 'A'; + else break; + } + if (i > 0) + reread(); + } + break; + case '"': + case '\'': + if (ch == quotechar) { + done = TRUE; + ch = '\0'; + } + break; + } + + *cp++ = (char) ch; + len++; + } + if (!done || totlen) { + if (totlen) + str = (char *) realloc(str, totlen + len); + else + str = (char *) malloc(len); + if (str == NULL) { + math_error("Out of memory for reading tokens"); + /*NOTREACHED*/ + } + memcpy(str + totlen, buf, len); + totlen += len; + } + } + curtoken.t_str = addliteral(str); + if (str != buf) + free(str); +} + + +/* + * 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(void) +{ + 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(void) +{ + 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"); + /*NOTREACHED*/ + } + 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 (int)res; +} + + +/* + * Return the string value of the current token. + */ +char * +tokenstring(void) +{ + return curtoken.t_str; +} + + +/* + * Return the constant index of a numeric token. + */ +long +tokennumber(void) +{ + return curtoken.t_numindex; +} + + +/* + * Push back the token just read so that it will be seen again. + */ +void +rescantoken(void) +{ + rescan = TRUE; +} + + +/* + * Describe an error message. + * Then skip to the next specified token (or one more powerful). + */ +void +scanerror(int skip, char *fmt, ...) +{ + va_list ap; + char *name; /* name of file with error */ + char buf[MAXERROR+1]; + + /* count the error */ + errorcount++; + + /* print the error message */ + name = inputname(); + if (name) + fprintf(stderr, "\"%s\", line %ld: ", name, linenumber()); + va_start(ap, fmt); + vsprintf(buf, fmt, ap); + va_end(ap); + fprintf(stderr, "%s\n", buf); + + /* bail out if too many errors */ + if (conf->maxerrorcount > 0 && errorcount > conf->maxerrorcount) { + fputs("Too many scan errors, compilation aborted.\n", stderr); + longjmp(jmpbuf, 1); + /*NOTREACHED*/ + } + + /* post-error report processing */ + 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/token.h b/token.h new file mode 100644 index 0000000..82ec11c --- /dev/null +++ b/token.h @@ -0,0 +1,138 @@ +/* + * Copyright (c) 1995 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_CD 125 /* change directory 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(void); +extern long tokennumber(void); +extern void inittokens(void); +extern int tokenmode(int flag); +extern int gettoken(void); +extern void rescantoken(void); +extern void scanerror(int, char *, ...); + +#endif + +/* END CODE */ diff --git a/value.c b/value.c new file mode 100644 index 0000000..6edd129 --- /dev/null +++ b/value.c @@ -0,0 +1,2006 @@ +/* + * Copyright (c) 1996 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" +#include "zrand.h" +#include "cmath.h" + + +/* + * Free a value and set its type to undefined. + * + * given: + * vp value to be freed + */ +void +freevalue(VALUE *vp) +{ + int type; /* type of value being freed */ + + type = vp->v_type; + vp->v_type = V_NULL; + if (type < 0) + return; + 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; + case V_RAND: + randfree(vp->v_rand); + break; + case V_RANDOM: + randomfree(vp->v_random); + break; + case V_CONFIG: + config_free(vp->v_config); + break; +#if 0 /* XXX - write */ + case V_HASH: + hash_free(vp->v_hash); + break; +#endif + default: + math_error("Freeing unknown value type"); + /*NOTREACHED*/ + } + vp->v_subtype = V_NOSUBTYPE; +} + + +/* + * Copy a value from one location to another. + * This overwrites the specified new value without checking it. + * + * given: + * oldvp value to be copied from + * newvp value to be copied into + */ +void +copyvalue(VALUE *oldvp, VALUE *newvp) +{ + if (oldvp->v_type < 0) { + newvp->v_type = oldvp->v_type; + return; + } + 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"); + /*NOTREACHED*/ + } + 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; + case V_RAND: + newvp->v_rand = randcopy(oldvp->v_rand); + break; + case V_RANDOM: + newvp->v_random = randomcopy(oldvp->v_random); + break; + case V_CONFIG: + newvp->v_config = config_copy(oldvp->v_config); + break; +#if 0 /* XXX - write */ + case V_HASH: + newvp->v_hash = hash_copy(oldvp->v_hash); + break; +#endif + default: + math_error("Copying unknown value type"); + /*NOTREACHED*/ + } + 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(VALUE *vp, VALUE *vres) +{ + vres->v_type = vp->v_type; + switch (vp->v_type) { + case V_NUM: + vres->v_num = qneg(vp->v_num); + return; + case V_COM: + vres->v_com = cneg(vp->v_com); + return; + case V_MAT: + vres->v_mat = matneg(vp->v_mat); + return; + case V_OBJ: + *vres = objcall(OBJ_NEG, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) + return; + *vres = error_value(E_NEG); + return; + } +} + + +/* + * addnumeric - add two numeric values togethter + * + * If either value is not real or complex, it is assumed to have + * a value of 0. + * + * Result is placed in the indicated location. + */ +void +addnumeric(VALUE *v1, VALUE *v2, VALUE *vres) +{ + COMPLEX *c; + + /* + * add numeric values + */ + vres->v_subtype = V_NOSUBTYPE; + switch (TWOVAL(v1->v_type, v2->v_type)) { + case TWOVAL(V_NUM, V_NUM): + vres->v_num = qqadd(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; + } + + /* + * assume zero if a value is not numeric + */ + if (v1->v_type == V_NUM) { + /* v1 + 0 == v1 */ + vres->v_type = v1->v_type; + vres->v_num = qlink(v1->v_num); + } else if (v1->v_type == V_COM) { + /* v1 + 0 == v1 */ + vres->v_type = v1->v_type; + vres->v_com = clink(v1->v_com); + } else if (v2->v_type == V_NUM) { + /* v2 + 0 == v2 */ + vres->v_type = v2->v_type; + vres->v_num = qlink(v2->v_num); + } else if (v2->v_type == V_COM) { + /* v2 + 0 == v2 */ + vres->v_type = v2->v_type; + vres->v_com = clink(v2->v_com); + } else { + /* 0 + 0 = 0 */ + vres->v_type = V_NUM; + vres->v_num = qlink(&_qzero_); + } + return; +} + + +/* + * Add two arbitrary values together. + * Result is placed in the indicated location. + */ +void +addvalue(VALUE *v1, VALUE *v2, VALUE *vres) +{ + COMPLEX *c; + VALUE tmp; + + if (v1->v_type == V_LIST) { + tmp.v_type = V_NULL; + addlistitems(v1->v_list, &tmp); + addvalue(&tmp, v2, vres); + return; + } + if (v2->v_type == V_LIST) { + copyvalue(v1, vres); + addlistitems(v2->v_list, vres); + return; + } + if (v1->v_type == V_NULL) { + copyvalue(v2, vres); + return; + } + if (v2->v_type == V_NULL) { + copyvalue(v1, vres); + return; + } + vres->v_type = v1->v_type; + switch (TWOVAL(v1->v_type, v2->v_type)) { + case TWOVAL(V_NUM, V_NUM): + vres->v_num = qqadd(v1->v_num, v2->v_num); + return; + case TWOVAL(V_COM, V_NUM): + vres->v_com = caddq(v1->v_com, v2->v_num); + 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); + 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); + return; + default: + if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) { + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v2->v_type < 0) { + copyvalue(v2, vres); + return; + } + *vres = error_value(E_ADD); + return; + } + *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(VALUE *v1, VALUE *v2, VALUE *vres) +{ + COMPLEX *c; + + vres->v_type = v1->v_type; + switch (TWOVAL(v1->v_type, v2->v_type)) { + case TWOVAL(V_NUM, V_NUM): + vres->v_num = qsub(v1->v_num, v2->v_num); + return; + case TWOVAL(V_COM, V_NUM): + vres->v_com = csubq(v1->v_com, v2->v_num); + return; + case TWOVAL(V_NUM, V_COM): + c = csubq(v2->v_com, v1->v_num); + vres->v_type = V_COM; + vres->v_com = cneg(c); + comfree(c); + return; + case TWOVAL(V_COM, V_COM): + vres->v_com = csub(v1->v_com, v2->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); + return; + default: + if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) { + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v2->v_type < 0) { + copyvalue(v2, vres); + return; + } + *vres = error_value(E_SUB); + return; + } + *vres = objcall(OBJ_SUB, v1, v2, NULL_VALUE); + return; + } +} + + +/* + * Multiply two arbitrary values together. + * Result is placed in the indicated location. + */ +void +mulvalue(VALUE *v1, VALUE *v2, VALUE *vres) +{ + COMPLEX *c; + + vres->v_type = v1->v_type; + switch (TWOVAL(v1->v_type, v2->v_type)) { + case TWOVAL(V_NUM, V_NUM): + vres->v_num = qmul(v1->v_num, v2->v_num); + return; + case TWOVAL(V_COM, V_NUM): + vres->v_com = cmulq(v1->v_com, v2->v_num); + 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); + break; + case TWOVAL(V_MAT, V_MAT): + vres->v_mat = matmul(v1->v_mat, v2->v_mat); + return; + case TWOVAL(V_MAT, V_NUM): + case TWOVAL(V_MAT, V_COM): + vres->v_mat = matmulval(v1->v_mat, v2); + 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)) { + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v2->v_type < 0) { + copyvalue(v2, vres); + return; + } + *vres = error_value(E_MUL); + return; + } + *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(VALUE *vp, VALUE *vres) +{ + COMPLEX *c; + + vres->v_type = vp->v_type; + switch (vp->v_type) { + case V_NUM: + vres->v_num = qsquare(vp->v_num); + return; + case V_COM: + vres->v_com = csquare(vp->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); + return; + case V_OBJ: + *vres = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + *vres = error_value(E_SQUARE); + return; + } +} + + +/* + * Invert an arbitrary value. + * Result is placed in the indicated location. + */ +void +invertvalue(VALUE *vp, VALUE *vres) +{ + vres->v_type = vp->v_type; + switch (vp->v_type) { + case V_NUM: + vres->v_num = qinv(vp->v_num); + return; + case V_COM: + vres->v_com = cinv(vp->v_com); + return; + case V_MAT: + vres->v_mat = matinv(vp->v_mat); + return; + case V_OBJ: + *vres = objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + *vres = error_value(E_INV); + return; + } +} + + +/* + * Approximate numbers by multiples of v2 using rounding criterion v3. + * Result is placed in the indicated location. + */ +void +apprvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) +{ + NUMBER *e; + long R = 0; + NUMBER *q1, *q2; + COMPLEX *c; + + vres->v_type = v1->v_type; + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + e = NULL; + switch(v2->v_type) { + case V_NUM: e = v2->v_num; + break; + case V_NULL: e = conf->epsilon; + break; + default: + *vres = error_value(E_APPR2); + return; + } + switch(v3->v_type) { + case V_NUM: if (qisfrac(v3->v_num)) { + *vres = error_value(E_APPR3); + return; + } + R = qtoi(v3->v_num); + break; + case V_NULL: R = conf->appr; + break; + default: + *vres = error_value(E_APPR3); + return; + } + + if (qiszero(e)) { + copyvalue(v1, vres); + return; + } + switch (v1->v_type) { + case V_NUM: + vres->v_num = qmappr(v1->v_num, e, R); + return; + case V_MAT: + vres->v_mat = matappr(v1->v_mat, v2, v3); + return; + case V_LIST: + vres->v_list = listappr(v1->v_list, v2, v3); + return; + case V_COM: + q1 = qmappr(v1->v_com->real, e, R); + q2 = qmappr(v1->v_com->imag, e, R); + if (qiszero(q2)) { + vres->v_type = V_NUM; + vres->v_num = q1; + qfree(q2); + return; + } + c = comalloc(); + c->real = q1; + c->imag = q2; + vres->v_com = c; + return; + default: + *vres = error_value(E_APPR); + return; + } +} + + +/* + * Round numbers to number of decimals specified by v2, type of rounding + * specified by v3. Result placed in location vres. + */ +void +roundvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) +{ + NUMBER *q1, *q2; + COMPLEX *c; + long places, rnd; + + vres->v_type = v1->v_type; + if (v1->v_type == V_MAT) { + vres->v_mat = matround(v1->v_mat, v2, v3); + return; + } + if (v1->v_type == V_LIST) { + vres->v_list = listround(v1->v_list, v2, v3); + return; + } + if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) { + *vres = objcall(OBJ_ROUND, v1, v2, v3); + return; + } + places = 0; + switch (v2->v_type) { + case V_NUM: + if (qisfrac(v2->v_num)) { + *vres = error_value(E_ROUND2); + return; + } + places = qtoi(v2->v_num); + break; + case V_NULL: + break; + default: + *vres = error_value(E_ROUND2); + return; + } + rnd = 0; + switch (v3->v_type) { + case V_NUM: + if (qisfrac(v3->v_num)) { + *vres = error_value(E_ROUND3); + return; + } + rnd = qtoi(v3->v_num); + break; + case V_NULL: + rnd = conf->round; + break; + default: + *vres = error_value(E_ROUND3); + return; + } + switch(v1->v_type) { + case V_NUM: + vres->v_num = qround(v1->v_num, places, rnd); + return; + case V_COM: + q1 = qround(v1->v_com->real, places, rnd); + q2 = qround(v1->v_com->imag, places, rnd); + if (qiszero(q2)) { + vres->v_type = V_NUM; + vres->v_num = q1; + qfree(q2); + return; + } + c = comalloc(); + c->real = q1; + c->imag = q2; + vres->v_com = c; + return; + default: + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + *vres = error_value(E_ROUND); + return; + } +} + + + +/* + * Round numbers to number of binary digits specified by v2, type of rounding + * specified by v3. Result placed in location vres. + */ +void +broundvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) +{ + NUMBER *q1, *q2; + COMPLEX *c; + long places, rnd; + + vres->v_type = v1->v_type; + if (v1->v_type == V_MAT) { + vres->v_mat = matbround(v1->v_mat, v2, v3); + return; + } + if (v1->v_type == V_LIST) { + vres->v_list = listbround(v1->v_list, v2, v3); + return; + } + if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) { + *vres = objcall(OBJ_BROUND, v1, v2, v3); + return; + } + places = 0; + switch (v2->v_type) { + case V_NUM: + if (qisfrac(v2->v_num)) { + *vres = error_value(E_BROUND2); + return; + } + places = qtoi(v2->v_num); + break; + case V_NULL: + break; + default: + *vres = error_value(E_BROUND2); + return; + } + rnd = 0; + switch (v3->v_type) { + case V_NUM: + if (qisfrac(v3->v_num)) { + *vres = error_value(E_BROUND3); + return; + } + rnd = qtoi(v3->v_num); + break; + case V_NULL: + rnd = conf->round; + break; + default: + *vres = error_value(E_BROUND3); + return; + } + switch(v1->v_type) { + case V_NUM: + vres->v_num = qbround(v1->v_num, places, rnd); + return; + case V_COM: + q1 = qbround(v1->v_com->real, places, rnd); + q2 = qbround(v1->v_com->imag, places, rnd); + if (qiszero(q2)) { + vres->v_type = V_NUM; + vres->v_num = q1; + qfree(q2); + return; + } + c = comalloc(); + c->real = q1; + c->imag = q2; + vres->v_com = c; + return; + default: + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + *vres = error_value(E_BROUND); + return; + } +} + +/* + * Take the integer part of an arbitrary value. + * Result is placed in the indicated location. + */ +void +intvalue(VALUE *vp, VALUE *vres) +{ + COMPLEX *c; + + vres->v_type = vp->v_type; + 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); + return; + case V_COM: + if (cisint(vp->v_com)) { + vres->v_com = clink(vp->v_com); + return; + } + vres->v_com = cint(vp->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); + return; + case V_OBJ: + *vres = objcall(OBJ_INT, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + *vres = error_value(E_INT); + return; + } +} + + +/* + * Take the fractional part of an arbitrary value. + * Result is placed in the indicated location. + */ +void +fracvalue(VALUE *vp, VALUE *vres) +{ + COMPLEX *c; + + vres->v_type = vp->v_type; + 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); + 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); + 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 = matfrac(vp->v_mat); + return; + case V_OBJ: + *vres = objcall(OBJ_FRAC, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + *vres = error_value(E_FRAC); + return; + } +} + + +/* + * Increment an arbitrary value by one. + * Result is placed in the indicated location. + */ +void +incvalue(VALUE *vp, VALUE *vres) +{ + vres->v_type = vp->v_type; + switch (vp->v_type) { + case V_NUM: + vres->v_num = qinc(vp->v_num); + return; + case V_COM: + vres->v_com = caddq(vp->v_com, &_qone_); + return; + case V_OBJ: + *vres = objcall(OBJ_INC, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + *vres = error_value(E_INCV); + return; + } +} + + +/* + * Decrement an arbitrary value by one. + * Result is placed in the indicated location. + */ +void +decvalue(VALUE *vp, VALUE *vres) +{ + vres->v_type = vp->v_type; + switch (vp->v_type) { + case V_NUM: + vres->v_num = qdec(vp->v_num); + return; + case V_COM: + vres->v_com = caddq(vp->v_com, &_qnegone_); + return; + case V_OBJ: + *vres = objcall(OBJ_DEC, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + *vres = error_value(E_DECV); + return; + } +} + + +/* + * Produce the 'conjugate' of an arbitrary value. + * Result is placed in the indicated location. + * (Example: complex conjugate.) + */ +void +conjvalue(VALUE *vp, VALUE *vres) +{ + vres->v_type = vp->v_type; + switch (vp->v_type) { + case V_NUM: + vres->v_num = qlink(vp->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); + return; + case V_MAT: + vres->v_mat = matconj(vp->v_mat); + return; + case V_OBJ: + *vres = objcall(OBJ_CONJ, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + *vres = error_value(E_CONJ); + return; + } +} + + +/* + * Take the square root of an arbitrary value within the specified error. + * Result is placed in the indicated location. + */ +void +sqrtvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) +{ + NUMBER *q, *tmp; + COMPLEX *c; + long R; + + if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) { + *vres = objcall(OBJ_SQRT, v1, v2, v3); + return; + } + vres->v_type = v1->v_type; + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v2->v_type == V_NULL) + q = conf->epsilon; + else { + if (v2->v_type != V_NUM || qiszero(v2->v_num)) { + *vres = error_value(E_SQRT2); + return; + } + q = v2->v_num; + } + if (v3->v_type == V_NULL) + R = conf->sqrt; + else { + if (v3->v_type != V_NUM || qisfrac(v3->v_num)) { + *vres = error_value(E_SQRT3); + return; + } + R = qtoi(v3->v_num); + } + switch (v1->v_type) { + case V_NUM: + if (!qisneg(v1->v_num)) { + vres->v_num = qsqrt(v1->v_num, q, R); + return; + } + tmp = qneg(v1->v_num); + c = comalloc(); + c->imag = qsqrt(tmp, q, R); + qfree(tmp); + vres->v_com = c; + vres->v_type = V_COM; + break; + case V_COM: + vres->v_com = csqrt(v1->v_com, q, R); + break; + default: + *vres = error_value(E_SQRT); + return; + } + 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. + * + * given: + * v1 value to take root of + * v2 value specifying root to take + * v3 value specifying error + * vres result + */ +void +rootvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) +{ + NUMBER *q1, *q2; + COMPLEX ctmp; + COMPLEX *c; + + vres->v_type = v1->v_type; + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v2->v_type != V_NUM) { + *vres = error_value(E_ROOT2); + return; + } + q1 = v2->v_num; + if (qisneg(q1) || qiszero(q1) || qisfrac(q1)) { + *vres = error_value(E_ROOT2); + return; + } + if (v3->v_type != V_NUM || qiszero(v3->v_num)) { + *vres = error_value(E_ROOT3); + return; + } + q2 = v3->v_num; + switch (v1->v_type) { + case V_NUM: + if (!qisneg(v1->v_num) || zisodd(q1->num)) { + vres->v_num = qroot(v1->v_num, q1, q2); + return; + } + ctmp.real = v1->v_num; + ctmp.imag = &_qzero_; + ctmp.links = 1; + vres->v_com = croot(&ctmp, q1, q2); + vres->v_type = V_COM; + break; + case V_COM: + vres->v_com = croot(v1->v_com, q1, q2); + break; + case V_OBJ: + *vres = objcall(OBJ_ROOT, v1, v2, v3); + return; + default: + *vres = error_value(E_ROOT); + return; + } + c = vres->v_com; + if (cisreal(c)) { + vres->v_num = qlink(c->real); + vres->v_type = V_NUM; + comfree(c); + } +} + + +/* + * Take the absolute value of an arbitrary value within the specified error. + * Result is placed in the indicated location. + */ +void +absvalue(VALUE *v1, VALUE *v2, VALUE *vres) +{ + static NUMBER *q; + + if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) { + *vres = objcall(OBJ_ABS, v1, v2, NULL_VALUE); + return; + } + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + 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: + if (v2->v_type != V_NUM || qiszero(v2->v_num)) { + *vres = error_value(E_ABS2); + return; + } + q = qhypot(v1->v_com->real, v1->v_com->imag, v2->v_num); + break; + default: + *vres = error_value(E_ABS); + return; + } + 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(VALUE *vp, VALUE *vres) +{ + NUMBER *q1, *q2; + + vres->v_type = vp->v_type; + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + switch (vp->v_type) { + case V_NUM: + vres->v_num = qsquare(vp->v_num); + return; + case V_COM: + q1 = qsquare(vp->v_com->real); + q2 = qsquare(vp->v_com->imag); + vres->v_num = qqadd(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: + *vres = error_value(E_NORM); + return; + } +} + + +/* + * 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. + * + * given: + * v1 value to shift + * v2 shirt amount + * rightshift TRUE if shift right instead of left + * vres result + */ +void +shiftvalue(VALUE *v1, VALUE *v2, BOOL rightshift, VALUE *vres) +{ + COMPLEX *c; + long n = 0; + VALUE tmp; + + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if ((v2->v_type != V_NUM) || (qisfrac(v2->v_num))) { + *vres = error_value(E_SHIFT2); + return; + } + if (v1->v_type != V_OBJ) { + if (zge31b(v2->v_num->num)) { + *vres = error_value(E_SHIFT2); + return; + } + n = qtoi(v2->v_num); + } + if (rightshift) + n = -n; + vres->v_type = v1->v_type; + switch (v1->v_type) { + case V_NUM: + if (qisfrac(v1->v_num)) { + *vres = error_value(E_SHIFT); + return; + } + vres->v_num = qshift(v1->v_num, n); + return; + case V_COM: + if (qisfrac(v1->v_com->real) || + qisfrac(v1->v_com->imag)) { + *vres = error_value(E_SHIFT); + return; + } + c = cshift(v1->v_com, n); + if (!cisreal(c)) { + vres->v_com = c; + 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); + 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: + *vres = error_value(E_SHIFT); + return; + } +} + + +/* + * Scale a value by a power of two. + * Result is placed in the indicated location. + */ +void +scalevalue(VALUE *v1, VALUE *v2, VALUE *vres) +{ + long n = 0; + + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if ((v2->v_type != V_NUM) || qisfrac(v2->v_num)) { + *vres = error_value(E_SCALE2); + return; + } + if (v1->v_type != V_OBJ) { + if (zge31b(v2->v_num->num)) { + *vres = error_value(E_SCALE2); + return; + } + n = qtoi(v2->v_num); + } + vres->v_type = v1->v_type; + switch (v1->v_type) { + case V_NUM: + vres->v_num = qscale(v1->v_num, n); + return; + case V_COM: + vres->v_com = cscale(v1->v_com, n); + return; + case V_MAT: + vres->v_mat = matscale(v1->v_mat, n); + return; + case V_OBJ: + *vres = objcall(OBJ_SCALE, v1, v2, NULL_VALUE); + return; + default: + *vres = error_value(E_SCALE); + return; + } +} + + +/* + * Raise a value to an integral power. + * Result is placed in the indicated location. + */ +void +powivalue(VALUE *v1, VALUE *v2, VALUE *vres) +{ + NUMBER *q; + COMPLEX *c; + + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v2->v_type < 0) { + copyvalue(v2, vres); + return; + } + if (v2->v_type != V_NUM || qisfrac(v2->v_num)) { + *vres = error_value(E_POWI2); + return; + } + q = v2->v_num; + vres->v_type = v1->v_type; + switch (v1->v_type) { + case V_NUM: + vres->v_num = qpowi(v1->v_num, q); + return; + case V_COM: + vres->v_com = cpowi(v1->v_com, q); + 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); + return; + case V_OBJ: + *vres = objcall(OBJ_POW, v1, v2, NULL_VALUE); + return; + default: + *vres = error_value(E_POWI); + return; + } +} + + +/* + * Raise one value to another value's power, within the specified error. + * Result is placed in the indicated location. + */ +void +powervalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) +{ + NUMBER *epsilon; + COMPLEX *c, ctmp; + + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v1->v_type != V_NUM && v1->v_type != V_COM) { + *vres = error_value(E_POWER); + return; + } + if (v2->v_type != V_NUM && v2->v_type != V_COM) { + *vres = error_value(E_POWER2); + return; + } + + if (v3->v_type != V_NUM || qiszero(v3->v_num)) { + *vres = error_value(E_POWER3); + return; + } + epsilon = v3->v_num; + vres->v_type = v1->v_type; + 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); + 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: + *vres = error_value(E_POWER); + return; + } + /* + * 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(VALUE *v1, VALUE *v2, VALUE *vres) +{ + COMPLEX *c; + COMPLEX ctmp; + VALUE tmpval; + + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v2->v_type < 0) { + copyvalue(v2, vres); + return; + } + if (!testvalue(v2)) { + if (testvalue(v1)) + *vres = error_value(E_1OVER0); + else + *vres = error_value(E_0OVER0); + return; + } + vres->v_type = v1->v_type; + switch (TWOVAL(v1->v_type, v2->v_type)) { + case TWOVAL(V_NUM, V_NUM): + vres->v_num = qdiv(v1->v_num, v2->v_num); + return; + case TWOVAL(V_COM, V_NUM): + vres->v_com = cdivq(v1->v_com, v2->v_num); + return; + case TWOVAL(V_NUM, V_COM): + if (qiszero(v1->v_num)) { + vres->v_num = qlink(&_qzero_); + 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); + 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); + freevalue(&tmpval); + return; + default: + if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ)) { + *vres = error_value(E_DIV); + return; + } + *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(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) +{ + COMPLEX *c; + NUMBER *q1, *q2; + long rnd; + + vres->v_type = v1->v_type; + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + if (v1->v_type == V_MAT) { + vres->v_mat = matquoval(v1->v_mat, v2, v3); + return; + } + if (v1->v_type == V_LIST) { + vres->v_list = listquo(v1->v_list, v2, v3); + return; + } + if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) { + *vres = objcall(OBJ_QUO, v1, v2, v3); + return; + } + if (v2->v_type < 0) { + copyvalue(v2, vres); + return; + } + if (v2->v_type != V_NUM) { + *vres = error_value(E_QUO2); + return; + } + rnd = 0; + switch (v3->v_type) { + case V_NUM: + if (qisfrac(v3->v_num)) { + *vres = error_value(E_QUO3); + return; + } + rnd = qtoi(v3->v_num); + break; + case V_NULL: + rnd = conf->quo; + break; + default: + *vres = error_value(E_QUO3); + return; + } + switch (v1->v_type) { + case V_NUM: + vres->v_num = qquo(v1->v_num, v2->v_num, rnd); + return; + case V_COM: + q1 = qquo(v1->v_com->real, v2->v_num, rnd); + q2 = qquo(v1->v_com->imag, v2->v_num, rnd); + if (qiszero(q2)) { + qfree(q2); + vres->v_type = V_NUM; + vres->v_num = q1; + return; + } + c = comalloc(); + c->real = q1; + c->imag = q2; + vres->v_com = c; + return; + default: + *vres = error_value(E_QUO); + return; + } +} + + +/* + * Divide one arbitrary value by another one keeping only the remainder. + * Result is placed in the indicated location. + */ +void +modvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres) +{ + COMPLEX *c; + NUMBER *q1, *q2; + long rnd; + + if (v1->v_type < 0) { + copyvalue(v1, vres); + return; + } + vres->v_type = v1->v_type; + if (v1->v_type == V_MAT) { + vres->v_mat = matmodval(v1->v_mat, v2, v3); + return; + } + if (v1->v_type == V_LIST) { + vres->v_list = listmod(v1->v_list, v2, v3); + return; + } + if (v1->v_type == V_OBJ || v2->v_type == V_OBJ) { + *vres = objcall(OBJ_MOD, v1, v2, v3); + return; + } + if (v2->v_type < 0) { + copyvalue(v2, vres); + return; + } + if (v2->v_type != V_NUM) { + *vres = error_value(E_MOD2); + return; + } + rnd = 0; + switch (v3->v_type) { + case V_NUM: + if (qisfrac(v3->v_num)) { + *vres = error_value(E_MOD3); + return; + } + rnd = qtoi(v3->v_num); + break; + case V_NULL: + rnd = conf->mod; + break; + default: + *vres = error_value(E_MOD3); + return; + } + switch (v1->v_type) { + case V_NUM: + vres->v_num = qmod(v1->v_num, v2->v_num, rnd); + return; + case V_COM: + q1 = qmod(v1->v_com->real, v2->v_num, rnd); + q2 = qmod(v1->v_com->imag, v2->v_num, rnd); + if (qiszero(q2)) { + qfree(q2); + vres->v_type = V_NUM; + vres->v_num = q1; + return; + } + c = comalloc(); + c->real = q1; + c->imag = q2; + vres->v_com = c; + return; + default: + *vres = error_value(E_MOD); + 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(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: + break; /* hack to get gcc on SunOS to be quiet */ + case V_OBJ: + val = objcall(OBJ_TEST, vp, NULL_VALUE, NULL_VALUE); + return (val.v_int != 0); + default: + math_error("Testing improper type"); + /*NOTREACHED*/ + } + /* hack to get gcc on SunOS to be quiet */ + return FALSE; +} + + +/* + * Compare two values for equality. + * Returns TRUE if the two values differ. + */ +BOOL +comparevalue(VALUE *v1, VALUE *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; + if (v1->v_type < 0) + return FALSE; + 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; + case V_RAND: + r = randcmp(v1->v_rand, v2->v_rand); + break; + case V_RANDOM: + r = randomcmp(v1->v_random, v2->v_random); + break; + case V_CONFIG: + r = config_cmp(v1->v_config, v2->v_config); + break; +#if 0 /* XXX - write */ + case V_HASH: + r = hash_cmp(v1->v_hash, v2->v_hash); + break; +#endif + default: + math_error("Illegal values for comparevalue"); + /*NOTREACHED*/ + } + return (r != 0); +} + + +BOOL +precvalue(VALUE *v1, VALUE *v2) +{ + VALUE val; + long index; + int r = 0; + FUNC *fp; + + index = adduserfunc("precedes"); + fp = findfunc(index); + if (fp) { + ++stack; + stack->v_type = V_ADDR; + stack->v_addr = v1; + ++stack; + stack->v_type = V_ADDR; + stack->v_addr = v2; + calculate(fp, 2); + val = *stack--; + if (val.v_type != V_NUM) { + math_error("Non-numeric value for precvalue()"); + /*NOTREACHED*/ + } + return (qtoi(val.v_num) ? TRUE : FALSE); + } + relvalue(v1, v2, &val); + if ((val.v_type == V_NUM && qisneg(val.v_num)) || + (val.v_type == V_COM && qisneg(val.v_com->imag))) + r = 1; + if (val.v_type == V_NULL) + r = (v1->v_type < v2->v_type); + freevalue(&val); + return r; +} + + +/* + * Compare two values for their relative values. + * Result is placed in the indicated location. + */ +void +relvalue(VALUE *v1, VALUE *v2, VALUE *vres) +{ + int r = 0; + COMPLEX ctmp, *c; + + if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) { + *vres = objcall(OBJ_REL, v1, v2, NULL_VALUE); + return; + } + switch (TWOVAL(v1->v_type, v2->v_type)) { + case TWOVAL(V_NUM, V_NUM): + r = qrel(v1->v_num, v2->v_num); + vres->v_type = V_NUM; + vres->v_num = itoq((long) r); + return; + case TWOVAL(V_STR, V_STR): + r = strcmp(v1->v_str, v2->v_str); + vres->v_type = V_NUM; + if (r < 0) { + vres->v_num = itoq((long) -1); + } else if (r > 0) { + vres->v_num = itoq((long) 1); + } else { + vres->v_num = itoq((long) 0); + } + return; + case TWOVAL(V_COM, V_COM): + c = crel(v1->v_com, v2->v_com); + break; + case TWOVAL(V_COM, V_NUM): + ctmp.real = v2->v_num; + ctmp.imag = &_qzero_; + ctmp.links = 1; + c = crel(v1->v_com, &ctmp); + break; + case TWOVAL(V_NUM, V_COM): + ctmp.real = v1->v_num; + ctmp.imag = &_qzero_; + ctmp.links = 1; + c = crel(&ctmp, v2->v_com); + break; + default: + vres->v_type = V_NULL; + return; + } + if (cisreal(c)) { + vres->v_num = qlink(c->real); + vres->v_type = V_NUM; + comfree(c); + return; + } + vres->v_com = c; + vres->v_type = V_COM; +} + + +/* + * Find a value representing sign or signs in a value + * Result is placed in the indicated location. + */ +void +sgnvalue(VALUE *vp, VALUE *vres) +{ + COMPLEX *c; + + vres->v_type = vp->v_type; + switch (vp->v_type) { + case V_NUM: + vres->v_num = qsign(vp->v_num); + return; + case V_COM: + c = comalloc(); + c->real = qsign(vp->v_com->real); + c->imag = qsign(vp->v_com->imag); + vres->v_com = c; + vres->v_type = V_COM; + return; + case V_OBJ: + *vres = objcall(OBJ_SGN, vp, NULL_VALUE, NULL_VALUE); + return; + default: + if (vp->v_type < 0) { + copyvalue(vp, vres); + return; + } + *vres = error_value(E_SGN); + return; + } +} + + +/* + * 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(VALUE *vp, int flags) +{ + int type; + + type = vp->v_type; + if (type < 0) { + if (-type > E__BASE) + printf("Error %d", -type); + else + printf("System error %d", -type); + return; + } + switch (type) { + case V_NUM: + qprintnum(vp->v_num, MODE_DEFAULT); + if (conf->traceflags & TRACE_LINKS) + printf("#%ld", vp->v_num->links); + break; + case V_COM: + comprint(vp->v_com); + if (conf->traceflags & TRACE_LINKS) + printf("##%ld", vp->v_com->links); + 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 : conf->maxprint)); + break; + case V_ASSOC: + assocprint(vp->v_assoc, + ((flags & PRINT_SHORT) ? 0L : conf->maxprint)); + break; + case V_MAT: + matprint(vp->v_mat, + ((flags & PRINT_SHORT) ? 0L : conf->maxprint)); + break; + case V_FILE: + printid(vp->v_file, flags); + break; + case V_RAND: + randprint(vp->v_rand, flags); + break; + case V_RANDOM: + randomprint(vp->v_random, flags); + break; + case V_CONFIG: + config_print(vp->v_config); + break; +#if 0 /* XXX - write */ + case V_HASH: + hash_print(vp->v_hash); + break; +#endif + default: + math_error("Printing unknown value"); + /*NOTREACHED*/ + } +} + + +/* + * config_print - print a configuration value + * + * given: + * cfg what to print + */ +void +config_print(CONFIG *cfg) +{ + NAMETYPE *cp; + VALUE tmp; + int tab_over; /* TRUE => ok move over one tab stop */ + int i; + + /* + * firewall + */ + if (cfg == NULL || cfg->epsilon == NULL || cfg->prompt1 == NULL || + cfg->prompt2 == NULL) { + math_error("CONFIG value is invaid"); + /*NOTREACHED*/ + } + + /* + * print each element + */ + tab_over = FALSE; + for (cp = configs; cp->name; cp++) { + + /* skip if special all value */ + if (cp->type == CONFIG_ALL) + continue; + + /* print tab if allowed */ + if (tab_over) { + printf("\t"); + } else if (conf->tab_ok) { + tab_over = TRUE; /* tab next time */ + } + + /* print name and spaces */ + printf("%s", cp->name); + i = 16 - (int)strlen(cp->name); + while (i-- > 0) + printf(" "); + + /* print value */ + config_value(cfg, cp->type, &tmp); + printvalue(&tmp, PRINT_SHORT | PRINT_UNAMBIG); + freevalue(&tmp); + if ((cp+1)->name) + printf("\n"); + } +} + +/* END CODE */ diff --git a/value.h b/value.h new file mode 100644 index 0000000..978e0e7 --- /dev/null +++ b/value.h @@ -0,0 +1,455 @@ +/* + * Copyright (c) 1995 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" +#include "config.h" +#include "shs.h" +#include "calcerr.h" +#include "hash.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; +typedef struct rand RAND; +typedef struct random RANDOM; +typedef struct block BLOCK; + + +/* + * calc values + * + * See below for information on what needs to be added for a new type. + */ +struct value { + short v_type; /* type of value */ + short v_subtype; /* other data related to some types */ + union { /* types of values (see V_XYZ below) */ + long vv_int; /* 1: small integer value */ + NUMBER *vv_num; /* 2: arbitrary sized numeric value */ + COMPLEX *vv_com; /* 3: complex number */ + VALUE *vv_addr; /* 4: address of variable value */ + char *vv_str; /* 5: string value */ + MATRIX *vv_mat; /* 6: address of matrix */ + LIST *vv_list; /* 7: address of list */ + ASSOC *vv_assoc; /* 8: address of association */ + OBJECT *vv_obj; /* 9: address of object */ + FILEID vv_file; /* 10: id of opened file */ + RAND *vv_rand; /* 11: additive 55 random state */ + RANDOM *vv_random; /* 12: Blum random state */ + CONFIG *vv_config; /* 13: configuration state */ + HASH *vv_hash; /* 14: hash state */ + BLOCK *vv_block; /* 15: memory block */ + } 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 +#define v_rand v_union.vv_rand +#define v_random v_union.vv_random +#define v_config v_union.vv_config +#define v_hash v_union.vv_hash +#define v_block v_union.vv_block + + +/* + * Value types. + * + * NOTE: The following files should be checked/adjusted for a new type: + * + * quickhash.c + * shs.c + * value.c + * + * There may be others, but at is at least a start. + */ +#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_RAND 11 /* address of additive 55 random state */ +#define V_RANDOM 12 /* address of Blum random state */ +#define V_CONFIG 13 /* configuration state */ +#define V_HASH 14 /* hash state */ +#define V_BLOCK 15 /* memory block */ +#define V_MAX 15 /* 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) << 4 | (b)) /* for switch of two values */ + +#define NULL_VALUE ((VALUE *) 0) + + +/* + * value functions + */ +extern void freevalue(VALUE *vp); +extern void copyvalue(VALUE *vp, VALUE *vres); +extern void negvalue(VALUE *vp, VALUE *vres); +extern void addvalue(VALUE *v1, VALUE *v2, VALUE *vres); +extern void addnumeric(VALUE *v1, VALUE *v2, VALUE *vres); +extern void subvalue(VALUE *v1, VALUE *v2, VALUE *vres); +extern void mulvalue(VALUE *v1, VALUE *v2, VALUE *vres); +extern void squarevalue(VALUE *vp, VALUE *vres); +extern void invertvalue(VALUE *vp, VALUE *vres); +extern void roundvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres); +extern void broundvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres); +extern void apprvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres); +extern void intvalue(VALUE *vp, VALUE *vres); +extern void fracvalue(VALUE *vp, VALUE *vres); +extern void incvalue(VALUE *vp, VALUE *vres); +extern void decvalue(VALUE *vp, VALUE *vres); +extern void conjvalue(VALUE *vp, VALUE *vres); +extern void sqrtvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres); +extern void rootvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres); +extern void absvalue(VALUE *v1, VALUE *v2, VALUE *vres); +extern void normvalue(VALUE *vp, VALUE *vres); +extern void shiftvalue(VALUE *v1, VALUE *v2, BOOL rightshift, VALUE *vres); +extern void scalevalue(VALUE *v1, VALUE *v2, VALUE *vres); +extern void powivalue(VALUE *v1, VALUE *v2, VALUE *vres); +extern void powervalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres); +extern void divvalue(VALUE *v1, VALUE *v2, VALUE *vres); +extern void quovalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres); +extern void modvalue(VALUE *v1, VALUE *v2, VALUE *v3, VALUE *vres); +extern BOOL testvalue(VALUE *vp); +extern BOOL comparevalue(VALUE *v1, VALUE *v2); +extern void relvalue(VALUE *v1, VALUE *v2, VALUE *vres); +extern void sgnvalue(VALUE *vp, VALUE *vres); +extern QCKHASH hashvalue(VALUE *vp, QCKHASH val); +extern void printvalue(VALUE *vp, int flags); +extern BOOL precvalue(VALUE *v1, VALUE *v2); +extern VALUE error_value(int e); +extern long countlistitems(LIST *lp); +extern void addlistitems(LIST *lp, VALUE *vres); +extern void addlistinv(LIST *lp, VALUE *vres); + + + +/* + * 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(MATRIX *m1, MATRIX *m2); +extern MATRIX *matsub(MATRIX *m1, MATRIX *m2); +extern MATRIX *matmul(MATRIX *m1, MATRIX *m2); +extern MATRIX *matneg(MATRIX *m); +extern MATRIX *matalloc(long size); +extern MATRIX *matcopy(MATRIX *m); +extern MATRIX *matinit(MATRIX *m, VALUE *v1, VALUE *v2); +extern MATRIX *matsquare(MATRIX *m); +extern MATRIX *matinv(MATRIX *m); +extern MATRIX *matscale(MATRIX *m, long n); +extern MATRIX *matshift(MATRIX *m, long n); +extern MATRIX *matmulval(MATRIX *m, VALUE *vp); +extern MATRIX *matpowi(MATRIX *m, NUMBER *q); +extern MATRIX *matconj(MATRIX *m); +extern MATRIX *matquoval(MATRIX *m, VALUE *vp, VALUE *v3); +extern MATRIX *matmodval(MATRIX *m, VALUE *vp, VALUE *v3); +extern MATRIX *matint(MATRIX *m); +extern MATRIX *matfrac(MATRIX *m); +extern MATRIX *matappr(MATRIX *m, VALUE *v2, VALUE *v3); +extern MATRIX *mattrans(MATRIX *m); +extern MATRIX *matcross(MATRIX *m1, MATRIX *m2); +extern BOOL mattest(MATRIX *m); +extern void matsum(MATRIX *m, VALUE *vres); +extern BOOL matcmp(MATRIX *m1, MATRIX *m2); +extern long matsearch(MATRIX *m, VALUE *vp, long index); +extern long matrsearch(MATRIX *m, VALUE *vp, long index); +extern VALUE matdet(MATRIX *m); +extern VALUE matdot(MATRIX *m1, MATRIX *m2); +extern void matfill(MATRIX *m, VALUE *v1, VALUE *v2); +extern void matfree(MATRIX *m); +extern void matprint(MATRIX *m, long max_print); +extern VALUE *matindex(MATRIX *mp, BOOL create, long dim, VALUE *indices); +extern void matreverse(MATRIX *m); +extern void matsort(MATRIX *m); +extern BOOL matisident(MATRIX *m); +extern MATRIX *matround(MATRIX *m, VALUE *v2, VALUE *v3); +extern MATRIX *matbround(MATRIX *m, VALUE *v2, VALUE *v3); + + + +/* + * 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(LIST *lp, VALUE *vp); +extern void insertlistlast(LIST *lp, VALUE *vp); +extern void insertlistmiddle(LIST *lp, long index, VALUE *vp); +extern void removelistfirst(LIST *lp, VALUE *vp); +extern void removelistlast(LIST *lp, VALUE *vp); +extern void removelistmiddle(LIST *lp, long index, VALUE *vp); +extern void listfree(LIST *lp); +extern void listprint(LIST *lp, long max_print); +extern long listsearch(LIST *lp, VALUE *vp, long index); +extern long listrsearch(LIST *lp, VALUE *vp, long index); +extern BOOL listcmp(LIST *lp1, LIST *lp2); +extern VALUE *listfindex(LIST *lp, long index); +extern LIST *listalloc(void); +extern LIST *listcopy(LIST *lp); +extern void listreverse(LIST *lp); +extern void listsort(LIST *lp); +extern LIST *listappr(LIST *lp, VALUE *v2, VALUE *v3); +extern LIST *listround(LIST *m, VALUE *v2, VALUE *v3); +extern LIST *listbround(LIST *m, VALUE *v2, VALUE *v3); +extern LIST *listquo(LIST *lp, VALUE *v2, VALUE *v3); +extern LIST *listmod(LIST *lp, VALUE *v2, VALUE *v3); +extern BOOL evp(LISTELEM *cp, LISTELEM *x, VALUE *vres); +extern BOOL evalpoly(LIST *clist, LISTELEM *x, VALUE *vres); +extern void insertitems(LIST *lp1, LIST *lp2); + + +/* + * 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 */ + QCKHASH 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(long initsize); +extern ASSOC *assoccopy(ASSOC *ap); +extern void assocfree(ASSOC *ap); +extern void assocprint(ASSOC *ap, long max_print); +extern long assocsearch(ASSOC *ap, VALUE *vp, long index); +extern long assocrsearch(ASSOC *ap, VALUE *vp, long index); +extern BOOL assoccmp(ASSOC *ap1, ASSOC *ap2); +extern VALUE *assocfindex(ASSOC *ap, long index); +extern VALUE *associndex(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 */ + long 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(OBJECT *op); +extern OBJECT *objalloc(long index); +extern VALUE objcall(int action, VALUE *v1, VALUE *v2, VALUE *v3); +extern void objfree(OBJECT *op); +extern void objuncache(void); +extern int addelement(char *name); +extern void defineobject(char *name, int indices[], int count); +extern int checkobject(char *name); +extern void showobjfuncs(void); +extern void showobjtypes(void); +extern int findelement(char *name); +extern int objoffset(OBJECT *op, long index); + + +/* + * Configuration parameter name and type. + */ +typedef struct { + char *name; /* name of configuration string */ + int type; /* type for configuration */ +} NAMETYPE; +extern NAMETYPE configs[]; +extern void config_value(CONFIG *cfg, int type, VALUE *ret); +extern void setconfig(int type, VALUE *vp); +extern void config_print(CONFIG *cfg); /* the CONFIG to print */ + + +/* + * hashfunc - interface for hashing hash objects + */ +struct hashfunc { + int type; /* hash type (see XYZ_HASH_TYPE below) */ + HASH *(*init)(HASH*); /* initialize hash state */ + HASH *(*longval)(HASH*, long); /* hash a long value */ + HASH *(*str)(HASH*, char*); /* hash a string */ +#if defined(FUNCT_DECL_BUG) + HASH *(*value)(HASH*, void*); /* hash a VALUE */ + HASH *(*complex)(HASH*, void*); /* hash a COMPLEX* */ + HASH *(*number)(HASH*, void*); /* hash a NUMBER* */ + HASH *(*zvalue)(HASH*, void); /* hash a ZVALUE */ +#else + HASH *(*value)(HASH*, VALUE*); /* hash a VALUE */ + HASH *(*complex)(HASH*, COMPLEX*); /* hash a COMPLEX* */ + HASH *(*number)(HASH*, NUMBER*); /* hash a NUMBER* */ + HASH *(*zvalue)(HASH*, ZVALUE); /* hash a ZVALUE */ +#endif + ZVALUE (*final)(HASH *); /* complete hash state and return a ZVALUE */ +}; +typedef struct hashfunc HASHFUNC; + +/* external HASHFUNC functions */ +extern void shs_hashfunc(HASHFUNC *); + + +/* + * block - dynamic of fixed memory block + * + * There are two types of memory blocks: fixed memory blocks are fixed + * in size and dynamic memory blocks can grow in size. The max length + * (x.max) may be >= current (x.len), even in the fixed case. A fixed block + * can be shrunk instead of realloced. The (x.max) refers to the number + * of bytes malloced and 0 <= (x.len) <= (x.max). If (x.max) == 0, then + * (x.data) does not point to malloced storage. + */ +struct block { + int type; /* block type */ + int len; /* current block length in USB8's */ + int max; /* malloced block length in USB8's */ + USB8 *data; /* start of data block if max > 0 */ +}; + +#define V_FIXEDBLOCK 1 /* memory block is fixed in size */ +#define V_DYNAMBLOCK 2 /* memory block size is dynamic */ + +#define is_fixedblock(x) (((x)->type) == V_FIXEDBLOCK) +#define is_dynamblock(x) (((x)->type) == V_DYNAMBLOCK) + +#endif diff --git a/version.c b/version.c new file mode 100644 index 0000000..7067150 --- /dev/null +++ b/version.c @@ -0,0 +1,25 @@ +/* + * Copyright (c) 1996 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 10 /* minor version */ +#define PATCH_LEVEL 2 /* patch level */ +#define SUB_PATCH_LEVEL "t30" /* test number or empty string */ + + +void +version(FILE *stream) +{ + fprintf(stream, + "C-style arbitrary precision calculator (version %d.%d.%d%s)\n", + MAJOR_VER, MINOR_VER, PATCH_LEVEL, SUB_PATCH_LEVEL); +} + +/* END CODE */ diff --git a/zfunc.c b/zfunc.c new file mode 100644 index 0000000..2fb071a --- /dev/null +++ b/zfunc.c @@ -0,0 +1,1820 @@ +/* + * Copyright (c) 1995 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" + +ZVALUE _tenpowers_[TEN_MAX+1]; /* table of 10^2^n */ + + +/* + * Compute the factorial of a number. + */ +void +zfact(ZVALUE z, ZVALUE *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"); + /*NOTREACHED*/ + } + if (zge24b(z)) { + math_error("Very large factorial"); + /*NOTREACHED*/ + } + n = ztolong(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 permutation function M! / (M - N)!. + */ +void +zperm(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + SFULL count; + ZVALUE cur, tmp, ans; + + if (zisneg(z1) || zisneg(z2)) { + math_error("Negative argument for permutation"); + /*NOTREACHED*/ + } + if (zrel(z1, z2) < 0) { + math_error("Second arg larger than first in permutation"); + /*NOTREACHED*/ + } + if (zge24b(z2)) { + math_error("Very large permutation"); + /*NOTREACHED*/ + } + count = ztolong(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(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + ZVALUE ans; + ZVALUE mul, div, temp; + FULL count, i; + HALF dh[2]; + + if (zisneg(z1) || zisneg(z2)) { + math_error("Negative argument for combinatorial"); + /*NOTREACHED*/ + } + zsub(z1, z2, &temp); + if (zisneg(temp)) { + zfree(temp); + math_error("Second arg larger than first for combinatorial"); + /*NOTREACHED*/ + } + if (zge24b(z2) && zge24b(temp)) { + zfree(temp); + math_error("Very large combinatorial"); + /*NOTREACHED*/ + } + count = ztofull(z2); + i = ztofull(temp); + if (zge24b(z2) || (!zge24b(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] = (HALF)(i & BASE1); + dh[1] = (HALF)(i >> BASEB); + div.len = 1 + (dh[1] != 0); + zmul(ans, mul, &temp); + zfree(ans); + zquo(temp, div, &ans, 0); + zfree(temp); + zsub(mul, _one_, &temp); + if (mul.v != z1.v) + zfree(mul); + mul = temp; + } + if (mul.v != z1.v) + zfree(mul); + *res = ans; +} + + +/* + * 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(ZVALUE z1, ZVALUE 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, 0); + 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(ZVALUE z, ZVALUE *res) +{ + long n; + int sign; + ZVALUE fnm1, fn, fnp1; /* consecutive fibonacci values */ + ZVALUE t1, t2, t3; + FULL i; + + if (zge31b(z)) { + math_error("Very large Fibonacci number"); + /*NOTREACHED*/ + } + n = ztolong(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 >>= (FULL)1; + i >>= (FULL)1; + 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 >>= (FULL)1; + } + 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(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + int sign; /* final sign of number */ + unsigned long power; /* power to raise to */ + FULL 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 (zisabsleone(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 (zge31b(z2)) { + math_error("Raising to very large power"); + /*NOTREACHED*/ + } + power = ztoulong(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 >>= 1; + bit >>= 1; + zsquare(z1, &ans); + if (bit & power) { + zmul(ans, z1, &temp); + zfree(ans); + ans = temp; + } + bit >>= 1; + while (bit) { + zsquare(ans, &temp); + zfree(ans); + ans = temp; + if (bit & power) { + zmul(ans, z1, &temp); + zfree(ans); + ans = temp; + } + bit >>= 1; + } + /* + * 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(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) { + if (i <= TEN_MAX) { + zsquare(_tenpowers_[i-1], &_tenpowers_[i]); + } else { + math_error("cannot compute 10^2^(TEN_MAX+1)"); + /*NOTREACHED*/ + } + } + 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(ZVALUE u, ZVALUE v, ZVALUE *res) +{ + FULL q1, q2, ui3, vi3, uh, vh, A, B, C, D, T; + ZVALUE u2, u3, v2, v3, qz, tmp1, tmp2, tmp3; + + v.sign = 0; + if (zisneg(u) || (zrel(u, v) >= 0)) + zmod(u, v, &v3, 0); + 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, 0); + 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 = ztofull(u3); + vi3 = ztofull(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(ZVALUE z1, ZVALUE z2, ZVALUE *res1, ZVALUE *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, 0); + 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"); + /*NOTREACHED*/ + } + 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, 0); + zfree(t2); + u1.sign = (BOOL)sign; + t1.sign = 0; + *res1 = t1; + *res2 = u1; +} +#endif + + + +/* + * Compute the greatest common divisor of a pair of integers. + */ +void +zgcd(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + int h, i, j, k; + LEN len, l, m, n, o, p, q; + HALF u, v, w, x; + HALF *a, *a0, *A, *b, *b0, *B, *c, *d; + FULL f, g; + ZVALUE gcd; + BOOL needw; + + if (zisunit(z1) || zisunit(z2)) { + *res = _one_; + return; + } + z1.sign = 0; + z2.sign = 0; + if (ziszero(z1) || !zcmp(z1, z2)) { + zcopy(z2, res); + return; + } + if (ziszero(z2)) { + zcopy(z1, res); + return; + } + + o = 0; + while (!(z1.v[o] | z2.v[o])) o++; /* Count common zero digits */ + + c = z1.v + o; + d = z2.v + o; + + m = z1.len - o; + n = z2.len - o; + u = *c | *d; /* Count common zero bits */ + v = 1; + p = 0; + while (!(u & v)) { + v <<= 1; + p++; + } + + while (!*c) { /* Removing zero digits */ + c++; + m--; + } + + while (!*d) { + d++; + n--; + } + + + u = *d; /* Count zero bits for *d */ + v = 1; + q = 0; + while (!(u & v)) { + v <<= 1; + q++; + } + + a0 = A = alloc(m); + b0 = B = alloc(n); + + memcpy(A, c, m * sizeof(HALF)); /* Copy c[] to A[] */ + + /* Copy d[] to B[], shifting if necessary */ + if (q) { + i = n; + b = B + n; + d += n; + f = 0; + while (i--) { + f = f << BASEB | *--d; + *--b = (HALF) (f >> q); + } + if (B[n-1] == 0) n--; + } + else memcpy(B, d, n * sizeof(HALF)); + + if (n == 1) { /* One digit case; use Euclid's algorithm */ + n = m; + b0 = A; + m = 1; + a0 = B; + if (m == 1) { /* a has one digit */ + v = *a0; + if (v > 1) { /* Euclid's algorithm */ + b = b0 + n; + i = n; + u = 0; + while (i--) { + f = (FULL) u << BASEB | *--b; + u = (HALF) (f % v); + } + while (u) { w = v % u; v = u; u = w; } + } + *b0 = v; + n = 1; + } + len = n + o; + gcd.v = alloc(len + 1); + /* Common zero digits */ + if (o) memset(gcd.v, 0, o * sizeof(HALF)); + /* Left shift for common zero bits */ + if (p) { + i = n; + f = 0; + b = b0; + a = gcd.v + o; + while (i--) { + f = f >> BASEB | (FULL) *b++ << p; + *a++ = (HALF) f; + } + if (f >>= BASEB) {len++; *a = (HALF) f;} + } + else memcpy(gcd.v + o, b0, n * sizeof(HALF)); + gcd.len = len; + gcd.sign = 0; + freeh(A); + freeh(B); + *res = gcd; + return; + } + + u = B[n-1]; /* Bit count for b */ + k = (n - 1) * BASEB; + while (u >>= 1) k++; + + needw = TRUE; + + w = 0; + while (m) { /* START OF MAIN LOOP */ + q = 0; + u = *a0; + v = 1; + while (!(u & v)) { /* count zero bits for *a0 */ + q++; + v <<= 1; + } + + if (q) { /* right-justify a */ + a = a0 + m; + i = m; + f = 0; + while (i--) { + f = f << BASEB | *--a; + *a = (HALF) (f >> q); + } + if (!a0[m-1]) m--; /* top digit vanishes */ + } + + if (m == 1) break; + + u = a0[m-1]; + j = (m - 1) * BASEB; + while (u >>= 1) j++; /* counting bits for a */ + h = j - k; + if (h < 0) { /* swapping to get h > 0 */ + l = m; + m = n; + n = l; + a = a0; + a0 = b0; + b0 = a; + k = j; + h = -h; + needw = TRUE; + } + if (h > 1) { + if (needw) { /* find w = minv(*b0, h0) */ + u = 1; + v = *b0; + w = 0; + x = 1; + i = h; + while (i-- && x) { + if (u & x) { u -= v * x; w |= x;} + x <<= 1; + } + needw = FALSE; + } + g = *a0 * w; + if (h < BASEB) g &= (1 << h) - 1; + else g &= BASE1; + } + else g = 1; + a = a0; + b = b0; + i = n; + if (g > 1) { /* a - g * b case */ + f = 0; + while (i--) { + f = (FULL) *a - g * *b++ - f; + *a++ = (HALF) f; + f >>= BASEB; + f = -f & BASE1; + } + if (f) { + i = m - n; + while (i-- && f) { + f = *a - f; + *a++ = (HALF) f; + f >>= BASEB; + f = -f & BASE1; + } + } + while (m && !*a0) { /* Removing trailing zeros */ + m--; + a0++; + } + if (f) { /* a - g * b < 0 */ + while (m > 1 && a0[m-1] == BASE1) m--; + *a0 = - *a0; + a = a0; + i = m; + while (--i) { + a++; + *a = ~*a; + } + } + } + else { /* abs(a - b) case */ + while (i && *a++ == *b++) i--; + q = n - i; + if (m == n) { /* a and b same length */ + if (i) { /* a not equal to b */ + while (m && a0[m-1] == b0[m-1]) m--; + if (a0[m-1] < b0[m-1]) { + /* Swapping since a < b */ + a = a0; + a0 = b0; + b0 = a; + k = j; + } + a = a0 + q; + b = b0 + q; + i = m - q; + f = 0; + while (i--) { + f = (FULL) *a - *b++ - f; + *a++ = (HALF) f; + f >>= BASEB; + f = -f & BASE1; + } + } + } + else { /* a has more digits than b */ + a = a0 + q; + b = b0 + q; + i = n - q; + f = 0; + while (i--) { + f = (FULL) *a - *b++ - f; + *a++ = (HALF) f; + f >>= BASEB; + f = -f & BASE1; + } + if (f) { while (!*a) *a++ = BASE1; + (*a)--; + } + } + a0 += q; + m -= q; + } + while (m && !a0[m-1]) m--; /* Removing leading zeros */ + } + if (m == 1) { /* a has one digit */ + v = *a0; + if (v > 1) { /* Euclid's algorithm */ + b = b0 + n; + i = n; + u = 0; + while (i--) { + f = (FULL) u << BASEB | *--b; + u = (HALF) (f % v); + } + while (u) { w = v % u; v = u; u = w; } + } + *b0 = v; + n = 1; + } + len = n + o; + gcd.v = alloc(len + 1); + if (o) memset(gcd.v, 0, o * sizeof(HALF)); /* Common zero digits */ + if (p) { /* Left shift for common zero bits */ + i = n; + f = 0; + b = b0; + a = gcd.v + o; + while (i--) { + f = (FULL) *b++ << p | f; + *a++ = (HALF) f; + f >>= BASEB; + } + if (f) {len++; *a = (HALF) f;} + } + else memcpy(gcd.v + o, b0, n * sizeof(HALF)); + gcd.len = len; + gcd.sign = 0; + freeh(A); + freeh(B); + *res = gcd; + return; +} + +/* + * 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(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + ZVALUE temp1, temp2; + + zgcd(z1, z2, &temp1); + zequo(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(ZVALUE z1, ZVALUE z2) +{ + 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, (FULL)3 * 5 * 7 * 11 * 13); + rem2 = zmodi(z2, (FULL)3 * 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, (FULL)17 * 19 * 23); + rem2 = zmodi(z2, (FULL)17 * 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(ZVALUE z1, ZVALUE 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 > 0 and the base is > 1 + */ + if (zislezero(z1) || zisleone(z2)) { + math_error("Bad arguments for log"); + /*NOTREACHED*/ + } + + /* + * 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(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"); + /*NOTREACHED*/ + } + /* + * 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(ZVALUE z1, ZVALUE z2) +{ + long count; /* number of factors removed */ + ZVALUE tmp; /* ignored return value */ + + if (ziszero(z1) || ziszero(z2) || zisunit(z2)) + return 0; + count = zfacrem(z1, z2, &tmp); + zfree(tmp); + return count; +} + + +/* + * Remove all occurences 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(ZVALUE z1, ZVALUE z2, ZVALUE *rem) +{ + register ZVALUE *zp; /* current square */ + long count; /* total count of divisions */ + long worth; /* worth of current square */ + long lowbit; /* for zlowbit(z2) */ + ZVALUE temp1, temp2, temp3; /* temporaries */ + ZVALUE squares[32]; /* table of squares of factor */ + + z1.sign = 0; + z2.sign = 0; + /* + * Reject trivial cases. + */ + if ((z1.len < z2.len) || (zisodd(z1) && ziseven(z2)) || + ziszero(z2) || zisone(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)) { + lowbit = zlowbit(z2); + count = zlowbit(z1) / lowbit; + rem->v = alloc(z1.len); + rem->len = z1.len; + rem->sign = 0; + zcopyval(z1, *rem); + zshiftr(*rem, count * lowbit); + ztrim(rem); + return count; + } + /* + * See if the factor goes in even once. + */ + zdiv(z1, z2, &temp1, &temp2, 0); + 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, 0); + 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, 0); + 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(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + ZVALUE tmp1, tmp2; + + /* + * Begin by taking the gcd for the first time. + * If the number is already relatively prime, then we are done. + */ + z1.sign = 0; + z2.sign = 0; + zgcd(z1, z2, &tmp1); + if (zisunit(tmp1) || ziszero(tmp1)) { + res->len = z1.len; + res->v = alloc(z1.len); + res->sign = 0; + zcopyval(z1, *res); + return; + } + zequo(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; +} + + +/* + * Return the number of digits (base 10) in a number, ignoring the sign. + */ +long +zdigits(ZVALUE z1) +{ + long count, val; + + z1.sign = 0; + if (!zge16b(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. + */ +long +zdigit(ZVALUE z1, long n) +{ + ZVALUE tmp1, tmp2; + long 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, 0); + res = zmodi(tmp2, 10L); + zfree(tmp1); + zfree(tmp2); + return res; +} + + +/* + * z is to be a nonnegative integer + * If z is the square of a integer stores at dest the square root of z; + * otherwise stores at z an integer differing from the square root + * by less than 1. Returns the sign of the true square root minus + * the calculated integer. Type of rounding is determined by + * rnd as follows: rnd = 0 gives round down, rnd = 1 + * rounds up, rnd = 8 rounds to even integer, rnd = 9 rounds to odd + * integer, rnd = 16 rounds to nearest integer. + */ +FLAG +zsqrt(ZVALUE z, ZVALUE *dest, long rnd) +{ + HALF *a, *A, *b, *a0, u; + int i, j, j1, j2, k, k1, m, m0, m1, n, n0, o; + FULL d, e, f, g, h, s, t, x, topbit; + int remsign; + BOOL up, onebit; + ZVALUE sqrt; + + if (z.sign) { + math_error("Square root of negative number"); + /*NOTREACHED*/ + } + if (ziszero(z)) { + *dest = _zero_; + return 0; + } + m0 = z.len; + o = m0 & 1; + m = m0 + o; /* m is smallest even number >= z.len */ + n0 = n = m / 2; + f = z.v[z.len - 1]; + k = 1; + while (f >>= 2) + k++; + if (!o) + k += BASEB/2; + j = BASEB - k; + m1 = m; + if (k == BASEB) { + m1 += 2; + n0++; + } + A = alloc(m1); + A[m1] = 0; + a0 = A + n0; + memcpy(A, z.v, m0 * sizeof(HALF)); + if (o) + A[m - 1] = 0; + if (n == 1) { + if (j) + f = (FULL) A[1] << j | A[0] >> k; + else + f = A[1]; + g = (FULL) A[0] << (j + BASEB); + d = e = topbit = (FULL)1 << (k - 1); + } + else { + if (j) + f = (FULL) A[m-1] << (j + BASEB) | (FULL) A[m-2] << j | + A[m-3] >> k; + else + f = (FULL) A[m-1] << BASEB | A[m-2]; + g = (FULL) A[m-3] << (j + BASEB) | (FULL) A[m-4] << j; + d = e = topbit = (FULL)1 << (BASEB + k - 1); + } + + s = (f & topbit); + f <<= 1; + if (g & TOPFULL) + f++; + g <<= 1; + if (s) { + f -= 4 * d; + e = 2 * d - 1; + } + else + f -= d; + while (d >>= 1) { + if (!(s | f | g)) + break; + while (d && (f & topbit) == s) { + d >>= 1; + f <<= 1; + if (g & TOPFULL) + f++; + g <<= 1; + } + if (d == 0) + break; + if (s) + f += e + 1; + else + f -= e; + t = f & topbit; + f <<= 1; + if (g & TOPFULL) + f++; + g <<= 1; + if (t == 0 && f < d) + t = topbit; + f -= d; + if (s) + e -= d - !t; + else + e += d - (t > 0); + s = t; + } + if (n0 == 1) { + A[1] = (HALF)e; + A[0] = (HALF)f; + m = 1; + goto done; + } + if (n0 == 2) { + A[3] = (HALF)(e >> BASEB); + A[2] = (HALF)e; + A[1] = (HALF)(f >> BASEB); + A[0] = (HALF)f; + m = 2; + goto done; + } + u = (HALF)(s ? BASE1 : 0); + if (k < BASEB) { + A[m1 - 1] = (HALF)(e >> (BASEB - 1)); + A[m1 - 2] = (HALF)(e << 1 | (s > 0)); + A[m1 - 3] = (HALF)(f >> BASEB); + A[m1 - 4] = (HALF)f; + m = m1 - 2; + k1 = k + 1; + } + else { + A[m1 - 1] = 1; + A[m1 - 2] = (HALF)(e >> (BASEB - 1)); + A[m1 - 3] = (HALF)(e << 1 | (s > 0)); + A[m1 - 4] = u; + A[m1 - 5] = (HALF)(f >> BASEB); + A[m1 - 6] = (HALF)f; + m = m1 - 3; + k1 = 1; + } + h = e >> k; + onebit = ((e & ((FULL)1 << (k - 1))) ? TRUE : FALSE); + j2 = BASEB - k1; + j1 = BASEB + j2; + while (m > n0) { + a = A + m - 1; + if (j2) + f = (FULL) *a << j1 | (FULL) a[-1] << j2 | a[-2] >> k1; + else + f = (FULL) *a << BASEB | a[-1]; + if (u) + f = ~f; + x = f / h; + if (x) { + if (onebit && x > 2 * (f % h) + 2) + x--; + b = a + 1; + i = m1 - m; + a -= i + 1; + if (u) { + f = *a + x * (BASE - x); + *a++ = (HALF)f; + u = (HALF)(f >> BASEB); + while (i--) { + f = *a + x * *b++ + u; + *a++ = (HALF)f; + u = (HALF)(f >> BASEB); + } + u += *a; + x = ~x + !u; + if (!(x & TOPHALF)) + a[1] -= 1; + } + else { + f = *a - x * x; + *a++ = (HALF)f; + u = -(HALF)(f >> BASEB); + while (i--) { + f = *a - x * *b++ - u; + *a++ = (HALF)f; + u = -(HALF)(f >> BASEB); + } + u = *a - u; + x = x + u; + if (x & TOPHALF) + a[1] |= 1; + } + *a = (HALF)((x << 1) | (u > 0)); + } + else + *a = u; + m--; + if (*--a == u) { + while (m > 1 && *--a == u) + m--; + } + } + i = n; + a = a0; + while (i--) { + *a >>= 1; + if (a[1] & 1) *a |= TOPHALF; + a++; + } + s = u; +done: if (s == 0) { + while (m > 0 && A[m - 1] == 0) + m--; + if (m == 0) { + remsign = 0; + sqrt.v = alloc(n); + sqrt.len = n; + sqrt.sign = 0; + memcpy(sqrt.v, a0, n * sizeof(HALF)); + freeh(A); + *dest = sqrt; + return remsign; + } + } + if (rnd & 16) { + if (s == 0) { + if (m != n) + up = (m > n); + else { + i = n; + b = a0 + n; + a = A + n; + while (i > 0 && *--a == *--b) + i--; + up = (i > 0 && *a > *b); + } + } + else { + while (m > 1 && A[m - 1] == BASE1) + m--; + if (m != n) + up = (m < n); + else { + i = n; + b = a0 + n; + a = A + n; + while (i > 0 && *--a + *--b == BASE1) + i--; + up = ((FULL) *a + *b >= BASE); + } + } + } + else + if (rnd & 8) + up = (((rnd ^ *a0) & 1) ? TRUE : FALSE); + else + up = ((rnd & 1) ? TRUE : FALSE); + if (up) { + remsign = -1; + i = n; + a = a0; + while (i-- && *a == BASE1) + *a++ = 0; + if (i >= 0) + (*a)++; + else { + n++; + *a = 1; + } + } + else + remsign = 1; + sqrt.v = alloc(n); + sqrt.len = n; + sqrt.sign = 0; + memcpy(sqrt.v, a0, n * sizeof(HALF)); + freeh(A); + *dest = sqrt; + return remsign; + +} + +/* + * 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(ZVALUE z1, ZVALUE z2, ZVALUE *dest) +{ + ZVALUE try, quo, old, temp, temp2; + ZVALUE k1; /* holds k - 1 */ + int sign; + long i; + LEN highbit, k; + SIUNION sival; + + sign = z1.sign; + if (sign && ziseven(z2)) { + math_error("Even root of negative number"); + /*NOTREACHED*/ + } + if (ziszero(z2) || zisneg(z2)) { + math_error("Non-positive root"); + /*NOTREACHED*/ + } + if (ziszero(z1)) { /* root of zero */ + *dest = _zero_; + return; + } + if (zisunit(z2)) { /* first root */ + zcopy(z1, dest); + return; + } + if (zge31b(z2)) { /* humongous root */ + *dest = _one_; + dest->sign = (BOOL)((HALF)sign); + return; + } + k = (LEN)ztolong(z2); + highbit = zhighbit(z1); + if (highbit < k) { /* too high a root */ + *dest = _one_; + dest->sign = (BOOL)((HALF)sign); + return; + } + sival.ivalue = k - 1; + k1.v = &sival.silow; + /* ignore Saber-C warning #112 - get ushort from uint */ + /* ok to ignore on name zroot`sival */ + 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, 0); + 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 = (BOOL)((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, 0); + zfree(temp2); + } +} + + +/* + * Test to see if a number is an exact square or not. + */ +BOOL +zissquare(ZVALUE z) +{ + long n, i; + ZVALUE tmp; + + /* negative values are never perfect squares */ + if (zisneg(z)) { + return FALSE; + } + + /* ignore trailing zero words */ + while ((z.len > 1) && (*z.v == 0)) { + z.len--; + z.v++; + } + + /* zero or one is a perfect square */ + if (zisabsleone(z)) { + return TRUE; + } + + /* check mod 16 values */ + n = (long)(*z.v & 0xf); + if ((n != 0) && (n != 1) && (n != 4) && (n != 9)) + return FALSE; + + /* check mod 256 values */ + n = (long)(*z.v & 0xff); + i = 0x80; + while (((i * i) & 0xff) != n) + if (--i <= 0) + return FALSE; + + /* must do full square root test now */ + n = !zsqrt(z, &tmp, 0); + zfree(tmp); + return (n ? TRUE : FALSE); +} + +/* END CODE */ diff --git a/zio.c b/zio.c new file mode 100644 index 0000000..59d379b --- /dev/null +++ b/zio.c @@ -0,0 +1,713 @@ +/* + * Copyright (c) 1996 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 "config.h" +#include "zmath.h" +#include "args.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) +#define PRINTF3(fmt, a1, a2, a3) math_fmt(fmt, a1, a2, a3) +#define PRINTF4(fmt, a1, a2, a3, a4) math_fmt(fmt, a1, a2, a3, a4) + + +/* + * 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(void) +{ + 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(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"); + /*NOTREACHED*/ + } + 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(char *str) +{ + char *cp; + long len; + + if (!outputisstring) { + fputs(str, outfp); + return; + } + len = (long)strlen(str); + if ((outbufused + len) > outbufsize) { + cp = (char *)realloc(outbuf, outbufsize + len + OUTBUFSIZE + 1); + if (cp == NULL) { + math_error("Cannot realloc output string"); + /*NOTREACHED*/ + } + 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(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. + */ +void +math_fmt(char *fmt, ...) +{ + va_list ap; + char buf[200]; + + va_start(ap, fmt); + vsprintf(buf, fmt, ap); + va_end(ap); + math_str(buf); +} + + +/* + * Flush the current output stream. + */ +void +math_flush(void) +{ + 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(void) +{ + register IOSTATE *sp; + + sp = (IOSTATE *) malloc(sizeof(IOSTATE)); + if (sp == NULL) { + math_error("No memory for diverting output"); + /*NOTREACHED*/ + } + sp->oldiostates = oldiostates; + sp->outdigits = conf->outdigits; + sp->outmode = conf->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"); + /*NOTREACHED*/ + } + 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(void) +{ + register IOSTATE *sp; + char *cp; + + sp = oldiostates; + if (sp == NULL) { + math_error("No diverted state to restore"); + /*NOTREACHED*/ + } + cp = outbuf; + cp[outbufused] = '\0'; + oldiostates = sp->oldiostates; + conf->outdigits = sp->outdigits; + conf->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(void) +{ + 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(FILE *newfp) +{ + outfp = newfp; + outputisstring = (oldiostates && (newfp == stdout)); +} + + +/* + * Set the output mode for numeric output. + * This also returns the previous mode. + */ +int +math_setmode(int newmode) +{ + int oldmode; + + if ((newmode <= MODE_DEFAULT) || (newmode > MODE_MAX)) { + math_error("Setting illegal output mode"); + /*NOTREACHED*/ + } + oldmode = conf->outmode; + conf->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(long newdigits) +{ + long olddigits; + + if (newdigits < 0) { + math_error("Setting illegal number of digits"); + /*NOTREACHED*/ + } + olddigits = conf->outdigits; + conf->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(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 <= (HALF) 9)) { + len = '0' + (int)(*z.v); + PUTCHAR(len & 0xff); + return; + } + hp = z.v + len; +#if BASEB == 32 + PRINTF1("0x%lx", (PRINT) *hp--); + while (--len >= 0) { + PRINTF1("%08lx", (PRINT) *hp--); + } +#else /* BASEB == 32 */ + PRINTF1("0x%lx", (FULL) *hp--); + while (--len >= 0) { + PRINTF1("%04lx", (FULL) *hp--); + } +#endif /* BASEB == 32 */ +} + + +/* + * Print an integer value as a binary number. + * The special characters 0b appear to indicate the number is binary. + */ +/*ARGSUSED*/ +void +zprintb(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' + (int)(*z.v); + PUTCHAR(len & 0xff); + 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 & 0xff); + 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(ZVALUE z, long width) +{ + register HALF *hp; /* current word to print */ + int len; /* number of halfwords to type */ +#if BASEB == 32 /* Yes, the larger base needs a smaller type! */ + HALF num1='0'; /* numbers to type */ + HALF num2=(HALF)0; /* numbers to type */ + HALF num3; /* numbers to type */ + HALF num4; /* numbers to type */ +#else + FULL num1='0'; /* numbers to type */ + FULL num2=(FULL)0; /* numbers to type */ +#endif + 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' + (int)(*z.v); + PUTCHAR((int)(num1 & 0xff)); + return; + } + hp = z.v + len - 1; + rem = len % 3; +#if BASEB == 32 + switch (rem) { /* handle odd amounts first */ + case 0: + num1 = ((hp[0]) >> 8); + num2 = (((hp[0] & 0xff) << 16) + (hp[-1] >> 16)); + num3 = (((hp[-1] & 0xffff) << 8) + (hp[-2] >> 24)); + num4 = (hp[-2] & 0xffffff); + if (num1) { + PRINTF4("0%lo%08lo%08lo%08lo", + (PRINT) num1, (PRINT) num2, + (PRINT) num3, (PRINT) num4); + } else { + PRINTF3("0%lo%08lo%08lo", + (PRINT) num2, (PRINT) num3, (PRINT) num4); + } + rem = 3; + break; + case 1: + PRINTF1("0%lo", (PRINT) hp[0]); + break; + case 2: + num1 = ((hp[0]) >> 16); + num2 = (((hp[0] & 0xffff) << 8) + (hp[-1] >> 24)); + num3 = (hp[-1] & 0xffffff); + if (num1) { + PRINTF3("0%lo%08lo%08lo", + (PRINT) num1, (PRINT) num2, (PRINT) num3); + } else { + PRINTF2("0%lo%08lo", (PRINT) num2, (PRINT) num3); + } + break; + } + len -= rem; + hp -= rem; + while (len > 0) { /* finish in groups of 3 words */ + PRINTF4("%08lo%08lo%08lo%08lo", + (PRINT) ((hp[0]) >> 8), + (PRINT) (((hp[0] & 0xff) << 16) + (hp[-1] >> 16)), + (PRINT) (((hp[-1] & 0xffff) << 8) + (hp[-2] >> 24)), + (PRINT) (hp[-2] & 0xffffff)); + hp -= 3; + len -= 3; + } +#else + 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%lo%08lo", num1, num2); + } else { + PRINTF1("0%lo", num2); + } + len -= rem; + hp -= rem; + while (len > 0) { /* finish in groups of 3 halfwords */ + PRINTF2("%08lo%08lo", + ((((FULL) hp[0]) << 8) + (((FULL) hp[-1]) >> 8)), + ((((FULL) (hp[-1] & 0xff)) << 16) + ((FULL) hp[-2]))); + hp -= 3; + len -= 3; + } +#endif +} + + +/* + * 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". + * + * given: + * z number to be printed + * decimals number of decimal places + * width number of columns to print in + */ +void +zprintval(ZVALUE z, long decimals, long width) +{ + int depth; /* maximum depth */ + int n; /* current index into array */ + long 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) { + if (depth <= TEN_MAX) { + zsquare(_tenpowers_[depth-1], + &_tenpowers_[depth]); + } else { + math_error("cannot compute 10^2^(TEN_MAX+1)"); + /*NOTREACHED*/ + } + } + } + /* + * 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, 0); + if (!ziszero(quo)) + digits += (1L << i); + n++; + leftnums[n] = quo; + rightnums[n] = rem; + } + i = (long)(leftnums[n].v[0]); + if (output || i || (n == 0)) { + if (!output) { + output = TRUE; + if (decimals < digits) + leadspaces -= digits; + else + leadspaces -= decimals+conf->leadzero; + while (--leadspaces >= 0) + PUTCHAR(' '); + if (neg) + PUTCHAR('-'); + if (decimals) { + putpoint = (digits - decimals); + if (putpoint <= 0) { + if (conf->leadzero) + PUTCHAR('0'); + PUTCHAR('.'); + while (++putpoint <= 0) + PUTCHAR('0'); + putpoint = 0; + } + } + } + i += '0'; + PUTCHAR((int)(i & 0xff)); + 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 +str2z(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/zmath.c b/zmath.c new file mode 100644 index 0000000..bf38039 --- /dev/null +++ b/zmath.c @@ -0,0 +1,1742 @@ +/* + * Copyright (c) 1996 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 _zeroval_[] = { 0 }; +HALF _oneval_[] = { 1 }; +HALF _twoval_[] = { 2 }; +HALF _threeval_[] = { 3 }; +HALF _fourval_[] = { 4 }; +HALF _fiveval_[] = { 5 }; +HALF _sixval_[] = { 6 }; +HALF _sevenval_[] = { 7 }; +HALF _eightval_[] = { 8 }; +HALF _nineval_[] = { 9 }; +HALF _tenval_[] = { 10 }; +HALF _elevenval_[] = { 11 }; +HALF _twelveval_[] = { 12 }; +HALF _thirteenval_[] = { 13 }; +HALF _fourteenval_[] = { 14 }; +HALF _fifteenval_[] = { 15 }; +HALF _sqbaseval_[] = { 0, 1 }; + +ZVALUE zconst[] = { + { _zeroval_, 1, 0}, { _oneval_, 1, 0}, { _twoval_, 1, 0}, + { _threeval_, 1, 0}, { _fourval_, 1, 0}, { _fiveval_, 1, 0}, + { _sixval_, 1, 0}, { _sevenval_, 1, 0}, { _eightval_, 1, 0}, + { _nineval_, 1, 0}, { _tenval_, 1, 0}, { _elevenval_, 1, 0}, + { _twelveval_, 1, 0}, { _thirteenval_, 1, 0}, { _fourteenval_, 1, 0}, + { _fifteenval_, 1, 0} +}; + +ZVALUE _zero_ = { _zeroval_, 1, 0}; +ZVALUE _one_ = { _oneval_, 1, 0 }; +ZVALUE _two_ = { _twoval_, 1, 0 }; +ZVALUE _ten_ = { _tenval_, 1, 0 }; +ZVALUE _sqbase_ = { _sqbaseval_, 2, 0 }; + + +/* + * highhalf[i] - masks off the upper i bits of a HALF + * lowhalf[i] - masks off the upper i bits of a HALF + * bitmask[i] - (1 << i) for 0 <= i <= BASEB*2 + */ +HALF highhalf[BASEB+1] = { +#if BASEB == 32 + 0x00000000, + 0x80000000, 0xC0000000, 0xE0000000, 0xF0000000, + 0xF8000000, 0xFC000000, 0xFE000000, 0xFF000000, + 0xFF800000, 0xFFC00000, 0xFFE00000, 0xFFF00000, + 0xFFF80000, 0xFFFC0000, 0xFFFE0000, 0xFFFF0000, + 0xFFFF8000, 0xFFFFC000, 0xFFFFE000, 0xFFFFF000, + 0xFFFFF800, 0xFFFFFC00, 0xFFFFFE00, 0xFFFFFF00, + 0xFFFFFF80, 0xFFFFFFC0, 0xFFFFFFE0, 0xFFFFFFF0, + 0xFFFFFFF8, 0xFFFFFFFC, 0xFFFFFFFE, 0xFFFFFFFF +#elif BASEB == 16 + 0x0000, + 0x8000, 0xC000, 0xE000, 0xF000, + 0xF800, 0xFC00, 0xFE00, 0xFF00, + 0xFF80, 0xFFC0, 0xFFE0, 0xFFF0, + 0xFFF8, 0xFFFC, 0xFFFE, 0xFFFF +#else + -=@=- BASEB not 16 or 32 -=@=- +#endif +}; +HALF lowhalf[BASEB+1] = { + 0x0, + 0x1, 0x3, 0x7, 0xF, + 0x1F, 0x3F, 0x7F, 0xFF, + 0x1FF, 0x3FF, 0x7FF, 0xFFF, + 0x1FFF, 0x3FFF, 0x7FFF, 0xFFFF +#if BASEB == 32 + ,0x1FFFF, 0x3FFFF, 0x7FFFF, 0xFFFFF, + 0x1FFFFF, 0x3FFFFF, 0x7FFFFF, 0xFFFFFF, + 0x1FFFFFF, 0x3FFFFFF, 0x7FFFFFF, 0xFFFFFFF, + 0x1FFFFFFF, 0x3FFFFFFF, 0x7FFFFFFF, 0xFFFFFFFF +#endif +}; +HALF bitmask[(2*BASEB)+1] = { +#if BASEB == 32 + 0x00000001, 0x00000002, 0x00000004, 0x00000008, + 0x00000010, 0x00000020, 0x00000040, 0x00000080, + 0x00000100, 0x00000200, 0x00000400, 0x00000800, + 0x00001000, 0x00002000, 0x00004000, 0x00008000, + 0x00010000, 0x00020000, 0x00040000, 0x00080000, + 0x00100000, 0x00200000, 0x00400000, 0x00800000, + 0x01000000, 0x02000000, 0x04000000, 0x08000000, + 0x10000000, 0x20000000, 0x40000000, 0x80000000, + 0x00000001, 0x00000002, 0x00000004, 0x00000008, + 0x00000010, 0x00000020, 0x00000040, 0x00000080, + 0x00000100, 0x00000200, 0x00000400, 0x00000800, + 0x00001000, 0x00002000, 0x00004000, 0x00008000, + 0x00010000, 0x00020000, 0x00040000, 0x00080000, + 0x00100000, 0x00200000, 0x00400000, 0x00800000, + 0x01000000, 0x02000000, 0x04000000, 0x08000000, + 0x10000000, 0x20000000, 0x40000000, 0x80000000, + 0x00000001 +#elif BASEB == 16 + 0x0001, 0x0002, 0x0004, 0x0008, + 0x0010, 0x0020, 0x0040, 0x0080, + 0x0100, 0x0200, 0x0400, 0x0800, + 0x1000, 0x2000, 0x4000, 0x8000, + 0x0001, 0x0002, 0x0004, 0x0008, + 0x0010, 0x0020, 0x0040, 0x0080, + 0x0100, 0x0200, 0x0400, 0x0800, + 0x1000, 0x2000, 0x4000, 0x8000, + 0x0001 +#else + -=@=- BASEB not 16 or 32 -=@=- +#endif +}; /* actual rotation thru 8 cycles */ + +BOOL _math_abort_; /* nonzero to abort calculations */ + + +#ifdef ALLOCTEST +static long nalloc = 0; +static long nfree = 0; +#endif + + +HALF * +alloc(LEN len) +{ + HALF *hp; + + if (_math_abort_) { + math_error("Calculation aborted"); + /*NOTREACHED*/ + } + hp = (HALF *) malloc((len+1) * sizeof(HALF)); + if (hp == 0) { + math_error("Not enough memory"); + /*NOTREACHED*/ + } +#ifdef ALLOCTEST + ++nalloc; +#endif + return hp; +} + + +#ifdef ALLOCTEST +void +freeh(HALF *h) +{ + if ((h != _zeroval_) && (h != _oneval_)) { + free(h); + ++nfree; + } +} + + +void +allocStat(void) +{ + fprintf(stderr, "nalloc: %ld nfree: %ld kept: %ld\n", + nalloc, nfree, nalloc - nfree); +} +#endif + + +/* + * Convert a normal integer to a number. + */ +void +itoz(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)len; + res->v = alloc((LEN)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(ZVALUE z) +{ + long i; + + if (zgtmaxlong(z)) { + i = MAXLONG; + return (z.sign ? -i : i); + } + i = ztolong(z); + return (z.sign ? -i : i); +} + + +/* + * Convert a normal unsigned integer to a number. + */ +void +utoz(FULL i, ZVALUE *res) +{ + long len; + + res->len = 1; + res->sign = 0; + if (i == 0) { + res->v = _zeroval_; + return; + } + if (i == 1) { + res->v = _oneval_; + return; + } + len = 1 + (((FULL) i) >= BASE); + res->len = (LEN)len; + res->v = alloc((LEN)len); + res->v[0] = (HALF)i; + if (len == 2) + res->v[1] = (HALF) (i / BASE); +} + + +/* + * Convert a number to a unsigned normal integer, as far as possible. + * If the number is out of range, the largest number is returned. + * The absolute value of z is converted. + */ +FULL +ztou(ZVALUE z) +{ + if (z.len > 2) { + return MAXUFULL; + } + return ztofull(z); +} + + +/* + * Make a copy of an integer value + */ +void +zcopy(ZVALUE z, ZVALUE *res) +{ + res->sign = z.sign; + res->len = z.len; + if (zisabsleone(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(ZVALUE z1, ZVALUE z2, ZVALUE *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)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; + /* ignore Saber-C warning #112 - get ushort from uint */ + /* ok to ignore on name zadd`sival */ + *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(ZVALUE z1, ZVALUE z2, ZVALUE *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 = (long)carry; + h1 = z2.v; + h2 = z1.v; + dest.sign = !dest.sign; + } + hd = alloc((LEN)len1); + dest.v = hd; + dest.len = (LEN)len1; + len1 -= len2; + carry = 0; + while (--len2 >= 0) { + /* ignore Saber-C warning #112 - get ushort from uint */ + /* ok to ignore on name zsub`sival */ + sival.ivalue = (BASE1 - ((FULL) *h1++)) + *h2++ + carry; + *hd++ = (HALF)(BASE1 - sival.silow); + carry = sival.sihigh; + } + while (--len1 >= 0) { + sival.ivalue = (BASE1 - ((FULL) *h1++)) + carry; + *hd++ = (HALF)(BASE1 - sival.silow); + carry = sival.sihigh; + } + if (hd[-1] == 0) + ztrim(&dest); + *res = dest; +} + + +/* + * Multiply an integer by a small number. + */ +void +zmuli(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; + } +#if LONG_BITS > BASEB + low = ((FULL) n) & BASE1; + high = ((FULL) n) >> BASEB; +#else + low = (FULL)n; + high = 0; +#endif + 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--) { + /* ignore Saber-C warning #112 - get ushort from uint */ + /* ok to ignore on name zmuli`sival */ + 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(ZVALUE z1, ZVALUE z2, ZVALUE *z1res, ZVALUE *z2res) +{ + ZVALUE tmp; + + if (zisabsleone(z1) || zisabsleone(z2)) + tmp = _one_; + else + zgcd(z1, z2, &tmp); + if (zisunit(tmp)) { + zcopy(z1, z1res); + zcopy(z2, z2res); + } else { + zequo(z1, tmp, z1res); + zequo(z2, tmp, z2res); + } + zfree(tmp); +} + + + +/* + * Compute the quotient and remainder for division of an integer by an + * integer, rounding criteria determined by rnd. Returns the sign of + * the remainder. + */ +long +zdiv(ZVALUE z1, ZVALUE z2, ZVALUE *quo, ZVALUE *rem, long rnd) +{ + register HALF *a, *b; + HALF s, u; + HALF *A, *B, *a1, *b0; + FULL f, g, h, x; + BOOL adjust, onebit; + LEN m, n, len, i, p, j1, j2, k; + long t, val; + + if (ziszero(z2)) { + math_error("Division by zero in zdiv"); + /*NOTREACHED*/ + } + m = z1.len; + n = z2.len; + B = z2.v; + s = 0; + if (m < n) { + A = alloc(n + 1); + memcpy(A, z1.v, m * sizeof(HALF)); + for (i = m; i <= n; i++) + A[i] = 0; + a1 = A + n; + len = 1; + goto done; + } + A = alloc(m + 2); + memcpy(A, z1.v, m * sizeof(HALF)); + A[m] = 0; + A[m + 1] = 0; + len = m - n + 1; /* quotient length will be len or len +/- 1 */ + a1 = A + n; /* start of digits for quotient */ + b0 = B - 1; + p = n; + while (!*++b0) /* b0: working start for divisor */ + p--; + if (p == 1) { + u = *b0; + if (u == 1) { + for (; m >= n; m--) + A[m] = A[m - 1]; + A[m] = 0; + goto done; + } + f = 0; + a = A + m; + i = len; + while (i--) { + f = f << BASEB | *--a; + a[1] = (HALF)(f / u); + f = f % u; + } + *a = (HALF)f; + m = n; + goto done; + } + f = B[n - 1]; + k = 1; + while (f >>= 1) + k++; /* k: number of bits in top divisor digit */ + j1 = BASEB - k; + j2 = BASEB + j1; + h = j1 ? ((FULL) B[n - 1] << j1 | B[n - 2] >> k) : B[n-1]; + onebit = (BOOL)((B[n - 2] >> (k - 1)) & 1); + m++; + while (m > n) { + m--; + f = (FULL) A[m] << j2 | (FULL) A[m - 1] << j1; + if (j1) f |= A[m - 2] >> k; + if (s) f = ~f; + x = f / h; + if (x) { + if (onebit && x > TOPHALF + f % h) + x--; + a = A + m - p; + b = b0; + u = 0; + i = p; + if (s) { + while (i--) { + f = (FULL) *a + u + x * *b++; + *a++ = (HALF) f; + u = (HALF) (f >> BASEB); + } + s = *a + u; + A[m] = (HALF) (~x + !s); + } + else { + while (i--) { + f = (FULL) *a - u - x * *b++; + *a++ = (HALF) f; + u = -(HALF)(f >> BASEB); + } + s = *a - u; + A[m] = (HALF)(x + s); + } + } + else + A[m] = s; + } +done: while (m > 0 && A[m - 1] == 0) + m--; + if (m == 0 && s == 0) { + *rem = _zero_; + val = 0; + if (a1[len - 1] == 0) + len--; + if (len == 0) + *quo = _zero_; + else { + quo->len = len; + quo->v = alloc(len); + memcpy(quo->v, a1, len * sizeof(HALF)); + quo->sign = z1.sign ^ z2.sign; + } + freeh(A); + return val; + } + if (rnd & 8) + adjust = (((*a1 ^ rnd) & 1) ? TRUE : FALSE); + else + adjust = (((rnd & 1) ^ z1.sign ^ z2.sign) ? TRUE : FALSE); + if (rnd & 2) + adjust ^= z1.sign ^ z2.sign; + if (rnd & 4) + adjust ^= z2.sign; + if (rnd & 16) { /* round-off case */ + a = A + n; + b = B + n; + i = n + 1; + f = g = 0; + t = -1; + if (s) { + while (--i > 0 ) { + g = (FULL) *--a + (*--b >> 1 | f); + if (g != BASE1) + break; + f = *b & 1 ? TOPHALF : 0; + } + if (g == BASE && f == 0) { + while (i-- && (*--a | *--b) == 0); + t = (i > 0); + } + else if (g >= BASE) + t = 1; + } + else { + while (--i > 0) { + g = (FULL) *--a - (*--b >> 1 | f); + if (g != 0) + break; + f = *b & 1 ? TOPHALF : 0; + } + if (g > 0 && g < BASE) + t = 1; + else if (g == 0 && f == 0) + t = 0; + } + if (t) + adjust = (t > 0); + } + if (adjust) { + i = len; + a = a1; + while (i > 0 && *a == BASE1) { + i--; + *a++ = 0; + } + (*a)++; + if (i == 0) + len++; + } + if (s && adjust) { + i = 0; + while (A[i] == 0) + i++; + A[i] = -A[i]; + while (++i < n) + A[i] = ~A[i]; + m = n; + while (A[m - 1] == 0) + m--; + } + if (!s && adjust) { + a = A; + b = B; + i = n; + u = 0; + while (i--) { + f = (FULL) *b++ - *a - (FULL) u; + *a++ = (HALF) f; + u = -(HALF)(f >> BASEB); + } + m = n; + while (A[m - 1] == 0) + m--; + } + if (s && !adjust) { + a = A; + b = B; + i = n; + f = 0; + while (i--) { + f = (FULL) *b++ + *a + (f >> BASEB); + *a++ = (HALF) f; + } + m = n; + while (A[m-1] == 0) + m--; + } + rem->len = m; + rem->v = alloc(m); + memcpy(rem->v, A, m * sizeof(HALF)); + rem->sign = z1.sign ^ adjust; + val = rem->sign ? -1 : 1; + if (a1[len - 1] == 0) + len--; + if (len == 0) + *quo = _zero_; + else { + quo->len = len; + quo->v = alloc(len); + memcpy(quo->v, a1, len * sizeof(HALF)); + quo->sign = z1.sign ^ z2.sign; + } + freeh(A); + return val; +} + + +/* + * Compute and store at a specified location the integer quotient + * of two integers, the type of rounding being determined by rnd. + * Returns the sign of z1/z2 - calculated quotient. + */ +long +zquo(ZVALUE z1, ZVALUE z2, ZVALUE *res, long rnd) +{ + ZVALUE tmp; + long val; + + val = zdiv(z1, z2, res, &tmp, rnd); + if (z2.sign) + val = -val; + zfree(tmp); + return val; +} + + +/* + * Compute and store at a specified location the remainder for + * division of an integer by an integer, the type of rounding + * used being determined by rnd. Returns the sign of the remainder. + */ +long +zmod(ZVALUE z1, ZVALUE z2, ZVALUE *res, long rnd) +{ + ZVALUE tmp; + long val; + + val = zdiv(z1, z2, &tmp, res, rnd); + zfree(tmp); + return val; +} + + +/* + * Computes the quotient z1/z2 on the assumption that this is exact. + * There is no thorough check on the exactness of the division + * so this should not be called unless z1/z2 is an integer. + */ +void +zequo(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + LEN i, j, k, len, m, n, o, p; + HALF *a, *a0, *A, *b, *B, u, v, w, x; + FULL f, g; + + if (ziszero(z1)) { + *res = _zero_; + return; + } + if (ziszero(z2)) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + if (zisone(z2)) { + zcopy(z1, res); + return; + } + if (zhighbit(z1) < zhighbit(z2)) { + math_error("Bad call to zequo"); + /*NOTREACHED*/ + } + B = z2.v - 1; + o = 0; + while (!*++B) + o++; + m = z1.len - o; + n = z2.len - o; + len = m - n + 1; /* Maximum length of quotient */ + v = *B; + A = alloc(len); + memcpy(A, z1.v + o, len * sizeof(HALF)); + if (n == 1) { + if (v > 1) { + a = A + len; + i = len; + f = 0; + while (i--) { + f = f << BASEB | *--a; + *a = (HALF)(f / v); + f %= v; + } + } + } + else { + k = 0; + while (!(v & 1)) { + k++; + v >>= 1; + } + j = BASEB - k; + if (n > 1 && k > 0) + v |= B[1] << j; + u = v - 1; + w = x = 1; + while (u) { /* To find w = inverse of v modulo BASE */ + do { + v <<= 1; + x <<= 1; + } + while (!(u & x)); + u += v; + w |= x; + } + a0 = A; + p = len; + while (p > 1) { + if (!*a0) { + while (!*++a0 && p > 1) + p--; + --a0; + } + if (p == 1) + break; + x = k ? w * (*a0 >> k | a0[1] << j) : w * *a0; + g = x; + if (x) { + a = a0; + b = B; + u = 0; + i = n; + if (i > p) + i = p; + while (i--) { + f = (FULL) *a - g * *b++ - (FULL) u; + *a++ = (HALF)f; + u = -(HALF)(f >> BASEB); + } + if (u && p > n) { + i = p - n; + while (u && i--) { + f = (FULL) *a - u; + *a++ = (HALF) f; + u = -(HALF)(f >> BASEB); + } + } + } + *a0++ = x; + p--; + } + if (k == 0) + *a0 = w * *a0; + else { + u = (HALF)(w * *a0) >> k; + x = (HALF)(((FULL) z1.v[z1.len - 1] << BASEB + | z1.v[z1.len - 2]) + /((FULL) B[n-1] << BASEB | B[n-2])); + if ((x ^ u) & 1) x--; + *a0 = x; + } + } + if (!A[len - 1]) len--; + res->v = A; + res->len = len; + res->sign = z1.sign != z2.sign; +} + + + +/* + * 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(ZVALUE z, long n, ZVALUE *res) +{ + HALF *h1, *sd; + FULL val; + HALF divval[2]; + ZVALUE div; + ZVALUE dest; + LEN len; + + if (n == 0) { + math_error("Division by zero"); + /*NOTREACHED*/ + } + 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.v = divval; + divval[0] = (HALF) n; +#if LONG_BITS > BASEB + divval[1] = (HALF)(((FULL) n) >> BASEB); + div.len = 2; +#else + div.len = 1; +#endif + zdiv(z, div, res, &dest, 0); + n = ztolong(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-- = (HALF)(val / n); + val %= n; + } + zquicktrim(dest); + *res = dest; + return (long)val; +} + + + +/* + * Calculate the mod of an integer by a small number. + * This is only defined for positive moduli. + */ +long +zmodi(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"); + /*NOTREACHED*/ + } + if (n < 0) { + math_error("Non-positive modulus"); + /*NOTREACHED*/ + } + 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.v = divval; + divval[0] = (HALF) n; +#if LONG_BITS > BASEB + divval[1] = (HALF)(((FULL) n) >> BASEB); + div.len = 2; +#else + div.len = 1; +#endif + zmod(z, div, &temp, 0); + n = ztolong(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 (long)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(ZVALUE z1, ZVALUE z2) +{ + LEN i, j, k, m, n; + HALF u, v, w, x; + HALF *a, *a0, *A, *b, *B, *c, *d; + FULL f; + BOOL ans; + + if (zisunit(z2) || ziszero(z1)) return TRUE; + if (ziszero(z2)) return FALSE; + + m = z1.len; + n = z2.len; + if (m < n) return FALSE; + + c = z1.v; + d = z2.v; + + while (!*d) { + if (*c++) return FALSE; + d++; + m--; + n--; + } + + j = 0; + u = *c; + v = *d; + while (!(v & 1)) { /* Counting and checking zero bits */ + if (u & 1) return FALSE; + u >>= 1; + v >>= 1; + j++; + } + + if (n == 1 && v == 1) return TRUE; + if (!*c) { /* Removing any further zeros */ + while(!*++c) + m--; + c--; + } + + if (m < n) return FALSE; + + if (j) { + B = alloc((LEN)n); /* Array for shifted z2 */ + d += n; + b = B + n; + i = n; + f = 0; + while(i--) { + f = f << BASEB | *--d; + *--b = (HALF)(f >> j); + } + if (!B[n - 1]) n--; + } + else B = d; + u = *B; + v = x = 1; + w = 0; + while (x) { /* Finding minv(*B, BASE) */ + if (v & x) { + v -= x * u; + w |= x; + } + x <<= 1; + } + + A = alloc((LEN)(m + 2)); /* Main working array */ + memcpy(A, c, m * sizeof(HALF)); + A[m + 1] = 1; + A[m] = 0; + + k = m - n + 1; /* Length of presumed quotient */ + + a0 = A; + + while (k--) { + if (*a0) { + x = w * *a0; + a = a0; + b = B; + i = n; + u = 0; + while (i--) { + f = (FULL) *a - (FULL) x * *b++ - u; + *a++ = (HALF)f; + u = -(HALF)(f >> BASEB); + } + f = (FULL) *a - u; + *a++ = (HALF)f; + u = -(HALF)(f >> BASEB); + if (u) { + while (*a == 0) *a++ = BASE1; + (*a)--; + } + } + a0++; + } + ans = FALSE; + if (A[m + 1]) { + a = A + m; + while (--n && !*--a); + if (!n) ans = TRUE; + } + freeh(A); + if (j) freeh(B); + return ans; +} + + +/* + * Compute the logical OR of two numbers + */ +void +zor(ZVALUE z1, ZVALUE z2, ZVALUE *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(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + HALF *h1, *h2, *hd; + LEN 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(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + register HALF *sp, *dp; + LEN len; + ZVALUE bz, lz, dest; + + if (z1.len == z2.len) { + /* ignore Saber-C warning #530 about empty for statement */ + /* ok to ignore in proc zxor */ + 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(ZVALUE z, long n, ZVALUE *res) +{ + ZVALUE ans; + LEN 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 = (LEN)(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 = (LEN)(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(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; + /* ignore Saber-C warning #530 about empty while statement */ + /* ok to ignore in proc zlowbit */ + 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). + */ +LEN +zhighbit(ZVALUE z) +{ + HALF dataval; + HALF *bitval; + + dataval = z.v[z.len-1]; + if (dataval == 0) { + return 0; + } + bitval = bitmask+BASEB; + if (dataval) { + /* ignore Saber-C warning #530 about empty while statement */ + /* ok to ignore in proc zhighbit */ + while ((*(--bitval) & dataval) == 0) { + } + } + return (z.len*BASEB)+(LEN)(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. + * + * given: + * low lowest bit to reverse, <0 => lowbit(z) + * high highest bit to reverse, <0 => highbit(z) + * z value to bit reverse + * res resulting bit reverse number + */ +void +zbitrev(long low, long high, ZVALUE z, ZVALUE *res) +{ +} +#endif + + +/* + * Return whether or not the specifed bit number is set in a number. + * Rightmost bit of a number is bit 0. + */ +BOOL +zisset(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(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(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(long n, ZVALUE *res) +{ + ZVALUE z; + + if (n < 0) n = 0; + z.sign = 0; + z.len = (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(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(ZVALUE z1, ZVALUE z2) +{ + register HALF *h1, *h2; + register FULL 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(ZVALUE z1, ZVALUE 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; +} + + +/* + * Utility to calculate the gcd of two FULL integers. + */ +FULL +uugcd(FULL f1, FULL f2) +{ + FULL temp; + + while (f1) { + temp = f2 % f1; + f2 = f1; + f1 = temp; + } + return (FULL) f2; +} + + +/* + * Utility to calculate the gcd of two small integers. + */ +long +iigcd(long i1, long 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(ZVALUE *z) +{ + HALF *h; + LEN 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. + * + * NOTE: The ZVALUE length is not adjusted instead, the value is + * zero padded from the left. One may need to call ztrim() + * or use zshift() instead. + */ +void +zshiftr(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) | (HALF)mask); + mask = maskt; + --h; + } + } +} + + +/* + * Utility routine to shift left. + * + * NOTE: The ZVALUE length is not adjusted. The bits in the upper + * HALF are simply tossed. You may want to use zshift() instead. + */ +void +zshiftl(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; + } + } +} + +/* END CODE */ diff --git a/zmath.h b/zmath.h new file mode 100644 index 0000000..b46c92f --- /dev/null +++ b/zmath.h @@ -0,0 +1,547 @@ +/* + * Copyright (c) 1996 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. + */ + +#if !defined(ZMATH_H) +#define ZMATH_H + +#include +#include "alloc.h" +#include "endian_calc.h" +#include "longbits.h" +#include "byteswap.h" + +#include "have_stdlib.h" +#ifdef HAVE_STDLIB_H +# include +#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 + + +#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 + * HALF must be BASEB bits long + */ + +#if defined(HAVE_B64) + +#define BASEB 32 /* use base 2^32 */ +typedef USB32 HALF; /* unit of number storage */ +typedef SB32 SHALF; /* signed HALF */ +typedef USB64 FULL; /* double unit of number storage */ +typedef SB64 SFULL; /* signed FULL */ + +#define SWAP_HALF_IN_B64(dest, src) SWAP_B32_IN_B64(dest, src) +#define SWAP_HALF_IN_B32(dest, src) (*(dest) = *(src)) +#define SWAP_HALF_IN_FULL(dest, src) SWAP_B32_IN_B64(dest, src) +#define SWAP_HALF_IN_HASH(dest, src) SWAP_B16_IN_HASH(dest, src) +#define SWAP_HALF_IN_FLAG(dest, src) SWAP_B16_IN_FLAG(dest, src) +#define SWAP_HALF_IN_BOOL(dest, src) SWAP_B16_IN_BOOL(dest, src) +#define SWAP_HALF_IN_LEN(dest, src) SWAP_B16_IN_LEN(dest, src) +#define SWAP_B32_IN_FULL(dest, src) SWAP_B32_IN_B64(dest, src) +#define SWAP_B16_IN_FULL(dest, src) SWAP_B16_IN_B64(dest, src) +#define SWAP_B16_IN_HALF(dest, src) SWAP_B16_IN_B32(dest, src) +#define SWAP_B8_IN_FULL(dest, src) SWAP_B8_IN_B64(dest, src) +#define SWAP_B8_IN_HALF(dest, src) SWAP_B8_IN_B32(dest, src) + +#else + +#define BASEB 16 /* use base 2^16 */ +typedef USB16 HALF; /* unit of number storage */ +typedef SB16 SHALF; /* signed HALF */ +typedef USB32 FULL; /* double unit of number storage */ +typedef SB32 SFULL; /* signed FULL */ + +#define SWAP_HALF_IN_B64(dest, src) SWAP_B32_IN_B64(dest, src) +#define SWAP_HALF_IN_B32(dest, src) SWAP_B16_IN_B32(dest, src) +#define SWAP_HALF_IN_FULL(dest, src) SWAP_B16_IN_B32(dest, src) +#define SWAP_HALF_IN_HASH(dest, src) SWAP_B16_IN_HASH(dest, src) +#define SWAP_HALF_IN_FLAG(dest, src) SWAP_B16_IN_FLAG(dest, src) +#define SWAP_HALF_IN_BOOL(dest, src) SWAP_B16_IN_BOOL(dest, src) +#define SWAP_HALF_IN_LEN(dest, src) SWAP_B16_IN_LEN(dest, src) +#define SWAP_B32_IN_FULL(dest, src) (*(dest) = *(src)) +#define SWAP_B16_IN_FULL(dest, src) SWAP_B16_IN_B32(dest, src) +#define SWAP_B16_IN_HALF(dest, src) (*(dest) = *(src)) +#define SWAP_B8_IN_FULL(dest, src) SWAP_B8_IN_B32(dest, src) +#define SWAP_B8_IN_HALF(dest, src) SWAP_B8_IN_B16(dest, src) + +#endif + +#define BASE ((FULL)1<> 3) /* longest value allowed */ + + +#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 +#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 + /\oo/\ BYTE_ORDER must be BIG_ENDIAN or LITTLE_ENDIAN /\oo/\ !!! +# 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. + */ +extern HALF * alloc(LEN len); +#ifdef ALLOCTEST +extern void freeh(HALF *); +#endif + + +/* + * Input, output, and conversion routines. + */ +extern void zcopy(ZVALUE z, ZVALUE *res); +extern void itoz(long i, ZVALUE *res); +extern void utoz(FULL i, ZVALUE *res); +extern void str2z(char *s, ZVALUE *res); +extern long ztoi(ZVALUE z); +extern FULL ztou(ZVALUE z); +extern void zprintval(ZVALUE z, long decimals, long width); +extern void zprintx(ZVALUE z, long width); +extern void zprintb(ZVALUE z, long width); +extern void zprinto(ZVALUE z, long width); + + +/* + * Basic numeric routines. + */ +extern void zmuli(ZVALUE z, long n, ZVALUE *res); +extern long zdivi(ZVALUE z, long n, ZVALUE *res); +extern long zmodi(ZVALUE z, long n); +extern void zadd(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zsub(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zmul(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern long zdiv(ZVALUE z1, ZVALUE z2, ZVALUE *res, ZVALUE *rem, long R); +extern long zquo(ZVALUE z1, ZVALUE z2, ZVALUE *res, long R); +extern long zmod(ZVALUE z1, ZVALUE z2, ZVALUE *rem, long R); +extern void zequo(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern BOOL zdivides(ZVALUE z1, ZVALUE z2); +extern void zor(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zand(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zxor(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zshift(ZVALUE z, long n, ZVALUE *res); +extern void zsquare(ZVALUE z, ZVALUE *res); +extern long zlowbit(ZVALUE z); +extern LEN zhighbit(ZVALUE z); +extern void zbitvalue(long n, ZVALUE *res); +extern BOOL zisset(ZVALUE z, long n); +extern BOOL zisonebit(ZVALUE z); +extern BOOL zisallbits(ZVALUE z); +extern FLAG ztest(ZVALUE z); +extern FLAG zrel(ZVALUE z1, ZVALUE z2); +extern BOOL zcmp(ZVALUE z1, ZVALUE z2); + + +/* + * More complicated numeric functions. + */ +extern FULL uugcd(FULL i1, FULL i2); +extern long iigcd(long i1, long i2); +extern void zgcd(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zlcm(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zreduce(ZVALUE z1, ZVALUE z2, ZVALUE *z1res, ZVALUE *z2res); +extern void zfact(ZVALUE z, ZVALUE *dest); +extern void zperm(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zcomb(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern FLAG zjacobi(ZVALUE z1, ZVALUE z2); +extern void zfib(ZVALUE z, ZVALUE *res); +extern void zpowi(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void ztenpow(long power, ZVALUE *res); +extern void zpowermod(ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *res); +extern BOOL zmodinv(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern BOOL zrelprime(ZVALUE z1, ZVALUE z2); +extern long zlog(ZVALUE z1, ZVALUE z2); +extern long zlog10(ZVALUE z); +extern long zdivcount(ZVALUE z1, ZVALUE z2); +extern long zfacrem(ZVALUE z1, ZVALUE z2, ZVALUE *rem); +extern void zgcdrem(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern long zdigits(ZVALUE z1); +extern long zdigit(ZVALUE z1, long n); +extern FLAG zsqrt(ZVALUE z1, ZVALUE *dest, long R); +extern void zroot(ZVALUE z1, ZVALUE z2, ZVALUE *dest); +extern BOOL zissquare(ZVALUE z); + + +/* + * Prime related functions. + */ +extern FLAG zisprime(ZVALUE z); +extern FULL znprime(ZVALUE z); +extern FULL next_prime(FULL v); +extern FULL zpprime(ZVALUE z); +extern void zpfact(ZVALUE z, ZVALUE *dest); +extern BOOL zprimetest(ZVALUE z, long count, ZVALUE skip); +extern BOOL zredcprimetest(ZVALUE z, long count, ZVALUE skip); +extern BOOL znextcand(ZVALUE z1, long count, ZVALUE skip, ZVALUE res, ZVALUE mod, ZVALUE *cand); +extern BOOL zprevcand(ZVALUE z1, long count, ZVALUE skip, ZVALUE res, ZVALUE mod, ZVALUE *cand); +extern FULL zlowfactor(ZVALUE z, long count); +extern FLAG zfactor(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern long zpix(ZVALUE z1); +extern void zlcmfact(ZVALUE z, ZVALUE *dest); + + +/* + * Misc misc functions. :-) + */ +#if 0 +extern void zapprox(ZVALUE z1, ZVALUE z2, ZVALUE *res1, ZVALUE *res2); +extern void zmulmod(ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *res); +extern void zsquaremod(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zsubmod(ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *res); +#endif +extern void zminmod(ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern BOOL zcmpmod(ZVALUE z1, ZVALUE z2, ZVALUE z3); +extern void zio_init(void); + + +/* + * These functions are for internal use only. + */ +extern void ztrim(ZVALUE *z); +extern void zshiftr(ZVALUE z, long n); +extern void zshiftl(ZVALUE z, long n); +extern HALF *zalloctemp(LEN len); + + +/* + * 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(ZVALUE z1); +extern void zredcfree(REDC *rp); +extern void zredcencode(REDC *rp, ZVALUE z1, ZVALUE *res); +extern void zredcdecode(REDC *rp, ZVALUE z1, ZVALUE *res); +extern void zredcmul(REDC *rp, ZVALUE z1, ZVALUE z2, ZVALUE *res); +extern void zredcsquare(REDC *rp, ZVALUE z1, ZVALUE *res); +extern void zredcpower(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 zisabstwo(z) ((*(z).v == 2) && ((z).len == 1)) +#define zisabsleone(z) ((*(z).v <= 1) && ((z).len == 1)) +#define zislezero(z) (zisneg(z) || ziszero(z)) +#define zisleone(z) (zisneg(z) || zisabsleone(z)) +#define zistiny(z) ((z).len == 1) + +/* + * zgtmaxfull(z) TRUE if abs(z) > MAXFULL + */ +#define zgtmaxfull(z) (((z).len > 2) || (((z).len == 2) && (((SHALF)(z).v[1]) < 0))) + +/* + * zgtmaxufull(z) TRUE if abs(z) will not fit into a FULL (> MAXUFULL) + */ +#define zgtmaxufull(z) ((z).len > 2) + +/* + * zgtmaxulong(z) TRUE if abs(z) > MAXULONG + */ +#if BASEB >= LONG_BITS +#define zgtmaxulong(z) ((z).len > 1) +#else +#define zgtmaxulong(z) zgtmaxufull(z) +#endif + +/* + * zgtmaxlong(z) TRUE if abs(z) > MAXLONG + */ +#if BASEB >= LONG_BITS +#define zgtmaxlong(z) (((z).len > 1) || (((z).len == 1) && (((SHALF)(z).v[0]) < 0))) +#else +#define zgtmaxlong(z) zgtmaxfull(z) +#endif + +/* + * Some algorithms testing for values of a certain length. Macros such as + * zistiny() do this well. In other cases algorthms require tests for values + * in comparison to a given power of 2. In the later case, zistiny() compares + * against a different power of 2 on a 64 bit machine. The macros below + * provide a tests against powers of 2 that are independent of the work size. + * + * zge16b(z) TRUE if abs(z) >= 2^16 + * zge24b(z) TRUE if abs(z) >= 2^24 + * zge31b(z) TRUE if abs(z) >= 2^31 + * zge32b(z) TRUE if abs(z) >= 2^32 + * zge64b(z) TRUE if abs(z) >= 2^64 + */ +#if BASEB == 32 + +#define zge16b(z) (!zistiny(z) || ((z).v[0] >= (HALF)0x10000)) +#define zge24b(z) (!zistiny(z) || ((z).v[0] >= (HALF)0x1000000)) +#define zge31b(z) (!zistiny(z) || (((SHALF)(z).v[0]) < 0)) +#define zge32b(z) (!zistiny(z)) +#define zge64b(z) ((z).len > 2) + +#else + +#define zge16b(z) (!zistiny(z)) +#define zge24b(z) (((z).len > 2) || (((z).len == 2) && ((z).v[1] >= (HALF)0x100))) +#define zge31b(z) (((z).len > 2) || (((z).len == 2) && (((SHALF)(z).v[1]) < 0))) +#define zge32b(z) ((z).len > 2) +#define zge64b(z) ((z).len > 4) + +#endif + + +/* + * ztofull - convert an absolute value of a ZVALUE to a FULL if possible + * + * If the value is too large, only the low order bits that are able to + * be converted into a FULL will be used. + */ +#define ztofull(z) (zistiny(z) ? ((FULL)((z).v[0])) : \ + ((FULL)((z).v[0]) + \ + ((FULL)((z).v[1]) << BASEB))) + +#define z1tol(z) ((long)((z).v[0])) +#define z2tol(z) ((long)(((z).v[0]) + \ + (((z).v[1] & MAXHALF) << BASEB))) + +/* + * ztoulong - convert an absolute value of a ZVALUE to an unsigned long + * + * If the value is too large, only the low order bits that are able to + * be converted into a long will be used. + */ +#if BASEB >= LONG_BITS +# define ztoulong(z) ((unsigned long)z1tol(z)) +#else +# define ztoulong(z) ((unsigned long)ztofull(z)) +#endif + +/* + * ztolong - convert an absolute value of a ZVALUE to a long + * + * If the value is too large, only the low order bits that are able to + * be converted into a long will be used. + */ +#define ztolong(z) ((long)(ztoulong(z) & MAXLONG)) + +#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(int ch); +extern void math_str(char *str); +extern void math_fill(char *str, long width); +extern void math_flush(void); +extern void math_divertio(void); +extern void math_cleardiversions(void); +extern void math_setfp(FILE *fp); +extern char *math_getdivertedio(void); +extern int math_setmode(int mode); +extern long math_setdigits(long digits); +extern void math_fmt(char *, ...); + + +/* + * The error routine. + */ +extern void math_error(char *, ...); + + +/* + * external swap functions + */ +extern HALF *swap_b8_in_HALFs(HALF *dest, HALF *src, LEN len); +extern ZVALUE *swap_b8_in_ZVALUE(ZVALUE *dest, ZVALUE *src, BOOL all); +extern HALF *swap_b16_in_HALFs(HALF *dest, HALF *src, LEN len); +extern ZVALUE *swap_b16_in_ZVALUE(ZVALUE *dest, ZVALUE *src, BOOL all); +extern ZVALUE *swap_HALF_in_ZVALUE(ZVALUE *dest, ZVALUE *src, BOOL all); + + +/* + * constants used often by the arithmetic routines + */ +extern HALF _zeroval_[], _oneval_[], _twoval_[], _threeval_[], _fourval_[]; +extern HALF _fiveval_[], _sixval_[], _sevenval_[], _eightval_[], _nineval_[]; +extern HALF _tenval_[], _elevenval_[], _twelveval_[], _thirteenval_[]; +extern HALF _fourteenval_[], _fifteenval_[]; +extern HALF _sqbaseval_[]; + +extern ZVALUE zconst[]; /* ZVALUE integers from 0 thru 15 */ + +extern ZVALUE _zero_, _one_, _two_, _ten_, _sqbase_; + +extern BOOL _math_abort_; /* nonzero to abort calculations */ +extern ZVALUE _tenpowers_[]; /* table of 10^2^n */ +extern HALF bitmask[]; /* bit rotation, norm 0 */ +extern HALF lowhalf[]; /* bit masks from low end of HALF */ +extern HALF highhalf[]; /* bit masks from high end of HALF */ + +#endif diff --git a/zmod.c b/zmod.c new file mode 100644 index 0000000..5c716ed --- /dev/null +++ b/zmod.c @@ -0,0 +1,2039 @@ +/* + * Copyright (c) 1996 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 "config.h" +#include "zmath.h" + + +#define POWBITS 4 /* bits for power chunks (must divide BASEB) */ +#define POWNUMS (1< z3.len)) { + zmod(tmp, z3, res, 0); + 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, 0); + 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. + * + * given: + * z1 number to be subtracted from + * z2 number to be subtracted + * z3 number to take mod with + * res result + */ +void +zsubmod(ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *res) +{ + if (ziszero(z3) || zisneg(z3)) { + math_error("Mod of non-positive integer"); + /*NOTREACHED*/ + } + if (ziszero(z2)) { + zmod(z1, z3, res, 0); + 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. + * + * given: + * z1 number to take negative of + * z2 number to take mod with + * res result + */ +static void +znegmod(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + int sign; + int cv; + + if (ziszero(z2) || zisneg(z2)) { + math_error("Mod of non-positive integer"); + /*NOTREACHED*/ + } + 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, 0); +} +#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]. + * + * given: + * z1 number to find minimum congruence of + * z2 number to take mod with + * res result + */ +void +zminmod(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + ZVALUE tmp1, tmp2; + int sign; + int cv; + + if (ziszero(z2) || zisneg(z2)) { + math_error("Mod of non-positive integer"); + /*NOTREACHED*/ + } + 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, 0); + 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. + * + * given: + * z1 first number to be compared + * z2 second number to be compared + * z3 modulus + */ +BOOL +zcmpmod(ZVALUE z1, ZVALUE z2, ZVALUE z3) +{ + ZVALUE tmp1, tmp2, tmp3; + FULL digit; + LEN len; + int cv; + + if (zisneg(z3) || ziszero(z3)) { + math_error("Non-positive modulus in zcmpmod"); + /*NOTREACHED*/ + } + 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, 0); + zfree(tmp3); + if (ziszero(tmp1)) { + zfree(tmp1); + return FALSE; + } else { + zfree(tmp1); + return TRUE; + } +} + + +/* + * Given the address of a positive integer whose word count does not + * exceed twice that of the modulus stored at lastmod, to evaluate and store + * at that address the value of the integer modulo the modulus. + */ +static void +zmod5(ZVALUE *zp) +{ + LEN len, modlen, j; + ZVALUE tmp1, tmp2; + ZVALUE z1, z2, z3; + HALF *a, *b; + FULL f; + HALF u; + + int subcount = 0; + + if (zrel(*zp, *lastmod) < 0) + return; + modlen = lastmod->len; + len = zp->len; + z1.v = zp->v + modlen - 1; + z1.len = len - modlen + 1; + z1.sign = z2.sign = z3.sign = 0; + if (z1.len > modlen + 1) { + math_error("Bad call to zmod5!!!"); + /*NOTREACHED*/ + } + z2.v = lastmodinv->v + modlen + 1 - z1.len; + z2.len = lastmodinv->len - modlen - 1 + z1.len; + zmul(z1, z2, &tmp1); + z3.v = tmp1.v + z1.len; + z3.len = tmp1.len - z1.len; + if (z3.len > 0) { + zmul(z3, *lastmod, &tmp2); + j = modlen; + a = zp->v; + b = tmp2.v; + u = 0; + len = modlen; + while (j-- > 0) { + f = (FULL) *a - (FULL) *b++ - (FULL) u; + *a++ = (HALF) f; + u = - (HALF) (f >> BASEB); + } + if (z1.len > 1) { + len++; + if (tmp2.len > modlen) + f = (FULL) *a - (FULL) *b - (FULL) u; + else + f = (FULL) *a - (FULL) u; + *a++ = (HALF) f; + } + while (len > 0 && *--a == 0) + len--; + zp->len = len; + zfree(tmp2); + } + zfree(tmp1); + while (len > 0 && zrel(*zp, *lastmod) >= 0) { + subcount++; + if (subcount > 2) { + math_error("Too many subtractions in zmod5"); + /*NOTREACHED*/ + } + j = modlen; + a = zp->v; + b = lastmod->v; + u = 0; + while (j-- > 0) { + f = (FULL) *a - (FULL) *b++ - (FULL) u; + *a++ = (HALF) f; + u = - (HALF) (f >> BASEB); + } + if (len > modlen) { + f = (FULL) *a - (FULL) u; + *a++ = (HALF) f; + } + while (len > 0 && *--a == 0) + len--; + zp->len = len; + } + if (len == 0) + zp->len = 1; +} + +static void +zmod6(ZVALUE z1, ZVALUE *res) +{ + LEN len, modlen, len0; + int sign; + ZVALUE zp0, ztmp; + + if (ziszero(z1) || zisone(*lastmod)) { + *res = _zero_; + return; + } + sign = z1.sign; + z1.sign = 0; + zcopy(z1, &ztmp); + modlen = lastmod->len; + zp0.sign = 0; + while (zrel(ztmp, *lastmod) >= 0) { + len = ztmp.len; + zp0.len = len; + len0 = 0; + if (len > 2 * modlen) { + zp0.len = 2 * modlen; + len0 = len - 2 * modlen; + } + zp0.v = ztmp.v + len - zp0.len; + zmod5(&zp0); + len = len0 + zp0.len; + while (len > 0 && ztmp.v[len - 1] == 0) + len--; + if (len == 0) { + zfree(ztmp); + *res = _zero_; + return; + } + ztmp.len = len; + } + if (sign) + zsub(*lastmod, ztmp, res); + else + zcopy(ztmp, res); + zfree(ztmp); +} + + + +/* + * 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(ZVALUE z1, ZVALUE z2, ZVALUE z3, ZVALUE *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 */ + ZVALUE ztmp; + 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"); + /*NOTREACHED*/ + } + if (zisneg(z2)) { + math_error("Negative power in zpowermod"); + /*NOTREACHED*/ + } + + + /* + * 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) && (!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. + */ + ztmp.len = 0; + if (zisneg(z1) || zrel(z1, z3) >= 0) { + zmod(z1, z3, &ztmp, 0); + z1 = ztmp; + } + if (ziszero(z1)) { + if (ztmp.len) + zfree(ztmp); + *res = _zero_; + return; + } + if (zisone(z1) && ziseven(z2)) { + if (ztmp.len) + zfree(ztmp); + zfree(z1); + *res = _one_; + return; + } + + /* + * If modulus is large enough use zmod5 + */ + if (z3.len >= conf->pow2) + { + if (havelastmod && zcmp(z3, *lastmod)) { + zfree(*lastmod); + zfree(*lastmodinv); + havelastmod = FALSE; + } + if (!havelastmod) { + zcopy(z3, lastmod); + zbitvalue(2 * z3.len * BASEB, &temp); + zquo(temp, z3, lastmodinv, 0); + zfree(temp); + havelastmod = TRUE; + } + + /* zzz */ + for (pp = &lowpowers[2]; pp < &lowpowers[POWNUMS]; pp++) { + pp->len = 0; + pp->v = NULL; + } + 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->v == NULL) { + if (curpow & 0x1) + zcopy(z1, &modpow); + else + modpow = _one_; + + for (curbit = 0x2; curbit <= curpow; curbit *= 2) { + pp = &lowpowers[curbit]; + if (pp->v == NULL) { + zsquare(lowpowers[curbit/2], &temp); + zmod5(&temp); + zcopy(temp, pp); + zfree(temp); + } + if (curbit & curpow) { + zmul(*pp, modpow, &temp); + zfree(modpow); + zmod5(&temp); + zcopy(temp, &modpow); + zfree(temp); + } + } + pp = &lowpowers[curpow]; + if (pp->v != NULL) { + zfree(*pp); + } + *pp = modpow; + } + + /* + * If the power is nonzero, then accumulate the small power + * into the result. + */ + if (curpow) { + zmul(ans, *pp, &temp); + zfree(ans); + zmod5(&temp); + zcopy(temp, &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); + zmod5(&temp); + zcopy(temp, &ans); + zfree(temp); + } + } + + for (pp = &lowpowers[2]; pp < &lowpowers[POWNUMS]; pp++) { + if (pp->v != NULL) + freeh(pp->v); + } + *res = ans; + if (ztmp.len) + zfree(ztmp); + return; + } + + /* + * If the modulus is odd and small enough then use + * the REDC algorithm. The size where this is done is configurable. + */ + if (z3.len < conf->redc2 && zisodd(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; + pp->v = NULL; + } + 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->v == NULL) { + if (curpow & 0x1) + zcopy(z1, &modpow); + else + modpow = _one_; + + for (curbit = 0x2; curbit <= curpow; curbit *= 2) { + pp = &lowpowers[curbit]; + if (pp->v == NULL) { + zsquare(lowpowers[curbit/2], &temp); + zmod(temp, z3, pp, 0); + zfree(temp); + } + if (curbit & curpow) { + zmul(*pp, modpow, &temp); + zfree(modpow); + zmod(temp, z3, &modpow, 0); + zfree(temp); + } + } + pp = &lowpowers[curpow]; + if (pp->v != NULL) { + zfree(*pp); + } + *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, 0); + 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, 0); + zfree(temp); + } + } + + for (pp = &lowpowers[2]; pp < &lowpowers[POWNUMS]; pp++) { + if (pp->v != NULL) + freeh(pp->v); + } + *res = ans; + if (ztmp.len) + zfree(ztmp); +} + +/* + * Given a positive odd N-word integer z, evaluate minv(-z, BASEB^N) + */ +static void +zredcmodinv(ZVALUE z, ZVALUE *res) +{ + ZVALUE tmp; + HALF *a0, *a, *b; + HALF bit, h, inv, v; + FULL f; + LEN N, i, j, len; + + N = z.len; + tmp.sign = 0; + tmp.len = N; + tmp.v = alloc(N); + zclearval(tmp); + *tmp.v = 1; + h = 1 + *z.v; + bit = 1; + inv = 1; + while (h) { + bit <<= 1; + if (bit & h) { + inv |= bit; + h += bit * *z.v; + } + } + + j = N; + a0 = tmp.v; + while (j-- > 0) { + v = inv * *a0; + i = j; + a = a0; + b = z.v; + f = (FULL) v * (FULL) *b++ + (FULL) *a++; + *a0 = v; + while (i-- > 0) { + f = (FULL) v * (FULL) *b++ + (FULL) *a + (f >> BASEB); + *a++ = (HALF) f; + } + while (j > 0 && *++a0 == 0) + j--; + } + a = tmp.v + N; + len = N; + while (*--a == 0) + len--; + tmp.len = len; + zcopy(tmp, res); + zfree(tmp); +} + + +/* + * 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. + * + * given: + * z1 modulus to initialize for + */ +REDC * +zredcalloc(ZVALUE z1) +{ + REDC *rp; /* REDC information */ + ZVALUE tmp; + long bit; + + if (ziseven(z1) || zisneg(z1)) { + math_error("REDC requires positive odd modulus"); + /*NOTREACHED*/ + } + + rp = (REDC *) malloc(sizeof(REDC)); + if (rp == NULL) { + math_error("Cannot allocate REDC structure"); + /*NOTREACHED*/ + } + + /* + * 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. + */ + zcopy(z1, &rp->mod); + zredcmodinv(z1, &rp->inv); + bit = zhighbit(z1) + 1; + if (bit % BASEB) + bit += (BASEB - (bit % BASEB)); + zbitvalue(bit, &tmp); + zmod(tmp, rp->mod, &rp->one, 0); + zfree(tmp); + rp->len = (LEN)(bit / BASEB); + return rp; +} + + +/* + * Free any numbers associated with the specified REDC structure, + * and then the REDC structure itself. + * + * given: + * rp REDC information to be cleared + */ +void +zredcfree(REDC *rp) +{ + 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. + * + * given: + * rp REDC information + * z1 number to be converted + * res returned converted number + */ +void +zredcencode(REDC *rp, ZVALUE z1, ZVALUE *res) +{ + ZVALUE tmp1; + + /* + * Confirm or initialize lastmod information when modulus is a + * big number. + */ + + if (rp->len >= conf->pow2) { + if (havelastmod && zcmp(rp->mod, *lastmod)) { + zfree(*lastmod); + zfree(*lastmodinv); + havelastmod = FALSE; + } + if (!havelastmod) { + zcopy(rp->mod, lastmod); + zbitvalue(2 * rp->len * BASEB, &tmp1); + zquo(tmp1, rp->mod, lastmodinv, 0); + zfree(tmp1); + havelastmod = TRUE; + } + } + /* + * 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. + */ + zshift(z1, rp->len * BASEB, &tmp1); + if (rp->len < conf->pow2) + zmod(tmp1, rp->mod, res, 0); + else + zmod6(tmp1, res); + zfree(tmp1); +} + + +/* + * 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. + * + * given: + * rp REDC information + * z1 number to be transformed + * res returned transformed number + */ +void +zredcdecode(REDC *rp, ZVALUE z1, ZVALUE *res) +{ + ZVALUE tmp1, tmp2; + ZVALUE ztmp; + ZVALUE ztop; + ZVALUE zp1; + FULL muln; + HALF *h1; + HALF *h3; + HALF *hd = NULL; + HALF Ninv; + LEN modlen; + LEN len; + FULL f; + int sign; + int i, j; + + /* + * 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; + } + ztop.len = 0; + ztmp.len = 0; + modlen = rp->len; + sign = z1.sign; + z1.sign = 0; + if (z1.len > modlen) { + ztop.v = z1.v + modlen; + ztop.len = z1.len - modlen; + ztop.sign = 0; + if (zrel(ztop, rp->mod) >= 0) { + zmod(ztop, rp->mod, &ztmp, 0); + ztop = ztmp; + } + len = modlen; + h1 = z1.v + len; + while (len > 0 && *--h1 == 0) + len--; + if (len == 0) { + if (ztmp.len) + *res = ztmp; + else + zcopy(ztop, res); + return; + } + z1.len = len; + + } + if (rp->mod.len < conf->pow2) { + Ninv = rp->inv.v[0]; + res->sign = 0; + res->len = modlen; + res->v = alloc(modlen); + zclearval(*res); + h1 = z1.v; + for (i = 0; i < modlen; i++) { + h3 = rp->mod.v; + hd = res->v; + f = (FULL) *hd++; + if (i < z1.len) + f += (FULL) *h1++; + muln = (HALF) ((f & BASE1) * Ninv); + f = ((muln * (FULL) *h3++) + f) >> BASEB; + j = modlen; + while (--j > 0) { + f += (muln * (FULL) *h3++) + (FULL) *hd; + hd[-1] = (HALF) f; + f >>= BASEB; + hd++; + } + hd[-1] = (HALF) f; + } + len = modlen; + while (*--hd == 0 && len > 1) + len--; + if (len == 0) + len = 1; + res->len = len; + } + else { + /* Here 0 < z1 < 2^bitnum */ + + /* + * First calculate the following: + * tmp2 = ((z1 * 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. + */ + zmul(z1, rp->inv, &tmp2); + if (tmp2.len > modlen) { + h1 = tmp2.v + modlen; + len = modlen; + while (len > 0 && *--h1 == 0) + len--; + tmp2.len = len; + } + + /* + * Next calculate the following: + * res = (z1 + tmp2 * modulus) / 2^bitnum + * Since 0 < z1 < 2^bitnum and the division is always exact, + * the quotient can be evaluated by rounding up + * (tmp2 * modulus)/2^bitnum. This can be achieved by defining + * zp1 by an appropriate shift and then adding one. + */ + zmul(tmp2, rp->mod, &tmp1); + zfree(tmp2); + if (tmp1.len > modlen) { + zp1.v = tmp1.v + modlen; + zp1.len = tmp1.len - modlen; + zp1.sign = 0; + zadd(zp1, _one_, res); + } + else + *res = _one_; + zfree(tmp1); + } + if (ztop.len) { + zadd(*res, ztop, &tmp1); + zfree(*res); + if (ztmp.len) + zfree(ztmp); + *res = tmp1; + } + + /* + * 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(*res, rp->mod) >= 0) { + zsub(*res, rp->mod, &tmp1); + zfree(*res); + *res = tmp1; + } + if (sign && !ziszero(*res)) { + zsub(rp->mod, *res, &tmp1); + zfree(*res); + *res = tmp1; + } + return; +} + + +/* + * 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. + * + * given: + * rp REDC information + * z1 first REDC number to be multiplied + * z2 second REDC number to be multiplied + * res resulting REDC number + */ +void +zredcmul(REDC *rp, ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + 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 carry; + ZVALUE tmp; + ZVALUE z1tmp, z2tmp; + int sign; + + sign = z1.sign ^ z2.sign;; + z1.sign = 0; + z2.sign = 0; + z1tmp.len = 0; + if (zrel(z1, rp->mod) >= 0) { + zmod(z1, rp->mod, &z1tmp, 0); + z1 = z1tmp; + } + z2tmp.len = 0; + if (zrel(z2, rp->mod) >= 0) { + zmod(z2, rp->mod, &z2tmp, 0); + z2 = z2tmp; + } + + + /* + * Check for special values which we easily know the answer. + */ + if (ziszero(z1) || ziszero(z2)) { + *res = _zero_; + if (z1tmp.len) + zfree(z1tmp); + if (z2tmp.len) + zfree(z2tmp); + return; + } + + if ((z1.len == rp->one.len) && (z1.v[0] == rp->one.v[0]) && + (zcmp(z1, rp->one) == 0)) { + if (sign) + zsub(rp->mod, z2, res); + else + zcopy(z2, res); + if (z1tmp.len) + zfree(z1tmp); + if (z2tmp.len) + zfree(z2tmp); + return; + } + + if ((z2.len == rp->one.len) && (z2.v[0] == rp->one.v[0]) && + (zcmp(z2, rp->one) == 0)) { + if (sign) + zsub(rp->mod, z1, res); + else + zcopy(z1, res); + if (z1tmp.len) + zfree(z1tmp); + if (z2tmp.len) + zfree(z2tmp); + 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 >= conf->redc2) { + zmul(z1, z2, &tmp); + zredcdecode(rp, tmp, res); + zfree(tmp); + if (sign && !ziszero(*res)) { + zsub(rp->mod, *res, &tmp); + zfree(*res); + *res = tmp; + } + if (z1tmp.len) + zfree(z1tmp); + if (z2tmp.len) + zfree(z2tmp); + 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++) + ((FULL) sival1.silow); + carry.ivalue = ((FULL) sival1.sihigh) + ((FULL) sival2.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++) + + ((FULL) *hd) + ((FULL) carry.silow); + sival2.ivalue = muln * ((FULL) *h3++) + + ((FULL) sival1.silow); + carry.ivalue = ((FULL) sival1.sihigh) + + ((FULL) sival2.sihigh) + + ((FULL) carry.sihigh); + + hd[-1] = sival2.silow; + hd++; + } + + /* + * Now continue the loop as necessary so the total number + * of iterations 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++) + + ((FULL) *hd) + + ((FULL) carry.silow); + carry.ivalue = ((FULL) sival2.sihigh) + + ((FULL) carry.sihigh); + + hd[-1] = sival2.silow; + hd++; + } + + carry.ivalue += topdigit; + hd[-1] = carry.silow; + topdigit = carry.sihigh; + } + + /* + * Now continue the loop as necessary so the total number + * of iterations 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++) + (FULL) *hd++; + carry.ivalue = ((FULL) sival2.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++) + + ((FULL) *hd) + ((FULL) carry.silow); + carry.ivalue = ((FULL) sival2.sihigh) + + ((FULL) carry.sihigh); + + hd[-1] = sival2.silow; + hd++; + } + carry.ivalue += topdigit; + hd[-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; + while (*--hd == 0 && len > 1) { + len--; + } + res->len = len; + + /* + * Compare the result with the modulus. + * If it is less than the modulus, then the calculation is complete. + */ + + if (zrel(*res, rp->mod) < 0) { + if (z1tmp.len) + zfree(z1tmp); + if (z2tmp.len) + zfree(z2tmp); + if (sign && !ziszero(*res)) { + zsub(rp->mod, *res, &tmp); + zfree(*res); + *res = tmp; + } + 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++ = (HALF)(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; + if (z1tmp.len) + zfree(z1tmp); + if (z2tmp.len) + zfree(z2tmp); + if (sign && !ziszero(*res)) { + zsub(rp->mod, *res, &tmp); + zfree(*res); + *res = tmp; + } + +} + +/* + * Square a number in REDC format producing a result also in REDC format. + * + * given: + * rp REDC information + * z1 REDC number to be squared + * res resulting REDC number + */ +void +zredcsquare(REDC *rp, ZVALUE z1, ZVALUE *res) +{ + FULL mulb; + FULL muln; + HALF *h1; + HALF *h2; + HALF *h3; + HALF *hd = NULL; + HALF Ninv; + HALF topdigit = 0; + LEN modlen; + LEN len; + SIUNION sival1; + SIUNION sival2; + SIUNION sival3; + SIUNION carry; + ZVALUE tmp, ztmp; + FULL f; + int i, j; + + ztmp.len = 0; + z1.sign = 0; + if (zrel(z1, rp->mod) >= 0) { + zmod(z1, rp->mod, &ztmp, 0); + z1 = ztmp; + } + if (ziszero(z1)) { + *res = _zero_; + if (ztmp.len) + zfree(ztmp); + return; + } + if ((z1.len == rp->one.len) && (z1.v[0] == rp->one.v[0]) && + (zcmp(z1, rp->one) == 0)) { + zcopy(z1, res); + if (ztmp.len) + zfree(ztmp); + 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 >= conf->redc2 + || 3 * z1.len < 2 * rp->mod.len) { + zsquare(z1, &tmp); + zredcdecode(rp, tmp, res); + zfree(tmp); + if (ztmp.len) + zfree(ztmp); + return; + } + modlen = rp->mod.len; + Ninv = rp->inv.v[0]; + + res->sign = 0; + res->len = modlen; + res->v = alloc(modlen); + + zclearval(*res); + + h1 = z1.v; + + for (i = 0; i < z1.len; i++) { + mulb = (FULL) *h1++; + h2 = h1; + h3 = rp->mod.v; + hd = res->v; + if (i == 0) { + sival1.ivalue = mulb * mulb; + muln = (HALF) (sival1.silow * Ninv); + sival2.ivalue = muln * ((FULL) *h3++) + + (FULL) sival1.silow; + carry.ivalue = (FULL) sival1.sihigh + + (FULL) sival2.sihigh; + hd++; + } + else { + muln = (HALF) (*hd * Ninv); + f = (muln * ((FULL) *h3++) + (FULL) *hd++) >> BASEB; + j = i; + while (--j > 0) { + f += muln * ((FULL) *h3++) + *hd; + hd[-1] = (HALF) f; + f >>= BASEB; + hd++; + } + carry.ivalue = f; + sival1.ivalue = mulb * mulb + (FULL) carry.silow; + sival2.ivalue = muln * ((FULL) *h3++) + + (FULL) *hd + + (FULL) sival1.silow; + carry.ivalue = (FULL) sival1.sihigh + + (FULL) sival2.sihigh + + (FULL) carry.sihigh; + hd[-1] = sival2.silow; + hd++; + } + j = z1.len - i; + while (--j > 0) { + sival1.ivalue = mulb * ((FULL) *h2++); + sival2.ivalue = ((FULL) sival1.silow << 1) + + muln * ((FULL) *h3++); + sival3.ivalue = (FULL) sival2.silow + + (FULL) *hd + + (FULL) carry.silow; + carry.ivalue = ((FULL) sival1.sihigh << 1) + + (FULL) sival2.sihigh + + (FULL) sival3.sihigh + + (FULL) carry.sihigh; + hd[-1] = sival3.silow; + hd++; + } + j = modlen - z1.len; + while (j-- > 0) { + sival1.ivalue = muln * ((FULL) *h3++) + + (FULL) *hd + + (FULL) carry.silow; + carry.ivalue = (FULL) sival1.sihigh + + (FULL) carry.sihigh; + hd[-1] = sival1.silow; + hd++; + } + carry.ivalue += (FULL) topdigit; + hd[-1] = carry.silow; + topdigit = carry.sihigh; + } + i = modlen - z1.len; + while (i-- > 0) { + h3 = rp->mod.v; + hd = res->v; + muln = (HALF) (*hd * Ninv); + sival1.ivalue = muln * ((FULL) *h3++) + (FULL) *hd++; + carry.ivalue = (FULL) sival1.sihigh; + j = modlen; + while (--j > 0) { + sival1.ivalue = muln * ((FULL) *h3++) + + (FULL) *hd + + (FULL) carry.silow; + carry.ivalue = (FULL) sival1.sihigh + + (FULL) carry.sihigh; + hd[-1] = sival1.silow; + hd++; + } + carry.ivalue += (FULL) topdigit; + hd[-1] = carry.silow; + topdigit = carry.sihigh; + } + if (topdigit == 0) { + len = modlen; + while (*--hd == 0 && len > 1) { + len--; + } + res->len = len; + if (zrel(*res, rp->mod) < 0) { + if (ztmp.len) + zfree(ztmp); + return; + } + } + + 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++ = (HALF)(BASE1 - carry.silow); + carry.silow = carry.sihigh; + } + + len = modlen; + hd = &res->v[len - 1]; + while ((*hd == 0) && (len > 1)) { + hd--; + len--; + } + res->len = len; + if (ztmp.len) + zfree(ztmp); +} + + +/* + * 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. + * + * given: + * rp REDC information + * z1 REDC number to be raised + * z2 normal number to raise number to + * res result + */ +void +zredcpower(REDC *rp, ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + HALF *hp; /* pointer to current word of the power */ + ZVALUE *pp; /* pointer to low power table */ + ZVALUE ans, temp; /* calculation values */ + ZVALUE ztmp; + 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 sign; + int i; + + if (zisneg(z2)) { + math_error("Negative power in zredcpower"); + /*NOTREACHED*/ + } + + if (zisunit(rp->mod)) { + *res = _zero_; + return; + } + + sign = zisodd(z2) ? z1.sign : 0; + z1.sign = 0; + ztmp.len = 0; + if (zrel(z1, rp->mod) >= 0) { + zmod(z1, rp->mod, &ztmp, 0); + z1 = ztmp; + } + /* + * Check for zero or the REDC format for one. + */ + if (ziszero(z1)) { + if (ziszero(z2)) + *res = _one_; + else + *res = _zero_; + if (ztmp.len) + zfree(ztmp); + return; + } + if (zcmp(z1, rp->one) == 0) { + if (sign) + zsub(rp->mod, rp->one, res); + else + zcopy(rp->one, res); + if (ztmp.len) + zfree(ztmp); + 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) ^ sign) { + *res = temp; + if (ztmp.len) + zfree(ztmp); + return; + } + zfree(temp); + zcopy(rp->one, res); + if (ztmp.len) + zfree(ztmp); + 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); + } + if (sign && !ziszero(ans)) { + zsub(rp->mod, ans, res); + zfree(ans); + } + else + *res = ans; + if (ztmp.len) + zfree(ztmp); +} + +/* END CODE */ diff --git a/zmul.c b/zmul.c new file mode 100644 index 0000000..fa3fd3c --- /dev/null +++ b/zmul.c @@ -0,0 +1,1097 @@ +/* + * Copyright (c) 1995 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 "config.h" +#include "zmath.h" + + +static HALF *tempbuf; /* temporary buffer for multiply and square */ + +static LEN domul(HALF *v1, LEN size1, HALF *v2, LEN size2, HALF *ans); +static LEN dosquare(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. + * + * given: + * z1 numbers to multiply + * z2 numbers to multiply + * res result of multiplication + */ +void +zmul(ZVALUE z1, ZVALUE z2, ZVALUE *res) +{ + 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 + 2); + 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. + * + * given: + * v1 first number + * size1 size of first number + * v2 second number + * size2 size of second number + * ans location for result + */ +static LEN +domul(HALF *v1, LEN size1, HALF *v2, LEN size2, HALF *ans) +{ + 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 < conf->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; + /* ignore Saber-C warning #112 - get ushort from uint */ + /* ok to ignore on name domul`sival */ + *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; + /* + * 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. + * + * This warning may be triggered by executing the following code: + * + * a = 0xffff0000ffffffff00000000ffff0000000000000000ffff; + * config("mul2", 2); + * pmod(3,a-1,a); + * + * When this code is executed, shift == 6 and v2 is 3 shorts + * long (size2 == 2). This baseC points 3 shorts beyond the + * allocated end of v2. + * + * The stack was as follows: + * + * domul(v1=0x2d93d8, size1=12, + * v2=0x2ded30, size2=2, ans=0x2ee8a8) at "zmul.c":313 + * zmul(z1=0x2ee928, z2=0x2ee92c, res=0x16d8c0) at "zmul.c":73 + * zpowermod(z1=0x2ee828, z2=0x2ee82c, + * z3=0x2ee830, res=0x57bfe4) at "zmod.c":666 + * qpowermod(q1=0x57bf90, q2=0x57bfc8, q3=0x57bf3c) at "qfunc.c":78 + * builtinfunc(...) at "func.c":400 + * o_call(...) at "opcodes.c":2094 + * calculate(...) at "opcodes.c":288 + * evaluate(...) at "codegen.c":170 + * getcommands(...) at "codegen.c":109 + * main(...) at "calc.c":167 + */ + /* ok to ignore on name domul`baseC */ + 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++ = (HALF)(BASE1 - sival.silow); + carry = sival.sihigh; + } + while (copysize--) { + sival.ivalue = (BASE1 - ((FULL) *h1++)) + carry; + *hd++ = (HALF)(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++ = (HALF)(BASE1 - sival.silow); + carry = sival.sihigh; + } + while (copysize--) { + sival.ivalue = (BASE1 - ((FULL) *h1++)) + carry; + *hd++ = (HALF)(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++ = (HALF)(BASE1 - sival.silow); + carry = sival.sihigh; + } + while (carry) { + sival.ivalue = BASE1 - ((FULL) *hd) + carry; + *hd++ = (HALF)(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(ZVALUE z, ZVALUE *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+2) * 2); + /* + * Without the memset below, Purify reports that dosquare() + * will read uninitialized memory at the dosquare() line below + * the comment: + * + * uninitialized memory read (see zsquare) + * + * This problem occurs during regression test #622 and may + * be duplicated by executing: + * + * config("sq2", 2); + * 0xffff0000ffffffff00000000ffff0000000000000000ffff^2; + */ + memset((char *)res->v, 0, ((z.len+2) * 2)*sizeof(HALF)); + 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. + * + * given: + * vp value to be squared + * size length of value to square + * ans location for result + */ +static LEN +dosquare(HALF *vp, LEN size, HALF *ans) +{ + 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 < conf->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; + /* ignore Saber-C warning #112 - get ushort from uint */ + /* ok to ignore on name dosquare`sival */ + *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) { + /* uninitialized memory read (see zsquare) */ + 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++ = (HALF)(BASE1 - sival.silow); + carry = sival.sihigh; + } + while (copysize--) { + sival.ivalue = (BASE1 - ((FULL) *h1++)) + carry; + *hd++ = (HALF)(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++ = (HALF)(BASE1 - sival.silow); + carry = sival.sihigh; + } + while (carry) { + sival.ivalue = BASE1 - ((FULL) *hd) + carry; + *hd++ = (HALF)(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. + * + * given: + * len required number of HALFs in buffer + */ +HALF * +zalloctemp(LEN len) +{ + 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); + } + /* don't call alloc() because _math_abort_ may not be set right */ + hp = (HALF *) malloc((len+1) * sizeof(HALF)); + if (hp == NULL) { + math_error("No memory for temp buffer"); + /*NOTREACHED*/ + } + bufptr = hp; + buflen = len; + return hp; +} + +/* END CODE */ diff --git a/zprime.c b/zprime.c new file mode 100644 index 0000000..1d61510 --- /dev/null +++ b/zprime.c @@ -0,0 +1,1616 @@ +/* + * Copyright (c) 1996 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 "zmath.h" +#include "prime.h" +#include "jump.h" +#include "config.h" +#include "zrand.h" +#include "have_const.h" + + +/* + * When performing a probabilistic primality test, check to see + * if the number has a factor <= PTEST_PRECHECK. + * + * XXX - what should this value be? Perhaps this should be a function + * of the size of the text value and the number of tests? + */ +#define PTEST_PRECHECK ((FULL)101) + +/* + * product of primes that fit into a long + */ +static CONST FULL pfact_tbl[MAX_PFACT_VAL+1] = { + 1, 1, 2, 6, 6, 30, 30, 210, 210, 210, 210, 2310, 2310, 30030, 30030, + 30030, 30030, 510510, 510510, 9699690, 9699690, 9699690, 9699690, + 223092870, 223092870, 223092870, 223092870, 223092870, 223092870 +#if FULL_BITS == 64 + , U(6469693230), U(6469693230), U(200560490130), U(200560490130), + U(200560490130), U(200560490130), U(200560490130), U(200560490130), + U(7420738134810), U(7420738134810), U(7420738134810), U(7420738134810), + U(304250263527210), U(304250263527210), U(13082761331670030), + U(13082761331670030), U(13082761331670030), U(13082761331670030), + U(614889782588491410), U(614889782588491410), U(614889782588491410), + U(614889782588491410), U(614889782588491410), U(614889782588491410) +#endif +}; + +/* + * determine the top 1 bit of a 8 bit value: + * + * topbit[0] == 0 by convention + * topbit[x] gives the highest 1 bit of x + */ +static CONST unsigned char topbit[256] = { + 0, 0, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7 +}; + +/* + * integer square roots of powers of 2 + * + * isqrt_pow2[x] == (int)(sqrt(2 to the x power)) (for 0 <= x < 64) + * + * We have enough table entries for a FULL that is 64 bits long. + */ +static CONST FULL isqrt_pow2[64] = { + 1, 1, 2, 2, 4, 5, 8, 11, /* 0 .. 7 */ + 16, 22, 32, 45, 64, 90, 128, 181, /* 8 .. 15 */ + 256, 362, 512, 724, 1024, 1448, 2048, 2896, /* 16 .. 23 */ + 4096, 5792, 8192, 11585, 16384, 23170, 32768, 46340, /* 24 .. 31 */ + 65536, 92681, 131072, 185363, /* 32 .. 35 */ + 262144, 370727, 524288, 741455, /* 36 .. 39 */ + 1048576, 1482910, 2097152, 2965820, /* 40 .. 43 */ + 4194304, 5931641, 8388608, 11863283, /* 44 .. 47 */ + 16777216, 23726566, 33554432, 47453132, /* 48 .. 51 */ + 67108864, 94906265, 134217728, 189812531, /* 52 .. 55 */ + 268435456, 379625062, 536870912, 759250124, /* 56 .. 59 */ + 1073741824, 1518500249, 0x80000000, 0xb504f333 /* 60 .. 63 */ +}; + +/* + * static functions + */ +static FULL fsqrt(FULL v); /* quick square root of v */ +static long pix(FULL x); /* pi of x */ +static FULL small_factor(ZVALUE n, FULL limit); /* factor or 0 */ + + +/* + * Determine if a value is a small (32 bit) prime + * + * Returns: + * 1 z is a prime <= MAX_SM_VAL + * 0 z is not a prime <= MAX_SM_VAL + * -1 z > MAX_SM_VAL + */ +FLAG +zisprime(ZVALUE z) +{ + FULL n; /* number to test */ + FULL isqr; /* factor limit */ + CONST unsigned short *tp; /* pointer to a prime factor */ + + z.sign = 0; + if (zisleone(z)) { + return 0; + } + + /* even numbers > 2 are not prime */ + if (ziseven(z)) { + /* + * "2 is the greatest odd prime because it is the least even!" + * - Dr. Dan Jurca 1978 + */ + return zisabstwo(z); + } + + /* ignore non-small values */ + if (zge32b(z)) { + return -1; + } + + /* we now know that we are dealing with a value 0 <= n < 2^32 */ + n = ztofull(z); + + /* lookup small cases in pr_map */ + if (n <= MAX_MAP_VAL) { + return (pr_map_bit(n) ? 1 : 0); + } + + /* ignore Saber-C warning #530 about empty for statement */ + /* ok to ignore in proc zisprime */ + /* a number >=2^16 and < 2^32 */ + for (isqr=fsqrt(n), tp=prime; (*tp <= isqr) && (n % *tp); ++tp) { + } + return ((*tp <= isqr && *tp != 1) ? 0 : 1); +} + + +/* + * Determine the next small (32 bit) prime > a 32 bit value. + * + * given: + * z search point + * + * Returns: + * 0 next prime is 2^32+15 + * 1 abs(z) >= 2^32 + * smallest prime > abs(z) otherwise + */ +FULL +znprime(ZVALUE z) +{ + FULL n; /* search point */ + + z.sign = 0; + + /* ignore large values */ + if (zge32b(z)) { + return (FULL)1; + } + + /* deal a search point of 0 or 1 */ + if (zisabsleone(z)) { + return (FULL)2; + } + + /* deal with returning a value that is beyond our reach */ + n = ztofull(z); + if (n >= MAX_SM_PRIME) { + return (FULL)0; + } + + /* return the next prime */ + return next_prime(n); +} + + +/* + * Compute the next prime beyond a small (32 bit) value. + * + * This function assumes that 2 <= n < 2^32-5. + * + * given: + * n search point + */ +FULL +next_prime(FULL n) +{ + CONST unsigned short *tp; /* pointer to a prime factor */ + CONST unsigned char *j; /* current jump increment */ + int tmp; + + /* find our search point */ + n = ((n & 0x1) ? n+2 : n+1); + + /* if we can just search the bit map, then search it */ + if (n <= MAX_MAP_PRIME) { + + /* search until we find a 1 bit */ + while (pr_map_bit(n) == 0) { + n += (FULL)2; + } + + /* too large for our table, find the next prime the hard way */ + } else { + FULL isqr; /* factor limit */ + + /* + * Our search for a prime may cause us to increment n over + * a perfect square, but never two perfect squares. The largest + * prime gap <= 2614941711251 is 651. Shanks conjectures that + * the largest gap below P is about ln(P)^2. + * + * The value fsqrt(n)^2 will always be the perfect square + * that is <= n. Given the smallness of prime gaps we will + * deal with, we know that n could carry us across the next + * perfect square (fsqrt(n)+1)^2 but not the following + * perfect square (fsqrt(n)+2)^2. + * + * Now the factor search limit for values < (fsqrt(n)+2)^2 + * is the same limit for (fsqrt(n)+1)^2; namely fsqrt(n)+1. + * Therefore setting our limit at fsqrt(n)+1 and never + * bothering with it after that is safe. + */ + isqr = fsqrt(n)+1; + + /* + * If our factor limit is even, then we can reduce it to + * the next lowest odd value. We already tested if n + * was even and all of our remaining potential factors + * are odd. + */ + if ((isqr & 0x1) == 0) { + --isqr; + } + + /* + * Skip to next value not divisible by a trivial prime. + */ + n = firstjmp(n, tmp); + j = jmp + jmpptr(n); + + /* + * Look for tiny prime factors of increasing n until we + * find a prime. + */ + do { + /* ignore Saber-C warning #530 - empty for statement */ + /* ok to ignore in proc next_prime */ + /* XXX - speed up test for large n by using gcds */ + /* find a factor, or give up if not found */ + for (tp=JPRIME; (*tp <= isqr) && (n % *tp); ++tp) { + } + } while (*tp <= isqr && *tp != 1 && (n += nxtjmp(j))); + } + + /* return the prime that we found */ + return n; +} + + +/* + * Determine the previous small (32 bit) prime < a 32 bit value + * + * given: + * z search point + * + * Returns: + * 1 abs(z) >= 2^32 + * 0 abs(z) <= 2 + * greatest prime < abs(z) otherwise + */ +FULL +zpprime(ZVALUE z) +{ + CONST unsigned short *tp; /* pointer to a prime factor */ + FULL isqr; /* isqrt(z) */ + FULL n; /* search point */ + CONST unsigned char *j; /* current jump increment */ + int tmp; + + z.sign = 0; + + /* ignore large values */ + if (zge32b(z)) { + return (FULL)1; + } + + /* deal with special case small values */ + n = ztofull(z); + switch (n) { + case 0: + case 1: + case 2: + /* ignore values <= 2 */ + return (FULL)0; + case 3: + /* 3 returns the only even prime */ + return (FULL)2; + } + + /* deal with values above the bit map */ + if (n > NXT_MAP_PRIME) { + + /* find our search point */ + n = ((n & 0x1) ? n-2 : n-1); + + /* our factor limit - see next_prime for why this works */ + isqr = fsqrt(n)+1; + if ((isqr & 0x1) == 0) { + --isqr; + } + + /* + * Skip to previous value not divisible by a trivial prime. + */ + tmp = jmpindxval(n); + if (tmp >= 0) { + + /* find next value not divisible by a trivial prime */ + n += tmp; + + /* find the previous jump index */ + j = jmp + jmpptr(n); + + /* jump back */ + n -= prevjmp(j); + + /* already not divisible by a trivial prime */ + } else { + /* find the current jump index */ + j = jmp + jmpptr(n); + } + + /* factor values until we find a prime */ + do { + /* ignore Saber-C warning #530 - empty for statement */ + /* ok to ignore in proc zpprime */ + /* XXX - speed up test for large n by using gcds */ + /* find a factor, or give up if not found */ + for (tp=prime; (*tp <= isqr) && (n % *tp); ++tp) { + } + } while (*tp <= isqr && *tp != 1 && (n -= prevjmp(j))); + + /* deal with values within the bit map */ + } else if (n <= MAX_MAP_PRIME) { + + /* find our search point */ + n = ((n & 0x1) ? n-2 : n-1); + + /* search until we find a 1 bit */ + while (pr_map_bit(n) == 0) { + n -= (FULL)2; + } + + /* deal with values that could cross into the bit map */ + } else { + /* MAX_MAP_PRIME < n <= NXT_MAP_PRIME returns MAX_MAP_PRIME */ + return MAX_MAP_PRIME; + } + + /* return what we found */ + return n; +} + + +/* + * Compute the number of primes <= a ZVALUE that can fit into a FULL + * + * given: + * z compute primes <= z + * + * Returns: + * -1 error + * >=0 number of primes <= x + */ +long +zpix(ZVALUE z) +{ + /* pi(<0) is always 0 */ + if (zisneg(z)) { + return (long)0; + } + + /* firewall */ + if (zge32b(z)) { + return (long)-1; + } + return pix(ztofull(z)); +} + + +/* + * Compute the number of primes <= a ZVALUE + * + * given: + * x value of z + * + * Returns: + * -1 error + * >=0 number of primes <= x + */ +static long +pix(FULL x) +{ + long count; /* pi(x) */ + FULL top; /* top of the range to test */ + CONST unsigned short *tp; /* pointer to a tiny prime */ + FULL i; + + /* compute pi(x) using the 2^8 step table */ + if (x <= MAX_PI10B) { + + /* x within the prime table, so use it */ + if (x < MAX_MAP_PRIME) { + /* firewall - pix(x) ==0 for x < 2 */ + if (x < 2) { + count = 0; + + } else { + /* determine how and where we will count */ + if (x < 1024) { + count = 1; + tp = prime; + } else { + count = pi10b[x>>10]; + tp = prime+count-1; + } + /* count primes in the table */ + while (*tp++ <= x) { + ++count; + } + } + + /* x is larger than the prime table, so count the hard way */ + } else { + + /* case: count down from pi18b entry to x */ + if (x & 0x200) { + top = (x | 0x3ff); + count = pi10b[(top+1)>>10]; + for (i=next_prime(x); i <= top; + i=next_prime(i)) { + --count; + } + + /* case: count up from pi10b entry to x */ + } else { + count = pi10b[x>>10]; + for (i=next_prime(x&(~0x3ff)); + i <= x; i = next_prime(i)) { + ++count; + } + } + } + + /* compute pi(x) using the 2^18 interval table */ + } else { + + /* compute sum of intervals up to our interval */ + for (count=0, i=0; i < (x>>18); ++i) { + count += pi18b[i]; + } + + /* case: count down from pi18b entry to x */ + if (x & 0x20000) { + top = (x | 0x3ffff); + count += pi18b[i]; + if (top > MAX_SM_PRIME) { + if (x < MAX_SM_PRIME) { + for (i=next_prime(x); i < MAX_SM_PRIME; + i=next_prime(i)) { + --count; + } + --count; + } + } else { + for (i=next_prime(x); i<=top; i=next_prime(i)) { + --count; + } + } + + /* case: count up from pi18b entry to x */ + } else { + for (i=next_prime(x&(~0x3ffff)); + i <= x; i = next_prime(i)) { + ++count; + } + } + } + return count; +} + + +/* + * Compute the smallest prime factor < limit + * + * given: + * n number to factor + * zlimit ending search point + * res factor, if found, or NULL + * + * Returns: + * -1 error, limit >= 2^32 + * 0 no factor found, res is not changed + * 1 factor found, res (if non-NULL) is smallest prime factor + * + * NOTE: This routine will not return a factor == the test value + * except when the test value is 1 or -1. + */ +FLAG +zfactor(ZVALUE n, ZVALUE zlimit, ZVALUE *res) +{ + FULL f; /* factor found, or 0 */ + + /* + * determine the limit + */ + if (zge32b(zlimit)) { + /* limit is too large to be reasonable */ + return -1; + } + n.sign = 0; /* ignore sign of n */ + + /* + * find the smallest factor <= limit, if possible + */ + f = small_factor(n, ztofull(zlimit)); + + /* + * report the results + */ + if (f > 0) { + /* return factor if requested */ + if (res) { + utoz(f, res); + } + /* report a factor was found */ + return 1; + } + /* no factor was found */ + return 0; +} + + +/* + * Find a smallest prime factor <= some small (32 bit) limit of a value + * + * given: + * z number to factor + * limit largest factor we will test + * + * Returns: + * 0 no prime <= the limit was found + * != 0 the smallest prime factor + */ +static FULL +small_factor(ZVALUE z, FULL limit) +{ + FULL top; /* current max factor level */ + CONST unsigned short *tp; /* pointer to a tiny prime */ + FULL factlim; /* highest factor to test */ + CONST unsigned short *p; /* test factor */ + FULL factor; /* test factor */ + HALF tlim; /* limit on prime table use */ + HALF divval[2]; /* divisor value */ + ZVALUE div; /* test factor/divisor */ + ZVALUE tmp; + CONST unsigned char *j; + + /* + * catch impossible ranges + */ + if (limit < 2) { + /* range is too small */ + return 0; + } + + /* + * perform the even test + */ + if (ziseven(z)) { + if (zistwo(z)) { + /* z is 2, so don't return 2 as a factor */ + return 0; + } + return 2; + + /* + * value is odd + */ + } else if (limit == 2) { + /* limit is 2, value is odd, no factors will ever be found */ + return 0; + } + + /* + * force the factor limit to be odd + */ + if ((limit & 0x1) == 0) { + --limit; + } + + /* + * case: number to factor fits into a FULL + */ + if (!zgtmaxufull(z)) { + FULL val = ztofull(z); /* find the smallest factor of val */ + FULL isqr; /* sqrt of val */ + + /* + * special case: val is a prime <= MAX_MAP_PRIME + */ + if (val <= MAX_MAP_PRIME && pr_map_bit(val)) { + /* z is prime, so no factors will be found */ + return 0; + } + + /* + * we need not search above the sqrt of val + */ + isqr = fsqrt(val); + if (limit > isqr) { + /* limit is largest odd value <= sqrt of val */ + limit = ((isqr & 0x1) ? isqr : isqr-1); + } + + /* + * search for a small prime factor + */ + top = ((limit < MAX_MAP_VAL) ? limit : MAX_MAP_VAL); + for (tp = prime; *tp <= top && *tp != 1; ++tp) { + if (val%(*tp) == 0) { + return ((FULL)*tp); + } + } + +#if FULL_BITS == 64 + /* + * Our search will carry us beyond the prime table. We will + * continue to values until we reach our limit or until a + * factor is found. + * + * It is faster to simply test odd values and ignore non-prime + * factors because the work needed to find the next prime is + * more than the work one saves in not factor with non-prime + * values. + * + * We can improve on this method by skipping odd values that + * are a multiple of 3, 5, 7 and 11. We use a table of + * bytes that indicate the offsets between odd values that + * are not a multiple of 3,4,5,7 & 11. + */ + /* XXX - speed up test for large z by using gcds */ + j = jmp + jmpptr(NXT_MAP_PRIME); + for (top=NXT_MAP_PRIME; top <= limit; top += nxtjmp(j)) { + if ((val % top) == 0) { + return top; + } + } +#endif /* FULL_BITS == 64 */ + + /* no prime factors found */ + return 0; + } + + /* + * Find a factor of a value that is too large to fit into a FULL. + * + * determine if/what our sqrt factor limit will be + */ + if (zge64b(z)) { + /* we have no factor limit, avoid highest factor */ + factlim = MAX_SM_PRIME-1; + } else if (zge32b(z)) { + /* determine if limit is too small to matter */ + if (limit < BASE) { + factlim = limit; + } else { + /* find the isqrt(z) */ + if (!zsqrt(z, &tmp, 0)) { + /* sqrt is exact */ + factlim = ztofull(tmp); + } else { + /* sqrt is inexact */ + factlim = ztofull(tmp)+1; + } + zfree(tmp); + + /* avoid highest factor */ + if (factlim >= MAX_SM_PRIME) { + factlim = MAX_SM_PRIME-1; + } + } + } else { + /* determine our factor limit */ + factlim = fsqrt(ztofull(z)); + if (factlim >= MAX_SM_PRIME) { + factlim = MAX_SM_PRIME-1; + } + } + if (factlim > limit) { + factlim = limit; + } + + /* + * walk the prime table looking for factors + * + * XXX - consider using gcd of products of primes to speed this + * section up + */ + tlim = (HALF)((factlim >= MAX_MAP_PRIME) ? MAX_MAP_PRIME-1 : factlim); + div.sign = 0; + div.v = divval; + div.len = 1; + for (p=prime; (HALF)*p <= tlim; ++p) { + + /* setup factor */ + div.v[0] = (HALF)(*p); + + if (zdivides(z, div)) + return (FULL)(*p); + } + if ((FULL)*p > factlim) { + /* no factor found */ + return (FULL)0; + } + + /* + * test the highest factor possible + */ + div.v[0] = MAX_MAP_PRIME; + + if (zdivides(z, div)) + return (FULL)MAX_MAP_PRIME; + + /* + * generate higher test factors as needed + * + * XXX - consider using gcd of products of primes to speed this + * section up + */ +#if BASEB == 16 + div.len = 2; +#endif + factor = NXT_MAP_PRIME; + j = jmp + jmpptr(factor); + for(; factor <= factlim; factor += nxtjmp(j)) { + + /* setup factor */ +#if BASEB == 32 + div.v[0] = (HALF)factor; +#else + div.v[0] = (factor & BASE1); + div.v[1] = (factor >> BASEB); +#endif + + if (zdivides(z, div)) + return (FULL)(factor); + } + if (factor >= factlim) { + /* no factor found */ + return (FULL)0; + } + + /* + * test the highest factor possible + */ +#if BASEB == 32 + div.v[0] = MAX_SM_PRIME; +#else + div.v[0] = (MAX_SM_PRIME & BASE1); + div.v[1] = (MAX_SM_PRIME >> BASEB); +#endif + if (zdivides(z, div)) + return (FULL)MAX_SM_PRIME; + + /* + * no factor found + */ + return (FULL)0; +} + + +/* + * Compute the product of the primes up to the specified number. + */ +void +zpfact(ZVALUE z, ZVALUE *dest) +{ + long n; /* limiting number to multiply by */ + long p; /* current prime */ + CONST unsigned short *tp; /* pointer to a tiny prime */ + CONST unsigned char *j; /* current jump increment */ + ZVALUE res, temp; + + /* firewall */ + if (zisneg(z)) { + math_error("Negative argument for factorial"); + /*NOTREACHED*/ + } + if (zge24b(z)) { + math_error("Very large factorial"); + /*NOTREACHED*/ + } + n = ztolong(z); + + /* + * Deal with table lookup pfact values + */ + if (n <= MAX_PFACT_VAL) { + utoz(pfact_tbl[n], dest); + return; + } + + /* + * Multiply by the primes in the static table + */ + utoz(pfact_tbl[MAX_PFACT_VAL], &res); + for (tp=(&prime[NXT_PFACT_VAL]); *tp != 1 && (long)(*tp) <= n; ++tp) { + zmuli(res, *tp, &temp); + zfree(res); + res = temp; + } + + /* + * if needed, multiply by primes beyond the static table + */ + j = jmp + jmpptr(NXT_MAP_PRIME); + for (p = NXT_MAP_PRIME; p <= n; p += nxtjmp(j)) { + FULL isqr; /* isqrt(p) */ + + /* our factor limit - see next_prime for why this works */ + isqr = fsqrt(p)+1; + if ((isqr & 0x1) == 0) { + --isqr; + } + + /* ignore Saber-C warning #530 about empty for statement */ + /* ok to ignore in proc zpfact */ + /* find the next prime */ + for (tp=prime; (*tp <= isqr) && (p % (long)(*tp)); ++tp) { + } + if (*tp <= isqr && *tp != 1) { + continue; + } + + /* multiply by the next prime */ + zmuli(res, p, &temp); + zfree(res); + res = temp; + } + *dest = res; +} + + +/* + * Perform a probabilistic primality test (algorithm P in Knuth vol2, 4.5.4). + * 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. + * + * It is interesting to note that ptest(a,1,x) (for any x >= 0) of this + * test will always return TRUE for a prime, and rarely return TRUE for + * a non-prime. The 1/4 is appears in practice to be a poor upper + * bound. Even so the only result that is EXACT and TRUE is when + * this test returns FALSE for a non-prime. When ptest returns TRUE, + * one cannot determine if the value in question is prime, or the value + * is one of those rare non-primes that produces a false positive. + * + * The absolute value of count determines how many times to check + * for primality. If count < 0, then the trivial factor check is + * omitted. + * skip = 0 uses random bases + * skip = 1 uses prime bases 2, 3, 5, ... + * skip > 1 or < 0 uses bases skip, skip + 1, ... + */ +BOOL +zprimetest(ZVALUE z, long count, ZVALUE skip) +{ + long limit = 0; /* test odd values from skip up to limit */ + ZVALUE zbase; /* base as a ZVALUE */ + long i, ij, ik; + ZVALUE zm1, z1, z2, z3; + int type; /* random, prime or consecutive integers */ + CONST unsigned short *pr; /* pointer to small prime */ + + /* + * firewall - ignore sign of z, values 0 and 1 are not prime + */ + z.sign = 0; + if (zisleone(z)) { + return 0; + } + + /* + * firewall - All even values, except 2, are not prime + */ + if (ziseven(z)) + return zistwo(z); + + if (z.len == 1 && *z.v == 3) + return 1; /* 3 is prime */ + + /* + * we know that z is an odd value > 1 + */ + + /* + * Perform trivial checks if count is not negative + */ + if (count >= 0) { + + /* + * If the number is a small (32 bit) value, do a direct test + */ + if (!zge32b(z)) { + return zisprime(z); + } + + /* + * See if the number has a tiny factor. + */ + if (small_factor(z, PTEST_PRECHECK) != 0) { + /* a tiny factor was found */ + return FALSE; + } + + /* + * If our count is zero, do nothing more + */ + if (count == 0) { + /* no test was done, so no test failed! */ + return TRUE; + } + + } else { + /* use the absolute value of count */ + count = -count; + } + if (z.len < conf->redc2) { + return zredcprimetest(z, count, skip); + } + + if (ziszero(skip)) { + type = 0; + zbase = _zero_; + } + else if (zisone(skip)) { + type = 1; + itoz(2, &zbase); + limit = 1 << 16; + if (!zge16b(z)) + limit = ztolong(z); + } + else { + type = 2; + if (zrel(skip, z) >= 0 || zisneg(skip)) + zmod(skip, z, &zbase, 0); + else + zcopy(skip, &zbase); + } + /* + * Loop over various bases, testing each one. + */ + zsub(z, _one_, &zm1); + ik = zlowbit(zm1); + zshift(zm1, -ik, &z1); + pr = prime; + for (i = 0; i < count; i++) { + switch (type) { + case 0: + zfree(zbase); + zrandrange(_two_, zm1, &zbase); + break; + case 1: + if (i == 0) + break; + zfree(zbase); + if (*pr == 1 || (long)*pr >= limit) { + zfree(z1); + zfree(zm1); + return TRUE; + } + itoz((long) *pr++, &zbase); + break; + default: + if (i == 0) + break; + zadd(zbase, _one_, &z3); + zfree(zbase); + zbase = z3; + } + + ij = 0; + zpowermod(zbase, z1, z, &z3); + for (;;) { + if (zisone(z3)) { + if (ij) { + /* number is definitely not prime */ + zfree(z3); + zfree(zm1); + zfree(z1); + zfree(zbase); + return FALSE; + } + break; + } + if (!zcmp(z3, zm1)) + break; + if (++ij >= ik) { + /* number is definitely not prime */ + zfree(z3); + zfree(zm1); + zfree(z1); + zfree(zbase); + return FALSE; + } + zsquare(z3, &z2); + zfree(z3); + zmod(z2, z, &z3, 0); + zfree(z2); + } + zfree(z3); + } + zfree(zm1); + zfree(z1); + zfree(zbase); + + /* number might be prime */ + return TRUE; +} + + +/* + * Called by zprimetest when simple cases have been eliminated + * and z.len < conf->redc2. Here count > 0, z is odd and > 3. + */ +BOOL +zredcprimetest(ZVALUE z, long count, ZVALUE skip) +{ + long limit = 0; /* test odd values from skip up to limit */ + ZVALUE zbase; /* base as a ZVALUE */ + REDC *rp; + long i, ij, ik; + ZVALUE zm1, z1, z2, z3; + ZVALUE zredcm1; + int type; /* random, prime or consecutive integers */ + CONST unsigned short *pr; /* pointer to small prime */ + + + rp = zredcalloc(z); + zsub(z, rp->one, &zredcm1); + if (ziszero(skip)) { + zbase = _zero_; + type = 0; + } + else if (zisone(skip)) { + itoz(2, &zbase); + type = 1; + limit = 1 << 16; + if (!zge16b(z)) + limit = ztolong(z); + } + else { + zredcencode(rp, skip, &zbase); + type = 2; + } + /* + * Loop over various "random" numbers, testing each one. + */ + zsub(z, _one_, &zm1); + ik = zlowbit(zm1); + zshift(zm1, -ik, &z1); + pr = prime; + + for (i = 0; i < count; i++) { + switch (type) { + case 0: + do { + zfree(zbase); + zrandrange(_one_, z, &zbase); + } + while (!zcmp(zbase, rp->one) || + !zcmp(zbase, zredcm1)); + break; + case 1: + if (i == 0) { + break; + } + zfree(zbase); + if (*pr == 1 || (long)*pr >= limit) { + zfree(z1); + zfree(zm1); + if (z.len < conf->redc2) { + zredcfree(rp); + zfree(zredcm1); + } + return TRUE; + } + itoz((long) *pr++, &z3); + zredcencode(rp, z3, &zbase); + zfree(z3); + break; + default: + if (i == 0) + break; + zadd(zbase, rp->one, &z3); + zfree(zbase); + zbase = z3; + if (zrel(zbase, z) >= 0) { + zsub(zbase, z, &z3); + zfree(zbase); + zbase = z3; + } + } + + ij = 0; + zredcpower(rp, zbase, z1, &z3); + for (;;) { + if (!zcmp(z3, rp->one)) { + if (ij) { + /* number is definitely not prime */ + zfree(z3); + zfree(zm1); + zfree(z1); + zfree(zbase); + zredcfree(rp); + zfree(zredcm1); + return FALSE; + } + break; + } + if (!zcmp(z3, zredcm1)) + break; + if (++ij >= ik) { + /* number is definitely not prime */ + zfree(z3); + zfree(zm1); + zfree(z1); + zfree(zbase); + zredcfree(rp); + zfree(zredcm1); + return FALSE; + } + zredcsquare(rp, z3, &z2); + zfree(z3); + z3 = z2; + } + zfree(z3); + } + zfree(zbase); + zredcfree(rp); + zfree(zredcm1); + zfree(zm1); + zfree(z1); + + /* number might be prime */ + return TRUE; +} + + +/* + * znextcand - find the next integer that passes ptest(). + * The signs of z and mod are ignored. Result is the least integer + * greater than abs(z) congruent to res modulo abs(mod), or if there + * is no such integer, zero. + * + * given: + * z search point > 2 + * count ptests to perform per candidate + * skip ptests to skip + * res return congruent to res modulo abs(mod) + * mod congruent to res modulo abs(mod) + * cand candidate found + */ +BOOL +znextcand(ZVALUE z, long count, ZVALUE skip, ZVALUE res, ZVALUE mod, ZVALUE *cand) +{ + ZVALUE tmp1; + ZVALUE tmp2; + + z.sign = 0; + mod.sign = 0; + if (ziszero(mod)) { + if (zrel(res, z) > 0 && zprimetest(res, count, skip)) { + zcopy(res, cand); + return TRUE; + } + return FALSE; + } + if (ziszero(z) && zisone(mod)) { + zcopy(_two_, cand); + return TRUE; + } + zsub(res, z, &tmp1); + if (zmod(tmp1, mod, &tmp2, 0)) + zadd(z, tmp2, cand); + else + zadd(z, mod, cand); + + /* + * Now *cand is least integer greater than abs(z) and congruent + * to res modulo mod. + */ + zfree(tmp1); + zfree(tmp2); + if (zprimetest(*cand, count, skip)) + return TRUE; + zgcd(*cand, mod, &tmp1); + if (!zisone(tmp1)) { + zfree(tmp1); + zfree(*cand); + return FALSE; + } + zfree(tmp1); + if (ziseven(*cand)) { + zadd(*cand, mod, &tmp1); + zfree(*cand); + *cand = tmp1; + if (zprimetest(*cand, count, skip)) + return TRUE; + } + /* + * *cand is now least odd integer > abs(z) and congruent to + * res modulo mod. + */ + if (zisodd(mod)) + zshift(mod, 1, &tmp1); + else + zcopy(mod, &tmp1); + do { + zadd(*cand, tmp1, &tmp2); + zfree(*cand); + *cand = tmp2; + } while (!zprimetest(*cand, count, skip)); + zfree(tmp1); + return TRUE; +} + + +/* + * zprevcand - find the nearest previous integer that passes ptest(). + * The signs of z and mod are ignored. Result is greatest positive integer + * less than abs(z) congruent to res modulo abs(mod), or if there + * is no such integer, zero. + * + * given: + * z search point > 2 + * count ptests to perform per candidate + * skip ptests to skip + * res return congruent to res modulo abs(mod) + * mod congruent to res modulo abs(mod) + * cand candidate found + */ +BOOL +zprevcand(ZVALUE z, long count, ZVALUE skip, ZVALUE res, ZVALUE mod, ZVALUE *cand) +{ + ZVALUE tmp1; + ZVALUE tmp2; + + z.sign = 0; + mod.sign = 0; + if (ziszero(mod)) { + if (zispos(res)&&zrel(res, z)<0 && zprimetest(res,count,skip)) { + zcopy(res, cand); + return TRUE; + } + return FALSE; + } + zsub(z, res, &tmp1); + if (zmod(tmp1, mod, &tmp2, 0)) + zsub(z, tmp2, cand); + else + zsub(z, mod, cand); + /* + * *cand is now the greatest integer < z that is congruent to res + * modulo mod. + */ + zfree(tmp1); + zfree(tmp2); + if (zisneg(*cand)) { + zfree(*cand); + return FALSE; + } + if (zprimetest(*cand, count, skip)) + return TRUE; + zgcd(*cand, mod, &tmp1); + if (!zisone(tmp1)) { + zfree(tmp1); + zmod(*cand, mod, &tmp1, 0); + zfree(*cand); + if (zprimetest(tmp1, count, skip)) { + *cand = tmp1; + return TRUE; + } + if (ziszero(tmp1)) { + zfree(tmp1); + if (zprimetest(mod, count, skip)) { + zcopy(mod, cand); + return TRUE; + } + return FALSE; + } + zfree(tmp1); + return FALSE; + } + zfree(tmp1); + if (ziseven(*cand)) { + zsub(*cand, mod, &tmp1); + zfree(*cand); + if (zisneg(tmp1)) { + zfree(tmp1); + return FALSE; + } + *cand = tmp1; + if (zprimetest(*cand, count, skip)) + return TRUE; + } + /* + * *cand is now the greatest odd integer < z that is congruent to + * res modulo mod. + */ + if (zisodd(mod)) + zshift(mod, 1, &tmp1); + else + zcopy(mod, &tmp1); + + do { + zsub(*cand, tmp1, &tmp2); + zfree(*cand); + *cand = tmp2; + } while (!zprimetest(*cand, count, skip) && !zisneg(*cand)); + zfree(tmp1); + if (zisneg(*cand)) { + zadd(*cand, mod, &tmp1); + zfree(*cand); + *cand = tmp1; + if (zistwo(*cand)) + return TRUE; + zfree(*cand); + return FALSE; + } + return TRUE; +} + + +/* + * Find the lowest prime factor of a number if one can be found. + * Search is conducted for the first count primes. + * + * Returns: + * 1 no factor found or z < 3 + * >1 factor found + */ +FULL +zlowfactor(ZVALUE z, long count) +{ + FULL factlim; /* highest factor to test */ + CONST unsigned short *p; /* test factor */ + FULL factor; /* test factor */ + HALF tlim; /* limit on prime table use */ + HALF divval[2]; /* divisor value */ + ZVALUE div; /* test factor/divisor */ + ZVALUE tmp; + + z.sign = 0; + + /* + * firewall + */ + if (count <= 0 || zisleone(z) || zistwo(z)) { + /* number is < 3 or count is <= 0 */ + return (FULL)1; + } + + /* + * test for the first factor + */ + if (ziseven(z)) { + return (FULL)2; + } + if (count <= 1) { + /* count was 1, tested the one and only factor */ + return (FULL)1; + } + + /* + * determine if/what our sqrt factor limit will be + */ + if (zge64b(z)) { + /* we have no factor limit, avoid highest factor */ + factlim = MAX_SM_PRIME-1; + } else if (zge32b(z)) { + /* find the isqrt(z) */ + if (!zsqrt(z, &tmp, 0)) { + /* sqrt is exact */ + factlim = ztofull(tmp); + } else { + /* sqrt is inexact */ + factlim = ztofull(tmp)+1; + } + zfree(tmp); + + /* avoid highest factor */ + if (factlim >= MAX_SM_PRIME) { + factlim = MAX_SM_PRIME-1; + } + } else { + /* determine our factor limit */ + factlim = fsqrt(ztofull(z)); + } + if (factlim >= MAX_SM_PRIME) { + factlim = MAX_SM_PRIME-1; + } + + /* + * walk the prime table looking for factors + */ + tlim = (HALF)((factlim >= MAX_MAP_PRIME) ? MAX_MAP_PRIME-1 : factlim); + div.sign = 0; + div.v = divval; + div.len = 1; + for (p=prime, --count; count > 0 && (HALF)*p <= tlim; ++p, --count) { + + /* setup factor */ + div.v[0] = (HALF)(*p); + + if (zdivides(z, div)) + return (FULL)(*p); + } + if (count <= 0 || (FULL)*p > factlim) { + /* no factor found */ + return (FULL)1; + } + + /* + * test the highest factor possible + */ + div.v[0] = MAX_MAP_PRIME; + if (zdivides(z, div)) + return (FULL)MAX_MAP_PRIME; + + /* + * generate higher test factors as needed + */ +#if BASEB == 16 + div.len = 2; +#endif + for(factor = NXT_MAP_PRIME; + count > 0 && factor <= factlim; + factor = next_prime(factor), --count) { + + /* setup factor */ +#if BASEB == 32 + div.v[0] = (HALF)factor; +#else + div.v[0] = (factor & BASE1); + div.v[1] = (factor >> BASEB); +#endif + + if (zdivides(z, div)) + return (FULL)(factor); + } + if (count <= 0 || factor >= factlim) { + /* no factor found */ + return (FULL)1; + } + + /* + * test the highest factor possible + */ +#if BASEB == 32 + div.v[0] = MAX_SM_PRIME; +#else + div.v[0] = (MAX_SM_PRIME & BASE1); + div.v[1] = (MAX_SM_PRIME >> BASEB); +#endif + if (zdivides(z, div)) + return (FULL)MAX_SM_PRIME; + + /* + * no factor found + */ + return (FULL)1; +} + + +/* + * Compute the least common multiple of all the numbers up to the + * specified number. + */ +void +zlcmfact(ZVALUE z, ZVALUE *dest) +{ + long n; /* limiting number to multiply by */ + long p; /* current prime */ + long pp = 0; /* power of prime */ + long i; /* test value */ + CONST unsigned short *pr; /* pointer to a small prime */ + ZVALUE res, temp; + + if (zisneg(z) || ziszero(z)) { + math_error("Non-positive argument for lcmfact"); + /*NOTREACHED*/ + } + if (zge24b(z)) { + math_error("Very large lcmfact"); + /*NOTREACHED*/ + } + n = ztolong(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 (pr=prime; (long)(*pr) <= n && *pr > 1; ++pr) { + i = p = *pr; + while (i <= n) { + pp = i; + i *= p; + } + zmuli(res, pp, &temp); + zfree(res); + res = temp; + } + for (p = NXT_MAP_PRIME; p <= n; p = (long)next_prime(p)) { + i = p; + while (i <= n) { + pp = i; + i *= p; + } + zmuli(res, pp, &temp); + zfree(res); + res = temp; + } + /* + * Finish by scaling by the necessary power of two. + */ + zshift(res, zhighbit(z), dest); + zfree(res); +} + + +/* + * fsqrt - fast square root of a FULL value + * + * We will determine the square root of a given value. + * Starting with the integer square root of the largest power of + * two <= the value, we will perform 3 Newton interations to + * arive at our guess. + * + * We have verified that fsqrt(x) == (FULL)sqrt((double)x), or + * fsqrt(x)-1 == (FULL)sqrt((double)x) for all 0 <= x < 2^32. + * + * given: + * x compute the integer square root of x + */ +static FULL +fsqrt(FULL x) +{ + FULL y; /* (FULL)temporary value */ + int i; + + /* firewall - deal with 0 */ + if (x == 0) { + return 0; + } + + /* ignore Saber-C warning #530 about empty for statement */ + /* ok to ignore in proc fsqrt */ + /* determine our initial guess */ + for (i=0, y=x; y >= (FULL)256; i+=8, y>>=8) { + } + y = isqrt_pow2[i + topbit[y]]; + + /* perform 3 Newton interations */ + y = (y+x/y)>>1; + y = (y+x/y)>>1; + y = (y+x/y)>>1; +#if FULL_BITS == 64 + y = (y+x/y)>>1; +#endif + + /* return the result */ + return y; +} diff --git a/zrand.c b/zrand.c new file mode 100644 index 0000000..a097a5b --- /dev/null +++ b/zrand.c @@ -0,0 +1,3558 @@ +/* + * Copyright (c) 1996 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. + * + * Prior to calc 2.9.3t9, these routines existed as a calc library called + * cryrand.cal. They have been rewritten in C for performance as well + * as to make them available directly from libcalc.a. + * + * 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 + * + * chongo was here /\../\ + */ + +/* + * XXX - Add shs() and md5 hash functions. Ensure that any object can + * be hashed. Ensure that if a == b, hash of a == hash of b. + * This can be done by hashing all values of an value that + * are used in the equality test. Note that the value type should + * also be hashed to help distinguish different value types. + * Also note that objects should hash their name. The shs() and + * md5() should NOT replace the foohash() functions used by + * associative arrays as those functions need to be fast. + * + * XXX - write random() and srandom() help pages + */ + +/* + * AN OVERVIEW OF THE FUNCTIONS: + * + * This module contains two pseudo-random number generators: + * + * Additive 55 shuffle generator: + * + * We refer to this generator as the a55 generator. + * + * rand - a55 shuffle generator + * srand - seed the a55 shuffle generator + * + * This generator has two distinct parts, the a55 generator + * and the shuffle generator. + * + * The additive 55 generator is 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. + * + * The shuffle generator is 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. If you need a fast generator and do not + * need a cryptographically strong one, this generator is likely to do + * the job. + * + * The shuffle generator is feed values by the additive 55 process. + * + * Blum-Blum-Shub generator: + * + * We refer to this generator as the Blum generator. + * + * 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. + * + * Sciences 28, pp. 270-299. + * + * Bruce Schneier, "Applied Cryptography", John Wiley & Sons, + * 1st edition (1994), pp 365-366. + * + * This generator is considered 'strong' in that it passes all + * polynomial-time statistical tests. The sequences produced + * are random in an absolutely precise way. There is absolutely + * no better way to predict the sequence than by tossing a coin + * (as with TRULY random numbers) EVEN IF YOU KNOW THE MODULUS! + * Furthermore, having a large chunk of output from the sequence + * does not help. The BITS THAT FOLLOW OR PRECEDE A SEQUENCE + * ARE UNPREDICTABLE! + * + * To compromise the generator, an adversary must either factor the + * modulus or perform an exhaustive search just to determine the next + * (or previous) bit. If we make the modulus hard to factor + * (such as the product of two large well chosen primes) breaking + * the sequence could be intractable for todays computers and methods. + **** + * + * 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 need + * + * By using the appropriate seed and other arguments, one may + * increase the strength of the generator to suit the need of + * the application. One does not have just a few levels. + * + * Even though I have done my best to implement a good system, you still + * must use these routines your own risk. + * + * Share and enjoy! :-) + */ + +/* + * 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. + * The shuffle generator has a very good period, and is fast. It is + * fairly good as generators go, particularly when it is feed reasonably + * random numbers. Because of this, we use feed values from the additive + * 55 process into the shuffle generator. + * + * The a55 generator uses 2 tables: + * + * additive table - 55 entries of 64 bits used by the additive 55 + * part of the a55 generator + * + * shuffle table - 256 entries of 64 bits used by the shuffle + * part of the a55 generator and feed by the + * additive table. + * + * Casual direct use of the shuffle generator may be acceptable. If one + * desires cryptographically strong random numbers, or if one is paranoid, + * one should use the Blum generator instead. + * + * The a55 generator as the following calc interfaces: + * + * rand(min,max) (where min < max) + * + * Print an a55 generator random value over interval [a,b). + * + * rand() + * + * Same as rand(0, 2^64). Print 64 bits. + * + * rand(lim) (where 0 > lim) + * + * Same as rand(0, lim). + * + * randbit(x) (where x > 0) + * + * Same as rand(0, 2^x). Print x bits. + * + * randbit(skip) (where skip < 0) + * + * Skip random bits and return the bit skip count (-skip). + * + *** + * + * The Blum 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 Blum generator is not too slow, though + * seeding the generator via srandom(seed,plen,qlen) can be slow. + * Shortcuts and pre-defined generators have been provided for this reason. + * Use of Blum should be more than acceptable for many applications. + * + * The Blum generator as the following calc interfaces: + * + * random(min, max) (where min < max) + * XXX - write this function + * + * Print a Blum generator random value over interval [min,max). + * + * random() + * XXX - write this function + * + * Same as random(0, 2^64). Print 64 bits. + * + * random(lim) (where 0 > lim) + * XXX - write this function + * + * Same as random(0, lim). + * + * randombit(x) (where x > 0) + * XXX - write this function + * + * Same as random(0, 2^x). Print x bits. + * + * randombit(skip) (where skip < 0) + * XXX - write this function + * + * Skip skip random bits and return the bit skip count (-skip). + */ + +/* + * INITIALIZATION AND SEEDS: + * + * All generators come already seeded with precomputed initial constants. + * Thus, it is not required to seed a generator before using it. + * + * The a55 generator may be initialized and seeded via srand(). + * The Blum generator may be initialized and seeded via srandom(). + * + * Using a seed of '0' will reload generators with their initial states. + * + * srand(0) restore additive 55 generator to the initial state + * srandom(0) restore Blum generator to the initial state + * + * The above single arg calls are fairly fast. + * + * The call: + * + * srandom(seed, newn) + * + * is fast when the config value "srandom" is 0, 1 or 2. + * + * Optimal seed range for the a55 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 * 55!) should be + * sufficient for most purposes. An easy way to stay within this + * range to to use seeds that are between 21 and 93 digits, or + * 64 to 308 bits long. + * + * 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. + * + * Optimal seed range for the Blum generator: + * + * There is no limit on the size of a seed. On the other hand, + * in most cases the seed is taken modulo the Blum modulus. + * Using a seed that is too small (except for 0) results in + * an internal generator be used to increase its size. + * + * It is faster to use seeds that are in the half open internal + * [sqrt(n), n) where n is the Blum modulus. + * + * The default Blum modulus is 256 bits. The default + * optimal size of a seed is between 128 and 256 bits. + * + * The exception is when srandom(seed, plen, qlen) is used. + * When seed < 0, the seed is given to an internal a55 generator + * and the a55 generator range (negated) applies. When seed > 0, + * the seed is given to an internal Blum generator and the + * 128 to 256 bit range applies. The value seed == 0 may also + * be used in this type of call. + * + ***** + * + * srand(seed) + * + * Seed the a55 generator. + * + * seed != 0: + * --------- + * Any buffered random bits are flushed. The additive table is loaded + * with the default additive table. The low order 64 bits of seed is + * xor-ed against each table value. The additive table is shuffled + * according to seed/2^64. + * + * The following calc code produces the same effect: + * + * (* reload default additive table xored with low 64 seed bits *) + * seed_xor = seed & ((1<<64)-1); + * for (i=0; i < 55; ++i) { + * additive[i] = xor(default_additive[i], seed_xor); + * } + * + * (* shuffle the additive table *) + * seed >>= 64; + * for (i=55; seed > 0 && i > 0; --i) { + * quomod(seed, i+1, seed, j); + * swap(additive[i], additive[j]); + * } + * + * Seed must be >= 0. All seed values < 0 are reserved for future use. + * + * The additive 55 pointers are reset to additive[23] and additive[54]. + * Last the shuffle table is loaded with successive values from the + * additive 55 generator. + * + * seed == 0: + * --------- + * Restore the initial state and modulus of the a55 generator. + * After this call, the a55 generator is restored to its initial + * state after calc started. + * + * The additive 55 pointers are reset to additive[23] and additive[54]. + * Last the shuffle table is loaded with successive values from the + * additive 55 generator. + * + *** + * + * srand(mat55) + * + * Seed the a55 generator. + * + * Any buffered random bits are flushed. The additive table with the + * first 55 entries of the array mat55, mod 2^64. + * + * The additive 55 pointers are reset to additive[23] and additive[54]. + * Last the shuffle table is loaded with successive values from the + * additive 55 generator. + * + *** + * + * srand() + * + * Return current a55 generator state. This call does not alter + * the generator state. + * + *** + * + * srand(state) + * + * Restore the a55 state and return the previous state. Note that + * the argument state is a rand state value (isrand(state) is true). + * Any internally buffered random bits are restored. + * + * The states of the a55 generators can be saved by calling the seed + * function with no arguments, and later restored by calling the seed + * functions with that same return value. + * + * rand_state = srand(); + * ... generate random bits ... + * prev_rand_state = srand(rand_state); + * ... generate the same random bits ... + * srand() == prev_rand_state; (* is true *) + * + * Saving the state just after seeding a generator and restoring it later + * as a very fast way to reseed a generator. + * + *** + * + * srandom(seed) + * XXX - write this function + * + * Seed the Blum generator using the current Blum modulus. + * + * Here we assume that the Blum modulus is n. Any internally buffered + * random bits are flushed. + * + * seed > 0: + * -------- + * Seed the an internal additive 55 shuffle generator, and use it + * to produce an initial quadratic residue in the range: + * + * [2^(binsize*4/5), 2^(binsize-2)) + * + * where 2^(binsize-1) < n <= 2^binsize and 'n' is the current Blum + * modulus. Here, binsize is the smallest power of 2 >= n. + * + * The follow calc script produces an equivalent effect: + * + * cur_state = srand(seed); + * binsize = highbit(n)+1; (* n is the current Blum modulus *) + * r = pmod(rand(1< 0, 1007 <= newn: + * ---------------------- + * If 'newn' passes the tests (if applicable) specified by the "srandom" + * config value, it becomes the Blum modulus. Once the Blum modulus + * is set, seed is used to seed an internal Additive 55 generator + * state which in turn is used to set the initial quadratic residue. + * + * While not as efficient, this call is equivalent to: + * + * srandom(0, newn); + * srandom(seed); + * + * seed < 0, 1007 <= newn: + * ---------------------- + * Reserved for future use. + * + * any seed, 20 < newn < 1007: + * -------------------------- + * Reserved for future use. + * + * seed == 0, 0 < newn <= 20: + * ------------------------- + * Seed with one of the predefined Blum moduli. + * + * The Blum moduli used by the pre-defined generators were generated + * using the above process. The initial search values for the Blum + * primes and the value used for selecting the initial quadratic + * residue (by squaring it mod the Blum modulus) were produced by + * special purpose hardware that produces cryptographically strong + * random numbers. + * + * See the URL: + * + * http://lavarand.sgi.com + * + * for an explination of how the search points of the generators + * were selected. + * + * XXX - This URL is not available on 16Jun96 ... but will be soon. + * + * The purpose of these pre-defined Blum moduli is to provide users with + * an easy way to use a generator where the individual Blum primes used + * are not well known. True, these values are in some way "MAGIC", on + * the other hand that is their purpose! If this bothers you, don't + * use them. See the section "FOR THE PARANOID" below for details. + * + * The value 'newn' determines which pre-defined generator is used. + * For a given 'newn' the Blum modulus 'n' (product of 2 Blum primes) + * and initial quadratic residue 'r' is set as follows: + * + * newn == 1: (Blum modulus bit length 130) + * n = 0x5049440736fe328caf0db722d83de9361 + * r = 0xb226980f11d952e74e5dbb01a4cc42ec + * + * newn == 2: (Blum modulus bit length 137) + * n = 0x2c5348a2555dd374a18eb286ea9353443f1 + * r = 0x40f3d643446cd710e3e893616b21e3a218 + * + * newn == 3: (Blum modulus bit length 147) + * n = 0x9cfd959d6ce4e3a81f1e0f2ca661f11d001f1 + * r = 0xfae5b44d9b64ff5cea4f3e142de2a0d7d76a + * + * newn == 4: (Blum modulus bit length 157) + * n = 0x3070f9245c894ed75df12a1a2decc680dfcc0751 + * r = 0x20c2d8131b2bdca2c0af8aa220ddba4b984570 + * + * newn == 5: (Blum modulus bit length 257) + * n = 0x2109b1822db81a85b38f75aac680bc2fa5d3fe1118769a0108b99e5e799 + * 166ef1 + * r = 0x5e9b890eae33b792e821a9605f5df6db234f7b7d1e70aeed0e6c77c859e + * 2efa9 + * + * newn == 6: (Blum modulus bit length 259) + * n = 0xa7bfd9d7d9ada2c79f2dbf2185c6440263a38db775ee732dad85557f1e1 + * ddf431 + * r = 0x5e94a02f88667154e097aedece1c925ce1f3495d2c98eccfc5dc2e80c94 + * 04daf + * + * newn == 7: (Blum modulus bit length 286) + * n = 0x43d87de8f2399ef237801cd5628643fcff569d6b0dcf53ce52882e7f602 + * f9125cf9ec751 + * r = 0x13522d1ee014c7bfbe90767acced049d876aefcf18d4dd64f0b58c3992d + * 2e5098d25e6 + * + * newn == 8: (Blum modulus bit length 294) + * n = 0x5847126ca7eb4699b7f13c9ce7bdc91fed5bdbd2f99ad4a6c2b59cd9f0b + * c42e66a26742f11 + * r = 0x853016dca3269116b7e661fa3d344f9a28e9c9475597b4b8a35da929aae + * 95f3a489dc674 + * + * newn == 9: (Blum modulus bit length 533) + * n = 0x39e8be52322fd3218d923814e81b003d267bb0562157a3c1797b4f4a867 + * 52a84d895c3e08eb61c36a6ff096061c6fd0fdece0d62b16b66b980f95112 + * 745db4ab27e3d1 + * r = 0xb458f8ad1e6bbab915bfc01508864b787343bc42a8aa82d9d2880107e3f + * d8357c0bd02de3222796b2545e5ab7d81309a89baedaa5d9e8e59f959601e + * f2b87d4ed20d + * + * newn == 10: (Blum modulus bit length 537) + * n = 0x25f2435c9055666c23ef596882d7f98bd1448bf23b50e88250d3cc952c8 + * 1b3ba524a02fd38582de74511c4008d4957302abe36c6092ce222ef9c73cc + * 3cdc363b7e64b89 + * r = 0x66bb7e47b20e0c18401468787e2b707ca81ec9250df8cfc24b5ffbaaf2c + * f3008ed8b408d075d56f62c669fadc4f1751baf950d145f40ce23442aee59 + * 4f5ad494cfc482 + * + * newn == 11: (Blum modulus bit length 542) + * n = 0x497864de82bdb3094217d56b874ecd7769a791ea5ec5446757f3f9b6286 + * e58704499daa2dd37a74925873cfa68f27533920ee1a9a729cf522014dab2 + * 2e1a530c546ee069 + * r = 0x8684881cb5e630264a4465ae3af8b69ce3163f806549a7732339eea2c54 + * d5c590f47fbcedfa07c1ef5628134d918fee5333fed9c094d65461d88b13a + * 0aded356e38b04 + * + * newn == 12: (Blum modulus bit length 549) + * n = 0x3457582ab3c0ccb15f08b8911665b18ca92bb7c2a12b4a1a66ee4251da1 + * 90b15934c94e315a1bf41e048c7c7ce812fdd25d653416557d3f09887efad + * 2b7f66d151f14c7b99 + * r = 0xdf719bd1f648ed935870babd55490137758ca3b20add520da4c5e8cdcbf + * c4333a13f72a10b604eb7eeb07c573dd2c0208e736fe56ed081aa9488fbc4 + * 5227dd68e207b4a0 + * + * newn == 13: (Blum modulus bit length 1048) + * n = 0x1517c19166b7dd21b5af734ed03d833daf66d82959a553563f4345bd439 + * 510a7bda8ee0cb6bf6a94286bfd66e49e25678c1ee99ceec891da8b18e843 + * 7575113aaf83c638c07137fdd3a76c3a49322a11b5a1a84c32d99cbb2b056 + * 671589917ed14cc7f1b5915f6495dd1892b4ed7417d79a63cc8aaa503a208 + * e3420cca200323314fc49 + * r = 0xd42e8e9a560d1263fa648b04f6a69b706d2bc4918c3317ddd162cb4be7a + * 5e3bbdd1564a4aadae9fd9f00548f730d5a68dc146f05216fe509f0b8f404 + * 902692de080bbeda0a11f445ff063935ce78a67445eae5c9cea5a8f6b9883 + * faeda1bbe5f1ad3ef6409600e2f67b92ed007aba432b567cc26cf3e965e20 + * 722407bfe46b7736f5 + * + * newn == 14: (Blum modulus bit length 1054) + * n = 0x5e56a00e93c6f4e87479ac07b9d983d01f564618b314b4bfec7931eee85 + * eb909179161e23e78d32110560b22956b22f3bc7e4a034b0586e463fd40c6 + * f01a33e30ede912acb86a0c1e03483c45f289a271d14bd52792d0a076fdfe + * fe32159054b217092237f0767434b3db112fee83005b33f925bacb3185cc4 + * 409a1abdef8c0fc116af01 + * r = 0xf7aa7cb67335096ef0c5d09b18f15415b9a564b609913f75f627fc6b0c5 + * b686c86563fe86134c5a0ea19d243350dfc6b9936ba1512abafb81a0a6856 + * c9ae7816bf2073c0fb58d8138352b261a704b3ce64d69dee6339010186b98 + * 3677c84167d4973444194649ad6d71f8fa8f1f1c313edfbbbb6b1b220913c + * c8ea47a4db680ff9f190 + * + * newn == 15: (Blum modulus bit length 1055) + * n = 0x97dd840b9edfbcdb02c46c175ba81ca845352ebe470be6075326a26770c + * ab84bfc0f2e82aa95aac14f40de42a0590445b902c2b8ebb916753e72ab86 + * c3278cccc1a783b3e962d81b80df03e4380a8fa08b0d86ed0caa515c196a5 + * 30e49c558ddb53082310b1d0c7aee6f92b619798624ffe6c337299bc51ff5 + * d2c721061e7597c8d97079 + * r = 0xb8220703b8c75869ab99f9b50025daa8d77ca6df8cef423ede521f55b1c + * 25d74fbf6d6cc31f5ef45e3b29660ef43797f226860a4aa1023dbe522b1fe + * 6224d01eb77dee9ad97e8970e4a9e28e7391a6a70557fa0e46eca78866241 + * ba3c126fc0c5469f8a2f65c33db95d1749d3f0381f401b9201e6abd43d98d + * b92e808f0aaa6c3e2110 + * + * newn == 16: (Blum modulus bit length 1062) + * n = 0x456e348549b82fbb12b56f84c39f544cb89e43536ae8b2b497d426512c7 + * f3c9cc2311e0503928284391959e379587bc173e6bc51ba51c856ba557fee + * 8dd69cee4bd40845bd34691046534d967e40fe15b6d7cf61e30e283c05be9 + * 93c44b6a2ea8ade0f5578bd3f618336d9731fed1f1c5996a5828d4ca857ac + * 2dc9bd36184183f6d84346e1 + * r = 0xb0d7dcb19fb27a07973e921a4a4b6dcd7895ae8fced828de8a81a3dbf25 + * 24def719225404bfd4977a1508c4bac0f3bc356e9d83b9404b5bf86f6d19f + * f75645dffc9c5cc153a41772670a5e1ae87a9521416e117a0c0d415fb15d2 + * 454809bad45d6972f1ab367137e55ad0560d29ada9a2bcda8f4a70fbe04a1 + * abe4a570605db87b4e8830 + * + * newn == 17: (Blum modulus bit length 2062) + * n = 0x6177813aeac0ffa3040b33be3c0f96e0faf97ca54266bfedd7be68494f7 + * 6a7a91144598bf28b3a5a9dc35a6c9f58d0e5fb19839814bc9d456bff7f29 + * 953bdac7cafd66e2fc30531b8d544d2720b97025e22b1c71fa0b2eb9a499d + * 49484615d07af7a3c23b568531e9b8507543362027ec5ebe0209b4647b7ff + * 54be530e9ef50aa819c8ff11f6d7d0a00b25e88f2e6e9de4a7747022b949a + * b2c2e1ab0876e2f1177105718c60196f6c3ac0bde26e6cd4e5b8a20e9f0f6 + * 0974f0b3868ff772ab2ceaf77f328d7244c9ad30e11a2700a120a314aff74 + * c7f14396e2a39cc14a9fa6922ca0fce40304166b249b574ffd9cbb927f766 + * c9b150e970a8d1edc24ebf72b72051 + * r = 0x53720b6eaf3bc3b8adf1dd665324c2d2fc5b2a62f32920c4e167537284d + * a802fc106be4b0399caf97519486f31e0fa45a3a677c6cb265c5551ba4a51 + * 68a7ce3c29731a4e9345eac052ee1b84b7b3a82f906a67aaf7b35949fd7fc + * 2f9f4fbc8c18689694c8d30810fff31ebee99b1cf029a33bd736750e7fe0a + * 56f7e1d2a9b5321b5117fe9a10e46bf43c896e4a33faebd584f7431e7edbe + * bd1703ccee5771b44f0c149888af1a4264cb9cf2e0294ea7719ed6fda1b09 + * fa6e016c039aeb6d02a03281bcea8c278dd2a807eacae6e52ade048f58f2e + * b5193f4ffb9dd68467bc6f8e9d14286bfef09b0aec414c9dadfbf5c46d945 + * d147b52aa1e0cbd625800522b41dac + * + * newn == 18: (Blum modulus bit length 2074) + * n= 0x68f2a38fb61b42af07cb724fec0c7c65378efcbafb3514e268d7ee38e21 + * a5680de03f4e63e1e52bde1218f689900be4e5407950539b9d28e9730e8e6 + * ad6438008aa956b259cd965f3a9d02e1711e6b344b033de6425625b6346d2 + * ca62e41605e8eae0a7e2f45c25119ef9eece4d3b18369e753419d94118d51 + * 803842f4de5956b8349e6a0a330145aa4cd1a72afd4ef9db5d8233068e691 + * 18ff4b93bcc67859f211886bb660033f8170640c6e3d61471c3b7dd62c595 + * b156d77f317dc272d6b7e7f4fdc20ed82f172fe29776f3bddf697fb673c70 + * defd6476198a408642ed62081447886a625812ac6576310f23036a7cd3c93 + * 1c96f7df128ad4ed841351b18c8b78629 + * r= 0x4735e921f1ac6c3f0d5cda84cd835d75358be8966b99ff5e5d36bdb4be1 + * 2c5e1df70ac249c0540a99113a8962778dc75dac65af9f3ab4672b4c575c4 + * 9926f7f3f306fd122ac033961d042c416c3aa43b13ef51b764d505bb1f369 + * ac7340f8913ddd812e9e75e8fde8c98700e1d3353da18f255e7303db3bcbb + * eda4bc5b8d472fbc9697f952cfc243c6f32f3f1bb4541e73ca03f5109df80 + * 37219a06430e88a6e94be870f8d36dbcc381a1c449c357753a535aa5666db + * 92af2aaf1f50a3ddde95024d9161548c263973665a909bd325441a3c18fc7 + * 0502f2c9a1c944adda164e84a8f3f0230ff2aef8304b5af333077e04920db + * a179158f6a2b3afb78df2ef9735ea3c63 + * + * newn == 19: (Blum modulus bit length 2133) + * n= 0x230d7ab23bb9e8d6788b252ad6534bdde276540721c3152e410ad4244de + * b0df28f4a6de063ba1e51d7cd1736c3d8410e2516b4eb903b8d9206b92026 + * 64cacbd0425c516833770d118bd5011f3de57e8f607684088255bf7da7530 + * 56bf373715ed9a7ab85f698b965593fe2b674225fa0a02ebd87402ffb3d97 + * 172acadaa841664c361f7c11b2af47a472512ee815c970af831f95b737c34 + * 2508e4c23f3148f3cdf622744c1dcfb69a43fd535e55eebcdc992ee62f2b5 + * 2c94ac02e0921884fe275b3a528bdb14167b7dec3f3f390cd5a82d80c6c30 + * 6624cc7a7814fb567cd4d687eede573358f43adfcf1e32f4ee7a2dc4af029 + * 6435ade8099bf0001d4ae0c7d204df490239c12d6b659a79 + * r= 0x8f1725f21e245e4fc17982196605b999518b4e21f65126fa6fa759332c8 + * e27d80158b7537da39d001cc62b83bbef0713b1e82f8293dad522993f86d1 + * 761015414b2900e74fa23f3eaaa55b31cffd2e801fefb0ac73fd99b5d0cf9 + * a635c3f4c73d8892d36ad053fc17a423cdcbcf07967a8608c7735e287d784 + * ae089b3ddea9f2d2bb5d43d2ee25be346832e8dd186fc7a88d82847c03d1c + * 05ee52c1f2a51a85f733338547fdbab657cb64b43d44d41148eb32ea68c7e + * 66a8d47806f460cd6573b6ca1dd3eeaf1ce8db9621f1e121d2bb4a1878621 + * dd2dbdd7b5390ab06a5dcd9307d6662eb4248dff2ee263ef2ab778e77724a + * 14c62406967daa0d9ad4445064483193d53a5b7698ef473 + * + * newn == 20: (Blum modulus bit length 2166) + * n= 0x4fd2b820e0d8b13322e890dddc63a0267e5b3a648b03276066a3f356d79 + * 660c67704c1be6803b8e7590ee8a962c8331a05778d010e9ba10804d661f3 + * 354be1932f90babb741bd4302a07a92c42253fd4921864729fb0f0b1e0a42 + * d66b6777893195abd2ee2141925624bf71ad7328360135c565064ee502773 + * 6f42a78b988f47407ba4f7996892ffdc5cf9e7ab78ac95734dbf4e3a3def1 + * 615b5b4341cfbf6c3d0a61b75f4974080bbac03ee9de55221302b40da0c50 + * ded31d28a2f04921a532b3a486ae36e0bb5273e811d119adf90299a74e623 + * 3ccce7069676db00a3e8ce255a82fd9748b26546b98c8f4430a8db2a4b230 + * fa365c51e0985801abba4bbcf3727f7c8765cc914d262fcec3c1d081 + * r= 0x46ef0184445feaa3099293ee960da14b0f8b046fa9f608241bc08ddeef1 + * 7ee49194fd9bb2c302840e8da88c4e88df810ce387cc544209ec67656bd1d + * a1e9920c7b1aad69448bb58455c9ae4e9cd926911b30d6b5843ff3d306d56 + * 54a41dc20e2de4eb174ec5ac3e6e70849de5d5f9166961207e2d8b31014cf + * 35f801de8372881ae1ba79e58942e5bef0a7e40f46387bf775c54b1d15a14 + * 40e84beb39cd9e931f5638234ea730ed81d6fca1d7cea9e8ffb171f6ca228 + * 56264a36a2a783fd7ac39361a6598ed3a565d58acf1f5759bd294e5f53131 + * bc8e4ee3750794df727b29b1f5788ae14e6a1d1a5b26c2947ed46f49e8377 + * 3292d7dd5650580faebf85fd126ac98d98f47cf895abdc7ba048bd1a + * + * NOTE: The Blum moduli associated with 1 <= newn < 12 are subject + * to having their Blum moduli factored, depending in their size, + * by small PCs in a reasonable to large supercomputers/highly + * parallel processors over a long time. Their value lies in their + * speed relative the the default Blum generator. As of Jan 1996, + * the Blum moduli associated with 12 <= newn < 20 appear to + * be well beyond the scope of hardware and algorithms. + * See the section titled 'FOR THE PARANOID' for more details. + * + * seed > 0, 0 < newn <= 20: + * ------------------------ + * Use the same pre-defined Blum moduli 'n' noted above but use 'seed' + * to find a different quadratic residue 'r'. + * + * While not as efficient, this call is equivalent to: + * + * srandom(0, newn); + * srandom(seed); + * + * seed < 0, 0 < newn <= 20: + * ------------------------ + * Use the same pre-defined Blum moduli 'n' noted above but use '-seed' + * to compute a different quadratic residue 'r'. + * + * This call has the same effect as: + * + * srandom(0, newn) + * + * followed by the setting of the quadratic residue 'r' as follows: + * + * r = pmod(seed, 2, n) + * + * where 'n' is the Blum moduli generated by 'srandom(0,newn)' and + * 'r' is the new quadratic residue. + * + * NOTE: Because no checking on 'seed' is performed, it is recommended + * that 'seed' be selected as follows: + * + * binsize = highbit(n)+1; + * seed = -rand(1<= n=p*q. + * + * The use of the above range 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. + * + * Lower bound 2^(binsize*4/5) (4/5 the size of the smallest power of 2 >= n) + * is used because it avoids initial quadratic residues near 0, n^1/4, n^1/2, + * n^1/3, n^2/3 and n^3/4. For a trivial example, take the trivial case of + * selecting a quadratic residue of 1, 0 or n-1. Repeated squarings produce + * poor results. Similar but far less drastic results come from an + * initial selection that is near n^1/2 or other small fractional power. + * While the above initial quadratic residue range range allows for + * powers of n such as n^3/7, n^5/6, these powers are more complex and + * produce less obvious patterns when squared mod n. + * + * The upper bound of 2^(binsize-2) allows one to avoid initial quadratic + * residues near 'n'. Since n could be as small as 2^(binsize-1)+1, we + * must use the next lower power of 2: 2^(binsize-2) to be sure that we + * avoid initial quadratic residues near n. + * + * Taking some care to select a good initial residue helps eliminate cheap + * search attacks. It is true that a subsequent residue could be one of the + * residues that we would first avoid. However such an occurrence will + * happen after the generator is well underway and any such seed information + * has been lost. + * + * The size of Blum modulus 'n=p*q' was taken to be > 2^1024, or 1025 bits + * (309 digits) long. As if Jan 1996, the upper reach of the state of + * the art for factoring general numbers was around 2^512. We selected + * 2^1024 because it was twice that size and would hopefully remain well + * beyond the reach of Number Theory and CPU power for some time. + * + * Not being able to factor 'n=p*q' into 'p' and 'q' does not directly + * improve the quality Blum generator. On the other hand, it does + * improve the security of it. + * + * The number of bits produced each cycle for a given Blum modulus 'n' + * is int(log2(log2(n))). Thus for 2^1024 <= n < 2^2048, 10 bits are + * produced. For optimal performance, we use a Blum modulus that is + * slightly larger than 2^(2^x) to produce 'x' bits at a time. + * + * The lengths of the two Blum probable primes 'p' and 'q' used to make up + * the default Blum modulus 'n=p*q' differ slightly to avoid certain + * 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 up to 6% of the product size to avoid such attacks. + * Clearly one does not want the size of the two factors to differ + * by a large percentage: p=3 and q large would result in a easy + * to factor Blum modulus. Thus we select sizes that differ by + * up to 6% but not (significantly) greater than 6%. + * + * Again, the ability (or lack thereof) to factor 'n=p*q' does not + * directly relate to the strength of the Blum generator. We + * selected n=p*q > 2^1024 mainly because 1024 was a power of 2. + * Secondly 1024 the first power of 2 beyond 512 which bit size at + * or near the general factor limit a of Jan 1996. + * + * Using the '6% rule' above, a Blum modulus n=p*q > 2^1024 would have two + * Blum factors p > 2^482 and q > 2^542. This is because 482+542 = 1024. + * The difference 542-482 is ~5.86% of 1024, and is the largest difference + * that is < 6%. + * + * The default Blum modulus is the product of two Blum probable primes + * that were selected by the Rand Book of Random Numbers. Using the '6% rule', + * a default Blum modulus n=p*q > 2^1024 would be satisfied if p were + * 146 decimal digits and q were 164 decimal digits in length. We restate + * the sizes in decimal digits because the Rand Book of Random Numbers is a + * book of decimal digits. Using the first 146 rand digits as a + * starting search point for 'p', and the next 164 digits for a starting + * search point for 'q'. + * + * (* + * * setup the search points (lines split for readability) + * *) + * ip = 10097325337652013586346735487680959091173929274945 + * 37542048056489474296248052403720636104020082291665 + * 0842268953196450930323209025601595334764350803; + * iq = 36069901902529093767071538311311658867674397044362 + * 76591280799970801573614764032366539895116877121717 + * 68336606574717340727685036697361706581339885111992 + * 91703106010805; + * + * (* + * * find the first Blum prime + * *) + * fp = int((ip-1)/2); + * do { + * fp = nextcand(fp+2, 25, 0, 3, 4); + * p = 2*fp+1; + * } while (ptest(p, 25) == 0); + * + * (* + * * find the 2nd Blum prime + * *) + * fq = int((iq-1)/2); + * do { + * fq = nextcand(fq+2, 25, 0, 3, 4); + * q = 2*fq+1; + * } while (ptest(q, 25) == 0); + * + * The above script produces the Blum probable primes and initial quadratic + * residue (line wrapped for readability): + * + * p = 0x33c08d08248479497fe557b0e013b1beb51957cb441840f95d199e40fa9 + * 19faee2444d687775cb391bc703d710bd05f0cb0670b0bd49430ec8f9393e + * 7 + * + * q = 0xa05970f94cdf85f9773f7772636d591c0575bf5873299b4f48f873529f8 + * 85e91577802c65d629e809e797d130254afb7b1e8a4d7afe4f18facec41c2 + * 7f2bcfa1496e53a7 + * + * These Blum primes were found after 43m 56s of CPU time on a 150 Mhz IP22 + * R4400 version 5.0 processor. The first Blum prime 'p' was 411284 higher + * than the initial search value 'ip'. The second Blum prime 'q' was 87282 + * higher than the initial starting 'iq'. + * + * The product of the two Blum primes results in a 1026 bit Blum modulus of: + * + * n = 0x206a6cecc22e947050ffcf5eb53742e0a85433800fcaab4452df182bccf + * 72b874f3abaf118b29d64a859cd9c1465796a1cdf061f9bf3374443da6e1c + * fc63b7a7bd90dad9a3853642820ab4664a82ae1951779f3d1af9a70bedfd4 + * abcd89cdc200cbb917c1f7881fc900163d7a84f5e8e53d5bc5918590c15a4 + * 45430bbee7b60b1 + * + * The selection if the initial quadratic residue comes from the next + * unused digits of the Rand Book of Random Numbers. Now the two initial + * search values 'ip' and 'iq' used above needed the first 146 digits and + * the next 164 digits. Thus we will skip the first 146+164=310 digits + * and begin to build in initial search value for a quadratic residue (most + * significant digit first) from the Rand Book of Numbers digits until we + * have a value that is within the range: + * + * [2^(binsize*4/5), 2^(binsize-2)) + * + * where 2^(binsize-1) < n=p*q <= 2^binsize. Here, binsize is the + * smallest power of 2 >= n=p*q. Using this method, we arrive at an + * initial search value for the quadratic residue (wrapped for readability): + * + * ir = 45571824063530342614867990743923403097328526977602 + * 02051656926866574818730538524718623885796357332135 + * 05325470489055357548284682870983491256247379645753 + * 03529647783580834282609352034435273884359852017767 + * 14905686072210940558609709343350500739981180505431 + * 39808277325072568248294052420152775678518345299634 + * 06288980 + * + * using the next 308 digits from the Rand Book of Random Numbers. The + * (310+309)th digit results in an 'ir' that is outside the range noted above. + * + * Using pmod(ir, 2, n), we arrive at the initial quadratic residue of the + * default Blum generator: + * + * r = 0x1455b0e84ea73df591501002a7ff7855ef114f4ab34114f7e78208179a7 + * 8b722591126b68629b8e840ef5408f7d46db41b438fba4bfd69a6fa7635ab + * fbbfde64a198d62cfab4f03f43fb1f402c63202c7beb0b023034f27c6729b + * 672fc0ac85e14c610137e7766c67f1ea9cf75e0d60339e254065642e37b7f + * 4b9462d0687e467 + * + * In the above process, we selected primes of the form: + * + * 2*x + 1 x is also prime + * + * because Blum generators with modulus 'n=p*q' have a period: + * + * lambda(n) = lcm(factors of p-1 & q-1) + * + * since 'p' and 'q' are both odd, 'p-1' and 'q-1' have 2 as + * a factor. The calc script above ensures that '(p-1)/2' and + * '(q-1)/2' are probable prime, thus maximizing the period + * of the default generator to: + * + * lambda(n) = lcm(2,2,fp,fq) = 2*fp*fq = ~2*(p/2)*(q/2) = ~n/2 + * + * The process above resulted in a default generator Blum modulus n > 2^1024 + * with period of at least 2^1023 bits. To be exact, the period of the + * default Blum generator is: + * + * 0x9edee4226e56e1ba24e6b20180648967ae10bba409a1a1975e95c9c4be0dc9b7 + * 4af2d44bd15a117f6a108d043418c88957f4a3e2c10c3267b44332c7445b6a0c + * dcdc2ebefec6f8fa48aff8c9867769c4bfa790acba7e7aaa4b90bc2bff5ba65f + * 9e652919cfc51edd706b52c884cf56e8fbd378c1f561c651a9f7000180481e0d2 + * + * which is approximately: + * + * ~1.785 * 10^309 + * + * This period is more than long enough for computationally tractable tasks. + * + **** + * + * 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 of Random Numbers 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. + * + * When using the a55 generator, one may select your own 55 additive + * values by calling: + * + * srand(mat55) + * + * and avoid using my magic numbers. The randreseed64 process is NOT + * applied to the matrix values. Of course, you must pick good additive + * 55 values yourself! + * + * One might object to the complexity of the seed scramble/mapping + * via the randreseed64() function. The randreseed64() function maps: + * + * 0 ==> 0 + * 10239951819489363767 ==> 1363042948800878693 + * + * so that srand(0) does the default action and randreseed64() remains + * an 1-to-1 and onto map. Thus calling srand(0) 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 the above script that produced a 1028 bit + * Blum modulus. As far as I know, 310 digits (1028 bits) is beyond the + * state of the art of Number Theory and Computation as of 01 Jan 96. + * It is possible in the future that 310 digit products of two primes could + * come within reach of factoring 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? + * + * If all the above fails to pacify the truly paranoid, then one may + * select your own modulus and initial quadratic residue by calling: + * + * srandom(s, n); + * + * Of course, you will need to select a correct Blum modulus 'n' as the + * product of two Blum primes (both 3 mod 4) and with a long period (where + * lcm(factors of one less than the two Blum primes) is large) and an + * initial quadratic residue 's' that is hard to guess (a large value + * from the range [n^(4/5), n/2) selected at random. + * + * A simple way to seed the generator would be to: + * + * config("srandom", 0); + * srandom(s, nextcand(ip,25,0,3,4)*nextcand(iq,25,0,3,4)) + * + * where 'ip' and 'iq' are large integers that are unlikely to be 'guessed' + * and where they are selected randomly from the [2^(binsize*4/5), + * 2^(binsize-2)) where 2^(binsize-1) < n=p*q <= 2^binsize. + * + * Of course you can increase the '25' value if 1 of 4^25 odds of a + * non-prime are too probable for you. The '0' means don't skip any + * tests* and the final '3,4' means to select only Blum candidates. + * The config("srandom", 0) call turns off srandom checks on the 'n'' + * argument. This is OK to do in the above case because the nextcand() + * calls ensure proper Blum prime selection. + * + * The problem with the above call is that the period of the Blum generator + * could be small if 'p' and 'q' have lots of small prime factors in common. + * + * A better way to do seed the Blum generator yourself is to use the + * seedrandom(seed1, seed2, size [,tests]) function from "seedrandom.cal" + * with the args: + * + * seed1 - seed rand() to search for 'p', select from [2^64, 2^308) + * seed2 - seed rand() to search for 'q', select from [2^64, 2^308) + * size - minimum bit size of the Blum modulus 'n=p*q' + * tests - optional arg for number of pseudo prime tests (default is 25) + * + * The seedrandom() function ensures that the Blum generator produced + * has a maximal period. + * + * The following call will seed the Blum generator to an identical state + * produced by srandom(0): + * + * seedrandom(10097325337652013586346735487680959091173929274945, + * 37542048056489474296248052403720636104020082291665, + * 1024) + * + * The seedrandom() function in seedrandom.cal makes use of the rand() + * additive 55 generator. If you object to using rand(), you could + * substitute your own generator (by rewriting the function). + * + * Last, one could use some external random source to select starting + * search points for 'p', 'q' and the quadratic residue. One way to + * do this is: + * + * fp = int((ip-1)/2); + * do { + * fp = nextcand(fp+2, tests, 0, 3, 4); + * p = 2*fp+1; + * } while (ptest(p, tests) == 0); + * fq = int((iq-1)/2); + * do { + * fq = nextcand(fq+2, tests, 0, 3, 4); + * q = 2*fq+1; + * } while (ptest(q, tests) == 0); + * srandom(pmod(ir,2,p*q), p*q); + * + * where 'tests' is the number of pseudo prime tests that a candidate must + * pass before being considered a probable prime (must be >0, perhaps 25), and + * where 'ip' is the initial search location for the Blum prime 'p', and + * where 'iq' is the initial search location for the Blum prime 'q', and + * where 'ir' is the initial Blum quadratic residue generator. The 'ir' + * value should be a random value in the range [2^(binsize*4/5), 2^(binsize-2)) + * where 2^(binsize-1) < n=p*q <= 2^binsize. + * + * Your external generator would need to generate 'ip', 'iq' and 'ir'. + * While any value for 'ip' and 'iq will do (provided that their product + * is large enough to meet your modulus needs), 'ir' should be selected + * to avoid values near 0 or near 'n' (or ip*iq). + * + * The Blum moduli used with the pre-defined generators (via the call + * srandom(seed, 0 0 (so that srand(0) acts as default) + * randreseed64() is an 1-to-1 and onto map + * + * 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 Random 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 Random Numbers. Because m=2^64 is 20 decimal digits long, + * we will search the Rand Book of Random 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 of Random Numbers 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) + * + * We can determine which 0<=y 10239951819489363767 + * + * 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(). + */ +static void +randreseed64(ZVALUE seed, ZVALUE *res) +{ + ZVALUE t; /* temp value */ + ZVALUE chunk; /* processed 64 bit chunk value */ + ZVALUE seed64; /* seed mod 2^64 */ + HALF *v64; /* 64 bit array of HALFs */ + long chunknum; /* 64 bit chunk number */ + + /* + * quickly return 0 if seed is 0 + */ + if (ziszero(seed) || seed.len <= 0) { + itoz(0, res); + return; + } + + /* + * allocate result + */ + seed.sign = 0; /* use the value of seed */ + res->len = (int)(((seed.len+SHALFS-1) / SHALFS) * SHALFS); + res->v = alloc(res->len); + res->sign = 0; + memset(res->v, 0, res->len*sizeof(HALF)); /* default value is 0 */ + + /* + * process 64 bit chunks until done + */ + chunknum = 0; + while (!zislezero(seed)) { + + /* + * grab the lower 64 bits of seed + */ + if (zge64b(seed)) { + v64 = alloc(SHALFS); + memcpy(v64, seed.v, SHALFS*sizeof(HALF)); + seed64.v = v64; + seed64.len = SHALFS; + seed64.sign = 0; + } else { + zcopy(seed, &seed64); + } + zshiftr(seed, SBITS); + ztrim(&seed); + ztrim(&seed64); + + /* + * do nothing if chunk is zero + */ + if (ziszero(seed64)) { + ++chunknum; + zfree(seed64); + continue; + } + + /* + * Compute the linear congruence generator map: + * + * X1 <-- (a*X0 + c) mod m + * + * in other words: + * + * chunk == (a_val*seed + c_val) mod 2^64 + */ + zmul(seed64, a_val, &t); + zfree(seed64); + zadd(t, c_val, &chunk); + zfree(t); + + /* + * form chunk mod 2^64 + */ + if (chunk.len > SHALFS) { + /* result is too large, reduce to 64 bits */ + v64 = alloc(SHALFS); + memcpy(v64, chunk.v, SHALFS*sizeof(HALF)); + free(chunk.v); + chunk.v = v64; + chunk.len = SHALFS; + ztrim(&chunk); + } + + /* + * 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 (ziszero(chunk)) { + /* load 1363042948800878693 instead of 0 */ + zcopy(c_val, &chunk); + memcpy(res->v+(chunknum*SHALFS), c_val.v, + c_val.len*sizeof(HALF)); + + /* + * load the 64 bit chunk into the result + */ + } else { + memcpy(res->v+(chunknum*SHALFS), chunk.v, + chunk.len*sizeof(HALF)); + } + ++chunknum; + zfree(chunk); + } + ztrim(res); +} + + +/* + * zsrand - seed the a55 generator + * + * given: + * pseed - ptr to seed of the generator or NULL + * pmat55 - additive 55 state table or NULL + * + * returns: + * previous a55 state + */ +RAND * +zsrand(CONST ZVALUE *pseed, CONST MATRIX *pmat55) +{ + RAND *ret; /* previous a55 state */ + CONST VALUE *v; /* value from a passed matrix */ + ZVALUE zscram; /* scrambled 64 bit seed */ + ZVALUE seed; /* to hold *pseed */ + FULL shufxor[SLEN]; /* zshufxor as an 64 bit array of FULLs */ + long indx; /* index to shuffle slots for seeding */ + int i; + + /* + * firewall + */ + if (pseed != NULL && zisneg(*pseed)) { + math_error("neg seeds for srand reserved for future use"); + /*NOTREACHED*/ + } + + /* + * initialize state if first call + */ + if (!a55.seeded) { + a55 = init_a55; + } + + /* + * save the current state to return later + */ + ret = (RAND *)malloc(sizeof(RAND)); + if (ret == NULL) { + math_error("cannot allocate RAND state"); + /*NOTREACHED*/ + } + *ret = a55; + + /* + * if call was srand(), just return current state + */ + if (pseed == NULL && pmat55 == NULL) { + return ret; + } + + /* + * if call is srand(0), initialize and return quickly + */ + if (pmat55 == NULL && ziszero(*pseed)) { + a55 = init_a55; + return ret; + } + + /* + * clear buffered bits, initialize pointers + */ + a55.seeded = 0; /* not seeded now */ + a55.j = INIT_J-1; + a55.k = INIT_K-1; + a55.bits = 0; + memset(a55.buffer, 0, sizeof(a55.buffer)); + + /* + * load additive table + * + * We will load the default additive table unless we are passed a + * matrix. If we are passed a matrix, we will load the first 55 + * values mod 2^64 instead. + */ + if (pmat55 == NULL) { + memcpy(a55.slot, additive, sizeof(additive)); + } else { + + /* + * use the first 55 entries from the matrix arg + */ + if (pmat55->m_size < A55) { + math_error("matrix for srand has < 55 elements"); + /*NOTREACHED*/ + } + for (v=pmat55->m_table, i=0; i < A55; ++i, ++v) { + + /* reject if not integer */ + if (v->v_type != V_NUM || qisfrac(v->v_num)) { + math_error("matrix for srand must contain ints"); + /*NOTREACHED*/ + } + + /* load table element from matrix element mod 2^64 */ + SLOAD(a55, i, v->v_num->num); + } + } + + /* + * scramble the seed in 64 bit chunks + */ + if (pseed != NULL) { + seed.sign = pseed->sign; + seed.len = pseed->len; + seed.v = alloc(seed.len); + zcopyval(*pseed, seed); + randreseed64(seed, &zscram); + zfree(seed); + } + + /* + * xor additive table with the rehashed lower 64 bits of seed + */ + if (pseed != NULL && !ziszero(zscram)) { + + /* xor additive table with lower 64 bits of seed */ + SMOD64(shufxor, zscram); + for (i=0; i < A55; ++i) { + SXOR(a55, i, shufxor); + } + } + + /* + * shuffle additive 55 table according to seed, if passed + */ + if (pseed != NULL && zge64b(zscram)) { + + /* prepare the seed for additive slot shuffling */ + zshiftr(zscram, 64); + ztrim(&zscram); + + /* shuffle additive table */ + for (i=A55-1; i > 0 && !zislezero(zscram); --i) { + + /* determine what we will swap with */ + indx = zdivi(zscram, i+1, &zscram); + + /* do nothing if swap with itself */ + if (indx == i) { + continue; + } + + /* swap slot[i] with slot[indx] */ + SSWAP(a55, i, indx); + } + zfree(zscram); + } + + /* + * load the shuffle table + * + * We will generate SHUFCNT entries from the additive 55 slots + * and fill the shuffle table in consecutive order. + */ + for (i=0; i < SHUFCNT; ++i) { + + /* bump j and k */ + if (++a55.j >= A55) { + a55.j = 0; + } + if (++a55.k >= A55) { + a55.k = 0; + } + + /* slot[k] += slot[j] */ + SADD(a55, a55.k, a55.j); + + /* shuf[i] = slot[k] */ + SSHUF(a55, i, a55.k); + } + + /* + * note that we are seeded + */ + a55.seeded = 1; + + /* + * return the previous state + */ + return ret; +} + + +/* + * zsrandom - seed the Blum generator + * + * seed > 0, n == NULL: + * + * Seed the an internal additive 55 shuffle generator, and use it + * to produce an initial quadratic residue in the range: + * + * [2^(binsize*4/5), 2^(binsize-2)) + * + * where 2^(binsize-1) < n <= 2^binsize and 'n' is the current Blum + * modulus. Here, binsize is the smallest power of 2 >= n. + * + * The follow calc script produces an equivalent effect: + * + * cur_state = srand(seed); + * binsize = highbit(n)+1; (* n is the current Blum modulus *) + * r = pmod(rand(1<= 1007: + * + * If 'n' passes the tests (if applicable) specified by the "srandom" + * config value, it becomes the Blum modulus. Any internally buffered + * random bits are flushed. + * + * The initial quadratic residue 'r', is selected as if the following + * was executed: + * + * (* set Blum modulus to newn if allowed by "srandom" config value *) + * (* and then set the initial quadratic residue by the next call *) + * srandom(n % 2^309); + * + * The first srand() call seeds the additive 55 shuffle generator + * with the lower 309 bits of n. In actual practice, calc uses + * an independent internal rand() state value. + * + * seed > 0, n >= 1007: + * + * If 'n' passes the tests (if applicable) specified by the "srandom" + * config value, it becomes the Blum modulus. Once the Blum modulus + * is set, seed is used to seed an internal Additive 55 generator + * state which in turn is used to set the initial quadratic residue. + * + * While not as efficient, this call is equivalent to: + * + * srandom(0, n); + * srandom(seed); + * + * seed < 0, n >= NULL: + * + * Reserved for future use. + * + * any seed, 20 < n < 1007: + * + * Reserved for future use. + * + * any seed, n < 0: + * + * Reserved for future use. + * + * seed == 0, 0 < n <= 20: + * + * Seed with one of the predefined Blum moduli. (see the comments + * near the top under the section 'INITIALIZATION AND SEEDS') + * + * seed > 0, 0 < n <= 20: + * + * Use the same pre-defined Blum moduli 'n' noted above but use 'seed' + * to find a different quadratic residue 'r'. + * + * While not as efficient, this call is equivalent to: + * + * srandom(0, n); + * srandom(seed); + * + * seed < 0, 0 < n <= 20: + * + * Use the same pre-defined Blum moduli 'n' noted above but use '-seed' + * to compute a different quadratic residue 'r'. + * + * This call has the same effect as: + * + * srandom(0, n) + * + * followed by the setting of the quadratic residue 'r' as follows: + * + * r = pmod(seed, 2, n) + * + * where 'n' is the Blum moduli generated by 'srandom(0,newn)' and + * 'r' is the new quadratic residue. + * + * given: + * pseed - seed of the generator or NULL + * n - ptr to n (Blum modulus), or NULL + * + * returns: + * previous Blum state + */ +/*XXX - use them*/ +/*ARGSUSED*/ +RANDOM * +zsrandom(CONST ZVALUE seed, CONST ZVALUE *n) +{ + RANDOM *ret; /* previous Blum state */ + + /* + * initialize state if first call + */ + if (!blum.seeded) { + blum = init_blum; + zcopy(*(init_blum.n), blum.n); + zcopy(*(init_blum.r), blum.r); + blum.seeded = 1; + } + + /* + * save the current state to return later + */ + ret = (RANDOM *)malloc(sizeof(RANDOM)); + if (ret == NULL) { + math_error("cannot allocate RANDOM state"); + /*NOTREACHED*/ + } + /* move the ZVALUES over to ret */ + *ret = blum; + + + /* XXX - finish this function */ + + /* + * return the previous state + */ + return ret; +} + + +/* + * zsetrand - set the a55 generator state + * + * given: + * state - the state to copy + * + * returns: + * previous a55 state + */ +RAND * +zsetrand(CONST RAND *state) +{ + RAND *ret; /* previous a55 state */ + + /* + * initialize state if first call + */ + if (!a55.seeded) { + a55 = init_a55; + } + + /* + * save the current state to return later + */ + ret = randcopy(&a55); + + /* + * load the new state + */ + a55 = *state; + + /* + * return the previous state + */ + return ret; +} + + +/* + * zsetrandom - set the Blum generator state + * + * given: + * state - the state to copy + * + * returns: + * previous RANDOM state + */ +RANDOM * +zsetrandom(CONST RANDOM *state) +{ + RANDOM *ret; /* previous Blum state */ + + /* + * initialize state if first call + */ + if (!blum.seeded) { + blum = init_blum; + zcopy(*(init_blum.n), blum.n); + zcopy(*(init_blum.r), blum.r); + blum.seeded = 1; + } + + /* + * save the current state to return later + */ + ret = (RANDOM *)malloc(sizeof(RANDOM)); + if (ret == NULL) { + math_error("cannot allocate RANDOM state"); + /*NOTREACHED*/ + } + /* move the ZVALUES over to ret */ + *ret = blum; + + /* + * load the new state + */ + if (state != NULL) { + blum.seeded = 0; /* avoid being caught while copying */ + blum.bits = state->bits; + blum.buffer = state->buffer; + zcopy(*(state->n), blum.n); + zcopy(*(state->r), blum.r); + blum.seeded = 1; + } + + /* + * return the previous state + */ + return ret; +} + + +/* + * slotcp - copy up to 64 bits from a 64 bit array of FULLs to some HALFs + * + * We will copy data from an array of FULLs into an array of HALFs. + * The destination within the HALFs is some bit location found in bitstr. + * We will attempt to copy 64 bits, but if there is not enough room + * (bits not yet loaded) in the destination bit string we will transfer + * what we can. + * + * The src slot is 64 bits long and is stored as an array of FULLs. + * When FULL_BITS is 64 the element is 1 FULL, otherwise FULL_BITS + * is 32 bits and the element is 2 FULLs. The most significant bit + * in the array (highest bit in the last FULL of the array) is to + * be transfered to the most significant bit in the destination. + * + * given: + * bitstr - most significant destination bit in a bit string + * src - low order FULL in a 64 bit slot + * count - number of bits to transfer (must be 0 < count <= 64) + * + * returns: + * number of bits transfered + */ +static int +slotcp(BITSTR *bitstr, FULL *src, int count) +{ + HALF *dh; /* most significant HALF in dest */ + int dnxtbit; /* next bit beyond most signif in dh */ + int need; /* number of bits we need to transfer */ + int ret; /* bits transfered */ + + /* + * determine how many bits we actually need to transfer + */ + dh = bitstr->loc; + dnxtbit = bitstr->bit+1; + count &= (SBITS-1); + need = (bitstr->len < count) ? bitstr->len : count; + + /* + * prepare for the return + * + * Note the final bitstr location after we have moved the + * position down 'need' bits. + */ + bitstr->len -= need; + bitstr->loc -= need / BASEB; + bitstr->bit -= need % BASEB; + if (bitstr->bit < 0) { + --bitstr->loc; + bitstr->bit += BASEB; + } + ret = need; + + /* + * deal with aligned copies quickly + */ + if (dnxtbit == BASEB) { + if (need == SBITS) { +#if 2*FULL_BITS == SBITS + *dh-- = (HALF)(src[SLEN-1] >> BASEB); + *dh-- = (HALF)(src[SLEN-1]); +#endif + *dh-- = (HALF)(src[0] >> BASEB); + *dh = (HALF)(src[0]); +#if 2*FULL_BITS == SBITS + } else if (need > FULL_BITS+BASEB) { + *dh-- = (HALF)(src[SLEN-1] >> BASEB); + *dh-- = (HALF)(src[SLEN-1]); + *dh-- = (HALF)(src[0] >> BASEB); + *dh = ((HALF)src[0] & + highhalf[need-FULL_BITS-BASEB]); + } else if (need > FULL_BITS) { + *dh-- = (HALF)(src[SLEN-1] >> BASEB); + *dh-- = (HALF)(src[SLEN-1]); + *dh = ((HALF)(src[0] >> BASEB) & + highhalf[need-FULL_BITS]); +#endif + } else if (need > BASEB) { + *dh-- = (HALF)(src[SLEN-1] >> BASEB); + *dh = ((HALF)(src[SLEN-1]) & highhalf[need-BASEB]); + } else { + *dh = ((HALF)(src[SLEN-1] >> BASEB) & highhalf[need]); + } + return ret; + } + + /* + * load the most significant HALF + */ + if (need >= dnxtbit) { + /* fill up the most significant HALF */ + *dh-- |= (HALF)(src[SLEN-1] >> (FULL_BITS-dnxtbit)); + need -= dnxtbit; + } else if (need > 0) { + /* we exhaust our need before 1st half is filled */ + *dh |= (HALF)((src[SLEN-1] >> (FULL_BITS-need)) << + (dnxtbit-need)); + return ret; /* our need has been filled */ + } else { + return ret; /* our need has been filled */ + } + + /* + * load the 2nd most significant HALF + */ + if (need > BASEB) { + /* fill up the 2nd most significant HALF */ + *dh-- = (HALF)(src[SLEN-1] >> (BASEB-dnxtbit)); + need -= BASEB; + } else if (need > 0) { + /* we exhaust our need before 2nd half is filled */ + *dh |= ((HALF)(src[SLEN-1] >> (BASEB-dnxtbit)) & + highhalf[need]); + return ret; /* our need has been filled */ + } else { + return ret; /* our need has been filled */ + } + + /* + * load the 3rd most significant HALF + * + * At this point we know that our 3rd HALF will force us + * to cross into a second FULL for systems with 32 bit FULLs. + * We know this because the aligned case has been previously + * taken care of above. + * + * For systems that have 64 bit FULLs (and 32 bit HALFs) this + * is will be our least significant HALF. We also know that + * the need must be < BASEB. + */ +#if FULL_BITS == SBITS + *dh |= (((HALF)src[0] & highhalf[dnxtbit+need]) << dnxtbit); +#else + if (need > BASEB) { + /* load the remaining bits from the most signif FULL */ + *dh-- = ((((HALF)src[SLEN-1] & lowhalf[BASEB-dnxtbit]) + << dnxtbit) | (HALF)(src[0] >> (FULL_BITS-dnxtbit))); + need -= BASEB; + } else if (need > 0) { + /* load the remaining bits from the most signif FULL */ + *dh-- |= (((((HALF)src[SLEN-1] & lowhalf[BASEB-dnxtbit]) + << dnxtbit) | (HALF)(src[0] >> (FULL_BITS-dnxtbit))) & + highhalf[need]); + return ret; /* our need has been filled */ + } else { + return ret; /* our need has been filled */ + } + + /* + * load the 4th most significant HALF + * + * At this point, only 32 bit FULLs are operating. + */ + if (need > BASEB) { + /* fill up the 2nd most significant HALF */ + *dh-- = (HALF)(src[0] >> (BASEB-dnxtbit)); + /* no need todo: need -= BASEB, because we are nearly done */ + } else if (need > 0) { + /* we exhaust our need before 2nd half is filled */ + *dh |= ((HALF)(src[0] >> (BASEB-dnxtbit)) & + highhalf[need]); + return ret; /* our need has been filled */ + } else { + return ret; /* our need has been filled */ + } + + /* + * load the 5th and least significant HALF + * + * At this point we know that the need will be satisfied. + */ + *dh |= (((HALF)src[0] & lowhalf[BASEB-dnxtbit]) << dnxtbit); +#endif + return ret; /* our need has been filled */ +} + + +/* + * slotcp64 - copy 64 bits from a 64 bit array of FULLs to some HALFs + * + * We will copy data from an array of FULLs into an array of HALFs. + * The destination within the HALFs is some bit location found in bitstr. + * Unlike slotcp(), this function will always copy 64 bits. + * + * The src slot is 64 bits long and is stored as an array of FULLs. + * When FULL_BITS is 64 this array is 1 FULL, otherwise FULL_BITS + * is 32 bits and the array is 2 FULLs. The most significant bit + * in the array (highest bit in the last FULL of the array) is to + * be transfered to the most significant bit in the destination. + * + * given: + * bitstr - most significant destination bit in a bit string + * src - low order FULL in a 64 bit slot + * + * returns: + * number of bits transfered + */ +static void +slotcp64(BITSTR *bitstr, FULL *src) +{ + HALF *dh = bitstr->loc; /* most significant HALF in dest */ + int dnxtbit = bitstr->bit+1; /* next bit beyond most signif in dh */ + + /* + * prepare for the return + * + * Since we are moving the point 64 bits down, we know that + * the bit location (bitstr->bit) will remain the same. + */ + bitstr->len -= SBITS; + bitstr->loc -= SBITS/BASEB; + + /* + * deal with aligned copies quickly + */ + if (dnxtbit == BASEB) { +#if 2*FULL_BITS == SBITS + *dh-- = (HALF)(src[SLEN-1] >> BASEB); + *dh-- = (HALF)(src[SLEN-1]); +#endif + *dh-- = (HALF)(src[0] >> BASEB); + *dh = (HALF)(src[0]); + return; + } + + /* + * load the most significant HALF + */ + *dh-- |= (HALF)(src[SLEN-1] >> (FULL_BITS-dnxtbit)); + + /* + * load the 2nd most significant HALF + */ + *dh-- = (HALF)(src[SLEN-1] >> (BASEB-dnxtbit)); + + /* + * load the 3rd most significant HALF + * + * At this point we know that our 3rd HALF will force us + * to cross into a second FULL for systems with 32 bit FULLs. + * We know this because the aligned case has been previously + * taken care of above. + * + * For systems that have 64 bit FULLs (and 32 bit HALFs) this + * is will be our least significant HALF. + */ +#if FULL_BITS == SBITS + *dh |= (((HALF)src[0] & lowhalf[BASEB-dnxtbit]) << dnxtbit); +#else + /* load the remaining bits from the most signif FULL */ + *dh-- = ((((HALF)src[SLEN-1] & lowhalf[BASEB-dnxtbit]) + << dnxtbit) | (HALF)(src[0] >> (FULL_BITS-dnxtbit))); + + /* + * load the 4th most significant HALF + * + * At this point, only 32 bit FULLs are operating. + */ + *dh-- = (HALF)(src[0] >> (BASEB-dnxtbit)); + + /* + * load the 5th and least significant HALF + * + * At this point we know that the need will be satisfied. + */ + *dh |= (((HALF)src[0] & lowhalf[BASEB-dnxtbit]) << dnxtbit); +#endif +} + + +/* + * zrandskip - skip s bits + * + * given: + * count - number of bits to be skipped + */ +void +zrandskip(long cnt) +{ + int indx; /* shuffle entry index */ + + /* + * initialize state if first call + */ + if (!a55.seeded) { + a55 = init_a55; + } + + /* + * skip required bits in the buffer + */ + if (a55.bits > 0 && a55.bits <= cnt) { + + /* just toss the buffer bits */ + cnt -= a55.bits; + a55.bits = 0; + memset(a55.buffer, 0, sizeof(a55.buffer)); + + } else if (a55.bits > 0 && a55.bits > cnt) { + + /* buffer contains more bits than we need to toss */ +#if FULL_BITS == SBITS + a55.buffer[0] <<= cnt; +#else + if (cnt >= FULL_BITS) { + a55.buffer[SLEN-1] = (a55.buffer[0] << cnt); + a55.buffer[0] = 0; + } else { + a55.buffer[SLEN-1] = + ((a55.buffer[SLEN-1] << cnt) | + (a55.buffer[0] >> (FULL_BITS-cnt))); + a55.buffer[0] <<= cnt; + } +#endif + a55.bits -= cnt; + return; /* skip need satisfied */ + } + + /* + * skip 64 bits at a time + */ + while (cnt >= SBITS) { + + /* bump j and k */ + if (++a55.j >= A55) { + a55.j = 0; + } + if (++a55.k >= A55) { + a55.k = 0; + } + + /* slot[k] += slot[j] */ + SADD(a55, a55.k, a55.j); + + /* we will ignore the output value of a55.slot[indx] */ + indx = SINDX(a55, a55.k); + cnt -= SBITS; + + /* store a55.k into a55.slot[indx] */ + SSHUF(a55, indx, a55.k); + } + + /* + * skip the final bits + */ + if (cnt > 0) { + + /* bump j and k */ + if (++a55.j >= A55) { + a55.j = 0; + } + if (++a55.k >= A55) { + a55.k = 0; + } + + /* slot[k] += slot[j] */ + SADD(a55, a55.k, a55.j); + + /* we will ignore the output value of a55.slot[indx] */ + indx = SINDX(a55, a55.k); + + /* + * We know the buffer is empty, so fill it + * with any unused bits. Copy SBITS-trans bits + * from slot[indx] into buffer. + */ + a55.bits = (int)(SBITS-cnt); + memcpy(a55.buffer, &a55.shuf[indx*SLEN], + sizeof(a55.buffer)); + + /* + * shift the buffer bits all the way up to + * the most significant bit + */ +#if FULL_BITS == SBITS + a55.buffer[0] <<= cnt; +#else + if (cnt >= FULL_BITS) { + a55.buffer[SLEN-1] = (a55.buffer[0] << cnt); + a55.buffer[0] = 0; + } else { + a55.buffer[SLEN-1] = + ((a55.buffer[SLEN-1] << cnt) | + (a55.buffer[0] >> (FULL_BITS-cnt))); + a55.buffer[0] <<= cnt; + } +#endif + + /* store a55.k into a55.slot[indx] */ + SSHUF(a55, indx, a55.k); + } +} + + +/* + * zrand - crank the a55 generator for some bits + * + * given: + * count - number of bits required + * res - where to place the random bits as ZVALUE + */ +void +zrand(long cnt, ZVALUE *res) +{ + long hlen; /* length of ZVALUE in HALFs */ + BITSTR dest; /* destination bit string */ + int trans; /* bits transfered */ + int indx; /* shuffle entry index */ + + /* + * firewall + */ + if (cnt <= 0) { + if (cnt == 0) { + /* zero length random number is always 0 */ + itoz(0, res); + return; + } else { + math_error("negative zrand bit count"); + /*NOTREACHED*/ + } +#if LONG_BITS > 32 + } else if (cnt > (1L<<31)) { + math_error("huge rand bit count in internal zrand function"); + /*NOTREACHED*/ +#endif + } + + /* + * initialize state if first call + */ + if (!a55.seeded) { + a55 = init_a55; + } + + /* + * allocate storage + */ + hlen = (cnt+BASEB-1)/BASEB; + res->len = (LEN)hlen; + res->v = alloc((LEN)hlen); + memset(res->v, 0, hlen*sizeof(HALF)); + + /* + * dest bit string + */ + dest.len = (int)cnt; + dest.loc = res->v + (hlen-1); + dest.bit = (int)((cnt-1) % BASEB); + + /* + * load from buffer first + */ + if (a55.bits > 0) { + + /* + * We know there are only a55.bits in the buffer, so + * transfer as much as we can (treating it as a slot) + * and return the bit transfer count. + */ + trans = slotcp(&dest, a55.buffer, a55.bits); + + /* + * If we need to keep bits in the buffer, + * shift the buffer bits all the way up to + * the most significant unused bit. + */ + if (trans < a55.bits) { +#if FULL_BITS == SBITS + a55.buffer[0] <<= trans; +#else + if (trans >= FULL_BITS) { + a55.buffer[SLEN-1] = + (a55.buffer[0] << (trans-FULL_BITS)); + a55.buffer[0] = 0; + } else { + a55.buffer[SLEN-1] = + ((a55.buffer[SLEN-1] << trans) | + (a55.buffer[0] >> (FULL_BITS-trans))); + a55.buffer[0] <<= trans; + } +#endif + } + /* note that we have fewer bits in the buffer */ + a55.bits -= trans; + } + + /* + * spin the generator until we need less than 64 bits + * + * The buffer did not contain enough bits, so we crank the + * a55 generator and load then 64 bits at a time. + */ + while (dest.len >= SBITS) { + + /* bump j and k */ + if (++a55.j >= A55) { + a55.j = 0; + } + if (++a55.k >= A55) { + a55.k = 0; + } + + /* slot[k] += slot[j] */ + SADD(a55, a55.k, a55.j); + + /* select slot index to output */ + indx = SINDX(a55, a55.k); + + /* move up to 64 bits from slot[indx] to dest */ + slotcp64(&dest, &a55.shuf[indx*SLEN]); + + /* store a55.k into a55.slot[indx] */ + SSHUF(a55, indx, a55.k); + } + + /* + * spin the generator one last time to fill out the remaining need + */ + if (dest.len > 0) { + + /* bump j and k */ + if (++a55.j >= A55) { + a55.j = 0; + } + if (++a55.k >= A55) { + a55.k = 0; + } + + /* slot[k] += slot[j] */ + SADD(a55, a55.k, a55.j); + + /* select slot index to output */ + indx = SINDX(a55, a55.k); + + /* move up to 64 bits from slot[indx] to dest */ + trans = slotcp(&dest, &a55.shuf[indx*SLEN], dest.len); + + /* buffer up unused bits if we are done */ + if (trans != SBITS) { + + /* + * We know the buffer is empty, so fill it + * with any unused bits. Copy SBITS-trans bits + * from slot[indx] into buffer. + */ + a55.bits = SBITS-trans; + memcpy(a55.buffer, &a55.shuf[indx*SLEN], + sizeof(a55.buffer)); + + /* + * shift the buffer bits all the way up to + * the most significant bit + */ +#if FULL_BITS == SBITS + a55.buffer[0] <<= trans; +#else + if (trans >= FULL_BITS) { + a55.buffer[SLEN-1] = + (a55.buffer[0] << (trans-FULL_BITS)); + a55.buffer[0] = 0; + } else { + a55.buffer[SLEN-1] = + ((a55.buffer[SLEN-1] << trans) | + (a55.buffer[0] >> (FULL_BITS-trans))); + a55.buffer[0] <<= trans; + } +#endif + } + + /* store a55.k into a55.slot[indx] */ + SSHUF(a55, indx, a55.k); + } + res->sign = 0; + ztrim(res); +} + + +/* + * zrandrange - generate a random value in the range [low, high) + * + * given: + * low - low value of range + * high - beyond end of range + * res - where to place the random bits as ZVALUE + */ +void +zrandrange(CONST ZVALUE low, CONST ZVALUE high, ZVALUE *res) +{ + ZVALUE range; /* high-low */ + ZVALUE rval; /* random value [0, 2^bitlen) */ + ZVALUE rangem1; /* range - 1 */ + long bitlen; /* smallest power of 2 >= diff */ + + /* + * firewall + */ + if (zrel(low, high) >= 0) { + math_error("srand low range >= high range"); + /*NOTREACHED*/ + } + + /* + * determine the size of the random number needed + */ + zsub(high, low, &range); + if (zisone(range)) { + zfree(range); + *res = low; + return; + } + zsub(range, _one_, &rangem1); + bitlen = 1+zhighbit(rangem1); + zfree(rangem1); + + /* + * generate a random value between [0, diff) + * + * 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). + */ + rval.v = NULL; + do { + if (rval.v != NULL) { + zfree(rval); + } + zrand(bitlen, &rval); + } while (zrel(rval, range) >= 0); + + /* + * add in low value to produce the range [0+low, diff+low) + * which is the range [low, high) + */ + zadd(rval, low, res); + zfree(rval); + zfree(range); +} + + +/* + * irand - generate a random long in the range [0, s) + * + * given: + * s - limit of the range + * + * returns: + * random long in the range [0, s) + */ +long +irand(long s) +{ + ZVALUE z1, z2; + long res; + + if (s <= 0) { + math_error("Non-positive argument for irand()"); + /*NOTREACHED*/ + } + if (s == 1) + return 0; + itoz(s, &z1); + zrandrange(_zero_, z1, &z2); + res = ztoi(z2); + zfree(z1); + zfree(z2); + return res; +} + + +/* + * randcopy - make a copy of an a55 state + * + * given: + * state - the state to copy + * + * returns: + * a malloced copy of the state + */ +RAND * +randcopy(CONST RAND *state) +{ + RAND *ret; /* return copy of state */ + + /* + * malloc state + */ + ret = (RAND *)malloc(sizeof(RAND)); + if (ret == NULL) { + math_error("can't allocate RAND state"); + /*NOTREACHED*/ + } + *ret = *state; + + /* + * return copy + */ + return ret; +} + + +/* + * randomcopy - make a copy of a Blum state + * + * given: + * state - the state to copy + * + * returns: + * a malloced copy of the state + */ +RANDOM * +randomcopy(CONST RANDOM *state) +{ + RANDOM *ret; /* return copy of state */ + + /* + * malloc state + */ + ret = (RANDOM *)malloc(sizeof(RANDOM)); + if (ret == NULL) { + math_error("can't allocate RANDOM state"); + /*NOTREACHED*/ + } + + /* + * clone data + */ + *ret = *state; + if (state->r->v == NULL) { + ret->r->v = NULL; + } else { + zcopy(*(state->r), ret->r); + } + if (state->n->v == NULL) { + ret->n->v = NULL; + } else { + zcopy(*(state->n), ret->n); + } + + /* + * return copy + */ + return ret; +} + + +/* + * randfree - free an a55 state + * + * given: + * state - the state to free + */ +void +randfree(RAND *state) +{ + /* free it */ + free(state); +} + + +/* + * randomfree - free a Blum state + * + * given: + * state - the state to free + */ +void +randomfree(RANDOM *state) +{ + /* free the values */ + state->seeded = 0; + zfree(*state->n); + zfree(*state->r); + + /* free it */ + free(state); +} + + +/* + * randcmp - compare two a55 states + * + * given: + * s1 - first state to compare + * s2 - second state to compare + * + * return: + * TRUE if states differ + */ +BOOL +randcmp(CONST RAND *s1, CONST RAND *s2) +{ + /* + * assume uninitialized state == the default seeded state + */ + if (!s1->seeded) { + if (!s2->seeded) { + /* uninitialized == uninitialized */ + return TRUE; + } else { + /* uninitialized only equals default state */ + return randcmp(s2, &init_a55); + } + } else if (!s2->seeded) { + if (!s1->seeded) { + /* uninitialized == uninitialized */ + return TRUE; + } else { + /* uninitialized only equals default state */ + return randcmp(s1, &init_a55); + } + } + + /* compare states */ + return (BOOL)(memcmp(s1, s2, sizeof(RAND)) != 0); +} + + +/* + * randomcmp - compare two Blum states + * + * given: + * s1 - first state to compare + * s2 - second state to compare + * + * return: + * TRUE if states differ + */ +BOOL +randomcmp(CONST RANDOM *s1, CONST RANDOM *s2) +{ + /* + * assume uninitialized state == the default seeded state + */ + if (!s1->seeded) { + if (!s2->seeded) { + /* uninitialized == uninitialized */ + return TRUE; + } else { + /* uninitialized only equals default state */ + return randomcmp(s2, &post_init_blum); + } + } else if (!s2->seeded) { + /* uninitialized only equals default state */ + return randomcmp(s1, &post_init_blum); + } + + /* + * compare operating mask parameters + */ + if ((s1->loglogn != s2->loglogn) || (s1->mask != s2->mask)) { + return FALSE; + } + + /* + * compare bit buffer + */ + if ((s1->bits != s2->bits) || (s1->buffer != s2->buffer)) { + return FALSE; + } + + /* + * compare quadratic residues + */ + if (!zcmp(*(s1->r), *(s2->r))) { + return FALSE; + } + + /* + * compare moduli + */ + if (!zcmp(*(s1->n), *(s2->n))) { + return FALSE; + } + + /* + * they are equal + */ + return TRUE; +} + + +/* + * randprint - print an a55 state + * + * given: + * state - state to print + * flags - print flags passed from printvalue() in value.c + */ +/*ARGSUSED*/ +void +randprint(CONST RAND *state, int flags) +{ + math_str("RAND state"); +} + + +/* + * randomprint - print a Blum state + * + * given: + * state - state to print + * flags - print flags passed from printvalue() in value.c + */ +/*ARGSUSED*/ +void +randomprint(CONST RANDOM *state, int flags) +{ + math_str("RANDOM state"); +} diff --git a/zrand.h b/zrand.h new file mode 100644 index 0000000..abe7f1a --- /dev/null +++ b/zrand.h @@ -0,0 +1,330 @@ +/* + * Copyright (c) 1996 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. + * + * Prior to calc 2.9.3t9, these routines existed as a calc library called + * cryrand.cal. They have been rewritten in C for performance as well + * as to make them available directly from libcalc.a. + * + * 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 + * + * chongo was here /\../\ + */ + +/* + * random number generator - see random.c for details + */ + +#if !defined(ZRAND_H) +#define ZRAND_H + + +#include "value.h" +#include "have_const.h" + + +/* + * BITSTR - string of bits within an array of HALFs + * + * This typedef records a location of a bit in an array of HALFs. + * Bit 0 in a HALF is assumed to be the least significant bit in that HALF. + * + * The most significant bit is found at (loc,bit). Bits of lesser + * significance may be found in previous bits and HALFs. + */ +typedef struct { + HALF *loc; /* half address of most significant bit */ + int bit; /* bit position within half of most significant bit */ + int len; /* length of string in bits */ +} BITSTR; + + +/* + * a55 generator defines + * + * NOTE: SBITS must be a power of two to make the (&= (SBITS-1)) + * in slotcp() to work. + */ +#define SBITS (64) /* size of additive or shuffle entry in bits */ +#define SBYTES (SBITS/8) /* size of additive or shuffle entry in bytes */ +#define SHALFS (SBYTES/sizeof(HALF)) /* size in HALFs */ + +/* + * seed defines + */ +#define SEEDXORBITS 64 /* low bits of a55 seed devoted to xor */ + +/* + * shuffle table defines + */ +#define SHUFPOW 8 /* power of 2 size of the shuffle table */ +#define SHUFCNT (1 << SHUFPOW) /* size of shuffle table */ +#define SHUFLEN (SLEN*SHUFCNT) /* length of shuffle table in FULLs */ +#define SHUFMASK (SHUFLEN-1) /* mask for shuffle table entry selection */ + +/* + * additive 55 constants + */ +#define A55 55 /* slots in an additive 55 table */ +#define INIT_J 23 /* initial first walking table index */ +#define INIT_K 54 /* initial second walking table index */ + +/* + * additive 55 table defines + * + * SLEN - length in FULLs of an additive 55 slot + * + * SVAL(x,y) - form a 64 bit hex slot entry in the additive 55 table + * x: up to 8 hex digits without the leading 0x (upper half) + * y: up to 8 hex digits without the leading 0x (lower half) + * + * NOTE: Due to a SunOS cc bug, don't put spaces in the SVAL call! + * + * SHVAL(a,b,c,d) - form an 64 bit array of HALFs + * a: up to 4 hex digits without the leading 0x (upper half) + * b: up to 4 hex digits without the leading 0x (2nd half) + * c: up to 4 hex digits without the leading 0x (3rd half) + * d: up to 4 hex digits without the leading 0x (lower half) + * + * NOTE: Due to a SunOS cc bug, don't put spaces in the SHVAL call! + * + * HVAL(x,y) - form an array of HALFs given 8 hex digits + * x: up to 4 hex digits without the leading 0x (upper half) + * y: up to 4 hex digits without the leading 0x (lower half) + * + * NOTE: Due to a SunOS cc bug, don't put spaces in the HVAL call! + * + * SLOAD(s,i,z) - load table slot i from additive 55 state s with zvalue z + * s: type RAND + * i: type int, s.slot[i] slot index + * z: type ZVALUE, what to load into s.slot[i] + * + * SADD(s,k,j) - slot[k] += slot[j] + * s: type RAND + * k: type int, s.slot[k] slot index, what to gets changed + * j: type int, s.slot[j] slot index, what to add to s.slot[k] + * (may use local variable tmp) + * + * SINDX(s,k) - select the shuffle table entry from slot[k] (uses top bits) + * s: type RAND + * k: type int, s.slot[k] slot index, selects shuffle entry + * result type int, refers to s.shuf[SINDX(s,k)] + * + * SBUFFER(s,t) - load a55 buffer with t + * s: type RAND + * t: type int, s.shuf[t] entry index, replace buffer with it + * + * SSHUF(s,t,k) - save slot[k] into shuffle entry t + * s: type RAND + * t: type int, s.shuf[t] entry index, what gets changed + * k: type int, s.slot[k] slot index, load into s.shuf[t] + * + * SSWAP(s,j,k) - swap slot[j] with slot[k] + * s: type RAND + * j: type int, s.slot[j] slot index, goes into s.slot[k] + * k: type int, s.slot[k] slot index, goes into s.slot[j] + * (uses local variable tmp) + * + * SMOD64(t,z) - t = seed z mod 2^64 + * t: type FULL*, array of FULLs that get z mod 2^64 + * z: type ZVALUE, what gets (mod 2^64) placed into t + * + * SOXR(s,i,v) - xor slot[i] with lower 64 bits of slot value v + * s: type RAND + * i: type int, s.slot[i] slot index, what gets xored + * v: type FULL*, 64 bit value to xor into s.slot[i] + * + * SCNT - length of an additive 55 table in FULLs + */ +#if FULL_BITS == SBITS + +# define SLEN 1 /* a 64 bit slot can be held in a FULL */ +# if defined(__STDC__) && __STDC__ != 0 +# define SVAL(x,y) (FULL)U(0x ## x ## y) +# define SHVAL(a,b,c,d) (HALF)0x ## c ## d, (HALF)0x ## a ## b +# define HVAL(x,y) (HALF)(0x ## x ## y) +# else +# define SVAL(x,y) (FULL)U(0x/**/x/**/y) +# define SHVAL(a,b,c,d) (HALF)0x/**/c/**/d,(HALF)0x/**/a/**/b +# define HVAL(x,y) (HALF)(0x/**/x/**/y) +# endif +#define SLOAD(s,i,z) ((s).slot[i] = ztofull(z)) +#define SADD(s,k,j) ((s).slot[k] += (s).slot[j]) +#define SINDX(s,k) ((int)((s).slot[k] >> (FULL_BITS - SHUFPOW))) +#define SBUFFER(s,t) {(s).buffer[0] = ((s).shuf[t] & BASE1); \ + (s).buffer[1] = ((s).shuf[t] >> BASEB); \ + } +#define SSHUF(s,t,k) ((s).shuf[t] = (s).slot[k]) +#define SSWAP(s,j,k) {FULL tmp = (s).slot[j]; \ + (s).slot[j] = (s).slot[k]; \ + (s).slot[k] = tmp; \ + } +#define SMOD64(t,z) ((t)[0] = ztofull(z)) +#define SXOR(s,i,v) ((s).slot[i] ^= (v)[0]) + +#elif 2*FULL_BITS == SBITS + +# define SLEN 2 /* a 64 bit slot needs 2 FULLs */ +# if defined(__STDC__) && __STDC__ != 0 +# define SVAL(x,y) (FULL)(0x ## y), (FULL)(0x ## x) +# define SHVAL(a,b,c,d) (HALF)0x ## d, (HALF)0x ## c, \ + (HALF)0x ## b, (HALF)0x ## a +# define HVAL(x,y) (HALF)(0x ## y), (HALF)(0x ## x) +# else + /* NOTE: Due to a SunOS cc bug, don't put spaces in the SVAL call! */ +# define SVAL(x,y) (FULL)(0x/**/y), (FULL)(0x/**/x) + /* NOTE: Due to a SunOS cc bug, don't put spaces in the SHVAL call! */ +# define SHVAL(a,b,c,d) (HALF)0x/**/d, (HALF)0x/**/c, \ + (HALF)0x/**/b, (HALF)0x/**/a + /* NOTE: Due to a SunOS cc bug, don't put spaces in the HVAL call! */ +# define HVAL(x,y) (HALF)(0x/**/y), (HALF)(0x/**/x) +# endif +#define SLOAD(s,i,z) {(s).slot[(i)<<1] = ztofull(z); \ + (s).slot[1+((i)<<1)] = \ + (((z).len <= 2) ? (FULL)0 : \ + (((z).len == 3) ? (FULL)((z).v[2]) : \ + ((FULL)((z).v[2]) + ((FULL)((z).v[3]) << BASEB)))); \ + } +#define SADD(s,k,j) {FULL tmp = (s).slot[(k)<<1]; \ + (s).slot[(k)<<1] += (s).slot[(j)<<1]; \ + (s).slot[1+((k)<<1)] += ((tmp <= (s).slot[(k)<<1]) ? \ + (s).slot[1+((j)<<1)] : \ + (s).slot[1+((j)<<1)] + 1); \ + } +#define SINDX(s,k) ((int)((s).slot[1+((k)<<1)] >> (FULL_BITS - SHUFPOW))) +#define SBUFFER(s,t) {(s).buffer[0] = ((s).shuf[(t)<<1] & BASE1); \ + (s).buffer[1] = ((s).shuf[(t)<<1] >> BASEB); \ + (s).buffer[2] = ((s).shuf[1+((t)<<1)] & BASE1); \ + (s).buffer[3] = ((s).shuf[1+((t)<<1)] >> BASEB); \ + } +#define SSHUF(s,t,k) {(s).shuf[(t)<<1] = (s).slot[(k)<<1]; \ + (s).shuf[1+((t)<<1)] = (s).slot[1+((k)<<1)]; \ + } +#define SSWAP(s,j,k) {FULL tmp = (s).slot[(j)<<1]; \ + (s).slot[(j)<<1] = (s).slot[(k)<<1]; \ + (s).slot[(k)<<1] = tmp; \ + tmp = (s).slot[1+((j)<<1)]; \ + (s).slot[1+((j)<<1)] = (s).slot[1+((k)<<1)]; \ + (s).slot[1+((k)<<1)] = tmp; \ + } +#define SMOD64(t,z) {(t)[0] = ztofull(z); \ + (t)[1] = (((z).len <= 2) ? (FULL)0 : \ + (((z).len == 3) ? (FULL)((z).v[2]) : \ + ((FULL)((z).v[2]) + ((FULL)((z).v[3]) << BASEB)))); \ + } +#define SXOR(s,i,v) {(s).slot[(i)<<1] ^= (v)[0]; \ + (s).slot[1+((i)<<1)] ^= (v)[1]; \ + } + +#else + + /\../\ FULL_BITS is assumed to be SBITS or 2*SBITS /\../\ !!! + +#endif + +#define SCNT (SLEN*A55) /* length of additive 55 table in FULLs */ + + +/* + * a55 generator state + */ +struct rand { + int seeded; /* 1 => state has been seeded */ + int bits; /* buffer bit count */ + FULL buffer[SLEN]; /* unused random bits from last call */ + int j; /* first walking table index */ + int k; /* second walking table index */ + FULL slot[SCNT]; /* additive 55 table */ + FULL shuf[SHUFLEN]; /* shuffle table entries */ +}; + + +/* + * Blum generator state + * + * The size of the buffer implies that a turn of the quadratic residue crank + * will never yield more than the number of bits in a FULL. At worst + * this implies that a turn can yield no more than 32 bits. This implies that + * the lower bound on the largest modulus supported is 2^32 bits long. + */ +struct random { + int seeded; /* 1 => state has been seeded */ + int bits; /* number of unused bits in buffer */ + int loglogn; /* int(log2(log2(n))), bits produced per turn */ + HALF buffer; /* unused random bits from previous call */ + HALF mask; /* mask for the log2(log2(n)) lower bits of r */ + ZVALUE *n; /* Blum modulus */ + ZVALUE *r; /* Blum quadratic residue */ +}; + + +/* + * Blum constants + */ +#define BLUM_PREGEN 20 /* number of non-default predefined Blum generators */ + + +/* + * Blum random config constants + */ +#define BLUM_CFG_MIN BLUM_CFG_NOCHECK +#define BLUM_CFG_NOCHECK 0 /* no checks are performed */ +#define BLUM_CFG_1MOD4 1 /* require 1 mod 4 */ +#define BLUM_CFG_1MOD4_PTEST0 2 /* require 1 mod 4 and ptest(n,0) */ +#define BLUM_CFG_1MOD4_PTEST1 3 /* require 1 mod 4 and ptest(n,1) */ +#define BLUM_CFG_1MOD4_PTEST25 4 /* require 1 mod 4 and ptest(n,25) */ +#define BLUM_CFG_MAX BLUM_CFG_1MOD4_PTEST25 +#define BLUM_CFG_DEFAULT BLUM_CFG_1MOD4_PTEST1 /* default config value */ + + +/* + * a55 generator function declarations + */ +extern RAND *zsrand(CONST ZVALUE *seed, CONST MATRIX *pmat55); +extern RAND *zsetrand(CONST RAND *state); +extern void zrandskip(long count); +extern void zrand(long count, ZVALUE *res); +extern void zrandrange(CONST ZVALUE low, CONST ZVALUE beyond, ZVALUE *res); +extern long irand(long s); +extern RAND *randcopy(CONST RAND *rand); +extern void randfree(RAND *rand); +extern BOOL randcmp(CONST RAND *s1, CONST RAND *s2); +extern void randprint(CONST RAND *state, int flags); + + +/* + * Blum generator function declarations + */ +extern RANDOM *zsrandom(CONST ZVALUE seed, CONST ZVALUE *newn); +extern RANDOM *zsetrandom(CONST RANDOM *state); +extern RANDOM *randomcopy(CONST RANDOM *random); +extern void randomfree(RANDOM *random); +extern BOOL randomcmp(CONST RANDOM *s1, CONST RANDOM *s2); +extern void randomprint(CONST RANDOM *state, int flags); + +#endif /* ZRAND_H */