commit 4618313a82000c8d9adf4eab2da4ca4ec78aa6a1 Author: Landon Curt Noll Date: Sat Jul 6 04:17:00 1996 -0700 Release calc version 2.10.2t30 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 */